     	SUBROUTINE WRW5000
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            DEC-15-1992 S.Z. TO PUT INTMAX
C
C	THIS ROUTINE WRITES OUT A DIFFRAC-5000 RAW DATA FILE
C	FROM CORRESPONDING COMMON BLOCKS
C===================================================================
     	INCLUDE 'FILECONV.CBS'
        CHARACTER DACOUT*1
     	INTEGER*2 IDUM,MTHC
     	DIMENSION NRNS(20)
	REAL*4 SPCAN(4)

     	CLOSE( UNIT=IOUT)

     	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
     	IREC = ISBF                         !200
       IF(IFLI.NE.1) THEN
        DO I=1,12
        IRPR(I,1)=0
        IRPR(I,2)=0
        ENDDO
       ENDIF


        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)
     
      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

        TYPE*,'WAVELEN=',WAVE(1,IELE),'IELE=',IELE

     	IF( WAVE(1,IELE).EQ.0.0 ) IELE=4

        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.
                
        IF(INTMAX.EQ.0) INTMAX=BANG(4)/BANG(10)   

     	WRITE(IOUT,REC= IREC) (NAME(I),I=1,3),DATM,TIMM
     &  ,FTYP,MTYP,INTMAX,RES,NREP,MPRO,NRNG,SCAN

      WRITE(IOUT,REC=IREC+1)(SPCAN(I),I=3,4),STYP,MTHC
     &           ,DACOUT,(SLID(I),I=1,9)
     	WRITE(IOUT,REC= IREC+2) (SLID(I),I=10,15)

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 

        IF(I.GT.4950 .AND. I.LE.5050)THEN
        TYPE*,'**** YOBS(',I,')=',YOBS(I)
        ENDIF

        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
