      PROGRAM TRAVEC
***************************  File: U625002 TRAVEC FORTRAN N = TRAVEC FOR
****                                         Last update:   11 Nov. 1999
**** G. Admiraal: ''a new version of TRAVEC (author G. Schaefer), ... ''
**** Last part of file: see ORIENT: Nordman, Strumpel, G.Beurskens, ptb.
**** Juny 1996: optimizations via rotations disabled !!!!!!!!!!!!!!!!!!!
**** OLD VERSION AVAILABLE ON REQUEST ==> file U625002 TRAVECR FORTRAN E
************************************************************************
* wensen:    - test op MAXVEC=960?       - div subr oppoetsen
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IATOMS, IFILE(1))
      EQUIVALENCE (IKLAD,  IFILE(20))
      EQUIVALENCE (IATOLD, IFILE(2))
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IFMAP, IFILE(17))
      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 /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1
      PARAMETER (MAXAT = 213)
      COMMON /CARATP/  NAT, CARXYZ(3,MAXAT), IZATOM(MAXAT), XYZT(3)
      COMMON /TRAVDA/ MM
      CHARACTER*6    LAT(1)
      DIMENSION   CARXIN(3,MAXAT), XYZTIN(3), INHVAM(50)
      DATA LAT /'ATOMS'/
      CALL KEPROG( 'TRAVEC' )
      WRITE (LIS2, FMT = '('' Last TRAVEC update: 11 Nov. 1999'')')
      CALL PRETRA
      CALL PRETAB
      CALL CONTRA
      KSTOP = 0
      CALL TRADEK (KSTOP)
      IF (KSTOP .NE. 0) GOTO 1111
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) CALL KERROR ('Error on file ATOMS', -1,'TRAVEC')
      CALL FILINQ (IKLAD, 'ATOMK', 'FORMATTED', 'SCRATCH', KINQ)
      MMODH=50
      MMMOD=0
 111  CALL KERIFF (IATOMS, LAT, 1, LEND)
      IF (LEND.EQ.-1 .OR. LEND.GT.0) GOTO 1000
      IF (NLUSER(1).LE.0) GOTO 111
      IFOM = 100
      IBOTS = 0
      R2X = 1.00
      IF (LIT(NLIT) .NE. 'FOM=' .AND. LIT(NLIT-1) .NE. 'FOM=') THEN
         WRITE (LIS1,FMT='('' Old TRACOR output: FOM= not avalable'')')
      ELSEIF (LIT(NLIT) .EQ. 'FOM=') THEN
         IFOM = NINT(FNUM(NFNUM))
         IF(LIT(NLIT-1) .EQ. 'R2=') R2X = FNUM(NFNUM-1)
      ELSE
         IFOM = NINT(FNUM(NFNUM-1))
         IF (LIT(NLIT) .EQ. 'X=') IBOTS = NINT(FNUM(NFNUM))
         IF(LIT(NLIT-2) .EQ. 'R2=') R2X = FNUM(NFNUM-2)
         ENDIF
      IFOMX(1,MMMOD+1) = IFOM
      IFOMX(2,MMMOD+1) = IBOTS
      IFOMX(3,MMMOD+1) = NINT (R2X * 1000.)
      BACKSPACE IATOMS
      CALL MODSIN (IATOMS, NAT, CARXIN, XYZTIN, IZATOM)
      IF (NAT .LE. 1 .OR. NAT .GT. MAXAT) GOTO 1111
      GRIDS1 = DISPMX/2.
      MM = MMMOD+1
      CALL REFMOD (MM, CARXIN, XYZTIN)
      IF (MM .LT. 0) GOTO 1111
      MMMOD=MMMOD+1
      WRITE (LIS1, FMT='(/'' TEMP: Number of models:'', I3)') MMMOD
      IF (MMMOD .LT. MMODH) GOTO 111
 1000 IF (MMMOD .LE. 1) THEN
         WRITE (LIS1, FMT='(/'' One model only.......... STOP....''/
     *      '' Bypass further TRAVEC calculations. ''/)')
         GOTO 1111
         ENDIF
      CALL SQMODL (MMMOD, INHVAM, MMODH)
      GOTO 9999
 1111 CONTINUE
      CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
      WRITE (LIS1, 710)
      WRITE (LIS2, 710)
  710 FORMAT (/
     * ' All TRACOR results sets are written to the ATOLD file.' /)
      IF (IFOMX(2,1) .LE. 0) GOTO 9999
      WRITE (IPR1, 810)
      WRITE (LIS1, 810)
      WRITE (LIS2, 810)
  810 FORMAT (/
     * ' NOTE. The first ATOMS set from TRACOR is not acceptable, as ' /
     * ' the molecule collides with symmetry related molecules  !!!!' /
     * ' You may decide what is best to do next ...     We will STOP' /
     * ' If the molecule is on a  symmetry  element,  then  use your' /
     * ' local software to generate a  symmetry independent fragment' /
     * ' to be stored in the ATOMS file, and then continue with' /
     * ' DIRDIF CCODE PHASEX  for completion of the structure. !!!!!' )
      CALL FILINQ (IDDSY, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IDDSY, FMT='(''STOP'')')
      CALL FILCLO (IDDSY, 'KEEP')
 9999 CALL FILCLO (IATOMS, 'KEEP')
      IDDOKA = KEYS(10)
      IF (IDDOKA .EQ. 17) GOTO 999
      CALL KEPROX
  999 CONTINUE
      WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)')
      STOP 99
      END
      SUBROUTINE PRETRA
      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)), (LIS1, IFILE(7))
      EQUIVALENCE (ICOND, IFILE(4))
      EQUIVALENCE (KLAUE,  KEYS(6))
      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 /IMSEFU/  MSUM, AMINMN, AMINMX
      CHARACTER*6 LITA(1)
      DATA LITA(1) / 'TRAVEC' /
   91 CALL RDCOND (ICOND, LITA, 1, KEND)
      IF (KEND .LE. 0) GOTO 92
      GOTO 91
   92 CONTINUE
      CALL FILCLO (ICOND, 'KEEP')
      WRITE (LIS1, FMT='('' Execute TRAVEC without optimization'')')
      CALL RDCRYS( ICRYS )
      CALL FILCLO( ICRYS, 'KEEP' )
      GOTO
     * (101,102,103,104,103,101,101,101,101,101,104,104,103,103), ILAUE
  101 KLAUE = 1
      GOTO 105
  102 IF (IUNIQ .EQ. 3) GOTO 104
      KLAUE = 2
      GOTO 105
  103 KLAUE = 3
      GOTO 105
  104 KLAUE = 4
105   CONTINUE
      MSUM = 200
      RETURN
      END
      SUBROUTINE PRETAB
      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))
      EQUIVALENCE (IDDL,  IFILE(9))
      EQUIVALENCE (SINGPK, KEYS(27))
      EQUIVALENCE (ORIGIN, KEYS(28))
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      DIMENSION PATP(8)
      DATA      DELY,DEL2Y /0.,0./
      DEL = .01
      CALL LOGRD (IDDL, 'SINGPK', KLOG)
      IF (KLOG.LT.0) CALL KERROR('DDLOG file not available',-1,'PRETRA')
      IF (KLOG.EQ.0 .OR. NFNUM.NE.3) CALL KERROR
     * ('DDLOG file not correct, SINGPK a/o ORIGIN missing',-1,'PRETRA')
      SINGPK = FNUM(2)
      ORIGIN = FNUM(3)
      CALL LOGRD (IDDL, 'PK', KLOG)
      CALL FILCLO (IDDL, 'KEEP')
      IF (KLOG.LE.0 .OR. NFNUM.NE.9) CALL KERROR
     *   ('DDLOG file: no peak shape (Rerun Patterson)',-1,'PRETRA')
      CALL KERNAB (FNUM(2), PATP, 8)
      IF (PATP(1) .LT. .5)
     *   CALL KERROR ('wrong PK SHAPE in DDLOG file', 0, 'VEC')
      DO 120 I = 2, 8
      IF (PATP(I) .LT. 0.) PATP(I) = 0.
      IF (PATP(I-1) .LT. 0.2) THEN
         PATP(I-1) = PATP(I-1) * 0.9
         PATP(I) = AMIN1 (0.99, PATP(I))
         ENDIF
      PATP(I) = AMIN1 (PATP(I), PATP(I-1) * (1. - 0.02 * FLOAT(I)))
  120 CONTINUE
      WRITE (LIS2, 123) PATP
  123 FORMAT (' PEAK PROFILE:  ',
     *  'for x.a = 0.0   0.1   0.2   0.3   0.4   0.5   0.6   0.7   0.8'/
     *  16X, 'shape   = 1.000', 8F6.3 )
      TAB(1) = 1.
      IMAX2=0
      IXL = 0
      I = 2
   36 RRR = SQRT(FLOAT(I) - 0.9999)
      IX = RRR
      IF (IX .LE. 0) THEN
         WRITE (LIS1, FMT='('' Important error = IX = tell PTB'')')
         IX = 1
         ENDIF
      IF (IX.EQ.IXL) GOTO 37
      IXL = IX
      TAB(I) = PATP(IX)
      IF (IX.EQ.7) GOTO 38
      DELY = PATP(IX+1) - PATP(IX)
      DEL2Y = 0.5 * ( PATP(IX+2) - PATP(IX+1) - DELY )
      GOTO 38
   37 DELX = RRR - FLOAT(IX)
      TAB(I) = PATP(IX) + DELX * DELY + DELX * (DELX-1.) * DEL2Y
   38 IF (TAB(I).GT.0.1) IMAX2 = I - 1
      I = I + 1
      IF (I.LE.50) GOTO 36
      IF (IMAX2.GT.48) IMAX2=48
      RMAX2 = FLOAT(IMAX2) / 100.
      RMAX = SQRT( RMAX2)
      RETURN
      END
      SUBROUTINE CONTRA
      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 (SCADEK, KEYS(26))
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      WRITE (LIS2, FMT='
     * ('' TRAVEC calculates AMINM for all input models,''/
     *  '' AMINM = maximum of image seeking function (ISF) ''/
     *  /'' Values and effects of control variables:''/)')
      SCADEK=0.2
      DISPMX = 0.32
      IF ( DISPMX .GT. RMAX ) DISPMX = RMAX
      DISPMX = DISPMX/2.
      VMIN = 0.7
      VMAX = 10.
      WRITE (LIS2, FMT='('' Intra-model vectors with length > than'',
     *    '' VMAX ='',F5.1, /'' do not contribute to ISF.'',
     *    '' Minimum length is VMIN ='',F5.1 )') VMAX, VMIN
      FRACM = 0.30
      WRITE (LIS2, FMT='('' Fraction of search-vectors which contributes
     * to minM is'',F5.2)') FRACM
      RETURN
      END
      SUBROUTINE TRADEK (KSTOP)
      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)),(IFMAP, IFILE(17))
      EQUIVALENCE (KLAUE,  KEYS(6))
      EQUIVALENCE (SCADEK, KEYS(26))
      EQUIVALENCE (SINGPK, KEYS(27)), (ORIGIN, KEYS(28))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI,  SWITCH(10))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      PARAMETER (NUMTAB = 200000)
      COMMON /  / TTT, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), TTT)
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3)
      EQUIVALENCE (NX,NXYZ(1)), (NY,NXYZ(2)), (NZ,NXYZ(3))
      EQUIVALENCE (NUMX, NUM(1))
      INTEGER * 2 LPAT(198)
      DIMENSION NXYZM(3)
      EQUIVALENCE (NXM,NXYZM(1)), (NYM,NXYZM(2)), (NZM,NXYZM(3))
      DIMENSION ITLE(20)
      EQUIVALENCE (FFTSC, ITLE(18))
      DATA JXYZC, LXYZC / 0, 0 /
      DATA IZ, KXYZC, IXYZC / 0, 0, 0 /
      ILMAX = 100000
      DO 111 I = 1, NUMTAB
 111  ITAB (I) = 0
      MAXFUN = 30254
      MIFUN = 0
      FUNSUM = 0.
      CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ.NE.0) THEN
         WRITE(LIS1, FMT='(
     *    '' Patterson file (FMAP, output ORIENT) not found:''/
     *    '' TRAVEC is bypassed.'')')
         KSTOP = 1
         RETURN
         ENDIF
      READ (IFMAP) ITLE, IMAP, IHALF
      IF (SWPRI) WRITE (LIS2, FMT='('' IMAP, IHALF, FFTSC ='',
     *   2I3, F10.5)') IMAP, IHALF, FFTSC
      IF (IMAP .NE. 2 .AND. IMAP .NE. 6) THEN
         WRITE(LIS1, FMT='(
     *    '' Patterson file (FMAP, output ORIENT) incorrect:''/
     *    '' No Patteron function (i.e. error on file FMAP):''/
     *    '' TRAVEC is bypassed.'')')
         KSTOP = 1
         CALL FILCLO (IFMAP, 'DELETE')
         RETURN
         ENDIF
      READ (IFMAP) NX, NZ, NYHALF, NY
      WRITE (LIS2,6) NX, NY, NZ
   6  FORMAT (' Patterson grid X * Y * Z = ' , I3, 2(' *',I3) )
      SCAL = SCADEK
      ABSCAL = SCAL * FFTSC * VOLUM
      SINGPK = ORIGIN * ABSCAL * 18. /VOLUM
      IF (SWPRI) WRITE (LIS2, 138) FFTSC
  138 FORMAT (' Input Patterson scale = ',12X, F10.5,' * volume ')
      IF (SWITCH(1)) WRITE (LIS2,1138) FFTSC
 1138 FORMAT (' PTB TEMP Input SCALE: SCALOR = 3000 / sumF2 =' , F10.5)
      WRITE (LIS2, 152) SCAL, ABSCAL, SINGPK
  152 FORMAT (' Input function values will be multiplied by: ', F10.5 /
     *        ' To put the Patterson function on abs.scale *  ', F9.5 /
     *        ' Single-vector peak-height is approximately   ' ,F10.2 /)
      K = 0
      DO 12 I=1,3
      L = (NXYZ(I)+1) / 2
      IF (I.NE.2 .AND. KLAUE.LT.0) L=NXYZ(I)-1
      IF (L.GT.ILMAX) CALL KERROR ('KANNIET', 12, 'TRADEK')
      LXYZ(I) = MIN0 (L, ILMAX)
   12 IS(I) = 0
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.4) IS(2)=-LXYZ(2)
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.2) IS(3)=-LXYZ(3)
      DO 14 I=1,3
      NXYZM(I) = NXYZ(I)
      IF (IS(I) .EQ. 0) NXYZM(I) = LXYZ(I) + 1
   14 NUM(I) = LXYZ(I) - IS(I) + 1
      NUMXY = NUM(1) * NUM(2)
      NUMXYZ = NUMXY * NUM(3)
      IF (NUMXYZ .GT. NUMTAB) THEN
         WRITE(LIS1, FMT='(
     *    '' Storage problems in TRADEK: Patterson map is too large :''/
     *    '' TRAVEC is bypassed.'')')
         KSTOP = 1
         RETURN
         ENDIF
      DO 217 I = 1,3
  217 GTXYZ(I) = NXYZ(I)
      NUMC = NUMXY * IS(3) + NUM(1) * IS(2) + IS(1) - 1
      IF (NYM .GT. NYHALF) CHOUT = ' Please tell PTB: NYM gt NYHALF '
      IF (NYM .GT. NYHALF) CALL SHOUT
      IF (NYM .GT. NYHALF) NYM=NYHALF
      DO 50 I1=1,NYM
      IY = I1 - 1
      KY = IY - NY
      IXY = NUM(1) * IY
      KXY = NUM(1) * KY
      K = 1
      IF (IS(2).EQ.0) GOTO 26
      IF (IY .GT. LXYZ(2)) K=3
      IF (IY.EQ.LXYZ(2) .OR. IY.EQ.NY/2) K=2
      IF (K.EQ.2 .AND. IY.GT.ILMAX) K=3
      IF (K.EQ.2 .AND. KY+ILMAX.LT.0) K=1
      IF (K.EQ.1 .AND. IY.GT.ILMAX) K=0
      IF (K.EQ.3 .AND. KY+ILMAX.LT.0) K=0
      IF (K.EQ.3) IXY=KXY
   26 DO 48 I2=1,NZ
      IF (I2.GT.NZM) K=0
      IF (K.EQ.0) GOTO 28
      IZ = I2 - 1
      IXYZ = NUMXY * IZ
      IXYZC = IXYZ + IXY - NUMC
      KXYZC = IXYZ + KXY - NUMC
      L = 1
      IF (IS(3).EQ.0) GOTO 28
      KZ = IZ - NZ
      JXYZ = NUMXY * KZ
      JXYZC = JXYZ + IXY - NUMC
      LXYZC = JXYZ + KXY - NUMC
      IF (IZ.GT.LXYZ(3)) L=3
      IF (IZ.EQ.LXYZ(3) .OR. IZ.EQ.NZ/2) L=2
      IF (L.EQ.2 .AND. IZ.GT.ILMAX) L=3
      IF (L.EQ.2 .AND. KZ+ILMAX.LT.0) L=1
      IF (L.EQ.1 .AND. IZ.GT.ILMAX) L=0
      IF (L.EQ.3 .AND. KZ+ILMAX.LT.0) L=0
      IF (L.EQ.3) IXYZC=JXYZC
      IF (L.EQ.3) KXYZC=LXYZC
   28 READ (IFMAP) IBSEC, IBJ, IBNX,(LPAT(I),I=1,IBNX)
      IF (K.EQ.0 .OR. L.EQ.0) GOTO 48
      DO 40 I3=1,NXM
      FUN = LPAT(I3)
      FUN = 99. * (FUN * SCAL + 25.)
      IFUN = NINT(FUN)
      IF (IFUN) 32, 32, 30
   30 IF (IFUN.GT.MIFUN) MIFUN=IFUN
      IF (IFUN .LE. MAXFUN) GOTO 36
      IFUN = MAXFUN
      GOTO 36
   32 IFUN = 0
   36 LPAT(I3) = IFUN
      FUNSUM = FUNSUM + FLOAT(IFUN)
      IX = I3 - 1
      IADR = IXYZC + IX
      IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=1=',-4,'TRADEK')
      ITAB(IADR) = IFUN
      IF (L.NE.2) GOTO 39
      IADR = JXYZC + IX
      IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=2=',-4,'TRADEK')
      ITAB(IADR) = IFUN
   39 IF (K.NE.2) GOTO 40
      IADR = KXYZC + IX
      IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=3=',-4,'TRADEK')
      ITAB(IADR) = IFUN
      IF (L.NE.2) GOTO 40
      IADR = LXYZC + IX
      IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=4=',-4,'TRADEK')
      ITAB(IADR) = IFUN
   40 CONTINUE
   48 CONTINUE
   50 CONTINUE
      CALL FILCLO (IFMAP, 'DELETE')
      FUNSUM = FUNSUM / FLOAT(NUMXYZ)
      IFUN = FUNSUM
      WRITE (LIS2,52) MIFUN, IFUN
   52 FORMAT (' Largest scaled Patterson value is: ', 15X, I5, /
     *         20X,    ' averaged value is: ', 11X, I5, /)
      RETURN
      END
      SUBROUTINE MODSIN (IATOMS, NAT, CARXIN, XYZTIN, IZATOM)
      PARAMETER (MAXAT = 213)
      DIMENSION CARXIN(3,MAXAT),XYZTIN(3),IZATOM(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 (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IATOLD, IFILE(2))
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      PARAMETER (MAXATT = 993)
      COMMON /ATODAT/  NAT1, ATXYZ(10,MAXATT), IZAT(MAXATT), XYZT(3)
      COMMON /ATNAMA/ ATNAME(MAXATT)
      CHARACTER * 6   ATNAME
      DATA NATINP / 0/
      IF (NATINP .EQ. 0) THEN
         WRITE (LIS2, FMT='('' Input parameter sets from file ATOMS'',
     *       ''  (TR= TRACOR output model number).'',
     *     /'' Of each set, only the first atom is printed'',
     *              '' for inspection.''
     *     / '' Atom name'', 5X, ''x'', 9X, ''y'', 9X, ''z''/)')
         NATINP = -1
         ENDIF
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXATT, NAT, KEYT)
      WRITE (LIS2, FMT='(1X, A80)') CHIN
      NAT1 = NAT
      IF (NAT.LE.0) CALL KERROR('No atoms on ATOMS file',-1,'ATREAD')
      IF (NAT .LE. 1 .OR. NAT .GT. MAXAT) THEN
         IF (NAT .LE. 1) WRITE(LIS1, FMT='(/
     *      '' The input ATOMS file contains only one atom:'')')
         IF (NAT .GT. MAXAT) WRITE(LIS1, FMT='( //'' Hold it .......''/
     *      '' The input ATOMS file contains too many atoms:''/
     *      '' ( max: '', I4, '') : '')') MAXAT
         WRITE(LIS1, FMT='('' TRAVEC is bypassed./'')')
         RETURN
         ENDIF
      WRITE (LIS2, 112)  ATNAME(1), (ATXYZ(J,1),J=1,3), IZAT(1)
  112 FORMAT (3X, A6, 2X, 3F10.5, '  Z =', I3)
      CALL KERNZA (0., XYZT, 3)
      DO 10 I = 1, NAT
   10 CALL VPLUSV (XYZT, ATXYZ(1,I), XYZT, 3)
      DO 11 J = 1, 3
   11 XYZT(J) = - XYZT(J) / FLOAT(NAT)
      DO 20 I = 1, NAT
      CALL VPLUSV (ATXYZ(1,I), XYZT, ATXYZ(1,I), 3)
  20  CONTINUE
      DO 300 I = 1,NAT
      CALL MAT6XV (FRAC2C, ATXYZ(1,I), ATXYZ(1,I))
  300 CONTINUE
      DO 110 N = 1,NAT
      CALL KERNAB (ATXYZ(1,N), CARXIN(1,N), 3 )
      IZATOM(N) = IZAT(N)
  110 CONTINUE
      CALL KERNAB(XYZT, XYZTIN, 3)
      RETURN
      END
      SUBROUTINE REFMOD (NOMODL, CARXIN, XYZTN)
      DIMENSION                  CARXIN(3,NAT),  XYZTN(3)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IKLAD, IFILE(20))
      EQUIVALENCE (IPR1,IFILE(6)), (LIS1,IFILE(7))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1
      PARAMETER (MAXAT = 213)
      COMMON /CARATP/  NAT, CARXYZ(3,MAXAT), IZATOM(MAXAT), XYZT(3)
      PARAMETER (MAXATT = 993)
      COMMON /ATNAMA/ ATNAME(MAXATT)
      CHARACTER * 6   ATNAME
      PARAMETER (MAXVEC = 960)
      PARAMETER (MAXASV = 3600)
      PARAMETER (MAXIQ = 360)
      COMMON /VCTSET/  NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48),
     *                 NA1A2(2,MAXASV),
     *                 MINNVS,NVV,    VECT(6, MAXVEC), IPVECT(48),
     *                 INDXHV(MAXASV), INDVEC(MAXVEC),
     *                 IQTRVS(MAXIQ)
      COMMON /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48)
      COMMON /IMSEFU/  MSUM, AMINMN, AMINMX
      DIMENSION ROFXYZ(3,MAXAT), SMINML(48), VALISF(5), VAMI(5), FRMM(5)
      LOGICAL LALLOW(MAXASV)
      LOGICAL ASYMNW
      CHARACTER*8   REMARK(10)
      CHARACTER*80  RMRK80
      EQUIVALENCE  (REMARK(1),RMRK80)
      DATA FRMM, VAMI / 0.1, 0.2, 0.3, 0.5, 0.7, 5*0./
      DATA DMAX, DAVG /0.0, 0.0/
      DO 100  I = 1, 3
      XYZT(I) = XYZTN(I)
      DO 100  N = 1, NAT
      CARXYZ(I,N) = CARXIN(I,N)
 100  CONTINUE
      DO 120 N = 1, NAT
      CALL MAT6XV (CART2F, CARXYZ(1,N), ROFXYZ(1,N))
      CALL VMINV (ROFXYZ(1,N), XYZT, ROFXYZ(1,N), 3)
  120 CONTINUE
      CALL VECLCO (LALLOW, VMAX, LIS1)
      IF (VMAX .LT. 0.0) THEN
         NOMODL = -1
         RETURN
         ENDIF
      NTRPA  = 1
      DEMPT  = 0.6666667
      GRIDSZ = GRIDS1 / DEMPT
      DO 133 I = 1,3
      GRISTP(I) = GRIDSZ / CELL(I)
  133 CONTINUE
      CALL SCADIR
      CALL VECCAL (ROFXYZ, IZATOM, NAT, LALLOW, VMIN, ASYMNW)
          CALL VECSET (ASYMNW)
      CALL CALISF (ROFXYZ, NAT, MSUM, SMINML, VALISF)
              AMINMX = VALISF( 3)
           DO 1010 I=1,5
           MALL=NINT(FRMM(I)*NVV)
           IF (MALL.GT.200) MALL = 200
           CALL ISF(MALL,VECT,NVV,VAM)
 1010      VAMI(I)=VAM
      MALL=MSUM*NSMAX
      IF (MALL.GT.200) MALL=200
      IFOM = IFOMX(1,NOMODL)
      VAMI(1) = AMINMX
      VAMI(5) = FLOAT(IFOM) / 1000.
      AMINMX = VAMI(1) * VAMI(5) * 10.
      WRITE (RMRK80, FMT= '(''REMARK   '',I3,3F6.3,2I4,I3,5F6.3)')
     *       NOMODL, AMINMX, DMAX,DAVG, NASV, NVV, MALL, (VAMI(I),I=1,5)
      CALL ATMOUT (IKLAD, CCODE, REMARK, ATNAME, NAT, ROFXYZ, NAT)
      WRITE (IPR1, FMT='(
     *    '' TRAVEC on atom set TR='',I3, '' completed'')') NOMODL
      RETURN
      END
      SUBROUTINE VECLCO (LALLOW, VMAX, LIS1)
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      PARAMETER (MAXAT = 213)
      COMMON /CARATP/  NAT, CARXYZ(3,MAXAT), IZATOM(MAXAT), XYZT(3)
      PARAMETER (MAXVEC = 960)
      PARAMETER (MAXASV = 3600)
      PARAMETER (MAXIQ = 360)
      COMMON /VCTSET/  NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48),
     *                 NA1A2(2,MAXASV),
     *                 MINNVS,NVV,    VECT(6, MAXVEC), IPVECT(48),
     *                 INDXHV(MAXASV), INDVEC(MAXVEC),
     *                 IQTRVS(MAXIQ)
      EQUIVALENCE ( VECLEN(1,1), ASVECT(1,1) )
      DIMENSION VECLEN(2,MAXASV)
      LOGICAL LALLOW(MAXASV)
      NSMXX = NSYMM
      IF (ICENT .NE. 1)  NSMXX = 2 * NSMXX
      NVALLM = MAXASV/NSMXX - NAT
 101  VMAXRE = 1./VMAX
      ACVMAX = 0.
      N = 0
      NVALL = 0
      NATM1 = NAT -1
      DO 120 J =  1, NATM1
      J1 = J + 1
      DO 110 K = J1, NAT
      N = N + 1
      IF (N .GT. MAXASV) THEN
         WRITE(LIS1, FMT='(
     *      '' Dimension of LALLOW in VECLCO is too small!''/
     *      '' TRAVEC is bypassed.'')')
         VMAX  = - 99.
         RETURN
         ENDIF
      NALLOW = ISELFC ( CARXYZ(1,J), CARXYZ(1,K), VMAX, DSTNCE )
      IF (DSTNCE .LT. 0.7) THEN
                              LALLOW(N) = .FALSE.
                              VECLEN(1,N) = 0.1
                              VECLEN(2,N) = 10.
         GOTO 110
         ENDIF
      IF ( NALLOW .EQ. 1 )  THEN
                              NVALL     = NVALL + 1
                              LALLOW(N) = .TRUE.
                              VECLEN(1,N) = DSTNCE
                              VECLEN(2,N) = 1./DSTNCE
                              IF (DSTNCE .GT. ACVMAX)  ACVMAX = DSTNCE
                            ELSE
                              LALLOW(N) = .FALSE.
                              VECLEN(1,N) = VMAX
                              VECLEN(2,N) = VMAXRE
      ENDIF
  110 CONTINUE
  120 CONTINUE
      IF (NVALL .GT. NVALLM) THEN
              NHIG1 = NVALLM+1
              CALL DETSEQ(INDXHV, NHIG1, VECLEN,2,N, 2, 0)
              VMAX  = VECLEN(1,INDXHV(NHIG1)) - .0001
      IF (VMAX .LT. 9.0) WRITE (8, 346) NVALL, VMAX
  346 FORMAT (' TEMP: VMAX reset: NVALL=',I5,' new VMAX=', F6.2)
              GOTO 101
      ENDIF
      RETURN
      END
      SUBROUTINE DETSEQ ( INDXHV,NHIGST, ARRAY,NDIM1,NE, ISQ, N1)
      DIMENSION           INDXHV(NHIGST),  ARRAY(NDIM1,NE)
      IF (N1 .LT. NHIGST)  THEN
         NRE = N1
      ELSE
         NRE = NHIGST
         ENDIF
      NRE1 = NRE - 1
      N2 = N1 + 1
      DO 300   N = N2, NE
      IF ( N .GT. NHIGST ) THEN
         IF ( ARRAY( ISQ, N) .LE. ARRAY( ISQ, INDXHV(NRE)) ) GOTO 300
         ENDIF
      IF (N .LE. NHIGST)  THEN
         NRE1 = NRE
         NRE = N
         ENDIF
      IF (N    .LE. 0) CALL KERROR (' CALL SRSEQN N', 300, 'DETSEQ')
      IF (NRE1 .LE. 0) THEN
         NR = 1
      ELSE
         CALL SRSEQN (INDXHV, NRE1, ARRAY(1,N), ARRAY,NDIM1,NE, ISQ,NR)
         ENDIF
      DO 100  I = NRE1, NR, -1
  100 INDXHV(I+1) = INDXHV(I)
      INDXHV(NR) = N
  300 CONTINUE
      RETURN
      END
      SUBROUTINE SRSEQN (INDXHV,NRE,  EL,ARR2,I1,NE,      ISQ,  N)
      DIMENSION          INDXHV(NRE), EL(I1), ARR2(I1,NE)
      N  = NRE + 1
      NG = 0
110   IF (NG .EQ. N-1)   RETURN
      NLG = NG + (N - NG)/2
      IF (EL(ISQ) .GT. ARR2(ISQ,INDXHV(NLG)) )  THEN
          N  = NLG
      ELSE
          NG = NLG
      ENDIF
      GOTO 110
      END
      SUBROUTINE SCADIR
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      PARAMETER (MAXVEC = 960)
      PARAMETER (MAXASV = 3600)
      PARAMETER (MAXIQ = 360)
      COMMON /VCTSET/  NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48),
     *                 NA1A2(2,MAXASV),
     *                 MINNVS,NVV,    VECT(6, MAXVEC), IPVECT(48),
     *                 INDXHV(MAXASV), INDVEC(MAXVEC),
     *                 IQTRVS(MAXIQ)
      COMMON /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48)
      DIMENSION ISM(3,3,48)
      EQUIVALENCE ( ISM(1,1,1), D1G2F(1,1,1) )
      IF (ICENT.EQ.1) THEN
         IN2 = 1
      ELSE
         IN2 = -1
         ENDIF
      NS = 0
      DO 130 IN = 1,IN2,-2
      DO 120 NSA= 1,NSYMM
      NS = NS + 1
      DO 110  I = 1,3
      DO 110  J = 1,3
      ISM(I,J,NS) = IRSYMM(I,J,1) - (IRSYMM(I,J,NSA) * IN)
  110 CONTINUE
  120 CONTINUE
  130 CONTINUE
      NSMAX = NS
      CALL EQTRVS ( NSMAX, IQTRVS )
      DO 230 NS = 1,NSMAX
      DO 220 I=1,3
      DO 210 J=1,3
      D1G2F(I,J,NS) = ISM(I,J,NS) * GRISTP(J)
  210 CONTINUE
  220 CONTINUE
  230 CONTINUE
      RETURN
      END
      SUBROUTINE EQTRVS ( NSMAX, IQTRVS )
      PARAMETER (MAXIQ = 360)
      DIMENSION                    IQTRVS(MAXIQ)
      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 /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48)
      DIMENSION ISM(3,3,48), ISMEQ(3,3)
      EQUIVALENCE ( ISM(1,1,1), D1G2F(1,1,1) )
      INQ = 0
      DO 160 NI = 2, NSMAX
      IF ( MAXIQ-INQ .LT. 5 )  GOTO 200
      INQL = INQ + 1
      IQTRVS(INQL) = NI
      DO 140 NIM = 2, NI
      IF (NIM.NE.NI) THEN
         IS1 = 1
      ELSE
         IS1 = 2
         ENDIF
      DO 120 ISIM = IS1, NSYMM
      CALL IMAXMA ( IRSYMM(1,1,ISIM), ISM(1,1,NI), ISMEQ )
      IEQM = IARREQ( ISMEQ, ISM(1,1,NIM), 9 )
      IF (IEQM .EQ. 1  .OR.  IEQM .EQ. -1) THEN
                                   IF ( MAXIQ-INQL .LT. 4 )  GOTO 150
                                   INQL = INQL + 1
                                   IQTRVS(INQL) = NIM
                                   INQL = INQL + 1
                                   IQTRVS(INQL) = ISIM * IEQM
      ENDIF
  120 CONTINUE
  140 CONTINUE
  150 IF (INQL .NE. INQ+1)  THEN
                            INQL = INQL + 1
                            IQTRVS(INQL) = 0
                            INQ  = INQL
      ENDIF
  160 CONTINUE
  200 IQTRVS(INQ+1) = 0
      RETURN
      END
      SUBROUTINE IMAXMA( IA, IB, IAXIB )
      DIMENSION          IA(3,3), IB(3,3), IAXIB(3,3)
      DO 200 L = 1,3
      DO 100 K = 1,3
      IAXIB(L,K) = IA(L,1)*IB(1,K) + IA(L,2)*IB(2,K) + IA(L,3)*IB(3,K)
  100 CONTINUE
  200 CONTINUE
      RETURN
      END
      FUNCTION IARREQ( IA, IB, N)
      DIMENSION IA(N), IB(N)
      DO 200 I = 1, N
      IF ( IA(I) .NE. IB(I) )   THEN
                                DO 100 J = 1, N
                                IF ( IA(J) .NE. -IB(J) )  THEN
                                     IARREQ = 0
                                     RETURN
                                ENDIF
  100                           CONTINUE
                                IARREQ = -1
                                RETURN
      ENDIF
  200 CONTINUE
      IARREQ = 1
      RETURN
      END
      SUBROUTINE VECCAL ( FXYZ, IZATOM, NAT, LALLOW, VMIN, ASYMNW )
      DIMENSION FXYZ(3, NAT), IZATOM( NAT)
      PARAMETER (MAXASV = 3600)
      LOGICAL LALLOW(MAXASV)
      LOGICAL ASYMNW
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      PARAMETER (MAXVEC = 960)
      PARAMETER (MAXIQ = 360)
      COMMON /VCTSET/  NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48),
     *                 NA1A2(2,MAXASV),
     *                 MINNVS,NVV,    VECT(6, MAXVEC), IPVECT(48),
     *                 INDXHV(MAXASV), INDVEC(MAXVEC),
     *                 IQTRVS(MAXIQ)
      LOGICAL VMINCH,LPTB
      DIMENSION  RATC(3), ORIGIN(3),             SYQDAT(3)
      DATA ORIGIN / 0.,0.,0. /
      DATA NSBEF  / 0 /
      IF (NSBEF .EQ. 0) THEN
         NSBEF = 1
         CALL KERNZI (0, IPOASV, 48)
         ASYMNW = .TRUE.
         ENDIF
      VMINCH = .TRUE.
      LPTB = .FALSE.
      IF (ICENT.EQ.1) THEN
            IN2 = 1
       ELSE
            IN2 = -1
      ENDIF
      NASV = 0
      NS = 0
      DO 180  IN = 1,IN2,-2
      DO 170  NSA= 1,NSYMM
      NS = NS + 1
      NALL = 0
      DO 160  J = 1, NAT
      CALL SYMEQU (NSA, 1, 0, IN, .TRUE., FXYZ(1,J),  RATC, SYQDAT)
      J1 = J
      IF (NS .EQ. 1)  J1 = J + 1
      DO 130  K = J1, NAT
      IF ( J .NE. K )                  NALL = NALL + 1
      IF (NALL .EQ. 0) THEN
         LPTB = .FALSE.
      ELSE
         LPTB = LALLOW(NALL)
         ENDIF
      IF (LPTB .OR. J .EQ. K)  THEN
         NASV = NASV + 1
         CALL VMINV ( FXYZ(1,K), RATC, ASVECT(1,NASV), 3)
         IF (ISELFG( ASVECT(1,NASV), ORIGIN, VMINCH, VMIN, VOUTSQ )
     *    .EQ.1) THEN
             NASV = NASV - 1
             GOTO 130
             ENDIF
         NA1A2(1,NASV) = J
         NA1A2(2,NASV) = K
         ASVECT(4,NASV) = IZATOM(J) * IZATOM(K)
         IF (K.EQ.J)  ASVECT(4,NASV) = ASVECT(4,NASV) / 2.
         IF (ICENT .EQ. 2) ASVECT(4,NASV) = 2. * ASVECT(4,NASV)
         ENDIF
  130 CONTINUE
  160 CONTINUE
      ASYMNW = ASYMNW .OR. IPOASV(NS).NE.NASV
      IPOASV(NS) = NASV
  170 CONTINUE
  180 CONTINUE
      RETURN
      END
      SUBROUTINE SYMEQU (NS, ITS, NLT, INV, FIRST, X, XEQ,  XS)
      LOGICAL                               FIRST
      DIMENSION                                    X(3), XEQ(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)
      IF (FIRST)  THEN
         DO 120  I2 = 1,3
         XS(I2) = 0.
         DO 110  I1 = 1,3
         IF      (IRSYMM(I2,I1,NS) .NE. 0) THEN
              IF (IRSYMM(I2,I1,NS) .EQ. 1) THEN
                                           XS(I2) = XS(I2) + X(I1)
              ELSE
                                           XS(I2) = XS(I2) - X(I1)
              ENDIF
         ENDIF
 110     CONTINUE
 120     CONTINUE
         IF (ITS .EQ. 1) CALL VPLUSV (XS, TSYMM(1,NS), XS, 3)
         CALL KERNAB (XS,  XEQ, 3)
      ELSEIF (INV .EQ. -1)  THEN
         XEQ(1) = -XEQ(1)
         XEQ(2) = -XEQ(2)
         XEQ(3) = -XEQ(3)
         RETURN
         ENDIF
      IF (NLT .GT. 1)     CALL VPLUSV ( XS, TLATT(1,NLT), XEQ, 3)
      IF (INV .EQ. -1) THEN
         XEQ(1) = -XEQ(1)
         XEQ(2) = -XEQ(2)
         XEQ(3) = -XEQ(3)
         ENDIF
      RETURN
      END
      FUNCTION ISELFG (X, Y, DMINCH, DMIN, DISTSQ)
      LOGICAL DMINCH
      DIMENSION X(3), Y(3)
      DIMENSION  DM(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)
      DATA  DMINSQ  /1.0/
      ISELFG=0
      IF ( DMINCH ) THEN
         DO 110 I=1, 3
            DM(I)=ABS (RCELL(I)*DMIN)
  110    CONTINUE
         DMINSQ=DMIN*DMIN
         DMINCH=.FALSE.
      ENDIF
      DO 120 I=1, 3
      D(I)=X(I)-Y(I)-ANINT (X(I)-Y(I))
      IF (ABS (D(I)).GT.DM(I)) RETURN
  120 CONTINUE
      DISTSQ=0.0
      DO 130 I=1, 3
         DISTSQ=DISTSQ+
     *          D(I)*(RRMAT(1,I)*D(1)+RRMAT(2,I)*D(2)+RRMAT(3,I)*D(3))
  130 CONTINUE
      IF (DISTSQ.LE.DMINSQ) THEN
         ISELFG=1
      ENDIF
      RETURN
      END
      SUBROUTINE VECSET (ASYMNW)
      LOGICAL            ASYMNW
      PARAMETER (MAXVEC = 960)
      PARAMETER (MAXASV = 3600)
      PARAMETER (MAXIQ = 360)
      COMMON /VCTSET/  NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48),
     *                 NA1A2(2,MAXASV),
     *                 MINNVS,NVV,    VECT(6, MAXVEC), IPVECT(48),
     *                 INDXHV(MAXASV), INDVEC(MAXVEC),
     *                 IQTRVS(MAXIQ)
      COMMON /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48)
      LOGICAL          OWCINP
      OWCINP = .FALSE.
      CALL OVLTAB
      IF ( ASYMNW ) CALL SELVEC
      ASYMNW = .FALSE.
      DO 120  J = 1, NVV
      JA = INDXHV(J)
      DO 110  I = 1,3
      VECT(I,J) = ASVECT(I,JA)
  110 CONTINUE
      VECT(4,J) = ASVECT(5,JA)
  120 CONTINUE
      RETURN
      END
      SUBROUTINE OVLTAB
      PARAMETER (MAXVEC = 960)
      PARAMETER (MAXASV = 3600)
      PARAMETER (MAXIQ = 360)
      COMMON /VCTSET/  NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48),
     *                 NA1A2(2,MAXASV),
     *                 MINNVS,NVV,    VECT(6, MAXVEC), IPVECT(48),
     *                 INDXHV(MAXASV), INDVEC(MAXVEC),
     *                 IQTRVS(MAXIQ)
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      LOGICAL FIRST, ALLSEQ
      LOGICAL   CONOVL, EQUIVV
      DIMENSION VEXYZ(3), SYQDAT(3)
      INW = 0
      NVECT1 = 1
      LHP = 0
      DO 99 NVSET = 1, NSMAX
      IF (1 .LE. IPOASV(NVSET) )  THEN
         NVSET1 = NVSET
         GOTO 100
         ENDIF
  99  CONTINUE
      RETURN
 100  CONTINUE
      DO 101  NV = NVECT1, NASV
          ASVECT(5,NV) = ASVECT(4,NV)
          ASVECT(6,NV) = 0.0
 101  CONTINUE
      DO 1100 NVSET = NVSET1, NSMAX
          IF (NVSET .NE. NVSET1) NVECT1= IPOASV(NVSET-1) + 1
          NVEND = IPOASV(NVSET)
      DO  1000   NV = NVECT1, NVEND
          NVA = NV - 1
         LHP = NV - 1
         IOVLB1 = 0
         IOVLB2 = 0
      NS = 1
      NLT= 1
      INV= 1
      FIRST = .TRUE.
      ALLSEQ = .FALSE.
 111  CALL SYMEQU (NS,0,NLT,INV, FIRST, ASVECT(1,NV), VEXYZ, SYQDAT)
      INVXNS = INV * NS
      I1 = 1
      DO 130 IVS = 1, NVSET
          CALL GEQTVS (NVSET, IVS, INVXNS, CONOVL)
      IF (.NOT. CONOVL) GOTO 130
         IF (INW .NE. 5) THEN
              INW  =   5
              ENDIF
      IF (IVS .NE.1 ) I1   = IPOASV(IVS-1) + 1
                      IEND = IPOASV(IVS)
      IF (IEND .GT. NVA) IEND = NVA
      DO 120 I = I1,  IEND
      IF ( ISELGG( VEXYZ, ASVECT(1,I), RMAX, RR2 )
     *     .EQ. 1 ) THEN
        EQUIVV = I .EQ. NV
        W1 =ASVECT(INW,NV)
        W2 =ASVECT(INW,I)
        CALL COVERW(ASVECT(4,NV), W1, ASVECT(4,I), W2, EQUIVV, RR2)
        ASVECT(INW,NV) = W1
        ASVECT(INW,I) = W2
         IF (INV .EQ. 1)  THEN
            INS = NS
         ELSE
            INS = NS + NSYMM
            ENDIF
         IOVLB1 = INS
         IOVLB2 = NLT
         ENDIF
  120 CONTINUE
  130 CONTINUE
      NVA = NV
      CALL NEXSYM (NS,NLT,INV, NSYMM,NLATT, FIRST, ALLSEQ)
      IF (.NOT. ALLSEQ)  GOTO 111
 1000 CONTINUE
 1100 CONTINUE
      IOVLB1 = 0
      IOVLB2 = 100
      RETURN
      END
      SUBROUTINE GEQTVS (NVSET, IVS, INS, CONOVL)
      LOGICAL CONOVL
      PARAMETER (MAXVEC = 960)
      PARAMETER (MAXASV = 3600)
      PARAMETER (MAXIQ = 360)
      COMMON /VCTSET/  NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48),
     *                 NA1A2(2,MAXASV),
     *                 MINNVS,NVV,    VECT(6, MAXVEC), IPVECT(48),
     *                 INDXHV(MAXASV), INDVEC(MAXVEC),
     *                 IQTRVS(MAXIQ)
      IF (NVSET .EQ. 1) THEN
          CONOVL = .TRUE.
          RETURN
      ENDIF
      IF (NVSET .EQ. IVS .AND. INS .EQ. 1) THEN
          CONOVL = .TRUE.
          RETURN
      ENDIF
      CONOVL = .FALSE.
      INQL = 0
  101 INQ1 = INQL + 1
      IF (IQTRVS(INQ1) .EQ. 0)  THEN
          RETURN
      ENDIF
      IF (IQTRVS(INQ1) .LT. NVSET)  THEN
  102     INQL = INQL + 1
          IF (IQTRVS(INQL) .NE. 0    )  GOTO 102
            GOTO 101
      ENDIF
      IF (IQTRVS(INQ1) .GT. NVSET)         RETURN
      INQ1 = INQ1 + 1
      DO 200 INQ = INQ1, MAXIQ, 2
         IF (IQTRVS(INQ) .EQ. IVS) THEN
             IF (IQTRVS(INQ+1) .EQ. INS) THEN
                 CONOVL = .TRUE.
                 RETURN
             ENDIF
          ELSE
            IF (IQTRVS(INQ) .EQ. 0  .OR. IQTRVS(INQ) .GT. IVS)   RETURN
          ENDIF
 200         CONTINUE
      RETURN
      END
      SUBROUTINE COVERW( WI1, W1, WI2, W2, EQUIVV, RR2)
      LOGICAL                              EQUIVV
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
           IF ( RR2 .LE. RMAX2 )  THEN
             G = RR2/DEL + 1.
             IG = G
             F = G - FLOAT(IG)
             OVRLAP = TAB(IG) + (TAB(IG+1) - TAB(IG)) * F
             W1  = W1       + OVRLAP * WI2
             IF (.NOT. EQUIVV)
     *       W2  = W2       + OVRLAP * WI1
           ENDIF
      RETURN
      END
      SUBROUTINE NEXSYM (NS, NLT, INV, NSYMM, NLATT, SMOD, ALLSEQ)
      LOGICAL                                        SMOD, ALLSEQ
      IF (INV .EQ. 1) THEN
          INV = -1
          SMOD = .FALSE.
          GOTO 110
      ENDIF
      IF (INV .EQ. -1) INV = 1
      IF     (NLT .NE. 0)     THEN
          IF (NLT .GE. NLATT) THEN
              NLT = 1
          ELSE
              NLT = NLT + 1
              SMOD = .FALSE.
              GOTO 110
          ENDIF
      ENDIF
      NS = NS + 1
      SMOD   = .TRUE.
 110  ALLSEQ =  NS .GT. NSYMM
      RETURN
      END
      SUBROUTINE SELVEC
      COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1
      PARAMETER (MAXVEC = 960)
      PARAMETER (MAXASV = 3600)
      PARAMETER (MAXIQ = 360)
      COMMON /VCTSET/  NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48),
     *                 NA1A2(2,MAXASV),
     *                 MINNVS,NVV,    VECT(6, MAXVEC), IPVECT(48),
     *                 INDXHV(MAXASV), INDVEC(MAXVEC),
     *                 IQTRVS(MAXIQ)
      COMMON /IMSEFU/  MSUM, AMINMN, AMINMX
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      LOGICAL    DMICH
      DIMENSION  NDELV(48)
      PARAMETER (IFRAC = 1)
      PARAMETER (MXV = 100)
      PARAMETER (MSUMI = 3)
      DATA  MINASV,MINNV2,MXAV1,MXAV2,MXAV4 /0,0,24, 48, IFRAC*MXV/
      MXAV3 = IFRAC*MXAV2
      IF (MXAV2 .GT. MAXVEC/NSMAX) THEN
          MXAV2=MAXVEC/NSMAX
          IF (MXAV1 .GE. MXAV2) MXAV1=MXAV2-1
          MXAV3=IFRAC*MXAV2
      ENDIF
      MINASV = MAXASV
      MAXXAV = 0
      J1 = 0
      DO 110 NS = 1, NSMAX
      NASVCS = IPOASV(NS) - J1
      IF (MINASV .GT. NASVCS) MINASV = NASVCS
      IF (MAXXAV .LT. NASVCS) MAXXAV = NASVCS
      J1 = IPOASV(NS)
 110  CONTINUE
      IF       (MINASV.GT.MXAV4) THEN
                                     MAXNVS = MXV
      ELSE  IF (MINASV.GT.MXAV3) THEN
                                     MAXNVS = MINASV/IFRAC
      ELSE  IF (MINASV.GT.MXAV2) THEN
                                     MAXNVS = MXAV2
      ELSE  IF (MINASV.GT.MXAV1) THEN
                                     MAXNVS = MINASV
      ELSE
                                     MAXNVS = MAXXAV
              IF (MAXNVS .GT. MXAV1) MAXNVS = MXAV1
      ENDIF
      IF (MAXNVS .GT. MAXVEC/NSMAX)  MAXNVS = MAXVEC/NSMAX
      J1 = 0
      IF ( MINASV .GT. MXAV2)  THEN
                               MINVCS = MXAV2
      ELSE IF ( MINASV .GT. MXAV1) THEN
                               MINVCS = MINASV
      ELSE
                               MINVCS = MXAV1
      ENDIF
      DO 120 NS = 1, NSMAX
      NDELV(NS) = IPOASV(NS) - J1 - MINVCS
      IF (NDELV(NS) .LT. 0) NDELV(NS) = 0
      J1 = IPOASV(NS)
 120  CONTINUE
      MINNVS = MAXNVS
      MINNV2 = MAXNVS
      DMICH =.TRUE.
      DMIN  = RMAX * 0.75
      JA1   = 1
      JVEC1 = 1
      DO 500 NS = 1, NSMAX
      IF (NS .NE. 1)  THEN
          JA1   = IPOASV(NS-1) + 1
          JVEC1 = IPVECT(NS-1) + 1
      ENDIF
      NASVCS = IPOASV(NS) - JA1 + 1
      NHIGST = NASVCS
      CALL DETSEQ (INDXHV(JVEC1),NHIGST, ASVECT(1,JA1),6,NASVCS, 5,0)
         J = JVEC1
        JJ = JVEC1
      NRESTA = NASVCS
      IF (MINASV .LE. MXAV2) THEN
         NDVMIN = NDELV(NS)
      ELSE
         NDVMIN = NASVCS - MAXNVS
         ENDIF
      NCLOSE = 0
  200 CONTINUE
      IF (NRESTA+NCLOSE .EQ. NDVMIN  .OR.  NRESTA .EQ. 0)   GOTO 401
         JA = INDXHV(JJ) + JA1 - 1
         JJ = JJ + 1
         NRESTA = NRESTA - 1
           INDXHV(J) = JA
           J = J + 1
      GOTO 200
  401 CONTINUE
          IF (MINNVS .GT. J-JVEC1)   MINNVS = J-JVEC1
          IF (NS.GT.1)  THEN
              IF (MINNV2 .GT. J-JVEC1)   MINNV2 = J-JVEC1
          ENDIF
          IPVECT(NS) = J - 1
          IF (NS.EQ.1)     INDVEC(1)= 0
          IF (NS.NE.NSMAX) INDVEC(J)= 0
  500 CONTINUE
      IF (MINASV .GT. MXAV2) THEN
            MAXNVS=MINNVS
            J1 =0
            J2 =0
            JA1=0
            DO  630  NS = 1,NSMAX
               DO  610 J= J1+1, J1+MINNVS
               J2 = J2+1
               INDXHV(J2)=INDXHV(J)
 610           CONTINUE
               J1=IPVECT(NS)
               IPVECT(NS)=J2
               IF(NS.NE.NSMAX) INDVEC(J2+1)= 0
               NDELV(NS) =IPOASV(NS)-JA1 - MINNVS
               JA1=IPOASV(NS)
 630        CONTINUE
      ENDIF
          NVV = IPVECT(NSMAX)
              IF (MSUM .GT. MINNV2*FRACM)  MSUM = MINNV2 * FRACM
              IF (MSUM .LT. MSUMI)   MSUM=MSUMI
              IF (MSUM .GT. MINNV2-2)  MSUM=MINNV2-2
              IF (MSUM .GT. MINNVS)
     *                                 MSUM=MINNVS
              IF (MSUM .LE. 0)         MSUM=1
      RETURN
      END
      SUBROUTINE CALISF(FXYZ,NAT,MSUM, SMINML,VALISF)
      DIMENSION FXYZ(3, NAT),  SMINML(NSMAX), VALISF(5)
      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 /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1
      PARAMETER (MAXATT = 993)
      COMMON /ATNAMA/ ATNAME(MAXATT)
      CHARACTER * 6   ATNAME
      PARAMETER (MAXVEC = 960, MAXASV = 3600, MAXIQ = 360)
      COMMON /VCTSET/  NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48),
     *                 NA1A2(2,MAXASV),
     *                 MINNVS,NVV,    VECT(6, MAXVEC), IPVECT(48),
     *                 INDXHV(MAXASV), INDVEC(MAXVEC),
     *                 IQTRVS(MAXIQ)
      LOGICAL FIRST
      DATA  FIRST, VALUMN  /.TRUE., -1.0E+15/
      DATA  VALUMX / 1.0E+15 /
      AMNMIN = VALUMN
      ISFTYL = 1
      INDVEC(1) = 0
      DO 101 NS = 1, NSMAX-1
 101  INDVEC( IPVECT(NS)+1 ) = 0
      TMIM = VALUMX
      TSUM = 0.
      CALL SUPTAM ( AMNMIN, MSUM, VECT, NVV,
     *  IPVECT, NSMAX, INDVEC, SMINML, TMIM,TSUM)
                       MALL = NSMAX * MSUM
      IF (MALL.GT.200)  MALL = 200
      CALL ISF( MALL, VECT, NVV, TMINM)
      SUM2= 0.0
      SMIN2= SMINML(2)
      DO 140 NS = 2, NSMAX
      SUM2= SUM2+ SMINML(NS)
      IF (SMIN2 .GT. SMINML(NS))   SMIN2=SMINML(NS)
 140  CONTINUE
                      VALISF(1) = SMIN2
                      VALISF(2) = TMIM
                      VALISF(3) = TMINM
                  VALISF(4) = TSUM
                      VALISF(5) = SUM2
      IF (FIRST) THEN
          FIRST = .FALSE.
      JA1 = 0
      JS1 = 0
      DO 300 NS = 1, NSMAX
      NAVSET = IPOASV(NS)-JA1
         JA1 = IPOASV(NS)
      NSVSET = IPVECT(NS)-JS1
         JS1 = IPVECT(NS)
 300  CONTINUE
      ENDIF
      INDVEC(1) = 0
      DO 111 NS = 1, NSMAX-1
 111  INDVEC( IPVECT(NS)+1 ) = 0
      RETURN
      END
      SUBROUTINE ISF( M, VECT, NVV, TMINM)
      DIMENSION          VECT(6,NVV), INXLPW(200)
      DO 110 N = 1,NVV
 110  VECT(5,N)=-VECT(5,N)
      CALL DETSEQ(INXLPW,M, VECT, 6, NVV, 5, 0)
      DO 120 N = 1,NVV
 120  VECT(5,N)=-VECT(5,N)
        TSUMP = 0.0
        TSUMW = 0.0
        DO 210 IN = 1,M
        N = INXLPW(IN)
        TSUMP = TSUMP + VECT(6,N)
        TSUMW = TSUMW + VECT(4,N)
 210    CONTINUE
        TMINM = TSUMP/TSUMW
      RETURN
      END
      SUBROUTINE SUPTAM ( AMINMN, MSUM, VECT, NVV,
     *   IPVECT, NSM, INDVEC, SMINML, TMIMAP, TSUMAP)
      DIMENSION VECT(6,NVV), IPVECT(NSM), INDVEC(NVV), SMINML(NSM)
      LOGICAL TDONE
      NS1 = 1
      DO 400  NS = NS1, NSM
      IF ( TDONE ( AMINMN, TMIMAP) ) THEN
         SMINML(NS) = 0.0
         GOTO 400
         ENDIF
      IF (NS. NE. 1) THEN
                       J1 = IPVECT(NS-1) + 1
                     ELSE
                       J1 = 1
      ENDIF
      NVECS = IPVECT(NS) - J1 + 1
      CALL MINMVS (MSUM, AMINMN,VECT(1,J1),NVECS,INDVEC(J1), SMINML(NS))
                         WSMINM = SMINML(NS)
      IF (WSMINM .LT. TMIMAP) TMIMAP = WSMINM
  400 CONTINUE
      RETURN
      END
      SUBROUTINE MINMVS (MSUM, AMINMN, VECT, NVECS, INDVEC, SMINML)
      DIMENSION VECT(6,NVECS),INDVEC(NVECS)
           DO 110  N = 1, NVECS
  110      INDVEC(N) = N
      SUMP = 0.
      SUMW = 0.
      DO 200  JSEQ = 1, NVECS
         I = INDVEC(JSEQ)
         CALL RDFUN ( VECT(1,I), PFUNF )
         VECT(6,I) =  PFUNF
         VECT( 5,I) =  VECT(6,I) / VECT( 4,I)
         CALL UPISF (SMINML, SUMP, SUMW, JSEQ, MSUM, VECT,
     *                                              INDVEC, NVECS)
  200 CONTINUE
      RETURN
      END
      SUBROUTINE UPISF ( SMINML, SUMP, SUMW, J, M,
     *                   VECT,          INDVEC, NVECS )
      DIMENSION          VECT(6,NVECS), INDVEC( NVECS )
      IJ = INDVEC(J)
      IF (J.GT.M) THEN
         IM = INDVEC(M)
         IF ( VECT(5,IM) .LE. VECT(5,IJ) ) RETURN
            SUMP = SUMP + VECT(6,IJ) - VECT(6,IM)
            SUMW = SUMW + VECT(4,IJ) - VECT(4,IM)
      ELSE
            SUMP = SUMP + VECT(6,IJ)
            SUMW = SUMW + VECT(4,IJ)
         IF (J .LT. M) RETURN
         ENDIF
         SMINML = SUMP/SUMW
      IF (J.GT.M)  THEN
         MC=INDVEC(M)
         INDVEC(M)=INDVEC(J)
         INDVEC(J)=MC
         ENDIF
      PWMAX = VECT( 5,INDVEC(M) )
      IMAX  = M
      MMIN1 = M-1
      DO 100 I = 1,MMIN1
      II = INDVEC(I)
      IF (VECT(5,II) .GT. PWMAX) THEN
         PWMAX = VECT(5,II)
         IMAX  = I
         ENDIF
  100 CONTINUE
      IF (IMAX .EQ. M ) RETURN
      MC = INDVEC(M)
      INDVEC(M) = INDVEC(IMAX)
      INDVEC(IMAX) = MC
      RETURN
      END
      LOGICAL FUNCTION TDONE ( AMINMN, TMMAP)
      TDONE = .FALSE.
      TDONE = TMMAP .LT. AMINMN
      RETURN
      END
      SUBROUTINE RDFUN (ARG, FUNF)
      DIMENSION ARG(3)
      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 /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3)
      EQUIVALENCE (NX, NUM(1)), (NY, NUM(2)), (NXY, NUMXY)
      PARAMETER (NUMTAB = 200000)
      COMMON /  / TTT, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), TTT)
      DIMENSION  IFAR(3), INEAR(3), RARG(3), FM(3)
      EQUIVALENCE (IXFAR,IFAR(1)),  (IYFAR,IFAR(2)),  (IZFAR,IFAR(3))
      EQUIVALENCE (IXNEAR,INEAR(1)),(IYNEAR,INEAR(2)),(IZNEAR,INEAR(3))
      EQUIVALENCE (RX,RARG(1)),     (RY,RARG(2)),     (RZ,RARG(3))
      EQUIVALENCE (FMX,FM(1)),      (FMY,FM(2)),      (FMZ,FM(3))
      DO 301 J= 1, 3
      RARG(J) = AMOD(ARG(J),1.0)
      IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0
      IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0
  301 CONTINUE
      CALL SYMM (RX, RY, RZ)
      DO 599 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      IF (T) 540, 550, 550
  540 T = T - 1.
  544 I = IFIX(T)
      IF (I.GE.-LXYZ(IX)) GOTO 555
      T = T + 0.01
      GOTO 544
  550 I = IFIX(T)
      IF (I.LT.LXYZ(IX)) GOTO 555
      T = FLOAT(I) - 0.01
      GOTO 550
 555  F=T-FLOAT(I)
      IF (F) 560,590,570
 560       F=F+1.0
 570  IF (F-0.5) 590,580,580
 580  FM(IX) = 1. - F
      IFAR(IX)=I
      INEAR(IX)=I+1
      GOTO 599
 590  FM(IX) = F
      INEAR(IX)=I
      IFAR(IX)=I+1
 599  CONTINUE
      K111 = NXY * IZNEAR + NX * IYNEAR + IXNEAR - NUMC
      IJX = ITAB(K111)
      FUNF = FLOAT( IJX ) / 99.
      FUNNER=FUNF
      K211=K111-IXNEAR+IXFAR
      K121=K111+NX*(IYFAR-IYNEAR)
      K112=K111+NXY*(IZFAR-IZNEAR)
      IJX = ITAB(K211)
      FUNX = FLOAT( IJX ) / 99.
      IJX = ITAB(K121)
      FUNY = FLOAT( IJX ) / 99.
      IJX = ITAB(K112)
      FUNZ = FLOAT( IJX ) / 99.
      FUNF = FUNF * (1.-FMX-FMY-FMZ) + FUNX*FMX + FUNY*FMY + FUNZ*FMZ
      I1=IZFAR*NXY
      I2=IYFAR*NX
      K222 = I1 + I2 + IXFAR - NUMC
      K122=K222-IXFAR+IXNEAR
      K212=K222-I2+NX*IYNEAR
      K221=K222+NXY*IZNEAR-I1
      FMXY=FMX*FMY
      FMXZ=FMX*FMZ
      FMYZ=FMY*FMZ
      FMXYZ=FMX*FMYZ
      IJX = ITAB(K222)
      FUNFAR = FLOAT( IJX ) / 99.
      T1=FMYZ-FMXYZ
      IJX = ITAB(K122)
      FUNYZ = FLOAT( IJX ) / 99.
      T2=FMXZ-FMXYZ
      IJX = ITAB(K212)
      FUNXZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K221)
      FUNXY = FLOAT( IJX ) / 99.
      FUNF=FUNF+ FMXYZ*FUNFAR + T1*FUNYZ + T2*FUNXZ +
     1(FMXY-FMXYZ)*FUNXY+FUNNER*(T1+FMXZ+FMXY) - FUNZ*(T2+FMYZ)
     1 -FUNY*(T1+FMXY) - FUNX*(T2+FMXY)
      RETURN
      END
      SUBROUTINE SYMM (X, Y, Z)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      EQUIVALENCE (KLAUE,  KEYS(6))
      GOTO (5, 15, 25, 35), KLAUE
   5  IF (X.GE.0.0) RETURN
      X = -X
      Y = -Y
      Z = -Z
      RETURN
   15 Y = ABS(Y)
      IF (X.GE.0.0) RETURN
      X = -X
      Z = -Z
      RETURN
   25 X = ABS(X)
      Y = ABS(Y)
      Z = ABS(Z)
      RETURN
   35 Z = ABS(Z)
      IF (X.GE.0.0) RETURN
      X = -X
      Y = -Y
      RETURN
      END
      SUBROUTINE SQMODL (MMOD, INHVAM, MMODB)
      DIMENSION INHVAM(MMOD)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IATOMS, IFILE(1))
      EQUIVALENCE (IATOLD, IFILE(2)), (IDDSY, IFILE(3))
      EQUIVALENCE (ICOND, IFILE(4))
      EQUIVALENCE (IKLAD, IFILE(20))
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8))
      COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1
      DIMENSION VAMINM(50), VAMI(5)
      CHARACTER *6  REMARK(1)
      CHARACTER *6 CBOTS, TBOTS
      DATA REMARK /'REMARK'/
      REFMAM = .75
      WRITE (LIS2, FMT='('' REFMAM ='',F5.2)') REFMAM
         WRITE(LIS1,FMT='('' Results for all input models, sorted'',
     *      '' on CFOM = TRACOR * TRAVEC * 10'')')
         WRITE(LIS1,FMT='('' Shift #            FOM    FOM   '')')
         WRITE(LIS1,FMT='('' TV= TR=    CFOM TRACOR TRAVEC   '',
     *      '' R2 '')')
         WRITE(LIS2,FMT='('' Results for all input models, sorted'',
     *      '' on CFOM = TRACOR * TRAVEC * 10'')')
         WRITE(LIS2,FMT='('' Shift #            FOM    FOM   '',
     *      ''      Nr of Vectors    Select for MIN(%)'')')
         WRITE(LIS2,FMT='('' TV= TR=    CFOM TRACOR TRAVEC   '',
     *      '' R2    all sel MIN      20%   30%   50% '')')
      REWIND IKLAD
      REWIND IATOMS
      NRMODL = 0
      DO 510 N = 1, MMOD
 501  CALL KERINA(IKLAD, REMARK, 1, LEND)
      IF (LEND .EQ. -1) GOTO 511
      IF (NLUSER(1).LE.0) GOTO  501
      NRMODL = NRMODL +1
      VAMINM(NRMODL) = FNUM(2)
 510  CONTINUE
 511  N=NRMODL
      CALL DETSEQ (INHVAM, NRMODL, VAMINM, 1, N, 1, 0)
      IT = MAX0 (0, 10000 * (ITIME(1)-1900) + 100 * ITIME(2) + ITIME(3))
      IBOX = 0
      DO 531 N=1,NRMODL
      REWIND IKLAD
      DO 521 I=1,INHVAM(N)
 520  CALL KERINA(IKLAD, REMARK, 1, LEND)
      IF (LEND .EQ. -1) GOTO 531
      IF (NLUSER(1).LE.0) GOTO  520
 521  CONTINUE
      READ (CHIN, FMT= '(9X,I3,3F6.3,2I4,I3,5F6.3)')
     *       NOMODL, AMINMX, DMAX,DAVG, NASV, NVV, MALL, (VAMI(I),I=1,5)
      R2X = FLOAT(IFOMX(3, NOMODL)) / 1000.
      WRITE (LIS1, FMT= '(2I4,F8.3,2F7.3,    F7.3 )')
     *   N, NOMODL, AMINMX, VAMI(5), VAMI(1), R2X
      WRITE (LIS2, FMT= '(2I4,F8.3,2F7.3,1X, F6.3, 2X, 3I4, 4X,4F6.3)')
     *   N, NOMODL, AMINMX, VAMI(5), VAMI(1), R2X,
     *   NASV, NVV, MALL, (VAMI(I),I=2,4)
      IFOM = NINT (AMINMX * 1000.)
      IBOTS = IFOMX(2, NOMODL)
      IF (N .EQ. 1) IBOX = IBOTS
      IF (IBOTS .GT. 0) THEN
         CALL KERI2C (IBOTS, TBOTS, 2)
         CBOTS(5:6) = TBOTS(1:2)
         CBOTS(1:4) = ' X= '
      ELSE
         CBOTS = ' '
         ENDIF
      WRITE (IATOMS, 102) CCODE, IT, KEYS(13), N, R2X, IFOM, CBOTS
  102 FORMAT ('ATOMS ', A6, ' < TRAVEC', I7,
     *    ' RUN', I4, ' TV=', I3,' R2= ', F6.3, ' FOM=', I5, A6)
      WRITE(CHIN, FMT= '(''REMARK from TR='',I3,''     FOM based '',
     * ''on TRACOR+TRAVEC :'',F6.3, ''  (not on R2)'')') NOMODL, AMINMX
 522  WRITE (IATOMS, FMT='(A80)') CHIN
      CALL KERINA(IKLAD, REMARK, 1, LEND)
      IF (LEND .NE.  4) GOTO 522
      WRITE (IATOMS, FMT='(''END'')')
 531  CONTINUE
      CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
      REWIND IKLAD
      CALL FILCLO (IKLAD, 'DELETE')
      IF (IBOX .GT. 0) GOTO 801
      WRITE (LIS1, 710)
      WRITE (LIS2, 710)
  710 FORMAT (/
     * ' The first accepted parameter set is transferred to PHASEX.' /
     * ' All accepted parameter sets are written to the ATOLD file,' /
     * ' for use in case the first set does not lead to the correct'/
     * ' structure.' )
      WRITE (LIS2, 711)
  711 FORMAT (
     * ' Note:' /
     * ' All accepted parameter sets are written to the ATOMS file,' /
     * ' but  DDMAIN + PHASEX  are going to use only the first set.')
      RETURN
  801 CONTINUE
      WRITE (IPR1, 810)
      WRITE (LIS1, 810)
      WRITE (LIS2, 810)
  810 FORMAT (/
     * ' All parameter sets are written to the  ATOMS file,  sorted.' /
     * ' The first and best  ATOMS  set, however, is not acceptable.' /
     * ' The molecule collides with symmetry related molecules  !!!!' /
     * ' You may decide what is best to do next ...     We will STOP' /
     * ' If the molecule is on a  symmetry  element,  then  use your' /
     * ' local software to generate a  symmetry independent fragment' /
     * ' to be stored in the ATOMS file, and then continue with' /
     * ' DIRDIF CCODE PHASEX  for completion of the structure. !!!!!' )
      CALL FILINQ (IDDSY, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IDDSY, FMT='(''STOP'')')
      CALL FILCLO (IDDSY, 'KEEP')
      CALL KEPROX
      RETURN
      END
      FUNCTION  ISELFC( XC1, XC2, DMIN, DOUT )
      DIMENSION  XC1(3), XC2(3), D(3)
      ISELFC = 0
      DO 100 I = 1,3
      D(I) = ABS( XC1(I) - XC2(I) )
      IF ( D(I) .GT. DMIN )  RETURN
 100  CONTINUE
      DMINSQ = DMIN * DMIN
      DOUT =   D(1)*D(1) + D(2)*D(2) + D(3)*D(3)
      IF (DOUT .GT. DMINSQ)  RETURN
      DOUT = SQRT( DOUT )
      ISELFC = 1
      RETURN
      END
      FUNCTION ISELGG (X, Y, DMAX1, DISTSQ)
      DIMENSION X(3),Y(3)
      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  DM1(3), D(3)
      LOGICAL DMA1CH
      DATA  DMASQ1 /0.0/
      DATA  DMA1CH /.TRUE./
      IF ( DMA1CH) THEN
         DO 110 I=1, 3
            DM1(I)=ABS (RCELL(I)*DMAX1)
  110    CONTINUE
         DMA1CH=.FALSE.
         DMASQ1=DMAX1*DMAX1
         ENDIF
      ISELGG = 0
      DO 130 I=1, 3
         D(I)=X(I)-Y(I)-ANINT (X(I)-Y(I))
            IF ( ABS(D(I)) .GT. DM1(I) ) RETURN
  130 CONTINUE
      DISTSQ=0.0
      DO 140 I=1, 3
         DISTSQ=DISTSQ+
     *          D(I)*(RRMAT(1,I)*D(1)+RRMAT(2,I)*D(2)+RRMAT(3,I)*D(3))
  140 CONTINUE
      IF (DISTSQ .GT. DMASQ1)   RETURN
      ISELGG=1
      RETURN
      END
      SUBROUTINE VPLUSV (V1, V2, VOUT, N)
      DIMENSION V1(N), V2(N), VOUT(N)
      DO 110 I = 1, N
      VOUT(I) = V1(I) + V2(I)
 110  CONTINUE
      RETURN
      END
      SUBROUTINE VMINV (V1, V2, VOUT, N)
      DIMENSION          V1(N), V2(N), VOUT(N)
      DO 110 I = 1, N
        VOUT(I) = V1(I) - V2(I)
 110  CONTINUE
      RETURN
      END
      SUBROUTINE ATMOUT (IUNIT, CCODE, REMARK, ATNAME, NNAMS, XYZ, NAT)
      CHARACTER*6               CCODE,         ATNAME(NNAMS)
      CHARACTER*8                      REMARK(10)
      DIMENSION  XYZ(3,NAT)
      IF (REMARK(1) .NE. 'REMARK  ') THEN
      WRITE(IUNIT,FMT='(''ATOMS'',5X,A6,6A8)') CCODE,(REMARK(I),I=1,6)
      ELSE
         WRITE(IUNIT,FMT='(''ATOMS'', 5X,A6)' ) CCODE
         WRITE (IUNIT, FMT='(10A8)' ) REMARK
         ENDIF
      NAMI = 1
      DO 110 I = 1,NAT
      IF (I.LE.NNAMS) NAMI=I
      WRITE (IUNIT, FMT='(''ATOM  '', A6, 3F10.5)' )
     *   ATNAME(NAMI), (XYZ(J,I),J=1,3)
  110 CONTINUE
      WRITE (IUNIT, FMT='(''END'')')
      RETURN
      END
