C	PROGRAM CODEN
C
C	TO READ THE CODENS FILES ASSOCIATED WITH THE NBS CRYSTAL DATA FILE
C	AND PRINT OUT MATCHES.
C
C	FILES FOR THE INORGANIC AND ORGANIC CODENS ARE "CODENSI" AND
C	"CODENSO" RESPECTIVELY, AND ARE LOCATED ON PSEUDO-DEVICE "CD:".
C
	CHARACTER*6 IC,ICODENS,BLANK
	CHARACTER*72 REFER
	DATA IUNIT1/1/,LO/5/,LI/5/,BLANK/'      '/
C
	WRITE (LO,9)
9	FORMAT (//,20X,' NBS*CODEN -- VERSION 1',//)
1	WRITE (LO,10)
10	FORMAT (/,'$ENTER THE SIX CHARACTERS OF THE CODEN: ')
	READ (LI,20) IC
20	FORMAT (A,A)
	IF(IC.EQ.BLANK) GO TO 999
C
	OPEN (UNIT=IUNIT1,FILE='CD:CODENSI.;',SHARED,
     $  ACCESS='SEQUENTIAL',FORM='FORMATTED',READONLY,STATUS='OLD')
25	READ (IUNIT1,20,END=50) ICODENS,REFER
	IF (IC.NE.ICODENS) GO TO 25
	WRITE (LO,40) ICODENS,REFER
40	FORMAT (/,' INORGANIC MATCH FOUND:',/' 'A,A)
	GO TO 1
50	CLOSE (UNIT=IUNIT1)
	OPEN (UNIT=IUNIT1,FILE='CD:CODENSO.;',SHARED,
     $  ACCESS='SEQUENTIAL',FORM='FORMATTED',READONLY,STATUS='OLD')
55	READ (IUNIT1,20,END=100) ICODENS,REFER
	IF (IC.NE.ICODENS) GO TO 55
	WRITE (LO,60) ICODENS,REFER
60	FORMAT (/,' ORGANIC MATCH FOUND:',/' 'A,A)
100	CLOSE (UNIT=IUNIT1)
	WRITE (LI,110) IC
110	FORMAT (/,' NO MATCH FOUND FOR CODEN: 'A)
	GO TO 1
999	STOP '                     END OF NBS*CODEN'
	END
