      PROGRAM PATTY
********************************************** Last update: 11 Nov. 1999
********************************************** Source: G.Admiraal +HB+CS
C Subroutine SYMM is common to ORIENT, PATTY and TRAVEC
C Warning: this subroutine maybe different: do not reject : check!
C NAT=1 naar DDLOG: beslissing hoort in DDMAIN wegens verdere selectie
* backup: PATTY.FEB
 
* PATTY LOG of recent modifications (last on top
      PARAMETER (MXPKS=150, MXPEAK=MXPKS+100)
      DIMENSION XP(5, MXPEAK)
      PARAMETER (MXHEAV=20,MXSTSX=30)
      DIMENSION XZ(5*MXHEAV+5,MXSTSX)
      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)), (IPDEK, IFILE(14))
      EQUIVALENCE (IPR1, IFILE(6)), (LIS2, IFILE(8))
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /ELEMB/ ACELTY(10)
      CHARACTER*2 ACELTY
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (MXPP=128)
      COMMON /PATPKS/ VP(4,MXPP), NVPS, SC2DEK, PATADD
      CALL KEPROG ('PATTY')
      WRITE (LIS2, FMT = '('' Last PATTY update: 11 Nov. 1999'')')
      CALL PREPRO
      CALL ELEMS
      CALL PATHVY (PFMAPX, PORIGI, SCPAT, PLIM, VP,NVPS, XZ, NSTSXZ)
      IF (NSTSXZ.GE.1 .AND. NCONS.LE.2) GOTO 110
      PATAD = 25.
      CALL PREDEK (PFMAPX, PORIGI, SCPAT, PLIM, SCADEK, PATAD, PATP)
      SC2DEK=SCADEK
      PATADD=PATAD
      CALL PATTIN
      WRITE (LIS1, FMT='('' Patterson origin height:'',12X,F10.1)')
     *   PORIGI
      WRITE (LIS1, FMT='('' Patterson height for a '',A2,''-'',A2,
     *   '' vector:'',F10.1)') ACELTY(1), ACELTY(1),
     *   SCPAT*NCELLZ(1)**2 + PATAD
      IF (LTHEAV .GT. 1)
     *   WRITE (LIS1, FMT='('' Patterson height for a '',A2,''-'',A2,
     *   '' vector:'',F10.1)') ACELTY(LTHEAV), ACELTY(LTHEAV),
     *   SCPAT*NCELLZ(LTHEAV)**2 + PATAD
      CALL REMORI
      CALL GETOVC
      CALL KERNZA (0.0, XP, 5*MXPEAK)
      CALL SYMMPK (XP, NOP)
      IF (NOP.EQ.0) CALL KERROR
     *   ('No peaks found in the symmetry map', 0, 'PATTY')
      CALL PROSPK (XP, NOP, XZ, NSTSXZ)
      IF (NSTSXZ .EQ. 0) THEN
         WRITE (LIS1, 106)
         WRITE (IPR1, 106)
  106 FORMAT(/' The results from the symmetry map are not acceptable:',
     */' Scaling errors? B too low? Wrong H.A. in CELL contents?'/)
         CALL KERROR ('No solution acceptable !', 106, 'PATTY')
         ENDIF
 110  CALL HCOOUT (XZ, NSTSXZ, 1)
      CALL KEPROX
      WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)')
      STOP 0
      END
      SUBROUTINE PREPRO
      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 (KLAUE, KEYS(6))
      EQUIVALENCE (ITPL, KEYS(7))
      EQUIVALENCE (FRACIN, KEYS(25))
      EQUIVALENCE (IATOMS,IFILE(1))
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (LIS2, IFILE(8))
      EQUIVALENCE (IFMAP, IFILE(17))
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      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 (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4)
      COMMON /MOVECS/ XCELL(3,MXNUP),NPCELL, NAXCEL(MXNUP),
     *                ASVECT(5,MAXASV),NASV
      CALL KERNZA (0.0, ASVECT, 5*MAXASV)
      CALL RDCRYS( ICRYS )
      CALL FILCLO( ICRYS, 'KEEP' )
      P1METH=.FALSE.
      IF (ICENT.EQ.1 .AND. NSYMM.EQ.1) P1METH=.TRUE.
      GOTO
     * (101,102,103,104,103,101,101,101,101,101,104,104,103,103), ILAUE
  101 KLAUE = 1
      GOTO 105
  102 IF (IUNIQ .EQ. 3) GOTO 104
      KLAUE = -2
      IF (IUNIQ .EQ. 1) GOTO 105
      KLAUE = 2
      GOTO 105
  103 KLAUE = 3
      GOTO 105
  104 KLAUE = 4
  105 CONTINUE
      ITPL = 10
      FRACIN=0.0
      RETURN
      END
      SUBROUTINE TERIVA (VARNAM, VALUE)
      CHARACTER*8        VARNAM
      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))
 101  WRITE(IPR1, FMT ='('' '',A8,'' ='',F10.2)')  VARNAM, VALUE
 102  WRITE(IPR1, FMT ='('' Do you want to change the value of '',
     *                     A8,''?  (Y or N)'')') VARNAM
      CALL KETERM (0, 1, KEND)
      IF (KEND .EQ. 24)  RETURN
      IF (KEND .EQ. 35) THEN
 110       WRITE(IPR1, FMT ='('' Give '',A6)')  VARNAM
           CALL KETERM (1, 0, KEND)
           IF (KEND .GE. 0) THEN
             VALUE = FNUM(1)
           ELSE
             GOTO 110
           ENDIF
           GOTO   101
      ELSE
           WRITE(IPR1, FMT ='('' Answer with Y or N!'')')
           GOTO   102
      ENDIF
      END
      SUBROUTINE TERMYN (YES)
      LOGICAL            YES
      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))
 102  CALL KETERM (0, 1, KEND)
      YES=.FALSE.
      IF (KEND .EQ. 24)  RETURN
      YES=.TRUE.
      IF (KEND .EQ. 35) RETURN
      WRITE(IPR1, FMT ='('' Answer with Y or N'')')
       GOTO   102
      END
      SUBROUTINE ELEMS
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /ELEMB/ ACELTY(10)
      CHARACTER*2 ACELTY
      COMMON /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 (ICRYS, IFILE(3)),(LIS1, IFILE(7))
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      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)
      CALL CELZAT (ACELTY, NCELTY, NCELLZ)
 100  AVZ = 0.0
      TATOMS= 0.0
      DO 110 N=1,NTYPE
      IF (NCELLZ(N).GT. 1.1) THEN
         AVZ = AVZ + NCELLZ(N)*NCELTY(N)
         TATOMS = TATOMS + NCELTY(N)
         ENDIF
 110  CONTINUE
      ZMAX = NCELLZ(1)
      AVZ =AVZ / TATOMS
      IF (TATOMS/IMULT.GT.8.0 .AND. ZMAX**2.LT.1.25*AVZ**2)
     *   CALL KERROR (' No heavy atom structure. Do not use PATTY',0,
     *   'ELEMS')
      ZHEVY = (AVZ + ZMAX)/2.
      IF (ZHEVY .GT. ZMAX-0.01) ZHEVY=ZMAX-0.01
      WRITE(LIS1,FMT='('' Define heavy atoms:'' /
     *   '' Heavy atoms   number in asym.unit   Z'')')
      IMULTP=IMULT
      IF (P1METH) IMULTP=NLATT
      AMULT = IMULTP
      AVZ=AVZ*TATOMS
      DO 127 NT=1,2
      NHEAVY = 0
      NCELH = 0
      NCELHS= 0
      DO 120 N=1,NTYPE
      NCELSP(N) = MOD(NCELTY(N),IMULTP)
      NASYMP(N) = NCELTY(N)/IMULTP
      IF (NCELSP(N).GT.0) NASYMP(N)=NASYMP(N)+1
      IF (NCELLZ(N) .GT. ZHEVY) THEN
         LTHEAV = N
         IF (ZHEVY**2 .GT. 0.75*NCELLZ(N)**2)  ZHEVY = 0.866*NCELLZ(N)
         NCONST(N) = NASYMP(N)
         NHEAVY = NHEAVY + NCONST(N)
         NCELH = NCELH + NCELTY(N)
         IF (ICENT.EQ.2 .AND. NCELH/NLATT.LT.3 .AND. N.EQ.1)  THEN
            IF (ZHEVY.GT.NCELLZ(2).AND.NCELLZ(2).GT.AVZ.AND.
     *      NCELLZ(1)**2.LT.2*NCELLZ(2)*NCELLZ(1)) ZHEVY=NCELLZ(N+1)-.01
            ENDIF
         AVZ = AVZ - NCELTY(N)*NCELLZ(N)
         NCELHS= NCELHS+ NCELSP(N)
         ENDIF
 120  CONTINUE
      LT1=0
      LTHV=LTHEAV
      NCONS=NHEAVY
      IF (NT.EQ.2) GOTO 127
      IF (TATOMS-NCELH.GT.0.99) AVZ = AVZ/(TATOMS-NCELH)
      IF (TATOMS/IMULTP.GT.8.0 .AND. ZMAX**2 .LT. 2.0*AVZ**2)
     *   CALL KERROR (' No heavy atom structure. Do not use PATTY',0,
     *   'ELEMS')
      IF (NHEAVY.GT.3) GOTO 128
      DO 125  L = LTHEAV+1,NTYPE-1
      IF (NCELLZ(L)**2 .GT. 2.5*AVZ**2) THEN
         IF (.5*NCELLZ(L)**2 .GT. NCELLZ(L+1)**2) THEN
            ZHEVY=NCELLZ(L)-0.1
            GOTO 127
            ENDIF
      ELSE
         GOTO 128
         ENDIF
 125  CONTINUE
      GOTO 128
 127  CONTINUE
 128  CONTINUE
      DO 129 N=1,LTHEAV
      WRITE(LIS1,FMT='(3X,A2, F22.2, I11)')
     *   ACELTY(N), NCELTY(N)/AMULT, NCELLZ(N)
 129  CONTINUE
      HEAVYN = NCELH/AMULT
      IF (.NOT.P1METH .AND.
     *   ICENT.EQ.1 .AND. NSYMM.EQ.2 .AND. ILAUE.LE.2) THEN
         NM=0
         DO 210 I=1,3
 210     IF (IRSYMM(I,I,2).EQ.-1) NM=NM+1
         IF (NM.LE.1 .OR. HEAVYN.GT.2.9) P1METH=.TRUE.
         IF (P1METH) GOTO 100
         ENDIF
      NELMS = NTYPE
      CALL FILINQ( ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) THEN
         WRITE(CHOUT, 130) CCODE
 130     FORMAT (' ERROR no CRYSDA file found for ', A6)
         CALL KERROR( CHOUT, 0, 'ELEMS')
         ENDIF
      DH1H2=2.7
      CALL RDCRYB(ICRYS, 'ELEM ', KEND)
      IF (KEND.EQ.1) THEN
         READ (CHIN,FMT='(14X,I6,20X,3F10.5)') NELECS, RAT1,RAT2,RAT3
         NELEC1 = NELECS
 211     CONTINUE
         IF (NELECS.GT.ZHEVY) DH1H2=AMIN1(DH1H2,2.*RAT1,2.*RAT2,2.*RAT3)
         CALL RDCRYB(ICRYS, 'ELEM ', KEND2)
         IF (KEND2.EQ.1) THEN
            READ (CHIN,FMT='(14X,I6,20X,3F10.5)') NELECS, RAT1,RAT2,RAT3
            IF (NELECS .NE. NELEC1) GOTO 211
            ENDIF
         ENDIF
      DH1H2=(DH1H2-0.2)*0.9
      CALL FILCLO( ICRYS, 'KEEP' )
      RETURN
      END
      SUBROUTINE PREDEK(PFMAPX, PORIGI,SCPAT, PLIM, SCADEK, PATAD, PATP)
      DIMENSION  PATP(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 (LIS2, IFILE(8))
      EQUIVALENCE (IDDL, IFILE(9)), (IPDEK, IFILE(14))
      EQUIVALENCE (SCAKEY,KEYS(26)),(SINGPK,KEYS(27)),(ORIGIN,KEYS(28))
      PARAMETER (PDEKX=254.)
      CALL LOGRD (IDDL, 'SINGPK', KLOG)
      IF (KLOG.LT.0) CALL KERROR('DDLOG file not available',-1,'PREDEK')
      IF (KLOG.EQ.0 .OR. NFNUM.NE.3) CALL KERROR
     *   ('DDLOG file:  SINGPK a/o ORIGIN missing',-1,'PREDEK')
      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,'PREDEK')
      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
  120 PATP(I) = AMIN1 (PATP(I), PATP(I-1) * (1. - 0.02 * FLOAT(I)))
      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'/
     * ' shape = 1.000', 8F6.3 )
      CALL PPROFI (PATP)
      SCADEK = (PDEKX-PATAD)/ PFMAPX
      SCAKEY = SCADEK
      PLIM = 0.25* PLIM * SCADEK + PATAD
      WRITE (LIS2, FMT='(/'' PLIM used for symmetry-map='',F9.2)') PLIM
      PORIGI = PORIGI * SCADEK + PATAD
      SCPAT = SCPAT * SCADEK
      RETURN
      END
      SUBROUTINE PPROFI (PATP)
      DIMENSION PATP(8)
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      DATA IMAX2, DELY, DEL2Y /0, 0.0, 0.0/
      DEL = 0.01
      TAB(1) = 1.
      IXL = 0
      I = 2
   36 RRR = SQRT(FLOAT(I) - 0.9999)
      IX = RRR
      IF (IX.EQ.IXL) GOTO 37
      IXL = IX
      TAB(I) = PATP(IX)
      IF (IX.EQ.7) GOTO 38
      DELY = PATP(IX+1) - PATP(IX)
      DEL2Y = 0.5 * ( PATP(IX+2) - PATP(IX+1) - DELY )
      GOTO 38
   37 DELX = RRR - FLOAT(IX)
      TAB(I) = PATP(IX) + DELX * DELY + DELX * (DELX-1.) * DEL2Y
   38 IF (TAB(I).GT.0.1) IMAX2 = I - 1
      I = I + 1
      IF (I.LE.50) GOTO 36
      IF (IMAX2.GT.48) IMAX2=48
      RMAX2 = FLOAT(IMAX2) / 100.
      RMAX = SQRT( RMAX2)
      RETURN
      END
      SUBROUTINE PATHVY (PFMAPX, PORIGI, SCPAT,PLIM, VP,NVPS,XZ,NSTSXZ)
      PARAMETER (MXHEAV=20,MXSTSX=30,MXPP=128)
      DIMENSION XZ(5*MXHEAV+5,MXSTSX), VP(4,MXPP)
      DIMENSION INXZ(MXSTSX), X1Z(5*MXHEAV+5)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      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 (IDDL, IFILE(9))
      EQUIVALENCE (IFMAP, IFILE(17))
      EQUIVALENCE (SCADEK, KEYS(26))
      EQUIVALENCE (ORFMAP, KEYS(28))
      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 ITLE(20)
      EQUIVALENCE (ITLE(18), FFTSC)
      INTEGER*2 LPAT1
      ZN2 = NCELLZ(1)**2
      SUM = 0.0
      DO 110 IE = 1, NELMS
      ZI2 = NCELLZ(IE)**2
      NI  = NCELTY(IE)/NLATT
      SUM = SUM + NI*ZI2
      IF (IE .LE. LTHEAV) ZN2 = ZI2
 110  CONTINUE
      CALL LOGRD (IDDL, 'SINGPK', KLOG)
      IF (KLOG.LT.0) CALL KERROR('DDLOG file not available',-1,'PATHVY')
      IF (KLOG.EQ.0 .OR. NFNUM.NE.3) CALL KERROR
     *   ('DDLOG file incorrect, SINGPK a/o ORIGIN missing',-1,'PATHVY')
      ORIGIN = FNUM(3)
      CALL FILCLO (IDDL, 'KEEP')
      CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ.NE.0) CALL KERROR
     *   ('Patterson file (FMAP) not found.', -1, 'PATHVY')
      READ (IFMAP) ITLE, IMAP, IHALF
      READ (IFMAP)
      READ (IFMAP) IBSEC, IBJ, IBNX, LPAT1
      CALL FILCLO (IFMAP, 'KEEP')
      ORFMAP = 6000.
      PORIGI = ORFMAP
      SCPAT=ORFMAP/SUM
      PHH = SCPAT * NCELLZ(1)**2
      IF (ICENT.EQ.2 .AND. NCELTY(1).GE.4) PHH=PHH+PHH
      PLIM = SCPAT * ZN2
      PLIM2=PLIM
      IF (ICENT.EQ.2) PLIM2=PLIM+PLIM
      PFMAPX = 8.* PHH
      CALL RDVECA (VP,NVPS,DH1H2)
      IF (NVPS.GT.1) PFMAPX= VP(4,2)
      IF (PFMAPX .GT. 0.8*ORFMAP) PFMAPX=0.8*ORFMAP
      NSTSXZ=0
      IF (NSYMM.NE.1 .OR. ICENT.NE.1) RETURN
      ISQ = 5*MXHEAV+3
      X1Z(1)=0.0
      X1Z(2)=0.0
      X1Z(3)=0.0
      X1Z(4)=1.0
      X1Z(5)=NCELLZ(1)
      X1Z(5*MXHEAV-1)=1.0
      X1Z(5*MXHEAV)=X1Z(5)*X1Z(5)
      X1Z(5*MXHEAV+1)=1.0
      X1Z(5*MXHEAV+3)=1.0*X1Z(5*MXHEAV)
      CALL EL2AR2 (X1Z, 5*MXHEAV+5, ISQ, XZ, MXSTSX, NSTSXZ, INXZ)
      NCO2=0
      IF (NCONST(1).GT.1)  NCO2=1
      IF (NCO2.EQ.0 .AND. LTHEAV.GT.1)  NCO2=2
      IF (NCO2.EQ.0)   RETURN
      X1Z(10)=NCELLZ(1)
      IF (NCELTY(1).LE.1) X1Z(10)=NCELLZ(2)
      X1Z(5*MXHEAV)=X1Z(5)**2+2*X1Z(10)*X1Z(5)+X1Z(10)**2
      NMXSTS=MXSTSX+1
      IF (NMXSTS.GT.NVPS) NMXSTS=NVPS
      DO 310 N=2,NMXSTS,1
      X1Z(6)=VP(1,N)
      X1Z(7)=VP(2,N)
      X1Z(8)=VP(3,N)
      X1Z(9)=1.0
      X1Z(10)=NCELLZ(NCO2)
      AMINM = VP(4,N)/(SCPAT*X1Z(10)*X1Z(5))
      X1Z(5*MXHEAV-1)=AMINM
      AM1=AMINM
      AM2=0.0
      IF (AM1.GT.1.3) THEN
         AM1=1.3
         AM2=(AMINM-1.3)*0.1
         ENDIF
      X1Z(5*MXHEAV+1)=2.0
      X1Z(5*MXHEAV+3)= (AM1+AM2) * X1Z(5*MXHEAV)
      CALL EL2AR2 (X1Z, 5*MXHEAV+5, ISQ, XZ, MXSTSX, NSTSXZ, INXZ)
 310  CONTINUE
      MXINXZ=MXSTSX
      CALL SORTIN(INXZ,MXINXZ, NSTSXZ, XZ, 5*MXHEAV+5, MXSTSX)
      RETURN
      END
      SUBROUTINE RDVECA (VEC,NVEC,DH1H2)
      PARAMETER  (MXPP=128)
      DIMENSION          VEC(4,MXPP)
      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 (IATOMS,IFILE(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
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      LOGICAL  READVC
      DIMENSION VECN(3), VEC000(3), DVEC(3)
      CHARACTER*6  LATM(1)
      DATA     LATM, VEC000 / 'ATOM  ', 0.,0.,0./
      READVC=.FALSE.
      NVEC=1
      VEC(1,1)=0.0
      VEC(2,1)=0.0
      VEC(3,1)=0.0
      VEC(4,1)=30254.
      DHAHB = DH1H2*0.8
      DHAHB2=DHAHB**2
      CALL FILINQ( IATOMS,'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR
     *   ('No ATOMS file (with Patterson pieks) found', 0, 'RDVECA')
 111  CALL KERINA (IATOMS, LATM, 1, LEND)
      IF (LEND.NE.0) GOTO  310
      IF (NLUSER(1).GT.0 .AND. NFNUM.GE.5) THEN
         READVC = .TRUE.
         IF (ABS(FNUM(2)).LT.0.01 .AND. ABS(FNUM(3)).LT.0.01 .AND.
     *          ABS(FNUM(4)).LT.0.01 .AND. NVEC.EQ.1 ) THEN
            GOTO 111
         ELSE
            VECN(1)=FNUM(2)
            VECN(2)=FNUM(3)
            VECN(3)=FNUM(4)
            CALL DISTSQ (VEC000, VECN, DHAHB, DVEC, RR2)
            IF (RR2.GT.DHAHB2) THEN
                NVEC=NVEC+1
                CALL KERNAB(VECN,VEC(1,NVEC),3)
                VEC(4,NVEC)=FNUM(5)
                ENDIF
            IF (NVEC.LT.MXPP-1) GOTO 111
            ENDIF
      ELSE
         IF (.NOT. READVC) GOTO 111
         ENDIF
 310  CONTINUE
      RETURN
      END
      SUBROUTINE REMORI
      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 /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      DIMENSION X(3),XYZL(3),XYZS(3),XORI(3),XOR(3),
     *          IXORI(3),IXOR(3),IXR(3),IXL(3),IX1(3),IT(3)
      EQUIVALENCE (IT(1),ITX),(IT(2),ITY),(IT(3),ITZ)
      PARAMETER (NUMTAB =300000)
      COMMON / / ITAB(NUMTAB)
      INTEGER * 2 ITAB
      STEPR=0.0
      CALL KERNZA(0.0,XORI,3)
      DO 100 I=1,3
      XYZL(I)=LXYZ(I)/GTXYZ(I)
      XYZS(I)=IS(I)/GTXYZ(I)
      CALL KERNZA(0.0,X, 3)
      X(I) = 1./GTXYZ(I)
      STEP = SQDIST(XORI,X)
      STEPR= STEPR + STEP
      STEP = SQRT(STEP)
      R=DH1H2-0.5*STEP
      IXR(I) = R/STEP
 100  CONTINUE
      STEPR=SQRT(STEPR)
      R = DH1H2-0.5*STEPR
      R2=R*R
      DO 910 NL=1,NLATT
      DO 110 I=1,3
      TLNL=TLATT(I,NL)
      IF (TLNL.LT.XYZS(I)) TLNL=TLNL+INT(0.999+XYZS(I)-TLATT(I,NL))
      IF (TLNL.GT.XYZL(I)) TLNL=TLNL-INT(0.999+TLATT(I,NL)-XYZL(I))
      IXORI(I)=NINT(TLNL*GTXYZ(I))
      XORI(I)=TLNL
 110  CONTINUE
      DO 610 ITX = -1,1,1
      DO 610 ITY = -1,1,1
      DO 610 ITZ = -1,1,1
      DO 120 I=1,3
      XOR(I)=XORI(I)+IT(I)
      IXOR(I)=IXORI(I)+IT(I)*NUM(I)
      IXL(I)=IXOR(I)+IXR(I)
      IF (IXL(I).LT.IS(I))  GOTO 610
      IX1(I)=IXOR(I)-IXR(I)
      IF (IX1(I).GT.LXYZ(I)) GOTO 610
      IF (IXL(I).GT.LXYZ(I)) IXL(I) = LXYZ(I)
      IF (IX1(I).LT.IS(I))   IX1(I) = IS(I)
 120  CONTINUE
      DO 310 IZ = IX1(3), IXL(3)
      X(3)= IZ/GTXYZ(3)
      DO 310 IY = IX1(2), IXL(2)
      X(2)= IY/GTXYZ(2)
      DO 310 IX = IX1(1), IXL(1)
      X(1)= IX/GTXYZ(1)
      DX2= SQDIST(XOR,X)
      IF (DX2.LT.R2) THEN
         IADR = NUMXY * IZ + NUM(1) * IY + IX - NUMC
         ITAB(IADR) = 0
         ENDIF
 310  CONTINUE
 610  CONTINUE
 910  CONTINUE
      RETURN
      END
      SUBROUTINE GETOVC
      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 (ICRYS, IFILE(3))
      EQUIVALENCE (LIS1, IFILE(7))
      COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE,
     *      CHIN, LIT(32), CHOUT
      CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64,
     *      CHIN *80, LIT *6, CHOUT *72
      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 /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3)
      CALL FILINQ( ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) THEN
          WRITE(CHOUT, 110) CCODE
 110      FORMAT (' ERROR no CRYSDA file found for ', A6)
          CALL KERROR( CHOUT, 0, 'GETOVC')
          ENDIF
      CALL RDCRYB(ICRYS, 'NORIG', KEND)
      IF (KEND.EQ.1) THEN
         READ (CHIN,FMT='(10X,I10)') NOR
         DO 210 N=1,NOR
         CALL RDCRYB(ICRYS, 'ORGVEC', KEND2)
         IF (KEND2.EQ.1) THEN
            READ (CHIN,FMT='(10X,3F10.7)') (ORIG(I,N),I=1,3)
         ELSE
            NOR=N-1
            WRITE (LIS1,
     *         FMT='(''  ERROR CRYSDA: NUMBER OF ORIGINS < NORIG'')')
            GOTO 220
            ENDIF
 210     CONTINUE
 220     IDDPOL=1
         IF (IPOLA.EQ.0) IDDPOL=0
         IF (IPOLA.EQ.3 .OR. IPOLA.EQ.5 .OR. IPOLA.EQ.6) IDDPOL=2
         IF (IPOLA.EQ.7) IDDPOL=3
         RVPOL(1)=0.0
         IF (IPOLA.EQ.1 .OR. IPOLA.EQ.6 .OR. IPOLA.EQ.8) RVPOL(1)=1.0
         RVPOL(2)=0.0
         IF (IPOLA.EQ.2 .OR. IPOLA.EQ.5 .OR. IPOLA.EQ.8) RVPOL(2)=1.0
         RVPOL(3)=0.0
         IF (IPOLA.EQ.3 .OR. IPOLA.EQ.4 .OR. IPOLA.EQ.8) RVPOL(3)=1.0
      ELSE
         WRITE(CHOUT, 310) CCODE
 310     FORMAT(' ERROR no origins on CRYSDA file for ',A6 )
         CALL KERROR( CHOUT, 0, 'GETOVC')
         ENDIF
      CALL FILCLO( ICRYS, 'KEEP' )
      RETURN
      END
      SUBROUTINE PROSPK (XP, NOP, XZ, NSTSXZ)
      PARAMETER (MXHEAV=20, MXSTSX=30)
      DIMENSION XP(5, NOP), XZ(5*MXHEAV+5,MXSTSX)
      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 (ITPL, KEYS(7))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IPR1,   IFILE(6))
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM,
     +      WAVE, CELALL(10), AMOLW, ZET,
     +      NELEC, F000, ABSMU, ICENT,
     +      ILATT, ISYST, ILAUE, IMULT,
     +      IUNIQ, IPOLA, NTYPE, NSYMM,
     +      IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4),
     +      FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      PARAMETER (MXPKS=150, MXSTSP=140)
      DIMENSION XP2(5, MXPKS), MULORD(MXPKS), NCOSTA(MXHEAV),
     *          PISET(MXHEAV+3,MXSTSP), X(4*MXHEAV+5,MXSTSX), PLIMF(3)
      LOGICAL READY, SPGP1, REDYIN
      DATA NCOSTA / MXHEAV*-1/
      NP2 = MIN0(NOP,MXPKS)
      NXP = NP2
      SPGP1 = NSYMM*ICENT .EQ. 1
       CALL OCCUPA (P1METH, XP, XP2, NP2)
      IF (.NOT. P1METH) THEN
         WRITE (LIS1, FMT = '(/ '' Highest peaks of the symmetry map''/
     *      ''  No.      x         y         z        height    '',
     *      ''mult.factor'')')
         NOPRI = MIN0 (10, NOP)
         DO 199 N = 1, NOPRI
         WRITE (LIS1, FMT='('' '',I3,2X,3F10.4,8F10.1)')
     *      N, (XP(I,N),I=1,5)
  199    CONTINUE
         ENDIF
      CALL PATHLI (XP2, NP2, NP3)
      NP2=NP3
      WRITE(LIS2,FMT='('' Limit patterson height:'',F6.1)') PLIMS(LTHV)
      WRITE (LIS2, FMT='('' Symmetry-map peaks lower than this value'',
     *'' are ignored'')')
      NHP=0
      ITPL = 2
      IF (.NOT.P1METH .AND. IPOLA.NE.0)  ITPL = 4
      PLIM0=PLIMC(LTHEAV,LTHEAV)
      CALL CROS2P( XP2,NP2, PLIM0, MULORD, NPKS2, MAHEAV)
      MIHEAV=2
      DO 100 I = 1, MXHEAV
      IF (I.LT.MIHEAV .OR. I.GT.MAHEAV) THEN
        NCOSTA(I)=-1
      ELSE
        NCOSTA(I)= 1
      ENDIF
      IF (SPGP1 .AND. I.LE.2) NCOSTA(I)=2
 100  CONTINUE
      NPS1=0
      REDYIN = .FALSE.
 111  CALL EVALUX (XZ,NSTSXZ,NEWXZ, NCOSTA, READY)
      CALL PATHLI (XP2, NP2, NP3)
      IF (.NOT. READY) THEN
         NEWXZ=0
         CALL CROS2S (XP2,MULORD,NCOSTA,PISET,NSETS,XZ,NSTSXZ)
         WRITE (LIS2, FMT='('' Sets of peaks and minimum-value'')')
         WRITE (LIS2, FMT='('' Number of sets found:'',I3)') NSETS
         IF (MAHEAV .GT. 1 .AND. NSETS.GT.0) THEN
            NSETSX=0
            PLIMF(3)=PLIMC(LTHV,LTHV)
            IF (NCONST(LTHV).EQ.1.AND.LTHV.GT.1)
     *         PLIMF(3)=PLIMC(LTHV-1,LTHV)
            IF (LT1.GT.0 .AND. LT1.LT.LTHV)  THEN
               PLIMF(1)=PLIMC(LT1,LT1)
               PLIMF(2)=PLIMC(LT1,LTHV)
            ELSE
               PLIMF(1)=PLIMF(3)
               PLIMF(2)=PLIMF(3)
               ENDIF
            CALL FIXONE (XP2,NPKS2, PISET,NSETS, PLIMF, X,NSETSX)
            CALL DISCRX (X, NSETSX, XZ, NSTSXZ, NEWXZ)
            ENDIF
         WRITE(IPR1,FMT='('' Search for'',I3,'' atoms ready'')') NCONS
         WRITE(LIS1,FMT='('' Search for'',I3,'' atoms ready'')') NCONS
         IF (NSTSXZ.GT.0) CALL HCOOUT (XZ, NSTSXZ, 0)
         GOTO 111
         ENDIF
      IF (NCONS .EQ. 1) THEN
         IF (SPGP1) NXP=1
         CALL POS1S (XP, NXP, X, NSETSX)
         CALL DISCRX (X, NSETSX, XZ, NSTSXZ, NEWXZ)
         ENDIF
      NPMAX=16*NLATT
      CALL DISCAB (XZ,NSTSXZ,NPMAX)
      RETURN
      END
      SUBROUTINE OCCUPA (SPGP1, X1, X2, NX)
      LOGICAL SPGP1
      DIMENSION X1(5,NX), X2(5,NX)
      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))
      DIMENSION XLOCK(3)
      PARAMETER (DMAX=0.7)
      DO 210 N = 1,NX
      IF (.NOT.SPGP1) THEN
         X1(5,N) = OCCUPX( X1(1,N) )
         IF (X1(5,N) .LT. 0.99) THEN
         CALL LOCKIN (X1(1,N), DMAX, XLOCK, DIST, NPOS)
         IF (DIST.GT.0.1) WRITE (LIS1,120) N,DIST,(X1(J,N),J=1,3),XLOCK
  120    FORMAT (' Atom ',I3,' locked in: peak shifted over', F6.2,
     *      ' Angstrom' / ' Peak xyz:',3F9.5, ' LOCKED xyz:',3F9.5)
         CALL KERNAB (XLOCK,X1(1,N),3)
         ENDIF
         ENDIF
 210  CALL KERNAB (X1(1,N), X2(1,N), 5)
      RETURN
      END
      SUBROUTINE PATHLI (XP2, NP2, NP3)
      DIMENSION XP2(5, NP2)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /ELEMB/ ACELTY(10)
      CHARACTER*2 ACELTY
      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 /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 P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      EQUIVALENCE (LIS2, IFILE(8))
      EQUIVALENCE (FRACIN, KEYS(25))
      DIMENSION ILIMS(10), ILIMC(10,10)
      LOGICAL FIRST
      DATA FIRST, FRAC /.TRUE., 0.0/
      DATA IFRAC / 0 /
      CALL KERNZA (-1. , PLIMC, 100)
      PLIMOL=PLIM
      IF (FIRST) THEN
         CALL KERNZI (0, ILIMS, 10)
         CALL KERNZI (0, ILIMC, 100)
         IF (P1METH) THEN
            PLIMTH= SCPAT * (NCELLZ(1)*NCELLZ(LTHV)) + PATAD
            FRAC=0.40
            ATSMIN=AMAX1((HEAVYN*HEAVYN - HEAVYN)/2.0+1.0, 11.)
         ELSE
            PLIMTH= SCPAT * (NCELLZ(LTHEAV)**2) + PATAD
            FRAC = 0.30
            ATSMIN=4.0*HEAVYN
            ENDIF
         PLIM=AMAX1((PLIMTH-PATAD)*FRAC*1.25 + PATAD, PLIMOL)
         ATOMS = 0.0
         DO 110 N = 1, NP2
         ATOMS = ATOMS + AMIN1( XP2(5,N),1.0 )
         IF (ATSMIN .LT. ATOMS + 0.01) THEN
            IF (PLIM .GT. XP2(4,N)) PLIM=AMAX1(XP2(4,N), PLIMOL)
            GOTO 120
            ENDIF
 110     CONTINUE
 120     FRAC = (PLIM-PATAD)/(PLIMTH-PATAD)
         FRAC = FRAC*0.8
         IF (FRAC.LT.0.3) THEN
            FRAC=0.3
            PLIM=(PLIMTH-PATAD)*FRAC+ PATAD
            ENDIF
         ENDIF
      IF (FRACIN.GT.0.01) FRAC=FRACIN
      IF (FRACIN.LT.0.01) FRACIN=FRAC
      KFRAC = 100.1 * FRAC
      IF (KFRAC .NE. IFRAC) WRITE (LIS2,FMT='
     *   (/'' Limit P(Patterson) ='',F5.2,'' x P(theoretical)'')') FRAC
      IF (KFRAC .NE. IFRAC) IFRAC = KFRAC
      FRACS= FRAC*1.25
      FRACC= FRAC
      FRACHL=0.8
      I1=1
      IF (LT1.NE.0 .AND. LTHV.GT.LT1)  I1=LT1+1
      IF (FIRST) I1=1
      DO 220 I = 1,NELMS
      IF (I.GE.I1) THEN
         IF (P1METH) THEN
            PLIMS(I) = (SCPAT*NCELLZ(1)*NCELLZ(I))*FRACS + PATAD
         ELSE
            PLIMS(I) = (SCPAT*NCELLZ(I)*NCELLZ(I))*FRACS + PATAD
            ENDIF
         IF (PLIM.GT.PLIMS(I))   PLIM=PLIMS(I)
         ENDIF
      II = 100.1 * PLIMS(I)
      IF (II .NE. ILIMS(I)) THEN
         WRITE(LIS2,FMT=
     *      '('' Limit value selfvector  of atoms  '',A2, 3X, F7.1)')
     *      ACELTY(I), PLIMS(I)
         ILIMS(I) = II
         ENDIF
      DO 210 J = I,LTHV
      IF (I.GE.I1 .OR. J.GE.I1) THEN
         FRACCC=FRACC
         IF (J.GT.LTHV) FRACCC=FRACHL
         PLIMC(I,J)=(SCPAT*NCELLZ(I)*NCELLZ(J))*FRACCC+ PATAD
         IF (J.GT.LTHV) GOTO 210
         IF (PLIM.GT.PLIMC(I,J)) PLIM=PLIMC(I,J)
         PLIMC(J,I)=PLIMC(I,J)
         II = 100.1 * PLIMC(I,J)
         IF (II .NE. ILIMC(I,J)) THEN
            WRITE(LIS2,FMT=
     *        '('' Limit value crossvector of atoms  '',A2,1X,A2,F7.1)')
     *        ACELTY(I), ACELTY(J), PLIMC(I,J)
            ILIMC(I,J) = II
            ILIMC(J,I) = II
            ENDIF
         ENDIF
 210  CONTINUE
 220  CONTINUE
      FIRST=.FALSE.
      DO 310 N=2,NP2
      IF (XP2(4,N).LT.PLIMS(LTHV)) THEN
         NP3=N-1
         RETURN
         ENDIF
 310  CONTINUE
      NP3=NP2
      RETURN
      END
      SUBROUTINE CROS2S(XP2,MULORD,NCOSTA,PISET,IPSTS, XZ,NSTSXZ)
      PARAMETER (MXPKS = 150, MXHEAV=20,MXSTSP=140)
      PARAMETER (MXSTSX=30, IXZ=5*MXHEAV+5)
      DIMENSION XP2(5, MXPKS), NCOSTA(MXHEAV), PISET(MXHEAV+3,MXSTSP)
      DIMENSION MULORD(MXPKS), ICANPK(MXPKS), PISET1(MXHEAV+3,MXSTSP),
     *          ICANP1(MXPKS), XZ(IXZ,MXSTSX)
      PARAMETER (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV),
     *                IBRK, ICD, MINBRK
      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))
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      DATA     NPI1 /0/
      NPKS=NPCT
      CALL SELCPK(XP2,NPKS, ICANP1)
      MINBRK=NCONS1+1
      IF (MINBRK.GT.NCONS) MINBRK=1
      IF (P1METH .AND. MINBRK.EQ.1 .AND. NCONS.GE.2)  MINBRK=2
      ICP=-1
      IF (MINBRK.EQ.1 .OR. (P1METH.AND.MINBRK.EQ.2)) ICP=0
      IF (ICP.LT.0 .AND. MINBRK.EQ.2)                ICP=1
      IF (ICP.LT.0 .AND. P1METH.AND.MINBRK.EQ.3)     ICP=2
      IF (ICP.LT.0)                                  ICP=3
      NET=0
      NT1=0
      DO 101 L=1,LTHV
      DO 100 N=1,NPKS
      IF (ICANP1(N).NE.L) GOTO 100
      NET=NET+1
      NSET(NET)=N
 100  CONTINUE
      IF ((ICP.EQ.1 .OR. ICP.EQ.2) .AND. L.EQ.LT1)  NT1=NET
 101  CONTINUE
      WRITE(LIS1,FMT='(I4,'' peaks selected for atoms search'')') NET
      WRITE(LIS2,FMT='(I4,'' peaks selected for atoms search'')') NET
      IF (ICP.EQ.0) THEN
         IPSTS=0
         CALL CONSPN (XP2,NPKS,MULORD,ICANP1,PISET,IPSTS)
         GOTO 1000
      ENDIF
      N1=0
      IF (ICP.EQ.3) THEN
           IF (NPI1.EQ.0) THEN
             VALXZM=XZ(5*MXHEAV+3,1)
             DO 110 N=1,NSTSXZ
             IF (XZ(5*MXHEAV+3,N)/VALXZM .LT. 0.666) GOTO 112
             NN=XZ(5*MXHEAV+5,N)
             IF (PISET(MXHEAV,NN).LT.-0.1) THEN
               PISET(MXHEAV,NN)=1.0
               NPI1=NPI1+1
               DO 105 I=1,MINBRK-1
 105           PISET1(I,NPI1)=PISET(I,NN)
             ENDIF
 110         CONTINUE
           ENDIF
 112       N1=NPI1
      ENDIF
      IF (ICP.EQ.1) N1=NT1
      IF (ICP.EQ.2) N1=NT1-1
      IPSTS=0
      DO 510 N=1,N1
      IF (ICP.EQ.3) THEN
         DO 220 I=1,MINBRK-1
         NSET1=NINT(PISET1(I,N))
         DO 210 J=I,NET
         IF (NSET1.NE.NSET(J)) GOTO 210
           NSET(J)=NSET(I)
           NSET(I)=NSET1
           GOTO 220
 210     CONTINUE
         GOTO 510
 220     CONTINUE
      ELSE IF (N.GT.1) THEN
         NSET1=NSET(MINBRK-1)
         DO 310 J=MINBRK,NET
 310     NSET(J-1)=NSET(J)
         NSET(NET)=NSET1
         IF (ICP.EQ.2) THEN
           NP2=NSET(MINBRK-1)
           IF (NINT(XP2(5, NSET1)) .EQ. NINT(XP2(5, NP2)) ) GOTO 510
         ENDIF
      ENDIF
      DO 410 I=1,NET
      I1=NSET(I)
      ICANPK(I1)=ICANP1(I1)
      IF (I.GE.MINBRK .AND. ICANPK(I1).LE.LT1)  ICANPK(I1)=LT1+1
 410  CONTINUE
      CALL CONSPN(XP2,NPKS,MULORD,ICANPK, PISET,IPSTS)
 510  CONTINUE
 1000 CONTINUE
      NCOSTA(NCONS) = 2
      RETURN
      END
      SUBROUTINE CROS2P( XP2,NP, PLIM0, MULORD,NPKS, MAHEAV)
      PARAMETER (MXPKS = 150)
      DIMENSION XP2(5, MXPKS), MULORD(MXPKS)
      PARAMETER (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28),
     *      NFNUM, NLIT, NCOLN(32), NCOLL(32),
     *      NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32),
     *      SWITCH(28)
      LOGICAL SWITCH
      EQUIVALENCE (KEYS(7),ITPL)
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM,
     +      WAVE, CELALL(10), AMOLW, ZET,
     +      NELEC, F000, ABSMU, ICENT,
     +      ILATT, ISYST, ILAUE, IMULT,
     +      IUNIQ, IPOLA, NTYPE, NSYMM,
     +      IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4),
     +      FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      DIMENSION XPNPEQ(3,48), XOUT(5,20), CVEC(3)
      LOGICAL PATSYM, TLATTI, ENANTI
      DATA  PATSYM, TLATTI, ENANTI /.FALSE.,.FALSE.,.TRUE./
      CALL KERNZA( PATAD, P1X2, NMAXP2)
      IF (P1METH) THEN
        NPCT=NP
        NPKS=NP
        MAHEAV=HEAVYN
        CALL KERNZI (1,MULORD,MXPKS)
        NMULN=1
        NMULN2=1
        NOUT=1
        DO 120 N2=1,NPKS
        DO 110 N =N2+1,NPKS
        CALL VMINV(XP2(1,N2),XP2(1,N),CVEC,3)
        CALL GRDOUT (CVEC,FUNF)
        XOUT(4,1)=FUNF
        IF (N2.EQ.1) XP2(4,N)=FUNF
        CALL WRCROS (N,NMULN,N2,NMULN2,XOUT, NOUT,P1X2,NMAXP2,NPCT)
 110    CONTINUE
        FUNF=XP2(4,N2)
        N=N2
        CALL AR2SYM( FUNF,N,N2, NPKS, P1X2, NMAXP2)
 120    CONTINUE
        GOTO 3000
      ENDIF
      CALL CROSPP (XP2,NP, MULORD,PLIM0)
      NPKS = NPCT
      MAHEAV = MXESUM (XP2, NPKS, HEAVYN)
      IF (MAHEAV .EQ. 1) RETURN
      DO 2000 N2 = 1, NPKS
      IF (XP2(5,N2)-0.01 .GT. HEAVYN)  GOTO 2000
      IF (MULORD(N2) .LT. 0) GOTO 2000
      NMULN2 = MULORD(N2)
      DO 1000 N = N2+1, NPKS
      IF (XP2(5,N2)+XP2(5,N)-0.01 .GT. HEAVYN)  GOTO 1000
      IF (MULORD(N) .LT. 0) GOTO 1000
      NMULN = MULORD(N)
      CALL ALLEQP( XP2(1,N), XPNPEQ, 48, PATSYM,TLATTI, NEQPNP)
      NOUT = MAX0( NMULN2, NMULN)
      PXX2 = OCMINF (XP2(1,N2), XPNPEQ, NEQPNP, 1, 0, ENANTI,
     *    PLIM0, XOUT, NOUT)
      IF (NOUT.EQ.0) THEN
         XOUT(4,1)=PXX2
         NOUT=1
         ENDIF
      CALL WRCROS (N,NMULN, N2,NMULN2, XOUT, NOUT, P1X2, NMAXP2, NPCT)
 1000 CONTINUE
 2000 CONTINUE
 3000 CONTINUE
      IP2LST=IPOIN1(NPCT,NPCT,NPCT)
      AVCROS=0.0
      DO 3100 I=1,IP2LST
 3100 AVCROS=AVCROS+P1X2(I)
      AVCROS=AVCROS/IP2LST
      WRITE(LIS1,FMT='(''  Average value of cross-table:'',F8.1)')AVCROS
      WRITE(LIS2,FMT='(''  Average value of cross-table:'',F8.1)')AVCROS
      RETURN
      END
      SUBROUTINE CROSPP (XP2,NPKS, MULORD,PLIM0)
      PARAMETER (MXPKS=150, NMAXP2=(MXPKS*MXPKS+MXPKS)/2 )
      DIMENSION XP2(5, MXPKS), MULORD(MXPKS)
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      PARAMETER (MXHEAV=20)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      DIMENSION INP1X1(MXPKS), PNXN(2), P1X1N(2,MXPKS), IP11SQ(MXPKS),
     *      MULPK(MXPKS), P1X1(MXPKS)
      DIMENSION XPNPEQ(3,48), XOUT(5,20), PXX(5,20)
      EQUIVALENCE (XOUT(1,1), PXX(1,1))
      LOGICAL PATSYM, TLATTI, ENANTI
      DATA  PATSYM, TLATTI, ENANTI /.FALSE.,.FALSE.,.TRUE. /
      NPKSMX=MXPKS
      NPKSL = MIN0 (NPKS, NPKSMX)
      PLIML =AMAX1 (XP2(4,NPKSL),PLIM0)
      F = 0.5
      PLIM2 = PLIML + (PLIML-PATAD)*F
      NPKS11 = 0
      DO 1000 N = 1, NPKSL
      MULPK(N) = 0
      PNXN(1) = N
      PNXN(2) = XP2(4,N)
      CALL EL2AR2 (PNXN,2,2,P1X1N,NPKSMX,NPKS11,IP11SQ)
      IF (XP2(4,N).GT.PLIM2 .AND. 2.0*XP2(5,N)-0.01.LT.HEAVYN)  THEN
         NOUT = NINT( (XP2(4,N)-PLIML)/((PLIML-PATAD)*F) )
         NOUT1= NINT(HEAVYN/XP2(5,N))
         NOUT = MIN0(NOUT,MXHEAV-1,NOUT1)
         CALL ALLEQP( XP2(1,N), XPNPEQ, 48, PATSYM,TLATTI, NEQPNP)
         PXX2 = OCMINF
     *      (XP2(1,N),XPNPEQ,NEQPNP, 1, 0, ENANTI, PLIML, XOUT,NOUT)
         PNXN(1) = N
         DO 110 N1 = 1, NOUT
         IF (XOUT(4,N1).LT.PLIM0) GOTO 1000
         PNXN(2) = XOUT(4,N1)
  110    CALL EL2AR2 (PNXN,2,2,P1X1N,NPKSMX,NPKS11,IP11SQ)
      ENDIF
 1000 CONTINUE
      IPKS11=NPKS11
      CALL SORTIN(IP11SQ,MXPKS, IPKS11, P1X1N, 2, NPKS11)
      DO 1100 M = 1, NPKS11
      N = NINT(P1X1N(1,M))
      MULPK(N)=MULPK(N)+1
 1100 CONTINUE
      INP1X1(1) = 0
      DO 1200 N = 1, NPKS-1
 1200 INP1X1(N+1) = INP1X1(N) + MULPK(N)
      DO 1300 M = 1, NPKS11
      N = NINT(P1X1N(1,M))
      IP = INP1X1(N) + 1
      P1X1(IP) = P1X1N(2,M)
      INP1X1(N) = IP
 1300 CONTINUE
      NI = 0
      DO 1400 N = 1, NPKSL
      IF (MULPK(N) .NE. 0) THEN
         NI = NI +1
         CALL KERNAB(XP2(1,N), XP2(1,NI), 5)
         MULPK(NI) = MULPK(N)
         INP1X1(NI) = INP1X1(N)
      ENDIF
 1400 CONTINUE
      NPKSL = NI
      NPCT=NPKS11
      N1 = NPKS11+1
      DO 2300 N = NPKSL,1,-1
      N11 = N1 - 1
      DO 2100 M = MULPK(N),1,-1
      N1 = N1 - 1
      MULORD(N1) = 1 - M
 2100 CALL KERNAB (XP2(1,N), XP2(1,N1), 5)
      NMULN1 = MULPK(N)
      MULORD(N1) = NMULN1
      NMULN2 = NMULN1
      N2 = N1
      NX = 0
      DO 2200 NP1 = N1, N11
      NX = NX + 1
 2200 PXX(4,NX) = P1X1(NP1)
      CALL WRCROS (N1,NMULN1, N2,NMULN2, PXX, NX, P1X2, NMAXP2, NPCT)
 2300 CONTINUE
      RETURN
      END
      SUBROUTINE HCOOUT (X, NSTSX, KATOUT)
      PARAMETER (MXHEAV=20, MSTSX=30)
      DIMENSION X(5*MXHEAV+5, MSTSX)
      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 (IDDL, IFILE(1)), (IATOMS,IFILE(1)), (IATOLD,IFILE(2))
      EQUIVALENCE (LIS1, IFILE(7))
      EQUIVALENCE (IPR1, IFILE(6))
      EQUIVALENCE (IRUN, KEYS(13))
      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 ATXYZ(10,MXHEAV)
      CHARACTER*6 ATNAME(MXHEAV)
      CHARACTER*72 REWRCO(25)
      DATA NAT1 /0/
      DO 100 N=1,MXHEAV
      CALL KERNZA (0.0, ATXYZ(1,N), 10)
 100  ATXYZ(4,N)=1.0
      NAT=0
      NXPT = 5*MXHEAV+1
      NXVL = 5*MXHEAV+3
      FMUL = X(NXVL,1)/10000.
      FPVAL= X(NXVL,1)*0.666
      IF (FMUL.LT.1.0) FMUL=1.0
      IF (KATOUT .EQ. 1)
     *    WRITE (LIS1, FMT= '(/'' Set  FOM  MinAv  Min1  Minx  '',
     *    ''  Atom       x        y        z      mult.'')')
      MA=0
      DO 210 MX = 1, NSTSX
      ISETVL = NINT(X(NXVL,MX)/FMUL)
      AMINM = X(5*MXHEAV-1,MX)
      CONTHL= X(5*MXHEAV-2,MX)
      AMIM1 = X(5*MXHEAV-3,MX)
      IF (KATOUT .EQ. 1)
     *   WRITE (LIS1,FMT='(I4,I6,3F6.3)') MX,ISETVL,AMINM, AMIM1, CONTHL
      NHEOUT = NINT( X(NXPT,MX))
      CALL AZATNA (X(1,MX), NHEOUT, ATXYZ, ATNAME)
      DO 105 N=1,NHEOUT
      IF (KATOUT .EQ. 1)
     *   WRITE (LIS1,FMT='(33X,A6,3F9.5,F6.2)') ATNAME(N),
     *   (ATXYZ(I,N),I=1,4)
 105  ATXYZ(4,N)=1.0
      NAT = NHEOUT
      IF (MX .EQ. 1) REWIND IATOMS
      WRITE(CHOUT,FMT='('' Model PAT'',I3,'' FOM='',I6)') MX, ISETVL
      CALL ATOMWR(IATOMS, ATXYZ, ATNAME, NAT)
      IF (MX.EQ.1) NAT1=NAT
      MA=MA+1
      IF (X(NXVL,MX) .LT. FPVAL) GOTO 310
 210  CONTINUE
 310  CONTINUE
      IF (KATOUT .EQ. 0) RETURN
      CALL COPY80( IATOMS, 'ATOMS', IATOLD, 'ATOLD')
      CALL FILCLO (IATOMS, 'KEEP')
      KPROG = 7
      WRITE (CHOUT,FMT='(''RUN '',I3,'' ATOMS NAT= '',I4,
     *    '' KPROG '', I3)') IRUN, NAT1, KPROG
      CALL LOGWR (IDDL)
      CALL FILCLO (IDDL, 'KEEP')
      WRITE (IPR1, FMT='('' Number of ATOM sets output: '', I3)') MA
      IF (MA .GT. 1) RETURN
      ICON = IDDL
      CALL FILINQ( ICON, 'CONDA', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) RETURN
  400 CALL KERINA (ICON, LIT, 1, LEND)
      IF (LEND .NE. 0) RETURN
      IF (LIT(2) .NE. 'R2CALC' .OR. LIT(4) .NE. 'PATTY') GOTO 400
      IR = 1
  401 READ (ICON, FMT='(A72)', END=411) REWRCO(IR)
      IF (IR.EQ.1 .AND. REWRCO(1)(1:7).NE.'PROGRAM') GOTO 401
      IR = IR + 1
      GOTO 401
  411 REWIND ICON
      WRITE (ICON, 430) CCODE, (ITIME(IT), IT=1,3)
  430 FORMAT ('CONDA ', A6, 1X, I4, 2I3)
      IF (TITLE .NE. ' ') WRITE (ICON, FMT='(''TITLE '', A64)') TITLE
      IRL = IR - 1
      DO 437 IR = 1, IRL
  437 WRITE (ICON, FMT='(A72)') REWRCO(IR)
      CALL FILCLO (ICON, 'KEEP')
      IDDS = ICON
      CALL FILINQ( IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IDDS, FMT='(''DDMAIN''/''PHASEX''/''DDMAIN''/''FOUR'')')
      WRITE (IDDS, FMT='(''STOP'')')
      REWIND IDDS
      CALL FILCLO (IDDS, 'KEEP')
      RETURN
      END
      SUBROUTINE AZATNA (X, N, ATXYZ, ATNAME)
      DIMENSION X(5,N), ATXYZ(10,N)
      CHARACTER*6 ATNAME(N)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /ELEMB/ ACELTY(10)
      CHARACTER*2 ACELTY
      CHARACTER*4 CNANR
      M=0
      DO 210 NE=1,NELMS
      DO 110 N1=1,N
      IZN1 = NINT(X(5,N1))
      IF ( IZN1 .EQ. NCELLZ(NE) ) THEN
          M=M+1
          IL = INDEX(ACELTY(NE), ' ')
          IF (IL.NE.2) IL=3
          ATNAME(M)(1:IL-1) = ACELTY(NE)(1:IL-1)
          NANR=1
          DO 105 NA=1,N1-1
          IF (IZN1 .EQ. NINT(X(5,NA))) NANR=NANR+1
 105      CONTINUE
          WRITE (CNANR, FMT='(I4)') NANR
          IN=0
 111      IN=IN+1
          IF (CNANR(IN:IN) .EQ. ' ') GOTO 111
          ATNAME(M)(IL:) = CNANR(IN:)
          DO 120 I=1,4
 120      ATXYZ(I,M)=X(I,N1)
      ENDIF
 110  CONTINUE
 210  CONTINUE
      RETURN
      END
      SUBROUTINE EVALUX (XZ,NSTSXZ,NEWXZ, NCOSTA, READY)
      PARAMETER (MXHEAV=20, MXSTSX=30)
      DIMENSION XZ(5*MXHEAV+5,MXSTSX), NCOSTA(MXHEAV)
      LOGICAL  READY
      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 P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      EQUIVALENCE (FRACIN, KEYS(25))
      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 /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      LOGICAL  FIRST
      DATA     FIRST, FRAC, LTFRA /.TRUE., 0.2, 0/
      IF (FIRST) THEN
         FIRST=.FALSE.
         FRAC=FRACIN
         LTFRA=0
         NCONS=0
         I1=2
         IF (NSYMM*ICENT.EQ.1) I1=3
         DO 102 I=MXHEAV,I1,-1
         IF (NCOSTA(I).EQ.1) THEN
           DO 101 J=I1,I
 101       NCOSTA(J)=1
           GOTO 103
         ENDIF
 102     CONTINUE
 103     IF (P1METH .AND. NSYMM*ICENT.NE.1) THEN
             DO 106 J=1,3
             IF (ABS(TSYMM(J,2)).GT.0.1) THEN
               DO 105 I=1,MXHEAV,2
 105           IF (NCOSTA(I).EQ.1) NCOSTA(I)=-1
               GOTO 107
             ENDIF
 106         CONTINUE
         ENDIF
 107     MXHVY=0
         DO 110 I=1,MXHEAV
 110     IF (NCOSTA(I).EQ.1) MXHVY=I
         IF (MXHVY .LE. 1) THEN
            NCONS=1
            NCONST(1)=1
            LTHV=1
            READY=.TRUE.
            GOTO 1000
         ENDIF
         NCONS1=0
         LT1=0
         NHVY=MIN0(NASYMP(1), MXHVY)
          DO 120 I=2,LTHEAV
            IF ((0.6*NCELLZ(I-1)**2 .GT. NCELLZ(I)**2)) THEN
              LT1=I-1
              GOTO 121
            ENDIF
          NHVY=MIN0(NHVY+NASYMP(I), MXHVY)
          IF (NHVY.EQ.MXHVY) GOTO 122
 120      CONTINUE
          IF (.NOT.P1METH) GOTO 122
          NHVY=1
          LT1=1
 121      NCONS1=NHVY
          IF (NHVY.EQ.1) NHVY=MIN0(NHEAVY, MXHVY)
          IF (P1METH .AND. NHVY.EQ.2) NHVY=MIN0(NHEAVY, MXHVY)
 122      CONTINUE
         IF (NHVY.LT.2) NHVY=2
         L=0
         DO 140 I=NHVY,2,-1
         IF (NCOSTA(I).EQ.1) THEN
             NCONS = I
             L=1
             NCONST(1)=0
             DO 130 J=1,NCONS
             NCONST(L)=NCONST(L)+1
             IF (J.EQ.NCONS) GOTO 130
             IF (NCONST(L).EQ.NASYMP(L) .AND. L.LT.LTHEAV) THEN
                L=L+1
                NCONST(L)=0
             ENDIF
 130         CONTINUE
             IF (NCONS.LT.NHVY .AND. NCONS1.GT.NCONS) THEN
                 NCONS1=NCONS
                 LT1=L
             ENDIF
             GOTO 141
         ENDIF
 140     CONTINUE
 141     LTHV=L
         READY=.FALSE.
         NCOSTA(NCONS)=0
         GOTO 1000
      ELSE
        IF (NEWXZ.EQ.0) THEN
         DO 210 J = NCONS,MXHEAV
         IF (NCOSTA(J).NE.2)   NCOSTA(J)=-1
 210     CONTINUE
        ENDIF
        READY = .FALSE.
        MXCDON=0
        MAXC=1
        MINC=MXHEAV+1
        DO 340 J = MXHEAV,1,-1
        IF (NCOSTA(J).EQ.2 .AND. MXCDON.EQ.0) MXCDON=J
        IF (NCOSTA(J).EQ.1 .AND. MAXC.EQ.1) MAXC=J
        IF (NCOSTA(J).EQ.1) MINC=J
        IF (MAXC.NE.1.AND.(NCOSTA(J).EQ.2 .OR. MAXC.LT.MXCDON)) GOTO 400
 340    CONTINUE
        IF (MAXC.EQ.1) NCONS=1
        IF (MAXC.EQ.1) MINC=1
      ENDIF
 400  VALMOX=0.0
      IF (NSTSXZ.GT.0)  VALMOX = XZ(5*MXHEAV+3,1)
      IF (NSTSXZ.GT.0 .AND. NCONS.EQ.1) THEN
          VALMXN=IMULT**2 * NCELLZ(1)**2 * AMI2
          IF (VALMXN.LT.VALMOX) THEN
             NCONS=2
             READY=.TRUE.
             GOTO 1000
          ENDIF
      ENDIF
      IF (READY) RETURN
      NCONS=0
      L=1
      NCONST(1)=0
      DO 430 J=1,MAXC
      NCONS=NCONS+1
      NCONST(L)=NCONST(L)+1
      IF (J.EQ.MAXC) GOTO 430
      IF (NCONST(L).EQ.NASYMP(L)) THEN
        IF (L.EQ.LTHEAV) GOTO 410
        IF (J.LT.MINC .OR. NCONST(L+1)+NASYMP(L+1).LE.MAXC) THEN
            L=L+1
            NCONST(L)=0
            GOTO 430
        ENDIF
 410    IF (J.LT.MINC) GOTO 430
 411     IF (NCOSTA(NCONS).EQ.1)  GOTO 441
         NCONS=NCONS-1
         IF (NCONST(L).EQ.0) L=L-1
         NCONST(L)=NCONST(L)-1
         GOTO 411
      ENDIF
 430  CONTINUE
 441  LTHV=L
      NCOSTA(NCONS)=0
      IF (NCONS.EQ.1) READY=.TRUE.
      IF (NCONS.EQ.1) RETURN
      IF (MXCDON.GT.NCONS) THEN
            IF (NSTSXZ.EQ.0) GOTO 1000
            IF (NCONS .GT. XZ(5*MXHEAV+1,1)) GOTO 1000
          IMULTP=IMULT
          IF (P1METH) IMULTP=NLATT
          NHVYCL=NINT(HEAVYN*IMULTP)
          SUMINW=0.0
          JMSUM=0
          DO 520 M=1,LTHV
          JM=NCONST(M)*IMULTP
          IF (JMSUM+JM .GT. NHVYCL) JM=NHVYCL-JMSUM
          JMSUM=JMSUM+JM
          SUM=0.0
          JNSUM=0
          DO 510 N=1,LTHV
          JN=NCONST(N)*IMULTP
          IF (JNSUM+JN .GT. NHVYCL) JN=NHVYCL-JNSUM
          JNSUM=JNSUM+JN
 510      SUM=SUM + JN * NCELLZ(M)*NCELLZ(N)
          SUMINW=SUMINW + JM*SUM
 520      CONTINUE
          VALMX1=VALMOX
          IF (XZ(5*MXHEAV+1,1)+0.1 .LT. MXHEAV)
     *       VALMX1 = (VALMOX/ XZ(5*MXHEAV-1,1)) * XZ(5*MXHEAV-3,1)
          FRACIN=AMAX1(0.667*VALMX1/SUMINW, FRAC)
          IF (FRACIN.GT. 1.2) FRACIN=1.2
          VALMXN=SUMINW*AMI2
          IF (VALMXN .LT. VALMOX)    READY=.TRUE.
      ENDIF
 1000 CONTINUE
      IF (LTHV.GT.LTFRA) THEN
        LTFRA=LTHV
        IF (NCONS.LE.1) RETURN
        IFPL = 1000
        IF (P1METH) IFPL = 2000
 1111   CALL FRALIM(FRACIN, FRACIN+0.4, IFPL, FRACN)
        IF (FRACIN.GT.0.29 .AND. FRACN.LT.0.001) THEN
          FRACIN=FRACIN-0.1
          GOTO 1111
        ENDIF
        IF (FRACN.GT.0.001) FRACIN = FRACN
        FRAC=FRACIN
      ENDIF
      RETURN
      END
      SUBROUTINE POS1S (XP,NP, X, NSETSX)
      PARAMETER (MXHEAV=20, MXSTSX=30, IX=4*MXHEAV+5,MXPKS=150)
      PARAMETER (MXINX=MXSTSX)
      DIMENSION X(IX,MXSTSX), XP(5, MXPKS)
      DIMENSION XF(IX), INX(MXINX)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      LOGICAL ENUGHA
      PARAMETER (PMAX=30254., D1=0.001)
      DATA   XF /IX*0.0/
      ENUGHA=.FALSE.
      NSETSX=0
      ISQ = 4*MXHEAV+3
      PLIML = PLIM
      DO 210 N = 1, NP
         IF (ENUGHA .AND. XP(4,N) .LT. PLIML) GOTO 220
         IF (XP(5,N).LT.HEAVYN+D1) THEN
           ATOMSX = XP(5,N)
           IF (.NOT.ENUGHA) THEN
            ENUGHA= ATOMSX .GT. HEAVYN-D1 .OR. ATOMSX .GT. 0.99
            IF (ENUGHA) THEN
            PLIMLL = (XP(4,N)-PATAD)*0.50 + PATAD
            IF (PLIMLL .LT. PLIML) PLIML=PLIMLL
            ENDIF
           ENDIF
           CALL KERNAB (XP(1,N), XF, 3)
           XF(4)=XP(5,N)
           XF(4*MXHEAV+1)=1.
           XF(4*MXHEAV+2)=ATOMSX
           XF(4*MXHEAV+3)=XP(4,N) + (PMAX-PLIM)*ATOMSX
           CALL EL2AR2 (XF,IX, ISQ, X, MXSTSX, NSETSX, INX)
         ENDIF
 210     CONTINUE
 220     CONTINUE
      CALL SORTIN(INX,MXINX, NSETSX, X,IX,MXSTSX)
      RETURN
      END
      SUBROUTINE SYMMPK (XP, NOP)
      PARAMETER (MXPKS=150,MXPEAK=MXPKS+100)
      DIMENSION XP(5, MXPEAK)
      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))
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE,
     *      CHIN, LIT(32), CHOUT
      CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64,
     *      CHIN *80, LIT *6, CHOUT *72
      COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM,
     +      WAVE, CELALL(10), AMOLW, ZET,
     +      NELEC, F000, ABSMU, ICENT,
     +      ILATT, ISYST, ILAUE, IMULT,
     +      IUNIQ, IPOLA, NTYPE, NSYMM,
     +      IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4),
     +      FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER  (MXPP=128)
      COMMON /PATPKS/ VP(4,MXPP), NVPS, SC2DEK, PATADD
      COMMON /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3)
      COMMON /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      DIMENSION ASY(6), XPP(3,12)
      LOGICAL PATSYM, TLATTI
      DATA DMAX, PATSYM, TLATTI / 0.05, .TRUE., .FALSE./
      IF (.NOT. P1METH) GOTO 200
         NOP=0
         DO 100 N=1,NVPS
         CALL ALLEQP (VP(1,N), XPP, 12, PATSYM,TLATTI, NEQP)
         DO 95 I=1,NEQP
         NOP=NOP+1
         CALL KERNAB(XPP(1,I),XP(1,NOP),3)
         XP(4,NOP)=VP(4,N)
         XP(5,NOP)=N+0.01
  95     CONTINUE
         IF (N.EQ.NVPS .OR. NOP+NEQP.GT.MXPEAK)
     *      CALL DELIPO (XP, NOP, DMAX)
         IF (NOP+NEQP .GT. MXPEAK) RETURN
  100    CONTINUE
         RETURN
  200 CALL ASYMS (ASY)
      CALL SYSTOP (ASY)
      CALL HAMAWT
      WRITE (LIS2, FMT='(/'' Subroutine HAMAWT'',
     *  '' = symmetry of symmetry map:'' /
     *  '' Rotation matrix         Translation         weight     NSDH''
     *   , 48(/ 3(3I2, 1X), 2X, 3F6.2, F7.1, 5X, 4I4 ) )')
     *   ( ((IRSY1(I,J,N),I=1,3), J=1,3), (TSY1(I,N), I=1,3),
     *   SWGT(N), (NSDH(I,N), I=1,4), N=1, NSSY )
      CHOUT = ' Calculate symmetry map'
      CALL SHOUT
      CALL SYMMAP
      CHOUT = ' ---------------------- and interpret its peaks'
      CALL SHOUT
      NPEAKS=MXPEAK
      CALL PEAKHG (NPEAKS, PLIM, NOP, XP)
      IF (NOP.GT.1) CALL DELPKO (XP, NOP, NXYZS)
      RETURN
      END
      SUBROUTINE SYSTOP (ASY)
      DIMENSION ASY(6)
      PARAMETER (NUMTAB =300000)
      COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3)
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(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
      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 / / ITAB(NUMTAB)
      INTEGER * 2 ITAB
      DATA  IFUNMX /30254/
      MLEFT = NUMTAB - NUMXYZ
      RES2P = 2.
 101  IF (RES2P .LT. 0.9) CALL KERROR ('Symmetry map storage problems:',
     *   101, 'SYSTOP')
      DO 110 I=1,3
      NXYZS(I) = NINT( RES2P * NXYZ(I))
      GTXYZS(I) = FLOAT(NXYZS(I))
      FSTPSY(I) = 1./GTXYZS(I)
      I2 = I+I
      ISS(I) = INT(ASY(I2-1)* GTXYZS(I) - 0.999 ) - 2
      LXYZS(I) = INT(ASY(I2) * GTXYZS(I) + 0.999 ) + 2
      NUMS(I) = LXYZS(I) - ISS(I) + 1
 110  CONTINUE
      NUSXY = NUMS(1)*NUMS(2)
      NUSXYZ= NUSXY * NUMS(3)
      IF (NUSXYZ .GT. MLEFT) THEN
         RES2P = RES2P - 0.1
         GOTO 101
         ENDIF
      WRITE (LIS2,FMT='(/'' Subroutine SYSTOP''/
     *                   '' Stepsizes of patterson:   '',3F5.2,
     *      '' (Angstrom)'')') (CELL(I)/GTXYZ(I), I=1,3)
      WRITE (LIS2,FMT='( '' Stepsizes of symmetry-map:'',3F5.2,
     *      '' (Angstrom)'')') (CELL(I)/GTXYZS(I),I=1,3)
      IADEOP = NUM(1) * NUM(2) * NUM(3)
      NUMSC = NUSXY * ISS(3) + NUMS(1) * ISS(2) + ISS(1) - 1 - IADEOP
      WRITE (LIS2,FMT='( '' Stored block: NGRID / cell edges :'', 3I4,
     *                 / '' Stored block starting grid points:'', 3I4,
     *                 / '' Stored block: nr of points stored:'', 3I4
     *   )') NXYZS, ISS, NUMS
      WRITE (LIS2,FMT='( '' Address  for symmetry-map:  IADR ='', I7,
     *   '' * IZ +'', I3, '' * IY + IX -'', I7)') NUSXY, NUMS(1), NUMSC
      IADR1 = IADEOP + 1
      IADEND= IADEOP + NUMS(1)*NUMS(2)*NUMS(3)
      DO  210 IADR = IADR1, IADEND
 210  ITAB(IADR) = IFUNMX
      RETURN
      END
      SUBROUTINE SYMMAP
      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 /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      COMMON /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      DIMENSION NUMSS1(3), IX(3), X(3),GX(3)
      DATA  FUNMX /30254./
      FUNFSP = FUNMX + 1.
      SYMAX = 30254.
      DO 500 NSY1= 2, NSSY
      DO 104 I=1,3
      IF (IRSY1(1,I,NSY1).EQ.0 .AND. IRSY1(2,I,NSY1).EQ.0 .AND.
     *    IRSY1(3,I,NSY1).EQ.0) THEN
         NUMSS1(I) = 1
      ELSE
         NUMSS1(I) = NUMS(I)
         ENDIF
 104  CONTINUE
      NUMXS1=NUMSS1(1)
      NUMYS1=NUMSS1(2)
      NUMZS1=NUMSS1(3)
      SYMXNW= 0.0
            GX(3) = ISS(3) - 1
            IX(3) = ISS(3) - 1
      DO 333 JZ = 1, NUMZS1
            IX(3) = IX(3)+1
            GX(3) = GX(3)+1.
            X(3) = GX(3)/GTXYZS(3)
            GX(2) = ISS(2) - 1
            IX(2) = ISS(2) - 1
      DO 222 JY = 1, NUMYS1
            IX(2) = IX(2)+1
            GX(2) = GX(2)+1.
            X(2) = GX(2)/GTXYZS(2)
            GX(1) = ISS(1) - 1
            IX(1) = ISS(1) - 1
      DO 111 JX = 1, NUMXS1
            IX(1) = IX(1)+1
            GX(1) = GX(1)+1.
            X(1) = GX(1)/GTXYZS(1)
      CALL STORSY (X, IX, NSY1, NUMSS1, SYMAX, SYMXNW)
 111  CONTINUE
 222  CONTINUE
 333  CONTINUE
      SYMAX=SYMXNW
 500  CONTINUE
      RETURN
      END
      SUBROUTINE HAMADI(IRSY1, NUMS, NUMXS1)
      DIMENSION IRSY1(3,3), NUMS(3), NUMXS1(3)
      DO 140 I=1,3
      IF (IRSY1(1,I).EQ.0 .AND. IRSY1(2,I).EQ.0
     *      .AND. IRSY1(3,I).EQ.0) THEN
           NUMXS1(I) = 1
      ELSE
           NUMXS1(I) = NUMS(I)
      ENDIF
 140  CONTINUE
      RETURN
      END
      SUBROUTINE HARVEC (IRSY1, TSY1, X, XS)
      DIMENSION IRSY1(3,3), TSY1(3), X(3), XS(3)
      DO 120 I2 = 1,3
      XS(I2) = 0.
      DO 110 I1 = 1,3
      IF (IRSY1(I2,I1) .NE. 0) THEN
            IF (IRSY1(I2,I1) .GT. 0) THEN
            XS(I2) = XS(I2) + X(I1)
            IF (IRSY1(I2,I1) .EQ. 2) XS(I2) = XS(I2) + X(I1)
            ELSE
            XS(I2) = XS(I2) - X(I1)
            ENDIF
      ENDIF
 110  CONTINUE
 120  CONTINUE
      CALL VPLUSV (XS, TSY1, XS, 3)
      RETURN
      END
      SUBROUTINE STORSY (X, IX, NSY1, NUMSS1, SYMAX, SYMXNW)
      DIMENSION X(3),IX(3), NUMSS1(3)
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (NUMTAB =300000)
      COMMON / / ITAB(NUMTAB)
      INTEGER * 2 ITAB
      DIMENSION XGS(3),XG(3),STPX(3)
      LOGICAL FIRST1
      DATA   FUNF  /30254./
      FIRST1=.TRUE.
      DO 101 I=1,3
      XGS(I)= IX(I)/GTXYZS(I)
 101  STPX(I)=1./GTXYZS(I)
      IXL1= IX(1)
      IYL1= IX(2)
      IZL = IX(3)
      XG(3)=XGS(3)
      DO 333 JZ = NUMSS1(3), NUMS(3)
      IYL = IYL1
      XG(2)= XGS(2)
      DO 222 JY = NUMSS1(2), NUMS(2)
      IXL = IXL1
      XG(1)= XGS(1)
      DO 111 JX = NUMSS1(1), NUMS(1)
      IADR = NUSXY * IZL + NUMS(1) * IYL + IXL - NUMSC
      IJX = ITAB(IADR)
      FUNF1 = FLOAT( IJX ) / 99.
         IF (FIRST1) THEN
            FUNF=SSMINF(X,NSY1,.FALSE.,NSMIN)
            KG=1
            CALL HAVWGT(NSY1,XG,KG,FUNF,WFUNF)
            IF (WFUNF .GT. SYMAX-.1) RETURN
            FIRST1=.FALSE.
            ENDIF
         KG=0
         CALL HAVWGT(NSY1,XG,KG,FUNF,WFUNF)
         IFUNF = NINT(WFUNF * 100.)
         IF (IFUNF .LT. 0) IFUNF = 0
         IF (WFUNF .LT. FUNF1) THEN
            ITAB(IADR) = IFUNF
            IF (SYMXNW.LT.WFUNF) SYMXNW = WFUNF
            ENDIF
      IXL = IXL + 1
      XG(1) = XG(1)+STPX(1)
 111  CONTINUE
      IYL = IYL + 1
      XG(2) = XG(2)+STPX(2)
 222  CONTINUE
      IZL = IZL + 1
      XG(3) = XG(3)+STPX(3)
 333  CONTINUE
      RETURN
      END
      SUBROUTINE HAVWGT (NSY1, X, KG, FUNF, WFUNF)
      DIMENSION  X(3)
      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 /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      DIMENSION XQ1(3,5), XQL(3), XDUMMY(3)
      LOGICAL FIRST
      DATA    FIRST,ITS,NLT,DMAX /.TRUE.,1,0, 0.3/
      WGTV = SWGT(NSY1)
      WFUNF=FUNF
      IF (WGTV.LT.1.1) RETURN
      IF (KG.EQ.1)  GOTO 300
      N1=1
      CALL KERNAB(X,XQ1(1,1),3)
      NDH=NINT(WGTV)
      DO 120 N = 1,NDH-1
      NSS=NSDH(N,NSY1)
      INVERT=1
      IF (NSS.LT.0) INVERT=-1
      NSS=IABS(NSS)
      N1=N1+1
      CALL SYMEQU(NSS,ITS,NLT,INVERT,FIRST,X,XQ1(1,N1),XDUMMY)
      DO 120 NT=1,NLATT
      CALL VPLUSV (XQ1(1,N1),TLATT(1,NT),XQL,3)
      DO 110 N2=1,N1-1
      IF (ISELFD(XQ1(1,N2),XQL,DMAX).EQ.1) THEN
          WGTV=WGTV-1.
          IF (WGTV .LT. 1.1) RETURN
          N1=N1-1
          GOTO 210
      ENDIF
 110  CONTINUE
 120  CONTINUE
 210  CONTINUE
 300  WGTV = (WGTV-1.)*0.5 + 1.
      WFUNF=(WFUNF-PATAD)/WGTV + PATAD
      RETURN
      END
      SUBROUTINE DELPKO (XP, NP, NXYZ)
      DIMENSION XP(5,NP), NXYZ(3)
      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 /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3)
      LOGICAL ENANTI
      DATA  ENANTI /.TRUE./
      DMAX=SQRT( (CELL(1)/NXYZ(1))**2 +
     *      (CELL(2)/NXYZ(2))**2 +
     *      (CELL(3)/NXYZ(3))**2 )
      CALL DELXEQ (XP, NP, NOR, .FALSE., ENANTI, DMAX)
      RETURN
      END
      SUBROUTINE WRCROS (N,NMULN, N2,NMULN2, XNO,NX, P1X2, NMAXP2, NPKS)
      DIMENSION XNO(5,20),P1X2(NMAXP2)
      DO 2200 J = 0, NMULN-1
      M = N + J
      DO 1100 K = 0, NMULN2-1
      M2= N2+ K
      IF (K.EQ.J) THEN
          PXX2 = XNO(4,1)
      ELSE IF (K.GT.0 .AND. J.GT.0) THEN
         PXX2 = XNO(4,2)
      ELSEIF (K.EQ.0) THEN
         IF (J.LT.NX) THEN
            PXX2 = XNO(4,J+1)
         ELSE
            PXX2 = 0.0
         ENDIF
      ELSE IF (J.EQ.0) THEN
          IF (K.LT.NX) THEN
            PXX2 = XNO(4,K+1)
          ELSE
            PXX2 = 0.0
          ENDIF
      ENDIF
      CALL AR2SYM( PXX2,M,M2, NPKS, P1X2, NMAXP2)
 1100 CONTINUE
 2200 CONTINUE
      RETURN
      END
      SUBROUTINE CONSPN(XP,NPKS,MULORD,ICANPK, PISET,NSTS)
      PARAMETER (MXHEAV=20,MXSTSP=140, MXHEV2=MXHEAV+3)
      DIMENSION XP(5, NPKS),MULORD(NPKS), ICANPK(NPKS),
     *          PISET(MXHEV2,MXSTSP)
      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 P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      PARAMETER (MXPKS=150, NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV),
     *                IBRK, ICD, MINBRK
      DIMENSION QPSET(MXHEV2), INP2S(MXSTSP), CVEC(3), VEC23(3)
      LOGICAL  COOK, FSTCOM
      PARAMETER (PMAX = 30254.)
      DATA  QPSET, DMAX  /MXHEV2*0.0, 0.35  /
      IF (NCONS1.EQ.NCONS) THEN
         QPSET(MXHEAV)=-1.0
      ELSE
         QPSET(MXHEAV)= 1.0
      ENDIF
      IF (MINBRK.LE.0 .OR. MINBRK.GT.NCONS) MINBRK=1
      QPSET(MXHEV2)=MINBRK-1
      HEVYN1 = HEAVYN+0.01
      NDIM1 = MXHEV2
      NATM= MXHEAV + 1
      ISQ = MXHEAV + 2
      NH = NCONS
      IF (NET .LT. NH) GOTO 2000
      NEP = NH
      NLVP1 =NSET(2)
      IBRK=1
      IEL(1)=0
      FSTCOM=.TRUE.
      NUPS=0
 1111 CALL UPSETX
      IF (NUPS.LT.100) THEN
          NUPS=NUPS+1
         IF (NUPS.EQ.50) THEN
         ENDIF
      ELSE IF (NUPS.EQ.100) THEN
          NUPS=NUPS+1
      ENDIF
      IF (.NOT.FSTCOM .AND. IBRK.LT.MINBRK) GOTO 2000
      FSTCOM=.FALSE.
      IF (P1METH .AND. IBRK.EQ.2) THEN
            N2=NLVP1
            DO 250 M1=2,NPCT
            IF (ICANPK(M1).GT.LTHV) GOTO 250
            DO 240 M2=M1+1,NPCT
            IF (ICANPK(M2).GT.LTHV) GOTO 240
            NCR=IPOIN1(M1,M2,NPCT)
            IF (P1X2(NCR).GT.0.0) THEN
              CALL VMINV(XP(1,M1),XP(1,M2),CVEC,3)
              ISLF=ISELFD(CVEC,XP(1,N2),DMAX)
              IF(ISLF.EQ.1)  P1X2(NCR)=-P1X2(NCR)
            ENDIF
 240        CONTINUE
 250        CONTINUE
         LVI2 = XP(5, NLVP1)
         NVI2 = XP(5, NPSET(2))
         NLVP1=NPSET(2)
         IF (LVI2.EQ.NVI2) GOTO 1111
      ENDIF
      CALL CHCKCO (ICANPK,NPKS,MULORD,XP,PSETVL,ATMSVL, COOK)
      IF (COOK) THEN
        CALL KERI2F (NPSET,QPSET,NH)
        QPSET(NH+1)= 0.0
        QPSET(NATM)= ATMSVL
        QPSET(ISQ) = PSETVL+ AMIN1(ATMSVL,HEAVYN)*(PMAX-PLIM)
        CALL EL2AR2 (QPSET, NDIM1, ISQ, PISET,MXSTSP, NSTS, INP2S)
      ENDIF
      IF (P1METH .AND. IBRK.EQ.3) THEN
          N2=NPSET(2)
          N3=NPSET(3)
          CALL VMINV(XP(1,N2),XP(1,N3), VEC23, 3)
            DO 320 NT=1,NET
            NP=NSET(NT)
            IF (NP.LT.0) GOTO 320
            IF (ISELFD(VEC23, XP(1,NP), DMAX).EQ.1) NSET(NT)=NP-ICD
 320        CONTINUE
      ENDIF
      GOTO 1111
 2000 CONTINUE
      DO 350 N=1,NET
      DO 340 ID=1,NEP
      IF (NSET(N).GT.0) GOTO 350
      NSET(N)=NSET(N)+ICD
 340  CONTINUE
 350  CONTINUE
      IF(NSTS.GT.1) CALL SORTIN(INP2S,MXSTSP,NSTS, PISET,NDIM1,NSTS)
      IF (P1METH) THEN
            DO 410 M1=2,NPCT
            DO 410 M2=M1+1,NPCT
            NCR=IPOIN1(M1,M2,NPCT)
            IF (P1X2(NCR).LT.0.0) P1X2(NCR)=-P1X2(NCR)
 410        CONTINUE
      ENDIF
      RETURN
      END
      FUNCTION TCOMBS(K,N)
      PARAMETER  (TCOMMX=1.0E+30)
      TCOMBS=1.0
      IF (K.GE.N)  THEN
         IF (K.GT.N) TCOMBS=0.0
         RETURN
      ELSE
         FK=K
         FN=N
         TCOMOF=TCOMMX/(FN-FK)
         DO 110 I=1,K
         TCOMBS=TCOMBS*(FN/FK)
         IF (TCOMBS.GT.TCOMOF)  GOTO  210
         FN=FN-1.
         FK=FK-1.
 110     CONTINUE
         RETURN
      ENDIF
 210  TCOMBS=-TCOMMX
      RETURN
      END
      FUNCTION COMBNO(IEL,K,N)
      DIMENSION       IEL(K)
      PARAMETER  (TCOMMX=1.0E+30)
      IF (K.EQ.1) THEN
         COMBNO=IEL(1)
         RETURN
      ENDIF
      J1=1
      N1=0
      COMBNO=0.0
      DO 210 I=1,K-1
      K1=K-I
      IF (J1.LT.IEL(I)) THEN
        N1=N-J1
        TCO=TCOMBS(K1,N1)
        IF (TCO.LT.0.0 .OR. TCO.GT.TCOMMX-COMBNO) THEN
          COMBNO = -TCOMMX
          RETURN
        ENDIF
        COMBNO = COMBNO + TCO
        J1=J1+1
        FN1K1=N1-K1
        FN1=N1
 111    IF (J1.LT.IEL(I)) THEN
          TCO=TCO*FN1K1/FN1
          IF (TCO.GT.TCOMMX-COMBNO) THEN
            COMBNO = -TCOMMX
            RETURN
          ENDIF
          COMBNO = COMBNO + TCO
          FN1K1=FN1K1-1.
          FN1=FN1-1.
          J1=J1+1
          GOTO 111
        ENDIF
      ENDIF
      J1=IEL(I)+1
 210  CONTINUE
      COMBNO=COMBNO+IEL(K)-IEL(K-1)
      RETURN
      END
c         heavy atomtype.
      SUBROUTINE CHCKCO(ICANPK,NPKS,MULORD,XP,PSETVL,ATMSVL, COOK)
      DIMENSION  ICANPK(NPKS), MULORD(NPKS), XP(5, NPKS)
      LOGICAL COOK
      PARAMETER  (MXPKS=150, MXHEAV=20)
      COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV),
     *                IBRK, ICD, MINBRK
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      DIMENSION  ATMSV(MXHEAV), PSETV(MXHEAV)
      COOK=.FALSE.
      IBRK1= MULSET (NPSET, NEP, MULORD, NPKS)
      LT=LTHV
      IF (IBRK1.LE.1) RETURN
      IBRK2= NRATY(LT,NCONST,LTHV, NPSET,IBRK1-1, ICANPK,NPKS)
      IF (IBRK2.EQ.IBRK) RETURN
      HEVYN1 = HEAVYN+0.01
      IBRK3=IBRK2
      DO 130 I = IBRK, IBRK2-1
      II=NPSET(I)
      IF (I.EQ.1) THEN
         ATMSV(1) = AMIN1(XP(5,II),1.0)
         PSETV(1) = XP(4,II)
      ELSE
         ATMSV(I) = ATMSV(I-1) + AMIN1( XP(5,II), 1.0)
         PSETV(I) = AMIN1 (PSETV(I-1), XP(4,II))
      ENDIF
      IF (ATMSV(I).GT.HEVYN1) THEN
        IBRK3=I
        GOTO 200
      ENDIF
      DO 120  J = 1, I-1
      JJ=NPSET(J)
      IJ = IPOIN1(JJ,II, NPCT)
      IF (P1X2(IJ) .LT. PLIM) THEN
        IBRK3=I
        GOTO 200
      ENDIF
      IF (PSETV(I).GT.P1X2(IJ)) PSETV(I) = P1X2(IJ)
 120  CONTINUE
 130  CONTINUE
      IF (IBRK2-1 .EQ. NEP) THEN
        PSETVL=PSETV(NEP)
        ATMSVL=ATMSV(NEP)
      ENDIF
 200  IF (IBRK3 .EQ. IBRK) RETURN
      NP2=IBRK3-1
      CALL TSTPKS(NP2,ICANPK,NPKS, COOK)
      RETURN
      END
      SUBROUTINE SELCPK(XP2,NPKS, ICANPK)
      PARAMETER (MXPKS = 150)
      DIMENSION  XP2(5, MXPKS), ICANPK(MXPKS)
      PARAMETER                 (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      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  ICCPK(MXPKS)
      ISQ=2
      CALL KERNZI(0,ICANPK,NPKS)
      DO 330 N=1,NPKS
      DO 320 IT=1,LTHV
      IF (ICANPK(N).LE.IT .AND. XP2(4,N).GT.PLIMS(IT)) THEN
         ICANPK(N)=IT
         GOTO 330
      ENDIF
 320  CONTINUE
      ICANPK(N)=LTHV+1
 330  CONTINUE
      NCYCLE = 0
      DO 350 N=1,NPKS
      IT1=ICANPK(N)
      DO 340 IT=IT1,LTHV
      CALL ATYPKS(N,IT,NPKS,ICANPK,NCYCLE,ICCPK,NHT)
      IF (IT.EQ.NHT) THEN
         ICANPK(N)=IT
         GOTO 350
      ENDIF
 340  CONTINUE
      ICANPK(N)=LTHV+1
 350  CONTINUE
      ITEST=0
      RETURN
      END
      SUBROUTINE TSTPKS(NP2, ICANPK,NPKS, COOK)
      DIMENSION             ICANPK(NPKS)
      LOGICAL                            COOK
      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 P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      PARAMETER  (MXPKS=150, MXHEAV=20)
      COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV),
     *                IBRK, ICD, MINBRK
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      DIMENSION ICCPK(MXPKS), ICAPKL(MXPKS,MXHEAV)
      LOGICAL  OKF
      NCYCLE=1
      IF (IBRK.EQ.1) THEN
        NI1=1
        CALL KERNZI(LTHV+1,ICAPKL(1,1),NPKS)
        DO 102 NR=1,NET
        NO=NSET(NR)
        ICAPKL(NO,1)=ICANPK(NO)
 102    CONTINUE
      ELSE
        NI1=IEL(IBRK-1)+1
      ENDIF
      COOK=.FALSE.
      NP1=IBRK
      DO 210 NN=NP1,NP2
      N=NPSET(NN)
      NI=IEL(NN)
      DO 104 MI=NI1,NI-1
      M=NSET(MI)
 104  IF (M.GT.0) ICAPKL(M,NN)=LTHV+1
      OKF=.FALSE.
      NHT=LTHV+1
      LTN=LTHV
      IF (P1METH .AND. NN.EQ.1) THEN
       LTN=1
      ELSE IF (NN.LE.NCONS1 .AND. LT1.LT.LTHV) THEN
       LTN=LT1
      ENDIF
      DO 150 I = LTN, ICAPKL(N,NN), -1
      IF (I .GT. NHT) GOTO 150
      CALL ATYPKS(N,I,NPKS,ICAPKL(1,NN),NCYCLE,ICCPK,NHT)
      IF (NHT.EQ.0) GOTO 160
      IF (I.GT.NHT) GOTO 150
      IF (NRATY(NHT,NCONST,LTHV,NPSET,NN,ICCPK,NPKS).LE.NN)  GOTO 150
      IF (I .GT. NHT)  GOTO 150
      IF (NN.EQ.NEP) THEN
         COOK=.TRUE.
         RETURN
      ENDIF
      IF (OKF) THEN
        ICAPKL(N,NN+1)=I
      ELSE
        OKF=.TRUE.
        ICAPKL(N,NN+1)=I
        DO 110 M=1,NPKS
 110    IF (M.NE.N) ICAPKL(M,NN+1)=ICCPK(M)
        DO 120 NR=1,NET
        NO=NSET(NR)
        IF (NO.GT.0) THEN
          IF (ICAPKL(NO,NN+1) .LE. LTHV)  GOTO 120
        ENDIF
        NSET(NR)=NO-ICD
 120    CONTINUE
        IBRK=NN+1
      ENDIF
 150  CONTINUE
 160  IF (.NOT.OKF) RETURN
      NI1=NI+1
 210  CONTINUE
      IBRK=NP2+1
      RETURN
      END
      SUBROUTINE ATYPKS(N,I,NPKS,ICANPK,NCYCLE,ICCPK,NHT)
      DIMENSION                  ICANPK(NPKS),ICCPK(NPKS)
      PARAMETER      (MXPKS = 150)
      DIMENSION ICCDY(MXPKS)
      LOGICAL   CHCTYP
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      CALL TSTATY(N,I,NPKS,ICANPK, ICCPK,NHT)
      IF (NHT.NE.I  .OR. NCONS.LT.3 .OR. NCYCLE.EQ.0)  RETURN
      DO 310 NCY=1,NCYCLE
      CHCTYP = .FALSE.
      DO 210 M=1,NPKS
      IF (M.EQ.N .OR. ICCPK(M).GT.LTHV) GOTO 210
      J1=ICCPK(M)
      MHT=LTHV+1
      MJ=MHT
      DO 110 J=LTHV,J1,-1
      IF (J .GT. MHT)  GOTO 110
      CALL TSTATY(M,J,NPKS,ICCPK,ICCDY, MHT)
      IF (J.EQ.MHT) MJ=J
      IF (MHT.EQ.0) THEN
        IF (ICCPK(M) .LT. MJ) THEN
          CHCTYP=.TRUE.
          ICCPK(M)=MJ
        ENDIF
        GOTO 210
      ENDIF
 110  CONTINUE
 210  CONTINUE
      IF (CHCTYP) THEN
          NHT = NATYOK (N,I, ICCPK,NPKS, NCONST,LTHV)
          IF (NHT.EQ.0) RETURN
      ELSE
          RETURN
      ENDIF
 310  CONTINUE
      RETURN
      END
      SUBROUTINE TSTATY (N,I,NP, ICANPK, ICCPK, NHT)
      DIMENSION              ICANPK(NP), ICCPK(NP)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      PARAMETER      (MXPKS=150, NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      CALL KERNAI (ICANPK,ICCPK,NP)
      DO 210 M=1,NP
      IF (M.EQ.N .OR. ICCPK(M).GT.LTHV) GOTO 210
      NM = IPOIN1(N,M,NPCT)
      DO 110 J=1,LTHV
      IF (P1X2(NM).GT.PLIMC(I,J)) THEN
         IF (ICCPK(M).LT.J) ICCPK(M)=J
         GOTO 210
      ENDIF
 110  CONTINUE
      ICCPK(M)=LTHV+1
 210  CONTINUE
      NHT = NATYOK (N,I, ICCPK,NP, NCONST,LTHV)
      RETURN
      END
      FUNCTION NATYOK (N,I, ICANPK,NP, NCONST,LT)
      DIMENSION  NCONST(LT), ICANPK(NP), NPTY(11), NCTY(11)
      CALL KERNZI (0, NPTY, 11)
      DO 110 M = 1,NP
      IF (M.NE.N) NPTY(ICANPK(M))=NPTY(ICANPK(M)) + 1
 110  CONTINUE
      DO 420 II=I,ICANPK(N),-1
      CALL KERNAI(NPTY,NCTY,11)
      NCTY(II)=NCTY(II)+1
      DO 410 J=1,LT
      IF (NCTY(J).LT.NCONST(J)) GOTO 420
      IF (J.LT.LT) THEN
         NCTY(J+1)=NCTY(J+1) + (NCTY(J)-NCONST(J))
         NCTY(J)=NCONST(J)
      ENDIF
 410  CONTINUE
      NATYOK = II
      RETURN
 420  CONTINUE
      NATYOK = 0
      RETURN
      END
      FUNCTION NRATY (J,NCONST,LT, IPKSET,NPS, ICANPK,NP)
      DIMENSION  NCONST(LT), IPKSET(NPS), ICANPK(NP), NPTY(11)
      CALL KERNZI (0, NPTY, 11)
      DO 210 M = 1,NPS-1
      N=IPKSET(M)
      I=ICANPK(N)
 111  CONTINUE
      IF (NPTY(I).LT.NCONST(I)) THEN
          NPTY(I)=NPTY(I) + 1
      ELSE
          I=I+1
          IF (I.LE.LT) GOTO 111
          NPTY(I-1)=NPTY(I-1)+1
          NRATY=M
          RETURN
      ENDIF
 210  CONTINUE
      N=IPKSET(NPS)
      J1=J
      DO 310 I = J1, ICANPK(N), -1
      IF (NPTY(I).LT.NCONST(I)) THEN
          J=I
          NRATY=NPS+1
          RETURN
      ENDIF
 310  CONTINUE
      NRATY=NPS
      RETURN
      END
      SUBROUTINE UPSETX
      PARAMETER  (MXPKS=150, MXHEAV=20)
      COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV),
     *                IBRK, ICD, MINBRK
      IF (IEL(1) .EQ. 0) THEN
         DO 101 I = 1,NEP
         NPSET(I)=NSET(I)
 101     IEL(I) = I
         IBRK=1
         ICD=0
         DO 102 I = 1,NET
 102     IF (ICD.LT.NSET(I))  ICD=NSET(I)
         ICD=ICD+1
         RETURN
      ENDIF
      IBRKI = IBRK
      DO 500 I = IBRKI,1,-1
      IF (IEL(I) .NE. NET-NEP+I) THEN
        IF (I.LT.IBRK) THEN
          DO 220 N=1,NET
          DO 210 ID=1,IBRK-I
          IF (NSET(N).GT.0) GOTO 220
          NSET(N)=NSET(N)+ICD
 210      CONTINUE
 220      CONTINUE
          IBRK=I
        ENDIF
        NR = IEL(I)
        DO 320 J=I-1, NEP-1
 310    NR = NR + 1
        IF (NR .LE. NET-NEP+J+1) THEN
           IF (NSET(NR).LT.0) GOTO 310
           IEL(J+1)=NR
        ELSE
           GOTO 500
        ENDIF
 320    CONTINUE
         DO 410 J=I,NEP
 410     NPSET(J)=NSET(IEL(J))
         RETURN
      ENDIF
 500  CONTINUE
      IEL(1)=0
      IBRK=0
      RETURN
      END
      FUNCTION MXESUM (X, NX, SUMMX)
      DIMENSION X(5,NX)
      PARAMETER (MXE=100)
      DIMENSION E(MXE)
      SUM = 0.0
      MXESUM=0
      JMAX=1
      DO 510 N = 1,NX
      IF (MXESUM.LT.MXE) THEN
         MXESUM = MXESUM+1
      ELSE
         MXESUM=-MXESUM
         RETURN
         ENDIF
      E(MXESUM) = X(5,N)
      IF (SUM+E(MXESUM).LT.SUMMX+0.0001) THEN
            SUM=SUM+E(MXESUM)
            IF (E(MXESUM).GT.E(JMAX)) JMAX=MXESUM
      ELSE
         IF (E(MXESUM).LT.E(JMAX)) THEN
            SUM=SUM-E(JMAX)
            SUM=SUM+E(MXESUM)
            E(JMAX)=E(MXESUM)
            DO 110 J=1,MXESUM-1
            IF (E(J).GT.E(JMAX)) JMAX=J
 110        CONTINUE
         ENDIF
         MXESUM=MXESUM-1
      ENDIF
 510  CONTINUE
      RETURN
      END
      FUNCTION MULSET (NPSET, NP, NMUL, N)
      DIMENSION NPSET(NP), NMUL(N)
      M=0
      DO 1000 NN = 1, NP
      NPSTNN = NPSET(NN)
      IF (NMUL(NPSTNN) .GT. 0) THEN
            M = NN
            GOTO 1000
      ELSE IF (M.NE.0) THEN
           IF (NPSTNN-NN+M .EQ. NPSET(M)) GOTO 1000
      ENDIF
            MM= NN
            GOTO 1100
 1000 CONTINUE
      MM = NP + 1
 1100 MULSET = MM
      RETURN
      END
      FUNCTION SMINF (X, XS, NEQP,NXS, NXSEQX)
      DIMENSION X(3), XS(3,NEQP,NXS)
      DIMENSION VECS(3,48)
      DATA  NV, VALMAX /48, 30254./
      SMINF=VALMAX
      DO 120 NX = 1,NXS
      IF (NX .EQ. NXSEQX) GOTO 120
      CALL VECXXS( X, XS(1,1,NX), NEQP, VECS, NV, NVECS)
      DO 110 N = 1, NVECS
      CALL GRDOUT(VECS(1,N), FUNF)
      IF (SMINF .GT. FUNF) SMINF = FUNF
 110  CONTINUE
 120  CONTINUE
      RETURN
      END
      FUNCTION SSMINF (X,NREQP, WGTING, NEMIN)
      DIMENSION X(3)
      LOGICAL   WGTING
      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 /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      DIMENSION VXYZ(3)
      DIMENSION VXYZT(3)
      DATA  VALMAX /30254./
      SSMINF=VALMAX
      NEMIN=0
      KG=0
      WGTV=1.0
      IF (NREQP .GT. 1) THEN
          NE1= NREQP
          NEQP=NREQP
      ELSE
         NE1= 2
         NEQP = NSSY
         ENDIF
      DO 500 NE = NE1, NEQP
      CALL HARVEC (IRSY1(1,1,NE), TSY1(1,NE), X, VXYZ)
      CALL REDFCO (VXYZ, VXYZ, 3)
      DO 125 NL=1,NLATT
      VXYZT(1)=VXYZ(1)+TLATT(1,NL)
      VXYZT(2)=VXYZ(2)+TLATT(2,NL)
      VXYZT(3)=VXYZ(3)+TLATT(3,NL)
      CALL REDFCO (VXYZT, VXYZT, 3)
      DO 120 I=1,3
      IF (ABS(VXYZT(I)) .GT. 1.5*FSTPSY(I)) GOTO 125
 120  CONTINUE
      FUNF = VALMAX
      GOTO 130
 125  CONTINUE
      CALL GRDOUT (VXYZ, FUNF)
      IF (WGTING) THEN
         CALL HAVWGT (NE,X,KG,FUNF,WFUNF)
         FUNF=WFUNF
      ENDIF
 130  IF (SSMINF.GT.FUNF) THEN
          SSMINF=FUNF
          NEMIN=NE
      ENDIF
 500  CONTINUE
      RETURN
      END
      FUNCTION OCMINF (X,XS,NEQP, NXS, NXSEQX, ENANTI, PLIMM, XOUT,NOUT)
      DIMENSION X(3), XS(3,NEQP,NXS), XOUT(5,NOUT)
      LOGICAL ENANTI
      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 /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      COMMON /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3)
      PARAMETER (MXHEAV=20)
      DIMENSION XO(3), XL(3), XOU(5), INXOUT(MXHEAV)
      LOGICAL ONEXT, OSTART, PEAK
      DATA NADDED /0/
      CALL KERNAB (X,XL,3)
      PLIM1=PLIMM-0.1
      OCMINF = 0.0
      IF (NOUT .GT. 1) THEN
         NADDED = 0
         IF (NOUT .GT. MXHEAV) NOUT = MXHEAV
         ENDIF
      ONEXT = .TRUE.
      IF (ENANTI .AND. ICENT.EQ.1) THEN
         NEN = -1
      ELSE
         NEN = 1
         ENDIF
      DO 310 NE = 1,NEN,-2
      DO 210 NO = 1,NOR
      OSTART=.TRUE.
 110  CALL ORSHIX( XL, ORIG(1,NO), XO, ONEXT)
      SMINX = SMINF (XO, XS, NEQP, NXS, NXSEQX)
      IF (OCMINF .LT. SMINX) THEN
         OCMINF = SMINX
         IF (NOUT.EQ.1) THEN
            CALL KERNAB(XO,XOU,3)
            XOU(4)= OCMINF
            IF (ICENT.EQ.2) XOU(4)= (OCMINF-PATAD)/2.00+PATAD
            XOU(5) = NE
            ENDIF
         ENDIF
      IF (NOUT .GT. 1) THEN
         CALL PKS1DF (XO, SMINX, PLIM1, OSTART, ONEXT, XOU,FUNXOU, PEAK)
         IF (PEAK) THEN
            XOU(4) = FUNXOU
            IF (ICENT.EQ.2) XOU(4)= (FUNXOU-PATAD)/2.00 +PATAD
            XOU(5) = NE
            CALL EL2AR2 (XOU,5,4, XOUT,NOUT, NADDED, INXOUT)
            ENDIF
         ENDIF
      IF (.NOT. ONEXT) GOTO 110
 210  CONTINUE
      IF (NEN.EQ.-1) CALL INVAB (X,XL,3)
 310  CONTINUE
      IF (ICENT.EQ.2) OCMINF = (OCMINF-PATAD)/2.00 + PATAD
      IF (NOUT.EQ.1) THEN
         IF (OCMINF .GT. PLIMM) THEN
            CALL KERNAB(XOU, XOUT(1,1), 5)
         ELSE
            NOUT = 0
         ENDIF
      ENDIF
      IF (NOUT.GT.1) THEN
         NOUT = NADDED
         IF (NADDED.GT.1)
     *      CALL SORTIN(INXOUT,MXHEAV,NADDED, XOUT,5,NOUT)
         ENDIF
      RETURN
      END
      SUBROUTINE PKS1DF (X3, FUNX3, FLIM, START, STOP, XPK,FUNPK, PEAK)
      DIMENSION X3(3) , XPK(5)
      LOGICAL START, STOP, PEAK
      DIMENSION X1(3), X2(3), X4(3)
      LOGICAL SECPNT
      PARAMETER (PMAX=30254., FUNMAX=PMAX)
      DATA  FUNX1,FUNX2,FUNX4,FUNX5, SECPNT /0.,0.,0.,0.,.FALSE./
      IF (START .AND. STOP) THEN
         START = .FALSE.
         PEAK = FUNX3.GT.FLIM
         IF (PEAK) THEN
            CALL KERNAB (X3,XPK,3)
            FUNPK=FUNX3
         ENDIF
         RETURN
      ENDIF
      IF (START) THEN
         START = .FALSE.
         SECPNT= .TRUE.
         PEAK = .FALSE.
         FUNX1 = FUNMAX
         CALL KERNAB (X3,X4,3)
         FUNX4 = FUNX3
         CALL KERNAB (X3,X2 ,3)
         FUNX2 = FUNX3
         RETURN
      ENDIF
      PEAK = FUNX2.GT.FLIM .AND. FUNX2.GT.FUNX1 .AND. FUNX2.GE.FUNX3
      IF (PEAK) THEN
          CALL KERNAB (X2,XPK,3)
          FUNPK=FUNX2
          IF (STOP) RETURN
      ENDIF
      IF (STOP) THEN
         PEAK = FUNX3.GT.FLIM .AND. FUNX3.GT.FUNX2 .AND. FUNX3.GE.FUNX4
         IF (PEAK) THEN
            CALL KERNAB (X3,XPK,3)
            FUNPK=FUNX3
            RETURN
         ENDIF
         PEAK = FUNX4.GT.FLIM .AND. FUNX4.GT.FUNX3 .AND. FUNX4.GE.FUNX5
         IF (PEAK) THEN
            CALL KERNAB (X4,XPK,3)
            FUNPK=FUNX4
         ENDIF
         RETURN
      ENDIF
      IF (SECPNT) THEN
          FUNX5 = FUNX3
          SECPNT =.FALSE.
      ENDIF
      CALL KERNAB (X2,X1 ,3)
      FUNX1 = FUNX2
      CALL KERNAB (X3,X2 ,3)
      FUNX2 = FUNX3
      RETURN
      END
      SUBROUTINE ORSHIX (X, ORIG, XO, ONEXT)
      DIMENSION X(3), ORIG(3), XO(3)
      LOGICAL ONEXT
      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 /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3)
      DIMENSION ORSH(3), FRSTEP(3), NGPXYZ(3)
      LOGICAL FIRST, STARTS
      DATA  FIRST /.TRUE./
      DATA NGPXYZ / 1,1,1 /
      DATA NGP / 0 /
      IF (FIRST) THEN
            FIRST = .FALSE.
            ONEXT = .TRUE.
        IF (IPOLA.NE.0) THEN
            DO 101 I=1,3
 101        FRSTEP(I)= 1./GTXYZ(I)
          IF(MOD(IPOLA,2) .EQ.1 ) NGPXYZ(1)=NXYZ(1)
          IF(IPOLA.EQ.3 .OR. IPOLA.EQ.2 .OR. IPOLA.EQ.6 .OR. IPOLA.EQ.7)
     *      NGPXYZ(2)=NXYZ(2)
          IF(IPOLA.GE.4 .AND. IPOLA.LE.7) NGPXYZ(3)=NXYZ(3)
          IF(IPOLA.EQ.8) THEN
            FRSTEP(2)=FRSTEP(1)
            FRSTEP(3)=FRSTEP(1)
            NGPXYZ(1)=NXYZ(1)
            NGPXYZ(2)=NXYZ(1)
            NGPXYZ(3)=NXYZ(1)
          ENDIF
        ENDIF
      ENDIF
      IF (IPOLA.EQ.0) THEN
            CALL KERNAB (ORIG, ORSH, 3)
      ELSE IF (IPOLA.NE.8) THEN
            STARTS = ONEXT
            IF (STARTS) NGP = 0
            CALL SCAN3D (ORIG, ORSH, FRSTEP, NGPXYZ, NGP,STARTS)
            ONEXT = STARTS
      ELSE
            IF (ONEXT) THEN
            ONEXT = .FALSE.
            CALL KERNAB (ORIG, ORSH, 3)
            NGP = 0
            ELSE
            CALL VPLUSV (ORSH, FRSTEP, ORSH, 3)
            NGP=NGP + 1
            IF (NGP .EQ. NGPXYZ(1)) THEN
            ONEXT = .TRUE.
            ENDIF
            ENDIF
      ENDIF
      CALL VMINV (X, ORSH, XO, 3)
      RETURN
      END
      SUBROUTINE GRDOUT (ARG, FUNF)
      DIMENSION ARG(3)
      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 (ITPL, KEYS(7))
      COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3)
      EQUIVALENCE (NX, NUM(1)), (NY, NUM(2)), (NXY, NUMXY)
      DIMENSION IFAR(3), INEAR(3), RARG(3), FM(3)
      EQUIVALENCE (IXFAR,IFAR(1)), (IYFAR,IFAR(2)), (IZFAR,IFAR(3))
      EQUIVALENCE (IXNEAR,INEAR(1)),(IYNEAR,INEAR(2)),(IZNEAR,INEAR(3))
      EQUIVALENCE (RX,RARG(1)), (RY,RARG(2)), (RZ,RARG(3))
      EQUIVALENCE (FMX,FM(1)), (FMY,FM(2)), (FMZ,FM(3))
      IF (ITPL.NE.10) THEN
       CALL RDOUTT(ARG, FUNF)
       RETURN
      ENDIF
      DO 301 J= 1, 3
      RARG(J) = AMOD(ARG(J),1.0)
      IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0
  301 IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0
      CALL SYMM (RX, RY, RZ)
      DO 599 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      IF (T) 540, 550, 550
  540 T = T - 1.
  544 I = IFIX(T)
      IF (I.GE.-LXYZ(IX)) GOTO 555
      T = T + 0.01
      GOTO 544
  550 I = IFIX(T)
      IF (I.LT.LXYZ(IX)) GOTO 555
      T = FLOAT(I) - 0.01
      GOTO 550
  555 F=T-FLOAT(I)
      IF (F) 560,590,570
  560 F=F+1.0
  570 IF (F-0.5) 590,580,580
  580 FM(IX) = 1. - F
      IFAR(IX)=I
      INEAR(IX)=I+1
      GOTO 599
  590 FM(IX) = F
      INEAR(IX)=I
      IFAR(IX)=I+1
  599 CONTINUE
      CALL LINPOL(INEAR,IFAR,FM,FUNF)
      RETURN
      END
      SUBROUTINE LINPOL(INEAR,IFAR,FM,FUNF)
      DIMENSION INEAR(3),IFAR(3),FM(3)
      COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3)
      EQUIVALENCE (NX, NUM(1)), (NY, NUM(2)), (NXY, NUMXY)
      DIMENSION IXB(3),XB(3),FUN(3)
      PARAMETER (NUMTAB =300000)
      COMMON / / ITAB(NUMTAB)
      INTEGER * 2 ITAB
      K111 = NXY * INEAR(3)+ NX * INEAR(2) + INEAR(1) - NUMC
      IJX = ITAB(K111)
      FUN2 = FLOAT( IJX ) / 99.
      DO 400 I=1,3
      KFAR = K111-INEAR(I)+IFAR(I)
      IJX = ITAB(KFAR)
      FUN3 = FLOAT( IJX ) / 99.
      FUN(I) = FUN2 + (FUN3-FUN2)*FM(I)
      DO 110 J=1,3
 110  IXB(J)=INEAR(J)
      IXB(I)=INEAR(I)-IFAR(I)+INEAR(I)
      IF (IXB(I).LT.IS(I) .OR. IXB(I).GT.LXYZ(I)) THEN
          DO 120 J=1,3
           XB(J)=IXB(J)/GTXYZ(J)
           XB(J) = AMOD(XB(J),1.0)
           IF (XB(J) .GE. 0.5) XB(J) = XB(J) - 1.0
 120       IF (XB(J) .LT. -.5) XB(J) = XB(J) + 1.0
          CALL SYMM(XB(1),XB(2),XB(3))
          DO 130 J=1,3
           XB(J)=XB(J)*GTXYZ(J)
           IXB(J)=NINT(XB(J))
           IF (ABS(IXB(J)-XB(J)).GT.0.1) THEN
            GOTO 400
          ENDIF
 130     CONTINUE
      ENDIF
      KBEG = NXY*IXB(3)+NX*IXB(2)+IXB(1)-NUMC
      IJX = ITAB(KBEG)
      FUN1 = FLOAT( IJX ) / 99.
      FUN(I)=
     * FUN2+((FUN3-FUN1)*FM(I))/2.-((2.*FUN2-FUN3-FUN1)*FM(I)*FM(I))/2.
 400  CONTINUE
      FUNF = FUN(1) + FUN(2)-FUN2 + FUN(3)-FUN2
      RETURN
      END
      SUBROUTINE SCAN3D (X1, X, STEPX, NGPXYZ, NRGRIP, START)
      LOGICAL START
      DIMENSION X1(3),X(3),STEPX(3),NGPXYZ(3)
      DIMENSION XMAX(3)
      DATA LGRIP / 0 /
      IF (START) THEN
          CALL KERNAB (X1,X,3)
          DO 110 I=1,3
 110        XMAX(I) = X1(I)+ ( (NGPXYZ(I)-1.5) * STEPX(I) )
          LGRIP = NRGRIP-1 + NGPXYZ(1)*NGPXYZ(2)*NGPXYZ(3)
          START =.FALSE.
          RETURN
      ENDIF
      IF(X(1).LT.XMAX(1)) THEN
            X(1)= X(1)+STEPX(1)
      ELSE
            X(1)=X1(1)
            IF(X(2).LT.XMAX(2)) THEN
            X(2)= X(2)+STEPX(2)
            ELSE
            X(2)=X1(2)
            X(3)= X(3)+STEPX(3)
            ENDIF
      ENDIF
      NRGRIP = NRGRIP + 1
      IF (NRGRIP .EQ. LGRIP) START = .TRUE.
      RETURN
      END
      SUBROUTINE VECXXS (X, XS, NEQP, VECS, NV, NVECS)
      DIMENSION X(3), XS(3,NEQP), VECS(3,NV)
      LOGICAL PATSYM,TLATTI
      DATA  PATSYM,TLATTI /.FALSE.,.FALSE./
      IF(NEQP.EQ.1) THEN
          CALL ALLEQP (XS, VECS, NV, PATSYM,TLATTI, NVECS)
          DO 110 M = 1, NVECS
 110      CALL VMINV(X,VECS(1,M),VECS(1,M),3)
      ELSE
          NVECS = NEQP
          DO 120 M = 1, NVECS
 120      CALL VMINV(X, XS(1,M), VECS(1,M),3)
      ENDIF
      RETURN
      END
      SUBROUTINE HAMAWT
      COMMON /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      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 IRSYEQ(3,3),TM(3),TSM(3)
      DO 100 I=1,3
      TSY1(I,1) = 0.
      DO 100 J=1,3
      IRSY1(I,J,1) = 0
 100  CONTINUE
      CALL KERNZA (1., SWGT, 48)
      SWGT(1) = 0.
      CALL KERNZI (0, NSDH, 192)
      INVEND=1-ICENT
      NSY1=0
      DO 300 INV = 1,INVEND,-2
      DO 200 NS=1,NSYMM
      NSY1=NSY1+1
      IF (NSY1 .EQ. 1) GOTO 200
      DO 120 I=1,3
      DO 110 J=1,3
      IRSY1(I,J,NSY1) = -(INV * IRSYMM(I,J,NS))
 110  CONTINUE
      IRSY1(I,I,NSY1) = IRSY1(I,I,NSY1) + 1
      TSY1(I,NSY1) = -INV*TSYMM(I,NS)
 120  CONTINUE
      DO 150 NP=1,NSYMM
      CALL IMAXMA(IRSYMM(1,1,NP),IRSY1(1,1,NSY1), IRSYEQ)
      DO 140 NSY=2,NSY1-1
      INVNP=IMATEQ(IRSYEQ,IRSY1(1,1,NSY),3)
      IF (INVNP.EQ.0) GOTO 140
      DO 130 I=1,3
      TSYEQ= INVNP*(IRSYMM(I,1,NP)*TSY1(1,NSY1)+
     *   IRSYMM(I,2,NP)*TSY1(2,NSY1)+IRSYMM(I,3,NP)*TSY1(3,NSY1))
      TM(I)=TSYEQ-TSY1(I,NSY)
 130  CONTINUE
      DO 135 NT=1,NLATT
      DO 134 I=1,3
      TMLI=TM(I)+TLATT(I,NT)
      TMLI=TMLI-NINT(TMLI)
      IF (ABS(TMLI).GT.0.01) GOTO 135
 134  CONTINUE
      NSY1=NSY1-1
      GOTO 200
 135  CONTINUE
 140  CONTINUE
 150  CONTINUE
      SWGT(NSY1)=1.
      ND=0
      DO 180 NS1=1,NSYMM
      DO 175 INVER1=1,INVEND,-2
      IF (NS1.NE.1 .OR. INVER1.EQ.-1) THEN
      DO 171 INVER2=1,INVEND,-2
      DO 170 NS2=1,NSYMM
      DO 161 I=1,3
      DO 160 J=1,3
      IRSYIJ=INVER1*IRSYMM(I,J,NS1) - INVER2*IRSYMM(I,J,NS2)
      IF (IRSYIJ .NE. IRSY1(I,J,NSY1)) GOTO 170
 160  CONTINUE
      TSM(I)=INVER1*TSYMM(I,NS1)-INVER2*TSYMM(I,NS2) - TSY1(I,NSY1)
 161  CONTINUE
      DO 165 NT=1,NLATT
      DO 164 I=1,3
      TMLI=TSM(I)+TLATT(I,NT)
      TMLI=TMLI-NINT(TMLI)
      IF (ABS(TMLI).GT.0.01) GOTO 165
 164  CONTINUE
      SWGT(NSY1) = SWGT(NSY1) +1.
      ND=ND+1
      NSDH(ND,NSY1)=INVER1*NS1
      IF (ND.EQ.4) GOTO 200
      GOTO 180
 165  CONTINUE
 170  CONTINUE
 171  CONTINUE
      ENDIF
 175  CONTINUE
 180  CONTINUE
      IF (ND.LT.4) NSDH(ND+1,NSY1)=0
 200  CONTINUE
 300  CONTINUE
      NSSY=NSY1
      RETURN
      END
      SUBROUTINE IMAXMA( IA, IB, IAXIB )
      DIMENSION IA(3,3), IB(3,3), IAXIB(3,3)
      DO 200 L = 1,3
      DO 100 K = 1,3
      IAXIB(L,K) = IA(L,1)*IB(1,K) + IA(L,2)*IB(2,K) + IA(L,3)*IB(3,K)
  100 CONTINUE
  200 CONTINUE
      RETURN
      END
      FUNCTION IMATEQ( IA, IB, N)
      DIMENSION IA(N,N), IB(N,N)
      IMATEQ = 0
      INVERT=1
 110  CONTINUE
      DO 200 J = 1, N
      DO 200 I = 1, N
      IF ( IA(I,J) .NE. INVERT*IB(I,J) ) THEN
        IF (INVERT.EQ.-1) RETURN
        INVERT=-1
        GOTO 110
      ENDIF
  200 CONTINUE
      IMATEQ = INVERT
      RETURN
      END
      SUBROUTINE FIXONE(XP,NX, PISET,NSETS, PLIM, X,NSTSX)
      PARAMETER (MXHEAV=20, MXSTSX=30)
      DIMENSION XP(5, NX), PISET(MXHEAV+3,NSETS), PLIM(3),
     *       X(4*MXHEAV+5,MXSTSX)
      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 P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      PARAMETER (MXVC=(MXHEAV*MXHEAV-MXHEAV)/2,
     *      RTMXH1=4.4, MXVW= 1.5 * MXHEAV * RTMXH1)
      COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1,
     *      XEO(5,MXHEAV),
     *      NVEC, VEC(4,MXVC), NP1P2(2,MXVC),
     *      NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW),
     *      IMPNTS(MXHEAV),
     *      VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX)
      DIMENSION INXEO(MXHEAV), X1(4,MXHEAV)
      CALL KERNZA (0.0, XF, 4*MXHEAV+5)
      IF (NSTSX .GT. MXSTSX) NSTSX=MXSTSX
      IF (NSTSX .LE. 0) FATSMX=0.0
      MINPTS = FATSMX+0.01
      IF (MINPTS.LT.2) MINPTS=2
      DO 510 M=1,NSETS
      N=1
 111  NP = PISET(N,M)+0.1
      IF (NP.NE.0 .AND. N.LE.MXHEAV) THEN
           CALL KERNAB (XP(1,NP), XEO(1,N), 5)
         N=N+1
         GOTO 111
      ELSE
         N=N-1
      ENDIF
      MAXPTS=N
      NPONT1=NINT(PISET(MXHEAV+3,M))
      IF (P1METH) THEN
          NCM=NQSET(PISET(1,M),MAXPTS)
          VASETM=PISET(MXHEAV+2,M)+0.1
          DO 115 M1=M-1,1,-1
          IF (PISET(MXHEAV+2,M1).GT.VASETM) GOTO 116
          IF (NCM .EQ. NQSET(PISET(1,M1),MAXPTS)) GOTO 510
 115      CONTINUE
 116      CALL SYSRCH(XEO,5,MAXPTS, X1, NX1)
          ATMS=0.0
          DO 120 N1=1,NX1
 120      ATMS=ATMS+X1(4,N1)
          IF (NINT(ATMS*NSYMM*ICENT).NE.MAXPTS) THEN
             PISET(MXHEAV,M)=0.0
             GOTO 510
          ENDIF
          NSTSX=NSTSX+1
          DO 121 N1=1,NX1
 121      CALL KERNAB (X1(1,N1), X(N1*4-3,NSTSX), 4)
          X(4*MXHEAV+1,NSTSX)=NX1
          X(4*MXHEAV+2,NSTSX)=ATMS
          X(4*MXHEAV+3,NSTSX)=PISET(MXHEAV+2,M)
          X(4*MXHEAV+5,NSTSX)=M
          IF (NSTSX.EQ.MXSTSX) RETURN
      ELSE
          CALL DETSEQ( INXEO,N, XEO,5,MAXPTS, 5, 0)
          ATMS=0.0
          DO 210 N=1,MAXPTS
          ATMS=ATMS+XEO(5,INXEO(N))
          IF (ATMS.GT.FATSMX-0.01) THEN
            MINPTS=N
            GOTO 220
          ENDIF
 210      CONTINUE
          GOTO 510
 220      NPONTS=MAXPTS
          IF (MINPTS.LT.2) MINPTS=2
          XF(4*MXHEAV+5) = M
          XF(4*MXHEAV+1) = 0.0
          CALL VIMAGE (PLIM, X, NSTSX)
          IF (XF(4*MXHEAV+1).LT.0.1)  PISET(MXHEAV,M)=0.0
      ENDIF
 510  CONTINUE
      IF (P1METH) RETURN
      MXIN=MXSTSX
      IF (NSTSX.GT.0) CALL SORTIN(INX,MXIN,NSTSX, X,4*MXHEAV+5, MXSTSX)
      RETURN
      END
      SUBROUTINE VIMAGE(PLIM, X, NSTSX)
      PARAMETER (MXHEAV=20, MXSTSX=30)
      DIMENSION X(4*MXHEAV+5,MXSTSX), PLIM(3)
      PARAMETER (MXVC=(MXHEAV*MXHEAV-MXHEAV)/2,
     *      RTMXH1=4.4, MXVW= 1.5 * MXHEAV * RTMXH1)
      COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1,
     *      XEO(5,MXHEAV),
     *      NVEC, VEC(4,MXVC), NP1P2(2,MXVC),
     *      NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW),
     *      IMPNTS(MXHEAV),
     *      VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX)
      DIMENSION XN1Q(3,48), XN2OUT(5,20)
      LOGICAL PATSYM, TLATTI, ENANTI
      DATA  PATSYM,TLATTI,ENANTI /.FALSE.,.FALSE.,.TRUE./
      MX2 = MXVC/((NPONTS*NPONTS - NPONTS)/2)
      IF (MX2 .GT. MXHEAV) MX2=MXHEAV
      NVEC=0
      PLIMF=PLIM(3)
      DO 220 N1 = 1, NPONTS-1
         CALL ALLEQP( XEO(1,N1), XN1Q, 48, PATSYM,TLATTI, NEQP)
      DO 210 N2 = N1+1, NPONTS
        IF(NPONT1.EQ.0) GOTO 101
        IF (N2.LE.NPONT1) THEN
           PLIMF=PLIM(1)
        ELSE IF (N1.LE.NPONT1) THEN
           PLIMF=PLIM(2)
        ELSE
           PLIMF=PLIM(3)
        ENDIF
 101     NOUT = MX2
         PXX2 =
     * OCMINF (XEO(1,N2), XN1Q,NEQP, 1, 0, ENANTI,PLIMF, XN2OUT,NOUT)
       DO 110 K2 = 1, NOUT
       NVEC = NVEC + 1
       CALL VMINV (XN2OUT(1,K2), XEO(1,N1), VEC(1,NVEC), 3)
       VEC(4,NVEC) = XN2OUT(4,K2)
         NP1P2(1,NVEC) = N1
       IF (XN2OUT(5,K2) .GT. 0.0) THEN
         NP1P2(2,NVEC) = N2
       ELSE
         NP1P2(2,NVEC) =-N2
       ENDIF
 110   CONTINUE
 210  CONTINUE
 220  CONTINUE
      PLIMF=PLIM(3)
      CALL COIMAG (PLIMF, X, NSTSX)
      RETURN
      END
      SUBROUTINE COIMAG(PLIM, X,NSTSX)
      PARAMETER (MXHEAV=20, MXSTSX=30)
      DIMENSION X(4*MXHEAV+5,MXSTSX)
      PARAMETER (MXVC=(MXHEAV*MXHEAV-MXHEAV)/2,
     *      RTMXH1=4.4, MXVW= 1.5 * MXHEAV * RTMXH1)
      COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1,
     *      XEO(5,MXHEAV),
     *      NVEC, VEC(4,MXVC), NP1P2(2,MXVC),
     *      NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW),
     *      IMPNTS(MXHEAV),
     *      VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX)
      PARAMETER (NXFVAL=4*MXHEAV+3)
      DIMENSION ICOP(MXHEAV)
      LOGICAL RING, BRI, READY
      PARAMETER (PMAX=30254.)
      I=0
      MAXI=NPONTS-1
      NVIEW=0
      NDELP=0
      CALL SELVWP(NVIEW,NDELP, READY)
      IF (READY) RETURN
      CALL USET1G (IVP, NPONTS-1, ICOP, I, BRI, MINPTS-1, MAXI)
 211  IF (I.EQ.0) THEN
            NDELP = NVWP
            RETURN
      ENDIF
 311    NVW = ICOP(I)
        IMPNTS(I) = IVWP(NVW)
        J=IABS(IMPNTS(I))
        CALL KERNAB (VECVWP(1,NVW),VECIM(1,I),3)
        PVECVJ = VECVWP(4,NVW)
        PVECJJ = XEO(4,J)
        CALL VECRIN (I, PVECVJ,PVECJJ, VALIM, SUMVIM, RING)
        IF (RING) THEN
          IL=I
          CALL USET1G (IVP, NPONTS-1, ICOP, I, BRI, MINPTS-1, MAXI)
          IF (I.GT.IL) GOTO 311
          NP=IL+1
        ELSE
          BRI=.TRUE.
          IL=I
          CALL USET1G (IVP, NPONTS-1, ICOP, I, BRI, MINPTS-1, MAXI)
          IF (I.GE.IL) GOTO 311
          NP=IL
        ENDIF
          IF (NP .EQ. MAXPTS) THEN
            CALL VEC2FP (XEO,MAXPTS,VECIM,NVWP,IMPNTS,NP,XF,ATMS)
            XF(4*MXHEAV+1) = NP
            XF(4*MXHEAV+2) = ATMS
            XF(4*MXHEAV+3) = VALIM + (PMAX-PLIM) * ATMS
            XF(4*MXHEAV+4) = SUMVIM
            DO 510 NX=1,NSTSX
            IX=INX(NX)
            IF (X(NXFVAL,IX).LT. XF(NXFVAL)-0.01) GOTO 520
            IF (X(NXFVAL,IX).GT. XF(NXFVAL)+0.01) GOTO 510
            IF (X(NXFVAL+1,IX) .GT. SUMVIM-0.10 .AND.
     *          X(NXFVAL+1,IX) .LT. SUMVIM+0.10)  GOTO 530
            IF (ABS(X(NXFVAL+1,IX)-SUMVIM).LT. 0.005*SUMVIM) GOTO 530
 510        CONTINUE
 520        CALL EL2AR2 (XF, 4*MXHEAV+5, NXFVAL, X,MXSTSX, NSTSX, INX)
            IF (FATSMX .LT. ATMS) THEN
            FATSMX = ATMS
            IF (MINPTS.LT.ATMS - 0.01) MINPTS=ATMS+0.01
            ENDIF
 530        CONTINUE
          ENDIF
        GOTO 211
      END
      SUBROUTINE VEC2FP (XEO,NXEO,VECIM,NVWP, IMPNTS,NIP,XF,ATMS)
      DIMENSION XEO(5,NXEO), VECIM(3,NIP-1), IMPNTS(NIP-1),
     *      XF(4,NIP)
      NFP = 0
      ATMS = 0.0
      DO 120 NP=1,NXEO
      IF (NP .EQ. NVWP) THEN
          NFP = NFP+1
          CALL KERNAB( XEO(1,NVWP), XF(1,NFP), 3)
          XF(4,NFP)=XEO(5,NVWP)
          ATMS = ATMS + XF(4,NFP)
          GOTO 120
      ENDIF
        DO 110 N = 1,NIP-1
        IF (NP .EQ. IABS(IMPNTS(N)) ) THEN
            NFP = NFP+1
            CALL VPLUSV( XEO(1,NVWP), VECIM(1,N), XF(1,NFP), 3)
            XF(4,NFP)=XEO(5,NP)
            ATMS = ATMS + XF(4,NFP)
            GOTO 120
        ENDIF
 110    CONTINUE
 120  CONTINUE
      RETURN
      END
      SUBROUTINE SELVWP(NVIEW,NDELP, READY)
      LOGICAL READY
      PARAMETER (MXHEAV=20, MXVC=(MXHEAV*MXHEAV-MXHEAV)/2,
     *      RTMXH1=4.4, MXVW= 1.5 * MXHEAV * RTMXH1, MXSTSX=30)
      COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1,
     *      XEO(5,MXHEAV),
     *      NVEC, VEC(4,MXVC), NP1P2(2,MXVC),
     *      NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW),
     *      IMPNTS(MXHEAV),
     *      VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX)
      READY = .FALSE.
      IF (NDELP.GT.0 .AND. NDELP.LE.NPONTS) THEN
         NPONTS=NPONTS-1
         READY = NPONTS .LT. MINPTS
         IF (READY) RETURN
         XEO(5,NDELP)= 0.0
         ATMS=0.0
         DO 101 N=1,MAXPTS
 101     ATMS=ATMS+XEO(5,N)
         READY=ATMS.LT.FATSMX
         IF (READY) RETURN
         N=0
         DO 100 NVE=1,NVEC
         IF (NP1P2(1,NVE).NE.NDELP .AND. IABS(NP1P2(2,NVE)).NE.NDELP)
     *       THEN
           N=N+1
           CALL KERNAB (VEC(1,NVE),VEC(1,N),4)
           NP1P2(1,N)=NP1P2(1,NVE)
           NP1P2(2,N)=NP1P2(2,NVE)
         ENDIF
 100     CONTINUE
         NVEC=N
      ENDIF
      IF (NVIEW.GT.0 .AND. NVIEW.LE.NPONTS) THEN
         NVWP = NVIEW
      ELSE
         MINVVW = NVEC+1
         DO 210 NVW = 1, NPONTS
          NVECVW = 0
         DO 110 NVE = 1, NVEC
          IF (NP1P2(1,NVE) .EQ. NVW .OR. IABS(NP1P2(2,NVE)) .EQ. NVW)
     *      NVECVW = NVECVW + 1
 110     CONTINUE
         IF (NVECVW .EQ. 0)  GOTO  210
         IF (MINVVW .GT. NVECVW) THEN
            MINVVW = NVECVW
            NVWP = NVW
         ENDIF
 210     CONTINUE
      ENDIF
      NVI = 0
      IPO = 0
      DO  410 IP = 1, NPONTS
      IF (NVWP .EQ. IP) GOTO 410
      DO  310 NVE = 1, NVEC
      IF (NP1P2(1,NVE) .EQ. NVWP .AND. IABS(NP1P2(2,NVE)) .EQ. IP) THEN
          NVI=NVI+1
          CALL KERNAB (VEC(1,NVE), VECVWP(1,NVI), 4)
          IVWP(NVI) = NP1P2(2,NVE)
      ELSE
      IF (NP1P2(1,NVE) .EQ. IP .AND. IABS(NP1P2(2,NVE)) .EQ. NVWP) THEN
          NVI=NVI+1
          IF (NP1P2(2,NVE) .GT. 0) THEN
            CALL INVAB(VEC(1,NVE), VECVWP(1,NVI), 3)
            VECVWP(4,NVI)=VEC(4,NVE)
            IVWP(NVI) = NP1P2(1,NVE)
          ELSE
            CALL KERNAB (VEC(1,NVE), VECVWP(1,NVI), 4)
            IVWP(NVI) = -NP1P2(1,NVE)
          ENDIF
       ENDIF
      ENDIF
 310  CONTINUE
      IPO = IPO + 1
      IVP(IPO) = NVI
 410  CONTINUE
      NVVW = NVI
      RETURN
      END
      SUBROUTINE VECRIN (NI, PVECVJ,PVECJJ, VALUIM, SUMVIM, RING)
      LOGICAL RING
      PARAMETER (MXHEAV=20, MXVC=(MXHEAV*MXHEAV-MXHEAV)/2,
     *      RTMXH1=4.4, MXVW= 1.5 * MXHEAV * RTMXH1, MXSTSX=30)
      COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1,
     *      XEO(5,MXHEAV),
     *      NVEC, VEC(4,MXVC), NP1P2(2,MXVC),
     *      NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW),
     *      IMPNTS(MXHEAV),
     *      VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX)
      DIMENSION VECJI(3), VECNVI(3), VALIMN(MXHEAV), SUMIMN(MXHEAV)
      LOGICAL DMAXCH
      PARAMETER (VALMIN=0.0)
      NII = NI
      IF (NII.EQ. 1) THEN
          VALUIM = AMIN1(PVECVJ,PVECJJ)
          SUMVIM = PVECVJ+PVECJJ
          SUMIMN(1)= SUMVIM
          VALIMN(1)= VALUIM
          DMAX = 0.80
          DMAXCH=.TRUE.
          GOTO 211
      ENDIF
      J = IMPNTS(NII)
      VALUIM= AMIN1(PVECVJ,PVECJJ,VALIMN(NII-1))
      SUMVIM= PVECVJ+PVECJJ+SUMIMN(NII-1)
      DO  210 I1 = 1, NII-1
      CALL VMINV (VECIM(1,I1), VECIM(1,NII), VECJI, 3)
      I = IMPNTS(I1)
      IRING = 0
      VALJI = VALMIN
      DIS2MI = 4.
      DO  110 NV = 1, NVEC
      IS = 0
      IF (NP1P2(1,NV) .EQ. I .AND. NP1P2(2,NV) .EQ. J) IS = -1
      IF (NP1P2(1,NV) .EQ.-I .AND. NP1P2(2,NV) .EQ.-J) IS = 1
      IF (IS .NE. 0) THEN
        IF (IS .EQ. 1) THEN
            IQUAL = ISELFD(VECJI, VEC(1,NV), DMAX)
        ELSE
            CALL INVAB (VEC(1,NV), VECNVI, 3)
            IQUAL = ISELFD(VECJI, VECNVI, DMAX)
        ENDIF
        IF (IQUAL .EQ. 1 .AND. VEC(4,NV) .GT. VALJI) THEN
            IRING = 1
            VALJI = VEC(4,NV)
        ENDIF
      ENDIF
 110  CONTINUE
      RING = IRING .EQ. 1
      IF (.NOT. RING) RETURN
      IF (VALUIM .GT. VALJI) VALUIM = VALJI
      SUMVIM = SUMVIM + VALJI
 210  CONTINUE
      VALIMN(NI) = VALUIM
      SUMIMN(NI) = SUMVIM
 211  RING = .TRUE.
      RETURN
      END
      SUBROUTINE DISCRX(X, NMODX, XZ, NMODXZ, NEWXZ)
      PARAMETER (MXHEAV=20, MXSTSX=30, IXZ=5*MXHEAV+5)
      PARAMETER (MXINXZ=MXSTSX)
      DIMENSION X(4*MXHEAV+5,MXSTSX), XZ(IXZ,MXSTSX)
      DIMENSION INXZ(MXINXZ), X1Z(IXZ)
      DATA  X1Z /IXZ*0.0/
      ISQ = 5*MXHEAV+3
      NEWXZ=0
      IF (NMODX.LE.0)  RETURN
      IF (NMODXZ .GT. 0) THEN
        NHIGXZ=NMODXZ
        CALL DETSEQ(INXZ,NHIGXZ, XZ, IXZ, NMODXZ, ISQ, 0)
      ENDIF
      DO 120 M=1,NMODX
      NH = NINT( X(4*MXHEAV+1,M) )
      DO 110 I = 1, NH
 110  CALL KERNAB(X(4*I-3,M),X1Z(5*I-4),4)
      CALL ATIFCO(X1Z, NH,VAL1X,AMINMM,AMIM1,CONTHL,SUMIW)
      IF (VAL1X .LT. 0.1) GOTO 120
      NEWXZ=NEWXZ+1
      X1Z(5*MXHEAV+1) = NH
      X1Z(5*MXHEAV+2) = X(4*MXHEAV+2,M)
      X1Z(5*MXHEAV+4) = X(4*MXHEAV+4,M)
      X1Z(5*MXHEAV+5) = X(4*MXHEAV+5,M)
      X1Z(ISQ) = VAL1X
      IF (NH .LT. MXHEAV) THEN
         X1Z(5*MXHEAV-1) = AMINMM
         X1Z(5*MXHEAV-2) = CONTHL
         X1Z(5*MXHEAV-3) = AMIM1
         X1Z(5*MXHEAV) = SUMIW
      ENDIF
      CALL EL2AR2 (X1Z, 5*MXHEAV+5, ISQ, XZ, MXSTSX, NMODXZ, INXZ)
 120  CONTINUE
      CALL SORTIN(INXZ,MXINXZ, NMODXZ, XZ, 5*MXHEAV+5, MXSTSX)
      RETURN
      END
      SUBROUTINE ATIFCO (X, NX, VALX, AMINMM, AMIM1, CONTHL, SUMIW)
      DIMENSION X(5,NX)
      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 P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM,
     +      WAVE, CELALL(10), AMOLW, ZET,
     +      NELEC, F000, ABSMU, ICENT,
     +      ILATT, ISYST, ILAUE, IMULT,
     +      IUNIQ, IPOLA, NTYPE, NSYMM,
     +      IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4),
     +      FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (MXOVRL=1800)
      PARAMETER (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4)
      COMMON /MOVECS/ XCELL(3,MXNUP),NPCELL, NAXCEL(MXNUP),
     *                ASVECT(5,MAXASV),NASV
      LOGICAL READY, COVERF, OVTABL
      DIMENSION OVRLTA(MXOVRL), NOVRLT(3,MXOVRL), IZPOT(2,MXHEAV),
     *          IZCOMB(2,MXHEAV), IZAT(MXHEAV), NZCONS(10), LCONST(10)
      DATA AMINM,AMINM1 / 0.0,0.0 /
      AMI1 = 0.3
      AMI2 = 1.9
      NPMAX=4*NLATT
      CALL VECCHL (X, NX, NPMAX, CONTHL)
      DO 120 M = 1,LTHV
        IZPOT(1,M) = -NCELLZ(M)
 120    IZPOT(2,M) = NCELTY(M)
      NZP = LTHV
      IF (.NOT.P1METH .OR. (NSYMM.EQ.1 .AND. ICENT.EQ.1) ) THEN
          DO 121 M=1,LTHV
 121      LCONST(M)=NCONST(M)
      ELSE
          DO 122 M=1,LTHV
 122      LCONST(M)=(NCONST(M)+1)/2
      ENDIF
      DO 130 N=1,NX
 130  IZCOMB(2,N) = NINT(IMULT * X(4,N))
      MSUM = 0
      OVTABL = .FALSE.
      VALX = -1.
      SUMIW= VALX
      INIT= 0
1111  CALL COMBIS (IZCOMB,NX,INIT, IZPOT,NZP, COVERF, READY)
          IF (READY) RETURN
      IF (LTHV.GT.1) THEN
        CALL KERNZI (0, NZCONS, 10)
        DO 135 N=1,NX
        DO 134 M=1,LTHV
        IF (-IZCOMB(1,N).EQ.NCELLZ(M)) THEN
          NZCONS(M)=NZCONS(M)+1
          GOTO 135
         ENDIF
 134    CONTINUE
 135    CONTINUE
        DO 136 M=1,LTHV-1
        IF (NZCONS(M).LT.LCONST(M)) GOTO 1111
 136    CONTINUE
      ENDIF
      DO 140 N=1,NX
 140  IZAT(N)=-IZCOMB(1,N)
      CALL INTWGT(NAXCEL,NPCELL, IZAT,N, SUMINW)
      IF (SUMINW*AMI2 .LT. VALX) GOTO 1111
      IF (NASV.EQ.0) THEN
         AMINM = AMIN1(AMI2,1.0)
         COMVAL = AMINM * SUMINW  + CONTHL*0.5*SUMINW
      ELSE
        IF (.NOT.OVTABL) THEN
          CALL OVLWGT(ASVECT,NASV,XCELL,NAXCEL,NPCELL,OVRLTA,NT,NOVRLT)
          OVTABL = .TRUE.
        ENDIF
        CALL OVLWBT (ASVECT,NASV, OVRLTA,NT, NOVRLT, IZAT)
        CALL ISFP (ASVECT,NASV, MSUM, AMINM, AMINM1)
        AMINM = AMINM/SCPAT * NLATT
        AMINM1= AMINM1/SCPAT * NLATT
        IF (AMINM1.GT.AMI2) AMINM1=AMI2
        IF (AMINM.GT.AMI2) AMINM=AMI2
        IF (AMINM.GT.AMI1) THEN
          AM1=AMINM
          AM2=0.0
          IF (AM1.GT.1.3) THEN
            AM1=1.3
            AM2=(AMINM-1.3)*0.1
          ENDIF
          COMVAL = (AM1+AM2) * SUMINW  + CONTHL*0.5*SUMINW
        ELSE
           COMVAL =-2.0
        ENDIF
      ENDIF
      IF (COMVAL .GT. VALX) THEN
         SUMIW = SUMINW
         AMINMM= AMINM
         AMIM1 = AMINM1
         VALX = COMVAL
         DO 150 N = 1,NX
 150     X(5,N)= IZAT(N)
         ENDIF
      GOTO 1111
      END
      SUBROUTINE VECCAP (X, NX, ASVECT, NASV, XCELL, NP, NAXCEL)
      PARAMETER (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4)
      DIMENSION X(5, NX), ASVECT(5,MAXASV), XCELL(3,MXNUP),
     *                                     NAXCEL(MXNUP)
      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 P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM,
     +      WAVE, CELALL(10), AMOLW, ZET,
     +      NELEC, F000, ABSMU, ICENT,
     +      ILATT, ISYST, ILAUE, IMULT,
     +      IUNIQ, IPOLA, NTYPE, NSYMM,
     +      IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4),
     +      FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      PARAMETER (MXXEQ=48*3)
      DIMENSION XEQ(3,MXXEQ), XEQT(3)
      LOGICAL PATSYM, TLATTI, PATS, ENANTI
      DATA DMAX, PATSYM,TLATTI,PATS,ENANTI / 0.1,.FALSE.,.FALSE.,.TRUE.,
     *     .FALSE./
      NASV=0
      NP=0
      NP1=0
      DO 310 J = 1, NX
      CALL ALLEQP( X(1,J), XEQ, MXXEQ, PATSYM,TLATTI, NEQP)
      N11=0
      DO 150 N =1,NEQP
      IF (N.EQ.1) GOTO 130
      DO 120 L=1,NLATT
      CALL VPLUSV(XEQ(1,N),TLATT(1,L),XEQT,3)
      DO 110 N1=1,N11
 110  IF (ISELFD(XEQT,XEQ(1,N1),DMAX) .EQ. 1)  GOTO 150
 120  CONTINUE
 130  NP=NP+1
      NAXCEL(NP)=J
      CALL KERNAB(XEQ(1,N),XCELL(1,NP),3)
      N11=N11+1
      IF (N11.NE.1) CALL KERNAB(XEQ(1,N),XEQ(1,N11),3)
 150  CONTINUE
      NEQP=N11
      IF (NASV.EQ.MAXASV) GOTO  310
      J1 = J
      N1 = 2
      DO 220 K = J1, NX
      NASVJ=NASV+1
      NV=0
      DO 210 N = N1, NEQP
      NASV = NASV + 1
      CALL VMINV ( X(1,K), XEQ(1,N), ASVECT(1,NASV), 3)
      IF (NASV.EQ.MAXASV)  GOTO  310
  210 CONTINUE
      IF (J.EQ.K) THEN
         NV=NASV-NASVJ+1
         IF (NV.NE.0)
     *      CALL DELXEQ (ASVECT(1,NASVJ), NV, 0, PATS, ENANTI, DMAX)
         NASV=NASVJ+NV-1
         ENDIF
      N1 = 1
  220 CONTINUE
  310 CONTINUE
      IF (NASV.NE.0)
     *   CALL DELXEQ (ASVECT, NASV, 0, PATS, ENANTI, DMAX)
      NP1=NP
      DO 410 N1=1,NP1
      DO 410 L=2,NLATT
      CALL VPLUSV(XCELL(1,N1),TLATT(1,L),XEQT,3)
      DO 400 N=1,NP
 400  IF (ISELFD(XEQT,XCELL(1,N),DMAX) .EQ. 1)  GOTO 410
      NP=NP+1
      NAXCEL(NP)=NAXCEL(N1)
      CALL KERNAB(XEQT,XCELL(1,NP),3)
 410  CONTINUE
      RETURN
      END
      SUBROUTINE INTWGT(NAXCEL,NP, IZAT,N, SUMINW)
      DIMENSION NAXCEL(NP), IZAT(N)
      SUMINW = 0.0
      DO 210  N1=1,NP
      J1=NAXCEL(N1)
      DO 110  N2=1,NP
      J2=NAXCEL(N2)
 110  SUMINW=SUMINW+IZAT(J1)*IZAT(J2)
 210  CONTINUE
      RETURN
      END
      SUBROUTINE OVLWGT (ASVECT,NASV, XCELL,NAXCEL,NP, OVRLTA, NT,
     *                                                         NOVRLT)
      PARAMETER (MXOVRL=1800)
      DIMENSION ASVECT(5,NASV), XCELL(3,NP), NAXCEL(NP),
     *          OVRLTA(MXOVRL), NOVRLT(3,MXOVRL)
      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 /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      DIMENSION VECN(3), DVEC(3)
      NT=0
      DO 510 N1=1,NP
      J1=NAXCEL(N1)
      DO 410 N2=1,NP
      IF (N1.EQ.N2)  GOTO 410
      CALL VMINV(XCELL(1,N1), XCELL(1,N2), VECN, 3)
      J2=NAXCEL(N2)
      DO 310 I=1,NASV
      CALL DISTSQ (VECN, ASVECT(1,I), RMAX, DVEC, RR2)
      IF (RR2 .LT. RMAX2) THEN
        NT=NT+1
        G = RR2/DEL + 1.
        IG = G
        F = G - FLOAT(IG)
        OVRLTA(NT) = TAB(IG) + (TAB(IG+1) - TAB(IG)) * F
        NOVRLT(1,NT)=I
        NOVRLT(2,NT)=J1
        NOVRLT(3,NT)=J2
        IF (NT .EQ. MXOVRL)  RETURN
      ENDIF
 310  CONTINUE
 410  CONTINUE
 510  CONTINUE
      RETURN
      END
      SUBROUTINE OVLWBT (ASVECT,NASV, OVRLTA,NT, NOVRLT, IZAT)
      PARAMETER (MXHEAV=20, MXOVRL=1800)
      DIMENSION ASVECT(5,NASV), OVRLTA(MXOVRL), NOVRLT(3,MXOVRL),
     *                                                   IZAT(MXHEAV)
      DO 110 NV = 1,NASV
 110  ASVECT(4,NV)=0.0
      IF (NT.EQ.0)   RETURN
      DO 120 N = 1,NT
      NV1= NOVRLT(1,N)
      J1 = NOVRLT(2,N)
      J2 = NOVRLT(3,N)
      ASVECT(4,NV1) = ASVECT(4,NV1) + OVRLTA(N)*IZAT(J1)*IZAT(J2)
 120  CONTINUE
      RETURN
      END
      SUBROUTINE COMBIS (ICOMB,N,IN, IPOT,NP, COVERF, READY)
      DIMENSION ICOMB(2,N), IPOT(2,NP)
      LOGICAL COVERF, READY
      PARAMETER (MXCOM=20)
      LOGICAL CONOTP
      IF (N.GT. MXCOM) THEN
          COVERF = .TRUE.
          RETURN
      ELSE
          COVERF = .FALSE.
      ENDIF
      IF (IN .EQ. 0) THEN
         CALL COMBIM( ICOMB,N, IPOT,NP, 1, CONOTP)
         READY = CONOTP
         IF (.NOT. READY) IN=N
         RETURN
      ENDIF
      DO 530 JJ = N, 1, -1
      DO 520 I= 1, NP
      IF (ICOMB(1,JJ).EQ.IPOT(1,I)) THEN
         IL=I
         DO 510 I1 = I+1,NP
         IF (IPOT(2,I1) .GE. ICOMB(2,JJ)) THEN
            IPOT(2,IL) = IPOT(2,IL) + ICOMB(2,JJ)
            ICOMB(1,JJ)= IPOT(1,I1)
            IPOT(2,I1) = IPOT(2,I1) - ICOMB(2,JJ)
            IL=I1
            CALL COMBIM (ICOMB,N, IPOT,NP, JJ+1, CONOTP)
            IF (CONOTP) GOTO 510
            READY = .FALSE.
            RETURN
         ENDIF
 510     CONTINUE
         IPOT(2,I) = IPOT(2,I) + ICOMB(2,JJ)
         GOTO 530
      ENDIF
 520  CONTINUE
 530  CONTINUE
      READY = .TRUE.
      RETURN
      END
      SUBROUTINE COMBIM (ICOMB,N, IPOT,NP, JJJ, CONOTP)
      DIMENSION ICOMB(2,N), IPOT(2,NP)
      LOGICAL CONOTP
      PARAMETER (MXCOM=20)
      DIMENSION LIP(MXCOM)
      IF (JJJ .GT. N) GOTO 410
       I  = 0
       J1 = JJJ
 111   CONTINUE
            JJ1= J1
            LI = I+1
            DO 310 J=JJ1,N
            DO 210 I=LI,NP
            IF (IPOT(2,I).GE.ICOMB(2,J) )THEN
            ICOMB(1,J) = IPOT(1,I)
            IPOT(2,I) = IPOT(2,I) - ICOMB(2,J)
            LIP(J) = I
            GOTO 309
            ENDIF
 210        CONTINUE
            J1=J-1
            IF (J1.LT.JJJ) THEN
            CONOTP = .TRUE.
            RETURN
            ENDIF
            I = LIP(J1)
            IPOT(2,I) = IPOT(2,I) + ICOMB(2,J1)
       GOTO 111
 309        LI = 1
 310        CONTINUE
 410  CONOTP= .FALSE.
      RETURN
      END
      SUBROUTINE ISFP (ASVECT,NASV, MSUM, AMINM, AMINM1)
      DIMENSION ASVECT(5,NASV)
      PARAMETER (MAXASV=3600, MXMSUM=20)
      DIMENSION PW(MAXASV), IPW(MXMSUM)
      DATA  ISQ, PNCV /1, 0.25/
      MSUML = MSUM
      NCV = NASV
      DO 110 N=1,NASV
      IF (ASVECT(5,N).GT.0.10) THEN
        PW(N) = -ASVECT(5,N)/ASVECT(4,N)
        IF (ASVECT(4,N).LT.0.1) THEN
        ENDIF
      ELSE
        PW(N) = 0.0
      ENDIF
 110  CONTINUE
      IF (MSUM.EQ.0) THEN
          MSUM = NCV * PNCV
          IF (MSUM.LT.1) MSUM=1
          MSUML= MIN0 (MSUM, MXMSUM, NCV)
          MSUM = MSUML
      ENDIF
      CALL DETSEQ(IPW, MSUML, PW, 1, NASV, ISQ, 0)
      AMINM=0.0
      DO 120 I = 1,MSUML
 120  AMINM = AMINM - PW(IPW(I))
      AMINM = AMINM/MSUML
      AMINM1= -PW(IPW(1))
      RETURN
      END
      SUBROUTINE PEAKHG( NPEAKS, PLEVEL, NO, XP)
      PARAMETER (MXPKS=150,MXPEAK=MXPKS+100)
      DIMENSION XP(5, MXPEAK)
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      DIMENSION B(19), XX(3), XXMAX(5)
      DIMENSION INDXP(MXPEAK), ISXYZ2(3), LXYZ2(3)
      EQUIVALENCE (ISXYZ2(1), ISX2), (LXYZ2(1), LX2),
     *      (ISXYZ2(2), ISY2), (LXYZ2(2), LY2),
     *      (ISXYZ2(3), ISZ2), (LXYZ2(3), LZ2)
      DIMENSION STEPX(3)
      DATA XXMAX /5*0.0/
      DO 100 I=1,3
 100  STEPX(I)=1./GTXYZS(I)
      NPIEKS = NPEAKS
      IF (NPEAKS.GT.MXPEAK) NPIEKS = MXPEAK
      NO = 0
      IZ1=ISS(3)
      IZ2=ISS(3)+1
      IZ3=ISS(3)+2
      DO 102 I = 1,3
      ISXYZ2(I) = ISS(I)
      LXYZ2(I) = LXYZS(I)
      IF (ISS(I).LT.LXYZS(I)) THEN
         ISXYZ2(I) = ISXYZ2(I) + 1
         LXYZ2(I) = LXYZ2(I) - 1
         ENDIF
 102  CONTINUE
      DO 333 IZ2= ISZ2,LZ2
            IZ1= IZ2-1
            IZ3= IZ2+1
      DO 222 IY = ISY2,LY2
      DO 111 IX = ISX2,LX2
      B(10) = DKMAP (IX,IY,IZ2)
            IF (B(10) .LT.PLEVEL ) GO TO 111
      B(1) = DKMAP (IX-1,IY-1,IZ2)
            IF (B(10) .LT. B(1) ) GO TO 111
      B(2) = DKMAP (IX,IY-1,IZ1)
            IF (B(10) .LT. B(2) ) GO TO 111
      B(3) = DKMAP (IX,IY-1,IZ2)
            IF (B(10) .LT. B(3) ) GO TO 111
      B(4) = DKMAP (IX,IY-1,IZ3)
            IF (B(10) .LT. B(4) ) GO TO 111
            IBB = NINT ( (B(10)-B(4)) * 99.)
            IF (IZ3.LE.LZ2 .AND. IBB.EQ.0 ) GO TO 111
      B(5) = DKMAP (IX+1,IY-1,IZ2)
            IF (B(10) .LT. B(5) ) GO TO 111
      B(6) = DKMAP (IX-1,IY,IZ1)
            IF (B(10) .LT. B(6) ) GO TO 111
      B(7) = DKMAP (IX-1,IY,IZ2)
            IF (B(10) .LT. B(7) ) GO TO 111
      B(8) = DKMAP (IX-1,IY,IZ3)
            IF (B(10) .LT. B(8) ) GO TO 111
            IBB = NINT ( (B(10)-B(8)) * 99.)
            IF (IZ3.LE.LZ2 .AND. IBB.EQ.0) GO TO 111
      B(9) = DKMAP (IX,IY,IZ1)
            IF (B(10) .LT. B(9) ) GO TO 111
      B(11) = DKMAP (IX,IY,IZ3)
            IF (B(10) .LT. B(11)) GO TO 111
            IBB = NINT ( (B(10)-B(11)) * 99.)
            IF (IZ3.LE.LZ2 .AND. IBB.EQ.0) GO TO 111
      B(12) = DKMAP (IX+1,IY,IZ1)
            IF (B(10) .LT. B(12)) GO TO 111
      B(13) = DKMAP (IX+1,IY,IZ2)
            IF (B(10) .LT. B(13)) GO TO 111
            IBB = NINT ( (B(10)-B(13)) * 99.)
            IF (IX.LT.LX2 .AND. IBB.EQ.0) GO TO 111
      B(14) = DKMAP (IX+1,IY,IZ3)
            IF (B(10) .LT. B(14)) GO TO 111
            IBB = NINT ( (B(10)-B(14)) * 99.)
            IF ((IX.LT.LX2 .AND. IZ3.LE.LZ2) .AND. IBB.EQ.0) GOTO 111
      B(15) = DKMAP (IX-1,IY+1,IZ2)
            IF (B(10) .LT. B(15)) GO TO 111
            IBB = NINT ( (B(10)-B(15)) * 99.)
            IF (IY.LT.LY2 .AND. IBB.EQ.0) GO TO 111
      B(16) = DKMAP (IX,IY+1,IZ1)
            IF (B(10) .LT. B(16)) GO TO 111
      B(17) = DKMAP (IX,IY+1,IZ2)
            IF (B(10) .LT. B(17)) GO TO 111
            IBB = NINT ( (B(10)-B(17)) * 99.)
            IF (IY.LT.LY2 .AND. IBB.EQ.0) GO TO 111
      B(18) = DKMAP (IX,IY+1,IZ3)
            IF (B(10) .LT. B(18)) GO TO 111
            IBB = NINT ( (B(10)-B(18)) * 99.)
            IF ((IY.LT.LY2 .AND. IZ3.LE.LZ2) .AND. IBB.EQ.0) GOTO 111
      B(19) = DKMAP (IX+1,IY+1,IZ2)
            IF (B(10) .LT. B(19)) GO TO 111
            IBB = NINT ( (B(10)-B(19)) * 99.)
            IF ((IX.LT.LX2 .AND. IY.LT.LY2) .AND. IBB.EQ.0) GOTO 111
      XX(1) = FLOAT(IX)/GTXYZS(1)
      XX(2) = FLOAT(IY)/GTXYZS(2)
      XX(3) = FLOAT(IZ2)/GTXYZS(3)
      CALL SMAXMN (XX, STEPX, XXMAX, SMAX)
      XXMAX(4) = SMAX
      CALL EL2AR2( XXMAX, 5, 4, XP,NPIEKS, NO, INDXP)
 111  CONTINUE
 222  CONTINUE
 333  CONTINUE
      CALL SORTIN (INDXP,MXPEAK,NO, XP, 5, NPIEKS)
      RETURN
      END
      FUNCTION DKMAP(IX,IY,IZ)
      PARAMETER (NUMTAB =300000)
      COMMON / / ITAB(NUMTAB)
      INTEGER * 2 ITAB
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      DKMAP=0.0
      IF (IX.LT.ISS(1) .OR. IX.GT.LXYZS(1)) RETURN
      IF (IY.LT.ISS(2) .OR. IY.GT.LXYZS(2)) RETURN
      IF (IZ.LT.ISS(3) .OR. IZ.GT.LXYZS(3)) RETURN
      IADR = NUSXY * IZ + NUMS(1) * IY + IX - NUMSC
      IJX = ITAB(IADR)
      DKMAP = FLOAT( IJX ) / 99.
      RETURN
      END
      SUBROUTINE SMAXMN (X, STEPX, XMAX, SMAX)
      DIMENSION X(3), STEPX(3), XMAX(5)
      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 /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      DIMENSION DS(48,5,3), XX(3), SO(48), JM(3)
      DATA  PMIN,PMAX /0.0,30254./
      DO 210 NS=2,NSSY
      SO(NS) = SSMINF(X,NS,.TRUE.,NSMIN)
      DO 150 I = 1,3
      CALL KERNAB(X,XX,3)
      XX(I) = X(I)-0.75*STEPX(I)
      DO 130 J = 1,5
      XX(I)=XX(I)+0.25*STEPX(I)
      IF (J.EQ.3) THEN
         DS(NS,J,I) = 0.0
      ELSE
         DS(NS,J,I) = SSMINF(XX,NS,.TRUE.,NSMIN) - SO(NS)
      ENDIF
 130  CONTINUE
 150  CONTINUE
 210  CONTINUE
      SMAX=PMIN
      DO 3000 J3 = 1, 5
      DO 2000 J2 = 1, 5
      DO 1000 J1 = 1, 5
      SMIN3=PMAX
      DO 300 NS=2,NSSY
      S3 = DS(NS,J1,1) + DS(NS,J2,2) + DS(NS,J3,3) + SO(NS)
      IF (SMIN3.GT.S3) SMIN3=S3
 300  CONTINUE
      IF (SMAX.LT.SMIN3) THEN
          SMAX=SMIN3
          JM(1)=J1
          JM(2)=J2
          JM(3)=J3
          ENDIF
 1000 CONTINUE
 2000 CONTINUE
 3000 CONTINUE
      DO 4000 I=1,3
      XMAX(I) = X(I)+(0.25*JM(I)-0.75)*STEPX(I)
 4000 CONTINUE
      RETURN
      END
      SUBROUTINE USET1G (IP, NP, ISET, I, BRI, MI, MAXI)
      DIMENSION IP(NP), ISET(MAXI)
      LOGICAL BRI
      DATA MXI / 0 /
      IF (I.EQ.0) THEN
        BRI=.FALSE.
        MXI = MAXI
        IF (MXI.GT.NP) MXI = NP
        IF (MI.GT.MXI .OR. MXI.LE.0) RETURN
        I=1
        ISET(1)=1
        IF (MXI.GE.2) ISET(2)=IP(1)
        RETURN
      ENDIF
      IF (BRI) THEN
        BRI=.FALSE.
        I=I-1
      ENDIF
      J1=I+1
      IF (J1.GT.MXI) J1=MXI
      DO 320 J = J1, 1, -1
      N = MIN0(NP+J-MI, NP)
      IF (ISET(J)+1 .LE. IP(N)) THEN
        ISET(J)=ISET(J)+1
        IF (J.LT.MXI) THEN
          DO 310 M=N, 2, -1
          IF (ISET(J) .GT. IP(M-1)) GOTO 315
 310      CONTINUE
          M=1
 315      ISET(J+1) = IP(M)
        ENDIF
        I=J
        RETURN
      ENDIF
 320  CONTINUE
      I=0
      RETURN
      END
      SUBROUTINE DELXEQ ( X, NR, NOR, PATS, ENANTI, DMAX)
      DIMENSION X(5,NR)
      LOGICAL PATS, ENANTI
      LOGICAL PATSYM,TLATTI
      DATA  TLATTI /.TRUE./
      PATSYM=PATS
      N11=1
      NOR1 = NOR
      IF (NOR1.LE.0) NOR1=1
      DO 410 N2= 2, NR
      DO 310 NO= 1, NOR1
      NO1 = NO
      IF (NOR.LE.0) NO1=0
      IF (IEQUX(X(1,N2), X, N11, PATSYM, ENANTI, TLATTI, DMAX, NO1)
     *      .EQ. 1) GOTO 410
 310  CONTINUE
      N11 = N11+1
      CALL KERNAB (X(1,N2), X(1,N11), 5)
 410  CONTINUE
      NR=N11
      RETURN
      END
      FUNCTION IEQUX(X1, X, N1, PATSYM,ENANTI,TLATTI, DMAX, NOR1)
      DIMENSION X1(3), X(5,N1)
      LOGICAL PATSYM,ENANTI,TLATTI
      COMMON /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3)
      DIMENSION X1DATA(4), XEQ(3), XO1(3)
      LOGICAL DMAXCH, ALLEQ
      DMAXCH= .TRUE.
      IF (NOR1.GT.NOR) THEN
         IEQUX=0
         RETURN
      ENDIF
      IF (NOR1 .NE. 0) THEN
         CALL VMINV (X1, ORIG(1,NOR1), XO1,3)
         CALL KERNAB(XO1, X1DATA, 3)
      ELSE
         CALL KERNAB(X1, X1DATA, 3)
      ENDIF
 110  CALL SYMOPN (X1DATA, XEQ, PATSYM, ENANTI, TLATTI, ALLEQ)
      DO 210 N= 1, N1
      IF (NOR1.NE.0 .AND. IDDPOL.NE.0)
     *    CALL POLASH(XEQ,X(1,N), IDDPOL, RVPOL, XEQ)
      IEQUX = ISELFD (XEQ, X(1,N), DMAX)
      IF (IEQUX .EQ. 1) THEN
           RETURN
      ENDIF
 210  CONTINUE
      IF (.NOT.ALLEQ) GOTO 110
      RETURN
      END
      SUBROUTINE POLASH (XSH, X, IDD, RV, XSHFD)
      DIMENSION XSH(3),X(3), RV(3), XSHFD(3)
      DIMENSION SHFV(3)
      CALL VMINV (X,XSH, SHFV, 3)
      IF (IDD .EQ. 1) THEN
        IF(RV(1).GT.0.9 .AND. RV(2).GT.0.9 .AND. RV(3).GT.0.9) THEN
          SHFV(1)=(SHFV(1)+SHFV(2)+SHFV(3))/3.
          SHFV(2)=SHFV(1)
          SHFV(3)=SHFV(1)
        ELSE
          DO 110 I =1,3
 110      SHFV(I)=SHFV(I)*RV(I)
        ENDIF
      ELSE IF (IDD.EQ.2) THEN
        DO 120 I =1,3
 120    IF (RV(I).GT.0.9) SHFV(I)=0.0
      ENDIF
      CALL VPLUSV (XSH, SHFV, XSHFD, 3)
      RETURN
      END
      SUBROUTINE SYMEQU (NS, ITS, NLT, INV, FIRST, X, XEQ, XS)
      LOGICAL FIRST
      DIMENSION X(3), XEQ(3), XS(3)
      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)
      ELSE IF (INV .EQ. -1) THEN
          CALL INVAB ( XEQ, XEQ, 3)
          RETURN
      ENDIF
      IF (NLT .GT. 1) CALL VPLUSV ( XS, TLATT(1,NLT), XEQ, 3)
      IF (INV .EQ. -1) CALL INVAB ( XEQ, XEQ, 3)
      RETURN
      END
      SUBROUTINE NEXSYM (NS, NLT, INV, NSYMM, NLATT, SMOD, ALLSEQ)
      LOGICAL SMOD, ALLSEQ
      IF (INV .EQ. 1) THEN
          INV = -1
          SMOD = .FALSE.
          GOTO 110
      ENDIF
      IF (INV .EQ. -1) INV = 1
      IF    (NLT .NE. 0) THEN
          IF (NLT .GE. NLATT) THEN
            NLT = 1
          ELSE
            NLT = NLT + 1
            SMOD = .FALSE.
            GOTO 110
          ENDIF
      ENDIF
      NS = NS + 1
      SMOD  = .TRUE.
 110  ALLSEQ = NS .GT. NSYMM
      RETURN
      END
      SUBROUTINE SYMOPN (XDATAS, XEQ, PATSYM, ENANTI, TLATTI, ALLSEQ )
      DIMENSION XDATAS(4),XEQ(3)
      LOGICAL PATSYM, ENANTI, TLATTI, ALLSEQ
      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, SMOD
      DIMENSION X(3), XEQL(3), XINTRM(3)
      IF (XDATAS(1).LT. 100.) THEN
           DO 110 I=3,1,-1
           X(I)=XDATAS(I)
 110       XDATAS(I+1)=XDATAS(I)
           XDATAS(1)=101.
           FIRST= .TRUE.
           NS=1
           ITS=1
           IF (PATSYM) ITS=0
           NLT = 0
           IF (TLATTI .AND. NLATT.GT.1) NLT=1
           INV=0
           IF (ENANTI .OR. ICENT.EQ.2 .OR. PATSYM) INV=1
      ENDIF
      CALL SYMEQU (NS, ITS, NLT, INV, FIRST, X, XEQL, XINTRM)
      CALL NEXSYM (NS, NLT, INV, NSYMM, NLATT, SMOD, ALLSEQ)
      FIRST = SMOD
           CALL KERNAB (XEQL, XEQ, 3)
           IF (ALLSEQ) THEN
            DO 210 I=1,3
 210        XDATAS(I) = XDATAS(I+1)
           ENDIF
      RETURN
      END
      FUNCTION OCCUPX (X)
      DIMENSION X(3)
      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 XEQ(3,48), IXSELF(48), XEQM(3)
      LOGICAL PATSYM,TLATTI
      DATA  PATSYM,TLATTI /.FALSE.,.FALSE./
      DATA  DMAX / 0.7/
      OCCUPX = IMULT
      CALL ALLEQP (X, XEQ, 48, PATSYM, TLATTI, NEQP)
      CALL KERNZI (0, IXSELF, NEQP)
      DO 120 N= 1,NEQP
      OCCUPX = OCCUPX - IXSELF(N)*NLATT
      IF (IXSELF(N).EQ.1) GOTO 120
            N1=N+1
      DO 110 M=N1,NEQP
      DO 105 L= 1,NLATT
      IF (IXSELF(M).EQ.1) GOTO 110
      CALL VPLUSV (XEQ(1,M), TLATT(1,L), XEQM, 3)
      IXSELF(M)=ISELFD (XEQ(1,N), XEQM, DMAX)
 105  CONTINUE
 110  CONTINUE
 120  CONTINUE
      OCCUPX = OCCUPX/IMULT
      RETURN
      END
      SUBROUTINE ALLEQP (X, XEQ, NXQ, PATSYM,TLATTI, NEQP)
      DIMENSION X(3), XEQ(3,NXQ)
      LOGICAL PATSYM,TLATTI
      DIMENSION XDATAS(4)
      LOGICAL ALLSEQ, ENANTI
      DATA  ENANTI /.FALSE./
      CALL KERNAB (X,XDATAS,3)
      N=0
 110  CONTINUE
      N = N + 1
      CALL SYMOPN (XDATAS, XEQ(1,N), PATSYM, ENANTI, TLATTI, ALLSEQ)
      IF (.NOT. ALLSEQ .AND. N.LT.NXQ) GOTO 110
      NEQP = N
      RETURN
      END
      SUBROUTINE DELIPO (X, N, DMAX)
      DIMENSION X(5,N)
      LOGICAL DMAXCH
      DMAXCH = .TRUE.
      N11=1
      DO 410 N2= 2, N
      DO 210 N1= 1, N11
      IF (ISELFD (X(1,N2), X(1,N1), DMAX) .EQ. 1) GOTO 410
 210  CONTINUE
      N11 = N11+1
      CALL KERNAB (X(1,N2), X(1,N11), 5)
 410  CONTINUE
      N=N11
      RETURN
      END
      SUBROUTINE INVAB ( A, B, N)
      DIMENSION A(N), B(N)
      DO 110 I = 1, N
      B(I) = -A(I)
 110  CONTINUE
      RETURN
      END
      SUBROUTINE VPLUSV (V1, V2, VOUT, N)
      DIMENSION V1(N), V2(N), VOUT(N)
      DO 110 I = 1, N
        VOUT(I) = V1(I) + V2(I)
 110  CONTINUE
      RETURN
      END
      SUBROUTINE VMINV (V1, V2, VOUT, N)
      DIMENSION V1(N), V2(N), VOUT(N)
      DO 110 I = 1, N
        VOUT(I) = V1(I) - V2(I)
 110  CONTINUE
      RETURN
      END
      SUBROUTINE REDFCO (X, XOUT, N)
      DIMENSION X(N), XOUT(N)
      DO 110 I = 1, N
        XOUT(I) = X(I) - ANINT(X(I))
 110  CONTINUE
      RETURN
      END
      SUBROUTINE AR2SYM (AIJ, I, J, IJMAX, ARRAYS, NMAX)
      DIMENSION ARRAYS(NMAX)
      N = IPOIN1 (I,J, IJMAX)
      ARRAYS(N) = AIJ
      RETURN
      END
      FUNCTION IPOIN1 (I,J, IJMAX)
      IF (I.GE.J) THEN
          IPOIN1 = (J-1) * IJMAX - (J*J - J)/2 + I
      ELSE
          IPOIN1 = (I-1) * IJMAX - (I*I - I)/2 + J
      ENDIF
      RETURN
      END
      FUNCTION SQDIST (X, Y)
      DIMENSION X(3), Y(3)
      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 D(3)
      DO 120 I=1, 3
         D(I)=X(I)-Y(I)-ANINT (X(I)-Y(I))
  120 CONTINUE
      SQDIST=0.0
      DO 130 I=1, 3
       SQDIST=SQDIST+
     *      D(I)*(RRMAT(1,I)*D(1)+RRMAT(2,I)*D(2)+RRMAT(3,I)*D(3))
  130 CONTINUE
      RETURN
      END
      SUBROUTINE DETSEQ ( INDXHV,NHIGST, ARRAY,NDIM1,NE, ISQ, N1)
      DIMENSION INDXHV(NHIGST), ARRAY(NDIM1,NE)
      IF (N1 .LT. NHIGST) THEN
            NRE = N1
      ELSE
            NRE = NHIGST
      ENDIF
      NRE1 = NRE - 1
            N2 = N1 + 1
      DO 300 N = N2, NE
      IF ( N .GT. NHIGST ) THEN
        IF ( ARRAY( ISQ, N) .LE. ARRAY( ISQ, INDXHV(NRE)) ) GOTO 300
      ENDIF
      IF (N .LE. NHIGST) THEN
            NRE1 = NRE
            NRE = N
      ENDIF
      IF (NRE1.NE.0) THEN
        CALL SRSEQN (INDXHV, NRE1, ARRAY(1,N), ARRAY,NDIM1,NE, ISQ, NR)
          DO 100 I = NRE1, NR, -1
  100       INDXHV(I+1) = INDXHV(I)
            INDXHV(NR) = N
      ELSE
            INDXHV(1) = N
      ENDIF
  300 CONTINUE
      RETURN
      END
      SUBROUTINE SRSEQN (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 EL2AR2 (EL, I1, ISQ, AR2, MAX2, NELS, INDAR2)
      DIMENSION EL(I1), AR2(I1,MAX2), INDAR2( MAX2)
      DATA IND / 0 /
      IF ( NELS .EQ. MAX2 ) THEN
        IF ( EL(ISQ) .LT. AR2(ISQ,INDAR2(NELS)) ) RETURN
        IF (NELS .NE. INDAR2(NELS) ) THEN
           CALL KERNAB (AR2(1,NELS), AR2(1,INDAR2(NELS)), I1)
           DO 110 N = 1, NELS
           IF (INDAR2(N) .EQ. NELS) THEN
            IND = N
            GOTO 111
           ENDIF
  110      CONTINUE
  111      INDAR2(IND) = INDAR2(NELS)
        ENDIF
      ELSE
         NELS = NELS + 1
      ENDIF
      CALL KERNAB (EL, AR2(1,NELS), I1)
      CALL DETSEQ ( INDAR2,NELS, AR2,I1,NELS, ISQ, NELS-1)
      RETURN
      END
      SUBROUTINE SORTIN ( INDXHV,NIND, NHIGST, ARRAY,NDIM1,NE )
      DIMENSION INDXHV(NIND), ARRAY(NDIM1,NE)
      DO 210 N = 1,NHIGST
            NR = INDXHV(N)
         IF (NR .EQ. N) GOTO 210
      DO 110 I = 1,NDIM1
      ELIN = ARRAY(I,N)
      ARRAY(I,N) = ARRAY(I,NR)
      ARRAY(I,NR)= ELIN
 110  CONTINUE
      INDXHV(N) = N
            N1 = N + 1
      DO 120 N2 = N1,NHIGST
      IF (INDXHV(N2) .EQ. N) THEN
            INDXHV(N2)=NR
            GOTO 210
      ENDIF
 120  CONTINUE
 210  CONTINUE
      RETURN
      END
      SUBROUTINE PATTIN
      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)),  (IPRPAT, KEYS(8))
      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 = 300000)
      COMMON /  / ITAB(NUMTAB)
      INTEGER * 2 ITAB
      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 /
      DO 111 I = 1, NUMTAB
 111  ITAB(I) = 0
      FMAX99 = 30254.
      FUNGR = 0.
      FUNSUM = 0.
      CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ.NE.0) CALL KERROR
     *   ('Patterson file (FMAP) not found.', -1, 'PATTIN')
      READ (IFMAP) 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) CALL KERROR
     *   ('No Patteron function (error on file FMAP)', 0 , 'PATTIN' )
      READ (IFMAP) NX, NZ, NYHALF, NY
      WRITE (LIS2,6) NX, NY, NZ
   6  FORMAT (' Fourier grid X * Y * Z = ' , I3, 2(' *',I3) )
      SCAL = 0.2
      IF (PROGNM .EQ. 'PATTY ')     SCAL = SCADEK
      ABSCAL = SCAL * FFTSC * VOLUM
      SINGPK = ORIGIN * ABSCAL * 18. /VOLUM
      IF (SWPRI) WRITE (LIS2, 138) FFTSC
  138 FORMAT ('0Input 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 C-C :  peak-height is approximately   ' ,F10.2 /)
      K = 0
      DO 12 I=1,3
      L = (NXYZ(I)+1) / 2
      IF (I.NE.2 .AND. KLAUE.LT.0) L=NXYZ(I)-1
      LXYZ(I) = L
   12 IS(I) = 0
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.4) IS(2)=-LXYZ(2)
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.2) IS(3)=-LXYZ(3)
      DO 14 I=1,3
      NXYZM(I) = NXYZ(I)
      IF (IS(I) .EQ. 0) NXYZM(I) = LXYZ(I) + 1
   14 NUM(I) = LXYZ(I) - IS(I) + 1
      NUMXY = NUM(1) * NUM(2)
      NUMXYZ = NUMXY * NUM(3)
      IF (NUMXYZ .GT. NUMTAB) THEN
         WRITE (LIS1, 171) NUMTAB, NUMXYZ
  171 FORMAT (' Storage of Patterson, space:', I7,', needed:', I7)
         CALL KERROR (' PATTERSON TOO LARGE', 171, 'PATTIN' )
         ENDIF
      DO 217 I = 1,3
  217 GTXYZ(I) = NXYZ(I)
      NUMC = NUMXY * IS(3) + NUM(1) * IS(2) + IS(1) - 1
      IF (IPRPAT .GT. 0) THEN
         WRITE (CHOUT, FMT=
     *      '('' Print input Patterson map to printer LIS2'')')
         CALL SHOUT2
         WRITE (LIS2,24) (I, I=1, NUMX-1)
  24     FORMAT ('1Input Patterson map, file FMAP'//
     *      '  IY  IZ  IX = 0' , 24I4 / (12X, 25I4))
         WRITE (LIS2, FMT='('' '')')
         ENDIF
      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.3) IXY=KXY
   26 DO 48 I2=1,NZ
      IF (I2.GT.NZM) K=0
      IF (K.EQ.0) GOTO 28
      IZ = I2 - 1
      IXYZ = NUMXY * IZ
      IXYZC = IXYZ + IXY - NUMC
      KXYZC = IXYZ + KXY - NUMC
      L = 1
      IF (IS(3).EQ.0) GOTO 28
      KZ = IZ - NZ
      JXYZ = NUMXY * KZ
      JXYZC = JXYZ + IXY - NUMC
      LXYZC = JXYZ + KXY - NUMC
      IF (IZ.GT.LXYZ(3)) L=3
      IF (IZ.EQ.LXYZ(3) .OR. IZ.EQ.NZ/2) L=2
      IF (L.EQ.3) IXYZC=JXYZC
      IF (L.EQ.3) KXYZC=LXYZC
   28 READ (IFMAP) IBSEC, IBJ, IBNX,(LPAT(I),I=1,IBNX)
      IF (K.EQ.0 .OR. L.EQ.0) GOTO 48
      DO 40 I3=1,NXM
      FUN = LPAT(I3)
      FUN99 = 99. * ( FUN * SCAL + 25.)
      IF (FUN99 .LT. 0.0) FUN99 = 0.0
      IF (FUN99 .GT. FMAX99) FUN99 = FMAX99
      IF (FUN99 .GT. FUNGR) FUNGR = FUN99
      IFUN99 = NINT(FUN99)
      LPAT(I3) = IFUN99
      FUNSUM = FUNSUM + FUN99
      IX = I3 - 1
      IADR = IXYZC + IX
      ITAB(IADR) = IFUN99
      IADR = JXYZC + IX
      IF (L.EQ.2) ITAB(IADR) = IFUN99
      IF (K.NE.2) GOTO 40
      IADR = KXYZC + IX
      ITAB(IADR) = IFUN99
      IADR = LXYZC + IX
      IF (L.EQ.2) ITAB(IADR) = IFUN99
   40 CONTINUE
      IF (IPRPAT .GT. 0) WRITE (LIS2,42) IY, IZ, (LPAT(I3), I3=1,NUMX)
   42 FORMAT (2I4, 4X, 25I4 / (12X, 25I4))
   48 CONTINUE
   50 CONTINUE
      IF (ILAUE .EQ.1 .AND. ICENT .EQ. 1) THEN
         CALL FILCLO (IFMAP, 'DELETE')
      ELSE
         CALL FILCLO (IFMAP, 'KEEP')
         ENDIF
      FUNSUM = FUNSUM / FLOAT(NUMXYZ)
      WRITE (LIS2,52) FUNGR, FUNSUM
   52 FORMAT (' Largest scaled Patterson value is: ', 13X, F7.0/
     *         20X,    ' averaged value is: ', 9X, F7.0)
      RETURN
      END
      SUBROUTINE RDOUTT(ARG, FUNF)
      DIMENSION ARG(3)
      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 (ITPL,  KEYS(7))
      PARAMETER (NUMTAB =300000)
      COMMON / / ITAB(NUMTAB)
      INTEGER * 2 ITAB
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3)
      EQUIVALENCE (NX, NUM(1)), (NY, NUM(2)), (NXY, NUMXY)
      LOGICAL  SYMM2, SYMM3
      DIMENSION  IFAR(3), INEAR(3), RARG(3), FM(3)
      EQUIVALENCE (IXFAR,IFAR(1)),  (IYFAR,IFAR(2)),  (IZFAR,IFAR(3))
      EQUIVALENCE (IXNEAR,INEAR(1)),(IYNEAR,INEAR(2)),(IZNEAR,INEAR(3))
      EQUIVALENCE (RX,RARG(1)),     (RY,RARG(2)),     (RZ,RARG(3))
      EQUIVALENCE (FMX,FM(1)),      (FMY,FM(2)),      (FMZ,FM(3))
      DATA IZD,IYZD / 0, 0/
      DO 301 J= 1, 3
      RARG(J) = AMOD(ARG(J),1.0)
      IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0
  301 IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0
      CALL SYMM (RX, RY, RZ)
      IF (ITPL.EQ.2) GOTO 2000
      IF (ITPL.EQ.3) GOTO 2000
      DO 599 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      IF (T) 540, 550, 550
  540 T = T - 1.
  544 I = IFIX(T)
      IF (I.GE.-LXYZ(IX)) GOTO 555
      T = T + 0.01
      GOTO 544
  550 I = IFIX(T)
      IF (I.LT.LXYZ(IX)) GOTO 555
      T = FLOAT(I) - 0.01
      GOTO 550
  555 F=T-FLOAT(I)
      IF (F) 560,590,570
  560 F=F+1.0
  570 IF (F-0.5) 590,580,580
  580 FM(IX) = 1. - F
      IFAR(IX)=I
      INEAR(IX)=I+1
      GOTO 599
  590 FM(IX) = F
      INEAR(IX)=I
      IFAR(IX)=I+1
  599 CONTINUE
      K111 = NXY * IZNEAR + NX * IYNEAR + IXNEAR - NUMC
      IJX = ITAB(K111)
      FUNNER = FLOAT( IJX ) / 99.
      K211=K111-IXNEAR+IXFAR
      K121=K111+NX*(IYFAR-IYNEAR)
      K112=K111+NXY*(IZFAR-IZNEAR)
      IJX = ITAB(K211)
      FUNX = FLOAT( IJX ) / 99.
      IJX = ITAB(K121)
      FUNY = FLOAT( IJX ) / 99.
      IJX = ITAB(K112)
      FUNZ = FLOAT( IJX ) / 99.
      FUNF = FUNNER * (1.-FMX-FMY-FMZ) + FUNX*FMX + FUNY*FMY + FUNZ*FMZ
      IF (ITPL .NE. 4) GOTO 610
      FUNF = AMAX1 (FUNF, 0.25 * (FUNNER + FUNX + FUNY + FUNZ) )
      RETURN
  610 I1=IZFAR*NXY
      I2=IYFAR*NX
      K222 = I1 + I2 + IXFAR - NUMC
      K122=K222-IXFAR+IXNEAR
      K212=K222-I2+NX*IYNEAR
      K221=K222+NXY*IZNEAR-I1
      IJX = ITAB(K222)
      FUNFAR = FLOAT( IJX ) / 99.
      IJX = ITAB(K122)
      FUNYZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K212)
      FUNXZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K221)
      FUNXY = FLOAT( IJX ) / 99.
      FMXY=FMX*FMY
      FMXZ=FMX*FMZ
      FMYZ=FMY*FMZ
      FMXYZ=FMX*FMYZ
      T1=FMYZ-FMXYZ
      T2=FMXZ-FMXYZ
      FUNF = FUNF + FMXYZ*FUNFAR + T1*FUNYZ + T2*FUNXZ +
     1 (FMXY-FMXYZ)*FUNXY + FUNNER*(T1+FMXZ+FMXY) - FUNZ*(T2+FMYZ)
     1 - FUNY*(T1+FMXY) - FUNX*(T2+FMXY)
      RETURN
 2000 FUNF=-100.
      DO 713 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      I = INT(T)
      DT=I-T
      IF (T.LT.0.) THEN
        IFAR(IX)=I
        I=I-1
        IF (DT.GT.0.95) THEN
          I=I-1
        ELSE IF (DT.LT.0.05) THEN
          IFAR(IX)=IFAR(IX)+1
        ENDIF
      ELSE
        IFAR(IX)=I+1
        IF (DT.LT.-0.95) THEN
          IFAR(IX)=IFAR(IX)+1
        ELSE IF (DT.GT.-0.05) THEN
          I=I-1
        ENDIF
      ENDIF
  713 INEAR(IX)=I
      DO 720 IZ=INEAR(3),IFAR(3)
       SYMM3=IZ.LT.IS(3) .OR. IZ.GT.LXYZ(3)
       IF (.NOT.SYMM3)  IZD=NXY*IZ-NUMC
      DO 720 IY=INEAR(2),IFAR(2)
       SYMM2=SYMM3 .OR. IY.LT.IS(2) .OR. IY.GT.LXYZ(2)
       IF (.NOT.SYMM2)  IYZD=IZD+NX*IY
      DO 720 IX=INEAR(1),IFAR(1)
       IF (SYMM2 .OR. IX.LT.IS(1) .OR. IX.GT.LXYZ(1)) THEN
        RX=IX/GTXYZ(1)
        RY=IY/GTXYZ(2)
        RZ=IZ/GTXYZ(3)
        DO 715 J= 1, 3
        RARG(J) = AMOD(RARG(J),1.0)
        IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0
  715   IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0
        CALL SYMM(RX,RY,RZ)
        I1=NINT(RX*GTXYZ(1))
        I2=NINT(RY*GTXYZ(2))
        I3=NINT(RZ*GTXYZ(3))
        IADR = NXY*I3 + NX*I2 + I1 - NUMC
        IJX = ITAB(IADR)
        FUN1 = FLOAT( IJX ) / 99.
       ELSE
        K111=IYZD+IX
        IJX = ITAB(K111)
        FUN1 = FLOAT( IJX ) / 99.
        ENDIF
       IF (FUN1.GT.FUNF) FUNF=FUN1
 720  CONTINUE
      RETURN
      END
      SUBROUTINE 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))
      IF (KLAUE.LT.0) THEN
        IF (Y.LT.0.0) THEN
            X=-X
            Y=-Y
            Z=-Z
        ENDIF
        IF (X.LT.0.0) X=1.+X
        IF (Z.LT.0.0) Z=1.+Z
        RETURN
      ENDIF
      GOTO (5, 15, 25, 35), KLAUE
   5  IF (X.GE.0.0) RETURN
      X = -X
      Y = -Y
      Z = -Z
      RETURN
   15 Y = ABS(Y)
      IF (X.GE.0.0) RETURN
      X = -X
      Z = -Z
      RETURN
   25 X = ABS(X)
      Y = ABS(Y)
      Z = ABS(Z)
      RETURN
   35 Z = ABS(Z)
      IF (X.GE.0.0) RETURN
      X = -X
      Y = -Y
      RETURN
      END
      SUBROUTINE ASYMS (ASY)
      DIMENSION ASY(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
      EQUIVALENCE (LIS2, IFILE(8))
      DIMENSION USX(3), TSV(3,4)
      LOGICAL ASUNIT
      CHARACTER *1 ALATS(7)
      DATA ALATS /'P', 'A', 'B', 'C', 'I', 'F', 'R'/
      CALL UNITCS (USX, TSV, NT, ILATS)
      WRITE (LIS2, FMT='(/'' Subroutine ASYMS''/
     *   '' Symmetry map, unit cell:'', 3F8.3)') USX
      WRITE (LIS2, FMT='('' Centering:    '', A1)') ALATS(ILATS)
      WRITE (LIS2, FMT='('' Translations: '', 4(''/'',3F4.1))')
     *   ((TSV(I,II), I=1,3), II=1, NT)
      CALL ASYMPP (ILATS, ASY, ASUNIT)
      WRITE (LIS2,FMT='('' Asymmetric part:'',3X,3(''/'',2F8.3))') ASY
      ASY(2)=USX(1)*ASY(2)
      ASY(4)=USX(2)*ASY(4)
      ASY(6)=USX(3)*ASY(6)
      WRITE (LIS2,FMT='('' - for symm. map:'',3X,3(''/'',2F8.3)/)') ASY
      RETURN
      END
      SUBROUTINE UNITCS (USX, TSV, NT, ILATS)
      DIMENSION USX(3), TSV(3,4)
      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 /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3)
      DIMENSION IFREE(3)
      CALL KERNZA (0.0, USX, 3)
      NT=1
      CALL KERNZA (0.0, TSV(1,1), 3)
      ILATS = 1
      IF (IDDPOL.EQ.3) RETURN
      CALL KERNZI (0, IFREE, 3)
      I2=2
      I3=3
      DO 101 I=1,3
      IF (IDDPOL.EQ.1) THEN
         IF(RVPOL(I).GT.0.01 .AND.
     *      RVPOL(I2).LT.0.01 .AND. RVPOL(I3).LT.0.01 ) THEN
            IFREE(I)=1
            GOTO 100
            ENDIF
      ELSE IF (IDDPOL.EQ.2) THEN
         IF( RVPOL(I).LT.0.01 .AND.
     *      (RVPOL(I2).GT.0.01 .OR. RVPOL(I3).GT.0.01) ) THEN
            IFREE(I)=1
            GOTO 100
            ENDIF
         ENDIF
 100  IF (I2.EQ.1) I3=2
      I2=1
 101  CONTINUE
      I2=2
      I3=3
      DO 210 I=1,3
      USX(I)=1.0
      IF (IFREE(I).EQ.1) USX(I)=0.0
      DO 115 LT=1,NLATT
      N1=1
      IF (LT.EQ.1) N1=2
      DO 110 N=N1,NOR
      IF ( (AMOD(ORIG(I2,N)+TLATT(I2,LT)+8.,1.0).LT.0.01  .OR.
     *     IFREE(I2).EQ.1 )  .AND.
     *     (AMOD(ORIG(I3,N)+TLATT(I3,LT)+8.,1.0).LT.0.01  .OR.
     *     IFREE(I3).EQ.1 )  )  THEN
              IF (AMOD(ORIG(I,N)+TLATT(I,LT)+8.,1.0).LT.USX(I))
     *           USX(I)=AMOD(ORIG(I,N)+TLATT(I,LT)+8.,1.0)
         ENDIF
 110  CONTINUE
 115  CONTINUE
      IF (I2.EQ.1) I3=2
      I2=1
 210  CONTINUE
      DO 315 LT=1,NLATT
      N1=1
      IF (LT.EQ.1) N1=2
      DO 310 N=N1,NOR
      NC=0
      ND=0
      NT=NT+1
      DO 305 J=1,3
      TSV(J,NT)= AMOD(ORIG(1,N)+TLATT(1,LT)+8.,1.0)
      IF (TSV(J,NT).LT.0.001) NC=NC+1
      IF (NC.GT.1) GOTO 306
      IF (USX(J).GT.0.01) THEN
         IF (TSV(J,NT).GT.USX(J)-0.0001)  GOTO 306
      ELSE
         IF (TSV(J,NT).GT.USX(J)+0.0001)  GOTO 306
         ENDIF
      DO 302 MT=1,NT-1
 302  IF (ABS(TSV(J,NT)-TSV(J,MT)).LT.0.01)  ND=ND+1
 305  CONTINUE
      IF (ND.LT.3) GOTO 310
 306  NT=NT-1
 310  CONTINUE
 315  CONTINUE
      IF (NT.EQ.1) RETURN
      IF (NT.EQ.2) THEN
         I3=0
         IF (ABS(TSV(1,2)) .LT. 0.0001) THEN
             ILATS=2
             I1=2
             I2=3
         ELSE IF (ABS(TSV(2,2)) .LT. 0.0001) THEN
             ILATS=3
             I1=1
             I2=3
         ELSE IF (ABS(TSV(3,2)) .LT. 0.0001) THEN
             ILATS=4
             I1=1
             I2=2
         ELSE
             ILATS=5
             I1=1
             I2=2
             I3=3
             ENDIF
         IF (I3.EQ.0) I3=I1
         IF (AMOD(TSV(I1,2)/USX(I1)-0.5, 1.0) .GT. 0.001) ILATS=1
         IF (AMOD(TSV(I2,2)/USX(I2)-0.5, 1.0) .GT. 0.001) ILATS=1
         IF (AMOD(TSV(I3,2)/USX(I3)-0.5, 1.0) .GT. 0.001) ILATS=1
         RETURN
         ENDIF
      IF (NT.EQ.4) THEN
         DO 420 I=1,3
         I1=I+1
         IF (I1.GT.3) I1=1
         I2=I-1
         IF (I2.LT.1) I2=3
         DO 410 N=2,NT
         IF (AMOD(TSV(I,N),1.0) .LT. 0.0001) THEN
            IF (AMOD(TSV(I1,N)/USX(I1)-0.5, 1.0) .GT. 0.001) RETURN
            IF (AMOD(TSV(I2,N)/USX(I2)-0.5, 1.0) .GT. 0.001) RETURN
            GOTO 420
            ENDIF
 410     CONTINUE
         RETURN
 420     CONTINUE
         ENDIF
      IF (NT.EQ.3) THEN
         I1=0
         DO 510 N=2,NT
         IF (I1.NE.23 .AND.
     *      AMOD(TSV(1,N)/USX(1)-0.666667, 1.0) .LT. 0.001) THEN
            IF (AMOD(TSV(2,N)/USX(2)-0.333333,1.0) .GT. 0.001) RETURN
            IF (AMOD(TSV(3,N)/USX(3)-0.333333,1.0) .GT. 0.001) RETURN
            I1=23
            GOTO 510
         ELSE IF (I1.NE.13 .AND.
     *      AMOD(TSV(1,N)/USX(1)-0.33333, 1.0) .LT. 0.001) THEN
            IF (AMOD(TSV(2,N)/USX(2)-0.666667,1.0) .GT. 0.001) RETURN
            IF (AMOD(TSV(3,N)/USX(3)-0.666667,1.0) .GT. 0.001) RETURN
            I1=13
            GOTO 510
         ENDIF
         RETURN
 510     CONTINUE
         ILATS=7
         ENDIF
      RETURN
      END
      SUBROUTINE ASYMPP (ILATS, ASY, ASUNIT)
      DIMENSION ASY(6)
      LOGICAL ASUNIT
      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)
      ASUNIT = .TRUE.
      ASY(1)=0.0
      ASY(3)=0.0
      ASY(5)=0.0
      GOTO(100,200,300,400,500,600,700,800,900,1000,1100,1200,1300,1400)
     *   ILAUE
 100  ASY(2)=0.5
      ASY(4)=1.0
      ASY(6)=1.0
      RETURN
 200  CONTINUE
      ASY(2)=0.5
      ASY(4)=0.5
      ASY(6)=1.0
      IF (IUNIQ.EQ.2 .AND.(ILATS.EQ.2 .OR. ILATS.EQ.4 .OR. ILATS.EQ.5))
     *   ASY(4)=0.25
      IF (IUNIQ.EQ.3) THEN
         ASY(2)=1.0
         ASY(6)=0.5
         IF (ILATS.EQ.2 .OR. ILATS.EQ.3 .OR. ILATS.EQ.5)  ASY(6)=0.25
      ELSEIF (IUNIQ.EQ.1) THEN
         ASY(4)=1.0
         ASY(6)=0.5
         ENDIF
      RETURN
 300  CONTINUE
 400  CONTINUE
 500  ASY(2)=0.5
      ASY(4)=0.5
      ASY(6)=0.5
      IF (ILAUE .GE. 4) THEN
         IF (ILATS .EQ. 5)  ASY(6)=0.25
         GOTO 1220
      ELSE
         IF (ILATS.EQ.4 .OR. ILATS.EQ.5 .OR. ILATS.EQ.6)  ASY(2)=0.25
         IF (ILATS.EQ.6)  ASY(4)=0.25
         ENDIF
      RETURN
 600  CONTINUE
 700  CONTINUE
      ASY(2)=1.0
      ASY(4)=1.0
      ASY(6)=0.5
      GOTO 1220
 800  ASY(2)=2./3.
      IF (ILATS.EQ.7) GOTO 1110
      ASY(4)=2./3.
      ASY(6)=0.5
      GOTO 1220
 900  ASY(2)=2./3.
      IF (ILATS.EQ.7) GOTO 1110
      ASY(4)=1./3.
      ASY(6)=1.0
      GOTO 1220
 1000 CONTINUE
 1100 ASY(2)=2./3.
      IF (ILATS.EQ.7) GOTO 1110
      ASY(4)=0.5
      ASY(6)=0.5
      GOTO  1220
 1110 ASY(4)=2./3.
      ASY(6)=1./6.
      GOTO  1220
 1200 ASY(2)=2./3.
      ASY(4)=1./3.
      ASY(6)=0.5
 1220 ASUNIT = IUNIQ.EQ.3
      IF (.NOT. ASUNIT)  GOTO 100
      RETURN
 1300 CONTINUE
 1400 ASY(2)=0.5
      ASY(4)=0.5
      ASY(6)=0.5
      IF (ILATS.EQ.6) ASY(6)=0.25
      IF (ILATS.EQ.6 .AND. ILAUE.EQ.14)  ASY(4)=0.25
      IF (ILATS.EQ.5 .AND. ILAUE.EQ.14)  ASY(6)=0.25
      RETURN
      END
      FUNCTION NQSET (RSET, N)
      DIMENSION RSET(N)
      NQSET=0
      DO 110 M=1,N
      JC=NINT(RSET(M))
      IF (JC.GT.10)  JC=10*JC
      IF (JC.GT.100) JC=100*JC
 110  NQSET = NQSET + JC
      RETURN
      END
      SUBROUTINE XHELIV (X,NHX, ASVXX,NASV, AMINHL, UX, NUX)
      PARAMETER  (MXPKS=150, MXHH=16, MXPP=128, MXUX=MXPP/4)
      DIMENSION X(3,NHX), ASVXX(5,NASV), UX(MXHH+6,MXUX)
      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 /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATPKS/ VP(4,MXPP), NVPS, SC2DEK, PATADD
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT,AMI1,AMI2,PLIM,PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (MXVHL=8*MXUX)
      DIMENSION V(5,4*MXPKS+1),VVP(MXPKS), VVP1(MXPKS),
     *    R1(3), UUX(MXHH+6), INDX(MXUX), INDXV(MXVHL),
     *    VEQ(3,48), R1EQ(3,MXHH), VML(3,4)
      LOGICAL PATSYM,TLATTI, L2L, FIRST, PATSR1
      DATA DMAX,DMAXP,PLIMHL,P1,NEQV,NV,LL,NUXM /0.8,0.2,.0,.0,1,0,0,0/
      DATA SUMIW /0.0/
      DATA PATSR1,PATSYM,TLATTI,FIRST /.FALSE.,.TRUE.,.FALSE.,.TRUE./
      NUX=0
      AMINHL=0.0
      NX=NHX/NLATT
      IF (NHEAVY.GT.2)                                   GOTO 2000
      IF (LTHEAV.EQ.NELMS)                               GOTO 2000
      IF (LTHEAV.NE.LTHV .OR. NHX.LT.NINT(HEAVYN*IMULT)) GOTO 2000
      IF (NX.LE.1 .OR. NX.GT.MXHH .OR. NVPS.LE.0)        GOTO 2000
      IF (0.7*NCELLZ(1)**2 .GT. NCELLZ(LTHV)**2)         GOTO 2000
      L2L = NHX.LT.IMULT
      ISQ=MXHH+6
      NDIM1=ISQ
      NP=NVPS
      IF (FIRST) THEN
         FIRST=.FALSE.
         CALL KERNZA (0., UUX, NDIM1)
         IF (ABS(SC2DEK-1.).GT.0.0001) THEN
            DO 100 N=2,NVPS
 100        VP(4,N)=SC2DEK*VP(4,N) + PATADD
            SC2DEK=1.0
            ENDIF
         DO 110  L=LTHEAV+1,NELMS
         IF (0.7*NCELLZ(LTHEAV+1) .LT. NCELLZ(L)) THEN
            LL=L
            NUXM=NUXM+NCELTY(L)
            ENDIF
 110      CONTINUE
       NUXM=NUXM/NLATT
       IF (NUXM.GT.MXVHL) NUXM=MXVHL
       NUXM=NUXM/(NSYMM*ICENT)
       IF (NUXM.GT.MXUX) NUXM=MXUX
       PLIMHL=(PLIMC(LTHEAV,LL)-PATAD)*ICENT
       SMLIM=0.3*PLIMHL/ICENT
       ITSTQV=2
       NV=0
       NVQ=4*MXPKS
       NEQV=1
       DO 150 M=2,NP
       IF (VP(4,M).LT.PLIMHL+PATAD)  GOTO 140
       CALL ALLEQP (VP(1,M), VEQ, 48, PATSYM,TLATTI, NEQV)
       NVQ=NVQ-NEQV
       DO 130 N=1,NEQV
       NV=NV+1
       V(5,NV)=0.001
       CALL KERNAB (VEQ(1,N),V(1,NV),3)
 121   IF (V(1,NV).GT. 0.00001) GOTO 130
        V(1,NV)=V(1,NV)+1.0
        GOTO 121
 130   V(4,NV)=M+0.01
 140   IF (M.EQ.NP .OR. NVQ.LT.NEQV) THEN
          CALL DELIP2 (V, NV, VVP1, NP, DMAXP)
          NVQ=4*MXPKS-NV
          IF (NVQ.LT.NEQV) GOTO 160
       ENDIF
 150   CONTINUE
 160   V(4,NV+1)=0.001
       VVP1(1)=1.0
       DO 170 M=1,NP
 170   VVP1(M)=VVP1(M)/NEQV
       ISUMH=0
       IH=0
       DO 180 I=1,LTHV
       ICELH=NCELTY(I)/NLATT
       IF (IH+ICELH.GT.NX) ICELH=NX-IH
       IF (ICELH.EQ.0) GOTO 185
       IH=IH+ICELH
       ISUMH = ISUMH + ICELH*NCELLZ(I)
 180   CONTINUE
 185   ILMAX=(NV*ICENT)/IH
       IF (ILMAX.GT.NUXM*ICENT*NSYMM) ILMAX=NUXM*ICENT*NSYMM
       IL=NX-IH
       ISUML=IL*NCELLZ(LTHV)
       DO 190 I=LTHV+1,LL
       ICELL=NCELTY(I)/NLATT
       IF (IL+ICELL.GT.ILMAX) ICELL=ILMAX-IL
       IF (ICELL.EQ.0) GOTO 195
       IL=IL+ICELL
 190   ISUML=ISUML+ (ICELL * NCELLZ(I))
 195   SUMIW=ISUML*ISUMH
      ENDIF
      DO 210 M=1,NP
 210  VVP(M)=(VP(4,M)-PATADD)*VVP1(M)
      PHT= ICENT*(PLIMC(LTHV,LTHV)-PATAD)
      DO 240 NA=1,NASV
      DO 230 N =1,NV
      M=V(4,N)
      IF (VVP(M).LT.PLIMHL) GOTO 230
      IF (ISELFD(V(1,N),ASVXX(1,NA),DMAXP) .EQ. 1)  THEN
         PH=ASVXX(5,NA)*VVP1(M)
         IF (PH.GT.PHT) PH=PHT
         VVP(M)=VVP(M)-PH
         GOTO 240
      ENDIF
 230  CONTINUE
 240  CONTINUE
      L2L=L2L .OR. NCELLZ(LL).GE.20
      NHIGV=0
      DO 310 N=1,NV
      I=V(4,N)
      V(5,N)=-100.
      IF (VVP(I).GT.PLIMHL) THEN
        CALL VMINV(X(1,1),V(1,N),R1,3)
        PR1=SMINF(R1,X,NX,1,0)-PATAD
        IF (L2L) THEN
         SPM= SSMINF (R1,0,.TRUE.,NEMIN)
         SPM=((SPM-PATAD) * NCELLZ(1)) / NCELLZ(LL)
         PR1=AMIN1(PR1,SPM)
        ENDIF
        V(5,N)=PR1
        IF (V(5,N).GT.0.3*PLIMHL .AND. NHIGV.LT.MXUX) NHIGV=NHIGV+1
      ENDIF
 310  CONTINUE
      IF (NHIGV.EQ.0) GOTO 2000
      ISQV=5
      CALL DETSEQ (INDXV, NHIGV, V, 5, NV, ISQV, 0)
      NV1=NHIGV
      DO 710 IN=1,NV1
      N=INDXV(IN)
      I=V(4,N)
      IF (V(1,N).GT.0.0) THEN
        CALL VMINV(X(1,1),V(1,N),R1,3)
        PR1=V(5,N)
        UUX(1)=N+0.1
        UUX(ISQ)=-100.
        NOV2R1=0
        DO 530 M=2,NX
        CALL VMINV(X(1,M),R1,VML(1,1),3)
        DO 510 L=2,NLATT
 510    CALL VPLUSV(VML(1,1),TLATT(1,L),VML(1,L),3)
          DO 520 K=1,NV
          KI=V(4,K)
          IF (VVP(KI).GT.PLIMHL) THEN
            DO 515 L=1,NLATT
            IF (ISELFD(V(1,K),VML(1,L),DMAX) .EQ. 1) THEN
              UUX(M)=K+0.1
              GOTO 530
            ENDIF
 515        CONTINUE
          ENDIF
 520      CONTINUE
          UUX(M)=0.1
          NOV2R1=NOV2R1+1
          IF (PR1.LT.PLIMHL .OR. FLOAT(NOV2R1)/NX .GT. 0.15) GOTO 701
 530    CONTINUE
        UUX(ISQ-1)=30254.
        PMIN=UUX(ISQ-1)
        DO 550 M=1,NX
        NI=UUX(M)
        IF (NI.EQ.0) GOTO 550
        NI=V(4,NI)
        IF (PMIN.GT.VVP(NI)) PMIN=VVP(NI)
 550    CONTINUE
        IF (PMIN.LT.PR1) PMIN=PR1
        PMIN = ((NX-NOV2R1)*PMIN + NOV2R1*PR1)/NX
        IF (PMIN.LT.PLIMHL) GOTO 701
        UUX(ISQ)=PMIN
        CALL ALLEQP (R1, R1EQ, MXHH, PATSR1, TLATTI, NEQR)
        DO 630 I=1,NEQR
        DO 590 J=1,3
        R1EQ(J,I)=R1EQ(J,I)-ANINT(R1EQ(J,I))
 590    IF (R1EQ(J,I).LT.0.0) R1EQ(J,I)=R1EQ(J,I)+1.0
        IF (I.NE.1) THEN
         DO 595 J=1,3
         IF (R1(J).LT.R1EQ(J,I)-0.0000001) GOTO 597
         IF (R1(J) .GT. R1EQ(J,I)+0.0000001) GOTO 596
 595     CONTINUE
        ENDIF
 596    CALL KERNAB(R1EQ(1,I),R1,3)
 597    IF (I.EQ.1) GOTO 630
        CALL VMINV (X(1,1), R1EQ(1,I), VML(1,1), 3)
        DO 602 L=2,NLATT
 602    CALL VPLUSV(VML(1,1),TLATT(1,L),VML(1,L),3)
        DO 610 IK=IN+1,NV1
        K=INDXV(IK)
        IF (V(1,K).LT.0.0) GOTO 610
        DO 603 L=1,NLATT
        IF (ISELFD(V(1,K),VML(1,L),DMAX) .EQ. 1) THEN
 601      IF (V(1,K).LT.0.0) GOTO 610
          V(1,K)=V(1,K)-1.0
          GOTO 601
        ENDIF
 603    CONTINUE
 610    CONTINUE
 630    CONTINUE
        CALL KERNAB (R1, UUX(MXHH+1), 3)
        UUX(ISQ-2)=PR1
        IF (UUX(ISQ).GT.PLIMHL)
     *      CALL EL2AR2 (UUX, NDIM1, ISQ, UX,MXUX, NUX, INDX)
      ENDIF
 701  IF (V(1,N).GT. 0.00001) GOTO 710
        V(1,N)=V(1,N)+1.0
        GOTO 701
 710  CONTINUE
      IF (NUX.EQ.0) GOTO 2000
      SUM=0.0
      IF (NUX.GT.NUXM) NUX=NUXM
      DO 930 IJ=1,NUX
      J=INDX(IJ)
      PMINJ= UX(ISQ,J)
      DO 920 I=1,NX
      M=UX(I,J)
      IF (M.EQ.0) GOTO 920
      M=V(4,M)
      P1=AMAX1(VVP(M),0.0)
      IF (PMINJ.LT.P1) P1=PMINJ
      VVP(M)=VVP(M)-PMINJ
      SUM=SUM+P1
 920  CONTINUE
 930  CONTINUE
      SUM=(IMULT*SUM)/(NLATT*SCPAT)
      IF (ICENT.EQ.1) SUM=2.0*SUM
      AMINHL = SUM/SUMIW
 2000 CONTINUE
      IF (AMINHL.LT.0.0001) AMINHL=0.0001
      RETURN
      END
      SUBROUTINE DELIP2 (V, NV, VVP, NAV, DMAX)
      DIMENSION V(5,NV), VVP(NAV)
      CALL KERNZA(0.0, VVP, NAV)
      N11=1
      M2=V(4,1)
      VVP(M2)=VVP(M2)+1.0
      DO 410 N2= 2, NV
      M2=V(4,N2)
      DO 210 N1= 1, N11
      M1=V(4,N1)
      IF (M1.NE.M2) GOTO 210
      IF (ISELFD (V(1,N2), V(1,N1), DMAX) .EQ. 1) THEN
         GOTO 410
      ENDIF
 210  CONTINUE
      N11 = N11+1
      CALL KERNAB (V(1,N2), V(1,N11), 5)
      VVP(M2)=VVP(M2)+1.0
 410  CONTINUE
      NV=N11
      RETURN
      END
      SUBROUTINE FRALIM (F1,F2,IFPL, FRAC)
      PARAMETER (MXPKS=150, NMAXP2=(MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      COMMON /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))
      DIMENSION FPT(10), IPT(10)
      FRAC=0.0
      L=LTHV
      NCO=NCONS
      IF (NCO.LE.1) RETURN
      IFPLL=IFPL
      DF = (F2-F1)/8.0
      NCRH=(NCO*NCO-NCO)/2
      PT = SCPAT * NCELLZ(L)**2
      F=F1-DF
      FPT(1)=0.0
      DO 110 N=2,10
      F=F+DF
 110  FPT(N) = F*PT + PATAD
      CALL KERNZI(0,IPT,10)
      DO 230 J=1,NPCT-1
      DO 220 I=J+1,NPCT
      IJ=IPOIN1(I,J,NPCT)
      DO 210 N=1,10
      IF (P1X2(IJ).LT.FPT(N)) GOTO 220
 210  IPT(N)=IPT(N)+1
 220  CONTINUE
 230  CONTINUE
      IF (IPT(2).LT.NCRH)  RETURN
      FRAC=F1
      IF (IFPLL.GT.IPT(2)) GOTO 400
      F=F1
      DO 310 N=3,10
      IF (IPT(N).LT.IFPLL) THEN
        FRAC=F + (DF*(IPT(N-1)-IFPLL))/(IPT(N-1)-IPT(N))
        IF (FRAC.GT.F2) FRAC=F2
        IF (FRAC.LT.F1) FRAC=F1
        GOTO 400
      ENDIF
      F=F+DF
 310  CONTINUE
      FRAC=F2
 400  CONTINUE
      WRITE (LIS2, FMT='(''       F      FPT      IPT'')')
      F=0.0
      DO 240 N=1,10
      WRITE (LIS2, FMT='(F10.3, F10.3, I10)')  F, FPT(N), IPT(N)
      IF (N.EQ.1) F=F1-DF
 240  F=F+DF
      WRITE (LIS2, FMT='(''       NCRH     IFPL   '')')
      WRITE (LIS2, FMT='(I10, I10)')  NCRH, IFPL
      WRITE (LIS2, FMT='(''       F1       F2      FRAC  '')')
      WRITE (LIS2, FMT='(F10.3, F10.3, F10.3)')  F1, F2, FRAC
      RETURN
      END
      SUBROUTINE VECCHL (X, NX, NPMAX, CONTHL)
      DIMENSION X(5,NX)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4,
     *           MXHH=16, MXPP=128, MXUX=MXPP/4)
      COMMON /MOVECS/ XCELL(3,MXNUP),NPCELL, NAXCEL(MXNUP),
     *                ASVECT(5,MAXASV),NASV
      DIMENSION UX(MXHH+6,MXUX)
      CALL VECCAP (X, NX, ASVECT, NASV, XCELL, NPCELL, NAXCEL)
      DO 110 NV = 1, NASV
      CALL GRDOUT (ASVECT(1,NV), FUNF)
      ASVECT(5,NV) = FUNF-PATAD
 110  CONTINUE
      CONTHL=0.0
      IF (NPCELL.LE.NPMAX)
     * CALL XHELIV(XCELL,NPCELL,ASVECT,NASV,CONTHL, UX, NUX)
      RETURN
      END
      SUBROUTINE DISCAB(XZ,NSTSXZ, NPMAX)
      PARAMETER (MXHEAV=20, MXSTSX=30, IXZ=5*MXHEAV+5, MXINXZ=MXSTSX)
      DIMENSION XZ(IXZ,MXSTSX), INXZ(MXINXZ)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      LOGICAL M1DONE
      DATA FOM1, NH1 /0.0, 0/
      IF (NSTSXZ.LE.0)  RETURN
      IF (NHEAVY.GT.2)  RETURN
      IHL =5*MXHEAV-2
      IFOM=5*MXHEAV+3
      ISW =5*MXHEAV
      M1DONE=.FALSE.
      LTHVV=LTHV
      DO 310 N=1,NSTSXZ
      NH=XZ(5*MXHEAV+1,N)
      ATOMS=0.0
      DO 110  J=1,NH
 110  ATOMS=ATOMS+XZ(5*J-1,N)
      IF (N.EQ.1) THEN
        IF (ATOMS.LT.HEAVYN-0.01) RETURN
        IF (XZ(IHL,1).GT. 0.00005)    RETURN
        LTHV=LTHEAV
        FOM1=XZ(IFOM,1)
        NH1=NH
      ELSE
        FOM = XZ(IFOM,N)
        IF (FOM.GT.0.8*FOM1 .AND. ATOMS.GT.HEAVYN-0.01 .AND.
     *                                 XZ(IHL,N).LT. 0.00005)  THEN
 211      IF (M1DONE) THEN
              M=N
              MH=NH
          ELSE
              M=1
              MH=NH1
              ENDIF
          CALL VECCHL (XZ(1,M), MH, NPMAX, CONTHL)
          IF (M.EQ.1 .AND. CONTHL.LT. 0.00005) GOTO 410
          XZ(IHL,M)=CONTHL
          XZ(IFOM,M)=XZ(IFOM,M)+CONTHL*0.5*XZ(ISW,M)
          M1DONE=.TRUE.
          IF (M.EQ.1) GOTO 211
        ENDIF
      ENDIF
 310  CONTINUE
      NHIGXZ=NSTSXZ
      CALL DETSEQ(INXZ,NHIGXZ, XZ, IXZ, NSTSXZ, IFOM, 0)
      CALL SORTIN(INXZ,MXINXZ, NSTSXZ, XZ, 5*MXHEAV+5, MXSTSX)
 410  LTHV=LTHVV
      RETURN
      END
      SUBROUTINE SYSRCH(X,IP,N,XX,NX)
      PARAMETER (MXHEAV=20)
      DIMENSION X(IP,MXHEAV), XX(4,MXHEAV)
      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 AA(3),A(3), S(3), AVS(3), DMAX(3), X2(3), X1(3,MXHEAV),
     *      KSEQ(MXHEAV), ISEQ(MXHEAV), LA(MXHEAV), RSYMM2(3),TSYMM2(3)
      DATA  DMAX, DMAXA / 0.02, 0.02, 0.02, 0.35/
      NEQMAX=0
      IF (NSYMM.EQ.1 .AND. ICENT.EQ.1) THEN
         DO 105 I=1,N
         CALL KERNAB(X(1,I),XX(1,I),3)
         XX(4,I)=1.0
 105     CONTINUE
         NX=N
         RETURN
      ENDIF
      IF (ICENT.EQ.2) THEN
        DO 106 K=1,3
        RSYMM2(K)=-1.
 106    TSYMM2(K)=0.0
      ELSE
        DO 107 K=1,3
        RSYMM2(K)=IRSYMM(K,K,2)
 107    TSYMM2(K)=TSYMM(K,2)
      ENDIF
      DO 610 I=1,N
      MXNEQ= N-I+1
      IF (MXNEQ.LE.NEQMAX) RETURN
      DO 520 L=1,NLATT
      DO 110 K=1,3
 110  AA(K)=RSYMM2(K) * X(K,I) + TSYMM2(K) + TLATT(K,L)
      DO 510 J=I,N
      DO 210 K=1,3
      A(K)=AA(K)-X(K,J)
      IF (ABS(1.-RSYMM2(K)) .GT. 0.001) THEN
         S(K)=A(K)/(1.-RSYMM2(K))
      ELSE
         IF (ABS(AMOD(A(K),1.0)) .GT. DMAX(K)) GOTO 510
         S(K)=0.0
      ENDIF
 210  CONTINUE
      DO 310 M=I,N
      DO 310 K=1,3
 310  X1(K,M) = X(K,M)+S(K)
      CALL KERNZI (0, KSEQ,N)
      CALL KERNZI (1, LA,N)
      LA(I)=L
      KSEQ(I)=J
      NEQ=1
      KSEQ(J)=I
      IF (J.NE.I) NEQ=NEQ+1
      DO 410 I1=I+1,N
      DO 405 L1=1,NLATT
      IF (KSEQ(I1).NE.0)  GOTO 410
      DO 320 K=1,3
 320  X2(K)=RSYMM2(K) * X1(K,I1) + TSYMM2(K) + TLATT(K,L1)
      DO 400 J1=I1,N
      IF (KSEQ(J1).NE.0)  GOTO 400
      IF (ISELFD(X1(1,J1), X2, DMAXA) .NE. 1)  GOTO 400
      LA(I1)=L1
      KSEQ(J1)=I1
      NEQ=NEQ+1
      KSEQ(I1)=J1
      IF (J1.NE.I1) NEQ=NEQ+1
      GOTO 410
 400  CONTINUE
 405  CONTINUE
 410  CONTINUE
      IF (NEQ.LE.NEQMAX) GOTO 510
        NEQMAX=NEQ
        CALL KERNAI (KSEQ,ISEQ,N)
        NSUM=0
        AVS(1)=0.0
        AVS(2)=0.0
        AVS(3)=0.0
        DO 440 I1=I,N
        IF (KSEQ(I1).EQ.0) GOTO 440
        L1 = LA(I1)
        J1 = KSEQ(I1)
        DO 430 K=1,3
        A(K)=RSYMM2(K)*X1(K,I1)+TSYMM2(K)+TLATT(K,L1) - X1(K,J1)
        IF (ABS(1.-RSYMM2(K)) .GT. 0.001) THEN
            S(K)=A(K)/(1.-RSYMM2(K))
        ELSE
            S(K)=0.0
        ENDIF
        AVS(K)=AVS(K)+S(K)
 430    CONTINUE
        NSUM=NSUM+1
        KSEQ(I1)=0
        KSEQ(J1)=0
 440    CONTINUE
        DO 445 K=1,3
 445    AVS(K)=AVS(K)/NSUM
      NX=0
      DO 480 I1=I,N
      IF (ISEQ(I1).EQ.0) GOTO 480
      NX=NX+1
      J1=ISEQ(I1)
      L1=LA(I1)
      DO 450 K=1,3
      IF (I1.NE.J1) X1(K,I1) = X1(K,I1)+AVS(K)
 450                X1(K,J1) = X1(K,J1)+AVS(K)
      DO 460 K=1,3
      X2(K)=RSYMM2(K) * X1(K,I1) + TSYMM2(K) + TLATT(K,L1)
      X2(K)=X2(K)-NINT(X2(K)-X1(K,J1))
      X2(K)=X2(K)+X1(K,J1)
      X2(K)=X2(K)/2.
      XX(K,NX)=X2(K)
 460  CONTINUE
      XX(4,NX)=1.0
      IF (I1.EQ.J1) XX(4,NX)=0.5
      ISEQ(I1)=0
      ISEQ(J1)=0
 480  CONTINUE
 510  CONTINUE
 520  CONTINUE
 610  CONTINUE
      RETURN
      END
      SUBROUTINE SYMPRI
      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 /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3)
      PARAMETER (NUMTAB =300000)
      COMMON / / ITAB(NUMTAB)
      INTEGER * 2 ITAB
      DIMENSION FLINE(100)
      WRITE (LIS2, FMT='(''NUM , NUMS'', 3I5,3X, 3I5/)') NUM, NUMS
      DO 333 JZ = ISS(3), NUMS(3)
      WRITE (LIS2, FMT='(/''JZ='', I5, '' ---------------------''/)') JZ
      DO 222 JY = ISS(2), NUMS(2)
      WRITE (LIS2, FMT='(''JZ, JY, JX = '',3I5,'' ....'')') JZ,JY,ISS(1)
      L = 0
      DO 111 JX = ISS(1), NUMS(1)
         IADR = NUSXY * JZ + NUMS(1) * JY + JX - NUMSC
         IJX = ITAB(IADR)
         FUNF = FLOAT( IJX ) / 99.
      L = L + 1
      FLINE(L) = FUNF
 111  CONTINUE
      WRITE (LIS2, FMT='( 10F7.1)') (FLINE(LL), LL=1,L)
 222  CONTINUE
 333  CONTINUE
      RETURN
      END
