      SUBROUTINE WRW5000(DATM,TIMM)
C
C  PROGRAMMER:  R.S. ZHOU
C		ALFRED UNIVERSITY   FEB-1987
C  MODIFIED: JDW 4-JUL-89 TO READ A PSD FILE.
C
C  MODIFIED: S.I. ZDZIESZYNSKI TO WRITE D5000 RAW DATA FILE
C                                              
C            OCT-18-1991
C
C
C	THIS ROUTINE WRITES OUT A DIFFRAC-5000 RAW DATA FILE
C	FROM CORRESPONDING COMMON BLOCKS
C===================================================================
     	INCLUDE 'FILECONV.CBS'
        CHARACTER DACOUT*1,SLID*60,SLID1*36,SLID2*24,FILOUT*14,NAME*12
     	INTEGER*2 IDUM,MTHC
     	DIMENSION NRNS(20)
	REAL*4 SPCAN(4)     !,DATM,TIMM

        COMMON /FILE/ FILOUT
        COMMON /USER/ NAME
        COMMON /SAMPLE/ SLID
        COMMON /SETUP/ RSTART,REND,RSTEP,CTIME,NDIGIT
        COMMON /DATA/ NPTS,YOBS(10000)
     	CLOSE( UNIT=IOUT)
C
C        TYPE 500, FILOUT,NAME,SLID,RSTART,REND,RSTEP,CTIME
C     &          ,NDIGIT
C500     FORMAT(' FILE:',A14,5X,'NAME:',A12,/,' SAMPLE ID:',A60,
C     &         /,' START=',F6.3,3X,'END=',F6.3,3X,'STEP=',F6.3,/,
C     &           ' TIME=',A4,'NDIGIT=',I)
     	OPEN( UNIT=IOUT, FILE=FILOUT, STATUS='NEW',ERR=888,
     1   ACCESS='DIRECT', RECL=12)
C
C  WRITE THE FILE HEADER BLOCK...
C

        
        IDUM=2
        ITYP=1
        NHDB=1
        ISBF=2
        LENG=3
        MESFLG=1
      WRITE(IOUT,REC=1,ERR=888)IDUM,ITYP,NHDB,ISBF,LENG,MESFLG,IOVER 
C
C  WRITE THE SPECIFICATION BLOCK REFERENCES...
C

C      TYPE 36,(I,IRPR(I,1),IRPR(I,2),I=1,12)
C36    FORMAT(' * NO. - ',I2,  ' IRPR(1)=',I5,3X,'IRPR(2)=',I5)

     	IREC = ISBF                         !200
       IF(IFLI.NE.1) THEN
        DO I=1,12
        IRPR(I,1)=0
        IRPR(I,2)=0
        ENDDO
       ENDIF
        NRNG=1

        IRPR(3,1)=ISBF+LENG
        IRPR(3,2)=3
        IRPR(1,1)=IRPR(3,1)+IRPR(3,2)
        IRPR(1,2)=9
        IRPR(2,1)=IRPR(1,1)+IRPR(1,2)
        IF(IRPR(2,2).EQ.0) IRPR(2,1)=0

        IRPR(4,1)=IRPR(1,1)+IRPR(1,2)+IRPR(2,2)
        IRPR(4,2)=NRNG*2
        IRPR(10,1)=IRPR(4,1)+IRPR(4,2)
        IRPR(10,2)=NRNG*2
        IRPR(5,1)=IRPR(4,1)+IRPR(4,2)+IRPR(10,2)
        IF(IRPR(5,2).EQ.0) IRPR(5,1)=0
        IRPR(6,1)=IRPR(4,1)+IRPR(4,2)+IRPR(10,2)+IRPR(5,2)
        IRPR(6,2)=INT(NPTS/12+0.5)
C      TYPE 35,(I,IRPR(I,1),IRPR(I,2),I=1,12)
C35    FORMAT(' ** NO. - ',I2,  ' IRPR(1)=',I5,3X,'IRPR(2)=',I5)
     
      WRITE(IOUT,REC=IREC,ERR=888)(IRPR(I,1),IRPR(I,2),IRLR(I),I=1,4)    
      WRITE(IOUT,REC=IREC+1,ERR=888)(IRPR(I,1),IRPR(I,2),IRLR(I),I=5,8) 
      WRITE(IOUT,REC=IREC+2,ERR=888)(IRPR(I,1),IRPR(I,2),IRLR(I),I=9,12) 


C
C  WRITE THE INSTRUMENTATION BLOCK...
C
     	IREC = IRPR(1,1)+4 

C READ THE WAVE SOURCES

        DIFNUM=6
        DIFVER='A'
C
C        TYPE 31,DIFNUM,DIFVER
C31      FORMAT(' *** DIFFRACTOMETER:',I2,'-',A1)
        WAVE(1,6)=0.20899
        WAVE(2,6)=0.21381
        WAVE(3,6)=0.21060
        WAVE(4,6)=0.18436
        WAVE(5,6)=2
     	IF( WAVE(1,IELE).EQ.0.0 ) IELE=6

C        TYPE 30,( I ,IELE,WAVE(I,IELE),I=1,5)
C30      FORMAT(' ! *** WRW5000 - WAVE(',I1,',',I1,')=',F8.6)  

        ANODE(6)='W'


        WRITE(IOUT,REC=IREC,ERR=888)DIFNUM,DIFVER,GONINT,ANODE(IELE)
     &  ,CHRLIN ,(WAVE(I,IELE),I=1,5)

C  READ THE FILE DESCRIPTION BLOCK...

     	IREC = IRPR(3,1)


        NRNG=1	!S.Z.
        NREP=1  !S.Z.
        FTYP=12 !S.Z.

        BANG(4)=YOBS(1)
        DO I=1,NPTS
        IF(YOBS(I).GT.BANG(4)) BANG(4)=YOBS(I)
C       TYPE*,'YOBS(',I,')=',YOBS(I)
        ENDDO

        BANG(1)=RSTART
        BANG(2)=REND
        BANG(3)=RSTEP
        DECODE(NDIGIT,1,CTIME)BANG(10)  
 1      FORMAT(F3.0)       
        IF(INTMAX.EQ.0) INTMAX=BANG(4)  

C       TYPE*,'DATM;',DATM,'TIMM;',TIMM
     	WRITE(IOUT,REC= IREC) NAME,DATM,TIMM
     &  ,FTYP,MTYP,INTMAX,RES,NREP,MPRO,NRNG,SCAN

        DECODE(60,50,SLID)SLID1,SLID2
50      FORMAT(A36,A24)

      WRITE(IOUT,REC=IREC+1)(SPCAN(I),I=3,4),STYP,MTHC
     &           ,DACOUT,SLID1
     	WRITE(IOUT,REC= IREC+2) SLID2

C
C  WRITE THE LINE MEASUREMENT BLOCK...
C
     	IREC = IRPR(4,1)

              WRITE(IOUT,REC= IREC,ERR=888) (BANG(I),I=1,12)
     	      WRITE(IOUT,REC= IREC+1,ERR=888) (BANG(I),I=13,14)

     	NPTS = INT( (BANG(2)-BANG(1))/BANG(3)) + 1
       
     	IRNG = NRNG  

        L=0
        NREC=0
        DO K=1,NPTS 
        L=L+1
        IF(L.EQ.12. OR .K.EQ.NPTS) THEN
          NREC=NREC+1
          L=0
        ENDIF   
        ENDDO

     	IREC = IRPR(6,1)

        K=1
        FIRST=1
        LAST=12
        DO J=0,NREC-1
        WRITE(IOUT,REC=IREC+J,ERR=888)(YOBS(K),K=FIRST,LAST)
        FIRST=FIRST+12
        LAST=LAST+12
        IF(NPTS-LAST.LT.0) LAST=NPTS
100     ENDDO
     	GOTO 999
888	IERR = 2
999	RETURN
    	END
