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