CSUBNIJX2 === file NIJX2.F   = Part 2 of the NIJX subr. Updt:  4 Nov. 99
* Note: NIJX = NIJX1 + NIJX2              NIJX2 is computer independent.
* Note: for NIJX1 various versions are supplied: IBM, VAX/VMS, unix etc.
*-----------------------------------------------------------------------
**** Comments NIJX1 + NIJX2
*    WARNING :  COMMON / / too small for TRAVEC
 
**** modifications NIJX1 + NIJX2  /  log  /  **** last on top
* 04 Nov KEPROX for DDOKA set KEYS(20)=+17 (corr!)
      SUBROUTINE KEDATE
      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))
      CHARACTER * 4  M(12)
      DIMENSION L(12)
      DATA M / 'Jan.',   'Feb.',   'Mar.',   'Apr.',   'May ',  'June',
     +         'July',   'Aug.',   'Sep.',   'Oct.',   'Nov.',  'Dec.'/
      DATA    L  / 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /
      DATA IPR /0/
      IF (IPR .NE. 0) IPR = LIS1
      IF (IPR .EQ. 0) IPR = LIS2
      CALL DATIME (I1, I2, I3)
      CALL KERNZI (0, ITIME, 3)
      IF (I3.GT.0) GOTO 110
      WRITE (LIS2, 100)
  100 FORMAT (' TIME REPORT NOT AVAILABLE')
      RETURN
  110 ITIME(1) = I3 / 1000 + 1900
      IF (MOD(ITIME(1),4).EQ.0) L(2) = 29
      IL = MOD(I3,1000)
      DO 120 I=1,12
      IF (IL.LE.L(I)) GOTO 130
  120 IL = IL - L(I)
      I = 12
  130 ITIME(2) = I
      ITIME(3) = IL
      IHH = I1 / 100
      IMM = I1 - 100 * IHH
      WRITE (IPR, 140) I3, IHH, IMM, IL, M(I), ITIME(1)
  140 FORMAT (/7X, ' Day number:' ,I6, '. The time:', I3, ' h', I3,
     *        ' min.', ' The date:', I3, ' ', A4, I5)
      RETURN
      END
      SUBROUTINE KETIME (IPRX)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      CHARACTER *4 MONTH(12)
      DATA MONTH / 'Jan.', 'Feb.', 'Mar.', 'Apr.', 'May ', 'June',
     *             'July', 'Aug.', 'Sep.', 'Oct.', 'Nov.', 'Dec.'/
      DATA  ISW / 0 /
      DATA IREL / 0 /
      CALL DATIME (I1, I2, I3)
      IF (I3.LE.0) RETURN
      IF (ISW.NE.0) GOTO 100
      ISW = 1
      IREL = I2
  100 ITIME(4) = I2 - IREL
      IF (ITIME(4).EQ.0 .OR. IPRX.LE.0) RETURN
      F = FLOAT(ITIME(4)) / 1000.
      M = ITIME(2)
      WRITE (IPRX, 110) ITIME(3), MONTH(M), ITIME(1), PROGNM, F
  110 FORMAT (/' Time report. Date: ', I3, 1X, A4, I5,
     *        4X, 'CPU time used by ', A8, ':', F7.3, ' s')
      RETURN
      END
      SUBROUTINE KERNAB (A, B, N)
      DIMENSION A(N), B(N)
      DO 100 I=1,N
  100 B(I) = A(I)
      RETURN
      END
      SUBROUTINE KERNAI (IA, IB, N)
      DIMENSION IA(N), IB(N)
      DO 100 I=1,N
  100 IB(I) = IA(I)
      RETURN
      END
      SUBROUTINE KERNZA (X, A, N)
      DIMENSION A(N)
      DO 100 I=1,N
  100 A(I) = X
      RETURN
      END
      SUBROUTINE KERNZI (IX, IA, N)
      DIMENSION IA(N)
      DO 100 I=1,N
  100 IA(I) = IX
      RETURN
      END
      SUBROUTINE KERNZ1 (CH, CHA, N)
      CHARACTER * 1  CH, CHA(N)
      DO 100 I=1,N
  100 CHA(I) = CH
      RETURN
      END
      SUBROUTINE KERNZ6 (CH, CHA, N)
      CHARACTER * 6  CH, CHA(N)
      DO 100 I=1,N
  100 CHA(I) = CH
      RETURN
      END
      SUBROUTINE KEREQ1 (L, LL, N, KEND)
      CHARACTER * 1  LL(N), L
      DO 100 KEND=1,N
      IF (LL(KEND).EQ.L) GOTO 110
  100 CONTINUE
      KEND = -1
  110 RETURN
      END
      SUBROUTINE KEREQ6 (L6, LL6, N, KEND)
      CHARACTER * 6  L6, LL6(N)
      DO 110 KEND=1,N
      IF (L6.NE.LL6(KEND)) GOTO 110
      RETURN
  110 CONTINUE
      KEND = -1
      RETURN
      END
      SUBROUTINE KERC2I (L, KEND)
      CHARACTER * 1 L, LLL(49), LLC(26)
      DATA LLL / '1','2','3','4','5', '6','7','8','9',' ',
     +           'A','B','C','D','E', 'F','G','H','I','J',
     +           'K','L','M','N','O', 'P','Q','R','S','T',
     +           'U','V','W','X','Y', 'Z','+','-','.',',',
     +           '*','/','=','$','''','(',')','?',':'      /
      DATA LLC / 'a','b','c','d','e', 'f','g','h','i','j',
     +           'k','l','m','n','o', 'p','q','r','s','t',
     +           'u','v','w','x','y', 'z'                  /
      KEND = 0
      IF (L.EQ.'0') RETURN
      CALL KEREQ1 (L, LLL, 49, KEND)
      IF (KEND.GT.0) RETURN
      CALL KEREQ1 (L, LLC,  26, KEND)
      IF (KEND.GT.0) KEND = KEND + 10
      RETURN
      END
      SUBROUTINE KERI2C (I, CCC, N)
      CHARACTER * 6  CCC
      CHARACTER * 1  N10(10)
      DATA N10 / '1', '2', '3', '4', '5', '6', '7', '8', '9', '0' /
      CCC = ' '
      JNUM = IABS(I)
      NN = N
      IF (NN .GT. 6) NN = 6
      K = 10**NN
      IF (JNUM .GE. K) JNUM = K-1
      J = K / 10
      DO 100 L=1,NN
      IF (JNUM.GE.J) GOTO 110
      NN = NN- 1
      J = J / 10
  100 CONTINUE
  110 DO 120 L=1,NN
      K = JNUM / J
      IF (K.EQ.0) THEN
         CCC(L:L) = N10(10)
      ELSE
         CCC(L:L) = N10(K)
         ENDIF
      JNUM = JNUM - K*J
  120 J = J / 10
      RETURN
      END
      SUBROUTINE KERI2F (IA, FA, N)
      DIMENSION IA(N), FA(N)
      DO 100 I=1,N
  100 FA(I) = IA(I)
      RETURN
      END
      SUBROUTINE KERF2I (FA, IA, N)
      DIMENSION FA(N), IA(N)
      DO 100 I=1,N
  100 IA(I) = NINT (FA(I))
      RETURN
      END
      SUBROUTINE KERC2U (CA, CB, N)
      CHARACTER CA *(*), CB *(*)
      CHARACTER * 1  LUC(26), LLC(26)
      DATA LUC / 'A','B','C','D','E', 'F','G','H','I','J',
     +           'K','L','M','N','O', 'P','Q','R','S','T',
     +           'U','V','W','X','Y', 'Z'                  /
      DATA LLC / 'a','b','c','d','e', 'f','g','h','i','j',
     +           'k','l','m','n','o', 'p','q','r','s','t',
     +           'u','v','w','x','y', 'z'                  /
      DO 120 I = 1, N
      CB(I:I) = CA(I:I)
      IF (CB(I:I) .EQ. ' ') GOTO 120
      CALL KEREQ1 (CB(I:I), LLC, 26, KEND)
      IF (KEND .LE. 0) GOTO 120
      CB(I:I) = LUC(KEND)
  120 CONTINUE
      RETURN
      END
      SUBROUTINE KERICH (I, CH, KEND)
      CHARACTER * 1 CH, LLL(50), LLC(26)
      DATA LLL / '1','2','3','4','5', '6','7','8','9',' ',
     +           'A','B','C','D','E', 'F','G','H','I','J',
     +           'K','L','M','N','O', 'P','Q','R','S','T',
     +           'U','V','W','X','Y', 'Z','+','-','.',',',
     +           '*','/','=','$','''','(',')','?',':','@'  /
      DATA LLC / 'a','b','c','d','e', 'f','g','h','i','j',
     +           'k','l','m','n','o', 'p','q','r','s','t',
     +           'u','v','w','x','y', 'z'                  /
      IF (I .GT. 99) GOTO 100
      IF (I .EQ. 0) THEN
         CH = '0'
      ELSEIF (I .LT. 0 .OR. I .GT. 76) THEN
         CH = ' '
      ELSEIF (I .LE. 50) THEN
         CH = LLL(I)
      ELSE
         CH = LLC (I - 50)
         ENDIF
      RETURN
  100 CONTINUE
      KEND = 0
      IF (CH .EQ. '0') RETURN
      CALL KEREQ1 (CH, LLL, 50, KEND)
      IF (KEND.GT.0) RETURN
      CALL KEREQ1 (CH, LLC,  26, KEND)
      IF (KEND.GT.0) KEND = KEND + 50
      IF (KEND.LE.0) KEND = 97
      RETURN
      END
      SUBROUTINE KEPROG (NAME)
      CHARACTER NAME *(*)
      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 NIJMEG
      EQUIVALENCE (NIJMEG, SWITCH(1))
      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)), (IDDJ, IFILE(1)), (IDDS, IFILE(2))
      EQUIVALENCE (IRD,  IFILE(5)), (IHELP, IFILE(3))
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (ISTOP, IFILE(20))
      EQUIVALENCE (IS,   KEYS(17)), (IT, KEYS(18)),   (IN,   KEYS(19))
      PARAMETER (NCHMAX=517)
      COMMON / / DUMMY(1), CHONDA(NCHMAX)
      CHARACTER * 80 CHONDA, CHINJ
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      LOGICAL FIRST
      CHARACTER * 2 ISTAR
      DATA ISTAR / '**' /
      DATA FIRST /.TRUE./
      DO 100 I=1,20
      IFSTAT(I) = -2
  100 IFILE(I) = I
      CHOUT  = ' '
      PROGNM = NAME
      PROSNM = ' '
      IF (FIRST) THEN
         TITLE = ' '
         CCODE = 'CCODE'
         CALL KERNZI (0, ITIME, 4)
         ENDIF
      CALL KERNZI (0, KEYS, 28)
      DO 101 I=1,28
  101 SWITCH(I) = .FALSE.
      SWITCH(9) = FIRST
      CALL FILINQ (IDDJ, 'DDJOB', 'FORMATTED', 'INPUT', KIDDJ)
      KEYS(4) = KIDDJ
      IF (KIDDJ .NE. 0) GOTO 102
      CALL KERINA (IDDJ, LIT, 1, LEND)
      CHINJ = CHIN
      CALL FILCLO (IDDJ, 'KEEP')
      CCODE = LIT(1)
  102 CALL RDDCON
      CALL KEYSWI
      CALL FILINQ (ISTOP, 'DDSTOP', 'FORMATTED', 'INPUT', KINQ)
      CALL FILCLO (ISTOP, 'DELETE')
      KEYS(22) = 2
      CALL FILINQ (LIS1, 'LIS1', 'FORMATTED', 'OUTPUT', KINQ)
      CALL FILINQ (LIS2, 'LIS2', 'FORMATTED', 'OUTPUT', KINX)
      IF (CCODE.EQ.'END' .OR. CCODE.EQ.'HELP' .OR. CCODE.EQ.'H' .OR.
     *  CCODE.EQ.'CCODE' .OR. CCODE.EQ.'?' .OR. CCODE.EQ.'BATCH') RETURN
      ILIS2 = 0
      IF (KINX .LT. 0) GOTO 110
  105 READ( LIS2, FMT = '(A80)', END = 106) CHIN
      IF (CHIN(1:7) .EQ. '$FINISH' ) GOTO 107
      ILIS2 = 1
      GOTO 105
  106 IF (ILIS2 .EQ. 0) GOTO 110
      ILIS2 = -1
  107 BACKSPACE  LIS2
  110 I = 0
      IF (KINQ .LT. 0) GOTO 120
  111 READ( LIS1, FMT = '(A80)', END = 113) CHIN
      IF (CHIN(1:7) .EQ. '$FINISH' ) GOTO 125
      I = 1
      GOTO 111
  113 IF (I .EQ. 0) GOTO 120
      BACKSPACE  LIS1
      WRITE (LIS1, 115)
      WRITE (IPR1, 115)
  115 FORMAT (// ' Problems ! ...  File LIS1 is incorrectly closed'/)
      WRITE (IPR1, FMT='('' See LIS1 ...''/)')
      CALL FILCLO (IHELP, 'KEEP')
      CALL XHELP (IHELP, LIS1, 10.0)
      WRITE (IPR1, 116) PROGNM
  116 FORMAT (/'NOTE: this interrupt-ERROR did not happen in program ',
     * A8 / '      but in the preceding program (see above).')
      PROGNM = ' '
      CALL KESTOP
      CALL KEPROX
  120 KEYS(22) = 1
      WRITE (LIS1, 122) (ISTAR, I=1,70)
  122 FORMAT (/// 1X, 35A2, '*' / ' ****', 62X, ' ****' / ' ****',
     +' The DIRDIF program system, version 99.2, update  4 Nov.  1999 '
     +             ,'****' / ' ****', 62X, ' ****' / 1X, 35A2, '*')
      IS = 992
      IT = 806
      CALL FILCLO (IHELP, 'KEEP')
      CALL XHELP (IHELP, LIS1, 11.0)
      CALL FILCLO (IHELP, 'KEEP')
      GOTO 130
  125 BACKSPACE  LIS1
  130 CONTINUE
      IF (KINX .LT. 0) GOTO 140
      IF (ILIS2 .GE. 0) GOTO 150
  135 FORMAT (// ' Problems ! ...  File LIS2 is incorrectly closed'/)
      WRITE (LIS1, 135)
      WRITE (IPR1, 135)
      WRITE (IPR1, FMT='('' See LIS1 ...''/)')
      CALL FILCLO (IHELP, 'KEEP')
      CALL XHELP (IHELP, LIS1, 10.0)
      WRITE (IPR1, 116) PROGNM
      PROGNM = ' '
      CALL KESTOP
      CALL KEPROX
  140 WRITE (LIS2, FMT='(''1      File LIS2: Auxiliary listing''/
     * ''       !! Extra information for troublesome structures !!''/
     * ''       Do not print ... Compare with LIS1 = LISTING print''/)')
      WRITE (LIS2, 122) (ISTAR, I=1,70)
  150 WRITE (LIS2, 152) (ISTAR, I=1,23), PROGNM, (ISTAR, I=1,23)
  152 FORMAT (/ 1X, 23A2 / ' ****', 38X, '****' / ' ****', 16X, A8,
     +   14X, '****' / ' ****', 38X, '****' / 1X, 23A2 )
      CALL KEDATE
      IF (KINQ .LT. 0) THEN
         CALL KEDATE
         CALL KETIME (LIS1)
      ELSE
         CALL KETIME (0)
         ENDIF
      IF (CCODE.EQ.'ATMOD' .OR. CCODE.EQ.'ORBASE') GOTO 911
      WRITE (CHOUT, FMT='(''0============ Program '', A8)') PROGNM
      IF (PROGNM .EQ. 'DDSTART') THEN
         IN = IS
         IF (IN .GT. 900) IN = IN - 900
         IN = IN * 10000 + IT
         ENDIF
      CALL LOGRD (IDDL, 'DDLOG', I)
      IF (I .GT. 0) THEN
         IF (LIT(1) .NE. 'DDLOG') THEN
            REWIND IDDL
            CALL KERINA (IDDL, LIT, 1, I)
            ENDIF
         IF (CCODE .EQ. 'CCODE') CCODE = LIT(2)
         IF (CCODE .NE. LIT(2)) THEN
            CHOUT = ' Wrong CCODE on DDLOG file: typing error? '
            CALL SHOUT
            CHOUT = ' Wrong directory?  Wrong compound code? '
            CALL SHOUT
            CALL KERROR (' What happened ??? ', 152, 'KEPROG')
            ENDIF
         IF (CCODE .NE. 'NONAME') THEN
            IF (CCODE(5:6) .EQ. '  ') THEN
               CCODE = ' '
               CCODE(3:6) = LIT(2)(1:4)
            ELSEIF (CCODE(6:6) .EQ. ' ') THEN
               CCODE = ' '
               CCODE(2:6) = LIT(2)(1:5)
               ENDIF
            WRITE (CHOUT, FMT='(''0============ Execute program '', A8,
     *         '' ============ for compound: '', A6  )') PROGNM, CCODE
            CCODE = LIT(2)
            ENDIF
         ENDIF
      CALL SHOUT
      CALL LOGRD (IDDL, 'RUN', IRUN)
      IF (IRUN .LE. 0) THEN
         IRUN = 0
      ELSE
         IRUN = NINT(FNUM(2))
         CALL LOGRD (IDDL, 'TITLE', ITIT)
         IF (ITIT .EQ. 1) THEN
            TITLE = CHIN(7:70)
            WRITE (LIS1, 160) TITLE
            WRITE (LIS2, 160) TITLE
  160       FORMAT (' LOG TITLE: ', A64)
            ENDIF
         ENDIF
      KEYS(13) = IRUN
      CALL FILCLO (IDDL, 'KEEP')
      IF (.NOT. FIRST) GOTO 211
      KEYS(5) = -1
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'INPUT', KIDDS)
      IF (KIDDS .EQ. -1) GOTO 211
      CALL KERINA (IDDS, LIT(32), 1, LEND)
      IF (LIT(1) .NE. PROGNM(1:6)) THEN
         CHOUT = ' Warning:  unexpected (incorrect?) DDSYST file'
         CALL SHOUT
         KEYS(5) = 1
         GOTO 211
         ENDIF
         KEYS(5) = 0
      NCH = 0
  201 CALL KERINA (IDDS, LIT(32), 1, LEND)
      IF (LEND .EQ. -1) GOTO 207
      NCH = NCH + 1
      CHONDA(NCH) = CHIN
      GOTO 201
  207 REWIND IDDS
      DO 208 I = 1, NCH
  208 WRITE (IDDS, FMT = '(A80) ') CHONDA(I)
      REWIND IDDS
      CALL FILCLO (IDDS, 'KEEP')
  211 FIRST = .FALSE.
      IF (KIDDJ .NE. 0) RETURN
  911 CHIN = CHINJ
      CALL KERINB (LIT(32), 1)
      IF (LIT(2) .EQ. 'BATCH') SWITCH(8) = .TRUE.
      IF (CCODE .NE. ' ') THEN
         CCODE = LIT(1)
         WRITE (CHOUT, FMT='(''0'', 64(''=''), 1X, A6)') CCODE
         CALL SHOUT
         ENDIF
      RETURN
      END
      SUBROUTINE KEPROX
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IDDOKA, KEYS(10))
      CHARACTER * 2  IISO
      DATA IISO   / '==' /
      CALL KEYSWI
      CALL KETIME (LIS2)
      IF (TITLE .NE. ' ') WRITE (LIS2, 110) TITLE
  110 FORMAT (' TITLE: ', A64)
      WRITE (LIS2, 111)  PROGNM, (IISO, I=1,23)
  111 FORMAT (' End of program ' , A8 /
     +     ' ' , 23A2  //  '$FINISH')
      WRITE (LIS1, FMT='('' End of program '', A8 // ''$FINISH'')')
     * PROGNM
      IF (IDDOKA .EQ. -17) THEN
         IDDOKA = 17
         DO 200 I=1,20
         IF (I.GE.6 .AND. I.LE.8) GOTO 200
         CALL FILCLO (I, 'KEEP')
  200    CONTINUE
         RETURN
         ENDIF
      STOP 0
      END
      SUBROUTINE KERNER (KEY, NAME)
      CHARACTER NAME *(*), NAMEX *8
      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)), (LIS2, IFILE(8))
      EQUIVALENCE (ISTOP, IFILE(20))
      EQUIVALENCE (IRUN, KEYS(13))
      CHARACTER * 6  SUBPGM
      DATA SUBPGM /'SUBPGM'/
      NAMEX = NAME
      IF (PROSNM.EQ.' ') SUBPGM=' '
      CLOSE (UNIT = ISTOP)
      CALL FILINQ (ISTOP, 'DDSTOP', 'FORMATTED', 'OUTPUT', KINQ)
      IF (KINQ .LT. 0) THEN
         WRITE (ISTOP, FMT= '(''DDSTOP  error stop in RUN'',
     *   I4, ''  for CCODE = '', A6)') IRUN, CCODE
         WRITE (ISTOP, FMT= '(''ERROR MESSAGE:'')')
      ELSE
         READ (ISTOP, FMT='(1X)')
         READ (ISTOP, FMT='(1X)')
         READ (ISTOP, FMT='(1X)')
         ENDIF
      WRITE (CHOUT, 100) PROGNM, SUBPGM, PROSNM, NAMEX
  100 FORMAT (' ERROR STOP IN ' ,A8, 3X,A6,1X,A6,' MODULE ',A8)
      WRITE (LIS2, 100) PROGNM, SUBPGM, PROSNM, NAMEX
      WRITE (ISTOP,100) PROGNM, SUBPGM, PROSNM, NAMEX
      CALL SHOUT
      IF (KEY.EQ.0) GOTO 190
      IF (KEY.LT.0) GOTO 120
      WRITE (CHOUT, 110) KEY
      WRITE (ISTOP, 110) KEY
  110 FORMAT (' ERROR (unexpected) OCCURED NEAR LABEL NUMBER', I6)
      CALL SHOUT
      GOTO 190
  120 WRITE (CHOUT, 130) KEY
      WRITE (ISTOP, 130) KEY
  130 FORMAT (' ERROR NUMBER', I5)
      CALL SHOUT
      IF (KEY.EQ.-1) WRITE (CHOUT, 140)
      IF (KEY.EQ.-1) WRITE (ISTOP, 140)
  140 FORMAT (' ERROR : INPUT DATA INCORRECT')
      CALL SHOUT
      IF (KEY.EQ.-2) WRITE (CHOUT, 150)
      IF (KEY.EQ.-2) WRITE (ISTOP, 150)
  150 FORMAT (' ERROR : INPUT DATA FILE(S) INCORRECT')
      CALL SHOUT
      IF (KEY.EQ.-3) WRITE (CHOUT, 160)
      IF (KEY.EQ.-3) WRITE (ISTOP, 160)
  160 FORMAT (' ERROR : SORRY, DATA IS INCONSISTENT')
      CALL SHOUT
      IF (KEY.EQ.-4) WRITE (CHOUT, 170)
      IF (KEY.EQ.-4) WRITE (ISTOP, 170)
  170 FORMAT (' ERROR ..MAY BE PROGRAMMERS ERROR..')
      CALL SHOUT
      IF (KEY.EQ.-5) WRITE (CHOUT, 180)
      IF (KEY.EQ.-5) WRITE (ISTOP, 180)
  180 FORMAT (' ERROR ... SEE MANUAL FOR DETAILS....')
      IF (KEY.EQ.-6) THEN
         WRITE (CHOUT, 140)
         WRITE (ISTOP, 140)
         CALL SHOUT
         WRITE (CHOUT, FMT='('' ERROR : LAST INPUT RECORD WAS:'')')
         WRITE (ISTOP, FMT='('' ERROR : LAST INPUT RECORD WAS:'')')
         CALL SHOUT
         WRITE (IPR1, 181) CHIN(1:72)
         WRITE (LIS1, 181) CHIN(1:72)
         WRITE (LIS2, 181) CHIN(1:72)
         WRITE (ISTOP,181) CHIN(1:72)
  181    FORMAT (' ERROR ! ', A72)
         ENDIF
  190 CONTINUE
      WRITE (LIS1, 187)
      WRITE (ISTOP,187)
  187 FORMAT (/' ERROR ! Here follows a general ERROR message.'/
     * ' The present error-stop is the result of an internal test'/
     * ' which could (may be) refer to a user-error. '/
     * ' If you understand the printed message, ignore the following',
     *   ' lines.'/ '   In most cases,',
     * ' error-stops occur at unexpected places or for unexpected'/
     * ' reasons, and consequently the error messages are ',
     *     'not transparant'/
     * ' for the user. At present (1999) we are trying to improve those'
     * / ' messages, but that is a slow process... ')
      WRITE (LIS1, 188)
      WRITE (ISTOP,188)
  188 FORMAT (
     * ' If the present error message is not clear to you, please, ',
     *      'tell us'/
     * ' about it: we can help..., at least we can explain the message,'
     * / ' and we learn from your cooperation.'/
     * ' We need to know what can go wrong.'/
     * ' And hopefully next DIRDIF release can be improved.'/
     * ' Thank you for your help.    Paul T. Beurskens.'/)
      CALL KETIME (LIS1)
      CALL KETIME (LIS2)
      CALL KETIME (ISTOP)
      WRITE (ISTOP, FMT='(''STOP'')')
      IF (NAMEX .EQ. 'FILINQ') THEN
         CLOSE (UNIT = IDDS)
         OPEN (UNIT = IDDS)
      ELSE
         CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'TEST', KINQ)
         IF (KINQ .LT. 0) GOTO 220
         ENDIF
      REWIND IDDS
      WRITE (IDDS, FMT='(''STOP'')')
      REWIND IDDS
      CALL FILCLO (IDDS, 'KEEP')
      IF (NAMEX .EQ. 'FILINQ') GOTO 230
  220 CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'TEST', KINQ)
      IF (KINQ .EQ. 0) CALL FILCLO (ICON, 'DELETE')
      CALL KEYSWI
  230 CONTINUE
      WRITE (LIS1, FMT='(/''$FINISH'')')
      WRITE (LIS2, FMT='(/''$FINISH'')')
      STOP 1
      END
      SUBROUTINE KERROR (MESGE, KEY, NAME)
      CHARACTER MESGE *(*) , MESGEX *70
      CHARACTER NAME  *(*) , NAMEX  *8
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (ISTOP, IFILE(20))
      EQUIVALENCE (IRUN, KEYS(13))
      NAMEX  = NAME
      MESGEX = MESGE
      WRITE (CHOUT, FMT='('' ERROR MESSAGE: '')')
      CALL SHOUT
      WRITE (IPR1, 100) MESGEX
      WRITE (LIS1, 100) MESGEX
      WRITE (LIS2, 100) MESGEX
  100 FORMAT (' ERROR : ', A70)
      CLOSE (UNIT = ISTOP)
      CALL FILINQ (ISTOP, 'DDSTOP', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (ISTOP, FMT=   '(''DDSTOP  error stop in RUN'',
     *   I4, ''  for CCODE = '', A6)') IRUN, CCODE
      WRITE (ISTOP, FMT='(''ERROR MESSAGE:'')')
      WRITE (ISTOP, 100) MESGEX
      WRITE (ISTOP, FMT='(''END'')')
      CALL KERNER (KEY, NAME)
      END
      SUBROUTINE KESTOP
      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 (IDDS, IFILE(2)), (ICON, IFILE(4))
      CALL FILCLO (IDDS, 'KEEP')
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IDDS, FMT='(''STOP'')')
      REWIND IDDS
      CALL FILCLO (IDDS, 'KEEP')
      CALL FILCLO (ICON, 'KEEP')
      CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'TEST', KINQ)
      IF (KINQ .EQ. 0) CALL FILCLO (ICON, 'DELETE')
      CALL KEYSWI
      END
      SUBROUTINE KERINA (IRD, L, LMAX, LEND)
      CHARACTER * 6  L(LMAX)
      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
      LEND = 0
      IF (IRD.LE.0 .OR. IRD.GT.20) CALL KERROR (' IRD?',-4,'KERINA')
      READ (IRD, 110, ERR = 120, END = 120, IOSTAT = IFSTAT(IRD)) CHIN
  110 FORMAT (A80)
      IF (IFSTAT(IRD) .EQ. 0) GOTO 130
  120 LEND = -1
      CHIN = ' '
  130 CALL KERINB (L, LMAX)
      IF (LEND.LE.-1) RETURN
      IF (LIT(1).EQ.'END   ') LEND = 4
      IF (LIT(1).EQ.'FINISH') LEND = 5
      IF (LIT(1).EQ.'STOP  ') LEND = 6
      RETURN
      END
      SUBROUTINE  KERINB (LUSER, LUMAX)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      CHARACTER * 6  LUSER(LUMAX)
      CHARACTER * 1  CH1
      CHARACTER * 6  CHLIT, IBL, LBOS
      DATA IDMAX  / 32 /
      DATA IBL    /'  '/
      DATA MCOL   / 72 /
      CALL KERNZ6 (IBL,  LIT, IDMAX)
      CALL KERNZA (0.0, FNUM, IDMAX)
      CALL KERNZI (0,  NCOLN, IDMAX)
      CALL KERNZI (0,  NCOLL, IDMAX)
      CALL KERNZI (0,  NFDOT, IDMAX)
      CALL KERNZI (0,  NFDOL, IDMAX)
      CALL KERNZI (0, NLUSER, IDMAX)
      LUMA = LUMAX
      IF (LUMA.EQ.1 .AND. LUSER(1).EQ.' ') LUMA = 0
      NFNUM = 0
      NLIT  = 0
      ITEM  = 0
      KEND  = 0
      NEND  = 0
      I = 1
  110 IF (I.GT.MCOL) GOTO 270
      DO 120 K=I,MCOL
      CH1 = CHIN(K:K)
      IF (CH1.NE.' ' .AND. CH1.NE.',') GOTO 130
  120 CONTINUE
      GOTO 270
  130 NONUM  = 0
      NONUM2 = 0
      NSIG = 0
      NDOT = 0
      I = K
      DO 170 K=I,MCOL
      CH1 = CHIN(K:K)
      CALL KERC2I (CH1, J)
      IF (J.GE.0 .AND. J.LE.9) GOTO 140
      IF (CH1.EQ.'.') GOTO 150
      IF (J.LT.0 .OR. J.GE.41) GOTO 240
      IF (J.GE.11 .AND. J.LE.36) GOTO 240
      IF (NDOT.EQ.1  .AND. NONUM.EQ.0) GOTO 240
      IF (CH1.EQ.',' .AND. NONUM.EQ.0) GOTO 240
      IF (CH1.EQ.',') GOTO 180
      IF (CH1.EQ.'+'.OR. CH1.EQ.'-') GOTO 160
      IF (NONUM2.EQ.1) GOTO 240
      IF (NSIG.EQ.1) GOTO 170
      IF (NONUM.EQ.0) GOTO 240
      GOTO 180
  140 NONUM  = 1
      NONUM2 = 0
      NSIG = 0
      GOTO 170
  150 NDOT = NDOT + 1
      IF (NDOT.EQ.2) GOTO 240
      GOTO 170
  160 IF (NSIG.EQ.1) GOTO 240
      IF (NDOT.EQ.1 .AND. NONUM.EQ.0) GOTO 240
      NSIG = 1
      NONUM2 = NONUM
      NONUM  = 0
      NDOT = 0
  170 CONTINUE
      IF (NONUM.EQ.0) GOTO 240
  180 ITEM  = ITEM  + 1
      NFNUM = NFNUM + 1
      IF (NFNUM.LE.IDMAX) NCOLN(NFNUM) = I
      IF (NFNUM.GT.IDMAX) NCOLN(IDMAX) = - IABS(NCOLN(IDMAX))
      NONUM = 0
      NSIG  = 0
      NDOT  = 0
      DO 220 K=I,MCOL
      CH1 = CHIN(K:K)
      CALL KERC2I (CH1, J)
      IF (J.GE.0 .AND. J.LE.9) GOTO 190
      IF (CH1.EQ.'.') GOTO 200
      IF (CH1.EQ.',') GOTO 230
      IF (CH1.EQ.'+' .OR. CH1.EQ.'-') GOTO 210
      IF (J.NE.10) CALL KERNER (-4, 'KERINB')
      IF (NSIG.EQ.1) GOTO 220
      IF (NONUM.EQ.1) GOTO 230
      CALL KERNER (-4, 'KERINB')
  190 CONTINUE
      NONUM = 1
      NSIG  = 0
      GOTO 220
  200 NDOT = 1
      GOTO 220
  210 IF (NONUM.EQ.1) GOTO 230
      NSIG  = 1
      NONUM = 0
  220 CONTINUE
      KEND = 999
  230 CONTINUE
      CALL KERINF (CHIN, I, K-1, A, NEND)
      I = K
      IF (NFNUM.LE.IDMAX) FNUM(NFNUM)  = A
      IF (NFNUM.LE.IDMAX) NFDOT(NFNUM) = NDOT+1
      IF (NFNUM.GT.IDMAX) NFNUM = IDMAX
      IF (ITEM.LE.IDMAX)  NFDOL(ITEM) = NDOT+1
      GOTO 110
  240 ITEM = ITEM + 1
      NLIT = NLIT + 1
      IF (NLIT.LE.IDMAX) NCOLL(NLIT)  = I
      IF (NLIT.GT.IDMAX) NCOLL(IDMAX) = - IABS(NCOLL(IDMAX))
      L = 1
      CHLIT = ' '
      DO 250 K=I,MCOL
      CH1 = CHIN(K:K)
      IF (CH1.EQ.' ' .OR. CH1.EQ.',') GOTO 260
      IF (L.LE.6) CHLIT(L:L) = CH1
  250 L = L + 1
      KEND = 999
      L = MCOL - I + 2
  260 I = K
      IF (NLIT.LE.IDMAX) LIT(NLIT) = CHLIT
      IF (NLIT.GT.IDMAX) NLIT = IDMAX
      IF (ITEM.LE.IDMAX) NFDOL(ITEM) = 1 - L
      IF (NLIT.GT.IDMAX) GOTO 270
      CALL KERC2U (LIT(NLIT), LBOS, 6)
      LIT(NLIT) = LBOS
      IF (LUMA.GT.0) CALL KEREQ6 (LIT(NLIT), LUSER, LUMA, NLUSER(NLIT))
      IF (KEND.EQ.999) I = KEND
      GOTO 110
  270 RETURN
      END
      SUBROUTINE KERINC (IPRX, LEND)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      LOGICAL SWPRI, BATCH
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (BATCH, SWITCH(8)),  (LIS2, IFILE(8))
      CHARACTER * 64 TITLX
      CHARACTER * 6  L(9)
      DATA  L     / '    ', 'REMARK', 'TITLE', 'END', 'FINISH',
     +              'STOP', 'BATCH',  '     ', 'PRINT' /
      DATA LMAX / 9 /
      CALL KEREQ6 (LIT(1), L, LMAX, LEND)
      IF (LEND.LE.0) GOTO 100
      GOTO (1,2,3,4,4,4,7,1,9), LEND
    1 IF (NFNUM.LE.0) GOTO 4
  100 LEND = 0
      RETURN
    2 IF (IPRX .GT. 0) WRITE (IPRX, 110) CHIN(1:72)
      IF (IPRX .NE. LIS2) WRITE (LIS2, 110) CHIN(1:72)
  110 FORMAT (' INPUT: ' , 72A, / )
      GOTO 4
    3 IF (TITLE.NE.' ') GOTO 4
      READ (CHIN(7:72), FMT=120) TITLE
  120 FORMAT (A64)
      DO 122 I=61,1,-1
      IF (TITLE(I:I+1) .EQ. '  ') TITLX      =TITLE
      IF (TITLE(I:I+1) .EQ. '  ') TITLE(I:64)=TITLX(I+1:64)
  122 CONTINUE
      IF (TITLE(1:1)   .EQ. ' ' ) TITLX      =TITLE
      IF (TITLE(1:1)   .EQ. ' ' ) TITLE(1:64)=TITLX(2  :64)
      WRITE (CHOUT, 130) TITLE
  130 FORMAT (' TITLE: ', A64)
      CALL SHOUT2
    4 RETURN
    7 BATCH = .TRUE.
      GOTO 150
    9 SWPRI = .TRUE.
  150 IF (SWPRI) WRITE (LIS2, 110)  CHIN(1:72)
      RETURN
      END
      SUBROUTINE KERINF (CHIN, I, K, FF, KEND)
      CHARACTER * 80 CHIN
      CHARACTER * 6  LL
      CHARACTER * 8  CHFMT
      M = K - I + 1
      KEND = 0
      CALL KERI2C (M, LL, 6)
      CHFMT = '(F'//LL(1:3)//'.0)'
      READ (CHIN(I:K), FMT = CHFMT, ERR = 99) FF
      RETURN
   99 KEND = -1
      RETURN
      END
      SUBROUTINE KERIFF (IRD, L, LMAX, LEND)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      LOGICAL      SWPRI
      EQUIVALENCE (LIS2, IFILE(8))
      EQUIVALENCE (SWPRI, SWITCH(10))
      CHARACTER * 6  L(LMAX)
      IPRX = 0
      IF (SWPRI) IPRX = LIS2
  100 CALL KERINA (IRD, L, LMAX, LEND)
      IF (LEND.LE.-1) RETURN
      CALL KERINC (IPRX, LEND)
      IF (LEND.EQ.0) RETURN
      IF (LEND.LT.4 .OR. LEND.GT.7) GOTO 100
      RETURN
      END
      SUBROUTINE KETERM (KNUM, KLIT, KEND)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IRD, IFILE(5)), (IPR1, IFILE(6))
      DATA I / 0 /
      IF (KNUM.EQ.0 .AND. KLIT.EQ.0) CALL KERNER (-4, 'KETERM')
      READ (IRD, FMT = '(A80)', END = 105, ERR = 105)  CHIN
      GOTO 120
  105 WRITE (IPR1, 110)
  110 FORMAT (' Your input line is empty' )
      REWIND IRD
      KEND = -1
      RETURN
  120 CALL KERINB (LIT, 1)
      IF (NFNUM.GT.0 .OR. NLIT.GT.0) GOTO 140
      KEND = -2
      WRITE (IPR1, 130)
  130 FORMAT (' Blank line' )
      RETURN
  140 IF ((KNUM.GE.0 .AND. NFNUM.NE.KNUM) .OR.
     *    (KLIT.GE.0 .AND. NLIT .NE.KLIT))    THEN
         WRITE (IPR1, 142) KLIT, KNUM, NLIT, NFNUM
  142    FORMAT (' Program requested', I3, ' literal(s) and',
     +   I3, ' number(s)' / ' but you supplied:', I3,
     +   ' literal(s) and', I3, ' number(s). Please, try again'  /)
         KEND = -3
         RETURN
         ENDIF
      KEND = 99
      IF (NFDOL(2).NE.0) RETURN
      IF (NLIT.EQ.1)  I = NCOLL(1)
      IF (NFNUM.EQ.1) I = NCOLN(1)
      IF (CHIN(I+1:I+1).NE.' ') RETURN
      CALL KERC2I (CHIN(I:I), KEND)
      IF (KEND.LT.0) KEND = 99
      RETURN
      END
      SUBROUTINE SHOUT
      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 *72
      CHOUTX = CHOUT
      CHOUTX(1:1) = ' '
      IF (IPR1.NE.LIS1) WRITE (IPR1, 100) CHOUTX
  100 FORMAT (A72)
      CALL SHOUT2
      RETURN
      END
      SUBROUTINE SHOUT2
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
  100 FORMAT (A72)
  101 FORMAT (/A72)
      IF (CHOUT(1:1) .EQ. '0') THEN
         CHOUT(1:1) = ' '
         WRITE (LIS1, 101) CHOUT
         IF (LIS1 .NE. LIS2) WRITE (LIS2, 101) CHOUT
      ELSE
         WRITE (LIS1, 100) CHOUT
         IF (LIS1 .NE. LIS2) WRITE (LIS2, 100) CHOUT
         ENDIF
      CHOUT = ' '
      RETURN
      END
      SUBROUTINE FILINQ (IUNIT, FNAMEX, FFORMX, FKEYX, KINQ)
      CHARACTER FNAMEX *(*), FFORMX *(*), FKEYX *(*),
     *          FNAME  *64,  FFORM  *11,  FKEY  *7
      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))
      CHARACTER FORMIN *11, FULNAM *255, POSFMT *7, POSUNF *7, FULNA *63
      LOGICAL   OPN, EXS, NMD
      FNAME = FNAMEX
      CALL FILINX (FNAME)
      FFORM = FFORMX
      FKEY  = FKEYX
      IF (FKEY.NE.'SCRATCH' .AND. FKEY.NE.'TEST' .AND. FKEY.NE.'INPUT'
     *    .AND. FKEY.NE.'OUTPUT') THEN
         WRITE (CHOUT, 147) FKEY
  147    FORMAT (' ERROR : ',A7,' used for SCRATCH TEST INPUT OUTPUT?')
         CALL SHOUT
         WRITE (CHOUT, 148) IUNIT
  148    FORMAT (' ERROR ! other call params: UNIT=',I3,'  FNAME=   ')
         CHOUT (48:72) = FNAME
         CALL SHOUT
         CALL KERROR('Programmers error in call params', 147, 'FILINQ')
         ENDIF
      IF (IUNIT.LE.0 .OR. IUNIT.GT.20) THEN
         WRITE (CHOUT, 151) IUNIT
  151    FORMAT (' ERROR :  in call params: UNIT=', I3, '  FNAME=   ')
         CHOUT (49:72) = FNAME
         CALL SHOUT
         CALL KERROR ('Bad file unit number', 151, 'FILINQ')
         ENDIF
      INQUIRE (FILE = FNAME, ERR  = 900, IOSTAT = KINQ, EXIST = EXS,
     *         OPENED = OPN, FORM = FORMIN, NUMBER = NUM,
     *         NAMED  = NMD, NAME = FULNAM,
     *         FORMATTED = POSFMT, UNFORMATTED = POSUNF)
      IF ( EXS ) THEN
         IF ( OPN ) THEN
            IF (FORMIN .NE. FFORM ) GOTO 910
            IF (NUM    .NE. IUNIT ) GOTO 920
            IF (FKEY   .NE. 'TEST') REWIND IUNIT
            GOTO 200
            ENDIF
         IF (FFORM .EQ. '  FORMATTED' .AND. POSFMT .EQ. 'NO') GOTO 930
         IF (FFORM .EQ. 'FORMATTED'   .AND. POSFMT .EQ. 'NO') GOTO 930
         IF (FFORM .EQ. 'UNFORMATTED' .AND. POSUNF .EQ. 'NO') GOTO 932
         IF (FKEY .EQ. 'SCRATCH') THEN
            OPEN (UNIT = IUNIT, ERR = 940, IOSTAT = KINQ,
     *            FORM = FFORM, STATUS = 'SCRATCH')
            REWIND IUNIT
            GOTO 200
            ENDIF
         OPEN (UNIT = IUNIT, ERR = 940, IOSTAT = KINQ, FILE = FNAME,
     *         FORM = FFORM, STATUS = 'OLD')
         REWIND IUNIT
  200    IF (IUNIT .EQ. IFILE(IUNIT)) IFSTAT(IUNIT) = 0
         KINQ = 0
      ELSE
         IF (FKEY .EQ. 'SCRATCH') THEN
            OPEN (UNIT = IUNIT, ERR = 950, IOSTAT = KINQ,
     *            FORM = FFORM, STATUS = 'SCRATCH')
         ELSEIF (FKEY .EQ. 'OUTPUT') THEN
            OPEN (UNIT = IUNIT, ERR = 950, IOSTAT = KINQ, FILE = FNAME,
     *            FORM = FFORM, STATUS = 'NEW')
            ENDIF
         IF (IUNIT .EQ. IFILE(IUNIT)) IFSTAT(IUNIT) = -1
         KINQ = -1
         ENDIF
      RETURN
  900 WRITE (LIS1, 901) IUNIT, FNAME, KINQ
  901 FORMAT (
     *' ERROR Transmission error during execution of INQUIRE statement'/
     * 'ERROR ? Unit number:',I3,' File name: ', A24,' Error code:',I4)
      GOTO 990
  910 WRITE (LIS1, 911) FNAME, IUNIT, FFORM, FORMIN
  911 FORMAT ( ' ERROR :',
     * ' The requested c.q. expected I/O-access mode of an already' /
     * ' ERROR !',
     * ' existing and opened file does not match the I/O-access mode' /
     * ' ERROR !',
     * ' found by INQUIRE for file name: ',A24, 'Unit number: ', I2 /
     * ' ERROR ! Requested mode: ', A11, 5X,'Mode found: ', A11)
      IF ( NMD ) GOTO 917
  912 WRITE (LIS1, 913)
  913 FORMAT (' ERROR :',
     *    ' Full file name not returned by INQUIRE, unnamed file!')
      GOTO 990
  917 FULNA = FULNAM
      WRITE (LIS1, 918) FULNA
  918 FORMAT (' ERROR : Full file name: ',A63)
      GOTO 990
  920 WRITE (LIS1, 921) FNAME, IUNIT, NUM
  921 FORMAT ( ' ERROR :',
     * ' The requested c.q. expected unit number of an already',/,
     * ' ERROR !',
     * ' existing and opened file does not match the unit number',/,
     * ' ERROR ! found by INQUIRE for file name: ',A32/,
     * ' ERROR ! Requested unit number:',I3,5X,'Unit number found:',I3)
      IF ( NMD ) GOTO 917
      GOTO 912
  930 WRITE (LIS1, 931) FNAME, IUNIT, FFORM, POSFMT
  931 FORMAT (' ERROR :',
     * ' The requested I/O-access mode for an already existing file' /
     * ' ERROR !',
     * ' does not match the allowed I/O-access mode for this file as' /
     * ' ERROR !',
     * ' found by INQUIRE for file name: ',A24, 'Unit number: ', I2 /
     * ' ERROR !',
     * ' Requested mode: ', A11, 5X, 'FORMATTED mode allowed: ', A7)
      IF ( NMD ) GOTO 917
      GOTO 912
  932 WRITE (LIS1, 933) FNAME, IUNIT, FFORM, POSUNF
  933 FORMAT (' ERROR :',
     * ' The requested I/O-access mode for an already existing file' /
     * ' ERROR !',
     * ' does not match the allowed I/O-access mode for this file as' /
     * ' ERROR !',
     * ' found by INQUIRE for file name: ',A24, 'Unit number: ', I2 /
     * ' ERROR !',
     * ' Requested mode: ', A11, 5X, 'UNFORMATTED mode allowed: ', A7)
      IF ( NMD ) GOTO 917
      GOTO 912
  940 WRITE (LIS1, 941) FKEY, IUNIT, FNAME, KINQ
  941 FORMAT (' ERROR :',
     * ' Transmission error during execution of OPEN statement' /
     * ' ERROR ! on an already existing file, option ', A7 /
     * ' ERROR !',
     * ' Unit number: ',I2, 4X, 'File name: ', A24, ' Error code: ',I4)
      GOTO 990
  950 WRITE (LIS1, 951) FKEY, IUNIT, FNAME, KINQ
  951 FORMAT (' ERROR :',
     * ' Transmission error during execution of OPEN statement' /
     * ' ERROR ! for a new file, option ', A7 /
     * ' ERROR !',
     * ' Unit number: ',I2, 4X, 'File name: ', A24, ' Error code: ',I4)
  990 WRITE (CHOUT, 992) FNAME
  992 FORMAT (' File error concerning file (name): ', A32)
      CALL KERROR (CHOUT, 0, 'FILINQ')
      END
      SUBROUTINE FILCLO (IUNIT, FKEYX)
      CHARACTER  FKEYX *(*), FKEY *7
      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))
      LOGICAL  OPN
      FKEY = FKEYX
      IF (FKEY .EQ. 'SCRATCH') FKEY = 'DELETE'
      IF (FKEY.NE.'KEEP'.AND.FKEY.NE.'DELETE') CALL KERNER(-4,'FILCLO')
      INQUIRE (UNIT = IUNIT, ERR = 200, OPENED = OPN)
      IF (.NOT. OPN) RETURN
      CLOSE (UNIT = IUNIT, ERR = 200, IOSTAT = KCLO, STATUS = FKEY)
      IF (KCLO.GE.1)  GOTO 200
      KCLO = -3
      IF (FKEY.EQ.'DELETE') KCLO = -2
      IF (IUNIT.EQ.IFILE(IUNIT)) IFSTAT(IUNIT) = KCLO
      RETURN
  200 WRITE (CHOUT, 210) IUNIT, FKEY
  210 FORMAT (' ERROR on closing file ', I3, ', option: ', A7)
      CALL KERROR (CHOUT, 0, 'FILCLO')
      END
      SUBROUTINE RDCRYS (ICRYS)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      CHARACTER CONT*1
      CHARACTER * 6  XTEST
      CHARACTER * 6  LLIT(30)
      CHARACTER * 6  NAME
      DATA NAME    / 'RDCRYS' /
      DATA LLMAX   / 27 /
      DATA LLIT   / 'CRYSDA', 'CELL  ', 'CELLSD', 'SPGR  ', 'RCELL ',
     +              'VOLUM ', 'WAVE  ', 'FORMUL', 'MOLW  ', 'Z     ',
     +              'NELEC ', 'F000  ', 'MU    ', 'ICENT ', 'ILATT ',
     +              'ISYST ', 'ILAUE ', 'IMULT ', 'IUNIQ ', 'IPOLA ',
     +              'NTYPE ', 'NSYMM ', 'NLATT ', 'FRAC2C', 'CART2F',
     +              'RRMAT ', 'SSMAT ', '      ', '      ', '      ' /
      DATA NPRI / 0 /
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) THEN
         WRITE (CHOUT, 100) CCODE
  100    FORMAT (' ERROR no crysda file found for ', A6)
         CALL KERROR (CHOUT, 0, 'RDCRYS')
         ENDIF
      NPRI = NPRI + 1
      DO 170 I=1,LLMAX
      CALL RDCRYB (ICRYS, LLIT(I), KEND)
      IF (KEND.LT.0) THEN
         WRITE (CHOUT, 917) LLIT(I)
  917    FORMAT (' ERROR : search for keyword ', A6,
     *           ' on CRYSDA file failed')
         CALL SHOUT
         GOTO 990
         ENDIF
      GOTO  (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
     *      16,17,18,19,20,21,22,23,24, 25, 26, 27,170,170,170), I
    1 IF (NPRI .EQ. 1) WRITE (LIS2, 101)
  101 FORMAT (' Input crystal data file  CRYSDA')
      CALL KERINB (LIT(32),1)
      IF (CCODE .EQ. ' ' .OR. CCODE .EQ. 'CCODE') CCODE = LIT(2)
      IF (CCODE .EQ. LIT(2)) GOTO 170
      WRITE (LIS1, 102) LIT(2), CCODE
  102 FORMAT (' Error: compound code on CRYSDA file is: ', A6,
     * ' expected: ', A6)
      GOTO 990
    2 READ (CHIN, 130) CELL
      GOTO 170
    3 READ (CHIN, 130) CELLSD
      GOTO 170
    4 CONTINUE
      SPGR = CHIN(11:26)
      GOTO 170
    5 READ (CHIN, 130) RCELL
      GOTO 170
    6 READ (CHIN, 130) VOLUM
      GOTO 170
    7 READ (CHIN, 107) WAVEAT, WAVE
  107 FORMAT (10X, A2, 8X, F10.6)
      GOTO 170
    8 READ (CHIN, 108) (CELATY(J), CELALL(J), J=1,5), CONT
  108 FORMAT (10X, 5(A2, F9.2, 1X), 1X, A1)
      IF (CONT.EQ.'=') READ (ICRYS,108) (CELATY(J), CELALL(J), J=6,10)
      GOTO 170
    9 READ (CHIN, 130) AMOLW
      GOTO 170
   10 READ (CHIN, 140) IZ
      ZET = IZ
      GOTO 170
   11 READ (CHIN, 140) NELEC
      GOTO 170
   12 READ (CHIN, 130) F000
      GOTO 170
   13 READ (CHIN, 130) ABSMU
      GOTO 170
   14 READ (CHIN, 140) ICENT
      GOTO 170
   15 READ (CHIN, 140) ILATT
      GOTO 170
   16 READ (CHIN, 140) ISYST
      GOTO 170
   17 READ (CHIN, 140) ILAUE
      GOTO 170
   18 READ (CHIN, 140) IMULT
      GOTO 170
   19 READ (CHIN, 140) IUNIQ
      GOTO 170
   20 READ (CHIN, 140) IPOLA
      GOTO 170
   21 READ (CHIN, 140) NTYPE
      DO 121 J=1,NTYPE
  121 CELALL(J) = CELALL(J) * ZET
      GOTO 170
   22 READ (CHIN, 140) NSYMM
      DO 122 M=1,NSYMM
  122 READ (ICRYS,1122) XTEST, ((IRSYMM(J,K,M),K=1,3),TSYMM(J,M),J=1,3)
 1122 FORMAT (A6, 4X, 3(3I3,1X,F10.7))
      IF (XTEST .NE. 'SYMMAT') GOTO 990
      GOTO 170
   23 READ (CHIN, 140) NLATT
      DO 123 M=1,NLATT
  123 READ (ICRYS, 1123) XTEST, (TLATT(J,M), J=1,3)
 1123 FORMAT (A6, 4X, 3(F10.7))
      IF (XTEST .NE. 'CENVEC') GOTO 990
      GOTO 170
   24 BACKSPACE ICRYS
      READ (ICRYS, 150) ((FRAC2C(J,K), K=1,3), J=1,3)
      GOTO 170
   25 BACKSPACE ICRYS
      READ (ICRYS, 150) ((CART2F(J,K), K=1,3), J=1,3)
      GOTO 170
   26 BACKSPACE ICRYS
      READ (ICRYS, 150) ((RRMAT(J,K), K=1,3), J=1,3)
      GOTO 170
   27 BACKSPACE ICRYS
      READ (ICRYS, 150) ((SSMAT(J,K), K=1,3), J=1,3)
  130 FORMAT (10X, 6F10.5)
  140 FORMAT (10X, I10)
  150 FORMAT (3(10X, 3F15.6, /))
  170 CONTINUE
      IF (NPRI .NE. 1) RETURN
      WRITE (LIS2, 171) CELL, SPGR
  171 FORMAT (' Cell', 3F8.3, 3F7.2, '  SpGr ', A16)
      IF (PROGNM .EQ. 'DDSTART' .OR. PROGNM .EQ. 'FFT')
     *   WRITE (LIS1, 171) CELL, SPGR
      RETURN
  990 WRITE (LIS1,991) LLIT(I)
  991 FORMAT (' ERROR : CONTENTS OF CRYSDA FILE INCORRECT: '/
     *        ' ERROR ! TRYING TO READ RECORD: ', A6)
      CALL KERNER (-6, NAME)
      RETURN
      END
      SUBROUTINE  RDCRYB (ICRYS, LLITX, KEND)
      CHARACTER LLITX *(*), LLIT *6
      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
      LLIT = LLITX
      KEND = -3
  100 READ (ICRYS, 110, END=120) CHIN
  110 FORMAT (A80)
      IF (CHIN(1:4).EQ.'END')  GOTO 120
      IF (CHIN(1:6).EQ.LLIT) GOTO 130
      IF (CHIN(1:5).EQ.'TITLE' .AND. TITLE.EQ.' ') TITLE = CHIN(7:71)
      GOTO 100
  120 KEND = KEND + 1
      REWIND ICRYS
      IF (KEND.LT.-1) GOTO 100
      RETURN
  130 KEND = 1
      RETURN
      END
      SUBROUTINE RDCRYX (ICRYS, LLITX, F, N)
      CHARACTER LLITX *(*), LLIT *6
      DIMENSION F(N)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      CHARACTER * 6  NAME
      DATA NAME   / 'RDCRYX' /
      LLIT = LLITX
      CALL RDCRYB (ICRYS, LLIT, KEND)
      IF (KEND.LT.0) GOTO 990
      M = MIN0 (6, N)
      READ (CHIN, 100) (F(I), I=1,M)
  100 FORMAT (10X, 6F10.5)
      IF (N.LE.6) RETURN
      IF (LLIT.NE.'SFAC') GOTO 990
      READ (ICRYS, 110) (F(I), I=7,N)
  110 FORMAT (10X, 3F10.5, 2F7.3, F11.3, F5.2)
      RETURN
  990 CALL KERNER (-2, NAME)
      RETURN
      END
      SUBROUTINE RCELLR (CELL, V, RCELL)
      DIMENSION CELL(6), RCELL(6), AC(6)
      EQUIVALENCE (AC(1),      A), (AC(2),      B),  (AC(3),      C)
      EQUIVALENCE (AC(4),  ALPHA), (AC(5),   BETA),  (AC(6),  GAMMA)
      R2D = 45. / ATAN(1.0)
      CALL KERNAB (CELL, AC, 6)
      CA = COS(ALPHA / R2D)
      CB = COS(BETA  / R2D)
      CC = COS(GAMMA / R2D)
      SA = SQRT(1.0-CA**2)
      SB = SQRT(1.0-CB**2)
      SC = SQRT(1.0-CC**2)
      CASTR = (CB*CC-CA) / (SB*SC)
      CBSTR = (CA*CC-CB) / (SA*SC)
      CCSTR = (CA*CB-CC) / (SA*SB)
      SASTR = SQRT(1.0-CASTR**2)
      SBSTR = SQRT(1.0-CBSTR**2)
      SCSTR = SQRT(1.0-CCSTR**2)
      V = A*B*C * SQRT (1.0-CA*CA-CB*CB-CC*CC+2.0*CA*CB*CC)
      RCELL(1) = B*C*SA / V
      RCELL(2) = A*C*SB / V
      RCELL(3) = A*B*SC / V
      RCELL(4) = ASIN(SASTR) * R2D
      RCELL(5) = ASIN(SBSTR) * R2D
      RCELL(6) = ASIN(SCSTR) * R2D
      IF (CASTR .LT. 0.0) RCELL(4) = 180.0 - RCELL(4)
      IF (CBSTR .LT. 0.0) RCELL(5) = 180.0 - RCELL(5)
      IF (CCSTR .LT. 0.0) RCELL(6) = 180.0 - RCELL(6)
      RETURN
      END
      SUBROUTINE CELLRR (CELL, RR)
      DIMENSION CELL(6), RR(3,3)
      R2D = 45. / ATAN(1.0)
      CA = COS(CELL(4) / R2D)
      CB = COS(CELL(5) / R2D)
      CC = COS(CELL(6) / R2D)
      RR(1,1) = CELL(1) * CELL(1)
      RR(1,2) = CELL(1) * CELL(2) * CC
      RR(1,3) = CELL(1) * CELL(3) * CB
      RR(2,1) = RR(1,2)
      RR(2,2) = CELL(2) * CELL(2)
      RR(2,3) = CELL(2) * CELL(3) * CA
      RR(3,1) = RR(1,3)
      RR(3,2) = RR(2,3)
      RR(3,3) = CELL(3) * CELL(3)
      RETURN
      END
      SUBROUTINE CELZAT (ACELTY, NCELTY, NCELLZ)
      DIMENSION ACELTY(10), NCELTY(10), NCELLZ(10)
      CHARACTER ACELTY *2
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (LIS2,   IFILE(8))
      COMMON /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 JCELLZ(10)
      DO 160 N = 1, NTYPE
  160 CALL ATOMIZ(CELATY(N), K, JCELLZ(N))
      DO 180 N = 1, 10
      NCELLZ(N) = 0
      NCELTY(N) = 0
  180 ACELTY(N) = ' '
      LZ = 999
      DO 580 N = 1, NTYPE
      DO 570 J = 1, NTYPE
      IF (JCELLZ(J) .GE. LZ) GOTO 570
      IF (JCELLZ(J) .EQ. NCELLZ(N))
     *   NCELTY(N) = NCELTY(N) + NINT(CELALL(J))
      IF (JCELLZ(J) .GT. NCELLZ(N)) THEN
         NCELLZ(N) = JCELLZ(J)
         NCELTY(N) = NINT(CELALL(J))
         ACELTY(N) = CELATY(J)
         ENDIF
  570 CONTINUE
  580 LZ = NCELLZ(N)
      WRITE (LIS2, 611) (ACELTY(I), I=1,NTYPE)
  611 FORMAT (' Cell contents.  Atoms:  ', 10(3X, A2))
      WRITE (LIS2, 612) (NCELLZ(I), I=1,NTYPE)
  612 FORMAT (17X, 'Z =  : ', 10I5)
      WRITE (LIS2, 613) (NCELTY(I), I=1,NTYPE)
  613 FORMAT (' Total number of atoms: ', 10I5)
      RETURN
      END
      SUBROUTINE BINIX (IFI, FILENM, NIT, NW1, BUF)
      CHARACTER FILENM *(*), FILEN *6
      PARAMETER (MAXBUF = 198)
      DIMENSION BUF(MAXBUF)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (LIS2, IFILE(8))
      FILEN = FILENM
      CALL FILINQ (IFI, FILEN, 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ.LT.0) THEN
         WRITE (CHOUT, FMT='(''Binary input file '',
     *         A6, 1X, A6, '' not found'')') CCODE, FILEN
         CALL KERROR (CHOUT, 0, 'BINIX')
         ENDIF
      IF (SWPRI) WRITE (LIS2, 100) FILEN
  100 FORMAT (' Read binary data file ', A6)
      CALL KERNZA (0., BUF, MAXBUF)
      READ   (IFI, ERR=120, IOSTAT=IFSTAT(IFI))
     *           NW, NIT, NRR, NW1, CHIN, (BUF(I), I=1,NW1)
      IF (CHIN(1:6) .NE. FILEN) THEN
         WRITE (CHOUT, 105) FILEN, CHIN(1:6)
  105    FORMAT (' Warning: filename conflict, file: ', A6,
     *         ' interal i.d.: ', A6)
         CALL SHOUT
         ENDIF
      IF (IFSTAT(IFI) .EQ. 0) RETURN
  120 WRITE (CHOUT, 130) FILENM, IFI
  130 FORMAT (' Error input file ', A6, ', unit number ', I3)
      CALL KERROR (CHOUT, 120, 'BINIX')
      RETURN
      END
      SUBROUTINE BINOX (IFO, FILENM, NIT, NW1, BUF)
      CHARACTER FILENM *(*), FILEN *6
      PARAMETER (MAXBUF = 198)
      DIMENSION BUF(MAXBUF)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (LIS2, IFILE(8))
      FILEN = FILENM
      CALL FILINQ (IFO, FILEN, 'UNFORMATTED', 'OUTPUT', KINQ)
      IF (SWPRI) WRITE (LIS2, 100) FILEN
  100 FORMAT (' Write binary data file ', A6)
      IF (NW1 .GT. MAXBUF-24) CALL KERNER (100, 'BINOX')
      NW  = MAXBUF
      NRR = MAXBUF / NIT
      DO 110 I=1,4
  110 BUF(I) = ITIME(I)
      CHIN(1 :6)  = FILEN
      CHIN(7 :12) = CCODE
      CHIN(13:20) = PROGNM
      CHIN(21:80) = TITLE
      WRITE (IFO, ERR=120, IOSTAT=IFSTAT(IFO))
     *      NW, NIT, NRR, NW1, CHIN, (BUF(I), I=1,NW1)
      IF (MAXBUF .GT. NW1) CALL KERNZA (0., BUF(NW1+1), MAXBUF-NW1)
      IF (IFSTAT(IFO) .EQ. 0) RETURN
  120 WRITE (CHOUT, 130) FILENM, IFO
  130 FORMAT (' Error output file ', A6, ', unit number ', I3)
      CALL KERROR (CHOUT, 0, 'BINOX')
      RETURN
      END
      SUBROUTINE BINIFF (KEY, IFI, FILENM, FITEMS, NIT, BUF, NEND)
      CHARACTER FILENM *(*), FILEN *6
      PARAMETER (MAXBUF = 198)
      DIMENSION BUF(MAXBUF)
      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
      DIMENSION FITEMS (1)
      DATA FSTOP / -66.9E06 /
      IF (IFI.LE.0 .OR. IFI.GT.20) CALL KERROR (' IFI?',-4,'BINIFF')
      IF (KEY) 140, 110, 100
  100 FILEN = FILENM
      CALL BINIX (IFI, FILEN, NIT, NW1, BUF)
      NEND = - NW1
      RETURN
  110 IF (NEND.LT.0) GOTO 115
      IF (NEND.LE.MAXBUF-NIT) GOTO 120
  115 READ (IFI, ERR=150, END=150, IOSTAT=IFSTAT(IFI)) BUF
      IF (IFSTAT(IFI) .NE. 0) GOTO 150
      NEND = 0
  120 IF (BUF(NEND+1).LE.FSTOP) GOTO 130
      CALL KERNAB (BUF(NEND+1), FITEMS, NIT)
      NEND = NEND + NIT
      RETURN
  130 NEND = -NEND
      IF (NEND.GE.0) NEND = -999
  140 RETURN
  150 WRITE (CHOUT, 160) FILENM, IFI
  160 FORMAT (' Error reading input file ', A6, ', unit number ', I3)
      CALL KERROR (CHOUT, 0, 'BINIFF')
      END
      SUBROUTINE BINOFF (KEY, IFO, FILENM, FITEMS, NIT, BUF, NEND)
      CHARACTER FILENM *(*), FILEN *6
      PARAMETER (MAXBUF = 198)
      DIMENSION BUF(MAXBUF)
      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
      DIMENSION FITEMS (NIT)
      DATA FSTOP / -67.0E06 /
      IF (IFO.LE.0 .OR. IFO.GT.20) CALL KERROR (' IFO?',-4,'BINOFF')
      IF (KEY) 120, 110, 100
  100 NW1 = MIN0(MAXBUF, MAX0(KEY,4))
      IF (NW1.GT.4) GOTO 101
      NW1 = 5
      BUF(5) = 0.
  101 FILEN = FILENM
      CALL BINOX (IFO, FILEN, NIT, NW1, BUF)
      GOTO 140
  110 CALL KERNAB (FITEMS, BUF(NEND+1), NIT)
      NEND = NEND + NIT
      IF (NEND .LE. MAXBUF-NIT) RETURN
      GOTO 130
  120 BUF(NEND+1) = FSTOP
      CALL KERNZA (0.0, BUF(NEND+2), MAXBUF-NEND-1)
  130 CONTINUE
      WRITE (IFO, ERR=150, IOSTAT=IFSTAT(IFO)) BUF
  140 NEND = - IFSTAT(IFO)
      IF (NEND.LT.0) GOTO 150
      RETURN
  150 WRITE (CHOUT, 160) FILENM, IFO
  160 FORMAT (' Error writing output file ', A6, ', unit number ', I3)
      CALL KERROR (CHOUT, 0, 'BINOFF')
      RETURN
      END
      SUBROUTINE ATOMIZ (LM, NLET, IZ)
      CHARACTER * 2 LM, L, LL, LLC, LLLC
      DIMENSION L(100), LLC(100), LLLC(100)
      DATA L    / 'H ', 'HE', 'LI', 'BE', 'B ', 'C ', 'N ', 'O ', 'F ',
     *      'NE', 'NA', 'MG', 'AL', 'SI', 'P ', 'S ', 'CL', 'AR', 'K ',
     *      'CA', 'SC', 'TI', 'V ', 'CR', 'MN', 'FE', 'CO', 'NI', 'CU',
     *      'ZN', 'GA', 'GE', 'AS', 'SE', 'BR', 'KR', 'RB', 'SR', 'Y ',
     *      'ZR', 'NB', 'MO', 'TC', 'RU', 'RH', 'PD', 'AG', 'CD', 'IN',
     *      'SN', 'SB', 'TE', 'I ', 'XE', 'CS', 'BA', 'LA', 'CE', 'PR',
     *      'ND', 'PM', 'SM', 'EU', 'GD', 'TB', 'DY', 'HO', 'ER', 'TM',
     *      'YB', 'LU', 'HF', 'TA', 'W ', 'RE', 'OS', 'IR', 'PT', 'AU',
     *      'HG', 'TL', 'PB', 'BI', 'PO', 'AT', 'RN', 'FR', 'RA', 'AC',
     *      'TH', 'PA', 'U ', 'NP', 'PU', 'AM', 'CM', 'BK', 'CF', 'ES',
     *      'FM' /
      DATA LLC  / 'H ', 'He', 'Li', 'Be', 'B ', 'C ', 'N ', 'O ', 'F ',
     *      'Ne', 'Na', 'Mg', 'Al', 'Si', 'P ', 'S ', 'Cl', 'Ar', 'K ',
     *      'Ca', 'Sc', 'Ti', 'V ', 'Cr', 'Mn', 'Fe', 'Co', 'Ni', 'Cu',
     *      'Zn', 'Ga', 'Ge', 'As', 'Se', 'Br', 'Kr', 'Rb', 'Sr', 'Y ',
     *      'Zr', 'Nb', 'Mo', 'Tc', 'Ru', 'Rh', 'Pd', 'Ag', 'Cd', 'In',
     *      'Sn', 'Sb', 'Te', 'I ', 'Xe', 'Cs', 'Ba', 'La', 'Ce', 'Pr',
     *      'Nd', 'Pm', 'Sm', 'Eu', 'Gd', 'Tb', 'Dy', 'Ho', 'Er', 'Tm',
     *      'Yb', 'Lu', 'Hf', 'Ta', 'W ', 'Re', 'Os', 'Ir', 'Pt', 'Au',
     *      'Hg', 'Tl', 'Pb', 'Bi', 'Po', 'At', 'Rn', 'Fr', 'Ra', 'Ac',
     *      'Th', 'Pa', 'U ', 'Np', 'Pu', 'Am', 'Cm', 'Bk', 'Cf', 'Es',
     *      'Fm' /
      DATA LLLC / 'h ', 'he', 'li', 'be', 'b ', 'c ', 'n ', 'o ', 'f ',
     *      'ne', 'na', 'mg', 'al', 'si', 'p ', 's ', 'cl', 'ar', 'k ',
     *      'ca', 'sc', 'ti', 'v ', 'cr', 'mn', 'fe', 'co', 'ni', 'cu',
     *      'zn', 'ga', 'ge', 'as', 'se', 'br', 'kr', 'rb', 'sr', 'y ',
     *      'zr', 'nb', 'mo', 'tc', 'ru', 'rh', 'pd', 'ag', 'cd', 'in',
     *      'sn', 'sb', 'te', 'i ', 'xe', 'cs', 'ba', 'la', 'ce', 'pr',
     *      'nd', 'pm', 'sm', 'eu', 'gd', 'tb', 'dy', 'ho', 'er', 'tm',
     *      'yb', 'lu', 'hf', 'ta', 'w ', 're', 'os', 'ir', 'pt', 'au',
     *      'hg', 'tl', 'pb', 'bi', 'po', 'at', 'rn', 'fr', 'ra', 'ac',
     *      'th', 'pa', 'u ', 'np', 'pu', 'am', 'cm', 'bk', 'cf', 'es',
     *      'fm' /
      IZ = -1
      CALL KERC2I (LM(2:2), KEND1)
      NLET = 1
      IF (KEND1.GT.10 .AND. KEND1.LT.37) NLET = 2
      LL = LM(1:NLET)
      IF (LL .EQ. 'Q' .OR. LL .EQ. 'q') LL = 'H'
      IF (LL.EQ.'D' .OR. LL.EQ.'T') LL = 'H'
      IF (LL.EQ.'d' .OR. LL.EQ.'t') LL = 'H'
      DO 100 I=1,100
      IF (LL.EQ.L(I) .OR. LL.EQ.LLC(I) .OR. LL.EQ.LLLC(I)) GOTO 110
  100 CONTINUE
      RETURN
  110 IZ = I
      RETURN
      END
      SUBROUTINE ATOMCH (IZ)
      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
      IF (NFDOL(2).GE.0) GOTO 150
      I = NCOLL(2)
      CALL ATOMIZ (CHIN(I:I+1), NLET, IZ)
      IF (IZ .LE. 0) GOTO 150
      I = I + NLET
      IF (CHIN(I:I).NE.' ') GOTO 110
      IF (NFDOL(3).EQ.2) RETURN
      IF (NFDOL(3).LE.0) GOTO 150
      K = NCOLN(1)
      IF (CHIN(K:K).EQ.'+' .OR. CHIN(K:K).EQ.'-') RETURN
      IF (K-I.GT.4) GOTO 150
      IF (NFNUM .EQ. 3) RETURN
      CHOUT(I:NCOLN(2)-1) = CHIN(K:NCOLN(2)-1)
      CHIN(I:NCOLN(2)-1) = CHOUT(I:NCOLN(2)-1)
      CHOUT = ' '
      CALL KERINB (LIT(32),1)
      RETURN
  110 CALL KERC2I (CHIN(I:I), NEN)
      IF (NEN.EQ.37 .OR. NEN.EQ.38) NEN = 0
      IF (NEN.EQ.45 .OR. NEN.EQ.46) NEN = 0
      IF (NEN.LT.0 .OR. NEN.GT.9) GOTO 150
      RETURN
  150 CALL KERROR (' Incorrect atomic symbol', -6, 'ATOMCH')
      END
      SUBROUTINE ATOMIN (IFAT, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      PARAMETER (NSLOT = 10)
      DIMENSION ATXYZ(NSLOT,MAXAT), IZAT(MAXAT)
      CHARACTER * 6 ATNAME(MAXAT)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (IPR1, IFILE(6)), (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
      CHARACTER      CHIN2 *80
   99 FORMAT (/' DIRDIF cannot proceed:'/
     *         ' the input ATOMS or ATMOD file is incorrect:'/
     *         ' maybe a leftover of a preceding error stop? MSG:')
      IF (IFAT.LE.0 .OR. IFAT.GT.20) CALL KERROR (' IFAT?',-4,'ATOMIN')
      READ (IFAT, 105, ERR = 940, END = 940, IOSTAT = IFSTAT(IFAT))
     *      CHIN(1:72)
  105 FORMAT (A72)
      CHIN2 = CHIN
      CALL KERINB (LIT, 1)
      IF (LIT(1) .NE. 'ATMOD' .AND. LIT(1) .NE. 'ATOMS'
     *   .AND. LIT(1) .NE. 'ATLIT' ) GOTO 951
      IF (LIT(1) .EQ. 'ATOMS' .AND. LIT(2) .NE.  CCODE) GOTO 953
      IF (LIT(1) .EQ. 'ATLIT' .AND. LIT(2) .NE.  CCODE) GOTO 953
      LEND = 999
      NAT = 1
  107 CALL ATOMIA (IFAT, ATXYZ, ATNAME, IZAT, MAXAT, NAT, LEND)
      IF (LEND.NE.0) GOTO 200
      NAT = NAT + 1
      IF (NAT .EQ. MAXAT) CALL KERROR ('Too many atoms', -6, 'ATOMIN')
      GOTO 107
  200 NAT = NAT - 1
      IF (NAT .LE. 0) GOTO 955
      IF (LEND .LT. 0) THEN
         CHOUT = ' Warning ATOMS or ATMOD file: END card missing'
         CALL SHOUT
         ENDIF
      CALL ATOMST (0, ATXYZ, NAT, KEYT)
      DO 302 I = 1, NAT
      IF (ATNAME(I) (1:1) .EQ. 'Q') THEN
         ATXYZ(4,I) = 0.0
         ATXYZ(5,I) = 0.0
         ENDIF
  302 CONTINUE
      CHIN = CHIN2
      CALL KERINB (LIT, 1)
      RETURN
  940 WRITE (LIS1, 99)
      WRITE (IPR1, 99)
      CALL KERROR('File error reading ATOMS or ATMOD file', 0,'ATOMIN')
  951 WRITE (LIS1, 99)
      WRITE (IPR1, 99)
      CALL KERROR
     *   ('No file identification on ATOMS or ATMOD file', -6,'ATOMIN')
  953 WRITE (LIS1, 99)
      WRITE (IPR1, 99)
      CALL KERROR ('Incorrect CCODE on ATOMS file', -6,'ATOMIN')
  955 WRITE (LIS1, 99)
      WRITE (IPR1, 99)
      CALL KERROR
     *   ('No atoms found on ATOMS or ATMOD file', -6, 'ATOMIN')
      END
      SUBROUTINE ATOMIA (IFAT, ATXYZ, ATNAME, IZAT, MAXAT, NAT, LEND)
      PARAMETER (NSLOT = 10)
      DIMENSION ATXYZ(NSLOT,MAXAT),   IZAT(MAXAT)
      CHARACTER * 6 ATNAME(MAXAT)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      CHARACTER CHIN2 *80 ,  LITA(4) *6
      DATA LITA /'ATOM', 'BIJ', 'ATESD', 'BIJESD' /
      DATA LEND2 / 0 /
      IF (LEND .EQ. 999) THEN
         CALL KERIFF (IFAT, LITA, 4, LEND)
         IF (LIT(1).NE.'ATOM') CALL KERROR
     *   ('First atom on ATOMS or ATMOD file not: ATOM', -6, 'ATOMIA')
      ELSE
         CHIN = CHIN2
         LEND = LEND2
         CALL KERINB (LIT, 1)
         ENDIF
      IF (LEND.NE.0) RETURN
      CALL ATOMCH (IZAT(NAT))
      ATNAME(NAT) = LIT(2)
      DO 110 I = 1, NSLOT
      IF (I.LE.3 .AND. NCOLN(I).LE.0) CALL KERROR
     *   ('Data on atoms card not correct', -6, 'ATOMIA')
  110 ATXYZ(I,NAT) = FNUM(I)
  117 CALL KERIFF (IFAT, LITA, 4, LEND)
      IF (LEND .NE. 0) GOTO 201
      GOTO (201, 202, 203, 204), NLUSER(1)
      CALL KERROR
     *   ('Record on ATOMS or ATMOD file not recognised', -6, 'ATOMIA')
  201 CHIN2 = CHIN
      LEND2 = LEND
      LEND = 0
      RETURN
  202 CALL KERNAB (FNUM, ATXYZ(5,NAT), 6)
      GOTO 117
  203 CALL KERNAB (FNUM, ATXYZ(1,NAT+1), 5)
      GOTO 117
  204 CALL KERNAB (FNUM, ATXYZ(5,NAT+1), 6)
      GOTO 117
      END
      SUBROUTINE ATOMPR (IPRX, NAPR, ATXYZ, ATNAME, IZAT, NAT)
      DIMENSION ATXYZ(10,NAT), IZAT(NAT), ATNAME(NAT)
      CHARACTER *6 ATNAME
      NATX = (NAPR * 5 + 1) / 2
      IF (NATX .GT. NAT) NATX = NAT
      IF (NATX .LT. NAT) NATX = NAPR
      IF (NATX .LE. 0) NATX = MIN0 (3, NAT)
      WRITE (IPRX, FMT='('' Number of atoms stored:'', I4)') NAT
      KEYT = 1
      DO 102 I=1,NATX
      IF (ATXYZ(4,I) .LT. 0.999 .OR. ATXYZ(5,I) .GT. 0.0001) KEYT = 2
      IF (ATXYZ(6,I) .GT. 0.000001) GOTO 103
  102 CONTINUE
      IF (KEYT .EQ. 1) WRITE (IPRX, FMT='
     *   ('' Atom name    x        y        z'', 8X,''Z'')')
      IF (KEYT .EQ. 2) WRITE (IPRX, FMT=' ('' Atom name    x'',
     *    ''        y        z'', 8X,''Z   occ.f.      B'')')
      GOTO 104
  103 WRITE (IPRX, FMT=' ('' Atom name    x'',
     *    ''        y        z'', 8X,''Z   occ.f.      B.equiv.'')')
  104 DO 109 I=1,NATX
      IF (ATXYZ(4,I) .LT. 0.999 .OR. ATXYZ(5,I) .GT. 0.0001) THEN
         WRITE (IPRX, 106)  ATNAME(I), (ATXYZ(J,I),J=1,3), IZAT(I),
     *      (ATXYZ(J,I),J=4,5)
  106    FORMAT (3X, A6, 2X, 3F9.5, I4, 2F9.4)
      ELSE
         WRITE (IPRX, 106)  ATNAME(I), (ATXYZ(J,I),J=1,3), IZAT(I)
         ENDIF
  109 CONTINUE
      IF (NAT .GT. NATX) WRITE (IPRX, FMT='('' Printing of remaining'',
     *                                    '' atoms supressed.'')')
      RETURN
      END
      SUBROUTINE ATOMWR (IATOMS, ATXYZ, ATNAME, NAT)
      DIMENSION ATXYZ(10,NAT), ATNAME(NAT)
      CHARACTER *6 ATNAME
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS2, IFILE(8))
      CHARACTER FATOMX * 6
      FATOMX = 'ATOMS'
      IF (SWITCH(25)) FATOMX = 'ATMOD'
      CALL ATOMWA (IATOMS)
      DO 109 NATR = 1, NAT
  109 CALL ATOMWB (IATOMS, ATXYZ, ATNAME, NATR)
      WRITE (LIS2, 120) FATOMX, NAT
  120 FORMAT (' Number of atoms written to ', A6, 'file:', I4)
      WRITE (IATOMS, FMT = '(''END'')')
      RETURN
      END
      SUBROUTINE ATOMWA (IATOMS)
      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
      IT = MAX0 (0, 10000 * (ITIME(1)-1900) + 100 * ITIME(2) + ITIME(3))
      IF (SWITCH(25)) THEN
         WRITE (IATOMS, 101) PROGNM, IT, KEYS(13)
  101    FORMAT ('ATMOD  CART   generated by program ',
     *            A8, ' date', I7, ' RUN', I4)
      ELSEIF (FNUM(32) .LT. 0.0001) THEN
         WRITE (IATOMS, 102) CCODE, PROGNM, IT, KEYS(13)
  102    FORMAT ('ATOMS  ', A6, ' generated by program ',
     *            A8, ' date', I7, ' RUN', I4)
      ELSE
         WRITE (IATOMS, 103) CCODE, PROGNM, IT, KEYS(13), FNUM(32)
  103    FORMAT ('ATOMS  ', A6, ' gener. progr. ',
     *            A8, ' date', I7, ' RUN', I4, ' SC=', F12.7)
         FNUM(32) = 0.0
         ENDIF
      IF (CHOUT .NE. ' ') THEN
         WRITE (IATOMS, FMT = '(''REMARK '', A65)') CHOUT(1:65)
         CHOUT = ' '
         ENDIF
      RETURN
      END
      SUBROUTINE ATOMWB (IATOMS, ATXYZ, ATNAME, NATR)
      DIMENSION ATXYZ(10,NATR), ATNAME(NATR)
      CHARACTER *6 ATNAME
      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
      DIMENSION BEQ(1)
      BEQ(1) = ATXYZ(5,NATR)
      IF (ATXYZ(5,NATR) .GT. 0.00001 .AND. ATXYZ(6,NATR) .GT. 0.00001)
     *   CALL ATBEQ (ATXYZ(1,NATR), BEQ, 1)
      IF ((ATXYZ(4,NATR) .GT. 0.00001 .AND. ABS(ATXYZ(4,NATR)-1.)
     *   .GT. 0.00001) .OR. ATXYZ(5,NATR) .GT. 0.00001) THEN
         WRITE (IATOMS, 104) ATNAME(NATR), (ATXYZ(J,NATR), J=1,4), BEQ
  104    FORMAT ('ATOM  ', A6, 2X, 3F9.5, 2F8.4)
      ELSE
         WRITE (IATOMS, 104) ATNAME(NATR), (ATXYZ(J,NATR), J=1,3)
         ENDIF
      IF (ATXYZ(5,NATR) .GT. 0.00001 .AND. ATXYZ(6,NATR) .GT. 0.00001)
     *   WRITE (IATOMS, 108)  ATNAME(NATR), (ATXYZ(J,NATR), J = 5,10)
  108 FORMAT ('BIJ   ', A6, 2X, 6F9.5)
      RETURN
      END
      SUBROUTINE ATOMST (KEY, ATXYZ, NAT, KEYT)
      PARAMETER (NSLOT = 10)
      DIMENSION ATXYZ(NSLOT,NAT)
      PARAMETER (U2B = 8. * 3.141593 **2)
      FAC = U2B
      IF (KEY .EQ. 1) FAC = 1. / U2B
      KEYT = 1
      DO 200 I=1,NAT
      IF (ABS(ATXYZ(4,I)).LT.0.000001) ATXYZ(4,I) = 1.0
      IF (ATXYZ(5,I).LT.0.000001) THEN
         ATXYZ(5,I) = 0.0
         ATXYZ(6,I) = -0.000001
         GOTO 150
         ENDIF
      IF (ATXYZ(6,I).GT.0.000001) THEN
         KEYT = 3
      ELSE
         ATXYZ(6,I) = -0.000001
         ENDIF
      IF (KEYT.EQ.1) KEYT = 2
  150 IF (KEY .EQ. 0) GOTO 200
      IF (ABS(ATXYZ(5,I)) .LT. 0.000001) GOTO 200
      ATXYZ(5,I) = ATXYZ(5,I) * FAC
      IF (ATXYZ(6,I) .LE. 0.) GOTO 200
      DO 180 J=6, NSLOT
  180 ATXYZ(J,I) = ATXYZ(J,I) * FAC
  200 CONTINUE
      RETURN
      END
      SUBROUTINE ATOMOC (KEY, ATXYZ, MSELF, NAT)
      PARAMETER (NSLOT = 10)
      DIMENSION ATXYZ(NSLOT,NAT), MSELF(NAT)
      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  XYZ(3)
      DO 150 I=1,NAT
      N = 0
      DO 140 IL=1,NLATT
      DO 140 J=1,NSYMM
      DO 120 K=1,3
  120 XYZ(K) = TSYMM(K,J) + TLATT(K,IL)
     *       + ATXYZ(1,I) * IRSYMM(K,1,J)
     *       + ATXYZ(2,I) * IRSYMM(K,2,J)
     *       + ATXYZ(3,I) * IRSYMM(K,3,J)
      N = N + ISELFD (ATXYZ(1,I), XYZ, 0.04)
      IF (ICENT.EQ.1)  GOTO 140
      DO 130 IC=1,3
  130 XYZ(IC) = -XYZ(IC)
      N = N + ISELFD (ATXYZ(1,I), XYZ, 0.04)
  140 CONTINUE
      IF (KEY .EQ. 0) MSELF(I) = N
      IF (KEY .EQ. 1) ATXYZ(4,I) = ATXYZ(4,I) / FLOAT(N)
      IF (KEY .LE. 1) GOTO 150
      ATXYZ(4,I) = ATXYZ(4,I) * FLOAT(N)
      IF (ABS (ATXYZ(4,I) - 1.0) .LT. 0.0001) ATXYZ(4,I) = 1.0
  150 CONTINUE
      RETURN
      END
      SUBROUTINE ATBEQ (ATXYZ, BEQ, NAT)
      PARAMETER (NSLOT = 10)
      DIMENSION ATXYZ(NSLOT,NAT), BEQ(NAT)
      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 SI(3), CO(3), SISI(6)
      LOGICAL CONT
      DATA CONT /.FALSE./
      DATA R4 / 0.0 /
      IF (NAT .GT. 1) CONT = .FALSE.
      IF (CONT) GOTO 133
      CONT = .TRUE.
      RAD = 57.295789
      DO 100  I=4,6
      SI(I-3) = SIN(CELL(I)/RAD)
      CO(I-3) = COS(CELL(I)/RAD)
      IF (ABS(CELL(I)-90.).LT.0.0001)  CO(I-3)=0.0
  100 CONTINUE
      R4 = 1.0
      DO 110  I=1,3
  110 R4 = R4 - CO(I)**2
      R4 = (R4 + (2. * CO(1) * CO(2) * CO(3))) * 3.
      DO 130  I=1,3
      SISI(I) = SI(I)**2
      DO 130  J=1,3
      IF (J - I)   130, 130, 120
  120 SISI(9-I-J) = SI(I) * SI(J) * 2.0 * CO(6-I-J)
  130 CONTINUE
  133 DO 150  M=1,NAT
      B = 0.0
      DO 140  I=1,6
  140 B = B + SISI (I) * ATXYZ(I+4,M)
  150 BEQ(M) = B / R4
      RETURN
      END
      SUBROUTINE ATBETA (ATXYZ, NAT)
      PARAMETER (NSLOT = 10)
      DIMENSION ATXYZ(NSLOT,NAT)
      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 RLP(3), RLP2(6)
      DATA IFIRST /0/
      IFIRST = IFIRST + 1
      DO 200 K=1,3
      RLP(K)  = SQRT(SSMAT(K,K))
  200 RLP2(K) = SSMAT(K,K)
      RLP2(4) = RLP(2) * RLP(3) * 2.
      RLP2(5) = RLP(1) * RLP(3) * 2.
      RLP2(6) = RLP(1) * RLP(2) * 2.
      DO 220 I=1,NAT
      IF (ATXYZ(6,I).LE.0.0) GOTO 220
      DO 210 J=5,10
  210 ATXYZ(J,I) = ATXYZ(J,I) * RLP2(J-4)
  220 CONTINUE
      RETURN
      END
      SUBROUTINE CELZIN (ATXYZ, IZAT, NAT, NCELLZ, NCELIN)
      DIMENSION ATXYZ(10,NAT),  IZAT(NAT), NCELLZ(10), NCELIN(10)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (LIS2,   IFILE(8))
      COMMON /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 IOCC(1)
      CALL KERNZI (0, NCELIN, 10)
      DO 590 I = 1, NAT
      CALL ATOMOC (0, ATXYZ(1,I), IOCC(1), 1)
      NN = NINT (ATXYZ(4,I) * FLOAT (IMULT/IOCC(1)))
      DO 585 N = 1, NTYPE
      IF (NCELLZ(N) .NE. IZAT(I)) GOTO 585
      NCELIN(N) = NCELIN(N) + NN
      GOTO 590
  585 CONTINUE
      IF (IZAT(I) .LE. 1) GOTO 590
      CALL KERROR
     *   (' Input atom type not defined by CRYSDA', 585, 'CELZIN')
  590 CONTINUE
      WRITE (LIS2, 614) (NCELIN(I), I=1,NTYPE)
  614 FORMAT (' Number of atoms input: ', 10I5)
      RETURN
      END
      SUBROUTINE RDCOND (IRDX, L, LMAX, KEND)
      CHARACTER * 6  L(LMAX)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      LOGICAL FIRST
      EQUIVALENCE (SWITCH(9), FIRST)
      PARAMETER (NCHMAX=517)
      COMMON / / DUMMY(1), CHONDA(NCHMAX)
      CHARACTER * 80 CHONDA
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      CHARACTER * 6  PROLD
      LOGICAL CONDA
      DATA    CONDA, PROLD / .TRUE., ' ' /
      DATA NCH, NCHA, KDAT  / 0, 0, 0 /
      KEND = -2
      IF (.NOT. CONDA)  RETURN
      IF (PROLD .NE. ' ') GOTO 300
      CALL FILINQ (IRDX, 'CONDA', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) THEN
         WRITE (LIS2, 190) CCODE
  190    FORMAT (' Control data file: ', A6,' CONDA not present')
         CONDA = .FALSE.
         RETURN
         ENDIF
      CALL KERINA (IRDX, LIT, 1, LEND)
      IF (LEND.NE.0 .OR. LIT(1).NE.'CONDA' .OR. LIT(2).EQ.' ')
     * CALL KERROR ('ERROR on first record of CONDA file', 0, 'RDCOND')
      IF (CCODE .EQ. ' ') CCODE = LIT(2)
      WRITE (LIS2, 230)
  230 FORMAT (' Input control data file  CONDA')
      IF (CCODE .NE. LIT(2)) THEN
         WRITE (CHOUT, 250) CCODE, LIT(2)
  250    FORMAT ('ERROR: CCODE = ', A6,' but on CONDA file it is ', A6)
         CALL KERROR (CHOUT, 0, 'RDCOND')
         ENDIF
      NCH = 1
      NCHA = 1
      CHONDA(NCH) = CHIN
      CALL KERINA (IRDX, LIT, 1, LEND)
      IF (LEND.LT.0 .OR. LEND.GE.5) THEN
         WRITE (CHOUT, FMT='('' Empty CONDA file ...... '')')
         CALL SHOUT
         CONDA = .FALSE.
         CALL FILCLO (IRDX, 'DELETE')
         RETURN
         ENDIF
      PROLD = '$DUMMY'
      IF (LIT(1) .EQ. 'TITLE') THEN
         IF (TITLE(1:64) .NE. CHIN(7:70)) THEN
            TITLE = CHIN(7:80)
            WRITE (LIS1, FMT='('' RUN TITLE: '', A64)') TITLE
            WRITE (LIS2, FMT='('' RUN TITLE: '', A64)') TITLE
            ENDIF
         NCH = 2
         NCHA = 2
         CHONDA(NCH) = CHIN
      ELSE
         BACKSPACE IRDX
         ENDIF
  290 CALL KERINA (IRDX, L, LMAX, LEND)
      IF (LEND .LT. 0 .OR. LEND .GE. 5) THEN
         WRITE (LIS2, 295) L(1)
  295    FORMAT (' Requested record: PROGRAM ', A6 /
     *            ' not found in CONDA file ' )
         PROLD = ' '
         KEND = -1
         CALL FILCLO (IRDX, 'KEEP')
         RETURN
         ENDIF
      IF   (LIT(1).NE.'PROGRA' .OR. LIT(2).NE.L(1)) GOTO 290
      KDAT = 0
      KEND = 1
      RETURN
  300 KEND = 0
      CALL KERIFF (IRDX, L, LMAX, KSTOP)
      IF (KSTOP .LT. 0) GOTO 807
      IF (KSTOP .GE. 5) GOTO 803
      IF (KSTOP .NE. 0) GOTO 801
      IF (LIT(1).EQ.'PROGRA') GOTO 803
      IF (KDAT .EQ. 0) THEN
         WRITE (LIS2, 320) CCODE
  320 FORMAT (' Input from control data file CONDA for compound ', A6)
         KDAT = 1
         ENDIF
      WRITE (LIS2, 322) CHIN(1:72)
  322 FORMAT (' Input: ' , A72)
      IF (NLUSER(1).LE.0) CALL KERROR (' Unidentified control card',
     *    0, 'RDCOND')
      KEND = NLUSER(1)
      RETURN
  801 CALL KERINA (IRDX, LIT(32), 1, LEND)
      IF (LEND .EQ. -1) GOTO 807
  803 NCH = NCH + 1
      IF (LIT(1) .EQ. 'STOP' .OR. LIT(1) .EQ. 'FINISH') NCHA = NCHA+1
      IF (NCH .GE. NCHMAX) CALL KERROR ('CONDA too big', 801, 'RDCOND')
      CHONDA(NCH) = CHIN
      IF (LIT(1) .NE. 'STOP' .AND. LIT(1) .NE. 'FINISH') GOTO 801
  807 REWIND IRDX
      DO 808 I = 1, NCH
  808 WRITE (IRDX, FMT = '(A80)') CHONDA(I)
      REWIND IRDX
      IF (NCHA .GE. NCH) THEN
         CALL FILCLO (IRDX, 'DELETE')
         CONDA = .FALSE.
         ENDIF
      PROLD =' '
      RETURN
      END
      SUBROUTINE RDDCON
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IRDX, IFILE(1))
      PARAMETER ( LMAX = 3 )
      CHARACTER * 6  L(LMAX)
      DATA L / 'DDOKA' , 'MSDOS', ' ' /
      CALL FILINQ (IRDX, 'DDCON', 'FORMATTED', 'INPUT', KINQ)
      IF ( KINQ .NE. 0 ) THEN
         RETURN
         ENDIF
      CALL KERINA (IRDX, LIT, 1, LEND)
      IF (LEND.NE.0 .OR. LIT(1).NE.'DDCON') THEN
         GOTO 999
         ENDIF
  300 CALL KERIFF (IRDX, L, LMAX, LEND)
      IF (LEND .LT. 0 .OR. LEND .GE. 4) GOTO 999
      KEND = NLUSER(1)
      IF ( KEND .LE. 0 ) GOTO 300
      GOTO ( 1, 2, 3 ), KEND
  1   CONTINUE
      IF (LIT(2) .NE. '=YES') THEN
         GOTO 300
         ENDIF
      KEYS(10) = -17
      KEYS(9) = -17
      KEYS(8) = -17
      GOTO 300
  2   CONTINUE
      GOTO 300
  3   CONTINUE
      GOTO 300
  999 CALL FILCLO (IRDX, 'KEEP')
      RETURN
      END
      SUBROUTINE LOGWR (IDDL)
      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)), (LIS1, IFILE(7))
      EQUIVALENCE (LIS2, IFILE(8))
      EQUIVALENCE (IRUN, KEYS(13))
      LOGICAL BATCH, FULAUT
      EQUIVALENCE (BATCH, SWITCH(8)), (FULAUT, SWITCH(12))
      CHARACTER*56 CHOUT2
      DATA IFIRST / 0 /
      IFIRST = IFIRST + 1
      CHOUT2 = CHOUT
      IT = 0
      IF (ITIME(1) .GT. 0)
     *    IT = 10000 * (ITIME(1)-1900) + 100 * ITIME(2) + ITIME(3)
      CALL FILINQ (IDDL, 'DDLOG', 'FORMATTED', 'OUTPUT', KINQ)
      IF (KINQ.EQ.0) GOTO 220
      WRITE (IDDL, 200) CCODE, IT
  200 FORMAT ('DDLOG ', A6,' GENERATION DATE ', I7,' DO NOT DESTROY')
      WRITE (LIS1, 201) IT
      WRITE (LIS2, 201) IT
  201 FORMAT (' DDLOG file: GENERATION DATE ', I7,' DO NOT DESTROY')
      IF (BATCH .OR. FULAUT) GOTO 215
  210 WRITE (IPR1, FMT='('' Welcome to DIRDIF Wonderland'' /
     * '' Please give TITLE (will be stored in DDLOG file):'')')
      CALL KETERM (-1, -1, KEND)
      IF (KEND.LT.0) GOTO 210
      TITLE = CHIN
  215 CHOUT = ' Welcome to DIRDIF Wonderland'
      CALL SHOUT2
      IF (TITLE .NE. ' ') THEN
         WRITE (IDDL, FMT='(''TITLE '', A64)') TITLE
         WRITE (LIS1, FMT='('' LOG TITLE: '', A64)') TITLE
         WRITE (LIS2, FMT='('' LOG TITLE: '', A64)') TITLE
         ENDIF
      CHOUT = 'RUN   1'
      WRITE (IDDL, 217) PROGNM, IT, CHOUT(1:56)
  217 FORMAT (A8, I7, 1X, A56)
      WRITE (LIS1, FMT='(A)')
     * ' Note: DDLOG is used for communication between various programs'
      CHOUT = ' '
      IRUN = 1
      IF (CHOUT2 .EQ. ' ') RETURN
      GOTO 250
  220 READ (IDDL, FMT='(A3)', END=230) CHIN(1:3)
      IF (CHIN(1:3).NE.'END') GOTO 220
      GOTO 245
  230 WRITE (LIS1, 240)
  240 FORMAT (' Warning: no END record found on the DDLOG file')
  245 BACKSPACE IDDL
  250 WRITE (IDDL, 260) PROGNM, IT, CHOUT2
  260 FORMAT (A8, I7, 1X, A56 / 'END' / 'END')
      IF (IFIRST .EQ. 1) WRITE (LIS2, FMT='(1X)')
      WRITE (LIS2, 262) PROGNM, IT, CHOUT2
  262 FORMAT (' Control data for DDLOG:'
     *    / 1X, A8, I7, 1X, A56)
      CHOUT = ' '
      RETURN
      END
      SUBROUTINE LOGRD (IDDL, LITX, KLOG)
      CHARACTER LITX *(*)
      CHARACTER LITS(1) *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 (IRD,  IFILE(5))
      EQUIVALENCE (IPR1, IFILE(6))
      EQUIVALENCE (LIS1, IFILE(7))
      CHARACTER CHINX *72
      CALL FILINQ (IDDL, 'DDLOG', 'FORMATTED', 'INPUT', KLOG)
      IF (KLOG.EQ.-1) RETURN
      ICOUNT = 0
      IREGEL = 0
      LITS(1) = LITX
  200 CALL KERINA (IDDL, LITS, 1, LEND)
      ICOUNT = ICOUNT + 1
      IF (LEND .EQ. -1) WRITE (LIS1,
     *    FMT='('' Warning: no END marker on the DDLOG file'')' )
      IF (LEND .NE. 0) GOTO 230
      DO 210 I=1,NLIT
      IF (NLUSER(I).EQ.1) GOTO 220
  210 CONTINUE
      GOTO 200
  220 KLOG = I
      IREGEL = ICOUNT
      CHINX = CHIN
      GOTO 200
  230 IF (KLOG .EQ. 0) RETURN
      CHIN = CHINX
      CALL KERINB (LITS, 1)
      REWIND (IDDL)
      DO 300 I=1,IREGEL
  300 READ (IDDL,FMT='(A1)')
      RETURN
      END
      SUBROUTINE COPY80 (IIN, FIN, IOUT, FOUT)
      CHARACTER FIN *(*), FOUT *(*), FINX *7, FOUTX *7
      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 (KEYS(13), IRUN)
      EQUIVALENCE (LIS1, IFILE(7))
      CHARACTER LAST *6
      FINX  = FIN
      FOUTX = FOUT
      LAST = ' '
      IF (IIN.LE.0 .OR. IIN.GT.20 .OR. FIN.EQ.' ') CALL KERROR
     *   ('No input unit number or no file name given', 0, 'COPY80')
      IF (IOUT.LE.0 .OR. IOUT.GT.20 .OR. FOUT.EQ.' ') CALL KERROR
     *   ('No output unit number or no file name given', 0, 'COPY80')
      CALL FILINQ (IIN, FINX, 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) RETURN
      CALL FILINQ (IOUT, FOUTX, 'FORMATTED', 'OUTPUT', KINQ)
      IF (KINQ .EQ. -1) THEN
         IF (FOUT .EQ. 'ATOLD')
     *      WRITE (IOUT, 142) CCODE, (ITIME(I), I=1,3), IRUN, CCODE
  142       FORMAT ('ATOLD ', A6, ' file (= ATOMS OLD) created: DAY',
     *        I5, 2I3, ' RUN', I4 /
     *        '    Note: for proper reuse of old atomic parameters:'/
     *        '    select wanted header record (ATOMS ', A6, '), and'/
     *        '    copy it with following records up to (incl.) END'/
     *        '    to the ATOMS file'/)
         IF (FOUT .NE. 'ATOLD')
     *      WRITE (IOUT, 144) FOUT, CCODE, (ITIME(I),I=1,3), IRUN, CCODE
  144       FORMAT ('REMARK : ', A6, 1X, A6, ' file created:  DAY',
     *         I5, 2I3, ' RUN', I4 )
         GOTO 200
         ENDIF
      NR = 0
  150 READ (IOUT, 202, END=180, ERR=250) CHIN
      NR = NR + 1
      IF (CHIN(1:6) .NE. 'FINISH') THEN
         LAST = CHIN(1:6)
         GOTO 150
         ENDIF
      BACKSPACE IOUT
      GOTO 190
  180 REWIND IOUT
      DO 182 I = 1, NR
  182 READ (IOUT, 202)
  190 IF (LAST .NE. 'END   ') WRITE (IOUT, FMT='(''END'')')
      WRITE (IOUT, 192) PROGNM, (ITIME(I), I=1,3), IRUN
  192 FORMAT (/ 'Next file appended by program ', A8,
     *       '   DAY', I5, 2I3, ' RUN', I4 /)
  200 N = 0
      READ (IIN, 202, END=210, ERR=270) CHIN
  202 FORMAT (A80)
      N = N + 1
      WRITE (IOUT, 202) CHIN
      IF (CHIN(1:6) .NE. 'FINISH') GOTO 200
  210 IF (CHIN(1:6) .NE. 'FINISH') WRITE (IOUT, FMT='(''FINISH'')')
      REWIND IIN
      REWIND IOUT
      CALL FILCLO (IOUT, 'KEEP')
      RETURN
  250 WRITE (CHOUT, 280) FOUTX, IOUT
      GOTO 282
  270 WRITE (CHOUT, 280) FINX, IIN
  280 FORMAT (' Error reading file ', A7, ', unit number ', I3)
  282 CALL KERROR (CHOUT, 0, 'COPY80')
      RETURN
      END
      SUBROUTINE VALDIS (KEY, V1, V2, KARR, KM, KEND)
      DIMENSION KARR(KM)
      DATA VINC, VBOT, VTOP, VSUB, VMIN / 0.0, 0.0, 0.0, 0.0, 0.0 /
      IF (KEY) 100, 110, 140
  100 KEND = 0
      CALL KERNZI (0, KARR, KM)
      VMIN = V1
      VMAX = V2
      VINC = (V2 - V1) / (KM - 2)
      VSUB = VMIN - VINC - VINC
      GOTO 130
  110 KEND = KEND + 1
      IF (KEND.GT.1) GOTO 120
      VBOT = V1
      VTOP = V1
  120 IF (V1.GT.VTOP) VTOP = V1
      IF (V1.LT.VBOT) VBOT = V1
      KAD = IFIX( (V1 - VSUB) / VINC )
      IF (KAD.LE.0)  KAD = 1
      IF (KAD.GT.KM) KAD = KM
      KARR(KAD) = KARR(KAD) + 1
  130 RETURN
  140 IF (VINC.GT.0.) GOTO 150
      VSUB = VBOT
      VBOT = VTOP
      VTOP = VSUB
  150 KE = KEND - KEY
      V1 = VBOT
      IF (KE.LE.0) GOTO 130
      KSOM = 0
      DO 160 KAD=1,KM
      KSOM = KSOM + KARR(KAD)
      IF (KSOM.GE.KE) GOTO 170
  160 CONTINUE
  170 A2 = VMIN + KAD*VINC - VINC
      A1 = A2 - VINC
      IF (KAD.EQ.1)  A1 = VBOT
      IF (KAD.EQ.KM) A2 = VTOP
      V1 = A1 + ((A2-A1) * (KE-KSOM+KARR(KAD))) / KARR(KAD)
      GOTO 130
      END
      SUBROUTINE LINPRI (KEY, FITEMS, NIT)
      DIMENSION FITEMS(NIT)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      CHARACTER PRFORM *72
      PARAMETER (MAXBUF = 100)
      DIMENSION BUF(MAXBUF)
      DATA NUMNIT, NITMAX, IPR  / 0, 0, 0 /
      IF (NIT.GT.MAXBUF .OR. NIT.LE.0) CALL KERROR
     *    (' Incorrect number of itmes send to LINPRI', 0, 'LINPRI')
      IF (KEY) 240, 220, 200
  200 IPR = KEY
      PRFORM = CHOUT
      CHOUT = ' '
      NITMAX = NIT
  210 CALL KERNZA (0., BUF, NITMAX)
      NUMNIT = 0
      RETURN
  220 IF (NUMNIT+NIT.GT.NITMAX) THEN
          WRITE (IPR, FMT=PRFORM) (BUF(IBUF),IBUF=1,NUMNIT)
          CALL KERNZA (0., BUF, NITMAX)
          NUMNIT = 0
      ENDIF
      DO 230 I=1,NIT
  230 BUF(NUMNIT+I) = FITEMS(I)
      NUMNIT = NUMNIT + NIT
      RETURN
  240 IF (NUMNIT.GT.0) WRITE (IPR, FMT=PRFORM) (BUF(IBUF),IBUF=1,NUMNIT)
      GOTO 210
      END
      SUBROUTINE XHELP (IHELP, IPRX, XLAB)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      EQUIVALENCE (LIS2, IFILE(8))
      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
      DATA IN, NLAB /0, 1000000/
      IF (IHELP .LE. 0) THEN
         IF (IN .GT. 0) CALL FILCLO (IN, 'KEEP')
         IN = -1
         RETURN
         ENDIF
      XLAB5 = XLAB - 0.0005
  110 CONTINUE
      IF (IN .NE. IHELP) THEN
         IN = IHELP
         NLAB = 1000000
         CALL FILCLO (IHELP, 'KEEP')
         CALL FILINQ (IHELP, 'DDHELP', 'FORMATTED', 'INPUT', KINQ)
         IF (KINQ .EQ. 0) GO TO 110
         CHOUT = ' File DIRDIF.DDHELP not found'
         CALL SHOUT
         CALL KERROR (' DDHELP missing ', 0, 'XHELP')
         ENDIF
      LAB  = NINT (1000. * XLAB)
      IF (LAB .LE. 0 .OR. LAB .GE. 1000000) THEN
         CHOUT = ' Help call range error'
         CALL SHOUT
         CALL KERROR (' DDHELP file error ', 0, 'XHELP')
         ENDIF
      IF (LAB .GT. NLAB) GOTO 220
      REWIND IN
  200 READ (IHELP, 210, END=980, ERR=990) CHIN(1:72)
  210 FORMAT (A72)
      IF (CHIN(1:7) .NE.'$XPRINT') GOTO 200
  220 READ (IHELP, 210, END=980, ERR=990) CHIN(1:72)
      IF (CHIN(1:1) .NE. '+') GOTO 220
      IF (CHIN(1:2) .EQ. '++') GOTO 220
      CALL KERINB (LIT, 1)
      IF (XLAB5 .GT. FNUM(1)) GOTO 220
      NLAB = NINT (1000. * FNUM(1))
      IF (NLAB  .NE. LAB) GOTO 980
      I = NCOLL(1) - 1
      IF (I .LE. 0) I =72
      CHIN (1:I) = ' '
      IF (I .LT. 72) I = I + 1
      CHOUT = CHIN(I:72)
      CHIN = CHOUT
      CHOUT = ' '
  310 WRITE (IPRX, 312) CHIN (1:72)
  312 FORMAT (1X, A72)
      READ (IHELP, 210, END=980, ERR=990) CHIN(1:72)
      IF (CHIN(1:1) .NE. '+') GO TO 310
      BACKSPACE IHELP
      RETURN
  980 WRITE (CHOUT, FMT='('' Requested label'',
     *   '' not found on DDHELP file'')')
      CALL SHOUT
      WRITE (LIS2, FMT='('' Exit key '', F8.3)') XLAB
  990 CALL KERROR ('Error reading DDHELP file', 990, 'XHELP')
      END
      FUNCTION ISELFD (X, Y, DMAX)
      DIMENSION X(3), Y(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 DM(3), D(3)
      DATA DMOLD /-999.0/
      DATA DMAXSQ / 0.0 /
      IF (ABS (DMOLD - DMAX) .GT. 0.0001) THEN
         DO 100 I=1, 3
  100    DM(I) = DMAX * RCELL(I)
         DMOLD = DMAX
         DMAXSQ = DMAX * DMAX
         ENDIF
      ISELFD=0
      DO 120 I=1, 3
      D(I) = X(I) - Y(I) - ANINT (X(I)-Y(I))
      IF (ABS (D(I)) .GT. DM(I)) RETURN
  120 CONTINUE
      CALL VMATV1 (D, RRMAT, D, DIST2)
      IF (DIST2 .LE. DMAXSQ) ISELFD = 1
      RETURN
      END
      SUBROUTINE DISTSQ (X, Y, DMAX, Z, DIST2)
      DIMENSION X(3), Y(3), Z(3)
      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 DM(3)
      DATA DMOLD /-9999.9/
      IF (ABS (DMOLD - DMAX) .GT. 0.0001) THEN
         DO 100 I=1, 3
  100    DM(I) = DMAX * RCELL(I)
         DMAXSQ = DMAX * DMAX
         DMOLD=DMAX
         ENDIF
      DIST2 = 9999.9
      DO 120 I=1, 3
      Z(I) = Y(I) - X(I) - ANINT (Y(I)-X(I))
      IF (ABS (Z(I)) .GT. DM(I)) RETURN
  120 CONTINUE
      CALL VMATV1 (Z, RRMAT, Z, DIST2)
      RETURN
      END
      SUBROUTINE SYMOP1 (IS, X, XS)
      DIMENSION X(3), XS(3)
      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 RSYMM(3,3,24)
      LOGICAL CONT
      DATA CONT / .FALSE. /
      IF (CONT) GOTO 200
      CONT = .TRUE.
      CALL KERI2F (IRSYMM, RSYMM, 9 * NSYMM)
  200 IF (IS .EQ. 1) THEN
         CALL KERNAB (X, XS, 3)
      ELSE
         CALL MATXV3 (RSYMM(1,1,IS), X, XS)
         XS(1) = XS(1) + TSYMM(1,IS)
         XS(2) = XS(2) + TSYMM(2,IS)
         XS(3) = XS(3) + TSYMM(3,IS)
         ENDIF
      END
      SUBROUTINE SYMOP2 (IC, IL, XS, XST)
      DIMENSION XS(3), XST(3)
      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)
      IF (IC .EQ. 1) THEN
         XST(1) = TLATT(1,IL) + XS(1)
         XST(2) = TLATT(2,IL) + XS(2)
         XST(3) = TLATT(3,IL) + XS(3)
      ELSE
         XST(1) = TLATT(1,IL) - XS(1)
         XST(2) = TLATT(2,IL) - XS(2)
         XST(3) = TLATT(3,IL) - XS(3)
         ENDIF
      END
      FUNCTION ISELFX (X, Y, DMAX)
      DIMENSION X(3), Y(3)
      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 DM(3), D(3)
      DATA DMOLD /-999.0/
      DATA DMAXSQ / 0.0 /
      IF (ABS (DMOLD - DMAX) .GT. 0.0001) THEN
         DO 100 I=1, 3
  100    DM(I) = DMAX * RCELL(I)
         DMOLD = DMAX
         DMAXSQ = DMAX * DMAX
         ENDIF
      ISELFX=0
      DO 120 I=1, 3
      D(I) = X(I) - Y(I) - ANINT (X(I)-Y(I))
      IF (ABS (D(I)).GT.DM(I)) RETURN
  120 CONTINUE
      CALL VMATV1 (D, RRMAT, D, DISTSQ)
      IF (DISTSQ .LE. DMAXSQ) THEN
         DO 130 I = 1,3
  130    Y(I) = Y(I) + ANINT( X(I)-Y(I) )
         ISELFX = 1
         ENDIF
      RETURN
      END
      SUBROUTINE LOCKIN (ATIN, DMAX, ATOUT, DIST, NPOS)
      DIMENSION ATIN(3), ATOUT(3), D(3)
      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  XYZ(3), XYZC(3), TPOS(3,48)
      LOGICAL CENTRO, AGAIN
      DATA CENTRO / .FALSE. /
      DATA DELTA  / 0.0001  /
      AGAIN = .FALSE.
      IF ( ICENT .EQ. 2 ) CENTRO = .TRUE.
      CALL KERNZA ( 0.0, ATOUT, 3 )
      CALL KERNAB (ATIN, TPOS, 3)
      NPOS = 1
      NADD = 0
  120 DO 200 I = 1,NPOS
      DO 190 JT = 1,NLATT
      DO 190 J  = 1,NSYMM
      IF ( CENTRO ) AGAIN = .TRUE.
      DO 130 K = 1,3
      XYZ(K) = TSYMM(K,J) + TLATT(K,JT) +
     *   TPOS(1,I) * IRSYMM(K,1,J) +
     *   TPOS(2,I) * IRSYMM(K,2,J) +
     *   TPOS(3,I) * IRSYMM(K,3,J)
  130 XYZC(K) = -XYZ(K)
  140 IF ( ISELFX (ATIN, XYZ, DMAX) .EQ. 1 ) THEN
         DO 150 L = 1,NPOS+NADD
         IF ( ( ABS(XYZ(1)-TPOS(1,L)) .LT. DELTA ) .AND.
     *      ( ABS(XYZ(2)-TPOS(2,L)) .LT. DELTA ) .AND.
     *      ( ABS(XYZ(3)-TPOS(3,L)) .LT. DELTA ) ) GOTO 170
  150    CONTINUE
         NADD = NADD + 1
         IF ( NPOS+NADD .GT. 48 ) CALL KERROR
     *      ('Program symm. error?', 150, 'LOCKIN')
         DO 160 K = 1,3
  160    TPOS(K,NPOS+NADD) = XYZ(K)
         ENDIF
  170 IF ( .NOT. CENTRO )  GOTO 190
      IF ( AGAIN ) THEN
         DO 180 K = 1,3
  180    XYZ(K) = XYZC(K)
         AGAIN = .FALSE.
         GOTO 140
         ENDIF
  190 CONTINUE
  200 CONTINUE
      IF ( NADD .EQ. 0 ) GOTO 220
      NPOS = NPOS + NADD
      NADD = 0
      GOTO 120
  220 DIST = 0.0
      FNPOS = FLOAT(NPOS)
      DO 240 I = 1,3
      DO 230 K = 1,NPOS
  230 ATOUT(I) = ATOUT(I) + TPOS(I,K)
  240 ATOUT(I) = ATOUT(I) / FNPOS
      IF ( NPOS .LE. 1 ) GOTO 260
      DO 250 I = 1,3
  250 D(I) = ATIN(I) - ATOUT(I)
      CALL VMATV1( D, RRMAT, D, DIST )
      DIST = SQRT( DIST )
  260 RETURN
      END
      SUBROUTINE HKLSTL (HKL, STL, STL2)
      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 HKL(3)
      STL2 = 0.0
      DO 100 I =1,3
      DO 100 J =1,3
  100 STL2 = STL2 + HKL(I) * SSMAT(I,J) * HKL(J)
      STL2 = STL2 / 4.0
      STL = SQRT(STL2)
      RETURN
      END
      SUBROUTINE HKLEXS (SWITCH, HKL, HCODE)
      LOGICAL SWITCH
      DIMENSION HKL(3)
      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 RSYMM(3,3,24), HHH(3)
      LOGICAL IRSW
      DATA IRSW / .FALSE. /
      IF (IRSW) GOTO 110
      IRSW = .TRUE.
      CALL KERI2F (IRSYMM, RSYMM, 9*NSYMM)
  110 DO 200 J = 1,NSYMM
      DO 120 K = 1,3
      HHH(K) = HKL(1) * RSYMM(1,K,J)
     *       + HKL(2) * RSYMM(2,K,J)
     *       + HKL(3) * RSYMM(3,K,J)
  120 CONTINUE
      CALL HKLC1 (HHH, HC)
      IF (SWITCH) HC = ABS(HC)
      IF (J.EQ.1) HCODE = HC
      HCODE = AMAX1 (HC, HCODE)
  200 CONTINUE
      RETURN
      END
      SUBROUTINE HKLEXT (HKL, KEND)
      DIMENSION HKL(3)
      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 KSYMM(3,3,24), TT(3,24), III(3), KKK(3)
      LOGICAL IRSW, SKIP
      DATA IRSW , SKIP / .FALSE. , .FALSE. /
      DATA NST / 0 /
      IF (SKIP) GOTO 102
      IF (IRSW) GOTO 110
      IF (NSYMM.GT.1) GOTO 103
  101 SKIP = .TRUE.
  102 KEND = 0
      RETURN
  103 IRSW = .TRUE.
      NST = 0
      DO 104 J = 2,NSYMM
      IF (ABS(TSYMM(1,J)) .LT. 0.01 .AND.
     *    ABS(TSYMM(2,J)) .LT. 0.01 .AND.
     *    ABS(TSYMM(3,J)) .LT. 0.01) GOTO 104
      NST = NST + 1
      CALL KERNAI (IRSYMM(1,1,J), KSYMM(1,1,NST), 9)
      CALL KERNAB (TSYMM(1,J), TT(1,NST), 3)
  104 CONTINUE
      IF (NST.EQ.0) GOTO 101
  110 CALL KERF2I (HKL, III, 3)
      DO 200 J = 1,NST
      TEST = 0.
      DO 120 K = 1,3
      KKK(K) = III(1) * KSYMM(1,K,J)
     *       + III(2) * KSYMM(2,K,J)
     *       + III(3) * KSYMM(3,K,J)
  120 CONTINUE
      IF (III(1).EQ.KKK(1) .AND. III(2).EQ.KKK(2) .AND.
     *    III(3).EQ.KKK(3) ) GOTO 130
      IF (ICENT.EQ.1) GOTO 200
      IF (III(1).NE.-KKK(1) .OR. III(2).NE.-KKK(2) .OR.
     *    III(3).NE.-KKK(3) ) GOTO 200
  130 TEST = TT(1,J) * HKL(1) + TT(2,J) * HKL(2) + TT(3,J) * HKL(3)
      IF (AMOD (ABS(TEST)+0.01, 1.0) .LT. 0.02) GOTO 200
      KEND = -1
      RETURN
  200 CONTINUE
      KEND = 0
      RETURN
      END
      SUBROUTINE HKLEX1 (HKL, HKLX)
      DIMENSION HKL(3), HKLX(3,24)
      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 RSYMM(3,3,24)
      LOGICAL IRSW
      DATA IRSW / .FALSE. /
      IF (IRSW) GOTO 110
      IRSW = .TRUE.
      CALL KERI2F (IRSYMM, RSYMM, 9*NSYMM)
  110 CALL KERNAB (HKL, HKLX, 3)
      IF (NSYMM.EQ.1) RETURN
      DO 120 J = 2,NSYMM
      DO 120 K = 1,3
  120 HKLX(K,J) = HKL(1) * RSYMM(1,K,J)
     *          + HKL(2) * RSYMM(2,K,J)
     *          + HKL(3) * RSYMM(3,K,J)
      RETURN
      END
      SUBROUTINE HKLEX2 (HKL, IDHKL, IEPS, IEPS2)
      DIMENSION HKL(3,24), IDHKL(24)
      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)
      IDHKL(1) = 0
      IF (NSYMM.EQ.1) THEN
         IEPS  = 1
         IEPS2 = 1
         RETURN
         ENDIF
      IEPS  = 0
      IEPS2 = 0
      DO 300 J=2,NSYMM
      IDHKL(J) = 0
      DO 200 K=1,J-1
      IF (ABS(HKL(1,K)-HKL(1,J)) .GT. 0.1) GOTO 180
      IF (ABS(HKL(2,K)-HKL(2,J)) .GT. 0.1) GOTO 180
      IF (ABS(HKL(3,K)-HKL(3,J)) .GT. 0.1) GOTO 180
      IDHKL(J) = K
      IEPS = IEPS + 1
      GOTO 300
  180 CONTINUE
      IF (ABS(HKL(1,K)+HKL(1,J)) .GT. 0.1) GOTO 200
      IF (ABS(HKL(2,K)+HKL(2,J)) .GT. 0.1) GOTO 200
      IF (ABS(HKL(3,K)+HKL(3,J)) .GT. 0.1) GOTO 200
      IDHKL(J) = - K
      IEPS2 = IEPS2 + 1
      GOTO 300
  200 CONTINUE
  300 CONTINUE
      IEPS2 = NSYMM / (NSYMM - IEPS - IEPS2)
      IF (ICENT .EQ. 1) THEN
         IEPS  = NSYMM / (NSYMM - IEPS)
      ELSE
         IEPS = IEPS2
         ENDIF
      RETURN
      END
      SUBROUTINE HKLEX3 (HKL, IDHKL, PSHIFT)
      DIMENSION HKL(3), IDHKL(24), PSHIFT(24)
      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)
      CALL KERNZA (0., PSHIFT, NSYMM)
      IF (NSYMM .EQ. 1) RETURN
      DO 220 I=1,NSYMM
      IF (IDHKL(I) .NE. 0) GOTO 210
      XTEST = 0.0
      DO 200 J=1,3
  200 XTEST  = XTEST - HKL(J) * TSYMM(J,I)
      XTEST  = AMOD(XTEST,1.0)
      IF (XTEST .LT. -0.01) XTEST = XTEST + 1.
      PSHIFT(I) = XTEST * 360.
      GOTO 220
  210 ITEST = IABS(IDHKL(I))
      PSHIFT(I) = PSHIFT(ITEST)
  220 CONTINUE
      RETURN
      END
      SUBROUTINE HKLAXT (HKL, KEND)
      DIMENSION HKL(3)
      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 IH(3)
      CALL KERF2I (HKL, IH, 3)
      GOTO (200, 2, 3, 4, 5, 6, 7), ILATT
  2   I = IH(2) + IH(3)
      GOTO 100
  3   I = IH(1) + IH(3)
      GOTO 100
  4   I = IH(1) + IH(2)
      GOTO 100
  5   I = IH(1) + IH(2) + IH(3)
  100 IF (MOD(I,2) .EQ. 0) GOTO 200
      GOTO 150
  6   IF (MOD (IH(1)+IH(2),2) .EQ. 0 .AND.
     *    MOD (IH(1)+IH(3),2) .EQ. 0) GOTO 200
      GOTO 150
  7   IF (MOD (-IH(1)+IH(2)+IH(3),3) .EQ. 0) GOTO 200
  150 KEND = -1
      RETURN
  200 CONTINUE
      KEND = 0
      RETURN
      END
      SUBROUTINE HKLC1 (HKL, HCODE)
      DIMENSION HKL(3), HKL1(3)
      PARAMETER (ADD   = -99.,  SPANL = 200., SPANKL = 200. * 200.,
     *                          LSPAN = 200 , KLSPAN = 200  * 200,
     *          IDDHKL =  99 * (KLSPAN + LSPAN + 1) )
      HCODE = HKL(1) * SPANKL + HKL(2) * SPANL + HKL(3)
      RETURN
      ENTRY HKLC1U (HCODE1, HKL1)
      KCODE  =  NINT (HCODE1) + IDDHKL
      I = KCODE / KLSPAN
      HKL1(1) = FLOAT (I) + ADD
      M = MOD(KCODE,KLSPAN)
      I = M / LSPAN
      HKL1(2) = FLOAT (I) + ADD
      M = MOD(KCODE, LSPAN)
      HKL1(3) = FLOAT (M) + ADD
      RETURN
      END
      SUBROUTINE HKLC2 (HKL, ACODE)
      DIMENSION HKL(3), HKL1(3), HMIN(3), HMAX(3)
      DIMENSION ADD(3)
      DATA SPANL, SPANKL, LSPAN, KLSPAN, IDDHKL  / 0.0, 0.0, 0, 0, 0 /
      ACODE = HKL(1) * SPANKL + HKL(2) * SPANL + HKL(3)
      RETURN
      ENTRY HKLC2U (ACODE1, HKL1)
      KCODE   = IFIX  (ACODE1) + IDDHKL
      HKL1(1) = FLOAT (     KCODE         /KLSPAN) + ADD(1)
      HKL1(2) = FLOAT ( MOD(KCODE,KLSPAN) / LSPAN) + ADD(2)
      HKL1(3) = FLOAT ( MOD(KCODE, LSPAN)        ) + ADD(3)
      RETURN
      ENTRY HKLC2I (HMIN, HMAX)
      CALL KERNAB (HMIN, ADD, 3)
      SPANL  = HMAX(3) - HMIN(3) + 1.
      SPANKL = SPANL * (HMAX(2) - HMIN(2) + 1.)
      LSPAN  = IFIX (SPANL  + 0.1)
      KLSPAN = IFIX (SPANKL + 0.1)
      ADDHKL = - HMIN(1) * SPANKL
     *         - HMIN(2) * SPANL - HMIN(3)
      IDDHKL = NINT (ADDHKL)
      RETURN
      END
      SUBROUTINE FCALCI (KEYT, ATXYZ, IZAT, ITAT, NAT)
      DIMENSION ATXYZ(10,NAT), IZAT(NAT), ITAT(NAT)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICRYS, IFILE(3))
      LOGICAL EXPAND
      EQUIVALENCE (EXPAND, SWITCH(23))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      DO 130 I=1,NTYPE
      CALL RDCRYB (ICRYS, 'ELEM' , KEND)
      IF (KEND.LE.0) THEN
        WRITE (CHOUT, 110) I
  110   FORMAT (' CRYSDA file: ELEM for atom TYPE no. ',I2,' not found')
        CALL KERROR (CHOUT, 0, 'FCALCI')
        ENDIF
      READ (CHIN, 120) IZTYPE(I)
  120 FORMAT (10X, 2X, I8)
  130 CALL RDCRYX (ICRYS, 'SFAC' , SFAC(1,I), 13)
      DO 150 I=1,NSYMM
      IF (ABS(TSYMM(1,I)).GT.0.001 .OR.
     *    ABS(TSYMM(2,I)).GT.0.001 .OR.
     *    ABS(TSYMM(3,I)).GT.0.001 ) THEN
         ITRS(I) = 1
         ELSE
         ITRS(I) = 0
         ENDIF
  150 CONTINUE
      AMULT = FLOAT (IMULT)
      ASYMM = FLOAT (NSYMM)
      ALATT = FLOAT (NLATT)
      ASYMCL= FLOAT (ICENT*NLATT)
      NSYMC = NSYMM * ICENT
      ASYMC = FLOAT (NSYMC)
      IF (.NOT. EXPAND) CALL ATOMOC (1, ATXYZ, ITAT, NAT)
      CALL KERNZA (0.0, CELPAR, NTYPE)
      AAMULT = AMULT
      IF (EXPAND) AAMULT = ALATT
      DO 161 I=1,NAT
      DO 160 J=1,NTYPE
      IF (IZAT(I).NE.IZTYPE(J)) GOTO 160
      ITAT(I) = J
      CELPAR(J) = CELPAR(J) + ATXYZ(4,I) * AAMULT
  160 CONTINUE
  161 CONTINUE
      IF (KEYT.EQ.3) CALL ATBETA (ATXYZ, NAT)
      CALL SICOT (SICO, 12500)
      ISMAX = IFIX (STLMAX * 400. +0.04  ) + 2
      IF (ISMAX.LE.500) GOTO 200
      WRITE (CHOUT, 198) STLMAX
  198 FORMAT (' Found max. sin(th/lam) = STLMAX =', F7.3,
     *        ' Max = 1.249 . ??DATA ERROR?? ')
      CALL KERROR (CHOUT, 0, 'FCALCI')
  200 DO 260 IS=1,ISMAX
      STL = FLOAT(IS-1) * 0.0025
      STL2 = STL * STL
      EXPBP(IS) = EXP(-BP * STL2)
      EXPBR(IS) = EXP(-BR * STL2)
      SUMF2(IS)  = 0.0
      SUMF2P(IS) = 0.0
      DO 260 I=1,NTYPE
      SFAC6 = AMIN1 (SFAC(6,I) * STL2, 99.99)
      SFAC8 = AMIN1 (SFAC(8,I) * STL2, 99.99)
      FF(IS,I) = SFAC(9,I) + SFAC(10,I)
     * + SFAC(1,I) * EXP (-SFAC(2,I) * STL2)
     * + SFAC(3,I) * EXP (-SFAC(4,I) * STL2)
     * + SFAC(5,I) * EXP (-SFAC6)    + SFAC(7,I) * EXP (-SFAC8)
      SUMF2(IS)  = SUMF2(IS) + FF(IS,I) * FF(IS,I) * CELALL(I)
  260 SUMF2P(IS) = SUMF2P(IS)+ FF(IS,I) * FF(IS,I) * CELPAR(I)
      PSQ = SUMF2P(2)/SUMF2(2)
      P1SQ = PSQ / ASYMC
      IF (.NOT. EXPAND) RETURN
      P1SQ = PSQ
      PSQ = AMIN1 (0.999 , P1SQ * ASYMC)
      RETURN
      END
      SUBROUTINE SICOT (SICO, M)
      DIMENSION SICO(M)
      PARAMETER (PI2 = 2.0 * 3.14159265 )
      M1 = M  / 5
      M2 = M1 * 2
      M4 = M2 * 2
      F = PI2 / FLOAT(M4)
      DO 240 I=1,M1
      AI = SIN (FLOAT(I) * F)
      SICO(I)    = AI
      SICO(M2-I) = AI
      SICO(M2+I) =-AI
      SICO(M4-I) =-AI
  240 SICO(M4+I) = AI
      SICO(M2)   = 0.0
      SICO(M4)   = 0.0
      RETURN
      END
      SUBROUTINE MACOL(A)
      DIMENSION A(3,3)
      N=1
  105 K=2
  110 T=A(K,N)
      A(K,N)=A(N,K)
      A(N,K)=T
      IF (N.EQ.3) RETURN
      K=K+1
      IF (K.LE.3) GOTO 110
      N=3
      GOTO 105
      END
      SUBROUTINE MATINV(A,B,D,KEND)
      DIMENSION A(3,3),B(3,3)
      PARAMETER (DETMAX = 10.E-15)
      KEND=0
      CALL VECAXB (A(1,2),A(1,3),B(1,1))
      CALL VECAXB (A(1,3),A(1,1),B(1,2))
      CALL VECAXB (A(1,1),A(1,2),B(1,3))
      D=A(1,1)*B(1,1)+A(2,1)*B(2,1)+A(3,1)*B(3,1)
      IF (D.LT.DETMAX .AND. D.GT.-DETMAX) KEND = -99
      IF (KEND.EQ.-99) RETURN
      DO 15 N=1,3
      DO 15 K=1,3
   15 B(K,N)=B(K,N)/D
      CALL MACOL(B)
      RETURN
      END
      FUNCTION ERFU (X)
      DIMENSION E(31)
      DATA E / .00000, .11246, .22270, .32863, .42839,
     *         .52050, .60386, .67780, .74210, .79691,
     *         .84270, .88021, .91031, .93401, .95229,
     *         .96611, .97635, .98379, .98909, .99279,
     *         .99532, .99702, .99814, .99886, .99931,
     *         .99959, .99976, .99987, .99992, .99996, .99998 /
      X10 = X*10. + 1.00001
      IX = X10
      IF (IX.GT.30) GOTO 100
      ERFU = E(IX) + (X10-IX) * (E(IX+1)-E(IX))
      RETURN
  100 ERFU = 1.
      RETURN
      END
      FUNCTION IPHFIX (HKL)
      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  HKL(3), ICODE(13), LTEST(3), IHKL(3)
      DATA ICODE / 2, -1, 9, 8, 7, -1, 6, -1, 5, 4, 3, -1, 2 /
      CALL KERF2I (HKL, IHKL, 3)
      IF(ICENT.EQ.1) GOTO 150
      IPHFIX = 2
      RETURN
  150 IPHFIX = 1
      IOLD = -1
      DO 180 I=2,NSYMM
      XTEST = 0.0
      KTEST = 0
      DO 170 J=1,3
      LTEST(J) = 0
      DO 160 L=1,3
  160 LTEST(J) = LTEST(J) + IHKL(L)*IRSYMM(L,J,I)
      KTEST = KTEST + IHKL(J) + LTEST(J)
      IF (KTEST.NE.0) GOTO 180
  170 XTEST = XTEST - (HKL(J) * TSYMM(J,I))
      XTEST = XTEST - IFIX(XTEST)
      IF (XTEST.LT.-0.01) XTEST = XTEST + 1.0
      IPHS = IFIX(12.*XTEST+0.1) + 1
      IPHFIX = ICODE(IPHS)
      IF (IOLD.EQ.-1) IOLD = IPHFIX
      IF (IPHFIX.NE.IOLD) GOTO 190
  180 CONTINUE
      IF (IPHFIX.GE.1) RETURN
  190 IPHFIX = -1
      RETURN
      END
      FUNCTION E2EXP (ITYP, E1, E2)
      EX1 = E1 * E1
      EX2 = E2 * E2
      IF (ITYP.NE.0) GOTO 100
      Q = (EX2-EX1) / 2.0
      E2EXP = EX1 + Q * (1. - SIMW(Q))
      RETURN
  100 EXX1 = EXP(-EX1*.5)
      EX3 = EXX1 / (EXX1 + EXP(-EX2*.5) )
      E2EXP = EX1*EX3 + (1.0 - EX3)*EX2
      RETURN
      END
      FUNCTION  SIMW (Q)
      SIMW = ((0.0106 * Q - 0.1304) * Q + 0.5658) * Q
      IF (Q.GT.5.) SIMW=0.8565 + 0.0075*Q
      RETURN
      END
      SUBROUTINE MATC2F (CELL, CX)
      DIMENSION CELL(6), CX(3,3)
      DIMENSION CELLT(6)
      EQUIVALENCE (A   ,CELLT(1)),  (B   ,CELLT(2))
      EQUIVALENCE (C   ,CELLT(3)),  (ALPH,CELLT(4))
      EQUIVALENCE (BET ,CELLT(5)),  (GAMM,CELLT(6))
      CALL KERNAB (CELL, CELLT, 6)
      D2R = ATAN(1.0) / 45.0
      ALPHA = ALPH * D2R
      BETA = BET * D2R
      GAMMA = GAMM * D2R
      COSA = COS(ALPHA)
      SINA = SIN(ALPHA)
      COSB = COS(BETA)
      SINB = SIN(BETA)
      COSC = COS(GAMMA)
      SINC = SIN(GAMMA)
      S = 0.5*(ALPHA+BETA+GAMMA)
      V = A*B*C *2. *SQRT(SIN(S)*SIN(S-ALPHA)*SIN(S-BETA)*SIN(S-GAMMA))
      CX(1,1) = 1./A
      CX(1,2) = -COSC/(A*SINC)
      CX(1,3) = B*C*(COSC*COSA-COSB)/(V*SINC)
      CX(2,1) = 0.
      CX(2,2) = 1./(B*SINC)
      CX(2,3) = A*C*(COSB*COSC-COSA)/(V*SINC)
      CX(3,1) = 0.
      CX(3,2) = 0.
      CX(3,3) = A*B*SINC/V
      RETURN
      END
      SUBROUTINE MATF2C (CELL, XC)
      DIMENSION CELL(6), XC(3,3)
      DIMENSION CELLT(6)
      EQUIVALENCE (A   ,CELLT(1)),  (B   ,CELLT(2))
      EQUIVALENCE (C   ,CELLT(3)),  (ALPH,CELLT(4))
      EQUIVALENCE (BET ,CELLT(5)),  (GAMM,CELLT(6))
      CALL KERNAB (CELL, CELLT, 6)
      D2R = ATAN(1.0) / 45.0
      ALPHA = ALPH * D2R
      BETA = BET * D2R
      GAMMA = GAMM * D2R
      COSA = COS(ALPHA)
      SINA = SIN(ALPHA)
      COSB = COS(BETA)
      SINB = SIN(BETA)
      COSC = COS(GAMMA)
      SINC = SIN(GAMMA)
      S = 0.5*(ALPHA+BETA+GAMMA)
      V = A*B*C *2. *SQRT(SIN(S)*SIN(S-ALPHA)*SIN(S-BETA)*SIN(S-GAMMA))
      XC(1,1) = A
      XC(1,2) = B*COSC
      XC(1,3) = C*COSB
      XC(2,1) = 0.
      XC(2,2) = B*SINC
      XC(2,3) = -C*(COSB*COSC-COSA)/SINC
      XC(3,1) = 0.
      XC(3,2) = 0.
      XC(3,3) = V/(A*B*SINC)
      RETURN
      END
      SUBROUTINE VECAXB (A, B, V)
      DIMENSION A(3), B(3), V(3)
      T1   = A(2) * B(3) - A(3) * B(2)
      T2   = A(3) * B(1) - A(1) * B(3)
      V(3) = A(1) * B(2) - A(2) * B(1)
      V(1) = T1
      V(2) = T2
      RETURN
      END
      SUBROUTINE MATAXB (A, B, P)
      DIMENSION A(3,3), B(3,3), P(3,3)
      DO 112 K = 1, 3
      DO 111 L = 1, 3
      P(K,L) = A(K,1) * B(1,L) + A(K,2) * B(2,L) + A(K,3) * B(3,L)
  111 CONTINUE
  112 CONTINUE
      RETURN
      END
      SUBROUTINE MATAXI (IA, IB, IP)
      DIMENSION IA(3,3), IB(3,3), IP(3,3)
      DO 112 I = 1, 3
      DO 111 J = 1, 3
      IP(I,J) = IA(I,1) * IB(1,J) +IA(I,2) * IB(2,J) +IA(I,3) * IB(3,J)
  111 CONTINUE
  112 CONTINUE
      RETURN
      END
      SUBROUTINE MAT6XV (XC, X, C)
      DIMENSION XC(3,3), X(3), C(3)
      C(1) = X(1)*XC(1,1) + X(2)*XC(1,2) + X(3)*XC(1,3)
      C(2) =                X(2)*XC(2,2) + X(3)*XC(2,3)
      C(3) =                               X(3)*XC(3,3)
      RETURN
      END
      SUBROUTINE MATXV3 (RR, A, B)
      DIMENSION RR(3,3), A(3), B(3)
      T1   = RR(1,1) * A(1) + RR(1,2) * A(2) + RR(1,3) * A(3)
      T2   = RR(2,1) * A(1) + RR(2,2) * A(2) + RR(2,3) * A(3)
      B(3) = RR(3,1) * A(1) + RR(3,2) * A(2) + RR(3,3) * A(3)
      B(1) = T1
      B(2) = T2
      RETURN
      END
      SUBROUTINE VXMATI (K, IR, L)
      DIMENSION K(3), IR(3,3), L(3)
      L1   = K(1) * IR(1,1)  + K(2) * IR(2,1)  + K(3) * IR(3,1)
      L2   = K(1) * IR(1,2)  + K(2) * IR(2,2)  + K(3) * IR(3,2)
      L(3) = K(1) * IR(1,3)  + K(2) * IR(2,3)  + K(3) * IR(3,3)
      L(1) = L1
      L(2) = L2
      RETURN
      END
      SUBROUTINE VMATV1 (A, R, B, Q)
      DIMENSION  A(3), R(3,3), B(3)
      Q=A(1) * (R(1,1) * B(1) + R(1,2) * B(2) + R(1,3) * B(3)) +
     *  A(2) * (R(2,1) * B(1) + R(2,2) * B(2) + R(2,3) * B(3)) +
     *  A(3) * (R(3,1) * B(1) + R(3,2) * B(2) + R(3,3) * B(3))
      RETURN
      END
