C        COPYRIGHT 1985 UNIVERSITY OF GLASGOW                           0001.000
C        CRYSTAL STRUCTURE ILLUSTRATION PROGRAM ORTEP                   0002.000
C        GX PACKAGE  APRIL 1985   PAUL R. MALLINSON                     0003.000
C                                                                       0004.000
         PROGRAM ORTEPPRM                                               0005.000
         LOGICAL STEREO,FIRST,STICK,MENU,LEFTI,ENGLSH,NEWSC,RHORG       0006.000
      LOGICAL LHORG                                                     0007.000
         CHARACTER COMPID(72),LINE(148)                                 0008.000
         CHARACTER*8 CHEM(200),FTYPE(13),TYPE(2),PREVIN                 0009.000
         CHARACTER*72 CBUF                                              0010.000
         INTEGER CN(200),CONTNT(13),ANR,FIRSTCH(20),FWIDTH(20)          0011.000
      DIMENSION      AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)    0012.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),  CONT(5),D(3,130)       0013.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 0014.000
      DIMENSION                      PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) 0015.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   0016.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   0017.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     0018.000
      COMMON NG,  AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,     CONT,D   0019.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,      NCD 0020.000
      COMMON NJ,NJ2,NOUT,NSR,     ORGN,     PAC,PAT,Q,REFV,RES,RMS,SCAL10021.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   0022.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                0023.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                0024.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 0025.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   0026.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    0027.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      0028.000
         COMMON/CONTRL/MENU                                             0029.000
         EQUIVALENCE (CBUF,LINE(2))                                     0030.000
         DATA LINE,   PREVIN/149*' '/,STEREO/.FALSE./,FIRST/.TRUE./     0031.000
         DATA LEFTI/.FALSE./,ENGLSH/.TRUE./,NEWSC/.FALSE./              0032.000
         DATA RHORG/.FALSE./,LHORG/.FALSE./                             0033.000
 2    LTNO=0                                                            0034.000
         MENU=.TRUE.                                                    0035.000
      CALL PRIME                                                        0036.000
      CALL PRELIM                                                       0037.000
      WRITE (NOUT,6)(TITLE(I),I=1,18)                                   0038.000
    5 FORMAT(1H010X,18A4)                                               0039.000
    6 FORMAT(1H110X,18A4)                                               0040.000
      ISAVE=0                                                           0041.000
      GO TO 507                                                         0042.000
    7 ISAVE=0                                                           0043.000
C     ***** ZERO AIN ARRAY *****                                        0044.000
    8 DO 10 J=1,140                                                     0045.000
   10 AIN(J)=0.                                                         0046.000
   11 FORMAT(1H04X,17H((((( INSTRUCTIONI5,6H ))))))                     0047.000
   12 FORMAT(I3,I6,7F9.0)                                               0048.000
   13 FORMAT(I3,I6,7E15.8)                                              0049.000
   14 FORMAT(1H 9X,7E15.7)                                              0050.000
C     ***** READ NEW INSTRUCTION CARD *****                             0051.000
      N1=-6                                                             0052.000
   16 N1=N1+7                                                           0053.000
      N2=N1+6                                                           0054.000
      IF(ISAVE)22,18,18                                                 0055.000
 18      IF (PREVIN.NE.'BON') GO TO 4021                                0056.000
         NF=813                                                         0057.000
         IF (STICK) NF=812                                              0058.000
         IC=2                                                           0059.000
         GO TO 4002                                                     0060.000
 4021 IF (PREVIN.NE.'MOL') GO TO 4031                                   0061.000
      IC=0                                                              0062.000
      NF=406                                                            0063.000
      AIN(1)=1.                                                         0064.000
      AIN(2)=NATOM                                                      0065.000
      AIN(3)=1.                                                         0066.000
      AIN(4)=NATOM                                                      0067.000
      AIN(5)=2.0                                                        0068.000
         IF (NFIELDS.GT.1) CALL FFORMT(LINE,FIRSTCH(2),FWIDTH(2),AIN(5))0069.000
      AIN(8)=1.                                                         0070.000
         IF (NFIELDS.GT.2) AIN(8)=0.                                    0071.000
      TYPE(1)='406'                                                     0072.000
      GO TO 4002                                                        0073.000
 4031    IF (.NOT.(PREVIN.EQ.'503'.AND.LHORG)) GO TO 4032               0074.000
         IC=0                                                           0075.000
         NF=202                                                         0076.000
         AIN(1)=-OFFSET                                                 0077.000
      LHORG=.FALSE.                                                     0078.000
         GO TO 4002                                                     0079.000
 4032    IF (.NOT.(PREVIN.EQ.'1103'.AND.STEREO)) GO TO 4033             0080.000
         IC=0                                                           0081.000
         NF=202                                                         0082.000
         IF (RHORG) AIN(1)=OFFSET                                       0083.000
         RHORG=.FALSE.                                                  0084.000
         TYPE(1)='202'                                                  0085.000
         GO TO 4002                                                     0086.000
 4033    IF (.NOT.(PREVIN.EQ.'202'.AND.STEREO)) GO TO 4034              0087.000
         IC=0                                                           0088.000
         NF=503                                                         0089.000
         AIN(1)=2.                                                      0090.000
         AIN(2)=-3.                                                     0091.000
         TYPE(1)='503'                                                  0092.000
         GO TO 4002                                                     0093.000
 4034    IF (.NOT.(PREVIN.EQ.'503'.AND.STEREO)) GO TO 4038              0094.000
         IC=0                                                           0095.000
         NF=1103                                                        0096.000
         TYPE(1)='1103'                                                 0097.000
         IF (.NOT.LEFTI) STEREO=.FALSE.                                 0098.000
         LEFTI=.FALSE.                                                  0099.000
         GO TO 4002                                                     0100.000
 4038    IF  (PREVIN.NE.' ') GO TO 4036                                 0101.000
         IC=0                                                           0102.000
         NF=203                                                         0103.000
         TYPE(1)='203'                                                  0104.000
         GO TO 4002                                                     0105.000
 4036    IF (PREVIN.NE.'203') GO TO 4040                                0106.000
         IC=0                                                           0107.000
         NF=301                                                         0108.000
         IF (.NOT.FIRST) NEWSC=.TRUE.                                   0109.000
         FIRST=.FALSE.                                                  0110.000
         AIN(1)=7.0                                                     0111.000
         AIN(2)=7.0                                                     0112.000
         AIN(3)=VIEW                                                    0113.000
         AIN(4)=0.7                                                     0114.000
         TYPE(1)='301'                                                  0115.000
         GO TO 4002                                                     0116.000
 4040    IF (.NOT.NEWSC) GO TO 4062                                     0117.000
         IC=0                                                           0118.000
         NF=604                                                         0119.000
         TYPE(1)='604'                                                  0120.000
         NEWSC=.FALSE.                                                  0121.000
         GO TO 4002                                                     0122.000
 4062    IF (.NOT.(((PREVIN.EQ.'ATO').OR.(PREVIN.EQ.'CEL').OR.          0123.000
     1   (PREVIN.EQ.'LAB')).AND.N1.GT.1)) GO TO 4090                    0124.000
         IC=0                                                           0125.000
         GO TO 4002                                                     0126.000
 4090    IF (PREVIN.NE.'201'.OR.NJ2.NE.0) GO TO 4012                    0127.000
         IC=0                                                           0128.000
         NF=301                                                         0129.000
         AIN(1)=10.0                                                    0130.000
         AIN(2)=10.0                                                    0131.000
         AIN(3)=VIEW                                                    0132.000
         AIN(4)=1.0                                                     0133.000
         TYPE(1)='301'                                                  0134.000
         NEWSC=.TRUE.                                                   0135.000
         GO TO 4002                                                     0136.000
C        RESET VDU TO NORMAL MODE                                       0137.000
 4012    NJ2=4                                                          0138.000
         CALL F200                                                      0139.000
 6010    READ (IN,4000,END=3000) (LINE(I),I=2,73)                       0140.000
 4000    FORMAT (72A1)                                                  0141.000
         CALL PARSE(LINE,NFIELDS,FIRSTCH,FWIDTH)                        0142.000
         IF (NFIELDS.EQ.0) GO TO 6010                                   0143.000
         FWIDTH(1)=3                                                    0144.000
         CALL AFORMT(LINE,FIRSTCH(1),FWIDTH(1),TYPE(1))                 0145.000
         IF (TYPE(1).NE.'BON') GO TO 4020                               0146.000
         IC=2                                                           0147.000
         NF=511                                                         0148.000
         STICK=.FALSE.                                                  0149.000
         IF (NFIELDS.EQ.1) GO TO 4002                                   0150.000
         STICK=.TRUE.                                                   0151.000
         CALL IFORMT(LINE,FIRSTCH(2),FWIDTH(2),NBOND)                   0152.000
         RADIUS=0.03                                                    0153.000
         IF (NFIELDS.GT.2) CALL FFORMT(LINE,FIRSTCH(3),FWIDTH(3),       0154.000
     1   RADIUS)                                                        0155.000
         IF (NFIELDS.GT.3)CALL FFORMT(LINE,FIRSTCH(4),FWIDTH(4),AIN(1)) 0156.000
         GO TO 4002                                                     0157.000
 4020 IF (TYPE(1).NE.'MOL') GO TO 4030                                  0158.000
      IC=0                                                              0159.000
      NF=401                                                            0160.000
      AIN(1)=155501.                                                    0161.000
      GO TO 4002                                                        0162.000
 4030    IF (TYPE(1).NE.'STE') GO TO 4035                               0163.000
         IC=0                                                           0164.000
         NF=503                                                         0165.000
         AIN(1)=2.                                                      0166.000
         AIN(2)=3.                                                      0167.000
         IF (NFIELDS.EQ.1) GO TO 5090                                   0168.000
                          CALL FFORMT(LINE,FIRSTCH(2),FWIDTH(2),OFFSET) 0169.000
         RHORG=.TRUE.                                                   0170.000
C ********** REMOVE THE NEXT TWO STATEMENTS IF YOU ARE USING STANDARD   0171.000
C            CALCOMP ROUTINES (TO ENABLE CORRECT POSITIONING OF         0172.000
C            SIDE-BY-SIDE STEREO PAIRS).                                0173.000
         OFFSET=0.5*OFFSET                                              0174.000
         LHORG=.TRUE.                                                   0175.000
C ********* END OF REMOVABLE SECTION                                    0176.000
 5090    LEFTI=.TRUE.                                                   0177.000
         STEREO=.TRUE.                                                  0178.000
         TYPE(1)='503'                                                  0179.000
         GO TO 4002                                                     0180.000
 4035    IF (TYPE(1).NE.'END') GO TO 4039                               0181.000
         IC=0                                                           0182.000
         NF=1102                                                        0183.000
         GO TO 4002                                                     0184.000
 4039    IF (TYPE(1).NE.'BES') GO TO 4041                               0185.000
         IC=0                                                           0186.000
         NF=1203                                                        0187.000
         NEWSC=.TRUE.                                                   0188.000
         GO TO 4002                                                     0189.000
 4041    IF (TYPE(1).NE.'PLO') GO TO 4042                               0190.000
         IC=0                                                           0191.000
         NF=201                                                         0192.000
         TYPE(1)='201'                                                  0193.000
         GO TO 4002                                                     0194.000
 4042    IF (TYPE(1).NE.'VDU') GO TO 4043                               0195.000
         IC=0                                                           0196.000
         NF=203                                                         0197.000
         TYPE(1)='203'                                                  0198.000
         GO TO 4002                                                     0199.000
 4043    IF (TYPE(1).NE.'ATO') GO TO 4044                               0200.000
         IC=0                                                           0201.000
         NF=714                                                         0202.000
         IF (NFIELDS.EQ.1) GO TO 4002                                   0203.000
         CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TYPE(2))                 0204.000
         IF (TYPE(2).EQ.'PLAIN') GO TO 4045                             0205.000
         IF (TYPE(2).NE.'SHADED') GO TO 4046                            0206.000
         NF=711                                                         0207.000
         GO TO 4045                                                     0208.000
 4046    IF (TYPE(2).NE.'UNSHADED') GO TO 4047                          0209.000
         NF=712                                                         0210.000
         GO TO 4045                                                     0211.000
 4047    WRITE (6,4048) TYPE(2)                                         0212.000
 4048    FORMAT(' UNRECOGNISED ELLIPSOID STYLE ',A8)                    0213.000
         GO TO 8                                                        0214.000
 4045    IF (NFIELDS.LT.3) GO TO 4002                                   0215.000
         CALL AFORMT(LINE,FIRSTCH(3),FWIDTH(3),TYPE(2))                 0216.000
 6004    IC=1                                                           0217.000
         K=10                                                           0218.000
 4064    ANR=1                                                          0219.000
         DO 4049 I=1,NATOM                                              0220.000
         J=NFTYPE(I)                                                    0221.000
         GO TO (4050,4051),ANR                                          0222.000
 4050    IF (FTYPE(J).NE.TYPE(2)) GO TO 4049                            0223.000
         AIN(K)=I                                                       0224.000
         ANR=2                                                          0225.000
         GO TO 4049                                                     0226.000
 4051    IF (FTYPE(J).EQ.TYPE(2)) GO TO 4049                            0227.000
         AIN(K+1)=I-1                                                   0228.000
         GO TO 4002                                                     0229.000
 4049    CONTINUE                                                       0230.000
         IF (ANR.EQ.2) GO TO 4061                                       0231.000
         WRITE (6,4011) TYPE(2)                                         0232.000
         GO TO 8                                                        0233.000
 4061    AIN(K+1)=NATOM                                                 0234.000
         GO TO 4002                                                     0235.000
 4044    IF (TYPE(1).NE.'SAV') GO TO 4053                               0236.000
         IC=0                                                           0237.000
         NF=1101                                                        0238.000
         GO TO 4002                                                     0239.000
 4053    IF (TYPE(1).NE.'EXE') GO TO 4054                               0240.000
C        CLEAR NON-GRAPHICS FROM SCREEN                                 0241.000
         IF (LTNO.EQ.1) THEN                                            0242.000
         NJ2=5                                                          0243.000
         CALL F200                                                      0244.000
         ENDIF                                                          0245.000
         IC=0                                                           0246.000
         NF=1103                                                        0247.000
         GO TO 4002                                                     0248.000
 4054    IF (TYPE(1).NE.'ROT') GO TO 4063                               0249.000
         IF (NFIELDS.EQ.1) GO TO 8                                      0250.000
         IC=0                                                           0251.000
         NF=502                                                         0252.000
         NEWSC=.TRUE.                                                   0253.000
         CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TYPE(2))                 0254.000
         IF (TYPE(2).NE.'X') GO TO 4055                                 0255.000
         AIN(1)=1.                                                      0256.000
         GO TO 4057                                                     0257.000
 4055    IF (TYPE(2).NE.'Y') GO TO 4056                                 0258.000
         AIN(1)=2.                                                      0259.000
         GO TO 4057                                                     0260.000
 4056    IF (TYPE(2).NE.'Z') GO TO 4058                                 0261.000
         AIN(1)=3.                                                      0262.000
         GO TO 4057                                                     0263.000
 4058    IF (TYPE(2).NE.'D') GO TO 4059                                 0264.000
         AIN(1)=-1.                                                     0265.000
         GO TO 4002                                                     0266.000
 4059    WRITE (6,4060) TYPE(2)                                         0267.000
 4060    FORMAT (' UNRECOGNISED ROTATION AXIS ',A8)                     0268.000
         GO TO 8                                                        0269.000
 4057    IF (NFIELDS.GT.2)CALL FFORMT(LINE,FIRSTCH(3),FWIDTH(3),AIN(2)) 0270.000
         GO TO 4002                                                     0271.000
 4063    IF (TYPE(1).NE.'SIZ') GO TO 4065                               0272.000
         IC=0                                                           0273.000
         NF=1202                                                        0274.000
         IF (NFIELDS.EQ.1) GO TO 5092                                   0275.000
         CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TYPE(2))                 0276.000
         IF (NFIELDS.GT.2)CALL FFORMT(LINE,FIRSTCH(3),FWIDTH(3),AIN(3)) 0277.000
         IF (TYPE(2).EQ.'ALL') GO TO 5092                               0278.000
         K=1                                                            0279.000
         GO TO 4064                                                     0280.000
 5092    AIN(1)=1.                                                      0281.000
         AIN(2)=NATOM                                                   0282.000
         GO TO 4002                                                     0283.000
 4065    IF (TYPE(1).NE.'MEN') GO TO 4070                               0284.000
         MENU=.NOT.MENU                                                 0285.000
         GO TO 8                                                        0286.000
 4070    IF (TYPE(1).NE.'NEW') GO TO 4071                               0287.000
         IF (NFIELDS.LT.2) GO TO 4072                                   0288.000
         CALL FFORMT(LINE,FIRSTCH(2),FWIDTH(2),VIEW)                    0289.000
         WRITE (NOUT,399) VIEW                                          0290.000
         IF (NFIELDS.GT.2)CALL FFORMT(LINE,FIRSTCH(3),FWIDTH(3),AIN(1)) 0291.000
 4072    IC=0                                                           0292.000
         NF=202                                                         0293.000
         GO TO 4002                                                     0294.000
 4071    IF (TYPE(1).NE.'SCA') GO TO 4082                               0295.000
      IF (NFIELDS.GT.1) GO TO 5099                                      0296.000
      NEWSC=.TRUE.                                                      0297.000
      GO TO 8                                                           0298.000
 5099    IC=0                                                           0299.000
         NF=603                                                         0300.000
         CALL FFORMT(LINE,FIRSTCH(2),FWIDTH(2),AIN(3))                  0301.000
         IF (NFIELDS.GT.2)CALL FFORMT(LINE,FIRSTCH(3),FWIDTH(3),AIN(4)) 0302.000
         GO TO 4002                                                     0303.000
 4082    IF (TYPE(1).NE.'NUM') GO TO 5093                               0304.000
         ENGLSH=.NOT.ENGLSH                                             0305.000
         GO TO 8                                                        0306.000
 5093    IF (TYPE(1).NE.'MOD') GO TO 5094                               0307.000
         IC=0                                                           0308.000
         NF=401                                                         0309.000
         AIN(1)=155501.                                                 0310.000
         AIN(2)=-(NATOM*1.E5+55501.)                                    0311.000
         GO TO 4002                                                     0312.000
 5094    IF (TYPE(1).NE.'DEL') GO TO 6000                               0313.000
         IC=0                                                           0314.000
         IF (NFIELDS.GT.1) GO TO 5095                                   0315.000
         NF=410                                                         0316.000
         GO TO 4002                                                     0317.000
 5095    NF=411                                                         0318.000
         L=0                                                            0319.000
         DO 5096 I=2,NFIELDS                                            0320.000
         CALL AFORMT(LINE,FIRSTCH(I),FWIDTH(I),TYPE(2))                 0321.000
         DO 5097 J=1,LATM                                               0322.000
         K=ATOMS(1,J)/1E5                                               0323.000
         IF (TYPE(2).NE.CHEM(K).AND.TYPE(2).NE.FTYPE(NFTYPE(K)))        0324.000
     1   GO TO 5097                                                     0325.000
         L=L+1                                                          0326.000
         IF (L.GT.140) GO TO 4002                                       0327.000
         AIN(L)  =ATOMS(1,J)                                            0328.000
 5097    CONTINUE                                                       0329.000
 5096    CONTINUE                                                       0330.000
      GO TO 4002                                                        0331.000
 6000    IF (TYPE(1).NE.'OUT') GO TO 6001                               0332.000
         IC=0                                                           0333.000
         NF=1002                                                        0334.000
         GO TO 4002                                                     0335.000
 6001    IF (TYPE(1).NE.'LAB') GO TO 6002                               0336.000
         AIN(5)=0.2                                                     0337.000
         IF (NFIELDS.GT.2)CALL FFORMT(LINE,FIRSTCH(3),FWIDTH(3),AIN(6)) 0338.000
         IF (NFIELDS.GT.3)CALL FFORMT(LINE,FIRSTCH(4),FWIDTH(4),AIN(7)) 0339.000
         IC=0                                                           0340.000
         IF (NFIELDS.EQ.1) GO TO 6005                                   0341.000
         CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TYPE(2))                 0342.000
         IF (TYPE(2).EQ.'AXES') GO TO 6005                              0343.000
         NF=715                                                         0344.000
         IF (TYPE(2).EQ.'ALL') GO TO 4002                               0345.000
         GO TO 6004                                                     0346.000
 6005    NF=1003                                                        0347.000
         GO TO 4002                                                     0348.000
 6002    IF (TYPE(1).NE.'CEL') GO TO 6003                               0349.000
         IC=1                                                           0350.000
         DO 550 I=5,7                                                   0351.000
 550      AIN(I)=0.5                                                    0352.000
         AIN(9)=2.                                                      0353.000
         IF (NFIELDS.GT.1)CALL FFORMT(LINE,FIRSTCH(2),FWIDTH(2),AIN(9)) 0354.000
         IF (NFIELDS.GT.2)CALL FFORMT(LINE,FIRSTCH(3),FWIDTH(3),AIN(5)) 0355.000
         IF (NFIELDS.GT.3)CALL FFORMT(LINE,FIRSTCH(4),FWIDTH(4),AIN(6)) 0356.000
         IF (NFIELDS.GT.4)CALL FFORMT(LINE,FIRSTCH(5),FWIDTH(5),AIN(7)) 0357.000
         NF=1004                                                        0358.000
         GO TO 4002                                                     0359.000
 6003    IF (TYPE(1).NE.'PEN') GO TO 4080                               0360.000
         IC=0                                                           0361.000
         AIN(1)=1.                                                      0362.000
         IF (NFIELDS.GT.1) CALL FFORMT(LINE,FIRSTCH(2),FWIDTH(2),AIN(1))0363.000
         NF=1001                                                        0364.000
         GO TO 4002                                                     0365.000
 4080    IF (TYPE(1).EQ.'EXI') GO TO 3000                               0366.000
         IF (.NOT.ENGLSH) GO TO 4001                                    0367.000
         WRITE (6,4081)                                                 0368.000
 4081    FORMAT (' THAT WAS NOT A COMMAND')                             0369.000
         GO TO 8                                                        0370.000
 4001 READ (CBUF,12)       IC,NF,(AIN(I),I=N1,N2)                       0371.000
 4002 IF(ISAVE)24,24,20                                                 0372.000
   20 WRITE (NSR)IC,NF,(AIN(I),I=N1,N2)                                 0373.000
      GO TO 24                                                          0374.000
   22 READ (NSR)IC,NF,(AIN(I),I=N1,N2)                                  0375.000
      IF(IC)7,24,24                                                     0376.000
   24 IF(N1-1)26,26,30                                                  0377.000
   26 WRITE (NOUT,11)NF                                                 0378.000
      NF1=NF                                                            0379.000
      IF(NF1)28,8,30                                                    0380.000
   28 IF(NF1+2)2,2,3000                                                 0381.000
   30 WRITE (NOUT,14)(AIN(I),I=N1,N2)                                   0382.000
         IF (PREVIN.NE.'BON') GO TO 4013                                0383.000
         PREVIN='812'                                                   0384.000
         IF (ISAVE.LE.0) GO TO 90                                       0385.000
         DO 4014 J=1,NCD                                                0386.000
         IF (J.EQ.NCD) IC=0                                             0387.000
 4014    WRITE (NSR) IC,(KD(I,J),I=1,5),(CD(I,J),I=1,8)                 0388.000
         GO TO 90                                                       0389.000
 4013    PREVIN=TYPE(1)                                                 0390.000
         NCD=0                                                          0391.000
   32 IC=IC+1                                                           0392.000
      GO TO (90,16,38,50),IC                                            0393.000
   33 FORMAT(I3,6X,5I3,8F6.0)                                           0394.000
   34 FORMAT(6I3,8E12.5)                                                0395.000
   35 FORMAT(1H 11X,5I3,8F11.5)                                         0396.000
C     ***** READ FORMAT 2 TRAILER CARDS *****                           0397.000
   38 NCD=NCD+1                                                         0398.000
      IF(ISAVE)44,40,40                                                 0399.000
 40      READ (IN,4000,END=3000) (LINE(I),I=2,73)                       0400.000
         IF (PREVIN.NE.'BON') GO TO 4003                                0401.000
         CALL PARSE(LINE,NFIELDS,FIRSTCH,FWIDTH)                        0402.000
         DO 4010 I=1,8                                                  0403.000
 4010    CD(I,NCD)=0.                                                   0404.000
         IF (NFIELDS.GE.2) GO TO 4005                                   0405.000
         IF (NFIELDS.EQ.0) GO TO 9867                                   0406.000
         WRITE (6,9866)                                                 0407.000
 9866    FORMAT (' THAT WAS NOT A BOND TYPE - PLEASE GIVE 2 ELEMENTS OR 0408.000
     1BLANK LINE TERMINATOR')                                           0409.000
         IC=2                                                           0410.000
         NCD=NCD-1                                                      0411.000
         GO TO 32                                                       0412.000
 9867    IC=0                                                           0413.000
         DO 4015 I=1,5                                                  0414.000
 4015    KD(I,NCD)=0                                                    0415.000
         GO TO 4004                                                     0416.000
 4005    K=0                                                            0417.000
         IC=2                                                           0418.000
         DO 4006 I=1,2                                                  0419.000
         CALL AFORMT(LINE,FIRSTCH(I),FWIDTH(I),TYPE(I))                 0420.000
         ANR=1                                                          0421.000
         DO 4009 J=1,NATOM                                              0422.000
         L=NFTYPE(J)                                                    0423.000
         GO TO (4007,4008),ANR                                          0424.000
 4007    IF (FTYPE(L).NE.TYPE(I)) GO TO 4009                            0425.000
         K=K+1                                                          0426.000
         KD(K,NCD)=J                                                    0427.000
         CD(2,NCD)=CD(2,NCD)+SFAC(13,L)                                 0428.000
         ANR=2                                                          0429.000
         GO TO 4009                                                     0430.000
 4008    IF (FTYPE(L).EQ.TYPE(I)) GO TO 4009                            0431.000
         K=K+1                                                          0432.000
         KD(K,NCD)=J-1                                                  0433.000
         GO TO 4006                                                     0434.000
 4009    CONTINUE                                                       0435.000
         IF (ANR.EQ.2) GO TO 4016                                       0436.000
         WRITE (6,4011) TYPE(I)                                         0437.000
 4011    FORMAT (' THERE ARE NO ',A8,'ATOMS')                           0438.000
         NCD=NCD-1                                                      0439.000
         GO TO 32                                                       0440.000
 4016    K=K+1                                                          0441.000
         KD(K,NCD)=NATOM                                                0442.000
 4006    CONTINUE                                                       0443.000
         KD(5,NCD)=NBOND                                                0444.000
         CD(3,NCD)=RADIUS                                               0445.000
         IF (NFIELDS.GT.2) CALL IFORMT(LINE,FIRSTCH(3),FWIDTH(3),       0446.000
     1   KD(5,NCD))                                                     0447.000
         IF (NFIELDS.GT.3) CALL FFORMT(LINE,FIRSTCH(4),FWIDTH(4),       0448.000
     1   CD(3,NCD))                                                     0449.000
         GO TO 4004                                                     0450.000
 4003 READ (CBUF,33)       IC,(KD(I,NCD),I=1,5),(CD(I,NCD),I=1,8)       0451.000
 4004 IF(ISAVE)46,46,42                                                 0452.000
   42 WRITE (NSR)IC,(KD(I,NCD),I=1,5),(CD(I,NCD),I=1,8)                 0453.000
      GO TO 46                                                          0454.000
   44 READ (NSR)IC,(KD(I,NCD),I=1,5),(CD(I,NCD),I=1,8)                  0455.000
   46 WRITE (NOUT,35)(KD(I,NCD),I=1,5),(CD(I,NCD),I=1,8)                0456.000
      GO TO 32                                                          0457.000
C     ***** READ FORMAT 3 TRAILER CARD *****                            0458.000
   50 IF(ISAVE)52,54,54                                                 0459.000
   52 READ (NSR)(TITLE2(I),I=1,18)                                      0460.000
      GO TO 55                                                          0461.000
   54 READ (IN ,4)(TITLE2(I),I=1,18)                                    0462.000
 4       FORMAT (20A4)                                                  0463.000
   55 WRITE (NOUT,5)(TITLE2(I),I=1,18)                                  0464.000
      IF(ISAVE)90,90,56                                                 0465.000
   56 WRITE (NSR)(TITLE2(I),I=1,18)                                     0466.000
C     ***** EXECUTE INSTRUCTION UNLESS WRITING SAVED SEQUENCE           0467.000
 90      IF (ISAVE.GT.0.AND.NF1.NE.1101.AND.NF1.NE.1102) GO TO 8        0468.000
      NJ=NF1/100                                                        0469.000
      NJ2=NF1-NJ*100                                                    0470.000
      NJ3=MOD(NJ2,10)                                                   0471.000
      IF(NJ-12)98,92,92                                                 0472.000
   92 CALL SPARE(NF1)                                                   0473.000
      IF(NG)94,8,94                                                     0474.000
   94 CALL ERPNT(0.,NF1)                                                0475.000
      GO TO 8                                                           0476.000
C     ******BRANCH TABLE FOR FUNCTION TYPES******                       0477.000
   98 GO TO(100,200,300,400,500,600,700,800,900,1000,1100),NJ           0478.000
C     *******STRUCTURE ANALYSIS FUNCTIONS*******                        0479.000
  100 GO TO (101,101,104,104,101,101,94),NJ2                            0480.000
  101 CALL SEARC                                                        0481.000
      GO TO 8                                                           0482.000
C     ***** ANISOTROPIC TEMP FACTOR OUTPUT *****                        0483.000
  104 DO 164 I=1,NATOM                                                  0484.000
      IF(MOD(I,14)-1)134,114,134                                        0485.000
  114 WRITE (NOUT,6)(TITLE(J),J=1,18)                                   0486.000
      WRITE (NOUT,129)                                                  0487.000
  129 FORMAT(1H010X,4HATOM3X,16HRMS DISPLACEMENT3X,31HROW VECTORS, BASED0488.000
     1 ON REFERENCE17X,29HPROBABILITY COVARIANCE MATRIX)                0489.000
  134 T1=55501.+FLOAT(I)*100000.                                        0490.000
      CALL PAXES(T1,-3)                                                 0491.000
      IF(NG)144,154,144                                                 0492.000
  144 CALL ERPNT(T1,104)                                                0493.000
  149 FORMAT(1H010X,A6,F10.6,6X,3F12.7,10X,3F12.7)                      0494.000
  154 WRITE (NOUT,149)CHEM(I),RMS(1),(PAC(J,1),J=1,3),(Q(J,1)           0495.000
     1,J=1,3)                                                           0496.000
  164 WRITE (NOUT,159)(RMS(K),(PAC(J,K),J=1,3),(Q(J,K),J=1,3)           0497.000
     1,K=2,3)                                                           0498.000
  159 FORMAT(1H 16X,F10.6,6X,3F12.7,10X,3F12.7)                         0499.000
      GO TO 8                                                           0500.000
C     *******PLOTTER INITIALIZE,FRAME ADVANCE,TERMINATE FUNCTIONS*******0501.000
  200 CALL F200                                                         0502.000
      GO TO 8                                                           0503.000
  300 GO TO (301,302,303,94),NJ2                                        0504.000
C     *******PLOT DIMENSIONS*******                                     0505.000
  301 IF(AIN(1))321,321,311                                             0506.000
  311 XLNG(1)=AIN(1)                                                    0507.000
  321 IF(AIN(2))341,341,331                                             0508.000
  331 XLNG(2)=AIN(2)                                                    0509.000
  341 IF(AIN(3))361,351,351                                             0510.000
  351 VIEW=AIN(3)                                                       0511.000
  361 IF(AIN(4))381,381,371                                             0512.000
  371 BRDR=AIN(4)                                                       0513.000
  381 WRITE (NOUT,389)XLNG(1),XLNG(2),BRDR                              0514.000
  389 FORMAT(1H010X,11HPLOT LIMITSF6.2,3H BYF6.2,15H IN.  INCLUDINGF6.2,0515.000
     112H  IN. MARGIN)                                                  0516.000
  391 WRITE (NOUT,399)VIEW                                              0517.000
  399 FORMAT(1H 10X,13HVIEW DISTANCEF7.3,7H INCHES)                     0518.000
      GO TO 8                                                           0519.000
C     *******LEGEND ROTATION*******                                     0520.000
  302 THETA=AIN(1)                                                      0521.000
      T1=THETA*.01745329252                                             0522.000
      COSTH=COS(T1)                                                     0523.000
      SINTH=SIN(T1)                                                     0524.000
      DO 312 J=1,9                                                      0525.000
  312 SYMB(J,1)=0.                                                      0526.000
      SYMB(1,1)=COSTH                                                   0527.000
      SYMB(2,2)=COSTH                                                   0528.000
      SYMB(3,3)=1.                                                      0529.000
      SYMB(2,1)=SINTH                                                   0530.000
      SYMB(1,2)=-SINTH                                                  0531.000
      WRITE (NOUT,319)THETA                                             0532.000
  319 FORMAT(1H010X,44HREGULAR TITLE AND SYMBOL ROTATION IN DEGREESF8.2)0533.000
      GO TO 8                                                           0534.000
C     ***** RETRACE DISPLACEMENT *****                                  0535.000
  303 DISP=AIN(1)                                                       0536.000
      WRITE (NOUT,313)DISP                                              0537.000
  313 FORMAT(1H010X,22HRETRACE DISPLACEMENT =F7.4,5H INCH)              0538.000
      GO TO 8                                                           0539.000
C     *******ATOM LIST FUNCTIONS*******                                 0540.000
  400 GO TO (401,401,401,401,401,401,490, 94, 94,410,                   0541.000
     1       401,401,401,401,401,401, 94),NJ2                           0542.000
  401 CALL F400                                                         0543.000
      GO TO 490                                                         0544.000
  410 LATM=0                                                            0545.000
      DO 420 I=1,1000                                                   0546.000
      DO 420 J=1,4                                                      0547.000
  420 ATOMS(J,I)=0.                                                     0548.000
  490 IF(LATM)8,8,491                                                   0549.000
  491 WRITE (NOUT,499)(ATOMS(1,I),I=1,LATM)                             0550.000
  499 FORMAT(1H010X,23HCONTENTS OF ATOMS ARRAY/(15X,10F10.0))           0551.000
      GO TO 8                                                           0552.000
C     *******CARTESIAN COORDINATE SYSTEM FUNCTIONS*******               0553.000
  500 CALL F500                                                         0554.000
      WRITE  (NOUT,503)(ORGN(J),J=1,3)                                  0555.000
  503 FORMAT(1H0,10X,    44HORIGIN FOR PROJECTION AXIS IN CRYSTAL COORD.0556.000
     1,3F15.6)                                                          0557.000
      IF(NJ3-3)507,539,601                                              0558.000
  507 WRITE (NOUT,529)                                                  0559.000
      WRITE (NOUT,519)((REFV(J,I),I=1,3),(AAREV(J,I),I=1,3),J           0560.000
     1=1,3)                                                             0561.000
      GO TO 8                                                           0562.000
  509 FORMAT(1H010X, 49HORTHONORMAL WORKING VECTORS BASED ON CRYSTAL AXE0563.000
     1S18X,33HPOST-FACTOR TRANSFORMATION MATRIX/16X,8HX VECTOR8X,8HY VEC0564.000
     2TOR8X,8HZ VECTOR)                                                 0565.000
  519 FORMAT(1H 10X,3E16.7,8X,3E16.7)                                   0566.000
  529 FORMAT(1H010X,51HORTHONORMAL REFERENCE VECTORS BASED ON CRYSTAL AX0567.000
     1ES16X,33HPOST-FACTOR TRANSFORMATION MATRIX/16X,8HX VECTOR8X,8HY VE0568.000
     2CTOR8X,8HZ VECTOR)                                                0569.000
  539 WRITE (NOUT,509)                                                  0570.000
      WRITE (NOUT,519)((WRKV(J,I),I=1,3),(AAWRK(J,I),I=1,3),J           0571.000
     1=1,3)                                                             0572.000
      GO TO 8                                                           0573.000
C     *******PLOT CENTERING FUNCTIONS*******                            0574.000
  600 CALL F600                                                         0575.000
  601 WRITE (NOUT,609)XO(1),XO(2),SCAL1,SCAL2                           0576.000
  609 FORMAT(1H010X,31HORIGIN POINT IN PLOTTER COORD.(F6.2,2H ,F6.2,8H )0577.000
     1 IN.  / 11X,15HOVERALL SCALE =F6.3,32H INCH/ANGSTROM ELLIPSOID SCA0578.000
     2LE =F6.3)                                                         0579.000
      GO TO 391                                                         0580.000
C     *******ELLIPSOID AND SYMBOL PLOT FUNCTIONS*******                 0581.000
C     ********FILL OUT DETAILS FOR SPECIAL MODELS********               0582.000
  700 GO TO (701,702,704,705,709,94),NJ3                                0583.000
  701 AIN(3)=8.                                                         0584.000
      GO TO 703                                                         0585.000
  702 AIN(3)=0.                                                         0586.000
  703 AIN(1)=4.                                                         0587.000
      AIN(2)=0.                                                         0588.000
      AIN(4)=0.                                                         0589.000
      GO TO 709                                                         0590.000
  704 AIN(1)=3.                                                         0591.000
      AIN(2)=-5.                                                        0592.000
      GO TO 706                                                         0593.000
  705 AIN(1)=1.                                                         0594.000
      AIN(2)=0.                                                         0595.000
  706 AIN(3)=1.                                                         0596.000
      AIN(4)=5.                                                         0597.000
  709 CALL F700                                                         0598.000
      GO TO 8                                                           0599.000
C     *******BOND FUNCTIONS*******                                      0600.000
  800 CALL F800                                                         0601.000
      GO TO 8                                                           0602.000
C     *******TITLE FUNCTIONS*******                                     0603.000
  900 CALL F900                                                         0604.000
      GO TO 8                                                           0605.000
C     *******CELL OUTLINE FUNCTIONS*******                              0606.000
 1000 CALL F1000                                                        0607.000
      GO TO 8                                                           0608.000
C     *******SAVE SEQUENCE FUNCTIONS*******                             0609.000
 1100 IF(NJ2-2)1101,1102,1103                                           0610.000
 1101 ISAVE=1                                                           0611.000
      GO TO 1104                                                        0612.000
 1102 ISAVE=0                                                           0613.000
      J=-1                                                              0614.000
C      END FILE NSR                                                     0615.000
      GO TO 1104                                                        0616.000
 1103 ISAVE=-1                                                          0617.000
 1104 REWIND NSR                                                        0618.000
      GO TO 8                                                           0619.000
C     ***** TERMINATE PLOTTER *****                                     0620.000
 3000 GO TO(3010,3006,3005),LTNO+1                                      0621.000
 3006 CALL CRT(0.,0.,0,5)                                               0622.000
 3005 CALL PLOT(0.,0.,999)                                              0623.000
 3010 ENDFILE 1                                                         0624.000
      STOP                                                              0625.000
      END                                                               0626.000
      FUNCTION ARCCOS(X)                                                0627.000
C     ARCCOS(X) IN DEGREES                                              0628.000
      IF(1.0-ABS(X))1,2,2                                               0629.000
    1 X=SIGN(1.0,X)                                                     0630.000
    2 IF(X)3,4,5                                                        0631.000
    3 ARCCOS=180.0+ATAN(SQRT(1.0-X*X)/X)*57.29577951                    0632.000
      GO TO 6                                                           0633.000
    4 ARCCOS=90.0                                                       0634.000
      GO TO 6                                                           0635.000
    5 ARCCOS=ATAN (SQRT(1.0-X*X)/X)*57.29577951                         0636.000
    6 RETURN                                                            0637.000
      END                                                               0638.000
      SUBROUTINE ATOM(QA,Z)                                             0639.000
C     ATOM COORDINATE SUBROUTINE                                        0640.000
      DIMENSION X(3),Z(3)                                               0641.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         0642.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         0643.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 0644.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      0645.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   0646.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   0647.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     0648.000
         CHARACTER COMPID(72)                                           0649.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                0650.000
         INTEGER CN(200),CONTNT(13)                                     0651.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                0652.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 0653.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   0654.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    0655.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      0656.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          0657.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       0658.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          0659.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   0660.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                0661.000
      K=QA/100000.0                                                     0662.000
      IF(K)109,109,117                                                  0663.000
  109 X(1)=0.0                                                          0664.000
      X(2)=0.0                                                          0665.000
      X(3)=0.0                                                          0666.000
      GO TO 125                                                         0667.000
  117 IF(K-NATOM)119,119,503                                            0668.000
  503 NG=5                                                              0669.000
      GO TO 325                                                         0670.000
  119 DO 123 J=1,3                                                      0671.000
  123 X(J)=P(J,K)                                                       0672.000
  125 TA=ABS(QA)                                                        0673.000
      KSYM=AMOD(TA,100000.0)                                            0674.000
      KT=KSYM/100                                                       0675.000
      KS=KSYM-100*KT                                                    0676.000
      IF(KS-NSYM)203,203,403                                            0677.000
  403 NG=4                                                              0678.000
      GO TO 325                                                         0679.000
  203 IF(KS)403,205,213                                                 0680.000
  205 Z(1)=X(1)                                                         0681.000
      Z(2)=X(2)                                                         0682.000
      Z(3)=X(3)                                                         0683.000
      GO TO 311                                                         0684.000
  213 DO 223 K=1,3                                                      0685.000
      Z(K)=TS(K,KS)                                                     0686.000
      DO 223 J=1,3                                                      0687.000
  223 Z(K)=Z(K)+FS(J,K,KS)*X(J)                                         0688.000
  311 IF(KT)403,325,313                                                 0689.000
  313 IF(KT-555)317,315,317                                             0690.000
  315 KSYM=KS                                                           0691.000
      GO TO 325                                                         0692.000
  317 K1=KT/100                                                         0693.000
      K=KT-100*K1                                                       0694.000
      K2=K/10                                                           0695.000
      K3=K-10*K2                                                        0696.000
      Z(1)=Z(1)+FLOAT(K1-5)                                             0697.000
      Z(2)=Z(2)+FLOAT(K2-5)                                             0698.000
      Z(3)=Z(3)+FLOAT(K3-5)                                             0699.000
  325 RETURN                                                            0700.000
      END                                                               0701.000
      SUBROUTINE AXEQB(A1,X,B1,JJJ)                                     0702.000
C     ***** SOLUTION OF MATRIX EQUATION AX=B FOR X *****                0703.000
C     ***** USES METHOD OF TRIANGULAR ELIMINATION *****                 0704.000
C     ***** B AND X HAVE DIMENSIONS (3,JJJ),A IS ALWAYS (3,3)           0705.000
C     ***** TO INVERT A MAKE B 3 BY 3 IDENITY MATRIX *****              0706.000
      DIMENSION A1(3,3),A(3,3),B(3,3),B1(3,3),X(3,3)                    0707.000
      NV=JJJ                                                            0708.000
C     ***** TRANSFER DATA *****                                         0709.000
      DO 2 I=1,3                                                        0710.000
      DO 2 J=1,3                                                        0711.000
      IF(NV-J)2,1,1                                                     0712.000
    1 B(I,J)=B1(I,J)                                                    0713.000
    2 A(I,J)=A1(I,J)                                                    0714.000
C     ***** TRIANGULARIZE MATRIX A *****                                0715.000
      DO 17 I=1,2                                                       0716.000
      S=0.0                                                             0717.000
      DO 4 J=I,3                                                        0718.000
      R=ABS(A(J,I))                                                     0719.000
      IF(R-S)4,3,3                                                      0720.000
    3 S=R                                                               0721.000
      L=J                                                               0722.000
    4 CONTINUE                                                          0723.000
      IF(L-I)5,10,5                                                     0724.000
    5 DO 6 J=I,3                                                        0725.000
      S=A(I,J)                                                          0726.000
      A(I,J)=A(L,J)                                                     0727.000
    6 A(L,J)=S                                                          0728.000
      DO 8 J=1,NV                                                       0729.000
      S=B(I,J)                                                          0730.000
      B(I,J)=B(L,J)                                                     0731.000
    8 B(L,J)=S                                                          0732.000
   10 TEM=A(I,I)                                                        0733.000
      IF(TEM)11,17,11                                                   0734.000
   11 IPO=I+1                                                           0735.000
      DO 16 J=IPO,3                                                     0736.000
      IF(A(J,I))12,16,12                                                0737.000
   12 S=A(J,I)/TEM                                                      0738.000
      A(J,I)=0.0                                                        0739.000
      DO 13 K=IPO,3                                                     0740.000
   13 A(J,K)=A(J,K)-A(I,K)*S                                            0741.000
      DO 15 K=1,NV                                                      0742.000
   15 B(J,K)=B(J,K)-B(I,K)*S                                            0743.000
   16 CONTINUE                                                          0744.000
   17 CONTINUE                                                          0745.000
C     ***** MODIFY SINGULAR MATRIX *****                                0746.000
      DO 20 I=1,3                                                       0747.000
      IF(A(I,I))20,19,20                                                0748.000
   19 A(I,I)=AMAX1(1.E-25,AMAX1(A(1,1),A(2,2),A(3,3))*1.E-15)           0749.000
   20 CONTINUE                                                          0750.000
      DO 24 K=1,NV                                                      0751.000
      DO 24 I=1,3                                                       0752.000
      N=4-I                                                             0753.000
      M=N+1                                                             0754.000
      TEM=B(N,K)                                                        0755.000
      IF(3-M)23,21,21                                                   0756.000
   21 DO 22 J=M,3                                                       0757.000
   22 TEM=TEM-A(N,J)*B(J,K)                                             0758.000
   23 B(N,K)=TEM/A(N,N)                                                 0759.000
   24 X(N,K)=B(N,K)                                                     0760.000
      RETURN                                                            0761.000
      END                                                               0762.000
      SUBROUTINE AXES(U,V,X,ITYPE)                                      0763.000
C     ***** STORE THREE ORTHOGONAL VECTORS EACH 1 ANGSTROM LONG *****   0764.000
C     ***** ITYPE .GT.0 FOR CARTESIAN,.LE.0 FOR TRICLINIC *****         0765.000
C     *****IABS(ITYPE)=1 W(1)=U,W(2)=(UXV),W(3)=UX(UXV) *****           0766.000
C     *****IABS(ITYPE)=2 W(1)=U,W(2)=(UXV)XU,W(3)=(UXV) *****           0767.000
C     ***** ITYPE=0 W(1)=A,W(2)=(AXB)XA,W(3)=(AXB), ABC=CELL VECTORS ***0768.000
      DIMENSION U(3),V(3),W(3,3),X(3,3)                                 0769.000
      IT=ITYPE                                                          0770.000
      IF(IT)115,105,115                                                 0771.000
  105 U(1)=1.                                                           0772.000
      U(2)=0.                                                           0773.000
      U(3)=0.                                                           0774.000
      V(1)=0.                                                           0775.000
      V(2)=1.                                                           0776.000
      V(3)=0.                                                           0777.000
  115 DO 125 J=1,3                                                      0778.000
  125 W(J,1)=U(J)                                                       0779.000
      IF(IABS(IT)-1)145,135,145                                         0780.000
  135 CALL NORM(U,V,W(1,2),IT)                                          0781.000
      CALL NORM(U,W(1,2),W(1,3),IT)                                     0782.000
      GO TO 155                                                         0783.000
  145 CALL NORM(U,V,W(1,3),IT)                                          0784.000
      CALL NORM(W(1,3),U,W(1,2),IT)                                     0785.000
  155 DO 195 I=1,3                                                      0786.000
      IF(IT)165,165,175                                                 0787.000
  165 IC=-1                                                             0788.000
      GO TO 195                                                         0789.000
  175 IC=1                                                              0790.000
  195 CALL UNIT(W(1,I),X(1,I),IC)                                       0791.000
      RETURN                                                            0792.000
      END                                                               0793.000
      SUBROUTINE BOND(Z1,Z2,NB,NA1,NA2)                                 0794.000
      DIMENSION B(3,3),E(3,3),S(3,3),U(3,3),VUE(3)                      0795.000
      DIMENSION V7(3),W(13,2),X(3),Z(3)                                 0796.000
      DIMENSION      AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)    0797.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),     CONT(5),D(3,130)    0798.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 0799.000
      DIMENSION                      PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) 0800.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   0801.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   0802.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     0803.000
         CHARACTER COMPID(72)                                           0804.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                0805.000
         INTEGER CN(200),CONTNT(13)                                     0806.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                0807.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 0808.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   0809.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    0810.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      0811.000
      COMMON NG,  AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,     CONT,D   0812.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,      NCD 0813.000
      COMMON NJ,NJ2,NOUT,NSR,     ORGN,     PAC,PAT,Q,REFV,RES,RMS,SCAL10814.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   0815.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                0816.000
C     SUPPRESS BOUND CHECKING - THE LOGIC OF THIS ROUTINE REQUIRES      0817.000
C     ARRAY SUBSCRIPT ZERO TO BE REFERENCED.                            0818.000
C     ***** OBTAIN POSITIONAL PARAMETERS *****                          0819.000
      NG1=0                                                             0820.000
      DO 105 J=1,26                                                     0821.000
  105 W(J,1)=0.                                                         0822.000
      W(1,1)=Z1                                                         0823.000
      W(1,2)=Z2                                                         0824.000
      DO 135 I=1,2                                                      0825.000
      CALL XYZ(W(1,I),W(4,I),2)                                         0826.000
      IF(NG)125,110,125                                                 0827.000
  110 DO 115 J=1,3                                                      0828.000
  115 W(J+6,I)=XT(J)                                                    0829.000
      K=W(1,I)/100000.                                                  0830.000
      L=W(1,I)-FLOAT(K)*100000.                                         0831.000
      CALL PLTXY(W(4,I),W(2,I))                                         0832.000
      IF(EDGE-BRDR*.25)120,128,128                                      0833.000
  120 NG=10                                                             0834.000
  125 NG1=1                                                             0835.000
      WRITE (NOUT,136)CHEM(K),K,L,(W(J,I),J=2,9)                        0836.000
      CALL ERPNT(W(1,I),800)                                            0837.000
      GO TO 135                                                         0838.000
  128 IF(NJ2-10)130,135,135                                             0839.000
  130 WRITE (NOUT,136)CHEM(K),K,L,(W(J,I),J=2,9)                        0840.000
  135 CONTINUE                                                          0841.000
  136 FORMAT(1H 10X,A6,3H  (I3,1H,I5,4H)   2F8.2,5X,3F8.3,13X,3F8.4)    0842.000
      IF(NG1)999,140,999                                                0843.000
  140 CALL DIFV(W(7,1),W(7,2),V7)                                       0844.000
      DIST=SQRT(VMV(V7,AA,V7))                                          0845.000
      IF(MOD(NJ2,10)-3)143,142,142                                      0846.000
  142 HGT=0.                                                            0847.000
      CALL SIMBOL(W(2,1),W(3,1),HGT,CHEM(IFIX(W(1,1)/100000.)),  0.,-   0848.000
     11)                                                                0849.000
      CALL SIMBOL(W(2,2),W(3,2),HGT,CHEM(IFIX(W(1,2)/100000.)),  0.,-   0850.000
     12)                                                                0851.000
      GO TO 570                                                         0852.000
  143 KODE=KD(5,NB)                                                     0853.000
      IF(KODE)145,144,146                                               0854.000
  144 NBND=0                                                            0855.000
      GO TO 148                                                         0856.000
  145 KODE=-KODE                                                        0857.000
  146 NBND=128/2**KODE                                                  0858.000
C     ***** FIND UPPERMOST ATOM PUT IN POSITION ONE *****               0859.000
  148 IF(VIEW)152,150,152                                               0860.000
  150 W(12,1)=1.                                                        0861.000
      W(12,2)=1.                                                        0862.000
      IF(W(6,1)-W(6,2))165,175,175                                      0863.000
C     *****VECTOR FROM ATOM TO VIEWPOINT *****                          0864.000
  152 DO 160 I=1,2                                                      0865.000
      DO 155 J=10,12                                                    0866.000
  155 W(J,I)=-W(J-6,I)                                                  0867.000
      W(12,I)=W(12,I)+VIEW                                              0868.000
C     ***** DISTANCE SQUARED TO VIEWPOINT *****                         0869.000
  160 W(13,I)=VV(W(10,I),W(10,I))                                       0870.000
      IF(W(13,2)-W(13,1))165,175,175                                    0871.000
C     ***** SWITCH ATOMS *****                                          0872.000
  165 DO 170 J=1,13                                                     0873.000
      T1=W(J,1)                                                         0874.000
      W(J,1)=W(J,2)                                                     0875.000
  170 W(J,2)=T1                                                         0876.000
C     ***** FORM IDEMFACTOR MATRIX *****                                0877.000
  175 DO 180 J=1,3                                                      0878.000
      E(J,J)=1.                                                         0879.000
      E(J+1,1)=0.                                                       0880.000
  180 E(J+5,1)=0.                                                       0881.000
C     ***** FORM VECTOR SET RADIAL TO BOND *****                        0882.000
      CALL DIFV(W(4,2),W(4,1),DA(1,3))                                  0883.000
      CALL UNIT(DA(1,3),V3,1)                                           0884.000
C     ***** UNIT VECTOR FROM BOND MIDPOINT TO REFERENCE VIEWPOINT ***** 0885.000
      DO 183 I=1,3                                                      0886.000
      V2(I)=0.0                                                         0887.000
      DO 181 J=1,3                                                      0888.000
  181 V2(I)=V2(I)+AAREV(J,3)*WRKV(J,I)                                  0889.000
      IF(VIEW)183,183,182                                               0890.000
  182 V2(I)=V2(I)*VIEW-0.5*(W(I+3,1)+W(I+3,2))                          0891.000
  183 CONTINUE                                                          0892.000
      CALL UNIT(V2,V2,1)                                                0893.000
      T6=ABS(VV(V3,V2))                                                 0894.000
      IF(.9994-T6)185,185,187                                           0895.000
C     ***** ALTERNATE CALC IF BOND IS ALONG REFERENCE VIEW DIRECTION ***0896.000
  185 DO 186 J=1,3                                                      0897.000
  186 V2(J)=W(J+9,1)+W(J+9,2)                                           0898.000
      CALL UNIT(V2,V2,1)                                                0899.000
      T6=ABS(VV(V3,V2))                                                 0900.000
      IF(.9994-T6)390,390,187                                           0901.000
  187 CALL AXES(V3,V2,B,1)                                              0902.000
  188 T1=CD(3,NB)/SCAL2                                                 0903.000
      DO 190 J=1,3                                                      0904.000
      DA(J,1)=-B(J,2)*T1                                                0905.000
  190 DA(J,2)=-B(J,3)*T1                                                0906.000
      IF(NBND)500,500,195                                               0907.000
  195 CALL RADIAL(3)                                                    0908.000
C     ***** DERIVE QUADRICS FOR EACH ATOM *****                         0909.000
      DO 380 II=1,2                                                     0910.000
      CALL PAXES(W(1,II),2)                                             0911.000
      IF(NG)205,210,205                                                 0912.000
  205 CALL ERPNT(W(1,II),800)                                           0913.000
      GO TO 999                                                         0914.000
C     ***** DOES BOND GO TO ELLIPSOID OR TO ENVELOPE *****              0915.000
  210 T1=3-II*2                                                         0916.000
      DO 212 J=1,3                                                      0917.000
      V3(J)=V3(J)*T1                                                    0918.000
  212 VUE(J)=0.                                                         0919.000
      IF(KD(5,NB))260,260,215                                           0920.000
  215 IF(VMV(V3,Q,W(10,II)))220,260,260                                 0921.000
  220 IBND=0                                                            0922.000
      IF(VIEW)240,240,225                                               0923.000
C     ***** DERIVE TANGENT CONE DIRECTLY WITHOUT ROTATING COORDINATES **0924.000
  225 T2=-(SCAL2*RMS(1)*RMS(2)*RMS(3))**2                               0925.000
      DO 230 J=1,3                                                      0926.000
      V1(J)=-W(J+9,II)/SCAL1                                            0927.000
      VUE(J)=V1(J)/SCAL2                                                0928.000
C     ***** INVERT ELLIPSOID MATRIX *****                               0929.000
      DO 230 K=J,3                                                      0930.000
      T1=0.0                                                            0931.000
      DO 228 I=1,3                                                      0932.000
  228 T1=T1+PAC(J,I)*PAC(K,I)*RMS(I)**2                                 0933.000
      U(J,K)=T1                                                         0934.000
  230 U(K,J)=T1                                                         0935.000
C     *****  ADD POLARIZED COFACTOR MATRIX TO ELLIPSOID MATRIX *****    0936.000
      DO 235 J=1,3                                                      0937.000
      J1=MOD(J,3)+1                                                     0938.000
      VJ1=V1(J1)                                                        0939.000
      J2=MOD(J+1,3)+1                                                   0940.000
      VJ2=V1(J2)                                                        0941.000
      DO 235 K=J,3                                                      0942.000
      K1=MOD(K,3)+1                                                     0943.000
      K2=MOD(K+1,3)+1                                                   0944.000
      S(J,K)=T2*Q(J,K)+(VJ2*(U(J1,K1)*V1(K2)-U(J1,K2)*V1(K1))           0945.000
     1                + VJ1*(U(J2,K2)*V1(K1)-U(J2,K1)*V1(K2)))          0946.000
  235 S(K,J)=S(J,K)                                                     0947.000
      T5=0.0                                                            0948.000
      GO TO 300                                                         0949.000
C     ***** DERIVE TANGENT CYLINDER WITH AXIS ALONG Z *****             0950.000
  240 T1=-1.0/Q(3,3)                                                    0951.000
      DO 250 J=1,2                                                      0952.000
      DO 245 K=1,2                                                      0953.000
  245 S(K,J)=Q(K,J)+Q(K,3)*Q(J,3)*T1                                    0954.000
      S(3,J)=0.0                                                        0955.000
  250 S(J,3)=0.0                                                        0956.000
      S(3,3)=0.0                                                        0957.000
      GO TO 270                                                         0958.000
C     ***** TRANSFER ELLIPSOID *****                                    0959.000
  260 DO 265 J=1,9                                                      0960.000
  265 S(J,1)=Q(J,1)                                                     0961.000
      IBND=II                                                           0962.000
  270 T5=1.                                                             0963.000
C     ***** CHECK FOR BOND TAPER *****                                  0964.000
  300 IF(II-2)305,310,310                                               0965.000
  305 RADIUS=1.+T6*TAPER                                                0966.000
      GO TO 320                                                         0967.000
  310 RADIUS=1.-T6*TAPER                                                0968.000
  320 CALL MV(S,V3,V4)                                                  0969.000
      T2=VV(V3,V4)                                                      0970.000
C     ***** COMPUTE BOND INTERSECTION *****                             0971.000
      KL=5-II-II                                                        0972.000
      KSTP=4                                                            0973.000
      IF(NJ2-21)324,322,322                                             0974.000
  322 KSTP=32                                                           0975.000
  324 DO 335 K=1,65,KSTP                                                0976.000
      DO 325 J=1,3                                                      0977.000
      V6(J)=D(J,K)*RADIUS                                               0978.000
  325 V5(J)=V6(J)+VUE(J)                                                0979.000
      T3=VV(V5,V4)                                                      0980.000
      T4=T3*T3-T2*(VMV(V5,S,V5)-T5)                                     0981.000
      IF(T4)345,330,330                                                 0982.000
  330 T4=SQRT(T4)                                                       0983.000
      T1=(T4-T3)/T2                                                     0984.000
      T3=(-T4-T3)/T2                                                    0985.000
      L=K+KL-1                                                          0986.000
      DO 335 J=1,3                                                      0987.000
      D(J,L)=(V6(J)+T1*V3(J))*SCL                                       0988.000
  335 D(J,L+1)=(-V6(J)-T3*V3(J))*SCL                                    0989.000
      IF(IBND+21-NJ2)360,338,360                                        0990.000
  338 IF(KD(5,NB))360,360,340                                           0991.000
C     ***** FOR OVERLAP, MAKE BOND QUADRANGLE TANGENT TO ENVELOPING CONE0992.000
  340 T3=VV(VUE,V4)                                                     0993.000
      T4=T3**2-T2*(VMV(VUE,S,VUE)-T5)                                   0994.000
      IF(T4)345,350,350                                                 0995.000
  345 NG=13                                                             0996.000
      CALL ERPNT(W(1,II),800)                                           0997.000
      GO TO 999                                                         0998.000
  350 T1=(SQRT(T4)-T3)/T2                                               0999.000
      DO 355 J=1,3                                                      1000.000
      T4=(T1*V3(J)*SCL-0.5*(D(J,KL)+D(J,KL+64)))*1.001                  1001.000
      D(J,KL)=D(J,KL)+T4                                                1002.000
  355 D(J,KL+64)=D(J,KL+64)+T4                                          1003.000
  360 CALL PROJ(D(1,KL),DP(1,II),W(4,II),XO,VIEW,1,65,KSTP)             1004.000
      IF(IBND-1)370,365,370                                             1005.000
  365 CALL PROJ(D(1,KL+5),DP(1,II+68),W(4,II),XO,VIEW,1,61,KSTP)        1006.000
      GO TO 380                                                         1007.000
C     ***** RETRACE TOP HALF *****                                      1008.000
  370 DO 375 K=4,64,4                                                   1009.000
      L=K+II                                                            1010.000
      M=L+64                                                            1011.000
      N=66-L                                                            1012.000
      DP(1,M)=DP(1,N)                                                   1013.000
  375 DP(2,M)=DP(2,N)                                                   1014.000
  380 CONTINUE                                                          1015.000
C     ***** CHECK FOR OVERLAP OR HIDDEN BOND *****                      1016.000
      DO 395 K=1,65,32                                                  1017.000
      T1=0.                                                             1018.000
      T2=0.                                                             1019.000
      DO 385 J=1,2                                                      1020.000
      T1=T1+(DP(J,K)-W(J+1,1))**2                                       1021.000
  385 T2=T2+(DP(J,K+1)-W(J+1,1))**2                                     1022.000
      IF(T2-T1)390,390,395                                              1023.000
  390 NG=14                                                             1024.000
      CALL ERPNT(W(1,2),800)                                            1025.000
      GO TO 999                                                         1026.000
  395 CONTINUE                                                          1027.000
C     ***** CALL OVERLAP ROUTINE *****                                  1028.000
      ICQ=0                                                             1029.000
      CALL LAP800(NA1,NA2,ICQ)                                          1030.000
      IF(NJ2-21)400,999,999                                             1031.000
  400 IF(ICQ)390,405,405                                                1032.000
C     ***** DRAW BOND OUTLINE *****                                     1033.000
  405 CALL DRAW(DP(1,1),0.,0.,3)                                        1034.000
      DO 415 K=5,129,4                                                  1035.000
  415 CALL DRAW(DP(1,K),0.,0.,2)                                        1036.000
      DO 420 K=2,66,4                                                   1037.000
  420 CALL DRAW(DP(1,K),0.,0.,2)                                        1038.000
      CALL DRAW(DP(1,65),0.,0.,2)                                       1039.000
C     ***** DRAW BOND DETAIL *****                                      1040.000
  425 K=65                                                              1041.000
  430 K=K-NBND                                                          1042.000
      IF(K-1)500,500,435                                                1043.000
  435 CALL DRAW(DP(1,K),0.,0.,3)                                        1044.000
      CALL DRAW(DP(1,K+1),0.,0.,2)                                      1045.000
      K=K-NBND                                                          1046.000
      IF(K-1)500,500,440                                                1047.000
  440 CALL DRAW(DP(1,K+1),0.,0.,3)                                      1048.000
      CALL DRAW(DP(1,K),0.,0.,2)                                        1049.000
      GO TO 430                                                         1050.000
  500 HGT=CD(4,NB)                                                      1051.000
      OFF=CD(5,NB)                                                      1052.000
      IF(HGT)570,570,510                                                1053.000
C     ***** PERSPECTIVE BOND LABEL ROUTINE *****                        1054.000
C     ***** BASE DECISIONS ON REFERENCE SYSTEM *****                    1055.000
  510 K=0                                                               1056.000
      CALL DIFV(W(7,2),W(7,1),V7)                                       1057.000
      CALL VM(V7,AAREV,V1)                                              1058.000
      CALL AXES(V1,E(1,3),U,1)                                          1059.000
      DO 535 I=1,3                                                      1060.000
      T1=1.                                                             1061.000
      IF(I-2)515,515,520                                                1062.000
  515 IF(VV(U(1,I),SYMB(1,I)))525,530,530                               1063.000
  520 IF(MOD(K,2))530,525,530                                           1064.000
  525 T1=-1.                                                            1065.000
      K=K+1                                                             1066.000
  530 DO 535 J=1,3                                                      1067.000
      U(J,I)=U(J,I)*T1                                                  1068.000
  535 VT(J,I)=B(J,I)*T1                                                 1069.000
      DO 540 J=1,3                                                      1070.000
  540 VT(J,4)=.5*(W(J+3,1)+W(J+3,2))                                    1071.000
C     ***** CHECK FOR EXCESS FORESHORTENING *****                       1072.000
      IF(FORE-ABS(U(3,1)))545,550,550                                   1073.000
  545 CALL NORM(U(1,2),SYMB(1,3),VT(1,1),1)                             1074.000
      VT(1,3)=SYMB(1,3)                                                 1075.000
      VT(2,3)=SYMB(2,3)                                                 1076.000
      VT(3,3)=SYMB(3,3)                                                 1077.000
      HGT=CD(6,NB)                                                      1078.000
      OFF=CD(7,NB)                                                      1079.000
      IF(HGT)550,999,550                                                1080.000
  550 T1=CD(8,NB)                                                       1081.000
      Z(1)=VT(1,4)-HGT*(11.+3.*T1)/7.                                   1082.000
      Z(2)=VT(2,4)+OFF-HGT*.5                                           1083.000
      Z(3)=VT(3,4)                                                      1084.000
      XO(3)=Z(3)                                                        1085.000
      ITILT=1                                                           1086.000
      I9=T1+2.                                                          1087.000
      T9=10.**I9                                                        1088.000
      DISTR=AINT((DIST*T9)+0.5)/T9 +.0001                               1089.000
      CALL NUMBUR(Z(1),Z(2),HGT,DISTR,0.,I9)                            1090.000
  570 ITILT=0                                                           1091.000
      IF(NJ2-10)580,999,999                                             1092.000
  580 WRITE (NOUT,571)DIST                                              1093.000
  571 FORMAT(1H 59X,10HDISTANCE =F8.3/1H )                              1094.000
  999 RETURN                                                            1095.000
      END                                                               1096.000
      SUBROUTINE DIFV(X,Y,Z)                                            1097.000
C     VECTOR - VECTOR                                                   1098.000
C     Z(3)=X(3)-Y(3)                                                    1099.000
      DIMENSIONX(3),Y(3),Z(3)                                           1100.000
      DO 111 I=1,3                                                      1101.000
  111 Z(I)=X(I)-Y(I)                                                    1102.000
      RETURN                                                            1103.000
      END                                                               1104.000
      SUBROUTINE DRAW(W,DX,DY,NPEN)                                     1105.000
      DIMENSION W(3),X(3),Y(3),Z(3)                                     1106.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         1107.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         1108.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 1109.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      1110.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   1111.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   1112.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     1113.000
         CHARACTER COMPID(72)                                           1114.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                1115.000
         INTEGER CN(200),CONTNT(13)                                     1116.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                1117.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 1118.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   1119.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    1120.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      1121.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          1122.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       1123.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          1124.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   1125.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                1126.000
C     SUPPRESS UNDERFLOW CHECKING                                       1127.000
      Y(1)=W(1)+DX                                                      1128.000
      Y(2)=W(2)+DY                                                      1129.000
      IF(ITILT)115,140,115                                              1130.000
C     ***** ROTATE FOR PERSPECTIVE TITLE *****                          1131.000
  115 Y(3)=XO(3)                                                        1132.000
      DO 120 I=1,3                                                      1133.000
  120 Z(I)=Y(I)-VT(I,4)                                                 1134.000
      DO 130 I=1,3                                                      1135.000
  130 X(I)=VT(I,1)*Z(1)+VT(I,2)*Z(2)+VT(I,3)*Z(3)+VT(I,4)               1136.000
      CALL PLTXY(X,Y)                                                   1137.000
C     ***** CHECK BOUNDRY *****                                         1138.000
  140 DO 160 J=1,2                                                      1139.000
      IF(Y(J)-XLNG(J)+.1)150,150,145                                    1140.000
  145 Y(J)=XLNG(J)-.1                                                   1141.000
  150 IF(Y(J)-.1)155,160,160                                            1142.000
  155 Y(J)=.1                                                           1143.000
  160 CONTINUE                                                          1144.000
C     ***** CHECK FOR OVERLAP *****                                     1145.000
      NCQ=0                                                             1146.000
      CALL LAPDRW(Y,NPEN,NCQ)                                           1147.000
      IF(NCQ)165,165,170                                                1148.000
C     ***** CALL PLOTTING ROUTINE IF NO OVERLAPPING ELEMENTS ARE STORED 1149.000
  165 CALL SCRIBE(Y,NPEN,LTNO)                                          1150.000
  170 RETURN                                                            1151.000
      END                                                               1152.000
      SUBROUTINE EIGENV (W,VALU,VECT)              
C     ***** EIGENVALUES AND EIGENVECTORS OF 3X3 MATRIX *****            1154.000
      DIMENSION W(3,3),VALU(3),VECT(3,3),A(3,3),B(3,3),V(3),U(3)        1155.000
      COMMON NG                                                         1156.000
C     ***** STATEMENT FUNCTION *****                                    1157.000
      PHIF(Z)=((B2-Z)*Z+B1)*Z+B0                                        1158.000
C     ***** START OF PROGRAM *****                                      1159.000
      ERRND=5.E-7                                                       1160.000
      SIGMA=0.                                                          1161.000
      DO 115 J=1,3                                                      1162.000
      DO 115 I=1,3                                                      1163.000
      TEM=W(I,J)                                                        1164.000
      A(I,J)=TEM                                                        1165.000
  115 SIGMA=SIGMA+TEM*TEM                                               1166.000
C     ***** CHECK FOR NULL MATRIX *****                                 1167.000
      IF(SIGMA)230,230,120                                              1168.000
  120 SIGMA=SQRT(SIGMA)                                                 1169.000
C     ***** FORM CHARACTERISTIC EQUATION *****                          1170.000
      B2=A(1,1)+A(2,2)+A(3,3)                                           1171.000
      B1=-A(1,1)*A(2,2)-A(1,1)*A(3,3)-A(2,2)*A(3,3)+A(1,3)*A(3,1)       1172.000
     1+A(2,3)*A(3,2)+A(1,2)*A(2,1)                                      1173.000
      B0=A(1,1)*A(2,2)*A(3,3)+A(1,2)*A(2,3)*A(3,1)+A(1,3)*A(3,2)*A(2,1)-1174.000
     1A(1,3)*A(3,1)*A(2,2)-A(1,1)*A(2,3)*A(3,2)-A(1,2)*A(2,1)*A(3,3)    1175.000
C     ***** FIRST ROOT BY BISECTION *****                               1176.000
      X=0.                                                              1177.000
      Y=SIGMA                                                           1178.000
      TEM=PHIF(SIGMA)                                                   1179.000
      VNEW=0.0                                                          1180.000
      IF(B0)135,250,145                                                 1181.000
  135 IF(TEM)140,140,165                                                1182.000
  140 Y=-Y                                                              1183.000
      GO TO 165                                                         1184.000
  145 Y=0.                                                              1185.000
      X=SIGMA                                                           1186.000
      IF(TEM)165,165,150                                                1187.000
  150 X=-X                                                              1188.000
C     ***** NOW PHIF(X).LT.0.AND.PHIF(Y).GT.0. *****                    1189.000
  165 VNEW=(X+Y)*.5                                                     1190.000
      DO 225 I=1,40                                                     1191.000
  175 IF(PHIF(VNEW))180,250,185                                         1192.000
  180 X=VNEW                                                            1193.000
      GO TO 200                                                         1194.000
  185 Y=VNEW                                                            1195.000
  200 VOLD=VNEW                                                         1196.000
      VNEW=(X+Y)*.5                                                     1197.000
      TEM=ABS(VOLD-VNEW)                                                1198.000
      IF(TEM-ERRND)250,250,205                                          1199.000
  205 IF(VOLD)210,225,210                                               1200.000
  210 IF (ABS(TEM/VOLD)-ERRND)250,250,225                               1201.000
  225 CONTINUE                                                          1202.000
C     ***** DID NOT CONVERGE, SET ERROR INDICATOR *****                 1203.000
  230 NG=6                                                              1204.000
      GO TO 400                                                         1205.000
C     ***** STORE FIRST ROOT *****                                      1206.000
  250 U(3)=VNEW                                                         1207.000
C     ***** DEFLATE *****                                               1208.000
      C1=B2-VNEW                                                        1209.000
      C0=B1+C1*VNEW                                                     1210.000
C     ***** SOLVE QUADRATIC *****                                       1211.000
      TEM=C1*C1+4.*C0                                                   1212.000
      IF(TEM)255,265,260                                                1213.000
C     ***** IGNORE IMAGINARY COMPONENT OF COMPLEX ROOT *****            1214.000
  255 TEM=0.                                                            1215.000
      GO TO 265                                                         1216.000
  260 TEM=SQRT(TEM)                                                     1217.000
  265 U(1)=.5*(C1-TEM)                                                  1218.000
      U(2)=.5*(C1+TEM)                                                  1219.000
C     ***** SORT ROOTS *****                                            1220.000
      DO 275 J=1,2                                                      1221.000
      IF(U(J)-U(3))275,275,270                                          1222.000
  270 TEM=U(J)                                                          1223.000
      U(J)=U(3)                                                         1224.000
      U(3)=TEM                                                          1225.000
  275 CONTINUE                                                          1226.000
      LLL=-2                                                            1227.000
      DO 375 III=1,2                                                    1228.000
C     ***** CHECK FOR MULTIPLE ROOTS *****                              1229.000
      TEM=ERRND*100.                                                    1230.000
      NG=0                                                              1231.000
      L=1                                                               1232.000
      DO 305 I=1,2                                                      1233.000
      IF(U(I+1)-U(I)-TEM)300,300,290                                    1234.000
  290 IF(U(I))295,305,295                                               1235.000
  295 IF(ABS((U(I+1)-U(I))/U(I))-TEM)300,300,305                        1236.000
  300 L=L-1                                                             1237.000
      NG=NG-2*I                                                         1238.000
  305 CONTINUE                                                          1239.000
      IF(LLL-L)308,400,400                                              1240.000
  308 LLL=L                                                             1241.000
C     ***** EIGENVECTOR ROUTINE *****                                   1242.000
      DO 375 II=1,3                                                     1243.000
      T1=U(II)                                                          1244.000
      IF(L)315,310,322                                                  1245.000
C     ***** TWO VECTORS NULL FOR DOUBLE ROOT *****                      1246.000
  310 IF(NG+5-II)315,322,315                                            1247.000
C     ***** ALL VECTORS NULL FOR TRIPLE ROOT *****                      1248.000
  315 DO 320 J=1,3                                                      1249.000
  320 VECT(J,II)=0.0                                                    1250.000
      GO TO 375                                                         1251.000
  322 DO 325 J=1,3                                                      1252.000
  325 A(J,J)=W(J,J)-T1                                                  1253.000
      SMAX=0.0                                                          1254.000
      DO 355 I=1,3                                                      1255.000
      I1=1                                                              1256.000
      IF(I-2)335,335,340                                                1257.000
  335 I1=I+1                                                            1258.000
  340 B(I,1)=A(I,2)*A(I1,3)-A(I,3)*A(I1,2)                              1259.000
      B(I,2)=A(I,3)*A(I1,1)-A(I,1)*A(I1,3)                              1260.000
      B(I,3)=A(I,1)*A(I1,2)-A(I,2)*A(I1,1)                              1261.000
      TEM=B(I,1)**2+B(I,2)**2+B(I,3)**2                                 1262.000
      IF(TEM-SMAX)355,355,350                                           1263.000
  350 SMAX=TEM                                                          1264.000
      IMAX=I                                                            1265.000
  355 CONTINUE                                                          1266.000
      IF(SMAX)353,353,360                                               1267.000
  353 NG=7                                                              1268.000
      GO TO 375                                                         1269.000
  360 SMAX=SQRT(SMAX)                                                   1270.000
      DO 365 J=1,3                                                      1271.000
  365 V(J)=B(IMAX,J)/SMAX                                               1272.000
C     ***** REFINE EIGENVECTOR *****                                    1273.000
      CALL AXEQB(A,V,V,1)                                               1274.000
      TEM=AMAX1(ABS(V(1)),ABS(V(2)),ABS(V(3)))                          1275.000
      DO 370 J=1,3                                                      1276.000
  370 V(J)=V(J)/TEM                                                     1277.000
      CALL UNIT(V,VECT(1,II),1)                                         1278.000
C     ***** REFINE EIGENVALUE *****                                     1279.000
      T1=VMV(VECT(1,II),W,VECT(1,II))                                   1280.000
      U(II)=T1                                                          1281.000
  375 VALU(II)=T1                                                       1282.000
  400 RETURN                                                            1283.000
      END                                                               1284.000
      SUBROUTINE ERPNT(T1,N)                                            1285.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         1286.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         1287.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 1288.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      1289.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   1290.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   1291.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     1292.000
         CHARACTER COMPID(72)                                           1293.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                1294.000
         INTEGER CN(200),CONTNT(13)                                     1295.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                1296.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 1297.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   1298.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    1299.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      1300.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          1301.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       1302.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          1303.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   1304.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                1305.000
C        RESET VDU TO NORMAL MODE                                       1306.000
         NJKEEP=NJ2                                                     1307.000
         NJ2=4                                                          1308.000
         CALL F200                                                      1309.000
         NJ2=NJKEEP                                                     1310.000
         IF (NG.EQ.3) WRITE (6,100)                                     1311.000
 100     FORMAT (' NON-POSITIVE-DEFINITE ANISOTROPIC TEMP. FACTOR')     1312.000
         IF (NG.EQ.13) WRITE (6,101)                                    1313.000
 101     FORMAT (' STICK BOND IS THICKER THAN ATOM')                    1314.000
         IF (NG.EQ.16) WRITE (6,102)                                    1315.000
 102     FORMAT (' MORE THAN 1000 ATOMS IN FIGURE OR BOND OVERLAP TABLE 1316.000
     1OVERFLOW')                                                        1317.000
         IF (NG.EQ.12) WRITE (6,103)                                    1318.000
 103     FORMAT (' FIGURE SUBJECT LIST EMPTY OR INSUFFICIENT')          1319.000
         IF (NG.NE.14.AND.NG.NE.10)  WRITE (6,115)NG,T1,N               1320.000
  115 FORMAT(1H 10X,10HFAULT NG =I3,F10.0,I6/1H )                       1321.000
      NG=0                                                              1322.000
      RETURN                                                            1323.000
      END                                                               1324.000
      SUBROUTINE F200                                                   1325.000
      DIMENSION      AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)    1326.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),     CONT(5),D(3,130)    1327.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 1328.000
      DIMENSION                      PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) 1329.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   1330.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   1331.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     1332.000
         LOGICAL MENU                                                   1333.000
         CHARACTER COMPID(72)                                           1334.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                1335.000
         INTEGER CN(200),CONTNT(13)                                     1336.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                1337.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 1338.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   1339.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    1340.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      1341.000
         COMMON/CONTRL/MENU                                             1342.000
      COMMON NG,  AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,     CONT,D   1343.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,      NCD 1344.000
      COMMON NJ,NJ2,NOUT,NSR,     ORGN,     PAC,PAT,Q,REFV,RES,RMS,SCAL11345.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   1346.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                1347.000
C     ***** CALCOMP CONTROL *****                                       1348.000
      NJQ = NJ2+1                                                       1349.000
      GO TO(260,200,225,205,210,265),NJQ                                1350.000
C     ***** INITIATE MECHANICAL CALCOMP PLOTTER (201 INSTRUCTION) ***** 1351.000
 200     NJ2=1                                                          1352.000
      CALL PLOTS(NJ2)                                                   1353.000
         IF (NJ2.EQ.0)  GO TO 270                                       1354.000
         IF (LTNO.EQ.2) GO TO 260                                       1355.000
         WRITE (6,271)                                                  1356.000
 271     FORMAT (' THE PLOTTER IS BUSY - PLEASE TRY AGAIN')             1357.000
         CALL CRT(0.,0.,0,5)                                            1358.000
         GO TO 260                                                      1359.000
 270  LTNO = 2                                                          1360.000
         GO TO 260                                                      1361.000
C     ***** INITIATE C.R.T. DISPLAY (203 INSTRUCTION) *****             1362.000
 205     LTNO=1                                                         1363.000
      CALL CRT(0.,0.,0,0)                                               1364.000
         GO TO 260                                                      1365.000
C     ***** RESET BEAM INTENSITY (204 INSTRUCTION) *****                1366.000
  210 IZ = AIN(1)                                                       1367.000
      IF(IZ)215,215,220                                                 1368.000
  215 IZ = 18                                                           1369.000
  220 CALL CRT(0.,0.,IZ,7)                                              1370.000
         RETURN                                                         1371.000
C        CLEAR NON-GRAPHICS FROM SCREEN (205 INSTRUCTION)               1372.000
 265     CALL CRT(0.,0.,0,8)                                            1373.000
         RETURN                                                         1374.000
C     ***** TERMINATE THE PLOT AND ADVANCE PLOTTER (202 INSTRUCTION) ***1375.000
 225     GO TO (260,300,301),LTNO+1                                     1376.000
 300     CALL  CRT(AIN(1),AIN(2),0,6)                                   1377.000
      IF (AIN(1).NE.0.0) RETURN                                         1378.000
         GO TO 260                                                      1379.000
  301 CALL PLOT(AIN(1),AIN(2),-3)                                       1380.000
      RETURN                                                            1381.000
 260     IF (MENU) WRITE (6,1000)                                       1382.000
         IF (MENU) WRITE (6,1001)                                       1383.000
 1000 FORMAT (' MENU ON/OFF (GIVE 1ST 3 LETTERS OF COMMANDS)'/' NUMERICA1384.000
     1L COMMANDS'/' MODEL INSERT'/' MOLECULE_INSERT <DMAX>  SYMMETRIC '/1385.000
     2' CELL_CONTENTS_INSERT <DMAX> <FRACTIONAL SEMI-DIMENSIONS>'/      1386.000
     3' DELETE <ATOM LABEL(S)/ATOM TYPE(S)>'/' BEST VIEW'/              1387.000
     4' SAVE SEQUENCE'/' BONDS <SHADE> <HALF-THICKNESS> <OVERLAP GAP> <C1388.000
     5R> <ELEMENT PAIR> <CR>'/' ATOMS  PLAIN/UNSHADED/SHADED  <ELEMENT>'1389.000
     6/' END SAVED SEQUENCE'/' EXECUTE SAVED SEQUENCE'/' VDU'/' PLOTTER'1390.000
     7/' PEN <PEN NO.>' /' ROTATE <AXIS> <ANGLE>'/' OUTLINE CELL')      1391.000
 1001 FORMAT (' LABEL  AXES /<ELEMENT>/ ALL  <X OFFSET> <Y OFFSET>'     1392.000
     1/' SIZE <ELEMENT>/ ALL  <RADIUS>'/' SCALE <MODEL SCALE> <ELLIPSOID1393.000
     2 SCALE>'/' STEREO <SEPARATION (INCHES)>'/                         1394.000
     3' NEW_PLOT <VIEW DISTANCE (INCHES)> <X ORIGIN (INCHES)>'/' EXIT'/)1395.000
      RETURN                                                            1396.000
      END                                                               1397.000
      SUBROUTINE F400                                                   1398.000
C     ***** ATOM LIST FUNCTIONS *****                                   1399.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         1400.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         1401.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 1402.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      1403.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   1404.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   1405.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     1406.000
         CHARACTER COMPID(72)                                           1407.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                1408.000
         INTEGER CN(200),CONTNT(13)                                     1409.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                1410.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 1411.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   1412.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    1413.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      1414.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          1415.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       1416.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          1417.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   1418.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                1419.000
      NG=0                                                              1420.000
      IF(LATM)402,402,400                                               1421.000
  400 DO 401 I=1,LATM                                                   1422.000
  401 CALL ATOM(ATOMS(1,I),ATOMS(2,I))                                  1423.000
  402 IF(MOD(NJ2,10)-1)499,404,403                                      1424.000
  403 CALL SEARC                                                        1425.000
      GO TO 499                                                         1426.000
C     ***** STORES (401) OR REMOVES (411) RUNS OF ATOMS *****           1427.000
C     ***** RUN HIERARCHY = ATOM NO./SYM/ A/B/C TRANS. *****            1428.000
  404 II=1                                                              1429.000
C     ***** FIND RUNS IN AIN ARRAY *****                                1430.000
  405 T1=AIN(II)                                                        1431.000
      IF(T1)410,410,420                                                 1432.000
  410 II=II+1                                                           1433.000
      IF(140-II)499,405,405                                             1434.000
  420 JJ=II                                                             1435.000
C     ***** SET INITIAL RUN VALUES *****                                1436.000
      M1=T1/100000.                                                     1437.000
      M2=AMOD(T1,100.)                                                  1438.000
      M5=AMOD(T1/100.,1000.)                                            1439.000
      IF(M5)422,422,423                                                 1440.000
  422 M5=555                                                            1441.000
  423 M3=M5/100                                                         1442.000
      M4=MOD(M5/10,10)                                                  1443.000
      M5=MOD(M5,10)                                                     1444.000
  425 JJ=JJ+1                                                           1445.000
      IF(140-JJ)435,430,430                                             1446.000
  430 T2=-AIN(JJ)                                                       1447.000
      IF(T2)435,425,440                                                 1448.000
  435 II=JJ-1                                                           1449.000
C     ***** SET TERMINAL VALUES FOR DEGENERATE RUN *****                1450.000
      N1=M1                                                             1451.000
      N2=M2                                                             1452.000
      N3=M3                                                             1453.000
      N4=M4                                                             1454.000
      N5=M5                                                             1455.000
      GO TO 450                                                         1456.000
  440 II=JJ                                                             1457.000
C     ***** SET TERMINAL RUN VALUES *****                               1458.000
      N1=T2/100000.                                                     1459.000
      N2=AMOD(T2,100.)                                                  1460.000
      N5=AMOD(T2/100.,1000.)                                            1461.000
      IF(N5)445,445,446                                                 1462.000
  445 N5=555                                                            1463.000
  446 N3=N5/100                                                         1464.000
      N4=MOD(N5/10,10)                                                  1465.000
      N5=MOD(N5,10)                                                     1466.000
C     ***** LOOP THROUGH ALL RUNS *****                                 1467.000
  450 DO 490 L5=M5,N5                                                   1468.000
      DO 490 L4=M4,N4                                                   1469.000
      DO 490 L3=M3,N3                                                   1470.000
      DO 490 L2=M2,N2                                                   1471.000
      DO 490 L1=M1,N1                                                   1472.000
      V1(1)=FLOAT(L1)*100000.+FLOAT(L3*10000+L4*1000+L5*100+L2)         1473.000
      CALL ATOM(V1(1),V1(2))                                            1474.000
      IF(NG)455,458,455                                                 1475.000
  455 CALL ERPNT(V1(1),401)                                             1476.000
      GO TO 490                                                         1477.000
  458 CALL STOR                                                         1478.000
  490 CONTINUE                                                          1479.000
      GO TO 410                                                         1480.000
  499 RETURN                                                            1481.000
      END                                                               1482.000
      SUBROUTINE F500                                                   1483.000
      DIMENSION RM(3,3),V(3,4)                                          1484.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         1485.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         1486.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 1487.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      1488.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   1489.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   1490.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     1491.000
         CHARACTER COMPID(72)                                           1492.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                1493.000
         INTEGER CN(200),CONTNT(13)                                     1494.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                1495.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 1496.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   1497.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    1498.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      1499.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          1500.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       1501.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          1502.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   1503.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                1504.000
      NG=0                                                              1505.000
      IF(NJ2-11)500,600,610                                             1506.000
  500 IF(NJ2-1)610,501,510                                              1507.000
  501 T1=AIN(1)                                                         1508.000
      CALL ATOM(T1,ORGN)                                                1509.000
      IF(NG)502,504,502                                                 1510.000
  502 CALL ERPNT(T1,501)                                                1511.000
      CALL EXIT                                                         1512.000
  504 DO 506 K=1,4                                                      1513.000
      T1=AIN(K+1)                                                       1514.000
      CALL ATOM(T1,V(1,K))                                              1515.000
      IF(NG)502,506,502                                                 1516.000
  506 CONTINUE                                                          1517.000
      DO 507 J=1,3                                                      1518.000
      V1(J)=V(J,2)-V(J,1)                                               1519.000
  507 V2(J)=V(J,4)-V(J,3)                                               1520.000
      IND=-1                                                            1521.000
      IF(AIN(7))509,509,508                                             1522.000
  508 IND=-2                                                            1523.000
  509 CALL AXES(V1,V2,REFV,IND)                                         1524.000
      GO TO 562                                                         1525.000
  510 IF(NJ2-4)515,511,599                                              1526.000
C      ***** SHIFT ORIGIN FOR PROJECTION AXIS (IN INCHES) *****         1527.000
  511 DO 513 J=1,3                                                      1528.000
      DO 512 K=1,3                                                      1529.000
  512 ORGN(J)=ORGN(J)+REFV(J,K)*AIN(K)/SCAL1                            1530.000
  513 XO(J)=XO(J)+AIN(J)                                                1531.000
      GO TO 570                                                         1532.000
C      ***** FORM ROTATION MATRIX *****                                 1533.000
  515 DO 552 L=1,139,2                                                  1534.000
      I=AIN(L)                                                          1535.000
      IF(I) 532,552,516                                                 1536.000
  516 X=AIN(L+1)*1.7453293E-2                                           1537.000
      T1=COS(X)                                                         1538.000
      T2=SIN(X)                                                         1539.000
      I3=MOD(I+2,3)+1                                                   1540.000
      I1=MOD(I3,3)+1                                                    1541.000
      I2=MOD(I1,3)+1                                                    1542.000
      RM(I1,I1)=T1                                                      1543.000
      RM(I1,I2)=T2                                                      1544.000
      RM(I1,I3)=0.0                                                     1545.000
      RM(I2,I1)=-T2                                                     1546.000
      RM(I2,I2)=T1                                                      1547.000
      RM(I2,I3)=0.0                                                     1548.000
      RM(I3,I1)=0.0                                                     1549.000
      RM(I3,I2)=0.0                                                     1550.000
      RM(I3,I3)=1.0                                                     1551.000
      CALL MM(REFV,RM,V)                                                1552.000
      IF(NJ2-3)518,525,599                                              1553.000
  518 DO 522 J=1,9                                                      1554.000
  522 REFV(J,1)=V(J,1)                                                  1555.000
      GO TO 552                                                         1556.000
  525 DO 528 J=1,9                                                      1557.000
  528 WRKV(J,1)=V(J,1)                                                  1558.000
      GO TO 552                                                         1559.000
  532 IF(NJ2-3)535,552,599                                              1560.000
  535 I=MOD(-I,3)                                                       1561.000
      DO 542 J=1,I                                                      1562.000
      DO 542 K=1,3                                                      1563.000
      T1=REFV(K,3)                                                      1564.000
      REFV(K,3)=REFV(K,2)                                               1565.000
      REFV(K,2)=REFV(K,1)                                               1566.000
  542 REFV(K,1)=T1                                                      1567.000
  552 CONTINUE                                                          1568.000
      IF(NJ2-3)562,582,599                                              1569.000
  562 CALL MM(AA,REFV,AAREV)                                            1570.000
  570 DO 572 J=1,9                                                      1571.000
      WRKV(J,1)=REFV(J,1)                                               1572.000
  572 AAWRK(J,1)=AAREV(J,1)                                             1573.000
      GO TO 599                                                         1574.000
  582 CALL MM(AA,WRKV,AAWRK)                                            1575.000
  599 CONTINUE                                                          1576.000
C     ***** ELIMINATE ALL PREVIOUSLY STORED OVERLAP INFORMATION ****    1577.000
C     ***** (ALL INSTRUCTIONS FROM 501 THROUGH 510 DO THIS *****        1578.000
      CALL LAP500(0)                                                    1579.000
      GO TO 610                                                         1580.000
C     ***** STORE NEW OVERLAP INFORMATION (INSTRUCTION 511) *****       1581.000
  600 CALL LAP500(1)                                                    1582.000
  610 RETURN                                                            1583.000
      END                                                               1584.000
      SUBROUTINE F600                                                   1585.000
C     ***** SCALING AND CENTERING FUNCTIONS *****                       1586.000
      DIMENSION MAX(3),SCAL(4),X(3),XMAX(3),XMIN(3),Z(2)                1587.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         1588.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         1589.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 1590.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      1591.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   1592.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   1593.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     1594.000
         CHARACTER COMPID(72)                                           1595.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                1596.000
         INTEGER CN(200),CONTNT(13)                                     1597.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                1598.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 1599.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   1600.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    1601.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      1602.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          1603.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       1604.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          1605.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   1606.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                1607.000
C     ***** DEL = 1. FOR INCRUMENTING FUNCTIONS *****                   1608.000
C     ***** DEL = 0. FOR REGULAR FUNCTIONS *****                        1609.000
      DEL=FLOAT(MOD(NJ2/10,2))                                          1610.000
      NJ2=MOD(NJ2,10)                                                   1611.000
C     ***** EXPLICIT ORIGIN AND SCALE *****                             1612.000
      IF(AIN(1))602,604,602                                             1613.000
  602 XO(1)=AIN(1)+XO(1)*DEL                                            1614.000
  604 IF(AIN(2))606,608,606                                             1615.000
  606 XO(2)=AIN(2)+XO(2)*DEL                                            1616.000
  608 IF(AIN(3))612,612,609                                             1617.000
  609 IF(DEL)611,611,610                                                1618.000
  610 SCAL1=SCAL1*AIN(3)                                                1619.000
      GO TO 612                                                         1620.000
  611 SCAL1=AIN(3)                                                      1621.000
  612 IF(AIN(4))616,616,614                                             1622.000
C     ***** SET ELLIPSOID SCALE FACTOR *****                            1623.000
  614 SCAL2=AIN(4)                                                      1624.000
C     ***** AUTOMATIC ORIGIN AND/OR SCALE *****                         1625.000
  616 IF(NJ2-2)790,622,620                                              1626.000
  620 XO(1)=XLNG(1)*.5                                                  1627.000
      XO(2)=XLNG(2)*.5                                                  1628.000
  622 IF(NJ2-3)625,640,625                                              1629.000
  625 SCAL1=1.                                                          1630.000
  630 IF(LATM-1)635,635,640                                             1631.000
  635 NG=12                                                             1632.000
      CALL ERPNT(0.,602)                                                1633.000
      CALL EXIT                                                         1634.000
  640 DO 650 J=1,3                                                      1635.000
      XMAX(J)=-1.E5                                                     1636.000
  650 XMIN(J)=1.E5                                                      1637.000
C     ***** FIT BOX AROUND SET OF ATOMS *****                           1638.000
      DO 670 I=1,LATM                                                   1639.000
      CALL XYZ(ATOMS(1,I),ATOMS(2,I),3)                                 1640.000
      IF(NG)652,653,652                                                 1641.000
  652 CALL ERPNT(ATOMS(1,I),600)                                        1642.000
      GO TO 670                                                         1643.000
  653 DO 668 J=1,3                                                      1644.000
      T1=ATOMS(J+1,I)                                                   1645.000
      IF(XMAX(J)-T1)655,660,660                                         1646.000
  655 XMAX(J)=T1                                                        1647.000
      MAX(J)=I                                                          1648.000
  660 IF(T1-XMIN(J))665,668,668                                         1649.000
  665 XMIN(J)=T1                                                        1650.000
  668 CONTINUE                                                          1651.000
  670 CONTINUE                                                          1652.000
C     ***** KM=TOP ATOM *****                                           1653.000
      KM=MAX(3)                                                         1654.000
      SMULT=1.                                                          1655.000
      DO 780 M=1,5                                                      1656.000
      IF(M-2)740,675,678                                                1657.000
C     ***** CHECK VIEW DISTANCE *****                                   1658.000
  675 IF(VIEW)785,785,680                                               1659.000
  678 IF(NJ2-3)680,785,680                                              1660.000
  680 T1=ATOMS(4,KM)*SMULT                                              1661.000
      IF(VIEW*.5-T1)685,690,690                                         1662.000
C     ***** INCREASE VIEW DISTANCE *****                                1663.000
  685 VIEW=2.*T1                                                        1664.000
C     ***** FIND PERSPECTIVE PROJECTION LIMITS *****                    1665.000
  690 DO 700 J=1,2                                                      1666.000
      XMAX(J)=-1.E5                                                     1667.000
  700 XMIN(J)=1.E5                                                      1668.000
      DO 725 I=1,LATM                                                   1669.000
      DO 705 J=1,3                                                      1670.000
  705 X(J)=ATOMS(J+1,I)*SMULT                                           1671.000
      T2=VIEW/(VIEW-X(3))                                               1672.000
      DO 725 J=1,2                                                      1673.000
      T1=X(J)*T2                                                        1674.000
      IF(XMAX(J)-T1)710,715,715                                         1675.000
  710 XMAX(J)=T1                                                        1676.000
  715 IF(T1-XMIN(J))720,725,725                                         1677.000
  720 XMIN(J)=T1                                                        1678.000
  725 CONTINUE                                                          1679.000
C     ***** REFINE PARAMETERS *****                                     1680.000
  740 IF(NJ2 -3)745,742,755                                             1681.000
  742 SMUL2=1.                                                          1682.000
      GO TO 765                                                         1683.000
C     ***** AUTOMATIC SCALE ONLY *****                                  1684.000
  745 DO 750 J=1,2                                                      1685.000
      T2=XO(J)                                                          1686.000
      SCAL(J)=(BRDR-T2)/XMIN(J)                                         1687.000
  750 SCAL(J+2)=(XLNG(J)-BRDR-T2)/XMAX(J)                               1688.000
      SMUL2=AMIN1(SCAL(1),SCAL(2),SCAL(3),SCAL(4))                      1689.000
      GO TO 780                                                         1690.000
C     ***** AUTOMATIC SCALE AND POSITION *****                          1691.000
  755 DO 760 J=1,2                                                      1692.000
  760 SCAL(J)=(XLNG(J)-BRDR*2.)/(XMAX(J)-XMIN(J))                       1693.000
      SMUL2=AMIN1(SCAL(1),SCAL(2))                                      1694.000
C     ***** AUTOMATIC POSITION *****                                    1695.000
  765 DO 770 J=1,2                                                      1696.000
  770 XO(J)=.5*(XLNG(J)-SMUL2*(XMAX(J)+XMIN(J)))                        1697.000
  780 SMULT=SMULT*SMUL2                                                 1698.000
      VIEW=VIEW*SMUL2                                                   1699.000
  785 SCAL1=SCAL1*SMULT                                                 1700.000
  790 SCL=SCAL1*SCAL2                                                   1701.000
C     ***** ELIMINATE ALL PREVIOUSLY STORED OVERLAP INFORMATION *****   1702.000
      CALL LAP500(0)                                                    1703.000
      RETURN                                                            1704.000
      END                                                               1705.000
      SUBROUTINE F700                                                   1706.000
C     ***** SUBROUTINE TO DRAW ELLIPSOIDS *****                         1707.000
      DIMENSION EYE(3),VIEWV(3),X(3),Z(3)                               1708.000
      CHARACTER*8 CHEMSYM(100)                                          1709.000
      DIMENSION      AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)    1710.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),     CONT(5),D(3,130)    1711.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 1712.000
      DIMENSION                      PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) 1713.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   1714.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   1715.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     1716.000
         CHARACTER COMPID(72)                                           1717.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                1718.000
         INTEGER CN(200),CONTNT(13)                                     1719.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                1720.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 1721.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   1722.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    1723.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      1724.000
      COMMON NG,  AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,     CONT,D   1725.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,      NCD 1726.000
      COMMON NJ,NJ2,NOUT,NSR,     ORGN,     PAC,PAT,Q,REFV,RES,RMS,SCAL11727.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   1728.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                1729.000
      EQUIVALENCE (CHEM(1),CHEMSYM(1))                                  1730.000
C     ***** SET ELLIPSOID GRAPHIC DETAILS *****                         1731.000
      ITILT=0                                                           1732.000
      NG=0                                                              1733.000
      NFIRST=1                                                          1734.000
      NPLANE=AIN(1)                                                     1735.000
      IF(NPLANE-1)720,715,720                                           1736.000
  715 NFIRST=4                                                          1737.000
      NPLANE=4                                                          1738.000
  720 NSOLID=AIN(2)                                                     1739.000
      NDOT=64/2**( IABS(NSOLID))                                        1740.000
      LINES=AIN(3)                                                      1741.000
      NDASH=AIN(4)                                                      1742.000
      CHSYM=AIN(5)                                                      1743.000
      DH=AIN(6)                                                         1744.000
      DV=AIN(7)                                                         1745.000
C     ***** ESTABLISH REFERENCE POINT OF VIEW *****                     1746.000
      T1=1.E6                                                           1747.000
      IF(VIEW)740,740,735                                               1748.000
  735 T1=VIEW/SCAL1                                                     1749.000
  740 DO 741 J=1,3                                                      1750.000
  741 EYE(J)=REFV(J,3)*T1+ORGN(J)                                       1751.000
       LNS=-1                                                           1752.000
C     ***** LOOP THROUGH ATOM LIST *****                                1753.000
      DO 1105 ITOM=1,LATM                                               1754.000
      T1=ATOMS(1,ITOM)                                                  1755.000
      IF(AIN(10))744,744,742                                            1756.000
  742 T2=AINT(T1/100000.)                                               1757.000
      IF(T2-AIN(10))1105,743,743                                        1758.000
  743 IF(AIN(11)-T2)1105,744,744                                        1759.000
  744 CALL XYZ(T1,X,2)                                                  1760.000
      IF(NG)758,746,758                                                 1761.000
  746 CALL PLTXY(X,Z)                                                   1762.000
      K=T1/100000.                                                      1763.000
      L=T1-FLOAT (K)*100000.                                            1764.000
      IF(NJ2-10)747,754,754                                             1765.000
  747 LNS=MOD(LNS+1,18)                                                 1766.000
      IF(LNS)749,748,749                                                1767.000
  748 WRITE (NOUT,751)(TITLE(I),I=1,18)                                 1768.000
      WRITE (NOUT,752)                                                  1769.000
  749 WRITE (NOUT,750)CHEM(K),K,L,Z(1),Z(2),(X(I),I=1,3),(XT(           1770.000
     1I),I=1,3)                                                         1771.000
  750 FORMAT(1H 10X,A6,3H  (I3,1H,I5,4H)   2F8.2,3X,3F8.3,11X,3F8.4)    1772.000
  751 FORMAT(1H110X,18A4)                                               1773.000
  752 FORMAT(1H010X,18HSYMBOL   ATOM CODE7X,16HPLOTTER X,Y(IN.) 3X,21HCA1774.000
     1RTESIAN X,Y,Z (IN.)15X,20HCRYSTAL SYSTEM X,Y,Z/1H 19X,45H(DIRECTIO1775.000
     2N COSINES(I,J),I=1,3),RMSD(J)),J=1,312X,42HFOR PRINCIPAL AXES BASE1776.000
     3D ON WORKING SYSTEM/1H )                                          1777.000
  754 IF(EDGE-BRDR*.75)755,760,760                                      1778.000
  755 NG=10                                                             1779.000
  758 CALL ERPNT(T1,700)                                                1780.000
      GO TO 1105                                                        1781.000
C     ***** CALL OVERLAP ROUTINE *****                                  1782.000
  760 ICQ=0                                                             1783.000
      DO 2000 I=1,3                                                     1784.000
 2000 V2(I)=X(I)/SCAL1                                                  1785.000
      WRITE (1,2001)      CHEMSYM(K),NFTYPE(K),V2                       1786.000
 2001    FORMAT (A8,I5,3F12.5)                                          1787.000
      CALL LAP700(ITOM,ICQ)                                             1788.000
      IF(ICQ)762,764,764                                                1789.000
C     ***** OMIT HIDDEN ATOM *****                                      1790.000
  762 NG=14                                                             1791.000
      GO TO 758                                                         1792.000
  764 IF(CHSYM)775,775,765                                              1793.000
C     ***** PLOT CHEMICAL SYMBOLS *****                                 1794.000
  765 T4=1.                                                             1795.000
      IF(VIEW)767,767,766                                               1796.000
  766 T4=VIEW/(VIEW-X(3))                                               1797.000
  767 T3=CHSYM*T4                                                       1798.000
      T4=DISP*T4*.5                                                     1799.000
      V1(1)=X(1)+DH*SYMB(1,1)+DV*SYMB(1,2)                              1800.000
      V1(2)=X(2)+DH*SYMB(2,1)+DV*SYMB(2,2)                              1801.000
      V1(3)=X(3)                                                        1802.000
      CALL PLTXY(V1,V3)                                                 1803.000
      IF(EDGE-CHSYM)775,768,768                                         1804.000
  768 V2(3)=0.                                                          1805.000
      DO 770 I=1,3,2                                                    1806.000
      V2(1)=V3(1)+FLOAT(I-2)*T4                                         1807.000
      DO 770 J=1,3,2                                                    1808.000
      V2(2)=V3(2)+FLOAT(J-2)*T4                                         1809.000
      CALL SIMBOL(V2(1),V2(2),T3,CHEM(K),THETA,6)                       1810.000
      IF(T4)775,775,770                                                 1811.000
  770 CONTINUE                                                          1812.000
  775 IF(NPLANE)1105,1105,780                                           1813.000
C     ***** ELLIPSOID PRINC VECTORS TOWARD VIEWER *****                 1814.000
  780 CALL PAXES(T1,2)                                                  1815.000
      IF(NG)758,783,758                                                 1816.000
  783 CALL DIFV(EYE,XT,VIEWV)                                           1817.000
      CALL UNIT(VIEWV,VIEWV,-1)                                         1818.000
      CALL VM(VIEWV,AA,V2)                                              1819.000
      DO 795 I=1,3                                                      1820.000
      IF(VV(V2,PAT(1,I)))785,795,795                                    1821.000
  785 DO 790 J=1,3                                                      1822.000
      PAC(J,I)=-PAC(J,I)                                                1823.000
  790 PAT(J,I)=-PAT(J,I)                                                1824.000
  795 CONTINUE                                                          1825.000
      DO 800 J=1,3                                                      1826.000
      PAC(J,4)=PAC(J,1)                                                 1827.000
  800 PAC(J,5)=PAC(J,2)                                                 1828.000
      IF(NJ2-10)802,803,803                                             1829.000
  801 FORMAT(1H 13X,3(3X,3F8.4,F8.5)/1H )                               1830.000
  802 WRITE (NOUT,801) ((PAC(J,K),J=1,3),RMS(K) ,K=1,3)                 1831.000
C     ***** V4 = VECTOR NORMAL TO POLAR PLANE *****                     1832.000
  803 CALL VM(VIEWV,AAWRK,V6)                                           1833.000
      CALL UNIT(V6,V6,1)                                                1834.000
      CALL MV(Q,V6,V4)                                                  1835.000
      CALL UNIT(V4,V4,1)                                                1836.000
C     ***** SET PLOTTING RESOLUTION FOR ELLIPSOID *****                 1837.000
      T3=RMS(3)*SCL                                                     1838.000
      NRESOL=1                                                          1839.000
      NBIS=5                                                            1840.000
      DO 805 J=1,3                                                      1841.000
      IF(T3-RES(J))804,810,810                                          1842.000
  804 NBIS=NBIS-1                                                       1843.000
  805 NRESOL=NRESOL*2                                                   1844.000
  810 NRES1=NRESOL+1                                                    1845.000
C     ***** LOOP THROUGH PRINC AND POLAR PLANES *****                   1846.000
      DO 1100 II=NFIRST,NPLANE                                          1847.000
      II0=MOD(II+2,3)+1                                                 1848.000
      II1=MOD(II,3)+1                                                   1849.000
      II2=MOD(II+1,3)+1                                                 1850.000
C     ***** GENERATE CONJUGATE DIAMETERS *****                          1851.000
      IF(.99938- ABS(VV(V4,PAC(1,II2))))820,820,830                     1852.000
  820 T1=RMS(II0)*SCL                                                   1853.000
      T2=RMS(II1)*SCL                                                   1854.000
      DO 825 J=1,3                                                      1855.000
      DA(J,1)=PAC(J,II0)*T1                                             1856.000
  825 DA(J,2)=PAC(J,II1)*T2                                             1857.000
      GO TO 850                                                         1858.000
  830 CALL NORM(PAC(1,II0),PAC(1,II1),V1,1)                             1859.000
      CALL NORM(V1,V4,V2,1)                                             1860.000
      CALL UNIT(V2,V2,1)                                                1861.000
      CALL MV(Q,V2,V3)                                                  1862.000
      IF(II-4)835,840,840                                               1863.000
  835 CALL NORM(V3,V1,V5,1)                                             1864.000
      GO TO 843                                                         1865.000
  840 CALL NORM(V3,V4,V5,1)                                             1866.000
  843 CALL UNIT(V5,V5,1)                                                1867.000
      T1=SCL/SQRT(VMV(V2,Q,V2))                                         1868.000
      T2=SCL/SQRT(VMV(V5,Q,V5))                                         1869.000
      DO 845 J=1,3                                                      1870.000
      DA(J,1)=V2(J)*T1                                                  1871.000
  845 DA(J,2)=V5(J)*T2                                                  1872.000
C     ***** GENERATE ELLIPSE *****                                      1873.000
  850 CALL RADIAL(NBIS)                                                 1874.000
      IF(II-4)900,851,851                                               1875.000
  851 IF(NSOLID)859,859,852                                             1876.000
C     ***** PLOT DOTTED BOUNDARY ELLIPSE *****                          1877.000
  852 IF(NDOT-NRESOL)853,855,855                                        1878.000
  853 CALL RADIAL(NSOLID-1)                                             1879.000
  855 CALL PROJ(D,DP,X,XO,VIEW,1,129,NDOT)                              1880.000
      DO 857 J=1,129,NDOT                                               1881.000
      CALL DRAW(DP(1,J),DISP,DISP,3)                                    1882.000
      DO 856 I=1,3,2                                                    1883.000
      T1=FLOAT(I-2)*DISP                                                1884.000
      DO 856 K=1,3,2                                                    1885.000
      T2=FLOAT(K-2)*DISP                                                1886.000
      CALL DRAW(DP(1,J),T1,T2,2)                                        1887.000
      IF(DISP)857,857,856                                               1888.000
  856 CONTINUE                                                          1889.000
  857 CONTINUE                                                          1890.000
      GO TO 1100                                                        1891.000
C     ***** PLOT SOLID BOUNDARY ELLIPSE *****                           1892.000
  859 CALL PROJ(D,DP,X,XO,VIEW,1,129,NRESOL)                            1893.000
      CALL DRAW(DP,0.,0.,3)                                             1894.000
      DO 860 J=NRES1,129,NRESOL                                         1895.000
  860 CALL DRAW(DP(1,J),0.,0.,2)                                        1896.000
      IF(DISP)1100,1100,865                                             1897.000
C     ***** BOUNDARY ANNULUS AS A LINEAR FUNCTION OF HEIGHT *****       1898.000
  865 CALL DIFV(XT,ORGN,V1)                                             1899.000
      T5=VV(V1,AAREV(1,3))*SCAL1                                        1900.000
      NCYCLE=.5+(AIN(8)+T5*AIN(9))/DISP                                 1901.000
      IF(NCYCLE)1100,1100,870                                           1902.000
  870 T3=(2.*DISP)/(T1+T2)                                              1903.000
C     ***** INCREASE ANNULAR THICKNESS *****                            1904.000
      DO 875 I=1,NCYCLE                                                 1905.000
      T4=T3*FLOAT(I)                                                    1906.000
      DO 875 J=1,129,NRESOL                                             1907.000
  875 CALL DRAW(DP(1,J),D(1,J)*T4,D(2,J)*T4,2)                          1908.000
      GO TO 1100                                                        1909.000
  900 CALL PROJ(D,DP,X,XO,VIEW,1,65,NRESOL)                             1910.000
C     ***** PLOT HALF AN ELLIPSE *****                                  1911.000
      CALL DRAW(DP,0.,0.,3)                                             1912.000
      DO 905 J=NRES1,65,NRESOL                                          1913.000
  905 CALL DRAW(DP(1,J),0.,0.,2)                                        1914.000
      IF(DISP)930,930,910                                               1915.000
C     ***** ACCENTUATE FRONT HALF *****                                 1916.000
  910 DO 925 I=1,3,2                                                    1917.000
      T2=FLOAT(I-2)*DISP                                                1918.000
      DO 915 J=1,65,NRESOL                                              1919.000
      K=66-J                                                            1920.000
  915 CALL DRAW(DP(1,K),DISP,T2,2)                                      1921.000
      DO 925 K=1,65,NRESOL                                              1922.000
  925 CALL DRAW(DP(1,K),-DISP,-T2,2)                                    1923.000
  930 IF(NSOLID)940,967,935                                             1924.000
  935 L=NDOT                                                            1925.000
      IF(NDOT-NRESOL)938,945,940                                        1926.000
  938 CALL RADIAL(NSOLID-1)                                             1927.000
      GO TO 945                                                         1928.000
  940 L=NRESOL                                                          1929.000
  945 CALL PROJ(D(1,65),DP(1,65),X,XO,VIEW,1,65,L)                      1930.000
      IF(NSOLID)960,967,950                                             1931.000
C     ***** DOTTED LINE ON REVERSE SIDE *****                           1932.000
  950 DO 958 J=65,129,NDOT                                              1933.000
      CALL DRAW(DP(1,J),DISP,DISP,3)                                    1934.000
      DO 955 I=1,3,2                                                    1935.000
      T1=FLOAT(I-2)*DISP                                                1936.000
      DO 955 K=1,3,2                                                    1937.000
      T2=FLOAT(K-2)*DISP                                                1938.000
      CALL DRAW(DP(1,J),T1,T2,2)                                        1939.000
      IF(DISP)958,958,955                                               1940.000
  955 CONTINUE                                                          1941.000
  958 CONTINUE                                                          1942.000
      GO TO 967                                                         1943.000
C     ***** SINGLE LINE ON REVERSE SIDE *****                           1944.000
  960 DO 965 J=65,129,NRESOL                                            1945.000
  965 CALL DRAW(DP(1,J),0.,0.,2)                                        1946.000
C     ***** DETAIL INTERIOR FEATURES *****                              1947.000
  967 T2=NDASH*2                                                        1948.000
      DO 975 J=1,3                                                      1949.000
      T1=PAC(J,II0)*RMS(II0)*SCL                                        1950.000
      DA(J,1)=T1                                                        1951.000
      DA(J,2)=PAC(J,II1)*RMS(II1)*SCL                                   1952.000
      DA(J,3)=0.                                                        1953.000
      IF(NDASH)975,975,970                                              1954.000
  970 V1(J)=-T1                                                         1955.000
      V2(J)=T1/T2                                                       1956.000
  975 CONTINUE                                                          1957.000
      IF(NDASH)987,987,980                                              1958.000
C     ***** DASHED LINE FOR REVERSE AXIS *****                          1959.000
  980 DO 985 J=1,NDASH                                                  1960.000
      DO 985 K=1,2                                                      1961.000
      L=4-K                                                             1962.000
      CALL PROJ(V1,DP,X,XO,VIEW,1,1,1)                                  1963.000
      CALL DRAW(DP,0.,0.,L)                                             1964.000
      DO 985 I=1,3                                                      1965.000
  985 V1(I)=V1(I)+V2(I)                                                 1966.000
C     ***** SOLID LINE FOR FORWARD AXIS *****                           1967.000
  987 IF(LINES)1100,1100,988                                            1968.000
  988 CALL PROJ(DA,DP,X,XO,VIEW,1,3,1)                                  1969.000
      T1=DISP*.5                                                        1970.000
      DO 990 I=1,3,2                                                    1971.000
      T2=FLOAT(2-I)*T1                                                  1972.000
      CALL DRAW(DP,T1,T2,3)                                             1973.000
      CALL DRAW(DP(1,3),T1,T2,2)                                        1974.000
      IF(DISP)1000,1000,989                                             1975.000
  989 CALL DRAW(DP(1,3),-T1,T2,2)                                       1976.000
  990 CALL DRAW(DP,-T1,T2,2)                                            1977.000
C     ***** SHADE QUADRANT BETWEEN TWO PRINCIPAL AXES *****             1978.000
 1000 L=LINES-1                                                         1979.000
      IF(L)1100,1100,1005                                               1980.000
 1005 T2=LINES                                                          1981.000
      DO 1025 I=1,L                                                     1982.000
      T1=FLOAT(I)/T2                                                    1983.000
      T3=SQRT(1.-T1*T1)                                                 1984.000
      IF(MOD(I,2))1010,1015,1010                                        1985.000
 1010 M=I*2                                                             1986.000
      N=M-1                                                             1987.000
      GO TO 1020                                                        1988.000
 1015 N=I*2                                                             1989.000
      M=N-1                                                             1990.000
 1020 DO 1025 J=1,3                                                     1991.000
      T4=DA(J,1)*T1                                                     1992.000
      D(J,M)=T4                                                         1993.000
 1025 D(J,N)=DA(J,2)*T3+T4                                              1994.000
      L=L*2                                                             1995.000
      CALL PROJ(D,DP,X,XO,VIEW,1,L,1)                                   1996.000
      DO 1030 I=2,L,2                                                   1997.000
      CALL DRAW(DP(1,I-1),0.,0.,3)                                      1998.000
 1030 CALL DRAW(DP(1,I),0.,0.,2)                                        1999.000
 1100 CONTINUE                                                          2000.000
 1105 CONTINUE                                                          2001.000
C     FORCE GKS TO FINISH POLYLINE (REMOVE NEXT STATEMENT FOR OTHER
C     GRAPHICS LIBRARIES)
      CALL EMPTYBUF
C     ***** ELIMINATE LOCAL OVERLAP INFORMATION BEFORE RETURNING *****  2002.000
      CALL LAP500(-1)                                                   2003.000
      RETURN                                                            2004.000
      END                                                               2005.000
      SUBROUTINE F800                                                   2006.000
C     ***** SUBROUTINE FINDS ATOM PAIRS FOR BONDS *****                 2007.000
      DIMENSION IA(3),W1(6)                                             2008.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         2009.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         2010.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 2011.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      2012.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   2013.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   2014.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     2015.000
         CHARACTER COMPID(72)                                           2016.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                2017.000
         INTEGER CN(200),CONTNT(13)                                     2018.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                2019.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 2020.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   2021.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    2022.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      2023.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          2024.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       2025.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          2026.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   2027.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                2028.000
      LNS=-4                                                            2029.000
      IF(MOD(NJ2,10)-2)805,848,848                                      2030.000
C     ***** EXPLICIT DESCRIPTION *****                                  2031.000
  805 II=0                                                              2032.000
      IF(NCD)810,810,815                                                2033.000
  810 NG=11                                                             2034.000
      CALL ERPNT(0.,NJ*100+NJ2)                                         2035.000
      GO TO 980                                                         2036.000
  815 II=II+1                                                           2037.000
      IF(140-II)980,980,820                                             2038.000
  820 T1=AIN(II)                                                        2039.000
      IF(T1)815,815,825                                                 2040.000
  825 II=II+1                                                           2041.000
      T2=AIN(II)                                                        2042.000
      IF(T2)815,815,830                                                 2043.000
  830 IF(NJ2-10)832,838,838                                             2044.000
  832 LNS=MOD(LNS+4,56)                                                 2045.000
      IF(LNS)838,834,838                                                2046.000
  834 WRITE (NOUT,835)(TITLE(I),I=1,18)                                 2047.000
  835 FORMAT(1H110X,18A4)                                               2048.000
      WRITE (NOUT,837)                                                  2049.000
  837 FORMAT(1H010X,18HSYMBOL   ATOM CODE6X,16HPLOTTER X,Y(IN.) 6X,21HCA2050.000
     1RTESIAN X,Y,Z (IN.)17X,20HCRYSTAL SYSTEM X,Y,Z/1H )               2051.000
C     ***** CHECK IF BOND ATOMS ARE IN ATOMS LIST (FOR OVERLAP CALC) ***2052.000
  838 NA1=0                                                             2053.000
      NA2=0                                                             2054.000
      IF(LATM-2)845,839,839                                             2055.000
  839 N2=2                                                              2056.000
      DO 844 K=1,LATM                                                   2057.000
      T3=ATOMS(1,K)                                                     2058.000
      IF(T3-T1)841,840,841                                              2059.000
  840 NA1=K                                                             2060.000
      GO TO 843                                                         2061.000
  841 IF(T3-T2)844,842,844                                              2062.000
  842 NA2=K                                                             2063.000
  843 N2=N2-1                                                           2064.000
      IF(N2)845,845,844                                                 2065.000
  844 CONTINUE                                                          2066.000
  845 IF(NA2-NA1)846,847,847                                            2067.000
  846 NA3=NA1                                                           2068.000
      NA1=NA2                                                           2069.000
      NA2=NA3                                                           2070.000
      T3=T1                                                             2071.000
      T1=T2                                                             2072.000
      T2=T3                                                             2073.000
  847 CALL BOND(T1,T2,1,NA1,NA2)                                        2074.000
      GO TO 815                                                         2075.000
C     ***** IMPLICIT DESCRIPTION *****                                  2076.000
  848 IF(LATM-2)810,850,850                                             2077.000
  850 SCAL3=SCAL1                                                       2078.000
      SCAL1=1.                                                          2079.000
      DO 855 I=1,LATM                                                   2080.000
  855 CALL XYZ(ATOMS(1,I),ATOMS(2,I),2)                                 2081.000
      SCAL1=SCAL3                                                       2082.000
      IF(NCD)810,810,860                                                2083.000
  860 WRITE (NOUT,861)                                                  2084.000
  861 FORMAT(1H010X,20HBOND SELECTION CODES//11X,94H(SEQUENCE(A))(SEQUEN2085.000
     1CE(B)) (BOND) (DISTANCES)( BOND )(PERSP.--LABELS)(NORMAL--LABELS)(2086.000
     2DIGITS) /11X,93H(  MIN  MAX )(  MIN  MAX ) (TYPE) (MIN   MAX)(RADI2087.000
     3US)(HEIGHT  OFFSET)(HEIGHT  OFFSET)(NUMBER))                      2088.000
      DMAX=0.                                                           2089.000
      DO 870 I=1,NCD                                                    2090.000
      IF(DMAX-CD(2,I))865,870,870                                       2091.000
  865 DMAX=CD(2,I)                                                      2092.000
  870 WRITE (NOUT,871)(KD(J,I),J=1,5),(CD(J,I),J=1,8)                   2093.000
  871 FORMAT(1H 10XI6,I5,I8,I5,I8,2F6.2,5F8.3,F7.0)                     2094.000
      DMAX=DMAX*DMAX                                                    2095.000
C     ***** LOOP THROUGH ATOMS ARRAY *****                              2096.000
      DO 977 M=1,LATM                                                   2097.000
      NA1=M                                                             2098.000
      T1=ATOMS(1,M)                                                     2099.000
      IA(1)=T1/100000.                                                  2100.000
      IA(3)=IA(1)                                                       2101.000
      W1(1)=ATOMS(2,M)                                                  2102.000
      W1(2)=ATOMS(3,M)                                                  2103.000
      W1(3)=ATOMS(4,M)                                                  2104.000
      L=M+1                                                             2105.000
      IF(LATM-L)977,872,872                                             2106.000
  872 DO 975 N=L,LATM                                                   2107.000
      NA2=N                                                             2108.000
      DIST=(ATOMS(2,N)-W1(1))**2                                        2109.000
      IF(DMAX-DIST)975,873,873                                          2110.000
  873 DIST=DIST+(ATOMS(3,N)-W1(2))**2                                   2111.000
      IF(DMAX-DIST)975,874,874                                          2112.000
  874 DIST=DIST+(ATOMS(4,N)-W1(3))**2                                   2113.000
      IF(DMAX-DIST)975,875,875                                          2114.000
  875 DIST=SQRT(DIST)                                                   2115.000
      T2=ATOMS(1,N)                                                     2116.000
      IA(2)=T2/100000.                                                  2117.000
C     ***** SELECT BONDS ACCORDING TO CODES *****                       2118.000
      DO 950 J=1,NCD                                                    2119.000
      JB=J                                                              2120.000
      IF(DIST-CD(1,J))   950,880,880                                    2121.000
  880 IF(CD(2,J)-DIST)   950,881,881                                    2122.000
  881 DO 885 K=1,2                                                      2123.000
      IF(IA(K)-KD(1,J))  885,882,882                                    2124.000
  882 IF(KD(2,J)-IA(K))  885,883,883                                    2125.000
  883 IF(IA(K+1)-KD(3,J))885,884,884                                    2126.000
  884 IF(KD(4,J)-IA(K+1))885,890,890                                    2127.000
  885 CONTINUE                                                          2128.000
      GO TO 950                                                         2129.000
C     ***** CHECK FOR POLYHEDRA CODE *****                              2130.000
  890 IF(CD(4,J))900,955,955                                            2131.000
  900 W1(4)=ATOMS(2,N)                                                  2132.000
      W1(5)=ATOMS(3,N)                                                  2133.000
      W1(6)=ATOMS(4,N)                                                  2134.000
      KM1=ABS(CD(4,J))                                                  2135.000
      KM2=ABS(CD(5,J))                                                  2136.000
      DSQ1=(CD(6,J))**2                                                 2137.000
      DSQ2=(CD(7,J))**2                                                 2138.000
C     ***** SEARCH FOR POLYHEDRA CENTER *****                           2139.000
      DO 935 IM=1,LATM                                                  2140.000
      K3=ATOMS(1,IM)/100000.                                            2141.000
      IF(K3-KM1)935,905,905                                             2142.000
  905 IF(KM2-K3)935,910,910                                             2143.000
C     ***** CHECK POLYHEDRA DISTANCE RANGE *****                        2144.000
  910 DO 930 J1=1,4,3                                                   2145.000
      DSQ=(ATOMS(2,IM)-W1(J1))**2                                       2146.000
      IF(DSQ2-DSQ)935,915,915                                           2147.000
  915 DSQ=DSQ+(ATOMS(3,IM)-W1(J1+1))**2                                 2148.000
      IF(DSQ2-DSQ)935,920,920                                           2149.000
  920 DSQ=DSQ+(ATOMS(4,IM)-W1(J1+2))**2                                 2150.000
      IF(DSQ2-DSQ)935,925,925                                           2151.000
  925 IF(DSQ-DSQ1)935,930,930                                           2152.000
  930 CONTINUE                                                          2153.000
      GO TO 955                                                         2154.000
  935 CONTINUE                                                          2155.000
C     ***** END OF POLYHEDRA CHECK *****                                2156.000
  950 CONTINUE                                                          2157.000
      GO TO 975                                                         2158.000
C     ***** PREPARE TO DRAW BOND *****                                  2159.000
  955 IF(NJ2-10)960,970,970                                             2160.000
  960 LNS=MOD(LNS+4,56)                                                 2161.000
      IF(LNS)965,965,970                                                2162.000
  965 WRITE (NOUT,835)(TITLE(I),I=1,18)                                 2163.000
      WRITE (NOUT,837)                                                  2164.000
  970 CALL BOND(T1,T2,JB,NA1,NA2)                                       2165.000
  975 CONTINUE                                                          2166.000
  977 CONTINUE                                                          2167.000
C     ***** ELIMINATE LOCAL OVERLAP INFORMATION BEFORE RETURNING *****  2168.000
  980 IF(NJ2-21)985,990,990                                             2169.000
  985 CALL LAP500(-1)                                                   2170.000
  990 RETURN                                                            2171.000
      END                                                               2172.000
      SUBROUTINE F900                                                   2173.000
      DIMENSION X(3),XW(3,5),Y(3),Z(3)                                  2174.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         2175.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         2176.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 2177.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      2178.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   2179.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   2180.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     2181.000
         CHARACTER COMPID(72)                                           2182.000
         CHARACTER*8 CHEM(200),FTYPE(13),CHAR,LABEL(3)                  2183.000
         INTEGER CN(200),CONTNT(13)                                     2184.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                2185.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 2186.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   2187.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    2188.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      2189.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          2190.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       2191.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          2192.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   2193.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                2194.000
         DATA LABEL/'a','b','c'/                                        2195.000
C     ***** LABELING FUNCTION SUBROUTINE *****                          2196.000
      ITILT=0                                                           2197.000
      NJ3=MOD(NJ2,10)                                                   2198.000
      TH=THETA                                                          2199.000
      SINTH=SYMB(2,1)                                                   2200.000
      COSTH=SYMB(1,1)                                                   2201.000
      ILAST=1                                                           2202.000
      IF(AIN(2)-11100.)910,910,905                                      2203.000
  905 ILAST=2                                                           2204.000
  910 DO 925 II=1,ILAST                                                 2205.000
C     ***** OBTAIN WORKING CARTESIAN COORDINATES *****                  2206.000
      CALL XYZ(AIN(II),XW(1,II),2)                                      2207.000
      IF(NG)915,925,915                                                 2208.000
  912 NG=15                                                             2209.000
  915 CALL ERPNT(AIN(II),NJ*100+NJ2)                                    2210.000
      GO TO 1199                                                        2211.000
  925 CALL XYZ(AIN(II),XW(1,II+3),3)                                    2212.000
      II=1                                                              2213.000
C     ***** FIND MEAN REFERENCE POINT *****                             2214.000
      DO 930 J=1,3                                                      2215.000
      T2=XW(J,ILAST)                                                    2216.000
      T1=XW(J,1)                                                        2217.000
      XW(J,3)=T2-T1                                                     2218.000
  930 X(J)=(T2+T1)*.5                                                   2219.000
C     ***** PERSPECTIVE SCALING FACTOR *****                            2220.000
      SCAL=1.                                                           2221.000
      IF(VIEW)940,940,935                                               2222.000
  935 SCAL=VIEW/(VIEW-X(3))                                             2223.000
  940 HGT=SCAL*AIN(5)                                                   2224.000
      IF(NJ2-3)960,950,945                                              2225.000
  945 IF(NJ2-6)950,950,960                                              2226.000
C     ***** PROJECTED VECTOR BASELINE *****                             2227.000
  950 CALL PLTXY(XW(1,4),V1)                                            2228.000
      CALL PLTXY(XW(1,5),V2)                                            2229.000
      T1=V2(1)-V1(1)                                                    2230.000
      T2=V2(2)-V1(2)                                                    2231.000
      T3=SQRT(T1*T1+T2*T2)                                              2232.000
      IF(T3)912,912,955                                                 2233.000
  955 COSTH=T1/T3                                                       2234.000
      SINTH=T2/T3                                                       2235.000
      TH=ARCCOS(COSTH)                                                  2236.000
      IF(SINTH)958,960,960                                              2237.000
  958 TH=-TH                                                            2238.000
  960 IF(NJ2-13)965,985,985                                             2239.000
C     ***** FIND CENTER OF PROJECTED LABEL *****                        2240.000
  965 Y(1)=SCAL*(X(1)+AIN(6)*COSTH-AIN(7)*SINTH)+XO(1)                  2241.000
      Y(2)=SCAL*(X(2)+AIN(6)*SINTH+AIN(7)*COSTH)+XO(2)                  2242.000
      Y(3)=0.                                                           2243.000
C     ***** CHECK FOR LEGEND RESET *****                                2244.000
      DO 980 J=1,2                                                      2245.000
      T1=AIN(J+2)                                                       2246.000
      IF(T1)975,980,970                                                 2247.000
  970 Y(J)=T1                                                           2248.000
      GO TO 980                                                         2249.000
  975 Y(J)=XLNG(J)+T1                                                   2250.000
  980 CONTINUE                                                          2251.000
C     ***** SET PARAMETERS FOR INDIVIDUAL FUNCTIONS *****               2252.000
  985 GO TO(990,995,995,1000,1000,1000,915,1105,1105,915,915,915,1005,102253.000
     105,1005,1005,915),NJ2                                             2254.000
  990 T6=17.                                                            2255.000
      L=AIN(1)/100000.                                                  2256.000
      ILAST=1                                                           2257.000
      DXW=0.                                                            2258.000
      DYW=0.                                                            2259.000
      GO TO 1030                                                        2260.000
  995 T6=215.                                                           2261.000
      ILAST=18                                                          2262.000
      T1=HGT*24./7.                                                     2263.000
      DXW=COSTH*T1                                                      2264.000
      DYW=SINTH*T1                                                      2265.000
      GO TO 1030                                                        2266.000
 1000 T6=10+3*(NJ3-4)                                                   2267.000
      DIST=SQRT(VV(XW(1,3),XW(1,3)))/SCAL1                              2268.000
      GO TO 1030                                                        2269.000
C     ***** TRUE PERSPECTIVE LABELS *****                               2270.000
 1005 CALL UNIT(XW(1,3),VT(1,1),1)                                      2271.000
      IF(ABS(VT(3,1))-.9994)1010,912,912                                2272.000
C     ***** FORM PERSPECTIVE ROTATION MATRIX *****                      2273.000
 1010 CALL NORM(AID(1,3),VT(1,1),VT(1,2),1)                             2274.000
      CALL UNIT(VT(1,2),VT(1,2),1)                                      2275.000
      CALL NORM(VT(1,1),VT(1,2),VT(1,3),1)                              2276.000
      DO 1015 J=1,3                                                     2277.000
 1015 VT(J,4)=X(J)                                                      2278.000
      ITILT=1                                                           2279.000
      HGT=AIN(5)                                                        2280.000
      TH=0.                                                             2281.000
      Y(3)=X(3)                                                         2282.000
      Y(2)=X(2)+AIN(7)-HGT*.5                                           2283.000
      IF(NJ2-13)1030,1025,1020                                          2284.000
C     ***** PERSPECTIVE BOND LABELS *****                               2285.000
 1020 Y(1)=X(1)+AIN(6)-HGT*FLOAT(22+3*(6-NJ3))/7.                       2286.000
      DIST=SQRT(VV(XW(1,3),XW(1,3)))/SCAL1                              2287.000
      GO TO 1050                                                        2288.000
C     ***** PERSPECTIVE TITLES *****                                    2289.000
 1025 Y(1)=X(1)+AIN(6)-HGT*215./7.                                      2290.000
      ILAST=18                                                          2291.000
      DXW=HGT*24./7.                                                    2292.000
      DYW=0.                                                            2293.000
      GO TO 1050                                                        2294.000
 1030 DH=HGT*T6/7.                                                      2295.000
      DV=HGT*.5                                                         2296.000
      Y(1)=Y(1)-DH*COSTH+DV*SINTH                                       2297.000
      Y(2)=Y(2)-DH*SINTH-DV*COSTH                                       2298.000
      Y(3)=0.                                                           2299.000
C     ***** PLOT VARIOUS LABELS *****                                   2300.000
 1050 Z(3)=Y(3)                                                         2301.000
      XO(3)=Y(3)                                                        2302.000
      GO TO(1060,1060,1060,1090,1090,1090,915,1105,1105),NJ3            2303.000
 1060 DO 1085 I=1,ILAST                                                 2304.000
      DO 1075 J=1,3,2                                                   2305.000
      Z(1)=Y(1)+FLOAT(J-2)*DISP*.5                                      2306.000
      DO 1075 K=1,3,2                                                   2307.000
      Z(2)=Y(2)+FLOAT(K-2)*DISP*.5                                      2308.000
      IF(NJ3-2)1065,1068,1068                                           2309.000
C     ***** PLOT CHEMICAL SYMBOL *****                                  2310.000
 1065 CALL SIMBOL(Z(1),Z(2),HGT,CHEM(L),TH,6)                           2311.000
      GO TO 1070                                                        2312.000
C     ***** PLOT TITLES *****                                           2313.000
 1068    WRITE (CHAR,9867) TITLE2(I)                                    2314.000
 9867    FORMAT (A8)                                                    2315.000
      CALL SIMBOL(Z(1),Z(2),HGT,CHAR,     TH,4)                         2316.000
 1070 IF(DISP)1080,1080,1075                                            2317.000
 1075 CONTINUE                                                          2318.000
 1080 Y(1)=Y(1)+DXW                                                     2319.000
 1085 Y(2)=Y(2)+DYW                                                     2320.000
      GO TO 1199                                                        2321.000
C     ***** PLOT BOND DISTANCE LABELS *****                             2322.000
 1090 I9=NJ3-3                                                          2323.000
      T9=10.**I9                                                        2324.000
      DISTR=AINT((DIST*T9)+0.5)/T9 +.0001                               2325.000
      CALL NUMBUR(Y(1),Y(2),HGT,DISTR,TH,I9)                            2326.000
      GO TO 1199                                                        2327.000
C     ***** PLOT CENTERED SYMBOLS *****                                 2328.000
 1105 CALL SIMBOL(Y(1),Y(2),HGT, LABEL(IFIX(AIN(8))),TH,7-NJ3)          2329.000
 1199 ITILT=0                                                           2330.000
      RETURN                                                            2331.000
      END                                                               2332.000
      SUBROUTINE F1000                                                  2333.000
         CHARACTER COMPID(72),LINE(148)                                 2334.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                2335.000
         INTEGER CN(200),CONTNT(13),ANR,FIRSTCH(20),FWIDTH(20)          2336.000
      DIMENSION      AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)    2337.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),    CONT(5),D(3,130)     2338.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 2339.000
      DIMENSION                      PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) 2340.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   2341.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   2342.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     2343.000
      COMMON NG,  AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,     CONT,D   2344.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,      NCD 2345.000
      COMMON NJ,NJ2,NOUT,NSR,     ORGN,     PAC,PAT,Q,REFV,RES,RMS,SCAL12346.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   2347.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                2348.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                2349.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 2350.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   2351.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    2352.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      2353.000
         GO TO (2,3,7,8),NJ2                                            2354.000
 2       NJ2=AIN(1)                                                     2355.000
      CALL NEWPEN(NJ2)                                                  2356.000
      WRITE (NOUT,11) NJ2                                               2357.000
 11   FORMAT ('0PEN',I2,' SELECTED')                                    2358.000
      RETURN                                                            2359.000
 3       AIN(1)=55501.                                                  2360.000
         AIN(2)=-66601.                                                 2361.000
         NJ2=1                                                          2362.000
         CALL F400                                                      2363.000
         CALL CELEDG(55501.,65501.)                                     2364.000
         CALL CELEDG(56501.,66501.)                                     2365.000
         CALL CELEDG(56601.,66601.)                                     2366.000
         CALL CELEDG(55601.,65601.)                                     2367.000
         CALL CELEDG(55501.,56501.)                                     2368.000
         CALL CELEDG(65501.,66501.)                                     2369.000
         CALL CELEDG(65601.,66601.)                                     2370.000
         CALL CELEDG(55601.,56601.)                                     2371.000
         CALL CELEDG(55501.,55601.)                                     2372.000
         CALL CELEDG(65501.,65601.)                                     2373.000
         CALL CELEDG(66501.,66601.)                                     2374.000
         CALL CELEDG(56501.,56601.)                                     2375.000
         RETURN                                                         2376.000
 7       NJ2=8                                                          2377.000
         AIN(1)=65501.                                                  2378.000
         AIN(8)=1.                                                      2379.000
         CALL F900                                                      2380.000
         AIN(1)=56501.                                                  2381.000
         AIN(8)=2.                                                      2382.000
         CALL F900                                                      2383.000
         AIN(1)=55601.                                                  2384.000
         AIN(8)=3.                                                      2385.000
         CALL F900                                                      2386.000
         RETURN                                                         2387.000
 8       NATOM=NATOM+1                                                  2388.000
         DO 9 I=1,3                                                     2389.000
 9       P(I,NATOM)=0.5                                                 2390.000
         NJ=4                                                           2391.000
         NJ2=4                                                          2392.000
         AIN(1)=NATOM                                                   2393.000
         AIN(2)=NATOM                                                   2394.000
         AIN(3)=1.                                                      2395.000
         AIN(4)=NATOM-1                                                 2396.000
         CALL F400                                                      2397.000
         NJ=5                                                           2398.000
         NJ2=1                                                          2399.000
         AIN(1)=1.E5*NATOM+55501.                                       2400.000
         AIN(2)=155501.                                                 2401.000
         AIN(3)=165501.                                                 2402.000
         AIN(4)=155501.                                                 2403.000
         AIN(5)=156501.                                                 2404.000
         AIN(6)=0.                                                      2405.000
         AIN(7)=1.                                                      2406.000
         CALL F500                                                      2407.000
         NJ=4                                                           2408.000
         NJ2=6                                                          2409.000
         NATOM=NATOM-1                                                  2410.000
         AIN(1)=1.                                                      2411.000
         AIN(2)=NATOM                                                   2412.000
         AIN(3)=1.                                                      2413.000
         AIN(4)=NATOM                                                   2414.000
         AIN(5)=AIN(9)                                                  2415.000
         AIN(6)=0.                                                      2416.000
         AIN(7)=0.                                                      2417.000
         CALL F400                                                      2418.000
         RETURN                                                         2419.000
      END                                                               2420.000
         SUBROUTINE CELEDG(ADC1,ADC2)                                   2421.000
         CHARACTER COMPID(72),LINE(148)                                 2422.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                2423.000
         INTEGER CN(200),CONTNT(13),ANR,FIRSTCH(20),FWIDTH(20)          2424.000
      DIMENSION      AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)    2425.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),    CONT(5),D(3,130)     2426.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 2427.000
      DIMENSION                      PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) 2428.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   2429.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   2430.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     2431.000
         DIMENSION X1(3),X2(3),P1(2),P2(2)                              2432.000
      COMMON NG,  AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,     CONT,D   2433.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,      NCD 2434.000
      COMMON NJ,NJ2,NOUT,NSR,     ORGN,     PAC,PAT,Q,REFV,RES,RMS,SCAL12435.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   2436.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                2437.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                2438.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 2439.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   2440.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    2441.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      2442.000
         CALL XYZ(ADC1,X1,2)                                            2443.000
         CALL PLTXY(X1,P1)                                              2444.000
         IF (EDGE.LT.BRDR*0.25) RETURN                                  2445.000
         CALL XYZ(ADC2,X2,2)                                            2446.000
         CALL PLTXY(X2,P2)                                              2447.000
         IF (EDGE.LT.BRDR*0.25) RETURN                                  2448.000
         CALL SIMBOL(P1(1),P1(2),0.,' ',0.,-1)                          2449.000
         CALL SIMBOL(P2(1),P2(2),0.,' ',0.,-2)                          2450.000
         RETURN                                                         2451.000
         END                                                            2452.000
      SUBROUTINE MM(X,Y,Z)                                              2453.000
C     MULTIPLY TWO MATRICES                                             2454.000
C     Z(3,3)=X(3,3)*Y(3,3)                                              2455.000
      DIMENSION X(3,3),Y(3,3),Z(3,3)                                    2456.000
      DO 117 I=1,3                                                      2457.000
      DO 117 K=1,3                                                      2458.000
      Z(I,K)=0.0                                                        2459.000
      DO 117 J=1,3                                                      2460.000
  117 Z(I,K)=Z(I,K)+X(I,J)*Y(J,K)                                       2461.000
      RETURN                                                            2462.000
      END                                                               2463.000
      SUBROUTINE MV(X,Y,Z)                                              2464.000
C     MATRIX * VECTOR                                                   2465.000
C     Z(3)=X(3,3)*Y(3)                                                  2466.000
      DIMENSION X(3,3),Y(3),Z(3)                                        2467.000
      DO 113 I=1,3                                                      2468.000
      Z(I)=0.0                                                          2469.000
      DO 113 J=1,3                                                      2470.000
  113 Z(I)=Z(I)+X(I,J)*Y(J)                                             2471.000
      RETURN                                                            2472.000
      END                                                               2473.000
      SUBROUTINE NORM(X,Y,Z,ITYPE)                                      2474.000
C     ***** VECTOR PRODUCT  Z=X*Y *****                                 2475.000
C     ***** ITYPE .GT.0 FOR CARTESIAN,.LE.0 FOR TRICLINIC *****         2476.000
      DIMENSION X(3),Y(3),Z(3),Z1(3)                                    2477.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         2478.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         2479.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 2480.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      2481.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   2482.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   2483.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     2484.000
         CHARACTER COMPID(72)                                           2485.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                2486.000
         INTEGER CN(200),CONTNT(13)                                     2487.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                2488.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 2489.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   2490.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    2491.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      2492.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          2493.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       2494.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          2495.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   2496.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                2497.000
      DO 125 I=1,3                                                      2498.000
      I1=MOD(I+3,3)+1                                                   2499.000
      I2=MOD(I+1,3)+1                                                   2500.000
      T1=X(I1)*Y(I2)-X(I2)*Y(I1)                                        2501.000
      IF(ITYPE)115,115,105                                              2502.000
  105 Z(I)=T1                                                           2503.000
      GO TO 125                                                         2504.000
  115 Z1(I)=T1                                                          2505.000
  125 CONTINUE                                                          2506.000
      IF(ITYPE)135,135,300                                              2507.000
  135 CALL MV(BB,Z1,Z)                                                  2508.000
  300 RETURN                                                            2509.000
      END                                                               2510.000
      SUBROUTINE PAXES(ACODE,ITYPE)                                     2511.000
C     ***** ITYPE .LT.0 FOR COVARIANCE MATRIX IN Q *****                2512.000
C     ***** ITYPE .GT.0 FOR ELLIPSOID QUADRATIC FORM IN Q *****         2513.000
C     ***** XABSF(ITYPE)=1 BASED ON TRICLINIC COORDINATE SYSTEM *****   2514.000
C     ***** =2 OR 3 FOR WORKING OR REFERENCE CARTESIAN SYSTEMS *****    2515.000
C     ***** CONTRAVARIANT EIGENVECTORS FOR Q IN COLUMNS OF PAC *****    2516.000
C     ***** CHECK ATOM CODE *****                                       2517.000
      DIMENSION W(3,3),X(3)                                             2518.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         2519.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         2520.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 2521.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      2522.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   2523.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   2524.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     2525.000
         CHARACTER COMPID(72)                                           2526.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                2527.000
         INTEGER CN(200),CONTNT(13)                                     2528.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                2529.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 2530.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   2531.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    2532.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      2533.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          2534.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       2535.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          2536.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   2537.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                2538.000
      IT=IABS(ITYPE)-1                                                  2539.000
      KS=AMOD(ACODE,100.)                                               2540.000
      IF(NSYM-KS)105,115,115                                            2541.000
  105 NG=4                                                              2542.000
      GO TO 300                                                         2543.000
  115 II=ACODE/100000.                                                  2544.000
      IF(NATOM-II)125,130,130                                           2545.000
  125 NG=5                                                              2546.000
      GO TO 300                                                         2547.000
  130 IF(II)125,125,135                                                 2548.000
C     ***** CRYSTALLOGRAPHIC SYMMETRY ROTATION *****                    2549.000
  135 CALL TMM(PA(1,1,II),FS(1,1,KS),PAT)                               2550.000
      IF(IT-1)160,145,155                                               2551.000
C     ***** TRANSFORM TO CARTESIAN SYSTEMS *****                        2552.000
  145 CALL TMM(PAT,AAWRK,PAC)                                           2553.000
      GO TO 175                                                         2554.000
  155 CALL TMM(PAT,AAREV,PAC)                                           2555.000
      GO TO 175                                                         2556.000
  160 IF(ITYPE)162,155,170                                              2557.000
C     ***** TRANSFORM TO TRICLINIC SYSTEM *****                         2558.000
  162 DO 165 J=1,9                                                      2559.000
  165 PAC(J,1)=PAT(J,1)                                                 2560.000
      GO TO 175                                                         2561.000
  170 CALL MM(AA,PAT,PAC)                                               2562.000
C     ***** FORM DIAGONAL MATRIX OR ITS INVERSE *****                   2563.000
  175 DO 205 J=1,3                                                      2564.000
      T1=EV(J,II)                                                       2565.000
      IF(ITYPE)195,195,185                                              2566.000
  185 X(J)=1./(T1*T1)                                                   2567.000
      GO TO 205                                                         2568.000
  195 X(J)=T1*T1                                                        2569.000
  205 RMS(J)=T1                                                         2570.000
C     ***** FORM QUADRATIC FORM *****                                   2571.000
      DO 245 I=1,3                                                      2572.000
      DO 245 J=I,3                                                      2573.000
      T1=0.0                                                            2574.000
      DO 225 K=1,3                                                      2575.000
  225 T1=T1+PAC(I,K)*PAC(J,K)*X(K)                                      2576.000
      Q(J,I)=T1                                                         2577.000
  245 Q(I,J)=T1                                                         2578.000
  300 RETURN                                                            2579.000
      END                                                               2580.000
      SUBROUTINE PLTXY(X,Y)                                             2581.000
C     ***** PLOT COORD. AND CLOSEST EDGE AFTER PROJECTION *****         2582.000
      DIMENSION X(3),Y(2)                                               2583.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         2584.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         2585.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 2586.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      2587.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   2588.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   2589.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     2590.000
         CHARACTER COMPID(72)                                           2591.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                2592.000
         INTEGER CN(200),CONTNT(13)                                     2593.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                2594.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 2595.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   2596.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    2597.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      2598.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          2599.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       2600.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          2601.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   2602.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                2603.000
      T4=1.                                                             2604.000
      T1=1.                                                             2605.000
      IF(VIEW)125,125,110                                               2606.000
  110 T4=VIEW-X(3)                                                      2607.000
      IF(T4)115,115,120                                                 2608.000
  115 Y(1)=-99.                                                         2609.000
      Y(2)=-99.                                                         2610.000
      GO TO 130                                                         2611.000
  120 T1=VIEW/T4                                                        2612.000
  125 Y(1)=X(1)*T1+XO(1)                                                2613.000
      Y(2)=X(2)*T1+XO(2)                                                2614.000
      T1=XLNG(1)-ABS(Y(1)*2.-XLNG(1))                                   2615.000
      T2=XLNG(2)-ABS(Y(2)*2.-XLNG(2))                                   2616.000
      EDGE=AMIN1(T1,T2)*.5                                              2617.000
      IF(T4-VIEW*.5)130,300,300                                         2618.000
  130 EDGE=-99.                                                         2619.000
  300 RETURN                                                            2620.000
      END                                                               2621.000
      SUBROUTINE PRELIM                                                 2622.000
C     ***** DATA INPUT ROUTINE *****                                    2623.000
         CHARACTER COMPID(72)                                           2624.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                2625.000
         CHARACTER*72 CTITLE                                            2626.000
         INTEGER CN(200),CONTNT(13)                                     2627.000
      DIMENSION B(9)                                                    2628.000
      DIMENSION      AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)    2629.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),    CONT(5),D(3,130)     2630.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 2631.000
      DIMENSION                      PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) 2632.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   2633.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   2634.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     2635.000
      COMMON NG,  AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,     CONT,D   2636.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,      NCD 2637.000
      COMMON NJ,NJ2,NOUT,NSR,     ORGN,     PAC,PAT,Q,REFV,RES,RMS,SCAL12638.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   2639.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                2640.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                2641.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 2642.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   2643.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    2644.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      2645.000
         EQUIVALENCE(COMPID(1),CTITLE)                                  2646.000
      DATA            ETPISQ/78.95684/                                  2647.000
         CALL MDLIN(16)                                                 2648.000
         WRITE (NOUT,109) COMPID                                        2649.000
 109     FORMAT (' ',72A1)                                              2650.000
C     ***** READ JOB TITLE CARD *****                                   2651.000
       READ  (CTITLE,1) TITLE                                           2652.000
 1    FORMAT (18A4)                                                     2653.000
      T1=ABS(A(4))-1.                                                   2654.000
      DO 125 J=1,3                                                      2655.000
      IF(T1)115,110,110                                                 2656.000
C     ***** CELL ANGLES IN DEGREES *****                                2657.000
  110 A(J+6)=A(J+3)                                                     2658.000
      A(J+3)=COS(A(J+6)*1.745329E-2)                                    2659.000
      GO TO 120                                                         2660.000
C     ***** COSINES OF CELL ANGLES *****                                2661.000
  115 A(J+6)=ARCCOS(A(J+3))                                             2662.000
C     ***** STORE IDEMFACTOR MATRIX *****                               2663.000
  120 AID(J,J)=1.                                                       2664.000
      AID(J+1,1)=0.                                                     2665.000
      AID(J+5,1)=0.                                                     2666.000
C     ***** STORE METRIC TENSOR *****                                   2667.000
  125 AA(J,J)=A(J)**2                                                   2668.000
      AA(1,2)=A(1)*A(2)*A(6)                                            2669.000
      AA(1,3)=A(1)*A(3)*A(5)                                            2670.000
      AA(2,3)=A(2)*A(3)*A(4)                                            2671.000
      AA(2,1)=AA(1,2)                                                   2672.000
      AA(3,1)=AA(1,3)                                                   2673.000
      AA(3,2)=AA(2,3)                                                   2674.000
C     ***** INVERT METRIC TENSOR *****                                  2675.000
      CALL AXEQB(AA,BB,AID,3)                                           2676.000
C     ***** CALCULATE RECIPROCAL CELL PARAMETERS *****                  2677.000
      DO 128 J=1,3                                                      2678.000
  128 B(J)=SQRT(BB(J,J))                                                2679.000
      B(6)=BB(1,2)/(B(1)*B(2))                                          2680.000
      B(5)=BB(1,3)/(B(1)*B(3))                                          2681.000
      B(4)=BB(2,3)/(B(2)*B(3))                                          2682.000
      DO 130 J=1,3                                                      2683.000
  130 B(J+6)=ARCCOS(B(J+3))                                             2684.000
C     ***** WAS INPUT FOR REAL OR RECIPROCAL CELL *****                 2685.000
      IF(A(1)-1.)135,150,150                                            2686.000
  135 DO 140 J=1,9                                                      2687.000
      T1=AA(J,1)                                                        2688.000
      AA(J,1)=BB(J,1)                                                   2689.000
      BB(J,1)=T1                                                        2690.000
      T1=A(J)                                                           2691.000
      A(J)=B(J)                                                         2692.000
  140 B(J)=T1                                                           2693.000
C     ***** WRITE OUT CELL PARAMETERS *****                             2694.000
  143 FORMAT(1H010X,22HDIRECT CELL PARAMETERS/1H 15X,1HA14X,1HB14X,1HC142695.000
     1X,5HALPHA10X,4HBETA11X,5HGAMMA)                                   2696.000
  145 FORMAT(1H 10X,F9.6,2F15.6,3F15.3/1H 48X,6HCOSINEF12.8,2F15.8)     2697.000
  147 FORMAT(1H010X,26HRECIPROCAL CELL PARAMETERS/1H 15X,2HA*13X,2HB*13X2698.000
     1,2HC*13X,6HALPHA*9X,5HBETA*10X,6HGAMMA*)                          2699.000
  150 WRITE (NOUT,143)                                                  2700.000
      WRITE (NOUT,145)(A(I),I=1,3),(A(I),I=7,9),(A(I),I=4,6)            2701.000
      WRITE (NOUT,147)                                                  2702.000
      WRITE (NOUT,145)(B(I),I=1,3),(B(I),I=7,9),(B(I),I=4,6)            2703.000
C     ***** STORE STANDARD VECTORS *****                                2704.000
      CALL AXES(AID,AID(1,2),REFV,0)                                    2705.000
      CALL MM(AA,REFV,AAREV)                                            2706.000
      DO 160 I=1,3                                                      2707.000
      DO 160 J=1,3                                                      2708.000
      AAWRK(J,I)=AAREV(J,I)                                             2709.000
      Q(J,I)=REFV(I,J)                                                  2710.000
  160 WRKV(J,I)=REFV(J,I)                                               2711.000
C     ***** READ AND WRITE SYMMETRY TRANSFORMATIONS *****               2712.000
  171 FORMAT(1H010X,24HSYMMETRY TRANSFORMATIONS/1H 14X,3HNO.12X,13HTRANS2713.000
     1FORMED X18X,13HTRANSFORMED Y18X,13HTRANSFORMED Z)                 2714.000
C 173 FORMAT(I1,F14.10,3F3.0,2(F15.10,3F3.0))                           2715.000
  175 FORMAT(1H 13X,I2,3(F13.6,F4.0,2H XF4.0,2H YF4.0,2H Z))            2716.000
  177 FORMAT(1H110X,18A4)                                               2717.000
      WRITE (NOUT,171)                                                  2718.000
      LINES=14                                                          2719.000
      DO 190 I=1,NSYM                                                   2720.000
      LINES=MOD(LINES+1,56)                                             2721.000
         DO 522 J=1,3                                                   2722.000
         TS(J,I)=R(I,J,4)                                               2723.000
         DO 522 K=1,3                                                   2724.000
 522     FS(K,J,I)=R(I,J,K)                                             2725.000
      IF (LINES) 185,180,185                                            2726.000
  180 WRITE (NOUT,177)(TITLE(J),J=1,18)                                 2727.000
      WRITE (NOUT,171)                                                  2728.000
  185 WRITE (NOUT,175)I,(TS(J,I),(FS(K,J,I),K=1,3),J=1,3)               2729.000
C     ***** NON-CRYSTALLOGRAPHIC HELIX-SYMMETRY INPUT *****             2730.000
      IF(FS(3,3,I)-5.)190,186,186                                       2731.000
  186 T1=FS(1,3,I)/FS(3,3,I)                                            2732.000
      TS(3,I)=TS(3,I)+T1                                                2733.000
      T1=AMOD(T1*FS(2,3,I),1.)*6.28318531                               2734.000
      T2=COS(T1)                                                        2735.000
      T1=SIN(T1)                                                        2736.000
      DO 187 J=1,9                                                      2737.000
  187 VT(J,1)=AID(J,1)                                                  2738.000
      VT(1,1)=T2                                                        2739.000
      VT(2,2)=T2                                                        2740.000
      VT(2,1)=-T1                                                       2741.000
      VT(1,2)=T1                                                        2742.000
      CALL MM(VT,Q,PAC)                                                 2743.000
      CALL MM(AAREV,PAC,FS(1,1,I))                                      2744.000
  190 CONTINUE                                                          2745.000
      IF (ICENT.EQ.1) GO TO 531                                         2746.000
      I1=NSYM+1                                                         2747.000
      NSYM=2*NSYM                                                       2748.000
      DO 532 I=I1,NSYM                                                  2749.000
      DO 533 J=1,3                                                      2750.000
      TS(J,I)=-TS(J,I-I1+1)                                             2751.000
      DO 533 K=1,3                                                      2752.000
 533  FS(K,J,I)=-FS(K,J,I-I1+1)                                         2753.000
 532  WRITE (NOUT,175) I,(TS(J,I),(FS(K,J,I),K=1,3),J=1,3)              2754.000
 531  IF (ILATT.EQ.1)               GO TO 530                           2755.000
         DO 540 I=2,ILATT                                               2756.000
         DO 540 J=1,NSYM                                                2757.000
         I1=NSYM*(I-1)+J                                                2758.000
         DO 535 K=1,3                                                   2759.000
         TS(K,I1)=TS(K,J)+T(K,I)                                        2760.000
         DO 535 L=1,3                                                   2761.000
 535     FS(K,L,I1)=FS(K,L,J)                                           2762.000
 540  WRITE (NOUT,175) I1,(TS(L,I1),(FS(K,L,I1),K=1,3),L=1,3)           2763.000
         NSYM=ILATT*NSYM                                                2764.000
C     ***** POSITIONAL AND THERMAL PARAMETERS *****                     2765.000
  207 FORMAT(11H0 NO. ATOM 8X,1HX10X,1HY10X,1HZ13X,3HB118X,3HB228X,3HB332766.000
     18X,3HB128X,3HB138X,10HB23   TYPE)                                 2767.000
  209 FORMAT(1H I3,1X,A6,3F11.6,5X,6F11.6,F5.0)                         2768.000
  210 FORMAT(1H I3,1X,A6,3F11.6,5X,2F11.6,4F11.0,F5.0)                  2769.000
 530  LINES=LINES+2                                                     2770.000
      IF(LINES-56)220,215,215                                           2771.000
  215 LINES=-1                                                          2772.000
      GO TO 225                                                         2773.000
  220 WRITE (NOUT,207)                                                  2774.000
 225     K=1                                                            2775.000
      DO 245  I=1,NATOM                                                 2776.000
      LINES=MOD(LINES+1,56)                                             2777.000
      DO 9987 J=1,6                                                     2778.000
 9987 PA(J,1,I)=UIJ(J,I)                                                2779.000
      PA(7,1,I)=8.                                                      2780.000
      IF(PA(2,1,I).GT.0) GO TO 9990                                     2781.000
      PA(7,1,I)=0.                                                      2782.000
      PA(1,1,I)=PA(1,1,I)*ETPISQ                                        2783.000
 9990 CONTINUE                                                          2784.000
 507  IF (LINES) 230,230,232                                            2785.000
  230 WRITE (NOUT,177)(TITLE(J),J=1,18)                                 2786.000
      WRITE (NOUT,207)                                                  2787.000
  232 IF(PA(3,1,I)-10000.)235,234,234                                   2788.000
  234 WRITE (NOUT,210)I,CHEM(I),(P(J,I),J=1,3),(PA(J,1,I),J=1           2789.000
     1,7)                                                               2790.000
      GO TO 238                                                         2791.000
  235 WRITE (NOUT,209)I,CHEM(I),(P(J,I),J=1,3),(PA(J,1,I),J=1           2792.000
     1,7)                                                               2793.000
  238 GO TO (245,239,241,242,245),K                                     2794.000
C     ***** TYPE 1 POSITIONAL PARAMETERS (ANGSTROMS) *****              2795.000
  239 DO 240 J=1,3                                                      2796.000
  240 P(J,I)=P(J,I)/A(J)                                                2797.000
      GO TO 245                                                         2798.000
C     ***** TYPE 2 POSITIONAL PARAMETERS, STANDARD CARTESIAN *****      2799.000
  241 V1(1)=P(1,I)                                                      2800.000
      V1(2)=P(2,I)                                                      2801.000
      GO TO 243                                                         2802.000
C     ***** TYPE 3 POSITIONAL PARAMETERS *****                          2803.000
C     ***** CYLINDRICAL COORDINATES REFERRED TO STANDARD CARTESIAN *****2804.000
  242 T2=P(2,I)*.01745329252                                            2805.000
      V1(1)=V1(1)+P(1,I)*COS(T2)                                        2806.000
      V1(2)=V1(2)+P(1,I)*SIN(T2)                                        2807.000
  243 V1(3)=P(3,I)                                                      2808.000
      CALL VM(V1,Q,P(1,I))                                              2809.000
  245 CONTINUE                                                          2810.000
C     ***** CONVERT TEMP FACTOR COEF TO STANDARD TYPE ZERO *****        2811.000
      NG1=0                                                             2812.000
      DO 450 I=1,NATOM                                                  2813.000
      T1=PA(1,1,I)                                                      2814.000
      K=1.+PA(7,1,I)                                                    2815.000
      IF(T1)250,250,255                                                 2816.000
  250 T1=.1                                                             2817.000
      GO TO 405                                                         2818.000
  255 T6=.0506605918                                                    2819.000
      GO TO(270,260,265,265,270,260,400,405,270,260,270,450),K          2820.000
C     ***** TYPE 1 *****                                                2821.000
  260 DO 262 J=4,6                                                      2822.000
  262 PA(J,1,I)=PA(J,1,I)*.5                                            2823.000
      GO TO 270                                                         2824.000
C     ***** TYPES 2 AND 3 (BASE 2 SYSTEMS) *****                        2825.000
  265 T6=.351152464                                                     2826.000
      IF(K-4)270,260,270                                                2827.000
C     ***** TYPES 0 THROUGH 5 *****                                     2828.000
  270 IF(PA(2,1,I))400,400,272                                          2829.000
  272 DO 300 J=1,3                                                      2830.000
      DO 300 L=J,3                                                      2831.000
      T2=T6                                                             2832.000
      IF(K-5)285,275,275                                                2833.000
  275 IF(K-6)280,280,281                                                2834.000
C     ***** TYPES 4 AND 5 *****                                         2835.000
  280 T2=B(J)*B(L)*T2*.25                                               2836.000
      GO TO 285                                                         2837.000
C     ***** TYPES 8 AND 9 (U(I,J) TENSOR SYSTEMS) *****                 2838.000
  281 T2=B(J)*B(L)                                                      2839.000
      IF(K-11)285,282,282                                               2840.000
C     ***** TYPE 10, (CARTESIAN TENSOR SYSTEM) *****                    2841.000
  282 T2=1.0                                                            2842.000
  285 IF(J-L)290,287,290                                                2843.000
  287 VT(J,J)=T2*PA(J,1,I)                                              2844.000
      GO TO 300                                                         2845.000
  290 M=J+L+1                                                           2846.000
      VT(J,L)=T2*PA(M,1,I)                                              2847.000
      VT(L,J)=VT(J,L)                                                   2848.000
  300 CONTINUE                                                          2849.000
C     ***** FIND PRINCIPAL AXES *****                                   2850.000
      IF(K-11)310,305,305                                               2851.000
  305 CALL MM(VT,Q,PAC)                                                 2852.000
      CALL MM(REFV,PAC,VT)                                              2853.000
  310 CALL MM(VT,AA,DA)                                                 2854.000
      CALL EIGENV(DA,RMS,PAT)                    
C     ***** ARE EIGENVALUES POSITIVE *****                              2856.000
      IF(RMS(1))325,325,320                                             2857.000
  320 IF(NG)350,360,330                                                 2858.000
  325 NG=3                                                              2859.000
  330 NG1=1                                                             2860.000
      CALL ERPNT(FLOAT(I)*100000.+55501.,0)                             2861.000
C     ***** 3 EQUAL EIGENVALUES, USE REFERENCE VECTORS *****            2862.000
  340 T3=SIGN(SQRT(ABS(RMS(1)+RMS(2)+RMS(3))/3.),RMS(1))                2863.000
      DO 345 J=1,3                                                      2864.000
      DO 342 K=1,3                                                      2865.000
  342 PA(J,K,I)=REFV(J,K)                                               2866.000
  345 EV(J,I)=T3                                                        2867.000
      GO TO 450                                                         2868.000
  350 IF(NG+6)340,340,352                                               2869.000
C     ***** TWO EQUAL EIGENVALUES *****                                 2870.000
  352 N=NG+5                                                            2871.000
      CALL UNIT(PAT(1,N),V1,-1)                                         2872.000
      DO 354 K=1,3                                                      2873.000
      IF(ABS(VMV(V1,AA,REFV(1,K)))-.58)356,354,354                      2874.000
  354 CONTINUE                                                          2875.000
  356 CALL MM(AA,DA,VT)                                                 2876.000
      CALL AXES(V1,REFV(1,K),DA,-1)                                     2877.000
      DO 359 K=1,3                                                      2878.000
      L=MOD(N+K-2,3)+1                                                  2879.000
      DO 358 J=1,3                                                      2880.000
  358 PA(J,L,I)=DA(J,K)                                                 2881.000
  359 EV(L,I)=SIGN(SQRT(ABS(VMV(DA(1,K),VT,DA(1,K)))),RMS(L))           2882.000
      GO TO 450                                                         2883.000
C     ***** MAKE EIGENVECTORS 1 ANGSTROM LONG *****                     2884.000
  360 CALL AXES(PAT(1,1),PAT(1,3),PA(1,1,I),-1)                         2885.000
  370 NG=0                                                              2886.000
C     ***** SQRT EIGENVALUE = RMS DISPLACEMENT *****                    2887.000
      DO 375 J=1,3                                                      2888.000
      T2=RMS(J)                                                         2889.000
  375 EV(J,I)=SIGN(SQRT(ABS(T2)),T2)                                    2890.000
      GO TO 450                                                         2891.000
C     ***** TYPE 6 (ISOTROPIC TEMP FACTOR) *****                        2892.000
  400 T1=SQRT(T1*1.266515E-2)                                           2893.000
C     ***** TYPE 7 (DUMMY SPHERE) *****                                 2894.000
  405 DO 410 J=1,3                                                      2895.000
  410 EV(J,I)=T1                                                        2896.000
      IF(PA(3,1,I))430,430,415                                          2897.000
C     ***** DEFINED VECTORS FOR SPHERE *****                            2898.000
  415 DO 425 J=1,4                                                      2899.000
      T2=PA(J+2,1,I)                                                    2900.000
      CALL ATOM(T2,VT(1,J))                                             2901.000
      IF(NG)420,425,420                                                 2902.000
  420 CALL ERPNT(T2,0)                                                  2903.000
      GO TO 430                                                         2904.000
  425 CONTINUE                                                          2905.000
      CALL DIFV(VT(1,2),VT(1,1),V1)                                     2906.000
      CALL DIFV(VT(1,4),VT(1,3),V2)                                     2907.000
      CALL AXES(V1,V2,PA(1,1,I),-1)                                     2908.000
      GO TO 450                                                         2909.000
C     ***** REFERENCE VECTORS FOR SPHERE *****                          2910.000
  430 DO 435 J=1,9                                                      2911.000
  435 PA(J,1,I)=REFV(J,1)                                               2912.000
  450 NG=0                                                              2913.000
C     ***** WRITE OUT RMS VALUES *****                                  2914.000
      LINES=LINES+2                                                     2915.000
      IF(LINES-56)458,458,455                                           2916.000
  455 LINES=-1                                                          2917.000
      GO TO 460                                                         2918.000
  458 WRITE (NOUT,461)                                                  2919.000
  460 DO 465 I=1,NATOM                                                  2920.000
      LINES=MOD(LINES+1,56)                                             2921.000
      IF(LINES)465,462,465                                              2922.000
  461 FORMAT(10H0NO. ATOM 8X,1HX10X,1HY10X,1HZ13X,7HRMSD 1 4X,7HRMSD 2 42923.000
     1X,7HRMSD 3 )                                                      2924.000
  462 WRITE (NOUT,177)(TITLE(J),J=1,18)                                 2925.000
      WRITE (NOUT,461)                                                  2926.000
  463 FORMAT(1H I3,1X,A6,3F11.6)                                        2927.000
  465 WRITE (NOUT,209)I,CHEM(I),(P(J,I),J=1,3),(EV(J,I),J=1,3           2928.000
     1)                                                                 2929.000
      IF(NG1)999,999,470                                                2930.000
  470 STOP                                                              2931.000
  999 RETURN                                                            2932.000
      END                                                               2933.000
      SUBROUTINE PRIME                                                  2934.000
C     ****GENERAL INITIALIZATION OF PRIME PARAMETERS****                2935.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         2936.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         2937.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 2938.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      2939.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   2940.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   2941.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     2942.000
         CHARACTER COMPID(72)                                           2943.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                2944.000
         INTEGER CN(200),CONTNT(13)                                     2945.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                2946.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 2947.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   2948.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    2949.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      2950.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          2951.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       2952.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          2953.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   2954.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                2955.000
      BRDR=0.5                                                          2956.000
C     ****CALCULATE CONSTANTS****                                       2957.000
      DO 2999 I=1,5                                                     2958.000
 2999 CONT(I)=SQRT(1./(2.*(1.+COS(3.141593   /2.**I))))                 2959.000
      DISP=0.0                                                          2960.000
      FORE=1.0                                                          2961.000
      IN=5                                                              2962.000
      ITILT=0                                                           2963.000
      LATM=0                                                            2964.000
      NCD=0                                                             2965.000
      NG=0                                                              2966.000
      NOUT=9                                                            2967.000
      NSR=3                                                             2968.000
      RES(1)=1.25                                                       2969.000
      RES(2)=.5                                                         2970.000
      RES(3)=.2                                                         2971.000
      SCAL1=1.0                                                         2972.000
      SCAL2=1.54                                                        2973.000
      SCL=1.54                                                          2974.000
      DO 3000 I=1,3                                                     2975.000
      SYMB(I,I)=1.                                                      2976.000
      SYMB(I+1,1)=0.                                                    2977.000
 3000 SYMB(I+5,1)=0.                                                    2978.000
      TAPER=.375                                                        2979.000
      THETA=0.0                                                         2980.000
      VIEW=30.0                                                         2981.000
      XLNG(1)=17.0                                                      2982.000
      XLNG(2)=11.0                                                      2983.000
      XO(1)=8.5                                                         2984.000
      XO(2)=5.5                                                         2985.000
      DO 3001 J=1,3                                                     2986.000
 3001 ORGN(J) = 0.0                                                     2987.000
C     ***** INITIATE OVERLAP ROUTINES *****                             2988.000
      CALL LAP500(0)                                                    2989.000
      RETURN                                                            2990.000
      END                                                               2991.000
      SUBROUTINE RADIAL(ND)                                             2992.000
C     ***** GENERATE ELLIPSE FROM TWO CONJUGATE VECTORS *****           2993.000
C     ***** ORTHONORMAL VECTORS PRODUCE 8-128 SPOKED CIRCLE *****       2994.000
C     ***** ND DENOTES NUMBER OF SUBDIVISIONS (1 TO 5) *****            2995.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         2996.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         2997.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 2998.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      2999.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   3000.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   3001.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     3002.000
         CHARACTER COMPID(72)                                           3003.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                3004.000
         INTEGER CN(200),CONTNT(13)                                     3005.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                3006.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 3007.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   3008.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    3009.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      3010.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          3011.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       3012.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          3013.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   3014.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                3015.000
      DO 115 J=1,3                                                      3016.000
      T1=DA(J,1)                                                        3017.000
      D(J,1)=T1                                                         3018.000
      D(J,129)=T1                                                       3019.000
      D(J,65)=-T1                                                       3020.000
      T1=DA(J,2)                                                        3021.000
      D(J,33)=T1                                                        3022.000
  115 D(J,97)=-T1                                                       3023.000
      DO 135 K=1,ND                                                     3024.000
      T1=CONT(K)                                                        3025.000
      KDEL=2**(6-K)                                                     3026.000
      KDEL1=KDEL+1                                                      3027.000
      KDEL2=KDEL/2                                                      3028.000
      DO 135 L=KDEL1,65,KDEL                                            3029.000
      J=L-KDEL                                                          3030.000
      M=L-KDEL2                                                         3031.000
      DO 135 N=1,3                                                      3032.000
      T2=(D(N,L)+D(N,J))*T1                                             3033.000
      D(N,M)=T2                                                         3034.000
  135 D(N,M+64)=-T2                                                     3035.000
      RETURN                                                            3036.000
      END                                                               3037.000
      SUBROUTINE SCRIBE(Y,NPEN,LTNO)                                    3038.000
      DIMENSION Y(2),YO(2)                                              3039.000
C     ***** SUBROUTINE WHICH LINKS WITH THE PLOTTER-SPECIFIC SUBROUTINES3040.000
      IF(NPEN-3)210,205,205                                             3041.000
C     ***** KEEP TRACK OF COORDINATES FOR LAST PEN-UP LOCATION *****    3042.000
  205 YO(1)=Y(1)                                                        3043.000
      YO(2)=Y(2)                                                        3044.000
      NPO=0                                                             3045.000
      RETURN                                                            3046.000
  210 GO TO(245,230,215),LTNO+1                                         3047.000
C     ***** CALL MECHANICAL PLOTTER PLOTTING SUBROUTINE *****           3048.000
  215 IF(NPO)225,220,225                                                3049.000
  220 CALL PLOT(YO(1),YO(2),3)                                          3050.000
  225 CALL PLOT(Y(1),Y(2),2)                                            3051.000
      GO TO 245                                                         3052.000
C     ***** CALL CRT PLOTTING SUBROUTINE *****                          3053.000
  230 IF(NPO)240,235,240                                                3054.000
  235 CALL CRT(YO(1),YO(2),0,1)                                         3055.000
  240 CALL CRT(Y(1),Y(2),1,1)                                           3056.000
  245 NPO=1                                                             3057.000
      RETURN                                                            3058.000
      END                                                               3059.000
      SUBROUTINE SEARC                                                  3060.000
      DIMENSION NW(6),DX(3),S(2,200),U(3),V(3),W(2,4),WW(2,3),X(4),Y(3) 3061.000
      DIMENSION Z(3)                                                    3062.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         3063.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         3064.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 3065.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      3066.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   3067.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   3068.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     3069.000
         CHARACTER COMPID(72)                                           3070.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                3071.000
         INTEGER CN(200),CONTNT(13)                                     3072.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                3073.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 3074.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   3075.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    3076.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      3077.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          3078.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       3079.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          3080.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   3081.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                3082.000
      EQUIVALENCE(NW(1),LL),(NW(2),LU),(NW(3),ML)                       3083.000
      EQUIVALENCE(NW(4),MU),(NW(5),NL),(NW(6),NU)                       3084.000
C     ***** OBTAIN PROBLEM PARAMETERS *****                             3085.000
      WRITE (NOUT,20)                                                   3086.000
   20 FORMAT(1H0 9X,82H        FROM ATOMS    TO ATOMS     WITH RADIUS OR3087.000
     1, IF A BOX, WITH SEMIDIMENSIONS  /11X,46HCODE   (MIN  MAX)   (MIN 3088.000
     2 MAX)                7X,1HA8X,1HB8X,1HC)                          3089.000
      IF(AIN(1)-10000.)100,100,101                                      3090.000
  100 ITOM1=AIN(1)                                                      3091.000
      SYITOM=55501.                                                     3092.000
      GO TO 103                                                         3093.000
  101 ITOM1=AIN(1)/100000.                                              3094.000
      SYITOM=AMOD(AIN(1),100000.)                                       3095.000
  102 IF(ABS(AIN(2))-10000.)103,103,104                                 3096.000
  103 ITOM2 = ABS(AIN(2))                                               3097.000
      SYITO2=SYITOM                                                     3098.000
      GO TO 105                                                         3099.000
  104 ITOM2=ABS(AIN(2))/100000.                                         3100.000
      SYITO2=AMOD(ABS(AIN(2)),100000.)                                  3101.000
  105 ITAR1=AIN(3)                                                      3102.000
      IF(ITAR1)108,108,110                                              3103.000
  108 ITAR1=1                                                           3104.000
  110 ITAR2=AIN(4)                                                      3105.000
      DMAX=AIN(5)                                                       3106.000
      IF(DMAX)115,115,120                                               3107.000
  115 DMAX=4.                                                           3108.000
      AIN(5)=DMAX                                                       3109.000
  120 DMX=DMAX*DMAX                                                     3110.000
      TEM=.01                                                           3111.000
      KFUN=NJ*100+MOD(NJ2,10)                                           3112.000
      K=NJ*100+NJ2                                                      3113.000
      I0=SYITOM                                                         3114.000
      I02=SYITO2                                                        3115.000
      LATOM=LATM                                                        3116.000
  121 FORMAT(1H010X,2I3,I5,I4,I5,2I4,18X,3F9.3/1H )                     3117.000
      WRITE (NOUT,121)K,ITOM1,I0,ITOM2,I02,                             3118.000
     1ITAR1,ITAR2,(AIN(J),J=5,7)                                        3119.000
  124 FORMAT(1H 15X,2I5,I8,I5,2F9.3)                                    3120.000
      IF(NCD)130,130,125                                                3121.000
  125 WRITE (NOUT,124) ((KD(J,I),J=1,4),(CD(J,I),J=1,2) ,I=1,           3122.000
     1NCD)                                                              3123.000
  130 DO 135 J=1,4                                                      3124.000
      W(1,J)=99.                                                        3125.000
  135 W(2,J)=-99.                                                       3126.000
      DO 155 I=ITAR1,ITAR2                                              3127.000
      T1=FLOAT(I)*100000.                                               3128.000
      CALL ATOM(T1,X)                                                   3129.000
      IF(NG)140,145,140                                                 3130.000
  140 CALL ERPNT(T1,KFUN)                                               3131.000
      GO TO 600                                                         3132.000
  145 X(4)=X(1)-X(2)                                                    3133.000
      DO 155 J=1,4                                                      3134.000
      TEM=X(J)                                                          3135.000
      IF(W(2,J)-TEM)148,150,150                                         3136.000
  148 W(2,J)=TEM                                                        3137.000
  150 IF(TEM-W(1,J))152,155,155                                         3138.000
  152 W(1,J)=TEM                                                        3139.000
  155 CONTINUE                                                          3140.000
      KFUN2=MOD(KFUN,10)                                                3141.000
      GO TO (165,165,160,156,165,165),KFUN2                             3142.000
C     ***** FIND PARALLELEPIPED WHICH ENCLOSES TRICLINIC BOX *****      3143.000
  156 DO 158 J=1,3                                                      3144.000
  158 DX(J)=AIN(J+4)                                                    3145.000
      GO TO 170                                                         3146.000
C     ***** FIND PARALLELEPIPED WHICH ENCLOSES RECTANGULAR BOX *****    3147.000
  160 DO 162 J=1,3                                                      3148.000
      DX(J)=0.                                                          3149.000
      DO 162 I=1,3                                                      3150.000
  162 DX(J)=DX(J)+ABS(REFV(J,I)*AIN(I+4))                               3151.000
      GO TO 170                                                         3152.000
C     ***** FIND PARALLELEPIPED WHICH ENCLOSES DMAX SPHERE *****        3153.000
  165 T1=1.-A(4)*A(4)-A(5)*A(5)-A(6)*A(6)+2.*A(4)*A(5)*A(6)             3154.000
      DO 168 J=1,3                                                      3155.000
  168 DX(J)=SQRT((1.-A(J+3)**2)/T1)*DMAX/A(J)                           3156.000
C     ***** START SEARCH AROUND REFERENCE ATOMS *****                   3157.000
  170 LIST=0                                                            3158.000
      LAST=0                                                            3159.000
      M1=ITOM1                                                          3160.000
      N1=ITOM2                                                          3161.000
      IF(KFUN2-5)186,172,172                                            3162.000
C     ***** CONVOLUTE AND REITERATIVE CONVOLUTE INSTRUCTIONS *****      3163.000
  172 IF(LATM)174,174,176                                               3164.000
C     ***** FAULT, NO ENTRIES IN ATOMS LIST *****                       3165.000
  174 NG=12                                                             3166.000
      CALL ERPNT(0.,KFUN)                                               3167.000
      GO TO 600                                                         3168.000
C     ***** CHECK FOR REFERENCE ATOMS IN ATOMS LIST *****               3169.000
  176 IF(LATM-LAST)600,600,177                                          3170.000
  177 LIST=LAST                                                         3171.000
      LAST=LATM                                                         3172.000
  178 LIST=LIST+1                                                       3173.000
      IF(LAST-LIST)505,180,180                                          3174.000
  180 T1=ATOMS(1,LIST)                                                  3175.000
      ITOM=T1/100000.                                                   3176.000
      IF(ITOM-ITOM1)178,184,182                                         3177.000
  182 IF(ITOM2-ITOM)178,184,184                                         3178.000
  184 SYITOM=AMOD(T1,100000.)                                           3179.000
      SYITO2=SYITOM                                                     3180.000
      M1=ITOM                                                           3181.000
      N1=ITOM                                                           3182.000
C     ***** SET INITIAL RUN PARAMETERS *****                            3183.000
  186 M2=AMOD(SYITOM,100.)                                              3184.000
      M5=AMOD(SYITOM/100.,1000.)                                        3185.000
      M3=M5/100                                                         3186.000
      M4=MOD(M5/10,10)                                                  3187.000
      M5=MOD(M5,10)                                                     3188.000
C     ***** SET TERMINAL RUN PARAMETERS *****                           3189.000
      N2=AMOD(SYITO2,100.)                                              3190.000
      N5=AMOD(SYITO2/100.,1000.)                                        3191.000
      N3=N5/100                                                         3192.000
      N4=MOD(N5/10,10)                                                  3193.000
      N5=MOD(N5,10)                                                     3194.000
C     ***** START SEARCH AROUND REFERENCE ATOMS *****                   3195.000
      DO 500 L5=M5,N5                                                   3196.000
      DO 500 L4=M4,N4                                                   3197.000
      DO 500 L3=M3,N3                                                   3198.000
      DO 500 L2=M2,N2                                                   3199.000
      DO 500 ITOM=M1,N1                                                 3200.000
      T1=FLOAT(ITOM)*100000.+FLOAT(L3*10000+L4*1000+L5*100+L2)          3201.000
      CALL ATOM(T1,Y)                                                   3202.000
      IF(NG)188,190,188                                                 3203.000
  188 CALL ERPNT(T1,KFUN)                                               3204.000
      GO TO 500                                                         3205.000
C     ***** K=SYMMETRY EQUIVALENT POSITION *****                        3206.000
  190 NUM=0                                                             3207.000
      DO 400 K=1,NSYM                                                   3208.000
C     ***** SUBTRACT SYMMETRY TRANSLATION FROM REFERENCE ATOM *****     3209.000
      DO 192 J=1,3                                                      3210.000
  192 U(J)=Y(J)-TS(J,K)                                                 3211.000
C     ***** DETERMINE LIMITING CELLS TO BE SEARCHED *****               3212.000
C     ***** FIRST,MOVE THE BOX THROUGH THE SYMMETRY OPERATION *****     3213.000
      DO 200 J=1,3                                                      3214.000
      DO 200 L=1,2                                                      3215.000
      WW(L,J)=0.0                                                       3216.000
      DO 200 I=1,3                                                      3217.000
      TEM=FS(I,J,K)                                                     3218.000
      IF(TEM)194,200,196                                                3219.000
  194 N=MOD(L,2)+1                                                      3220.000
      GO TO 198                                                         3221.000
  196 N=L                                                               3222.000
  198 WW(L,J)=WW(L,J)+W(N,I)*TEM                                        3223.000
  200 CONTINUE                                                          3224.000
C     ***** CHECK FOR MIXED INDEX TRANSFORMATION *****                  3225.000
      DO 215 J=1,2                                                      3226.000
      TEM=FS(1,J,K)                                                     3227.000
      IF(TEM+FS(2,J,K))215,201,215                                      3228.000
  201 IF(TEM)203,215,207                                                3229.000
  203 WW(1,J)=W(2,4)*TEM                                                3230.000
      WW(2,J)=W(1,4)*TEM                                                3231.000
      GO TO 215                                                         3232.000
  207 WW(1,J)=W(1,4)*TEM                                                3233.000
      WW(2,J)=W(2,4)*TEM                                                3234.000
  215 CONTINUE                                                          3235.000
C     ***** MOVE 4 CELLS AWAY THEN MOVE BACK UNTIL PARALLELEPIPED AROUND3236.000
C         REF ATOM AND BOX AROUND TRANSFORMED ASYM UNIT INTERSECT ***** 3237.000
      N=0                                                               3238.000
      DO 235 J=1,3                                                      3239.000
      DO 225 I=1,2                                                      3240.000
      N=N+1                                                             3241.000
      TT=(U(J)-WW(I,J))*FLOAT(I*2-3)-DX(J)                              3242.000
      TEM=5.0                                                           3243.000
  221 TEM=TEM-1.0                                                       3244.000
      IF(TEM+TT)225,225,221                                             3245.000
  225 NW(N)=TEM*FLOAT(I*2-3)+5.                                         3246.000
C     ***** IF NO POSSIBILITY OF A HIT, GO TO NEXT SYMMETRY OPER *****  3247.000
      IF(NW(N)-NW(N-1))400,235,235                                      3248.000
  235 CONTINUE                                                          3249.000
      LL=NW(1)                                                          3250.000
      LU=NW(2)                                                          3251.000
      ML=NW(3)                                                          3252.000
      MU=NW(4)                                                          3253.000
      NL=NW(5)                                                          3254.000
      NU=NW(6)                                                          3255.000
C     ***** L CELL TRANSLATIONS IN X *****                              3256.000
      DO 395 L=LL,LU                                                    3257.000
      V(1)=U(1)+FLOAT(L-5)                                              3258.000
C     ***** M CELL TRANSLATIONS IN Y *****                              3259.000
      DO 395 M=ML,MU                                                    3260.000
      V(2)=U(2)+FLOAT(M-5)                                              3261.000
C     ***** N CELL TRANSLATIONS IN Z *****                              3262.000
      DO 395 NN=NL,NU                                                   3263.000
      V(3)=U(3)+FLOAT(NN-5)                                             3264.000
C     ***** I = TARGET ATOM *****                                       3265.000
      DO 395 I=ITAR1,ITAR2                                              3266.000
      DO 250 J=1,3                                                      3267.000
      TEM=0.0                                                           3268.000
      DO 245 II=1,3                                                     3269.000
  245 TEM=TEM+FS(II,J,K)*P(II,I)                                        3270.000
C     ***** SEE IF WITHIN PARALLELEPIPED*****                           3271.000
      TEM=TEM-V(J)                                                      3272.000
      IF(DX(J)-ABS(TEM))395,250,250                                     3273.000
  250 X(J)=TEM                                                          3274.000
      GO TO (255,255,252,277,255,255),KFUN2                             3275.000
C     ***** SEE IF WITHIN MODEL BOX *****                               3276.000
  252 CALL VM(X,AAREV,V1(2))                                            3277.000
      DO 253 J=2,4                                                      3278.000
      IF(AIN(J+3)-ABS(V1(J)))395,253,253                                3279.000
  253 CONTINUE                                                          3280.000
      GO TO 277                                                         3281.000
C     ***** SEE IF WITHIN SPHERE *****                                  3282.000
  255 DSQ=VMV(X,AA,X)                                                   3283.000
      IF(DMX-DSQ)395,256,256                                            3284.000
  256 IF(DSQ-.0001)258,260,260                                          3285.000
  258 IF(KFUN-402)395,260,260                                           3286.000
  260 TEM=SQRT(DSQ)                                                     3287.000
      IF(AIN(8))265,265,261                                             3288.000
C     *****SELECT ONLY FIRST ASYMMETRIC UNIT ENCOUNTERED *****          3289.000
  261 IF(LATM)265,265,262                                               3290.000
  262 ZMIN=FLOAT(I)*100000.                                             3291.000
      ZMAX=ZMIN+100000.                                                 3292.000
      DO 264 J=1,LATM                                                   3293.000
      ZSTO=ATOMS(1,J)                                                   3294.000
      IF(ZSTO-ZMIN)264,263,263                                          3295.000
  263 IF(ZMAX-ZSTO)264,264,395                                          3296.000
  264 CONTINUE                                                          3297.000
C     ***** SELECT VECTORS ACCORDING TO CODES IF ANY *****              3298.000
  265 IF(NCD)277,277,268                                                3299.000
  268 DO 275 J=1,NCD                                                    3300.000
  269 IF(ITOM-KD(1,J))275,270,270                                       3301.000
  270 IF(KD(2,J)-ITOM)275,271,271                                       3302.000
  271 IF(I-KD(3,J))   275,272,272                                       3303.000
  272 IF(KD(4,J)-I)   275,273,273                                       3304.000
  273 IF(TEM-CD(1,J)) 275,274,274                                       3305.000
  274 IF(CD(2,J)-TEM) 275,277,277                                       3306.000
  275 CONTINUE                                                          3307.000
      GO TO 395                                                         3308.000
  277 V1(1) = 100000.*FLOAT(I)+FLOAT((1110-L*100-M*10-NN)*100+K)        3309.000
      IF(KFUN-402)278,325,325                                           3310.000
C     ***** DETERMINE CORRECT POSITION IN SORTED VECTOR TABLE *****     3311.000
  278 IF(NUM)317,317,279                                                3312.000
  279 DO 315 II=1,NUM                                                   3313.000
      TT=S(2,II)-TEM                                                    3314.000
      IF(ABS(TT)-0.0001)297,297,281                                     3315.000
  281 IF(TT)315,297,283                                                 3316.000
C     ***** MOVE LONGER VECTORS TOWARD END OF TABLE *****               3317.000
  283 IF(200-NUM)287,287,289                                            3318.000
  287 NUM=199                                                           3319.000
  289 IJ=NUM                                                            3320.000
      DO 295 J=II,NUM                                                   3321.000
      S(1,IJ+1)=S(1,IJ)                                                 3322.000
      S(2,IJ+1)=S(2,IJ)                                                 3323.000
  295 IJ=IJ-1                                                           3324.000
      GO TO 319                                                         3325.000
C     ***** CHECK FOR DUPLICATE VECTORS IF DISTANCES ARE EQUAL *****    3326.000
  297 CALL ATOM(S(1,II),Z)                                              3327.000
      DO 305 J=1,3                                                      3328.000
      IF(ABS(X(J)+Y(J)-Z(J))-0.0001)305,305,315                         3329.000
  305 CONTINUE                                                          3330.000
      GO TO 395                                                         3331.000
  315 CONTINUE                                                          3332.000
      IF(200-NUM)320,320,317                                            3333.000
C     ***** STORE THE RESULT IN VECTOR TABLE *****                      3334.000
  317 II=NUM+1                                                          3335.000
  319 NUM=NUM+1                                                         3336.000
      S(1,II)=V1(1)                                                     3337.000
      S(2,II)=TEM                                                       3338.000
  320 IF(KFUN-106)395,325,325                                           3339.000
C     ***** STORE RESULT IN ATOMS TABLE *****                           3340.000
  325 DO 330 J=1,3                                                      3341.000
  330 V1(J+1)=X(J)+Y(J)                                                 3342.000
      CALL STOR                                                         3343.000
  395 CONTINUE                                                          3344.000
  400 CONTINUE                                                          3345.000
C     ***** PRINT OUT DISTANCES *****                                   3346.000
C 421 FORMAT(1H010X,20HVECTORS FROM ATOM  (I3,1H,I5,1H)6X,8HTO ATOMSI4, 3347.000
C    18H THROUGHI4)                                                     3348.000
      I0 = AMOD(T1,100000.)                                             3349.000
C     WRITE (NOUT,421)ITOM,I0,ITAR1,ITAR2                               3350.000
      IF(NUM)500,500,423                                                3351.000
  423 DO 435 I=1,NUM                                                    3352.000
      T2=S(1,I)                                                         3353.000
      I1=T2/100000.                                                     3354.000
      I2=T2-FLOAT(I1)*100000.                                           3355.000
      CALL ATOM(T2,Z)                                                   3356.000
      IF(I-1)432,432,434                                                3357.000
  427 FORMAT(1H 13X,2(A6,1X),39X,1H(I3,1H,I5,1H)3F7.4,7X,3HD =F6.3)     3358.000
  429 FORMAT(1H 13X,2(A6,1X),2(3H  (I3,1H,I5,1H)3F7.4,3X),4X,3HD =F6.3) 3359.000
  432 WRITE (NOUT,429)CHEM(ITOM),CHEM(I1),ITOM,I0,(Y(J),J=1,3           3360.000
     1),I1,I2,(Z(J),J=1,3),S(2,I)                                       3361.000
      GO TO 435                                                         3362.000
  434 WRITE (NOUT,427)CHEM(ITOM),CHEM(I1),I1,I2,(Z(J),J=1,3),           3363.000
     1S(2,I)                                                            3364.000
  435 CONTINUE                                                          3365.000
C     ***** CALCULATE ANGLES ABOUT REF ATOM IF CODE IS 102 *****        3366.000
  437 IF(KFUN-102)500,451,500                                           3367.000
  441 FORMAT(1H010X,18HANGLES AROUND ATOMI5)                            3368.000
  451 WRITE (NOUT,441)ITOM                                              3369.000
      L=NUM-1                                                           3370.000
      IF(L)500,500,457                                                  3371.000
  457 DO 465 I=1,L                                                      3372.000
      T2=S(1,I)                                                         3373.000
      T3=S(2,I)                                                         3374.000
      I1=T2/100000.                                                     3375.000
      I2=T2-FLOAT(I1)*100000.                                           3376.000
      CALL ATOM(T2,X)                                                   3377.000
      CALL DIFV(X,Y,U)                                                  3378.000
      CALL MV(AA,U,V2)                                                  3379.000
      M=I+1                                                             3380.000
      DO 465 J=M,NUM                                                    3381.000
      T4=S(1,J)                                                         3382.000
      J1=T4/100000.                                                     3383.000
      J2=T4-FLOAT(J1)*100000.                                           3384.000
      CALL ATOM(T4,Z)                                                   3385.000
      CALL DIFV(Z,Y,V)                                                  3386.000
      F=ARCCOS(VV(V,V2)/(T3*S(2,J)))                                    3387.000
      CALL DIFV(X,Z,V3)                                                 3388.000
      F1=SQRT(VMV(V3,AA,V3))                                            3389.000
  460 FORMAT(1H 13X,3(A6,1X),7X,3(2H (I3,1H,I5,1H)),12X,3HD =F6.3,7X,3HA3390.000
     1 =F6.2)                                                           3391.000
  465 WRITE (NOUT,460)CHEM(I1),CHEM(ITOM),CHEM(J1),I1,I2,ITOM           3392.000
     1,I0,J1,J2,F1,F                                                    3393.000
  495 CONTINUE                                                          3394.000
  500 CONTINUE                                                          3395.000
      IF(LAST-LIST)505,505,178                                          3396.000
  505 IF(KFUN2-6)600,176,600                                            3397.000
  600 IF(KFUN-106)610,605,610                                           3398.000
  605 LATM=LATOM                                                        3399.000
  610 RETURN                                                            3400.000
      END                                                               3401.000
      SUBROUTINE SPARE(INST)                                            3402.000
C     ***** INSTRUCTION 1201 PRODUCES PUNCHED CARDS WITH POSIT.+THERMAL 3403.000
C     ***** PARAMETERS FOR ATOMS PLACED IN THE ATOMS LIST BY THE 400    3404.000
C     ***** SERIES INSTRUCTIONS                                         3405.000
      REAL*8 CHM                                                        3406.000
         REAL INERT(3,3)                                                3407.000
      DIMENSION      AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)    3408.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),     CONT(5),D(3,130)    3409.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 3410.000
      DIMENSION                      PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) 3411.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   3412.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   3413.000
      DIMENSION XLNG(3),XO(3),XT(3),V(3,3)                              3414.000
         CHARACTER COMPID(72)                                           3415.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                3416.000
         INTEGER CN(200),CONTNT(13)                                     3417.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                3418.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 3419.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   3420.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    3421.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      3422.000
      COMMON NG,  AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,     CONT,D   3423.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,      NCD 3424.000
      COMMON NJ,NJ2,NOUT,NSR,     ORGN,     PAC,PAT,Q,REFV,RES,RMS,SCAL13425.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   3426.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                3427.000
C     ***** FIRST FIELD ON INSTRUCTION CARD = NO. OF POSITION PARAMETER 3428.000
C     ***** CARDS TO BE READ BY THIS SUBROUTINE (STANDARD ORFLS FORMAT) 3429.000
C     ***** THE SEQUENCE OF THESE CARDS NEED NOT BE IDENTICAL WITH      3430.000
C     ***** THE ORIGINAL INPUT ATOM DECK SEQUENCE                       3431.000
      IF (INST-1201) 100,105,400                                        3432.000
  100 NG = 9                                                            3433.000
      RETURN                                                            3434.000
  105 IF(AIN(1))100,100,115                                             3435.000
  115 LAST = AIN(1)                                                     3436.000
      DO 150 L=1,LAST                                                   3437.000
      READ (IN,116) CHM,V2(1),V2(2),(V1(J),J=1,4)                       3438.000
  116 FORMAT(A6,3X,6F9.6)                                               3439.000
      WRITE (NOUT,117) CHM,V2(1),V2(2),(V1(J),J=1,4)                    3440.000
  117 FORMAT(1H0,24X,25HOLD POSITION PARAMETERS  ,A6,4X,6F10.6)         3441.000
C     ***** FIND ATOM NUMBER *****                                      3442.000
      DO 125 IA=1,NATOM                                                 3443.000
      DO 120 J=1,3                                                      3444.000
      IF(ABS(V1(J)-P(J,IA))-0.001)120,120,125                           3445.000
  120 CONTINUE                                                          3446.000
      IX = IA                                                           3447.000
      GO TO 130                                                         3448.000
  125 CONTINUE                                                          3449.000
      GO TO 150                                                         3450.000
C     ***** SEARCH ATOMS LIST FOR ENTRIES WITH ATOM NUMBER IX *****     3451.000
  130 IF(LATM)150,150,131                                               3452.000
  131 DO 145 IB=1,LATM                                                  3453.000
      T1 = ATOMS(1,IB)                                                  3454.000
      IF(IX-INT(T1/100000.))145,135,145                                 3455.000
  135 CALL ATOM(T1,V1)                                                  3456.000
      WRITE (NOUT,136) T1,CHM,V2(1),V2(2),(V1(J),J=1,4)                 3457.000
  136 FORMAT(1H0,9X,F10.0,5X,25HNEW POSITION PARAMETERS  ,A6,4X,6F10.6) 3458.000
      I1 = T1                                                           3459.000
C      PUNCH 137, CHM,V2(1),V2(2),(V1(J),J=1,4),I1                 
  137 FORMAT(A6,3X,6F9.6,9X,I8)                                         3461.000
      CALL PAXES(T1,-1)                                                 3462.000
      DO 140 I=1,3                                                      3463.000
      DO 140 J=1,3                                                      3464.000
  140 Q(J,I) = Q(J,I) /.0506605918                                      3465.000
      WRITE (NOUT,141) Q(1,1),Q(2,2),Q(3,3),Q(1,2),Q(1,3),Q(2,3)        3466.000
  141 FORMAT(1H ,24X,25HNEW THERMAL PARAMETERS   ,6F10.6)               3467.000
C      PUNCH 142, Q(1,1),Q(2,2),Q(3,3),Q(1,2),Q(1,3),Q(2,3),I1   
  142 FORMAT(6F9.6,18X,I8)                                              3469.000
  145 CONTINUE                                                          3470.000
  150 CONTINUE                                                          3471.000
  300 RETURN                                                            3472.000
 400     IF (INST.EQ.1202) GO TO 402                                    3473.000
         DO 6 I=1,3                                                     3474.000
         V2(I)=0.                                                       3475.000
         DO 6 J=1,3                                                     3476.000
 6       INERT(I,J)=0.                                                  3477.000
         DO 7 I=1,LATM                                                  3478.000
         CALL XYZ(ATOMS(1,I),ATOMS(2,I),2)                              3479.000
         DO 7 J=1,3                                                     3480.000
 7       V2(J)=V2(J)+ATOMS(J+1,I)                                       3481.000
         DO 8 J=1,3                                                     3482.000
 8       V2(J)=V2(J)/(LATM*SCAL1)                                       3483.000
         DO 9 J=1,LATM                                                  3484.000
         DO 9 I=1,3                                                     3485.000
         DO 9 K=1,3                                                     3486.000
 9       INERT(I,K)=INERT(I,K)+(ATOMS(I+1,J)/SCAL1-V2(I))*              3487.000
     1   (ATOMS(K+1,J)/SCAL1-V2(K))                                     3488.000
         CALL EIGENV(INERT,V3,V)                    
         DO 10 I=1,3                                                    3490.000
         DO 10 J=I,3                                                    3491.000
         IF (V3(I).GE.V3(J)) GO TO 10                                   3492.000
         T1=V3(I)                                                       3493.000
         V3(I)=V3(J)                                                    3494.000
         V3(J)=T1                                                       3495.000
         DO 11 K=1,3                                                    3496.000
         T1=V(K,I)                                                      3497.000
         V(K,I)=V(K,J)                                                  3498.000
 11      V(K,J)=T1                                                      3499.000
 10      CONTINUE                                                       3500.000
         DET=V(1,1)*(V(2,2)*V(3,3)-V(2,3)*V(3,2))                       3501.000
     1-V(1,2)*(V(2,1)*V(3,3)-V(2,3)*V(3,1))                             3502.000
     2+V(1,3)*(V(2,1)*V(3,2)-V(2,2)*V(3,1))                             3503.000
         IF (DET.GE.0.) GO TO 403                                       3504.000
         DO 404 I=1,3                                                   3505.000
 404     V(I,3)=-V(I,3)                                                 3506.000
 403     CALL AXEQB(AAWRK,INERT,AID,3)                                  3507.000
         CALL VM(V2,INERT,ORGN)                                         3508.000
         CALL  MM(AAWRK,V,INERT)                                        3509.000
         CALL MM(AID,INERT,AAREV)                                       3510.000
         CALL  MM(AID,INERT,AAWRK)                                      3511.000
         CALL AXEQB(AAREV,INERT,AID,3)                                  3512.000
         CALL TMM(AID,INERT,REFV)                                       3513.000
         CALL AXEQB(AAWRK,INERT,AID,3)                                  3514.000
         CALL TMM(AID,INERT,WRKV)                                       3515.000
         RETURN                                                         3516.000
 402  IFIRST=AIN(1)                                                     3517.000
      LAST=AIN(2)                                                       3518.000
      IF (AIN(3).EQ.0.) AIN(3)=0.1                                      3519.000
      DO 401 I=IFIRST,LAST                                              3520.000
      DO 401 J=1,3                                                      3521.000
 401  EV(J,I)=AIN(3)                                                    3522.000
      RETURN                                                            3523.000
      END                                                               3524.000
      SUBROUTINE STOR                                                   3525.000
C     ***** STORE IN OR REMOVE FROM ATOMS ARRAY *****                   3526.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         3527.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         3528.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 3529.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      3530.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   3531.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   3532.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     3533.000
         CHARACTER COMPID(72)                                           3534.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                3535.000
         INTEGER CN(200),CONTNT(13)                                     3536.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                3537.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 3538.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   3539.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    3540.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      3541.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          3542.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       3543.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          3544.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   3545.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                3546.000
      IF(LATM)481,481,450                                               3547.000
  450 IF(1000-LATM)455,455,460                                          3548.000
  455 IF(NJ2-10)490,490,460                                             3549.000
  460 L=LATM                                                            3550.000
C     ***** CHECK FOR POSITIONAL DUPLICATION *****                      3551.000
      DO 480 K=1,L                                                      3552.000
      DO 465 J=2,4                                                      3553.000
      IF(ABS(V1(J)-ATOMS(J,K))-0.001)465,465,480                        3554.000
  465 CONTINUE                                                          3555.000
      IF(NJ2-10)490,490,470                                             3556.000
C     ***** ATOM REMOVAL BY TABLE PUSHDOWN *****                        3557.000
  470 LATM=LATM-1                                                       3558.000
      DO 475 I=K,LATM                                                   3559.000
      DO 475 J=1,4                                                      3560.000
  475 ATOMS(J,I)=ATOMS(J,I+1)                                           3561.000
      GO TO 490                                                         3562.000
  480 CONTINUE                                                          3563.000
  481 IF(NJ2-10)482,490,490                                             3564.000
C     ***** STORE ATOM *****                                            3565.000
  482 IF(999-LATM)490,483,485                                           3566.000
  483 NG=16                                                             3567.000
      CALL ERPNT (V1(1),400)                                            3568.000
  485 LATM=LATM+1                                                       3569.000
      DO 486 J=1,4                                                      3570.000
  486 ATOMS(J,LATM)=V1(J)                                               3571.000
  490 RETURN                                                            3572.000
      END                                                               3573.000
      SUBROUTINE TMM(X,Y,Z)                                             3574.000
C     ***** TRANSPOSE(TRANSPOSE(X)*Y)=Z *****                           3575.000
C     ***** X,Y,Z ARE 3X3 MATRICES *****                                3576.000
      DIMENSION X(3,3),Y(3,3),Z(3,3)                                    3577.000
      DO 115 I=1,3                                                      3578.000
      DO 115 K=1,3                                                      3579.000
  115 Z(K,I)=X(1,I)*Y(1,K)+X(2,I)*Y(2,K)+X(3,I)*Y(3,K)                  3580.000
      RETURN                                                            3581.000
      END                                                               3582.000
      SUBROUTINE UNIT(X,Z,ITYPE)                                        3583.000
      DIMENSION X(3),Y(3),Z(3)                                          3584.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         3585.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         3586.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 3587.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      3588.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   3589.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   3590.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     3591.000
         CHARACTER COMPID(72)                                           3592.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                3593.000
         INTEGER CN(200),CONTNT(13)                                     3594.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                3595.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 3596.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   3597.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    3598.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      3599.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          3600.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       3601.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          3602.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   3603.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                3604.000
      Y(1)=X(1)                                                         3605.000
      Y(2)=X(2)                                                         3606.000
      Y(3)=X(3)                                                         3607.000
      IF(ITYPE)125,125,105                                              3608.000
  105 T1=SQRT(Y(1)*Y(1)+Y(2)*Y(2)+Y(3)*Y(3))                            3609.000
      GO TO 145                                                         3610.000
  125 T1=SQRT(Y(1)*(Y(1)*AA(1,1)+Y(2)*(AA(1,2)+AA(2,1))+Y(3)*(AA(1,3)+A 3611.000
     1A(3,1)))+Y(2)*(Y(2)*AA(2,2)+Y(3)*(AA(2,3)+AA(3,2)))+Y(3)*Y(3)*AA(33612.000
     2,3))                                                              3613.000
  145 IF(T1)155,155,175                                                 3614.000
  155 NG=5                                                              3615.000
      GO TO 300                                                         3616.000
  175 Z(1)=Y(1)/T1                                                      3617.000
      Z(2)=Y(2)/T1                                                      3618.000
      Z(3)=Y(3)/T1                                                      3619.000
  300 RETURN                                                            3620.000
      END                                                               3621.000
      SUBROUTINE VM(X,Y,Z)                                              3622.000
C     TRANSPOSED VECTOR TIMES MATRIX                                    3623.000
C     Z(3)=X(3)*Y(3,3)                                                  3624.000
      DIMENSION X(3),Y(3,3),Z(3)                                        3625.000
      DO 115 J=1,3                                                      3626.000
      Z(J)=0.0                                                          3627.000
      DO 115 I=1,3                                                      3628.000
  115 Z(J)=Z(J)+X(I)*Y(I,J)                                             3629.000
      RETURN                                                            3630.000
      END                                                               3631.000
      FUNCTION VMV(X1,Q,X2)                                             3632.000
C     TRANSPOSED VECTOR * MATRIX * VECTOR                               3633.000
C     VMV=X1(3)*Q(3,3)*X2(3)    TO  EVALUATE QUADRATIC OR BILINEAR FORM 3634.000
      DIMENSION X1(3),Q(3,3),X2(3)                                      3635.000
      T1=0.                                                             3636.000
      DO 10 J=1,3                                                       3637.000
   10 T1=T1+X1(J)*(X2(1)*Q(J,1)+X2(2)*Q(J,2)+X2(3)*Q(J,3))              3638.000
      VMV=T1                                                            3639.000
      RETURN                                                            3640.000
      END                                                               3641.000
      FUNCTION VV(X,Y)                                                  3642.000
C     TRANSPOSED VECTOR * VECTOR                                        3643.000
C     VV=X(3)*Y(3)                                                      3644.000
      DIMENSION X(3),Y(3)                                               3645.000
      VV=X(1)*Y(1)+X(2)*Y(2)+X(3)*Y(3)                                  3646.000
      RETURN                                                            3647.000
      END                                                               3648.000
      SUBROUTINE XYZ(QA,X,ITYPE)                                        3649.000
C     ***** ITYPE .GT.0 CART. COORD. FROM ATOM CODE WORD *****          3650.000
C     ***** XABSF(ITYPE) .LE.2 FOR WORKING SYSTEM *****                 3651.000
C     ***** XABSF(ITYPE) .GT.2 FOR REFERENCE SYSTEM *****               3652.000
C     ***** ITYPE .LE.0 USES TRICLINIC COORD. XT *****                  3653.000
      DIMENSION X(3)                                                    3654.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         3655.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         3656.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 3657.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      3658.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   3659.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   3660.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     3661.000
         CHARACTER COMPID(72)                                           3662.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                3663.000
         INTEGER CN(200),CONTNT(13)                                     3664.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                3665.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 3666.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   3667.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    3668.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      3669.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          3670.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       3671.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          3672.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   3673.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                3674.000
      IT=IABS(ITYPE)-2                                                  3675.000
      NG1=NG                                                            3676.000
      NG=0                                                              3677.000
      IF(ITYPE)10,10,5                                                  3678.000
    5 CALL ATOM(QA,XT)                                                  3679.000
      IF(NG)30,10,30                                                    3680.000
   10 T1=0.                                                             3681.000
      DO 15 J=1,3                                                       3682.000
      T2=XT(J)-ORGN(J)                                                  3683.000
      V1(J)=T2                                                          3684.000
   15 T1=T1+ABS(T2)                                                     3685.000
      IF(T1-.0001)20,20,40                                              3686.000
   20 NG=NG1                                                            3687.000
   30 DO 35 J=1,3                                                       3688.000
   35 X(J)=0.                                                           3689.000
      GO TO 300                                                         3690.000
   40 IF(IT)45,45,60                                                    3691.000
C     ***** RELATIVE TO WORKING SYSTEM *****                            3692.000
   45 DO 55 I=1,3                                                       3693.000
      T1=0.                                                             3694.000
      DO 50 J=1,3                                                       3695.000
   50 T1=T1+V1(J)*AAWRK(J,I)                                            3696.000
   55 X(I)=T1*SCAL1                                                     3697.000
      GO TO 300                                                         3698.000
C     ***** RELATIVE TO REFERENCE SYSTEM *****                          3699.000
   60 DO 70 I=1,3                                                       3700.000
      T1=0.                                                             3701.000
      DO 65 J=1,3                                                       3702.000
   65 T1=T1+V1(J)*AAREV(J,I)                                            3703.000
   70 X(I)=T1*SCAL1                                                     3704.000
  300 RETURN                                                            3705.000
      END                                                               3706.000
      SUBROUTINE LAP500(NTYPE)                                          3707.000
C     ***** STORE PROJECTED ATOM CONICS AND BOND QUADRANGLES *****      3708.000
      DIMENSION QC(3,3),QD(3,3),VD1(3),VD2(3)                           3709.000
C     ***** DOUBLE PRECISION FOR VERY SMALL ATOMS AND SHORT WORDLENGTH *3710.000
C     ***** IN GENERAL, DOUBLE PRECISION IS NOT REQUIRED *****          3711.000
      REAL*8 QC,QD,VD1,VD2,TD1,TD2,TD3                                  3712.000
C     ***** JUST REMOVE THE PRECEEDING REAL*8 CARD TO MAKE SINGLE PREC  3713.000
      COMMON/OLAP/CONIC(7,1000),COVER(6,20),KC(20),KQ(30),NCONIC,NCOVER,3714.000
     1 NQOVER,NQUAD,OVMRGN,QOVER(3,4,30),QUAD(9,600),SEGM(50,2)         3715.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         3716.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         3717.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 3718.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      3719.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   3720.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   3721.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     3722.000
         CHARACTER COMPID(72)                                           3723.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                3724.000
         INTEGER CN(200),CONTNT(13)                                     3725.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                3726.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPP,     NFTYPE(200),P(3,200), 3727.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   3728.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    3729.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      3730.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          3731.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       3732.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          3733.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   3734.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                3735.000
C     ***** ELIMINATE ALL PREVIOUSLY STORED LOCAL OVERLAP INFORMATION **3736.000
      NCOVER=0                                                          3737.000
      NQOVER=0                                                          3738.000
      IF(NTYPE)420,195,195                                              3739.000
C     ***** ELIMINATE ALL PREVIOUSLY STORED GLOBAL OVERLAP INFORMATION *3740.000
  195 NCONIC=0                                                          3741.000
      NQUAD=0                                                           3742.000
      IF(NTYPE)420,420,200                                              3743.000
C     ***** CONSTANT FOR OVERLAP MARGIN (WHITE MARGIN AT OVERLAP) ***** 3744.000
  200 IF(AIN(1))205,215,210                                             3745.000
C     ***** NEGATIVE NUMBER OR POSITIVE INTEGER GIVES OVMRGN=0.0 *****  3746.000
  205 OVMRGN=0.0                                                        3747.000
      GO TO 220                                                         3748.000
C     ***** SET OVERLAP MARGIN WIDTH DIRECTLY IN INCHES *****           3749.000
  210 OVMRGN=AIN(1)-AINT(AIN(1))                                        3750.000
      GO TO 220                                                         3751.000
C      ***** DEFAULT OPTION, OVERLAP MARGIN WIDTH AS A FUNCTION OF SCAL13752.000
  215 OVMRGN=AMAX1(SQRT(SCAL1)*0.030,0.025)                             3753.000
  220 WRITE (NOUT,2) OVMRGN                                             3754.000
    2 FORMAT(1H0,10X,17HOVERLAP MARGIN IS, F6.3,5H INCH)                3755.000
  225 IF(LATM)230,230,235                                               3756.000
  230 NG=12                                                             3757.000
      CALL ERPNT(0.,510+NJ2)                                            3758.000
      GO TO 420                                                         3759.000
C     ***** SORT ATOMS LIST BY -VIEWDISTANCE OR BY Z PARAMETER          3760.000
  235 IF(VIEW)250,250,240                                               3761.000
C     ***** CALCULATE VIEWDISTANCES**2 *(-1) IF VIEW.GT.ZERO *****      3762.000
  240 DO 245 I=1,LATM                                                   3763.000
      CALL XYZ(ATOMS(1,I),V3,2)                                         3764.000
      V3(3)=V3(3)-VIEW                                                  3765.000
  245 ATOMS(4,I)=-VV(V3,V3)                                             3766.000
      GO TO 260                                                         3767.000
C     ***** STORE CARTESIAN COORDINATES IF VIEW.EQ.ZERO *****           3768.000
  250 DO 255 I=1,LATM                                                   3769.000
  255 CALL XYZ(ATOMS(1,I),ATOMS(2,I),2)                                 3770.000
C     ***** SORTING PROCEDURE BY SHELL, COMM ACM 2,30 (1959) *****      3771.000
  260 M=LATM                                                            3772.000
  265 M=M/2                                                             3773.000
      IF(M)300,300,270                                                  3774.000
  270 K=LATM-M                                                          3775.000
      J=1                                                               3776.000
  275 I=J                                                               3777.000
  280 IM=I+M                                                            3778.000
      IF(ATOMS(4,I)-ATOMS(4,IM))295,295,285                             3779.000
  285 DO 290 L=1,4,3                                                    3780.000
      T1=ATOMS(L,I)                                                     3781.000
      ATOMS(L,I)=ATOMS(L,IM)                                            3782.000
  290 ATOMS(L,IM)=T1                                                    3783.000
      I=I-M                                                             3784.000
      IF(I)295,295,280                                                  3785.000
  295 J=J+1                                                             3786.000
      IF(J-K)275,275,265                                                3787.000
C     ***** LOOP THROUGH ALL ATOMS IN SORTED ATOMS LIST *****           3788.000
  300 DO 405 IA=1,LATM                                                  3789.000
      CALL XYZ(ATOMS(1,IA),ATOMS(2,IA),2)                               3790.000
      CALL PAXES(ATOMS(1,IA),2)                                         3791.000
      DO 305 J=1,3                                                      3792.000
      V1(J)=ATOMS(J+1,IA)                                               3793.000
      VD1(J)=V1(J)                                                      3794.000
      DO 305 K=1,3                                                      3795.000
  305 QD(J,K)=Q(J,K)                                                    3796.000
      IF(VIEW)340,340,310                                               3797.000
C     ***** CALCULATE ENVELOPING CONE WITH ORIGIN AT VIEWPOINT *****    3798.000
  310 V1(3)=V1(3)-VIEW                                                  3799.000
      VD1(3)=V1(3)                                                      3800.000
C     ***** FORM COFACTOR MATRIX *****                                  3801.000
      DO 315 J=1,3                                                      3802.000
      J1=MOD(J,3)+1                                                     3803.000
      J2=MOD(J+1,3)+1                                                   3804.000
      DO 315 K=J,3                                                      3805.000
      K1=MOD(K,3)+1                                                     3806.000
      K2=MOD(K+1,3)+1                                                   3807.000
      QC(J,K)= QD(J1,K1)*QD(J2,K2)-QD(J1,K2)*QD(J2,K1)                  3808.000
  315 QC(K,J)=QC(J,K)                                                   3809.000
C     ***** FORM POLARIZED COFACTOR MATRIX AND ADD TO ELLIPSOID MATRIX *3810.000
      TD2=-SCL**2                                                       3811.000
C     ***** TD1 IS AN ARBITRARY SCALING FACTOR *****                    3812.000
      TD1=VMV(V1,Q,V1)                                                  3813.000
      DO 325 J=1,3                                                      3814.000
      J1=MOD(J,3)+1                                                     3815.000
      J2=MOD(J+1,3)+1                                                   3816.000
      DO 320 K=J,3                                                      3817.000
      K1=MOD(K,3)+1                                                     3818.000
      K2=MOD(K+1,3)+1                                                   3819.000
      QD(J,K)=((VD1(J2)*(QC(J1,K1)*VD1(K2)-QC(J1,K2)*VD1(K1))           3820.000
     1 +VD1(J1)*(VD1(K1)*QC(J2,K2)-VD1(K2)*QC(J2,K1)))+TD2*QD(J,K))/TD1 3821.000
  320 QD(K,J)=QD(J,K)                                                   3822.000
C     ***** PROJECTED ELLIPSE IN HOMOGENEOUS COORD OF WORKING SYSTEM ***3823.000
      QD(J,3)=-QD(J,3)*VIEW                                             3824.000
  325 QD(3,J)=-QD(3,J)*VIEW                                             3825.000
C     ***** PROJECT CENTER OF ATOM ONTO PROJECTION PLANE *****          3826.000
      TD1=-VIEW/VD1(3)                                                  3827.000
      VD2(1)=VD1(1)*TD1                                                 3828.000
      VD2(2)=VD1(2)*TD1                                                 3829.000
C     ***** TRANSFORM TO NEW ORIGIN TO IMPROVE CONDITION OF MATRIX Q ***3830.000
      DO 330 J=1,3                                                      3831.000
      DO 330 K=1,2                                                      3832.000
  330 QD(J,3)=QD(J,3)+QD(J,K)*VD2(K)                                    3833.000
      DO 335 J=1,3                                                      3834.000
      DO 335 K=1,2                                                      3835.000
  335 QD(3,J)=QD(3,J)+VD2(K)*QD(K,J)                                    3836.000
      V6(1)=XO(1)+VD2(1)                                                3837.000
      V6(2)=XO(2)+VD2(2)                                                3838.000
      GO TO 355                                                         3839.000
C     ***** CALCULATE ENVELOPING CYLINDER ALONG Z OF WORKING SYSTEM ****3840.000
  340 DO 345 J=1,2                                                      3841.000
      DO 345 K=1,2                                                      3842.000
  345 QD(J,K)=QD(J,K)-QD(J,3)*QD(K,3)/QD(3,3)                           3843.000
      DO 350 J=1,2                                                      3844.000
      QD(J,3)=0.0                                                       3845.000
      QD(3,J)=0.0                                                       3846.000
  350 V6(J)=XO(J)+ATOMS(J+1,IA)                                         3847.000
C     ***** PROJECTED ELLIPSE IN HOMOGENEOUS COORD ABOUT CENTER OF ATOM 3848.000
      QD(3,3)=-SCL**2                                                   3849.000
C     ***** FIT RECTANGLE AROUND ELLIPSE ALLOWING OVERLAP MARGIN *****  3850.000
C     ***** FORM MATRIX OF COFACTORS *****                              3851.000
  355 DO 360 J=1,3                                                      3852.000
      J1=MOD(J,3)+1                                                     3853.000
      J2=MOD(J+1,3)+1                                                   3854.000
      DO 360 K=J,3                                                      3855.000
      K1=MOD(K,3)+1                                                     3856.000
      K2=MOD(K+1,3)+1                                                   3857.000
  360 QC(J,K)= QD(J1,K1)*QD(J2,K2)-QD(J1,K2)*QD(J2,K1)                  3858.000
C     ***** RESCALE MATRIX OF COFACTORS SO THAT QC(3,3)=1.0 *****       3859.000
      DO 365 J=1,3                                                      3860.000
      DO 365 K=J,3                                                      3861.000
      QC(J,K)= QC(J,K)/QC(3,3)                                          3862.000
  365 QC(K,J)=QC(J,K)                                                   3863.000
      TD2=QD(3,3)                                                       3864.000
      NDG=0                                                             3865.000
      DO 385 J=1,2                                                      3866.000
C     ***** SOLVE QUADRATIC EQUATION *****                              3867.000
      T1 =QC(3,J)**2-QC(J,J)                                            3868.000
      IF(T1)370,370,375                                                 3869.000
C     ***** ROUNDOFF PROBLEMS, RESET LIMITS IN X OR Y *****             3870.000
  370 NDG=1                                                             3871.000
      V5(J)=0.001+OVMRGN                                                3872.000
      GO TO 380                                                         3873.000
  375 V5(J)=  SQRT(T1)+OVMRGN                                           3874.000
      V6(J)=V6(J)+QC(3,J)                                               3875.000
      TD2=TD2+QD(3,J)*QC(3,J)                                           3876.000
  380 CONIC(2*J-1,IA)=V6(J)-V5(J)                                       3877.000
  385 CONIC(2*J,IA)=V6(J)+V5(J)                                         3878.000
      IF(NDG)390,390,395                                                3879.000
  390 IF(TD2)400,395,395                                                3880.000
C     ***** ELLIPSE IMAGINARY DUE TO ROUNDOFF, RESET TO REAL VALUE *****3881.000
  395 CONIC(5,IA)=1.0/((CONIC(2,IA)-CONIC(1,IA))*0.5)**2                3882.000
      CONIC(6,IA)=0.0                                                   3883.000
      CONIC(7,IA)=1.0/((CONIC(4,IA)-CONIC(3,IA))*0.5)**2                3884.000
      GO TO 405                                                         3885.000
C     ***** STORE NORMALIZED QUADRATIC COEFFICIENTS FOR ELLIPSE *****   3886.000
C     ***** SCALED BY OVERLAP MARGIN PARAMETER *****                    3887.000
  400 TD3= -(1.0-2.0*OVMRGN/(V5(1)+V5(2)))**2 /TD2                      3888.000
      CONIC(5,IA)=QD(1,1)*TD3                                           3889.000
      CONIC(6,IA)=QD(1,2)*TD3                                           3890.000
      CONIC(7,IA)=QD(2,2)*TD3                                           3891.000
  405 CONTINUE                                                          3892.000
      NCONIC=LATM                                                       3893.000
C     ***** PRINT OUT SORTED ATOMS ARRAY *****                          3894.000
      WRITE (NOUT,4)(ATOMS(1,J),J=1,LATM)                               3895.000
    4 FORMAT(1H0,10X,30HCONTENTS OF SORTED ATOMS ARRAY/(15X,10F10.0))   3896.000
C     ***** STORE BOND QUADRANGLES IF SEARCH CODES ARE GIVEN *****      3897.000
      IF(NCD)420,420,410                                                3898.000
C     ***** GENERATE PSEUDO-INSTRUCTION 822 TO CALCULATE BONDS *****    3899.000
  410 NJ2=22                                                            3900.000
      CALL F800                                                         3901.000
      IF(NQUAD)420,420,415                                              3902.000
C     ***** PRINT OUT NUMBER OF BOND QUADRANGLES STORED *****           3903.000
C     ***** PRINT OUT QUADRANGLE IDENTIFICATION ARRAY *****             3904.000
  415 WRITE (NOUT,6)NQUAD,(QUAD(9,J),J=1,NQUAD)                         3905.000
    6 FORMAT(1H0,10X,27HBOND OVERLAP ARRAY CONTAINS,I4,23H BONDS (MAXIMU3906.000
     1M IS 599)/  11X,  66HATOM-PAIR NUMBERS IN ARRAY REFER TO SEQUENCE 3907.000
     2IN SORTED ATOMS ARRAY/(15X,10F10.0))                              3908.000
  420 RETURN                                                            3909.000
      END                                                               3910.000
      SUBROUTINE LAP700(NA,ICQ)                                         3911.000
      DIMENSION DETER(2),QA(3,3,2),QC(3,3,2),V12(3,2),YMIN(2),YMAX(2)   3912.000
      DIMENSION OVMR(2)                                                 3913.000
C     ***** IN GENERAL, DOUBLE PRECISION IS NOT REQUIRED *****          3914.000
C     ***** BUT IN CASE OF TROUBLE, ACTIVATE THE CD COMMENT CARDS ***** 3915.000
CD    REAL*8 AOV3,AOV3SQ,BOV3,DETER,PI,PHI,POV3,POV3CU,QA,QC,QOV2,QOV2SQ3916.000
CD    REAL*8 ROOT,TD                                                    3917.000
      COMMON/OLAP/CONIC(7,1000),COVER(6,20),KC(20),KQ(30),NCONIC,NCOVER,3918.000
     1 NQOVER,NQUAD,OVMRGN,QOVER(3,4,30),QUAD(9,600),SEGM(50,2)         3919.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         3920.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         3921.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 3922.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      3923.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   3924.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   3925.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     3926.000
         CHARACTER COMPID(72)                                           3927.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                3928.000
         INTEGER CN(200),CONTNT(13)                                     3929.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                3930.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 3931.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   3932.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    3933.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      3934.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          3935.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       3936.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          3937.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   3938.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                3939.000
CD    PI=3.1415926535897932                                             3940.000
      PI=3.141593                                                       3941.000
      ICQ=0                                                             3942.000
      NCOVER=0                                                          3943.000
      NQOVER=0                                                          3944.000
      OVMR(1)=OVMRGN                                                    3945.000
      OVMR(2)=0.0                                                       3946.000
      IF(NCONIC-NA)200,200,205                                          3947.000
  200 RETURN                                                            3948.000
C     ***** ROUGH CHECK FOR OVERLAPPING ATOMS *****                     3949.000
  205 DO  210 J=1,2                                                     3950.000
      YMIN(J)=CONIC(2*J-1,NA)                                           3951.000
  210 YMAX(J)=CONIC(2*J,NA)                                             3952.000
      L=0                                                               3953.000
      DO 420 IA=NA,NCONIC                                               3954.000
      IF(IA-NA)230,230,215                                              3955.000
  215 DO 225 J=1,2                                                      3956.000
      IF(YMAX(J)-CONIC(2*J-1,IA))420,420,220                            3957.000
  220 IF(YMIN(J)-CONIC(2*J,IA))225,420,420                              3958.000
  225 CONTINUE                                                          3959.000
C     ***** EXACT CHECK FOR OVERLAPPING ATOMS *****                     3960.000
  230 IF(L-1)235,235,240                                                3961.000
  235 L=L+1                                                             3962.000
  240 CALL LAPCON(CONIC(1,IA),DA,V12(1,L),OVMR(L))                      3963.000
      DO 245 J=1,3                                                      3964.000
      DO 245 K=1,3                                                      3965.000
  245 QA(J,K,L)=DA(J,K)                                                 3966.000
C     ***** CALCULATE COFACTORS AND DETERMINANTS *****                  3967.000
      DETER(L)=0.0                                                      3968.000
      DO 250 J=1,3                                                      3969.000
      J1=MOD(J+3,3)+1                                                   3970.000
      J2=MOD(J+1,3)+1                                                   3971.000
      DO 250 K=1,3                                                      3972.000
      K1=MOD(K+3,3)+1                                                   3973.000
      K2=MOD(K+1,3)+1                                                   3974.000
      TD=QA(J1,K1,L)*QA(J2,K2,L)-QA(J1,K2,L)*QA(J2,K1,L)                3975.000
      DETER(L)=DETER(L)+TD*QA(J,K,L)                                    3976.000
  250 QC(J,K,L)=TD                                                      3977.000
C     ***** DETER(L) IS THE DETERMINANT TIMES 3 *****                   3978.000
      IF(L-1)420,420,255                                                3979.000
C     ***** FORM CHARACTERISTIC EQUATION AND EXAMINE ITS ROOTS *****    3980.000
  255 AOV3=0.0                                                          3981.000
      BOV3=0.0                                                          3982.000
      DO 260 J=1,3                                                      3983.000
      DO 260 K=1,3                                                      3984.000
      AOV3=AOV3+QC(J,K,2)*QA(J,K,1)                                     3985.000
  260 BOV3=BOV3+QC(J,K,1)*QA(J,K,2)                                     3986.000
      AOV3=AOV3/ DETER(2)                                               3987.000
      AOV3SQ=AOV3**2                                                    3988.000
      BOV3=BOV3/ DETER(2)                                               3989.000
      POV3=BOV3-AOV3SQ                                                  3990.000
CD    QOV2=AOV3*(AOV3SQ-BOV3*1.5D0)+DETER(1)/(DETER(2)*2.0D0)           3991.000
      QOV2=AOV3*(AOV3SQ-BOV3*1.5  )+DETER(1)/(DETER(2)*2.0  )           3992.000
C     ***** CHECK DISCRIMINANT OF CHARACTERISTIC CUBIC EQUATION *****   3993.000
      ITYPE=0                                                           3994.000
      POV3CU=POV3**3                                                    3995.000
      QOV2SQ=QOV2**2                                                    3996.000
      IF(POV3CU+QOV2SQ)270,310,265                                      3997.000
  265 IF(POV3CU*1.00001 +QOV2SQ)310,310,400                             3998.000
  270 IF(POV3CU+1.00001 *QOV2SQ)275,310,310                             3999.000
C     ***** THREE REAL ROOTS, ALL DIFFERENT *****                       4000.000
  275 ITYPE=1                                                           4001.000
C     ***** NO INTERSECTION IF A/3 AND B/3 INVARIANTS ARE NEGATIVE *****4002.000
      IF(AOV3)280,285,285                                               4003.000
  280 IF(BOV3)420,285,285                                               4004.000
C     ***** CALCULATE ONE ROOT OF CHARACTERISTIC CUBIC EQUATION *****   4005.000
  285 IF(QOV2)295,290,295                                               4006.000
CD290 PHI=PI/2.0D0                                                      4007.000
  290 PHI=PI/2.0                                                        4008.000
      GO TO 305                                                         4009.000
CD295 PHI=DATAN(-DSQRT(-POV3CU-QOV2SQ)/QOV2)                            4010.000
  295 PHI= ATAN(- SQRT(-POV3CU-QOV2SQ)/QOV2)                            4011.000
      IF(PHI)300,305,305                                                4012.000
  300 PHI=PHI+PI                                                        4013.000
CD305 ROOT=2.0D0*DSQRT(-POV3)*DCOS(PHI/3.0D0)-AOV3                      4014.000
  305 ROOT=2.0  * SQRT(-POV3)* COS(PHI/3.0  )-AOV3                      4015.000
      GO TO 325                                                         4016.000
C     ***** THREE REAL ROOTS, AT LEAST TWO ARE EQUAL *****              4017.000
  310 ITYPE=2                                                           4018.000
C     ***** CHECK SIGNS OF INVARIANTS A/3 AND B/3 *****                 4019.000
      IF(AOV3)315,320,320                                               4020.000
  315 IF(BOV3)420,320,320                                               4021.000
C     ***** CALCULATE REPEATED ROOT OF CUBIC EQUATION *****             4022.000
CD320 ROOT=DSIGN(DSQRT(-POV3),QOV2)-AOV3                                4023.000
  320 ROOT= SIGN( SQRT(-POV3),QOV2)-AOV3                                4024.000
C     ***** FORM DEGENERATE CONIC (LINE PAIR WHICH MAY BE COINCIDENT) **4025.000
  325 DO 330 J=1,3                                                      4026.000
      DO 330 K=1,3                                                      4027.000
  330 DA(J,K)=QA(J,K,1)+ROOT*QA(J,K,2)                                  4028.000
C     ***** EXAMINE INVARIANTS OF THE DEGENERATE CONIC *****            4029.000
      T6=DA(1,1)*DA(2,2)                                                4030.000
      T7=DA(1,2)**2                                                     4031.000
C     ***** NEGATIVE DENOTES REAL INTERSECTING LINE PAIR *****          4032.000
C     ***** POSITIVE DENOTES IMAGINARY LINES INTERSECTING AT REAL POINT 4033.000
      IF(T6-T7)335,345,340                                              4034.000
  335 IF(T6*1.0001  -T7)400,345,345                                     4035.000
  340 IF(T6-1.0001  *T7)345,345,365                                     4036.000
  345 T8=DA(3,3)*(DA(1,1)+DA(2,2))                                      4037.000
      T9=DA(1,3)**2+DA(2,3)**2                                          4038.000
C     ***** NEGATIVE DENOTES REAL PARALLEL LINE PAIR *****              4039.000
C     ***** POSITIVE DENOTES IMAGINARY PARALLELS *****                  4040.000
C     ***** ZERO DENOTES ONE REAL LINE (COINCIDENT PARALLELS) *****     4041.000
      IF(T8-T9)350,360,355                                              4042.000
  350 IF(T8*1.0001  -T9)400,360,360                                     4043.000
  355 IF(T8-1.0001  *T9)360,360,365                                     4044.000
C     ***** COINCIDENT LINE PAIR FOUND FOR THE REPEATED ROOT *****      4045.000
  360 ITYPE=3                                                           4046.000
C     ***** COMPARE AREAS OF CONICS *****                               4047.000
  365 KA=1                                                              4048.000
      KB=2                                                              4049.000
      IF(QC(3,3,KA)-QC(3,3,KB))370,375,375                              4050.000
  370 KA=2                                                              4051.000
      KB=1                                                              4052.000
C     ***** SEE IF ONE CONIC IS INSIDE THE OTHER CONIC *****            4053.000
  375 T1=0.0                                                            4054.000
      DO 385 J=1,3                                                      4055.000
      T2=QA(J,3,KB)                                                     4056.000
      DO 380 K=1,2                                                      4057.000
  380 T2=T2+QA(J,K,KB)*V12(K,KA)                                        4058.000
  385 T1=T1+V12(J,KA)*T2                                                4059.000
C     ***** DISCARD IF KA IS OUTSIDE KB *****                           4060.000
      IF(T1)390,390,420                                                 4061.000
  390 IF(KA-1)395,395,400                                               4062.000
C     ***** THE OVERLAPPING ATOM HIDES THE ORIGINAL ATOM *****          4063.000
  395 ICQ=-1                                                            4064.000
      RETURN                                                            4065.000
C     ***** STORE OVERLAPPING ATOM *****                                4066.000
  400 ICQ=ICQ+1                                                         4067.000
      IF(NCOVER-20)410,405,405                                          4068.000
  405 NG=17                                                             4069.000
      CALL ERPNT(ATOMS(1,IA),700)                                       4070.000
      NCOVER=NCOVER-1                                                   4071.000
  410 NCOVER=NCOVER+1                                                   4072.000
      IJ=1                                                              4073.000
      DO 415 I=1,3                                                      4074.000
      DO 415 J=I,3                                                      4075.000
      COVER(IJ,NCOVER)=QA(I,J,2)                                        4076.000
  415 IJ=IJ+1                                                           4077.000
      KC(NCOVER)=IA                                                     4078.000
  420 CONTINUE                                                          4079.000
C     ***** SECOND PART OF SUBROUTINE CHECKS FOR BONDS OVER THE ATOM ***4080.000
  425 IF(NQUAD)470,470,430                                              4081.000
  430 ITY=0                                                             4082.000
C     ***** ROUGH CHECK FOR OVERLAPPING BONDS *****                     4083.000
      DO 465 IQ=1,NQUAD                                                 4084.000
      TID=QUAD(9,IQ)                                                    4085.000
      NA1=TID/1000.                                                     4086.000
      NA2=AMOD(TID,1000.)                                               4087.000
      IF(NA-NA2)435,435,465                                             4088.000
  435 DO 445 J=1,2                                                      4089.000
      IF(YMAX(J)-AMIN1(QUAD(J,IQ),QUAD(J+2,IQ),QUAD(J+4,IQ),QUAD(J+6,IQ)4090.000
     1 ))465,465,440                                                    4091.000
  440 IF(YMIN(J)-AMAX1(QUAD(J,IQ),QUAD(J+2,IQ),QUAD(J+4,IQ),QUAD(J+6,IQ)4092.000
     1 ))445,465,465                                                    4093.000
  445 CONTINUE                                                          4094.000
C     ***** EXACT CHECK FOR OVERLAPPING BONDS *****                     4095.000
  450 ITY=ITY-1                                                         4096.000
      IQQ=0                                                             4097.000
      CALL LAPAB(IQ,NA,IQQ,ITY)                                         4098.000
      IF(IQQ)455,460,460                                                4099.000
  455 ICQ=-1                                                            4100.000
      RETURN                                                            4101.000
  460 ICQ=ICQ+1                                                         4102.000
      IF(NQOVER-30)465,470,470                                          4103.000
  465 CONTINUE                                                          4104.000
  470 RETURN                                                            4105.000
      END                                                               4106.000
      SUBROUTINE LAP800(NA1,NA2,ICQ)                                    4107.000
C     ***** SUBROUTINE CHECKS FOR ATOMS AND BONDS OVERLAPPING A BOND ***4108.000
      DIMENSION FL(4,4),Y1(2),Y2(2),YMAX(2),YMIN(2),QUA(3,4)            4109.000
      DIMENSION VUE(3)                                                  4110.000
      COMMON/OLAP/CONIC(7,1000),COVER(6,20),KC(20),KQ(30),NCONIC,NCOVER,4111.000
     1 NQOVER,NQUAD,OVMRGN,QOVER(3,4,30),QUAD(9,600),SEGM(50,2)         4112.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         4113.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         4114.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 4115.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      4116.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   4117.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   4118.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     4119.000
         CHARACTER COMPID(72)                                           4120.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                4121.000
         INTEGER CN(200),CONTNT(13)                                     4122.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                4123.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 4124.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   4125.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    4126.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      4127.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          4128.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       4129.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          4130.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   4131.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                4132.000
      IQ=0                                                              4133.000
      ICQ=0                                                             4134.000
      IF(NA1*NA2)245,245,195                                            4135.000
  195 TID1=FLOAT(NA1)*1000.+FLOAT(NA2)                                  4136.000
      IF(NCONIC)245,245,200                                             4137.000
  200 IF(NJ2-21)250,205,205                                             4138.000
C     ***** PART 1, CALLED FROM BOND, STORES BOND OUTLINE INFORMATION **4139.000
  205 IF(NQUAD-599)215,210,210                                          4140.000
  210 NG=16                                                             4141.000
      CALL ERPNT(ATOMS(1,NA1),822)                                      4142.000
      GO TO 245                                                         4143.000
  215 NQUAD=NQUAD+1                                                     4144.000
C     ***** CALCULATE OVERLAP MARGIN FOR BOND QUADRANGLE *****          4145.000
      T1=0.0                                                            4146.000
      T2=0.0                                                            4147.000
      DO 220 J=1,2                                                      4148.000
      Y1(J)=DP(J,1)-DP(J,65)                                            4149.000
      Y2(J)=DP(J,2)-DP(J,66)                                            4150.000
      T1=T1+Y1(J)**2                                                    4151.000
  220 T2=T2+Y2(J)**2                                                    4152.000
      IF(T1*T2)225,225,230                                              4153.000
  225 T1=0.0                                                            4154.000
      T2=0.0                                                            4155.000
      GO TO 235                                                         4156.000
  230 T1=OVMRGN/SQRT(T1)                                                4157.000
      T2=OVMRGN/SQRT(T2)                                                4158.000
C     ***** STORE BOND QUADRANGLE *****                                 4159.000
  235 DO 240 J=1,2                                                      4160.000
      Y1(J)=Y1(J)*T1                                                    4161.000
      Y2(J)=Y2(J)*T2                                                    4162.000
      QUAD(J,NQUAD)=DP(J,1)+Y1(J)                                       4163.000
      QUAD(J+2 ,NQUAD)=DP(J,2)+Y2(J)                                    4164.000
      QUAD(J+4,NQUAD)=DP(J,66)-Y2(J)                                    4165.000
  240 QUAD(J+6,NQUAD)=DP(J,65)-Y1(J)                                    4166.000
      QUAD(9,NQUAD)=TID1                                                4167.000
  245 RETURN                                                            4168.000
C     ***** PART 2, CALLED FROM BOND, OVERLAP CHECK FOR BOND NA1-NA2 ***4169.000
  250 NCOVER=0                                                          4170.000
      NQOVER=0                                                          4171.000
      TOL=1.E-5                                                         4172.000
      IF(NCONIC-NA1)245,245,255                                         4173.000
C     ***** SAVE QUADRANGLE TEMPORARILY *****                           4174.000
  255 IQ=NQUAD+1                                                        4175.000
      DO 260 J=1,2                                                      4176.000
      QUAD(J,IQ)=DP(J,1)                                                4177.000
      QUAD(J+2,IQ)=DP(J,2)                                              4178.000
      QUAD(J+4,IQ)=DP(J,66)                                             4179.000
  260 QUAD(J+6,IQ)=DP(J,65)                                             4180.000
      QUAD(9,IQ)=TID1                                                   4181.000
C     ***** FIT RECTANGLE AROUND QUADRANGLE *****                       4182.000
  265 DO 270 J=1,2                                                      4183.000
      YMIN(J)=AMIN1(DP(J,1),DP(J,2),DP(J,66),DP(J,65))                  4184.000
  270 YMAX(J)=AMAX1(DP(J,1),DP(J,2),DP(J,66),DP(J,65))                  4185.000
C     ***** ROUGH CHECK FOR ATOM-OVER-BOND OVERLAP *****                4186.000
      NA1P1=NA1+1                                                       4187.000
      ITY=0                                                             4188.000
      DO 305 IA=NA1P1,NCONIC                                            4189.000
      DO 285 J=1,2                                                      4190.000
      IF(IA-NA2)275,305,275                                             4191.000
  275 IF(YMAX(J)-CONIC(2*J-1,IA))305,305,280                            4192.000
  280 IF(YMIN(J)-CONIC(2*J,IA))285,305,305                              4193.000
  285 CONTINUE                                                          4194.000
C     ***** CHECK FOR TRUE ATOM-OVER-BOND OVERLAP *****                 4195.000
      ITY=ITY+1                                                         4196.000
      CALL LAPAB(IQ,IA,IQQ,ITY)                                         4197.000
      IF(IQQ)290,305,300                                                4198.000
C     ***** HIDDEN BOND *****                                           4199.000
  290 ICQ=-1                                                            4200.000
  295 RETURN                                                            4201.000
  300 ICQ=ICQ+1                                                         4202.000
      IF(NCOVER-20)305,310,310                                          4203.000
  305 CONTINUE                                                          4204.000
  310 IF(NQUAD)295,295,315                                              4205.000
C     ***** ROUGH CHECK FOR BOND-OVER-BOND OVERLAP *****                4206.000
  315 CALL DIFV(ATOMS(2,NA2),ATOMS(2,NA1),V1)                           4207.000
      CALL UNIT(V1,V1,1)                                                4208.000
      VUE(1)=  ATOMS(2,NA1)                                             4209.000
      VUE(2)=  ATOMS(3,NA1)                                             4210.000
      VUE(3)=  ATOMS(4,NA1)-VIEW                                        4211.000
      DO 495 IB=1,NQUAD                                                 4212.000
      TID2=QUAD(9,IB)                                                   4213.000
      IF(TID1-TID2)320,495,320                                          4214.000
  320 NB2=AMOD(TID2,1000.)                                              4215.000
      NB1=TID2/1000.                                                    4216.000
      IF(NA1-NB2)325,495,495                                            4217.000
  325 DO 335 J=1,2                                                      4218.000
      IF(YMAX(J)-AMIN1(QUAD(J,IB),QUAD(J+2,IB),QUAD(J+4,IB),QUAD(J+6,IB)4219.000
     1 ))495,495,330                                                    4220.000
  330 IF(YMIN(J)-AMAX1(QUAD(J,IB),QUAD(J+2,IB),QUAD(J+4,IB),QUAD(J+6,IB)4221.000
     1 ))335,495,495                                                    4222.000
  335 CONTINUE                                                          4223.000
C     ***** SET UP LINEAR FORMS FOR EDGES OF QUADRANGLE *****           4224.000
      DO 345 L=1,4                                                      4225.000
      K=2*L                                                             4226.000
      K1=MOD(K,8)+2                                                     4227.000
      QUA(1,L)=QUAD(K,IB)-QUAD(K1,IB)                                   4228.000
      QUA(2,L)=QUAD(K1-1,IB)-QUAD(K-1,IB)                               4229.000
      QUA(3,L)=QUAD(K-1,IB)*QUAD(K1,IB)-QUAD(K,IB)*QUAD(K1-1,IB)        4230.000
C     ***** NORMALIZE LINE EQUATION COEFFICIENTS *****                  4231.000
      T1=SQRT(QUA(1,L)**2+QUA(2,L)**2)                                  4232.000
      IF(T1)495,495,340                                                 4233.000
  340 DO 345 J=1,3                                                      4234.000
  345 QUA(J,L)=QUA(J,L)/T1                                              4235.000
C     ***** EVALUATE LINEAR FORMS AND SIGNATURES FOR QUADRANGLE *****   4236.000
      T3=3.0                                                            4237.000
      DO 365 K=1,4                                                      4238.000
      T2=3.0                                                            4239.000
      J=K*2                                                             4240.000
      DO 355 L=1,4                                                      4241.000
      T1=QUAD(J-1,IQ)*QUA(1,L)+QUAD(J,IQ)*QUA(2,L)+QUA(3,L)             4242.000
      IF(T1)350,355,355                                                 4243.000
  350 T2=T2-1.0                                                         4244.000
  355 FL(L,K)=T1                                                        4245.000
      IF(T2)360,365,365                                                 4246.000
  360 T3=T3-1.0                                                         4247.000
  365 CONTINUE                                                          4248.000
C     ***** CHECK FOR 4 POINTS INSIDE QUADRANGLE *****                  4249.000
      IF(T3)370,375,375                                                 4250.000
  370 ITYPE=-1                                                          4251.000
      GO TO 415                                                         4252.000
C     ***** CHECK FOR 1 TO 3 POINTS INSIDE QUADRANGLE ****              4253.000
  375 IF(T3-3.0)380,385,385                                             4254.000
  380 ITYPE=0                                                           4255.000
      GO TO 415                                                         4256.000
C     ***** DETERMINE WHICH EDGES ARE CROSSED BY THE 4 LINE SEGMENTS ***4257.000
  385 DO 405 L=1,4                                                      4258.000
      L1=MOD(L,4)+1                                                     4259.000
C     ***** LINE SEGMENT L FROM POINT Y1 TO POINT Y2 *****              4260.000
      Y1(1)=QUAD(L*2-1,IQ)                                              4261.000
      Y1(2)=QUAD(L*2,IQ)                                                4262.000
      Y2(1)=QUAD(L1*2-1,IQ)                                             4263.000
      Y2(2)=QUAD(L1*2,IQ)                                               4264.000
      DO 405 K=1,4                                                      4265.000
      T1=FL(K,L)                                                        4266.000
      T2=FL(K,L1)                                                       4267.000
      T3=T1-T2                                                          4268.000
C     ***** T1 AND T2 MUST HAVE OPPOSITE SIGNS FOR INTERSECTION TO OCCUR4269.000
      IF(T1*T2)390,390,405                                              4270.000
C     ***** COMPONENT OF SEGMENT L PERPENDICULAR TO EDGE K OF IB IS T3  4271.000
  390 IF(ABS(T3)-1.E-5)405,405,395                                      4272.000
C     ***** CALCULATE COORDINATES OF INTERSECTION *****                 4273.000
  395 T4=(T1*Y2(1)-T2*Y1(1))/T3                                         4274.000
      T5=(T1*Y2(2)-T2*Y1(2))/T3                                         4275.000
      K0=2*K                                                            4276.000
      K1=2*(MOD(K,4)+1)                                                 4277.000
C     ***** IS INTERSECTION WITHIN QUADRANGLE IQ *****                  4278.000
      T6=(T4-QUAD(K0-1,IB))*(QUAD(K1-1,IB)-T4)+(T5-QUAD(K0,IB))*        4279.000
     1 (QUAD(K1,IB)-T5)                                                 4280.000
      IF(ABS(T6)-1.E-4)410,410,400                                      4281.000
  400 IF(T6)405,410,410                                                 4282.000
  405 CONTINUE                                                          4283.000
      GO TO 495                                                         4284.000
  410 ITYPE=1                                                           4285.000
C     ***** CHECK OVER/UNDER AMBIGUITY *****                            4286.000
  415 IF((NA1-NB1)*(NA2-NB2)*(NA2-NB1))425,420,425                      4287.000
C     ***** BONDS SHARE AN ATOM *****                                   4288.000
  420 IF(NA1+NA2-NB1-NB2)465,495,495                                    4289.000
  425 CALL DIFV(ATOMS(2,NB2),ATOMS(2,NB1),V2)                           4290.000
      CALL DIFV(ATOMS(2,NB1),ATOMS(2,NA1),V4)                           4291.000
      CALL UNIT(V2,V2,1)                                                4292.000
      CALL UNIT(V4,V4,1)                                                4293.000
      CALL NORM(V1,V2,V3,1)                                             4294.000
      IF(VV(V3,V3)-TOL)430,430,435                                      4295.000
C     ***** PARALLEL BONDS, RECALCULATE V3 *****                        4296.000
  430 CALL NORM(V1,V4,V5,1)                                             4297.000
      CALL NORM(V5,V1,V3,1)                                             4298.000
C     ***** CHECK FOR COLLINEAR BONDS *****                             4299.000
      IF(VV(V3,V3)-TOL)465,465,450                                      4300.000
  435 IF(VV(V3,V4)+TOL)440,450,450                                      4301.000
  440 DO 445 J=1,3                                                      4302.000
  445 V3(J)=-V3(J)                                                      4303.000
C     ***** V3 IS NORMAL TO BONDS IQ AND IB GOING FROM IQ TOWARD IB *** 4304.000
  450 IF(VIEW)455,455,460                                               4305.000
  455 IF(V3(3))495,495,465                                              4306.000
  460 IF(VV(VUE,V3))465,495,495                                         4307.000
C     ***** OVERLAPPING BOND FOUND *****                                4308.000
  465 ICQ=ICQ+1                                                         4309.000
      IF(ITYPE)470,475,475                                              4310.000
C     ***** HIDDEN BOND *****                                           4311.000
  470 ICQ=-1                                                            4312.000
      RETURN                                                            4313.000
C     ***** STORE INTERFERING QUADRANGLE *****                          4314.000
  475 IF(NQOVER-30)485,480,480                                          4315.000
  480 NG=17                                                             4316.000
      CALL ERPNT(TID2,800)                                              4317.000
      RETURN                                                            4318.000
  485 NQOVER=NQOVER+1                                                   4319.000
      DO 490 K=1,4                                                      4320.000
      DO 490 J=1,3                                                      4321.000
  490 QOVER(J,K,NQOVER)=QUA(J,K)                                        4322.000
      KQ(NQOVER)=IB                                                     4323.000
  495 CONTINUE                                                          4324.000
  500 RETURN                                                            4325.000
      END                                                               4326.000
      SUBROUTINE LAPAB(IQ,IA,ICQ,ITY)                                   4327.000
C     ***** SUBROUTINE CHECKS FOR OVERLAP BETWEEN ATOMS AND BONDS ***** 4328.000
C     ***** CALLED BY SUBROUTINES LAP700 AND LAP800 *****               4329.000
      DIMENSION BF(4),CON(3,3),QF(5),QUA(3,4)                           4330.000
      COMMON/OLAP/CONIC(7,1000),COVER(6,20),KC(20),KQ(30),NCONIC,NCOVER,4331.000
     1 NQOVER,NQUAD,OVMRGN,QOVER(3,4,30),QUAD(9,600),SEGM(50,2)         4332.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         4333.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         4334.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 4335.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      4336.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   4337.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   4338.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     4339.000
         CHARACTER COMPID(72)                                           4340.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                4341.000
         INTEGER CN(200),CONTNT(13)                                     4342.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                4343.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 4344.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   4345.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    4346.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      4347.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          4348.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       4349.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          4350.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   4351.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                4352.000
      TID=QUAD(9,IQ)                                                    4353.000
      NA1=TID/1000.                                                     4354.000
      NA2=AMOD(TID,1000.)                                               4355.000
C     ***** ITY.GT.0, CHECK FOR ATOMS OVER A BOND ****                  4356.000
C     ***** ITY.LT.0, CHECK FOR BONDS OVER AN ATOM *****                4357.000
      ICQ=0                                                             4358.000
      IF(ITY)210,200,205                                                4359.000
  200 RETURN                                                            4360.000
  205 CALL LAPCON(CONIC(1,IA),CON,V1,0.0)                               4361.000
      IF(ITY-2)220,240,240                                              4362.000
  210 IF(ITY+2)220,220,215                                              4363.000
  215 CALL LAPCON(CONIC(1,IA),CON,V1,OVMRGN)                            4364.000
C     ***** SET UP LINEAR FORMS FOR EDGES OF QUADRANGLE *****           4365.000
  220 DO 235 L=1,4                                                      4366.000
      K=2*L                                                             4367.000
      K1=MOD(K,8)+2                                                     4368.000
      QUA(1,L)=QUAD(K,IQ)-QUAD(K1,IQ)                                   4369.000
      QUA(2,L)=QUAD(K1-1,IQ)-QUAD(K-1,IQ)                               4370.000
      QUA(3,L)=QUAD(K-1,IQ)*QUAD(K1,IQ)-QUAD(K,IQ)*QUAD(K1-1,IQ)        4371.000
      T1=SQRT(QUA(1,L)**2+QUA(2,L)**2)                                  4372.000
      IF(T1)225,225,230                                                 4373.000
  225 ITY=0                                                             4374.000
      ICQ=0                                                             4375.000
      RETURN                                                            4376.000
C     ***** TRANSFORM COEFFICIENTS FOR EDGES TO NORMAL FORM *****       4377.000
  230 DO 235 J=1,3                                                      4378.000
  235 QUA(J,L)=QUA(J,L)/T1                                              4379.000
C     ***** EVALUATE 4 QUADRATIC AND 4 BILINEAR FORMS *****             4380.000
  240 V2(3)=1.0                                                         4381.000
      V3(3)=1.0                                                         4382.000
      T2=3.0                                                            4383.000
      DO 265 L=1,4                                                      4384.000
      L1=(MOD(L,4)+1)*2                                                 4385.000
      V2(1)=QUAD(2*L-1,IQ)                                              4386.000
      V2(2)=QUAD(2*L,IQ)                                                4387.000
      V3(1)=QUAD(L1-1,IQ)                                               4388.000
      V3(2)=QUAD(L1,IQ)                                                 4389.000
      QF(L)=0.0                                                         4390.000
      BF(L)=0.0                                                         4391.000
      DO 250 K=1,3                                                      4392.000
      T1=CON(3,K)                                                       4393.000
      DO 245 J=1,2                                                      4394.000
  245 T1=T1+V2(J)*CON(J,K)                                              4395.000
      QF(L)=QF(L)+T1*V2(K)                                              4396.000
  250 BF(L)=BF(L)+T1*V3(K)                                              4397.000
      IF(QF(L))260,255,265                                              4398.000
  255 T2=T2-0.8                                                         4399.000
      GO TO 265                                                         4400.000
  260 T2=T2-1.0                                                         4401.000
  265 CONTINUE                                                          4402.000
      QF(5)=QF(1)                                                       4403.000
C     ***** CHECK FOR 4 POINTS OF QUADRANGLE INSIDE OR ON ELLIPSE ***** 4404.000
      IF(T2)270,275,275                                                 4405.000
  270 ITYPE=-1                                                          4406.000
      GO TO 330                                                         4407.000
C     ***** CHECK FOR 1 TO 3 POINTS OF QUADRANGLE INSIDE THE ELLIPSE ***4408.000
  275 IF(T2-2.2)280,285,285                                             4409.000
  280 ITYPE=0                                                           4410.000
      IF(NA2-IA)340,375,335                                             4411.000
C     ***** CHECK FOR QUADRANGLE-ELLIPSE INTERSECTION *****             4412.000
  285 DO 305 K=1,4                                                      4413.000
C     ***** EVALUATE DISCRIMINANT *****                                 4414.000
      T1=BF(K)**2-QF(K)*QF(K+1)                                         4415.000
      IF(T1)305,305,290                                                 4416.000
  290 T1=SQRT(T1)                                                       4417.000
C     ***** IS INTERSECTION WITHIN BOUNDS OF QUADRANGLE *****           4418.000
      T3=QF(K)-BF(K)                                                    4419.000
      T4=T3+QF(K+1)-BF(K)                                               4420.000
      IF(ABS(T4)-1.E-5)305,305,295                                      4421.000
  295 T5=(T3-T1)/T4                                                     4422.000
      IF(T5)305,280,300                                                 4423.000
  300 IF(1.0-T5)305,305,280                                             4424.000
  305 CONTINUE                                                          4425.000
C     ***** NO VALID INTERSECTION FOUND *****                           4426.000
C     ***** CHECK FOR CENTER OF ELLIPSE WITHIN THE QUADRANGLE ****      4427.000
      T3=3.0                                                            4428.000
      DO 320 K=1,4                                                      4429.000
      T1=QUA(3,K)                                                       4430.000
      DO 310 J=1,2                                                      4431.000
  310 T1=T1+V1(J)*QUA(J,K)                                              4432.000
      IF(T1)315,320,320                                                 4433.000
  315 T3=T3-1.0                                                         4434.000
  320 CONTINUE                                                          4435.000
      IF(T3)325,370,370                                                 4436.000
  325 ITYPE=1                                                           4437.000
C     ***** CHECK OVER/UNDER AMBIGUITY *****                            4438.000
  330 IF(NA2-IA)375,375,335                                             4439.000
  335 IF(IA-NA1)375,375,340                                             4440.000
  340 CALL DIFV(ATOMS(2,NA2),ATOMS(2,NA1),V2)                           4441.000
      CALL DIFV(ATOMS(2,IA),ATOMS(2,NA1),V3)                            4442.000
      CALL UNIT(V2,V2,1)                                                4443.000
      CALL UNIT(V3,V3,1)                                                4444.000
      CALL NORM(V2,V3,V4,1)                                             4445.000
      IF(VV(V4,V4)-1.E-5)345,345,350                                    4446.000
C     ***** CENTER OF ATOM IQ IS ON THE BOND LINE *****                 4447.000
  345 IF(ITY)370,370,385                                                4448.000
C     ***** CENTER OF ATOM IQ IS NOT ON THE BOND LINE *****             4449.000
  350 CALL NORM(V4,V2,V5,1)                                             4450.000
      T1=-V5(3)                                                         4451.000
      IF(VIEW)365,365,355                                               4452.000
  355 T1=V5(3)*(ATOMS(4,IA)-VIEW)                                       4453.000
      DO 360 J=1,2                                                      4454.000
  360 T1=T1+V5(J)*ATOMS(J+1,IA)                                         4455.000
  365 IF(T1*FLOAT(ITY))375,375,370                                      4456.000
C     ***** NO INTERFERENCE FOUND *****                                 4457.000
  370 ICQ=0                                                             4458.000
      RETURN                                                            4459.000
C     ***** ITYPE=1 ENCLOSED ELLIPSE / ITYPE=-1 ENCLOSED QUADRANGLE ****4460.000
  375 IF(ITYPE*ITY)380,385,385                                          4461.000
C     ***** HIDDEN ATOM OR HIDDEN BOND *****                            4462.000
  380 ICQ=-1                                                            4463.000
      RETURN                                                            4464.000
  385 ICQ=1                                                             4465.000
      IF(ITY)410,390,390                                                4466.000
C     ***** STORE INTERFERING ELLIPSE *****                             4467.000
  390 IF(NCOVER-20)400,395,395                                          4468.000
  395 NG=17                                                             4469.000
      CALL ERPNT(ATOMS(1,IA),800)                                       4470.000
      NCOVER=NCOVER-1                                                   4471.000
  400 NCOVER=NCOVER+1                                                   4472.000
      IJ=1                                                              4473.000
      DO 405 I=1,3                                                      4474.000
      DO 405 J=I,3                                                      4475.000
      COVER(IJ,NCOVER)=CON(I,J)                                         4476.000
  405 IJ=IJ+1                                                           4477.000
      KC(NCOVER)=IA                                                     4478.000
      RETURN                                                            4479.000
C     ***** STORE INTERFERING QUADRANGLE *****                          4480.000
  410 IF(NQOVER-30)420,415,415                                          4481.000
  415 NG=18                                                             4482.000
      CALL ERPNT(TID,700)                                               4483.000
      NQOVER=NQOVER-1                                                   4484.000
  420 NQOVER=NQOVER+1                                                   4485.000
      DO 425 K=1,4                                                      4486.000
      DO 425 J=1,3                                                      4487.000
  425 QOVER(J,K,NQOVER)=QUA(J,K)                                        4488.000
      KQ(NQOVER)=IQ                                                     4489.000
      RETURN                                                            4490.000
      END                                                               4491.000
      SUBROUTINE LAPCON(CON1,CON,Y,OVMR)                                4492.000
C     ***** TRANSFORM CONIC TO PLOTTER HOMOGENEOUS COORDINATE SYSTEM ***4493.000
C     ***** CALLED BY SUBROUTINES LAP700 AND LAPAB *****                4494.000
      DIMENSION CON1(7),CON(3,3),Y(3)                                   4495.000
      Y(1)=(CON1(1)+CON1(2))*0.5                                        4496.000
      Y(2)=(CON1(3)+CON1(4))*0.5                                        4497.000
      Y(3)=1.0                                                          4498.000
      CON(1,1)=CON1(5)                                                  4499.000
      CON(1,2)=CON1(6)                                                  4500.000
      CON(2,1)=CON1(6)                                                  4501.000
      CON(2,2)=CON1(7)                                                  4502.000
      T1=(CON1(2)-CON1(1)+CON1(4)-CON1(3))*0.25                         4503.000
      CON(3,3)=-((T1-OVMR)/T1)**2                                       4504.000
      DO 205 K=1,2                                                      4505.000
      CON(K,3)=0.0                                                      4506.000
      DO 200 J=1,2                                                      4507.000
  200 CON(K,3)=CON(K,3)-Y(J)*CON(J,K)                                   4508.000
      CON(3,K)=CON(K,3)                                                 4509.000
  205 CON(3,3)=CON(3,3)-CON(3,K)*Y(K)                                   4510.000
      RETURN                                                            4511.000
      END                                                               4512.000
      SUBROUTINE LAPDRW(Y,NPEN,NCQ)                                     4513.000
C     ***** SUBROUTINE ELIMINATES HIDDEN LINES AND DRAWS VISIBLE LINES *4514.000
      DIMENSION CB(20),CQ(50,2),QL(4,30,2),SEG(2),Y(3),YN(3),YO(3),Z(3) 4515.000
      COMMON/OLAP/CONIC(7,1000),COVER(6,20),KC(20),KQ(30),NCONIC,NCOVER,4516.000
     1 NQOVER,NQUAD,OVMRGN,QOVER(3,4,30),QUAD(9,600),SEGM(50,2)         4517.000
      DIMENSION AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140)         4518.000
      DIMENSION ATOMS(4,1000),BB(3,3),CD(8,10),CONT(5),D(3,130)         4519.000
      DIMENSION DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,10),ORGN(3) 4520.000
      DIMENSION PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3)                      4521.000
      DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48)   4522.000
      DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3)   4523.000
      DIMENSION XLNG(3),XO(3),XT(3)                                     4524.000
         CHARACTER COMPID(72)                                           4525.000
         CHARACTER*8 CHEM(200),FTYPE(13)                                4526.000
         INTEGER CN(200),CONTNT(13)                                     4527.000
         COMMON/MODELC/COMPID,CHEM,FTYPE                                4528.000
         COMMON/MODEL/NATOM,NSYM,ILATT,NTYPE,     NFTYPE(200),P(3,200), 4529.000
     1   CN,SOF(200),UIJ(6,200),PA(3,3,200),DUM(200),                   4530.000
     2   WAVEL,A(9),ECELL(3),R(24,3,4),T(3,4),ICENT,                    4531.000
     3   SFAC(14,13),CONTNT,SCALE,       EXTNCT(6)                      4532.000
      COMMON NG,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CONT,D          4533.000
      COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NCD       4534.000
      COMMON NJ,NJ2,NOUT,NSR,ORGN,PAC,PAT,Q,REFV,RES,RMS,SCAL1          4535.000
      COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2   4536.000
      COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT                                4537.000
      NCQ=NCOVER+NQOVER                                                 4538.000
      IF(NCQ)200,200,205                                                4539.000
  200 RETURN                                                            4540.000
C     ***** CHECK ALL OVERLAPPING ATOMS AND BONDS *****                 4541.000
  205 NPM3=NPEN-3                                                       4542.000
      IF(NPM3)  210,230,230                                             4543.000
C     ***** SAVE INFORMATION FROM LAST POINT IF PEN IS DOWN *****       4544.000
  210 YO(1)=YN(1)                                                       4545.000
      YO(2)=YN(2)                                                       4546.000
      YO(3)=1.0                                                         4547.000
      NPO=NPN                                                           4548.000
      DO 215 K=1,NCQ                                                    4549.000
  215 CQ(K,1)=CQ(K,2)                                                   4550.000
      IF(NQOVER)230,230,220                                             4551.000
  220 DO 225 K=1,NQOVER                                                 4552.000
      DO 225 J=1,4                                                      4553.000
  225 QL(J,K,1)=QL(J,K,2)                                               4554.000
C     ***** EVALUATE CONIC QUADRATIC FORMS AT NEW POINT YN *****        4555.000
  230 YN(1)=Y(1)                                                        4556.000
      YN(2)=Y(2)                                                        4557.000
      YN(3)=1.0                                                         4558.000
      NPN=NPEN                                                          4559.000
      IF(NCOVER)250,250,235                                             4560.000
  235 DO 245 K=1,NCOVER                                                 4561.000
      Z(1)=YN(1)*COVER(1,K)+YN(2)*COVER(2,K)+COVER(3,K)                 4562.000
      Z(2)=YN(1)*COVER(2,K)+YN(2)*COVER(4,K)+COVER(5,K)                 4563.000
      Z(3)=YN(1)*COVER(3,K)+YN(2)*COVER(5,K)+COVER(6,K)                 4564.000
      CQ(K,2)=Z(1)*YN(1)+Z(2)*YN(2)+Z(3)                                4565.000
C     ***** EVALUATE CONIC BILINEAR FORM IF PEN IS DOWN *****           4566.000
      IF(NPM3)240,245,245                                               4567.000
  240 CB(K)= Z(1)*YO(1)+Z(2)*YO(2)+Z(3)                                 4568.000
  245 CONTINUE                                                          4569.000
C     ***** EVALUATE LINEAR FORMS AND SIGNATURE FOR QUADRANGLE *****    4570.000
  250 IF(NQOVER)275,275,255                                             4571.000
  255 KCQ=NCOVER                                                        4572.000
      DO 270 K=1,NQOVER                                                 4573.000
      T2=3.0                                                            4574.000
      DO 265 J=1,4                                                      4575.000
      T1=YN(1)*QOVER(1,J,K)+YN(2)*QOVER(2,J,K)+QOVER(3,J,K)             4576.000
      IF(T1)260,265,265                                                 4577.000
  260 T2=T2-1.0                                                         4578.000
  265 QL(J,K,2)=T1                                                      4579.000
      KCQ=KCQ+1                                                         4580.000
C     ***** T2=-1 INSIDE, =0 ACROSS ANY EDGE, =1 ACROSS ANY VERTEX *****4581.000
  270 CQ(KCQ,2)=T2                                                      4582.000
C     ***** IF PEN IS UP, OMIT ALL SUBSEQUENT CHECKING *****            4583.000
  275 IF(NPM3)285,280,280                                               4584.000
  280 NPN=3                                                             4585.000
      CALL SCRIBE(YN,NPN,LTNO)                                          4586.000
      RETURN                                                            4587.000
C     ***** CHECK FOR HIDDEN SEGMENT *****                              4588.000
  285 DO 295 K=1,NCQ                                                    4589.000
      IF(CQ(K,1))290,295,295                                            4590.000
  290 IF(CQ(K,2))280,295,295                                            4591.000
  295 CONTINUE                                                          4592.000
C     ***** FIND ENTRY AND EXIT POINTS ON EACH CONIC *****              4593.000
      NINT=0                                                            4594.000
      IF(NCOVER)330,330,300                                             4595.000
  300 DO 325 K=1,NCOVER                                                 4596.000
C     ***** EVALUATE DISCRIMINANT *****                                 4597.000
      T1=CB(K)**2-CQ(K,1)*CQ(K,2)                                       4598.000
      IF(T1)325,325,305                                                 4599.000
  305 T1=SQRT(T1)                                                       4600.000
C     ***** SOLVE QUADRATIC EQATION *****                               4601.000
      T2=CQ(K,1)-CB(K)                                                  4602.000
      T3=T2+CQ(K,2)-CB(K)                                               4603.000
      IF(ABS(T3)-1.E-5)325,325,310                                      4604.000
  310 T4=(T2-T1)/T3                                                     4605.000
      T5=(T2+T1)/T3                                                     4606.000
C     ***** VALID INTERSECTION IF T4.LT.1 AND T5.GT.0 *****             4607.000
      IF(T4-1.0)315,325,325                                             4608.000
  315 IF(T5)325,325,320                                                 4609.000
C     ***** SAVE VALID CONIC INTERSECTIONS *****                        4610.000
  320 NINT=NINT+1                                                       4611.000
      SEGM(NINT,1)=T4                                                   4612.000
      SEGM(NINT,2)=T5                                                   4613.000
  325 CONTINUE                                                          4614.000
  330 IF(NQOVER)425,425,335                                             4615.000
C     ***** FIND ENTRY AND EXIT POINTS FOR EACH QUADRANGLE *****        4616.000
  335 DO 420 K=1,NQOVER                                                 4617.000
      I12=0                                                             4618.000
      KCQ=NCOVER+K                                                      4619.000
C     ***** CHECK FOR SINGLE INSIDE POINT *****                         4620.000
      SEG(1)=CQ(KCQ,1)                                                  4621.000
      IF(SEG(1))345,340,340                                             4622.000
  340 SEG(1)=1.0-CQ(KCQ,2)                                              4623.000
      IF(SEG(1)-1.0)350,350,345                                         4624.000
C     ***** INSIDE POINT FOUND, ONLY ONE INTERSECTION POSSIBLE *****    4625.000
  345 I12=1                                                             4626.000
C     ***** FIND WHICH EDGES ARE CROSSED BY THE SEGMENT *****           4627.000
  350 DO 410 J=1,4                                                      4628.000
      T1=QL(J,K,1)                                                      4629.000
      T2=QL(J,K,2)                                                      4630.000
      T3=T1-T2                                                          4631.000
      IF(T1*T2)355,355,410                                              4632.000
C     ***** CHECK FOR SEGMENT ON AN EDGE *****                          4633.000
  355 IF(ABS(T3)-1.E-5)420,420,360                                      4634.000
C     ***** CALCULATE COORDINATES OF INTERSECTION *****                 4635.000
  360 T4=(T1*YN(1)-T2*YO(1))/T3                                         4636.000
      T5=(T1*YN(2)-T2*YO(2))/T3                                         4637.000
      J1=2*(MOD(J,4)+1)                                                 4638.000
      IQ=KQ(K)                                                          4639.000
C     ***** IS INTERSECTION WITHIN LIMITS OF QUADRANGLE *****           4640.000
      T6=(T4-QUAD(2*J-1,IQ))*(QUAD(J1-1,IQ)-T4)+(T5-QUAD(2*J,IQ))*      4641.000
     1 (QUAD(J1,IQ)-T5)                                                 4642.000
      IF(ABS(T6)-1.E-4)370,370,365                                      4643.000
  365 IF(T6)410,370,370                                                 4644.000
C     ***** CALCULATE FRACTION PARAMETER AND STORE IT *****             4645.000
  370 T1=T1/T3                                                          4646.000
      IF(I12-1)375,380,395                                              4647.000
C     ***** STORE FIRST INTERSECTION *****                              4648.000
  375 I12=1                                                             4649.000
      GO TO 390                                                         4650.000
C     ***** STORE SECOND INTERSECTION ****                              4651.000
  380 I12=2                                                             4652.000
      IF(T1-SEG(1))385,405,405                                          4653.000
  385 SEG(2)=SEG(1)                                                     4654.000
  390 SEG(1)= T1                                                        4655.000
      GO TO 410                                                         4656.000
C     ***** MORE THAN TWO INTERSECTIONS (I.E.,QUADRANGLE DIAGONAL) *****4657.000
  395 IF(T1-SEG(1))390,410,400                                          4658.000
  400 IF(T1-SEG(2))410,410,405                                          4659.000
  405 SEG(2)=T1                                                         4660.000
  410 CONTINUE                                                          4661.000
      IF(I12-1)420,420,415                                              4662.000
C     ***** STORE FRACTION PARAMETERS *****                             4663.000
  415 NINT=NINT+1                                                       4664.000
      SEGM(NINT,1)=SEG(1)                                               4665.000
      SEGM(NINT,2)=SEG(2)                                               4666.000
  420 CONTINUE                                                          4667.000
C     ***** END OF ENTRY-AND-EXIT-POINT CALCULATIONS *****              4668.000
  425 IF(NINT-1)430,490,435                                             4669.000
C     ***** NO INTERFERENCE FOUND, DRAW ENTIRE SEGMENT *****            4670.000
  430 CALL SCRIBE(YN,2,LTNO)                                            4671.000
      RETURN                                                            4672.000
C     **** SORT SEGMENT INTERSECTION LIST *****                         4673.000
C     ***** SORTING PROCEDURE BY SHELL,D.L. COMM. ACM 2,30-32 (1959) ***4674.000
  435 M=NINT                                                            4675.000
  440 M=M/2                                                             4676.000
      IF(M)490,490,445                                                  4677.000
  445 K=NINT-M                                                          4678.000
      J=1                                                               4679.000
  450 I=J                                                               4680.000
  455 IM=I+M                                                            4681.000
      IF(SEGM(I,1))460,470,470                                          4682.000
  460 IF(SEGM(IM,1))465,465,485                                         4683.000
  465 IF(SEGM(I,2)-SEGM(IM,2))485,485,475                               4684.000
  470 IF(SEGM(I,1)-SEGM(IM,1))485,485,475                               4685.000
  475 DO 480 L=1,2                                                      4686.000
      T1=SEGM(I,L)                                                      4687.000
      SEGM(I,L)=SEGM(IM,L)                                              4688.000
  480 SEGM(IM,L)=T1                                                     4689.000
      I=I-M                                                             4690.000
      IF(I)485,485,455                                                  4691.000
  485 J=J+1                                                             4692.000
      IF(J-K)450,450,440                                                4693.000
C     ***** FIND STARTING POINT P0 AND END POINT P1 *****               4694.000
  490 P0=0.0                                                            4695.000
      K=0                                                               4696.000
  495 K=K+1                                                             4697.000
      IF(K-NINT)500,500,515                                             4698.000
  500 P1=SEGM(K,1)                                                      4699.000
      IF(P1)510,505,505                                                 4700.000
  505 IF(P1-P0)510,510,520                                              4701.000
  510 P0=AMAX1(P0,SEGM(K,2))                                            4702.000
      IF(P0-1.0)495,530,525                                             4703.000
  515 P1=1.0                                                            4704.000
C     ***** DRAW SEGMENT FROM P0 TO P1 *****                            4705.000
  520 IF(P0)535,535,530                                                 4706.000
  525 P0=1.0                                                            4707.000
  530 Z(1)=YO(1)*(1.-P0)+YN(1)*P0                                       4708.000
      Z(2)=YO(2)*(1.-P0)+YN(2)*P0                                       4709.000
      NPN=3                                                             4710.000
      CALL SCRIBE(Z,NPN,LTNO)                                           4711.000
      IF(P0-1.0)535,540,540                                             4712.000
  535 Z(1)=YO(1)*(1.-P1)+YN(1)*P1                                       4713.000
      Z(2)=YO(2)*(1.-P1)+YN(2)*P1                                       4714.000
      NPN=2                                                             4715.000
      CALL SCRIBE(Z,NPN,LTNO)                                           4716.000
      IF(P1-1.0)510,540,540                                             4717.000
  540 RETURN                                                            4718.000
      END                                                               4719.000
      SUBROUTINE PROJ(D,DP,X,XO,VIEW,I1,I2,I3)                          4720.000
C     ***** 3D CARTESIAN TO 2D PLOTTER COORDINATES *****                4721.000
      DIMENSION D(3,129),DP(2,129),X(3),XO(3)                           4722.000
      T3=VIEW-X(3)                                                      4723.000
      DO 145 I=I1,I2,I3                                                 4724.000
      T1=D(1,I)+X(1)                                                    4725.000
      T2=D(2,I)+X(2)                                                    4726.000
      IF(VIEW)135,135,120                                               4727.000
  120 T4=VIEW/(T3-D(3,I))                                               4728.000
      T1=T1*T4                                                          4729.000
      T2=T2*T4                                                          4730.000
  135 DP(1,I)=T1+XO(1)                                                  4731.000
  145 DP(2,I)=T2+XO(2)                                                  4732.000
      RETURN                                                            4733.000
      END                                                               4734.000
      SUBROUTINE SIMBOL(X,Y,H,BCD,THETA,M)                              4735.000
      DIMENSION IBCD(2),X(1)                                            4736.000
      CHARACTER*8     BCD                                               4737.000
      READ (BCD,10) IBCD                                                4738.000
 10   FORMAT (2A4)                                                      4739.000
      CALL SYMBOL(X,Y,H,IBCD,THETA,M)                                   4740.000
      RETURN                                                            4741.000
      END                                                               4742.000
      SUBROUTINE NUMBUR(X,Y,H,D,THETA,M)                                4743.000
      CALL NUMBER(X,Y,H,D,THETA,M)                                      4744.000
      RETURN                                                            4745.000
      END                                                               4746.000
C     SUBROUTINE CRT(X,Y,I1,I2)                                         4747.000
C     ***** DUMMY CATHODE-RAY-TUBE PACKAGE ***                          4748.000
C     ***** SUBROUTINE CRT IS CALLED BY SUBROUTINES F200 AND SCRIBE *** 4749.000
C     RETURN                                                            4750.000
C     END                                                               4751.000
