	PROGRAM CHEM
C	PRINT THE INFORMATION IN THE TN0700.EXT FILE
C	THAT WAS STORED BY THE SEARCH PROGRAM
C
C**********************************************************************
C
C	ROUTINES USED:
C		CHEDLG		SETS FLAG FOR PRINTING RSPACES
C		CHEPRM		PRINTS THE INFO STORED IN THE HEADER BLOCK
C		  CHEEL		PRINTS ELEMENT SYMBOLS FROM MAPS
C		  CHEFLG	PRINTS SPECIAL FLAGS USED
C		CHREAD		READS THE CHEMICAL INFO FOR THE COMPOUND
C		CHCELL		DETERMINE THE CELL ANGLES
C
CC	HEADER BLOCK OF OUTPUT IS IN THE FOLLOWING ORDER
C
C	REFFOM		REFERENCE FOM FOR TEST 2
C	REFMIS		REFERENCE # MISSES FOR TEST 1
C	HITMIN		MINIMUM # OF ELEMENT HITS
C	RFAC		CAMERA CONSTANT
C	INRKNT		# INDEX RECS EXAMINED
C	INPKNT		RECS W/ ELEMENT(S) MATCH
C	FMPKNT		FLAG TESTS PASSED
C	EMPKNT		ELEMENT TESTS PASSED

C	FOMKNT		# FOM CALCULATIONS
C	PDFCNT		# OF PDF #'S SAVED
C	RSNUM0		COUNTS # OF RSPACES
C	SCODES		SPECIAL CODES THAT MUST BE PRESENT
C	ECODES		SPECIAL CODES THAT MUST BE ABSENT
C	IELREQ(3)	BIT MAP FOR REQUIRED ELEMENTS

C	IELREQ(3)	BIT MAP FOR REQUIRED ELEMENTS
C	NACMFL		1=SEARCH OUTSIDE NA-CM RANGE
C	IELDET(4)	ELEMENTS DETECTED (MIN # REQUIRED)

C	IELDET(2)	ELEMENTS DETECTED (MIN # REQUIRED)	(REVERSE)
C	IELEXC(6)	ELEMENTS EXCLUDED			(REVERSE)
C	BLANK SPACE
C	RSPACE		RSPACE VALUES * 1000 STARTING AT WORD 50
C
C THE MATCH RECORDS ARE STORED AS FOLLOWS:
C
C	IBLOCK		RECORD IN SEARCH FILE WITH MATCH
C	BIR	(B)	COMPOUND # IN SEARCH RECORD
C	BCHEM	(B)	CHEM FILE # CONTAINING CORRESPONDING REF INFO
C	INUMB		COMPOUND # IN CHEM FILE
C	IDHCNT		RSPACE DOUBLET ONLY HITS
C	IMINUS		MINUS RSPACE HITS
C	IDIRCT		DIRECT RSPACE HITS
C	IPLUS		PLUS RSPACE HITS
C	BFOM	(B)	FIGURE OF MERIT
C	BELHIT	(B)	# OF ELEMENT HITS
C
	IMPLICIT BYTE (B), LOGICAL*1 (L), INTEGER*2 (I-K,M,N)
	DIMENSION BFILE(25),BFMU(300),BNAME(256),IRSPAC(11),IBUF(256),
     *		IBLOCK(32),BIR(32),BCHEM(32),INUMB(32),IDHCNT(32),
     *		IMINUS(32),IDIRCT(32),IPLUS(32),BFOM(32),BELHIT(32),
     *		IUCLEN(3),IRCLEN(3),ITABLE(96),ICELL(6),BCREF(4),
     *		BJOUR(25),BREFNO(6),IBITS(16),RSP(10),RTAG(2),ANG(6),
     *		BLINE(80)
	EQUIVALENCE (BCREF(3),ICREF)
	DATA BLANK,BSTAR,BA/' ','*','A'/
	DATA I377/"377/
	DATA RTAG /'PDF ','C.D.'/
	DATA IBITS/ "1,      "2,      "4,      "10,     "20,     "40,
     *		    "100,    "200,    "400,    "1000,   "2000,   "4000,
     *		    "10000,  "20000,  "40000,  "100000/
	DATA IBFOM/8002/		!FIRST FOM REC STORED BY SEARCH
	DATA IBLAST/8111/		!LAST FOM REC STORED BY SEARCH
	DATA IBRSP/96/			!FIRST SEARCH FILE RECORD
C
	DATA ITABLE/
     *	'NA','MG','AL','SI','P ','S ','CL','AR','K ','CA','SC','TI',
     *	'V ','CR','MN','FE',
     *	'CO','NI','CU','ZN','GA','GE','AS','SE','BR','KR','RB','SR',
     *	'Y ','ZR','NB','MO',
     *	'TC','RU','RH','PD','AG','CD','IN','SN','SB','TE','I ','XE',
     *	'CS','BA','LA','CE',
     *	'PR','ND','PM','SM','EU','GD','TB','DY','HO','ER','TM','YB',
     *	'LU','HF','TA','W ',
     *	'RE','OS','IR','PT','AU','HG','TL','PB','BI','PO','AT','RN',
     *	'FR','RA','AC','TH',
     *	'PA','U ','NP','PU','AM','CM','H ','HE','LI','BE','B ','C ',
     *	'N ','O ','F ','NE'/
	CALL CHEDLG (BRSP)	!SET RSPACE PRINT FLAG
C OPEN FILE CONTAINING MATCHES
	OPEN (UNIT=3,NAME='TN0700.EXT',TYPE='OLD',ACCESS='DIRECT',
     *		RECORDSIZE=128)
C PRINT HEADER INFO.
	CALL CHEPRM (IBUF,ITABLE,IBFOM,RFAC)
	WRITE (6,30) 12		!FORM FEED
30	FORMAT (1X,A1)
	IREC3 = IBFOM + 1	!LEAVE ROOM FOR HEADER BLOCK
	BPREV = 0		!FLAG TO DETERMINE IF NEW CHEM FILE 
	IHITS = 0		!COUNTER FOR # OF HITS
C
C	PROCESS MATCH RECORDS
C
50	IF (IREC3 .GT. IBLAST) GOTO 1000	!END OF FILE
	READ (3'IREC3,ERR=1000) (IBLOCK(I),BIR(I),BCHEM(I),
     *		INUMB(I),IDHCNT(I),IMINUS(I),IDIRCT(I),IPLUS(I),
     *		BFOM(I),BELHIT(I),I=1,32)
	IREC3 = IREC3 + 1
	DO 900 IR=1,32		!32 RECORDS PER BLOCK
	  IF (IBLOCK(IR) .EQ. 0) GOTO 1000		!END OF FILE
C	  DETERMINE CORRESPONDING CHEM FILE AND SEE IF IT IS ALREADY OPEN
200	  IF (BCHEM(IR) .EQ. BPREV) GOTO 300		!ALREADY OPEN
	  ITAG = 2			!TAG FOR PDF OR C.D.
	  IF (BCHEM(IR) .LT. 10) ITAG = 1
	  BPREV = BCHEM(IR)
	  CLOSE (UNIT=1,ERR=250)
C	  DETERMINE THE CHEM FILE TO OPEN
250	  ENCODE (11,270,BFILE) BCHEM(IR),0
270	  FORMAT ('CHEM',I2,'.EXT',A1)
	  IF (BCHEM(IR) .LE. 9) BFILE(5) = '0'
C OPEN THE CHEM FILE
290	  OPEN (UNIT=1,NAME=BFILE,TYPE='OLD',ACCESS='DIRECT',
     *		RECORDSIZE=128)
C READ THE CHEMICAL INFORMATION
300	  CALL CHREAD (INUMB(IR),BFMU,ILFRM,BNAME,ILNAM,ICELL,NCELL,
     *		BCELL,BCREF,BJOUR,IYEAR,BREFNO,ILINT,LERR)
	  IF (LERR) THEN
	    WRITE (6,400) BREFNO
400	    FORMAT (/' COMPOUND # ',6A1,' WAS NOT FOUND')
	    GOTO 900
	  END IF
C	  READ THE CORRESPONDING RSPACE RECORD
	  IREC33 = IBLOCK(IR)
	  ITMP = BIR(IR)
	  IWRSP = (ITMP-1)*28+6		!SKIP OTHER RECORDS
	  IF (IWRSP .GT. 256) THEN
	    IREC33 = IREC33 + 1
	    IWRSP = IWRSP - 256
	  END IF
C COMPOUND INFO STORED IN THE SEARCH FILE RECORD
	  READ (3'IREC33) (IDUM,I=1,IWRSP),
     *		(IRSPAC(J),J=1,11),BSPAC,BSLET,IUCLEN,IRCLEN,IVOL,
     *		BFLGS
C	  RECORD WAS FOUND, PRINT THE CHEMICAL INFORMATION
	  WRITE (6,500) BREFNO,RTAG(ITAG),BFOM(IR),BCHEM(IR),INUMB(IR),
     *		(BNAME(J),J=1,ILNAM)
500	  FORMAT (/' # ',6A1,1X,A4,10X,'FOM: ',I3,' TAPE: ',I2,
     *		' # ',I5/(1X,65A1))
	  WRITE (6,510) (BFMU(J),J=1,ILFRM)	!PRINT FORMULA
510	  FORMAT (1X,65A1)
C	  PRINT FLAGS ASSOCIATED WITH THE COMPOUND
	  IS = 1
	  IF ((BFLGS.AND.1) .NE. 0) THEN
	    CALL BCOPY ('Mineral ',BLINE(IS),8)
	    IS = IS + 8
	  END IF
	  IF ((BFLGS.AND.2) .NE. 0) THEN
	    CALL BCOPY ('Deleted ',BLINE(IS),8)
	    IS = IS + 8
	  END IF
	  IF ((BFLGS.AND."100) .NE. 0) THEN
	    CALL BCOPY ('Alloy ',BLINE(IS),6)
	    IS = IS + 6
	  END IF
	  IF (IS .GT. 1) WRITE (6,515) (BLINE(I),I=1,IS-1)
515	  FORMAT (1X,80A1)
C SET UP PEARSON SYMBOL OR CRYSTAL CODE
	  ISLET = I377 .AND. BSLET
	  BCHAR = BLANK
	  IF (ISLET .GE. 100) THEN
	    BCHAR = BSTAR
	    ISLET = ISLET - 100
	  END IF
	  IF (ISLET .LT. 1) THEN
	    BSLET = BLANK
	  ELSE
	    BSLET = ISLET-1+BA
	  END IF
	  ISPAC = I377 .AND. BSPAC
C PRINT REFERENCE AND SYMBOL
	  WRITE (6,520) BCREF(1),BCREF(2),ICREF,ISPAC,BSLET,BCHAR,
     *		BJOUR,IYEAR
520	  FORMAT (' Pearson Symbol / Crystal System Code: ',2A1,I4,
     *		  5X,' Space Group: ',I3,2A1/
     *		  ' Reference: ',25A1,1X,I4)
C GET CELL ANGLES
	  CALL CHCELL (BCELL,ICELL,ANG)
C PRINT CELL INFO
	  WRITE (6,525) (IUCLEN(I)/100.,I=1,3),(ANG(I),I=1,3),
     *		        (IRCLEN(I)/100.,I=1,3),(ANG(I),I=4,6)
525	  FORMAT ('    Unit Cell Lengths: ',3F8.2/
     *		  '               Angles: ',3F8.2/
     *		  ' Reduced Cell Lengths: ',3F8.2/
     *		  '              Angles : ',3F8.2)
C FOR C.D. FILES PRINT IF SPACING DOESN'T MATCH
	  IF ((ITAG.EQ.2) .AND. ((BFLGS.AND."20).NE.0)) WRITE (6,526)
526	  FORMAT (' *** AUTHOR''S SPACING IS DIFFERENT *** ')
C PRINT NUMBER AND TYPE OF HITS
	  WRITE (6,530) IDHCNT(IR),IMINUS(IR),IDIRCT(IR),IPLUS(IR),
     *		BELHIT(IR)
530	  FORMAT (1X,' DOUBLETS: ',I3,2X,'   MINUS: ',I3,
     *		'   DIRECT: ',I3,
     *		'   PLUS: ',I3,'   # ELEMENTS HIT: ',I3)
	  IHIT = IHIT + 1
	  IF (BRSP .NE. 'Y') GOTO 900	!RSPACES NOT PRINTED
C PRINT RSPACES
C CONVERT THE INTERNAL RSPACE FORMAT TO RSPACES
C IC IS USED FOR PRINTING PURPOSES (10 RSPACES PER LINE)
	  IC = 0
	  IWORD = -1
	  DO 800 J=1,11
	    IF (IRSPAC(J) .NE. 0) THEN
C	      DETERMINE WHICH BITS ARE SET
	      DO 775 K=1,16
	        IF ((IRSPAC(J).AND.IBITS(K)) .NE. 0) THEN
C	          THE +.09 PLACES THE VALUE AT THE CENTER OF THE CELL
	          IC = IC + 1
	          RSP(IC) = (IWORD+K) * .18 + .09
	          IF (IC .EQ. 10) THEN
	            WRITE (6,760) (RSP(JJ)*RFAC/25,JJ=1,10)
760	            FORMAT (10X,10F6.3)
	            IC = 0
	          END IF
	        END IF
775	        CONTINUE
	    END IF
	    IWORD = IWORD + 16
800	    CONTINUE
	  IF (IC .NE. 0) WRITE (6,760) (RSP(J)*RFAC/25,J=1,IC)
900	  CONTINUE
	GOTO 50
1000	IF (IHIT .GT. 0) WRITE (6,1105)
1105	FORMAT ('1'////////////////////////////////)
	CALL EXIT
	END
