

     	SUBROUTINE WDI5000
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 D/I DATA FILE
C                                              
C           OCT-18-1991
C           FEB-16-1993 to write detector information in to D/I file S.Z.
C
C	THIS ROUTINE WRITES OUT A DIFFRAC-5000 RAW DATA FILE
C	FROM CORRESPONDING COMMON BLOCKS
C
     	INCLUDE 'FILECONV.CBS'
C==================================================================
        CHARACTER IQS*1,DACOUT
     	INTEGER*2 IDUM,HKLP(3),NPEAK,ILOC1(100),ILOC2(100)
     &            ,DIFSER,DIFRNG,DUMY2(MNK),MTHC,DIVER
     
	REAL*4 DUMY1(MNK),SPCAN(4)     !,INTMAX,RES
        COMMON DIFSER ,DIFRNG
     	CLOSE( UNIT=IOUT)

     	OPEN( UNIT=IOUT, FILE=FILOUT, STATUS='NEW', ERR=888,
     1   ACCESS='DIRECT', RECL=12)
C					!200
C  WRITE THE FILE HEADER BLOCK...
C

        DIVER=3
        ITYP=2
        NHDB=1
        ISBF=2
        LENG=3
       
     	WRITE(IOUT,REC= 1) DIVER,ITYP,NHDB,ISBF,LENG   !REC=1

C
C  WRITE THE SPECIFICATION BLOCK REFERENCES...
C

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

        IRPR(2,1)=IRPR(1,1)+IRPR(1,2)
        IF(IRPR(2,2).EQ.0) IRPR(2,1)=0
        IRPR(3,1)=IRPR(1,1)+IRPR(1,2)+IRPR(2,2)
        IRPR(3,2)=3
        IRPR(4,1)=IRPR(1,1)+IRPR(1,2)+IRPR(2,2)+IRPR(3,2)
        IF(IFLI.EQ.32. OR .IFLI.EQ.30. OR .NRNG.EQ.0) NRNG=1
        IRPR(4,2)=NRNG*2
        IRPR(8,1)=IRPR(1,1)+IRPR(1,2)+IRPR(2,2)+IRPR(3,2)+IRPR(4,2)
        IRPR(8,2)=2
        IRPR(5,1)=IRPR(4,1)+IRPR(4,2)+IRPR(8,2)
        IRPR(5,2)=1
        IRPR(7,1)=IRPR(5,1)+IRPR(5,2)
        IRPR(7,2)=2
        IRPR(6,1)=IRPR(4,1)+IRPR(4,2)+IRPR(5,2)+IRPR(7,2)
        IRPR(6,2)=1 + NPKS

     
      WRITE(IOUT,REC=IREC)(IRPR(I,1),IRPR(I,2),IRLR(I),I=1,4)    !REC=2
      WRITE(IOUT,REC=IREC+1)(IRPR(I,1),IRPR(I,2),IRLR(I),I=5,8)  !REC=3
      WRITE(IOUT,REC=IREC+2)(IRPR(I,1),IRPR(I,2),IRLR(I),I=9,12) !REC=4


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

C READ THE WAVE SOURCES


        IF(WAVE(1,IELE).EQ.0.0)IELE=4 
        WRITE(IOUT,REC=IREC)DIFNUM,DIFVER,GONINT,ANODE(IELE), 
     &                         CHRLIN ,(WAVE(I,IELE),I=1,5)



        IF(DETCOD.EQ.0)  DETCOD=2                   !S.Z. FEB-16-93   
        WRITE(IOUT,REC=IREC+1) SOLINC,SOLDIV,SCATYP,DB3,DB4,SLCHGR,
     &  RBM,BFC,BM,BMTYP,DETCOD,GONCOD,GONTYP



C  READ THE FILE DESCRIPTION BLOCK...

     	IREC = IRPR(3,1)


        NRNG=1	!S.Z.
        NREP=1  !S.Z.
        FTYP=12 !S.Z.
                
      WRITE(IOUT,REC= IREC ) (NAME(I),I=1,3),DATM,TIMM	!REC=
     &  ,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 TH EXPERIMENTAL BLOCK
C
        

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

              WRITE(IOUT,REC= IREC) (BANG(I),I=1,12)
C
C  WRITE THE DIFILE DATA BLOCK
C
        DIFSER=1
        DIFRNG=1
        IREC=IRPR(6,1)
        ILOC1(1)=2
        ILOC2(1)=NPKS
        WRITE(IOUT,REC=IREC,ERR=888) DIFSER,DIFRNG,ILOC1(1),ILOC2(1)
        NREC=IREC+ILOC1(1)-1
        DO I=1,NPKS
        IREC=NREC+I-1
      WRITE(IOUT,REC=IREC) F2TH(I),C2TH(I),PEAK(I),DUMY1(I),
     & PHGH(I),DUMY1(I),(AREA(I,J),J=1,2),FWHM(I),
     & (PHKL(J,I),J=1,3),DUMY2(I),RELA(I)


        ENDDO  
     	GOTO 999

777	IERR = 1
     	GOTO 999
888	IERR = 2
999	RETURN
    	END
