      SUBROUTINE EXPUT                                                          
      include 'param.inc'
      REAL LAMDA                                                                
      INTEGER PTR                                                               
      COMMON/F1/RJAC(MSZ,MSZ),VX(MSZ)
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,SB,WDT,            
     *UU,VV,WW,POLPAR
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,          
     *LST3,IPL1,IPL2,MCYCLE,EPS,MAXS,IFOUR,NFMT
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(NUPH,20),
     *APAR(NUPH,20),LPAR(NUPH,20),XL(NATS,11),LP(NATS,11),A(NATS,11),                            
     *PTR(NATS),RELAX(4),RATIO(2)       
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)                                        
      COMMON/PARAC/ATEXT,NTYP                                                   
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),                            
     *NATOM(NUPH),PREF(NUPH,3),NBCKGD,NEXCRG,NSCAT,IWT                  
      CHARACTER SYMB(NUPH,20)*1,ISPACE*1,IDOT*1,ISTAR*1,IPLUS*1,IMINUS*1           
     *,IBAR*1                                                                   
      CHARACTER TITLE*80,PHSNM(NUPH)*80                                            
      CHARACTER*1 IOUT(150)                                                     
      COMMON/CHAR/SYMB,TITLE,PHSNM                                              
      COMMON/COEFF/AC(10,16),POSI(30),SCAT(30),DFP(16),DFPP(16)                 
      CHARACTER*4 NAM(16)                                                       
      COMMON/COEFC/NAM                                                          
      COMMON/DATAX/Y(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS,WT(IDSZ)                      
      COMMON/REFLS/IREFS(IRS),REFS(IRS,8),FF(IRS),IC(NUPH)
      COMMON/RBRAGG/COBS(IRS),SOMEGA(IRS),VAR(IRS)
      COMMON/FOUR/PHASE(IRS)
      DIMENSION DEL(10),KI(10),IRE(IRS)                                                  
      DIMENSION LABEL(12),KS(50)                                                
      DATA ISPACE,IDOT,ISTAR,IPLUS,IMINUS,IBAR/' ','.','*','+','0','-'/         
      ZER=GLB(1)                                                                
      IF(IPL.NE.0)READ(15,19,END=10000)ISCALE,IDIF
   19 FORMAT(BZ,2I8)                                                            
10000 IF(IPL2.NE.0)READ(15,17,END=10001)IFY,IFYC,IFM,IFD,EXPAND
10001 IF(JOBTYP.GT.2)IFY=0                                                      
C     IFD SET TO 9 TO BYPASS PLOT OF DIFFERENCE PROFILE IN CALPLT
      IF(JOBTYP.GT.2)IFD=9                                                      
   17 FORMAT(BZ,4I1,4X,F8.0)                                                    
C     CODE FOR REFLECTIONS BEYOND OBS PATTERN
      THMAX=ALOW(NEXCRG) - STEP
      NPTS=(THMAX-THMIN)/STEP + 1.5
      NEXCRG=NEXCRG-1
      IF(NXT.NE.0.AND.JOBTYP.LT.3)CALL REWRIT(ISCALE,IDIF,IFY,IFYC              
     *,IFM,IFD,EXPAND)                                                          
      NEXCRG=NEXCRG+1
C     END CODE
      IF(JOBTYP.GT.2)GOTO 37                                                    
      WRITE(16,10)
   10 FORMAT(42H AVERAGE INTENSITY DIFFERENCE FOR PATTERN,,/,
     1 37H GIVEN FOR BLOCKS OF 20 OBSERVATIONS.)
      DO 15 I=1,NPTS,200                                                        
      DO 14 J=1,10                                                              
      J20=20*(J-1)                                                              
      DEL(J)=0                                                                  
      DO 13 K=1,20                                                              
      J20IK=J20+I+K-1                                                           
   13 DEL(J)=DEL(J)+Y(J20IK)-BK(J20IK)-YC(J20IK)                                
      KI(J)=J+I/20                                                              
      DEL(J)=DEL(J)/20.                                                         
      IF(DEL(J).GT.999.9) DEL(J)=999.9
      IF(DEL(J).LT.-99.9) DEL(J)=-99.9
      IF(KI(J)*20.GE.NPTS)GOTO 15                                               
   14 CONTINUE                                                                  
      J=10                                                                      
   15 WRITE(16,20)(KI(JJ),DEL(JJ),JJ=1,J)
   20 FORMAT(1H ,6X,10(I4,2X,F5.1))
      IF(MAT.EQ.0)GOTO 37                                                       
      WRITE(16,7)
      IA=1                                                                      
      LIM=19                                                                    
   38 LIM=MIN0(MAXS,LIM)                                                        
      WRITE(16,8)(I,I=IA,LIM)
      DO 39 I=1,MAXS                                                            
      L=0                                                                       
      X=RJAC(I,I)                                                               
      DO 40 J=IA,LIM                                                            
      L=L+1                                                                     
      YY=RJAC(J,J)*X                                                            
   40 KS(L)=100.*RJAC(I,J)/(SQRT(ABS(YY))*SIGN(1.,YY))+0.5                      
   39 WRITE(16,12)I,(KS(J),J=1,L)
      IF(LIM.GE.MAXS)GOTO 37                                                    
      IA=LIM+1                                                                  
      LIM=LIM+19                                                                
      GOTO 38                                                                   
    7 FORMAT(20H CORRELATION MATRIX=)
    8 FORMAT(5H     ,19I6)
   12 FORMAT(I5,19I6)                                                           
   37 DO 47 I=1,NPTS                                                            
      YC(I)=YC(I)+BK(I)                                                         
   47 IF(JOBTYP.GT.2)Y(I)=YC(I)                                                 
      IF(IPC.EQ.0)GOTO 36                                                       
      DO 400 K=1,NPHASE                                                         
      T2OBS=0.                                                                  
      TDOBS=0.                                                                  
      ICZ=0
      DO 300 II=1,NPHASE
  300 ICZ=ICZ+IC(II)
      IXX=0                                                                     
      DO 481 IX=1,ICZ                                                           
      IF(K.NE.IREFS(IX)/256/256/256/4)GOTO 481                                
      DO 485 J=1,NEXCRG                                                         
      IF((REFS(IX,2)+ZER).GT.ALOW(J).AND.(REFS(IX,2)+ZER).LT.AHIGH(J))
     #   GO TO 481              
  485 CONTINUE                                                                  
      IXX=IXX+1
      IRL=MOD(IREFS(IX),256)-128                                                
      IRK=MOD(IREFS(IX)/256,256)-128                                            
      IRH=MOD(IREFS(IX)/256/256,256)-128                                        
      IRC=MOD(IREFS(IX)/256/256/256,4)                                        
C        NEW BRAGG CODE
      FF(IX)=FF(IX)*REFS(IX,3)*PAR(K,1)/STEP
CRJH      CESD=SQRT(VAR(IX))*REFS(IX,3)*PAR(K,1)/(STEP*SOMEGA(IX))
      CESD=SQRT(VAR(IX)+COBS(IX))*REFS(IX,3)*PAR(K,1)/(STEP*SOMEGA(IX))   
      COBS(IX)=COBS(IX)*REFS(IX,3)*PAR(K,1)/(STEP*SOMEGA(IX))
      DIF=COBS(IX)-FF(IX)
      T2OBS=T2OBS+COBS(IX)
      TDOBS=TDOBS+ABS(COBS(IX)-FF(IX))
      HW=REFS(IX,1)
      GO TO (91,91,93,91,93), NPROF
   93 IF (MOD(IXX-1,50).EQ.0) WRITE(16,482) K,PHSNM(K)
  482 FORMAT(7H PHASE ,I2,2H: ,A80,//,
     *1X,32HNO.  CODE     H   K   L   HW    ,
     *17H  POSN      ICALC ,4X,5HCOBS ,6X,4HDIFF,7X,3HESD/)                                          
      TT=TAN(REFS(IX,2)/(2.0*57.2957795))
      HW=VHALF(K,TT,IRH,IRK,IRL)
      WRITE(16,470)IXX,IRC,IRH,IRK,IRL,HW,REFS(IX,2),FF(IX)
     *,COBS(IX),DIF,CESD
  470 FORMAT(1X,2I4,3X,3I4,2F8.3,2F10.0,2F10.1)                                        
      GO TO 29
   91 IF(MOD(IXX-1,50).EQ.0) WRITE(16,479) K,PHSNM(K)
  479 FORMAT(7H PHASE ,I2,2H: ,A80,//,
     *1X,38HNO.  CODE    H   K   L   HW     SHAPE ,
     *19H   POSN      ICALC ,4X,5HCOBS ,6X,4HDIFF,7X,3HESD,/)
      WRITE(16,471)IXX,IRC,IRH,IRK,IRL,HW,REFS(IX,4),REFS(IX,2),FF(IX)
     *,COBS(IX),DIF,CESD
  471 FORMAT(1X,2I4,3X,3I4,3F8.3,2F10.0,2F10.1)
   29 CONTINUE                               
C       CODE FOR FOURIER TAPE
      IF(IRC.EQ.2.OR.K.GE.2.OR.IFOUR.EQ.0) GO TO 481
      COSA=COS(PHASE(IX))
      SINA=SIN(PHASE(IX))
      SINTL=SIN(REFS(IX,2)/114.591559)/LAMDA(IRC)
      FCALC=SQRT(FF(IX)/REFS(IX,3))
      IF(COBS(IX).LT.0.0) COBS(IX)=0.0
      FOBS=SQRT(COBS(IX)/REFS(IX,3))
      FDIF=FOBS-FCALC
      NN=0
      FESD=SQRT(CESD/REFS(IX,3))
C     INSERT BY LI DEYU FOR FOURIER USING SHELX OCT.1989
      WRITE(20,888)IRH,IRK,IRL,FOBS,FESD,NN,FDIF
  888 FORMAT (3I4,2F8.2,I4,10X,F8.3)
C     END OF INSERT
C     WRITE(20)IRH,IRK,IRL,SINTL,FOBS,FCALC,COSA,SINA,FDIF,NN,FESD
C       END CODE FOR FOURIER TAPE
  481 CONTINUE                                                                  
      IF(JOBTYP.GT.2) T2OBS=TDOBS
      TDOBS=100.*TDOBS/T2OBS                                                    
      WRITE(16,483)TDOBS
  483 FORMAT(26H DERIVED BRAGG R-FACTOR=  ,F8.2)
      WRITE(7,484)TDOBS
  484 FORMAT(18H BRAGG R-FACTOR = ,F8.2)
 400  CONTINUE                                                                  
c      OPEN(UNIT=9,STATUS='NEW',CARRIAGE CONTROL='LIST')
      WRITE(9,961)THMIN,STEP,THMAX
 961  FORMAT(3F8.3)
      WRITE(9,1962)(NINT(YC(II)),II=1,NPTS)
 1962 FORMAT(10I8)
      CLOSE(UNIT=9)
C     END OF INSERT
  36  IF(IOT.EQ.0)GOTO 30                                                       
      NP=NPTS/250                                                               
      DO 31 I=1,NPTS                                                            
   31 BK(I)=THMIN+FLOAT(I-1)*STEP                                               
      WRITE(16,101)(((BK(250*N-300+50*I+J),Y(250*N-300+50*I+J),YC(
     !250*N-300+50*I+J),I=1,5),J=1,50),N=1,NP)                                  
 101  FORMAT((2H  ,5(6H2THETA,3X,4HYOBS,4X,5HYCALC,4X),/,50(5(1X,F8.4,
     !2F8.0,1X),/)))                                                            
      NPTS2=NPTS-NP*250                                                         
      IF(NPTS2.EQ.0)GOTO 30                                                     
      NCOL=NPTS2/50                                                             
      WRITE(16,103)
 103  FORMAT(2H  ,5(6H2THETA,3X,4HYOBS,4X,5HYCALC,4X))
      NLINES=NPTS2-NCOL*50                                                      
      IF(NLINES.EQ.0)GOTO 33                                                    
      NCOL1=NCOL+1                                                              
      NP=250*NP-50                                                              
      DO 34 J=1,NLINES                                                          
 34   WRITE(16,102)(BK(NP+50*I+J),Y(NP+50*I+J),YC(NP+50*I+J),I=1,NCOL1)
 102  FORMAT(5(1X,F8.4,2F8.0,1X))                                               
      NP=NP+NLINES                                                              
      NLINES=50-NLINES                                                          
   33 DO 35 J=1,NLINES                                                          
 35   WRITE(16,102)(BK(NP+50*I+J),Y(NP+50*I+J),YC(NP+50*I+J),I=1,NCOL)
 30   IF(IPL.EQ.0)GOTO 45                                                       
      DO210I=1,12                                                               
  210 LABEL(I)=10*I*ISCALE                                                      
      WRITE(16,100) TITLE,LABEL
  100 FORMAT(1H ,30X,A80//1X,12I10)
      DO11I=1,12                                                                
   11 LABEL(I)=-60*IDIF+10*I*IDIF                                               
      WRITE(16,203) LABEL
  203 FORMAT(1H ,12I10)                                                         
      DO 60 I=1,NPTS                                                            
    1 DO 3 J=1,120                                                              
    3 IOUT(J)=ISPACE                                                            
      IOUT(1)=IDOT                                                              
      IOUT(61)=IDOT                                                             
      IOUT(120)=IDOT                                                            
  200 IY=INT(Y(I))/ISCALE+2                                                     
      IY=MAX0(MIN0(IY,120),2)                                                   
      IOUT(IY-1)=IBAR                                                           
      IOUT(IY)=IPLUS                                                            
      IF(IY.LE.119)IOUT(IY+1)=IBAR                                              
      IY=INT(YC(I))/ISCALE+2                                                    
      IY=MAX0(MIN0(IY,120),2)                                                   
      IOUT(IY)=IMINUS                                                           
      IY=INT(Y(I)-YC(I))/IDIF+61                                                
      IY=MAX0(MIN0(IY,120),2)                                                   
      IOUT(IY)=ISTAR                                                            
      IF(MOD(I-1,10).NE.0) GOTO 55                                              
      TLABEL=THMIN+STEP*FLOAT(I-1)                                             
      WRITE(16,104)(IOUT(J),J=1,113),TLABEL,IOUT(120)
  104 FORMAT(1X,113A1,F6.2,A1)                                                  
       GO TO 60                                                                 
   55   WRITE(16,201) (IOUT(J),J=1,120)
  201 FORMAT(1X,120A1)                                                          
   60 CONTINUE                                                                  
   45 IF(JOBTYP.LT.3)GOTO 72                                                    
      REWIND 4                                                                  
      WRITE(4,70)THMIN,STEP,THMAX                                               
   70 FORMAT(3F8.4)                                                             
      WRITE(4,71)(YC(I),I=1,NPTS)                                               
   71 FORMAT(10F8.0)                                                        
CRJH   72 IF(IPL2.NE.0)CALL CALPLT(IFY,IFYC,IFM,IFD,EXPAND,ZER)                     
CRJH   NEW CODE FOR OFF-LINE PLOTTING
   72 IF (IPL2.NE.0) THEN
      NREF=0
      DO 503 IL=1,NPHASE
  503 NREF = NREF + IC(IL)    
      DO 504 IH=1,NREF
  504 IRE(IH) = IREFS(IH)/256/256/256/4 
      WRITE (1,500) TITLE,THMIN,STEP,THMAX,ZER,NPHASE,NREF,NPTS,
     +              IFY,IFYC,IFM,IFD,EXPAND
  500 FORMAT (A80,/,3F8.3,2X,F8.3,I4,I6,I8,2X,4I1,F6.3)
      WRITE (1,501) (IRE(IH),REFS(IH,2),IH=1,NREF)
  501 FORMAT (8(I3,F7.3))
      DO 505 IKR=1,NPTS
      WT(IKR)=WT(IKR)*(Y(IKR)-YC(IKR))*(Y(IKR)-YC(IKR))
      IF (KR(IKR).EQ.IRS) GO TO 506
      KR(IKR)=0
      GO TO 505
  506 KR(IKR)=1
  505 CONTINUE
      WRITE (1,502) (Y(IK),YC(IK),WT(IK),KR(IK),IK=1,NPTS)
  502 FORMAT (3(F8.0,F8.0,F8.1,I2))
      ENDIF
CRJH   END OF NEW PLOT CODE
      RETURN                                                                    
      END
