C        (C) COPYRIGHT 1985 UNIVERSITY OF GLASGOW                       0001.000
C        GEOMETRY PROGRAM GEOM   MARCH 1986                             0002.000
C        GX PACKAGE  APRIL 1985   PAUL R. MALLINSON                     0003.000
C                                                                       0004.000
         PROGRAM GEOMPRM                                                0005.000
         CHARACTER FSPEC(80),           COMPID(72),LINE(148)            0006.000
      CHARACTER*8 ATM(200),       FTYPE(13),TAG,STRING                  0007.000
      CHARACTER*80 CBUF                                                 0008.000
      INTEGER               CN(200),CONTNT(13),FIRSTC(20),FWIDTH(20)    0009.000
         LOGICAL FIRST,SPPOS                                            0010.000
      DIMENSION OM(3,3),RCP(3)                                          0011.000
      COMMON  IPRIN,LPP,ICORR,IRAD,IC(3),FIRSTC,FWIDTH,TITLE(20),X(3),  0012.000
     1   S(9),P(3,3),DUM(270)                                           0013.000
         COMMON/MODELC/COMPID,ATM,FTYPE                                 0014.000
         COMMON/MODEL/N,NR,NLATT,NTYPE,   NJD(200),XR(3,200),           0015.000
     1   CN,SOF(200),UIJ(6,200),CIG(3,200),ESOF(200),SIGUIJ(6,200),     0016.000
     2   WAVEL,U,V,W,COSALP,COSBET,COSGAM,ECELL(6),R(24,3,4),           0017.000
     3   T(3,4),ICENT,SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                0018.000
      COMMON /LIMITS/MAXYZ,MAXUIJ,MAXBON                                0019.000
         COMMON/ESDS/         XIG(6,200)                                0020.000
         COMMON/CHARA/LINE,FSPEC                                        0021.000
         COMMON/CONSTR/NCON,ICON(99,2),EFACT(99,2)                      0022.000
         COMMON/OSLO/SPPOS                                              0023.000
         EQUIVALENCE (CBUF,LINE(7))                                     0024.000
      DATA INTRAL,INTRAA/2*0/,IPUBS/0/,FIRST/.TRUE./,DMAX/0.0/,AMAX/0.0/0025.000
      DATA INTERL,MPLANE,NDIANG/0,0,0/,BLANK/' '/,ILOC/0/,ISTOP/0/      0026.000
         DATA DMIN/0.01/                                                0027.000
 100     FORMAT ('0BOND DISTANCES ARE SUMS OF COVALENT RADII')          0028.000
 101     FORMAT (20A4)                                                  0029.000
 102  FORMAT (80A1)                                                     0030.000
  104 FORMAT(1X,A7,   F8.5,2F9.5,3F8.5,3F8.4,3F8.5)                     0031.000
 109     FORMAT (' ',72A1)                                              0032.000
 209  FORMAT (' ',20A4)                                                 0033.000
 110  FORMAT('0    A =',F8.4,'(',F7.4,')   B =',F8.4,'(',F7.4,')    C ='0034.000
     1,F8.4,'(',F7.4,')'/' ALPHA =',F8.3,'(',F6.3,') BETA =',F8.3,'(',  0035.000
     2F6.3,') GAMMA =',F8.3,'(',F6.3,')')                               0036.000
 111  FORMAT ('0BONDS FROM',F6.2,' A TO',F6.2,' A')                     0037.000
  112 FORMAT(       '           FRACTIONAL COORDINATES    STANDARD DEVIA0038.000
     1TIONS  ORTHOGONAL COORDINATES (A)  STANDARD DEVIATIONS')          0039.000
  113 FORMAT(      ' ATOM        X        Y        Z      SIGX    SIGY  0040.000
     1  SIGZ     X       Y       Z      SIGX    SIGY    SIGZ')          0041.000
 114     FORMAT ('0CELL COSINES WILL BE USED AS CORRELATION COEFFICIENTS0042.000
     1')                                                                0043.000
 115     FORMAT ('0****** CORRELATION MATRIX AND COORDINATES FROM ITS FI0044.000
     1LE WILL BE USED FOR'/' INTERATOMIC DISTANCES AND BOND ANGLES *****0045.000
     2*')                                                               0046.000
 116     FORMAT ('0ASYMMETRIC FLAG IS SET - SYMMETRY OPERATIONS WILL BE'0047.000
     1/' APPLIED ONLY FOR NON-BONDED DISTANCES AND CONTACTS')           0048.000
 425     FORMAT (1X,A8,' <<<<<<< COMMAND NOT RECOGNISED')               0049.000
 504     FORMAT ('1')                                                   0050.000
 1041 FORMAT (1H+,105X,2F10.3)                                          0051.000
20000 FORMAT (' GEOM COMPLETED')                                        0052.000
69827 FORMAT('0ORTHOGONALISATION MATRIX FOR CARTESIAN SYSTEM DEFINED BY 0053.000
     1A AND B*'/3(3F12.5/))                                             0054.000
69828 FORMAT (' CELL VOLUME =',F9.2,'(',F5.2,') A**3'/)                 0055.000
 1222 FORMAT(1H+,107X,'COVALENT & CONTACT RADII')                       0056.000
 1592    FORMAT(' PLEASE TYPE COMMANDS (1ST 3 LETTERS) FROM THE LIST, TE0057.000
     1RMINATED BY A BLANK LINE:'/' TITLE <TITLE>'/' ATOMS <SIGMA(XYZ) LI0058.000
     2MIT> <SIGMA(UIJ) LIMIT> (DEFAULTS 20, 10)'/                       0059.000
     3' BONDS <SIGMA(BOND LENGTH) LIMIT (DEFAULT 20)> <DMAX> <DMIN>'/   0060.000
     4' ANGLES <DMAX> <DMIN>'/' TORSION_ANGLES <DMAX> <DMIN>'/          0061.000
     5' ASYMMETRIC'/' PLANES'/' LOCAL_GEOMETRY <DMAX> <DMIN>'/          0062.000
     6' NON-BONDED_DISTANCES <DMAX> <DMIN>'/' CONTACTS <DMAX> <DMIN>'/  0063.000
     7' CORRELATIONS GIVEN'/' PRINT <NO. OF COPIES>'/' PAGE_LENGTH <NO. 0064.000
     8OF LINES> (DEFAULT 35)    S  (FOR SINGLE COLUMN)'/' EXIT')        0065.000
 1594    FORMAT ('0N.B. COVALENT & VAN DER WAALS RADII ARE USED UNLESS D0066.000
     1MAX IS GIVEN')                                                    0067.000
         MAXYZ=20                                                       0068.000
         MAXUIJ=10                                                      0069.000
         MAXBON=20                                                      0070.000
         IRAD=1                                                         0071.000
      ICORR=0                                                           0072.000
         LPP=35                                                         0073.000
         STRING=' '                                                     0074.000
         SPPOS=.FALSE.                                                  0075.000
         IPRIN=6                                                        0076.000
         NCOPS=1                                                        0077.000
         DO 2 I=1,145                                                   0078.000
 2       LINE(I)=' '                                                    0079.000
         DO 1 I=1,3                                                     0080.000
 1       IC(I)=I                                                        0081.000
         DO 1593 I=1,20                                                 0082.000
 1593    TITLE(I)=BLANK                                                 0083.000
C * * * * GOULD-S.E.L. ONLY  * * * * *                                  0084.000
C        CALL X:GDSPCE(15,NGET,,)                                       0085.000
C        CALL X:GDSPCE(15,NGET,,)                                       0086.000
C        CALL X:GDSPCE(1,NGET,,)                                        0087.000
C * * * * END GOULD-S.E.L. CODE * * * *                                 0088.000
         CALL MDLIN(16)                                                 0089.000
C        THE FOLLOWING ALLOWS THE INTERATOMIC DISTANCE ROUTINE          0090.000
C        TO WORK WITH ORTHOGONAL COORDINATES IN THE MODEL FILE          0091.000
         IF (U.EQ.1.0.AND.V.EQ.1.0.AND.W.EQ.1.0) THEN                   0092.000
         U=10.                                                          0093.000
         V=10.                                                          0094.000
         W=10.                                                          0095.000
         DO 3 I=1,N                                                     0096.000
         DO 3 J=1,3                                                     0097.000
 3       XR(J,I)=XR(J,I)*0.1                                            0098.000
         ENDIF                                                          0099.000
 501     WRITE (6,1592)                                                 0100.000
         WRITE (6,1594)                                                 0101.000
 411     READ (1,102,END=412) (LINE(I),I=2,73)                          0102.000
         CALL PARSE(LINE,NFIELD,FIRSTC,FWIDTH)                          0103.000
         IF (NFIELD.EQ.0) GO TO 412                                     0104.000
         IF (FWIDTH(1).GT.3) FWIDTH(1)=3                                0105.000
         CALL AFORMT(LINE,FIRSTC(1),FWIDTH(1),TAG)                      0106.000
         IF (TAG.NE.'TIT')   GO TO 410                                  0107.000
         READ (CBUF,101) TITLE                                          0108.000
         GO TO 411                                                      0109.000
 410     IF (TAG.NE.'BON')   GO TO 413                                  0110.000
         INTRAL=1                                                       0111.000
         IF(NFIELD.GT.1)CALL IFORMT(LINE,FIRSTC(2),FWIDTH(2),MAXBON)    0112.000
         IF (NFIELD.GT.2) THEN                                          0113.000
                           CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMAX)   0114.000
         IF (NFIELD.GT.3) CALL FFORMT(LINE,FIRSTC(4),FWIDTH(4),DMIN)    0115.000
         IF (DMAX.GT.DMIN) THEN                                         0116.000
         IRAD=0                                                         0117.000
         ELSE                                                           0118.000
         WRITE (6,999)                                                  0119.000
 999     FORMAT (' DMAX MUST BE GREATER THAN DMIN. PLEASE REPEAT')      0120.000
         ENDIF                                                          0121.000
         ENDIF                                                          0122.000
         GO TO 411                                                      0123.000
 413     IF (TAG.NE.'ANG')    GO TO 414                                 0124.000
         INTRAA=1                                                       0125.000
         IF (NFIELD.GT.1) THEN                                          0126.000
                           CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),DMAX)   0127.000
         IF (NFIELD.GT.2) CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMIN)    0128.000
         IF (DMAX.GT.DMIN) THEN                                         0129.000
         IRAD=0                                                         0130.000
         ELSE                                                           0131.000
         WRITE (6,999)                                                  0132.000
         ENDIF                                                          0133.000
         ENDIF                                                          0134.000
         GO TO 411                                                      0135.000
 414     IF (TAG.NE.'LOC')     GO TO 415                                0136.000
         ILOC=1                                                         0137.000
         IF (NFIELD.GT.1) THEN                                          0138.000
                           CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),DMAX)   0139.000
         IF (NFIELD.GT.2) CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMIN)    0140.000
         IF (DMAX.GT.DMIN) THEN                                         0141.000
         IRAD=0                                                         0142.000
         ELSE                                                           0143.000
         WRITE (6,999)                                                  0144.000
         ENDIF                                                          0145.000
         ENDIF                                                          0146.000
         GO TO 411                                                      0147.000
 415     IF (TAG.NE.'CON')      GO TO 416                               0148.000
         INTERL=-1                                                      0149.000
         IF (NFIELD.GT.1) THEN                                          0150.000
                           CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),AMAX)   0151.000
         IF (NFIELD.GT.2) CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMAX)    0152.000
         IF (AMAX.GT.DMAX) THEN                                         0153.000
         IRAD=0                                                         0154.000
         ELSE                                                           0155.000
         WRITE (6,999)                                                  0156.000
         ENDIF                                                          0157.000
         ENDIF                                                          0158.000
         GO TO 411                                                      0159.000
 416     IF (TAG.NE.'PLA')    GO TO 417                                 0160.000
         MPLANE=1                                                       0161.000
         GO TO 411                                                      0162.000
 417     IF (TAG.NE.'TOR')     GO TO 418                                0163.000
         NDIANG=1                                                       0164.000
         IF (NFIELD.GT.1) THEN                                          0165.000
                           CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),DMAX)   0166.000
         IF (NFIELD.GT.2) CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMIN)    0167.000
         IF (DMAX.GT.DMIN) THEN                                         0168.000
         IRAD=0                                                         0169.000
         ELSE                                                           0170.000
         WRITE (6,999)                                                  0171.000
         ENDIF                                                          0172.000
         ENDIF                                                          0173.000
         GO TO 411                                                      0174.000
 418     IF (TAG.NE.'PAG')  GO TO 420                                   0175.000
         IF (NFIELD.GT.1) CALL IFORMT(LINE,FIRSTC(2),FWIDTH(2),LPP)     0176.000
         IF (NFIELD.GT.2) CALL AFORMT(LINE,FIRSTC(3),FWIDTH(3),STRING)  0177.000
         GO TO 411                                                      0178.000
 420     IF (TAG.NE.'COR')     GO TO 421                                0179.000
         ICORR=1                                                        0180.000
         GO TO 411                                                      0181.000
 421     IF (TAG.NE.'NON') GO TO 423                                    0182.000
         INTERL=-2                                                      0183.000
         IF (NFIELD.GT.1) THEN                                          0184.000
                           CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),AMAX)   0185.000
         IF (NFIELD.GT.2) CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMAX)    0186.000
         IF (AMAX.GT.DMAX) THEN                                         0187.000
         IRAD=0                                                         0188.000
         ELSE                                                           0189.000
         WRITE (6,999)                                                  0190.000
         ENDIF                                                          0191.000
         ENDIF                                                          0192.000
         GO TO 411                                                      0193.000
 423     IF (TAG.NE.'ATO')   GO TO 424                                  0194.000
         IF(NFIELD.GT.1)CALL IFORMT(LINE,FIRSTC(2),FWIDTH(2),MAXYZ)     0195.000
         IF(NFIELD.GT.2)CALL IFORMT(LINE,FIRSTC(3),FWIDTH(3),MAXUIJ)    0196.000
         IPUBS=1                                                        0197.000
         GO TO 411                                                      0198.000
 424     IF (TAG.NE.'PRI') GO TO 427                                    0199.000
         IPRIN=3                                                        0200.000
         IF (NFIELD.GT.1) CALL IFORMT(LINE,FIRSTC(2),FWIDTH(2),NCOPS)   0201.000
         GO TO 411                                                      0202.000
 427     IF (TAG.NE.'ASY') GO TO 428                                    0203.000
         SPPOS=.TRUE.                                                   0204.000
         GO TO 411                                                      0205.000
 428     IF (TAG.EQ.'EXI') THEN                                         0206.000
         ISTOP=1                                                        0207.000
         ELSE                                                           0208.000
         WRITE (6,425) TAG                                              0209.000
         GO TO 411                                                      0210.000
         ENDIF                                                          0211.000
 412     WRITE (IPRIN,109) COMPID                                       0212.000
         ICALC=NDIANG+INTRAL+INTRAA+MPLANE+ILOC+IABS(INTERL)            0213.000
         IF (.NOT.FIRST) GO TO 502                                      0214.000
      WRITE(IPRIN,209)        TITLE                                     0215.000
      SINALP=SQRT(1.-COSALP*COSALP)                                     0216.000
      SINBET=SQRT(1.-COSBET*COSBET)                                     0217.000
      SINGAM=SQRT(1.-COSGAM*COSGAM)                                     0218.000
      WRITE (IPRIN,110) U,ECELL(1),V,ECELL(2),W,ECELL(3),ACOS(COSALP)*  0219.000
     157.29578,ECELL(4)*57.29578/SINALP,ACOS(COSBET)*57.29578,ECELL(5)* 0220.000
     257.29578/SINBET,ACOS(COSGAM)*57.29578,ECELL(6)*57.29578/SINGAM    0221.000
      Q=(COSALP-COSBET*COSGAM)/SINGAM                                   0222.000
      PZ=SINBET*SINBET-Q*Q                                              0223.000
      PZ=SQRT(PZ)                                                       0224.000
C     FORM ORTHOGONALISATION MATRIX                                     0225.000
      OM(1,1)=U                                                         0226.000
      OM(1,2)=V*COSGAM                                                  0227.000
      OM(1,3)=W*COSBET                                                  0228.000
      OM(2,1)=0.                                                        0229.000
      OM(2,2)=V*SINGAM                                                  0230.000
      OM(2,3)=W*Q                                                       0231.000
      OM(3,1)=0.                                                        0232.000
      OM(3,2)=0.                                                        0233.000
      OM(3,3)=W*PZ                                                      0234.000
      IF (ICALC.NE.0) WRITE (IPRIN,69827) ((OM(I,J),J=1,3),I=1,3)       0235.000
      VOL=U*V*W*SQRT(1.-COSALP**2-COSBET**2-COSGAM**2+                  0236.000
     12.*COSALP*COSBET*COSGAM)                                          0237.000
      PZ=(U*V*W/VOL)**2                                                 0238.000
      EVOL=VOL*SQRT((ECELL(1)/U)**2+(ECELL(2)/V)**2+(ECELL(3)/W)**2+    0239.000
     1(PZ*(-COSALP      +COSBET*COSGAM)*ECELL(4))**2+(PZ*(-COSBET      +0240.000
     2COSALP*COSGAM)*ECELL(5))**2+(PZ*(-COSGAM      +COSALP*COSBET)*    0241.000
     3ECELL(6))**2)                                                     0242.000
      WRITE (IPRIN,69828) VOL,EVOL                                      0243.000
      REWIND 16                                                         0244.000
      IREM=0                                                            0245.000
 701  READ (16,102,END=700) (LINE(I),I=2,73)                            0246.000
      CALL PARSE(LINE,NFIELDS,FIRSTC,FWIDTH)                            0247.000
      IF (NFIELDS.EQ.0) GO TO 701                                       0248.000
      CALL AFORMT(LINE,FIRSTC(1),3,TAG)                                 0249.000
      IF (TAG.NE.'REM') GO TO 701                                       0250.000
      IREM=IREM+1                                                       0251.000
      WRITE (IPRIN,109) (LINE(I),I=2,73)                                0252.000
      GO TO 701                                                         0253.000
 700  RCP(1)=V*W*SINALP/VOL                                             0254.000
      RCP(2)=U*W*SINBET/VOL                                             0255.000
      RCP(3)=U*V*SINGAM/VOL                                             0256.000
      IF (IPRIN.NE.6.AND.ICALC.NE.0) WRITE(IPRIN,112)                   0257.000
      IF ((IRAD.EQ.1.OR.DMAX.EQ.0.).AND.IPRIN.NE.6.AND.ICALC.NE.0)      0258.000
     1   WRITE (IPRIN,1222)                                             0259.000
      IF (IPRIN.NE.6.AND.ICALC.NE.0) WRITE(IPRIN,113)                   0260.000
      DO 130 I=1,N                                                      0261.000
C     FORM VARIANCE MATRIX S                                            0262.000
      DO 600 J=1,3                                                      0263.000
 600  S(J)=CIG(J,I)**2                                                  0264.000
      S(4)=-COSGAM*CIG(1,I)*CIG(2,I)                                    0265.000
      S(5)=-COSBET*CIG(1,I)*CIG(3,I)                                    0266.000
      S(6)=-COSALP*CIG(2,I)*CIG(3,I)                                    0267.000
      CALL TRANM(S,OM,P)                                                0268.000
      DO 601 J=1,3                                                      0269.000
 601  XIG(J,I)=P(J,J)                                                   0270.000
      XIG(4,I)=P(1,2)                                                   0271.000
      XIG(5,I)=P(1,3)                                                   0272.000
      XIG(6,I)=P(2,3)                                                   0273.000
         DO 500 J=1,3                                                   0274.000
 500     S(J)=SQRT(XIG(J,I))                                            0275.000
         CALL MV(OM,XR(1,I),X)                                          0276.000
      IF (IPRIN.NE.6.AND.ICALC.NE.0) WRITE(IPRIN,104)ATM(I),            0277.000
     1   (XR(J,I),J=1,3),(CIG(J,I),J=1,3),X,(S(J),J=1,3)                0278.000
         IF ((IRAD.EQ.1.OR.DMAX.EQ.0.).AND.IPRIN.NE.6.AND.ICALC.NE.0)   0279.000
     1   WRITE (IPRIN,1041) SFAC(13,NJD(I)),SFAC(14,NJD(I))             0280.000
  130 CONTINUE                                                          0281.000
 502  IF (IRAD.EQ.0.AND.DMAX.GT.0.) THEN                                0282.000
         IF (ICALC.NE.0) WRITE (IPRIN,111) DMIN,DMAX                    0283.000
         ELSE                                                           0284.000
         IF (ICALC.NE.0) WRITE (IPRIN,100)                              0285.000
         ENDIF                                                          0286.000
         IF (ICORR.EQ.0) THEN                                           0287.000
         IF (ICALC.NE.0) WRITE (IPRIN,114)                              0288.000
         ELSE                                                           0289.000
         IF (ICALC.NE.0) WRITE (IPRIN,115)                              0290.000
         ENDIF                                                          0291.000
         IF (ICALC.NE.0.AND.SPPOS) WRITE (IPRIN,116)                    0292.000
      IF (IPUBS.EQ.1) CALL PUBS(RCP)                                    0293.000
      IF(NDIANG.EQ.1) THEN                                              0294.000
         CALL JANE(AMAX,DMAX,DMIN,OM,RCP,3)                             0295.000
      CALL TORSN                                                        0296.000
         ENDIF                                                          0297.000
         IF (ICORR.EQ.1) CALL ORFFEB                                    0298.000
         IF (INTRAL.EQ.1) CALL JANE(AMAX,DMAX,DMIN,OM,RCP,1)            0299.000
         IF (INTRAA.EQ.1) CALL JANE(AMAX,DMAX,DMIN,OM,RCP,2)            0300.000
         ITABL=NDIANG+INTRAL+INTRAA+IPUBS                               0301.000
         IF (ITABL.NE.0) THEN                                           0302.000
         ENDFILE 2                                                      0303.000
         REWIND 2                                                       0304.000
         ENDIF                                                          0305.000
         IF (IPRIN.NE.6) THEN                                           0306.000
         IF ((FIRST.OR.ITABL.NE.0).AND.                                 0307.000
     1   (.NOT.(ICALC.NE.0.AND.ITABL.EQ.0))) THEN                       0308.000
         DO 426 I=1,NCOPS                                               0309.000
 426     CALL PRNTAB(STRING)                                            0310.000
         ENDIF                                                          0311.000
         ENDIF                                                          0312.000
      IF(MPLANE.EQ.1) CALL MEANP(OM)                                    0313.000
         IF (ILOC.EQ.1) CALL JANE(AMAX,DMAX,DMIN,OM,RCP,0)              0314.000
      IF(INTERL.LT.0) CALL JANE(AMAX,DMAX,DMIN,OM,RCP,INTERL)           0315.000
         IF (IPRIN.NE.6) WRITE (IPRIN,504)                              0316.000
         IF (ISTOP.EQ.1) GO TO 503                                      0317.000
         FIRST=.FALSE.                                                  0318.000
         IRAD=1                                                         0319.000
         ILOC=0                                                         0320.000
         INTRAL=0                                                       0321.000
         INTRAA=0                                                       0322.000
         IPUBS=0                                                        0323.000
         DMAX=0.                                                        0324.000
         DMIN=0.01                                                      0325.000
         INTERL=0                                                       0326.000
         MPLANE=0                                                       0327.000
         NDIANG=0                                                       0328.000
         MAXYZ=20                                                       0329.000
         MAXUIJ=10                                                      0330.000
         MAXBON=20                                                      0331.000
         ICORR=0                                                        0332.000
         LPP=35                                                         0333.000
         STRING=' '                                                     0334.000
         SPPOS=.FALSE.                                                  0335.000
         IPRIN=6                                                        0336.000
         NCOPS=1                                                        0337.000
         GO TO 501                                                      0338.000
 503  WRITE (IPRIN,20000)                                               0339.000
      STOP                                                              0340.000
      END                                                               0341.000
      SUBROUTINE PRECIS(ESD,      IESD,       FSPEC)                    0342.000
      CHARACTER FSPEC(80),BUF(80)                                       0343.000
      CHARACTER*80 CBUF                                                 0344.000
      COMMON /LIMITS/MAXYZ,MAXUIJ,MAXBON                                0345.000
      EQUIVALENCE (CBUF,BUF)                                            0346.000
      IESD =INT(ESD *1.E3)+1                                            0347.000
      IF (IESD .LT.MAXBON) GO TO 3                                      0348.000
      IESD =INT(ESD *1.E2)+1                                            0349.000
      WRITE (CBUF,12)                                                   0350.000
 12   FORMAT ('(1X,16A1,F7.2,13A1)')                                    0351.000
      GO TO 2                                                           0352.000
 3    WRITE (CBUF,13)                                                   0353.000
 13   FORMAT('(1X,16A1,F8.3,13A1)')                                     0354.000
 2    DO 10 I=1,80                                                      0355.000
 10   FSPEC(I)=BUF(I)                                                   0356.000
      IF (ESD .LE.0.) IESD =-1                                          0357.000
      RETURN                                                            0358.000
      END                                                               0359.000
         SUBROUTINE PRNTAB(STRING)                                      0360.000
         CHARACTER*4 LINEL(13),LINER(13)                                0361.000
         CHARACTER*8 STRING                                             0362.000
         INTEGER TYPE                                                   0363.000
         COMMON IPRIN,LPP                                               0364.000
 101     READ (2,1,END=100,ERR=100) LINEL                               0365.000
 1       FORMAT (26A4)                                                  0366.000
         IF (LINEL(1).EQ.'BOND') THEN                                   0367.000
         TYPE=1                                                         0368.000
         ELSE IF (LINEL(1).EQ.'ANGL'.OR.LINEL(1).EQ.'TORS') THEN        0369.000
         TYPE=2                                                         0370.000
         ELSE IF (LINEL(1).EQ.'COOR') THEN                              0371.000
         TYPE=3                                                         0372.000
         ELSE IF (LINEL(1).EQ.'TEMP') THEN                              0373.000
         TYPE=4                                                         0374.000
         ELSE                                                           0375.000
         REWIND 2                                                       0376.000
         RETURN                                                         0377.000
         ENDIF                                                          0378.000
         IF (TYPE.EQ.3) THEN                                            0379.000
         WRITE  (IPRIN,16)                                              0380.000
 16   FORMAT('1',10(/' '),55X,'TABLE'/'0',30X,'FRACTIONAL ATOMIC COORDIN0381.000
     1ATES AND ISOTROPIC TEMPERATURE FACTORS'/31X,'(ANGSTROM SQUARED), W0382.000
     2ITH STANDARD DEVIATIONS IN THE LEAST'/31X,'SIGNIFICANT DIGITS IN P0383.000
     3ARENTHESES. ',     'FOR ANISOTROPIC ATOMS, THE'/31X,'EQUIVALENT IS0384.000
     4OTROPIC TEMPERATURE FACTORS ARE SHOWN.')                          0385.000
         ELSE IF (TYPE.EQ.4) THEN                                       0386.000
         WRITE (IPRIN,21)                                               0387.000
 21      FORMAT ('1',10(/' '),55X,'TABLE'/'0',25X,'VIBRATION PARAMETERS 0388.000
     1(ANGSTROM SQUARED) IN THE EXPRESSION:'/'0',25X,'-2(PI SQUARED)(U110389.000
     2((H.A*)SQUARED) + U22((K.B*)SQUARED) +'/26X,'U33((L.C*)SQUARED) + 0390.000
     32.U12.H.K.A*.B* + 2.U13.H.L.A*.C* +'/26X,'2.U23.K.L.B*.C*)')      0391.000
         ENDIF                                                          0392.000
         WRITE (IPRIN,5)                                                0393.000
 5       FORMAT ('1',10(/' '))                                          0394.000
         LINES=0                                                        0395.000
         IF (TYPE.EQ.3) THEN                                            0396.000
         WRITE (IPRIN,19)                                               0397.000
 19      FORMAT (46X,'X/A',12X,'Y/B',12X,'Z/C',12X,'U')                 0398.000
         LINES=LINES+1                                                  0399.000
         ELSE IF (TYPE.EQ.4) THEN                                       0400.000
         WRITE (IPRIN,20)                                               0401.000
 20      FORMAT (39X,'U11',7X,'U22',7X,'U33',7X,'U12',7X,'U13',7X,'U23')0402.000
         LINES=LINES+1                                                  0403.000
         ENDIF                                                          0404.000
 107     READ (2,1,END=100,ERR=100) LINEL,LINER                         0405.000
         IF (LINEL(1).EQ.'END') GO TO 101                               0406.000
         IF (TYPE.GT.2) GO TO 110                                       0407.000
         READ (2,1,END=108,ERR=108) LINER                               0408.000
         IF (LINER(1).NE.'END') GO TO 109                               0409.000
 108     GO TO (102,103),TYPE                                           0410.000
 102     WRITE (IPRIN,3) LINEL                                          0411.000
 3       FORMAT (16X,13A4,13A4)                                         0412.000
         GO TO 101                                                      0413.000
 103     IF (STRING.EQ.' ') THEN                                        0414.000
         WRITE (IPRIN,4) LINEL                                          0415.000
         ELSE                                                           0416.000
         WRITE (IPRIN,3) LINEL                                          0417.000
         ENDIF                                                          0418.000
 4       FORMAT (10X,13A4,13A4)                                         0419.000
         GO TO 101                                                      0420.000
 109     GO TO (104,105),TYPE                                           0421.000
 104     IF (STRING.EQ.' ') THEN                                        0422.000
         WRITE (IPRIN,3) LINEL,LINER                                    0423.000
         ELSE                                                           0424.000
         WRITE (IPRIN,8) LINEL,LINER                                    0425.000
 8       FORMAT (16X,13A4/16X,13A4)                                     0426.000
         LINES=LINES+1                                                  0427.000
         ENDIF                                                          0428.000
         GO TO 106                                                      0429.000
 105     IF (STRING.EQ.' ') THEN                                        0430.000
         WRITE (IPRIN,4) LINEL,LINER                                    0431.000
         ELSE                                                           0432.000
         WRITE (IPRIN,8) LINEL,LINER                                    0433.000
         LINES=LINES+1                                                  0434.000
         ENDIF                                                          0435.000
         GO TO 106                                                      0436.000
 110     GO TO (111,112),TYPE-2                                         0437.000
 111     WRITE (IPRIN,6) LINEL,(LINER(I),I=1,5)                         0438.000
 6       FORMAT (30X,18A4)                                              0439.000
         GO TO 106                                                      0440.000
 112     WRITE (IPRIN,7) LINEL,(LINER(I),I=1,5)                         0441.000
 7       FORMAT (25X,18A4)                                              0442.000
 106     LINES=LINES+1                                                  0443.000
         IF (LINES.GE.LPP) THEN                                         0444.000
         WRITE (IPRIN,5)                                                0445.000
         LINES=0                                                        0446.000
         IF (TYPE.EQ.3) THEN                                            0447.000
         WRITE (IPRIN,19)                                               0448.000
         LINES=LINES+1                                                  0449.000
         ELSE IF (TYPE.EQ.4) THEN                                       0450.000
         WRITE (IPRIN,20)                                               0451.000
         LINES=LINES+1                                                  0452.000
         ENDIF                                                          0453.000
         ENDIF                                                          0454.000
         GO TO 107                                                      0455.000
 100     REWIND 2                                                       0456.000
         RETURN                                                         0457.000
         END                                                            0458.000
      SUBROUTINE TORSN                                                  0459.000
         CHARACTER COMPID(72),IBRAK1(13),IBRAK2(8),IBRAK3(8),IBRAK4(8)  0460.000
         CHARACTER IBRAK5(8)                                            0461.000
      CHARACTER*8 ATM(200),SYMBOL,FTYPE(13)                             0462.000
      INTEGER         CN(200),CONTNT(13),SYMC,SYMA                      0463.000
         COMMON IPRIN,LPP,ICORR,IRAD,IDUM(3),                           0464.000
     1                              LTRANC(3),LTRANA(3),D(3),E(3),F(3), 0465.000
     2G(3),P(3),Q(3)                                                    0466.000
C        SIG CONTAINS SIGMA**2                                          0467.000
         COMMON/ESDS/         SIG(6,200)                                0468.000
         COMMON/MODELC/COMPID,ATM,FTYPE                                 0469.000
         COMMON/MODEL/N,NR,NLATT,NTYPE,NFTYPE(200),XR(3,200),           0470.000
     1   CN,SOF(200),UIJ(6,200),CIG(3,200),ESOF(200),SIGUIJ(6,200),     0471.000
     2   WAVEL,U,V,W,COSALP,COSBET,COSGAM,ECELL(6),R(24,3,4),           0472.000
     3   T(3,4),ICENT,SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                0473.000
      COMMON/ORFFE/SAVE(3500,3,2),IADC(3500,2),NANGLE(200),             0474.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   0475.000
C     EXTENDED BLOCK/ORFFE/SAVE(3500,3,2),IADC(3500,2),NANGLE(200),     0476.000
C * * * * END GOULD S.E.L. CODE * * * * *                               0477.000
     1IDONE(500,4),NADC,DUMMY(31284)                                    0478.000
C        31284=MATRX+60-30201                                           0479.000
 505  FORMAT (1X,32A1,F7.1,13A1)                                        0480.000
 506     FORMAT ('END OF TABLE')                                        0481.000
 507     FORMAT ('TORSION ANGLES')                                      0482.000
C        IADC HOLDS THE DESIGNATOR CODES OF THE ATOMS SUBTENDING        0483.000
C        AN ANGLE.                                                      0484.000
C        NANGLE(I) IS THE RUNNING TOTAL OF ANGLES UP TO AND INCLUDING   0485.000
C        THOSE OF APEX ATOM I.                                          0486.000
         DPR=57.29578                                                   0487.000
         K1=1                                                           0488.000
         NDONE=0                                                        0489.000
         WRITE (2,507)                                                  0490.000
         DO 1 I=1,N                                                     0491.000
         IF (I.GT.1) K1=NANGLE(I-1)+1                                   0492.000
         K2=NANGLE(I)                                                   0493.000
         IF (K2.LT.K1) GO TO 1                                          0494.000
C        LOOP THROUGH ANGLES ADDED BY THIS ATOM                         0495.000
         DO 2 K=K1,K2                                                   0496.000
         L=1                                                            0497.000
 40      IF (L.GT.NADC) GO TO 2                                         0498.000
         IF (L.GE.K1.AND.L.LE.K2) GO TO 41                              0499.000
         J1=1                                                           0500.000
 42      DO 3 J2=1,2                                                    0501.000
         IF (IADC(K,J1).NE.IADC(L,J2)) GO TO 3                          0502.000
         N1=3-J1                                                        0503.000
         IF (IADC(K,J1).GT.0.AND.IADC(K,N1).GT.0) GO TO 7               0504.000
 3       CONTINUE                                                       0505.000
         IF (J1.EQ.2) GO TO 41                                          0506.000
 43      J1=2                                                           0507.000
         GO TO 42                                                       0508.000
 41      L=L+1                                                          0509.000
         GO TO 40                                                       0510.000
 7       IB=I                                                           0511.000
         DO 5 M=1,N                                                     0512.000
         IF (NANGLE(M).GE.L) GO TO 6                                    0513.000
 5       CONTINUE                                                       0514.000
 6       ID=M                                                           0515.000
         IBDC=IB*531441+265387                                          0516.000
         IDDC=ID*531441+265387                                          0517.000
         IF (NDONE.EQ.0) GO TO 501                                      0518.000
C        TRAP ANGLES ALREADY DONE                                       0519.000
         DO 500 M=1,NDONE                                               0520.000
         IF (IADC(K,N1).EQ.IDONE(M,4).AND.IBDC.EQ.IDONE(M,3).AND.       0521.000
     1IADC(K,J1).EQ.IDONE(M,2).AND.IDDC.EQ.IDONE(M,1)) GO TO 502        0522.000
         IF (IADC(K,N1).EQ.IDONE(M,1).AND.IBDC.EQ.IDONE(M,2).AND.       0523.000
     1IADC(K,J1).EQ.IDONE(M,3).AND.IDDC.EQ.IDONE(M,4)) GO TO 502        0524.000
 500     CONTINUE                                                       0525.000
 501     CALL DCODE(IADC(K,N1),IA,SYMA,ISTARA,NPA,LTRANA)               0526.000
         CALL DCODE(IADC(K,J1),IC,SYMC,ISTARC,NPC,LTRANC)               0527.000
         DO 4 M=1,3                                                     0528.000
         D(M)=-SAVE(K,M,N1)                                             0529.000
         E(M)=-SAVE(K,M,J1)                                             0530.000
         F(M)=-E(M)                                                     0531.000
 4       G(M)=SAVE(L,M,J2)                                              0532.000
         DO 35 II=1,3                                                   0533.000
         J=II+1                                                         0534.000
         IF (J-3) 36,36,37                                              0535.000
 37      J=J-3                                                          0536.000
 36      KK=J+1                                                         0537.000
         IF (KK-3) 38,38,39                                             0538.000
 39      KK=KK-3                                                        0539.000
 38      P(II)=D(J)*E(KK)-D(KK)*E(J)                                    0540.000
 35      Q(II)=F(J)*G(KK)-F(KK)*G(J)                                    0541.000
         PNORM=FNORM(P(1),P(2),P(3))                                    0542.000
         QNORM=FNORM(Q(1),Q(2),Q(3))                                    0543.000
         PDOTQ=P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3)                            0544.000
         COSPQ=PDOTQ/(PNORM*QNORM)                                      0545.000
         IF (ABS(COSPQ).GT.1.) COSPQ=SIGN(1.0,COSPQ)
         ANGPQ=ACOS(COSPQ)*DPR                                          0546.000
         ASIGN=P(1)*(Q(2)*E(3)-Q(3)*E(2))+P(2)*(E(1)*Q(3)-Q(1)*E(3)) 
     1+P(3)*(Q(1)*E(2)-Q(2)*E(1))                                       0548.000
         IF (ASIGN.LT.0) ANGPQ=-ANGPQ       
C        TORSION ANGLE ERROR. SEE HELV. CHIM. ACT. 44, 2027 (1961) &    0550.000
C        ACTA CRYST. A28, 213  (1972).                                  0551.000
         R12=FNORM(SAVE(K,1,N1),SAVE(K,2,N1),SAVE(K,3,N1))              0552.000
         R23=FNORM(SAVE(K,1,J1),SAVE(K,2,J1),SAVE(K,3,J1))              0553.000
         R34=FNORM(SAVE(L,1,J2),SAVE(L,2,J2),SAVE(L,3,J2))              0554.000
         DO 50 II=1,3                                                   0555.000
         D(II)=SAVE(K,II,N1)/R12                                        0556.000
         E(II)=SAVE(K,II,J1)/R23                                        0557.000
 50      F(II)=SAVE(L,II,J2)/R34                                        0558.000
         CPHI1=D(1)*E(1)+D(2)*E(2)+D(3)*E(3)                            0559.000
         CPHI2=E(1)*F(1)+E(2)*F(2)+E(3)*F(3)                            0560.000
         C2PHI1=CPHI1*CPHI1                                             0561.000
         C2PHI2=CPHI2*CPHI2                                             0562.000
         S2PHI1=1.-C2PHI1                                               0563.000
         S2PHI2=1.-C2PHI2                                               0564.000
         SPHI1=SQRT(S2PHI1)                                             0565.000
         SPHI2=SQRT(S2PHI2)                                             0566.000
         T2PHI1=0.
         IF (S2PHI1.NE.0.) T2PHI1=C2PHI1/S2PHI1              
         CTPHI1=SQRT(T2PHI1)                                            0568.000
         T2PHI2=0.
         IF (S2PHI2.NE.0.) T2PHI2=C2PHI2/S2PHI2         
         CTPHI2=SQRT(T2PHI2)                                            0570.000
         S1=(SIG(1,IA)+SIG(2,IA)+SIG(3,IA))/3.                          0571.000
         S2=(SIG(1,IB)+SIG(2,IB)+SIG(3,IB))/3.                          0572.000
         S3=(SIG(1,IC)+SIG(2,IC)+SIG(3,IC))/3.                          0573.000
         S4=(SIG(1,ID)+SIG(2,ID)+SIG(3,ID))/3.                          0574.000
         SIGW=S1/(R12*R12*S2PHI1)+(S2/(R23*R23))*(((R23-R12*CPHI1)      0575.000
     1/(R12*SPHI1))**2-2.*((R23-R12*CPHI1)/(R12*SPHI1))*CTPHI2*COSPQ    0576.000
     2+T2PHI2)+(S3/(R23*R23))*(((R23-R34*CPHI2)/(R34*SPHI2))**2-2.      0577.000
     3*((R23-R34*CPHI2)/(R34*SPHI2))*CTPHI1*COSPQ+T2PHI1)               0578.000
     4+S4/(R34*R34*S2PHI2)                                              0579.000
      IF (SIGW.GT.0.) THEN
         SIGW=SQRT(SIGW)*DPR                                            0580.000
      ELSE
         SIGW=0.
      ENDIF
         JSIG=INT(SIGW*10.)+1                                           0581.000
         IF (SIGW.EQ.0) JSIG=-1                                         0582.000
         CALL TABLE (0,JSIG,-1,0,IBRAK1,13)                             0583.000
         SYMBOL=ATM(IA)                                                 0584.000
         CALL CTABLE(SYMBOL,1,IBRAK2,8)                                 0585.000
         SYMBOL=ATM(IB)                                                 0586.000
         CALL CTABLE(SYMBOL,1,IBRAK3,8)                                 0587.000
         SYMBOL=ATM(IC)                                                 0588.000
         CALL CTABLE(SYMBOL,1,IBRAK4,8)                                 0589.000
         SYMBOL=ATM(ID)                                                 0590.000
         CALL CTABLE(SYMBOL,0,IBRAK5,8)                                 0591.000
         WRITE (2,505) IBRAK2,IBRAK3,IBRAK4,IBRAK5,ANGPQ,IBRAK1         0592.000
         IF (IPRIN.EQ.6)                                                0593.000
     1   WRITE (IPRIN,505) IBRAK2,IBRAK3,IBRAK4,IBRAK5,ANGPQ,IBRAK1     0594.000
         NDONE=NDONE+1                                                  0595.000
         IF (NDONE.GT.500) NDONE=1                                      0596.000
         IDONE(NDONE,1)=IADC(K,N1)                                      0597.000
         IDONE(NDONE,2)=IBDC                                            0598.000
         IDONE(NDONE,3)=IADC(K,J1)                                      0599.000
         IDONE(NDONE,4)=IDDC                                            0600.000
 502     IF (J1.EQ.1) GO TO 43                                          0601.000
         L=NANGLE(ID)+1                                                 0602.000
         GO TO 40                                                       0603.000
 2       CONTINUE                                                       0604.000
 1       CONTINUE                                                       0605.000
         WRITE (2,506)                                                  0606.000
      RETURN                                                            0607.000
      END                                                               0608.000
         SUBROUTINE DCODE(N,I,NS,IS,NP,LTRAN)                           0609.000
C * * * * GOULD-S.E.L. ONLY * * * *                                     0610.000
C        EXTENDED DUMMY N                                               0611.000
C * * * * END GOULD-S.E.L. CODE  * * * * *                              0612.000
         DIMENSION LTRAN(3)                                             0613.000
         I1=N/729                                                       0614.000
         IR=N-729*I1                                                    0615.000
         N1=IR/5                                                        0616.000
         IS=IR-5*N1                                                     0617.000
         NS=N1/5                                                        0618.000
         NP=N1-5*NS                                                     0619.000
         I=I1/729                                                       0620.000
         IR=I1-729*I                                                    0621.000
         L1=IR/9                                                        0622.000
         LTRAN(1)=IR-9*L1-4                                             0623.000
         L2=L1/9                                                        0624.000
         LTRAN(2)=L1-9*L2-4                                             0625.000
         LTRAN(3)=L2-4                                                  0626.000
         RETURN                                                         0627.000
         END                                                            0628.000
         FUNCTION FNORM(X,Y,Z)                                          0629.000
C * * * * GOULD-S.E.L. ONLY * * * *                                     0630.000
C        EXTENDED DUMMY X,Y,Z                                           0631.000
C * * * * END GOULD-S.E.L. * * * * *                                    0632.000
         FNORM=SQRT(X*X+Y*Y+Z*Z)                                        0633.000
         RETURN                                                         0634.000
         END                                                            0635.000
      SUBROUTINE MEANP(OM)                                              0636.000
      CHARACTER IC(148),COMPID(72),TAG,FSPEC(80)                        0637.000
         CHARACTER*8 AMIN(20),ATM(200),FTYPE(13)                        0638.000
         DIMENSION OM(3,3)                                              0639.000
         INTEGER CN(200),CONTNT(13)                                     0640.000
      COMMON IPRIN,LPP,ICORR,IRAD,ICCC(3),ICH(20),IW(20),W(200),V(3,3), 0641.000
     1MIN(20),A(3,3),VJ(3,20),SUMWX(3),XI(3),X(3)                       0642.000
         COMMON/ESDS/         SIG(6,200)                                0643.000
         COMMON/CHARA/IC,FSPEC                                          0644.000
         COMMON/MODELC/COMPID,ATM,FTYPE                                 0645.000
         COMMON/MODEL/N,NR,NLATT,NTYPE,NFTYPE(200),XR(3,200),           0646.000
     1   CN,SOF(200),UIJ(6,200),CIG(3,200),ESOF(200),SIGUIJ(6,200),     0647.000
     2   WAVEL,U,VV,WW,COSALP,COSBET,COSGAM,ECELL(6),R(24,3,4),         0648.000
     3   T(3,4),ICENT,SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                0649.000
C                                                                       0650.000
C                                                                       0651.000
   82 FORMAT  ('1          MEAN PLANES')                                0652.000
 88   FORMAT (144A1)                                                    0653.000
 91   FORMAT('0SIGMA DELTA SQUARED =',F10.6/'0CHI SQUARED =',F15.4,     0654.000
     1'   NUMBER OF DEGREES OF FREEDOM =',I4///)                        0655.000
   92 FORMAT(14H EIGEN VALUE =,F10.4)                                   0656.000
 87   FORMAT ('0PLANE NO.',I4)                                          0657.000
 93   FORMAT(23H ATOMS OUT OF THE PLANE/19X,5H ATOM,11X,2HXI,8X,2HYI,8X,0658.000
     12HZI,8X,2H W,4X,'ESD(ZI)')                                        0659.000
   94 FORMAT(20X,A8,3F10.4,F10.1,F10.4)                                 0660.000
 95   FORMAT(' ATOMS IN THE PLANE'/19X,5H ATOM,11X,2HXI,8X,2HYI,8X,     0661.000
     12HZI,8X,2H W,4X,'ESD(ZI)')                                        0662.000
   96 FORMAT(6H M(I)=,3F10.5,    49H (COMPONENTS OF UNIT VECTOR NORMAL T0663.000
     1O BEST PLANE)/3H D=,F10.5,23X,46H (PERPENDICULAR DISTANCE FROM PLA0664.000
     2NE TO ORIGIN)//'0COORDINATES W.R.T. INERTIAL AXES (ZI IS DELTA)'/)0665.000
 500  FORMAT(' ANGLE BETWEEN NORMALS OR LINES', I3,4H AND,I3,        4H 0666.000
     1IS ,F6.2,9H DEGREES )                                             0667.000
 99   FORMAT ('0TENSOR OF INERTIA'/3(3F15.3/))                          0668.000
 1002 FORMAT ('0ATOM SYMBOL ',A8,' INCONSISTENT'/'1')                   0669.000
 1254 FORMAT(' PLUS THE CENTRO-SYMMETRICALLY-RELATED ATOMS')            0670.000
      WRITE(IPRIN,82)                                                   0671.000
      NJ=0                                                              0672.000
 3    NA=0                                                              0673.000
      NORG=0                                                            0674.000
      DO 14 J=1,N                                                       0675.000
   14 W(J)=1.0                                                          0676.000
         WRITE (6,603)                                                  0677.000
 603     FORMAT (' TYPE ATOM SYMBOLS TO DEFINE PLANE (BLANK LINE TO EXIT0678.000
     1,'/' = TO CONTINUE SYMBOLS ON NEXT LINE)')                        0679.000
      READ(1,88,END=4)(IC(K),K=2,73)                                    0680.000
         DO 26 K=74,145                                                 0681.000
 26      IC(K)=' '                                                      0682.000
      CALL PARSE(IC,NIN,ICH,IW)                                         0683.000
      IF (NIN.EQ.0) GO TO 4                                             0684.000
         J=ICH(NIN)                                                     0685.000
         IF (IC(J).NE.'=') GO TO 20                                     0686.000
         IC(J)=' '                                                      0687.000
         READ (1,88,END=4) (IC(K),K=74,145)                             0688.000
         CALL PARSE(IC,NIN,ICH,IW)                                      0689.000
 20   DO 101 I=1,NIN                                                    0690.000
  101 CALL AFORMT(IC,ICH(I),IW(I),AMIN(I))                              0691.000
      DO 1001 I=1,NIN                                                   0692.000
      DO 100 J=1,N                                                      0693.000
      IF (AMIN(I).NE.ATM(J)) GO TO 100                                  0694.000
      MIN(I)=J                                                          0695.000
      GO TO 1001                                                        0696.000
  100 CONTINUE                                                          0697.000
      WRITE (6,1002) AMIN(I)                                            0698.000
      GO TO 3                                                           0699.000
 1001 CONTINUE                                                          0700.000
         IF (NIN.EQ.2) THEN                                             0701.000
         NJ=NJ+1                                                        0702.000
         MATMJ=MIN(1)                                                   0703.000
         CALL MV(OM,XR(1,MATMJ),X)                                      0704.000
         DO 200 I=1,3                                                   0705.000
 200     VJ(ICCC(I),NJ)=X(I)                                            0706.000
         MATMJ=MIN(2)                                                   0707.000
         CALL MV(OM,XR(1,MATMJ),X)                                      0708.000
         DO 201 I=1,3                                                   0709.000
 201     VJ(ICCC(I),NJ)=VJ(ICCC(I),NJ)-X(I)                             0710.000
         DIST=SQRT(VJ(1,NJ)**2+VJ(2,NJ)**2+VJ(3,NJ)**2)                 0711.000
         DO 202 I=1,3                                                   0712.000
 202     VJ(I,NJ)=VJ(I,NJ)/DIST                                         0713.000
         WRITE (IPRIN,203) NJ,ATM(MIN(1)),ATM(MIN(2)),DIST,             0714.000
     1   (VJ(I,NJ),I=1,3)                                               0715.000
 203     FORMAT ('0LINE NO.',I4,' BETWEEN ATOMS ',A8,' AND ',A8/        0716.000
     1   '0INTERATOMIC DISTANCE =',F9.4,' ANGSTROMS'/                   0717.000
     2   '0DIRECTION COSINES ARE',3F10.5)                               0718.000
         ELSE                                                           0719.000
         WRITE (6,600)                                                  0720.000
 600  FORMAT (' UNIT WEIGHTS? (N)')                                     0721.000
         READ (1,88)  TAG                                               0722.000
         IF (TAG.EQ.'Y') NA=1                                           0723.000
         WRITE (6,601)                                                  0724.000
 601  FORMAT (' PLANE THROUGH CENTRE OF SYMMETRY AT ORIGIN? (N)')       0725.000
         READ (1,88) TAG                                                0726.000
         IF (TAG.EQ.'Y') NORG=1                                         0727.000
      IF(NA) 16,16,5                                                    0728.000
 16   DO 1401 J=1,N                                                     0729.000
      W(J) = 0.0                                                        0730.000
      DO 1400 K = 1,3                                                   0731.000
 1400 W(J)=W(J)+SIG(K,J)                                                0732.000
      IF (W(J).EQ.0.) GO TO 1401                                        0733.000
      W(J)=3./W(J)                                                      0734.000
 1401 CONTINUE                                                          0735.000
 5    SUMD2=0.0                                                         0736.000
      CHISQ=0.                                                          0737.000
      SUMW=0.                                                           0738.000
      DO 6 I=1,3                                                        0739.000
      SUMWX(I)=0.0                                                      0740.000
      DO 6 J=1,3                                                        0741.000
    6 A(I,J)=0.0                                                        0742.000
      NJ=NJ+1                                                           0743.000
      WRITE (IPRIN,87) NJ                                               0744.000
      DO 7 J=1,NIN                                                      0745.000
      MATMJ=MIN(J)                                                      0746.000
      SUMW=SUMW+W(MATMJ)                                                0747.000
         CALL MV(OM,XR(1,MATMJ),X)                                      0748.000
      DO 7 I=1,3                                                        0749.000
 7    SUMWX(I)=SUMWX(I)+W(MATMJ)*X(I)                                   0750.000
      DO 120 I=1,3                                                      0751.000
      SUMWX(I)=SUMWX(I)/SUMW                                            0752.000
      IF (NORG.EQ.1) SUMWX(I)=0.                                        0753.000
 120  CONTINUE                                                          0754.000
      DO 109 J=1,NIN                                                    0755.000
      MATMJ=MIN(J)                                                      0756.000
         CALL MV(OM,XR(1,MATMJ),X)                                      0757.000
      DO 109 I=1,3                                                      0758.000
      DO 109 K=1,3                                                      0759.000
 109  A(I,K)=A(I,K)+W(MATMJ)*(X(I)-SUMWX(I))*(X(K)-SUMWX(K))            0760.000
      WRITE (IPRIN,99) ((A(I,J),J=1,3),I=1,3)                           0761.000
      CALL ARRAY1(2,3,3,A,A)                                            0762.000
      CALL EIGEN(A,V,3,0)                                               0763.000
      CALL  ARRAY1(1,3,3,A,A)                                           0764.000
      DET=V(1,1)*V(2,2)*V(3,3)+V(2,1)*V(3,2)*V(1,3)+V(3,1)*V(2,3)*V(1,2)0765.000
     1-V(1,3)*V(2,2)*V(3,1)-V(1,2)*V(2,1)*V(3,3)-V(1,1)*V(3,2)*V(2,3)   0766.000
      IF (DET.GE.0.) GO TO 801                                          0767.000
      V(1,3)=-V(1,3)                                                    0768.000
      V(2,3)=-V(2,3)                                                    0769.000
      V(3,3)=-V(3,3)                                                    0770.000
 801  WRITE (IPRIN,92) A(3,3)                                           0771.000
      D=V(1,3)*SUMWX(1)+V(2,3)*SUMWX(2)+V(3,3)*SUMWX(3)                 0772.000
      DO 30 M=1,3                                                       0773.000
 30   VJ(ICCC(M),NJ)=V(M,3)                                             0774.000
      WRITE (IPRIN,96) (VJ(M,NJ),M=1,3),D                               0775.000
      WRITE(IPRIN,95)                                                   0776.000
      DO 9 I=1,NIN                                                      0777.000
      K=MIN(I)                                                          0778.000
         CALL MV(OM,XR(1,K),X)                                          0779.000
      DO 11 J=1,3                                                       0780.000
 11   XI(J)=X(J)  -SUMWX(J)                                             0781.000
      DELTA=SQRT(SIG(1,K)*VJ(1,NJ)**2  +SIG(2,K)*VJ(2,NJ)**2  +         0782.000
     1SIG(3,K)*VJ(3,NJ)**2)                                             0783.000
      CALL MTV(V,XI)                                                    0784.000
      IF(DELTA.GT.0.) CHISQ=CHISQ+(XI(3) /DELTA)**2                     0785.000
      SUMD2=SUMD2+(XI(3))**2                                            0786.000
 9    WRITE (IPRIN,94) ATM(K),XI,W(K),DELTA                             0787.000
      IF (NORG.EQ.1) WRITE (IPRIN,1254)                                 0788.000
      NDF=NIN-3                                                         0789.000
      IF (NORG.EQ.1) NDF=2*NIN-3                                        0790.000
      WRITE (IPRIN,91) SUMD2,CHISQ,NDF                                  0791.000
      WRITE(IPRIN,93)                                                   0792.000
      DO 10 K = 1,N                                                     0793.000
      DO 9876 J = 1,NIN                                                 0794.000
      IF (K-MIN(J)) 9876,10,9876                                        0795.000
 9876 CONTINUE                                                          0796.000
         CALL MV(OM,XR(1,K),X)                                          0797.000
      DO 12 J=1,3                                                       0798.000
 12   XI(J)=X(J)  -SUMWX(J)                                             0799.000
      DELTA=SQRT(SIG(1,K)*VJ(1,NJ)**2  +SIG(2,K)*VJ(2,NJ)**2  +         0800.000
     1SIG(3,K)*VJ(3,NJ)**2)                                             0801.000
      CALL MTV(V,XI)                                                    0802.000
      WRITE (IPRIN,94) ATM(K),XI,W(K),DELTA                             0803.000
   10 CONTINUE                                                          0804.000
         ENDIF                                                          0805.000
      GO TO 3                                                           0806.000
    4 NB=1                                                              0807.000
      IF (NJ-1) 44,44,45                                                0808.000
   45 NC=NB+1                                                           0809.000
      DO 40 K=NC,NJ                                                     0810.000
      COSAN =VJ(1,NB)*VJ(1,K)+VJ(2,NB)*VJ(2,K)+VJ(3,NB)*VJ(3,K)         0811.000
      ANG=ACOS(COSAN)                                                   0812.000
      ANG=ANG*57.29578                                                  0813.000
   40 WRITE(IPRIN,500)NB,K,ANG                                          0814.000
      NB=NB+1                                                           0815.000
      IF(NB-NJ)45,43,43                                                 0816.000
   43 CONTINUE                                                          0817.000
   44 CONTINUE                                                          0818.000
      RETURN                                                            0819.000
      END                                                               0820.000
      SUBROUTINE TRANM(B,L,V)                                           0821.000
C     FORM MATRIX V=LBL(TRANSPOSED). B IS FIRST RE-ARRANGED AS A        0822.000
C     SYMMETRIC MATRIX GIVEN THE UPPER TRIANGLE IN THE FIRST TWO COLUMNS0823.000
      REAL L(3,3),LT(3,3)                                               0824.000
      DIMENSION B(3,3),V(3,3),W(3,3)                                    0825.000
      B(1,3)=B(2,2)                                                     0826.000
      B(2,3)=B(3,2)                                                     0827.000
      B(3,3)=B(3,1)                                                     0828.000
      B(2,2)=B(2,1)                                                     0829.000
      B(2,1)=B(1,2)                                                     0830.000
      B(3,1)=B(1,3)                                                     0831.000
      CALL MMULT(B,L,W)                                                 0832.000
      DO 1 I=1,3                                                        0833.000
      DO 1 J=1,3                                                        0834.000
 1    LT(I,J)=L(J,I)                                                    0835.000
      CALL MMULT(LT,W,V)                                                0836.000
      RETURN                                                            0837.000
      END                                                               0838.000
      SUBROUTINE MMULT(B,A,W)                                           0839.000
C     FORM MATRIX W=AB                                                  0840.000
      DIMENSION A(3,3),B(3,3),W(3,3)                                    0841.000
      DO 1 I=1,3                                                        0842.000
      DO 1 J=1,3                                                        0843.000
      W(I,J)=0.                                                         0844.000
      DO 1 K=1,3                                                        0845.000
 1    W(I,J)=W(I,J)+A(I,K)*B(K,J)                                       0846.000
      RETURN                                                            0847.000
      END                                                               0848.000
      SUBROUTINE MTV(M,V)                                               0849.000
C     TRANSFORM VECTOR V BY MATRIX M(TRANSPOSED)                        0850.000
      REAL W(3),V(3),M(3,3)                                             0851.000
      DO 1 I=1,3                                                        0852.000
      W(I)=0.                                                           0853.000
      DO 1 J=1,3                                                        0854.000
 1    W(I)=W(I)+M(J,I)*V(J)                                             0855.000
      DO 2 I=1,3                                                        0856.000
 2    V(I)=W(I)                                                         0857.000
      RETURN                                                            0858.000
      END                                                               0859.000
      SUBROUTINE CTABLE(IN1,         NBLNK,IBRAK,IFW)                   0860.000
C     SET UP ATOM SYMBOL FOR PRINTING.                                  0861.000
      CHARACTER*8 IN1,FIELD                                             0862.000
      CHARACTER IOUT(20),IBRAK(IFW),IBLNK,  LABEL(8),MINUS              0863.000
      EQUIVALENCE (FIELD,LABEL)                                         0864.000
      DATA IBLNK,                  MINUS/' ','-'/                       0865.000
      DO 1 I=1,IFW                                                      0866.000
 1    IBRAK(I)=IBLNK                                                    0867.000
      I2=0                                                              0868.000
      FIELD=IN1                                                         0869.000
      DO 50 I=1,8                                                       0870.000
      IF (LABEL(I).EQ.IBLNK) GO TO 50                                   0871.000
      I2=I2+1                                                           0872.000
      IBRAK(I2)=LABEL(I)                                                0873.000
 50   CONTINUE                                                          0874.000
C     INSERT HYPHEN IF NOT LAST ATOM SYMBOL                             0875.000
      IF (NBLNK.EQ.0) RETURN                                            0876.000
      I=IFW-I2                                                          0877.000
      IF (I.LE.0) RETURN                                                0878.000
      I=I/2+MOD(I,2)                                                    0879.000
      IBRAK(I2+I)=MINUS                                                 0880.000
      RETURN                                                            0881.000
      END                                                               0882.000
      SUBROUTINE TABLE (IN1,IN2,MODE,NBLNK,IBRAK,IFW)                   0883.000
C     SET UP PARAMETER VALUE FOR PRINTING.                              0884.000
      CHARACTER*20 FIELD                                                0885.000
      CHARACTER IOUT(20),IBLNK,IBRAK(IFW),LBRAK,NBRAK,MINUS,IZERO       0886.000
      EQUIVALENCE (FIELD,IOUT)                                          0887.000
      DATA IBLNK,LBRAK,NBRAK,MINUS,IZERO/' ','(',')','-','0'/           0888.000
      DO 1 I=1,IFW                                                      0889.000
 1    IBRAK(I)=IBLNK                                                    0890.000
      I2=0                                                              0891.000
      IF (MODE.LT.0) GO TO 15                                           0892.000
      WRITE (FIELD,200) IN1                                             0893.000
 200  FORMAT (I7)                                                       0894.000
      I2=7                                                              0895.000
      DO 8 I=1,I2                                                       0896.000
C     IF MODE=2,INSERT LEADING ZEROS IN PARAMETER VALUE                 0897.000
      IF (MODE-1) 23,23,24                                              0898.000
 24   IF (I-NBLNK) 23,23,37                                             0899.000
 37   IF (IOUT(I).EQ.MINUS) GO TO 34                                    0900.000
      IF (IOUT(I).EQ.IBLNK) GO TO 33                                    0901.000
 23   IBRAK(I)=IOUT(I)                                                  0902.000
      GO TO 8                                                           0903.000
 34   IBRAK(NBLNK)=MINUS                                                0904.000
 33   IBRAK(I)=IZERO                                                    0905.000
 8    CONTINUE                                                          0906.000
C     SET UP ESD IN BRACKETS (SKIP IF ESD IS -VE)                       0907.000
 15   IF (IN2.LT.0) RETURN                                              0908.000
      N=0                                                               0909.000
      WRITE (FIELD,201) IN2                                             0910.000
 201  FORMAT (I5)                                                       0911.000
      DO 2 I=1,5                                                        0912.000
      IF (IOUT(I).EQ.IBLNK) N=N+1                                       0913.000
 2    CONTINUE                                                          0914.000
      I1=5-N                                                            0915.000
      DO 4 I=1,I1                                                       0916.000
      J=N+I                                                             0917.000
      K=I+I2+1                                                          0918.000
 4    IBRAK(K) =IOUT(J)                                                 0919.000
      IBRAK(I2+1)=LBRAK                                                 0920.000
      J=I1+2+I2                                                         0921.000
      IBRAK(J)=NBRAK                                                    0922.000
      RETURN                                                            0923.000
      END                                                               0924.000
      FUNCTION NINT(A)                                                  0925.000
      IF (A) 3,4,4                                                      0926.000
3     NINT=A-0.5                                                        0927.000
      RETURN                                                            0928.000
4     NINT=A+0.5                                                        0929.000
      RETURN                                                            0930.000
      END                                                               0931.000
      SUBROUTINE JANE(CMAX,BMAX,BMIN,U,RCP,INTERL)                      0932.000
C     INTERATOMIC DISTANCE, ANGLE           PROGRAM                     0933.000
C     P.R.MALLINSON   MAY 1973    FROM AN ALGORITHM BY J.S.ROLLETT      0934.000
C     PROGRAM JANE - JUXTAPOSITION, ANGLES                              0935.000
C     ROUTINE OF GEOM   JULY 1976  P.R.M.                               0936.000
         CHARACTER COMPID(72)                                           0937.000
      CHARACTER*8 ATOM(200),FTYPE(13)                                   0938.000
      INTEGER S,COUNT(3),CN(200),CONTNT(13),DONE                        0939.000
      DIMENSION RCP(3),     U(3,3),POINT(3)                             0940.000
      COMMON  IPRIN,LPP,ICORR,IRAD,IC(3),      XJ(3),I,J,S,D(3),        0941.000
     1   DONE,   JATOM(15),XOUT(3),    DMAX2,COUNT,INT,IS,ND            0942.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                0943.000
         COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),X(3,200),                0944.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0945.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0946.000
     3   SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                             0947.000
 16   FORMAT ('1EQUIVALENT POSITIONS'/)                                 0948.000
 18   FORMAT ('0LATTICE POINTS'/)                                       0949.000
 20   FORMAT ( I2,3F12.4)                                               0950.000
 104  FORMAT        ('0CENTROSYMMETRIC')                                0951.000
 105  FORMAT        ('0NON-CENTROSYMMETRIC')                            0952.000
C     N = NO. OF ATOMS, M = NO. OF SYMMETRY OPERATIONS                  0953.000
C     NT = NO. OF LATTICE POINTS, ICENT = 0/1 CENTRO/NON-CENTRO         0954.000
         DMAX=CMAX                                                      0955.000
         AMAX=BMAX                                                      0956.000
         AMIN=BMIN                                                      0957.000
      IF (AMAX.GT.DMAX.OR.INTERL.GE.0) DMAX=AMAX                        0958.000
      DMAX2=DMAX*DMAX                                                   0959.000
         IF (INTERL.LT.1) THEN                                          0960.000
      WRITE (IPRIN,16)                                                  0961.000
         CALL SYMPRT(IPRIN)                                             0962.000
      WRITE (IPRIN,18)                                                  0963.000
      DO 1 K=1,NT                                                       0964.000
      DO 2 L=1,3                                                        0965.000
 2    POINT(IC(L))=T(L,K)                                               0966.000
      WRITE (IPRIN,20) (K,(POINT(L),L=1,3))                             0967.000
 1    CONTINUE                                                          0968.000
      IF (ICENT.EQ.0) WRITE (IPRIN,104)                                 0969.000
      IF (ICENT.NE.0) WRITE (IPRIN,105)                                 0970.000
         ENDIF                                                          0971.000
      CALL SYMM(  DMAX,AMAX,AMIN,             U,  RCP,INTERL)           0972.000
      RETURN                                                            0973.000
      END                                                               0974.000
      SUBROUTINE SYMM(  DMAX,AMAX,AMIN,             U,  RCP,INTERL)     0975.000
C     TO GENERATE THE EQUIVALENT POSITIONS                              0976.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      CHARACTER  FSPEC(80),  COMPID(72),STAR(2),LBUF(148)               0977.000
      CHARACTER IBRAK1(13),IBRAK2(8), IBRAK3(8),IBRAK4(8)               0978.000
      CHARACTER*8 ATOM(200),FTYPE(13),SYMBOL,HEAD(2)                    0979.000
      INTEGER S,CN(200),CONTNT(13),DONE                                 0980.000
      DIMENSION RCP(3),  CP(3),U(3,3)                                   0981.000
      LOGICAL SPPOS                                                     0982.000
         DIMENSION           SAVE(3500,3,2),IADC(3500,2),NANGLE(200)    0983.000
         DIMENSION IDONE(500,4),LTR(3),P1(3),P2(3),P3(3),PAR1(3),PAR3(3)0984.000
      COMMON  IPRIN,LPP,ICORR,IRAD,IC(3),  XJ(3),I,J,S,D(3),            0985.000
     1   DONE,   JATOM(15),XOUT(3),    DMAX2,KOUNT(3),IT,IS,      ND,   0986.000
     2DKEEP(15),EKEEP(15),XKEEP(3,15),DFKEEP(3,15)                      0987.000
         COMMON/CHARA/LBUF,FSPEC                                        0988.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                0989.000
         COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),X(3,200),                0990.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0991.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0992.000
     3   SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                             0993.000
         COMMON/ESDS/XIG(6,200)                                         0994.000
         COMMON/OSLO/SPPOS                                              0995.000
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                0996.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   0997.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        0998.000
C * * * * END GOULD S.E.L. CODE * * * * *                               0999.000
         COMMON/OUT/IN(231)                                             1000.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCLE,SAVEA,SAVEP,C,VARA,VARP 1001.000
     2,E,E1,LZ,NQZ,MQZ                                                  1002.000
         EQUIVALENCE                  (SAVE,PM(1)),(IADC,PM(21001)),    1003.000
     1(NANGLE,PM(28001)),(IDONE,PM(28201)),(NADC,PM(30201)),(LTR,XOUT)  1004.000
         DATA STAR/' ','*'/,HEAD/'BONDS','ANGLES'/                      1005.000
 100     FORMAT ('0BOND DISTANCES ARE SUMS OF COVALENT RADII')          1006.000
 102  FORMAT ('0',28X,'BOND ANGLES   E.S.D.')                           1007.000
 103  FORMAT (' ',2(A8,  '-  '),A8,   F8.2,F9.2)                        1008.000
 201  FORMAT('0****',A8,2X,'BOND LENGTHS',2X,                           1009.000
     1    'E.S.D. NS   NP   TA TB TC',9X,'X2',8X,'Y2',8X,'Z2')          1010.000
 203  FORMAT('0THE COVALENT AND VAN DER WAALS RADII WILL BE USED TO DEFI1011.000
     1NE THE BOND AND CONTACT DISTANCES')                               1012.000
 204  FORMAT (' ',A8,  '-  ',A8,F7.4,F7.4,I4,A1,I4,I5,2I3,3X,3F10.5)    1013.000
  205 FORMAT('0ONLY DISTANCES INVOLVING A SYMMETRY TRANSFORMATION AND GR1014.000
     1EATER THAN THE SUM OF'/' COVALENT RADII (OR DMIN) APPEAR BELOW')  1015.000
 210  FORMAT('0CONTACTS FROM',F6.2,' A TO',F6.2,' A')                   1016.000
 211  FORMAT ('0BONDS FROM',F6.2,' A TO',F6.2,' A')                     1017.000
 212     FORMAT ('0CONTACTS FROM SUM OF COVALENT RADII TO',F6.2,' A')   1018.000
      DO 1 L=1,3                                                        1019.000
 1    D(L)=1./RCP(L)                                                    1020.000
         IF (INTERL.LT.0) THEN                                          1021.000
         NOPT=0                                                         1022.000
         SPPOS=.FALSE.                                                  1023.000
         ELSE                                                           1024.000
         NOPT=1                                                         1025.000
         ENDIF                                                          1026.000
      IF(INTERL.EQ.-1) WRITE (IPRIN,205)                                1027.000
      IF (IRAD.EQ.1.AND.INTERL.LT.1) WRITE(IPRIN,203)                   1028.000
      IF (IRAD.EQ.0.AND.INTERL.LT.0) THEN                               1029.000
         IF (AMAX.GT.0.) THEN                                           1030.000
         WRITE (IPRIN,210) AMAX,DMAX                                    1031.000
         ELSE                                                           1032.000
         WRITE (IPRIN,212) DMAX                                         1033.000
         ENDIF                                                          1034.000
         ENDIF                                                          1035.000
         IF (IRAD.EQ.0.AND.INTERL.EQ.0) THEN                            1036.000
         IF (AMAX.GT.0.) THEN                                           1037.000
         WRITE (IPRIN,211) AMIN,AMAX                                    1038.000
         ELSE                                                           1039.000
         WRITE (IPRIN,100)                                              1040.000
         ENDIF                                                          1041.000
         ENDIF                                                          1042.000
C     CHANGE AXES SO THAT D(100).GE.D(010).GE.D(001)                    1043.000
      DO 2 K=1,2                                                        1044.000
      K1=K+1                                                            1045.000
      DO 2 L=K1,3                                                       1046.000
      IF (D(K)-D(L)) 3,2,2                                              1047.000
 3    DO 4 K2=1,N                                                       1048.000
 4    CALL ROTAT(X(K,K2),X(L,K2))                                       1049.000
      DO 5 K2=1,M                                                       1050.000
C     INTERCHANGE COLS OF ROTATION MATRIX                               1051.000
      DO 28 K3=1,3                                                      1052.000
 28   CALL ROTAT (R(K2,K3,K),R(K2,K3,L))                                1053.000
C     INTERCHANGE ROWS OF ROTATION MATRIX AND TRANSLATION VECTOR        1054.000
      DO 5 K3=1,4                                                       1055.000
 5    CALL ROTAT(R(K2,K,K3),R(K2,L,K3))                                 1056.000
      DO 27 K2=1,NT                                                     1057.000
 27   CALL ROTAT(T(K,K2),T(L,K2))                                       1058.000
      CALL ROTA2(IC(K),IC(L))                                           1059.000
      CALL ROTAT(D(K),D(L))                                             1060.000
         CALL ROTAT(RCP(K),RCP(L))                                      1061.000
C     INTERCHANGE ROWS AND COLS OF ORTHOGONALISATION MATRIX             1062.000
      DO 41 K3=1,3                                                      1063.000
 41   CALL ROTAT(U(K,K3),U(L,K3))                                       1064.000
      DO 42 K3=1,3                                                      1065.000
 42   CALL ROTAT(U(K3,K),U(K3,L))                                       1066.000
 2    CONTINUE                                                          1067.000
C     ATOM1 LOOP                                                        1068.000
      IF (INTERL.EQ.1.OR.INTERL.EQ.2) WRITE (2,302) HEAD(INTERL)        1069.000
 302     FORMAT (A8)                                                    1070.000
         NADC=0                                                         1071.000
      DO 11 I=1,N                                                       1072.000
      IF (NOPT) 50,50,13                                                1073.000
 50   K=I                                                               1074.000
      GO TO 14                                                          1075.000
 13   K=1                                                               1076.000
 14   ND=0                                                              1077.000
         DONE=0                                                         1078.000
C     ATOM2 LOOP                                                        1079.000
      DO 10 J=K,N                                                       1080.000
      IF (IRAD.EQ.0.AND.AMAX.GT.0.) GO TO 200                           1081.000
         AMIN=0.01                                                      1082.000
      AMAX=SFAC(13,NFTYPE(I))+SFAC(13,NFTYPE(J))                        1083.000
         IF (INTERL.LT.0) THEN                                          1084.000
         IF (IRAD.EQ.0) GO TO 200                                       1085.000
      DMAX=SFAC(14,NFTYPE(I))+SFAC(14,NFTYPE(J))                        1086.000
         ELSE                                                           1087.000
         DMAX=AMAX                                                      1088.000
         ENDIF                                                          1089.000
      DMAX2=DMAX*DMAX                                                   1090.000
C     EQUIV POSN LOOP                                                   1091.000
 200  DO 9 S=1,M                                                        1092.000
      IF (SPPOS.AND.S.GT.1) GO TO 9                                     1093.000
      IS=1                                                              1094.000
      DO 8 L=1,3                                                        1095.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)    1096.000
C     LATTICE POINT LOOP                                                1097.000
 21   DO 17 IT=1,NT                                                     1098.000
      IF (J-I) 7,6,7                                                    1099.000
 6    IF (S-1) 7,19,7                                                   1100.000
 19   IF (IT-1) 7,26,7                                                  1101.000
 26   IF (IS-1) 17,17,7                                                 1102.000
 7    DO 20 L=1,3                                                       1103.000
 20   XJ(L)=CP(L)+T(L,IT)                                               1104.000
      CALL TRSLN(DMAX,AMAX,AMIN,U,INTERL)                               1105.000
         IF (ND.EQ.15) THEN                                             1106.000
         WRITE (IPRIN,104)                                              1107.000
 104     FORMAT (' TABLE OVERFLOW. SOME BONDS HAVE BEEN SKIPPED')       1108.000
         GO TO 105                                                      1109.000
         ENDIF                                                          1110.000
 17   CONTINUE                                                          1111.000
C     INVERSION IF CENTROSYMMETRIC                                      1112.000
      IF (ICENT.GT.0.OR.SPPOS) GO TO 9                                  1113.000
      IF (IS-1) 22,22,9                                                 1114.000
 22   DO 24 L=1,3                                                       1115.000
 24   CP(L)=-CP(L)                                                      1116.000
      IS=2                                                              1117.000
      GO TO 21                                                          1118.000
 9    CONTINUE                                                          1119.000
 10   CONTINUE                                                          1120.000
      IF (ND.EQ.0) GO TO 12                                             1121.000
 105  IF (INTERL.LT.1.) WRITE (IPRIN,201) ATOM(I)                       1122.000
      DO 202 K=1,ND                                                     1123.000
         IF (INTERL.EQ.1.AND.JATOM(K)/531441.GE.I) THEN                 1124.000
         CALL PRECIS(EKEEP(K),IERR,FSPEC)                               1125.000
         CALL TABLE(0,IERR,-1,0,IBRAK1,13)                              1126.000
         SYMBOL=ATOM(I)                                                 1127.000
         CALL CTABLE(SYMBOL,           1,IBRAK2,8)                      1128.000
         SYMBOL=ATOM(JATOM(K)/531441)                                   1129.000
         CALL CTABLE(SYMBOL,           0,IBRAK3,8)                      1130.000
         WRITE (2,FSPEC) IBRAK2,IBRAK3,DKEEP(K),IBRAK1                  1131.000
         IF (IPRIN.EQ.6)                                                1132.000
     1   WRITE (IPRIN,FSPEC) IBRAK2,IBRAK3,DKEEP(K),IBRAK1              1133.000
         ELSE IF (INTERL.LT.1) THEN                                     1134.000
         CALL DCODE(JATOM(K),L,S,IS,IT,LTR)                             1135.000
      WRITE(IPRIN,204) ATOM(I),ATOM(L),       DKEEP(K),EKEEP(K),        1136.000
     1 S,       STAR(IS),IT,LTR,(XKEEP(J,K),J=1,3)                      1137.000
         ENDIF                                                          1138.000
 202     CONTINUE                                                       1139.000
         IF (ND.EQ.1.AND.INTERL.EQ.3) THEN                              1140.000
         IF (NADC.EQ.3500) THEN                                         1141.000
         WRITE (IPRIN,408)                                              1142.000
         DO 721 J=I,N                                                   1143.000
 721     NANGLE(J)=NADC                                                 1144.000
         RETURN                                                         1145.000
         ENDIF                                                          1146.000
         NADC=NADC+1                                                    1147.000
         IADC(NADC,1)=JATOM(1)                                          1148.000
         IADC(NADC,2)=0                                                 1149.000
         DO 722 J=1,3                                                   1150.000
 722     SAVE(NADC,J,1)=DFKEEP(J,1)                                     1151.000
         ENDIF                                                          1152.000
         IF (INTERL.NE.1.AND.ND.GT.1) THEN                              1153.000
         IF (INTERL.LT.1) WRITE (IPRIN,102)                             1154.000
      DO 16 K=1,ND-1                                                    1155.000
      DO 16 L=K+1,ND                                                    1156.000
         IF (INTERL.EQ.3) THEN                                          1157.000
         IF (NADC.EQ.3500) THEN                                         1158.000
         WRITE (IPRIN,408)                                              1159.000
 408  FORMAT (' TABLE OVERFLOW. SOME ANGLES HAVE BEEN SKIPPED')         1160.000
         NANGLE(I)=NADC                                                 1161.000
         IF (I.LT.N) THEN                                               1162.000
         DO 710 J=I+1,N                                                 1163.000
 710     NANGLE(J)=0                                                    1164.000
         ENDIF                                                          1165.000
         RETURN                                                         1166.000
         ENDIF                                                          1167.000
         NADC=NADC+1                                                    1168.000
         IADC(NADC,1)=JATOM(K)                                          1169.000
         IADC(NADC,2)=JATOM(L)                                          1170.000
         DO 702 J=1,3                                                   1171.000
         P1(J)=DFKEEP(J,K)/DKEEP(K)                                     1172.000
         P2(J)=DFKEEP(J,L)/DKEEP(L)                                     1173.000
         SAVE(NADC,J,1)=DFKEEP(J,K)                                     1174.000
 702     SAVE(NADC,J,2)=DFKEEP(J,L)                                     1175.000
         COSANG=P1(1)*P2(1)+P1(2)*P2(2)+P1(3)*P2(3)                     1176.000
         IF (ABS(COSANG).GT.0.999999) NADC=NADC-1                       1177.000
         ELSE                                                           1178.000
         IF (ICORR.EQ.0) THEN                                           1179.000
         DO 711 J=1,3                                                   1180.000
         P1(J)=DFKEEP(J,K)/DKEEP(K)                                     1181.000
 711     P2(J)=DFKEEP(J,L)/DKEEP(L)                                     1182.000
         COSANG=P1(1)*P2(1)+P1(2)*P2(2)+P1(3)*P2(3)                     1183.000
         IF (ABS(COSANG).GT.1.0) COSANG=SIGN(1.0,COSANG)
         F=ACOS(COSANG)*57.29578                                        1184.000
         IF (F.LT.0.0001) GO TO 16                                      1185.000
C        BOND ANGLE ERROR. SEE ACTA CRYST. 13, 683 (1960).              1186.000
         DO 712 J=1,3                                                   1187.000
         P1(J)=XKEEP(IC(J),K)                                           1188.000
 712     P3(J)=XKEEP(IC(J),L)                                           1189.000
         CALL MV(U,X(1,I),XOUT)                                         1190.000
         CALL MV(U,P1,PAR1)                                             1191.000
         CALL MV(U,P3,PAR3)                                             1192.000
         DO 713 J=1,3                                                   1193.000
         P1(IC(J))=PAR1(J)                                              1194.000
         P3(IC(J))=PAR3(J)                                              1195.000
 713     CP(IC(J))=XOUT(J)                                              1196.000
         DCS1=DKEEP(K)/DKEEP(L)*COSANG                                  1197.000
         DCS2=DKEEP(L)/DKEEP(K)*COSANG                                  1198.000
         DO 900 J=1,3                                                   1199.000
         PAR1(J)=(CP(J)-P1(J))-DCS1*(CP(J)-P3(J))                       1200.000
 900     PAR3(J)=(CP(J)-P3(J))-DCS2*(CP(J)-P1(J))                       1201.000
         DO 901 J=1,3                                                   1202.000
         P1(J)=PAR1(J)*PAR1(J)                                          1203.000
         P2(J)=PAR1(J)+PAR3(J)                                          1204.000
 901     P3(J)=PAR3(J)*PAR3(J)                                          1205.000
         JK=JATOM(K)/531441                                             1206.000
         JL=JATOM(L)/531441                                             1207.000
         E1=0.                                                          1208.000
         DO 902 J=1,3                                                   1209.000
 902     E1=E1+P3(J)*XIG(J,JK)+P2(J)*P2(J)*XIG(J,I)+P1(J)*XIG(J,JL)     1210.000
         SIN2A=1.-COSANG*COSANG                                         1211.000
            IF (SIN2A.LE.0.00001) THEN
               E1=0.
            ELSE
         E1=SQRT(E1/(DKEEP(K)*DKEEP(K)*DKEEP(L)*DKEEP(L)*SIN2A))        1212.000
     1   *57.29577                                                      1213.000
            ENDIF
         ELSE                                                           1214.000
         CALL DCODE(JATOM(K),IN(2),S,IS,IT,LTR)                         1215.000
         DO 700 J=1,3                                                   1216.000
 700     LTRAN(J,1)=LTR(J)                                              1217.000
         IN(1)=2                                                        1218.000
C        100C+S FOR ATOM K                                              1219.000
         IN(3)=100+(IS-1)*M+S+(IT-1)*(2-ICENT)*M                        1220.000
         CALL DCODE(JATOM(L),IN(6),S,IS,IT,LTR)                         1221.000
         DO 701 J=1,3                                                   1222.000
 701     LTRAN(J,2)=LTR(J)                                              1223.000
C        100C+S FOR ATOM L                                              1224.000
         IN(7)=200+(IS-1)*M+S+(IT-1)*(2-ICENT)*M                        1225.000
         IN(4)=I                                                        1226.000
C        100C+S FOR APEX ATOM                                           1227.000
         IN(5)=0                                                        1228.000
         CALL SUB19                                                     1229.000
         IF (F.LT.0.0001) GO TO 16                                      1230.000
         ENDIF                                                          1231.000
         IF (INTERL.EQ.2) THEN                                          1232.000
         J=INT(E1*10.)+1                                                1233.000
         IF (E1.EQ.0.) J=-1                                             1234.000
         CALL TABLE(0,J,-1,0,IBRAK1,13)                                 1235.000
         SYMBOL=ATOM(JATOM(K)/531441)                                   1236.000
         CALL CTABLE(SYMBOL,           1,IBRAK2,8)                      1237.000
         SYMBOL=ATOM(I)                                                 1238.000
         CALL CTABLE(SYMBOL,           1,IBRAK3,8)                      1239.000
         SYMBOL=ATOM(JATOM(L)/531441)                                   1240.000
         CALL CTABLE(SYMBOL,           0,IBRAK4,8)                      1241.000
         WRITE (2,300) IBRAK2,IBRAK3,IBRAK4,F,IBRAK1                    1242.000
 300     FORMAT (1X,24A1,F10.1,13A1)                                    1243.000
         IF (IPRIN.EQ.6)                                                1244.000
     1   WRITE (IPRIN,300) IBRAK2,IBRAK3,IBRAK4,F,IBRAK1                1245.000
         ELSE                                                           1246.000
      WRITE (IPRIN,103) ATOM(JATOM(K)/531441),ATOM(I),                  1247.000
     1ATOM(JATOM(L)/531441),F,E1                                        1248.000
         ENDIF                                                          1249.000
         ENDIF                                                          1250.000
 16      CONTINUE                                                       1251.000
         ENDIF                                                          1252.000
 12      NANGLE(I)=NADC                                                 1253.000
 11   CONTINUE                                                          1254.000
         IF (INTERL.EQ.1.OR.INTERL.EQ.2) WRITE (2,301)                  1255.000
 301     FORMAT ('END OF TABLE')                                        1256.000
      RETURN                                                            1257.000
      END                                                               1258.000
      SUBROUTINE TRSLN(DMAX,AMAX,AMIN,U,INTERL)                         1259.000
C     TO APPLY THE LATTICE TRANSLATIONS                                 1260.000
      CHARACTER              COMPID(72)                                 1261.000
      CHARACTER*8 ATOM(200),FTYPE(13)                                   1262.000
      INTEGER S,COUNT(3),CN(200),CONTNT(13),DONE                        1263.000
      DIMENSION U(3,3)                                                  1264.000
      COMMON IPRIN,LPP,ICORR,IRAD,IC(3),   XJ(3),I,J,S,D(3),            1265.000
     1   DONE,   JATOM(15),XOUT(3),    DMAX2,COUNT,INT,IS,ND            1266.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                1267.000
         COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),X(3,200),                1268.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        1269.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 1270.000
     3   SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                             1271.000
      K=1                                                               1272.000
      DO 2 L=1,3                                                        1273.000
 2    COUNT(L)=0                                                        1274.000
      GO TO 4                                                           1275.000
 3    XJ(K)=XJ(K)-1.                                                    1276.000
      COUNT(K)=COUNT(K)-1                                               1277.000
 4    IF ((X(K,I)-XJ(K))*D(K)-DMAX) 3,3,7                               1278.000
 6    W=(X(K,I)-XJ(K))*D(K)                                             1279.000
      IF (W+DMAX) 7,14,14                                               1280.000
 14   IF (W-DMAX) 11,11,7                                               1281.000
 7    XJ(K)=XJ(K)+1.                                                    1282.000
      COUNT(K)=COUNT(K)+1                                               1283.000
      IF ((X(K,I)-XJ(K))*D(K)+DMAX) 9,6,6                               1284.000
 9    K=K-1                                                             1285.000
      IF (K) 15,15,7                                                    1286.000
 15   RETURN                                                            1287.000
 11   K=K+1                                                             1288.000
      IF (K-3) 4,4,13                                                   1289.000
 13   CALL DISTN(AMAX,AMIN,U,INTERL)                                    1290.000
         IF (ND.EQ.15) RETURN                                           1291.000
      K=K-1                                                             1292.000
      GO TO 7                                                           1293.000
      END                                                               1294.000
      SUBROUTINE DISTN(AMAX,AMIN,U,INTERL )                             1295.000
C     TO CALCULATE AND PRINT AN INTERATOMIC DISTANCE                    1296.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      CHARACTER  STAR(2),    COMPID(72)                                 1297.000
      CHARACTER*8 ATOM(200),FTYPE(13)                                   1298.000
      INTEGER S,COUNT(3),DONE,   CN(200),CONTNT(13)                     1299.000
      DIMENSION DELX1(3),DELX2(3),SIG(3),DIR(3),   U(3,3)               1300.000
      COMMON IPRIN,LPP,ICORR,IRAD,IC(3),    XJ(3),I,J,S,D(3),           1301.000
     1   DONE,   JATOM(15),XOUT(3),    DMAX2,COUNT,INT,IS,      ND,     1302.000
     2DKEEP(15),EKEEP(15),XKEEP(3,15),DFKEEP(3,15)                      1303.000
         COMMON/ESDS/XIG(6,200)                                         1304.000
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                1305.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   1306.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        1307.000
C * * * * END GOULD S.E.L. CODE * * * * *                               1308.000
         COMMON/OUT/IN(231)                                             1309.000
      COMMON/W/DIST,FX,NP,NM,NS,NQ,INSAVE,ITDIST,SCLE,SAVEA,SAVEP,C,    1310.000
     2VARA,VARP,E,E1,LZ,NQZ,MQZ                                         1311.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                1312.000
         COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),XI(3,200),               1313.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        1314.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 1315.000
     3   SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                             1316.000
 100  FORMAT (' ',A8,  '-  ',A8,F7.4,F7.4,I4,A1,I4,I5,2I3,3X,3F10.5)    1317.000
 101  FORMAT ('0********DISTANCES FROM ',A8,' (',F8.5,2F10.5,')'/       1318.000
     129X,'E.S.D. NS   NP   TA TB TC',9X,'X2',8X,'Y2',8X,'Z2')          1319.000
      DATA STAR/' ','*'/                                                1320.000
      DO 1 L=1,3                                                        1321.000
 1    DELX1(L)=XI(L,I)-XJ(L)                                            1322.000
      CALL MV(U,DELX1,DELX2)                                            1323.000
      DIST=DELX2(1)*DELX2(1)+DELX2(2)*DELX2(2)+DELX2(3)*DELX2(3)        1324.000
      IF (DIST-DMAX2) 4,4,5                                             1325.000
 4    LTRAN(IC(1),1)=COUNT(1)                                           1326.000
      LTRAN(IC(2),1)=COUNT(2)                                           1327.000
      LTRAN(IC(3),1)=COUNT(3)                                           1328.000
      XOUT(IC(1))=XJ(1)                                                 1329.000
      XOUT(IC(2))=XJ(2)                                                 1330.000
      XOUT(IC(3))=XJ(3)                                                 1331.000
         IF (ICORR.EQ.0.OR.INTERL.EQ.3) THEN                            1332.000
         IF (INTERL.LT.2) THEN                                          1333.000
         DO 706 L=1,3                                                   1334.000
 706     DIR(IC(L))=DELX2(L)                                            1335.000
         DO 705 L=1,3                                                   1336.000
 705     SIG(L)=(XIG(L,I)+XIG(L,J))*DIR(L)*DIR(L)                       1337.000
         IF (DIST.GE.0.0001)
     1   E1=SQRT((SIG(1)+SIG(2)+SIG(3)+2.*DIR(1)*DIR(2)*XIG(4,I)        1338.000
     2   +2.*DIR(1)*DIR(2)*XIG(4,J)+2.*DIR(1)*DIR(3)*XIG(5,I)           1339.000
     3   +2.*DIR(1)*DIR(3)*XIG(5,J)+2.*DIR(2)*DIR(3)*XIG(6,I)           1340.000
     4   +2.*DIR(2)*DIR(3)*XIG(6,J))/DIST)                              1341.000
         ENDIF                                                          1342.000
         DIST=SQRT(DIST)                                                1343.000
         ELSE                                                           1344.000
         IN(1)=1                                                        1345.000
         IN(2)=I                                                        1346.000
         IN(3)=0                                                        1347.000
         IN(4)=J                                                        1348.000
         IN(5)=100+(IS-1)*M+S+(INT-1)*(2-ICENT)*M                       1349.000
         CALL SUB19                                                     1350.000
         ENDIF                                                          1351.000
      IF (DIST.GT.AMAX) GO TO 7                                         1352.000
         IF (INTERL.LT.0.OR.DIST.LT.AMIN) RETURN                        1353.000
      ND=ND+1                                                           1354.000
         EKEEP(ND)=E1                                                   1355.000
      DKEEP(ND)=DIST                                                    1356.000
         DO 11 L=1,3                                                    1357.000
         DFKEEP(IC(L),ND)=DELX2(L)                                      1358.000
 11      XKEEP(L,ND)=XOUT(L)                                            1359.000
C        FORM ATOM DESIGNATOR CODE, A 3-DIGIT NUMBER TO BASE 729,       1360.000
C        ALLOWING REPRESENTATION OF ALL LATTICE TRANSLATIONS UP TO      1361.000
C        + OR - 4 UNIT CELLS FOR ALL ATOMS IN ALL EQUIVALENT POSITIONS, 1362.000
C        SINCE 729=(4-(-4)+1)**3. 1ST DIGIT IS ATOM SEQUENCE NUMBER,    1363.000
C        2ND IS PACKED LATTICE TRANSLATIONS, 3RD IS PACKED EQUIVALENT   1364.000
C        POSITION NUMBER,LATTICE POINT NUMBER AND INVERSION INDICATOR.  1365.000
      JATOM(ND)=J*531441+((LTRAN(3,1)+4)*81+(LTRAN(2,1)+4)*9+LTRAN(1,1) 1366.000
     1+4)*729+S*25+INT*5+IS                                             1367.000
      RETURN                                                            1368.000
 7    IF (INTERL+1) 99,2,5                                              1369.000
 2    IF(S.EQ.1.AND.IS.EQ.1.AND.INT.EQ.1.AND.LTRAN(1,1).EQ.0.AND.       1370.000
     1LTRAN(2,1).EQ.0.AND.LTRAN(3,1).EQ.0) RETURN                       1371.000
 99      IF (DONE.EQ.0) THEN                                            1372.000
      DELX1(IC(1))=XI(1,I)                                              1373.000
      DELX1(IC(2))=XI(2,I)                                              1374.000
      DELX1(IC(3))=XI(3,I)                                              1375.000
      WRITE (IPRIN,101) ATOM(I),DELX1                                   1376.000
         DONE=1                                                         1377.000
         ENDIF                                                          1378.000
      WRITE (IPRIN,100) ATOM(I),ATOM(J),DIST,E1,S,STAR(IS),INT,         1379.000
     1(LTRAN(L,1),L=1,3),XOUT                                           1380.000
 5    RETURN                                                            1381.000
      END                                                               1382.000
         SUBROUTINE SYMPRT(LFC)                                         1383.000
         CHARACTER LINE(66),COMPID(72)                                  1384.000
         CHARACTER*8 LABEL(200),FTYPE(13)                               1385.000
         INTEGER CN(200),CONTNT(13),START                               1386.000
         DIMENSION RR(3,4),RRR(3,4)                                     1387.000
         COMMON IPRIN,LPP,ICORR,IRAD,ISWAP(3)                           1388.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               1389.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           1390.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        1391.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 1392.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      1393.000
         DO 10 I=1,NR                                                   1394.000
         DO 1 K=1,3                                                     1395.000
         DO 1 J=1,4                                                     1396.000
 1       RRR(ISWAP(K),J)=R(I,K,J)                                       1397.000
         DO 2 K=1,3                                                     1398.000
         RR(K,4)=RRR(K,4)                                               1399.000
         DO 2 J=1,3                                                     1400.000
 2       RR(J,ISWAP(K))=RRR(J,K)                                        1401.000
         START=1                                                        1402.000
         DO 11 J=1,3                                                    1403.000
         CALL CRDOUT(LINE,START,RR(J,1),RR(J,2),RR(J,3),RR(J,4))        1404.000
         IF (J.EQ.3) GO TO 11                                           1405.000
         LINE(START)=','                                                1406.000
         START=START+1                                                  1407.000
 11      CONTINUE                                                       1408.000
         START=START-1                                                  1409.000
 10      WRITE (LFC,100) I,(LINE(J),J=1,START)                          1410.000
 100     FORMAT (I3,2X,   66A1)                                         1411.000
         RETURN                                                         1412.000
         END                                                            1413.000
      SUBROUTINE ROTAT(X,Y)                                             1414.000
      Z=Y                                                               1415.000
      Y=X                                                               1416.000
      X=Z                                                               1417.000
      RETURN                                                            1418.000
      END                                                               1419.000
      SUBROUTINE ROTA2(I,J)                                             1420.000
      K=J                                                               1421.000
      J=I                                                               1422.000
      I=K                                                               1423.000
      RETURN                                                            1424.000
      END                                                               1425.000
      SUBROUTINE PUBS(RCP)                                              1426.000
C     LISTING OF ATOMIC PARAMETERS FOR PUBLICATION.                     1427.000
         CHARACTER COMPID(72),FSPEC(80),LBUF(148),IBRAK1(10),IBRAK2(7)  1428.000
         CHARACTER IBRAK3(7),IBRAK4(7),IBRAK5(4),IBRAK6(4),IBRAK7(4)    1429.000
      CHARACTER*8 SYM(200),LABEL,FTYPE(13)                              1430.000
      CHARACTER*80 CBUF                                                 1431.000
      INTEGER                      SIGU(6),CN(200),CONTNT(13)           1432.000
         DIMENSION RCP(3),RAX(3)                                        1433.000
      COMMON IPRIN,LPP,ICORR,IRAD,ISWAP(3),ISIG(3),U(6),SIGU            1434.000
         COMMON/CHARA/LBUF,FSPEC                                        1435.000
         COMMON/MODELC/COMPID,SYM,FTYPE                                 1436.000
         COMMON/MODEL/NA,NR,NT,NTYPE,NFTYPE(200),X(3,200),              1437.000
     1   CN,SOF(200),BETA(6,200),SIGX(3,200),ESOF(200),SIGB(6,200),     1438.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 1439.000
     3   SFAC(14,13),CONTNT,SCALE,EXTNCT(6)                             1440.000
         EQUIVALENCE (CBUF,FSPEC)                                       1441.000
 5    FORMAT ( '(1X,10A1,F8.5,7A1,2(F8.5,7A1),1X,F6.3,4A1)')            1442.000
 6       FORMAT (    '( 1X,10A1,F6.4,4A1,5(F6.4,4A1))')                 1443.000
 7       FORMAT ('COORDINATES & UISO/UEQ')                              1444.000
 17      FORMAT ('END OF TABLE')                                        1445.000
 18   FORMAT ('TEMPERATURE FACTORS')                                    1446.000
      WRITE (2,7)                                                       1447.000
      DO 6004 II=1,NA                                                   1448.000
         WRITE (CBUF,5)                                                 1449.000
         IE1=4                                                          1450.000
         DO 1124 I=1,3                                                  1451.000
         IF (SIGX(I,II).LE.0.000001) GO TO 1124                         1452.000
         CALL SETPRE(SIGX(I,II),IE1,FSPEC,0)                            1453.000
         GO TO 14                                                       1454.000
 1124    CONTINUE                                                       1455.000
 14   DO 6003 I=1,3                                                     1456.000
       ISIG(I)=NINT(SIGX(I,II)*10**IE1)                                 1457.000
      IF (SIGX(I,II).GT.0.000001) GO TO 6003                            1458.000
      ISIG(I)=-1                                                        1459.000
 6003 CONTINUE                                                          1460.000
      LABEL=SYM(II)                                                     1461.000
      CALL CTABLE(LABEL,            0,IBRAK1,10)                        1462.000
      CALL TABLE(0,    ISIG(1),-1,0,       IBRAK2,7)                    1463.000
      CALL TABLE(0,    ISIG(2),-1,0,       IBRAK3,7)                    1464.000
      CALL TABLE(0,    ISIG(3),-1,0,       IBRAK4,7)                    1465.000
         U(ISWAP(1))=X(1,II)                                            1466.000
         U(ISWAP(2))=X(2,II)                                            1467.000
         U(ISWAP(3))=X(3,II)                                            1468.000
         IE1=3                                                          1469.000
         IF (BETA(2,II).GT.0.000001)   THEN                             1470.000
         RAX(ISWAP(1))=RCP(1)                                           1471.000
         RAX(ISWAP(2))=RCP(2)                                           1472.000
         RAX(ISWAP(3))=RCP(3)                                           1473.000
         U(4)=0.                                                        1474.000
         DO 1 I=1,3                                                     1475.000
 1       U(4)=U(4)+BETA(I,II)*RAX(I)*RAX(I)*CELL(I)*CELL(I)             1476.000
         DO 2 I=1,2                                                     1477.000
         DO 2 J=I+1,3                                                   1478.000
 2       U(4)=U(4)+BETA(I+J+1,II)*RAX(I)*RAX(J)*CELL(I)*CELL(J)*        1479.000
     1   CELL(6-MOD(I+J,3))                                             1480.000
         U(4)=U(4)/3.                                                   1481.000
         UU=0.                                                          1482.000
         ELSE                                                           1483.000
         U(4)=BETA(1,II)                                                1484.000
         UU=SIGB(1,II)                                                  1485.000
         ENDIF                                                          1486.000
         IF (UU.GT.0.000001)   THEN                                     1487.000
         CALL SETPRE(UU,IE1,FSPEC,2)                                    1488.000
         SIGU(1)=NINT(UU*10**IE1)                                       1489.000
         ELSE                                                           1490.000
         SIGU(1)=-1                                                     1491.000
         ENDIF                                                          1492.000
         CALL TABLE(0,SIGU(1),-1,0,IBRAK5,4)                            1493.000
      WRITE (2,FSPEC)IBRAK1,U(1),IBRAK2,U(2),IBRAK3,U(3),IBRAK4,        1494.000
     1                   U(4),(IBRAK5(I),I=1,4)                         1495.000
      IF (IPRIN.EQ.6) WRITE (IPRIN,FSPEC)IBRAK1,U(1),IBRAK2,U(2),       1496.000
     1   IBRAK3,U(3),IBRAK4,U(4),(IBRAK5(I),I=1,4)                      1497.000
 6004 CONTINUE                                                          1498.000
         WRITE (2,17)                                                   1499.000
      WRITE (2,18)                                                      1500.000
      DO 6005 II=1,NA                                                   1501.000
      IF (BETA(2,II).LE.0.000001)   GO TO 6005                          1502.000
         WRITE (CBUF,6)                                                 1503.000
         IE1=3                                                          1504.000
         DO 1125 I=1,6                                                  1505.000
         IF (SIGB(I,II).LE.0.000001) GO TO 1125                         1506.000
         CALL SETPRE(SIGB(I,II),IE1,FSPEC,1)                            1507.000
         GO TO 111                                                      1508.000
 1125    CONTINUE                                                       1509.000
 111  LABEL=SYM(II)                                                     1510.000
      CALL CTABLE(LABEL,            0,IBRAK1,10)                        1511.000
      DO 6006 I=1,6                                                     1512.000
      SIGU(I)=NINT(SIGB(I,II)*10**IE1)                                  1513.000
      UU=BETA(I,II)                                                     1514.000
      IF (SIGB(I,II).GT.0.000001) GO TO 6006                            1515.000
      SIGU(I)=-1                                                        1516.000
 6006 U(I)=     UU                                                      1517.000
      CALL TABLE(0,   SIGU(1),-1,0,IBRAK2,4)                            1518.000
      CALL TABLE(0,   SIGU(2),-1,0,IBRAK3,4)                            1519.000
      CALL TABLE(0,   SIGU(3),-1,0,IBRAK4,4)                            1520.000
      CALL TABLE(0,   SIGU(4),-1,0,IBRAK5,4)                            1521.000
      CALL TABLE(0,   SIGU(5),-1,0,IBRAK6,4)                            1522.000
      CALL TABLE(0,   SIGU(6),-1,0,IBRAK7,4)                            1523.000
      WRITE (2,FSPEC)IBRAK1,U(1),(IBRAK2(I),I=1,4),U(2),(IBRAK3(I),     1524.000
     1I=1,4),U(3),(IBRAK4(I),I=1,4),U(4),IBRAK5,U(5),IBRAK6,U(6),IBRAK7 1525.000
         IF (IPRIN.EQ.6) WRITE (IPRIN,FSPEC)                            1526.000
     1               IBRAK1,U(1),(IBRAK2(I),I=1,4),U(2),(IBRAK3(I),     1527.000
     2I=1,4),U(3),(IBRAK4(I),I=1,4),U(4),IBRAK5,U(5),IBRAK6,U(6),IBRAK7 1528.000
 6005 CONTINUE                                                          1529.000
         WRITE (2,17)                                                   1530.000
      RETURN                                                            1531.000
      END                                                               1532.000
         SUBROUTINE SETPRE(ESD,IEXP,FSPEC,MODE)                         1533.000
         COMMON /LIMITS/MAXYZ,MAXUIJ,MAXBON                             1534.000
         CHARACTER FSPEC(80),BUF(80)                                    1535.000
         CHARACTER*80 CBUF                                              1536.000
         EQUIVALENCE (CBUF,BUF)                                         1537.000
         MAXESD=MAXYZ                                                   1538.000
         IF (MODE.GT.0) MAXESD=MAXUIJ                                   1539.000
         DO 1 I=1,5                                                     1540.000
         IEXP=6-I                                                       1541.000
         IF (NINT(ESD*10**IEXP).LT.MAXESD) GO TO 2                      1542.000
 1       CONTINUE                                                       1543.000
 2       GO TO (4,3,5),MODE+1                                           1544.000
 4       WRITE (CBUF,10)    IEXP+3,IEXP,IEXP,6-IEXP                     1545.000
 10      FORMAT ('(1X,10A1,F',I1,'.',I1,',7A1,2(F8.',I1,',7A1),',I1,    1546.000
     1   'X,')                                                          1547.000
         J=33                                                           1548.000
         GO TO 6                                                        1549.000
 3       IF (IEXP.GT.4) IEXP=4                                          1550.000
         WRITE (CBUF,11)      IEXP+2,IEXP,IEXP                          1551.000
 11      FORMAT ('(1X,10A1,F',I1,'.',I1,',4A1,5(F6.',I1,',4A1))')       1552.000
         J=80                                                           1553.000
 6       DO 7 I=1,J                                                     1554.000
 7       FSPEC(I)=BUF(I)                                                1555.000
         RETURN                                                         1556.000
 5       WRITE (CBUF,12) IEXP+3, IEXP                                   1557.000
 12      FORMAT ('F',I1,'.',I1,',4A1)')                                 1558.000
         DO 8 I=34,80                                                   1559.000
 8       FSPEC(I)=BUF(I-33)                                             1560.000
         RETURN                                                         1561.000
         END                                                            1562.000
         FUNCTION ACOS(X)                                               1563.000
         IF (ABS(X).GT.1.0) THEN                                        1564.000
            X=SIGN(1.0,X)                                               1565.000
         ENDIF                                                          1566.000
         IF (X.EQ.0.0) THEN                                             1567.000
            ACOS=1.5707964                                              1568.000
         ELSE IF (X.LT.0.0) THEN                                        1569.000
            ACOS=3.141593+ATAN(SQRT(1.0-X*X)/X)                         1570.000
         ELSE                                                           1571.000
            ACOS=ATAN(SQRT(1.0-X*X)/X)                                  1572.000
         ENDIF                                                          1573.000
         RETURN                                                         1574.000
         END                                                            1575.000
         SUBROUTINE ORFFEB                                              1576.000
C  LZ=MONITOR OUTPUT, MQZ=BINARY INPUT FROM RBLS                        1577.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                1578.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   1579.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        1580.000
C * * * * END GOULD S.E.L. CODE * * * * *                               1581.000
      COMMON/NAT/JTF(200),NADDRX(200),NADDRB(200)                       1582.000
      COMMON/NP/KI1(2000),KI2(2000),P(2000)                             1583.000
      COMMON/NV/DP(MMP),DFDP(MMP)                                       1584.000
      COMMON/OUT/IN(231)                                                1585.000
      COMMON/MET/AA(3,3),BB(3,3)                                        1586.000
      COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48)                         1587.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11588.000
     20),ROW(6),A(6)                                                    1589.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1590.000
     2,E,E1,LZ,NQZ,MQZ                                                  1591.000
      COMMON/E/NG                                                       1592.000
      COMMON/G1/NJE                                                     1593.000
         COMMON/CONSTR/NCON,ICON(99,2),EFACT(99,2)                      1594.000
         IC(1)=1                                                        1595.000
         IC(2)=0                                                        1596.000
         IC(3)=1                                                        1597.000
         IC(5)=0                                                        1598.000
         IC(6)=0                                                        1599.000
         IC(7)=0                                                        1600.000
         IC(8)=0                                                        1601.000
         IC(9)=0                                                        1602.000
         IC(10)=0                                                       1603.000
         NF=0                                                           1604.000
         IDR=0                                                          1605.000
      LZ=6                                                              1606.000
      MQZ=20                                                            1607.000
         REWIND MQZ                                                     1608.000
      READ          (MQZ)        (TITLE(I), I=1,10)                     1609.000
      READ          (MQZ)       IC(4),           NT                     1610.000
      READ(MQZ)NA,NCON                                                  1611.000
      READ(MQZ)(JTF(I),I=1,NA)                                          1612.000
      IF (NCON.GT.0) READ(MQZ)((EFACT(I,K),K=1,2),I=1,NCON)             1613.000
      READ(MQZ)ITF,NQ,IC(2)                                             1614.000
      NP=IC(2)                                                          1615.000
      READ     (MQZ)          (KI1(I),I=1,NP)                           1616.000
      READ     (MQZ)          (P(I),I=1,NP)                             1617.000
      IC(10)=NQ+5                                                       1618.000
      IC(8)=NQ+1                                                        1619.000
      IF(ITF-1)01301,01301,01401                                        1620.000
 1301 IC(7)=5                                                           1621.000
      IC(9)=5                                                           1622.000
      GO TO 01501                                                       1623.000
 1401 IC(7)=10                                                          1624.000
      IC(9)=10                                                          1625.000
 1501 KB=IC(10)                                                         1626.000
      KX=IC(8)                                                          1627.000
      DO 1801 I=1,NA                                                    1628.000
      NADDRX(I)=KX                                                      1629.000
      NADDRB(I)=KB                                                      1630.000
      IF(JTF(I)-1)1811,1811,1812                                        1631.000
 1811 KX=KX+5                                                           1632.000
      KB=KB+5                                                           1633.000
      GO TO 1801                                                        1634.000
 1812 KX=KX+10                                                          1635.000
      KB=KB+10                                                          1636.000
 1801 CONTINUE                                                          1637.000
      READ     (MQZ)          IC(5)                                     1638.000
      N=IC(5)                                                           1639.000
      NM=(N*(N+1))/2                                                    1640.000
      READ     (MQZ)           (PM(K),K=1,NM)                           1641.000
      NJE = 0                                                           1642.000
      DO 02104 I=1,NP                                                   1643.000
         IPOINT=KI1(I)/100                                              1644.000
         IF (IPOINT.GT.0) THEN                                          1645.000
         K=0                                                            1646.000
         DO 2 J=1,NP                                                    1647.000
         IF (KI1(J).EQ.1) THEN                                          1648.000
         K=K+1                                                          1649.000
         IF (K.EQ.IPOINT) GO TO 3                                       1650.000
         ENDIF                                                          1651.000
 2       CONTINUE                                                       1652.000
 3       ICON(MOD(KI1(I),100),1)=I                                      1653.000
         ICON(MOD(KI1(I),100),2)=J                                      1654.000
         KI1(I)=0                                                       1655.000
         ENDIF                                                          1656.000
      IF (KI1(I).EQ.0) GO TO 2104                                       1657.000
      NJE=NJE+1                                                         1658.000
 2104    CONTINUE                                                       1659.000
      READ          (MQZ)      (AS(I),I=1,3),(CAS(I),I=1,3)             1660.000
      IF(IDR)02203,02203,02204                                          1661.000
02203 DO 02206 I=1,3                                                    1662.000
      A(I)=AS(I)                                                        1663.000
02206 A(I+3)=CAS(I)                                                     1664.000
      GOTO 02207                                                        1665.000
02204 CALL CONVCC(AS,CAS,A)                                             1666.000
2207  IF(IC(3)-1)03401,02401,02701                                      1667.000
02401 DO 02402 I=1,21                                                   1668.000
02402 AM(I)=0.0                                                         1669.000
      READ          (MQZ)      AM(1),AM(7),AM(12),AM(16),AM(19),AM(21)  1670.000
      DO 02602 I=1,21                                                   1671.000
02602 AM(I)=AM(I)*AM(I)                                                 1672.000
 2701 K=1                                                               1673.000
      L=6                                                               1674.000
      DO 03303 I=1,6                                                    1675.000
      DA(I)=(0.01)*SQRT (AM(K))                                         1676.000
      K=K+L                                                             1677.000
03303 L=L-1                                                             1678.000
03401 NS=IC(4)                                                          1679.000
      IF(NS)03701,03701,03601                                           1680.000
03601 READ (MQZ)      ((TS(I,J),(TIS(K,I,J),K=1,3),I=1,3),J=1,NS)       1681.000
      DO03630 J=1,NS                                                    1682.000
      DO03630 I=1,3                                                     1683.000
      NULPE=1                                                           1684.000
      DO03629 K=1,3                                                     1685.000
      IF(ABS (TIS(K,I,J))-1.0)03612,03612,03613                         1686.000
03613 IF(TIS(K,I,J))03614,03614,03615                                   1687.000
03614 IS(1,I,J)=-K                                                      1688.000
      IS(2,I,J)=-K                                                      1689.000
      GOTO03630                                                         1690.000
03615 IS(1,I,J)=K                                                       1691.000
      IS(2,I,J)=K                                                       1692.000
      GOTO03630                                                         1693.000
03612 IF(TIS(K,I,J))03609,03629,03611                                   1694.000
03609 IS(NULPE,I,J)=-K                                                  1695.000
      NULPE=NULPE+1                                                     1696.000
      GOTO03629                                                         1697.000
03611 IS(NULPE,I,J)=K                                                   1698.000
      NULPE=NULPE+1                                                     1699.000
03629 CONTINUE                                                          1700.000
      GOTO(03620,03621,03630,03620),NULPE                               1701.000
 3620 WRITE           (LZ,03622)                                        1702.000
03622 FORMAT(23H ERROR IN SYMMETRY CARD)                                1703.000
      STOP                                                              1704.000
03621 IS(2,I,J)=0                                                       1705.000
03630 CONTINUE                                                          1706.000
      IF(NT)03701,03701,03751                                           1707.000
03751 READ          (MQZ)      ((ANT(IL,I),IL=1,3),I=1,NT)              1708.000
      NST=0                                                             1709.000
      DO03780 INT=1,NT                                                  1710.000
      NST=NST+NS                                                        1711.000
      DO03780 INS=1,NS                                                  1712.000
      INST=NST+INS                                                      1713.000
      DO03770 IL=1,3                                                    1714.000
      TS(IL,INST)=AMOD((TS(IL,INS)+ANT(IL,INT)),1.0)                    1715.000
      DO03770 IIS=1,2                                                   1716.000
03770 IS(IIS,IL,INST)=IS(IIS,IL,INS)                                    1717.000
 3780 CONTINUE                                                          1718.000
      NS=NS*(NT+1)                                                      1719.000
      IC(4)=NS                                                          1720.000
03701 IF(IC(1))03801,04001,03801                                        1721.000
03801 K=1                                                               1722.000
      L=N                                                               1723.000
      DO 03903 I=1,N                                                    1724.000
      DP(I)=(0.01)*SQRT (PM(K))                                         1725.000
      K=K+L                                                             1726.000
03903 L=L-1                                                             1727.000
 4001    RETURN                                                         1728.000
      END                                                               1729.000
         FUNCTION ARCCOS(X)                                             1730.000
C        ARC COS IN DEGREES                                             1731.000
         ARCCOS=57.2957795*ACOS(X)                                      1732.000
         RETURN                                                         1733.000
         END                                                            1734.000
      SUBROUTINEATOM(I,Y)                                               1735.000
CATOM    1471 WRB ATOM COORDINATE SUBROUTINE                            1736.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                1737.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   1738.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        1739.000
C * * * * END GOULD S.E.L. CODE * * * * *                               1740.000
      COMMON/E/NG                                                       1741.000
      COMMON/OUT/IN(231)                                                1742.000
      COMMON/NAT/JTF(200),NADDRX(200),NADDRB(200)                       1743.000
      COMMON/NP/KI1(2000),KI2(2000),P(2000)                             1744.000
      COMMON/NV/DP(MMP),DFDP(MMP)                                       1745.000
      COMMON/MET/AA(3,3),BB(3,3)                                        1746.000
      COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48)                         1747.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11748.000
     20),ROW(6),A(6)                                                    1749.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1750.000
     2,E,E1,LZ,NQZ,MQZ                                                  1751.000
      DIMENSIONI(2),X(3),Y(3)                                           1752.000
      IF(I(1))109,109,117                                               1753.000
  109 X(1)=0.0                                                          1754.000
      X(2)=0.0                                                          1755.000
      X(3)=0.0                                                          1756.000
      GOTO125                                                           1757.000
  117 I1=I(1)                                                           1758.000
      K=NADDRX(I1)                                                      1759.000
 1176 IF(K+2-IC(2))119,119,503                                          1760.000
  503 NG=5                                                              1761.000
      GOTO325                                                           1762.000
  119 DO123J=1,3                                                        1763.000
      X(J)=P(K)                                                         1764.000
  123 K=K+1                                                             1765.000
  125 KC=I(2)/100                                                       1766.000
      KS=I(2)-100*KC                                                    1767.000
      IF(KS-IC(4))203,203,403                                           1768.000
  403 NG=1                                                              1769.000
      GOTO325                                                           1770.000
  203 IF(KS)403,205,213                                                 1771.000
  205 Y(1)=X(1)                                                         1772.000
      Y(2)=X(2)                                                         1773.000
      Y(3)=X(3)                                                         1774.000
      GOTO311                                                           1775.000
  213 DO215J=1,3                                                        1776.000
  215 Y(J)=TS(J,KS)                                                     1777.000
      DO309K=1,3                                                        1778.000
      DO307J=1,2                                                        1779.000
      L=IS(J,K,KS)                                                      1780.000
      IF(L)225,307,305                                                  1781.000
  225 L=-L                                                              1782.000
      Y(K)=Y(K)-X(L)                                                    1783.000
      GOTO307                                                           1784.000
  305 Y(K)=Y(K)+X(L)                                                    1785.000
  307 CONTINUE                                                          1786.000
  309 CONTINUE                                                          1787.000
  311 IF (KC.EQ.0) RETURN                                               1788.000
      Y(1)=Y(1)+LTRAN(1,KC)                                             1789.000
      Y(2)=Y(2)+LTRAN(2,KC)                                             1790.000
      Y(3)=Y(3)+LTRAN(3,KC)                                             1791.000
  325 RETURN                                                            1792.000
      END                                                               1793.000
      SUBROUTINE CONVCC(AX,CO,AST)                                      1794.000
      DIMENSION AX(3),AST(6),CO(3)       ,ZIN(3),SIS(3)                 1795.000
      DO 1 I=1,3                                                        1796.000
    1 ZIN(I)=SQRT (1.0-CO(I)**2)                                        1797.000
      AST(4)=(CO(2)*CO(3)-CO(1))/(ZIN(2)*ZIN(3))                        1798.000
      AST(5)=(CO(1)*CO(3)-CO(2))/(ZIN(1)*ZIN(3))                        1799.000
      AST(6)=(CO(1)*CO(2)-CO(3))/(ZIN(1)*ZIN(2))                        1800.000
      DO 2 I=1,3                                                        1801.000
    2 SIS(I)=SQRT (1.0-AST(I+3)**2)                                     1802.000
      AST(1)=1.0/(AX(1)*SIS(2)*ZIN(3))                                  1803.000
      AST(2)=1.0/(AX(2)*SIS(1)*ZIN(3))                                  1804.000
      AST(3)=1.0/(AX(3)*SIS(1)*ZIN(2))                                  1805.000
      RETURN                                                            1806.000
      END                                                               1807.000
      FUNCTIONCOSVV(X,Y)                                                1808.000
CCOSVV   1471 WRB COSINE OF ANGLE BETWEEN VECTORS X AND Y               1809.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                1810.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   1811.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        1812.000
C * * * * END GOULD S.E.L. CODE * * * * *                               1813.000
      COMMON/E/NG                                                       1814.000
      COMMON/OUT/IN(231)                                                1815.000
      COMMON/NP/KI1(2000),KI2(2000),P(2000)                             1816.000
      COMMON/NV/DP(MMP),DFDP(MMP)                                       1817.000
      COMMON/MET/AA(3,3),BB(3,3)                                        1818.000
      COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48)                         1819.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11820.000
     20),ROW(6),A(6)                                                    1821.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1822.000
     2,E,E1,LZ,NQZ,MQZ                                                  1823.000
      DIMENSIONX(3),Y(3)                                                1824.000
      D=SQRT (VMV(X,AA,X)*VMV(Y,AA,Y))                                  1825.000
      IF(D)111,111,115                                                  1826.000
  111 NG=9                                                              1827.000
      GOTO117                                                           1828.000
  115 COSVV=VMV(X,AA,Y)/D                                               1829.000
  117 RETURN                                                            1830.000
      END                                                               1831.000
      SUBROUTINEDIFV(X,Y,Z)                                             1832.000
CDIFV    1471 WRB VECTOR - VECTOR                                       1833.000
C                 Z(3)=X(3)-Y(3)                                        1834.000
      DIMENSIONX(3),Y(3),Z(3)                                           1835.000
      DO111I=1,3                                                        1836.000
  111 Z(I)=X(I)-Y(I)                                                    1837.000
      RETURN                                                            1838.000
      END                                                               1839.000
      FUNCTIONFUNA(I)                                                   1840.000
CFUNA    1471 WRB ANGLE SUBROUTINE USED BY FUN2, FUN5, FUN6             1841.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                1842.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   1843.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        1844.000
C * * * * END GOULD S.E.L. CODE * * * * *                               1845.000
      COMMON/E/NG                                                       1846.000
      COMMON/NP/KI1(2000),KI2(2000),P(2000)                             1847.000
      COMMON/NV/DP(MMP),DFDP(MMP)                                       1848.000
      COMMON/MET/AA(3,3),BB(3,3)                                        1849.000
      COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48)                         1850.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11851.000
     20),ROW(6),A(6)                                                    1852.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1853.000
     2,E,E1,LZ,NQZ,MQZ                                                  1854.000
      DIMENSIONI(6),X1(3),X2(3),X3(3),V1(3),V2(3)                       1855.000
      CALLSTOAA                                                         1856.000
      CALLATOM(I(1),X1)                                                 1857.000
      CALLATOM(I(3),X2)                                                 1858.000
      CALLATOM(I(5),X3)                                                 1859.000
      IF(NG)123,117,123                                                 1860.000
  117 CALLDIFV(X1,X2,V1)                                                1861.000
      CALLDIFV(X3,X2,V2)                                                1862.000
      FUNA=ARCCOS(COSVV(V1,V2))                                         1863.000
  123 RETURN                                                            1864.000
      END                                                               1865.000
      FUNCTIONFUND(I)                                                   1866.000
CFUND    1471 WRB DISTANCE SUBROUTINE USED BY FUN1 AND FUN4             1867.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                1868.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   1869.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        1870.000
C * * * * END GOULD S.E.L. CODE * * * * *                               1871.000
      COMMON/E/NG                                                       1872.000
      COMMON/OUT/IN(231)                                                1873.000
      COMMON/NP/KI1(2000),KI2(2000),P(2000)                             1874.000
      COMMON/NV/DP(MMP),DFDP(MMP)                                       1875.000
      COMMON/MET/AA(3,3),BB(3,3)                                        1876.000
      COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48)                         1877.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11878.000
     20),ROW(6),A(6)                                                    1879.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1880.000
     2,E,E1,LZ,NQZ,MQZ                                                  1881.000
      DIMENSIONI(4),X1(3),X2(3),V(3)                                    1882.000
      CALLSTOAA                                                         1883.000
      CALLATOM(I(1),X1)                                                 1884.000
      CALLATOM(I(3),X2)                                                 1885.000
      CALLDIFV(X2,X1,V)                                                 1886.000
      FUND=SQRT (VMV(V,AA,V))                                           1887.000
      RETURN                                                            1888.000
      END                                                               1889.000
      SUBROUTINE FUNI(I)                                                1890.000
C   SELECTS THE FUN SUBROUTINE TO BE ENTERED                            1891.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                1892.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   1893.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        1894.000
C * * * * END GOULD S.E.L. CODE * * * * *                               1895.000
      COMMON/E/NG                                                       1896.000
      COMMON/OUT/IN(231)                                                1897.000
      COMMON/NP/KI1(2000),KI2(2000),P(2000)                             1898.000
      COMMON/NV/DP(MMP),DFDP(MMP)                                       1899.000
      COMMON/MET/AA(3,3),BB(3,3)                                        1900.000
      COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48)                         1901.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11902.000
     20),ROW(6),A(6)                                                    1903.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1904.000
     2,E,E1,LZ,NQZ,MQZ                                                  1905.000
         COMMON/CONSTR/NCON,ICON(99,2),EFACT(99,2)                      1906.000
      CALL SETA(A)                                                      1907.000
         IF (NCON.GT.0) THEN                                            1908.000
         DO 1 J=1,NCON                                                  1909.000
 1       P(ICON(J,1))=P(ICON(J,2))*EFACT(J,1)+EFACT(J,2)                1910.000
         ENDIF                                                          1911.000
      IF(I)6,6,5                                                        1912.000
    5 IF(I-2) 8,8,6                                                     1913.000
    6    NG=11                                                          1914.000
         GO TO 160                                                      1915.000
    8 GO TO (10,20),I                                                   1916.000
   10    CALL FUN1                                                      1917.000
         GO TO 160                                                      1918.000
   20    CALL FUN2                                                      1919.000
         GO TO 160                                                      1920.000
  160 RETURN                                                            1921.000
      END                                                               1922.000
      SUBROUTINEFUN1                                                    1923.000
CFUN1    1471 WRB COMPUTE INTERATOMIC DISTANCE                          1924.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                1925.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   1926.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        1927.000
C * * * * END GOULD S.E.L. * * * * *                                    1928.000
      COMMON/E/NG                                                       1929.000
      COMMON/OUT/IN(231)                                                1930.000
      COMMON/NP/KI1(2000),KI2(2000),P(2000)                             1931.000
      COMMON/NV/DP(MMP),DFDP(MMP)                                       1932.000
      COMMON/MET/AA(3,3),BB(3,3)                                        1933.000
      COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48)                         1934.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11935.000
     20),ROW(6),A(6)                                                    1936.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1937.000
     2,E,E1,LZ,NQZ,MQZ                                                  1938.000
      FX=FUND(IN(2))                                                    1939.000
      RETURN                                                            1940.000
      END                                                               1941.000
      SUBROUTINEFUN2                                                    1942.000
CFUN2    1471 WRB BOND ANGLE SUBROUTINE                                 1943.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                1944.000
C * * * * GOULD S.E.L. ONLY * * * *                                     1945.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        1946.000
C * * * * END GOULD S.E.L. * * * * *                                    1947.000
      COMMON/E/NG                                                       1948.000
      COMMON/OUT/IN(231)                                                1949.000
      COMMON/NP/KI1(2000),KI2(2000),P(2000)                             1950.000
      COMMON/NV/DP(MMP),DFDP(MMP)                                       1951.000
      COMMON/MET/AA(3,3),BB(3,3)                                        1952.000
      COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48)                         1953.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11954.000
     20),ROW(6),A(6)                                                    1955.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1956.000
     2,E,E1,LZ,NQZ,MQZ                                                  1957.000
      FX=FUNA(IN(2))                                                    1958.000
      RETURN                                                            1959.000
      END                                                               1960.000
      SUBROUTINEMV(X,Y,Z)                                               1961.000
CMV      1471 WRB MATRIX * VECTOR                                       1962.000
C                 Z(3)=X(3,3)*Y(3)                                      1963.000
      DIMENSIONX(3,3),Y(3),Z(3)                                         1964.000
      DO113I=1,3                                                        1965.000
      Z(I)=0.0                                                          1966.000
      DO113J=1,3                                                        1967.000
  113 Z(I)=Z(I)+X(I,J)*Y(J)                                             1968.000
      RETURN                                                            1969.000
      END                                                               1970.000
      SUBROUTINENORM(X,Y,Z)                                             1971.000
CNORM    1471 WRB STORE A VECTOR Z NORMAL TO VECTORS X AND Y            1972.000
      COMMON/MET/AA(3,3),BB(3,3)                                        1973.000
      DIMENSIONX(3),Y(3),Z(3),X1(6),Y1(6),Z1(3)                         1974.000
      DO115I=1,3                                                        1975.000
      X1(I)=X(I)                                                        1976.000
      X1(I+3)=X(I)                                                      1977.000
      Y1(I)=Y(I)                                                        1978.000
  115 Y1(I+3)=Y(I)                                                      1979.000
      DO119I=1,3                                                        1980.000
  119 Z1(I)=X1(I+1)*Y1(I+2)-X1(I+2)*Y1(I+1)                             1981.000
      CALLMV(BB,Z1,Z)                                                   1982.000
      RETURN                                                            1983.000
      END                                                               1984.000
      SUBROUTINE PREI(I)                                                1985.000
C   SELECTS THE PRE SUBROUTINE TO BE ENTERED                            1986.000
    4 IF(I)160,160,6                                                    1987.000
    6 IF(I-15)8,8,160                                                   1988.000
    8 GO TO (10,20),I                                                   1989.000
   10    CALL PRE1                                                      1990.000
         GO TO 160                                                      1991.000
   20    CALL PRE2                                                      1992.000
         GO TO 160                                                      1993.000
 160  RETURN                                                            1994.000
      END                                                               1995.000
      SUBROUTINEPRE1                                                    1996.000
      COMMON/OUT/IN(231)                                                1997.000
      CALLSETKX(IN(2))                                                  1998.000
      CALLSETKX(IN(4))                                                  1999.000
      RETURN                                                            2000.000
      END                                                               2001.000
      SUBROUTINEPRE2                                                    2002.000
CPRE2    1471 WRB PRELIMINARY SUBROUTINE 2                              2003.000
      COMMON/OUT/IN(231)                                                2004.000
      DO 107 I=2,6,2                                                    2005.000
 107  CALLSETKX(IN(I))                                                  2006.000
      RETURN                                                            2007.000
      END                                                               2008.000
      SUBROUTINE SETKX(I)                                               2009.000
CSETKX   SET KEY WORDS FOR ATOM COORDINATES                             2010.000
C     I=IN(K), THE INSTRUCTION INTEGER SPECIFYING THE ATOM NUMBER       2011.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                2012.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   2013.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        2014.000
C * * * * END GOULD S.E.L. * * * * *                                    2015.000
      COMMON/NAT/JTF(200),NADDRX(200),NADDRB(200)                       2016.000
      COMMON/E/NG                                                       2017.000
      COMMON/OUT/IN(231)                                                2018.000
      COMMON/NP/KI1(2000),KI2(2000),P(2000)                             2019.000
      COMMON/NV/DP(MMP),DFDP(MMP)                                       2020.000
      COMMON/MET/AA(3,3),BB(3,3)                                        2021.000
      COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48)                         2022.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(12023.000
     20),ROW(6),A(6)                                                    2024.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP2025.000
     2,E,E1,LZ,NQZ,MQZ                                                  2026.000
      IF(I)119,119,111                                                  2027.000
 111  J=NADDRX(I)                                                       2028.000
      KI2(J)=1                                                          2029.000
      KI2(J+1)=1                                                        2030.000
      KI2(J+2)=1                                                        2031.000
 119  RETURN                                                            2032.000
      END                                                               2033.000
      SUBROUTINESTOAA                                                   2034.000
CSTOAA   1471 WRB STORE METRIC TENSOR                                   2035.000
      COMMON/MET/AA(3,3),BB(3,3)                                        2036.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(12037.000
     20),ROW(6),A(6)                                                    2038.000
      AA(1,1)=A(1)*A(1)                                                 2039.000
      AA(2,2)=A(2)*A(2)                                                 2040.000
      AA(3,3)=A(3)*A(3)                                                 2041.000
      AA(1,2)=A(1)*A(2)*A(6)                                            2042.000
      AA(1,3)=A(1)*A(3)*A(5)                                            2043.000
      AA(3,1)=AA(1,3)                                                   2044.000
      AA(2,1)=AA(1,2)                                                   2045.000
      AA(2,3)=A(2)*A(3)*A(4)                                            2046.000
      AA(3,2)=AA(2,3)                                                   2047.000
      RETURN                                                            2048.000
      END                                                               2049.000
      SUBROUTINE SUB13                                                  2050.000
CSUB13   ERROR CALCULATION AND OUTPUT                                   2051.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                2052.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   2053.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        2054.000
C * * * * END GOULD S.E.L. * * * * *                                    2055.000
      COMMON/E/NG                                                       2056.000
      COMMON/OUT/IN(231)                                                2057.000
      COMMON/NP/KI1(2000),KI2(2000),P(2000)                             2058.000
      COMMON/NV/DP(MMP),DFDP(MMP)                                       2059.000
      COMMON/MET/AA(3,3),BB(3,3)                                        2060.000
      COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48)                         2061.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(12062.000
     20),ROW(6),A(6)                                                    2063.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP2064.000
     2,E,E1,LZ,NQZ,MQZ                                                  2065.000
      COMMON/G1/NJE                                                     2066.000
 109  FORMAT (1H ,51X,3H***,I3)                                         2067.000
 619  FORMAT (1H ,48X,F9.4,6X,3H***,I3)                                 2068.000
      IF(NG)107,113,107                                                 2069.000
 107  WRITE           (LZ,109)NG                                        2070.000
      GO TO 723                                                         2071.000
 113  VARA=0.0                                                          2072.000
      VARP=0.0                                                          2073.000
      IF(IC(3))119,313,119                                              2074.000
 119  DO 211 I=1,6                                                      2075.000
      IF(DA(I))201,123,201                                              2076.000
 123  DFDA(I)=0.0                                                       2077.000
      GO TO 211                                                         2078.000
 201  SAVEA=A(I)                                                        2079.000
      A(I)=A(I)+DA(I)                                                   2080.000
      CALL FUNI(IN(1))                                                  2081.000
      A(I)=SAVEA                                                        2082.000
      DFDA(I)=(FX-F)/DA(I)                                              2083.000
 211  CONTINUE                                                          2084.000
      K=1                                                               2085.000
      L=6                                                               2086.000
      DO 311 I=1,6                                                      2087.000
      IF(DFDA(I))225,221,225                                            2088.000
 221  K=K+L                                                             2089.000
      GO TO 311                                                         2090.000
 225  C=1.0                                                             2091.000
      DO 309 J=I,6                                                      2092.000
      IF(DFDA(J))305,307,305                                            2093.000
 305  VARA=VARA+C*DFDA(I)*DFDA(J)*AM(K)                                 2094.000
 307  K=K+1                                                             2095.000
 309  C=2.0                                                             2096.000
 311  L=L-1                                                             2097.000
 313  IF(IC(1))315,615,315                                              2098.000
 315  NP=IC(2)                                                          2099.000
      DO 319 I=1,NP                                                     2100.000
 319  KI2(I)=0                                                          2101.000
      CALL PREI(IN(1))                                                  2102.000
      J=0                                                               2103.000
      N=IC(5)                                                           2104.000
      DO 513 I=1,NJE                                                    2105.000
 403  J=J+1                                                             2106.000
      IF(KI1(J))407,403,407                                             2107.000
 407  IF(KI2(J))413,409,413                                             2108.000
 409  DFDP(I)=0.0                                                       2109.000
      GO TO 513                                                         2110.000
 413  IF(DP(I))501,409,501                                              2111.000
 501  SAVEP=P(J)                                                        2112.000
      P(J)=P(J)+DP(I)                                                   2113.000
      CALL FUNI(IN(1))                                                  2114.000
      P(J)=SAVEP                                                        2115.000
      DFDP(I)=(FX-F)/DP(I)                                              2116.000
      L=I                                                               2117.000
 513  CONTINUE                                                          2118.000
      KK=1                                                              2119.000
      KKD=N                                                             2120.000
      DO 613 I=1,L                                                      2121.000
      IF(DFDP(I))523,612,523                                            2122.000
 523  K=KK                                                              2123.000
      C=1.0                                                             2124.000
      DO 611 J=I,L                                                      2125.000
      IF(DFDP(J))607,609,607                                            2126.000
 607  VARP=VARP+C*DFDP(I)*DFDP(J)*PM(K)                                 2127.000
 609  K=K+1                                                             2128.000
 611  C=2.0                                                             2129.000
 612  KK=KK+KKD                                                         2130.000
 613  KKD=KKD-1                                                         2131.000
 615  IF(NG)617,623,617                                                 2132.000
 617  WRITE (LZ,619)F,NG                                                2133.000
      GO TO 723                                                         2134.000
 623  E1=SQRT (VARP)                                                    2135.000
      E=SQRT (VARP+VARA)                                                2136.000
 723  RETURN                                                            2137.000
      END                                                               2138.000
      SUBROUTINESUB19                                                   2139.000
CSUB19   1471 WRB FUNCTION AND ERROR CALCULATION                        2140.000
      PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2)
      COMMON/ORFFE/PM(MATRX),LTRAN(3,20)                                2141.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   2142.000
C     EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20)                        2143.000
C * * * * END GOULD S.E.L. * * * * *                                    2144.000
      COMMON/E/NG                                                       2145.000
      COMMON/OUT/IN(231)                                                2146.000
      COMMON/NP/KI1(2000),KI2(2000),P(2000)                             2147.000
      COMMON/NV/DP(MMP),DFDP(MMP)                                       2148.000
      COMMON/MET/AA(3,3),BB(3,3)                                        2149.000
      COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48)                         2150.000
      COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(12151.000
     20),ROW(6),A(6)                                                    2152.000
      COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP2153.000
     2,E,E1,LZ,NQZ,MQZ                                                  2154.000
      NG=0                                                              2155.000
      IF(IN(1))117,117,109                                              2156.000
 109  IF(IN(1)-20)111,111,117                                           2157.000
 111  CALL FUNI(IN(1))                                                  2158.000
      F=FX                                                              2159.000
      CALLSUB13                                                         2160.000
 117  RETURN                                                            2161.000
      END                                                               2162.000
      FUNCTIONVMV(W,X,Y)                                                2163.000
CVMV     1471 WRB TRANSPOSED VECTOR * MATRIX * VECTOR                   2164.000
C                 VMV=W(3)*X(3,3)*Y(3)                                  2165.000
      DIMENSIONW(3),X(3,3),Y(3),Z(3)                                    2166.000
      CALLMV(X,Y,Z)                                                     2167.000
      VMV=VV(W,Z)                                                       2168.000
      RETURN                                                            2169.000
      END                                                               2170.000
      FUNCTIONVV(X,Y)                                                   2171.000
CVV      1471 WRB TRANSPOSED VECTOR * VECTOR                            2172.000
C                 VV=X(3)*Y(3)                                          2173.000
      DIMENSIONX(3),Y(3)                                                2174.000
      VV=0.0                                                            2175.000
      DO111I=1,3                                                        2176.000
  111 VV=VV+X(I)*Y(I)                                                   2177.000
      RETURN                                                            2178.000
      END                                                               2179.000
      SUBROUTINE SETA(A)                                                2180.000
      RETURN                                                            2181.000
      END                                                               2182.000
