C        COPYRIGHT 1985 UNIVERSITY OF GLASGOW                           0001.000
C        RIGID GROUP LEAST SQUARES PROGRAM RBLS                         0002.000
C        GX PACKAGE  APRIL 1985   PAUL R. MALLINSON                     0003.000
C                                                                       0004.000
         PROGRAM RBLSPRM                                                0005.000
C
         PARAMETER(NNP=850,MATRX=NNP*(NNP+1)/2,NG=16)
         CHARACTER COMPID(72),LINE(148)                                 0006.000
         CHARACTER*8 ANAME(200),FTYPE(13),AMIN(20), TAG(2),PARAM,RBN(NG)0007.000
         CHARACTER*72 CBUF                                              0008.000
         INTEGER CN(200),CONTNT(13), MIN(20),  FIRSTCH(20),FWIDTH(20)   0009.000
         REAL MAT(3,3),BUFIO(2000),                SUMWX(3)             0010.000
         DIMENSION IREF(10,200),IREFG(7,NG),IPOINT(NNP)                 0011.000
         LOGICAL FIRST                                                  0012.000
         COMMON/NMATRX/AM(MATRX)                                        0013.000
C * * * * GOULD S.E.L. ONLY * * * *                                     0014.000
C        EXTENDED BLOCK/NMATRX/AM(MATRX)                                0015.000
C * * * * END GOULD S.E.L. * * * *                                      0016.000
      COMMON NPAR,PD(NNP),ZZ(NNP),DIAG(NNP),NELEM,SUMFX(NG,3),          0017.000
     1THET1(NG),THET2(NG),THET3(NG),NOT(2000),KK,FA,FB,CONVP,V,         0018.000
     2NTL,XO(200,3),NIP(NG),ALPH(3,3),DRHO1(NG,3,3),DRHO2(NG,3,3),      0019.000
     3DRHO3(NG,3,3),COMPD(10),AFACT(6),SMDVQ,SMFOB,SGWFS,SIGFC,SGWDS,   0020.000
     4NUNTW,NITER,RFAC,EITPSQ,EFACT(99,2),ISTAP,ISTAPR(NG),NRRRB(NG),   0021.000
     5NRR,WTGR,BISO(NG),ID(200),JITER,IC,ITER,STNDM,AMULT,IPRNT,CUTO,   0022.000
     6NOMAT,OLDR,ISUP,FIRSTCH,FWIDTH,L1,L2                              0023.000
         COMMON/GPNAME/RBN,LINE                                         0024.000
         COMMON/MODELC/COMPID,ANAME,FTYPE                               0025.000
         COMMON/MODEL/N,  NEQV,NT,ITYPES,      ITBL(200),XC(3,200),     0026.000
     1   CN,SOF(200),UU(6,200),EP(3,200),ESOF(200),EUIJ(6,200),         0027.000
     2   WAVEL,AR,BR,CR,COSA,COSB,COSG,ECELL(6),R(24,3,4),T(3,4),ICEND, 0028.000
     3         SFAC(14,13),CONTNT,G(4),ETA,NQ, EXTNCT                   0029.000
      EQUIVALENCE (BUFIO(1),  NOT(1)),(IREF,AM(1)),(IREFG,DIAG(1)),     0030.000
     1(CBUF,LINE(7)),(IPOINT(1),PD(1))                                  0031.000
         DATA                   BLANK/' '/                              0032.000
   79 FORMAT(80A1)                                                      0033.000
   81 FORMAT   (10A4)                                                   0034.000
   89 FORMAT('0GROUP ATOM SYMBOL ',A8,' INCONSISTENT - GROUP IGNORED')  0035.000
 91   FORMAT ('0MODEL FILE MUST CONTAIN A VALID ''LAMBDA'' ENTRY WHEN EX0036.000
     1TINCTION IS PRESENT')                                             0037.000
 92      FORMAT (' PLEASE TYPE COMMANDS (1ST 3 LETTERS) FROM THE LIST, T0038.000
     1ERMINATED BY A BLANK LINE:'/' TITLE <TITLE>'/                     0039.000
     2' CYCLES <NUMBER OF CYCLES>      <SHIFT/SIGMA>'/          ' GROUP 0040.000
     3<LABEL> <CR> <ATOM LABELS>'/' REF/NOREF  SCALE/EXTINCTN/ETA/X/Y/Z/0041.000
     4OCC/UIJ/ALL  <ATOM LABEL(S)>'/50X,'(2 LABELS DEFINE A SEQUENCE)'/ 0042.000
     5   ' ANISO <ATOM TYPE>'/' CONSTRAIN  X/Y/Z/OCC/UIJ  <ATOM LABEL> <0043.000
     6FACTOR>  X/Y/Z/OCC/UIJ  <ATOM LABEL>'/11X,'<TRANSLATION>'/' WEIGHT0044.000
     7S <SCHEME NO.> <FA> <FB>'/' CUT-OFF <G>'/' LIST STRUCTURE FACTORS'0045.000
     8/' RE-USE MATRIX'/' RIDE <ATOM LABEL(S)> ON <ATOM LABEL(S)>')     0046.000
 201     FORMAT ('0GROUP',A4,' HAS ONLY ONE ATOM OR NONE - IGNORED')    0047.000
 722     FORMAT (' SCHEME 1: WEIGHT = EXP(FA SIN**2THETA/LAMBDA**2)/SIGM0048.000
     1A**2(FO)'/11X,'NON-ZERO FB (+VE OR -VE) IS ADDED TO PFAC'/        0049.000
     2          '        2: WEIGHT = 1/(1+((FO-FB)/FA)**2)**2'/'        0050.000
     33: ALL WEIGHTS = 1.0'/' DEFAULT: SCHEME 1 WITH FA = 0, FB = 0.')  0051.000
 1115 FORMAT ('0RBLS COMPLETED')                                        0052.000
 1116 FORMAT ('0STRUCTURE FACTOR FILE COMPLETED')                       0053.000
 1119 FORMAT ('0CORRELATION MATRIX FILE COMPLETED')                     0054.000
C                                                                       0055.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   0056.000
C        CALL X:GDSPCE(15,NGET,,)                                       0057.000
C        CALL X:GDSPCE(15,NGET,,)                                       0058.000
C        CALL X:GDSPCE(1,NGET,,)                                        0059.000
C * * * * END GOULD S.E.L. * * * * *                                    0060.000
         CALL MDLIN(8)                                                  0061.000
         DO 80 I=1,10                                                   0062.000
 80      COMPD(I)=BLANK                                                 0063.000
         DO 84 I=1,14                                                   0064.000
         DO 95 J=1,3                                                    0065.000
         DO 95 K=1,3                                                    0066.000
 95      DRHO1(I,J,K)=0.                                                0067.000
         DO 83 J=1,6                                                    0068.000
 83      IREFG(J,I)=1                                                   0069.000
 84      IREFG(7,I)=0                                                   0070.000
         DO 87 I=1,NQ                                                   0071.000
 87      NOT(I)=1                                                       0072.000
         NOT(NQ+1)=0                                                    0073.000
         IF (EXTNCT.GT.0.) THEN                                         0074.000
         IF (WAVEL.LE.0.) THEN                                          0075.000
         WRITE (6,91)                                                   0076.000
         WRITE (3,91)                                                   0077.000
         STOP                                                           0078.000
         ELSE                                                           0079.000
         NOT(NQ+1)=1                                                    0080.000
         ENDIF                                                          0081.000
         ENDIF                                                          0082.000
         NOT(NQ+2)=0                                                    0083.000
         DO 82 I=1,N                                                    0084.000
         ID(I)=0                                                        0085.000
         IF (UU(2,I).NE.0.) ID(I)=-1                                    0086.000
         DO 78 J=1,3                                                    0087.000
 78      IREF(J,I)=1                                                    0088.000
         IREF(4,I)=0                                                    0089.000
         DO 82 J=5,10                                                   0090.000
 82      IREF(J,I)=1                                                    0091.000
         KK=0                                                           0092.000
         FIRST=.TRUE.                                                   0093.000
         DO 1 I=1,145                                                   0094.000
 1       LINE(I)=' '                                                    0095.000
         CUTO=0.                                                        0096.000
         NITER=0                                                        0097.000
         NUNTW=1                                                        0098.000
         IC=-1                                                          0099.000
         IPRNT=-1                                                       0100.000
         FA=0.0                                                         0101.000
         FB=0.0                                                         0102.000
         CONVP=0.5                                                      0103.000
         EITPSQ=78.956835                                               0104.000
         NOMAT=0                                                        0105.000
         NCON=0                                                         0106.000
      SINA=SQRT(1.-COSA*COSA)                                           0107.000
      SINB=SQRT(1.-COSB*COSB)                                           0108.000
      SING=SQRT(1.-COSG*COSG)                                           0109.000
      V=AR*BR*CR*SQRT(1.-COSA*COSA-COSB*COSB-COSG*COSG+2.*COSA*COSB*COSG0110.000
     1)                                                                 0111.000
      MAT(1,1)=AR                                                       0112.000
      MAT(1,2)=BR*COSG                                                  0113.000
      MAT(1,3)=CR*COSB                                                  0114.000
      MAT(2,1)=0.                                                       0115.000
      MAT(2,2)=BR*SING                                                  0116.000
      MAT(2,3)=CR*(COSA-COSB*COSG)/SING                                 0117.000
      MAT(3,1)=0.                                                       0118.000
      MAT(3,2)=0.                                                       0119.000
      MAT(3,3)=V/(AR*BR*SING)                                           0120.000
      ASTAR=BR*CR*SINA/V                                                0121.000
      BSTAR=AR*CR*SINB/V                                                0122.000
      CSTAR=AR*BR*SING/V                                                0123.000
      AFACT(1)=ASTAR*ASTAR                                              0124.000
      AFACT(2)=BSTAR*BSTAR                                              0125.000
      AFACT(3)=CSTAR*CSTAR                                              0126.000
      AFACT(4)=ASTAR*BSTAR*(COSA*COSB-COSG)/(SINA*SINB)                 0127.000
      AFACT(5)=ASTAR*CSTAR*(COSA*COSG-COSB)/(SINA*SING)                 0128.000
      AFACT(6)=BSTAR*CSTAR*(COSB*COSG-COSA)/(SINB*SING)                 0129.000
         WRITE (6,92)                                                   0130.000
 130     READ (2,79,END=48) (LINE(I),I=2,73)                            0131.000
         DO 26 I=74,145                                                 0132.000
 26      LINE(I)=' '                                                    0133.000
         CALL PARSE(LINE,KKK,FIRSTCH,FWIDTH)                            0134.000
         IF (KKK.EQ.0) GO TO 48                                         0135.000
         FWIDTH(1)=3                                                    0136.000
         CALL AFORMT (LINE,FIRSTCH(1),FWIDTH(1),TAG(1))                 0137.000
         IF (TAG(1).NE.'TIT') GO TO 700                                 0138.000
         READ (CBUF,81)      COMPD                                      0139.000
         GO TO 130                                                      0140.000
 700     IF (TAG(1).EQ.'GRO') GO TO 49                                  0141.000
         IF (TAG(1).NE.'CUT') GO TO 701                                 0142.000
         IF (KKK.GT.1) CALL FFORMT(LINE,FIRSTCH(2),FWIDTH(2),CUTO)      0143.000
         GO TO 130                                                      0144.000
 701     IF (TAG(1).NE.'CYC') GO TO 702                                 0145.000
         IF (KKK.GT.1) CALL IFORMT(LINE,FIRSTCH(2),FWIDTH(2),ITER)      0146.000
         IF (KKK.GT.2) CALL FFORMT(LINE,FIRSTCH(3),FWIDTH(3),CONVP)     0147.000
         IF (.NOT.FIRST) GO TO 707                                      0148.000
         FIRST=.FALSE.                                                  0149.000
         NITER=ITER                                                     0150.000
         GO TO 130                                                      0151.000
 707     IPRNT=2                                                        0152.000
         GO TO 48                                                       0153.000
 702     IF (TAG(1).NE.'WEI') GO TO 703                                 0154.000
         IF (KKK.GT.1) GO TO 721                                        0155.000
         WRITE (6,722)                                                  0156.000
         GO TO 130                                                      0157.000
 721     CALL IFORMT(LINE,FIRSTCH(2),FWIDTH(2),NUNTW)                   0158.000
         IF (KKK.GT.2) CALL FFORMT(LINE,FIRSTCH(3),FWIDTH(3),FA)        0159.000
         IF (KKK.GT.3) CALL FFORMT(LINE,FIRSTCH(4),FWIDTH(4),FB)        0160.000
         GO TO 130                                                      0161.000
 703     IF (TAG(1).NE.'COR') GO TO 704                                 0162.000
         IF (KKK.GT.1) CALL IFORMT(LINE,FIRSTCH(2),FWIDTH(2),IC)        0163.000
         GO TO 130                                                      0164.000
 704     IF (TAG(1).NE.'LIS') GO TO 705                                 0165.000
         IPRNT=0                                                        0166.000
         GO TO 130                                                      0167.000
 705     IF (TAG(1).NE.'NOR'.AND.TAG(1).NE.'REF') GO TO 717             0168.000
         IND=0                                                          0169.000
         IF (TAG(1).EQ.'REF') IND=1                                     0170.000
         IF (KKK.GT.1) CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),PARAM)     0171.000
         IF (KKK.GT.2) CALL AFORMT(LINE,FIRSTCH(3),FWIDTH(3),TAG(1))    0172.000
         IF (KKK.GT.3) CALL AFORMT(LINE,FIRSTCH(4),FWIDTH(4),TAG(2))    0173.000
         IF (PARAM.EQ.'ETA') THEN                                       0174.000
         NOT(NQ+2)=IND                                                  0175.000
         ELSE IF (PARAM.EQ.'SCALE') THEN                                0176.000
         DO 88 I=1,NQ                                                   0177.000
 88      NOT(I)=IND                                                     0178.000
         ELSE IF (PARAM.EQ.'EXTINCTN') THEN                             0179.000
         NOT(NQ+1)=IND                                                  0180.000
         ELSE                                                           0181.000
         CALL REFIND(PARAM,TAG,KKK,N,ANAME,IREF,KK,RBN,IREFG,IND,L1,L2) 0182.000
         ENDIF                                                          0183.000
         GO TO 130                                                      0184.000
 717     IF (TAG(1).NE.'CON') GO TO 720                                 0185.000
         IF (KKK.LT.5) GO TO 3180                                       0186.000
         NCON=NCON+2                                                    0187.000
         CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),PARAM)                   0188.000
         CALL AFORMT(LINE,FIRSTCH(3),FWIDTH(3),TAG(1))                  0189.000
C        PUT CONSTRAINT NUMBER INTO INDICATOR FOR CONSTRAINED PARAMETER 0190.000
         CALL REFIND(PARAM,TAG,3,N,ANAME,IREF,NRB,RBN,IREFG,NCON,L1,L2) 0191.000
C        SAVE DERIVATIVE COEFFICIENT FOR THIS CONSTRAINT                0192.000
         CALL FFORMT(LINE,FIRSTCH(4),FWIDTH(4),EFACT(NCON/2,1))         0193.000
         EFACT(NCON/2,2)=0.                                             0194.000
         CALL AFORMT(LINE,FIRSTCH(5),FWIDTH(5),PARAM)                   0195.000
C        NEED NOT SPECIFY 2ND ATOM IF PARAMETERS BELONG TO SAME ATOM    0196.000
         IF (KKK.GT.5) CALL AFORMT(LINE,FIRSTCH(6),FWIDTH(6),TAG(1))    0197.000
         CALL REFIND(PARAM,TAG,3,N,ANAME,IREF,NRB,RBN,IREFG,1,L1,L2)    0198.000
C        READ CONSTRAINT TERM FOR ORFFE, IF PRESENT                     0199.000
         IF (KKK.GT.6) CALL FFORMT(LINE,FIRSTCH(7),FWIDTH(7),           0200.000
     1   EFACT(NCON/2,2))                                               0201.000
C        SAVE POINTER TO THE INDEPENDENT VARIABLE FOR THIS CONSTRAINT   0202.000
         IPOINT(NCON/2)=(L1-1)*10+L2+1                                  0203.000
         GO TO 130                                                      0204.000
 720     IF (TAG(1).NE.'ANI') GO TO 719                                 0205.000
         IF (KKK.GT.1) CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TAG(1))    0206.000
         CALL UCONV(TAG(1),UU,FTYPE,ITBL,ID,AFACT,N)                    0207.000
         GO TO 130                                                      0208.000
 719     IF (TAG(1).NE.'RE-') GO TO 3157                                0209.000
         NOMAT=1                                                        0210.000
         GO TO 130                                                      0211.000
 3157    IF (TAG(1).NE.'RID') GO TO 3180                                0212.000
         IF (KKK.EQ.1.OR.KKK.GT.6) GO TO 3180                           0213.000
         GO TO (3180,3180,3167,3168,3169),KKK-1                         0214.000
 3167    CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TAG(1))                  0215.000
         CALL AFORMT(LINE,FIRSTCH(4),FWIDTH(4),TAG(2))                  0216.000
         CALL AMATCH(L1,L2,TAG,2,N,ANAME)                               0217.000
         IF (L1.EQ.0.OR.L2.EQ.0) GO TO 130                              0218.000
         ID(L1)=MOD(ID(L1),100)+ISIGN(100*L2,ID(L1))                    0219.000
         GO TO 130                                                      0220.000
 3168    CALL AFORMT(LINE,FIRSTCH(5),FWIDTH(5),TAG(1))                  0221.000
         CALL AMATCH(L1,L2,TAG,1,N,ANAME)                               0222.000
         IF (L1.EQ.0) GO TO 130                                         0223.000
         I=L1                                                           0224.000
         CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TAG(1))                  0225.000
         CALL AFORMT(LINE,FIRSTCH(3),FWIDTH(3),TAG(2))                  0226.000
         CALL AMATCH(L1,L2,TAG,2,N,ANAME)                               0227.000
         IF (L1.EQ.0.OR.L2.EQ.0) GO TO 130                              0228.000
         IF (L2.LT.L1) GO TO 3182                                       0229.000
         DO 3166 J=L1,L2                                                0230.000
 3166    ID(J)=MOD(ID(J),100)+ISIGN(100*I,ID(J))                        0231.000
         GO TO 130                                                      0232.000
 3169    CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TAG(1))                  0233.000
         CALL AFORMT(LINE,FIRSTCH(3),FWIDTH(3),TAG(2))                  0234.000
         CALL AMATCH(L1,L2,TAG,2,N,ANAME)                               0235.000
         IF (L1.EQ.0.OR.L2.EQ.0) GO TO 130                              0236.000
         IF (L2.LT.L1) GO TO 3182                                       0237.000
         CALL AFORMT(LINE,FIRSTCH(5),FWIDTH(5),TAG(1))                  0238.000
         CALL AFORMT(LINE,FIRSTCH(6),FWIDTH(6),TAG(2))                  0239.000
         CALL AMATCH(I,J,TAG,2,N,ANAME)                                 0240.000
         IF (I.EQ.0.OR.J.EQ.0) GO TO 130                                0241.000
         IF (J.LT.I) GO TO 3182                                         0242.000
         IF ((J-I).NE.(L2-L1)) THEN                                     0243.000
         WRITE (6,3181) ANAME(L1),ANAME(L2),ANAME(I),ANAME(J)           0244.000
 3181    FORMAT (' RIDE COMMAND HAS INCONSISTENT SEQUENCES',4(1X,A8))   0245.000
         GO TO 130                                                      0246.000
         ENDIF                                                          0247.000
         DO 3171 J=L1,L2                                                0248.000
 3171    ID(J)=MOD(ID(J),100)+ISIGN(100*(I+J-L1),ID(J))                 0249.000
         GO TO 130                                                      0250.000
 3182    WRITE (6,8) TAG                                                0251.000
 8       FORMAT (' RIDE COMMAND: LABELS ',A8,1X,A8,' HAVE INCONSISTENT S0252.000
     1EQUENCE')                                                         0253.000
         GO TO 130                                                      0254.000
 3180    WRITE (6,718) TAG(1)                                           0255.000
 718     FORMAT (' INVALID COMMAND IGNORED: ',A8,' <<<<<<<<<<<<<<')     0256.000
         GO TO 130                                                      0257.000
 49      KK=KK+1                                                        0258.000
         IF (KK.GT.NG) THEN                                             0259.000
         WRITE (3,654)                                                  0260.000
 654     FORMAT ('0PRESENT DIMENSIONS ALLOW UP TO NG GROUPS')           0261.000
         STOP                                                           0262.000
         ENDIF                                                          0263.000
      CALL INVER(MAT,ALPH)                                              0264.000
         CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),RBN(KK))                 0265.000
         READ (2,79,END=202) (LINE(I),I=2,73)                           0266.000
         CALL PARSE(LINE,KKK,FIRSTCH,FWIDTH)                            0267.000
         I=FIRSTCH(KKK)                                                 0268.000
         IF (LINE(I).EQ.'=') THEN                                       0269.000
         LINE(I)=' '                                                    0270.000
         READ (2,79,END=202) (LINE(I),I=74,145)                         0271.000
         CALL PARSE(LINE,KKK,FIRSTCH,FWIDTH)                            0272.000
         ENDIF                                                          0273.000
         IF (KKK.GE.2) GO TO 203                                        0274.000
 202     WRITE (6,201) RBN(KK)                                          0275.000
         KK=KK-1                                                        0276.000
         GO TO 130                                                      0277.000
 203     NIP(KK)=KKK                                                    0278.000
         DO 32 I=1,KKK                                                  0279.000
 32      CALL AFORMT(LINE,FIRSTCH(I),FWIDTH(I),AMIN(I))                 0280.000
      NCH=0                                                             0281.000
      DO 103 I=1,KKK                                                    0282.000
      DO 104 J=1,N                                                      0283.000
      IF (.NOT.(AMIN(I)  .EQ.ANAME(J))) GO TO 104                       0284.000
      NCH=NCH+1                                                         0285.000
      MIN(NCH)=J                                                        0286.000
         IF (ID(J).GE.0) THEN                                           0287.000
         ID(J)=KK                                                       0288.000
         ELSE                                                           0289.000
         ID(J)=-KK-1                                                    0290.000
         ENDIF                                                          0291.000
      DO 42 M=1,3                                                       0292.000
      XO(J,M)=0.                                                        0293.000
      DO 42 K=1,3                                                       0294.000
   42 XO(J,M)=XO(J,M)+XC(K,J)*MAT(M,K)                                  0295.000
         GO TO 103                                                      0296.000
  104 CONTINUE                                                          0297.000
      WRITE (6,89) AMIN(I)                                              0298.000
         KK=KK-1                                                        0299.000
         GO TO 130                                                      0300.000
 103     CONTINUE                                                       0301.000
      DO 107 I=1,3                                                      0302.000
      SUMFX(KK,I)=0.                                                    0303.000
 107  SUMWX(I)=0.                                                       0304.000
      DO 108 J=1,KKK                                                    0305.000
      MATMJ=MIN(J)                                                      0306.000
      DO 108 I=1,3                                                      0307.000
      SUMFX(KK,I)=SUMFX(KK,I)+         XC(I,MATMJ)                      0308.000
 108  SUMWX(I)=SUMWX(I)+         XO(MATMJ,I)                            0309.000
      DO 120 I=1,3                                                      0310.000
      SUMWX(I)=SUMWX(I)/FLOAT(KKK)                                      0311.000
 120  SUMFX(KK,I)=SUMFX(KK,I)/FLOAT(KKK)                                0312.000
      DO 1112 J=1,KKK                                                   0313.000
      MATMJ=MIN(J)                                                      0314.000
      DO 1112 I=1,3                                                     0315.000
 1112 XO(MATMJ,I)=XO(MATMJ,I)-SUMWX(I)                                  0316.000
      THET1(KK)=0.0                                                     0317.000
      THET2(KK)=0.0                                                     0318.000
      THET3(KK)=0.0                                                     0319.000
         GO TO 130                                                      0320.000
 48   CALL RBLSA                                                        0321.000
 573  CALL CLEAR                                                        0322.000
      CALL SFRB                                                         0323.000
         WRITE (4,100) COMPD,RFAC,WTGR,NTL                              0324.000
 100     FORMAT ('REMARK        ',10A4/'REMARK   R =',F7.4,' FOR THESE P0325.000
     1ARAMETERS'/'REMARK   WEIGHTED R =',F7.4,'  NUMBER OF REFLECTIONS =0326.000
     2',I6)                                                             0327.000
         ENDFILE 4                                                      0328.000
      IF (NITER.EQ.0) GO TO 872                                         0329.000
      CALL IMAT                                                         0330.000
      IF (JITER.EQ.NITER) NITER=0                                       0331.000
         GO TO 573                                                      0332.000
 872  ENDFILE 17                                                        0333.000
      WRITE (3,1116)                                                    0334.000
      IF (IC.EQ.0) GO TO 900                                            0335.000
      CALL CORRL                                                        0336.000
C        PREPARE FILE FOR ORFFE ROUTINES IN GEOM.                       0337.000
         WRITE (20) COMPD                                               0338.000
         WRITE (20) NEQV*(2-ICEND),NT-1                                 0339.000
      WRITE (20) N,NCON/2                                               0340.000
      NCH=1                                                             0341.000
         KKK=0                                                          0342.000
      DO 3156 I=1,N                                                     0343.000
      IF (ID(I).LT.0)  THEN                                             0344.000
         ID(I)=2                                                        0345.000
         KKK=KKK+1                                                      0346.000
      NCH=2                                                             0347.000
         ELSE                                                           0348.000
         ID(I)=1                                                        0349.000
         ENDIF                                                          0350.000
 3156    CONTINUE                                                       0351.000
      WRITE (20) (ID(I),I=1,N)                                          0352.000
         J=NCON/2                                                       0353.000
      IF (NCON.GT.0) WRITE (20)((EFACT(I,K),K=1,2), I=1,J)              0354.000
      LIQ=NQ+2+KK*7                                                     0355.000
         NPV=LIQ+N*5+KKK*5                                              0356.000
      WRITE (20)  NCH,LIQ,NPV                                           0357.000
      WRITE (20) (NOT(I),I=1,NPV)                                       0358.000
         DO 3170 I=1,NQ                                                 0359.000
 3170 BUFIO(I)=G(I)                                                     0360.000
      BUFIO(NQ+1)=EXTNCT                                                0361.000
         BUFIO(NQ+2)=ETA                                                0362.000
      NPV=NQ+2+KK                                                       0363.000
      IF (KK.EQ.0) GO TO 3158                                           0364.000
      DO 3159 I=NQ+3,NPV                                                0365.000
 3159 BUFIO(I)=0.                                                       0366.000
      DO 3160 I=1,KK                                                    0367.000
      DO 3161 J=1,3                                                     0368.000
      NPV=NPV+1                                                         0369.000
 3161 BUFIO(NPV)=SUMFX(I,J)                                             0370.000
      BUFIO(NPV+1)=THET1(I)                                             0371.000
      BUFIO(NPV+2)=THET2(I)                                             0372.000
      BUFIO(NPV+3)=THET3(I)                                             0373.000
 3160 NPV=NPV+3                                                         0374.000
 3158 DO 3162 I=1,N                                                     0375.000
      K=1                                                               0376.000
      IF (ID(I).EQ.2)  K=6                                              0377.000
      DO 3164 J=1,3                                                     0378.000
      NPV=NPV+1                                                         0379.000
 3164 BUFIO(NPV)=XC(J,I)                                                0380.000
         NPV=NPV+1                                                      0381.000
         BUFIO(NPV)=SOF(I)                                              0382.000
         DO 3165 J=1,K                                                  0383.000
         NPV=NPV+1                                                      0384.000
 3165    BUFIO(NPV)=UU(J,I)                                             0385.000
 3162    CONTINUE                                                       0386.000
      WRITE (20) (BUFIO(I),I=1,NPV)                                     0387.000
      WRITE (20) NPAR                                                   0388.000
      DO 3163 I=1,NELEM                                                 0389.000
 3163 AM(I)=AM(I)*STNDM                                                 0390.000
      WRITE (20) (AM(I),I=1,NELEM)                                      0391.000
         WRITE (20) AR,BR,CR,COSA,COSB,COSG                             0392.000
         WRITE (20) ECELL                                               0393.000
         IF (ICEND.EQ.0) THEN                                           0394.000
         WRITE (20) ((R(I,J,4),(R(I,J,K),K=1,3),J=1,3),I=1,NEQV),       0395.000
     1   ((-R(I,J,4),(-R(I,J,K),K=1,3),J=1,3),I=1,NEQV)                 0396.000
         ELSE                                                           0397.000
         WRITE (20) ((R(I,J,4),(R(I,J,K),K=1,3),J=1,3),I=1,NEQV)        0398.000
         ENDIF                                                          0399.000
         IF (NT.GT.1) THEN                                              0400.000
         WRITE (20) ((T(I,J),I=1,3),J=2,NT)                             0401.000
         ENDIF                                                          0402.000
      ENDFILE 20                                                        0403.000
      WRITE (3,1119)                                                    0404.000
 900  WRITE (3,1115)                                                    0405.000
      STOP                                                              0406.000
      END                                                               0407.000
      SUBROUTINE RBLSA                                                  0408.000
C     -- RBLS MAIN SET UP ROUTINE --                                    0409.000
         PARAMETER(NNP=850,MATRX=NNP*(NNP+1)/2,NG=16)
         CHARACTER COMPID(72),LINE(148)                                 0410.000
         CHARACTER*8 ANAME(200),FTYPE(13),TAG(2),PARAM,RBN(NG)          0411.000
         INTEGER CN(200),CONTNT(13),IREF(10,200),IREFG(7,NG)            0412.000
         INTEGER FIRSTCH(20),FWIDTH(20),IPOINT(NNP)                     0413.000
      REAL MAT(3,3),M,MU                                                0414.000
         COMMON/NMATRX/AM(MATRX)                                        0415.000
C * * * * GOULD S.E.L. ONLY * * * *                                     0416.000
C        EXTENDED BLOCK/NMATRX/AM(MATRX)                                0417.000
C * * * * END GOULD S.E.L. * * * *                                      0418.000
      COMMON NPAR,PD(NNP),V(NNP),DIAG(NNP),NELEM,XO(NG,6),              0419.000
     1NOT(2000),    NRB,      FA,FB,CONVP,VOL,NTL,                      0420.000
     2XC(200,3),NAR(NG),ALPH(3,3),DRHO1(NG,3,3),DRHO2(NG,3,3),          0421.000
     3DRHO3(NG,3,3),COMPD(10),AFACT(6),SMDVQ,SMFOB,SGWFS,SIGFC,SGWDS,   0422.000
     4NUNTW,NITER,RFAC,EITPSQ,EFACT(99,2),ISTAP,ISTAPR(NG),NRRRB(NG),   0423.000
     5NRR,WTGR,BISO(NG),ID(200),JITER,IC,ITER,STNDM,M,IPRNT,CUTO,NOMAT, 0424.000
     6OLDR,ISUP,FIRSTCH,FWIDTH,L1,L2                                    0425.000
         COMMON/GPNAME/RBN,LINE                                         0426.000
         COMMON/MODELC/COMPID,ANAME,FTYPE                               0427.000
         COMMON/MODEL/NSF,NEQV,NT,MMAT,      ITBL(200),XX(3,200),       0428.000
     1   CN,SOF(200),UU(6,200),EP(3,200),ESOF(200),EUIJ(6,200),         0429.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICEND,                 0430.000
     3   SFAC(14,13),CONTNT,G(4),ETA,NQ, RSTAR                          0431.000
         EQUIVALENCE (IREF,AM(1)),(IREFG,DIAG(1)),(IPOINT(1),PD(1))     0432.000
    2 FORMAT('0SEQUENCE NUMBERS OF REFINED PARAMETERS')                 0433.000
 3       FORMAT (1X,A8,3I5,3I10)                                        0434.000
 4    FORMAT (' ',I6,I3,5X,A8,   1X,10F10.4)                            0435.000
    5 FORMAT(/////  'RBLS PRESENTLY WILL NOT ACCEPT MORE THAN 2000 PARAM0436.000
     1ETERS - INCREASE DIMENSION OF NOT TO',I6)                         0437.000
 10   FORMAT (' ',72A1/'0',10A4)                                        0438.000
 11   FORMAT ('0',I4,' ATOMS',I10,' GROUPS',I10,' CYCLES')              0439.000
 26   FORMAT ('0EXTINCTION COEFFICIENT (RSTAR) X10**-3:',F10.4,5X,'ETA:'0440.000
     1,F10.4/'0FC SCALE FACTORS:',4F9.4)                                0441.000
   29 FORMAT('0MODEL INPUT PARAMETERS'/ 5X,'ID  F',5X,'ATOM',12X,'X',9X,0442.000
     1'Y',9X,'Z',6X,'OCCUPN',5X,'U/U11',6X,'U22',7X,'U33',7X,'U12',7X,  0443.000
     2'U13',7X,'U23')                                                   0444.000
 30      FORMAT ('0GROUP POSITIONAL PARAMETERS:'/12X,'X0',3X,'Y0',3X,   0445.000
     1'Z0',6X,'THETA1',4X,'THETA2',4X,'THETA3')                         0446.000
 79      FORMAT (80A1)                                                  0447.000
 92      FORMAT (' PLEASE TYPE COMMANDS (1ST 3 LETTERS) FROM THE LIST, T0448.000
     1ERMINATED BY A BLANK LINE:'/                                      0449.000
     2                            ' REF/NOREF  X/Y/Z/OCC/UIJ/ALL  <ATOM 0450.000
     3LABEL(S)>   2 LABELS SPECIFY A SEQUENCE'/                         0451.000
     4   ' ANISO <ATOM TYPE>'/' CONSTRAIN  X/Y/Z/OCC/UIJ  <ATOM LABEL> <0452.000
     5FACTOR>  X/Y/Z/OCC/UIJ  <ATOM LABEL>'/11X,'<TRANSLATION>'/' CYCLES0453.000
     6 <NO. OF CYCLES FOR BLOCK AFTER THIS>'/' LIST STRUCTURE FACTORS') 0454.000
 430     FORMAT('0PARAMETER NO.',I4,' SHIFT IS CONSTRAINED TO',F9.4,    0455.000
     1' TIMES VARIABLE NO.',I4,' SHIFT')                                0456.000
 603     FORMAT ('0GROUP TEMPERATURE FACTORS:'/(1X,A8,I5))              0457.000
 606     FORMAT ('0ATOM PARAMETERS:')                                   0458.000
 610     FORMAT ('0MATRIX WILL BE RE-USED')                             0459.000
 620     FORMAT ('0WEIGHT = EXP(',F5.1,' SIN**2THETA/LAMBDA**2)/SIGMA**20460.000
     1(FO)')                                                            0461.000
 621     FORMAT ('0WEIGHT = 1/(1+((FOBS -',F9.4,')/',F9.4,')**2)**2')   0462.000
 622     FORMAT ('0ALL WEIGHTS = 1.0')                                  0463.000
 623     FORMAT ('0WEIGHTS WILL BE SET BY SUBROUTINE FUDG')             0464.000
 624     FORMAT ('0CELL ',3F10.3,3F10.5/' LAMBDA ',F10.5)               0465.000
 625     FORMAT (F8.2,' HAS BEEN ADDED TO PFAC')                        0466.000
 1000 FORMAT('0EXTINCTION COEFFICIENT:',I3,'      ETA:',I3)             0467.000
 1010    FORMAT ('0SCALE FACTORS:',4I5)                                 0468.000
 1001 FORMAT (1X,A8,10I5)                                               0469.000
 1002 FORMAT('0NO. OF PARAMETERS TO BE REFINED =',I4)                   0470.000
 1003 FORMAT('0TOO MANY VARIABLES, EXECUTION TERMINATED')               0471.000
 1004 FORMAT('0NO. OF MATRIX ELEMENTS =',I5)                            0472.000
 1005 FORMAT('0SKIP REFLECTIONS FOR WHICH I <',F6.3,' SIGMA(I)')        0473.000
 1007 FORMAT('1NEW VARIABLES SELECTED',' FOR',I3,' CYCLES')             0474.000
 1009 FORMAT ('0NO. OF STRUCTURE PARAMETERS =',I6)                      0475.000
 2001 FORMAT ('0LINEAR ABSORPTION COEFFICIENT MU =',F7.2,' CM**-1    CEL0476.000
     1L VOLUME =',F9.2,' A**3')                                         0477.000
      JITER=0                                                           0478.000
      ISUP=0                                                            0479.000
      IF (.NOT.(NITER.EQ.0.AND.IPRNT.GT.1)) GO TO 511                   0480.000
         NITER=ITER                                                     0481.000
         IPRNT=-1                                                       0482.000
         DO 6 I=1,145                                                   0483.000
 6       LINE(I)=' '                                                    0484.000
         WRITE (6,92)                                                   0485.000
         K=0                                                            0486.000
 130     READ (2,79,END=48) (LINE(I),I=2,73)                            0487.000
         CALL PARSE(LINE,J,FIRSTCH,FWIDTH)                              0488.000
         IF (J.EQ.0) GO TO 48                                           0489.000
         FWIDTH(1)=3                                                    0490.000
         CALL AFORMT (LINE,FIRSTCH(1),FWIDTH(1),TAG(1))                 0491.000
         IF (TAG(1).NE.'CYC') GO TO 704                                 0492.000
         IF (J.GT.1) CALL IFORMT(LINE,FIRSTCH(2),FWIDTH(2),ITER)        0493.000
         IF (J.GT.2) CALL FFORMT(LINE,FIRSTCH(3),FWIDTH(3),CONVP)       0494.000
         IPRNT=2                                                        0495.000
         GO TO 48                                                       0496.000
 704     IF (TAG(1).NE.'LIS') GO TO 705                                 0497.000
         IPRNT=0                                                        0498.000
         GO TO 130                                                      0499.000
 705     IF (TAG(1).NE.'NOR'.AND.TAG(1).NE.'REF') GO TO 717             0500.000
         IND=0                                                          0501.000
         IF (TAG(1).EQ.'REF') IND=1                                     0502.000
         IF (J.GT.1) CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),PARAM)       0503.000
         IF (J.GT.2) CALL AFORMT(LINE,FIRSTCH(3),FWIDTH(3),TAG(1))      0504.000
         IF (J.GT.3) CALL AFORMT(LINE,FIRSTCH(4),FWIDTH(4),TAG(2))      0505.000
         CALL REFIND(PARAM,TAG,J,NSF,ANAME,IREF,NRB,RBN,IREFG,IND,L1,L2)0506.000
         GO TO 130                                                      0507.000
 717     IF (TAG(1).NE.'CON') GO TO 720                                 0508.000
         IF (J.LT.5) GO TO 130                                          0509.000
         K=K+2                                                          0510.000
         CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),PARAM)                   0511.000
         CALL AFORMT(LINE,FIRSTCH(3),FWIDTH(3),TAG(1))                  0512.000
         CALL REFIND(PARAM,TAG,3,NSF,ANAME,IREF,NRB,RBN,IREFG,K,L1,L2)  0513.000
         IF (J.GT.5) CALL AFORMT(LINE,FIRSTCH(6),FWIDTH(6),TAG(1))      0514.000
         CALL AFORMT(LINE,FIRSTCH(5),FWIDTH(5),PARAM)                   0515.000
         CALL FFORMT(LINE,FIRSTCH(4),FWIDTH(4),EFACT(K/2,1))            0516.000
         EFACT(K/2,2)=0.                                                0517.000
         CALL REFIND(PARAM,TAG,3,NSF,ANAME,IREF,NRB,RBN,IREFG,1,L1,L2)  0518.000
         IF (J.GT.6) CALL FFORMT(LINE,FIRSTCH(7),FWIDTH(7),EFACT(K/2,2))0519.000
         IPOINT(K/2)=(L1-1)*10+L2+1                                     0520.000
         GO TO 130                                                      0521.000
 720     IF (TAG(1).NE.'ANI') GO TO 719                                 0522.000
         IF (J.GT.1) CALL AFORMT(LINE,FIRSTCH(2),FWIDTH(2),TAG(1))      0523.000
         CALL UCONV(TAG(1),UU,FTYPE,ITBL,ID,AFACT,NSF)                  0524.000
         GO TO 130                                                      0525.000
 719     WRITE (6,718) TAG(1)                                           0526.000
 718     FORMAT (' INVALID CONTROL IGNORED: ',A8,' <<<<<<<<<<<<<<<<<')  0527.000
         GO TO 130                                                      0528.000
 48   WRITE(3,1007)NITER                                                0529.000
      GO TO 512                                                         0530.000
 511     M=FLOAT(NT)                                                    0531.000
      WRITE(3,10) COMPID,COMPD                                          0532.000
      IF (NITER.EQ.0) IC=0                                              0533.000
      WRITE (3,11) NSF,NRB,     NITER                                   0534.000
         IF (NOMAT.NE.0) WRITE (3,610)                                  0535.000
         WRITE (3,1005) CUTO                                            0536.000
         GO TO (611,612,613,615,615),NUNTW                              0537.000
 611     WRITE (3,620) FA                                               0538.000
         IF (FB.NE.0.) WRITE (3,625) FB                                 0539.000
         GO TO 614                                                      0540.000
 612     WRITE (3,621) FB,FA                                            0541.000
         GO TO 614                                                      0542.000
 613     WRITE (3,622)                                                  0543.000
         GO TO 614                                                      0544.000
 615     WRITE (3,623)                                                  0545.000
 614  WRITE (3,26)         RSTAR,ETA,(G(I),I=1,NQ)                      0546.000
      WRITE (3,624) CELL,WAVEL                                          0547.000
         CALL LATOUT(3)                                                 0548.000
         IF (NEQV.GT.1) CALL SYMOUT(3)                                  0549.000
         MU=0.                                                          0550.000
         DO 2000 I=1,MMAT                                               0551.000
 2000    MU=MU+CONTNT(I)*SFAC(12,I)                                     0552.000
         MU=MU/VOL                                                      0553.000
         WRITE (3,2001) MU,VOL                                          0554.000
C     NRB = NO. OF RIGID BODIES                                         0555.000
      IF (NRB) 512,512,343                                              0556.000
 343  IF (NITER) 512,512,234                                            0557.000
C     NOT IS PARAMETER SELECTOR ARRAY. VALUE GT 1 INDICATES DERIVATIVE  0558.000
C     REQUIRED BUT PARAMETER IS NOT TO BE REFINED (DEPENDENT VARIABLE)  0559.000
 234  IND=NQ+3+NRB                                                      0560.000
      DO 233 I=1,NRB                                                    0561.000
      IND2=I+NQ+2                                                       0562.000
      IND1=IND+5                                                        0563.000
         K=0                                                            0564.000
         DO 7 J=IND,IND1                                                0565.000
         K=K+1                                                          0566.000
 7       NOT(J)=IREFG(K,I)                                              0567.000
         NOT(IND2)=IREFG(7,I)                                           0568.000
  233 IND=IND1+1                                                        0569.000
  512 NAN=0                                                             0570.000
      IF (IPRNT.GE.0) GO TO 6521                                        0571.000
      ISUP=1                                                            0572.000
      IPRNT=0                                                           0573.000
 6521 WRITE (3,29)                                                      0574.000
      DO 115 I=1,NSF                                                    0575.000
      IF(ID(I)) 201,816,816                                             0576.000
 201  NAN=NAN+1                                                         0577.000
 816  WRITE (3,4) ID(I),ITBL(I), ANAME(I),         (XX(J,I),J=1,3),     0578.000
     1   SOF(I),(UU(J,I),J=1,6)                                         0579.000
  115 CONTINUE                                                          0580.000
      NPVP=NQ+2+NRB*7+NSF*5+NAN*5                                       0581.000
      WRITE (3,1009) NPVP                                               0582.000
      IF(NPVP-2000) 221,221,351                                         0583.000
  351 WRITE(3,5)  NPVP                                                  0584.000
      STOP                                                              0585.000
C     ORDER OF STRUCTURE PARAMETERS IS AS FOLLOWS: NQ SCALE FACTORS;    0586.000
C     ISOTROPIC EXTINCTION COEFFICIENT (RSTAR, A.C. LARSON,             0587.000
C     'CRYSTALLOGRAPHIC COMPUTING', ED. F.R. AHMED, MUNKSGAARD, 1970);  0588.000
C     COEFFICIENT OF IMAGINARY COMPONENT OF ANOMALOUS SCATTERING (ETA,  0589.000
C     D. ROGERS, ACTA CRYST. (1981), A37, 734); NRB GROUP TEMPERATURE   0590.000
C     FACTORS; 6*NRB GROUP POSITIONAL PARAMETERS; ATOM PARAMETERS       0591.000
C     (TOTAL NUMBER*5 + NUMBER ANISOTROPIC*5).                          0592.000
 221     ISTAPR(1)=0                                                    0593.000
         DO 462 I=1,NRB+NQ+2                                            0594.000
 462     ISTAPR(1)=ISTAPR(1)+NOT(I)                                     0595.000
         ISTAP=ISTAPR(1)                                                0596.000
         NRR=NQ+2+7*NRB                                                 0597.000
         IF (NRB.EQ.0) GO TO 999                                        0598.000
         DO 440 I=NRB+NQ+3,NRR                                          0599.000
 440     ISTAP=ISTAP+NOT(I)                                             0600.000
         DO 50 JJ=1,NRB                                                 0601.000
 50     NRRRB(JJ)=NRB+NQ+2+6*(JJ-1)                                     0602.000
         DO 51 JJ=2,NRB                                                 0603.000
         ISTAPR(JJ)=ISTAPR(JJ-1)                                        0604.000
         DO 51 I=NRRRB(JJ-1)+1,NRRRB(JJ-1)+6                            0605.000
 51     ISTAPR(JJ)=ISTAPR(JJ)+NOT(I)                                    0606.000
 999  IF(NITER)340,340,222                                              0607.000
 222  IND=NQ+3+NRB*7                                                    0608.000
      DO 226 I   =1,NSF                                                 0609.000
         JJ=MOD(ID(I),100)                                              0610.000
         IF (JJ.LT.-1) JJ=-JJ-1                                         0611.000
         IF (JJ.GT.0.OR.ID(I)/100.NE.0) THEN                            0612.000
         DO 202 J=1,3                                                   0613.000
 202     IREF(J,I)=0                                                    0614.000
         ENDIF                                                          0615.000
         IF (JJ.GT.0.AND.IREFG(7,JJ).GT.0) THEN                         0616.000
         DO 450 J=5,10                                                  0617.000
 450     IREF(J,I)=0                                                    0618.000
         ENDIF                                                          0619.000
      IF(ID(I))     230,231,231                                         0620.000
  231 IND1=IND+4                                                        0621.000
      GO TO 232                                                         0622.000
  230 IND1=IND+9                                                        0623.000
 232     K=0                                                            0624.000
         DO 1 J=IND,IND1                                                0625.000
         K=K+1                                                          0626.000
         IF (IREF(K,I).GT.1) GO TO 341                                  0627.000
         NOT(J)=IREF(K,I)                                               0628.000
         GO TO 1                                                        0629.000
 341     NOT(J)=IPOINT(IREF(K,I)/2)*100 +IREF(K,I)/2                    0630.000
 1       CONTINUE                                                       0631.000
      IND=IND1+1                                                        0632.000
  226 CONTINUE                                                          0633.000
  340 NPAR=0                                                            0634.000
      IF (NITER.EQ.0) GO TO 987                                         0635.000
      DO 119 I=1,NPVP                                                   0636.000
      IF (NOT(I)-1) 119,119,401                                         0637.000
 401     J=NQ+3+NRB*7                                                   0638.000
         CALL FINDLSP(NSF,ISTAP,J, ID,NOT,I)                            0639.000
         IF (NOT(I).EQ.0) GO TO 119                                     0640.000
         WRITE (3,430) I,EFACT(MOD(NOT(I),100),1),NOT(I)/100            0641.000
 119  CONTINUE                                                          0642.000
      WRITE (3,2)                                                       0643.000
         DO 600 I=1,NQ                                                  0644.000
         IF (NOT(I).EQ.1) THEN                                          0645.000
         NPAR=NPAR+1                                                    0646.000
         FIRSTCH(I)=NPAR                                                0647.000
         ELSE                                                           0648.000
         FIRSTCH(I)=0                                                   0649.000
         ENDIF                                                          0650.000
 600     CONTINUE                                                       0651.000
         WRITE (3,1010) (FIRSTCH(I),I=1,NQ)                             0652.000
         DO 601 I=NQ+1,NQ+2                                             0653.000
         J=I-NQ                                                         0654.000
         IF (NOT(I).EQ.1) THEN                                          0655.000
         NPAR=NPAR+1                                                    0656.000
         FIRSTCH(J)=NPAR                                                0657.000
         ELSE                                                           0658.000
         FIRSTCH(J)=0                                                   0659.000
         ENDIF                                                          0660.000
 601     CONTINUE                                                       0661.000
         WRITE (3,1000) (FIRSTCH(I),I=1,2)                              0662.000
         IF (NRB.GT.0) THEN                                             0663.000
         DO 602 I=NQ+3,NQ+2+NRB                                         0664.000
         J=I-NQ-2                                                       0665.000
         IF (NOT(I).EQ.1) THEN                                          0666.000
         NPAR=NPAR+1                                                    0667.000
         FIRSTCH(J)=NPAR                                                0668.000
         ELSE                                                           0669.000
         FIRSTCH(J)=0                                                   0670.000
         ENDIF                                                          0671.000
 602     CONTINUE                                                       0672.000
         WRITE (3,603) (RBN(I),FIRSTCH(I),I=1,NRB)                      0673.000
         WRITE (3,30)                                                   0674.000
         IND=NQ+3+NRB                                                   0675.000
         DO 604 I=1,NRB                                                 0676.000
         DO 605 J=IND,IND+5                                             0677.000
         K=J-IND+1                                                      0678.000
         IF (NOT(J).EQ.1) THEN                                          0679.000
         NPAR=NPAR+1                                                    0680.000
         FIRSTCH(K)=NPAR                                                0681.000
         ELSE                                                           0682.000
         FIRSTCH(K)=0                                                   0683.000
         ENDIF                                                          0684.000
 605     CONTINUE                                                       0685.000
         IND=IND+6                                                      0686.000
 604     WRITE (3,3) RBN(I),(FIRSTCH(J),J=1,6)                          0687.000
         ENDIF                                                          0688.000
         WRITE (3,606)                                                  0689.000
      IND=NQ+3+NRB*7                                                    0690.000
      DO 410 I   =1,NSF                                                 0691.000
      IF(ID(I))     411,412,412                                         0692.000
  412 IND1=IND+4                                                        0693.000
      GO TO 413                                                         0694.000
  411 IND1=IND+9                                                        0695.000
 413     DO 414 J=IND,IND1                                              0696.000
         K=J-IND+1                                                      0697.000
         IF (NOT(J).GT.1) THEN                                          0698.000
         FIRSTCH(K)=NOT(J)/100                                          0699.000
         ELSE IF (NOT(J).EQ.1) THEN                                     0700.000
         NPAR=NPAR+1                                                    0701.000
         FIRSTCH(K)=NPAR                                                0702.000
         ELSE                                                           0703.000
         FIRSTCH(K)=0                                                   0704.000
         ENDIF                                                          0705.000
 414     CONTINUE                                                       0706.000
      WRITE(3,1001)  ANAME(I),(FIRSTCH(J),J=1,K)                        0707.000
      IND=IND1+1                                                        0708.000
  410 CONTINUE                                                          0709.000
 987  WRITE (3,1002) NPAR                                               0710.000
      NELEM=NPAR*(NPAR+1)/2                                             0711.000
      WRITE(3,1004)NELEM                                                0712.000
      IF (NELEM-MATRX) 342,342,21                                       0713.000
 21   WRITE(3,1003)                                                     0714.000
      STOP                                                              0715.000
 342  RETURN                                                            0716.000
      END                                                               0717.000
         SUBROUTINE FINDLSP(N,ISTAP,NP,ID,NOT,I)                        0718.000
         DIMENSION ID(200),NOT(2000)                                    0719.000
         M=ISTAP                                                        0720.000
         DO 226 J=1,N                                                   0721.000
         IF (ID(J)) 400,401,401                                         0722.000
 400     IEND=NP+9                                                      0723.000
         GO TO 403                                                      0724.000
 401     IEND=NP+4                                                      0725.000
 403     K=0                                                            0726.000
 406     K=K+1                                                          0727.000
         IF (NOT(NP).EQ.1) M=M+1                                        0728.000
         IF (NOT(I)/100.NE.((J-1)*10+K+1)) GO TO 407                    0729.000
         IF (NOT(NP).EQ.1) THEN                                         0730.000
         NOT(I)=M*100+MOD(NOT(I),100)                                   0731.000
         ELSE                                                           0732.000
         NOT(I)=0                                                       0733.000
         ENDIF                                                          0734.000
         RETURN                                                         0735.000
 407     NP=NP+1                                                        0736.000
         IF (NP.LE.IEND) GO TO 406                                      0737.000
 226     CONTINUE                                                       0738.000
         RETURN                                                         0739.000
         END                                                            0740.000
      SUBROUTINE CLEAR                                                  0741.000
C      -- RBLS ARRAY CLEARING ROUTINE --                                0742.000
         PARAMETER(NNP=850,MATRX=NNP*(NNP+1)/2,NG=16)
         CHARACTER COMPID(72)                                           0743.000
         CHARACTER*8 ANAME(200),FTYPE(13)                               0744.000
         INTEGER CN(200),CONTNT(13)                                     0745.000
         DIMENSION IREF(10,200),IREFG(7,NG)                             0746.000
         COMMON/NMATRX/AM(MATRX)                                        0747.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   0748.000
C        EXTENDED BLOCK/NMATRX/AM(MATRX)                                0749.000
C  * * * * END GOULD S.E.L. * * * *                                     0750.000
      COMMON NPAR,PD(NNP),V(NNP),DIAG(NNP),NELEM,XO(NG,6),              0751.000
     1NOT(2000),    NRB,      FA,FB,CONVP,VOL,NTL,                      0752.000
     2XC(200,3),NAR(NG),ALPH(3,3),DRHO1(NG,3,3),DRHO2(NG,3,3),          0753.000
     3DRHO3(NG,3,3),COMPD(10),AFACT(6),SMDVQ,SMFOB,SGWFS,SIGFC,SGWDS,   0754.000
     4NUNTW,NITER,RFAC,EITPSQ,EFACT(99,2),ISTAP,ISTAPR(NG),NRRRB(NG),   0755.000
     5NRR,WTGR,BISO(NG),ID(200),JITER,IC,ITER,STNDM,MM,IPRNT,CUTO,NOMAT,0756.000
     6OLDR,ISUP                                                         0757.000
         COMMON/MODELC/COMPID,ANAME,FTYPE                               0758.000
         COMMON/MODEL/NSF,NEQV,NT,MMAT,      ITBL(200),XX(3,200),       0759.000
     1   CN,SOF(200),UU(6,200),EP(3,200),ESOF(200),EUIJ(6,200),         0760.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICEND,                 0761.000
     3   SFAC(14,13),CONTNT,G(4),ETA,NQ, RSTAR                          0762.000
         EQUIVALENCE (IREF,AM(1)),(IREFG,DIAG(1))                       0763.000
   14 FORMAT(6H0CYCLE,I3,5X,72A1/' ',10A4)                              0764.000
   15 FORMAT('0   H   K   L  SC    FOBS      FCALC     COSA      SINA   0765.000
     1   DELTA     SIG      RTWDEL     STHOL'/)                         0766.000
 16   FORMAT ('0FINAL STRUCTURE FACTOR CALCULATION',10X,10A4)           0767.000
      IF(NRB) 114,114,115                                               0768.000
  115 CALL SET2                                                         0769.000
 114  SMDVQ=0.                                                          0770.000
      SMFOB=0.                                                          0771.000
      SGWFS=0.                                                          0772.000
      SIGFC=0.                                                          0773.000
      SGWDS=0.                                                          0774.000
      IF(NITER) 53,53,54                                                0775.000
 53   IF (IPRNT-1) 553,553,653                                          0776.000
  553 WRITE(3,16)  COMPD                                                0777.000
      IPRNT=1                                                           0778.000
      IF (ISUP.EQ.1) IPRNT=0                                            0779.000
      GO TO 17                                                          0780.000
 653     DO 80 I=1,NRB                                                  0781.000
         DO 83 J=1,6                                                    0782.000
 83      IREFG(J,I)=1                                                   0783.000
 80      IREFG(7,I)=0                                                   0784.000
         DO 82 I=1,NSF                                                  0785.000
         DO 78 J=1,3                                                    0786.000
 78      IREF(J,I)=1                                                    0787.000
         IREF(4,I)=0                                                    0788.000
         DO 82 J=5,10                                                   0789.000
 82      IREF(J,I)=1                                                    0790.000
         CONVP=0.5                                                      0791.000
      CALL RBLSA                                                        0792.000
 54   JITER=JITER+1                                                     0793.000
      WRITE(3,14)  JITER,COMPID,COMPD                                   0794.000
      DO 2 I=1,NPAR                                                     0795.000
 2    V(I)=0.                                                           0796.000
      IF (NOMAT.EQ.1.AND.JITER.GT.1) GO TO 17                           0797.000
      DO 4 I=1,NELEM                                                    0798.000
 4    AM(I)=0.                                                          0799.000
   17 IF (IPRNT.EQ.1) WRITE(3,15)                                       0800.000
C        CONVERT UISO TO B OR UIJ TO BETA                               0801.000
      DO 40 I=1,NSF                                                     0802.000
         IF (ID(I).GT.-1) GO TO 102                                     0803.000
         DO 153 J=1,3                                                   0804.000
         EUIJ(J,I)=EITPSQ*EUIJ(J,I)*AFACT(J)/4.                         0805.000
 153     UU(J,I)=EITPSQ*UU(J,I)*AFACT(J)/4.                             0806.000
         DO 105 J=1,2                                                   0807.000
         DO 105 K=J+1,3                                                 0808.000
         EUIJ(J+K+1,I)=EITPSQ*SQRT(AFACT(J)*AFACT(K))*EUIJ(J+K+1,I)/4.  0809.000
 105     UU(J+K+1,I)=EITPSQ*SQRT(AFACT(J)*AFACT(K))*UU(J+K+1,I)/4.      0810.000
         GO TO 40                                                       0811.000
 102     UU(1,I)=UU(1,I)*EITPSQ                                         0812.000
         EUIJ(1,I)=EUIJ(1,I)*EITPSQ                                     0813.000
   40 CONTINUE                                                          0814.000
      RETURN                                                            0815.000
      END                                                               0816.000
      SUBROUTINE SET2                                                   0817.000
C      ROUTINE FOR R.B. DERIVATIVES --                                  0818.000
         PARAMETER(NNP=850,MATRX=NNP*(NNP+1)/2,NG=16)
         CHARACTER COMPID(72),LINE(148)                                 0819.000
         CHARACTER*8 ANAME(200),FTYPE(13),RBN(NG)                       0820.000
         INTEGER CN(200),CONTNT(13)                                     0821.000
      REAL RHO(3,3),PROD(3,3),SIGRHO(3,3),PO(3,3)                       0822.000
         COMMON/NMATRX/AM(MATRX)                                        0823.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   0824.000
C        EXTENDED BLOCK/NMATRX/AM(MATRX)                                0825.000
C * * * * END GOULD S.E.L. * * * *                                      0826.000
      COMMON NPAR,PD(NNP),V(NNP),DIAG(NNP),NELEM ,XO(NG,6),             0827.000
     1NOT(2000),    NRB,      FA,FB,CONVP,VOL,NTL,                      0828.000
     2XC(200,3),NAR(NG),ALPH(3,3),DRHO1(NG,3,3),DRHO2(NG,3,3),          0829.000
     3DRHO3(NG,3,3),COMPD(10),AFACT(6),SMDVQ,SMFOB,SGWFS,SIGFC,SGWDS,   0830.000
     4NUNTW,NITER,RFAC,EITPSQ,EFACT(99,2),ISTAP,ISTAPR(NG),NRRRB(NG),   0831.000
     5NRR,WTGR,BISO(NG),ID(200),JITER                                   0832.000
         COMMON/GPNAME/RBN,LINE                                         0833.000
         COMMON/MODELC/COMPID,ANAME,FTYPE                               0834.000
         COMMON/MODEL/NSF,NEQV,NT,MMAT,      ITBL(200),XX(3,200),       0835.000
     1   CN,SOF(200),UU(6,200),EP(3,200),ESOF(200),EUIJ(6,200),         0836.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICEND,                 0837.000
     3   SFAC(14,13),CONTNT,G(4),ETA,NQ, RSTAR                          0838.000
      COMMON/PAUL3/XD(200,3,3)                                          0839.000
 80   FORMAT ('0FRACTIONAL COORDINATES AND ERRORS FOR ATOMS OF GROUP ', 0840.000
     1   A8/)                                                           0841.000
 81   FORMAT (' ',I4,2X,A8,   6F10.5)                                   0842.000
      DO 451 M=1,NRB                                                    0843.000
      COST1=COS(XO(M,4))                                                0844.000
      COST2=COS(XO(M,5))                                                0845.000
      COST3=COS(XO(M,6))                                                0846.000
      SINT1=SIN(XO(M,4))                                                0847.000
      SINT2=SIN(XO(M,5))                                                0848.000
      SINT3=SIN(XO(M,6))                                                0849.000
      RHO(1,1)=COST1*COST2                                              0850.000
      RHO(1,2)=-SINT1*COST3+COST1*SINT2*SINT3                           0851.000
      RHO(1,3)=-SINT1*SINT3-COST1*COST3*SINT2                           0852.000
      RHO(2,1)=SINT1*COST2                                              0853.000
      RHO(2,2)=COST1*COST3+SINT1*SINT2*SINT3                            0854.000
      RHO(2,3)=COST1*SINT3-SINT1*COST3*SINT2                            0855.000
      RHO(3,1)=SINT2                                                    0856.000
      RHO(3,2)=-SINT3*COST2                                             0857.000
      RHO(3,3)=COST3*COST2                                              0858.000
         SIGRHO(1,1)=-COST2*SINT1*DRHO1(M,1,2)-COST1*SINT2*DRHO1(M,2,2) 0859.000
         SIGRHO(1,2)=-COST3*COST1*DRHO1(M,1,2)-SINT2*SINT3*SINT1        0860.000
     1   *DRHO1(M,1,2)+COST1*SINT3*COST2*DRHO1(M,2,2)+SINT1*SINT3       0861.000
     2   *DRHO1(M,3,2)+COST1*SINT2*COST3*DRHO1(M,3,2)                   0862.000
         SIGRHO(1,3)=-SINT3*COST1*DRHO1(M,1,2)+SINT2*COST3*SINT1        0863.000
     1   *DRHO1(M,1,2)-COST1*COST3*COST2*DRHO1(M,2,2)-SINT1*COST3       0864.000
     2   *DRHO1(M,3,2)+COST1*SINT2*SINT3*DRHO1(M,3,2)                   0865.000
         SIGRHO(2,1)=COST1*COST2*DRHO1(M,1,2)-SINT1*SINT2*DRHO1(M,2,2)  0866.000
         SIGRHO(2,2)=-COST3*SINT1*DRHO1(M,1,2)+SINT2*SINT3*COST1        0867.000
     1   *DRHO1(M,1,2)+SINT1*SINT3*COST2*DRHO1(M,2,2)-COST1*SINT3       0868.000
     2   *DRHO1(M,3,2)+SINT1*SINT2*COST3*DRHO1(M,3,2)                   0869.000
         SIGRHO(2,3)=-SINT3*SINT1*DRHO1(M,1,2)-SINT2*COST3*COST1        0870.000
     1   *DRHO1(M,1,2)-SINT1*COST3*COST2*DRHO1(M,2,2)+COST1*COST3       0871.000
     2   *DRHO1(M,3,2)+SINT1*SINT2*SINT3*DRHO1(M,3,2)                   0872.000
         SIGRHO(3,1)=COST2*DRHO1(M,2,2)                                 0873.000
         SIGRHO(3,2)=SINT3*SINT2*DRHO1(M,2,2)-COST2*COST3*DRHO1(M,3,2)  0874.000
         SIGRHO(3,3)=-COST3*SINT2*DRHO1(M,2,2)-COST2*SINT3*DRHO1(M,3,2) 0875.000
      IF (JITER.GT.0.AND.NITER.EQ.0) WRITE(3,80) RBN(M)                 0876.000
      CALL MPRD(ALPH,RHO,PROD,3,3,0,0,3)                                0877.000
      DO 452 IA=1,NSF                                                   0878.000
         I=MOD(ID(IA),100)                                              0879.000
         IF (I.LT.-1) I=-I-1                                            0880.000
         IF (I.NE.M) GO TO 452                                          0881.000
      DO 444 I=1,3                                                      0882.000
         OLD=XX(I,IA)                                                   0883.000
      XX(I,IA)=XO(M,I)                                                  0884.000
         DO 447 J=1,3                                                   0885.000
 447     RHO(I,J)=0.                                                    0886.000
      DO 445 J=1,3                                                      0887.000
         RHO(I,I)=XC(IA,J)*SIGRHO(I,J)+RHO(I,I)                         0888.000
 445  XX(I,IA)=XC(IA,J)*PROD(I,J)+XX(I,IA)                              0889.000
         DO 446 J=1,NSF                                                 0890.000
         IF (IABS(ID(J)/100).EQ.IA) XX(I,J)=XX(I,J)+XX(I,IA)-OLD        0891.000
 446     CONTINUE                                                       0892.000
 444     CONTINUE                                                       0893.000
         DO 449 I=1,3                                                   0894.000
 449     RHO(I,I)=RHO(I,I)*RHO(I,I)                                     0895.000
         CALL TRANM(RHO,ALPH,PO)                                        0896.000
         DO 448 I=1,3                                                   0897.000
 448     EP(I,IA)=DRHO1(M,I,1)+SQRT(PO(I,I))                            0898.000
         IF (JITER.GT.0.AND.NITER.EQ.0)                                 0899.000
     1   WRITE (3,81)ITBL(IA), ANAME(IA),(XX(J,IA),J=1,3),              0900.000
     2   (EP(J,IA),J=1,3)                                               0901.000
 452     CONTINUE                                                       0902.000
      IF (NITER.EQ.0) GO TO 451                                         0903.000
      DO 1 J=1,3                                                        0904.000
      DRHO3(M,J,1)=0                                                    0905.000
    1 DRHO1(M,3,J)=0                                                    0906.000
      DRHO1(M,1,1)=-SINT1*COST2                                         0907.000
      DRHO1(M,1,2)=-COST1*COST3-SINT1*SINT2*SINT3                       0908.000
      DRHO1(M,1,3)=-COST1*SINT3+SINT1*SINT2*COST3                       0909.000
      DRHO1(M,2,1)=COST1*COST2                                          0910.000
      DRHO1(M,2,2)=-SINT1*COST3+COST1*SINT2*SINT3                       0911.000
      DRHO1(M,2,3)=-SINT1*SINT3-COST1*SINT2*COST3                       0912.000
      DRHO2(M,1,1)=-COST1*SINT2                                         0913.000
      DRHO2(M,1,2)=COST1*COST2*SINT3                                    0914.000
      DRHO2(M,1,3)=-COST1*COST2*COST3                                   0915.000
      DRHO2(M,2,1)=-SINT1*SINT2                                         0916.000
      DRHO2(M,2,2)=SINT1*COST2*SINT3                                    0917.000
      DRHO2(M,2,3)=-SINT1*COST2*COST3                                   0918.000
      DRHO2(M,3,1)=COST2                                                0919.000
      DRHO2(M,3,2)=SINT2*SINT3                                          0920.000
      DRHO2(M,3,3)=-SINT2*COST3                                         0921.000
      DRHO3(M,1,2)=SINT1*SINT3+COST1*SINT2*COST3                        0922.000
      DRHO3(M,1,3)=-SINT1*COST3+COST1*SINT2*SINT3                       0923.000
      DRHO3(M,2,2)=-COST1*SINT3+SINT1*SINT2*COST3                       0924.000
      DRHO3(M,2,3)=COST1*COST3+SINT1*SINT2*SINT3                        0925.000
      DRHO3(M,3,2)=-COST2*COST3                                         0926.000
      DRHO3(M,3,3)=-COST2*SINT3                                         0927.000
C     CALCULATE DERIVATIVES OF R.B. ATOM COORDS W.R.T. ORIENTATION      0928.000
C     ANGLES                                                            0929.000
      DO 1722 I=1,3                                                     0930.000
      DO 1722 J=1,3                                                     0931.000
 1722 RHO(I,J)=DRHO1(M,I,J)                                             0932.000
      CALL MPRD(ALPH,RHO,PROD,3,3,0,0,3)                                0933.000
      DO 1728 IA=1,NSF                                                  0934.000
         I=MOD(ID(IA),100)                                              0935.000
         IF (I.LT.-1) I=-I-1                                            0936.000
         IF (I.NE.M) GO TO 1728                                         0937.000
      DO 1723 I=1,3                                                     0938.000
      XD(IA,I,1)=0.                                                     0939.000
      DO 1723 J=1,3                                                     0940.000
 1723 XD(IA,I,1)=XD(IA,I,1)+PROD(I,J)*XC(IA,J)                          0941.000
 1728    CONTINUE                                                       0942.000
      DO 1724 I=1,3                                                     0943.000
      DO 1724 J=1,3                                                     0944.000
 1724 RHO(I,J)=DRHO2(M,I,J)                                             0945.000
      CALL MPRD(ALPH,RHO,PROD,3,3,0,0,3)                                0946.000
      DO 1729 IA=1,NSF                                                  0947.000
         I=MOD(ID(IA),100)                                              0948.000
         IF (I.LT.-1) I=-I-1                                            0949.000
         IF (I.NE.M) GO TO 1729                                         0950.000
      DO 1725 I=1,3                                                     0951.000
      XD(IA,I,2)=0.                                                     0952.000
      DO 1725 J=1,3                                                     0953.000
 1725 XD(IA,I,2)=XD(IA,I,2)+PROD(I,J)*XC(IA,J)                          0954.000
 1729    CONTINUE                                                       0955.000
      DO 1726 I=1,3                                                     0956.000
      DO 1726 J=1,3                                                     0957.000
 1726 RHO(I,J)=DRHO3(M,I,J)                                             0958.000
      CALL MPRD(ALPH,RHO,PROD,3,3,0,0,3)                                0959.000
      DO 1730 IA=1,NSF                                                  0960.000
         I=MOD(ID(IA),100)                                              0961.000
         IF (I.LT.-1) I=-I-1                                            0962.000
         IF (I.NE.M) GO TO 1730                                         0963.000
      DO 1727 I=1,3                                                     0964.000
      XD(IA,I,3)=0.                                                     0965.000
      DO 1727 J=1,3                                                     0966.000
 1727 XD(IA,I,3)=XD(IA,I,3)+PROD(I,J)*XC(IA,J)                          0967.000
 1730    CONTINUE                                                       0968.000
  451 CONTINUE                                                          0969.000
         IF (JITER.EQ.0) RETURN                                         0970.000
         CALL MDLOUT(4)                                                 0971.000
      RETURN                                                            0972.000
      END                                                               0973.000
      SUBROUTINE IMAT                                                   0974.000
C          INVERSION OF THE MATRIX    CHOLESKI METHOD                   0975.000
         PARAMETER(NNP=850,MATRX=NNP*(NNP+1)/2,NG=16)
         DOUBLE PRECISION SUMA,TERM,DENOM
         COMMON/NMATRX/SUM(MATRX)                                       0976.000
C * * * * * GOULD S.E.L. ONLY * * * *                                   0977.000
C        EXTENDED BLOCK/NMATRX/SUM(MATRX)                               0978.000
C * * * * END GOULD S.E.L. * * * *                                      0979.000
      COMMON NPAR,SHIFT(NNP),VECT(NNP),SYGMA(NNP),                      0980.000
     1NELEM,XO(NG,6),NOT(2000),    NRB,      FA,FB,CONVP,VOL,NTL,       0981.000
     2XC(200,3),NAR(NG),ALPH(3,3),DRHO1(NG,3,3),DRHO2(NG,3,3),          0982.000
     3DRHO3(NG,3,3),COMPD(10),AFACT(6),SMDVQ,SMFOB,SGWFS,SIGFC,SGWDS,   0983.000
     4NUNTW,NITER,RFAC,EITPSQ,EFACT(99,2),ISTAP,ISTAPR(NG),NRRRB(NG),   0984.000
     5NRR,WTGR,BISO(NG),ID(200),JITER,IC,ITER,STNDM,AMM,IPRNT,IPNCH,    0985.000
     6NOMAT                                                             0986.000
 1111 FORMAT(////' SINGULAR MATRIX. ROW AND COLUMN',I4)                 0987.000
C     IM, IV ARE BLOCK POINTERS                                         0988.000
      IM=1                                                              0989.000
      IV=1                                                              0990.000
      IF (NOMAT.EQ.1.AND.JITER.GT.1) GO TO 600                          0991.000
    2 K=IM                                                              0992.000
      IF(NPAR-1)10,8,9                                                  0993.000
 8    SUM(IM)=1./SUM(IM)                                                0994.000
      SHIFT(1)=VECT(IV)*SUM(IM)                                         0995.000
      SYGMA(1)=SUM(IM)                                                  0996.000
      CALL OUTR                                                         0997.000
C     IM=IM+1                                                           0998.000
C     IV=IV+1                                                           0999.000
   10 RETURN                                                            1000.000
    9 DO 7 M=1,NPAR                                                     1001.000
      IMAX=M-1                                                          1002.000
      DO 6 L=M,NPAR                                                     1003.000
      SUMA=0.0                                                          1004.000
      KLI=L+IM-1                                                        1005.000
      KMI=M+IM-1                                                        1006.000
      IF(IMAX)523,523,101                                               1007.000
  101 DO 202 I=1,IMAX                                                   1008.000
      SUMA=SUMA+SUM(KLI)*SUM(KMI)                                       1009.000
      J=NPAR-I                                                          1010.000
      KLI=KLI+J                                                         1011.000
  202 KMI=KMI+J                                                         1012.000
  523 TERM=SUM(K)-SUMA                                                  1013.000
      IF(L-M)103,103,505                                                1014.000
  103 IF(TERM)110,110,504                                               1015.000
 110  WRITE (3,1111) M                                                  1016.000
      STOP                                                              1017.000
  504 DENOM=SQRT(TERM)                                                  1018.000
      SUM(K)=DENOM                                                      1019.000
      GO TO 6                                                           1020.000
  505 SUM(K)=TERM/DENOM                                                 1021.000
    6 K=K+1                                                             1022.000
    7 CONTINUE                                                          1023.000
      SUM(IM)=1./SUM(IM)                                                1024.000
      KDM=IM                                                            1025.000
      DO 104 L=2,NPAR                                                   1026.000
      KDM=KDM+NPAR-L+2                                                  1027.000
      TERM=1./SUM(KDM)                                                  1028.000
      SUM(KDM)=TERM                                                     1029.000
      KMI=IM-1                                                          1030.000
      KLI=IM+L-1                                                        1031.000
      IMAX=L-1                                                          1032.000
      DO 203 M=1,IMAX                                                   1033.000
      K=KLI                                                             1034.000
      SUMA=0.0                                                          1035.000
      DO 502 I=M,IMAX                                                   1036.000
      II=KMI+I                                                          1037.000
      SUMA=SUMA-SUM(KLI)*SUM(II)                                        1038.000
  502 KLI=KLI+NPAR-I                                                    1039.000
      SUM(K)=SUMA*TERM                                                  1040.000
      J=NPAR-M                                                          1041.000
      KLI=K+J                                                           1042.000
  203 KMI=KMI+J                                                         1043.000
  104 CONTINUE                                                          1044.000
      K=IM                                                              1045.000
      DO 303 M=1,NPAR                                                   1046.000
      KLI=K                                                             1047.000
      DO 302 L=M,NPAR                                                   1048.000
      KMI=K                                                             1049.000
      IMAX=NPAR-L+1                                                     1050.000
      SUMA=0.0                                                          1051.000
      DO 301 I=1,IMAX                                                   1052.000
      SUMA=SUMA+SUM(KLI)*SUM(KMI)                                       1053.000
      KLI=KLI+1                                                         1054.000
  301 KMI=KMI+1                                                         1055.000
      SUM(K)=SUMA                                                       1056.000
  302 K=K+1                                                             1057.000
  303 CONTINUE                                                          1058.000
C TO GET SIGMAS AND SHIFTS                                              1059.000
 600  DO 400 I=1,NPAR                                                   1060.000
      SHIFT(I)=0.0                                                      1061.000
      IJ=I+IM-1                                                         1062.000
      IJD=NPAR-1                                                        1063.000
      DO 401 J=1,NPAR                                                   1064.000
      JJ=IV+J-1                                                         1065.000
      SHIFT(I)=SHIFT(I)+SUM(IJ)*VECT(JJ)                                1066.000
      IF(J-I)402,403,404                                                1067.000
  402 IJ=IJ+IJD                                                         1068.000
      IJD=IJD-1                                                         1069.000
      GO TO 401                                                         1070.000
 403  SYGMA(I)=SUM(IJ)                                                  1071.000
  404 IJ=IJ+1                                                           1072.000
  401 CONTINUE                                                          1073.000
  400 CONTINUE                                                          1074.000
C     IM=IM+NPAR*(NPAR+1)/2                                             1075.000
C     IV=IV+NPAR                                                        1076.000
      CALL OUTR                                                         1077.000
      RETURN                                                            1078.000
      END                                                               1079.000
      SUBROUTINE CORRL                                                  1080.000
C      CORRELATION MATRIX OUTPUT --                                     1081.000
         PARAMETER(NNP=850,MATRX=NNP*(NNP+1)/2,NG=16)
         COMMON/NMATRX/AM(MATRX)                                        1082.000
C * * * * * GOULD S.E.L. ONLY * * * * *                                 1083.000
C        EXTENDED BLOCK/NMATRX/AM(MATRX)                                1084.000
C * * * * END GOULD S.E.L. * * * *                                      1085.000
      COMMON NPAR,PD(NNP),V(NNP),DIAG(NNP),MOUT,XO(NG,6),               1086.000
     1NOT(2000),    NRB,      FA,FB,CONVP,VOL,NTL,                      1087.000
     2XC(200,3),NAR(NG),ALPH(3,3),DRHO1(NG,3,3),DRHO2(NG,3,3),          1088.000
     3DRHO3(NG,3,3),COMPD(10),AFACT(6),SMDVQ,SMFOB,SGWFS,SIGFC,SGWDS,   1089.000
     4NUNTW,NITER,RFAC,EITPSQ,EFACT(99,2),ISTAP,ISTAPR(NG),NRRRB(NG),   1090.000
     5NRR,WTGR,BISO(NG),ID(200),JITER,IC,ITER,STNDM,MM,IPRNT            1091.000
 11   FORMAT  ('0ROW',I5)                                               1092.000
   97 FORMAT(19H0CORRELATION MATRIX/)                                   1093.000
 98   FORMAT (' ',10F12.4)                                              1094.000
 99   FORMAT (1X,I3,I6,F12.4)                                           1095.000
 100  FORMAT (' ROW   COL   COEFFICIENTS > 0.5')                        1096.000
      WRITE(3,97)                                                       1097.000
      IF (IC.EQ.-1) WRITE (3,100)                                       1098.000
      DO 452 I=1,NPAR                                                   1099.000
  452 DIAG(I)=1.0/SQRT(DIAG(I))                                         1100.000
      IJ=1                                                              1101.000
      DO 455 I=1,NPAR                                                   1102.000
      DO 454 J=I,NPAR                                                   1103.000
      V(J)=AM(IJ)*DIAG(I)*DIAG(J)*STNDM                                 1104.000
      IF (ABS(V(J)).GE.0.5.AND.J.GT.I.AND.IC.EQ.-1)                     1105.000
     1            WRITE (3,99)  I,J,V(J)                                1106.000
 454  IJ=IJ+1                                                           1107.000
      IF (IC.EQ.1) THEN                                                 1108.000
         WRITE (3,11) I                                                 1109.000
      WRITE(3,98)  (V(J),J=I,NPAR)                                      1110.000
         ENDIF                                                          1111.000
 455  CONTINUE                                                          1112.000
      RETURN                                                            1113.000
      END                                                               1114.000
      SUBROUTINE INVER(A,B)                                             1115.000
C     INVERT 3*3 MATRIX A                                               1116.000
      DIMENSION A(3,3),B(3,3)                                           1117.000
C     FORM ADJUGATE MATRIX                                              1118.000
      B(1,1)=A(2,2)*A(3,3)-A(2,3)*A(3,2)                                1119.000
      B(1,2)=A(1,3)*A(3,2)-A(1,2)*A(3,3)                                1120.000
      B(1,3)=A(1,2)*A(2,3)-A(1,3)*A(2,2)                                1121.000
      B(2,1)=A(2,3)*A(3,1)-A(2,1)*A(3,3)                                1122.000
      B(2,2)=A(1,1)*A(3,3)-A(1,3)*A(3,1)                                1123.000
      B(2,3)=A(1,3)*A(2,1)-A(1,1)*A(2,3)                                1124.000
      B(3,1)=A(2,1)*A(3,2)-A(2,2)*A(3,1)                                1125.000
      B(3,2)=A(1,2)*A(3,1)-A(1,1)*A(3,2)                                1126.000
      B(3,3)=A(1,1)*A(2,2)-A(1,2)*A(2,1)                                1127.000
C     CALC DETERMINANT AND INVERSE OF A                                 1128.000
      DET=A(1,1)*B(1,1)+A(1,2)*B(2,1)+A(1,3)*B(3,1)                     1129.000
      DO 109 I=1,3                                                      1130.000
      DO 109 J=1,3                                                      1131.000
 109  B(I,J)=B(I,J)/DET                                                 1132.000
      RETURN                                                            1133.000
      END                                                               1134.000
      SUBROUTINE FUDG (H,SC,FO,FC,DELTA,W)                              1135.000
C     DUMMY ROUTINE TO SET ROOT W                                       1136.000
      INTEGER H(3),SC                                                   1137.000
      RETURN                                                            1138.000
      END                                                               1139.000
         SUBROUTINE REFIND(PARAM,TAG,KKK,N,ANAME,IREF,NRB,RBN,IREFG,IND,1140.000
     1N1,L)                                                             1141.000
C * * * * GOULD S.E.L. ONLY * * * * *                                   1142.000
C        EXTENDED DUMMY IREF                                            1143.000
C * * * * END GOULD S.E.L. CODE * * * * *                               1144.000
         PARAMETER(NNP=850,MATRX=NNP*(NNP+1)/2,NNQ=NNP+1,NG=16)
         CHARACTER*8 TAG(2),PARAM,ANAME(200),RBN(NG)                    1145.000
         DIMENSION IREF(10,200),IREFG(7,NG)                             1146.000
         LOGICAL ALL,GPMATCH                                            1147.000
         ALL=.FALSE.                                                    1148.000
         GPMATCH=.FALSE.                                                1149.000
         IF (KKK.EQ.1) ALL=.TRUE.                                       1150.000
         N1=1                                                           1151.000
         N2=N                                                           1152.000
         IF (KKK.LT.3) GO TO 705                                        1153.000
         DO 703 K=1,KKK-2                                               1154.000
         DO 704 I=1,N                                                   1155.000
         IF (TAG(K).NE.ANAME(I)) GO TO 704                              1156.000
         GO TO (701,702),K                                              1157.000
 701     N1=I                                                           1158.000
 702     N2=I                                                           1159.000
         GO TO 703                                                      1160.000
 704     CONTINUE                                                       1161.000
         DO 801 I=1,NRB                                                 1162.000
         IF (TAG(K).NE.RBN(I)) GO TO 801                                1163.000
         GO TO (802,803),K                                              1164.000
 802     N1=I                                                           1165.000
 803     N2=I                                                           1166.000
         GPMATCH=.TRUE.                                                 1167.000
         GO TO 703                                                      1168.000
 801     CONTINUE                                                       1169.000
         WRITE (6,725) TAG(K)                                           1170.000
 725     FORMAT (' REF/NOREF COMMAND: LABEL ',A8,' INCONSISTENT')       1171.000
         RETURN                                                         1172.000
 703     CONTINUE                                                       1173.000
         IF (N2.LT.N1) THEN                                             1174.000
         WRITE (6,700) TAG                                              1175.000
 700     FORMAT (     ' REF/NOREF COMMAND: LABELS ',A8,1X,A8,' HAVE INCO1176.000
     1NSISTENT SEQUENCE')                                               1177.000
         RETURN                                                         1178.000
         ENDIF                                                          1179.000
         IF (GPMATCH) THEN                                              1180.000
         DO 804 I=N1,N2                                                 1181.000
 804     IREFG(7,I)=IND                                                 1182.000
         RETURN                                                         1183.000
         ENDIF                                                          1184.000
 705     IF (.NOT.ALL) GO TO 730                                        1185.000
         DO 731 I=N1,N2                                                 1186.000
         DO 731 J=1,10                                                  1187.000
 731     IREF(J,I)=IND                                                  1188.000
         RETURN                                                         1189.000
 730     DO 706 I=N1,N2                                                 1190.000
         IF (PARAM.NE.'X') GO TO 707                                    1191.000
         L=1                                                            1192.000
         GO TO 740                                                      1193.000
 707     IF (PARAM.NE.'Y') GO TO 708                                    1194.000
         L=2                                                            1195.000
         GO TO 740                                                      1196.000
 708     IF (PARAM.NE.'Z') GO TO 722                                    1197.000
         L=3                                                            1198.000
         GO TO 740                                                      1199.000
 722     IF (PARAM.NE.'OCC') GO TO 709                                  1200.000
         L=4                                                            1201.000
         GO TO 740                                                      1202.000
 709     IF (PARAM.NE.'U11') GO TO 710                                  1203.000
         L=5                                                            1204.000
         GO TO 740                                                      1205.000
 710     IF (PARAM.NE.'U22') GO TO 711                                  1206.000
         L=6                                                            1207.000
         GO TO 740                                                      1208.000
 711     IF (PARAM.NE.'U33') GO TO 712                                  1209.000
         L=7                                                            1210.000
         GO TO 740                                                      1211.000
 712     IF (PARAM.NE.'U12') GO TO 713                                  1212.000
         L=8                                                            1213.000
         GO TO 740                                                      1214.000
 713     IF (PARAM.NE.'U13') GO TO 714                                  1215.000
         L=9                                                            1216.000
         GO TO 740                                                      1217.000
 714     IF (PARAM.NE.'U23') GO TO 715                                  1218.000
         L=10                                                           1219.000
 740     IREF(L,I)=IND                                                  1220.000
         GO TO 706                                                      1221.000
 715     IF (PARAM.NE.'UIJ') GO TO 732                                  1222.000
         DO 721 J=5,10                                                  1223.000
 721     IREF(J,I)=IND                                                  1224.000
         GO TO 706                                                      1225.000
 732     IF (PARAM.NE.'ALL') GO TO 720                                  1226.000
         DO 733 J=1,10                                                  1227.000
 733     IREF(J,I)=IND                                                  1228.000
         GO TO 706                                                      1229.000
 720     WRITE (6,716) PARAM                                            1230.000
 716     FORMAT (' UNRECOGNISED PARAMETER DESCRIPTOR: ',A8)             1231.000
         RETURN                                                         1232.000
 706     CONTINUE                                                       1233.000
         RETURN                                                         1234.000
         END                                                            1235.000
         SUBROUTINE AMATCH(N1,N2,TAG,MODE,N,ANAME)                      1236.000
         CHARACTER*8 TAG(2),ANAME(200)                                  1237.000
         N1=0                                                           1238.000
         N2=0                                                           1239.000
         DO 3 I=1,MODE                                                  1240.000
         DO 4 J=1,N                                                     1241.000
         IF (TAG(I).NE.ANAME(J)) GO TO 4                                1242.000
         GO TO (5,6),I                                                  1243.000
 5       N1=J                                                           1244.000
         GO TO 3                                                        1245.000
 6       N2=J                                                           1246.000
         GO TO 3                                                        1247.000
 4       CONTINUE                                                       1248.000
         WRITE (6,7) TAG(I)                                             1249.000
 7       FORMAT (' RIDE COMMAND: NO MATCH FOR LABEL ',A8)               1250.000
 3       CONTINUE                                                       1251.000
         RETURN                                                         1252.000
         END                                                            1253.000
         SUBROUTINE UCONV(TAG,U,FTYPE,ITBL,ID,AFACT,N)                  1254.000
C        CONVERT UISO TO UIJ                                            1255.000
         CHARACTER*8 TAG,FTYPE(13)                                      1256.000
         DIMENSION ITBL(200),U(6,200),ID(200),AFACT(6)                  1257.000
         LOGICAL DONE                                                   1258.000
         DONE=.FALSE.                                                   1259.000
         DO 40 I=1,N                                                    1260.000
         IF (TAG.NE.FTYPE(ITBL(I)).OR.ID(I).LT.0) GO TO 40              1261.000
      DO 43 J=2,3                                                       1262.000
 43   U(J,I  )=       U(1,I)                                            1263.000
         DO 33 J=1,2                                                    1264.000
         DO 33 K=J+1,3                                                  1265.000
 33      U(J+K+1,I)=U(1,I)*AFACT(J+K+1)/SQRT(AFACT(J)*AFACT(K))         1266.000
         ID(I)=-ID(I)-1                                                 1267.000
         DONE=.TRUE.                                                    1268.000
 40      CONTINUE                                                       1269.000
         IF (DONE) RETURN                                               1270.000
         WRITE (6,725) TAG                                              1271.000
 725     FORMAT (' ANISO CONTROL IGNORED: ATOM TYPE ',A8,' UNRECOGNISED,1272.000
     1'/' OR NO INDIVIDUAL ISOTROPIC ATOMS OF THIS TYPE. <<<<<<<<<<<<<')1273.000
         RETURN                                                         1274.000
         END                                                            1275.000
         SUBROUTINE BCONV(U,EU,ID,EITPSQ,AFACT,N)                       1276.000
C        CONVERT B OR BETA TO UISO OR UIJ                               1277.000
         DIMENSION U(6,200),ID(200),AFACT(6),EU(6,200)                  1278.000
         DO 603 I=1,N                                                   1279.000
         IF (ID(I).GE.0) GO TO 30                                       1280.000
         DO 602 J=1,3                                                   1281.000
         U(J,I)=4.*U(J,I)/(EITPSQ*AFACT(J))                             1282.000
 602     EU(J,I)=4.*EU(J,I)/(EITPSQ*AFACT(J))                           1283.000
         DO 33 J=1,2                                                    1284.000
         DO 33 K=J+1,3                                                  1285.000
         U(J+K+1,I)=4.*U(J+K+1,I)/(EITPSQ*SQRT(AFACT(J)*AFACT(K)))      1286.000
 33      EU(J+K+1,I)=4.*EU(J+K+1,I)/(EITPSQ*SQRT(AFACT(J)*AFACT(K)))    1287.000
         GO TO 603                                                      1288.000
 30      U(1,I)=U(1,I)/EITPSQ                                           1289.000
         EU(1,I)=EU(1,I)/EITPSQ                                         1290.000
 603     CONTINUE                                                       1291.000
         RETURN                                                         1292.000
         END                                                            1293.000
      SUBROUTINE SFRB                                                   1294.000
C      S.F. CALCULATION --                                              1295.000
         PARAMETER(NNP=850,MATRX=NNP*(NNP+1)/2,NNQ=NNP+1,NG=16)
         CHARACTER COMPID(72)                                           1296.000
         CHARACTER*8 ANAME(200),FTYPE(13)                               1297.000
         INTEGER CN(200),CONTNT(13),H(3),SC,NARB(NG),NPWRB(NG),         1298.000
     1   NRRRB(NG),MPRB(NG),ISTAPR(NG)                                  1299.000
      REAL       FRAC(24),FHT(24),FKT(24),FLT(24),FHHT(24),FKKT(24),    1300.000
     1FLLT(24),FHLT(24),FKLT(24),FHKT(24),DRVA(NNQ),DRVB(NNQ),DRV1(3),  1301.000
     2 DRV2(3),DRV3(3),FF(13),    MM,ACRB(NG),BCRB(NG)                  1302.000
         COMMON/NMATRX/AM(MATRX)                                        1303.000
C * * * * * GOULD S.E.L. ONLY  * * * * *                                1304.000
C        EXTENDED BLOCK/NMATRX/AM(MATRX)                                1305.000
C * * * * END GOULD S.E.L. * * * *                                      1306.000
      COMMON NPAR,PD(NNP),V(NNP),DIAG(NNP),NELEM,XO(NG,6),              1307.000
     1NOT(2000),    NRB,      FA,FB,CONVP,VOL,NTL,                      1308.000
     2XC(200,3),NAR(NG),ALPH(3,3),DRHO1(NG,3,3),DRHO2(NG,3,3),          1309.000
     3DRHO3(NG,3,3),COMPD(10),AFACT(6),SMDVQ,SMFOB,SGWFS,SIGFC,SGWDS,   1310.000
     4NUNTW,NITER,RFAC,EITPSQ,EFACT(99,2),ISTAP,ISTAPR,NRRRB,NRR,       1311.000
     5WTGR,BISO(NG),ID(200),JITER,IC,ITER,STNDM,MM,IPRNT,CUTO,NOMAT,    1312.000
     6OLDR                                                              1313.000
         COMMON/MODELC/COMPID,ANAME,FTYPE                               1314.000
         COMMON/MODEL/NSF,NEQV,NT,MMAT,      ITBL(200),XX(  600),       1315.000
     1   CN,SOF(200),UU( 1200),EP(3,200),ESOF(200),EUIJ(6,200),         1316.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICEND,                 1317.000
     3   SFAC(14,13),CONTNT,G(4),ETA,NQ, RSTAR                          1318.000
      COMMON/PAUL3/XD(200,3,3)                                          1319.000
 5    FORMAT (' ',4I4,  8F10.5)                                         1320.000
 630     FORMAT ('0R FACTOR INCREASED BY > 0.1; REFINEMENT ABANDONED')  1321.000
 9000 FORMAT('0R INDEX =',F7.4,15X,'WEIGHTED R INDEX =',F7.4,' <<<------1322.000
     1-'/'0NO. OF PLANES IN LEAST SQUARES =',I5/'0SUM FOBS =',E12.5,10X,1323.000
     2'SUM FCALC =',E12.5,/'0SUM W*DELTA SQD. =',E12.5)                 1324.000
 9001 FORMAT('0SUM DELF =',E12.5,10X,'SUMWDS/(N-M) =',E12.5)            1325.000
      REWIND 16                                                         1326.000
      TWOPI=6.28318                                                     1327.000
         RSTAR2=2.*RSTAR                                                1328.000
         DELTC=79.384*WAVEL**3/((1.-CELL(4)**2-CELL(5)**2-CELL(6)**2+   1329.000
     1   2.*CELL(4)*CELL(5)*CELL(6))*(CELL(1)*CELL(2)*CELL(3))**2)      1330.000
         MEC=1                                                          1331.000
         DO 675 I=1,NQ                                                  1332.000
         IF (NOT(I).EQ.1) MEC=MEC+1                                     1333.000
 675     CONTINUE                                                       1334.000
C        MEC IS L.S.P.S.NO. OF EXTINCTION COEFF.                        1335.000
      NTL=0                                                             1336.000
 999  READ (16,END=9965) IW1,IW2,FOBS,SIG                               1337.000
         IF (FOBS.LT.CUTO*SIG) GO TO 999                                1338.000
         IF (NUNTW.EQ.1.AND.FB.NE.0.) THEN                              1339.000
         SIG=SIG*SIG                                                    1340.000
         SIG=SIG+SIGN(FB*FB*FOBS*FOBS,FB)                               1341.000
         SIG=SQRT(SIG)                                                  1342.000
         ENDIF                                                          1343.000
         FOBS=SQRT(FOBS)                                                1344.000
         SIG=0.5*SIG/FOBS                                               1345.000
         SC=IW1/16777216                                                1346.000
         IF (SC.GT.NQ) THEN                                             1347.000
         WRITE (6,998) H,SC                                             1348.000
 998     FORMAT (' NO SCALE FACTOR FOR',3I5,'  BATCH NO.',I3,' - REFLECT1349.000
     1ION IGNORED')                                                     1350.000
         GO TO 999                                                      1351.000
         ENDIF                                                          1352.000
         I=MOD(IW1,16777216)                                            1353.000
      FJ=(I/65536)-128                                                  1354.000
         I=MOD(I,65536)                                                 1355.000
      FK=(I/256)-128                                                    1356.000
         I=MOD(I,256)                                                   1357.000
      FL=I-128                                                          1358.000
         H(1)=FJ                                                        1359.000
         H(2)=FK                                                        1360.000
         H(3)=FL                                                        1361.000
      DELT=0.0                                                          1362.000
         TBAR=(IW2/65536)*1.E-4                                         1363.000
      FOBS=FOBS/G(SC)                                                   1364.000
         SIG=SIG/G(SC)                                                  1365.000
      SMFOB=SMFOB+FOBS                                                  1366.000
         SINN=(FJ*FJ*AFACT(1)+FK*FK*AFACT(2)+FL*FL*AFACT(3)+            1367.000
     1   2.*FJ*FK*AFACT(4)+2.*FJ*FL*AFACT(5)+2.*FK*FL*AFACT(6))*0.25    1368.000
         IF (RSTAR.GT.0.) THEN                                          1369.000
         SINTH=WAVEL*SQRT(SINN)                                         1370.000
         COSTH=SQRT(1.-SINTH*SINTH)                                     1371.000
         SIN2TH=2.*SINTH*COSTH                                          1372.000
         COSQ2TH=(COSTH*COSTH-SINTH*SINTH)**2                           1373.000
         DELT=DELTC*(1.+COSQ2TH*COSQ2TH)*TBAR/((1.+COSQ2TH)*SIN2TH)     1374.000
         ENDIF                                                          1375.000
      AC=0.                                                             1376.000
      BC=0.                                                             1377.000
         C=0.                                                           1378.000
         D=0.                                                           1379.000
      NPW=NRR                                                           1380.000
C        NPW IS NOW INITIALISED S.P.SEQ.NO. OF ATOM PARAMETERS          1381.000
      MRB=MEC-1+NOT(NQ+1)+NOT(NQ+2)                                     1382.000
C        MRB IS NOW INITIALISED L.S.P.SEQ.NO. OF GROUP TEMP. FACTORS    1383.000
      MSP=MEC+NOT(NQ+1)                                                 1384.000
C        MSP IS L.S.P.S.NO. OF SIGN OF F'' (ETA)                        1385.000
      MP=ISTAP                                                          1386.000
C        MP IS NOW INITIALISED L.S.P.S.NO. OF ATOM PARAMETERS           1387.000
         IF (NRB.EQ.0) GO TO 6218                                       1388.000
         DO 672 I=1,NRB                                                 1389.000
      ACRB(I)=0.                                                        1390.000
      BCRB(I)=0.                                                        1391.000
         NPWRB(I)=NRRRB(I)                                              1392.000
C        NPWRB IS NOW INITIALISED S.P.S.NO. OF GROUP I POS. PARAMETERS  1393.000
         MPRB(I)=ISTAPR(I)                                              1394.000
C        MPRB IS NOW INITIALISED L.S.P.S.NO. OF GROUP I POS. PARAMETERS 1395.000
  672 NARB(I)=0                                                         1396.000
C     NAR(I) = NO. OF ATOMS IN R.B. I, NARB(I) = RUNNING TOTAL          1397.000
 6218    IF (NITER.EQ.0) GO TO 466                                      1398.000
      DO 346 JJ=1,NPAR                                                  1399.000
      DRVA(JJ)=0.                                                       1400.000
  346 DRVB(JJ)=0.                                                       1401.000
 466  DO 124 JJ=1,NEQV                                                  1402.000
      FRAC(JJ)=R(JJ,1,4)*FJ+R(JJ,2,4)*FK+R(JJ,3,4)*FL                   1403.000
      FHT(JJ)=FJ*R(JJ,1,1)+FK*R(JJ,2,1)+FL*R(JJ,3,1)                    1404.000
      FKT(JJ)=FJ*R(JJ,1,2)+FK*R(JJ,2,2)+FL*R(JJ,3,2)                    1405.000
      FLT(JJ)=FJ*R(JJ,1,3)+FK*R(JJ,2,3)+FL*R(JJ,3,3)                    1406.000
      FHHT(JJ)=FHT(JJ)*FHT(JJ)                                          1407.000
      FKKT(JJ)=FKT(JJ)*FKT(JJ)                                          1408.000
      FLLT(JJ)=FLT(JJ)*FLT(JJ)                                          1409.000
      FHKT(JJ)=FHT(JJ)*FKT(JJ)                                          1410.000
      FHLT(JJ)=FHT(JJ)*FLT(JJ)                                          1411.000
      FKLT(JJ)=FKT(JJ)*FLT(JJ)                                          1412.000
  124 CONTINUE                                                          1413.000
         DO 125 JJ=1,MMAT                                               1414.000
         FF(JJ)=0.                                                      1415.000
         DO 8857 I=1,8,2                                                1416.000
 8857    FF(JJ)=FF(JJ)+SFAC(I,JJ)*EXP(-SFAC(I+1,JJ)*SINN)               1417.000
 125     FF(JJ)=FF(JJ)+SFAC(9,JJ)+SFAC(10,JJ)                           1418.000
      DO 399 II=1,NSF                                                   1419.000
      L=MOD(ID(II),100)                                                 1420.000
         IF (L.LT.-1) L=-L-1                                            1421.000
      NTYPE=ITBL(II)                                                    1422.000
         IF (L.GT.0) NARB(L)=NARB(L)+1                                  1423.000
      ICENT=ICEND                                                       1424.000
      IF (SFAC(11,NTYPE).EQ.0.0.OR.ETA.EQ.0.0) GO TO 9997               1425.000
      FIMAG=SOF(II)*SFAC(11,NTYPE)*ETA                                  1426.000
      ICENT=1                                                           1427.000
      GO TO 996                                                         1428.000
 9997 FIMAG=0.0                                                         1429.000
  996 IF(NITER) 501,501,502                                             1430.000
  502 IF (L.LE.0) GO TO 501                                             1431.000
      DO 838 I=1,3                                                      1432.000
      DRV1(I)=XD(II,I,1)                                                1433.000
      DRV2(I)=XD(II,I,2)                                                1434.000
 838  DRV3(I)=XD(II,I,3)                                                1435.000
 501     I=6*(II-1)                                                     1436.000
         K=I/2                                                          1437.000
      DO 126 JJ=1,NEQV                                                  1438.000
      ARG=FHT(JJ)*XX(1+K)+FKT(JJ)*XX(2+K)+FLT(JJ)*XX(3+K)+FRAC(JJ)      1439.000
      ARG=ARG*TWOPI                                                     1440.000
      IF (ID(II).LT.0) GO TO 306                                        1441.000
      TEMPX=EXP(-UU(1+I)*SINN)                                          1442.000
      GO TO 308                                                         1443.000
  306 TEMPX=EXP(-UU(1+I)*FHHT(JJ)-UU(2+I)*FKKT(JJ)-UU(3+I)*FLLT(JJ)-    1444.000
     1UU(4+I)*FHKT(JJ)*2.-UU(5+I)*FHLT(JJ)*2.-UU(6+I )*FKLT(JJ)*2.)     1445.000
 308  TEMP=FF(NTYPE)*TEMPX*MM*SOF(II)                                   1446.000
      COSARG=COS(ARG)                                                   1447.000
      SINARG=SIN(ARG)                                                   1448.000
      COST=TEMP*COSARG                                                  1449.000
      SINT=TEMP*SINARG                                                  1450.000
      TEMPM=FIMAG*TEMPX*MM                                              1451.000
      COSTM=TEMPM*COSARG                                                1452.000
         IF (ICEND) 718,713,718                                         1453.000
  713 COST=2.*COST                                                      1454.000
      SINT=2.*SINT                                                      1455.000
      COSTM=2.*COSTM                                                    1456.000
      SINT=SINT+COSTM                                                   1457.000
      ASINT=COSTM                                                       1458.000
      GO TO 717                                                         1459.000
 718  SINTM=TEMPM*SINARG                                                1460.000
      COST=COST-SINTM                                                   1461.000
      SINT=SINT+COSTM                                                   1462.000
      ASINT=SINT                                                        1463.000
         D=D+SINTM                                                      1464.000
 717     C=C+COSTM                                                      1465.000
      AC=AC+COST                                                        1466.000
      BC=BC+ASINT                                                       1467.000
      IF(NITER) 126,126,472                                             1468.000
 472  SINPI=-SINT*TWOPI                                                 1469.000
      COSPI=COST*TWOPI                                                  1470.000
      DRVAX=SINPI*FHT(JJ)                                               1471.000
      DRVAY=SINPI*FKT(JJ)                                               1472.000
      DRVAZ=SINPI*FLT(JJ)                                               1473.000
      DRVBX=COSPI*FHT(JJ)                                               1474.000
      DRVBY=COSPI*FKT(JJ)                                               1475.000
      DRVBZ=COSPI*FLT(JJ)                                               1476.000
C     L IS ATOM ATTRIBUTE DESCRIPTOR, CONTAINING PACKED RIDING POINTER &1477.000
C     TEMP. FACTOR TYPE/GROUP INDICATOR, TO BASE 100. LEAST SIGNIFICANT 1478.000
C     DIGIT HAS VALUES >0 FOR ISOTROPIC GROUP ATOMS, 0 FOR ISOTROPIC    1479.000
C     NON-GROUP ATOMS, -1 FOR ANISOTROPIC NON-GROUP, <-1 FOR ANISOTROPIC1480.000
C     GROUP ATOMS.                                                      1481.000
C     II = ATOM SEQUENCE NO., NPV = STRUCTURE PARAMETER                 1482.000
C     SEQUENCE NO., MP = LEAST SQUARES PARAMETER SEQUENCE NO.           1483.000
C     NDP IS PARAMETER TYPE. 1 - 6 GROUP, 1 - 4  X Y Z OCC, 5  BISO,    1484.000
C     5  - 10 BETA.                                                     1485.000
         NDP=0                                                          1486.000
         IF (L) 230,212,213                                             1487.000
 230     ASSIGN 724 TO N                                                1488.000
         NPV=NPW                                                        1489.000
         M=MP                                                           1490.000
         GO TO 1014                                                     1491.000
 212     ASSIGN 725 TO N                                                1492.000
         NPV=NPW                                                        1493.000
         M=MP                                                           1494.000
         GO TO 1014                                                     1495.000
 213     ASSIGN 770 TO N                                                1496.000
      NPV=NPWRB(L)                                                      1497.000
      M=MPRB(L)                                                         1498.000
      ACRB(L)=ACRB(L)+COST                                              1499.000
      BCRB(L)=BCRB(L)+ASINT                                             1500.000
 1014 NPV=NPV+1                                                         1501.000
      NDP=NDP+1                                                         1502.000
         GO TO N                                                        1503.000
 770     IF (NDP-2) 231,232,221                                         1504.000
 231     ASSIGN 731 TO J                                                1505.000
         GO TO 726                                                      1506.000
 232     ASSIGN 732 TO J                                                1507.000
         GO TO 726                                                      1508.000
 221     IF (NDP-4) 233,234,222                                         1509.000
 233     ASSIGN 733 TO J                                                1510.000
         GO TO 726                                                      1511.000
 234     ASSIGN 734 TO J                                                1512.000
         GO TO 726                                                      1513.000
 222     IF (NDP-6) 235,236,127                                         1514.000
 235     ASSIGN 735 TO J                                                1515.000
         GO TO 726                                                      1516.000
 236     ASSIGN 736 TO J                                                1517.000
         GO TO 726                                                      1518.000
 127     NDP=0                                                          1519.000
         NPWKEEP=NPV-1                                                  1520.000
         MPKEEP=M                                                       1521.000
         IF (ID(II)) 230,212,212                                        1522.000
 724     IF (NDP-2) 231,232,223                                         1523.000
 223     IF (NDP-4) 233,237,224                                         1524.000
 237     ASSIGN 737 TO J                                                1525.000
         GO TO 726                                                      1526.000
 224     IF (NDP-6) 239,240,225                                         1527.000
 239     ASSIGN 739 TO J                                                1528.000
         GO TO 726                                                      1529.000
 240     ASSIGN 740 TO J                                                1530.000
         GO TO 726                                                      1531.000
 225     IF (NDP-8) 241,242,226                                         1532.000
 241     ASSIGN 741 TO J                                                1533.000
         GO TO 726                                                      1534.000
 242     ASSIGN 742 TO J                                                1535.000
         GO TO 726                                                      1536.000
 226     IF (NDP-10) 243,244,126                                        1537.000
 243     ASSIGN 743 TO J                                                1538.000
         GO TO 726                                                      1539.000
 244     ASSIGN 744 TO J                                                1540.000
         GO TO 726                                                      1541.000
 725     IF (NDP-2) 231,232,227                                         1542.000
 227     IF (NDP-4) 233,237,228                                         1543.000
 228     IF (NDP-6) 238,126,126                                         1544.000
 238     ASSIGN 738 TO J                                                1545.000
 726  IF (NOT(NPV)-1) 1014,727,728                                      1546.000
  727 M=M+1                                                             1547.000
         GO TO J                                                        1548.000
C        CONSTRAINED PARAMETER                                          1549.000
 728     MKEEP=M                                                        1550.000
         M=351                                                          1551.000
         DRVA(351)=0.                                                   1552.000
         DRVB(351)=0.                                                   1553.000
         GO TO J                                                        1554.000
C     ATOM COORD AND R.B. ORIGIN DERIVATIVES                            1555.000
  731 DRVA(M)=DRVA(M)+DRVAX                                             1556.000
         IF (ICENT) 751,723,751                                         1557.000
  751 DRVB(M)=DRVB(M)+DRVBX                                             1558.000
      GO TO 723                                                         1559.000
  732 DRVA(M)=DRVA(M)+DRVAY                                             1560.000
         IF (ICENT) 752,723,752                                         1561.000
  752 DRVB(M)=DRVB(M)+DRVBY                                             1562.000
      GO TO 723                                                         1563.000
  733 DRVA(M)=DRVA(M)+DRVAZ                                             1564.000
         IF (ICENT) 753,723,753                                         1565.000
  753 DRVB(M)=DRVB(M)+DRVBZ                                             1566.000
      GO TO 723                                                         1567.000
C     R.B. ORIENTATION DERIVATIVES                                      1568.000
  734 DRVA(M)=DRVA(M)+DRVAX*DRV1(1)+DRVAY*DRV1(2)+DRVAZ*DRV1(3)         1569.000
         IF (ICENT) 754,723,754                                         1570.000
  754 DRVB(M)=DRVB(M)+DRVBX*DRV1(1)+DRVBY*DRV1(2)+DRVBZ*DRV1(3)         1571.000
      GO TO 723                                                         1572.000
  735 DRVA(M)=DRVA(M)+DRVAX*DRV2(1)+DRVAY*DRV2(2)+DRVAZ*DRV2(3)         1573.000
         IF (ICENT) 755,723,755                                         1574.000
  755 DRVB(M)=DRVB(M)+DRVBX*DRV2(1)+DRVBY*DRV2(2)+DRVBZ*DRV2(3)         1575.000
      GO TO 723                                                         1576.000
  736 DRVA(M)=DRVA(M)+DRVAX*DRV3(1)+DRVAY*DRV3(2)+DRVAZ*DRV3(3)         1577.000
         IF (ICENT) 756,723,756                                         1578.000
  756 DRVB(M)=DRVB(M)+DRVBX*DRV3(1)+DRVBY*DRV3(2)+DRVBZ*DRV3(3)         1579.000
      GO TO 723                                                         1580.000
C     OCCUPANCY DERIVATIVES                                             1581.000
 737  DRVA(M)=DRVA(M)+COST/SOF(II)                                      1582.000
         IF (ICENT) 757,723,757                                         1583.000
 757  DRVB(M)=DRVB(M)+SINT/SOF(II)                                      1584.000
      GO TO 723                                                         1585.000
C     BISO DERIVATIVES                                                  1586.000
  738 DRVA(M)=DRVA(M)-COST*SINN                                         1587.000
         IF (ICENT) 758,723,758                                         1588.000
  758 DRVB(M)=DRVB(M)-SINT*SINN                                         1589.000
      GO TO 723                                                         1590.000
C     BETA DERIVATIVES                                                  1591.000
  739 DRVA(M)=DRVA(M)-COST*FHHT(JJ)                                     1592.000
         IF (ICENT) 759,723,759                                         1593.000
  759 DRVB(M)=DRVB(M)-SINT*FHHT(JJ)                                     1594.000
      GO TO 723                                                         1595.000
  740 DRVA(M)=DRVA(M)-COST*FKKT(JJ)                                     1596.000
         IF (ICENT) 760,723,760                                         1597.000
  760 DRVB(M)=DRVB(M)-SINT*FKKT(JJ)                                     1598.000
      GO TO 723                                                         1599.000
  741 DRVA(M)=DRVA(M)-COST*FLLT(JJ)                                     1600.000
         IF (ICENT) 761,723,761                                         1601.000
  761 DRVB(M)=DRVB(M)-SINT*FLLT(JJ)                                     1602.000
      GO TO 723                                                         1603.000
  742 DRVA(M)=DRVA(M)-COST*FHKT(JJ)*2.                                  1604.000
         IF (ICENT) 762,723,762                                         1605.000
  762 DRVB(M)=DRVB(M)-SINT*FHKT(JJ)*2.                                  1606.000
      GO TO 723                                                         1607.000
  743 DRVA(M)=DRVA(M)-COST*FHLT(JJ)*2.                                  1608.000
         IF (ICENT) 763,723,763                                         1609.000
  763 DRVB(M)=DRVB(M)-SINT*FHLT(JJ)*2.                                  1610.000
      GO TO 723                                                         1611.000
  744 DRVA(M)=DRVA(M)-COST*FKLT(JJ)*2.                                  1612.000
         IF (ICENT) 764,723,764                                         1613.000
  764 DRVB(M)=DRVB(M)-SINT*FKLT(JJ)*2.                                  1614.000
 723     IF (NOT(NPV).EQ.1) GO TO 1014                                  1615.000
         IND=NOT(NPV)/100                                               1616.000
      DRVA(IND)=DRVA(IND)+EFACT(MOD(NOT(NPV),100),1)*DRVA(M)            1617.000
         IF (ICENT) 1012,1013,1012                                      1618.000
 1012 DRVB(IND)=DRVB(IND)+EFACT(MOD(NOT(NPV),100),1)*DRVB(M)            1619.000
 1013 M=MKEEP                                                           1620.000
      GO TO 1014                                                        1621.000
  126 CONTINUE                                                          1622.000
         IF (NITER) 399,399,465                                         1623.000
C     IF THIS IS THE LAST ATOM IN A R.B. WHOSE T.F. IS TO BE REFINED,   1624.000
C     CALCULATE R.B. ISOTROPIC T.F. DERIVATIVE.                         1625.000
 465     IF (L.LE.0) GO TO 397                                          1626.000
         IF (NARB(L).LT.NAR(L)) GO TO 397                               1627.000
      IF (NOT(L+NQ+2)) 398,398,463                                      1628.000
 463  NDP=MRB+L                                                         1629.000
      DRVA(NDP)=DRVA(NDP)-ACRB(L)*SINN                                  1630.000
         IF (ICENT) 3988,398,3988                                       1631.000
 3988 DRVB(NDP)=DRVB(NDP)-BCRB(L)*SINN                                  1632.000
 398     NPWRB(L)=NPWKEEP                                               1633.000
         MPRB(L)=MPKEEP                                                 1634.000
  397 NPW=NPV-1                                                         1635.000
      MP=M                                                              1636.000
  399 CONTINUE                                                          1637.000
      FCSQ=AC*AC+BC*BC                                                  1638.000
      IF (RSTAR.EQ.0.) GO TO 868                                        1639.000
      ECSQ=SQRT(1.+RSTAR2*FCSQ*DELT)                                    1640.000
      FCLC=SQRT(FCSQ/ECSQ)                                              1641.000
      GO TO 869                                                         1642.000
 868  FCLC=SQRT(FCSQ)                                                   1643.000
 869  COSA=AC/FCLC                                                      1644.000
      SINA=BC/FCLC                                                      1645.000
      DEL=FOBS-FCLC                                                     1646.000
      GO TO (134,400,401,1001,400),NUNTW                                1647.000
 1001 CALL FUDG (H,   SC,FOBS,FCLC,DEL,WTG)                             1648.000
      IF (WTG) 1002,1002,402                                            1649.000
 1002 SIG=1.E6                                                          1650.000
      GO TO 133                                                         1651.000
 402     SIG=1./WTG                                                     1652.000
         GO TO 133                                                      1653.000
 401  WTG=1.                                                            1654.000
         SIG=1.                                                         1655.000
      GO TO 133                                                         1656.000
  400 WTG=1.0/(1.0+((FOBS-FB)/FA)**2)                                   1657.000
         IF (NUNTW-5) 402,1001,1001                                     1658.000
 134     IF (FA.NE.0.) THEN                                             1659.000
C        DUNITZ-SEILER WEIGHTS                                          1660.000
         WTG=SQRT(EXP(FA*SINN))/SIG                                     1661.000
         ELSE                                                           1662.000
      WTG=1./SIG                                                        1663.000
      ENDIF                                                             1664.000
 133  WTDEL=WTG*DEL                                                     1665.000
      SIGFC=SIGFC+FCLC                                                  1666.000
      SMDVQ=SMDVQ+ABS(DEL)                                              1667.000
      SGWFS=SGWFS+(WTG*FOBS)**2                                         1668.000
      SGWDS=SGWDS+WTDEL*WTDEL                                           1669.000
      NTL=NTL+1                                                         1670.000
      IF (IPRNT.EQ.1) WRITE (3,5) H,       SC,FOBS,FCLC,COSA,SINA,DEL,  1671.000
     1 SIG,WTDEL,SINN                                                   1672.000
      IF (NITER) 464,888,464                                            1673.000
C        SCALE FACTOR DERIVATIVES                                       1674.000
 464     MNQ=0                                                          1675.000
         DO 26 II=1,NQ                                                  1676.000
         IF (NOT(II).EQ.0) GO TO 26                                     1677.000
         MNQ=MNQ+1                                                      1678.000
         IF (II.NE.SC) GO TO 26                                         1679.000
      DRVA(MNQ)=WTG*FCLC                                                1680.000
         GO TO 620                                                      1681.000
 26      CONTINUE                                                       1682.000
C        DERIVATIVES OF SIGN OF F''                                     1683.000
 620     IF (NOT(NQ+2).EQ.1) THEN                                       1684.000
         DRVB(MSP)=C/ETA                                                1685.000
         IF (ICENT.NE.0) DRVA(MSP)=-D/ETA                               1686.000
         ENDIF                                                          1687.000
      DO 528 II=MSP,NPAR                                                1688.000
 528  DRVA(II)=(COSA*DRVA(II)+SINA*DRVB(II))*WTG                        1689.000
      IF (RSTAR.LE.0..AND.NOT(NQ+1).EQ.0) GO TO 1721                    1690.000
      DENOM=(SQRT(ECSQ))**5                                             1691.000
      IF (NOT(NQ+1).EQ.0) GO TO 621                                     1692.000
C     DERIVATIVES W.R.T. LARSON EXTINCTION COEFFICIENT                  1693.000
      DRVA(MEC)=WTG*(-0.5*FCSQ*SQRT(FCSQ)*DELT/DENOM)                   1694.000
 621  DRVFF=(1.+RSTAR*FCSQ*DELT)/DENOM                                  1695.000
      DO 1722 II=MSP,NPAR                                               1696.000
 1722 DRVA(II)=DRVA(II)*DRVFF                                           1697.000
 1721 JK=1                                                              1698.000
      DO 1700 J=1,NPAR                                                  1699.000
      IF (NOMAT.EQ.1.AND.JITER.GT.1) GO TO 1700                         1700.000
      DO 1701 K=J,NPAR                                                  1701.000
      AM(JK)=AM(JK)+DRVA(K)*DRVA(J)                                     1702.000
 1701 JK=JK+1                                                           1703.000
 1700 V(J)=V(J)+DRVA(J)*WTDEL                                           1704.000
         GO TO 999                                                      1705.000
C     WRITE REFLECTION RECORD TO FILE 17                                1706.000
 888     SIG=2.*FOBS*SIG                                                1707.000
         FOBS=FOBS*FOBS                                                 1708.000
         IF (RSTAR.GT.0.) THEN                                          1709.000
         RTECSQ=SQRT(ECSQ)                                              1710.000
         AC=AC/RTECSQ                                                   1711.000
         BC=BC/RTECSQ                                                   1712.000
         ENDIF                                                          1713.000
      WRITE (17) IW1,IW2,FOBS,SIG,AC,BC,SINN                            1714.000
         GO TO 999                                                      1715.000
 9965 STNDM=SGWDS/FLOAT(NTL-NPAR)                                       1716.000
      RFAC=SMDVQ/SMFOB                                                  1717.000
      WTGR=SQRT(SGWDS/SGWFS)                                            1718.000
      WRITE(3,9000)RFAC,WTGR,NTL,SMFOB,SIGFC,SGWDS                      1719.000
      WRITE(3,9001)SMDVQ,STNDM                                          1720.000
         IF (JITER.GT.1.AND.RFAC.GT.(OLDR+0.1)) THEN                    1721.000
         NITER=0                                                        1722.000
         IC=0                                                           1723.000
         WRITE (3,630)                                                  1724.000
         ENDIF                                                          1725.000
         OLDR=RFAC                                                      1726.000
      RETURN                                                            1727.000
      END                                                               1728.000
      SUBROUTINE OUTR                                                   1729.000
C      OUTPUT OF RESULTS OF REFINEMENT --                               1730.000
         PARAMETER(NNP=850,MATRX=NNP*(NNP+1)/2,NNQ=NNP+1,NG=16)
         CHARACTER COMPID(72),LINE(148)                                 1731.000
         CHARACTER*8 ANAME(200),FTYPE(13),RBN(10),COXYS(10),CORBS(6)    1732.000
         CHARACTER*8 SSKNA,SSKNB,SSKNC                                  1733.000
         INTEGER CN(200),CONTNT(13)                                     1734.000
         REAL MM                                                        1735.000
         LOGICAL DONE                                                   1736.000
         COMMON/NMATRX/AM(MATRX)                                        1737.000
C * * * * * GOULD S.E.L. ONLY  * * * * *                                1738.000
C        EXTENDED BLOCK/NMATRX/AM(MATRX)                                1739.000
C * * * * END GOULD S.E.L. * * * *                                      1740.000
      COMMON NPAR,PD(NNP),V(NNP),DIAG(NNP),NELEM,XO(NG,6),              1741.000
     1NOT(2000),    NRB,      FA,FB,CONVP,VOL,NTL,                      1742.000
     2XC(200,3),NAR(NG),ALPH(3,3),DRHO1(NG,3,3),DRHO2(NG,3,3),          1743.000
     3DRHO3(NG,3,3),COMPD(10),AFACT(6),SMDVQ,SMFOB,SGWFS,SIGFC,SGWDS,   1744.000
     4NUNTW,NITER,RFAC,EITPSQ,EFACT(99,2),ISTAP,ISTAPR(NG),NRRRB(NG),   1745.000
     5NRR,WTGR,BISO(NG),ID(200),JITER,IC,ITER,STNDM,MM,IPRNT,CUTO,NOMAT 1746.000
         COMMON/GPNAME/RBN,LINE                                         1747.000
         COMMON/MODELC/COMPID,ANAME,FTYPE                               1748.000
         COMMON/MODEL/NSF,NEQV,NT,MMAT,      ITBL(200),XX(3,200),       1749.000
     1   CN,SOF(200),UU(6,200),EP(3,200),ESOF(200),EUIJ(6,200),         1750.000
     2   WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICEND,                 1751.000
     3   SFAC(14,13),CONTNT,G(4),ETA,NQ, RSTAR                          1752.000
      DATA CORBS/'X0','Y0','Z0','THETA1','THETA2','THETA3'/             1753.000
      DATA SSKNA,SSKNB/'SCALE','EXTINCTN'/,SSKNC/'ETA'/                 1754.000
      DATA  COXYS/'X','Y','Z','OCC','U/U11','U22','U33',                1755.000
     1'U12','U13','U23'/                                                1756.000
 25      FORMAT ('0SHIFT/SIGMA MAXIMUM =',F9.4,'     AVERAGE =',F9.4)   1757.000
 26      FORMAT ('0ALL SHIFTS ARE <'F4.1,' X SIGMA; REFINEMENT HAS CONVE1758.000
     1RGED AND WILL STOP AFTER THIS CYCLE')                             1759.000
   80 FORMAT(     '0GROUP U FACTOR SHIFTS (APPLIED, IN ANISOTROPIC FORM 1760.000
     1IF APPROPRIATE,'/' TO GROUP ATOMS)')                              1761.000
   81 FORMAT(     '0GROUP ORIGIN (FRACTIONAL COORDINATES) & ORIENTATION 1762.000
     1ANGLES (DEGREES)')                                                1763.000
   82 FORMAT('0ATOM PARAMETERS')                                        1764.000
   83 FORMAT(1X,A8,' TEMPERATURE FACTOR NON POSITIVE DEFINITE')         1765.000
 452  FORMAT ('0RSTAR NEGATIVE; REFINEMENT WILL STOP AFTER THIS CYCLE') 1766.000
 1102    FORMAT('0(1+ABS(ETA))/SIG(ETA) =',F7.1)                        1767.000
 1103 FORMAT ('0NEW FC SCALE FACTORS:',   6F9.4)                        1768.000
 1104 FORMAT(1H ,A8,2X,F12.5,3X,F12.7,2X,F12.5,2X,F12.6,4X,F8.4)        1769.000
 1105 FORMAT(1H0,A8,   I3)                                              1770.000
 1106 FORMAT (1H ,A4,21X,F12.7,16X,F12.6,4X,F8.4)                       1771.000
 1109 FORMAT(10H0PARAMETER,8X,3HOLD,10X,5HSHIFT,11X,3HNEW,10X,5HERROR,  1772.000
     14X,11HSHIFT/ERROR)                                                1773.000
      RADN=3.14159/180.                                                 1774.000
         SOEXMX=0.                                                      1775.000
         SOEXTO=0.                                                      1776.000
      DO 451 I=1,NPAR                                                   1777.000
      DIAG(I)=DIAG(I)*STNDM                                             1778.000
         SOEX=ABS(PD(I)/SQRT(DIAG(I)))                                  1779.000
         IF (SOEX.GT.SOEXMX) SOEXMX=SOEX                                1780.000
 451     SOEXTO=SOEXTO+SOEX                                             1781.000
         SOEXTO=SOEXTO/NPAR                                             1782.000
         IF (SOEXMX.LE.CONVP) NITER=JITER                               1783.000
      WRITE(3,1109)                                                     1784.000
         M=0                                                            1785.000
         DO 421 I=1,NQ                                                  1786.000
      IF (NOT(I).NE.1) GO TO 421                                        1787.000
         M=M+1                                                          1788.000
      PRS=PD(M)                                                         1789.000
      ERR=SQRT(DIAG(M))                                                 1790.000
      SOEX=ABS(PRS/ERR)                                                 1791.000
      SCALE=1.0                                                         1792.000
      RST=SCALE+PRS                                                     1793.000
      WRITE(3,1104) SSKNA,SCALE,PRS,RST,ERR,SOEX                        1794.000
      G(I)=G(I)*RST                                                     1795.000
 421     CONTINUE                                                       1796.000
      IF (NOT(NQ+1).EQ.0) GO TO 7                                       1797.000
      M=M+1                                                             1798.000
      PRS=PD(M)                                                         1799.000
      ERR=SQRT(DIAG(M))                                                 1800.000
      XXX=RSTAR+PRS                                                     1801.000
      SOEX=ABS(PRS/ERR)                                                 1802.000
      WRITE (3,1104) SSKNB,RSTAR,PRS,XXX,ERR,SOEX                       1803.000
      RSTAR=XXX                                                         1804.000
         IF (RSTAR.LT.0) THEN                                           1805.000
         NITER=JITER                                                    1806.000
         WRITE (3,452)                                                  1807.000
         ENDIF                                                          1808.000
 7       IF (NOT(NQ+2).EQ.0) GO TO 8                                    1809.000
         M=M+1                                                          1810.000
         PRS=PD(M)                                                      1811.000
         ERR=SQRT(DIAG(M))                                              1812.000
         XXX=ETA+PRS                                                    1813.000
         SOEX=ABS(PRS/ERR)                                              1814.000
         WRITE (3,1104) SSKNC,ETA,PRS,XXX,ERR,SOEX                      1815.000
         ETA=XXX                                                        1816.000
         SIGETA=ERR                                                     1817.000
 8    N=NQ+2                                                            1818.000
      IF(NRB) 5,5,3                                                     1819.000
 3       DONE=.FALSE.                                                   1820.000
      DO 500 I=1,NRB                                                    1821.000
      N=N+1                                                             1822.000
      IF(NOT(N)) 500,502,501                                            1823.000
  501 M=M+1                                                             1824.000
      PRS=PD(M)                                                         1825.000
      ERR=SQRT(DIAG(M))                                                 1826.000
      SOEX=ABS(PRS/ERR)                                                 1827.000
         IF ((.NOT.DONE).AND.JITER.EQ.NITER) WRITE (3,80)               1828.000
         DONE=.TRUE.                                                    1829.000
      IF (JITER.EQ.NITER) WRITE (3,1106) RBN(I),PRS/EITPSQ,ERR/EITPSQ,  1830.000
     1SOEX                                                              1831.000
      GO TO 503                                                         1832.000
  502 PRS=0.                                                            1833.000
 503  BISO(I)=PRS                                                       1834.000
  500 CONTINUE                                                          1835.000
      IF (JITER.EQ.NITER) WRITE(3,81)                                   1836.000
      DO 900 I=1,NRB                                                    1837.000
      IF (JITER.EQ.NITER) WRITE(3,1105) RBN(I)                          1838.000
      DO 901 K=1,6                                                      1839.000
      N=N+1                                                             1840.000
      IF(NOT(N)) 900,902,904                                            1841.000
  904 M=M+1                                                             1842.000
      PRS=PD(M)                                                         1843.000
      ERR=SQRT(DIAG(M))                                                 1844.000
      XXX=XO(I,K)+PRS                                                   1845.000
      SOEX=ABS(PRS/ERR)                                                 1846.000
      REFRP=XXX                                                         1847.000
      UNRP=XO(I,K)                                                      1848.000
  912 IF (K.LT.4) THEN                                                  1849.000
         DRHO1(I,K,1)=ERR                                               1850.000
         GO TO 903                                                      1851.000
      ELSE                                                              1852.000
         DRHO1(I,K-3,2)=ERR                                             1853.000
      UNRP=UNRP/RADN                                                    1854.000
      REFRP=REFRP/RADN                                                  1855.000
      ERR=ERR/RADN                                                      1856.000
      PRS=PRS/RADN                                                      1857.000
      GO TO 903                                                         1858.000
      ENDIF                                                             1859.000
  902 PRS=0.                                                            1860.000
      UNRP=XO(I,K)                                                      1861.000
      XXX=XO(I,K)                                                       1862.000
      ERR=0.                                                            1863.000
      SOEX=0.                                                           1864.000
      REFRP=XXX                                                         1865.000
      GO TO 912                                                         1866.000
  903 IF (JITER.EQ.NITER) WRITE(3,1104) CORBS(K),UNRP,PRS,REFRP,ERR,SOEX1867.000
      XO(I,K)=XXX                                                       1868.000
  901 CONTINUE                                                          1869.000
  900 CONTINUE                                                          1870.000
      IF (JITER.EQ.NITER) WRITE(3,82)                                   1871.000
    5 DO 930 I=1,NSF                                                    1872.000
         L=MOD(ID(I),100)                                               1873.000
         IF (L.GT.0) THEN                                               1874.000
         UU(1,I)=UU(1,I)+BISO(L)                                        1875.000
         ELSE IF (L.LT.-1) THEN                                         1876.000
         DO 936 J=1,6                                                   1877.000
 936     UU(J,I)=UU(J,I)+BISO(-L-1)*AFACT(J)/4.                         1878.000
         ENDIF                                                          1879.000
         DONE=.FALSE.                                                   1880.000
      DO 931 K=1,10                                                     1881.000
         IF (K.GT.5.AND.ID(I).GE.0) GO TO 930                           1882.000
      N=N+1                                                             1883.000
      IF (NOT(N)-1) 931,803,932                                         1884.000
 803  M=M+1                                                             1885.000
      IF ((.NOT.DONE).AND.JITER.EQ.NITER) WRITE(3,1105)  ANAME(I),      1886.000
     1ITBL(I)                                                           1887.000
         DONE=.TRUE.                                                    1888.000
 932     GO TO (700,700,700,701,702,702,702,702,702,702),K              1889.000
  700 OLD=   XX(K,I)                                                    1890.000
       GO TO 431                                                        1891.000
 701     OLD=SOF(I)                                                     1892.000
         GO TO 431                                                      1893.000
 702     OLD=UU(K-4,I)                                                  1894.000
 431     IF (NOT(N).GT.1) GO TO 933                                     1895.000
         ERR=SQRT(DIAG(M))                                              1896.000
         SOEX=ABS(PD(M)/ERR)                                            1897.000
         XXX=OLD+PD(M)                                                  1898.000
      IF (JITER.EQ.NITER) THEN                                          1899.000
         IF (K.LT.5) THEN                                               1900.000
         PRS=1.                                                         1901.000
         ELSE IF (ID(I).LT.0.AND.K.LT.8) THEN                           1902.000
         PRS=4./(EITPSQ*AFACT(K-4))                                     1903.000
         ELSE IF (K.EQ.8) THEN                                          1904.000
         PRS=4./(EITPSQ*SQRT(AFACT(1)*AFACT(2)))                        1905.000
         ELSE IF (K.EQ.9) THEN                                          1906.000
         PRS=4./(EITPSQ*SQRT(AFACT(1)*AFACT(3)))                        1907.000
         ELSE IF (K.EQ.10) THEN                                         1908.000
         PRS=4./(EITPSQ*SQRT(AFACT(2)*AFACT(3)))                        1909.000
         ELSE                                                           1910.000
         PRS=1./EITPSQ                                                  1911.000
         ENDIF                                                          1912.000
         WRITE (3,1104) COXYS(K),OLD*PRS,PD(M)*PRS,XXX*PRS,ERR*PRS,     1913.000
     1   SOEX                                                           1914.000
         ENDIF                                                          1915.000
         GO TO 934                                                      1916.000
 933     ERR=0.                                                         1917.000
         XXX=OLD+PD(NOT(N)/100)*EFACT(MOD(NOT(N),100),1)                1918.000
 934     GO TO (706,706,706,707,708,708,708,708,708,708),K              1919.000
 706  XX(K,I)=XXX                                                       1920.000
      EP(K,I) =ERR                                                      1921.000
         DO 600 J=1,NSF                                                 1922.000
         IF (IABS(ID(J)/100).EQ.I) XX(K,J)=XX(K,J)+XXX-OLD              1923.000
 600     CONTINUE                                                       1924.000
         GO TO 931                                                      1925.000
 707     SOF(I)=XXX                                                     1926.000
         ESOF(I)=ERR                                                    1927.000
         GO TO 931                                                      1928.000
 708     UU(K-4,I)=XXX                                                  1929.000
         EUIJ(K-4,I)=ERR                                                1930.000
  931 CONTINUE                                                          1931.000
      DO 2 J=1,3                                                        1932.000
      IF(UU(J,I)) 190,2,2                                               1933.000
    2 CONTINUE                                                          1934.000
      X8=UU(4,I)                                                        1935.000
      X9=UU(5,I)                                                        1936.000
      X10=UU(6,I )                                                      1937.000
      IF(UU(1,I)*UU(2,I)-X8**2)  190,120,120                            1938.000
  120 IF(UU(1,I)*UU(3,I)-X9**2)  190,130,130                            1939.000
  130 IF(UU(2,I)*UU(3,I)-X10**2)  190,140,140                           1940.000
  140 IF(UU(1,I)*UU(2,I)*UU(3,I)+2.*(X8*X9*X10)-UU(1,I)*X10**2-UU(2,I)* 1941.000
     1X9**2-UU(3,I)*X8**2) 190,930,930                                  1942.000
  190 WRITE(3,83) ANAME(I)                                              1943.000
  930 CONTINUE                                                          1944.000
      WRITE (3,1103) (G(I),I=1,NQ)                                      1945.000
         IF (NOT(NQ+2).EQ.1) THEN                                       1946.000
         XXX=(1.+ABS(ETA))/SIGETA                                       1947.000
         WRITE (3,1102) XXX                                             1948.000
         ENDIF                                                          1949.000
         WRITE (3,25) SOEXMX,SOEXTO                                     1950.000
         IF (SOEXMX.LE.CONVP) WRITE (3,26) CONVP                        1951.000
         REWIND 4                                                       1952.000
         WRITE (4,100) COMPD,RFAC,WTGR,NTL,JITER                        1953.000
 100     FORMAT ('REMARK        ',10A4/'REMARK  R =',F7.4,' AT START OF 1954.000
     1THIS CYCLE, I.E. FOR PREVIOUS PARAMETERS.'/'REMARK  WEIGHTED R =',1955.000
     2F7.4,'  NUMBER OF REFLECTIONS =',I6/'REMARK  THIS IS CYCLE',I3,' O1956.000
     3F CURRENT BLOCK')                                                 1957.000
         CALL BCONV(UU,EUIJ,ID,EITPSQ,AFACT,NSF)                        1958.000
         IF (NRB.NE.0) RETURN                                           1959.000
         CALL MDLOUT(4)                                                 1960.000
      RETURN                                                            1961.000
      END                                                               1962.000
      SUBROUTINE TRANM(B,L,V)                                           1963.000
C     FORM MATRIX V=LBL(TRANSPOSED).                                    1964.000
      REAL L(3,3),LT(3,3)                                               1965.000
      DIMENSION B(3,3),V(3,3),W(3,3)                                    1966.000
      CALL MMULT(B,L,W)                                                 1967.000
      DO 1 I=1,3                                                        1968.000
      DO 1 J=1,3                                                        1969.000
 1    LT(I,J)=L(J,I)                                                    1970.000
      CALL MMULT(LT,W,V)                                                1971.000
      RETURN                                                            1972.000
      END                                                               1973.000
      SUBROUTINE MMULT(B,A,W)                                           1974.000
C     FORM MATRIX W=AB                                                  1975.000
      DIMENSION A(3,3),B(3,3),W(3,3)                                    1976.000
      DO 1 I=1,3                                                        1977.000
      DO 1 J=1,3                                                        1978.000
      W(I,J)=0.                                                         1979.000
      DO 1 K=1,3                                                        1980.000
 1    W(I,J)=W(I,J)+A(I,K)*B(K,J)                                       1981.000
      RETURN                                                            1982.000
      END                                                               1983.000
