C	PROGRAM CDIF
C
C	TO CREATE A LISTING OF CDIF NUMBERS FOR ASSCESS TO CDROM
	INTEGER*4 TABLE(2000),NTABLE,MASK
      CHARACTER*1 ANS,IFLAG(2)
      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
        character*30 filename
	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 AUG 1, 1988'/
     1  10X,'GERALD G. JOHNSON JR., MRL/PSU'/
     1  10X,'RICHARD L. HARLOW, I, DUPONT'/
     1  10X,'PROGRAM TO CREATE A FILE OF (CDIF) RESULTS FOR CDROM'/
     1  10X,'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
        iflag(1)='I'
        IFLAG(2)='O'
1287    WRITE(6,1288)
1288    FORMAT(' PLEASE ENTER A FILENAME FOR THE OUTPUT'/
     1  10X,'ENTER ONLY THE ROOT--THIS FILE WILL BE USED WITH'/
     2  10X,'THE CDIF CDROM TO ACCESS THE FULL RECORD'/
     3  10X,'ENTER THE FILENAME    ',$)
        READ(5,1289) NCR,FILENAME
1289    FORMAT(Q,A)
        IF(NCR.EQ.0.OR.FILENAME.EQ.'    ') GO TO 1287
        OPEN(UNIT=46,STATUS='NEW',CARRIAGECONTROL='LIST',RECL=80,
     1  DEFAULTFILE='.CNUMS',FILE=FILENAME)
       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)
	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
	 WRITE(46,311) iflag(key),NREC,(ELEM(J),J=1,46)
	 WRITE(6,3111) NREC,(ELEM(J),J=1,46)
311	FORMAT (1X,1a1,I7,3X,46A1)
3111	FORMAT (1X,I7,3X,46A1)
390   CONTINUE
400   CONTINUE
        close(unit=46)
	CLOSE (UNIT=2)
C
C
20    WRITE(6,2299)
2299  FORMAT(//' NOW PROCEED TO MENU ITEM #4 OF THE MAIN MENU OF'
     1 10X,'LATTICE, TO VIEW THE COMPLETE INFORMATION FROM THE CDROM'//)
      STOP 'END OF CREATION OF CDIF FILE'
401   STOP 'BAD OPEN'
      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
