     	SUBROUTINE WDI500
C
C  PROGRAMMER:  R.S. ZHOU
C		ALFRED UNIVERSITY   FEB-1987
C  Updated 12/88 to allow for the Version 2 file structure.
C
C	THIS ROUTINE WRITES OUT A DIFFRAC-500 DIFILE
C	FROM THE COMMON BLOCKS
C
     	INCLUDE 'FILECONV.CBS'
     	CHARACTER IQS*1
     	INTEGER*2 IDUM, HKLP(3), NPEAK
     	CLOSE( UNIT=IOUT )
     	OPEN( UNIT=IOUT, FILE=FILOUT, STATUS='NEW', ERR=888,
     	1 ACCESS='DIRECT', RECL=1 )
C
C  WRITE THE FILE HEADER BLOCK...
C
     	IDUM = 1
        ITYP = ITYI
        NHDB = 5
        ISBF = 6
        LENG = 3*NSBR
     	WRITE(IOUT,REC= 1,ERR=888) IDUM,ITYP
     	WRITE(IOUT,REC= 2,ERR=888) NHDB
     	WRITE(IOUT,REC= 3,ERR=888) ISBF
     	WRITE(IOUT,REC= 4,ERR=888) LENG
     	WRITE(IOUT,REC= 5,ERR=888) IDUM,IDUM
C
C  WRITE THE SPECIFICATION BLOCK REFERENCES...
C
        IRPR(1,1) = 73
        IRPR(1,2) = 72
        IRPR(2,1) = 0
        IRPR(2,2) = 0
        IRPR(3,1) = 42
        IRPR(3,2) = 31
        IRPR(4,1) = 145
        IRPR(4,2) = 15
        IRPR(5,1) = 0
        IRPR(5,2) = 0
        IRPR(6,1) = 163
     	IRPR(6,2) = 2 + NPKS*12
        IRPR(10,1)= 160
        IRPR(10,2)= 3
     	IREC = ISBF-1
     	DO I=1, LENG/3
     	   WRITE(IOUT,REC= IREC+1,ERR=888) IRPR(I,1)
     	   WRITE(IOUT,REC= IREC+2,ERR=888) IRPR(I,2)
     	   WRITE(IOUT,REC= IREC+3,ERR=888) IRLR(I)
     	   IREC = IREC + 3
     	ENDDO
C
C  WRITE THE INSTRUMENTATION BLOCK...
C
     	IREC = IRPR(1,1)-1
     	IDUM = 4
     	IQS = 'A'

     	IF( WAVE(1,IELE).EQ.0.0 ) IELE = 4		!ASSUME CU
     	WRITE(IOUT,REC= IREC+1,ERR=888) IDUM,IQS
     	IDUM = 1
     	WRITE(IOUT,REC= IREC+5,ERR=888) ANODE(IELE),IDUM
     	IREC = IREC + 5
     	DO I=1, 5
     	   IREC = IREC + 1
     	   WRITE(IOUT,REC= IREC,ERR=888) WAVE(I,IELE)
     	ENDDO
C
C  WRITE THE FILE DESCRIPTION BLOCK...
C
     	IREC = IRPR(3,1)-1
     	WRITE(IOUT,REC= IREC+1,ERR=888) NAME(1)
     	WRITE(IOUT,REC= IREC+2,ERR=888) NAME(2)
     	WRITE(IOUT,REC= IREC+3,ERR=888) NAME(3)
     	WRITE(IOUT,REC= IREC+4,ERR=888) DATM
     	WRITE(IOUT,REC= IREC+5,ERR=888) TIMM
     	WRITE(IOUT,REC= IREC+6,ERR=888) FTYP,MTYP
     	WRITE(IOUT,REC= IREC+7,ERR=888) DANG(4)/DANG(10)
     	WRITE(IOUT,REC= IREC+9,ERR=888) NREP,MPRO
     	WRITE(IOUT,REC= IREC+10,ERR=888) NRNG,SCAN
     	IREC = IREC + 15
     	WRITE(IOUT,REC= IREC,ERR=888) STYP
     	DO I=1, 15
     	   IREC = IREC + 1
     	   WRITE(IOUT,REC= IREC,ERR=888) SLID(I)
    	ENDDO

C
C  WRITE THE EXPERIMENTAL BLOCK ...
C
     	DUMY = 0.0
     	IREC = IRPR(10,1)-1
     	WRITE(IOUT,REC= IREC+1,ERR=888) DUMY
     	WRITE(IOUT,REC= IREC+2,ERR=888) DUMY
     	WRITE(IOUT,REC= IREC+3,ERR=888) DUMY
C
C  WRITE THE LINE MEASUREMENT BLOCK...
C
     	IREC = IRPR(4,1)-1
     	DO I=1, 14
     	   IREC = IREC + 1
     	   WRITE(IOUT,REC= IREC,ERR=888) DANG(I)
        ENDDO
C
C  WRITE THE DIFILE DATA BLOCK...
C
     	IDUM = 1
     	IREC = IRPR(6,1)
     	WRITE(IOUT,REC= IREC,ERR=888) IDUM,IDUM
     	IREC = IREC + 1
c
c     	IDUM = IREC + 1  version 1 file structure.
c  We now store the pointer as a relative address within the 
c  data block  (ie 3)
c
     	IDUM = 3
     	NPEAK = NPKS
     	WRITE(IOUT,REC= IREC,ERR=888) IDUM,NPEAK
     	DO I=1, NPKS
     	   WRITE(IOUT,REC= IREC+1, ERR=888) F2TH(I)
     	   WRITE(IOUT,REC= IREC+2, ERR=888) C2TH(I)
     	   WRITE(IOUT,REC= IREC+3, ERR=888) PEAK(I)
     	   WRITE(IOUT,REC= IREC+5, ERR=888) PHGH(I)
     	   WRITE(IOUT,REC= IREC+7, ERR=888) AREA(I,1)
     	   WRITE(IOUT,REC= IREC+8, ERR=888) AREA(I,2)
     	   WRITE(IOUT,REC= IREC+9, ERR=888) FWHM(I)
     		HKLP(1) = PHKL(1,I)
     		HKLP(2) = PHKL(2,I)
     		HKLP(3) = PHKL(3,I)
     	   WRITE(IOUT,REC= IREC+10,ERR=888) HKLP(1),HKLP(2)
     	   WRITE(IOUT,REC= IREC+11,ERR=888) HKLP(3)
     	   WRITE(IOUT,REC= IREC+12,ERR=888) RELA(I)
     	   IREC = IREC + 12
     	ENDDO
     	GOTO 999
888	IERR = 1
999	RETURN
     	END
