C	PROGRAM FINAL_OUT
C
C	TO TYPE OR PRINT THE TABLE.TMP FILE WITH THE SEARCH RESULTS

	INTEGER*4 TABLE(2000),NTABLE,MASK
      CHARACTER*1 ANS
      CHARACTER*12 USER
	CHARACTER*80 KARD

C
C	ITEMS USED TO READ IN ENCODED DATA
C

	BYTE ASPC,ORIENC,ZCODEC,DCODE,IX,OX,MX,AX,ELEM(47)
	BYTE ISYS,STRUC,SOUR,EDIT,RAD,METRIC,IR,YEAR,ISET
	INTEGER*2 IAA(6),IAR(6),IVOLR,IAC(6),NSPGC,ICARD,COMP,QUAL,IZC
	INTEGER*2 IDMA,IDXC,MAT
	DIMENSION AA(6),AR(6),AC(6)
	CHARACTER*2 QUALIT(9)
	CHARACTER*4 YR
	CHARACTER*5 ETC
	CHARACTER*6 CODEN
	CHARACTER*8 SPGC,RADIAT(5)
	CHARACTER*9 VOLPAG
	CHARACTER*12 SYSTEM(7)
	CHARACTER*13 STRUCT(3),CONDIT(3)
	CHARACTER*16 SOURCE(4)
	CHARACTER*68 JOURNL
	EQUIVALENCE (MAT,IR)

	COMMON /UNIT5/ IDIRECT,ICODEN
	DATA IDIRECT/2/,ICODEN/3/

	DATA ETC/' etc.'/
	DATA RADIAT/'No Info.','X-ray   ','Neutron ','Electron',
	1 'Gamma   '/
	DATA SYSTEM/'Triclinic   ','Monoclinic  ','Orthorhombic',
	1 'Tetragonal  ','Hexagonal   ','Rhombohedral','Cubic       '/
	DATA QUALIT/'A ','A-','B ','B-','C ','C-','D ','D-','F '/
	DATA SOURCE/'Not Specified   ','Single Crystal  ',
	1 'Powder Diffract.','Rietveld/Profile'/
	DATA STRUCT/'No Info.      ','Limited Info.','Determined   '/
	DATA CONDIT/'             ','High/Low Temp','High Pressure'/


      NUMBER_OUT=0
      WRITE(6,123)
123   FORMAT(' VAX VERSION JULY 27, 1988'/
     1  10X,'GERALD G. JOHNSON JR., MRL/PSU'/
     1  10X,'RICHARD L. HARLOW, I, DUPONT'/
     1  10X,'PROGRAM TO PRINTOUT RESULTS FROM LOGIC SEARCHES'/
     1  10X,'FROM THE "CRYSTAL DATA" FILE'//)
      CALL GET(TABLE,ISIZE,NSIZE)
      IF(ISIZE.EQ.59613) KEY=1
      IF(ISIZE.EQ.56140) KEY=2
      IF(KEY.EQ.1) THEN
	OPEN (UNIT=2,NAME='LATTICEI',STATUS='OLD',READONLY,
	1 FORM='UNFORMATTED',ACCESS='DIRECT',RECL=32,SHARED)
	ENDIF
	IF (KEY.EQ.2) THEN
	OPEN (UNIT=2,NAME='LATTICEO',STATUS='OLD',READONLY,
	1 FORM='UNFORMATTED',ACCESS='DIRECT',RECL=32,SHARED)
	ENDIF
	OPEN (UNIT=ICODEN,NAME='CD:CODENS.DAT',STATUS='OLD',READONLY,
	1 FORM='FORMATTED', ACCESS='DIRECT',SHARED,RECL=80)
199   WRITE(6,200)
200   FORMAT(' PLEASE ENTER ONE OF THE FOLLOWING'/
     1   10X,'0 EXIT'/
     2   10X,'1 TYPE RESULTS          (ABBREVIATED FORMAT)'/
     3   10X,'2 TYPE RESULTS          (EXTENDED FORMAT)'/
     4   10X,'3 PRINT RESULTS         (ABBREVIATED FORMAT)'/
     5   10X,'4 PRINT RESULTS         (EXTENDED FORMAT)'/
     6   10X,'5 WRITE RESULTS TO FILE (ABBREVIATED FORMAT)'/
     7   10X,'6 WRITE RESULTS TO FILE (EXTENDED FORMAT)'/
     8   10X,'ENTER YOUR CHOICE [1]  ',$)
      READ(5,201,ERR=199,END=20) NCR,NUMBER
201   FORMAT(Q,I10)
      IF(NCR.EQ.0) NUMBER=1
	IF (NUMBER.EQ.0) STOP ' END OF REVIEW OF RESULTS'
      IF(NUMBER.LT.1.OR.NUMBER.GT.6) GOTO 199
      if( number.eq.2.or.number.eq.4) WRITE(6,33311)
33311 FORMAT(///' **** NOTE--THE SPACE GROUP IS FOR THE CRYSTAL DATA'
     1  1X,'CELL ****'///)
      IF(NUMBER.EQ.1.OR.NUMBER.EQ.2) WRITE(6,3333)
3333  FORMAT(' EVERY 50 RECORDS YOU WILL BE ASKED IF YOU'
     1 ,1X,'WANT TO CONTINUE !')
      NOUT=6
      IF(NUMBER.GE.3.AND.NUMBER.LE.6) THEN
                      WRITE(6,3000)
3000  FORMAT(' PLEASE ENTER A TITLE LINE (DESCRIBING LOGIC)')
                      READ(5,3001) KARD
3001  FORMAT(A80)
                      NOUT=55
                      OPEN(UNIT=NOUT,STATUS='NEW',RECL=132,
     1                FILE='CRYSTAL_DATA.OUT')
                      WRITE(NOUT,3002) KARD(1:79)
3002                  FORMAT(' ',A//)
	IF (NUMBER.EQ.3.OR.NUMBER.EQ.4) WRITE (6,3003)
3003	FORMAT (/' CREATING FILE "CRYSTAL_DATA.OUT" AND SENDING IT'
	1 ' TO LINE PRINTER.'/)
	IF (NUMBER.EQ.5.OR.NUMBER.EQ.6) WRITE (6,3004)
3004	FORMAT (/' CREATING FILE "CRYSTAL_DATA.OUT".')
      ENDIF
       DO 400 N=1,NSIZE
	NTABLE=TABLE(N)
	IF (NTABLE.EQ.0) GO TO 400
	DO 390 K=0,31
	MASK=IBITS(NTABLE,K,1)
	IF (MASK.EQ.0) GO TO 390
	I=(N-1)*32+(K+1)

C	CONVERT CODED INFORMATION INTO PRINTABLE ITEMS
        NUMBER_OUT=NUMBER_OUT+1
        IF((MOD(NUMBER_OUT,50).EQ.0).AND.(NUMBER.EQ.1.OR.
     1                                     NUMBER.EQ.2)) THEN
                    WRITE(6,6868)
6868    FORMAT(/' PUSH RETURN TO CONTINUE, ENTER A "Q" TO QUIT  ',$)
                                           READ(5,6869) NCR,ANS
6869    FORMAT(Q,1A1)
                                           KEY=STR$UPCASE(ANS,ANS)
                               IF(ANS.EQ.'Q') STOP 'JOB TERMINATED' 
        ENDIF
	READ (2,REC=I,ERR=401) IAA,IAR,IAC,IVOLR,SPGC,NSPGC,IDMA,IDXC,
	1 CODEN,VOLPAG,YEAR,ISET,ICARD,IZC,COMP,MAT,NREC,ELEM

C	DECODE PACKED INFORMATION IN COMP AND MAT

	RAD = IBITS(COMP,0,3)
	SOUR = IBITS(COMP,3,2)
	SOUR=SOUR+1
	STRUC = IBITS(COMP,5,2)
	STRUC=STRUC+1
	ISYS = IBITS(COMP,7,3)
	QUAL = IBITS(COMP,10,4)
	EDIT = IBITS(COMP,14,2)
	EDIT=EDIT+1
	IX = IBITS(MAT,0,1)
	OX = IBITS(MAT,1,1)
	MX = IBITS(MAT,2,1)
	AX = IBITS(MAT,3,1)

C	CONVERT UNIT CELL PARAMETERS -- THOSE PARAMETERS WHICH SEEMED
C	OUT OF LINE AND WHICH WERE TOO BIG TO BE PACKED INTO AN INTEGER
C	ARE ASSIGNED 999.99.

	IVA=0
	IVC=0
	IVR=0
	DO 302 J=1,6
	AA(J)=0.01*IAA(J)
	AC(J)=0.01*IAC(J)
	AR(J)=0.01*IAR(J)
	IF (AA(J).EQ.-1.) THEN
	AA(J)=-999.99
	IVA=1
	ENDIF
	IF (AC(J).EQ.-1.) THEN
	AC(J)=-999.99
	IVC=1
	ENDIF
	IF (AR(J).EQ.-1.) THEN
	AR(J)=-999.99
	IVR=1
	ENDIF
302	CONTINUE
	IF (IVA.EQ.0) CALL VOLUME (AA,VOLA)
	IF (IVA.EQ.1) VOLA=-9999.
	IF (IVC.EQ.0) CALL VOLUME (AC,VOLC)
	IF (IVC.EQ.1) VOLC=-9999.
	VOLR=IVOLR
	IF (IVR.EQ.1) VOLR=-9999.

C	SET UP REFERENCE INFORMATION

	IF (YEAR.EQ.0) YR='    '
	IF (YEAR.LT.0) YR='9999'
	IF (YEAR.GT.0) THEN
	IYR=1900+YEAR
	ENCODE(4,304,YR) IYR
304	FORMAT (I4)
	ENDIF
	CALL MCODEN (CODEN,JOURNL)

C	TOTAL LENGTH OF REFERENCE CANNOT EXCEED 68 CHARACTERS IN PRINTED
C	TEXT.  SINCE I ALWAYS WANT THE PAGE AND DATE, I HAVE LIMITED THE
C	JOURNAL TITLE TO 54 CHARACTERS -- THIS MAY BE A PROBLEM.

	L = LENGTH(JOURNL,54)
	JOURNL(L+1:L+1)=' '
	JOURNL(L+2:L+10)=VOLPAG(1:9)
	JOURNL(L+11:L+11)=' '
	JOURNL(L+12:L+15)=YR(1:4)


C	GET OTHER ODDS AND ENDS

	DMA=0.001*IDMA
	DXC=0.001*IDXC
	ZC=0.01*IZC
	ASPEC=' '
	IF (NSPGC.LT.0) THEN
	NSPGC=-NSPGC
	ASPEC='*'
	ENDIF
C
C
        metric=' '
C
C
	IF (IR.LT.0) THEN
	IR=-IR
	METRIC='X'
	ENDIF


C	HANDLE CHEMISTRY?




C	WRITE OUT INFORMATION

	IF (ELEM(47).EQ.'*') WRITE(NOUT,311) (ELEM(J),J=1,46),ETC,ZC
311	FORMAT (/' FORMULA:',3X,46A1,A,5X,'Z: 'F6.2)
	IF (ELEM(47).NE.'*') WRITE (NOUT,312) ELEM,ZC
312	FORMAT (/' FORMULA:',3X,47A1,9X,'Z: 'F6.2)
	WRITE (NOUT,330) AC,VOLC,METRIC
330	FORMAT (' CRY-DAT CELL:',6F8.2,F7.0,2X,'METRIC: 'A)
	IF (NUMBER.EQ.1.OR.NUMBER.EQ.3.OR.NUMBER.EQ.5) GO TO 348
	WRITE (NOUT,315) AR,VOLR,IR
315	FORMAT (' REDUCED CELL:'6F8.2,F7.0,2X,'REDFM: 'I2)
	WRITE (NOUT,320) AA,VOLA,QUALIT(QUAL)
320	FORMAT (' AUTHORS CELL:',6F8.2,F7.0,2X,'QLESD: 'A)
	IF (ASPEC.NE.'*') WRITE (NOUT,335) SYSTEM(ISYS),
	1 SPGC,NSPGC,DMA,DXC
335	FORMAT (' SYSTEM: 'A,3X,'SP.GRP: 'A,3X,'NUMBER: 'I3,3X,
	1 'DM: 'F6.3,3X,'DX: 'F6.3)
	IF (ASPEC.EQ.'*') WRITE (NOUT,336) SYSTEM(ISYS),
	1 SPGC,NSPGC,DMA,DXC
336	FORMAT (' SYSTEM: 'A,3X,'ASPECT: 'A,3X,'NUMBER: 'I3,3X,
	1 'DM: 'F6.3,3X,'DX: 'F6.3)
	WRITE (NOUT,345) SOURCE(SOUR),STRUCT(STRUC),CONDIT(EDIT)
345	FORMAT (' SOURCE: 'A,3X,'STRUCTURE: 'A,3X,'CONDITIONS: 'A)
348	WRITE (NOUT,350) JOURNL
350	FORMAT (' JOURNAL:',3X,A68)
	IF (NUMBER.EQ.1.OR.NUMBER.EQ.3) GO TO 390
	WRITE (NOUT,360) NREC
360	FORMAT (' RECORD: '3X,I7)


390	CONTINUE
400   CONTINUE
401   CONTINUE
	CLOSE (UNIT=ICODEN)
	CLOSE (UNIT=2)
      CALL WHO(USER)
      WRITE(NOUT,4401) USER
4401  FORMAT(///' THIS JOB WAS RUN BY 'A12)
      IF(NUMBER.EQ.1.OR.NUMBER.EQ.2) THEN
                     WRITE(6,402)
402   FORMAT(//' PRINTOUT FINISHED-- PUSH RETURN TO CONTINUE')
                     READ(5,4402) ANS
4402                 FORMAT(A)
      ENDIF
      IF(NUMBER.EQ.3.OR.NUMBER.EQ.4) THEN
                      CLOSE(UNIT=NOUT,STATUS='PRINT/DELETE')
      ENDIF
	IF(NUMBER.EQ.5.OR.NUMBER.EQ.6) CLOSE (UNIT=NOUT)
C
C
C
20    STOP 'END OF REVIEW PROCESS'
      END




	SUBROUTINE VOLUME(CELL,V)
C	****************************************************************

	DIMENSION CELL(6)
	DATA RAD/0.0174533/

	COSAL=COS(CELL(4)*RAD)
	COSBE=COS(CELL(5)*RAD)
	COSGA=COS(CELL(6)*RAD)
	COS2AL=COSAL*COSAL
	COS2BE=COSBE*COSBE
	COS2GA=COSGA*COSGA
	CTERM=2.0*COSAL*COSBE*COSGA
	STUFF=1.0-COS2AL-COS2BE-COS2GA+CTERM
        if(stuff.lt.0) then
                       write(6,1000) stuff
1000    format(' **** THE NEXT PHASE HAS A NEGATIVE VOLUME',F15.4)
                       STUFF=ABS(STUFF)
        ENDIF
	V=CELL(1)*CELL(2)*CELL(3)*SQRT(STUFF)
	RETURN
	END



	SUBROUTINE MCODEN (CODEN, JOURNL)
C **********************************************************************
C
C	MATCHES CODEN(A6) WITH REFERENCES IN THE CODEN FILE: ONEFILE.DAT
C
C
	IMPLICIT INTEGER (A-Z)
	COMMON /UNIT5/ IDIRECT,ICODEN
	CHARACTER*6	CODEN, INCDN
	CHARACTER*68	JOURNL

C
C	...READ CODEN-JOURNAL FILE UNTIL CODENS MATCH
	L = 1
	U = 1767

3000	IF(L .GT. U) GO TO 20
	M = (L + U)/2
	READ (ICODEN, 1200, REC=M) INCDN, JOURNL
1200	FORMAT(A6,1X,A54)
C
	IF(LGT(CODEN,INCDN)) THEN
	   L=M+1
	ELSE IF(LLT(CODEN,INCDN)) THEN
	   U=M-1
	ELSE
	   GO TO 9000
	ENDIF
	GO TO 3000


C
C-----END OF CODEN FILE FOUND WITHOUT MATCHING CODENS
C
20	JOURNL = '***misspelled or not in coden file***'
	GO TO 9000

9000	CONTINUE
	RETURN
	END




      FUNCTION LENGTH (STRING,MAXLEN)
C **********************************************************************
C
C          ROUTINE TO FIND THE LENGTH OF A CHARACTER STRING.
C          THE LENGTH IS DEFINED AS THE POSITION OF THE LAST
C          NON-BLANK CHARACTER.  LENGTH=0 IF STRING IS BLANK.
C
      IMPLICIT  INTEGER (A-Z)
      CHARACTER*1 STRING(MAXLEN)
C
      DO 400 I=MAXLEN,1,-1
      IF(STRING(I) .NE. ' ') THEN
         LENGTH = I
         RETURN
      ENDIF
400   CONTINUE

      LENGTH = 0
      RETURN
      END
