C        COPYRIGHT 1985 UNIVERSITY OF GLASGOW                           0001.000
C        ELECTRON DENSITY PEAK LOCATION AND INTERPRETATION              0002.000
C        PROGRAM SEARCH                                                 0003.000
C        GX PACKAGE  APRIL 1985   K.W. MUIR                             0004.000
C                                                                       0005.000
      PROGRAM SRCKWM                                                    0006.000
C     PART 1.                                                           0007.000
C     ------------------------------------------------------------------0008.000
      CHARACTER COMPID(72)                                              0009.000
      CHARACTER*8 LABEL(200),FTYPE(13)                                  0010.000
      INTEGER CN(200),CONTNT(13)                                        0011.000
      COMMON/MODELC/COMPID,LABEL,FTYPE                                  0012.000
      COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),              0013.000
     1CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),           0014.000
     2WAVEL,SELL(6),ECELL(6),R(24,3,4),TEE(3,4),ICENT,                  0015.000
     3SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                                0016.000
      COMMON ISYM(100),INBOND(1000),IFRAG(200),ICON(200),               0017.000
     1 IBOND(2000),JFRAG(200),JCON(200),JBOND(2000),IUSE(200),          0018.000
     2 IONA(6,200),IONP(6,200),MO(200),MU(200),NO(200),NU(200),         0019.000
     3 KEYST(200),LW(200),LR(200),LX(200),JK(200),IK(200),KEY(200),     0020.000
     4 IPL(200),CAN(200),CON(200),LL(200),IA(6,200),LS(200),DUM(14400)  0021.000
      CHARACTER*4 ITLE(18)                                              0022.000
      CHARACTER*8 XL(200),YL(400)                                       0023.000
      COMMON /TITLE/ ITLE                                               0024.000
      COMMON /ATOMS/ X(4,200),Y(4,400)                                  0025.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     0026.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          0027.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          0028.000
      COMMON /MISC/ CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM                0029.000
      COMMON /CENT/ TL(3,4),TS(3,24),FS(3,3,24),MLAT,NEQV               0030.000
      COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN      0031.000
      COMMON /NAMES/ XL,YL                                              0032.000
      CHARACTER  LTC(7),JOV(67),SWCH(3,2)                               0033.000
      DIMENSION  NSTORE(25100), XA(3,200), XB(4,200)                    0034.000
      DIMENSION IS(2,3,24), NAFRG(5), KMATCH(20)                        0035.000
      EQUIVALENCE (ISYM(1),NSTORE(1)), (IONA(1,1),XA(1,1)),             0036.000
     1  (IONP(1,1),XB(1,1)), (ISYM(1),IS(1,1,1))                        0037.000
      DATA LTC/1HP,1HA,1HB,1HC,1HI,1HF,1HR/                             0038.000
      DATA SWCH/'X','Y','Z','U','V','W'/                                0039.000
C     PRELIMINARY SECTION - SET UP ALL PROGRAM PARAMETERS               0040.000
C     LC = INSTRUCTION INPUT DEVICE                                     0041.000
      LC = 5                                                            0042.000
C     LP = PROMPT OUTPUT DEVICE                                         0043.000
      LP = 6                                                            0044.000
C     LT = LINE PRINTER                                                 0045.000
      LT = 7                                                            0046.000
C     LIN = INPUT FILE FROM FFT                                         0047.000
      LIN = 13                                                          0048.000
C     NOUT = OUTPUT FILE TO SFCALC                                      0049.000
      NOUT = 14                                                         0050.000
C     LMD = INPUT MODEL FILE                                            0051.000
      LMD = 1                                                           0052.000
C     KUSER1 = MAXIMUM NUMBER OF PEAKS TO BE FOUND + 20, ALSO MAXIMUM   0053.000
C     NUMBER OF PEAKS FOR INTERPRETATION AND DIMENSION OF SEVERAL ARRAYS0054.000
      KUSER1 = 220                                                      0055.000
C     KUSER2 = SIZE OF ARRAY NSTORE FOR STORING 3 SECTIONS OF E-MAP     0056.000
      KUSER2 = 25100                                                    0057.000
C     STEREOCHEMICAL CRITERIA - MAX AND MIN DISTANCES AND ANGLES        0058.000
      ANGMIN = 85.0                                                     0059.000
      ANGMAX = 145.0                                                    0060.000
      DMIN = 1.10                                                       0061.000
      DMAX = 1.95                                                       0062.000
C     ALL INTERPEAK DISTANCES LESS THAN DMUT ARE PRINTED OUT            0063.000
      DMUT = 2.40                                                       0064.000
C     IF 2 E-MAP PEAKS ARE CLOSER THAN DM THE SMALLER IS ELIMINATED     0065.000
      DM=0.85                                                           0066.000
C     IF TWO CLUSTERS ARE CLOSER TOGETHER THAN DFRG INCLUDE MORE PEAKS  0067.000
      DFRG = 2.80                                                       0068.000
C     LN = NUMBER OF LINES PER INCH ON LINEPRINTER - USED IN PICTUR     0069.000
      LN = 6                                                            0070.000
C     IWT = RELATIVE WEIGHT OF IDENTIFIED ATOMS TO UNIDENTIFIED         0071.000
      IWT = 2                                                           0072.000
C     INPUT DATA FROM FFT FILE                                          0073.000
      REWIND LIN                                                        0074.000
      READ (LIN)ITLE,NMAP,FACTOR,NUMSET,CELL,NEQV,NCENT,LATT,NATM,TS,IS 0075.000
      IF(NUMSET.LT.0) STOP                                              0076.000
C     INPUT DATA FROM CARDS                                             0077.000
      CALL TRANSL(NPC,NPROJ,MFRN,NA,NOJOIN,NHOLES,NEUTRON,NPATT,KUSER1) 0078.000
      IF (NPC .LT. 0) GO TO 760                                         0079.000
      NAT = NPC                                                         0080.000
      NPIC = NPC                                                        0081.000
      GO TO 800                                                         0082.000
  760 NAT = MIN0((11*NATM+13)/9, KUSER1-20)                             0083.000
      NPIC = MIN0((3*NATM+1)/2, KUSER1-20)                              0084.000
  800 WRITE (LT,880) CELL,LTC(LATT)                                     0085.000
  880 FORMAT(/21H UNIT CELL PARAMETERS,14X,4HA  =,F8.3/35X,4HB  =,F8.3/ 0086.000
     1  35X,4HC  =,F8.3/31X,8HALPHA  =,F8.2/32X,7HBETA  =,F8.2/31X,     0087.000
     2  8HGAMMA  =,F8.2/// 5X,65HCENTROSYMMETRIC SPACE GROUP SYMMETRY OP0088.000
     3ERATORS WITH LATTICE TYPE ,A1)                                    0089.000
      IF (NCENT.EQ.0) WRITE (LT,882)                                    0090.000
  882 FORMAT (1H+, 1X,3HNON)                                            0091.000
      WRITE (LT,883)                                                    0092.000
  883 FORMAT (/)                                                        0093.000
C     HALVE Y-AXIS BY C.OF.S. OR LATTICE TYPE IF POSSIBLE               0094.000
      IHALF=0                                                           0095.000
      IF (NCENT.EQ.1) IHALF=-1                                          0096.000
      IF (IHALF.NE.0) GOTO 888                                          0097.000
      GOTO (888,886,888,886,886,886,888), LATT                          0098.000
  886 IHALF = 1                                                         0099.000
  888 CALL CENTRE (1,1)                                                 0100.000
C     EXPAND TO FULL SPACE GROUP SYMMETRY                               0101.000
C     PUT CENTRING TRANSLATIONS IN TL(I,J)                              0102.000
      GO TO (940,890,890,890,890,910,920),LATT                          0103.000
  890 CALL CENTRE(2,LATT)                                               0104.000
      GO TO 940                                                         0105.000
  910 CALL CENTRE(2,2)                                                  0106.000
      CALL CENTRE(3,3)                                                  0107.000
      CALL CENTRE(4,4)                                                  0108.000
      GO TO 940                                                         0109.000
  920 CALL CENTRE(2,6)                                                  0110.000
      CALL CENTRE(3,7)                                                  0111.000
  940 DO 1000 I=1,NEQV                                                  0112.000
      DO 970 J=1,3                                                      0113.000
      DO 950 K=1,3                                                      0114.000
      FS(K,J,I)=0.0                                                     0115.000
  950 CONTINUE                                                          0116.000
      DO 960 K=1,2                                                      0117.000
      M=IABS(IS(K,J,I))                                                 0118.000
      IF(M.GT.0) FS(M,J,I)=FLOAT(ISIGN(1,IS(K,J,I)))                    0119.000
  960 CONTINUE                                                          0120.000
  970 CONTINUE                                                          0121.000
      IF (I.EQ.1.OR.IHALF.NE.0) GOTO 1000                               0122.000
C     HALVE Y-AXIS BY SYMMETRY OP. IF POSSIBLE                          0123.000
      DO 980 J=1,3                                                      0124.000
      IF (IABS(IS(1,J,I)).NE.J.OR.IS(2,J,I).NE.0) GOTO 1000             0125.000
  980 CONTINUE                                                          0126.000
      IF(IS(1,2,I).EQ.(-2).AND.ABS(TS(2,I)).LT.1E-6) IHALF= -1          0127.000
      IF(IS(1,2,I).EQ.2.AND.ABS(TS(2,I)-0.5).LT.1E-6) IHALF=1           0128.000
 1000 CONTINUE                                                          0129.000
      DO 1003 I=1,NEQV                                                  0130.000
      DO 1001 J=1,67                                                    0131.000
 1001 JOV(J)=' '                                                        0132.000
      DO 1002 J=1,3                                                     0133.000
      K=1+10*(J-1)                                                      0134.000
      CALL CRDOUT(JOV,K,FS(1,J,I),FS(2,J,I),FS(3,J,I),TS(J,I))          0135.000
 1002 CONTINUE                                                          0136.000
      IF(NPATT.NE.1)GOTO 1005                                           0137.000
      DO 1004 J=1,K                                                     0138.000
      DO 1006 L=1,3                                                     0139.000
 1006 IF(JOV(J).EQ.SWCH(L,1))JOV(J)=SWCH(L,2)                           0140.000
 1004 CONTINUE                                                          0141.000
 1005 WRITE(LT,1010)I,(JOV(J),J=1,K)                                    0142.000
 1003 CONTINUE                                                          0143.000
 1010 FORMAT(5X,I3,'.',5X,30A1)                                         0144.000
      NSYM=NEQV*(NCENT+1)*MLAT                                          0145.000
C     SET UP CONSTANTS                                                  0146.000
      DTOR = 4.0 * ATAN(1.0) / 180.0                                    0147.000
      ANGMIN=COS(DTOR*ANGMIN)                                           0148.000
      ANGMAX=COS(DTOR*ANGMAX)                                           0149.000
      DMIN=DMIN*DMIN                                                    0150.000
      DMAX=DMAX*DMAX                                                    0151.000
      DMUT = DMUT * DMUT                                                0152.000
      CA=COS(DTOR*CELL(4))                                              0153.000
      CB=COS(DTOR*CELL(5))                                              0154.000
      CC=COS(DTOR*CELL(6))                                              0155.000
      V=CELL(1)*CELL(2)*CELL(3)*SQRT(1.0-CA*CA-CB*CB-CC*CC+2.0*CA*CB*CC)0156.000
      DXMAX(1)=DM*CELL(2)*CELL(3)*SIN(DTOR*CELL(4))/V                   0157.000
      DXMAX(2)=DM*CELL(3)*CELL(1)*SIN(DTOR*CELL(5))/V                   0158.000
      DXMAX(3)=DM*CELL(1)*CELL(2)*SIN(DTOR*CELL(6))/V                   0159.000
      DM=DM*DM                                                          0160.000
      ALN=LN                                                            0161.000
C     SET UP MATRIX TO CALCULATE DISTANCES AND ANGLES                   0162.000
      DO 1020 I=4,6                                                     0163.000
      J=8/I                                                             0164.000
      K=15/I                                                            0165.000
      T(J,K)=COS(DTOR*CELL(I))                                          0166.000
      T(K,J)=T(J,K)                                                     0167.000
 1020 CONTINUE                                                          0168.000
      DO 1060 I=1,3                                                     0169.000
      T(I,I)=1.0                                                        0170.000
      DO 1040 J=1,3                                                     0171.000
      T(I,J)=T(I,J)*CELL(I)*CELL(J)                                     0172.000
 1040 CONTINUE                                                          0173.000
 1060 CONTINUE                                                          0174.000
      IF (IHALF.NE.0) WRITE (LT,1080)                                   0175.000
 1080 FORMAT (/   77H ** SINCE SPACE GROUP SYMMETRY PERMITS, ONLY HALF T0176.000
     1HE MAP WILL BE SEARCHED **)                                       0177.000
C     SEARCH MAP FOR PEAK POSITIONS AND RECORD PEAK HEIGHTS             0178.000
      IF(NMAP.LE.4)FACTOR=1.0/(FACTOR*V)                                0179.000
      IF(NPIC.EQ.0)GOTO 1100                                            0180.000
      CALL PKSRCH(NSTORE,KUSER1,KUSER2,IHALF)                           0181.000
      IF (NPIC.LT.NAT) NAT=NPIC                                         0182.000
      CALL SORT(X,KUSER1,NPIC,4)                                        0183.000
      CALL LBL(XL,NPIC,0)                                               0184.000
      CALL PATTERSN(NPATT,T,X,XL)                                       0185.000
      DO 1082 I=1,NPIC                                                  0186.000
 1082 X(4,I)=X(4,I)*FACTOR                                              0187.000
 1100 CALL GETHA(NHOLES,NEUTRON,T,NSTORE,KUSER1,KUSER2,IHALF,NA)        0188.000
C     ADJUST VALUES OF DXMAX FOR BOND LENGTH CALCULATION                0189.000
 1140 FACT=DFRG/SQRT(DM)                                                0190.000
      DO 1160 I=1,3                                                     0191.000
      DXMAX(I)=FACT*DXMAX(I)                                            0192.000
 1160 CONTINUE                                                          0193.000
      DFRG = DFRG * DFRG                                                0194.000
C     INPUT USERS OWN MOLECULES FOR COMPARISON WITH THOSE               0195.000
C     FRAGMENTS FOUND IN THE E-MAP                                      0196.000
      IF (MFRN.GT.0) CALL INSEQ(NSEQ,NAFRG)                             0197.000
C     IDENTIFY SEPARATE CLUSTERS AND CALCULATE BOND LENGTHS AND ANGLES  0198.000
      NN=0                                                              0199.000
      NOFRAG=0                                                          0200.000
      DO 1200 LOOP=1,KUSER1                                             0201.000
      IFRAG(LOOP)=0                                                     0202.000
      IUSE(LOOP)=0                                                      0203.000
      KEYST(LOOP)=0                                                     0204.000
 1200 CONTINUE                                                          0205.000
      IF(NOJOIN.EQ.0) CALL CLSTRS(0)                                    0206.000
      IF(NOJOIN.EQ.0.AND.MCON.GT.0) GO TO 1230                          0207.000
      WRITE(LT,1220)                                                    0208.000
 1220 FORMAT(//1H , 4X,34HNOJOIN SPECIFIED OR NO BONDS FOUND//)         0209.000
      GOTO 1650                                                         0210.000
C     FOR EACH CLUSTER OF MORE THAN 4 PEAKS WHICH HAS BEEN FOUND,       0211.000
C     PLOT THE PEAKS IN PROJECTION, INTERPRET THEM IN TERMS OF          0212.000
C     BONDED PEAKS AND COMPARE THEM WITH THOSE ATOMS INPUT BY THE USER  0213.000
 1230 DO 1600 NOFRG=1,NFRAG                                             0214.000
      NOFRAG = NOFRG                                                    0215.000
      IF (KFRAG(NOFRAG) .LE. 4) GO TO 1600                              0216.000
      IW = 0                                                            0217.000
      NINT=1                                                            0218.000
      FOM=0                                                             0219.000
 1240 ISTART=0                                                          0220.000
C     INTERPRETATION OF PEAKS BEGINS WITH PEAK ISTART                   0221.000
C     INTERPRET CLUSTER IN TERMS OF BONDED PEAKS AND ELIMINATE          0222.000
C     PEAKS WHICH DO NOT FULFIL DISTANCE AND ANGLE CRITERIA             0223.000
 1300 CALL INTERP(ISTART,KUSER1,IW,FOMF)                                0224.000
      IF(ISTART.EQ.0)GO TO 1600                                         0225.000
C     ACCEPT INTERPRETATION IF FRAGMENT 1 CONTAINS MORE THAN 4 PEAKS.   0226.000
      IF (ISTART .EQ. 1) GO TO 1400                                     0227.000
      IF (LFRAG(1) .LT. 5) GO TO 1240                                   0228.000
C     IF MORE THAN 1 FRAGMENT,SHUFFLE THEM AROUND                       0229.000
 1400 IF (MFRAG.LE.1.OR.NN.EQ.0) GOTO 1450                              0230.000
      CALL SHFFLE(MAXFRG)                                               0231.000
      IF (MAXFRG.EQ.0) GOTO 1450                                        0232.000
C     REDO CLUSTER                                                      0233.000
C     INITIALISE ARRAYS FOR CLSTRS                                      0234.000
 1410 MC=0                                                              0235.000
      M=1                                                               0236.000
      DO 1418 I=1,NAT                                                   0237.000
      IF(IFRAG(I).NE.0.AND.IFRAG(I).NE.-1000) GO TO 1412                0238.000
      IUSE(I)=0                                                         0239.000
      LW(I)=0                                                           0240.000
      LR(I)=0                                                           0241.000
      GO TO 1418                                                        0242.000
 1412 IF(M.GT.MCON) GO TO 1418                                          0243.000
      II=IBOND(M)/4194304                                               0244.000
      IF(II-I) 1416,1414,1418                                           0245.000
 1414 MC=MC+1                                                           0246.000
      IBOND(MC)=IBOND(M)                                                0247.000
 1416 M=M+1                                                             0248.000
      GO TO 1412                                                        0249.000
 1418 CONTINUE                                                          0250.000
      MCON=MC                                                           0251.000
      CALL CLSTRS(1)                                                    0252.000
C     REINTERPRET CLUSTER                                               0253.000
      FOM=0.0                                                           0254.000
 1420 CALL INTERP(ISTART,KUSER1,IW,FOMF)                                0255.000
C     ACCEPT INTERPRETATION IF FRAGMENT 1 CONTAINS MORE                 0256.000
C     THAN 4 PEAKS AND MORE THAN ONE NEW PEAK IS INCLUDED IN THE        0257.000
C     INTERPRETATION AND THE SIZE OF THE FRAGMENTS IS SIGNIFICANT.      0258.000
      IF (ISTART.EQ.0) GOTO 1600                                        0259.000
      IF (ISTART.EQ.1) GOTO 1450                                        0260.000
      IF (LFRAG(1).GE.5.AND.FOMF*FLOAT(IWT).GT.FOM) GOTO 1450           0261.000
      ISTART=0                                                          0262.000
      GOTO 1420                                                         0263.000
C     PLOT THIS CLUSTER IN THE BEST PROJECTION(S)                       0264.000
 1450 IF (NPROJ.GE.0.AND.NINT.EQ.1) CALL PICTUR (NPROJ,XA,XB,KUSER1)    0265.000
C     COMPARE THE FRAGMENTS FOUND WITH THOSE INPUT BY THE USER          0266.000
      IF (MFRN.GT.0) CALL COMPAR(NSEQ,NAFRG,KMATCH)                     0267.000
C     OUTPUT BONDING PATTERN AND IDENTIFIED ATOMS                       0268.000
      CALL OUTERP(ISTART,KMATCH,FOMF)                                   0269.000
      IF(ISTART.GT.0) NINT=NINT+1                                       0270.000
      IF (NINT.GT.3) GOTO 1600                                          0271.000
      ISTART=0                                                          0272.000
      GOTO 1420                                                         0273.000
 1600 CONTINUE                                                          0274.000
C     OUTPUT INTERPEAK DISTANCES, PEAK HEIGHTS, AND BOND ANGLES         0275.000
      CALL BONGLE                                                       0276.000
C     CREATE PEAK FILE FOR RECYCLING. IUSE(I).LT.0 IF PEAK I IS GOOD    0277.000
 1650 DO 1800 I=1,NAT                                                   0278.000
      WRITE(NOUT,1700)XL(I),(X(J,I),J=1,3)                              0279.000
 1700 FORMAT(' ATOM ',A8,3F10.5)                                        0280.000
 1800 CONTINUE                                                          0281.000
      STOP                                                              0282.000
      END                                                               0283.000
C     ------------------------------------------------------------------0284.000
C     FIND POSITIONS OF PEAKS BY FITTING QUADRATIC FUNCTION TO 19 POINTS0285.000
      SUBROUTINE PKSRCH(NR3D,KUSER1,KUSER2,IHALF)                       0286.000
      COMMON /ATOMS/ X(4,200),Y(4,400)                                  0287.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     0288.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          0289.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          0290.000
      COMMON /MISC/ CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM                0291.000
      DIMENSION  NR3D(KUSER2), XS(3), X1(3), IDIFF(19), B(19)           0292.000
C     INPUT DIMENSIONS OF E-MAP AND CHECK ARRAY SIZE                    0293.000
      MINUS=ISIGN(1,NPIC)                                               0294.000
      NPIC=IABS(NPIC)                                                   0295.000
      REWIND(LIN)                                                       0296.000
      READ(LIN)                                                         0297.000
      READ (LIN) NNX,NNZ,NNY                                            0298.000
C     HALVE Y-AXIS IF POSSIBLE                                          0299.000
      NNYOLD=NNY                                                        0300.000
      IF (IHALF.NE.0) NNY=NNY-NNY/2                                     0301.000
      NNXP2 = NNX + 2                                                   0302.000
      NXZ = NNXP2 * (NNZ + 2)                                           0303.000
      NXZ3 = 3 * NXZ                                                    0304.000
      IF (NXZ3 .LE. KUSER2) GO TO 1020                                  0305.000
      WRITE (LT,940) KUSER2, NXZ3                                       0306.000
  940 FORMAT(//33H NOT ENOUGH ROOM IN ARRAY NSTORE.,10X,18HSPACE AVAILAB0307.000
     1LE  =,I7,10X,17HSPACE REQUIRED  =,I7)                             0308.000
      STOP                                                              0309.000
C     INITIALISE CONSTANTS                                              0310.000
 1020 DX = 1.0 / FLOAT(NNX)                                             0311.000
      DY = 1.0/FLOAT(NNYOLD)                                            0312.000
      DZ = 1.0/FLOAT(NNZ)                                               0313.000
      LEVEL = 0                                                         0314.000
      LIMIT = MIN0(KUSER1, 2*NAT)                                       0315.000
C     SET UP TABLE OF OFFSETS TO LOOK UP 19 POINTS IN E-MAP             0316.000
 1100 IDIFF(1) = -NXZ - 1                                               0317.000
      IDIFF(2) = -NXZ - NNXP2                                           0318.000
      IDIFF(3) = -NXZ                                                   0319.000
      IDIFF(4) = -NXZ + NNXP2                                           0320.000
      IDIFF(5) = -NXZ + 1                                               0321.000
      IDIFF(6) = -NNXP2 - 1                                             0322.000
      IDIFF(7) = -1                                                     0323.000
      IDIFF(8) = NNXP2 - 1                                              0324.000
      IDIFF(9) = -NNXP2                                                 0325.000
      IDIFF(10) = 0                                                     0326.000
      DO 1120 I=1,9                                                     0327.000
      J=20-I                                                            0328.000
      IDIFF(J) = -IDIFF(I)                                              0329.000
 1120 CONTINUE                                                          0330.000
C     INITIALISE VARIABLES                                              0331.000
      NO = 0                                                            0332.000
      IY = -1                                                           0333.000
      NY = 0                                                            0334.000
C     IF (LEVEL .EQ. 0) GO TO 1300                                      0335.000
C     REPOSITION FILE TO READ IN FIRST TWO SECTIONS AGAIN               0336.000
 1200 REWIND LIN                                                        0337.000
      READ(LIN)                                                         0338.000
      READ(LIN)                                                         0339.000
      IF (IY+2.EQ.NNYOLD) GOTO 1400                                     0340.000
C     READ IN FIRST SECTION (END OF LAST UNIT CELL)                     0341.000
 1300 MAX=NXZ                                                           0342.000
      ISKIP=NNYOLD-1                                                    0343.000
      DO 1305 I=1,ISKIP                                                 0344.000
      READ (LIN)                                                        0345.000
 1305 CONTINUE                                                          0346.000
 1310 CALL RDSECT(MINUS,NR3D,MAX,NNXP2,NNZ,NXZ3,KUSER2)                 0347.000
      REWIND LIN                                                        0348.000
C     READ SECOND SECTION (START OF UNIT CELL)                          0349.000
      READ(LIN)                                                         0350.000
      READ(LIN)                                                         0351.000
      CALL RDSECT(MINUS,NR3D,MAX,NNXP2,NNZ,NXZ3,KUSER2)                 0352.000
C     READ IN THE NEXT SECTION                                          0353.000
 1400 MX = MAX - NXZ + NNX + 1                                          0354.000
      CALL RDSECT(MINUS,NR3D,MAX,NNXP2,NNZ,NXZ3,KUSER2)                 0355.000
      IY = IY + 1                                                       0356.000
      NY = MOD(NY+2, 3) - 1                                             0357.000
      KK = NXZ3                                                         0358.000
      IF (NY) 1440,1460,1500                                            0359.000
 1440 KK = -NXZ3                                                        0360.000
 1460 DO 1480 I=1,5                                                     0361.000
      IDIFF(I) = IDIFF(I) - KK                                          0362.000
 1480 CONTINUE                                                          0363.000
      IF (NY .EQ. 0) GO TO 1540                                         0364.000
 1500 DO 1520 I=15,19                                                   0365.000
      IDIFF(I) = IDIFF(I) - KK                                          0366.000
 1520 CONTINUE                                                          0367.000
C     SEARCH ONE SECTION OF THE E-MAP                                   0368.000
 1540 DO 2000 IZ=1,NNZ                                                  0369.000
      MN = MX + 3                                                       0370.000
      MX = MX + NNXP2                                                   0371.000
      DO 1980 IX=MN,MX                                                  0372.000
      IF (NR3D(IX) .LT. LEVEL) GO TO 1980                               0373.000
C     LOCATE GRID POINT WITH MAXIMUM DENSITY                            0374.000
      DO 1560 I=1,9                                                     0375.000
      J = IDIFF(I) + IX                                                 0376.000
      IF (NR3D(IX) .LE. NR3D(J)) GO TO 1980                             0377.000
 1560 CONTINUE                                                          0378.000
      DO 1580 I=11,19                                                   0379.000
      J = IDIFF(I) + IX                                                 0380.000
      IF (NR3D(IX) .LT. NR3D(J)) GO TO 1980                             0381.000
 1580 CONTINUE                                                          0382.000
C     FIT QUADRATIC FUNCTION TO 19 POINTS                               0383.000
C     DENS = A + C*X + D*Y + E*Z - 0.5*F*(X*X + Y*Y + Z*Z)              0384.000
      DO 1600 I=1,19                                                    0385.000
      J = IDIFF(I) + IX                                                 0386.000
      B(I) = NR3D(J)                                                    0387.000
 1600 CONTINUE                                                          0388.000
      B1 = B(3) + B(7) + B(9) + B(11) + B(13) + B(17)                   0389.000
      B2 = B(1) + B(2) + B(4) + B(5) + B(6) + B(8) + B(12) + B(14) +    0390.000
     1  B(15) + B(16) + B(18) + B(19)                                   0391.000
      F = (30.0 * B(10) + 11.0 * B1 - 8.0 * B2) / 63.0                  0392.000
      C = (B(5)+B(12)+B(13)+B(14)+B(19)-B(1)-B(6)-B(7)-B(8)-B(15))/10.0 0393.000
      DELTAX = C / F                                                    0394.000
      IF (ABS(DELTAX) .GT. 1.0) GO TO 1620                              0395.000
      D = (B(15)+B(16)+B(17)+B(18)+B(19)-B(1)-B(2)-B(3)-B(4)-B(5))/10.0 0396.000
      DELTAY = D / F                                                    0397.000
      IF (ABS(DELTAY) .GT. 1.0) GO TO 1620                              0398.000
      E = (B(4)+B(8)+B(11)+B(14)+B(18)-B(2)-B(6)-B(9)-B(12)-B(16))/10.0 0399.000
      DELTAZ = E / F                                                    0400.000
      IF (ABS(DELTAZ) .LE. 1.0) GO TO 1640                              0401.000
 1620 DELTAX = 0.0                                                      0402.000
      DELTAY = 0.0                                                      0403.000
      DELTAZ = 0.0                                                      0404.000
 1640 XX = (FLOAT(IX-MN+1) + DELTAX) * DX                               0405.000
      YY = (FLOAT(IY) + DELTAY) * DY                                    0406.000
      ZZ = (FLOAT(IZ) + DELTAZ) * DZ                                    0407.000
C     PEAK HEIGHT INTERPOLATION - NOT SUITABLE IF PEAK SHAPE IS POOR    0408.000
C     A = (9.0 * B(10) + 4.0 * B1 - B2) / 21.0                          0409.000
C     B(10) = AMAX1(A+0.5*(C*DELTAX+D*DELTAY+E*DELTAZ), B(10))          0410.000
      NOP1 = NO+1                                                       0411.000
      X(1,NOP1) = XX                                                    0412.000
      X(2,NOP1) = YY                                                    0413.000
      X(3,NOP1) = ZZ                                                    0414.000
      X(4,NOP1) = B(10)                                                 0415.000
      IF (NO .EQ. 0) GO TO 1820                                         0416.000
      IR=0                                                              0417.000
C     IF TWO PEAKS ARE CLOSER THAN DM ANGSTROMS ELIMINATE THE SMALLER   0418.000
      DO 1800 K=1,NSYM                                                  0419.000
      CALL OPER(K,XS,XX,YY,ZZ)                                          0420.000
      DO 1780 I=1,NO                                                    0421.000
      DO 1720 L=1,3                                                     0422.000
      X1(L) = X(L,I) - XS(L)                                            0423.000
 1680 IF (ABS(X1(L)) .LE. 0.5) GO TO 1700                               0424.000
      X1(L) = X1(L) - SIGN(1.0, X1(L))                                  0425.000
      GO TO 1680                                                        0426.000
 1700 IF (ABS(X1(L)) .GT. DXMAX(L)) GO TO 1780                          0427.000
 1720 CONTINUE                                                          0428.000
      IF (QUAD(X1,X1,T) .GT. DM) GO TO 1780                             0429.000
      IF(IR.GT.0) X(4,IR)=0.0                                           0430.000
      IR=0                                                              0431.000
      IF (B(10) .LE. X(4,I)) GO TO 1980                                 0432.000
      X(1,I) = XX                                                       0433.000
      X(2,I) = YY                                                       0434.000
      X(3,I) = ZZ                                                       0435.000
      X(4,I) = B(10)                                                    0436.000
      IR=I                                                              0437.000
 1780 CONTINUE                                                          0438.000
 1800 CONTINUE                                                          0439.000
      IF(IR.GT.0) GO TO 1980                                            0440.000
 1820 NO = NOP1                                                         0441.000
      IF (NO .LT. LIMIT) GO TO 1980                                     0442.000
      CALL SORT(X,KUSER1,NO,4)                                          0443.000
      NO = NPIC                                                         0444.000
      LEVEL = X(4,NPIC) + 0.5                                           0445.000
 1980 CONTINUE                                                          0446.000
 2000 CONTINUE                                                          0447.000
      IF (IY .GE. NNY) GO TO 2100                                       0448.000
      IF (IY - NNYOLD + 2) 1400,1200,1400                               0449.000
C     SORT PEAKS IN ORDER OF PEAK HEIGHT                                0450.000
 2100 CALL SORT(X,KUSER1,NO,4)                                          0451.000
      NNN = MIN0(NO,NPIC)                                               0452.000
      IF (NNN .EQ. NPIC) RETURN                                         0453.000
C     INSUFFICIENT PEAKS FOUND - LOWER SCAN LEVEL AND TRY AGAIN         0454.000
      LEVEL = LEVEL - 100                                               0455.000
      IF(LEVEL.GE.(-200)) GO TO 1100                                    0456.000
      NPIC=NO                                                           0457.000
      RETURN                                                            0458.000
      END                                                               0459.000
C     ------------------------------------------------------------------0460.000
C     INPUT FRAGMENTS FOR COMPARISON WITH THOSE FOUND IN MAP            0461.000
      SUBROUTINE INSEQ(NSEQ,NAFRG)                                      0462.000
      COMMON ISYM(100),INBOND(1000),IFRAG(200),ICON(200),               0463.000
     1 IBOND(2000),JFRAG(200),JCON(200),JBOND(2000),IUSE(200),          0464.000
     2 IONA(6,200),IONP(6,200),MO(200),MU(200),NO(200),NU(200),         0465.000
     3 KEYST(200),LW(200),LR(200),LX(200),JK(200),IK(200),KEY(200),     0466.000
     4 IPL(200),CAN(200),CON(200),LL(200),IA(6,200),LS(200),DUM(14400)  0467.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     0468.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          0469.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          0470.000
      DIMENSION ICH(12),LINE(72),LINX(60),IB(6),NAFRG(5)                0471.000
      DATA ICH/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H ,1H//         0472.000
      NSEQ=0                                                            0473.000
      WRITE(LT,50)                                                      0474.000
   50 FORMAT(1H0,10X,23HMOLECULES INPUT BY USER)                        0475.000
      DO 90 J=1,200                                                     0476.000
      DO 80 K=1,6                                                       0477.000
      IONP(K,J)=0                                                       0478.000
   80 CONTINUE                                                          0479.000
   90 CONTINUE                                                          0480.000
      NAFRG(1)=0                                                        0481.000
      NADR=0                                                            0482.000
      NUM=0                                                             0483.000
      ISL=0                                                             0484.000
      IP=0                                                              0485.000
      WRITE(LP,2000)                                                    0486.000
 2000 FORMAT('  TYPE IN CONNECTIVITY DATA ')                            0487.000
  120 WRITE(LP,1001)                                                    0488.000
 1001 FORMAT('  TYPE IN A LINE OF BOND SEQUENCES ')                     0489.000
  121 READ(LC,130,END=122)LINE                                          0490.000
  130 FORMAT(72A1)                                                      0491.000
      DO 1000 I=1,80                                                    0492.000
      DO 150 J=1,12                                                     0493.000
      IF(ICH(J).EQ.LINE(I)) GO TO 160                                   0494.000
  150 CONTINUE                                                          0495.000
      WRITE(LP,1002)LINE                                                0496.000
 1002 FORMAT('  >>>>>UNRECOGNISED CHARACTER IN LINE ',/                 0497.000
     11H ,72A1,/'  PLEASE RETYPE THE LINE')                             0498.000
      GOTO 121                                                          0499.000
  122 WRITE(LT,1003)                                                    0500.000
 1003 FORMAT(' EOF ON INPUT - ERROR STOP IN READING BOND SEQUENCES')    0501.000
      STOP                                                              0502.000
  160 IF(J.EQ.11) GO TO 170                                             0503.000
      IF(J.EQ.12) GO TO 180                                             0504.000
      NUM=10*NUM+J-1                                                    0505.000
      GO TO 1000                                                        0506.000
  170 IF(NUM.EQ.0) GO TO 1000                                           0507.000
      IF(IP.EQ.0) IAT=NUM                                               0508.000
      IF(IP.GT.0) IB(IP)=NUM                                            0509.000
      ISL=0                                                             0510.000
      NUM=0                                                             0511.000
      IP=IP+1                                                           0512.000
      GO TO 1000                                                        0513.000
  180 IF(IP.EQ.0) GO TO 400                                             0514.000
      IF(NUM.EQ.0) GO TO 190                                            0515.000
      IB(IP)=NUM                                                        0516.000
      IP=IP+1                                                           0517.000
      NUM=0                                                             0518.000
  190 IP=IP-1                                                           0519.000
      IF(IP.EQ.0) GO TO 1000                                            0520.000
      DO 250 K=1,IP                                                     0521.000
      NAFRG(NSEQ+1)=MAX0(NAFRG(NSEQ+1),IAT,IB(K))                       0522.000
      L=0                                                               0523.000
  210 L=L+1                                                             0524.000
      IF(IONP(L,IAT).EQ.IB(K)) GO TO 250                                0525.000
      IF(IONP(L,IAT).GT.0) GO TO 210                                    0526.000
      IONP(L,IAT)=IB(K)                                                 0527.000
      IX=IB(K)                                                          0528.000
      L=0                                                               0529.000
  220 L=L+1                                                             0530.000
      IF(IONP(L,IX).GT.0) GO TO 220                                     0531.000
      IONP(L,IX)=IAT                                                    0532.000
  250 CONTINUE                                                          0533.000
      IP=0                                                              0534.000
      GO TO 1000                                                        0535.000
  400 IF(ISL.EQ.(-1)) RETURN                                            0536.000
      ISL=-1                                                            0537.000
      NSEQ=NSEQ+1                                                       0538.000
      N=NAFRG(NSEQ)                                                     0539.000
      NX=-29                                                            0540.000
      WRITE(LT,720) NSEQ,N                                              0541.000
  720 FORMAT(1H0,10X,15HFRAGMENT NUMBER,I4,5X,17HNUMBER OF ATOMS =,I4)  0542.000
  730 NX=NX+30                                                          0543.000
      NP=MIN0(N,NX+29)                                                  0544.000
      WRITE(LT,740) (J,J=NX,NP)                                         0545.000
  740 FORMAT(1H0,5HATOMS,5X,30I3)                                       0546.000
      DO 780 K=1,6                                                      0547.000
      L=0                                                               0548.000
      LNO=0                                                             0549.000
      DO 750 J=1,60                                                     0550.000
      LINX(J)=ICH(11)                                                   0551.000
  750 CONTINUE                                                          0552.000
      DO 760 J=NX,NP                                                    0553.000
      L=L+2                                                             0554.000
      IF(IONP(K,J).EQ.0) GO TO 760                                      0555.000
      LNO=1                                                             0556.000
      II=IONP(K,J)                                                      0557.000
      JJ=II/10                                                          0558.000
      IF(JJ.GT.0) LINX(L-1)=ICH(JJ+1)                                   0559.000
      JJ=II-10*JJ                                                       0560.000
      LINX(L)=ICH(JJ+1)                                                 0561.000
      IONP(K,J)=0                                                       0562.000
      IF(II.LT.J) GO TO 760                                             0563.000
      NADR=NADR+1                                                       0564.000
      INBOND(NADR)=512*J+II                                             0565.000
  760 CONTINUE                                                          0566.000
      IF(LNO.EQ.0) GO TO 790                                            0567.000
      WRITE(LT,770) (LINX(J),J=1,L)                                     0568.000
  770 FORMAT(1H ,8HBONDS TO,2X,30(1X,2A1))                              0569.000
  780 CONTINUE                                                          0570.000
  790 IF(NP.LT.N) GO TO 730                                             0571.000
      NADR=NADR+1                                                       0572.000
      INBOND(NADR)=-1000                                                0573.000
      NAFRG(NSEQ+1)=0                                                   0574.000
      IF(NSEQ.GE.5) RETURN                                              0575.000
 1000 CONTINUE                                                          0576.000
      GO TO 120                                                         0577.000
      END                                                               0578.000
C     ------------------------------------------------------------------0579.000
      SUBROUTINE RDSECT(MINUS,NR3D,MAX,NNXP2,NNZ,NXZ3,KUSER2)           0580.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     0581.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          0582.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          0583.000
      DIMENSION  NR3D(KUSER2)                                           0584.000
      IF (MAX .GE. NXZ3) MAX = 0                                        0585.000
      MIN=MAX+1                                                         0586.000
      MAX=MAX+NNXP2*NNZ                                                 0587.000
      READ(LIN)(NR3D(IX),IX=MIN,MAX)                                    0588.000
      IF(MINUS.GT.0)GOTO 2                                              0589.000
      DO 1 IX=MIN,MAX                                                   0590.000
    1 NR3D(IX)=-NR3D(IX)                                                0591.000
    2 MX=MIN+2*NNXP2-1                                                  0592.000
      DO 3 IX=MIN,MX                                                    0593.000
      MAX=MAX+1                                                         0594.000
    3 NR3D(MAX)=NR3D(IX)                                                0595.000
      RETURN                                                            0596.000
      END                                                               0597.000
C-----------------------------------------------------------------------0598.000
C     INTERACTIVE INPUT                                                 0599.000
      SUBROUTINE TRANSL(NPC,NPROJ,MFRN,NA,NOJOIN,NHOLES,NEUTRON,NPATT,  0600.000
     1 KUSER1)                                                          0601.000
      CHARACTER COMPID(72),LINE(148)                                    0602.000
      CHARACTER*4 ITLE(18)                                              0603.000
      CHARACTER*8 LABEL(200),FTYPE(13),TAG,MENU(13)                     0604.000
      INTEGER CN(200),CONTNT(13),FCH(20),FWD(20)                        0605.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     0606.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          0607.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          0608.000
      COMMON /TITLE/ ITLE                                               0609.000
      COMMON/MODELC/COMPID,LABEL,FTYPE                                  0610.000
      COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),              0611.000
     1CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),           0612.000
     2WAVEL,SELL(6),ECELL(6),R(24,3,4),TEE(3,4),ICENT,                  0613.000
     3SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                                0614.000
      DATA LINE/148*' '/                                                0615.000
      DATA NMEN/13/,MENU/'PEAKS','HOLES','PLOTS','METAL','ATOMS',       0616.000
     1'JOIN','NEUTRON','MOLE','DOUT','DMIN','DMAX','AMIN','AMAX'/       0617.000
 1000 FORMAT(//10X,'<<<<<<SELECT ITEMS FROM THE MENU>>>>>>',//          0618.000
     1' 1. PEAKS  <NP>   5. ATOMS     <NO/YES>    9. DOUT   <ANG.>',/   0619.000
     2' 2. HOLES  <NH>   6. JOIN      <NO/YES>   10. DMIN   <ANG.>',/   0620.000
     3' 3. PLOTS  <NPL>  7. NEUTRON   <NO/YES>   11. DMAX   <ANG.>',/   0621.000
     4' 4. METAL  <NM>   8. MOLE      <NO/YES>   12. AMIN   <DEG.>',/   0622.000
     5'                                          13. AMAX   <DEG.>',/   0623.000
     6' MENU --- CAUSES THE MENU TO BE RETYPED',/                       0624.000
     7' <CR> --- STARTS THE PROGRAM',/)                                 0625.000
 1001 FORMAT(/' TYPE AN INSTRUCTION'/)                                  0626.000
 1002 FORMAT(72A1)                                                      0627.000
 1003 FORMAT(8X,' THE NUMBER OF PEAKS TO USE WILL BE DECIDED BY THE PROG0628.000
     1RAM')                                                             0629.000
 1004 FORMAT(8X,' THE PROGRAM WILL LOOK FOR ',I4,' PEAKS')              0630.000
 1005 FORMAT(8X,' THE PROGRAM WILL LOOK FOR ',I4,' HOLES')              0631.000
 1006 FORMAT(8X,' THE NUMBER OF PLOTS IS DECIDED BY THE PROGRAM')       0632.000
 1007 FORMAT(8X,' FOR EACH CLUSTER ',I2,' PLOTS WILL BE DRAWN')         0633.000
 1008 FORMAT(8X,' THE FIRST ',I2,' PEAKS ARE METAL ATOMS')              0634.000
 1009 FORMAT(8X,' ADD ATOMS IN MODEL FILE TO THE  PEAK LIST')           0635.000
 1010 FORMAT(8X,' NO ATOMS WILL BE READ FROM THE MODEL FILE')           0636.000
 1011 FORMAT(8X,' THE PEAK LIST WILL BE INTERPRETED')                   0637.000
 1012 FORMAT(8X,' NO INTERPRETATION OF THE PEAK LIST')                  0638.000
 1013 FORMAT(8X,' INCLUDE HOLES IN THE INTERPRETATION')                 0639.000
 1014 FORMAT(8X,' DON''T INCLUDE HOLES IN THE INTERPRETATION')          0640.000
 1015 FORMAT(8X,' NO BOND SEQUENCES ARE TO BE READ')                    0641.000
 1016 FORMAT(8X,' READ BOND SEQUENCES')                                 0642.000
 1017 FORMAT(8X,' PRINT ALL DISTANCES LESS THAN ',F5.2,' ANGSTROMS')    0643.000
 1018 FORMAT(8X,' MINIMUM BOND LENGTH = ',F5.2,' ANGSTROMS')            0644.000
 1019 FORMAT(8X,' PLEASE WAIT. I AM READING THE MODEL FILE'/)           0645.000
 1020 FORMAT(1H1,4X,' PEAK SEARCH AND INTERPRETATION',17X,              0646.000
     1' VERSION OF JAN 1980',/1H ,4X,' SET NO. ',I2,' FOR ',/1H ,5X,    0647.000
     118A4,/1H ,72('-'),/12X,' INSTRUCTIONS FOR SEARCHING THE MAP',     0648.000
     1/1H ,72('-'))                                                     0649.000
 1021 FORMAT(1H )                                                       0650.000
 1022 FORMAT(1H ,72('-'),/12X,' INTERPRETATION INSTRUCTIONS'/,1H ,      0651.000
     172('-'))                                                          0652.000
 1023 FORMAT(1H ,72('-'),/12X,' STEREOCHEMICAL CRITERIA',/1H ,72('-'))  0653.000
 1024 FORMAT(8X,' MAXIMUM BOND LENGTH = ',F5.2,' ANGSTROMS')            0654.000
 1025 FORMAT(8X,' MINIMUM BOND ANGLE  = ',F5.0,' DEGREES')              0655.000
 1026 FORMAT(8X,' MAXIMUM BOND ANGLE  = ',F5.0,' DEGREES')              0656.000
 1027 FORMAT(1H ,72('-'))                                               0657.000
      NPC=-1                                                            0658.000
      NHOLES=0                                                          0659.000
      NPROJ=0                                                           0660.000
      METAL=0                                                           0661.000
      NA=1                                                              0662.000
      NOJOIN=0                                                          0663.000
      NEUTRON=0                                                         0664.000
      MFRN=0                                                            0665.000
      NPATT=0                                                           0666.000
      IF(NMAP.EQ.5.OR.NMAP.EQ.6)NPATT=1                                 0667.000
      IF(NPATT.EQ.1)NOJOIN=1                                            0668.000
      IF(NMAP.GT.4)FACTOR=1.0                                           0669.000
      IF(NMAP.GT.4)NA=0                                                 0670.000
C********** FREE FORMAT INPUT****************************************** 0671.000
      ASSIGN 2 TO IRETURN                                               0672.000
    1 WRITE(LP,1000)                                                    0673.000
    2 WRITE(LP,1001)                                                    0674.000
    3 READ(LC,1002,END=35)(LINE(I),I=2,73)                              0675.000
      CALL PARSE(LINE,NFS,FCH,FWD)                                      0676.000
      IF(NFS.EQ.0)GOTO 35                                               0677.000
      CALL AFORMT(LINE,FCH(1),FWD(1),TAG)                               0678.000
      IF(TAG.EQ.'MENU'.OR.TAG.EQ.'MEN')GOTO 1                           0679.000
      NTAG=NMEN+1                                                       0680.000
      DO 4 I=1,NMEN                                                     0681.000
    4 IF(TAG.EQ.MENU(I))NTAG=I                                          0682.000
      IF(NFS.EQ.1)GOTO(10,12,14,16,18,20,22,24,26,28,30,32,34,2),NTAG   0683.000
      GOTO(5,5,5,5,6,6,6,6,7,7,7,7,7,2),NTAG                            0684.000
    5 CALL IFORMT(LINE,FCH(2),FWD(2),IN)                                0685.000
      GOTO 8                                                            0686.000
    6 CALL AFORMT(LINE,FCH(2),FWD(2),TAG)                               0687.000
      IF(TAG.EQ.'YES'.OR.TAG.EQ.'Y')IN=1                                0688.000
      IF(TAG.EQ.'NO' .OR.TAG.EQ.'N')IN=0                                0689.000
      GOTO 8                                                            0690.000
    7 CALL FFORMT(LINE,FCH(2),FWD(2),FIN)                               0691.000
    8 WRITE(LP,1021)                                                    0692.000
      GOTO(9,11,13,15,17,19,21,23,25,27,29,31,33,2),NTAG                0693.000
C********** NOW ASSIGN INPUT VALUES TO REQUIRED VARIABLE *************  0694.000
    9 NPC=IABS(IN)                                                      0695.000
   10 IF(NPC.LT.0)WRITE(LP,1003)                                        0696.000
      IF(NPC.GE.0)WRITE(LP,1004)NPC                                     0697.000
      GOTO IRETURN                                                      0698.000
   11 NHOLES=IABS(IN)                                                   0699.000
   12 WRITE(LP,1005)NHOLES                                              0700.000
      GOTO IRETURN                                                      0701.000
   13 NPROJ=MIN0(IN,3)                                                  0702.000
   14 IF(NPROJ.LE.0)WRITE(LP,1006)                                      0703.000
      IF(NPROJ.GT.0)WRITE(LP,1007)NPROJ                                 0704.000
      GOTO IRETURN                                                      0705.000
   15 METAL=IABS(IN)                                                    0706.000
   16 WRITE(LP,1008)METAL                                               0707.000
      GOTO IRETURN                                                      0708.000
   17 NA=IN                                                             0709.000
   18 IF(NA.NE.0)WRITE(LP,1009)                                         0710.000
      IF(NA.EQ.0)WRITE(LP,1010)                                         0711.000
      GOTO IRETURN                                                      0712.000
   19 NOJOIN=IABS(IN-1)                                                 0713.000
   20 IF(NOJOIN.EQ.0)WRITE(LP,1011)                                     0714.000
      IF(NOJOIN.NE.0)WRITE(LP,1012)                                     0715.000
      GOTO IRETURN                                                      0716.000
   21 NEUTRON=IN                                                        0717.000
   22 IF(NEUTRON.EQ.1)WRITE(LP,1013)                                    0718.000
      IF(NEUTRON.NE.1)WRITE(LP,1014)                                    0719.000
      GOTO IRETURN                                                      0720.000
   23 MFRN=IN                                                           0721.000
   24 IF(MFRN.EQ.0)WRITE(LP,1015)                                       0722.000
      IF(MFRN.NE.0)WRITE(LP,1016)                                       0723.000
      GOTO IRETURN                                                      0724.000
   25 DMUT=FIN                                                          0725.000
   26 WRITE(LP,1017)DMUT                                                0726.000
      GOTO IRETURN                                                      0727.000
   27 DMIN=FIN                                                          0728.000
   28 WRITE(LP,1018)DMIN                                                0729.000
      GOTO IRETURN                                                      0730.000
   29 DMAX=FIN                                                          0731.000
   30 WRITE(LP,1024)DMAX                                                0732.000
      GOTO IRETURN                                                      0733.000
   31 ANGMIN=FIN                                                        0734.000
   32 WRITE(LP,1025)ANGMIN                                              0735.000
      GOTO IRETURN                                                      0736.000
   33 ANGMAX=FIN                                                        0737.000
   34 WRITE(LP,1026)ANGMAX                                              0738.000
      GOTO IRETURN                                                      0739.000
C********** READ THE MODEL FILE AND OUTPUT FINAL PARAMETERS************ 0740.000
   35 IF(NA.LE.0)GOTO 37                                                0741.000
      WRITE(LP,1019)                                                    0742.000
      CALL MDLIN(LMD)                                                   0743.000
      NA=NATOM                                                          0744.000
      KNT=0                                                             0745.000
      DO 36 I=1,13                                                      0746.000
   36 KNT=KNT+CONTNT(I)                                                 0747.000
      KNT=KNT/(NR*NT*(2-ICENT)) - NATOM                                 0748.000
      IF(KNT.GT.0.AND.NMAP.NE.7)NATM=KNT                                0749.000
   37 NPC=MIN0(NPC,KUSER1-20)                                           0750.000
      NHOLES=MIN0(NHOLES,KUSER1-20)                                     0751.000
      LPP=LP                                                            0752.000
      LP=LT                                                             0753.000
      WRITE(LP,1020)NUMSET,ITLE                                         0754.000
      NTAG=0                                                            0755.000
      ASSIGN 38 TO IRETURN                                              0756.000
   38 NTAG=NTAG+1                                                       0757.000
      IF(NTAG.EQ.4)WRITE(LP,1022)                                       0758.000
      IF(NTAG.EQ.9)WRITE(LP,1023)                                       0759.000
      IF(NTAG.GT.4.AND.NOJOIN.EQ.1)GOTO 39                              0760.000
      GOTO(10,12,18,20,16,22,24,14,26,28,30,32,34,39),NTAG              0761.000
   39 WRITE(LP,1027)                                                    0762.000
      LP=LPP                                                            0763.000
      RETURN                                                            0764.000
      END                                                               0765.000
C     ------------------------------------------------------------------0766.000
C     LABEL PEAKS AND HOLES                                             0767.000
      SUBROUTINE LBL(XL,N,M)                                            0768.000
      CHARACTER*8 XL(N),TAG,ZERO                                        0769.000
      CHARACTER   D(16),NAME(8)                                         0770.000
      EQUIVALENCE (TAG,NAME(1))                                         0771.000
      DATA D/'0','1','2','3','4','5','6','7','8','9','(',')','P','K',   0772.000
     1'H','L'/,ZERO/'        '/                                         0773.000
      DO 3 I=1,N                                                        0774.000
      TAG=ZERO                                                          0775.000
      NAME(1)=D(13+M)                                                   0776.000
      NAME(2)=D(14+M)                                                   0777.000
      NAME(3)=D(11)                                                     0778.000
      KNT=3                                                             0779.000
      NUM=I                                                             0780.000
      K=NUM/100                                                         0781.000
      NUM=NUM-100*K                                                     0782.000
      IF(K.EQ.0)GOTO 1                                                  0783.000
      KNT=KNT+1                                                         0784.000
      NAME(KNT)=D(K+1)                                                  0785.000
    1 K=NUM/10                                                          0786.000
      NUM=NUM-10*K                                                      0787.000
      IF(K.EQ.0.AND.KNT.EQ.3)GOTO 2                                     0788.000
      KNT=KNT+1                                                         0789.000
      NAME(KNT)=D(K+1)                                                  0790.000
    2 KNT=KNT+1                                                         0791.000
      NAME(KNT)=D(NUM+1)                                                0792.000
      NAME(KNT+1)=D(12)                                                 0793.000
      XL(I)=TAG                                                         0794.000
    3 CONTINUE                                                          0795.000
      RETURN                                                            0796.000
      END                                                               0797.000
C     ------------------------------------------------------------------0798.000
C     LIST PATTERSON PEAKS WITH DISTANCES FROM ORIGIN AND STOP          0799.000
      SUBROUTINE PATTERSN(NPATT,T,X,XL)                                 0800.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     0801.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          0802.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          0803.000
      CHARACTER*8 XL(NPIC)                                              0804.000
      DIMENSION U(3),V(3),T(3,3),X(4,NPIC)                              0805.000
 1000 FORMAT(1H1,24X,'PATTERSON FUNCTION PEAKS',//1H ,72('-'),/         0806.000
     11H ,10X,'PEAK',12X,'U',7X,'V',7X,'W',5X,'P(UVW)  ORIGIN DISTANCE',0807.000
     2/1H ,72('-'))                                                     0808.000
 1001 FORMAT(1H ,10X,A8,3X,3F8.4,2X,F6.0,6X,F5.2)                       0809.000
 1002 FORMAT(1H ,72('-'))                                               0810.000
      IF(NPATT.NE.1)GOTO 6                                              0811.000
      WRITE(LT,1000)                                                    0812.000
      DO 5 I=1,NPIC                                                     0813.000
      DD=1000000.                                                       0814.000
      DO 4 J=1,NSYM                                                     0815.000
      CALL OPER(J,U,X(1,I),X(2,I),X(3,I))                               0816.000
      DO 2 L=1,3                                                        0817.000
    1 IF(ABS(U(L)).LE.0.5)GOTO 2                                        0818.000
      U(L)=U(L)-SIGN(1.0,U(L))                                          0819.000
      GOTO 1                                                            0820.000
    2 CONTINUE                                                          0821.000
      DSQ=QUAD(U,U,T)                                                   0822.000
      IF(DD.LE.DSQ)GOTO 4                                               0823.000
      DD=DSQ                                                            0824.000
      DO 3 L=1,3                                                        0825.000
    3 V(L)=U(L)                                                         0826.000
    4 CONTINUE                                                          0827.000
      DD=SQRT(DD)                                                       0828.000
      WRITE(LT,1001)XL(I),V,X(4,I),DD                                   0829.000
    5 CONTINUE                                                          0830.000
      WRITE(LT,1002)                                                    0831.000
      STOP                                                              0832.000
    6 RETURN                                                            0833.000
      END                                                               0834.000
C     ------------------------------------------------------------------0835.000
      SUBROUTINE GETHA(NHOLES,NEUTRON,G,NSTORE,KUSER1,KUSER2,           0836.000
     1IHALF,NA)                                                         0837.000
      DIMENSION XX(3),YY(3),G(3,3),NSTORE(KUSER2)                       0838.000
      CHARACTER COMPID(72)                                              0839.000
      CHARACTER*8 LABEL(200),FTYPE(13),XL(200),YL(400)                  0840.000
      INTEGER CN(200),CONTNT(13),FCH(20),FWD(20)                        0841.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     0842.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          0843.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          0844.000
      COMMON /TITLE/ ITLE                                               0845.000
      COMMON/MODELC/COMPID,LABEL,FTYPE                                  0846.000
      COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),              0847.000
     1CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),           0848.000
     2WAVEL,SELL(6),ECELL(6),R(24,3,4),TEE(3,4),ICENT,                  0849.000
     3SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                                0850.000
      COMMON /ATOMS/ X(4,200),Y(4,400)                                  0851.000
      COMMON /NAMES/ XL,YL                                              0852.000
 1000 FORMAT(1H1,34X,'PEAK LIST'//)                                     0853.000
 1001 FORMAT(1H ,78('-')/'  NO  ATOM',9X,'COVALENT RADIUS',10X,'X',9X,  0854.000
     1'Y',9X,'Z',/1H ,78('-'))                                          0855.000
 1002 FORMAT(1H ,I3,2X,A8,11X,F4.2,12X,3(F8.5,2X))                      0856.000
 1003 FORMAT(1H ,78('-')/'  NO  PEAK',34X,'X',9X,'Y',9X,'Z',8X,'HEIGHT'/0857.000
     11H ,78('-'))                                                      0858.000
 1004 FORMAT(1H ,5X,A8,' IS ',F5.2,' A FROM ',A8,2X,3(F7.4,3X),F8.2)    0859.000
 1005 FORMAT(1H ,I3,2X,A8,25('.'),2X,3(F7.4,3X),F8.2)                   0860.000
 1006 FORMAT(1H ,78('-'))                                               0861.000
 1007 FORMAT(' PEAK LIST TRUNCATED AT ',I6,' INCREASE KUSER1 ')         0862.000
C     DMULT - MULTIPLIER FOR COVALENT RADII. MINIMUM RADIUS IS RADMIN   0863.000
      DMULT=0.9                                                         0864.000
      RADMIN=.5                                                         0865.000
      WRITE(LT,1000)                                                    0866.000
      NPEAK=NPIC                                                        0867.000
      DO 2 I=1,NPEAK                                                    0868.000
      DO 1 J=1,4                                                        0869.000
    1 Y(J,I)=X(J,I)                                                     0870.000
    2 YL(I)=XL(I)                                                       0871.000
      IF(NHOLES.LE.0)GOTO 4                                             0872.000
      NPIC=-NHOLES                                                      0873.000
      CALL PKSRCH(NSTORE,KUSER1,KUSER2,IHALF)                           0874.000
      NHOLES=NPIC                                                       0875.000
      CALL SORT(X,KUSER1,NHOLES,4)                                      0876.000
      CALL LBL(XL,NHOLES,2)                                             0877.000
      DO 3 I=1,NHOLES                                                   0878.000
      J=I+NPEAK                                                         0879.000
      YL(J)=XL(I)                                                       0880.000
      Y(4,J)=-X(4,I)*FACTOR                                             0881.000
      DO 3 K=1,3                                                        0882.000
    3 Y(K,J)=X(K,I)                                                     0883.000
      NPIC=NPEAK                                                        0884.000
      NPEAK=NPIC+NHOLES                                                 0885.000
    4 IF(NA.LE.0)GOTO 7                                                 0886.000
      WRITE(LT,1001)                                                    0887.000
      DO 6 I=1,NA                                                       0888.000
      XL(I)=LABEL(I)                                                    0889.000
      X(4,I)=DMULT*SFAC(13,NFTYPE(I))                                   0890.000
      X(4,I)=AMAX1(X(4,I),RADMIN)                                       0891.000
      DO 5 J=1,3                                                        0892.000
    5 X(J,I)=P(J,I)                                                     0893.000
      WRITE(LT,1002)I,XL(I),X(4,I),(X(J,I),J=1,3)                       0894.000
      X(4,I)=X(4,I)*X(4,I)                                              0895.000
    6 CONTINUE                                                          0896.000
    7 WRITE(LT,1003)                                                    0897.000
      II=NA                                                             0898.000
      DO 13 I=1,NPEAK                                                   0899.000
      IF(NA.LE.0)GOTO 30                                                0900.000
      YA=Y(1,I)                                                         0901.000
      YB=Y(2,I)                                                         0902.000
      YC=Y(3,I)                                                         0903.000
      DO 12 J=1,NSYM                                                    0904.000
      CALL OPER(J,YY,YA,YB,YC)                                          0905.000
      DO 11 K=1,NA                                                      0906.000
      DO 10 L=1,3                                                       0907.000
      XX(L)=YY(L)-X(L,K)                                                0908.000
    8 IF(ABS(XX(L)).LE.0.5)GOTO 9                                       0909.000
      XX(L)=XX(L)-SIGN(1.0,XX(L))                                       0910.000
      GOTO 8                                                            0911.000
    9 CONTINUE                                                          0912.000
   10 CONTINUE                                                          0913.000
      DSQ=QUAD(XX,XX,G)                                                 0914.000
      IF(DSQ.GT.X(4,K))GOTO 11                                          0915.000
      DSQ=SQRT(DSQ)                                                     0916.000
      DO 19 L=1,3                                                       0917.000
   19 YY(L)=XX(L)+X(L,K)                                                0918.000
      WRITE(LT,1004)YL(I),DSQ,XL(K),YY,Y(4,I)                           0919.000
      Y(4,I)=-10000.                                                    0920.000
      GOTO 13                                                           0921.000
   11 CONTINUE                                                          0922.000
   12 CONTINUE                                                          0923.000
   30 II=II+1                                                           0924.000
      WRITE(LT,1005)II,YL(I),(Y(J,I),J=1,4)                             0925.000
   13 CONTINUE                                                          0926.000
      WRITE(LT,1006)                                                    0927.000
   14 II=NA                                                             0928.000
      MAT=0                                                             0929.000
      MPIC=0                                                            0930.000
      IF(NEUTRON.EQ.0)GOTO 22                                           0931.000
      NPIC=NPEAK                                                        0932.000
      NAT=NPEAK                                                         0933.000
      GOTO 23                                                           0934.000
   22 NPEAK=NPEAK-NHOLES                                                0935.000
   23 DO 18 I=1,NPEAK                                                   0936.000
      IF(Y(4,I).LT.-9999.)GOTO 17                                       0937.000
      II=II+1                                                           0938.000
      IF(II.LE.KUSER1-20)GOTO 15                                        0939.000
      WRITE(LT,1007)II                                                  0940.000
      GOTO 21                                                           0941.000
   15 XL(II)=YL(I)                                                      0942.000
      DO 16 K=1,4                                                       0943.000
   16 X(K,II)=Y(K,I)                                                    0944.000
      GOTO 18                                                           0945.000
   17 IF(I.LE.NAT)MAT=MAT +1                                            0946.000
      IF(I.LE.NPIC)MPIC=MPIC+1                                          0947.000
   18 CONTINUE                                                          0948.000
   21 NAT=MAX0(0,NAT-MAT)                                               0949.000
      NPIC=MAX0(0,NPIC-MPIC)                                            0950.000
      NAT=MIN0(NAT+NA,KUSER1-20)                                        0951.000
      NPIC=MIN0(NPIC+NA,KUSER1-20)                                      0952.000
      DO 20 I=1,NA                                                      0953.000
   20 X(4,I)=10000.                                                     0954.000
      RETURN                                                            0955.000
      END                                                               0956.000
C     FINISH PART 1. OF SEARCH                                          0957.000
C     PART 2 OF SEARCH.                                                 0958.000
C     ------------------------------------------------------------------0959.000
C     IDENTIFY SEPARATE BONDED CLUSTERS AND SET UP BONDING ARRAY.       0960.000
C     NPASS DETERMINES PATH THROUGH SUBROUTINE.                         0961.000
C     NPASS = 0 :SET UP ALL CLUSTERS ; NPASS =1 :REDO CLUSTER NOFRAG    0962.000
      SUBROUTINE CLSTRS(NPASS)                                          0963.000
      COMMON ISYM(100),INBOND(1000),IFRAG(200),ICON(200),               0964.000
     1 IBOND(2000),JFRAG(200),JCON(200),JBOND(2000),IUSE(200),          0965.000
     2 IONA(6,200),IONP(6,200),MO(200),MU(200),NO(200),NU(200),         0966.000
     3 KEYST(200),LW(200),LR(200),LX(200),JK(200),IK(200),KEY(200),     0967.000
     4 IPL(200),CAN(200),CON(200),LL(200),IA(6,200),LS(200),DUM(14400)  0968.000
      COMMON /ATOMS/ X(4,200),Y(4,400)                                  0969.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     0970.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          0971.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          0972.000
      COMMON /MISC/ CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM                0973.000
      COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN      0974.000
      DIMENSION   IB(3), XS(3), X1(3), X2(3), BSTOR(3),  XSTOR(3)       0975.000
      ICHECK=0                                                          0976.000
      IF (NPASS.EQ.0) GOTO 1010                                         0977.000
      ICHECK=1                                                          0978.000
C     REDUCE ISYM ARRAY TO EXCLUDE NOFRAG BONDINGS                      0979.000
      NNN=0                                                             0980.000
      DO 995 I=1,NN                                                     0981.000
      IF (ISYM(I)/250000.EQ.NOFRAG) GOTO 995                            0982.000
      NNN=NNN+1                                                         0983.000
      ISYM(NNN)=ISYM(I)                                                 0984.000
  995 CONTINUE                                                          0985.000
      NN=NNN                                                            0986.000
      GOTO 1025                                                         0987.000
 1000 NAT=NPIC                                                          0988.000
C     CLEAR ARRAYS                                                      0989.000
 1010 NN=0                                                              0990.000
      MCON=0                                                            0991.000
      DO 1020 I=1,NAT                                                   0992.000
      IFRAG(I)=0                                                        0993.000
      ICON(I)=0                                                         0994.000
      LW(I) = 0                                                         0995.000
      LR(I) = 0                                                         0996.000
 1020 CONTINUE                                                          0997.000
C     APPLY DISTANCE CRITERION TO PEAKS TO IDENTIFY SEPARATE CLUSTERS   0998.000
C     PEAKS WITHIN DISTANCE DMAX ARE POSSIBLE BONDED PEAKS              0999.000
      NFRAG=0                                                           1000.000
      NOFRAG=0                                                          1001.000
 1025 NATM1=NAT-1                                                       1002.000
C     START A NEW CLUSTER AT ATOM II                                    1003.000
      DO 1180 II=1,NATM1                                                1004.000
      IF (IFRAG(II).EQ.(-1000)) GOTO 1030                               1005.000
      IF (ICHECK.EQ.1.OR.IFRAG(II).NE.0) GOTO 1180                      1006.000
      NOFRAG=NOFRAG+1                                                   1007.000
      NFRAG=NFRAG+1                                                     1008.000
 1030 ICHECK=0                                                          1009.000
      IFRAG(II)=NOFRAG                                                  1010.000
C     KOUNT RECORDS NUMBER OF PEAKS IN PRESENT CLUSTER.                 1011.000
      KOUNT=1                                                           1012.000
      I=II                                                              1013.000
      IBEGIN=II                                                         1014.000
      IF (NPASS.EQ.1) IBEGIN=1                                          1015.000
 1040 DO 1140 J=IBEGIN,NAT                                              1016.000
C     DO NOT CONSIDER PEAK PAIRS MORE THAN ONCE                         1017.000
      IF (IFRAG(J).LT.0.AND.IFRAG(J).NE.(-1000)) GOTO 1140              1018.000
      JMOVE = 0                                                         1019.000
      KSYM=0                                                            1020.000
      DO 1120 K=1,NSYM                                                  1021.000
C     OMIT THE IDENTITY OPERATION WHEN I & J ARE THE SAME               1022.000
      IF (I.EQ.J.AND.K.EQ.1) GOTO 1120                                  1023.000
C     CALC K'TH SYMM POSITION OF J'TH PEAK & MOVE AS CLOSE              1024.000
C     TO I'TH PEAK AS POSSIBLE BY LATTICE TRANSLATIONS                  1025.000
      IF(JSYMM(I,J,K,IB,XS,X1).NE.0) GO TO 1120                         1026.000
C     CALCULATE DISTANCE BETWEEN PEAKS I & J                            1027.000
      DIST=QUAD(X1,X1,T)                                                1028.000
      IF (DIST.GT.DFRG) GOTO 1120                                       1029.000
C     PEAK J IS CLOSE TO CLUSTER NOFRAG                                 1030.000
      LR(J)=1                                                           1031.000
C     DO NOT CONSIDER PEAKS OUTSIDE BONDING DISTANCE                    1032.000
C     OR PEAKS LYING ON SYMMETRY ELEMENTS                               1033.000
      IF (DIST.GT.DMAX) GOTO 1120                                       1034.000
      IF (DIST.LT.0.04) GOTO 1120                                       1035.000
C     PEAKS I & J ARE WITHIN BONDING DISTANCE-ADD TO CLUSTER            1036.000
      IF (IABS(IFRAG(J)).EQ.NOFRAG) GOTO 1080                           1037.000
      IF (IFRAG(J).EQ.(-1000)) GOTO 1060                                1038.000
C     PEAK J CAN BE MOVED, SO MOVE IT & RECORD SYMM. OP.                1039.000
      JMOVE=1                                                           1040.000
      KSYM=K                                                            1041.000
      DO 1050 L=1,3                                                     1042.000
      XSTOR(L)=XS(L)                                                    1043.000
      BSTOR(L)=FLOAT(IB(L)-5)                                           1044.000
 1050 CONTINUE                                                          1045.000
C     ADD J TO CLUSTER                                                  1046.000
 1060 IFRAG(J)=NOFRAG                                                   1047.000
      KOUNT=KOUNT+1                                                     1048.000
C     IF PEAK MOVED, ADD TO BONDING ARRAY                               1049.000
      IF (KSYM.EQ.K) GOTO 1100                                          1050.000
 1080 JBND=100000*IB(1)+10000*IB(2)+1000*IB(3)+K                        1051.000
      IF (JBND.EQ.555001) GOTO 1100                                     1052.000
C     CLUSTER NOFRAG BONDS TO ITSELF THROUGH I & J - RECORD IN ISYM     1053.000
      NN=NN+1                                                           1054.000
      IF(I.LT.J) ISYM(NN)=250000*NOFRAG+500*I+J                         1055.000
      IF(I.GE.J) ISYM(NN)=250000*NOFRAG+500*J+I                         1056.000
      GOTO 1120                                                         1057.000
 1100 IF(I.EQ.J) GO TO 1120                                             1058.000
      IDIST=1000.0*SQRT(DIST)+0.5                                       1059.000
      MCON=MCON+1                                                       1060.000
      IBOND(MCON)=(512*I+J)*8192+IDIST                                  1061.000
      MCON=MCON+1                                                       1062.000
      IBOND(MCON)=(512*J+I)*8192+IDIST                                  1063.000
 1120 CONTINUE                                                          1064.000
      IF (JMOVE .EQ. 0) GO TO 1140                                      1065.000
      DO 1125 L=1,3                                                     1066.000
      X(L,J) = XSTOR(L)                                                 1067.000
 1125 CONTINUE                                                          1068.000
C     IF ONE PEAK IN A FRAGMENT MOVES,MOVE ALL THE REST                 1069.000
      IF (NPASS.NE.1.OR.JFRAG(J).EQ.0) GOTO 1140                        1070.000
      DO 1135 LOOP=1,NAT                                                1071.000
      IF (LOOP.EQ.J) GOTO 1135                                          1072.000
      IF (IFRAG(LOOP).NE.0) GOTO 1135                                   1073.000
      IF (JFRAG(LOOP).NE.JFRAG(J)) GOTO 1135                            1074.000
      CALL OPER(KSYM,XS,X(1,LOOP),X(2,LOOP),X(3,LOOP))                  1075.000
      DO 1130 L=1,3                                                     1076.000
      X(L,LOOP)=XS(L)                                                   1077.000
 1130 CONTINUE                                                          1078.000
 1135 CONTINUE                                                          1079.000
 1140 CONTINUE                                                          1080.000
C     PEAK I HAS BEEN COMPLETELY DEALT WITH                             1081.000
      IFRAG(I)=-IFRAG(I)                                                1082.000
C     CHOOSE NEXT PEAK IN CLUSTER                                       1083.000
      DO 1160 I=1,NAT                                                   1084.000
      IF(IFRAG(I).EQ.NOFRAG)GO TO 1040                                  1085.000
 1160 CONTINUE                                                          1086.000
C     CHECK FOR CLOSE APPROACHES BETWEEN CLUSTERS                       1087.000
      IF (NPASS.EQ.1) GOTO 1178                                         1088.000
      IF (NAT .EQ. NPIC) GO TO 1178                                     1089.000
      DO 1175 I=1,NAT                                                   1090.000
      IF (KOUNT.LE.4) GO TO 1170                                        1091.000
      IF (IABS(IFRAG(I)) .NE. NOFRAG) GO TO 1165                        1092.000
      IF (LW(I) .EQ. 0) GO TO 1170                                      1093.000
C     CLUSTERS ARE CLOSE TOGETHER - INCREASE NUMBER OF PEAKS            1094.000
      GO TO 1000                                                        1095.000
 1165 IF (LW(I) .EQ. 0) LW(I) = LR(I)                                   1096.000
 1170 LR(I) = 0                                                         1097.000
 1175 CONTINUE                                                          1098.000
 1178 IF(KOUNT.EQ.1)GO TO 1179                                          1099.000
      KFRAG(NOFRAG)=KOUNT                                               1100.000
      GOTO 1180                                                         1101.000
C     SINGLE PEAKS ARE GIVEN A CLUSTER NUMBER OF ZERO                   1102.000
 1179 IFRAG(II)=0                                                       1103.000
      NFRAG=NFRAG-1                                                     1104.000
      NOFRAG=NOFRAG-1                                                   1105.000
 1180 CONTINUE                                                          1106.000
      DO 1240 I=1,NAT                                                   1107.000
      IFRAG(I)=IABS(IFRAG(I))                                           1108.000
 1240 CONTINUE                                                          1109.000
C     PUT ENTRIES IN IBOND ARRAY IN ORDER OF PEAK HEIGHT                1110.000
      IF(MCON.GT.0) CALL ISORT(IBOND,MCON)                              1111.000
      RETURN                                                            1112.000
      END                                                               1113.000
C     ------------------------------------------------------------------1114.000
C     INTERPRET CLUSTER IN TERMS OF BONDED PEAKS AND ELIMINATE          1115.000
C     PEAKS WHICH DO NOT FULFIL DISTANCE AND ANGLE CRITERIA             1116.000
      SUBROUTINE INTERP(ISTART,KUSER1,IW,FOMF)                          1117.000
      COMMON ISYM(100),INBOND(1000),IFRAG(200),ICON(200),               1118.000
     1 IBOND(2000),JFRAG(200),JCON(200),JBOND(2000),IUSE(200),          1119.000
     2 IONA(6,200),IONP(6,200),MO(200),MU(200),NO(200),NU(200),         1120.000
     3 KEYST(200),LW(200),LR(200),LX(200),JK(200),IK(200),KEY(200),     1121.000
     4 IPL(200),CAN(200),CON(200),LL(200),IA(6,200),LS(200),DUM(14400)  1122.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     1123.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          1124.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          1125.000
      COMMON /MISC/ CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM                1126.000
      COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN      1127.000
      COMMON /ATOMS/ X(4,200),Y(4,400)                                  1128.000
      DIMENSION X1(3),X2(3)                                             1129.000
C     COPY CLUSTER INTO NEW ARRAY                                       1130.000
      M=1                                                               1131.000
      J=0                                                               1132.000
      DO 980 I=1,NAT                                                    1133.000
      JCON(I)=0                                                         1134.000
      JFRAG(I)=0                                                        1135.000
      ICON(I)=J                                                         1136.000
      IF (IFRAG(I) .NE. NOFRAG) GO TO 980                               1137.000
      IF(ISTART.EQ.0.AND.IUSE(I).EQ.0)ISTART=I                          1138.000
      IF (ISTART.LE.METAL) ISTART=0                                     1139.000
  950 IF(M.GT.MCON) GO TO 980                                           1140.000
      II=IBOND(M)/4194304                                               1141.000
      IF(II-I) 970,960,980                                              1142.000
  960 JCON(I)=JCON(I)+1                                                 1143.000
      J=J+1                                                             1144.000
      JBOND(J)=MOD(IBOND(M),4194304)                                    1145.000
      IF (I.EQ.ISTART.AND.JBOND(J)/8192.LE.METAL) ISTART = 0            1146.000
  970 M=M+1                                                             1147.000
      GO TO 950                                                         1148.000
  980 CONTINUE                                                          1149.000
      ICON(NAT+1)=J                                                     1150.000
      IF (ISTART.EQ.0) RETURN                                           1151.000
      MFRAG=0                                                           1152.000
      IDMIN=1000.0*SQRT(DMIN)+0.5                                       1153.000
C     START INTERPRETATION OF NEW SET OF PEAKS AT PEAK II               1154.000
      II=ISTART                                                         1155.000
      IF (METAL.EQ.0) GOTO 1080                                         1156.000
      DO 1020 I=1,METAL                                                 1157.000
      IF (IFRAG(I).NE.NOFRAG) GOTO 1020                                 1158.000
      JCON(I)=0                                                         1159.000
      KS=ICON(I)+1                                                      1160.000
      KL=ICON(I+1)                                                      1161.000
      IF(KS.GT.KL) GO TO 1010                                           1162.000
      DO 1000 J=KS,KL                                                   1163.000
      L=JBOND(J)/8192                                                   1164.000
      CALL ELIM(L,JFRAG(L),JCON,JBOND,ICON,KUSER1)                      1165.000
 1000 CONTINUE                                                          1166.000
 1010 CALL ELIM(I,JFRAG(I),JCON,JBOND,ICON,KUSER1)                      1167.000
 1020 CONTINUE                                                          1168.000
      GOTO 1080                                                         1169.000
 1040 II=0                                                              1170.000
 1060 II=II+1                                                           1171.000
      IF(II.GT.NAT)GO TO 1620                                           1172.000
      IF(JFRAG(II).NE.0)GO TO 1060                                      1173.000
      IF (JCON(II) .LE. 0) GO TO 1060                                   1174.000
 1080 MFRAG=MFRAG+1                                                     1175.000
      JFRAG(II)=MFRAG                                                   1176.000
      LFRAG(MFRAG)=1                                                    1177.000
      I=II                                                              1178.000
 1100 KS=ICON(I)+1                                                      1179.000
      KL=ICON(I+1)                                                      1180.000
C     APPLY MINIMUM DISTANCE CRITERION TO PEAKS AROUND THE ITH PEAK     1181.000
      DO 1140 J=KS,KL                                                   1182.000
      IF(JBOND(J).EQ.0) GO TO 1140                                      1183.000
      IDIST=MOD(JBOND(J),8192)                                          1184.000
      IF(IDIST.GE.IDMIN)GO TO 1140                                      1185.000
      L=JBOND(J)/8192                                                   1186.000
C     PEAKS I AND L ARE TOO CLOSE - ELIMINATE L                         1187.000
      CALL ELIM(L,JFRAG(L),JCON,JBOND,ICON,KUSER1)                      1188.000
 1140 CONTINUE                                                          1189.000
C     APPLY ANGLE CRITERIA TO PEAKS AROUND THE ITH PEAK                 1190.000
      IF(KS.EQ.KL)GO TO 1480                                            1191.000
C     CONSIDER THE ANGLES FRAGMENT - I - ANYTHING                       1192.000
      DO 1360 J=KS,KL                                                   1193.000
      IF(JBOND(J).EQ.0) GO TO 1360                                      1194.000
      JJ=JBOND(J)/8192                                                  1195.000
C     FIND A FRAGMENT PEAK                                              1196.000
      IF(IABS(JFRAG(JJ)).NE.MFRAG)GO TO 1360                            1197.000
C     SET UP VECTOR JJ - I FOR ANGLE CALCULATION                        1198.000
      DO 1300 L=1,3                                                     1199.000
      X1(L) = X(L,JJ) - X(L,I)                                          1200.000
 1300 CONTINUE                                                          1201.000
      VEC1=0.001*FLOAT(MOD(JBOND(J),8192))                              1202.000
      DO 1340 K=KS,KL                                                   1203.000
      IF(JBOND(K).EQ.0) GO TO 1340                                      1204.000
      KK=JBOND(K)/8192                                                  1205.000
      IF(JJ.EQ.KK)GO TO 1340                                            1206.000
C     CALCULATE COSINE OF ANGLE BETWEEN PEAKS JJ - I - KK               1207.000
      DO 1320 L=1,3                                                     1208.000
      X2(L)=X(L,KK)-X(L,I)                                              1209.000
 1320 CONTINUE                                                          1210.000
      VEC2=0.001*FLOAT(MOD(JBOND(K),8192))                              1211.000
      COSA=QUAD(X1,X2,T)/(VEC1*VEC2)                                    1212.000
C     IF ANGLE IS WITHIN LIMITS CONTINUE TESTING                        1213.000
      IF(COSA.GE.ANGMAX.AND.COSA.LE.ANGMIN)GO TO 1340                   1214.000
C     ELIMINATE KK IF IT IS NOT IN THE FRAGMENT                         1215.000
      IF(IABS(JFRAG(KK)).NE.MFRAG)GO TO 1330                            1216.000
      LFRAG(MFRAG) = LFRAG(MFRAG) - 1                                   1217.000
C     KK IS IN THE FRAGMENT - HAS IT ALREADY BEEN CONSIDERED            1218.000
      IF(JFRAG(KK).GT.0)GO TO 1330                                      1219.000
C     KK HAS ALREADY BEEN FULLY CONSIDERED FOR THE FRAGMENT-ELIMINATE I 1220.000
      CALL ELIM(I,JFRAG(I),JCON,JBOND,ICON,KUSER1)                      1221.000
      GO TO 1500                                                        1222.000
 1330 CALL ELIM(KK,JFRAG(KK),JCON,JBOND,ICON,KUSER1)                    1223.000
 1340 CONTINUE                                                          1224.000
 1360 CONTINUE                                                          1225.000
C     CONSIDER THE ANGLES NONFRAG - I - NONFRAG                         1226.000
      KLM1=KL-1                                                         1227.000
      DO 1460 J=KS,KLM1                                                 1228.000
      IF(JBOND(J).EQ.0) GO TO 1460                                      1229.000
      JJ=JBOND(J)/8192                                                  1230.000
C     FIND A NON-FRAGMENT PEAK                                          1231.000
      IF(IABS(JFRAG(JJ)).EQ.MFRAG)GO TO 1460                            1232.000
C     ADD PEAK TO FRAGMENT                                              1233.000
      JFRAG(JJ)=MFRAG                                                   1234.000
      LFRAG(MFRAG)=LFRAG(MFRAG)+1                                       1235.000
C     SET UP VECTOR JJ - I FOR ANGLE CALCULATION                        1236.000
      DO 1400 L=1,3                                                     1237.000
      X1(L)=X(L,JJ)-X(L,I)                                              1238.000
 1400 CONTINUE                                                          1239.000
      VEC1=0.001*FLOAT(MOD(JBOND(J),8192))                              1240.000
      JP1=J+1                                                           1241.000
      DO 1440 K=JP1,KL                                                  1242.000
      IF(JBOND(K).EQ.0) GO TO 1440                                      1243.000
      KK = JBOND(K)/8192                                                1244.000
C     FIND A NON-FRAGMENT PEAK                                          1245.000
      IF(IABS(JFRAG(KK)).EQ.MFRAG)GO TO 1440                            1246.000
C     CALCULATE COSINE OF ANGLE BETWEEN PEAKS JJ - I - KK               1247.000
      DO 1420 L=1,3                                                     1248.000
      X2(L)=X(L,KK)-X(L,I)                                              1249.000
 1420 CONTINUE                                                          1250.000
      VEC2=0.001*FLOAT(MOD(JBOND(K),8192))                              1251.000
      COSA=QUAD(X1,X2,T)/(VEC1*VEC2)                                    1252.000
C     IF ANGLE IS OUTSIDE LIMITS ELIMINATE KK                           1253.000
      IF(COSA.LT.ANGMAX.OR.COSA.GT.ANGMIN)CALL ELIM(KK,JFRAG(KK),       1254.000
     1  JCON,JBOND,ICON,KUSER1)                                         1255.000
 1440 CONTINUE                                                          1256.000
 1460 CONTINUE                                                          1257.000
C     SEE IF LAST PEAK CAN JOIN FRAGMENT                                1258.000
 1480 JJ=JBOND(KL)/8192                                                 1259.000
      IF(JCON(JJ).LE.0.OR.JFRAG(JJ).NE.0)GO TO 1490                     1260.000
      JFRAG(JJ)=MFRAG                                                   1261.000
      LFRAG(MFRAG)=LFRAG(MFRAG)+1                                       1262.000
C     PEAK I HAS NOW BEEN FULLY CONSIDERED                              1263.000
 1490 JFRAG(I)=-JFRAG(I)                                                1264.000
C     FIND LARGEST PEAK IN CLUSTER NOT YET DEALT WITH                   1265.000
 1500 DO 1520 I=1,NAT                                                   1266.000
      IF(JFRAG(I).EQ.MFRAG)GO TO 1100                                   1267.000
 1520 CONTINUE                                                          1268.000
      IF(LFRAG(MFRAG).GT.1)GO TO 1600                                   1269.000
C     SINGLE PEAKS ARE GIVEN A FRAGMENT NUMBER OF ZERO                  1270.000
      JFRAG(II)=0                                                       1271.000
      MFRAG=MFRAG-1                                                     1272.000
 1600 IF(II-ISTART)1060,1040,1060                                       1273.000
C     INTERPRETATION COMPLETE                                           1274.000
 1620 FOMF=0.0                                                          1275.000
      KKK=0                                                             1276.000
      DO 1640 I=1,NAT                                                   1277.000
      JFRAG(I)=IABS(JFRAG(I))                                           1278.000
      J=JFRAG(I)                                                        1279.000
      IF(J.EQ.0.OR.LFRAG(J).LT.4) GO TO 1640                            1280.000
      FOMF=FOMF+ALOG10(FLOAT(LFRAG(J)))*X(4,I)                          1281.000
      IF(IUSE(I).EQ.0) KKK=1                                            1282.000
 1640 CONTINUE                                                          1283.000
      IF(KKK.EQ.0) FOMF=0.0                                             1284.000
      IF(IUSE(ISTART).EQ.0)IUSE(ISTART)=1                               1285.000
      RETURN                                                            1286.000
      END                                                               1287.000
C     ------------------------------------------------------------------1288.000
C     THIS ROUTINE SHUFFLES FRAGMENTS ACCORDING TO THE BONDINGS         1289.000
C     STORED IN ISYM, ALTERING FRAGMENT NUMBER AS WELL                  1290.000
      SUBROUTINE SHFFLE(MAXFRG)                                         1291.000
      COMMON ISYM(100),INBOND(1000),IFRAG(200),ICON(200),               1292.000
     1 IBOND(2000),JFRAG(200),JCON(200),JBOND(2000),IUSE(200),          1293.000
     2 IONA(6,200),IONP(6,200),MO(200),MU(200),NO(200),NU(200),         1294.000
     3 KEYST(200),LW(200),LR(200),LX(200),JK(200),IK(200),KEY(200),     1295.000
     4 IPL(200),CAN(200),CON(200),LL(200),IA(6,200),LS(200),DUM(14400)  1296.000
      COMMON /ATOMS/ X(4,200),Y(4,400)                                  1297.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     1298.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          1299.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          1300.000
      COMMON /MISC/ CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM                1301.000
      COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN      1302.000
      DIMENSION XTEMP(3),TN(3),IB(3),XS(3),X1(3)                        1303.000
      MAXFRG=0                                                          1304.000
C     CONSIDER EACH SYMM. OP. IN TURN                                   1305.000
      DO 700 K1=1,NN                                                    1306.000
C     OBTAIN PEAKS IN RELEVANT SYMM OPS AND CLUSTER                     1307.000
      ITEMP=ISYM(K1)/250000                                             1308.000
      IF (ITEMP.NE.NOFRAG) GOTO 700                                     1309.000
      I1=MOD(ISYM(K1),250000)/500                                       1310.000
      I2=MOD(ISYM(K1),500)                                              1311.000
C     IF SAME FRAGMENT, DISREGARD SYMM. OP.                             1312.000
      IF(JFRAG(I1).EQ.JFRAG(I2)) GOTO 700                               1313.000
C     DETERMINE WHICH FRAGMENT TO MOVE, AND OBTAIN CORRECT              1314.000
C     SYMMETRY OPERATION TO DO SO,ACCOUNTING FOR SINGLE PEAKS.          1315.000
  100 JI1=JFRAG(I1)                                                     1316.000
      JI2=JFRAG(I2)                                                     1317.000
      IF (JI1.EQ.0) GOTO 150                                            1318.000
      IF (JI2.EQ.0) GOTO 200                                            1319.000
      IF(LFRAG(JI1).GE.LFRAG(JI2)) GOTO 200                             1320.000
  150 IAT=I1                                                            1321.000
      IOTHER=I2                                                         1322.000
      GOTO 300                                                          1323.000
  200 IAT=I2                                                            1324.000
      IOTHER=I1                                                         1325.000
  300 JIAT=JFRAG(IAT)                                                   1326.000
      JOTHER=JFRAG(IOTHER)                                              1327.000
C     IDENTIFY ALL PEAKS IN FRAGMENT TO BE MOVED, AND MOVE THEM         1328.000
      DO 345 K=1,NSYM                                                   1329.000
      IF(JSYMM(IOTHER,IAT,K,IB,XS,X1).NE.0) GO TO 345                   1330.000
      IF (QUAD(X1,X1,T).LE.DMAX) GOTO 347                               1331.000
  345 CONTINUE                                                          1332.000
  347 DO 350 L=1,3                                                      1333.000
      X(L,IAT)=XS(L)                                                    1334.000
      TN(L)=FLOAT(IB(L)-5)                                              1335.000
  350 CONTINUE                                                          1336.000
      JFRAG(IAT)=JOTHER                                                 1337.000
      IF (JIAT.EQ.0) GOTO 520                                           1338.000
      DO 500 K2=1,NAT                                                   1339.000
      IF (JFRAG(K2).NE.JIAT) GOTO 500                                   1340.000
      CALL OPER(K,XTEMP,X(1,K2),X(2,K2),X(3,K2))                        1341.000
      DO 450 K5=1,3                                                     1342.000
      X(K5,K2)=XTEMP(K5)+TN(K5)                                         1343.000
  450 CONTINUE                                                          1344.000
      JFRAG(K2)=JOTHER                                                  1345.000
  500 CONTINUE                                                          1346.000
C     CORRECT LFRAG ARRAY                                               1347.000
      LFRAG(JOTHER)=LFRAG(JOTHER)+LFRAG(JIAT)                           1348.000
      LFRAG(JIAT)=0                                                     1349.000
      GOTO 550                                                          1350.000
  520 LFRAG(JOTHER)=LFRAG(JOTHER)+1                                     1351.000
  550 IF (LFRAG(JOTHER).GT.MAXFRG) MAXFRG=LFRAG(JOTHER)                 1352.000
C     CLOSE UP LFRAG & JFRAG ARRAYS                                     1353.000
      IF (JIAT.EQ.0) GOTO 700                                           1354.000
      MFRAG=MFRAG-1                                                     1355.000
      DO 620 K7=1,MFRAG                                                 1356.000
      IF (LFRAG(K7).NE.0) GOTO 620                                      1357.000
      LFRAG(K7)=LFRAG(K7+1)                                             1358.000
      LFRAG(K7+1)=0                                                     1359.000
  620 CONTINUE                                                          1360.000
      DO 650 K8=1,NAT                                                   1361.000
      IF (JFRAG(K8).LT.JIAT) GOTO 650                                   1362.000
      JFRAG(K8)=JFRAG(K8)-1                                             1363.000
  650 CONTINUE                                                          1364.000
  700 CONTINUE                                                          1365.000
C     RETURN IF NO SHUFFLING HAS TAKEN PLACE                            1366.000
      IF (MAXFRG.EQ.0) RETURN                                           1367.000
C     PUTS IFRAG -VE FOR ALL PEAKS IN CLUSTERS OTHER THAN NOFRAG,       1368.000
C     ZEROS IFRAG FOR MOVABLE PEAKS, AND PUTS IFRAG                     1369.000
C     EQUAL TO -1000 FOR THE LARGEST COMBINED FRAGMENT.                 1370.000
      DO 900 LOOP=1,MFRAG                                               1371.000
      IF (LFRAG(LOOP).NE.MAXFRG) GOTO 900                               1372.000
      GOTO 1000                                                         1373.000
  900 CONTINUE                                                          1374.000
 1000 JCOMB=LOOP                                                        1375.000
      DO 1300 LOOP=1,NAT                                                1376.000
      IF (IFRAG(LOOP).EQ.NOFRAG) GOTO 1100                              1377.000
      IFRAG(LOOP)=-IFRAG(LOOP)                                          1378.000
      GOTO 1300                                                         1379.000
 1100 IF (JFRAG(LOOP).EQ.JCOMB) GOTO 1200                               1380.000
      IFRAG(LOOP)=0                                                     1381.000
      GOTO 1300                                                         1382.000
 1200 IFRAG(LOOP)=-1000                                                 1383.000
 1300 CONTINUE                                                          1384.000
      RETURN                                                            1385.000
      END                                                               1386.000
C     ------------------------------------------------------------------1387.000
      SUBROUTINE COMPAR(NSEQ,NAFRG,KMATCH)                              1388.000
      COMMON ISYM(100),INBOND(1000),IFRAG(200),ICON(200),               1389.000
     1 IBOND(2000),JFRAG(200),JCON(200),JBOND(2000),IUSE(200),          1390.000
     2 IONA(6,200),IONP(6,200),MO(200),MU(200),NO(200),NU(200),         1391.000
     3 KEYST(200),LW(200),LR(200),LX(200),JK(200),IK(200),KEY(200),     1392.000
     4 IPL(200),CAN(200),CON(200),LL(200),IA(6,200),LS(200),DUM(14400)  1393.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     1394.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          1395.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          1396.000
      COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN      1397.000
      DIMENSION NAFRG(5), KMATCH(20)                                    1398.000
      DO 2000 MOFRAG=1,MFRAG                                            1399.000
      KMATCH(MOFRAG)=0                                                  1400.000
      IF(LFRAG(MOFRAG).LT.5) GO TO 2000                                 1401.000
      M=0                                                               1402.000
      DO 100 I=1,NAT                                                    1403.000
      NU(I)=0                                                           1404.000
      IF(JFRAG(I).NE.MOFRAG) GO TO 100                                  1405.000
      M=M+1                                                             1406.000
      NO(M)=I                                                           1407.000
      NU(I)=M                                                           1408.000
  100 CONTINUE                                                          1409.000
      DO 150 I=1,NAT                                                    1410.000
      IF(NU(I).EQ.0) GO TO 150                                          1411.000
      KEYST(I)=0                                                        1412.000
      M=NU(I)                                                           1413.000
      DO 130 J=1,6                                                      1414.000
      IONP(J,M)=0                                                       1415.000
  130 CONTINUE                                                          1416.000
      K=0                                                               1417.000
      KS=ICON(I)+1                                                      1418.000
      KL=ICON(I+1)                                                      1419.000
      DO 140 J=KS,KL                                                    1420.000
      MC=JBOND(J)/8192                                                  1421.000
      IF(MC.LE.0) GO TO 140                                             1422.000
      K=K+1                                                             1423.000
      IONP(K,M)=NU(MC)                                                  1424.000
  140 CONTINUE                                                          1425.000
  150 CONTINUE                                                          1426.000
      CALL CANON(M,MR)                                                  1427.000
      KM=0                                                              1428.000
      DO 200 I=1,M                                                      1429.000
      K=NU(I)                                                           1430.000
      MU(K)=NO(I)                                                       1431.000
      LW(I)=LX(I)                                                       1432.000
      IF(I.LE.6.OR.I.LE.MR) KM=KM+LW(I)                                 1433.000
      DO 190 J=1,6                                                      1434.000
      IONA(J,I)=IONP(J,I)                                               1435.000
  190 CONTINUE                                                          1436.000
  200 CONTINUE                                                          1437.000
      NADR=0                                                            1438.000
      MSTOR=1                                                           1439.000
      MERIT=1                                                           1440.000
      DO 1800 NX=1,NSEQ                                                 1441.000
      N=NAFRG(NX)                                                       1442.000
      DO 350 I=1,N                                                      1443.000
      LL(I)=0                                                           1444.000
      DO 340 J=1,6                                                      1445.000
      IONP(J,I)=0                                                       1446.000
  340 CONTINUE                                                          1447.000
  350 CONTINUE                                                          1448.000
  360 NADR=NADR+1                                                       1449.000
      IF(INBOND(NADR).LT.(-999)) GO TO 370                              1450.000
      I=INBOND(NADR)/512                                                1451.000
      J=MOD(INBOND(NADR),512)                                           1452.000
      K=LL(I)+1                                                         1453.000
      IONP(K,I)=J                                                       1454.000
      LL(I)=K                                                           1455.000
      K=LL(J)+1                                                         1456.000
      IONP(K,J)=I                                                       1457.000
      LL(J)=K                                                           1458.000
      GO TO 360                                                         1459.000
  370 CALL CANON(N,NR)                                                  1460.000
      KN=0                                                              1461.000
      DO 410 I=1,N                                                      1462.000
      IF(I.LE.6.OR.I.LE.NR) KN=KN+LX(I)                                 1463.000
  410 CONTINUE                                                          1464.000
      IF(KN.GE.KM) CALL TELL(N,NR,M,MR,MERIT,1,IONA,IONP,LW)            1465.000
      IF(KN.LT.KM) CALL TELL(M,MR,N,NR,MERIT,2,IONP,IONA,LX)            1466.000
      IF(MERIT.LE.MSTOR) GO TO 1800                                     1467.000
      MSTOR=MERIT+1                                                     1468.000
      DO 450 I=1,N                                                      1469.000
      K=NU(I)                                                           1470.000
      NO(K)=I                                                           1471.000
  450 CONTINUE                                                          1472.000
      DO 500 I=1,NAT                                                    1473.000
      IF(JFRAG(I).EQ.MOFRAG) KEYST(I)=0                                 1474.000
  500 CONTINUE                                                          1475.000
      DO 1700 I=1,M                                                     1476.000
      IF(MO(I).EQ.0) GO TO 1700                                         1477.000
      K=MO(I)                                                           1478.000
      J=MU(I)                                                           1479.000
      KEYST(J)=NO(K)                                                    1480.000
 1700 CONTINUE                                                          1481.000
      KMATCH(MOFRAG)=NX                                                 1482.000
 1800 CONTINUE                                                          1483.000
 2000 CONTINUE                                                          1484.000
      RETURN                                                            1485.000
      END                                                               1486.000
C     ------------------------------------------------------------------1487.000
C     PLOT PROJECTION OF CLUSTER FOUND ONTO LEAST SQUARES PLANE         1488.000
C     PLOT ALSO AN ORTHOGONAL  PROJECTION IF THE ATOMIC OVERLAP IS LARGE1489.000
      SUBROUTINE PICTUR(NPROJ,XA,XB,KUSER1)                             1490.000
      COMMON ISYM(100),INBOND(1000),IFRAG(200),ICON(200),               1491.000
     1 IBOND(2000),JFRAG(200),JCON(200),JBOND(2000),IUSE(200),          1492.000
     2 IONA(6,200),IONP(6,200),MO(200),MU(200),NO(200),NU(200),         1493.000
     3 KEYST(200),LW(200),LR(200),LX(200),JK(200),IK(200),KEY(200),     1494.000
     4 IPL(200),CAN(200),CON(200),LL(200),IA(6,200),LS(200),DUM(14400)  1495.000
      CHARACTER*4 ITLE(18)                                              1496.000
      COMMON /TITLE/ ITLE                                               1497.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     1498.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          1499.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          1500.000
      COMMON /MISC/ CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM                1501.000
      COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN      1502.000
      COMMON /ATOMS/ X(4,200),Y(4,400)                                  1503.000
      DIMENSION IFMT(120), XA(3,KUSER1), XB(4,KUSER1),                  1504.000
     1  B(3,3), V(3,3), IND(3), SUM(3), XMAX(3), XMIN(3)                1505.000
      DATA IFMT(1)/4H(1H+/,IFMT(2)/1H,/,IBLANK/3H1X,/,IEND/3HI3)/       1506.000
C     DO NOT OUTPUT PICTURES WITH LESS THAN 8 PEAKS                     1507.000
      NUM = KFRAG(NOFRAG)                                               1508.000
   10 IF (NUM .LT. 8) RETURN                                            1509.000
      ANUM = NUM                                                        1510.000
C     SET UP ORTHOGONALISATION MATRIX                                   1511.000
      COSW=(COS(DTOR*CELL(5))-COS(DTOR*CELL(6))*COS(DTOR*CELL(4)))/(SIN(1512.000
     1DTOR*CELL(6))*SIN(DTOR*CELL(4)))                                  1513.000
      SINW=SQRT(1.0-COSW**2)                                            1514.000
      A11=CELL(1)*SINW*SIN(DTOR*CELL(6))                                1515.000
      A21=CELL(1)*COS(DTOR*CELL(6))                                     1516.000
      A22=CELL(2)                                                       1517.000
      A23=CELL(3)*COS(DTOR*CELL(4))                                     1518.000
      A31=CELL(1)*COSW*SIN(DTOR*CELL(6))                                1519.000
      A33 = CELL(3) * SIN(DTOR*CELL(4))                                 1520.000
C     INITIALISE ARRAYS                                                 1521.000
      DO 1020 J=1,3                                                     1522.000
      SUM(J)=0.0                                                        1523.000
      XMAX(J)=-10000.0                                                  1524.000
      XMIN(J)=10000.0                                                   1525.000
      DO 1000 I=1,3                                                     1526.000
      B(I,J)=0.0                                                        1527.000
 1000 CONTINUE                                                          1528.000
 1020 CONTINUE                                                          1529.000
C     CONVERT PEAK COORDINATES TO AN ORTHOGONAL SYSTEM AND SET UP       1530.000
C     THE MATRIX FOR THE PLANE FITTING CALCULATIONS                     1531.000
      DO 1080 I=1,NAT                                                   1532.000
      IF(IFRAG(I).NE.NOFRAG)GO TO 1080                                  1533.000
      XA(1,I)=X(1,I)*A11                                                1534.000
      XA(2,I)=X(1,I)*A21+X(2,I)*A22+X(3,I)*A23                          1535.000
      XA(3,I)=X(1,I)*A31+X(3,I)*A33                                     1536.000
      DO 1060 J=1,3                                                     1537.000
      SUM(J)=SUM(J)+XA(J,I)                                             1538.000
      DO 1040 K=1,3                                                     1539.000
      B(J,K)=B(J,K)+XA(J,I)*XA(K,I)                                     1540.000
 1040 CONTINUE                                                          1541.000
 1060 CONTINUE                                                          1542.000
 1080 CONTINUE                                                          1543.000
      DO 1120 J=1,3                                                     1544.000
      DO 1100 K=1,3                                                     1545.000
      B(J,K)=B(J,K)-SUM(J)*SUM(K)/ANUM                                  1546.000
 1100 CONTINUE                                                          1547.000
 1120 CONTINUE                                                          1548.000
C     CALCULATE EIGENVECTORS AND EIGENVALUES OF MATRIX                  1549.000
      CALL EIGEN(B,V,IND)                                               1550.000
C     CONVERT COORDINATES TO AXES GIVEN BY EIGENVECTORS                 1551.000
      K=0                                                               1552.000
      DO 1180 I=1,NAT                                                   1553.000
      IF (IFRAG(I).NE.NOFRAG) GOTO 1180                                 1554.000
      K=K+1                                                             1555.000
      XB(4,K)=I                                                         1556.000
      DO 1140 J=1,3                                                     1557.000
      L=IND(J)                                                          1558.000
      XB(J,K)=XA(1,I)*V(1,L)+XA(2,I)*V(2,L)+XA(3,I)*V(3,L)              1559.000
      XMAX(J)=AMAX1(XMAX(J),XB(J,K))                                    1560.000
      XMIN(J)=AMIN1(XMIN(J),XB(J,K))                                    1561.000
 1140 CONTINUE                                                          1562.000
 1180 CONTINUE                                                          1563.000
      NNN = 0                                                           1564.000
      N1 = 2                                                            1565.000
      N2 = 1                                                            1566.000
      IF (115.0/(XMAX(1)-XMIN(1)) .GE. 2.0/0.254) GO TO 1190            1567.000
      N1 = 1                                                            1568.000
      N2 = 2                                                            1569.000
C     CALCULATE SCALE FACTOR TO FILL PAGE OR GIVE 2.5 CMS/A             1570.000
 1190 AMAX = AMAX1(XMAX(N2)-XMIN(N2), XMAX(N2+1)-XMIN(N2+1))            1571.000
      SCALE = AMIN1(115.0/AMAX, 2.5/0.254)                              1572.000
      SCL = 0.254 * SCALE                                               1573.000
C     SORT PEAKS IN ORDER OF PLOTTING                                   1574.000
 1200 CALL SORT(XB,KUSER1,NUM,N1)                                       1575.000
C     OUTPUT HEADING AND PLOT PEAKS                                     1576.000
 1210 NNN = NNN + 1                                                     1577.000
      WRITE (LT,1220) ITLE,NUMSET,NOFRAG                                1578.000
 1220 FORMAT(//1X,119(1H+)//5X,18A4,13X,7HSET NO.,I3,5X,8H CLUSTER,I3)  1579.000
      GO TO(1240,1280,1320),NNN                                         1580.000
 1240 WRITE(LT,1260)SCL                                                 1581.000
 1260 FORMAT(/27X,36HPLOT OF PEAKS ON LEAST SQUARES PLANE,10X,8HSCALE  =1582.000
     1,F6.2,7H  CMS/A/////)                                             1583.000
      GO TO 1360                                                        1584.000
 1280 WRITE(LT,1300)SCL                                                 1585.000
 1300 FORMAT(/11X,66HPLOT OF PEAKS ON PLANE ORTHOGONAL TO LEAST AND MOST1586.000
     1 SQUARES PLANES,10X,8HSCALE  =,F6.2,7H  CMS/A/////)               1587.000
      GO TO 1360                                                        1588.000
 1320 WRITE(LT,1340)SCL                                                 1589.000
 1340 FORMAT(/27X,35HPLOT OF PEAKS ON MOST SQUARES PLANE,10X,8HSCALE  =,1590.000
     1F6.2,7H  CMS/A/////)                                              1591.000
 1360 IX=0                                                              1592.000
      OFFSET = 0.5 * (115.0 - (XMAX(N2) - XMIN(N2)) * SCALE) + 1.5      1593.000
      DO 1460 I=1,NUM                                                   1594.000
      IXREL = 0.1 * ALN * SCALE * (XMAX(N1)-XB(N1,I)) - FLOAT(IX) + 0.5 1595.000
      IF(IXREL.LE.0)GO TO 1420                                          1596.000
      DO 1400 J=1,IXREL                                                 1597.000
      WRITE(LT,1380)                                                    1598.000
 1380 FORMAT(1X)                                                        1599.000
 1400 CONTINUE                                                          1600.000
 1420 IX=IX+IXREL                                                       1601.000
      IY=SCALE*(XB(N2,I)-XMIN(N2))+OFFSET                               1602.000
      DO 1440 J=1,IY                                                    1603.000
      IFMT(J+2)=IBLANK                                                  1604.000
 1440 CONTINUE                                                          1605.000
      IFMT(IY+3)=IEND                                                   1606.000
      K=XB(4,I)+0.5                                                     1607.000
      WRITE(LT,IFMT)K                                                   1608.000
 1460 CONTINUE                                                          1609.000
C     TEST FOR PLOTTING OF NEXT PROJECTION                              1610.000
      IF (NPROJ .GT. NNN) GO TO 1500                                    1611.000
      IF (NPROJ .GT. 0 .OR. NNN .GE. 2) GO TO 1600                      1612.000
      NTEMP = 4-NNN                                                     1613.000
      IND1 = IND(NTEMP)                                                 1614.000
      IND2 = IND(NTEMP-1)                                               1615.000
      IF (B(IND2,IND2) .GT. 2.0*B(IND1,IND1)) GO TO 1600                1616.000
 1500 IF (NNN .EQ. 2) GO TO 1540                                        1617.000
      IF (N1 .EQ. 2) GO TO 1560                                         1618.000
      N2 = 3                                                            1619.000
      GO TO 1210                                                        1620.000
 1540 N2 = 2                                                            1621.000
      IF (N1 .EQ. 3) GO TO 1210                                         1622.000
 1560 N1 = 3                                                            1623.000
      GO TO 1200                                                        1624.000
 1600 RETURN                                                            1625.000
      END                                                               1626.000
C     ------------------------------------------------------------------1627.000
      SUBROUTINE OUTERP(ISTART,KMATCH,FOMF)                             1628.000
      COMMON ISYM(100),INBOND(1000),IFRAG(200),ICON(200),               1629.000
     1 IBOND(2000),JFRAG(200),JCON(200),JBOND(2000),IUSE(200),          1630.000
     2 IONA(6,200),IONP(6,200),MO(200),MU(200),NO(200),NU(200),         1631.000
     3 KEYST(200),LW(200),LR(200),LX(200),JK(200),IK(200),KEY(200),     1632.000
     4 IPL(200),CAN(200),CON(200),LL(200),IA(6,200),LS(200),DUM(14400)  1633.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     1634.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          1635.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          1636.000
      COMMON /MISC/ CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM                1637.000
      COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN      1638.000
      COMMON /ATOMS/ X(4,200),Y(4,400)                                  1639.000
      DIMENSION ICH(10), KMATCH(20)                                     1640.000
      DATA IBL/1H /,ISK/1H*/,ICY/1HY/                                   1641.000
      DATA ICH/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/                 1642.000
C     DECIDE IF SET IS WORTH PRINTING                                   1643.000
      ISTART=-ISTART                                                    1644.000
      FOMM=0.0                                                          1645.000
      DO 200 I=1,NAT                                                    1646.000
      J=JFRAG(I)                                                        1647.000
      IF(J.EQ.0.OR.LFRAG(J).LT.4.OR.KEYST(I).LE.0) GO TO 200            1648.000
      FOMM=FOMM+ALOG10(FLOAT(LFRAG(J)))*X(4,I)*FLOAT(IWT)               1649.000
  200 CONTINUE                                                          1650.000
      IDR=0                                                             1651.000
      IF(FOMM.GT.FOMF) IDR=1                                            1652.000
      IF(FOM.GE.FOMM.AND.FOM.GE.FOMF) RETURN                            1653.000
      FOM=AMAX1(FOMM,FOMF)                                              1654.000
      DO 240 I=1,NAT                                                    1655.000
      IF(IFRAG(I).NE.NOFRAG) GO TO 240                                  1656.000
      IUSE(I)=IABS(IUSE(I))                                             1657.000
      IF(JCON(I).LE.0) GO TO 240                                        1658.000
      J=JFRAG(I)                                                        1659.000
      IF(LFRAG(J).LT.4) GO TO 240                                       1660.000
      IF(IDR.EQ.0) IUSE(I)=-1                                           1661.000
      IF(IDR.EQ.1.AND.KEYST(I).GT.0) IUSE(I)=-1                         1662.000
  240 CONTINUE                                                          1663.000
      ISTART=-ISTART                                                    1664.000
      WRITE(LT,245)                                                     1665.000
  245 FORMAT(//1H ,119(1H-))                                            1666.000
C     OUTPUT FRAGMENT COMPARISON RESULTS                                1667.000
      IF(MFRN.EQ.0) GO TO 290                                           1668.000
      DO 270 K=1,MFRAG                                                  1669.000
      IF(LFRAG(K).LT.5) GO TO 270                                       1670.000
      NID=0                                                             1671.000
      DO 250 I=1,NAT                                                    1672.000
      IF(JFRAG(I).NE.K.OR.KEYST(I).LE.0) GO TO 250                      1673.000
      NID=NID+1                                                         1674.000
      IONP(1,NID)=I                                                     1675.000
      IONP(2,NID)=KEYST(I)                                              1676.000
  250 CONTINUE                                                          1677.000
      IF(NID.GT.0) WRITE(LT,260) NID,K,KMATCH(K),((IONP(I,J),I=1,2),    1678.000
     1 J=1,NID)                                                         1679.000
  260 FORMAT(/1H0,24X,I5,3X,17HPEAKS OF FRAGMENT,I5,3X,                 1680.000
     1 34HMATCH WITH ATOMS OF INPUT MOLECULE,I5/                        1681.000
     2 1H0,35X,24HPEAK-ATOM CORRESPONDENCE//(10(I6,2H -,I4)))           1682.000
  270 CONTINUE                                                          1683.000
C     DETERMINE RING STRUCTURE                                          1684.000
  290 DO 300 I=1,NAT                                                    1685.000
      IK(I)=JCON(I)                                                     1686.000
      IF(JCON(I).GT.0) LAST=I                                           1687.000
  300 CONTINUE                                                          1688.000
  400 NST=0                                                             1689.000
      DO 500 I=1,NAT                                                    1690.000
      IF(IK(I).NE.1) GO TO 500                                          1691.000
      NST=1                                                             1692.000
      IK(I)=0                                                           1693.000
      KS=ICON(I)+1                                                      1694.000
      KL=ICON(I+1)                                                      1695.000
      DO 450 J=KS,KL                                                    1696.000
      K=JBOND(J)/8192                                                   1697.000
      IF(K.LE.0) GO TO 450                                              1698.000
      IF(IK(K).GE.1) IK(K)=IK(K)-1                                      1699.000
  450 CONTINUE                                                          1700.000
  500 CONTINUE                                                          1701.000
      IF(NST.EQ.1) GO TO 400                                            1702.000
      WRITE(LT,650) NOFRAG,ISTART                                       1703.000
  650 FORMAT(//5X,25HINTERPRETATION OF CLUSTER,I3,27H  STARTING WITH PEA1704.000
     1K NUMBER,I3)                                                      1705.000
      LMAX=0                                                            1706.000
      M=0                                                               1707.000
      DO 1500 I=1,NAT                                                   1708.000
      IF(JCON(I).LE.0) GO TO 1500                                       1709.000
      M=M+1                                                             1710.000
      LW(M+30)=I                                                        1711.000
      IF(M.EQ.25.OR.I.EQ.LAST) WRITE(LT,700) (LW(K+30),K=1,M)           1712.000
  700 FORMAT(/1H0,4HPEAK,8X,25I4)                                       1713.000
      K=ICON(I)                                                         1714.000
      KL=ICON(I+1)                                                      1715.000
      DO 800 J=1,6                                                      1716.000
      MX=M+30*(J-1)                                                     1717.000
      LR(MX)=IBL                                                        1718.000
      LL(MX)=IBL                                                        1719.000
      LX(MX)=IBL                                                        1720.000
  740 K=K+1                                                             1721.000
      IF(K.GT.KL) GO TO 750                                             1722.000
      IF(JBOND(K).LE.0) GO TO 740                                       1723.000
      LMAX=MAX0(J,LMAX)                                                 1724.000
      JBS=JBOND(K)/8192                                                 1725.000
      JJ=JBS/100                                                        1726.000
      IF(JJ.GT.0) LR(MX)=ICH(JJ+1)                                      1727.000
      JJ=JBS/10-JJ*10                                                   1728.000
      IF(JBS.GE.10) LL(MX)=ICH(JJ+1)                                    1729.000
      JJ=MOD(JBS,10)                                                    1730.000
      LX(MX)=ICH(JJ+1)                                                  1731.000
  750 IF(LMAX.LT.J) GO TO 800                                           1732.000
      MJ=30*(J-1)+1                                                     1733.000
      IF(M.EQ.25.OR.I.EQ.LAST) WRITE(LT,770) (LR(L),LL(L),LX(L),L=MJ,MX)1734.000
  770 FORMAT(1H ,8HBONDS TO,4X,25(1X,3A1))                              1735.000
  800 CONTINUE                                                          1736.000
      LW(M)=JFRAG(I)                                                    1737.000
      JK(M)=IBL                                                         1738.000
      IF(IK(I).GE.2) JK(M)=ISK                                          1739.000
      IF(M.EQ.25.OR.I.EQ.LAST) WRITE(LT,840) (JK(K),K=1,M)              1740.000
  840 FORMAT(1H ,4HRING,8X,25(3X,A1))                                   1741.000
      IF(M.EQ.25.OR.I.EQ.LAST) WRITE(LT,850) (LW(K),K=1,M)              1742.000
  850 FORMAT(1H ,8HFRAGMENT,4X,25I4)                                    1743.000
      IF(MFRN.LE.0) GO TO 1490                                          1744.000
      JK(M+30)=IBL                                                      1745.000
      IF(KEYST(I).GT.0) JK(M+30)=ICY                                    1746.000
      IF(M.EQ.25.OR.I.EQ.LAST) WRITE(LT,860) (JK(K+30),K=1,M)           1747.000
  860 FORMAT(1H ,7HMATCHED,5X,25(3X,A1))                                1748.000
 1490 IF(M.NE.25) GO TO 1500                                            1749.000
      M=0                                                               1750.000
      LMAX=1                                                            1751.000
 1500 CONTINUE                                                          1752.000
      WRITE (LT,1580) (LFRAG(I),I=1,MFRAG)                              1753.000
 1580 FORMAT(/4X,33H    NO. OF PEAKS IN EACH FRAGMENT,5X,12I4)          1754.000
      RETURN                                                            1755.000
      END                                                               1756.000
C     ------------------------------------------------------------------1757.000
C     CALCULATE AND OUTPUT PEAK POSITIONS,BOND LENGTHS,AND ANGLES.      1758.000
      SUBROUTINE BONGLE                                                 1759.000
      COMMON ISYM(100),INBOND(1000),IFRAG(200),ICON(200),               1760.000
     1 IBOND(2000),JFRAG(200),JCON(200),JBOND(2000),IUSE(200),          1761.000
     2 IONA(6,200),IONP(6,200),MO(200),MU(200),NO(200),NU(200),         1762.000
     3 KEYST(200),LW(200),LR(200),LX(200),JK(200),IK(200),KEY(200),     1763.000
     4 IPL(200),CAN(200),CON(200),LL(200),IA(6,200),LS(200),DUM(14400)  1764.000
      CHARACTER*4 ITLE(18)                                              1765.000
      CHARACTER*8 XL(200),YL(400)                                       1766.000
      COMMON /NAMES/ XL,YL                                              1767.000
      COMMON /TITLE/ ITLE                                               1768.000
      COMMON /ATOMS/ X(4,200),Y(4,400)                                  1769.000
      COMMON /CENT/ TL(3,4),TS(3,24),FS(3,3,24),MLAT,NEQV               1770.000
      COMMON /CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,     1771.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          1772.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          1773.000
      COMMON /MISC/ CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM                1774.000
      COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN      1775.000
      DIMENSION   IB(3), XS(3), X1(3), X2(3), JFMT(20), ENIL1(4,4),     1776.000
     1 LINE(30), LINE1(4,6), ENIL(30), JBND(30), XSTOR(3)               1777.000
      DATA JFMT(1)/4H(1H+/,  JFMT(2)/4H,56X/, JFMT(3)/4H,   /,          1778.000
     1 JFMT(4)/4H    /,  JFMT(5)/4H    /, JFMT(6)/4H    /,              1779.000
     2 IBLANK/4H4X, /, IEND/4HI4) /                                     1780.000
 1000 FORMAT(1H ,I3,3X,A8,3F10.4)                                       1781.000
 1001 FORMAT(1H+,44X,F12.2)                                             1782.000
C     OUTPUT PEAK HEIGHTS, PEAK COORDINATES AND CLUSTER NUMBERS         1783.000
      WRITE (LT,900) ITLE                                               1784.000
  900 FORMAT(//1X,119(1H+)//1X,18A4,27X,'INTERPRETED PEAK LIST'         1785.000
     1///'  NO   PEAK',10X,'X',9X,'Y',9X,'Z',9X,'HEIGHT',               1786.000
     2 9X, 15H CLUSTER NUMBER/)                                         1787.000
      DO 940 I=1,NAT                                                    1788.000
      ICON(I+1)=0                                                       1789.000
      IFRAG(I)=IABS(IFRAG(I))                                           1790.000
      N=MIN0(IFRAG(I)+1,15)                                             1791.000
      DO 920 J=1,N                                                      1792.000
      JFMT(J+6)=IBLANK                                                  1793.000
  920 CONTINUE                                                          1794.000
      JFMT(N+7)=IEND                                                    1795.000
      WRITE(LT,1000)I,XL(I),(X(J,I),J=1,3)                              1796.000
      IF(X(4,I).LT.9999.)WRITE(LT,1001)X(4,I)                           1797.000
      WRITE(LT,JFMT)IFRAG(I)                                            1798.000
  940 CONTINUE                                                          1799.000
      N = MIN0(NFRAG, 14)                                               1800.000
      WRITE (LT,960) (KFRAG(I),I=1,N)                                   1801.000
      IW=0                                                              1802.000
  960 FORMAT(/19X,38HTOTAL NUMBER OF PEAKS IN EACH CLUSTER ,8X,14I4)    1803.000
      WRITE(LT,1110) ITLE                                               1804.000
 1110 FORMAT(//1X,119(1H+)//1X,18A4,19X,                                1805.000
     1  28HTABLE OF INTERPEAK DISTANCES//1H ,2X,4HFROM,3X,7HTO DIST)    1806.000
      ICON(1)=0                                                         1807.000
      DO 1115 I=1,MCON                                                  1808.000
      II=IBOND(I)/4194304                                               1809.000
      ICON(II+1)=I                                                      1810.000
 1115 CONTINUE                                                          1811.000
      DO 1260 I=1,NAT                                                   1812.000
      IF(ICON(I+1).EQ.0) ICON(I+1)=ICON(I)                              1813.000
      N=0                                                               1814.000
      JUMP=0                                                            1815.000
      DO 1220 J=1,NAT                                                   1816.000
      IF(J.EQ.I) GO TO 1170                                             1817.000
      DO 1120 K=1,3                                                     1818.000
      X1(K)=X(K,I)-X(K,J)                                               1819.000
      IF(ABS(X1(K)).GT.DXMAX(K)) GO TO 1170                             1820.000
 1120 CONTINUE                                                          1821.000
      DIST=QUAD(X1,X1,T)                                                1822.000
      IF(DIST.GT.DMUT) GO TO 1170                                       1823.000
      N=N+1                                                             1824.000
      JBND(N)=J                                                         1825.000
      ENIL(N)=SQRT(DIST)                                                1826.000
 1170 IF(N.LT.10.AND.J.NE.NAT) GO TO 1220                               1827.000
      IF(JUMP.EQ.0.AND.N.GT.0) WRITE(LT,1190) I,(JBND(L),ENIL(L),L=1,N) 1828.000
 1190 FORMAT(1H ,I5,10(I6,F5.2))                                        1829.000
      IF(JUMP.NE.0.AND.N.GT.0) WRITE(LT,1210) (JBND(L),ENIL(L),L=1,N)   1830.000
 1210 FORMAT(1H ,5X,10(I6,F5.2))                                        1831.000
      N=0                                                               1832.000
      JUMP=1                                                            1833.000
 1220 CONTINUE                                                          1834.000
 1260 CONTINUE                                                          1835.000
      DMX=SQRT(DMAX)                                                    1836.000
      WRITE(LT,1300) DMX                                                1837.000
 1300 FORMAT( ///16X,81HTABLE OF BOND ANGLES (IN DEGREES) AMONG PEAKS IN1838.000
     1 ABOVE TABLE CLOSER TOGETHER THAN,F5.2,1HA/)                      1839.000
      N=0                                                               1840.000
      RTOD=1.0/DTOR                                                     1841.000
      DO 1500 I=1,NAT                                                   1842.000
      KS=ICON(I)+1                                                      1843.000
      KL=ICON(I+1)                                                      1844.000
      IF(KS.GE.KL) GO TO 1500                                           1845.000
      KLM1=KL-1                                                         1846.000
      DO 1490 J=KS,KLM1                                                 1847.000
      V1=0.001*FLOAT(MOD(IBOND(J),8192))                                1848.000
      IF(V1.GT.DMX.OR.V1.LT.0.2) GO TO 1490                             1849.000
      JJ=IBOND(J)/8192                                                  1850.000
      JJ=MOD(JJ,512)                                                    1851.000
      JP1=J+1                                                           1852.000
      DO 1480 K=JP1,KL                                                  1853.000
      V2=0.001*FLOAT(MOD(IBOND(K),8192))                                1854.000
      IF(V2.GT.DMX.OR.V2.LT.0.2) GO TO 1480                             1855.000
      KK=IBOND(K)/8192                                                  1856.000
      KK=MOD(KK,512)                                                    1857.000
      DO 1430 L=1,3                                                     1858.000
      X1(L)=X(L,KK)-X(L,JJ)                                             1859.000
 1430 CONTINUE                                                          1860.000
      DIST=QUAD(X1,X1,T)                                                1861.000
      IF(DIST.LT.0.2) GO TO 1480                                        1862.000
      COSA=0.5*(V1*V1+V2*V2-DIST)/(V1*V2)                               1863.000
      SINA=SQRT(AMAX1(1.0-COSA*COSA,0.001))                             1864.000
      N=N+1                                                             1865.000
      LINE1(1,N)=JJ                                                     1866.000
      LINE1(2,N)=I                                                      1867.000
      LINE1(3,N)=KK                                                     1868.000
      LINE1(4,N)=AMOD(ATAN2(SINA,COSA)*RTOD+180.0,180.0)+0.5            1869.000
      IF(N.LT.6) GO TO 1480                                             1870.000
      WRITE(LT,1470) ((LINE1(L,N),L=1,4),N=1,6)                         1871.000
 1470 FORMAT(6(I6,2H -,I3,2H -,I3,I4))                                  1872.000
      N=0                                                               1873.000
 1480 CONTINUE                                                          1874.000
 1490 CONTINUE                                                          1875.000
 1500 CONTINUE                                                          1876.000
      IF(N.NE.0) WRITE(LT,1470) ((LINE1(L,J),L=1,4),J=1,N)              1877.000
      N = -1                                                            1878.000
      NATM1=NAT-1                                                       1879.000
      DO 1800 I=1,NATM1                                                 1880.000
      DO 1780 J=I,NAT                                                   1881.000
      DO 1740 K=1,NSYM                                                  1882.000
      IF(I.EQ.J.AND.K.EQ.1) GO TO 1740                                  1883.000
      IF(JSYMM(I,J,K,IB,XS,X1).NE.0) GO TO 1740                         1884.000
      IBJ=100*IB(1)+10*IB(2)+IB(3)                                      1885.000
      IF(IBJ.EQ.555.AND.K.EQ.1) GO TO 1740                              1886.000
      DIST=QUAD(X1,X1,T)                                                1887.000
      IF(DIST.GT.DMUT) GO TO 1740                                       1888.000
      IF(DIST.LT.0.2.AND.I.EQ.J) ICON(I)=10000                          1889.000
      ISIM=MOD(K,NEQV)                                                  1890.000
      IF(ISIM.EQ.0) ISIM=NEQV                                           1891.000
      IP=(K-1)/NEQV                                                     1892.000
      ILAT=MOD(IP,MLAT)+1                                               1893.000
      IF(IP.GE.MLAT) ISIM=-ISIM                                         1894.000
      N=N+1                                                             1895.000
      IF (N.EQ.0) WRITE(LT,1550)                                        1896.000
 1550 FORMAT(//33X,53HDISTANCES BETWEEN ATOMS IN DIFFERENT ASYMMETRIC UN1897.000
     1ITS//3(5X,35HFROM   TO SYMM  X    Y    Z    DIST))                1898.000
      IF (N.EQ.0) N = 1                                                 1899.000
      LINE1(N,1)=I                                                      1900.000
      LINE1(N,2)=J                                                      1901.000
      LINE1(N,3)=ISIM                                                   1902.000
      ENIL1(N,1)=FLOAT(IB(1))+TL(1,ILAT)-5.0                            1903.000
      ENIL1(N,2)=FLOAT(IB(2))+TL(2,ILAT)-5.0                            1904.000
      ENIL1(N,3)=FLOAT(IB(3))+TL(3,ILAT)-5.0                            1905.000
      ENIL1(N,4)=SQRT(DIST)                                             1906.000
      IF(N.LT.3) GO TO 1740                                             1907.000
      WRITE(LT,1710) ((LINE1(N,L),L=1,3),(ENIL1(N,L),L=1,4),N=1,3)      1908.000
 1710 FORMAT(3(I9,I5,1H(,I3,3F5.2,1H),F6.2))                            1909.000
      N=0                                                               1910.000
 1740 CONTINUE                                                          1911.000
 1780 CONTINUE                                                          1912.000
 1800 CONTINUE                                                          1913.000
      IF(N.GT.0) WRITE(LT,1710) ((LINE1(J,L),L=1,3),                    1914.000
     1  (ENIL1(J,L),L=1,4),J=1,N)                                       1915.000
      DO 1850 I=1,NAT                                                   1916.000
      IF(ICON(I).GT.999) WRITE(LT,1840) I                               1917.000
 1840 FORMAT(/5H PEAK,I4,28H  LIES ON A SYMMETRY ELEMENT/)              1918.000
 1850 CONTINUE                                                          1919.000
      IF(NN.LE.0) GO TO 1900                                            1920.000
      IF(NN.GT.1) CALL ISORT(ISYM,NN)                                   1921.000
      ISYM(NN+1)=0                                                      1922.000
      JJ=0                                                              1923.000
      K=0                                                               1924.000
      DO 1890 I=1,NN                                                    1925.000
      II=ISYM(I)/250000                                                 1926.000
      IF(II.NE.JJ) WRITE(LT,1860) II                                    1927.000
 1860 FORMAT(/9H  CLUSTER,I3,42H  JOINS TO ITSELF THROUGH THE PEAK PAIR(1928.000
     1S))                                                               1929.000
      JJ=II                                                             1930.000
      K=K+2                                                             1931.000
      LW(K-1)=MOD(ISYM(I),250000)/500                                   1932.000
      LW(K)=MOD(ISYM(I),500)                                            1933.000
      IF(K.LT.12.AND.II.EQ.ISYM(I+1)/250000) GO TO 1890                 1934.000
      WRITE(LT,1870) (LW(J),J=1,K)                                      1935.000
 1870 FORMAT(1H+,53X,6(I7,1H,,I3)/)                                     1936.000
      K=0                                                               1937.000
 1890 CONTINUE                                                          1938.000
 1900 RETURN                                                            1939.000
      END                                                               1940.000
C     ------------------------------------------------------------------1941.000
C     RETRIEVE CENTRING TRANSLATIONS                                    1942.000
      SUBROUTINE CENTRE(J,L)                                            1943.000
      COMMON /CENT/ TL(3,4),TS(72),FS(216),MLAT,NEQV                    1944.000
      DIMENSION TST(21)                                                 1945.000
      DATA TST/0.,0.,0., 0.,0.5,0.5, 0.5,0.,0.5, 0.5,0.5,0., 0.5,0.5,0.51946.000
     1 , 0.333333,0.666667,0.666667, 0.666667,0.333333,0.333333/        1947.000
      MLAT=J                                                            1948.000
      M=3*L-2                                                           1949.000
      TL(1,J)=TST(M)                                                    1950.000
      TL(2,J)=TST(M+1)                                                  1951.000
      TL(3,J)=TST(M+2)                                                  1952.000
      RETURN                                                            1953.000
      END                                                               1954.000
C     ------------------------------------------------------------------1955.000
C     COMPUTE EIGENVECTORS AND EIGENVALUES OF REAL SYMMETRIC MATRIX     1956.000
      SUBROUTINE EIGEN(B,V,IND)                                         1957.000
      DIMENSION B(3,3),V(3,3),IND(3)                                    1958.000
      DO 1020 I=1,3                                                     1959.000
      DO 1000 J=1,3                                                     1960.000
      V(I,J)=0.0                                                        1961.000
 1000 CONTINUE                                                          1962.000
      V(I,I)=1.0                                                        1963.000
 1020 CONTINUE                                                          1964.000
 1040 KNT=0                                                             1965.000
      IND1=1                                                            1966.000
      IND3=1                                                            1967.000
      DO 1500 I=1,2                                                     1968.000
      IP1=I+1                                                           1969.000
      DO 1460 J=IP1,3                                                   1970.000
      IF (ABS(B(I,J)) .LT. 0.000001 * B(IND1,IND1)) KNT = KNT + 1       1971.000
      BIJ=B(I,I)-B(J,J)                                                 1972.000
      IF(ABS(B(I,J)).LT.ABS(BIJ))GO TO 1100                             1973.000
      T=SIGN(1.0,B(I,J)*BIJ)                                            1974.000
      GO TO 1180                                                        1975.000
 1100 T=B(I,J)/BIJ                                                      1976.000
 1180 G=T/(2.0+2.0*T*T)                                                 1977.000
      SN=2.0*G/(1.0+G*G)                                                1978.000
      CS=1.0-G*SN                                                       1979.000
      DO 1200 K=1,3                                                     1980.000
      BIK=B(I,K)                                                        1981.000
      B(I,K)=CS*B(I,K)+SN*B(J,K)                                        1982.000
      B(J,K)=CS*B(J,K)-SN*BIK                                           1983.000
 1200 CONTINUE                                                          1984.000
      DO 1220 K=1,3                                                     1985.000
      BKI=B(K,I)                                                        1986.000
      B(K,I)=CS*B(K,I)+SN*B(K,J)                                        1987.000
      B(K,J)=CS*B(K,J)-SN*BKI                                           1988.000
      VKI=V(K,I)                                                        1989.000
      V(K,I)=CS*V(K,I)+SN*V(K,J)                                        1990.000
      V(K,J)=CS*V(K,J)-SN*VKI                                           1991.000
 1220 CONTINUE                                                          1992.000
 1460 CONTINUE                                                          1993.000
      IF(B(IP1,IP1).GT.B(IND1,IND1))IND1=IP1                            1994.000
      IF(B(IND3,IND3).GT.B(IP1,IP1))IND3=IP1                            1995.000
 1500 CONTINUE                                                          1996.000
      IF(KNT.LT.3)GO TO 1040                                            1997.000
      IND(1)=IND1                                                       1998.000
      IND(2)=1                                                          1999.000
      IND(3)=IND3                                                       2000.000
      IF(IND1.EQ.IND(2).OR.IND3.EQ.IND(2))IND(2)=2                      2001.000
      IF(IND1.EQ.IND(2).OR.IND3.EQ.IND(2))IND(2)=3                      2002.000
C     CHECK FOR RIGHT-HANDED SET OF VECTORS                             2003.000
      DET = V(1,1)*(V(2,2)*V(3,3)-V(2,3)*V(3,2))+V(1,2)*(V(2,3)*V(3,1)  2004.000
     1  -V(2,1)*V(3,3))+V(1,3)*(V(2,1)*V(3,2)-V(2,2)*V(3,1))            2005.000
      IF (DET .GT. 0.0) RETURN                                          2006.000
      DO 1520 I=1,3                                                     2007.000
      V(I,3) = -V(I,3)                                                  2008.000
 1520 CONTINUE                                                          2009.000
      RETURN                                                            2010.000
      END                                                               2011.000
C     ------------------------------------------------------------------2012.000
C     SORT PEAKS IN ORDER OF PEAK HEIGHT OR IN ORDER OF PLOTTING        2013.000
      SUBROUTINE SORT(X,KUSER1,NAT,N)                                   2014.000
      DIMENSION X(4,KUSER1),T(4)                                        2015.000
      INT=2                                                             2016.000
 1000 INT=INT+INT                                                       2017.000
      IF(INT.LT.NAT)GO TO 1000                                          2018.000
      INT=MIN0(NAT,(3*INT)/4-1)                                         2019.000
 1020 INT=INT/2                                                         2020.000
      IFIN=NAT-INT                                                      2021.000
      DO 1200 II=1,IFIN                                                 2022.000
      I=II                                                              2023.000
      J=I+INT                                                           2024.000
      IF(X(N,I).GE.X(N,J))GO TO 1200                                    2025.000
      DO 1060 K=1,4                                                     2026.000
      T(K)=X(K,J)                                                       2027.000
 1060 CONTINUE                                                          2028.000
 1080 DO 1100 K=1,4                                                     2029.000
      X(K,J)=X(K,I)                                                     2030.000
 1100 CONTINUE                                                          2031.000
      J=I                                                               2032.000
      I=I-INT                                                           2033.000
      IF(I)1140,1140,1120                                               2034.000
 1120 IF(X(N,I).LT.T(N))GO TO 1080                                      2035.000
 1140 DO 1160 K=1,4                                                     2036.000
      X(K,J)=T(K)                                                       2037.000
 1160 CONTINUE                                                          2038.000
 1200 CONTINUE                                                          2039.000
      IF(INT.NE.1)GO TO 1020                                            2040.000
      RETURN                                                            2041.000
      END                                                               2042.000
C     ------------------------------------------------------------------2043.000
C     GENERAL INTEGER SORT ROUTINE                                      2044.000
      SUBROUTINE ISORT(N,M)                                             2045.000
      DIMENSION N(M)                                                    2046.000
      INT=2                                                             2047.000
 1000 INT=INT+INT                                                       2048.000
      IF(INT.LT.M) GO TO 1000                                           2049.000
      INT=MIN0(M,(3*INT)/4-1)                                           2050.000
 1020 INT=INT/2                                                         2051.000
      IFIN=M-INT                                                        2052.000
      DO 1200 II=1,IFIN                                                 2053.000
      I=II                                                              2054.000
      J=I+INT                                                           2055.000
      IF(N(I).LE.N(J)) GO TO 1200                                       2056.000
      IT=N(J)                                                           2057.000
 1080 N(J)=N(I)                                                         2058.000
      J=I                                                               2059.000
      I=I-INT                                                           2060.000
      IF(I.GT.0.AND.N(I).GT.IT) GO TO 1080                              2061.000
      N(J)=IT                                                           2062.000
 1200 CONTINUE                                                          2063.000
      IF(INT.NE.1) GO TO 1020                                           2064.000
      RETURN                                                            2065.000
      END                                                               2066.000
C     ------------------------------------------------------------------2067.000
C     ELIMINATE THE IITH PEAK AND UPDATE THE BONDING ARRAY              2068.000
      SUBROUTINE ELIM(II,NNN,JCN,JBND,ICN,KUSER1)                       2069.000
      DIMENSION JCN(KUSER1), ICN(KUSER1), JBND(2000)                    2070.000
      JCN(II)=0                                                         2071.000
      NNN=0                                                             2072.000
      KS=ICN(II)+1                                                      2073.000
      KL=ICN(II+1)                                                      2074.000
      IF(KS.GT.KL) RETURN                                               2075.000
      DO 20 I=KS,KL                                                     2076.000
      J=JBND(I)/8192                                                    2077.000
      JCN(J)=JCN(J)-1                                                   2078.000
      JBND(I)=0                                                         2079.000
      KB=ICN(J)+1                                                       2080.000
      KE=ICN(J+1)                                                       2081.000
      IF(KB.GT.KE) GO TO 20                                             2082.000
      DO 10 K=KB,KE                                                     2083.000
      L=JBND(K)/8192                                                    2084.000
      IF(L.EQ.II) JBND(K)=0                                             2085.000
   10 CONTINUE                                                          2086.000
   20 CONTINUE                                                          2087.000
      RETURN                                                            2088.000
      END                                                               2089.000
C     ------------------------------------------------------------------2090.000
C     FUNCTION USED IN THE CALCULATION OF DISTANCES AND ANGLES          2091.000
      FUNCTION QUAD(X1,X2,T)                                            2092.000
      DIMENSION X1(3),X2(3),T(3,3)                                      2093.000
      QUAD=0.0                                                          2094.000
      DO 1000 I=1,3                                                     2095.000
      QUAD = QUAD+X2(I)*(T(I,1)*X1(1)+T(I,2)*X1(2)+T(I,3)*X1(3))        2096.000
 1000 CONTINUE                                                          2097.000
      RETURN                                                            2098.000
      END                                                               2099.000
C     ------------------------------------------------------------------2100.000
C     PERFORM THE KTH SYMMETRY OPERATION ON THE JTH PEAK                2101.000
C     AND MOVE IT AS CLOSE AS POSSIBLE TO PEAK I BY LATTICE TRANSLATIONS2102.000
      FUNCTION JSYMM(I,J,K,IB,XS,X1)                                    2103.000
      COMMON /ATOMS/ X(4,200),Y(4,400)                                  2104.000
      COMMON /MISC/ CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM                2105.000
      DIMENSION IB(3),XS(3),X1(3)                                       2106.000
      JSYMM = 0                                                         2107.000
      CALL OPER(K,XS,X(1,J),X(2,J),X(3,J))                              2108.000
      DO 1080 L=1,3                                                     2109.000
      IB(L)=5                                                           2110.000
 1060 X1(L)=X(L,I)-XS(L)                                                2111.000
      IF(ABS(X1(L)).LE.0.5)GO TO 1070                                   2112.000
      XS(L)=XS(L)+SIGN(1.0,X1(L))                                       2113.000
      IB(L)=IB(L)+ISIGN(1,IFIX(2.0*X1(L)))                              2114.000
      GO TO 1060                                                        2115.000
 1070 IF (ABS(X1(L)) .GT. DXMAX(L)) GO TO 1100                          2116.000
 1080 CONTINUE                                                          2117.000
      RETURN                                                            2118.000
 1100 JSYMM = 1                                                         2119.000
      RETURN                                                            2120.000
      END                                                               2121.000
C     ------------------------------------------------------------------2122.000
C     APPLY J'TH SYMMETRY ELEMENT TO X,Y,Z & PUT RESULT IN XN           2123.000
      SUBROUTINE OPER(J,XN,X,Y,Z)                                       2124.000
      DIMENSION XN(3)                                                   2125.000
      COMMON /CENT/ TL(12),TS(72),FS(216),MLAT,NEQV                     2126.000
      ISYM=MOD(J,NEQV)                                                  2127.000
      IF(ISYM.EQ.0) ISYM=NEQV                                           2128.000
      IP=(J-1)/NEQV                                                     2129.000
      ILAT=3*MOD(IP,MLAT)                                               2130.000
      JT=3*(ISYM-1)                                                     2131.000
      JJ=9*ISYM-8                                                       2132.000
      DO 20 L=1,3                                                       2133.000
      IND1=JT+L                                                         2134.000
      IND2=ILAT+L                                                       2135.000
      XN(L)=X*FS(JJ)+Y*FS(JJ+1)+Z*FS(JJ+2)                              2136.000
      IF(IP.GE.MLAT) XN(L)=-XN(L)                                       2137.000
      XN(L)=XN(L)+TS(IND1)+TL(IND2)                                     2138.000
      JJ=JJ+3                                                           2139.000
   20 CONTINUE                                                          2140.000
      RETURN                                                            2141.000
      END                                                               2142.000
C     ------------------------------------------------------------------2143.000
C     POINT BY POINT FRAGMENT COMPARISON                                2144.000
      SUBROUTINE TELL(N,NR,M,MR,MERIT,KOMP,INA,INP,LLW)                 2145.000
      DIMENSION JNP(200),JNA(200),LMP(200),LMA(200)                     2146.000
      DIMENSION INA(6,200),INP(6,200),LLW(200)                          2147.000
      COMMON ISYM(100),INBOND(1000),IFRAG(200),ICON(200),               2148.000
     1 IBOND(2000),JFRAG(200),JCON(200),JBOND(2000),IUSE(200),          2149.000
     2 IONA(6,200),IONP(6,200),MO(200),MU(200),NO(200),NU(200),         2150.000
     3 KEYST(200),LW(200),LR(200),LX(200),JK(200),IK(200),KEY(200),     2151.000
     4 IPL(200),KAN(200),CON(200),LL(200),IA(6,200),LS(200),DUM(14400)  2152.000
      COMMON/CONST/ LC, LT, LIN, NOUT, DTOR, ANGMIN, ANGMAX, DMIN,      2153.000
     1  DMAX,DMUT,DM,DFRG,ALN,NSYM,NUMSET,NATM,NAT,NPIC,METAL,          2154.000
     2  LP,LMD,NMAP,FACTOR,LPP                                          2155.000
      ICOUNT=0                                                          2156.000
      NAX=MAX0(N,M)                                                     2157.000
      DO 20 I=1,NAX                                                     2158.000
      KEY(I)=0                                                          2159.000
      IPL(I)=0                                                          2160.000
      MO(I)=0                                                           2161.000
   20 CONTINUE                                                          2162.000
      KY=MAX0(NR,6)                                                     2163.000
      LY=MAX0(MR,6)                                                     2164.000
      L=1                                                               2165.000
      LMP(1)=0                                                          2166.000
      LMA(1)=0                                                          2167.000
      DO 50 I=1,NAX                                                     2168.000
      LMP(I+1)=LMP(I)                                                   2169.000
      LMA(I+1)=LMA(I)                                                   2170.000
      DO 40 J=1,6                                                       2171.000
      IF(INA(J,I).GT.I.OR.INA(J,I).EQ.0) GO TO 30                       2172.000
      K=LMA(I+1)+1                                                      2173.000
      JNA(K)=INA(J,I)                                                   2174.000
      LMA(I+1)=K                                                        2175.000
   30 IF(INP(J,I).EQ.0) GO TO 40                                        2176.000
      K=LMP(I+1)+1                                                      2177.000
      JNP(K)=INP(J,I)                                                   2178.000
      LMP(I+1)=K                                                        2179.000
   40 CONTINUE                                                          2180.000
   50 CONTINUE                                                          2181.000
      NF=0                                                              2182.000
      LR(M+1)=0                                                         2183.000
      DO 90 I=1,M                                                       2184.000
      MM=M+1-I                                                          2185.000
      LR(MM)=LR(MM+1)+LLW(MM)                                           2186.000
   90 CONTINUE                                                          2187.000
  100 IK(L)=LMA(L)                                                      2188.000
      IF(L.LE.M) GO TO 200                                              2189.000
  150 L=L-1                                                             2190.000
      IF(L.EQ.0) GO TO 500                                              2191.000
      IF(KEY(L).EQ.0) GO TO 150                                         2192.000
      KX=KEY(L)                                                         2193.000
      NF=NF-LLW(L)                                                      2194.000
      IPL(KX)=0                                                         2195.000
      IF(MERIT.GT.LR(1)) GO TO 150                                      2196.000
  200 IF(NF.NE.0) GO TO 230                                             2197.000
      K=KEY(L)+1                                                        2198.000
      IF(K.LE.N) GO TO 350                                              2199.000
  220 KEY(L)=0                                                          2200.000
      L=L+1                                                             2201.000
      IF(NF+LR(L).GE.MERIT) GO TO 100                                   2202.000
      GO TO 150                                                         2203.000
  230 IF(IK(L).NE.LMA(L).AND.JK(L).NE.KAN(L)) GO TO 260                 2204.000
  240 IK(L)=IK(L)+1                                                     2205.000
      IF(IK(L).GT.LMA(L+1)) GO TO 220                                   2206.000
      K=IK(L)                                                           2207.000
      K=JNA(K)                                                          2208.000
      IF(KEY(K).EQ.0) GO TO 240                                         2209.000
      K=KEY(K)                                                          2210.000
      JK(L)=LMP(K)                                                      2211.000
      KAN(L)=LMP(K+1)                                                   2212.000
  260 JK(L)=JK(L)+1                                                     2213.000
      K=JK(L)                                                           2214.000
      K=JNP(K)                                                          2215.000
      IF(IPL(K).NE.0) GO TO 230                                         2216.000
      LP=LMP(K+1)                                                       2217.000
      LA=LMA(L+1)                                                       2218.000
      IF(L.GT.LY) GO TO 290                                             2219.000
      LJ=LMA(L)                                                         2220.000
  270 LJ=LJ+1                                                           2221.000
      IF(LJ.GT.LA) GO TO 290                                            2222.000
      J=JNA(LJ)                                                         2223.000
      IF(KEY(J).EQ.0) GO TO 270                                         2224.000
      LB=LMP(K)+1                                                       2225.000
  280 IF(LB.GT.LP) GO TO 230                                            2226.000
      IF(JNP(LB).EQ.KEY(J)) GO TO 270                                   2227.000
      LB=LB+1                                                           2228.000
      GO TO 280                                                         2229.000
  290 IF(K.GT.KY) GO TO 350                                             2230.000
      LJ=LMP(K)                                                         2231.000
  300 LJ=LJ+1                                                           2232.000
      IF(LJ.GT.LP) GO TO 350                                            2233.000
      J=JNP(LJ)                                                         2234.000
      IF(IPL(J).EQ.0) GO TO 300                                         2235.000
      LB=LMA(L)+1                                                       2236.000
  310 IF(LB.GT.LA) GO TO 230                                            2237.000
      IF(JNA(LB).EQ.IPL(J)) GO TO 300                                   2238.000
      LB=LB+1                                                           2239.000
      GO TO 310                                                         2240.000
  350 KEY(L)=K                                                          2241.000
      IPL(K)=L                                                          2242.000
      NF=NF+LLW(L)                                                      2243.000
      ICOUNT=ICOUNT+1                                                   2244.000
      IF(NF.LT.MERIT) GO TO 400                                         2245.000
      MERIT=NF+1                                                        2246.000
      DO 380 I=1,NAX                                                    2247.000
      IF(KOMP.EQ.1) MO(I)=KEY(I)                                        2248.000
      IF(KOMP.EQ.2) MO(I)=IPL(I)                                        2249.000
  380 CONTINUE                                                          2250.000
  400 L=L+1                                                             2251.000
      IF(ICOUNT.LT.100000) GO TO 100                                    2252.000
      WRITE(LT,450)                                                     2253.000
  450 FORMAT(1H0,30X,57HWARNING - FRAGMENT COMPARISON TOO COMPLICATED FO2254.000
     1R PROGRAM)                                                        2255.000
  500 RETURN                                                            2256.000
      END                                                               2257.000
C     ------------------------------------------------------------------2258.000
C     CANONICAL DESCRIPTION & SORT FOR FRAGMENT COMPARISON              2259.000
      SUBROUTINE CANON(M,MR)                                            2260.000
      COMMON ISYM(100),INBOND(1000),IFRAG(200),ICON(200),               2261.000
     1 IBOND(2000),JFRAG(200),JCON(200),JBOND(2000),IUSE(200),          2262.000
     2 IONA(6,200),IONP(6,200),MO(200),MU(200),NO(200),NU(200),         2263.000
     3 KEYST(200),LW(200),LR(200),LX(200),JK(200),IK(200),KEY(200),     2264.000
     4 IPL(200),CAN(200),CON(200),LL(200),IA(6,200),LS(200),DUM(14400)  2265.000
      DO 20 I=0,M                                                       2266.000
      CON(I)=1.0                                                        2267.000
      CAN(I)=0.0                                                        2268.000
      LL(I)=0                                                           2269.000
      NU(I)=0                                                           2270.000
      DO 10 J=1,6                                                       2271.000
      IF(IONP(J,I).GT.0) LL(I)=LL(I)+1                                  2272.000
   10 CONTINUE                                                          2273.000
   20 CONTINUE                                                          2274.000
      AM=0.0                                                            2275.000
      DO 110 I=1,M                                                      2276.000
      DO 80 J=1,M                                                       2277.000
      DO 70 K=1,6                                                       2278.000
      L=IONP(K,J)                                                       2279.000
      IF(L.GT.0) CAN(J)=CAN(J)+CON(L)                                   2280.000
   70 CONTINUE                                                          2281.000
   80 CONTINUE                                                          2282.000
      DO 90 J=1,M                                                       2283.000
      CON(J)=CAN(J)                                                     2284.000
      CAN(J)=0.0                                                        2285.000
      IF(I.EQ.M) AM=AMAX1(AM,CON(J))                                    2286.000
   90 CONTINUE                                                          2287.000
  110 CONTINUE                                                          2288.000
      DO 130 I=1,M                                                      2289.000
      A=CON(I)/AM                                                       2290.000
      A=10000.0*A*A                                                     2291.000
      LX(I)=A+20000.5                                                   2292.000
      IF(LX(I).EQ.20000) LX(I)=20001                                    2293.000
  130 CONTINUE                                                          2294.000
      DO 255 IEN=1,10                                                   2295.000
      DO 250 I=1,M                                                      2296.000
      IF(LL(I).NE.1) GO TO 250                                          2297.000
      DO 240 K=1,M                                                      2298.000
      IF(LL(K).LE.1) GO TO 240                                          2299.000
      DO 230 J=1,6                                                      2300.000
      IF(IONP(J,K).EQ.I) LL(K)=LL(K)-1                                  2301.000
  230 CONTINUE                                                          2302.000
  240 CONTINUE                                                          2303.000
      LL(I)=0                                                           2304.000
      LX(I)=LX(I)-20000                                                 2305.000
  250 CONTINUE                                                          2306.000
  255 CONTINUE                                                          2307.000
      DO 300 I=1,M                                                      2308.000
      LM=0                                                              2309.000
      DO 280 J=1,M                                                      2310.000
      IF(LX(J).LE.LM) GO TO 280                                         2311.000
      IF(I.EQ.1) GO TO 270                                              2312.000
      DO 260 K=1,6                                                      2313.000
      L=IONP(K,J)                                                       2314.000
      IF(L.EQ.0) GO TO 280                                              2315.000
      IF(NU(L).NE.0) GO TO 270                                          2316.000
  260 CONTINUE                                                          2317.000
      GO TO 280                                                         2318.000
  270 LM=LX(J)                                                          2319.000
      IX=J                                                              2320.000
  280 CONTINUE                                                          2321.000
      NU(IX)=I                                                          2322.000
      DO 290 J=1,6                                                      2323.000
      IA(J,I)=IONP(J,IX)                                                2324.000
  290 CONTINUE                                                          2325.000
      LS(I)=LX(IX)                                                      2326.000
      LX(IX)=0                                                          2327.000
  300 CONTINUE                                                          2328.000
      MR=0                                                              2329.000
      DO 350 I=1,M                                                      2330.000
      LX(I)=LS(I)                                                       2331.000
      IF(LL(I).GT.1) MR=MR+1                                            2332.000
      DO 330 J=1,6                                                      2333.000
      IONP(J,I)=0                                                       2334.000
      IF(IA(J,I).EQ.0) GO TO 330                                        2335.000
      MIN=1000                                                          2336.000
      DO 320 K=1,6                                                      2337.000
      IF(IA(K,I).LE.0) GO TO 320                                        2338.000
      IX=IA(K,I)                                                        2339.000
      IF(MIN.LT.NU(IX)) GO TO 320                                       2340.000
      MIN=NU(IX)                                                        2341.000
      KM=K                                                              2342.000
  320 CONTINUE                                                          2343.000
      IONP(J,I)=MIN                                                     2344.000
      IA(KM,I)=-1                                                       2345.000
  330 CONTINUE                                                          2346.000
  350 CONTINUE                                                          2347.000
      RETURN                                                            2348.000
      END                                                               2349.000
C     FINISH OF PART 2 OF SEARCH.                                       2350.000
