C        COPYRIGHT 1985 UNIVERSITY OF GLASGOW                           0001.000
C        ATOM BLOCK DIAGONAL LEAST SQUARES PROGRAM BLOCK                0002.000
C        GX PACKAGE  APRIL 1985   PAUL R. MALLINSON                     0003.000
C                                                                       0004.000
      PROGRAM BLOCKPRM                                                  0005.000
         REAL MU                                                        0006.000
      INTEGER         NV(2001),MPAR(200),JTF(200)                       0007.000
         INTEGER CN(200),CONTNT(13),FIRSTCH(20),FWIDTH(20)              0008.000
         DIMENSION VECT(2000),AM(11000),CELL(6),IREF(10,200)            0009.000
         CHARACTER LINE(148),COMPID(72)                                 0010.000
         CHARACTER*8     ATOM(200),FTYPE(13),PARAM,TAG(2)               0011.000
         CHARACTER*72 CBUF                                              0012.000
      COMMON AM,VECT,NV,    NPLAN,NPAR,NELMT,KI,SDSQ,      MKEEP,       0013.000
     1   EITPSQ,RINDX,WR,           IC,IP,IPRNT,NC,NCD,                 0014.000
     2   NUNTW,FA,FB,     MULT,JTF,MPAR,FUDGE(10),BTMBO,CELL,COMPD(10), 0015.000
     3 NDERV,TMBO,CUTO,IM,IV,ICALL,SHIFT(10),SYGMA(10),NPART            0016.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                0017.000
         COMMON/MODEL/NATOM,NMATX,NT,NTYPE,     IFA(200),X(3,200),      0018.000
     1   CN,OCC(200),BIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0019.000
     2   WAVEL,CP(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                   0020.000
     3   SFAC(14,13),CONTNT,G,GG(3),ETA,NQ,RSTAR                        0021.000
         EQUIVALENCE (AM(1),IREF),(CBUF,LINE(7))                        0022.000
         DATA LINE/148*' '/,BLANK/' '/                                  0023.000
      IC=5                                                              0024.000
      IP=3                                                              0025.000
         IPRNT=3                                                        0026.000
         NDERV=0                                                        0027.000
         NUNTW=1                                                        0028.000
         FA=0.                                                          0029.000
         FB=0.                                                          0030.000
         NC=0                                                           0031.000
         FUDGE(1)=0.8                                                   0032.000
         FUDGE(2)=0.91                                                  0033.000
         FUDGE(3)=0.71                                                  0034.000
         FUDGE(4)=1.26                                                  0035.000
         FUDGE(5)=0.6                                                   0036.000
         FUDGE(6)=1.92                                                  0037.000
         FUDGE(7)=0.85                                                  0038.000
         FUDGE(8)=0.53                                                  0039.000
         FUDGE(9)=3.12                                                  0040.000
         FUDGE(10)=1.0                                                  0041.000
         EITPSQ=78.956835                                               0042.000
         CUTO=0.                                                        0043.000
         CALL MDLIN(2)                                                  0044.000
         IF (RSTAR.GT.0..AND.WAVEL.LE.0.) THEN                          0045.000
         WRITE (6,91)                                                   0046.000
         WRITE (IP,91)                                                  0047.000
 91      FORMAT (' MODEL FILE MUST CONTAIN A VALID ''LAMBDA'' ENTRY WHEN0048.000
     1 EXTINCTION IS PRESENT')                                          0049.000
         STOP                                                           0050.000
         ENDIF                                                          0051.000
         DO 80 I=1,10                                                   0052.000
 80      COMPD(I)=BLANK                                                 0053.000
         DO 82 I=1,NATOM                                                0054.000
         JTF(I)=1                                                       0055.000
         IF (BIJ(2,I).NE.0.) JTF(I)=2                                   0056.000
         DO 78 J=1,3                                                    0057.000
 78      IREF(J,I)=1                                                    0058.000
         IREF(4,I)=0                                                    0059.000
         DO 82 J=5,10                                                   0060.000
 82      IREF(J,I)=1                                                    0061.000
         MULT=NT*(2-ICENT)                                              0062.000
         SINA=SQRT(1.-CP(4)*CP(4))                                      0063.000
         SINB=SQRT(1.-CP(5)*CP(5))                                      0064.000
         SING=SQRT(1.-CP(6)*CP(6))                                      0065.000
         V=CP(1)*CP(2)*CP(3)*SQRT(1.-CP(4)*CP(4)-CP(5)*CP(5)-CP(6)*CP(6)0066.000
     1   +2.*CP(4)*CP(5)*CP(6))                                         0067.000
         CELL(1)=CP(2)*CP(3)*SINA/V                                     0068.000
         CELL(2)=CP(1)*CP(3)*SINB/V                                     0069.000
         CELL(3)=CP(1)*CP(2)*SING/V                                     0070.000
         CELL(4)=(CP(5)*CP(6)-CP(4))/(SINB*SING)                        0071.000
         CELL(5)=(CP(4)*CP(6)-CP(5))/(SINA*SING)                        0072.000
         CELL(6)=(CP(4)*CP(5)-CP(6))/(SINA*SINB)                        0073.000
      TEMP=CELL(4)                                                      0074.000
      CELL(4)=CELL(1)*CELL(2)*CELL(6)/4.0                               0075.000
      CELL(5)=CELL(1)*CELL(3)*CELL(5)/4.0                               0076.000
      CELL(6)=CELL(2)*CELL(3)*TEMP/4.0                                  0077.000
      CELL(1)=CELL(1)*CELL(1)/4.0                                       0078.000
      CELL(2)=CELL(2)*CELL(2)/4.0                                       0079.000
      CELL(3)=CELL(3)*CELL(3)/4.0                                       0080.000
         WRITE (6,92)                                                   0081.000
 92      FORMAT (' PLEASE TYPE COMMANDS (1ST 3 LETTERS) FROM THE LIST, T0082.000
     1ERMINATED BY A BLANK LINE:'/' TITLE <TITLE>'/' CYCLES <NUMBER OF C0083.000
     2YCLES>'/' REF/NOREF  X/Y/Z/OCC/UIJ/ALL  <ATOM LABEL(S)>    2 LABEL0084.000
     3S SPECIFY A SEQUENCE'/' ANISO <ATOM TYPE>'/' LIST STRUCTURE FACTOR0085.000
     4S'/' CUT-OFF <G>'/                                                0086.000
     5' WEIGHTS <SCHEME NO.> <FA> <FB>'/                                0087.000
     6                  ' RIDE <ATOM LABEL(S)> ON <ATOM LABEL(S)>')     0088.000
 130     READ (IC,79,END=48) (LINE(I),I=2,73)                           0089.000
 79      FORMAT (80A1)                                                  0090.000
         CALL PARSE(LINE,KKK,FIRSTCH,FWIDTH)                            0091.000
         IF (KKK.EQ.0) GO TO 48                                         0092.000
         FWIDTH(1)=3                                                    0093.000
         CALL AFORMT (LINE,FIRSTCH(1),FWIDTH(1),TAG(1))                 0094.000
         IF (TAG(1).NE.'TIT') GO TO 700                                 0095.000
         READ (CBUF,81)      COMPD                                      0096.000
 81      FORMAT    (10A4)                                               0097.000
         GO TO 130                                                      0098.000
 700     IF (TAG(1).NE.'CUT') GO TO 701                                 0099.000
         IF (KKK.GT.1) CALL FFORMT(LINE,FIRSTCH(2),FWIDTH(2),CUTO)      0100.000
         GO TO 130                                                      0101.000
 701     IF (TAG(1).NE.'NOR'.AND.TAG(1).NE.'REF') GO TO 717             0102.000
         IND=0                                                          0103.000
         IF (TAG(1).EQ.  'REF') IND=1                                   0104.000
         IF (KKK.GT.1) CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),PARAM)     0105.000
         IF (KKK.GT.2) CALL AFORMT(LINE,FIRSTCH(3),FWIDTH(3),TAG(1))    0106.000
         IF (KKK.GT.3) CALL AFORMT(LINE,FIRSTCH(4),FWIDTH(4),TAG(2))    0107.000
         CALL REFIND(PARAM,TAG,KKK,NATOM,ATOM,IREF,IND)                 0108.000
         GO TO 130                                                      0109.000
 717     IF (TAG(1).NE.'ANI') GO TO 719                                 0110.000
         IF (KKK.GT.1) CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TAG(1))    0111.000
         CALL UCONV(TAG(1),BIJ,FTYPE,IFA,JTF,CELL,NATOM)                0112.000
         GO TO 130                                                      0113.000
 719     IF (TAG(1).NE.'CYC') GO TO 720                                 0114.000
         IF (KKK.GT.1) CALL IFORMT(LINE,FIRSTCH(2),FWIDTH(2),NC)        0115.000
         IF (NC.GT.10) NC=10                                            0116.000
         GO TO 130                                                      0117.000
 720     IF (TAG(1).NE.'LIS') GO TO 721                                 0118.000
         IPRNT=0                                                        0119.000
         GO TO 130                                                      0120.000
 721     IF (TAG(1).NE.'WEI') GO TO 3157                                0121.000
         IF (KKK.GT.1) THEN                                             0122.000
         CALL IFORMT(LINE,FIRSTCH(2),FWIDTH(2),NUNTW)                   0123.000
         IF (KKK.GT.2) CALL FFORMT(LINE,FIRSTCH(3),FWIDTH(3),FA)        0124.000
         IF (KKK.GT.3) CALL FFORMT(LINE,FIRSTCH(4),FWIDTH(4),FB)        0125.000
         ELSE                                                           0126.000
         WRITE (6,723)                                                  0127.000
 723     FORMAT (' SCHEME 1: WEIGHT = EXP(FA SIN**2THETA/LAMBDA**2)/SIGM0128.000
     1A**2(FO)'/11X,'NON-ZERO FB (+VE OR -VE) IS ADDED TO PFAC'/        0129.000
     2          '        2: WEIGHT = 1/(1+((FO-FB)/FA)**2)**2'/'        0130.000
     33: ALL WEIGHTS = 1.0'/' DEFAULT: SCHEME 1 WITH FA = 0, FB = 0.')  0131.000
         ENDIF                                                          0132.000
         GO TO 130                                                      0133.000
 3157    IF (TAG(1).NE.'RID') GO TO 722                                 0134.000
         IF (KKK.EQ.1.OR.KKK.GT.6) GO TO 722                            0135.000
         GO TO (722,722,3167,3168,3169),KKK-1                           0136.000
 3167    CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TAG(1))                  0137.000
         CALL AFORMT(LINE,FIRSTCH(4),FWIDTH(4),TAG(2))                  0138.000
         CALL AMATCH(L1,L2,TAG,2,NATOM,ATOM)                            0139.000
         IF (L1.EQ.0.OR.L2.EQ.0) GO TO 130                              0140.000
         JTF(L1)=MOD(JTF(L1),100)+100*L2                                0141.000
         GO TO 130                                                      0142.000
 3168    CALL AFORMT(LINE,FIRSTCH(5),FWIDTH(5),TAG(1))                  0143.000
         CALL AMATCH(L1,L2,TAG,1,NATOM,ATOM)                            0144.000
         IF (L1.EQ.0) GO TO 130                                         0145.000
         I=L1                                                           0146.000
         CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TAG(1))                  0147.000
         CALL AFORMT(LINE,FIRSTCH(3),FWIDTH(3),TAG(2))                  0148.000
         CALL AMATCH(L1,L2,TAG,2,NATOM,ATOM)                            0149.000
         IF (L1.EQ.0.OR.L2.EQ.0) GO TO 130                              0150.000
         IF (L2.LT.L1) GO TO 3182                                       0151.000
         DO 3166 J=L1,L2                                                0152.000
 3166    JTF(J)=MOD(JTF(J),100)+100*I                                   0153.000
         GO TO 130                                                      0154.000
 3169    CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TAG(1))                  0155.000
         CALL AFORMT(LINE,FIRSTCH(3),FWIDTH(3),TAG(2))                  0156.000
         CALL AMATCH(L1,L2,TAG,2,NATOM,ATOM)                            0157.000
         IF (L1.EQ.0.OR.L2.EQ.0) GO TO 130                              0158.000
         IF (L2.LT.L1) GO TO 3182                                       0159.000
         CALL AFORMT(LINE,FIRSTCH(5),FWIDTH(5),TAG(1))                  0160.000
         CALL AFORMT(LINE,FIRSTCH(6),FWIDTH(6),TAG(2))                  0161.000
         CALL AMATCH(I,J,TAG,2,NATOM,ATOM)                              0162.000
         IF (I.EQ.0.OR.J.EQ.0) GO TO 130                                0163.000
         IF (J.LT.I) GO TO 3182                                         0164.000
         IF ((J-I).NE.(L2-L1)) THEN                                     0165.000
         WRITE (6,3181) ATOM(L1),ATOM(L2),ATOM(I),ATOM(J)               0166.000
 3181    FORMAT (' RIDE COMMAND HAS INCONSISTENT SEQUENCES',4(1X,A8))   0167.000
         GO TO 130                                                      0168.000
         ENDIF                                                          0169.000
         DO 3171 J=L1,L2                                                0170.000
 3171    JTF(J)=MOD(JTF(J),100)+100*(I+J-L1)                            0171.000
         GO TO 130                                                      0172.000
 3182    WRITE (6,8) TAG                                                0173.000
 8       FORMAT (' RIDE COMMAND: LABELS ',A8,1X,A8,' HAVE INCONSISTENT S0174.000
     1EQUENCE')                                                         0175.000
         GO TO 130                                                      0176.000
 722     WRITE (6,718) TAG(1)                                           0177.000
 718     FORMAT (' INVALID COMMAND IGNORED: ',A8,' <<<<<<<<<<<<<<')     0178.000
         GO TO 130                                                      0179.000
 48   WRITE(IP,101) COMPD, COMPID                                       0180.000
  101 FORMAT(' ',10A4/' ',72A1)                                         0181.000
         WRITE (IP,4005) CUTO                                           0182.000
 4005 FORMAT('0SKIP REFLECTIONS FOR WHICH I <',F6.3,' SIGMA(I)')        0183.000
         GO TO (611,612,613,615,615),NUNTW                              0184.000
 611     WRITE (IP,620) FA                                              0185.000
 620     FORMAT ('0WEIGHT = EXP(',F5.1,' SIN**2THETA/LAMBDA**2)/SIGMA**20186.000
     1(FO)')                                                            0187.000
         IF (FB.NE.0.) WRITE (3,625) FB                                 0188.000
 625     FORMAT (F8.2,' HAS BEEN ADDED TO PFAC')                        0189.000
         GO TO 614                                                      0190.000
 612     WRITE (IP,621) FB,FA                                           0191.000
 621     FORMAT ('0WEIGHT = 1/(1+((FOBS -',F9.4,')/',F9.4,')**2)**2')   0192.000
         GO TO 614                                                      0193.000
 613      WRITE (IP,622)                                                0194.000
 622     FORMAT ('0ALL WEIGHTS = 1.0')                                  0195.000
         GO TO 614                                                      0196.000
 615     WRITE (IP,623)                                                 0197.000
 623     FORMAT ('0WEIGHTS WILL BE SET BY SUBROUTINE FUDG')             0198.000
 614  WRITE(IP,50) RSTAR,ETA,G                                          0199.000
   50 FORMAT('0EXTINCTION COEFFICIENT (RSTAR) X10**-3:',F10.4,          0200.000
     1   5X,'ETA:',F10.4/'0FC SCALE FACTOR:',F10.5)                     0201.000
      WRITE(IP,1102) CP,WAVEL                                           0202.000
 1102 FORMAT('0CELL ',3F10.3,3F10.5/')LAMBDA ',F10.5)                   0203.000
         CALL LATOUT(IP)                                                0204.000
         IF (NMATX.GT.1) CALL SYMOUT(IP)                                0205.000
         MU=0.                                                          0206.000
         DO 3000 I=1,NTYPE                                              0207.000
 3000    MU=MU+CONTNT(I)*SFAC(12,I)                                     0208.000
         MU=MU/V                                                        0209.000
         WRITE (IP,3001) MU,V                                           0210.000
 3001 FORMAT ('0LINEAR ABSORPTION COEFFICIENT MU =',F7.2,' CM**-1    CEL0211.000
     1L VOLUME =',F9.2,' A**3')                                         0212.000
         KI=1                                                           0213.000
      DO 200 I=1,NATOM                                                  0214.000
         IF (JTF(I)/100.NE.0) THEN                                      0215.000
         DO 202 J=1,3                                                   0216.000
 202     IREF(J,I)=0                                                    0217.000
         ENDIF                                                          0218.000
         DO 520 J=KI+2,KI+4                                             0219.000
 520     NV(J)=IREF(J-KI-1,I)                                           0220.000
         NV(KI+1)=IREF(4,I)                                             0221.000
         DO 521 J=KI+5,KI+5+5*(MOD(JTF(I),100)/2)                       0222.000
 521     NV(J)=IREF(J-KI,I)                                             0223.000
      KI=KI+5+5*(MOD(JTF(I),100)/2)                                     0224.000
  200 CONTINUE                                                          0225.000
      KIW=2                                                             0226.000
         NELMT=0                                                        0227.000
      DO 203 I=1,NATOM                                                  0228.000
      MPAR(I)=0                                                         0229.000
      IEND=5+5*(MOD(JTF(I),100)/2)                                      0230.000
      DO 204 J=1,IEND                                                   0231.000
      IF (NV(KIW)-1) 204,207,204                                        0232.000
  207 MPAR(I)=MPAR(I)+1                                                 0233.000
  204 KIW=KIW+1                                                         0234.000
      NELMT=NELMT+MPAR(I)*(MPAR(I)+1)/2                                 0235.000
 203  CONTINUE                                                          0236.000
      NPAR=0                                                            0237.000
      DO 1005 I=2,KI                                                    0238.000
      IF (NV(I)-1) 1005,1006,1005                                       0239.000
 1006 NPAR=NPAR+1                                                       0240.000
 1005 CONTINUE                                                          0241.000
      WRITE(IP,11115)                                                   0242.000
11115    FORMAT ('0MODEL INPUT PARAMETERS'/                             0243.000
     1                           '    ATOM     FCURVE     OCC         X 0244.000
     2        Y         Z        U11',7X,'U22',7X,'U33',7X,'U12',7X,    0245.000
     3   'U13',7X,'U23')                                                0246.000
      DO 1116 I=1,NATOM                                                 0247.000
 1116 WRITE(IP,1117)ATOM(I),IFA(I),OCC(I),X(1,I),X(2,I),X(3,I),(BIJ(K,I)0248.000
     1,K=1,6)                                                           0249.000
 1117 FORMAT(' ',3X,A8,I5,2X,10F10.5)                                   0250.000
         WRITE (IP,3163)                                                0251.000
 3163    FORMAT ('0REFINEMENT FLAGS')                                   0252.000
      KIW=2                                                             0253.000
         DO 3165 I=1,NATOM                                              0254.000
      KIWE=KIW+4+5*(MOD(JTF(I),100)/2)                                  0255.000
         WRITE (IP,3164) ATOM(I),(NV(J),J=KIW,KIWE)                     0256.000
 3164    FORMAT (1X,A8,10I5)                                            0257.000
 3165 KIW=KIWE+1                                                        0258.000
      MKEEP=1                                                           0259.000
      NPARP=NPAR+1                                                      0260.000
         IF (NC.EQ.0) THEN                                              0261.000
      NPAR=0                                                            0262.000
         NPARP=0                                                        0263.000
         NELMT=0                                                        0264.000
      DO 33 I=1,KI                                                      0265.000
   33 NV(I)=0                                                           0266.000
         IF (IPRNT.EQ.0) IPRNT=1                                        0267.000
         ENDIF                                                          0268.000
      WRITE (IP,2000) NPARP,NELMT                                       0269.000
 2000 FORMAT('0NO OF PARAMETERS TO BE REFINED =',I5/' NO OF MATRIX ELEME0270.000
     1NTS =',I5)                                                        0271.000
         IF (NC.GT.0) THEN                                              0272.000
         NPLAN=0                                                        0273.000
510      READ (50,END=501) IW1,IW2,FO,SIG                               0274.000
         IF (FO.GE.CUTO*SIG)           NPLAN=NPLAN+1                    0275.000
         GO TO 510                                                      0276.000
 501     ITIME=(0.001*NATOM+0.00015*NPAR)*NMATX*NPLAN*NC/60.+1          0277.000
      WRITE(6,1203) NC,ITIME                                            0278.000
 1203 FORMAT(' ESTIMATED RUN TIME FOR',I3,' CYCLES =',I5,' MINUTES')    0279.000
         ENDIF                                                          0280.000
         NCD=0                                                          0281.000
      CALL      BCALC                                                   0282.000
      WRITE (IP,9213)                                                   0283.000
 9213 FORMAT ('0BLOCK COMPLETED')                                       0284.000
      STOP                                                              0285.000
      END                                                               0286.000
      SUBROUTINE BSQS                                                   0287.000
C   BSQS   CALCULATION OF SHIFTS AND SIGMAS AND APPLYING THEM           0288.000
      INTEGER         NV(2001),MPAR(200),JTF(200)                       0289.000
         INTEGER CN(200),CONTNT(13)                                     0290.000
         DIMENSION VECT(2000),AM(11000),CELL(6),BTMBP(6),TMBP(6)        0291.000
         CHARACTER           COMPID(72)                                 0292.000
         CHARACTER*8     ATOM(200),FTYPE(13)                            0293.000
      COMMON AM,VECT,NV,    NPLAN,NPAR,NELMT,KI,SDSQ,      MKEEP,       0294.000
     1   EITPSQ,RINDX,WR,           IC,IP,IPRNT,NC,NCD,                 0295.000
     2   NUNTW,FA,FB,     MULT,JTF,MPAR,FUDGE(10),BTMBO,CELL,COMPD(10), 0296.000
     3 NDERV,TMBO,CUTO,IM,IV,ICALL,SHIFT(10),SYGMA(10),NPART            0297.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                0298.000
         COMMON/MODEL/NATOM,NMATX,NT,NTYPE,     IFA(200),X(3,200),      0299.000
     1   CN,OCC(200),BIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0300.000
     2   WAVEL,CP(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                   0301.000
     3   SFAC(14,13),CONTNT,G,EXTNCT(6)                                 0302.000
      BTMBO=BTMBO*FUDGE(NCD)                                            0303.000
      DO 13 I=1,6                                                       0304.000
      TMBP(I)=TMBO*CELL(I)                                              0305.000
   13 BTMBP(I)=BTMBO*CELL(I)                                            0306.000
      WRITE(IP,9712) TMBP,BTMBP                                         0307.000
 9712 FORMAT (' IN ANISOTROPIC FORM:',2(/6F11.5))                       0308.000
         IF (IPRNT.EQ.2) CALL MATPR                                     0309.000
      WRITE(IP,104) FUDGE(NCD)                                          0310.000
 104     FORMAT ('0MULTIPLIER FOR PARAMETER SHIFTS =',F6.2)             0311.000
      IF (NCD.EQ.NC) WRITE(IP,103)                                      0312.000
 103  FORMAT('0',17X,         3HOLD,10X,5HSHIFT,11X,3HNEW,10X,5HERROR,  0313.000
     14X,11HSHIFT/ERROR)                                                0314.000
      IM=1                                                              0315.000
      IV=1                                                              0316.000
      N=2                                                               0317.000
      DO 90 II=1,NATOM                                                  0318.000
      NPART=MPAR(II)                                                    0319.000
      IF(NPART) 3,3,201                                                 0320.000
  201 CALL LSUMB                                                        0321.000
      IF (NCD.EQ.NC) WRITE (IP,999) ATOM(II)                            0322.000
999   FORMAT (1X,A8)                                                    0323.000
      IF(ICALL)2,3,2                                                    0324.000
    2 WRITE(IP,101)ICALL                                                0325.000
  101 FORMAT('0SINGULAR MATRIX.  ROW AND COLUMN',I3)                    0326.000
         STOP                                                           0327.000
  3   M=1                                                               0328.000
      IEND=5+5*(MOD(JTF(II),100)/2)                                     0329.000
      DO 14 J=1,IEND                                                    0330.000
      IF (NV(N)-1)  14,5,14                                             0331.000
 5       IF (J.LT.5) THEN                                               0332.000
         PRS=1.                                                         0333.000
         ELSE IF (IEND .GT.5.AND.J.LT.8) THEN                           0334.000
         PRS=1./(EITPSQ*CELL(J-4))                                      0335.000
         ELSE IF (J.EQ.8) THEN                                          0336.000
         PRS=1./(EITPSQ*SQRT(CELL(1)*CELL(2)))                          0337.000
         ELSE IF (J.EQ.9) THEN                                          0338.000
         PRS=1./(EITPSQ*SQRT(CELL(1)*CELL(3)))                          0339.000
         ELSE IF (J.EQ.10) THEN                                         0340.000
         PRS=1./(EITPSQ*SQRT(CELL(2)*CELL(3)))                          0341.000
         ELSE                                                           0342.000
         PRS=1./EITPSQ                                                  0343.000
         ENDIF                                                          0344.000
         XXX=SHIFT(M)*FUDGE(NCD)                                        0345.000
         ERR=SYGMA(M)                                                   0346.000
         RATIO=ABS(XXX/ERR)                                             0347.000
      IF(J-1)7,7,6                                                      0348.000
 7       OLD=OCC(II)                                                    0349.000
      OCC(II)=OCC(II)+XXX                                               0350.000
         PNEW=OCC(II)                                                   0351.000
         ESOF(II)=ERR                                                   0352.000
      GO TO 8                                                           0353.000
    6 IF(J-4)9,9,10                                                     0354.000
 9       OLD=X(J-1,II)                                                  0355.000
      X(J-1,II)=X(J-1,II)+XXX                                           0356.000
         PNEW=X(J-1,II)                                                 0357.000
         EP(J-1,II)=ERR                                                 0358.000
         DO 700 I=1,NATOM                                               0359.000
         IF (JTF(I)/100.EQ.II) X(J-1,I)=X(J-1,I)+PNEW-OLD               0360.000
 700     CONTINUE                                                       0361.000
      GO TO 8                                                           0362.000
 10      OLD=BIJ(J-4,II)                                                0363.000
      IF(IEND-5)11,11,12                                                0364.000
   11 BIJ(J-4,II)=BIJ(J-4,II)+XXX                +BTMBO                 0365.000
      GO TO 601                                                         0366.000
   12 BIJ(J-4,II)=BIJ(J-4,II)+XXX                +BTMBP(J-4)            0367.000
 601     EUIJ(J-4,II)=ERR                                               0368.000
         PNEW=BIJ(J-4,II)                                               0369.000
 8       IF (NCD.EQ.NC) WRITE (IP,102) OLD*PRS,XXX*PRS,PNEW*PRS,ERR*PRS,0370.000
     1RATIO                                                             0371.000
 102  FORMAT(1H ,10X,  F12.5,3X,F12.7,2X,F12.5,2X,F12.6,4X,F8.4)        0372.000
      M=M+1                                                             0373.000
   14 N=N+1                                                             0374.000
 90   CONTINUE                                                          0375.000
      IF (NDERV) 301,301,300                                            0376.000
 300  CALL RESTX(OCC,X)                                                 0377.000
      CALL RESTB(BIJ)                                                   0378.000
 301     REWIND 4                                                       0379.000
         WRITE (4,100) COMPD,RINDX,WR,NPLAN,NCD                         0380.000
 100     FORMAT ('REMARK        ',10A4/'REMARK  R =',F7.4,' AT START OF 0381.000
     1THIS CYCLE, I.E. FOR PREVIOUS PARAMETERS.'/'REMARK  WEIGHTED R =',0382.000
     2F7.4,'  NUMBER OF REFLECTIONS =',I6/'REMARK  THIS IS CYCLE',I3)   0383.000
         CALL BCONV(BIJ,EUIJ,JTF,EITPSQ,CELL,NATOM)                     0384.000
         CALL MDLOUT(4)                                                 0385.000
      IF (NCD.LT.NC) RETURN                                             0386.000
      NPAR=0                                                            0387.000
      DO 33 I=1,KI                                                      0388.000
   33 NV(I)=0                                                           0389.000
         IF (IPRNT.EQ.0) IPRNT=1                                        0390.000
      RETURN                                                            0391.000
      END                                                               0392.000
C   LSUMB  INVERSION OF THE MATRIX    CHOLESKI METHOD                   0393.000
      SUBROUTINE LSUMB                                                  0394.000
      INTEGER         NV(2001),MPAR(200),JTF(200)                       0395.000
         INTEGER CN(200),CONTNT(13)                                     0396.000
         DIMENSION VECT(2000),AM(11000),CELL(6)                         0397.000
         CHARACTER           COMPID(72)                                 0398.000
         CHARACTER*8     ATOM(200),FTYPE(13)                            0399.000
      COMMON AM,VECT,NV,    NPLAN,NPARR,NELMT,KI,SDSQ,      MKEEP,      0400.000
     1   EITPSQ,RINDX,WR,           IC,IP,IPRNT,NC,NCD,                 0401.000
     2   NUNTW,FA,FB,     MULT,JTF,MPAR,FUDGE(10),BTMBO,CELL,COMPD(10), 0402.000
     3 NDERV,TMBO,CUTO,IM,IV,ICALL,SHIFT(10),SYGMA(10),NPAR             0403.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                0404.000
         COMMON/MODEL/NATOM,NMATX,NT,NTYPE,     IFA(200),X(3,200),      0405.000
     1   CN,OCC(200),BIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0406.000
     2   WAVEL,CP(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                   0407.000
     3   SFAC(14,13),CONTNT,G,EXTNCT(6)                                 0408.000
      ICALL=0                                                           0409.000
    2 K=IM                                                              0410.000
      IF(NPAR-1)10,8,9                                                  0411.000
    8 SHIFT(1)=VECT(IV)/AM(IM)                                          0412.000
      TAM=AM(IM)                                                        0413.000
      SYGMA(1)=SQRT(SDSQ/TAM)                                           0414.000
      IM=IM+1                                                           0415.000
      IV=IV+1                                                           0416.000
   10 RETURN                                                            0417.000
    9 DO 7 M=1,NPAR                                                     0418.000
      IMAX=M-1                                                          0419.000
      DO 6 L=M,NPAR                                                     0420.000
      SUMA=0.0                                                          0421.000
      KLI=L+IM-1                                                        0422.000
      KMI=M+IM-1                                                        0423.000
      IF(IMAX)523,523,101                                               0424.000
  101 DO 202 I=1,IMAX                                                   0425.000
      SUMA=SUMA+AM(KLI)*AM(KMI)                                         0426.000
      J=NPAR-I                                                          0427.000
      KLI=KLI+J                                                         0428.000
  202 KMI=KMI+J                                                         0429.000
  523 TERM=AM(K)-SUMA                                                   0430.000
      IF(L-M)103,103,505                                                0431.000
  103 IF(TERM)110,110,504                                               0432.000
  110 ICALL=M                                                           0433.000
         RETURN                                                         0434.000
  504 DENOM=SQRT(TERM)                                                  0435.000
      AM(K)=DENOM                                                       0436.000
      GO TO 6                                                           0437.000
  505 AM(K)=TERM/DENOM                                                  0438.000
    6 K=K+1                                                             0439.000
    7 CONTINUE                                                          0440.000
      AM(IM)=1./AM(IM)                                                  0441.000
      KDM=IM                                                            0442.000
      DO 104 L=2,NPAR                                                   0443.000
      KDM=KDM+NPAR-L+2                                                  0444.000
      TERM=1./AM(KDM)                                                   0445.000
      AM(KDM)=TERM                                                      0446.000
      KMI=IM-1                                                          0447.000
      KLI=IM+L-1                                                        0448.000
      IMAX=L-1                                                          0449.000
      DO 203 M=1,IMAX                                                   0450.000
      K=KLI                                                             0451.000
      SUMA=0.0                                                          0452.000
      DO 502 I=M,IMAX                                                   0453.000
      II=KMI+I                                                          0454.000
      SUMA=SUMA-AM(KLI)*AM(II)                                          0455.000
  502 KLI=KLI+NPAR-I                                                    0456.000
      AM(K)=SUMA*TERM                                                   0457.000
      J=NPAR-M                                                          0458.000
      KLI=K+J                                                           0459.000
  203 KMI=KMI+J                                                         0460.000
  104 CONTINUE                                                          0461.000
      K=IM                                                              0462.000
      DO 303 M=1,NPAR                                                   0463.000
      KLI=K                                                             0464.000
      DO 302 L=M,NPAR                                                   0465.000
      KMI=K                                                             0466.000
      IMAX=NPAR-L+1                                                     0467.000
      SUMA=0.0                                                          0468.000
      DO 301 I=1,IMAX                                                   0469.000
      SUMA=SUMA+AM(KLI)*AM(KMI)                                         0470.000
      KLI=KLI+1                                                         0471.000
  301 KMI=KMI+1                                                         0472.000
      AM(K)=SUMA                                                        0473.000
  302 K=K+1                                                             0474.000
  303 CONTINUE                                                          0475.000
C TO GET SIGMAS AND SHIFTS                                              0476.000
      DO 400 I=1,NPAR                                                   0477.000
      SHIFT(I)=0.0                                                      0478.000
      IJ=I+IM-1                                                         0479.000
      IJD=NPAR-1                                                        0480.000
      DO 401 J=1,NPAR                                                   0481.000
      JJ=IV+J-1                                                         0482.000
      SHIFT(I)=SHIFT(I)+AM(IJ)*VECT(JJ)                                 0483.000
      IF(J-I)402,403,404                                                0484.000
  402 IJ=IJ+IJD                                                         0485.000
      IJD=IJD-1                                                         0486.000
      GO TO 401                                                         0487.000
  403 TAM=AM(IJ)                                                        0488.000
      SYGMA(I)=SQRT(SDSQ*TAM)                                           0489.000
  404 IJ=IJ+1                                                           0490.000
  401 CONTINUE                                                          0491.000
  400 CONTINUE                                                          0492.000
      IM=IM+NPAR*(NPAR+1)/2                                             0493.000
      IV=IV+NPAR                                                        0494.000
      RETURN                                                            0495.000
      END                                                               0496.000
      SUBROUTINE MATPR                                                  0497.000
C     TO PRINT THE NORMAL MATRICES AND VECTORS. P.R.MALLINSON-JULY 1971 0498.000
      INTEGER         NV(2001),MPAR(200),JTF(200)                       0499.000
         INTEGER CN(200),CONTNT(13)                                     0500.000
         DIMENSION VECT(2000),AM(11000),CELL(6),ZERO(9)                 0501.000
         CHARACTER           COMPID(72)                                 0502.000
         CHARACTER*8     ATOM(200),FTYPE(13)                            0503.000
      COMMON AM,VECT,NV,    NPLAN,NPAR,NELMT,KI,SDSQ,      MKEEP,       0504.000
     1   EITPSQ,RINDX,WR,           IC,IP,IPRNT,NC,NCD,                 0505.000
     2   NUNTW,FA,FB,     MULT,JTF,MPAR,FUDGE(10),BTMBO,CELL,COMPD(10), 0506.000
     3 NDERV,TMBO,CUTO,IM,IV,ICALL,SHIFT(10),SYGMA(10),NPART            0507.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                0508.000
         COMMON/MODEL/NATOM,NMATX,NT,NTYPE,     IFA(200),X(3,200),      0509.000
     1   CN,OCC(200),BIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0510.000
     2   WAVEL,CP(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                   0511.000
     3   SFAC(14,13),CONTNT,G,EXTNCT(6)                                 0512.000
      DO 906 I=1,9                                                      0513.000
906   ZERO(I)=0.                                                        0514.000
      IDISP=1                                                           0515.000
      IVECT=1                                                           0516.000
      WRITE (IP,900)                                                    0517.000
900   FORMAT('0THE NORMAL MATRICES AND VECTORS ARE AS FOLLOW')          0518.000
      DO 901 II=1,NATOM                                                 0519.000
      NPART=MPAR(II)                                                    0520.000
      IF (NPART) 901,901,903                                            0521.000
903   WRITE (IP,902) ATOM(II)                                           0522.000
902   FORMAT ('0',A8)                                                   0523.000
      DO 904 I=1,NPART                                                  0524.000
      JMAX=IDISP+NPART-I                                                0525.000
      NZERO=I-1                                                         0526.000
      IF (NZERO) 907,907,908                                            0527.000
907   WRITE(IP,905) (AM(J),J=IDISP,JMAX),VECT(IVECT)                    0528.000
      GO TO 909                                                         0529.000
908   WRITE(IP,905) (ZERO(J),J=1,NZERO),(AM(J),J=IDISP,JMAX),VECT(IVECT)0530.000
905   FORMAT (1X,11E10.2)                                               0531.000
909   IDISP=JMAX+1                                                      0532.000
904   IVECT=IVECT+1                                                     0533.000
901   CONTINUE                                                          0534.000
      RETURN                                                            0535.000
      END                                                               0536.000
      SUBROUTINE FUDG (H,ISC,FO,FC,DELTA,W)                             0537.000
      INTEGER   H(3)                                                    0538.000
      RETURN                                                            0539.000
      END                                                               0540.000
      SUBROUTINE RESTX(OCC,X)                                           0541.000
      DIMENSION OCC(200),X(3,200)                                       0542.000
      RETURN                                                            0543.000
      END                                                               0544.000
      SUBROUTINE RESTB(BIJ)                                             0545.000
      DIMENSION BIJ(6,200)                                              0546.000
      RETURN                                                            0547.000
      END                                                               0548.000
      SUBROUTINE SETDR(N,I,E)                                           0549.000
      RETURN                                                            0550.000
      END                                                               0551.000
      SUBROUTINE BCALC                                                  0552.000
C   BCALC   FORMATION OF DELTA, DERIVATIVES, AND MATRIX ELEMENTS        0553.000
      INTEGER         NV(2001),MPAR(200),JTF(200)                       0554.000
         INTEGER CN(200),CONTNT(13),H(3)                                0555.000
         DIMENSION VECT(2000),AM(11000),CELL(6),SCALE(3),HS(3)          0556.000
         DIMENSION DERIV(2000),TEMP(2000),FACT(6),FF1(13)               0557.000
         CHARACTER           COMPID(72)                                 0558.000
         CHARACTER*8     ATOM(200),FTYPE(13)                            0559.000
      COMMON AM,VECT,NV,    NPLAN,NPAR,NELMT,KI,SDSQ,      MKEEP,       0560.000
     1   EITPSQ,RINDX,WR,           IC,IP,IPRNT,NC,NCD,                 0561.000
     2   NUNTW,FA,FB,     MULT,JTF,MPAR,FUDGE(10),BTMBO,CELL,COMPD(10), 0562.000
     3 NDERV,TMBO,CUTO,IM,IV,ICALL,SHIFT(10),SYGMA(10),NPART            0563.000
         COMMON/MODELC/COMPID,ATOM,FTYPE                                0564.000
         COMMON/MODEL/NATOM,NMATX,NT,NTYPE,     IFA(200),X(3,200),      0565.000
     1   CN,OCC(200),BIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),        0566.000
     2   WAVEL,CP(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                   0567.000
     3   SFAC(14,13),CONTNT,G,GG(3),ETA,NQ,RSTAR                        0568.000
79826    REWIND 50                                                      0569.000
      TWOPI=6.28318531                                                  0570.000
      SUMF=0.0                                                          0571.000
         SUMDF=0.0                                                      0572.000
      SDSQ=0.0                                                          0573.000
      SWFSQ=0.0                                                         0574.000
      SUMFC=0.0                                                         0575.000
      NPLAN=0                                                           0576.000
      AMULT=MULT                                                        0577.000
         RSTAR2=2.*RSTAR                                                0578.000
         TBAR=0.01                                                      0579.000
         DELTC=79.384*WAVEL**3/((1.-CP(4)**2-CP(5)**2-CP(6)**2          0580.000
     1+2.*CP(4)*CP(5)*CP(6))*(CP(1)*CP(2)*CP(3))**2)                    0581.000
      V1=0.0                                                            0582.000
      V2=0.0                                                            0583.000
      SCALE(1)=0.0                                                      0584.000
      SCALE(2)=0.0                                                      0585.000
      SCALE(3)=0.0                                                      0586.000
      DO 1008 I=1,NPAR                                                  0587.000
 1008 VECT(I)=0.0                                                       0588.000
      DO 1007 I=1,NELMT                                                 0589.000
 1007 AM(I)=0.0                                                         0590.000
C        CONVERT UISO TO B OR UIJ TO BETA                               0591.000
      DO 40 I=1,NATOM                                                   0592.000
         IF (MOD(JTF(I),100).NE.2) GO TO 102                            0593.000
         DO 153 J=1,3                                                   0594.000
         EUIJ(J,I)=EITPSQ*EUIJ(J,I)*CELL(J)                             0595.000
 153     BIJ(J,I)=EITPSQ*BIJ(J,I)*CELL(J)                               0596.000
         DO 105 J=1,2                                                   0597.000
         DO 105 K=J+1,3                                                 0598.000
         EUIJ(J+K+1,I)=EITPSQ*SQRT(CELL(J)*CELL(K))*EUIJ(J+K+1,I)       0599.000
 105     BIJ(J+K+1,I)=EITPSQ*SQRT(CELL(J)*CELL(K))*BIJ(J+K+1,I)         0600.000
         GO TO 40                                                       0601.000
 102     BIJ(1,I)=BIJ(1,I)*EITPSQ                                       0602.000
         EUIJ(1,I)=EUIJ(1,I)*EITPSQ                                     0603.000
   40 CONTINUE                                                          0604.000
         IF (NCD.LT.NC) THEN                                            0605.000
         WRITE (IP,51) NCD+1,COMPD                                      0606.000
 51      FORMAT ('0CYCLE',I3,5X,10A4)                                   0607.000
                        ELSE                                            0608.000
                        WRITE (IP,52) COMPD                             0609.000
 52      FORMAT ('0FINAL STRUCTURE FACTOR CALCULATION',1X,10A4)         0610.000
         END IF                                                         0611.000
      IF (IPRNT.EQ.1) WRITE(IP,50)                                      0612.000
   50 FORMAT(               '0   H    K    L      FO      FCALC        A0613.000
     1         B        SIG     DELTA'/)                                0614.000
C FCALC FOR EACH PLANE   +   DERIVATIVES                                0615.000
 209  READ(50,  END=10) IW1,IW2,FO,SIG                                  0616.000
         IF (FO.LT.CUTO*SIG) GO TO 209                                  0617.000
         IF (NUNTW.EQ.1.AND.FB.NE.0.) THEN                              0618.000
         SIG=SIG*SIG                                                    0619.000
         SIG=SIG+SIGN(FB*FB*FO*FO,FB)                                   0620.000
         SIG=SQRT(SIG)                                                  0621.000
         ENDIF                                                          0622.000
         FO=SQRT(FO)                                                    0623.000
         SIG=0.5*SIG/FO                                                 0624.000
         ISC=IW1/16777216                                               0625.000
         I=MOD(IW1,16777216)                                            0626.000
         H(1)=(I/65536)-128                                             0627.000
         I=MOD(I,65536)                                                 0628.000
         H(2)=(I/256)-128                                               0629.000
         I=MOD(I,256)                                                   0630.000
         H(3)=I-128                                                     0631.000
      IDISP=1                                                           0632.000
      IVECT=1                                                           0633.000
         SIG=SIG/G                                                      0634.000
      FO =    FO /G                                                     0635.000
      SSQ=H(1)*H(1)*CELL(1)+H(2)*H(2)*CELL(2)+H(3)*H(3)*CELL(3)+        0636.000
     1   2.*H(1)*H(2)*CELL(4)+2.*H(1)*H(3)*CELL(5)+2.*H(2)*H(3)*CELL(6) 0637.000
      M=MKEEP                                                           0638.000
      N=2                                                               0639.000
      A=0.0                                                             0640.000
      B=0.0                                                             0641.000
      C=0.0                                                             0642.000
      D=0.0                                                             0643.000
      DO 11 I=1,NPAR                                                    0644.000
      DERIV(I)=0.0                                                      0645.000
   11 TEMP(I)=0.0                                                       0646.000
         DO 126 I=1,NTYPE                                               0647.000
         FF1(I)=0.                                                      0648.000
         DO 60 K=1,8,2                                                  0649.000
 60   FF1(I)=FF1(I)+SFAC(K,I)*EXP(-SFAC(K+1,I)*SSQ)                     0650.000
 126  FF1(I)=FF1(I)+SFAC(9,I)+SFAC(10,I)                                0651.000
      DO 12 I=1,NMATX                                                   0652.000
      TS=0.0                                                            0653.000
      DO 13 II=1,3                                                      0654.000
      HS(II)=R(I,1,II)*H(1)+R(I,2,II)*H(2)+R(I,3,II)*H(3)               0655.000
      HS(II)=HS(II)*TWOPI                                               0656.000
   13 TS=TS+TWOPI*H(II)*R(I,II,4)                                       0657.000
      FACT(1)=HS(1)*HS(1)/TWOPI/TWOPI                                   0658.000
      FACT(2)=HS(2)*HS(2)/TWOPI/TWOPI                                   0659.000
      FACT(3)=HS(3)*HS(3)/TWOPI/TWOPI                                   0660.000
      FACT(4)=HS(1)*HS(2)/TWOPI/TWOPI*2.0                               0661.000
      FACT(5)=HS(1)*HS(3)/TWOPI/TWOPI*2.0                               0662.000
      FACT(6)=HS(2)*HS(3)/TWOPI/TWOPI*2.0                               0663.000
      DO 14 J=1,NATOM                                                   0664.000
      IF(MOD(JTF(J),100)-1)300,300,301                                  0665.000
  300 GEXP=EXP(-BIJ(1,J)*SSQ)                                           0666.000
      GO TO 302                                                         0667.000
  301 GEXP=BIJ(1,J)*FACT(1)+BIJ(2,J)*FACT(2)+BIJ(3,J)*FACT(3)+BIJ(4,J)*F0668.000
     1ACT(4)+BIJ(5,J)*FACT(5)+BIJ(6,J)*FACT(6)                          0669.000
      GEXP=EXP(-GEXP)                                                   0670.000
  302 ALFA=TS                                                           0671.000
      IFC=IFA(J)                                                        0672.000
      FACTR=AMULT*OCC(J)*FF1(IFC)*GEXP                                  0673.000
      DO 15 JJ=1,3                                                      0674.000
   15 ALFA=ALFA+HS(JJ)*X(JJ,J)                                          0675.000
         COSALF=COS(ALFA)                                               0676.000
         SINALF=SIN(ALFA)                                               0677.000
      ARS=COSALF*FACTR                                                  0678.000
      BRS=SINALF*FACTR                                                  0679.000
         NAST=-1                                                        0680.000
         IF (SFAC(11,IFC).EQ.0.0.OR.ETA.EQ.0.0) GO TO 4002              0681.000
         NAST=0                                                         0682.000
      FACTA=AMULT*OCC(J)*SFAC(11,IFC)*ETA*GEXP                          0683.000
      CRS=COSALF*FACTA                                                  0684.000
      DRS=SINALF*FACTA                                                  0685.000
      C=C+CRS                                                           0686.000
      D=D+DRS                                                           0687.000
 4002 IEND=5+5*(MOD(JTF(J),100)-1)                                      0688.000
      DO 16 K=1,IEND                                                    0689.000
      IF(NV(N))17,16,17                                                 0690.000
   17 IF(K-1)18,18,19                                                   0691.000
   18 DERIV(M)=DERIV(M)+ARS/OCC(J)                                      0692.000
      TEMP(M)=TEMP(M)+BRS/OCC(J)                                        0693.000
      IF(NAST)20,4004,4004                                              0694.000
 4004 DERIV(M)=DERIV(M)-DRS/OCC(J)                                      0695.000
      TEMP(M)=TEMP(M)+CRS/OCC(J)                                        0696.000
      GO TO 20                                                          0697.000
   19 IF(K-4)21,21,22                                                   0698.000
   21 DERIV(M)=DERIV(M)-HS(K-1)*BRS                                     0699.000
      TEMP(M)=TEMP(M)+HS(K-1)*ARS                                       0700.000
      IF(NAST)20,4005,4005                                              0701.000
 4005 DERIV(M)=DERIV(M)-HS(K-1)*CRS                                     0702.000
      TEMP(M)=TEMP(M)-HS(K-1)*DRS                                       0703.000
      GO TO 20                                                          0704.000
   22 IF(MOD(JTF(J),100)-1)522,522,622                                  0705.000
  522 DERIV(M)=DERIV(M)-SSQ*ARS                                         0706.000
      TEMP(M)=TEMP(M)-SSQ*BRS                                           0707.000
      IF(NAST)20,4006,4006                                              0708.000
 4006 DERIV(M)=DERIV(M)+SSQ*DRS                                         0709.000
      TEMP(M)=TEMP(M)-SSQ*CRS                                           0710.000
      GO TO 20                                                          0711.000
  622 DERIV(M)=DERIV(M)-FACT(K-4)*ARS                                   0712.000
      TEMP(M)=TEMP(M)-FACT(K-4)*BRS                                     0713.000
      IF(NAST)20,4007,4007                                              0714.000
 4007 DERIV(M)=DERIV(M)+FACT(K-4)*DRS                                   0715.000
      TEMP(M)=TEMP(M)-FACT(K-4)*CRS                                     0716.000
 20   IF (NDERV) 131,131,130                                            0717.000
 130  II=M                                                              0718.000
      E=0.                                                              0719.000
      CALL SETDR(N,II,E)                                                0720.000
      DERIV(II)=DERIV(II)+E     *DERIV(M)                               0721.000
      TEMP(II)=TEMP(II)+E     *TEMP(M)                                  0722.000
 131  IF (NV(N)-1) 16,27,16                                             0723.000
   27 M=M+1                                                             0724.000
   16 N=N+1                                                             0725.000
      A=A+ARS                                                           0726.000
C        END ATOM LOOP                                                  0727.000
   14 B=B+BRS                                                           0728.000
      M=MKEEP                                                           0729.000
C        END SYMMMETRY LOOP                                             0730.000
   12 N=2                                                               0731.000
      IF(ICENT)23,24,23                                                 0732.000
   24 D=0.0                                                             0733.000
      B=0.0                                                             0734.000
   23 AA=A-D                                                            0735.000
      BB=B+C                                                            0736.000
         FCSQ=AA*AA+BB*BB                                               0737.000
         IF (RSTAR.GT.0) THEN                                           0738.000
         SINTH=WAVEL*SQRT(SSQ)                                          0739.000
         COSTH=SQRT(1.-SINTH*SINTH)                                     0740.000
         SIN2TH=2.*SINTH*COSTH                                          0741.000
         COSQ2TH=(COSTH*COSTH-SINTH*SINTH)**2                           0742.000
         DELT=DELTC*(1.+COSQ2TH*COSQ2TH)*TBAR/((1.+COSQ2TH)*SIN2TH)     0743.000
         ECSQ=SQRT(1.+RSTAR2*FCSQ*DELT)                                 0744.000
         FMOD=SQRT(FCSQ/ECSQ)                                           0745.000
         ELSE                                                           0746.000
         FMOD=SQRT(FCSQ)                                                0747.000
         ENDIF                                                          0748.000
      IF (NPAR) 26,26,125                                               0749.000
  125 DO 25 KK=MKEEP,NPAR                                               0750.000
   25 DERIV(KK)=(DERIV(KK)*AA+TEMP(KK)*BB)/FMOD                         0751.000
   26 DELTA=FO-FMOD                                                     0752.000
         GO TO (134,400,401,500,400),NUNTW                              0753.000
500   CALL FUDG (H,ISC,FO,FMOD,DELTA,W)                                 0754.000
      IF (W) 502,502,402                                                0755.000
502   SIG=1.E6                                                          0756.000
         GO TO 501                                                      0757.000
 402     SIG=1./SQRT(W)                                                 0758.000
         GO TO 501                                                      0759.000
 401     W=1.                                                           0760.000
         SIG=1.                                                         0761.000
         GO TO 501                                                      0762.000
 400     W=1./(1.+((FO-FB)/FA)**2)**2                                   0763.000
         IF (NUNTW-5) 402,500,500                                       0764.000
 134     IF (FA.NE.0.) THEN                                             0765.000
         W=EXP(FA*SSQ)/(SIG*SIG)                                        0766.000
         ELSE                                                           0767.000
         W=1./(SIG*SIG)                                                 0768.000
         ENDIF                                                          0769.000
501   SCALE(1)=SCALE(1)+FMOD*FMOD*W                                     0770.000
      SCALE(2)=SCALE(2)-W*FMOD*FMOD*SSQ                                 0771.000
      SCALE(3)=SCALE(3)+FMOD*FMOD*SSQ*SSQ*W                             0772.000
      V1=V1+W*DELTA*FMOD                                                0773.000
      V2=V2-W*DELTA*FMOD*SSQ                                            0774.000
      SUMFC=SUMFC+FMOD                                                  0775.000
      SUMF=SUMF+FO                                                      0776.000
      SUMDF=SUMDF+ABS(DELTA)                                            0777.000
      SDSQ=SDSQ+DELTA*DELTA*W                                           0778.000
      SWFSQ=SWFSQ+W*FO*FO                                               0779.000
      NPLAN=NPLAN+1                                                     0780.000
      IF (IPRNT.EQ.1)  WRITE(IP,2001)H,FO,FMOD,AA,BB,SIG,DELTA          0781.000
 2001 FORMAT(' ',3I5,  6F10.5)                                          0782.000
         IF (NCD.LT.NC) GO TO 54                                        0783.000
C     WRITE REFLECTION RECORD TO FC FILE                                0784.000
         SIG=2.*FO*SIG                                                  0785.000
         FO=FO*FO                                                       0786.000
         IF (RSTAR.GT.0) THEN                                           0787.000
         RTECSQ=SQRT(ECSQ)                                              0788.000
         AA=AA/RTECSQ                                                   0789.000
         BB=BB/RTECSQ                                                   0790.000
         ENDIF                                                          0791.000
      WRITE (17) IW1,IW2,FO,SIG,AA,BB,SSQ                               0792.000
 54   IF (NPAR) 209,209,53                                              0793.000
 53      IF (RSTAR.GT.0.) THEN                                          0794.000
         DENOM=(SQRT(ECSQ))**5                                          0795.000
         DRVFF=(1.+RSTAR*FCSQ*DELT)/DENOM                               0796.000
         DO 55 KK=MKEEP,NPAR                                            0797.000
 55      DERIV(KK)=DERIV(KK)*DRVFF                                      0798.000
         ENDIF                                                          0799.000
      DO 253 II=1,NATOM                                                 0800.000
      NPART=MPAR(II)                                                    0801.000
      IF (NPART) 253,253,201                                            0802.000
201   DO 29 I=1,NPART                                                   0803.000
      VECT(IVECT)=VECT(IVECT)+W*DELTA*DERIV(IVECT)                      0804.000
      DO 200 J=I,NPART                                                  0805.000
      JJ=IVECT-I+J                                                      0806.000
      AM(IDISP)=AM(IDISP)+W*DERIV(IVECT)*DERIV(JJ)                      0807.000
  200 IDISP=IDISP+1                                                     0808.000
   29 IVECT=IVECT+1                                                     0809.000
  253 CONTINUE                                                          0810.000
      GO TO 209                                                         0811.000
   10 RINDX=SUMDF/SUMF                                                  0812.000
      WR=SQRT(SDSQ/SWFSQ)                                               0813.000
      WRITE(IP,2000)RINDX,WR,NPLAN                                      0814.000
 2000 FORMAT('0R INDEX =',F10.5/' WEIGHTED R INDEX =',F10.5/' NO OF PLAN0815.000
     1ES IN LEAST SQUARES =',I5 )                                       0816.000
      WRITE(IP,5000)SUMF,SUMFC,SDSQ                                     0817.000
 5000 FORMAT(' SUM FOBS =',E14.6/' SUM FCALC =',E14.6/' SUM W*DELTA SQD 0818.000
     1= ',E15.6)                                                        0819.000
         WRITE (4,100) COMPD,RINDX,WR,NPLAN                             0820.000
 100     FORMAT ('REMARK        ',10A4/'REMARK   R =',F7.4,' FOR THESE P0821.000
     1ARAMETERS'/'REMARK   WEIGHTED R =',F7.4,'  NUMBER OF REFLECTIONS =0822.000
     2',I6)                                                             0823.000
      IF (NCD-NC) 61,64,64                                              0824.000
 64      ENDFILE 17                                                     0825.000
      RETURN                                                            0826.000
 61      NCD=NCD+1                                                      0827.000
      DENOM=NPLAN-NPAR-1                                                0828.000
      SDSQ=SDSQ/DENOM                                                   0829.000
      DET=SCALE(1)*SCALE(3)-SCALE(2)*SCALE(2)                           0830.000
      GS=V1*SCALE(3)-V2*SCALE(2)                                        0831.000
      GS=GS/DET*FUDGE(NCD)                                              0832.000
        TMBO=(V2*SCALE(1)-V1*SCALE(2))/DET                              0833.000
      BTMBO=TMBO-V2/SCALE(3)                                            0834.000
      GSYG=SQRT(SCALE(3)/DET*SDSQ)*G                                    0835.000
      G=G*(1.+GS)                                                       0836.000
      WRITE(IP,309)G,GSYG,TMBO,BTMBO                                    0837.000
  309 FORMAT('0NEW SCALE = ',F10.5,'   SIGMA = ',F10.5/' OVERALL TEMPERA0838.000
     1TURE FACTOR CHANGE CALCULATED WITH SCALE INTERACTION =',F8.3/     0839.000
     2'  BACKSHIFT =',F8.3)                                             0840.000
      CALL      BSQS                                                    0841.000
      GO TO 79826                                                       0842.000
      END                                                               0843.000
         SUBROUTINE REFIND(PARAM,TAG,KKK,N,ANAME,IREF,IND)              0844.000
         CHARACTER*8 TAG(2),PARAM,ANAME(200)                            0845.000
         DIMENSION IREF(10,200)                                         0846.000
         LOGICAL ALL                                                    0847.000
         ALL=.FALSE.                                                    0848.000
         IF (KKK.EQ.1) ALL=.TRUE.                                       0849.000
         N1=1                                                           0850.000
         N2=N                                                           0851.000
         IF (KKK.LT.3) GO TO 705                                        0852.000
         DO 703 K=1,KKK-2                                               0853.000
         DO 704 I=1,N                                                   0854.000
         IF (TAG(K).NE.ANAME(I)) GO TO 704                              0855.000
         GO TO (701,702),K                                              0856.000
 701     N1=I                                                           0857.000
 702     N2=I                                                           0858.000
         GO TO 703                                                      0859.000
 704     CONTINUE                                                       0860.000
         WRITE (6,725) TAG(K)                                           0861.000
 725     FORMAT (' REF/NOREF CONTROL: ATOM LABEL ',A8,' INCONSISTENT')  0862.000
         RETURN                                                         0863.000
 703     CONTINUE                                                       0864.000
         IF (N2.GE.N1) GO TO 705                                        0865.000
         WRITE (6,700) TAG(1),TAG(2)                                    0866.000
 700     FORMAT (' REF/NOREF CONTROL: ATOM LABELS ',A8,1X,A8,' HAVE INCO0867.000
     1NSISTENT SEQUENCE')                                               0868.000
         RETURN                                                         0869.000
 705     IF (.NOT.ALL) GO TO 730                                        0870.000
         DO 731 I=N1,N2                                                 0871.000
         DO 731 J=1,10                                                  0872.000
 731     IREF (J,I)=IND                                                 0873.000
         RETURN                                                         0874.000
 730     DO 706 I=N1,N2                                                 0875.000
         IF (PARAM.NE.'X') GO TO 707                                    0876.000
         IREF(1,I)=IND                                                  0877.000
         GO TO 706                                                      0878.000
 707     IF (PARAM.NE.'Y') GO TO 708                                    0879.000
         IREF(2,I)=IND                                                  0880.000
         GO TO 706                                                      0881.000
 708     IF (PARAM.NE.'Z') GO TO 722                                    0882.000
         IREF(3,I)=IND                                                  0883.000
         GO TO 706                                                      0884.000
 722     IF (PARAM.NE.'OCC') GO TO 709                                  0885.000
         IREF(4,I)=IND                                                  0886.000
         GO TO 706                                                      0887.000
 709     IF (PARAM.NE.'U11') GO TO 710                                  0888.000
         IREF(5,I)=IND                                                  0889.000
         GO TO 706                                                      0890.000
 710     IF (PARAM.NE.'U22') GO TO 711                                  0891.000
         IREF(6,I)=IND                                                  0892.000
         GO TO 706                                                      0893.000
 711     IF (PARAM.NE.'U33') GO TO 712                                  0894.000
         IREF(7,I)=IND                                                  0895.000
         GO TO 706                                                      0896.000
 712     IF (PARAM.NE.'U12') GO TO 713                                  0897.000
         IREF(8,I)=IND                                                  0898.000
         GO TO 706                                                      0899.000
 713     IF (PARAM.NE.'U13') GO TO 714                                  0900.000
         IREF(9,I)=IND                                                  0901.000
         GO TO 706                                                      0902.000
 714     IF (PARAM.NE.'U23') GO TO 715                                  0903.000
         IREF(10,I)=IND                                                 0904.000
         GO TO 706                                                      0905.000
 715     IF (PARAM.NE.'UIJ') GO TO 732                                  0906.000
         DO 721 J=5,10                                                  0907.000
 721     IREF(J,I)=IND                                                  0908.000
         GO TO 706                                                      0909.000
 732     IF (PARAM.NE.'ALL') GO TO 720                                  0910.000
         DO 733 J=1,10                                                  0911.000
 733     IREF(J,I)=IND                                                  0912.000
         GO TO 706                                                      0913.000
 720     WRITE (6,716) PARAM                                            0914.000
 716     FORMAT (' UNRECOGNISED PARAMETER DESCRIPTOR: ',A8)             0915.000
         RETURN                                                         0916.000
 706     CONTINUE                                                       0917.000
         RETURN                                                         0918.000
         END                                                            0919.000
         SUBROUTINE UCONV(TAG,U,FTYPE,ITBL,ID,AFACT,N)                  0920.000
C        CONVERT UISO TO UIJ                                            0921.000
         CHARACTER*8 TAG,FTYPE(1)                                       0922.000
         DIMENSION ITBL(1),U(6,200),ID(1),AFACT(1)                      0923.000
         LOGICAL DONE                                                   0924.000
         DONE=.FALSE.                                                   0925.000
         DO 40 I=1,N                                                    0926.000
         IF (TAG.NE.FTYPE(ITBL(I)).OR.MOD(ID(I),100).NE.1) GO TO 40     0927.000
      DO 43 J=2,3                                                       0928.000
 43   U(J,I  )=       U(1,I)                                            0929.000
         DO 33 J=1,2                                                    0930.000
         DO 33 K=J+1,3                                                  0931.000
 33      U(J+K+1,I)=U(1,I)*AFACT(J+K+1)/SQRT(AFACT(J)*AFACT(K))         0932.000
      ID(I)=ID(I)+1                                                     0933.000
         DONE=.TRUE.                                                    0934.000
 40      CONTINUE                                                       0935.000
         IF (DONE) RETURN                                               0936.000
         WRITE (6,725) TAG                                              0937.000
 725     FORMAT (' ANISO CONTROL IGNORED: ATOM TYPE ',A8,' UNRECOGNISED,0938.000
     1'/' OR NO INDIVIDUAL ISOTROPIC ATOMS OF THIS TYPE. <<<<<<<<<<<<<')0939.000
         RETURN                                                         0940.000
         END                                                            0941.000
         SUBROUTINE BCONV(U,EU,ID,EITPSQ,AFACT,N)                       0942.000
C        CONVERT B OR BETA TO UISO OR UIJ                               0943.000
         DIMENSION U(6,200),ID(1),AFACT(1),EU(6,200)                    0944.000
         DO 603 I=1,N                                                   0945.000
         IF (MOD(ID(I),100).EQ.1) GO TO 30                              0946.000
         DO 602 J=1,3                                                   0947.000
         U(J,I)=   U(J,I)/(EITPSQ*AFACT(J))                             0948.000
 602     EU(J,I)=   EU(J,I)/(EITPSQ*AFACT(J))                           0949.000
         DO 33 J=1,2                                                    0950.000
         DO 33 K=J+1,3                                                  0951.000
         U(J+K+1,I)=   U(J+K+1,I)/(EITPSQ*SQRT(AFACT(J)*AFACT(K)))      0952.000
 33      EU(J+K+1,I)=   EU(J+K+1,I)/(EITPSQ*SQRT(AFACT(J)*              0953.000
     1   AFACT(K)))                                                     0954.000
         GO TO 603                                                      0955.000
 30      U(1,I)=U(1,I)/EITPSQ                                           0956.000
         EU(1,I)=EU(1,I)/EITPSQ                                         0957.000
 603     CONTINUE                                                       0958.000
         RETURN                                                         0959.000
         END                                                            0960.000
         SUBROUTINE AMATCH(N1,N2,TAG,MODE,N,ANAME)                      0961.000
         CHARACTER*8 TAG(2),ANAME(200)                                  0962.000
         N1=0                                                           0963.000
         N2=0                                                           0964.000
         DO 3 I=1,MODE                                                  0965.000
         DO 4 J=1,N                                                     0966.000
         IF (TAG(I).NE.ANAME(J)) GO TO 4                                0967.000
         GO TO (5,6),I                                                  0968.000
 5       N1=J                                                           0969.000
         GO TO 3                                                        0970.000
 6       N2=J                                                           0971.000
         GO TO 3                                                        0972.000
 4       CONTINUE                                                       0973.000
         WRITE (6,7) TAG(I)                                             0974.000
 7       FORMAT (' RIDE COMMAND: NO MATCH FOR LABEL ',A8)               0975.000
 3       CONTINUE                                                       0976.000
         RETURN                                                         0977.000
         END                                                            0978.000
