C______________________________________________________________________________
C        COPYRIGHT 1985 UNIVERSITY OF GLASGOW                           0001.00
C        VARIOUS MANIPULATIONS OF THE MODEL FILE    PROGRAM XYZ         0002.000
C        GX PACKAGE  APRIL 1985   K.W. MUIR & P.R. MALLINSON            0003.000
C        FEB 1992 GIRDWWOD & MUIR NEW FUNCTIONS
C        RESID,FIXH,FIXAT,FIXEL ADDED AND C-H DEFAULT CHANGED
C
C______________________________________________________________________________
      PROGRAM XYZKWM                                                    0005.000
      CHARACTER COMPID(72),LINE(148)                                    0006.000
      CHARACTER*8 LABEL(200),FTYPE(13)                                  0007.000
      INTEGER CN(200),CONTNT(13),FCH(20),FWD(20)                        0008.000
      COMMON /MODELC/COMPID,LABEL,FTYPE                                 0009.000
      COMMON /MODEL/ NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),            0010.000
     1CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),           0011.000
     2WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                    0012.000
     3SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                         0013.000
      CHARACTER*8 TAG                                                   0014.000
      COMMON /A1/ B(6),C(3,3),D(3,3),G(3,3),H(3,3),XYZ(3,200),
     1NALLOC,NRES,NMOL(200),GG(6)
      DIMENSION F1(3,3),F2(3,3),F3(3,3),TQ(3)                           0016.000
      COMMON IPRIN                                                      0017.000
      COMMON /DEV/LIN,LOUT,LC,LP,LT                                     0018.000
      COMMON /HG/DUMMY(2219),SP3LEN,SP2LEN                              0019.000
      DATA LINE/148*' '/,TQ/3*0./                                       0020.000
 1000 FORMAT(//10X,'<<<MENU OF OPERATIONS ON THE MODEL FILE>>>'//      0021.000
     1 2X,'  1. INVERT    - Invert configuration of model',/     
     2 2X,'  2. TIDY      - Sort atoms into logical order',/       
     3 2X,'  3. RING <D>  - Construct planar polygon of side D,'/
     418X,' D = 1.395 A if not specified by user'/        
     5 2X,'  4. CON R <T> - New x = Rx+T; type R in rows then ',
     5 'T. T is optional. '/ 
     6 2X,'  5. CENTROID NAME ATOM1 ATOM2... - Include centroid in '
     6 'model file '/
     7 2X,'  6. RESID <ATOM1 ATOM2 ...> - Collect atoms into connected '
     7 'residues.'/
     718X,' ATOM1 defaults to the first atom in the model file. '/
     818X,' Otherwise give one atom per residue ')
 1005 FORMAT( 2X,'  7. FIXEL EL1 EL2 ..- Reset U = 0.05 by element '/
     1 2X,'  8. FIXAT ATOM1 ATOM2 . - Reset to Uiso = Ueq by atom'/
     2 2X,'  9. FIXH  <DIST <UFAC>> - Tidy H-atoms. DIST = X-H' 
     3 2X,'and U(H) = UFAC * Ueq(X).'/
     318X,' DIST = 0.96 A, UFAC = 1.2 by default'   )
 1001 FORMAT(72A1)                                                      0028.000
 1002 FORMAT(//10X,'PLEASE WAIT. I AM READING THE MODEL FILE'//)        0029.000
 1003 FORMAT(//10X,' SORT ATOMS INTO LOGICAL ORDER',//                  0030.000
     110X,' WITHIN PARENTHESES OF LABEL DO NUMBERS HAVE PRECEDENCE?'//) 0031.000
 1004 FORMAT (2X,' 10. ADDH <TRIGONAL BOND LENGTH> <TETRAHEDRAL BOND LE0032.000
     1NGTH> '/ 18X,'Calculates H-atom positions; default X-H = 0.96 A.'/
     2 2X,' 11. END                 - Finish and write .MB '////)
      LIN=1                                                             0036.000
      LOUT=2                                                            0037.000
      LC=5                                                              0038.000
      LP=6                                                              0039.000
      LT=7                                                              0040.000
      IPRIN=7                                                           0041.000
      WRITE(LP,1002)                                                    0042.000
      CALL MDLIN(LIN)                                                   0043.000
      CALL AB(CELL,B,G,H,U,V)                                           0044.000
      CALL OM(CELL,B,C,D)
      DO 200 I = 1,3
  200 GG(I)=G(I,I)
      GG(4)=2.0*G(1,2)
      GG(5)=2.0*G(1,3)
      GG(6)=2.0*G(2,3)
      DO 290 I = NATOM+1, 200
  290 NFTYPE(I)=0
      GOTO 201
    1 WRITE(LP,1202)
 1202 FORMAT(' TYPE <CR> TO CONTINUE ')
      READ(LC,1001)
C                                                                       0047.000
C     XYZ CONTAINS ORTHOGONALISED COORDINATES                           0048.000
C     
  201 CALL MVS(XYZ,C,P,NATOM)                                           0046.000                                                                  0049.000
      WRITE(LP,1000)                                                    0050.000
      WRITE(LP,1005)
      WRITE (LP,1004)                                                   0051.000
      READ(LC,1001)(LINE(I),I=2,73)                                     0052.000
      CALL PARSE(LINE,NFS,FCH,FWD)                                      0053.000
      IF(NFS.EQ.0)GOTO 999                                              0054.000
      J=FCH(NFS)                                                        0055.000
      IF(LINE(J).NE.'=')GOTO 3333                                       0056.000
      K=J+71                                                            0057.000
      READ(LC,1001)(LINE(I),I=J,K)                                      0058.000
      CALL PARSE(LINE,NFS,FCH,FWD)                                      0059.000
 3333 CALL AFORMT(LINE,FCH(1),FWD(1),TAG)                               0060.000
      IF(TAG.EQ.'RING')GOTO 2                                           0061.000
      IF(TAG.EQ.'INVERT')GOTO 3                                         0062.000
      IF(TAG.EQ.'TIDY')GOTO 4                                           0063.000
      IF(TAG.EQ.'CON')GOTO 5                                            0064.000
      IF(TAG.EQ.'CENTROID')GOTO 6                                       0065.000
      IF (TAG.EQ.'ADDH') GO TO 7                                        0066.000
      IF (TAG.EQ.'RESID') GO TO 8 
      IF (TAG.EQ.'FIXEL') GO TO 9 
      IF (TAG.EQ.'FIXAT') GO TO 10
      IF (TAG.EQ.'FIXH') GO TO 11
      IF(TAG.EQ.'END') GO TO 999
      GOTO 1                                                            0067.000
C                                                                       0068.000
C     ADD OTHER BRANCHES HERE AS REQUIRED                               0069.000
C                                                                       0070.000
C     FIT ATOMIC POSITIONS TO POLYGON WITH N VERTICES AND SIDE BOND     0071.000
    2 BOND=1.395                                                        0072.000
      IF(NFS.GT.1)CALL FFORMT(LINE,FCH(2),FWD(2),BOND)                  0073.000
      CALL FITN(XYZ,D,BOND)                                             0074.000
      GOTO 1                                                            0075.000
    3 DO 31 I=1,NATOM                                                   0076.000
      DO 31 J=1,3                                                       0077.000
      P(J,I)=-P(J,I)                                                    0078.000
   31 XYZ(J,I)=-XYZ(J,I)                                                0079.000
      GOTO 1                                                            0080.000
    4 WRITE(LP,1003)                                                    0081.000
      CALL QUERY(LC,LP,I)                                               0082.000
      CALL TIDY(I)                                                      0083.000
    5 IF(NFS.LT.10)GOTO 1                                               0084.000
      K=1                                                               0085.000
      DO 50 I=1,3                                                       0086.000
      DO 50 J=1,3                                                       0087.000
      K=K+1                                                             0088.000
      CALL FFORMT(LINE,FCH(K),FWD(K),F3(I,J))                           0089.000
   50 CONTINUE                                                          0090.000
      IF(NFS.LT.13)GOTO 53                                              0091.000
      DO 52 J=1,3                                                       0092.000
      CALL FFORMT(LINE,FCH(K+J),FWD(K+J),TQ(J))                         0093.000
   52 CONTINUE                                                          0094.000
   53 CALL MVS(XYZ,F3,P,NATOM)                                          0095.000
      DO 51 I=1,NATOM                                                   0096.000
      DO 51 J=1,3                                                       0097.000
   51 P(J,I)=XYZ(J,I)+TQ(J)                                             0098.000
      GOTO 1                                                            0099.000
    6 IF(NFS.LT.4)GOTO 106                                              0100.000
      KNT=0                                                             0101.000
      MATOM=NATOM+1                                                     0102.000
      DO 100 I=1,3                                                      0103.000
  100 P(I,MATOM)=0.                                                     0104.000
      CALL AFORMT(LINE,FCH(2),FWD(2),LABEL(MATOM))                      0105.000
      DO 103 I=3,NFS                                                    0106.000
      CALL AFORMT(LINE,FCH(I),FWD(I),TAG)                               0107.000
      DO 102 J=1,NATOM                                                  0108.000
      IF(TAG.NE.LABEL(J))GOTO 102                                       0109.000
      KNT=KNT+1                                                         0110.000
      DO 101 K=1,3                                                      0111.000
  101 P(K,MATOM)=P(K,MATOM)+P(K,J)                                      0112.000
      GOTO 103                                                          0113.000
  102 CONTINUE                                                          0114.000
  103 CONTINUE                                                          0115.000
      NATOM=MATOM                                                       0116.000
      DO 104 I=1,3                                                      0117.000
      EP(I,NATOM)=0.                                                    0118.000
  104 P(I,NATOM)=P(I,NATOM)/REAL(KNT)                                   0119.000
      CN(NATOM)=0                                                       0120.000
      SOF(NATOM)=1.                                                     0121.000
      UIJ(1,NATOM)=.05                                                  0122.000
      ESOF(NATOM)=0.                                                    0123.000
      EUIJ(1,NATOM)=0.                                                  0124.000
      WRITE(LP,105)                                                     0125.000
  105 FORMAT(//10X,' CENTROID HAS BEEN ADDED TO MODEL FILE ',//)        0126.000
      GOTO 1                                                            0127.000
  106 WRITE(LP,107)                                                     0128.000
  107 FORMAT(//' ERROR IN CENTROID CALCULATION - RETYPE INSTRUCTION'//) 0129.000
      GOTO 1                                                            0130.000
 7    SP3LEN=0.960                                                      0131.000
      SP2LEN=0.960                                                      0132.000
      IF (NFS.GT.1) CALL FFORMT(LINE,FCH(2),FWD(2),SP2LEN)              0133.000
      IF (NFS.GT.2) CALL FFORMT(LINE,FCH(3),FWD(3),SP3LEN)              0134.000
      CALL ADDH                                                         0135.000
      GO TO 1
    8 CONTINUE
C MOVE ATOMS INTO CONNECTED RESIDUES
      NALLOC = 0
      DO 81 I = 1,NATOM
      NMOL(I) = 0
      DO 81 J = 1,3
   81 CALL FRAC(P(J,I))
      NRES=NFS-1
      IF(NRES.GT.0)GOTO 82
      NRES = 1
      NALLOC = 1
      NMOL(1) = 1
      GOTO 85
   82 DO 84 I = 2,NFS
      CALL AFORMT(LINE,FCH(I),FWD(I),TAG)
      DO 83 J = 1,NATOM
      IF(TAG.NE.LABEL(J))GOTO 83
      NMOL(J)=I-1
      NALLOC = NALLOC + 1
      GOTO 84
   83 CONTINUE
   84 CONTINUE
      IF(NALLOC.EQ.NRES)GOTO 85
      WRITE(LP,1100)
 1100 FORMAT(//10X, ' TRY AGAIN - ATOM NAMES NOT RECOGNISED ')
      GOTO 1
   85 CONTINUE
C NMOL(I) = 0 IF UNALLOCATED, OTHERWISE RESIDUE NUMBER
C NALLOC ATOMS ALLOCATED TO NRES RESIDUES
      CALL RESID
      WRITE(LP,1101)(LABEL(I),NMOL(I),I=1,NATOM)
 1101 FORMAT(//20X, ' ATOMS AND RESIDUES ',//
     140(10X,6(A8,I2,2X)/))
      GO TO 1
    9 CONTINUE
C RESET UIJ TO UISO = 0.05 BY ELEMENT
      DO 93 I = 2,NFS
      CALL AFORMT(LINE,FCH(I),FWD(I),TAG)
      DO 92 J = 1,NTYPE
      IF(TAG.NE.FTYPE(J))GOTO 92
      DO 91 K = 1,NATOM
      IF(NFTYPE(K).NE.J)GOTO 91
      WRITE(LP,9800)LABEL(K)
 9800 FORMAT(' ATOM ',2X,A8, ' RESET ISOTROPIC WITH U = 0.05 ASQ ')
      CALL UTRAN(K,0,K)
   91 CONTINUE
   92 CONTINUE
   93 CONTINUE
      GOTO 1
   10 CONTINUE
C RESET UIJ TO UEQ BY ATOM NAME
      DO 203 I = 2,NFS
      CALL AFORMT(LINE,FCH(I),FWD(I),TAG)
      DO 202 J = 1, NATOM
      IF(LABEL(J).NE.TAG) GO TO 202
      CALL UTRAN(J,-1,J)
      WRITE(LP,9801)LABEL(J)
 9801 FORMAT(' ATOM ',2X,A8, ' RESET ISOTROPIC WITH UISO = UEQ ')
  202 CONTINUE
  203 CONTINUE
      GO TO 1
   11 CONTINUE
C FIX C-H = DIST U(H) = UFAC*UEQ(X) H NAME
      DIST = 0.96
      UFAC = 1.2
      IF(NFS.GT.1) CALL FFORMT(LINE,FCH(2),FWD(2),DIST)
      IF(NFS.GT.2) CALL FFORMT(LINE,FCH(3),FWD(3),UFAC)
      DO 400 I = 1,NTYPE
  400 IF(FTYPE(I).EQ.'H       ')NUMH=I
      DO 499 I = 1, NATOM
      IF(NFTYPE(I).EQ.NUMH)GOTO 499
      IF(NFTYPE(I).EQ.0)GOTO 499
      NHBOND = 0
      DO 401 J = 1,3
  401 NMOL(J) = 0
      DO 480 J = 1,NATOM
      IF( (NFTYPE(J).EQ.NUMH) .OR. (NFTYPE(J).EQ.0) )GOTO 470
      GOTO 480
  470 IF( (SFAC(13,NFTYPE(I)) + SFAC(13,NFTYPE(J)) ).GT.1.35)GOTO 480
      BDIST=SQRT( (XYZ(1,I)-XYZ(1,J))**2 + (XYZ(2,I)-XYZ(2,J))**2 +
     1 (XYZ(3,I)-XYZ(3,J))**2 )
      IF(BDIST.GT.(SFAC(13,NFTYPE(I)) + SFAC(13,NFTYPE(J))))GOTO 480
      NHBOND=NHBOND+1
      NMOL(NHBOND) = J
      BDIST = DIST/BDIST
      DO 410 K = 1,3
  410 P(K,J) = BDIST*(P(K,J)-P(K,I))+P(K,I)
      CALL UTRAN(I,-1,J)
      UIJ(1,J)=UFAC*UIJ(1,J)
  480 CONTINUE
      IF(NHBOND.EQ.0)GOTO 499
      DO 490 J = 1,NHBOND
  490 CALL FIXLAB(LABEL(I),LABEL(NMOL(J)),NHBOND,J)
      WRITE(LP,1006) LABEL(I),(LABEL(NMOL(J)), J = 1, NHBOND)
 1006 FORMAT(10X,A8,' BONDED TO ',3(4X,A8))
  499 CONTINUE
      GOTO 1
  999 CALL MDLOUT(LOUT)                                                 0137.000
      STOP                                                              0138.000
      END                                                               0139.000
C-----------------------------------------------------------------------0140.000
      SUBROUTINE FIXLAB(TG1,TG2,NB,MB)
	CHARACTER*8 TAG1,TAG2,TG1,TG2
	CHARACTER ITAG1(8),ITAG2(8),SYM(7)
	EQUIVALENCE ( TAG1, ITAG1(1) ), ( TAG2, ITAG2(1) )
	DATA SYM/'A','B','C','H','(',')',' '/
	TAG1=TG1
	TAG2=TG2
	IJ=2
	I1=3
	I2=7
	DO 1 I=1,8
        ITAG2(I)=SYM(7)
	IF(ITAG1(I).EQ.SYM(5))I1=I+1
	IF(ITAG1(I).EQ.SYM(6))I2=I-1
    1	CONTINUE
	ITAG2(1)=SYM(4)
	ITAG2(2)=SYM(5)
	DO 2 I=I1,I2
	IJ=IJ+1
	ITAG2(IJ)=ITAG1(I)
	IF(IJ.EQ.7)GOTO 3
    2	CONTINUE
    3	IF(NB.EQ.1)GOTO 4
	IJ=IJ+1
	ITAG2(IJ)=SYM(MB)
    4	IJ=IJ+1
	IF(IJ.LE.8)ITAG2(IJ)=SYM(6)
    5   TG2=TAG2
	RETURN
	END
C___________________________________________________________________________
      SUBROUTINE RESID    
C    ATOMS IN CONNECTED RESIDUES 
      CHARACTER COMPID(72),LINE(148)                                    0006.000
      CHARACTER*8 LABEL(200),FTYPE(13)                                  0007.000
      INTEGER CN(200),CONTNT(13),FCH(20),FWD(20)                        0008.000
      COMMON /MODELC/COMPID,LABEL,FTYPE                                 0009.000
      COMMON /MODEL/ NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),            0010.000
     1CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),           0011.000
     2WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                    0012.000
     3SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                         0013.000
      CHARACTER*8 TAG                                                   0014.000
      COMMON /A1/ B(6),C(3,3),D(3,3),G(3,3),H(3,3),XYZ(3,200),
     1NALLOC,NRES,NMOL(200),GG(6)
      DIMENSION F1(3,3),F2(3,3),F3(3,3),TQ(3)                           0016.000
      COMMON IPRIN                                                      0017.000
      COMMON /DEV/LIN,LOUT,LC,LP,LT                                     0018.000
      COMMON /HG/DUMMY(2219),SP3LEN,SP2LEN                              0019.000
      DIMENSION XB(3)
      TOL = 0.25
   10 NPASS=0
      DO 50 IA=1,NATOM
      IF(NMOL(IA).EQ.0)GOTO 50
      RA=SFAC(13,NFTYPE(IA))
      DO 40 IB=1,NATOM
      IF(NMOL(IB).NE.0)GOTO 40
      RB=SFAC(13,NFTYPE(IB))
      RBOND=RA+RB+TOL
      CALL XDIST(IA,IB,XB,MR,RBOND)
      IF(MR.EQ.0)GOTO 40
      NPASS=NPASS+1
      NMOL(IB)=NMOL(IA)
      DO 20 I=1,3
   20 P(I,IB)=XB(I)
      CALL UTRAN(IB,MR,IB)
   40 CONTINUE
   50 CONTINUE
      NALLOC=NALLOC+NPASS
      IF(NALLOC.EQ.NATOM)RETURN
      IF(NPASS.NE.0)GOTO 10
      WRITE(LP,1000)
 1000 FORMAT(//10X, 'CHECK COVALENT RADII - RESID FAILED' )
      STOP
      END
C______________________________________________________________________________
      SUBROUTINE XDIST (IA,IB,XB,MR,RBOND)
C     TRANSPOSES ATOM B SO THAT DISTANCE A-B IS LESS THAN RBOND
C     ON EXIT XB CONTAINS THE TRANSPOSED FRACTIONAL COORDINATES OF B
C     MR IS THE ROTATION MATRIX NUMBER USED TO GET XB(0 IF NO TRANSPOSIT
C    1IONS FOUND)
C     RBOND IS MINIMUM DISTANCE FOUND
      CHARACTER COMPID(72),LINE(148)                                    0006.000
      CHARACTER*8 LABEL(200),FTYPE(13)                                  0007.000
      INTEGER CN(200),CONTNT(13),FCH(20),FWD(20)                        0008.000
      COMMON /MODELC/COMPID,LABEL,FTYPE                                 0009.000
      COMMON /MODEL/ NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),            0010.000
     1CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),           0011.000
     2WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                    0012.000
     3SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                         0013.000
      CHARACTER*8 TAG                                                   0014.000
      COMMON /A1/ B(6),C(3,3),D(3,3),G(3,3),H(3,3),XYZ(3,200),
     1NALLOC,NRES,NMOL(200),GG(6)
      DIMENSION F1(3,3),F2(3,3),F3(3,3),TQ(3)                           0016.000
      COMMON IPRIN                                                      0017.000
      COMMON /DEV/LIN,LOUT,LC,LP,LT                                     0018.000
      COMMON /HG/DUMMY(2219),SP3LEN,SP2LEN                              0019.000
      DIMENSION XB(3),FAC(2),X(3),Y(3)
      RLIMIT=RBOND
      RBOND=1000.0
      MR=0
      FAC(1)=1.0
      FAC(2)=-1.0
      NC=1
      IF(ICENT.EQ.0)NC=2
      DO 100 IT=1,NT
      DO 100 IR=1,NR
      DO 10 I=1,3
      X(I)=R(IR,I,1)*P(1,IB)+R(IR,I,2)*P(2,IB)+R(IR,I,3)*P(3,IB)
     3    +R(IR,I,4)+T(I,IT)
   10 CONTINUE
      DO 100 IC=1,NC
      DO 20 I=1,3
      X(I)=FAC(IC)*X(I)
   20 CALL FRAC(X(I))
      DO 100 IX=-1,1
      XB(1)=X(1)+FLOAT(IX)
      Y(1)=XB(1)-P(1,IA)
      DO 100 IY=-1,1
      XB(2)=X(2)+FLOAT(IY)
      Y(2)=XB(2)-P(2,IA)
      DO 100 IZ=-1,1
      XB(3)=X(3)+FLOAT(IZ)
      Y(3)=XB(3)-P(3,IA)
      DIST=SQRT(GG(1)*Y(1)*Y(1)+GG(4)*Y(1)*Y(2)
     1         +GG(2)*Y(2)*Y(2)+GG(5)*Y(1)*Y(3)
     2         +GG(3)*Y(3)*Y(3)+GG(6)*Y(2)*Y(3))
      IF(DIST.GE.RLIMIT)GOTO 100
      MR=IR
      RBOND=DIST
      RETURN
  100 CONTINUE
      RETURN
      END
C_____________________________________________________________________________
      SUBROUTINE FRAC(X)
    1 IF(X.GE.0.0)GOTO 2
      X=X+1.0
      GOTO 1
    2 IF(X.LT.1.0)GOTO 3
      X=X-1.0
      GOTO 2
    3 RETURN
      END
C______________________________________________________________________________
      SUBROUTINE UTRAN(IB,MR,IC)
      CHARACTER*8 LABEL(200),FTYPE(13)                                  0007.000
      INTEGER CN(200),CONTNT(13),FCH(20),FWD(20)                        0008.000
      COMMON /MODELC/COMPID,LABEL,FTYPE                                 0009.000
      COMMON /MODEL/ NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),            0010.000
     1CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),           0011.000
     2WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                    0012.000
     3SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                         0013.000
      CHARACTER*8 TAG                                                   0014.000
      COMMON /A1/ B(6),C(3,3),D(3,3),G(3,3),H(3,3),XYZ(3,200),
     1NALLOC,NRES,NMOL(200),GG(6)
      DIMENSION F1(3,3),F2(3,3),F3(3,3),TQ(3)                           0016.000
      COMMON IPRIN                                                      0017.000
      COMMON /DEV/LIN,LOUT,LC,LP,LT                                     0018.000
      COMMON /HG/DUMMY(2219),SP3LEN,SP2LEN                              0019.000
      DIMENSION Q1(3,3),RR1(3,3),RR2(3,3),Q2(3,3)
      IF(MR.GT.0)GOTO 50
C     RESET ISOTROPIC-MR NEGATIVE OR ZERO
      IF(MR.LT.0)GOTO 8
      UISO=0.05
      GOTO 9
    8 UISO=UIJ(1,IB)
      IF(UIJ(2,IB).GT.0.00001)UISO=(UIJ(1,IB)*B(1)*B(1)*G(1,1)
     1     +UIJ(2,IB)*B(2)*B(2)*G(2,2)
     2     +UIJ(3,IB)*B(3)*B(3)*G(3,3)
     3     +UIJ(4,IB)*B(1)*B(2)*G(1,2)
     4     +UIJ(5,IB)*B(1)*B(3)*G(1,3)
     5     +UIJ(6,IB)*B(2)*B(3)*G(2,3))/3.0
    9 DO 10 I=2,6
   10 UIJ(I,IC)=0.0
      UIJ(1,IC)=UISO
      GOTO 100
C     TRANSPOSE U BY OPERATION MR :B=RBR(TRANSPOSE)
   50 IF(UIJ(2,IB).LT.0.00001)GOTO 100
      DO 51 I=1,3
      Q1(I,I)=UIJ(I,IB)*B(I)*B(I)
      DO 51 J=1,3
   51 RR1(I,J)=R(MR,I,J)
      Q1(1,2)=UIJ(4,IB)*B(1)*B(2)
      Q1(1,3)=UIJ(5,IB)*B(1)*B(3)
      Q1(2,3)=UIJ(6,IB)*B(2)*B(3)
      Q1(2,1)=Q1(1,2)
      Q1(3,1)=Q1(1,3)
      Q1(3,2)=Q1(2,3)
      CALL MM(RR1,Q1,Q2)
      CALL MT(RR1,RR2)
      CALL MM(Q2,RR2,Q1)
      DO 52 I=1,3
      DO 52 J=1,3
   52 Q1(I,J)=Q1(I,J)/(B(I)*B(J))
      DO 53 I=1,3
   53 UIJ(I,IB)=Q1(I,I)
      UIJ(4,IB)=Q1(1,2)
      UIJ(5,IB)=Q1(1,3)
      UIJ(6,IB)=Q1(2,3)
  100 RETURN
      END
C-----------------------------------------------------------------------0140.000
C     FITS A REGULAR POLYGON OF SIDE BOND TO OBSERVED POSITIONS         0141.000
      SUBROUTINE FITN(XYZ,D,BOND)                                       0142.000
C     STORAGE FOR MODEL FILE AND FOR FREE FORMAT READING                0143.000
      CHARACTER COMPID(72),LINE(148)                                    0144.000
      CHARACTER*8 LABEL(200),FTYPE(13)                                  0145.000
      INTEGER CN(200),CONTNT(13),FCH(20),FWD(20)                        0146.000
      COMMON /MODELC/COMPID,LABEL,FTYPE                                 0147.000
      COMMON /MODEL/ NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),            0148.000
     1CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),           0149.000
     2WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                    0150.000
     3SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                         0151.000
C                                                                       0152.000
      CHARACTER*8 TAG(20)                                               0153.000
      DIMENSION XYZ(3,200),X(3,20),Y(3,20),Z(3,20),E(3,20),W(20)        0154.000
      DIMENSION A(3,3),D(3,3),ZBAR(3),ITAG(20)                          0155.000
      COMMON /DEV/LIN,LOUT,LC,LP,LT                                     0156.000
      DATA LINE/148*' '/                                                0157.000
 1000 FORMAT(//10X,' TYPE IN ATOM LABELS TO DEFINE RING',//)            0158.000
 1001 FORMAT(72A1)                                                      0159.000
 1002 FORMAT(//10X,'>>>>>>>>>>> ERROR IN PROCESSING',/1H ,72A1/)        0160.000
 1003 FORMAT(//10X,' THE FOLLOWING ATOMS NOW DEFINE A REGULAR POLYGON',/0161.000
     1/10X,'VERTICES =',I3,11X,'SIDE =',F6.3,' ANGSTROMS'/)             0162.000
 1004 FORMAT(5X,' FOR ',A8,' OBSERVED AND CALCULATED POSITIONS DIFFER BY0163.000
     1',F7.3,' ANGSTROMS')                                              0164.000
C                                                                       0165.000
    1 WRITE(LP,1000)                                                    0166.000
      READ (LC,1001)(LINE(I),I=2,73)                                    0167.000
      CALL PARSE(LINE,NAT,FCH,FWD)                                      0168.000
      IF(NAT.EQ.0)GOTO 999                                              0169.000
      J=FCH(NAT)                                                        0170.000
      IF(LINE(J).NE.'=')GOTO 3                                          0171.000
      K=J+71                                                            0172.000
      READ(LC,1001)(LINE(I),I=J,K)                                      0173.000
      CALL PARSE(LINE,NAT,FCH,FWD)                                      0174.000
      GOTO 3                                                            0175.000
    2 WRITE(LP,1002)(LINE(I),I=2,73)                                    0176.000
      GOTO 1                                                            0177.000
    3 IF(NAT.LT.3 .OR. NAT.GT.20)GOTO 2                                 0178.000
      DO 4 I=1,3                                                        0179.000
    4 ZBAR(I)=0.                                                        0180.000
      NRA=0                                                             0181.000
      DO 8 I=1,NAT                                                      0182.000
      CALL AFORMT(LINE,FCH(I),FWD(I),TAG(I))                            0183.000
         J=FCH(I)                                                       0184.000
      IF(LINE(J).NE.'X')GOTO 5                                          0185.000
      W(I)=0.                                                           0186.000
      NATOM=NATOM+1                                                     0187.000
      ITAG(I)=NATOM                                                     0188.000
      SOF(NATOM)=1.0                                                    0189.000
      UIJ(1,NATOM)=0.05                                                 0190.000
      LABEL(NATOM)=TAG(I)                                               0191.000
      GOTO 8                                                            0192.000
    5 ITAG(I)=0                                                         0193.000
      DO 6 J=1,NATOM                                                    0194.000
    6 IF(TAG(I).EQ.LABEL(J))ITAG(I)=J                                   0195.000
      IF(ITAG(I).EQ.0)GOTO 2                                            0196.000
      DO 7 J=1,3                                                        0197.000
      Z(J,I)=XYZ(J,ITAG(I))                                             0198.000
    7 ZBAR(J)=ZBAR(J)+Z(J,I)                                            0199.000
      NRA=NRA+1                                                         0200.000
      W(I)=1.                                                           0201.000
    8 CONTINUE                                                          0202.000
      IF(W(1)*W(3).LT.0.1)GOTO 2                                        0203.000
      DO 9 I=1,3                                                        0204.000
    9 ZBAR(I)=ZBAR(I)/REAL(NRA)                                         0205.000
      DO 10 I=1,3,2                                                     0206.000
      J=(I+1)/2                                                         0207.000
      DO 10 K=1,3                                                       0208.000
   10 A(K,J)=Z(K,I)-ZBAR(K)                                             0209.000
      CALL CROSS(A,1,2,3)                                               0210.000
      CALL CROSS(A,3,1,2)                                               0211.000
      DO 11 I=1,3                                                       0212.000
      CALL NORM(A,I,1.0)                                                0213.000
   11 CONTINUE                                                          0214.000
      CALL RING(X,NAT,BOND)                                             0215.000
      CALL MVS(Y,A,X,NAT)                                               0216.000
      DO 12 I=1,NAT                                                     0217.000
      DO 12 J=1,3                                                       0218.000
      Y(J,I)=Y(J,I)+ZBAR(J)                                             0219.000
      XYZ(J,ITAG(I))=Y(J,I)                                             0220.000
   12 E(J,I)=W(I)*(Y(J,I)-Z(J,I))                                       0221.000
      CALL MVS(Z,D,Y,NAT)                                               0222.000
      WRITE(LT,1003)NAT,BOND                                            0223.000
      DO 14 I=1,NAT                                                     0224.000
      DO 13 J=1,3                                                       0225.000
   13 P(J,ITAG(I))=Z(J,I)                                               0226.000
      CN(ITAG(I))=3                                                     0227.000
      DD=SQRT(E(1,I)*E(1,I)+E(2,I)*E(2,I)+E(3,I)*E(3,I))                0228.000
      WRITE(LT,1004)TAG(I),DD                                           0229.000
   14 CONTINUE                                                          0230.000
      GOTO 1                                                            0231.000
  999 RETURN                                                            0232.000
      END                                                               0233.000
C-----------------------------------------------------------------------0234.000
C     TRANSFORM N 3-D VECTORS:  Y = AX                                  0235.000
      SUBROUTINE MVS(Y,A,X,N)                                           0236.000
      DIMENSION X(3,N),Y(3,N),A(3,3)                                    0237.000
      DO 1 I=1,N                                                        0238.000
      DO 1 J=1,3                                                        0239.000
    1 Y(J,I)=A(J,1)*X(1,I)+A(J,2)*X(2,I)+A(J,3)*X(3,I)                  0240.000
      RETURN                                                            0241.000
      END                                                               0242.000
C-----------------------------------------------------------------------0243.000
C     A(6) B(6) REAL AND RECIPROCAL CELL                                0244.000
C     C ORTHOGONALISES, D IS ITS INVERSE:  Y = CX AND X = DY            0245.000
      SUBROUTINE OM(A,B,C,D)                                            0246.000
      DIMENSION A(6),B(6),C(3,3),D(3,3)                                 0247.000
      DO 1 I=1,3                                                        0248.000
      DO 1 J=1,3                                                        0249.000
      C(I,J)=0.                                                         0250.000
    1 D(I,J)=0.                                                         0251.000
      SA= SQRT(ABS(1.0 - A(4)*A(4)))                                    0252.000
      SB= SQRT(ABS(1.0 - A(5)*A(5)))                                    0253.000
      SGS=SQRT(ABS(1.0 - B(6)*B(6)))                                    0254.000
      C(1,1)= A(1)*SB*SGS                                               0255.000
      C(2,1)=-A(1)*SB*B(6)                                              0256.000
      C(3,1)= A(1)*A(5)                                                 0257.000
      C(2,2)= A(2)*SA                                                   0258.000
      C(3,2)= A(2)*A(4)                                                 0259.000
      C(3,3)= A(3)                                                      0260.000
      DO 2 I=1,3                                                        0261.000
    2 D(I,I)=1.0/C(I,I)                                                 0262.000
      D(2,1)=-C(2,1)*D(1,1)*D(2,2)                                      0263.000
      D(3,2)=-C(3,2)*D(2,2)*D(3,3)                                      0264.000
      D(3,1)=-D(3,3)*(C(3,1)*D(1,1)+C(3,2)*D(2,1))                      0265.000
      RETURN                                                            0266.000
      END                                                               0267.000
C-----------------------------------------------------------------------0268.000
C     NORMALISE THE NTH 3-D VECTOR IN A TO LENGTH B                     0269.000
      SUBROUTINE NORM(A,N,B)                                            0270.000
      DIMENSION A(3,N)                                                  0271.000
      C=B/SQRT(A(1,N)*A(1,N)+A(2,N)*A(2,N)+A(3,N)*A(3,N))               0272.000
      DO 1 I=1,3                                                        0273.000
    1 A(I,N)=C*A(I,N)                                                   0274.000
      RETURN                                                            0275.000
      END                                                               0276.000
C-----------------------------------------------------------------------0277.000
C     GENERATE THE VERTICES OF A N-SIDED POLYGON OF SIDE B              0278.000
      SUBROUTINE RING(X,N,B)                                            0279.000
      DIMENSION X(3,N)                                                  0280.000
      ALPHA=8.0*ATAN(1.0)/REAL(N)                                       0281.000
      D=0.5*B/SIN(0.5*ALPHA)                                            0282.000
      DO 1 I=1,N                                                        0283.000
      X(1,I)=D*COS(REAL(I-1)*ALPHA)                                     0284.000
      X(2,I)=D*SIN(REAL(I-1)*ALPHA)                                     0285.000
    1 X(3,I)=0.                                                         0286.000
      RETURN                                                            0287.000
      END                                                               0288.000
C-----------------------------------------------------------------------0289.000
C     COLUMN K OF A CONTAINS CROSS PRODUCT OF COLUMN I WITH COLUMN J    0290.000
      SUBROUTINE CROSS(A,I,J,K)                                         0291.000
      DIMENSION A(3,3)                                                  0292.000
      A(1,K)=A(2,I)*A(3,J)-A(3,I)*A(2,J)                                0293.000
      A(2,K)=A(3,I)*A(1,J)-A(1,I)*A(3,J)                                0294.000
      A(3,K)=A(1,I)*A(2,J)-A(2,I)*A(1,J)                                0295.000
      RETURN                                                            0296.000
      END                                                               0297.000
C-----------------------------------------------------------------------0298.000
C     A - REAL CELL GENERATES B - RECIPROCAL CELL, G AND H THE          0299.000
C     REAL AND RECIPROCAL METRIC TENSORS, AND U AND V REAL AND          0300.000
C     RECIPROCAL CELL VOLUMES.                                          0301.000
      SUBROUTINE AB(A,B,G,H,U,V)                                        0302.000
      DIMENSION A(6),B(6),G(3,3),H(3,3)                                 0303.000
      CALL AG(A,G)                                                      0304.000
      CALL SMI3(G,H,U )                                                 0305.000
      CALL GA(H,B)                                                      0306.000
      CALL VU(A,U,V)                                                    0307.000
      RETURN                                                            0308.000
      END                                                               0309.000
C-----------------------------------------------------------------------0310.000
C     METRIC FROM CELL                                                  0311.000
      SUBROUTINE AG(A,G)                                                0312.000
      DIMENSION A(6),G(3,3)                                             0313.000
      DO 1 I=1,3                                                        0314.000
      DO 1 J=1,3                                                        0315.000
      G(I,J)=A(I)*A(J)                                                  0316.000
      IF(I.EQ.J)GOTO 1                                                  0317.000
      G(I,J)=G(I,J)*A(9-I-J)                                            0318.000
    1 CONTINUE                                                          0319.000
      RETURN                                                            0320.000
      END                                                               0321.000
C-----------------------------------------------------------------------0322.000
C     CELL FROM METRIC                                                  0323.000
      SUBROUTINE GA(G,A)                                                0324.000
      DIMENSION A(6),G(3,3)                                             0325.000
      DO 1 I=1,3                                                        0326.000
    1 A(I)=SQRT (G(I,I))                                                0327.000
      A(4)=G(2,3)/(A(2)*A(3))                                           0328.000
      A(5)=G(1,3)/(A(1)*A(3))                                           0329.000
      A(6)=G(1,2)/(A(1)*A(2))                                           0330.000
      RETURN                                                            0331.000
      END                                                               0332.000
C-----------------------------------------------------------------------0333.000
C     MATRIX MULTIPLICATION C(3,3) = A(3,3) * B(3,3)                    0334.000
      SUBROUTINE MM(A,B,C)                                              0335.000
      DIMENSION A(3,3),B(3,3),C(3,3)                                    0336.000
      DO 1 I=1,3                                                        0337.000
      DO 1 J=1,3                                                        0338.000
      C(I,J)=0.0                                                        0339.000
      DO 2 K=1,3                                                        0340.000
    2 C(I,J)=C(I,J)+A(I,K)*B(K,J)                                       0341.000
    1 CONTINUE                                                          0342.000
      RETURN                                                            0343.000
      END                                                               0344.000
C-----------------------------------------------------------------------0345.000
C     B(3,3) = TRANSPOSE OF A(3,3)                                      0346.000
      SUBROUTINE MT(A,B)                                                0347.000
      DIMENSION A(3,3),B(3,3)                                           0348.000
      DO 1 I=1,3                                                        0349.000
      DO 1 J=1,3                                                        0350.000
    1 B(J,I)=A(I,J)                                                     0351.000
      RETURN                                                            0352.000
      END                                                               0353.000
C-----------------------------------------------------------------------0354.000
C     INVERT SYMMETRIC SQUARE MATRIX OF ORDER 3                         0355.000
      SUBROUTINE SMI3(A,AI,D)                                           0356.000
      DIMENSION A(3,3),AI(3,3)                                          0357.000
      DO 3 I=1,3                                                        0358.000
      K=1+ MOD (I+1,3)                                                  0359.000
      M=1+ MOD (I+3,3)                                                  0360.000
      DO 3 J=1,3                                                        0361.000
      L=1+ MOD (J+1,3)                                                  0362.000
      N=1+ MOD (J+3,3)                                                  0363.000
    3 AI(I,J)=A(L,K)*A(N,M)-A(L,M)*A(N,K)                               0364.000
      D=0.0                                                             0365.000
      DO 1 I=1,3                                                        0366.000
    1 D=D+A(I,1)*AI(1,I)                                                0367.000
      DO 2 I=1,3                                                        0368.000
      DO 2 J=1,3                                                        0369.000
    2 AI(I,J)=AI(I,J)/D                                                 0370.000
      RETURN                                                            0371.000
      END                                                               0372.000
C-----------------------------------------------------------------------0373.000
C     REAL AND RECIPROCAL CELL VOLUMES U AND V                          0374.000
      SUBROUTINE VU(A,V,U)                                              0375.000
      DIMENSION A(6)                                                    0376.000
      V=A(1)*A(2)*A(3)*SQRT (1.0+2.0*A(4)*A(5)*A(6)-A(4)**2-A(5)**2-A(  0377.000
     16)**2)                                                            0378.000
      U=1.0/V                                                           0379.000
      RETURN                                                            0380.000
      END                                                               0381.000
C-----------------------------------------------------------------------0382.000
C     SORT THE ATOMS INTO LOGICAL ORDER                                 0383.000
      SUBROUTINE TIDY(I)                                                0384.000
C     MODEL FILE AND FREE FORMAT READING STORAGE                        0385.000
      CHARACTER COMPID(72)                                              0386.000
      CHARACTER*8 LABEL(200),FTYPE(13)                                  0387.000
      INTEGER CN(200),CONTNT(13),FCH(20),FWD(20)                        0388.000
      COMMON /MODELC/COMPID,LABEL,FTYPE                                 0389.000
      COMMON /MODEL/ NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),            0390.000
     1CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),           0391.000
     2WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                    0392.000
     3SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                         0393.000
      CHARACTER*8 LBL(200),TAG                                          0394.000
      DIMENSION F1(3,200),F2(200),F3(6,200),F4(3,200),F5(200),          0395.000
     1F6(6,200),I1(200),I2(200),ITAG(200),JTAG(200)                     0396.000
      L1=2**20                                                          0397.000
      L2=2**16                                                          0398.000
      L3=2**10                                                          0399.000
      L4=1                                                              0400.000
      IF(I.EQ.0)GOTO 1                                                  0401.000
      L3=L4                                                             0402.000
      L4=2**5                                                           0403.000
    1 DO 3 J=1,NATOM                                                    0404.000
      KS1=NFTYPE(J)                                                     0405.000
      IF(KS1.LT.1.OR.KS1.GT.13)KS1=14                                   0406.000
      CALL DEK(LABEL(J),TAG,KN,KL)                                      0407.000
      KS2=14                                                            0408.000
      DO 2 K=1,NTYPE                                                    0409.000
    2 IF(TAG.EQ.FTYPE(K))KS2=K                                          0410.000
      ITAG(J)=L1*KS1+L2*KS2+L3*KL+L4*KN                                 0411.000
      JTAG(J)=J                                                         0412.000
    3 CONTINUE                                                          0413.000
      CALL SORT(ITAG,JTAG,NATOM)                                        0414.000
      DO 6 J=1,NATOM                                                    0415.000
      K=JTAG(J)                                                         0416.000
      LBL(J)=LABEL(K)                                                   0417.000
      I1(J) =NFTYPE(K)                                                  0418.000
      I2(J) =CN(K)                                                      0419.000
      F2(J) =SOF(K)                                                     0420.000
      F5(J) =ESOF(K)                                                    0421.000
      DO 4 L=1,3                                                        0422.000
      F1(L,J)=P(L,K)                                                    0423.000
    4 F4(L,J)=EP(L,K)                                                   0424.000
      DO 5 L=1,6                                                        0425.000
      F3(L,J)=UIJ(L,K)                                                  0426.000
    5 F6(L,J)=EUIJ(L,K)                                                 0427.000
    6 CONTINUE                                                          0428.000
      DO 9 J=1,NATOM                                                    0429.000
      LABEL(J)=LBL(J)                                                   0430.000
      NFTYPE(J)=I1(J)                                                   0431.000
      CN(J)=I2(J)                                                       0432.000
      SOF(J)=F2(J)                                                      0433.000
      ESOF(J)=F5(J)                                                     0434.000
      DO 7 L=1,3                                                        0435.000
      P(L,J)=F1(L,J)                                                    0436.000
    7 EP(L,J)=F4(L,J)                                                   0437.000
      DO 8 L=1,6                                                        0438.000
      UIJ(L,J)=F3(L,J)                                                  0439.000
    8 EUIJ(L,J)=F6(L,J)                                                 0440.000
    9 CONTINUE                                                          0441.000
      RETURN                                                            0442.000
      END                                                               0443.000
C-----------------------------------------------------------------------0444.000
C     CALCULATE THE SORT KEY FROM AN ATOM LABEL                         0445.000
C     KS - CHEMICAL TYPE KN - NUMERIC PART KL - ALPHABETIC PART         0446.000
      SUBROUTINE DEK(TAG,KS,KN,KL)                                      0447.000
      CHARACTER*8 TAG,TG,KS,KSS                                         0448.000
      CHARACTER ITG(8),IKS(8),AN(36)                                    0449.000
      EQUIVALENCE (TG,ITG(1)),(KSS,IKS(1))                              0450.000
      DATA AN/'1','2','3','4','5','6','7','8','9','0','A','B','C','D',  0451.000
     1'E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T',  0452.000
     2'U','V','W','X','Y','Z'/                                          0453.000
      TG=TAG                                                            0454.000
      KSS='        '                                                    0455.000
      KN=0                                                              0456.000
      KL=0                                                              0457.000
      J=0                                                               0458.000
    1 J=J+1                                                             0459.000
      IF(J.GT.6)GOTO 99                                                 0460.000
      IF(ITG(J).NE.'(')GOTO 1                                           0461.000
      J=J+1                                                             0462.000
      K=J-1                                                             0463.000
    2 K=K+1                                                             0464.000
      IF(K.GT.6)GOTO 4                                                  0465.000
      IF(ITG(K).NE.'(')GOTO 2                                           0466.000
      K=K-1                                                             0467.000
      L=0                                                               0468.000
      DO 3 N=J,K                                                        0469.000
      L=L+1                                                             0470.000
    3 IKS(L)=ITG(N)                                                     0471.000
      J=K+2                                                             0472.000
    4 DO 6 K=J,8                                                        0473.000
      DO 5 L=11,36                                                      0474.000
    5 IF(ITG(K).EQ.AN(L))KL=L-10                                        0475.000
      IF(KL.GT.0)GOTO 7                                                 0476.000
    6 CONTINUE                                                          0477.000
    7 DO 9 K=J,8                                                        0478.000
      M=-1                                                              0479.000
      DO 8 L=1,10                                                       0480.000
    8 IF(ITG(K).EQ.AN(L))M=L                                            0481.000
      IF(M.LT.0.AND.KN.GT.0)GOTO 99                                     0482.000
      IF(M.LT.0)GOTO 9                                                  0483.000
      KN=KN*10+MOD(M,10)                                                0484.000
    9 CONTINUE                                                          0485.000
   99 KS=KSS                                                            0486.000
      RETURN                                                            0487.000
      END                                                               0488.000
C-----------------------------------------------------------------------0489.000
      SUBROUTINE SORT(IX,IY,N)                                          0490.000
C**** SORTS IX AND IY  WITH IX AS THE KEY                               0491.000
      DIMENSION IX(N),IY(N)                                             0492.000
      INT=2                                                             0493.000
   10 INT=2*INT                                                         0494.000
      IF(INT.LT.N) GO TO 10                                             0495.000
      INT=MIN0(N,(3*INT)/4-1)                                           0496.000
   20 INT=INT/2                                                         0497.000
      IFIN=N-INT                                                        0498.000
      DO 70 II=1,IFIN                                                   0499.000
      I=II                                                              0500.000
      J=I+INT                                                           0501.000
      IF(IX(I).LE.IX(J)) GO TO 70                                       0502.000
      L=IX(J)                                                           0503.000
      LL=IY(J)                                                          0504.000
   40 IY(J)=IY(I)                                                       0505.000
      IX(J)=IX(I)                                                       0506.000
      J=I                                                               0507.000
      I=I-INT                                                           0508.000
      IF(I.LE.0) GO TO 60                                               0509.000
      IF(IX(I).GT.L) GO TO 40                                           0510.000
   60 IY(J)=LL                                                          0511.000
      IX(J)=L                                                           0512.000
   70 CONTINUE                                                          0513.000
      IF(INT.GT.1) GO TO 20                                             0514.000
      RETURN                                                            0515.000
      END                                                               0516.000
      SUBROUTINE QUERY(LIN,LOUT,ANSWER)                                 0517.000
      CHARACTER LINE(148)                                               0518.000
      CHARACTER*8 TAG                                                   0519.000
      INTEGER FCH(20),FWD(20),ANSWER                                    0520.000
      DATA LINE/148*' '/                                                0521.000
 1001 FORMAT(72A1)                                                      0522.000
 1002 FORMAT(//9X,' PLEASE ANSWER YES OR NO'/)                          0523.000
    1 READ(LIN,1001)(LINE(I),I=2,73)                                    0524.000
      CALL PARSE(LINE,NFS,FCH,FWD)                                      0525.000
      IF(NFS.NE.1)GOTO 2                                                0526.000
      CALL AFORMT(LINE,FCH(1),FWD(1),TAG)                               0527.000
      IF(TAG.EQ.'YES'.OR.TAG.EQ.'Y')GOTO 3                              0528.000
      IF(TAG.EQ.'NO'.OR.TAG.EQ.'N')GOTO 4                               0529.000
    2 WRITE(LOUT,1002)                                                  0530.000
      GOTO 1                                                            0531.000
    3 ANSWER=1                                                          0532.000
      GOTO 5                                                            0533.000
    4 ANSWER=0                                                          0534.000
    5 RETURN                                                            0535.000
      END                                                               0536.000
      SUBROUTINE ADDH                                                   0537.000
C GENERATION OF ATOMIC POSITIONS - TRIGONAL AND TETRAHEDRAL  FEB 68     0538.000
C     AUTHOR - B.L.VICKERY                                              0539.000
C     VERSION WITH AUTOMATIC PLACING JULY 1981 P.R.MALLINSON.           0540.000
C     INCORPORATED INTO XYZ PROGRAM OF GX SYSTEM OCTOBER 1983 P.R.M.    0541.000
         CHARACTER COMPID(72)                                           0542.000
         CHARACTER*8 ATSYM(200),FTYPE(13),NEWLAB                        0543.000
         INTEGER CN(200),CONTNT(13),PRNTR                               0544.000
         DIMENSION RCP(3),OJ(3,3),S(3),          R(24,3,4),TC(3,4)      0545.000
         DIMENSION VECT(3),X(3,2),IDUM(400)                             0546.000
         COMMON/MODELC/COMPID,ATSYM,FTYPE                               0547.000
         COMMON/MODEL/NO,NR,NT,NTYPE,NFTYPE(200),ACC(3,200),            0548.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0549.000
     2   WAVEL,ABC(3),C(3),ECELL(6),ROT(24,3,4),TR(3,4),ICENT,          0550.000
     3   SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                             0551.000
      COMMON/HG/O(3,3),T(3,3),AOC(3,200),N,XB(3,200,2),IB(200,2),       0552.000
     1SP3LEN,SP2LEN                                                     0553.000
      COMMON/RADII/                  CVR(200),VDR(200),IRAD             0554.000
         COMMON PRNTR                                                   0555.000
         EQUIVALENCE (IB(1,1),IDUM(1))                                  0556.000
 111  FORMAT ('0ADDH COMPLETED')                                        0557.000
 114  FORMAT ('0NEW SYMBOL ',A8,' BOND LENGTH',F7.3,' ANGSTROMS')       0558.000
  116 FORMAT(22X,'X/A',17X,'Y/B',17X,'Z/C')                             0559.000
  117 FORMAT(7X,F20.5,F20.5,F20.5)                                      0560.000
 119     FORMAT ('H(',A6)                                               0561.000
         IRAD=1                                                         0562.000
         DO 1220 I=1,400                                                0563.000
 1220    IDUM(I)=0                                                      0564.000
      DO 3 I=1,3                                                        0565.000
    3 S(I)=SQRT(1.-C(I)*C(I))                                           0566.000
C UNIT CELL VOLUME AND TRANSFORMATION MATRICES                          0567.000
      V=SQRT(1.-C(1)**2-C(2)**2-C(3)**2+2.*C(1)*C(2)*C(3))              0568.000
      V=ABC(1)*ABC(2)*ABC(3)*V                                          0569.000
      O(1,1)=ABC(1)                                                     0570.000
         OJ(1,1)=O(1,1)                                                 0571.000
      O(1,2)=ABC(2)*C(3)                                                0572.000
         OJ(1,2)=O(1,2)                                                 0573.000
      O(1,3)=ABC(3)*C(2)                                                0574.000
         OJ(1,3)=O(1,3)                                                 0575.000
      O(2,1)=0.                                                         0576.000
         OJ(2,1)=O(2,1)                                                 0577.000
      O(2,2)=ABC(2)*S(3)                                                0578.000
         OJ(2,2)=O(2,2)                                                 0579.000
      O(2,3)=ABC(3)*(C(1)-C(2)*C(3))/S(3)                               0580.000
         OJ(2,3)=O(2,3)                                                 0581.000
      O(3,1)=0.                                                         0582.000
         OJ(3,1)=O(3,1)                                                 0583.000
      O(3,2)=0.                                                         0584.000
         OJ(3,2)=O(3,2)                                                 0585.000
      O(3,3)=V/O(1,1)/O(2,2)                                            0586.000
         OJ(3,3)=O(3,3)                                                 0587.000
      T(1,1)=1./ABC(1)                                                  0588.000
      T(1,2)=-C(3)/ABC(1)/S(3)                                          0589.000
      T(1,3)=ABC(2)*ABC(3)*(C(1)*C(3)-C(2))/V/S(3)                      0590.000
      T(2,1)=0.                                                         0591.000
      T(2,2)=1./O(2,2)                                                  0592.000
      T(2,3)=-O(2,3)*ABC(1)/V                                           0593.000
      T(3,1)=0.                                                         0594.000
      T(3,2)=0.                                                         0595.000
      T(3,3)=1./O(3,3)                                                  0596.000
         RCP(1)=ABC(2)*ABC(3)*S(1)/V                                    0597.000
         RCP(2)=ABC(1)*ABC(3)*S(2)/V                                    0598.000
         RCP(3)=ABC(1)*ABC(2)*S(3)/V                                    0599.000
         DO 1202 I=1,4                                                  0600.000
         DO 1202 J=1,3                                                  0601.000
         TC(J,I)=TR(J,I)                                                0602.000
         DO 1202 K=1,NR                                                 0603.000
 1202    R(K,J,I)=ROT(K,J,I)                                            0604.000
         N=NO                                                           0605.000
   11 DO 14 I=1,NO                                                      0606.000
      DO 14 J=1,3                                                       0607.000
   14 AOC(J,I)=                ACC(J,I)                                 0608.000
C     READ COVALENT & VAN DER WAALS RADII                               0609.000
      DO 1201 I=1,NO                                                    0610.000
      CVR(I)=SFAC(13,NFTYPE(I))                                         0611.000
 1201 VDR(I)=SFAC(14,NFTYPE(I))                                         0612.000
C        IDENTIFY ATOMS ON WHICH TO PLACE NEW POSITIONS                 0613.000
         CALL JANE(0.0,OJ,RCP)                                          0614.000
C        GENERATE METHYL HYDROGENS                                      0615.000
         DO 1204 I=1,NO                                                 0616.000
C        IB HOLDS SEQUENCE NOS OF UP TO 2 ATOMS CONNECTED TO ATOM I     0617.000
C        XB HOLDS THEIR COORDS (IN APPROPRIATE EQUIV. POSITION)         0618.000
         IF (IB(I,1).EQ.0.OR.IB(I,2).GT.0) GO TO 1204                   0619.000
C        GENERATE A METHYL H ATOM ON ATOM I (STAGGERED CONFORMATION)    0620.000
         ICON=IB(I,1)                                                   0621.000
         DO 1205 K=1,2                                                  0622.000
         IF (IB(ICON,K).NE.I.AND.IB(ICON,K).GT.0) GO TO 1206            0623.000
 1205    CONTINUE                                                       0624.000
         WRITE (PRNTR,101) ATSYM(I)                                     0625.000
 101     FORMAT (' CAN''T DEFINE CONFORMATION OF METHYL GROUP AT ',A8)  0626.000
         GO TO 1204                                                     0627.000
 1206    N=N+1                                                          0628.000
         DO 1207 J=1,3                                                  0629.000
 1207    VECT(J)=AOC(J,ICON)-XB(J,ICON,K)                               0630.000
         CALL MV(O,VECT,RCP)                                            0631.000
         RCP(1)=SQRT(RCP(1)**2+RCP(2)**2+RCP(3)**2)                     0632.000
         DO 1208 J=1,3                                                  0633.000
         X(J,1)=XB(J,I,1)                                               0634.000
         AOC(J,N)=AOC(J,I)+VECT(J)*SP3LEN/RCP(1)                        0635.000
 1208    X(J,2)=AOC(J,N)                                                0636.000
         WRITE (NEWLAB,119) ATSYM(I)                                    0637.000
         ATSYM(N)=NEWLAB                                                0638.000
         CN(N)=1                                                        0639.000
      WRITE(PRNTR,114)ATSYM(N),SP3LEN                                   0640.000
      WRITE(PRNTR,116)                                                  0641.000
      WRITE(PRNTR,117) (X(J,2),J=1,3)                                   0642.000
         CALL GEN(X,I)                                                  0643.000
 1204    CONTINUE                                                       0644.000
         DO 1203 I=1,4                                                  0645.000
         DO 1203 J=1,3                                                  0646.000
         TR(J,I)=TC(J,I)                                                0647.000
         DO 1203 K=1,NR                                                 0648.000
 1203    ROT(K,J,I)=R(K,J,I)                                            0649.000
         NO=N                                                           0650.000
         DO 10 I=1,NO                                                   0651.000
         DO 10 J=1,3                                                    0652.000
 10      ACC(J,I)=AOC(J,I)                                              0653.000
      WRITE(PRNTR,111)                                                  0654.000
         RETURN                                                         0655.000
         END                                                            0656.000
         SUBROUTINE GEN(X,IC)                                           0657.000
         CHARACTER COMPID(72)                                           0658.000
         CHARACTER*8 ATSYM(200),FTYPE(13),NEWLAB                        0659.000
         INTEGER CN(200),CONTNT(13),PRNTR                               0660.000
         REAL NORM                                                      0661.000
         DIMENSION X(3,2),AT1O(3),AT2O(3),A(3,3),B(3),D(3),E(3),F(3)    0662.000
         COMMON/MODELC/COMPID,ATSYM,FTYPE                               0663.000
         COMMON/MODEL/NO,NR,NT,NTYPE,NFTYPE(200),ACC(3,200),            0664.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0665.000
     2   WAVEL,ABC(3),C(3),ECELL(6),ROT(24,3,4),TR(3,4),ICENT,          0666.000
     3   SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                             0667.000
      COMMON/HG/O(3,3),T(3,3),AOC(3,200),N,DUM(1200),IDUM(400),         0668.000
     1SP3LEN,SP2LEN                                                     0669.000
         COMMON PRNTR                                                   0670.000
C STATEMENT FUNCTION                                                    0671.000
      NORM(X,Y,Z)=SQRT(X*X+Y*Y+Z*Z)                                     0672.000
         DATA DPR/57.29578/                                             0673.000
 114  FORMAT ('0NEW SYMBOL ',A8,' BOND LENGTH ',F6.3,' ANGSTROMS')      0674.000
  116 FORMAT(22X,'X/A',17X,'Y/B',17X,'Z/C')                             0675.000
  117 FORMAT(7X,F20.5,F20.5,F20.5)                                      0676.000
 119     FORMAT ('H(',A6)                                               0677.000
         NUMBR=CN(IC)-2                                                 0678.000
         CALL MV(O,X(1,1),A(1,1))                                       0679.000
         CALL MV(O,AOC(1,IC),A(1,2))                                    0680.000
         CALL MV(O,X(1,2),A(1,3))                                       0681.000
C CALCULATION OF ATOMIC POSITIONS IN ORTHONORMAL SPACE                  0682.000
      DO 30 I=1,3                                                       0683.000
      B(I)=A(I,2)-A(I,1)                                                0684.000
   30 D(I)=A(I,2)-A(I,3)                                                0685.000
      BNORM=NORM(B(1),B(2),B(3))                                        0686.000
      DNORM=NORM(D(1),D(2),D(3))                                        0687.000
      DO 31 I=1,3                                                       0688.000
      B(I)=B(I)/BNORM                                                   0689.000
      D(I)=D(I)/DNORM                                                   0690.000
   31 E(I)=B(I)+D(I)                                                    0691.000
      ENORM=NORM(E(1),E(2),E(3))                                        0692.000
      DO 32 I=1,3                                                       0693.000
 32   E(I)=E(I)/ENORM                                                   0694.000
         GO TO (34,33),NUMBR                                            0695.000
   33 DO 35 I=1,3                                                       0696.000
      J=I+1                                                             0697.000
      IF(J-3)36,36,37                                                   0698.000
   37 J=J-3                                                             0699.000
   36 K=J+1                                                             0700.000
      IF(K-3)38,38,39                                                   0701.000
   39 K=K-3                                                             0702.000
   38 F(I)=B(J)*D(K)-B(K)*D(J)                                          0703.000
   35 CONTINUE                                                          0704.000
      FNORM=NORM(F(1),F(2),F(3))                                        0705.000
      R=54.5/DPR                                                        0706.000
         BOND=SP3LEN                                                    0707.000
      G=COS(R)*BOND                                                     0708.000
      H=SIN(R)*BOND                                                     0709.000
      DO 40 I=1,3                                                       0710.000
      F(I)=F(I)/FNORM                                                   0711.000
      AT1O(I)=A(I,2)+G*E(I)+H*F(I)                                      0712.000
   40 AT2O(I)=A(I,2)+G*E(I)-H*F(I)                                      0713.000
         CALL MV(T,AT1O,X(1,1))                                         0714.000
         CALL MV(T,AT2O,X(1,2))                                         0715.000
         N=N+1                                                          0716.000
         WRITE (NEWLAB,119)     ATSYM(IC)                               0717.000
         ATSYM(N)=NEWLAB                                                0718.000
         CN(N)=1                                                        0719.000
         DO 1 I=1,3                                                     0720.000
 1       AOC(I,N)=X(I,1)                                                0721.000
         N=N+1                                                          0722.000
         WRITE (NEWLAB,119)     ATSYM(IC)                               0723.000
         ATSYM(N)=NEWLAB                                                0724.000
         CN(N)=1                                                        0725.000
         DO 2 I=1,3                                                     0726.000
 2       AOC(I,N)=X(I,2)                                                0727.000
      WRITE(PRNTR,114)ATSYM(N),BOND                                     0728.000
      WRITE(PRNTR,116)                                                  0729.000
      WRITE(PRNTR,117) X                                                0730.000
      GO TO 19                                                          0731.000
 34      BOND=SP2LEN                                                    0732.000
      DO 47 I=1,3                                                       0733.000
   47 AT1O(I)=A(I,2)+E(I)*BOND                                          0734.000
         CALL MV(T,AT1O,X(1,1))                                         0735.000
         N=N+1                                                          0736.000
         WRITE (NEWLAB,119)     ATSYM(IC)                               0737.000
         ATSYM(N)=NEWLAB                                                0738.000
         CN(N)=1                                                        0739.000
         DO 4 I=1,3                                                     0740.000
 4       AOC(I,N)=X(I,1)                                                0741.000
      WRITE(PRNTR,114)ATSYM(N),BOND                                     0742.000
      WRITE(PRNTR,116)                                                  0743.000
      WRITE(PRNTR,117) (X(I,1),I=1,3)                                   0744.000
 19      RETURN                                                         0745.000
      END                                                               0746.000
      SUBROUTINE JANE(          AMIN,             U,      RCP)          0747.000
C     INTERATOMIC DISTANCE, ANGLE           PROGRAM                     0748.000
C     P.R.MALLINSON   MAY 1973    FROM AN ALGORITHM BY J.S.ROLLETT      0749.000
C     PROGRAM JANE - JUXTAPOSITION, ANGLES                              0750.000
C     ROUTINE OF GEOM   JULY 1976  P.R.M.                               0751.000
         CHARACTER COMPID(72)                                           0752.000
      CHARACTER*8 ATOM(200),FTYPE(13)                                   0753.000
      INTEGER S,COUNT(3),CN(200),CONTNT(13)                             0754.000
      DIMENSION RCP(3),U(3,3)                                           0755.000
      COMMON                         IPRIN,XJ(3),I,J,S,D(3),            0756.000
     1           JATOM(10), XA(3,10),   DMAX2,COUNT,INT,IS,IC(3),ND     0757.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                0758.000
         COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),X(3,200),                0759.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0760.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0761.000
     3   SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                             0762.000
C     N = NO. OF ATOMS, M = NO. OF SYMMETRY OPERATIONS                  0763.000
C     NT = NO. OF LATTICE POINTS, ICENT = 0/1 CENTRO/NON-CENTRO         0764.000
      CALL SYMM(DMAX,AMAX,AMIN,U,RCP)                                   0765.000
      RETURN                                                            0766.000
      END                                                               0767.000
      SUBROUTINE SYMM(  DMAX,AMAX,AMIN,             U,  RCP)            0768.000
C     TO GENERATE THE EQUIVALENT POSITIONS                              0769.000
      CHARACTER              COMPID(72)                                 0770.000
      CHARACTER*8 ATOM(200),FTYPE(13)                                   0771.000
      INTEGER S,CN(200),CONTNT(13)                                      0772.000
      DIMENSION RCP(3),          CP(3),DIST(3),       XOUT(3,2),        0773.000
     1U(3,3)                                                            0774.000
      COMMON                         IPRIN,XJ(3),I,J,S,D(3),            0775.000
     1           JATOM(10), XA(3,10),   DMAX2,KOUNT(3),INT,IS,IC(3),ND  0776.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                0777.000
         COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),X(3,200),                0778.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0779.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0780.000
     3   SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                             0781.000
      COMMON/RADII/                  CVR(200),VDR(200),IRAD             0782.000
      COMMON/HG/DUMMY(18),AOC(3,200),NO,XB(3,200,2),IB(200,2),SP3LEN,   0783.000
     1SP2LEN                                                            0784.000
 100  FORMAT ('0METHENE CASE - UNWANTED NEW ATOM NO.',I2,' ABOVE IS DISC0785.000
     1ARDED')                                                           0786.000
      DO 1 L=1,3                                                        0787.000
      IC(L)=L                                                           0788.000
 1    D(L)=1./RCP(L)                                                    0789.000
C     CHANGE AXES SO THAT D(100).GE.D(010).GE.D(001)                    0790.000
      DO 2 K=1,2                                                        0791.000
      K1=K+1                                                            0792.000
      DO 2 L=K1,3                                                       0793.000
      IF (D(K)-D(L)) 3,2,2                                              0794.000
 3    DO 4 K2=1,N                                                       0795.000
 4    CALL ROTAT(X(K,K2),X(L,K2))                                       0796.000
      DO 5 K2=1,M                                                       0797.000
C     INTERCHANGE COLS OF ROTATION MATRIX                               0798.000
      DO 28 K3=1,3                                                      0799.000
 28   CALL ROTAT (R(K2,K3,K),R(K2,K3,L))                                0800.000
C     INTERCHANGE ROWS OF ROTATION MATRIX AND TRANSLATION VECTOR        0801.000
      DO 5 K3=1,4                                                       0802.000
 5    CALL ROTAT(R(K2,K,K3),R(K2,L,K3))                                 0803.000
      DO 27 K2=1,NT                                                     0804.000
 27   CALL ROTAT(T(K,K2),T(L,K2))                                       0805.000
      CALL ROTA2(IC(K),IC(L))                                           0806.000
      CALL ROTAT(D(K),D(L))                                             0807.000
C     INTERCHANGE ROWS AND COLS OF ORTHOGONALISATION MATRIX             0808.000
      DO 41 K3=1,3                                                      0809.000
 41   CALL ROTAT(U(K,K3),U(L,K3))                                       0810.000
      DO 42 K3=1,3                                                      0811.000
 42   CALL ROTAT(U(K3,K),U(K3,L))                                       0812.000
 2    CONTINUE                                                          0813.000
      I1=IC(1)                                                          0814.000
      I2=IC(2)                                                          0815.000
      I3=IC(3)                                                          0816.000
C     ATOM1 LOOP                                                        0817.000
      DO 11 I=1,N                                                       0818.000
      ND=0                                                              0819.000
C     ATOM2 LOOP                                                        0820.000
      DO 10 J=1,N                                                       0821.000
      IF (IRAD.EQ.0) GO TO 200                                          0822.000
      DMAX=VDR(I)+VDR(J)                                                0823.000
      DMAX2=DMAX*DMAX                                                   0824.000
      AMAX=CVR(I)+CVR(J)                                                0825.000
C     EQUIV POSN LOOP                                                   0826.000
 200  DO 9 S=1,M                                                        0827.000
      IS=1                                                              0828.000
      DO 8 L=1,3                                                        0829.000
 8    CP(L)=X(1,J)*R(S,L,1)+X(2,J)*R(S,L,2)+X(3,J)*R(S,L,3)+R(S,L,4)    0830.000
C     LATTICE POINT LOOP                                                0831.000
 21   DO 17 INT=1,NT                                                    0832.000
      IF (J-I) 7,6,7                                                    0833.000
 6    IF (S-1) 7,19,7                                                   0834.000
 19   IF (INT-1) 7,26,7                                                 0835.000
 26   IF (IS-1) 17,17,7                                                 0836.000
 7    DO 20 L=1,3                                                       0837.000
 20   XJ(L)=CP(L)+T(L,INT)                                              0838.000
      CALL TRSLN(DMAX,AMAX,AMIN,U)                                      0839.000
 17   CONTINUE                                                          0840.000
C     INVERSION IF CENTROSYMMETRIC                                      0841.000
      IF (ICENT) 25,25,9                                                0842.000
 25   IF (IS-1) 22,22,9                                                 0843.000
 22   DO 24 L=1,3                                                       0844.000
 24   CP(L)=-CP(L)                                                      0845.000
      IS=2                                                              0846.000
      GO TO 21                                                          0847.000
 9    CONTINUE                                                          0848.000
 10   CONTINUE                                                          0849.000
         IF (ND-1) 11,704,15                                            0850.000
 704     IF (CN(I).LT.4) GO TO 11                                       0851.000
         XB(I1,I,1)=XA(1,1)                                             0852.000
         XB(I2,I,1)=XA(2,1)                                             0853.000
         XB(I3,I,1)=XA(3,1)                                             0854.000
         IB(I,1)=JATOM(1)                                               0855.000
         GO TO 11                                                       0856.000
 15   XOUT(I1,1)=XA(1,  1)                                              0857.000
      XOUT(I2,1)=XA(2,  1)                                              0858.000
      XOUT(I3,1)=XA(3,  1)                                              0859.000
      XOUT(I1,2)=XA(1,  2)                                              0860.000
      XOUT(I2,2)=XA(2,  2)                                              0861.000
      XOUT(I3,2)=XA(3,  2)                                              0862.000
         DO 703 K=1,2                                                   0863.000
         DO 703 L=1,3                                                   0864.000
 703     XB(L,I,K)=XOUT(L,K)                                            0865.000
         IB(I,1)=JATOM(1)                                               0866.000
         IB(I,2)=JATOM(2)                                               0867.000
         IF (ND.GE.CN(I)) GO TO 11                                      0868.000
C        GENERATE METHENE, METHYLENE, OR PHENYL H ATOMS                 0869.000
         CALL GEN(XOUT,I)                                               0870.000
         IF (CN(I).LT.4) GO TO 11                                       0871.000
C        CHECK FOR METHENE CASE, AND DISCARD UNWANTED H IF SO           0872.000
         DO 700 K=1,2                                                   0873.000
         DO 700 L=1,ND                                                  0874.000
         RCP(1)=XOUT(I1,K)-XA(1,L)                                      0875.000
         RCP(2)=XOUT(I2,K)-XA(2,L)                                      0876.000
         RCP(3)=XOUT(I3,K)-XA(3,L)                                      0877.000
         CALL MV(U,RCP,DIST)                                            0878.000
         IF ((DIST(1)**2+DIST(2)**2+DIST(3)**2).LT.1.0)  GO TO 701      0879.000
 700     CONTINUE                                                       0880.000
         GO TO 11                                                       0881.000
 701     NO=NO-1                                                        0882.000
         WRITE (IPRIN,100) K                                            0883.000
         IF (K.EQ.2) GO TO 11                                           0884.000
         DO 702 K=1,3                                                   0885.000
 702     AOC(K,NO)=AOC(K,NO+1)                                          0886.000
 11   CONTINUE                                                          0887.000
      RETURN                                                            0888.000
      END                                                               0889.000
      SUBROUTINE TRSLN(DMAX,AMAX,AMIN,U)                                0890.000
C     TO APPLY THE LATTICE TRANSLATIONS                                 0891.000
      CHARACTER              COMPID(72)                                 0892.000
      CHARACTER*8 ATOM(200),FTYPE(13)                                   0893.000
      INTEGER S,COUNT(3),CN(200),CONTNT(13)                             0894.000
      DIMENSION U(3,3)                                                  0895.000
      COMMON                         IPRIN,XJ(3),I,J,S,D(3),            0896.000
     1           JATOM(10), XA(3,10),   DMAX2,COUNT,INT,IS,IC(3),ND     0897.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                0898.000
         COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),X(3,200),                0899.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0900.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0901.000
     3   SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                             0902.000
      K=1                                                               0903.000
      DO 2 L=1,3                                                        0904.000
 2    COUNT(L)=0                                                        0905.000
      GO TO 4                                                           0906.000
 3    XJ(K)=XJ(K)-1.                                                    0907.000
      COUNT(K)=COUNT(K)-1                                               0908.000
 4    IF ((X(K,I)-XJ(K))*D(K)-DMAX) 3,3,7                               0909.000
 6    W=(X(K,I)-XJ(K))*D(K)                                             0910.000
      IF (W+DMAX) 7,14,14                                               0911.000
 14   IF (W-DMAX) 11,11,7                                               0912.000
 7    XJ(K)=XJ(K)+1.                                                    0913.000
      COUNT(K)=COUNT(K)+1                                               0914.000
      IF ((X(K,I)-XJ(K))*D(K)+DMAX) 9,6,6                               0915.000
 9    K=K-1                                                             0916.000
      IF (K) 15,15,7                                                    0917.000
 15   RETURN                                                            0918.000
 11   K=K+1                                                             0919.000
      IF (K-3) 4,4,13                                                   0920.000
 13   CALL DISTN(AMAX,AMIN,U)                                           0921.000
      K=K-1                                                             0922.000
      GO TO 7                                                           0923.000
      END                                                               0924.000
      SUBROUTINE DISTN(AMAX,AMIN,U)                                     0925.000
C     TO CALCULATE AND PRINT AN INTERATOMIC DISTANCE                    0926.000
      CHARACTER              COMPID(72)                                 0927.000
      CHARACTER*8 ATOM(200),FTYPE(13)                                   0928.000
      INTEGER S,COUNT(3),        CN(200),CONTNT(13)                     0929.000
      DIMENSION DELX1(3),DELX2(3),                 U(3,3)               0930.000
      COMMON                          IPRIN,XJ(3),I,J,S,D(3),           0931.000
     1           JATOM(10), XA(3,10),   DMAX2,COUNT,INT,IS,IC(3),ND     0932.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                0933.000
         COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),XI(3,200),               0934.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0935.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0936.000
     3   SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                             0937.000
 100  FORMAT (' MORE THAN 10 ATOMS ARE CONNECTED TO ',A8,' - CHECK RADII0938.000
     1')                                                                0939.000
      DO 1 L=1,3                                                        0940.000
 1    DELX1(L)=XI(L,I)-XJ(L)                                            0941.000
      CALL MV(U,DELX1,DELX2)                                            0942.000
      DIST=DELX2(1)*DELX2(1)+DELX2(2)*DELX2(2)+DELX2(3)*DELX2(3)        0943.000
      IF (DIST-DMAX2) 4,4,5                                             0944.000
 4    DIST=SQRT(DIST)                                                   0945.000
      IF (DIST.GT.AMAX.OR.DIST.LT.AMIN) RETURN                          0946.000
      ND=ND+1                                                           0947.000
         IF (ND.GT.10) GO TO 99                                         0948.000
      XA(1,ND)=XJ(1)                                                    0949.000
      XA(2,ND)=XJ(2)                                                    0950.000
      XA(3,ND)=XJ(3)                                                    0951.000
      JATOM(ND)=J                                                       0952.000
      RETURN                                                            0953.000
   99 WRITE (IPRIN,100)     ATOM(I)                                     0954.000
 5    RETURN                                                            0955.000
      END                                                               0956.000
      SUBROUTINE MV(A,Y,X)                                              0957.000
C     AY=X                                                              0958.000
      DIMENSION A(3,3),X(3),Y(3)                                        0959.000
      X(1)=A(1,1)*Y(1)+A(1,2)*Y(2)+A(1,3)*Y(3)                          0960.000
      X(2)=A(2,1)*Y(1)+A(2,2)*Y(2)+A(2,3)*Y(3)                          0961.000
      X(3)=A(3,1)*Y(1)+A(3,2)*Y(2)+A(3,3)*Y(3)                          0962.000
      RETURN                                                            0963.000
      END                                                               0964.000
      SUBROUTINE ROTAT(X,Y)                                             0965.000
      Z=Y                                                               0966.000
      Y=X                                                               0967.000
      X=Z                                                               0968.000
      RETURN                                                            0969.000
      END                                                               0970.000
      SUBROUTINE ROTA2(I,J)                                             0971.000
      K=J                                                               0972.000
      J=I                                                               0973.000
      I=K                                                               0974.000
      RETURN                                                            0975.000
      END                                                               0976.000
