      SUBROUTINE RCALC(SCFF,ITYPE)
C  
C ROUTINE TO CALCULATE CONTRIBUTIONS TO R 
C  
      INCLUDE 'RFINE.PRM'
      INCLUDE 'A.INC'
      INCLUDE 'D.INC'
      INCLUDE 'E.INC'
      INCLUDE 'F.INC'
      DIMENSION FRMT(12),NMBR(25,3,2),RNUM(4),RDENN(4),NUMBER(4)
     1,RZONE(25,3,2),WTRZ(25,3,2),RDEN(25,3,2),WTDEN(25,3,2),R(4)
     2,RRDEN(10,2,2),WTRDEN(10,2,2),RR(10,2,2),WTRR(10,2,2)
     3,NRR(10,2,2),JOUT(2,3),FOUT(2,3),IRNG(2),OPEN(2)
C
      EQUIVALENCE (FRMT(1),OPEN),(FRMT(12),ENDF)
C
      DATA OPEN,ENDF,SKIP,BLNK,V1,V2,V3
     1/'(10X',',','1X)','32X,',' ','2I8,','2F8.','3,'/
C
   10 FORMAT(1H1,18A4,5X,40HRESULTS OF STRUCTURE FACTOR CALCULATIONS
     1/16H0ALL REFLECTIONS,14X,9HNUMERATOR,4X,11HDENOMINATOR,4X,
     2 6HNUMBER,10X,1HR/1H )
   12 FORMAT(10X,10HWEIGHTED R,4X,2F15.2,I10,F11.3//10X,12HUNWEIGHTED R,
     1 2X,2F15.2,I10,F11.3//15X,'RANGE OF F',6X,'NUMBER',5X,'R'
     2,4X,'WTD. R',7X,'RANGE OF RHO',5X,'NUMBER',5X,'R'
     3,4X,'WTD. R'/)
   14 FORMAT(6X,F12.3,2H -,F8.3,I7,F10.3,F8.3,F12.5,2H -,F8.5
     1,I6,2F9.3)
   16 FORMAT(1H1,18A4,5X,40HRESULTS OF STRUCTURE FACTOR CALCULATIONS
     1/23H0UNREJECTED REFLECTIONS,7X,9HNUMERATOR,4X,11HDENOMINATOR,4X,
     2 6HNUMBER,10X,1HR/1H )
   18 FORMAT(//10X,'R FACTORS BY LEVEL'/17X,'H',4X,'NUMBER'
     1,4X,'R',3X,'WTD. R',7X,'K',4X,'NUMBER',4X,'R',3X,'WTD. R'
     2,7X,'L',4X,'NUMBER',4X,'R',3X,'WTD. R'/)
C
      IF(ITYPE.NE.0)GO TO 330
C
C CYCLE INITIATION - CLEAR ARRAYS
C
      DO 310 K=1,2
      DO 300 I=1,3
      DO 300 J=1,25
      NMBR(J,I,K)=0
      RZONE(J,I,K)=0.0
      WTRZ(J,I,K)=0.0
      RDEN(J,I,K)=0.0
  300 WTDEN(J,I,K)=0.0
      DO 310 I=1,2
      DO 310 J=1,10
      NRR(J,I,K)=0
      RR(J,I,K)=0.0
      WTRR(J,I,K)=0.0
      RRDEN(J,I,K)=0.0
  310 WTRDEN(J,I,K)=0.0
      DO 320 I=1,4
      RNUM(I)=0.0
      RDENN(I)=0.0
      NUMBER(I)=0
  320 CONTINUE
      RETURN
C
  330 IF(ITYPE.NE.1)GO TO 440
C
C ADD REFLECTION TO LISTS
C
C CALCULATE RANGE OF FOBS AND RHO 
      IRNG(1)=(SCFF*FOBS-FOMIN)/(FOMAX-FOMIN+0.00001)*10.0+1.0
      IF(IRNG(1).LT.1)IRNG(1)=1
      IF(IRNG(1).GT.10)IRNG(1)=10
      IRNG(2)=(RHO-RHOMN)/(RHOMX-RHOMN+0.00001)*10.0+1.0
      IF(IRNG(2).LT.1)IRNG(2)=1
      IF(IRNG(2).GT.10)IRNG(2)=10
C CALCULATE NUMERATOR AND DENOMINATOR FOR WEIGHTED R
      WT=SCFF**2/WT**2
      BIW=1.
      IF(MREF.EQ.0)  THEN
C REFINE ON F
         DELTA=FOBS-FCALC
         FDEN=WT*FOBS**2
      ELSE
C REFINEMENT ON F**2
         WT=0.25*WT/FOBS**2
         DELTA=FOBS**2-FCALC**2
         FDEN=FOBS**4*WT 
      END IF
      FNUM=WT*DELTA**2
      DELF=ABS(FOBS-FCALC)
      IF(NREJ.NE.0)GO TO 390
         NFLOSS=NFLOSS+1
         IF(IREJ.NE.2.AND.IREJ.NE.3)GO TO 370
            X=WT*(DELTA/DELMAX)**2
            IF(ABS(X).GT.1.)GO TO 360
               BIW=(1.-X)**2
               FLOSS=FLOSS+.5*FNUM*(1.-X*(1.-X/3.))
               EM=EM+1.-X*(6.-5.*X)
               GO TO 380
  360          BIW=0.
               FLOSS=FLOSS+DELMAX**2/6.
               NREJ=1
            GO TO 380
  370       FLOSS=FLOSS+FNUM
            EM=EM+1.
  380    SSUM=SSUM+BIW**2*FNUM
  390 CONTINUE
      FNUM=FNUM*BIW
      FDEN=FDEN*BIW
      RDENN(1)=RDENN(1)+FDEN
      RDENN(2)=RDENN(2)+FOBS
      RNUM(1)=RNUM(1)+FNUM
      RNUM(2)=RNUM(2)+DELF
      NUMBER(1)=NUMBER(1)+1
      IF(NREJ.NE.0)GO TO 400
C UNREJECTED REFLECTIONS
      RDENN(3)=RDENN(3)+FDEN
      RDENN(4)=RDENN(4)+FOBS
      RNUM(3)=RNUM(3)+FNUM
      RNUM(4)=RNUM(4)+DELF
      NUMBER(3)=NUMBER(3)+1
  400 K=1
  410 DO 420 I=1,2
      J=IRNG(I)
      NRR(J,I,K)=NRR(J,I,K)+1
      RR(J,I,K)=RR(J,I,K)+ABS(DELF)
      RRDEN(J,I,K)=RRDEN(J,I,K)+FOBS
      WTRR(J,I,K)=WTRR(J,I,K)+WT*DELF**2
  420 WTRDEN(J,I,K)=WTRDEN(J,I,K)+WT*FOBS**2
      DO 430 I=1,3
      IF(IABS(IH(I)).GT.12)GO TO 430
      J=IH(I)+13
      NMBR(J,I,K)=NMBR(J,I,K)+1
      RZONE(J,I,K)=RZONE(J,I,K)+ABS(DELF)
      WTRZ(J,I,K)=WTRZ(J,I,K)+WT*DELF**2
      RDEN(J,I,K)=RDEN(J,I,K)+FOBS
      WTDEN(J,I,K)=WTDEN(J,I,K)+WT*FOBS**2
  430 CONTINUE
      K=K+1
      IF(K.EQ.2.AND.NREJ.EQ.0) GO TO 410
      RETURN
C  END OF REFLECTIONS, START PRINT
  440 WRITE(IOUT,10)TITLE
C  CALCULATE R-FACTORS
      IF(NUMBER(1).EQ.0)RETURN
      NUMBER(2)=NUMBER(1)
      NUMBER(4)=NUMBER(3)
      DO 450 I=1,4
      IF(NUMBER(I).NE.0)THEN
        R(I)=SQRT(RNUM(I)/RDENN(I))
      ELSE
        R(I)=0.0
      END IF
      IF(MOD(I,2).EQ.0)R(I)=R(I)**2
  450 CONTINUE
      RFAC=R(3)
      IF(RDENN(3).NE.0.0)RMINUS=SQRT(RMINUS/RDENN(3))
      DO 470 I=1,2
      DO 460 J=1,2
      DO 460 K=1,10
      IF(NRR(K,J,I).EQ.0) GO TO 460
      RR(K,J,I)=RR(K,J,I)/RRDEN(K,J,I)
      WTRR(K,J,I)=SQRT(WTRR(K,J,I)/WTRDEN(K,J,I))
  460 CONTINUE
      DO 470 J=1,3
      DO 470 K=1,25
      IF(NMBR(K,J,I).EQ.0)GO TO 470
      RZONE(K,J,I)=RZONE(K,J,I)/RDEN(K,J,I)
      WTRZ(K,J,I)=SQRT(WTRZ(K,J,I)/WTDEN(K,J,I))
  470 CONTINUE
      DFO=(FOMAX-FOMIN)*0.1
      DRHO=(RHOMX-RHOMN)*0.1
C  PRINT FACTORS BY RANGES
      DO 540 I=1,2
      IF(I.EQ.2) WRITE(IOUT,16)TITLE
      WRITE(IOUT,12)(RNUM(J),RDENN(J),NUMBER(J),R(J),J=2*I-1,2*I)
      FMIN=FOMIN/SCFF
      RHMN=RHOMN
      EFO=DFO/SCFF
      DO 480 J=1,10
      FUP=FMIN+EFO
      RUP=RHMN+DRHO
      WRITE(IOUT,14)FMIN,FUP,NRR(J,1,I),RR(J,1,I),WTRR(J,1,I),RHMN
     A,RUP,NRR(J,2,I),RR(J,2,I),WTRR(J,2,I)
      FMIN=FUP
  480 RHMN=RUP
C  SET TO PRINT BY ZONES
      WRITE(IOUT,18)
      DO 500 K=1,3
      DO 490 J=1,25
      IF(NMBR(J,K,I).NE.0)GO TO 500
  490 CONTINUE
  500 IH(K)=J-1
C  BUILD OUTPUT FORMAT
      DO 530 J=1,25
      IFR=1
      NFND=0
      DO 520 K=1,3
      IH(K)=IH(K)+1
      L=IH(K)
      IF(NMBR(L,K,I).NE.0.AND.IH(K).LE.25)GO TO 510
C  FILL IN BLANKS
      FRMT(IFR+2)=SKIP
      FRMT(IFR+3)=BLNK
      FRMT(IFR+4)=BLNK
      GO TO 520
C  FILL IN VALUE
  510 FRMT(IFR+2)=V1
      FRMT(IFR+3)=V2
      FRMT(IFR+4)=V3
      NFND=NFND+1
      JOUT(1,NFND)=L-13
      JOUT(2,NFND)=NMBR(L,K,I)
      FOUT(1,NFND)=RZONE(L,K,I)
      FOUT(2,NFND)=WTRZ(L,K,I)
  520 IFR=IFR+3
C  CHECK IF THROUGH
      IF(NFND.EQ.0)GO TO 540
  530 WRITE(IOUT,FRMT) ((JOUT(K,L),K=1,2),(FOUT(K,L),K=1,2),L=1,NFND)
  540 CONTINUE
      RETURN
      END 
