C        COPYRIGHT 1985 UNIVERSITY OF GLASGOW                           0001.000
C        LIBRARY ROUTINES FOR GX PACKAGE (EXCLUDING GRAPHICS DRIVERS).  0002.000
C        PAUL R. MALLINSON APRIL 1985                                   0003.000
         BLOCK DATA MDLDAT                                              0004.000
         CHARACTER COMPID(72)                                           0005.000
         CHARACTER*8 LABEL(200),FTYPE(13)                               0006.000
         INTEGER CN(200),CONTNT(13)                                     0007.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0008.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0009.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0010.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0011.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0012.000
         DATA SOF/200*1./,(UIJ(1,I),I=1,200)/200*0.05/,                 0013.000
     1   ((UIJ(I,J),I=2,6),J=1,200)/1000*0./,EP/600*0./,ESOF/200*0./,   0014.000
     2   EUIJ/1200*0./,CELL/3*1.,3*0./,ECELL/6*0./,((R(1,I,J),J=1,4),I=10015.000
     3   ,3)/1.,0.,0.,0.,0.,1.,0.,0.,0.,0.,1.,0./,T/12*0./,SFAC/182*0./,0016.000
     4   CONTNT/13*0/,SCALE/4*1./,NQ/1/,WAVEL/0./,EXTNCT/0./,           0017.000
     5   CN/200*0/,ETA/1./,COMPID/72*' '/                               0018.000
         END                                                            0019.000
         SUBROUTINE MDLIN(LFC)                                          0020.000
         EXTERNAL MDLDAT                                                0021.000
         CHARACTER LINE(148),COMPID(72)                                 0022.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0023.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0024.000
         LOGICAL SHELX                                                  0025.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0026.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0027.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0028.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0029.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0030.000
         ICENT=0                                                        0031.000
         NT=1                                                           0032.000
         NR=1                                                           0033.000
         NATOM=0                                                        0034.000
         NTYPE=0                                                        0035.000
         REWIND LFC                                                     0036.000
 11      READ (LFC,100,END=10) (LINE(I),I=2,73)                         0037.000
 100     FORMAT(144A1)                                                  0038.000
         DO 26 I=74,145                                                 0039.000
 26      LINE(I)=' '                                                    0040.000
         CALL PARSE(LINE,NFIELD,FIRSTC,FWIDTH)                          0041.000
         IF (NFIELD.EQ.0) GO TO 11                                      0042.000
         J=FIRSTC(NFIELD)                                               0043.000
         IF (LINE(J).NE.'=') GO TO 20                                   0044.000
         LINE(J)=' '                                                    0045.000
         READ (LFC,100,END=28) (LINE(I),I=74,145)                       0046.000
         CALL PARSE(LINE,NFIELD,FIRSTC,FWIDTH)                          0047.000
 20      CALL AFORMT(LINE,FIRSTC(1),FWIDTH(1),TAG)                      0048.000
         IF (TAG.EQ.'REMARK') GO TO 11                                  0049.000
         IF (NFIELD.GT.1) GO TO 23                                      0050.000
         WRITE (6,104) TAG                                              0051.000
 104     FORMAT (' ',A8,' <<<<<<< IGNORED - NO PARAMETERS')             0052.000
         GO TO 11                                                       0053.000
 23      IF (TAG.NE.'TITLE') GO TO 12                                   0054.000
         DO 30 I=FIRSTC(2),FIRSTC(2)+71                                 0055.000
 30      COMPID(I-FIRSTC(2)+1)=LINE(I)                                  0056.000
         GO TO 11                                                       0057.000
 12      IF (TAG.NE.'CELL') GO TO 13                                    0058.000
         CALL CELLIN(LINE,NFIELD,FIRSTC,FWIDTH)                         0059.000
         GO TO 11                                                       0060.000
 13      IF (TAG.NE.'CELLSD') GO TO 14                                  0061.000
         CALL CLSDIN(LINE,NFIELD,FIRSTC,FWIDTH)                         0062.000
         GO TO 11                                                       0063.000
 14      IF (TAG.NE.'LAMBDA') GO TO 27                                  0064.000
         CALL LAMBIN(LINE,NFIELD,FIRSTC,FWIDTH)                         0065.000
         GO TO 11                                                       0066.000
 27      IF (TAG.NE.'LATT') GO TO 15                                    0067.000
         CALL LATTIN(LINE,NFIELD,FIRSTC,FWIDTH)                         0068.000
         GO TO 11                                                       0069.000
 15      IF (TAG.NE.'SYMM') GO TO 16                                    0070.000
         CALL SYMMIN(LINE,FIRSTC)                                       0071.000
         GO TO 11                                                       0072.000
 16      IF (TAG.NE.'SFAC') GO TO 17                                    0073.000
         CALL SFACIN(LINE,NFIELD,FIRSTC,FWIDTH)                         0074.000
         GO TO 11                                                       0075.000
 17      IF (TAG.NE.'CONTENTS') GO TO 18                                0076.000
         CALL CONTIN(LINE,NFIELD,FIRSTC,FWIDTH)                         0077.000
         GO TO 11                                                       0078.000
 18      IF (TAG.NE.'SCALE') GO TO 19                                   0079.000
         CALL SCALIN(LINE,NFIELD,FIRSTC,FWIDTH)                         0080.000
         GO TO 11                                                       0081.000
 19      IF (TAG.NE.'EXTINCTN') GO TO 24                                0082.000
         CALL EXTIN(LINE,NFIELD,FIRSTC,FWIDTH)                          0083.000
         GO TO 11                                                       0084.000
 24      IF (TAG.NE.'ATOM') GO TO 21                                    0085.000
         SHELX=.FALSE.                                                  0086.000
 50      CALL ATOMIN(LINE,NFIELD,FIRSTC,FWIDTH,SHELX)                   0087.000
         GO TO 11                                                       0088.000
 21      IF (TAG.NE.'ATOMSD') GO TO 25                                  0089.000
         CALL ATSDIN(LINE,NFIELD,FIRSTC,FWIDTH)                         0090.000
         GO TO 11                                                       0091.000
 25      IF (TAG.NE.'ETA') GO TO 229                                    0092.000
         CALL FDPIN(LINE,NFIELD,FIRSTC,FWIDTH)                          0093.000
         GO TO 11                                                       0094.000
 229     SHELX=.TRUE.                                                   0095.000
         GO TO 50                                                       0096.000
 10      RETURN                                                         0097.000
 28      WRITE (6,103)                                                  0098.000
 103     FORMAT (' MODEL FILE ENDS ON CONTINUATION LINE')               0099.000
         STOP                                                           0100.000
         END                                                            0101.000
         SUBROUTINE ATOMIN(LINE,NFIELD,FIRSTC,FWIDTH,SHELX)             0102.000
         CHARACTER LINE(148),COMPID(72),SYMBOL(8)                       0103.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0104.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0105.000
         LOGICAL SHELX                                                  0106.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0107.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0108.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0109.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0110.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0111.000
         EQUIVALENCE (TAG,SYMBOL(1))                                    0112.000
         NATOM=NATOM+1                                                  0113.000
         IF (SHELX) THEN                                                0114.000
         L=1                                                            0115.000
         ELSE                                                           0116.000
         L=2                                                            0117.000
         ENDIF                                                          0118.000
         NF=0                                                           0119.000
         DO 10 I=L,NFIELD                                               0120.000
         IF (SHELX.AND.I.EQ.2) GO TO 10                                 0121.000
         J=FIRSTC(I)                                                    0122.000
         IF (.NOT.(LINE(J).EQ.'C'.AND.LINE(J+1).EQ.'N')) GO TO 11       0123.000
         CALL IFORMT(LINE,J+2,FWIDTH(I)-2,CN(NATOM))                    0124.000
         GO TO 10                                                       0125.000
 11      NF=NF+1                                                        0126.000
         IF (NF.GT.11) GO TO 18                                         0127.000
         GO TO (12,13,13,13,16,17,17,17,17,17,17),NF                    0128.000
 12      CALL AFORMT(LINE,FIRSTC(I),FWIDTH(I),LABEL(NATOM))             0129.000
         IF (SHELX) THEN                                                0130.000
         CALL IFORMT(LINE,FIRSTC(I+1),FWIDTH(I+1),NFTYPE(NATOM))        0131.000
         IF (NFTYPE(NATOM).GT.NTYPE) THEN                               0132.000
         WRITE (6,52) LABEL(NATOM)                                      0133.000
 52      FORMAT (1X,A8,'TYPE NUMBER OUT OF RANGE <<<<<<<<<')            0134.000
         STOP                                                           0135.000
         ENDIF                                                          0136.000
         ELSE                                                           0137.000
         TAG=LABEL(NATOM)                                               0138.000
         DO 30 J=1,8                                                    0139.000
         IF (SYMBOL(J).EQ.'(') GO TO 31                                 0140.000
 30      CONTINUE                                                       0141.000
         J=9                                                            0142.000
 31      IF (J.GT.8) GO TO 33                                           0143.000
         DO 32 K=J,8                                                    0144.000
 32      SYMBOL(K)=' '                                                  0145.000
 33      DO 34 J=1,NTYPE                                                0146.000
         IF (TAG.EQ.FTYPE(J)) GO TO 35                                  0147.000
 34      CONTINUE                                                       0148.000
         CALL LOOKUP(10,TAG)                                            0149.000
         J=NTYPE                                                        0150.000
 35      NFTYPE(NATOM)=J                                                0151.000
         ENDIF                                                          0152.000
         GO TO 10                                                       0153.000
 13      CALL FFORMT(LINE,FIRSTC(I),FWIDTH(I),P(NF-1,NATOM))            0154.000
         GO TO 10                                                       0155.000
 16      CALL FFORMT(LINE,FIRSTC(I),FWIDTH(I),SOF(NATOM))               0156.000
         GO TO 10                                                       0157.000
 17      IF (SHELX.AND.NF.GT.8) THEN                                    0158.000
         CALL FFORMT(LINE,FIRSTC(I),FWIDTH(I),UIJ(15-NF,NATOM))         0159.000
         ELSE                                                           0160.000
         CALL FFORMT(LINE,FIRSTC(I),FWIDTH(I),UIJ(NF-5,NATOM))          0161.000
         ENDIF                                                          0162.000
 10      CONTINUE                                                       0163.000
 18      IF (NF.LE.6.OR.NF.EQ.11) RETURN                                0164.000
         DO 19 I=2,6                                                    0165.000
 19      UIJ(I,NATOM)=0.                                                0166.000
         WRITE (6,102) LABEL(NATOM)                                     0167.000
 102     FORMAT (' ATOM ',A8,' HAS INVALID UIJ PARAMETERS. SET ISOTROPIC0168.000
     1   ')                                                             0169.000
         RETURN                                                         0170.000
         END                                                            0171.000
         SUBROUTINE LATTIN(LINE,NFIELD,FIRSTC,FWIDTH)                   0172.000
         CHARACTER LINE(148),COMPID(72)                                 0173.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0174.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0175.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0176.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0177.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0178.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0179.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0180.000
         CALL AFORMT(LINE,FIRSTC(2),FWIDTH(2),TAG)                      0181.000
         IF (TAG.NE.'A') GO TO 11                                       0182.000
         ICENT=1                                                        0183.000
         GO TO 12                                                       0184.000
 11      IF (TAG.EQ.'C') GO TO 13                                       0185.000
 10      WRITE (6,100) TAG                                              0186.000
 100     FORMAT (' INVALID CENTRICITY OR LATTICE TYPE: ',A8)            0187.000
         STOP                                                           0188.000
 13      ICENT=0                                                        0189.000
 12      IF (NFIELD.LT.3) RETURN                                        0190.000
         CALL AFORMT(LINE,FIRSTC(3),FWIDTH(3),TAG)                      0191.000
         IF (TAG.EQ.'P') RETURN                                         0192.000
         IF (TAG.NE.'R') GO TO 17                                       0193.000
         NT=3                                                           0194.000
         T(1,2)=1/3.                                                    0195.000
         T(2,2)=2/3.                                                    0196.000
         T(3,2)=2/3.                                                    0197.000
         T(1,3)=2/3.                                                    0198.000
         T(2,3)=1/3.                                                    0199.000
         T(3,3)=1/3.                                                    0200.000
         RETURN                                                         0201.000
 17      NT=2                                                           0202.000
         T(1,2)=0.5                                                     0203.000
         T(2,2)=0.5                                                     0204.000
         T(3,2)=0.5                                                     0205.000
         IF (TAG.EQ.'I') RETURN                                         0206.000
         IF (TAG.NE.'A') GO TO 14                                       0207.000
         T(1,2)=0.                                                      0208.000
         RETURN                                                         0209.000
 14      IF (TAG.NE.'B') GO TO 15                                       0210.000
         T(2,2)=0.                                                      0211.000
         RETURN                                                         0212.000
 15      IF (TAG.NE.'C') GO TO 16                                       0213.000
         T(3,2)=0.                                                      0214.000
         RETURN                                                         0215.000
 16      IF (TAG.NE.'F') GO TO 10                                       0216.000
         NT=4                                                           0217.000
         T(3,2)=0.                                                      0218.000
         T(1,3)=0.5                                                     0219.000
         T(3,3)=0.5                                                     0220.000
         T(2,4)=0.5                                                     0221.000
         T(3,4)=0.5                                                     0222.000
         RETURN                                                         0223.000
         END                                                            0224.000
         SUBROUTINE CRDIN(LINE,J,A1,A2,A3,T,TERMIN,EMPTY)               0225.000
         CHARACTER LINE(148),COMPID(72),CHARA,DIGIT(10),CHARB(148)      0226.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0227.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13),SIG           0228.000
         REAL NUMBER                                                    0229.000
         LOGICAL FIRST,TERMIN,EMPTY                                     0230.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0231.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0232.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0233.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),S(3,4),ICENT,                 0234.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0235.000
         DATA DIGIT/'1','2','3','4','5','6','7','8','9','0'/,           0236.000
     1   CHARB/148*' '/                                                 0237.000
         EMPTY=.TRUE.                                                   0238.000
         A1=0.                                                          0239.000
         A2=0.                                                          0240.000
         A3=0.                                                          0241.000
         T=0.                                                           0242.000
C        SET SIG                                                        0243.000
 10      SIG=1                                                          0244.000
         NUM=0                                                          0245.000
         FIRST=.TRUE.                                                   0246.000
C        CLEAR B                                                        0247.000
 11      K=1                                                            0248.000
C        NEXT                                                           0249.000
 12      J=J+1                                                          0250.000
         IF (J.LE.145) GO TO 36                                         0251.000
         CHARA=';'                                                      0252.000
         GO TO 18                                                       0253.000
 36      CHARA=LINE(J)                                                  0254.000
         IF (CHARA.EQ.' ') GO TO 12                                     0255.000
         EMPTY=.FALSE.                                                  0256.000
         IF (CHARA.EQ.'+'.OR.CHARA.EQ.'-') GO TO 13                     0257.000
         IF (CHARA.EQ.'X'.OR.CHARA.EQ.'Y'.OR.CHARA.EQ.'Z') GO TO 14     0258.000
         IF (CHARA.EQ.'/') GO TO 15                                     0259.000
         DO 16 I=1,10                                                   0260.000
         IF (CHARA.EQ.DIGIT(I)) GO TO 17                                0261.000
 16      CONTINUE                                                       0262.000
         GO TO 18                                                       0263.000
C        DIGITS                                                         0264.000
 17      K=K+1                                                          0265.000
         CHARB(K)=CHARA                                                 0266.000
         FIRST=.FALSE.                                                  0267.000
         GO TO 12                                                       0268.000
C        SLASH                                                          0269.000
15       IF (K.EQ.1) GO TO 19                                           0270.000
         CALL IFORMT(CHARB,2,K-1,NUM)                                   0271.000
         GO TO 11                                                       0272.000
19       NUM=0                                                          0273.000
         GO TO 11                                                       0274.000
C        XYZ                                                            0275.000
14       IF (K.EQ.1) GO TO 24                                           0276.000
         CALL FFORMT(CHARB,2,K-1,NUMBER)                                0277.000
         IF (NUM.EQ.0) GO TO 21                                         0278.000
         NUMBER=SIG*NUM/NUMBER                                          0279.000
         GO TO 23                                                       0280.000
 21      NUMBER=SIG*NUMBER                                              0281.000
         GO TO 23                                                       0282.000
 24      NUMBER=SIG                                                     0283.000
 23      IF (CHARA.NE.'X') GO TO 25                                     0284.000
         A1=NUMBER                                                      0285.000
         GO TO 10                                                       0286.000
 25      IF (CHARA.NE.'Y') GO TO 26                                     0287.000
         A2=NUMBER                                                      0288.000
         GO TO 10                                                       0289.000
 26      A3=NUMBER                                                      0290.000
         GO TO 10                                                       0291.000
C        SIGNS                                                          0292.000
 13      IF (.NOT.FIRST) GO TO 27                                       0293.000
         IF (CHARA.NE.'+') GO TO 28                                     0294.000
         SIG=1                                                          0295.000
         GO TO 29                                                       0296.000
 28      SIG=-1                                                         0297.000
 29      FIRST=.FALSE.                                                  0298.000
 27      IF (K.EQ.1) GO TO 30                                           0299.000
         CALL FFORMT(CHARB,2,K-1,T)                                     0300.000
         IF (NUM.EQ.0) GO TO 32                                         0301.000
         T=SIG*NUM/T                                                    0302.000
         GO TO 33                                                       0303.000
 32      T=SIG*T                                                        0304.000
 33      IF (CHARA.NE.'+') GO TO 31                                     0305.000
         SIG=1                                                          0306.000
         GO TO 30                                                       0307.000
 31      SIG=-1                                                         0308.000
 30      NUM=0                                                          0309.000
         GO TO 11                                                       0310.000
C         TERMINATOR                                                    0311.000
 18      IF (CHARA.NE.','.AND.CHARA.NE.';') WRITE (6,100) CHARA         0312.000
 100     FORMAT (' WRONG EQUIVALENT POSITION DELIMITER: ',A1)           0313.000
         TERMIN=CHARA.EQ.';'                                            0314.000
         IF (NUM.EQ.0.AND.K.EQ.1) RETURN                                0315.000
         IF (K.EQ.1) GO TO 35                                           0316.000
         CALL FFORMT(CHARB,2,K-1,T)                                     0317.000
         GO TO 22                                                       0318.000
 35      T=0.                                                           0319.000
 22      IF (NUM.EQ.0) GO TO 34                                         0320.000
         T=SIG*NUM/T                                                    0321.000
         RETURN                                                         0322.000
 34      T=SIG*T                                                        0323.000
         RETURN                                                         0324.000
         END                                                            0325.000
         SUBROUTINE SYMMIN(LINE,FIRSTC)                                 0326.000
         CHARACTER LINE(148),COMPID(72)                                 0327.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0328.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13),START         0329.000
         LOGICAL SEMICO,EMPTY                                           0330.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0331.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0332.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0333.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0334.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0335.000
         START=FIRSTC(2)-1                                              0336.000
 11      NR=NR+1                                                        0337.000
         DO 10 I=1,3                                                    0338.000
         CALL CRDIN(LINE,START,R(NR,I,1),R(NR,I,2),R(NR,I,3),           0339.000
     1   R(NR,I,4),SEMICO,EMPTY)                                        0340.000
         IF (.NOT.EMPTY) GO TO 12                                       0341.000
         NR=NR-1                                                        0342.000
         RETURN                                                         0343.000
 12      IF (.NOT.((SEMICO.AND.I.NE.3).OR.(.NOT.SEMICO.AND.I.EQ.3)))    0344.000
     1   GO TO 10                                                       0345.000
         WRITE (6,100)                                                  0346.000
 100     FORMAT (' EQUIVALENT POSITION SEQUENCE IS INCORRECT')          0347.000
         STOP                                                           0348.000
 10      CONTINUE                                                       0349.000
C        IGNORE IDENTITY OPERATION                                      0350.000
         DO 102 I=1,3                                                   0351.000
         IF (R(NR,I,I).NE.1.) GO TO 13                                  0352.000
         DO 101 J=1,4                                                   0353.000
         IF (I.EQ.J) GO TO 101                                          0354.000
         IF (R(NR,I,J).NE.0.) GO TO 13                                  0355.000
 101     CONTINUE                                                       0356.000
 102     CONTINUE                                                       0357.000
         NR=NR-1                                                        0358.000
 13      IF (START.LT.145) GO TO 11                                     0359.000
         RETURN                                                         0360.000
         END                                                            0361.000
         SUBROUTINE CELLIN(LINE,NFIELD,FIRSTC,FWIDTH)                   0362.000
         CHARACTER LINE(148),COMPID(72)                                 0363.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0364.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0365.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0366.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0367.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0368.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0369.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0370.000
         IF (NFIELD.GE.4.AND.NFIELD.LE.7) GO TO 10                      0371.000
         WRITE (6,100)                                                  0372.000
 100     FORMAT (' UNIT CELL DATA INVALID')                             0373.000
         STOP                                                           0374.000
 10      DO 11 I=2,NFIELD                                               0375.000
 11      CALL FFORMT(LINE,FIRSTC(I),FWIDTH(I),CELL(I-1))                0376.000
         DO 12 I=4,6                                                    0377.000
         IF (CELL(I).GT.1.0) CELL(I)=COS(CELL(I)*0.0174533)             0378.000
 12      CONTINUE                                                       0379.000
         RETURN                                                         0380.000
         END                                                            0381.000
         SUBROUTINE LAMBIN(LINE,NFIELD,FIRSTC,FWIDTH)                   0382.000
         CHARACTER LINE(148),COMPID(72)                                 0383.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0384.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0385.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0386.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0387.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0388.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0389.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0390.000
         CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),WAVEL)                    0391.000
         RETURN                                                         0392.000
         END                                                            0393.000
         SUBROUTINE SFACIN(LINE,NFIELD,FIRSTC,FWIDTH)                   0394.000
         CHARACTER LINE(148),COMPID(72)                                 0395.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0396.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0397.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0398.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0399.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0400.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0401.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0402.000
         NTYPE=NTYPE+1                                                  0403.000
         CALL AFORMT(LINE,FIRSTC(2),FWIDTH(2),FTYPE(NTYPE))             0404.000
         IF (NFIELD.GE.13.AND.NFIELD.LE.16) GO TO 10                    0405.000
         WRITE (6,100) FTYPE(NTYPE)                                     0406.000
 100     FORMAT (' SFAC ',A8,' DATA INVALID')                           0407.000
         STOP                                                           0408.000
 10      DO 11 I=3,NFIELD                                               0409.000
 11      CALL FFORMT(LINE,FIRSTC(I),FWIDTH(I),SFAC(I-2,NTYPE))          0410.000
         RETURN                                                         0411.000
         END                                                            0412.000
         SUBROUTINE SCALIN(LINE,NFIELD,FIRSTC,FWIDTH)                   0413.000
         CHARACTER LINE(148),COMPID(72)                                 0414.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0415.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0416.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0417.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0418.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0419.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0420.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0421.000
         NQ=NFIELD-1                                                    0422.000
         IF (NQ.GT.4) THEN                                              0423.000
         WRITE (6,11)                                                   0424.000
 11      FORMAT (' MAXIMUM 4 SCALE FACTORS ALLOWED - REMAINDER IGNORED')0425.000
         NQ=4                                                           0426.000
         ENDIF                                                          0427.000
         IF (NQ.LT.1) THEN                                              0428.000
         WRITE (6,10)                                                   0429.000
 10      FORMAT (' SCALE ENTRY IN MODEL FILE HAS NO PARAMETERS - IGNORED0430.000
     1')                                                                0431.000
         RETURN                                                         0432.000
         ENDIF                                                          0433.000
         DO 1 I=1,NQ                                                    0434.000
 1       CALL FFORMT(LINE,FIRSTC(I+1),FWIDTH(I+1),SCALE(I))             0435.000
         RETURN                                                         0436.000
         END                                                            0437.000
      SUBROUTINE PARSE(LINE,J,NPOS,LENGTH)                              0438.000
C     GIVEN A LINE OF INPUT, RETURNS NUMBER OF FIELDS,                  0439.000
C     BEGINNING AND LENGTH OF EACH FIELD                                0440.000
      CHARACTER LINE(148)                                               0441.000
      DIMENSION NPOS(20),LENGTH(20)                                     0442.000
         J=0                                                            0443.000
         I=1                                                            0444.000
 1       I=I+1                                                          0445.000
         IF (I.GT.145) RETURN                                           0446.000
         IF (LINE(I).EQ.' ') GO TO 1                                    0447.000
         J=J+1                                                          0448.000
         IF (J.GT.20) THEN                                              0449.000
         J=20                                                           0450.000
         RETURN                                                         0451.000
         ENDIF                                                          0452.000
         NPOS(J)=I                                                      0453.000
         IF (LINE(I).EQ.',') GO TO 3                                    0454.000
 2       I=I+1                                                          0455.000
         IF (I.GT.145) GO TO 3                                          0456.000
         IF (LINE(I).NE.' '.AND.LINE(I).NE.',') GO TO 2                 0457.000
 3       LENGTH(J)=MIN(20,I-NPOS(J))                                    0458.000
         GO TO 1                                                        0459.000
      END                                                               0460.000
      SUBROUTINE AFORMT(LINE,ISTART,LENGTH,VALUE)                       0461.000
C     PACKS A CHARACTER STRING OF GIVEN FIELD-POSITION & WIDTH          0462.000
      CHARACTER*8 VALUE                                                 0463.000
         CHARACTER*20 VBUF                                              0464.000
         CHARACTER*80 SPEC                                              0465.000
      CHARACTER  BUF(20),LINE(148)                                      0466.000
         EQUIVALENCE(BUF(1),VBUF)                                       0467.000
         IF (LENGTH.EQ.0) RETURN                                        0468.000
         IF (LENGTH.GT.8) GO TO 2                                       0469.000
         DO 1 I=ISTART,ISTART+LENGTH-1                                  0470.000
 1       BUF(I-ISTART+1)=LINE(I)                                        0471.000
      WRITE (SPEC,10) LENGTH                                            0472.000
 10   FORMAT('(A',        I1,')')                                       0473.000
      READ (VBUF,SPEC,ERR=2) VALUE                                      0474.000
      RETURN                                                            0475.000
 2       WRITE (6,11) ISTART-1,(LINE(I),I=2,145)                        0476.000
 11      FORMAT (' I CAN''T READ FIELD STARTING AT CHARACTER',I4,' IN TH0477.000
     1IS LINE:'/(1X,72A1))                                              0478.000
         VALUE=' '                                                      0479.000
         RETURN                                                         0480.000
      END                                                               0481.000
      SUBROUTINE FFORMT(LINE,ISTART,LENGTH,VALUE)                       0482.000
C     DECODES A FLOATING-POINT NUMBER OF GIVEN FIELD-POSITION & WIDTH   0483.000
      CHARACTER          LINE(148),BUF(20)                              0484.000
         CHARACTER*20 VBUF                                              0485.000
         CHARACTER*80 SPEC                                              0486.000
         EQUIVALENCE (BUF(1),VBUF)                                      0487.000
         IF (LENGTH.EQ.0) RETURN                                        0488.000
         DO 1 I=ISTART,ISTART+LENGTH-1                                  0489.000
 1       BUF(I-ISTART+1)=LINE(I)                                        0490.000
      WIDTH=LENGTH                                                      0491.000
      WRITE (SPEC,10)       WIDTH                                       0492.000
 10   FORMAT('(F',        F4.1,')')                                     0493.000
         READ (VBUF,SPEC,ERR=2) VALUE                                   0494.000
      RETURN                                                            0495.000
 2       WRITE (6,11) ISTART-1,(LINE(I),I=2,145)                        0496.000
 11      FORMAT (' I CAN''T READ FIELD STARTING AT CHARACTER',I4,' IN TH0497.000
     1IS LINE:'/(1X,72A1))                                              0498.000
         RETURN                                                         0499.000
      END                                                               0500.000
      SUBROUTINE IFORMT(LINE,ISTART,LENGTH,IVALUE)                      0501.000
C     DECODES AN INTEGER OF GIVEN FIELD-POSITION & WIDTH                0502.000
      CHARACTER          LINE(148),BUF(20)                              0503.000
         CHARACTER*20 VBUF                                              0504.000
         CHARACTER*80 SPEC                                              0505.000
         EQUIVALENCE (BUF(1),VBUF)                                      0506.000
         IF (LENGTH.EQ.0) RETURN                                        0507.000
         DO 1 I=ISTART,ISTART+LENGTH-1                                  0508.000
 1       BUF(I-ISTART+1)=LINE(I)                                        0509.000
      WRITE (SPEC,10)       LENGTH                                      0510.000
 10   FORMAT('(I',        I2,  ')')                                     0511.000
         READ (VBUF,SPEC,ERR=2) IVALUE                                  0512.000
      RETURN                                                            0513.000
 2       WRITE (6,11) ISTART-1,(LINE(I),I=2,145)                        0514.000
 11      FORMAT (' I CAN''T READ FIELD STARTING AT CHARACTER',I4,' IN TH0515.000
     1IS LINE:'/(1X,72A1))                                              0516.000
         RETURN                                                         0517.000
      END                                                               0518.000
         SUBROUTINE MDLOUT(LFC)                                         0519.000
         CHARACTER COMPID(72)                                           0520.000
         CHARACTER*8 LABEL(200),FTYPE(13)                               0521.000
         INTEGER CN(200),CONTNT(13)                                     0522.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0523.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0524.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0525.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0526.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0527.000
         WRITE (LFC,100) COMPID                                         0528.000
 100     FORMAT (' TITLE ',72A1)                                        0529.000
         WRITE (LFC,101) (CELL(I),I=1,3),(ACOS(CELL(I))*57.29578,I=4,6) 0530.000
 101     FORMAT (' CELL ',3F11.4,3F9.3)                                 0531.000
         IF (ECELL(1).GT.0.) WRITE (LFC,102) (ECELL(I),I=1,3),          0532.000
     1   (ECELL(I)*57.29578/SQRT(1.-CELL(I)*CELL(I)),I=4,6)             0533.000
 102     FORMAT (' CELLSD ',3F11.4,3F9.3)                               0534.000
         IF (WAVEL.GT.0.) WRITE (LFC,200) WAVEL                         0535.000
 200     FORMAT (' LAMBDA ',F10.5)                                      0536.000
         IF (ICENT.EQ.1.OR.NT.GT.1) CALL LATOUT(LFC)                    0537.000
         IF (NR.GT.1) CALL SYMOUT(LFC)                                  0538.000
         IF (NTYPE.GT.0) WRITE (LFC,103) (FTYPE(I),(SFAC(J,I),J=1,14),  0539.000
     1   I=1,NTYPE)                                                     0540.000
         IF (CONTNT(1).GT.0) WRITE (LFC,104) (CONTNT(I),FTYPE(I),       0541.000
     1   I=1,NTYPE)                                                     0542.000
         WRITE (LFC,105) (SCALE(I),I=1,NQ)                              0543.000
 103     FORMAT (' SFAC ',A8,5F9.5,F10.5,' ='/3F10.5,2F8.3,F10.3,2F8.3) 
 104     FORMAT (' CONTENTS ',I4,A8,I4,A8,I4,A8,I4,A8,I4,A8)            0545.000
 105     FORMAT (' SCALE ',5F10.5)                                      0546.000
         IF (EXTNCT.GT.0.) WRITE (LFC,108) EXTNCT                       0547.000
 108     FORMAT (' EXTINCTN ',F10.5)                                    0548.000
         IF (ETA.NE.1.) WRITE (LFC,109) ETA                             0549.000
 109     FORMAT (' ETA '  ,F10.5)                                       0550.000
         IF (NATOM.GT.0)  WRITE (LFC,106) (LABEL(I),(P(J,I),J=1,3),     0551.000
     1   SOF(I),CN(I),(UIJ(J,I),J=1,6),I=1,NATOM)                       0552.000
 106     FORMAT (' ATOM ',A8,4F10.5,' CN',I1,' ='/6F10.5)               0553.000
         IF (NATOM.EQ.0) GO TO 10                                       0554.000
         DO 11 I=1,NATOM                                                0555.000
         DO 12 J=1,3                                                    0556.000
         IF (EP(J,I).GT.0.) GO TO 13                                    0557.000
 12      CONTINUE                                                       0558.000
         IF (ESOF(I).GT.0.) GO TO 13                                    0559.000
         IF (EUIJ(1,I).EQ.0.) GO TO 11                                  0560.000
 13      WRITE (LFC,107) LABEL(I),(EP(J,I),J=1,3),ESOF(I),              0561.000
     1   (EUIJ(J,I),J=1,6)                                              0562.000
 107     FORMAT (' ATOMSD ',A8,4F10.5,' ='/6F10.5)                      0563.000
 11      CONTINUE                                                       0564.000
 10      RETURN                                                         0565.000
         END                                                            0566.000
         SUBROUTINE LATOUT(LFC)                                         0567.000
         CHARACTER TAG1,TAG2,CHAR(7),COMPID(72)                         0568.000
         CHARACTER*8 LABEL(200),FTYPE(13)                               0569.000
         INTEGER CN(200),CONTNT(13)                                     0570.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0571.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0572.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0573.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0574.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0575.000
         DATA CHAR/'A','B','C','F','I','P','R'/                         0576.000
         TAG1=CHAR(3)                                                   0577.000
         IF (ICENT.EQ.1) TAG1=CHAR(1)                                   0578.000
         TAG2=CHAR(6)                                                   0579.000
         IF (NT.EQ.1) GO TO 10                                          0580.000
         IF (NT-3) 11,15,16                                             0581.000
 16      TAG2=CHAR(4)                                                   0582.000
         GO TO 10                                                       0583.000
 15      TAG2=CHAR(7)                                                   0584.000
         GO TO 10                                                       0585.000
 11      IF (T(1,2).NE.0.) GO TO 12                                     0586.000
         TAG2=CHAR(1)                                                   0587.000
         GO TO 10                                                       0588.000
 12      IF (T(2,2).NE.0.) GO TO 13                                     0589.000
         TAG2=CHAR(2)                                                   0590.000
         GO TO 10                                                       0591.000
 13      IF (T(3,2).NE.0.) GO TO 14                                     0592.000
         TAG2=CHAR(3)                                                   0593.000
         GO TO 10                                                       0594.000
 14      TAG2=CHAR(5)                                                   0595.000
 10      WRITE (LFC,100) TAG1,TAG2                                      0596.000
 100     FORMAT (' LATT  ',A1,2X,A1)                                    0597.000
         RETURN                                                         0598.000
         END                                                            0599.000
         SUBROUTINE SYMOUT(LFC)                                         0600.000
         CHARACTER LINE(66),COMPID(72)                                  0601.000
         CHARACTER*8 LABEL(200),FTYPE(13)                               0602.000
         INTEGER CN(200),CONTNT(13),START                               0603.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0604.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0605.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0606.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0607.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0608.000
         DO 10 I=2,NR                                                   0609.000
         START=1                                                        0610.000
         DO 11 J=1,3                                                    0611.000
         CALL CRDOUT(LINE,START,R(I,J,1),R(I,J,2),R(I,J,3),R(I,J,4))    0612.000
         IF (J.EQ.3) GO TO 11                                           0613.000
         LINE(START)=','                                                0614.000
         START=START+1                                                  0615.000
 11      CONTINUE                                                       0616.000
         START=START-1                                                  0617.000
 10      WRITE (LFC,100) (LINE(J),J=1,START)                            0618.000
 100     FORMAT (' SYMM ',66A1)                                         0619.000
         RETURN                                                         0620.000
         END                                                            0621.000
         SUBROUTINE CRDOUT(LINE,I,A1,A2,A3,T)                           0622.000
         CHARACTER LINE(66),TAG(3),BUF(4)                               0623.000
         CHARACTER*4 CBUF                                               0624.000
         DIMENSION OUT(3)                                               0625.000
         EQUIVALENCE (BUF(1),CBUF)                                      0626.000
         DATA TAG/'X','Y','Z'/                                          0627.000
         OUT(1)=A1                                                      0628.000
         OUT(2)=A2                                                      0629.000
         OUT(3)=A3                                                      0630.000
         IF (T.EQ.0.) GO TO 10                                          0631.000
         K=INT(12*T+0.5)                                                0632.000
         DO 11 L=1,6                                                    0633.000
         IF (L.EQ.3) GO TO 11                                           0634.000
         J=L                                                            0635.000
         IF (J.EQ.2) J=3                                                0636.000
         J=7-J                                                          0637.000
         IF (MOD(K,J).NE.0) GO TO 11                                    0638.000
         K=K/J                                                          0639.000
         J=12/J                                                         0640.000
         WRITE (CBUF,100) K,J                                           0641.000
 100     FORMAT (I2,'/',I1)                                             0642.000
         DO 200 IND=I,I+3                                               0643.000
 200     LINE(IND)=BUF(IND-I+1)                                         0644.000
         I=I+4                                                          0645.000
         GO TO 10                                                       0646.000
 11      CONTINUE                                                       0647.000
 10      DO 12 J=1,3                                                    0648.000
         IF (OUT(J).EQ.0.) GO TO 12                                     0649.000
         IF (OUT(J).GT.0.) GO TO 13                                     0650.000
         WRITE (CBUF,101)                                               0651.000
 101     FORMAT (' - ')                                                 0652.000
         GO TO 14                                                       0653.000
 13      WRITE (CBUF,102)                                               0654.000
 102     FORMAT (' + ')                                                 0655.000
 14      DO 201 IND=I,I+2                                               0656.000
 201     LINE(IND)=BUF(IND-I+1)                                         0657.000
         I=I+3                                                          0658.000
         A=ABS(OUT(J))                                                  0659.000
         IF (A.EQ.1.) GO TO 15                                          0660.000
         WRITE (CBUF,103) A                                             0661.000
 103     FORMAT (F3.1)                                                  0662.000
         DO 202 IND=I,I+2                                               0663.000
 202     LINE(IND)=BUF(IND-I+1)                                         0664.000
         I=I+3                                                          0665.000
 15      LINE(I)=TAG(J)                                                 0666.000
         I=I+1                                                          0667.000
 12      CONTINUE                                                       0668.000
         RETURN                                                         0669.000
         END                                                            0670.000
         SUBROUTINE ATSDIN(LINE,NFIELD,FIRSTC,FWIDTH)                   0671.000
         CHARACTER LINE(148),COMPID(72)                                 0672.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0673.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0674.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0675.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0676.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0677.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0678.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0679.000
         DO 10 I=2,NFIELD                                               0680.000
         IF (I.GT.12) GO TO 18                                          0681.000
         NF=I-1                                                         0682.000
         GO TO (12,13,13,13,16,17,17,17,17,17,17),NF                    0683.000
 12      CALL AFORMT(LINE,FIRSTC(I),FWIDTH(I),TAG)                      0684.000
         DO 34 J=1,NATOM                                                0685.000
         IF (TAG.EQ.LABEL(J)) GO TO 35                                  0686.000
 34      CONTINUE                                                       0687.000
         WRITE (6,104) TAG                                              0688.000
 104     FORMAT (' MODEL HAS SIGMAS FOR UNDEFINED ATOM ',A8,' <<<<<<<<')0689.000
         RETURN                                                         0690.000
 35      IATOM=J                                                        0691.000
         GO TO 10                                                       0692.000
 13      CALL FFORMT(LINE,FIRSTC(I),FWIDTH(I),EP(NF-1,IATOM))           0693.000
         GO TO 10                                                       0694.000
 16      CALL FFORMT(LINE,FIRSTC(I),FWIDTH(I),ESOF(IATOM))              0695.000
         GO TO 10                                                       0696.000
 17      CALL FFORMT(LINE,FIRSTC(I),FWIDTH(I),EUIJ(NF-5,IATOM))         0697.000
 10      CONTINUE                                                       0698.000
         RETURN                                                         0699.000
 18      WRITE (6,102) LABEL(IATOM)                                     0700.000
 102     FORMAT (' EXCESS FIELDS IGNORED ON ATOMSD ',A8,' ENTRY <<<<<<')0701.000
         RETURN                                                         0702.000
         END                                                            0703.000
         SUBROUTINE CONTIN(LINE,NFIELD,FIRSTC,FWIDTH)                   0704.000
         CHARACTER LINE(148),COMPID(72),SYMBOL(8),DIGIT(10)             0705.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0706.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0707.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0708.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0709.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0710.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0711.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0712.000
         EQUIVALENCE (TAG,SYMBOL(1))                                    0713.000
         DATA DIGIT/'0','1','2','3','4','5','6','7','8','9'/            0714.000
         DO 35 I=2,NFIELD                                               0715.000
         CALL AFORMT(LINE,FIRSTC(I),FWIDTH(I),TAG)                      0716.000
         DO 30 J=1,FWIDTH(I)                                            0717.000
         DO 12 K=1,10                                                   0718.000
         IF (SYMBOL(J).EQ.DIGIT(K)) GO TO 30                            0719.000
 12      CONTINUE                                                       0720.000
         GO TO 31                                                       0721.000
 30      CONTINUE                                                       0722.000
 16      WRITE (6,13) TAG                                               0723.000
 13      FORMAT (' INVALID CONTENTS ENTRY ',A8)                         0724.000
         STOP                                                           0725.000
 31      IF (J.EQ.1) GO TO 50                                           0726.000
         DO 20 K=1,9-J                                                  0727.000
 20      SYMBOL(K)=SYMBOL(K+J-1)                                        0728.000
         DO 21 K=10-J,8                                                 0729.000
 21      SYMBOL(K)=' '                                                  0730.000
 50      DO 34 K=1,NTYPE                                                0731.000
         IF (TAG.EQ.FTYPE(K)) GO TO 36                                  0732.000
 34      CONTINUE                                                       0733.000
         CALL LOOKUP(10,TAG)                                            0734.000
         K=NTYPE                                                        0735.000
 36      IF (J.EQ.1) THEN                                               0736.000
         CONTNT(K)=1                                                    0737.000
         ELSE                                                           0738.000
         CALL IFORMT(LINE,FIRSTC(I),J-1,CONTNT(K))                      0739.000
         ENDIF                                                          0740.000
 35      CONTINUE                                                       0741.000
         RETURN                                                         0742.000
         END                                                            0743.000
         SUBROUTINE EXTIN(LINE,NFIELD,FIRSTC,FWIDTH)                    0744.000
         CHARACTER LINE(148),COMPID(72)                                 0745.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0746.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0747.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0748.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0749.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0750.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0751.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0752.000
         CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),EXTNCT)                   0753.000
         RETURN                                                         0754.000
         END                                                            0755.000
         SUBROUTINE CLSDIN(LINE,NFIELD,FIRSTC,FWIDTH)                   0756.000
         CHARACTER LINE(148),COMPID(72)                                 0757.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0758.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0759.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0760.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0761.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0762.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0763.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0764.000
         IF (NFIELD.GE.4.AND.NFIELD.LE.7) GO TO 10                      0765.000
         WRITE (6,100)                                                  0766.000
 100     FORMAT (' CELLSD DATA INVALID')                                0767.000
         STOP                                                           0768.000
 10      DO 11 I=2,NFIELD                                               0769.000
 11      CALL FFORMT(LINE,FIRSTC(I),FWIDTH(I),ECELL(I-1))               0770.000
C        CONVERT TO E.S.D. OF THE COSINE IF NECESSARY                   0771.000
         DO 12 I=4,6                                                    0772.000
         IF (ECELL(I).GT.0.001) ECELL(I)=SQRT(1.-CELL(I)*CELL(I))       0773.000
     1   *ECELL(I)*0.0174533                                            0774.000
 12      CONTINUE                                                       0775.000
         RETURN                                                         0776.000
         END                                                            0777.000
         SUBROUTINE FDPIN(LINE,NFIELD,FIRSTC,FWIDTH)                    0778.000
         CHARACTER LINE(148),COMPID(72)                                 0779.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0780.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0781.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0782.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0783.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0784.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0785.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0786.000
         CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),ETA)                      0787.000
         RETURN                                                         0788.000
         END                                                            0789.000
         SUBROUTINE LOOKUP(LFC,TAG)                                     0790.000
C        READS DATABASE FILE (LOGICAL FILE CODE LFC) UNTIL ATOM TYPE    0791.000
C        MATCHES TAG, THEN CALLS PARSE AND SFACLO TO READ THE ENTRY.    0792.000
         CHARACTER LINE(148),COMPID(72)                                 0793.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13),DTAG                      0794.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0795.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0796.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0797.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0798.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0799.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0800.000
         REWIND LFC                                                     0801.000
 11      READ(LFC,100,END=10) (LINE(I),I=2,73)                          0802.000
 100     FORMAT(144A1)                                                  0803.000
         DO 26 I=74,145                                                 0804.000
 26      LINE(I)=' '                                                    0805.000
         CALL PARSE(LINE,NFIELD,FIRSTC,FWIDTH)                          0806.000
         IF(NFIELD.EQ. 0) GO TO 11                                      0807.000
         J=FIRSTC(NFIELD)                                               0808.000
         IF (LINE(J) .NE. '=')GO TO 20                                  0809.000
         LINE(J)=' '                                                    0810.000
         READ (LFC,100,END=10)  (LINE(I),I=74,145)                      0811.000
         CALL PARSE (LINE,NFIELD,FIRSTC,FWIDTH)                         0812.000
 20      CALL AFORMT (LINE,FIRSTC(1),FWIDTH(1),DTAG)                    0813.000
         IF (DTAG.EQ.TAG) THEN                                          0814.000
         CALL SFACLO(LINE,NFIELD,FIRSTC,FWIDTH)                         0815.000
         RETURN                                                         0816.000
         ENDIF                                                          0817.000
         GO TO 11                                                       0818.000
C        NO MATCH FOUND FOR TAG                                         0819.000
 10      WRITE (6,101) TAG                                              0820.000
         STOP                                                           0821.000
 101     FORMAT (' UNRECOGNISED ATOM TYPE ',A8,' <<<<<<<<<<<')          0822.000
         END                                                            0823.000
         SUBROUTINE SFACLO(LINE,NFIELD,FIRSTC,FWIDTH)                   0824.000
         CHARACTER LINE(148),COMPID(72)                                 0825.000
         CHARACTER*8 TAG,LABEL(200),FTYPE(13)                           0826.000
         INTEGER FIRSTC(20),FWIDTH(20),CN(200),CONTNT(13)               0827.000
         COMMON/MODELC/COMPID,LABEL,FTYPE                               0828.000
         COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),           0829.000
     1   CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0830.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                 0831.000
     3   SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                      0832.000
         NTYPE=NTYPE+1                                                  0833.000
         CALL AFORMT(LINE,FIRSTC(1),FWIDTH(1),FTYPE(NTYPE))             0834.000
         IF (NFIELD .EQ.18) GO TO 10                                    0835.000
         WRITE(6,100) FTYPE(NTYPE)                                      0836.000
100      FORMAT(' DATABASE ENTRY FOR ',A8,'INVALID')                    0837.000
         STOP                                                           0838.000
10       DO 11 I=2,10                                                   0839.000
11       CALL FFORMT(LINE,FIRSTC(I),FWIDTH(I),SFAC(I-1,NTYPE))          0840.000
         CALL FFORMT(LINE,FIRSTC(17),FWIDTH(17),SFAC(13,NTYPE))         0841.000
         CALL FFORMT(LINE,FIRSTC(18),FWIDTH(18),SFAC(14,NTYPE))         0842.000
         IF (WAVEL.LT.1.0) THEN                                         0843.000
         CALL FFORMT(LINE,FIRSTC(13),FWIDTH(13),SFAC(10,NTYPE))         0844.000
         CALL FFORMT(LINE,FIRSTC(14),FWIDTH(14),SFAC(11,NTYPE))         0845.000
         CALL FFORMT(LINE,FIRSTC(16),FWIDTH(16),SFAC(12,NTYPE))         0846.000
         ELSE                                                           0847.000
         CALL FFORMT(LINE,FIRSTC(11),FWIDTH(11),SFAC(10,NTYPE))         0848.000
         CALL FFORMT(LINE,FIRSTC(12),FWIDTH(12),SFAC(11,NTYPE))         0849.000
         CALL FFORMT(LINE,FIRSTC(15),FWIDTH(15),SFAC(12,NTYPE))         0850.000
         ENDIF                                                          0851.000
         RETURN                                                         0852.000
         END                                                            0853.000
         SUBROUTINE LOC(I,J,IR,N,M,MS)                                  0854.000
         IX=I                                                           0855.000
         JX=J                                                           0856.000
         IF (MS-1) 10,20,30                                             0857.000
 10      IRX=N*(JX-1)+IX                                                0858.000
         GO TO 36                                                       0859.000
 20      IF(IX-JX) 22,24,24                                             0860.000
 22      IRX=IX+(JX*JX-JX)/2                                            0861.000
         GO TO 36                                                       0862.000
 24      IRX=JX+(IX*IX-IX)/2                                            0863.000
         GO TO 36                                                       0864.000
 30      IRX=0                                                          0865.000
         IF (IX-JX) 36,32,36                                            0866.000
 32      IRX=IX                                                         0867.000
 36      IR=IRX                                                         0868.000
         RETURN                                                         0869.000
         END                                                            0870.000
         SUBROUTINE ARRAY(MODE,I,J,N,M,S,D)                             0871.000
         DIMENSION S(9),D(9)                                            0872.000
         NI=N-I                                                         0873.000
         IF (MODE-1) 100,100,120                                        0874.000
 100     IJ=I*J+1                                                       0875.000
         NM=N*J+1                                                       0876.000
         DO 110 K=1,J                                                   0877.000
         NM=NM-NI                                                       0878.000
         DO 110 L=1,I                                                   0879.000
         IJ=IJ-1                                                        0880.000
         NM=NM-1                                                        0881.000
 110     D(NM)=S(IJ)                                                    0882.000
         GO TO 140                                                      0883.000
 120     IJ=0                                                           0884.000
         NM=0                                                           0885.000
         DO 130 K=1,J                                                   0886.000
         DO 125 L=1,I                                                   0887.000
         IJ=IJ+1                                                        0888.000
         NM=NM+1                                                        0889.000
 125     S(IJ)=D(NM)                                                    0890.000
 130     NM=NM+NI                                                       0891.000
 140     RETURN                                                         0892.000
         END                                                            0893.000
      SUBROUTINE ARRAY1(MODE,I,N,S,D)                                   0894.000
C     ARRAY CONVERSION, STORAGE MODE 1.                                 0895.000
      DIMENSION S(9),D(9)                                               0896.000
      IF (MODE-1) 1,1,2                                                 0897.000
C     DOUBLE TO SINGLE DIMENSION                                        0898.000
 2    IJ=0                                                              0899.000
      NM=0                                                              0900.000
      DO 3 K=1,I                                                        0901.000
      DO 4 L=1,K                                                        0902.000
      IJ=IJ+1                                                           0903.000
      NM=NM+1                                                           0904.000
 4    S(IJ)=D(NM)                                                       0905.000
 3    NM=NM+N-K                                                         0906.000
      RETURN                                                            0907.000
C     SINGLE TO DOUBLE CONVERSION                                       0908.000
 1    IJ=(I*(I+1))/2+1                                                  0909.000
      NM=N*I+1                                                          0910.000
      DO 5 K=1,I                                                        0911.000
      NI=I+1-K                                                          0912.000
      NM=NM-N+NI                                                        0913.000
      DO 5 L=1,NI                                                       0914.000
      IJ=IJ-1                                                           0915.000
      NM=NM-1                                                           0916.000
 5    D(NM)=S(IJ)                                                       0917.000
      RETURN                                                            0918.000
      END                                                               0919.000
         SUBROUTINE MPRD(A,B,R,N,M,MSA,MSB,L)                           0920.000
         DIMENSION A(9),B(9),R(9)                                       0921.000
C        SPECIAL CASE FOR DIAGONAL BY DIAGONAL                          0922.000
         MS=MSA*10+MSB                                                  0923.000
         IF (MS-22) 30,10,30                                            0924.000
 10      DO 20 I=1,N                                                    0925.000
 20      R(I)=A(I)*B(I)                                                 0926.000
         RETURN                                                         0927.000
C        ALL OTHER CASES                                                0928.000
 30      IR=1                                                           0929.000
         DO 90 K=1,L                                                    0930.000
         DO 90 J=1,N                                                    0931.000
         R(IR)=0                                                        0932.000
         DO 80 I=1,M                                                    0933.000
         IF (MS) 40,60,40                                               0934.000
 40      CALL LOC(J,I,IA,N,M,MSA)                                       0935.000
         CALL LOC(I,K,IB,M,L,MSB)                                       0936.000
         IF (IA) 50,80,50                                               0937.000
 50      IF (IB) 70,80,70                                               0938.000
 60      IA=N*(I-1)+J                                                   0939.000
         IB=M*(K-1)+I                                                   0940.000
 70      R(IR)=R(IR)+A(IA)*B(IB)                                        0941.000
 80      CONTINUE                                                       0942.000
 90      IR=IR+1                                                        0943.000
         RETURN                                                         0944.000
         END                                                            0945.000
      SUBROUTINE EIGEN(A,R,N,MV)                                        0946.000
      DIMENSION A(9),R(9)                                               0947.000
C     GENERATE IDENTITY MATRIX                                          0948.000
      IF (MV-1) 10,25,10                                                0949.000
 10   IQ=-N                                                             0950.000
      DO 20 J=1,N                                                       0951.000
      IQ=IQ+N                                                           0952.000
      DO 20 I=1,N                                                       0953.000
      IJ=IQ+I                                                           0954.000
      R(IJ)=0.0                                                         0955.000
      IF (I-J) 20,15,20                                                 0956.000
 15   R(IJ)=1.0                                                         0957.000
 20   CONTINUE                                                          0958.000
C     COMPUTE INITIAL & FINAL NORMS (ANORM & ANORMX)                    0959.000
 25   ANORM=0.0                                                         0960.000
      DO 35 I=1,N                                                       0961.000
      DO 35 J=I,N                                                       0962.000
      IF (I-J) 30,35,30                                                 0963.000
 30   IA=I+(J*J-J)/2                                                    0964.000
      ANORM=ANORM+A(IA)*A(IA)                                           0965.000
 35   CONTINUE                                                          0966.000
      IF (ANORM) 165,165,40                                             0967.000
 40   ANORM=1.414*SQRT(ANORM)                                           0968.000
      ANRMX=ANORM*1.0E-6/FLOAT(N)                                       0969.000
C     INITIALISE INDICATORS & COMPUTE THRESHOLD, THR                    0970.000
      IND=0                                                             0971.000
      THR=ANORM                                                         0972.000
 45   THR=THR/FLOAT(N)                                                  0973.000
 50   L=1                                                               0974.000
 55   M=L+1                                                             0975.000
C     COMPUTE SIN & COS                                                 0976.000
 60   MQ=(M*M-M)/2                                                      0977.000
      LQ=(L*L-L)/2                                                      0978.000
      LM=L+MQ                                                           0979.000
      IF (ABS(A(LM))-THR) 130,65,65                                     0980.000
 65   IND=1                                                             0981.000
      LL=L+LQ                                                           0982.000
      MM=M+MQ                                                           0983.000
      X=0.5*(A(LL)-A(MM))                                               0984.000
      Y=-A(LM)/SQRT(A(LM)*A(LM)+X*X)                                    0985.000
      IF (X) 70,75,75                                                   0986.000
 70   Y=-Y                                                              0987.000
 75   SINX=Y/SQRT(2.0*(1.0+(SQRT(1.0-Y*Y))))                            0988.000
      SINX2=SINX*SINX                                                   0989.000
      COSX=SQRT(1.0-SINX2)                                              0990.000
      COSX2=COSX*COSX                                                   0991.000
      SINCS=SINX*COSX                                                   0992.000
C     ROTATE L & M COLUMNS                                              0993.000
      ILQ=N*(L-1)                                                       0994.000
      IMQ=N*(M-1)                                                       0995.000
      DO 125 I=1,N                                                      0996.000
      IQ=(I*I-I)/2                                                      0997.000
      IF (I-L) 80,115,80                                                0998.000
 80   IF (I-M) 85,115,90                                                0999.000
 85   IM=I+MQ                                                           1000.000
      GO TO 95                                                          1001.000
 90   IM=M+IQ                                                           1002.000
 95   IF (I-L) 100,105,105                                              1003.000
 100  IL=I+LQ                                                           1004.000
      GO TO 110                                                         1005.000
 105  IL=L+IQ                                                           1006.000
 110  X=A(IL)*COSX-A(IM)*SINX                                           1007.000
      A(IM)=A(IL)*SINX+A(IM)*COSX                                       1008.000
      A(IL)=X                                                           1009.000
 115  IF(MV-1) 120,125,120                                              1010.000
 120  ILR=ILQ+I                                                         1011.000
      IMR=IMQ+I                                                         1012.000
      X=R(ILR)*COSX-R(IMR)*SINX                                         1013.000
      R(IMR)=R(ILR)*SINX+R(IMR)*COSX                                    1014.000
      R(ILR)=X                                                          1015.000
 125  CONTINUE                                                          1016.000
      X=2.0*A(LM)*SINCS                                                 1017.000
      Y=A(LL)*COSX2+A(MM)*SINX2-X                                       1018.000
      X=A(LL)*SINX2+A(MM)*COSX2+X                                       1019.000
      A(LM)=(A(LL)-A(MM))*SINCS+A(LM)*(COSX2-SINX2)                     1020.000
      A(LL)=Y                                                           1021.000
      A(MM)=X                                                           1022.000
C     TESTS FOR COMPLETION                                              1023.000
C     TEST FOR M=LAST COLUMN                                            1024.000
 130  IF (M-N) 135,140,135                                              1025.000
 135  M=M+1                                                             1026.000
      GO TO 60                                                          1027.000
C     TEST FOR L = 2ND FROM LAST COLUMN                                 1028.000
 140  IF (L-(N-1)) 145,150,145                                          1029.000
 145  L=L+1                                                             1030.000
      GO TO 55                                                          1031.000
 150  IF (IND-1) 160,155,160                                            1032.000
 155  IND=0                                                             1033.000
      GO TO 50                                                          1034.000
C     COMPARE THRESHOLD WITH FINAL NORM                                 1035.000
 160  IF (THR-ANRMX) 165,165,45                                         1036.000
C     SORT EIGENVALUES & EIGENVECTORS                                   1037.000
 165  IQ=-N                                                             1038.000
      DO 185 I=1,N                                                      1039.000
      IQ=IQ+N                                                           1040.000
      LL=I+(I*I-I)/2                                                    1041.000
      JQ=N*(I-2)                                                        1042.000
      DO 185 J=I,N                                                      1043.000
      JQ=JQ+N                                                           1044.000
      MM=J+(J*J-J)/2                                                    1045.000
      IF (A(LL)-A(MM)) 170,185,185                                      1046.000
 170  X=A(LL)                                                           1047.000
      A(LL)=A(MM)                                                       1048.000
      A(MM)=X                                                           1049.000
      IF (MV-1) 175,185,175                                             1050.000
 175  DO 180 K=1,N                                                      1051.000
      ILR=IQ+K                                                          1052.000
      IMR=JQ+K                                                          1053.000
      X=R(ILR)                                                          1054.000
      R(ILR)=R(IMR)                                                     1055.000
 180  R(IMR)=X                                                          1056.000
 185  CONTINUE                                                          1057.000
      RETURN                                                            1058.000
      END                                                               1059.000
