C*************************************************************************
      SUBROUTINE TBLINIT(filename,ln,gparm,STATUS)
C*************************************************************************
C	Initializes the Current table from a subfile
C*************************************************************************
	CHARACTER*60 filename
	integer*4 LN
	BYTE gparm
	integer STATUS

	include 'LOGIC.common'
	include '[-.shared]TBL.cmn'

	INTEGER*2 IREC

	CHARACTER*1 ians
	integer*4 NCARDS,NWORDS
	INTEGER*4 ICARD,NAMREC,FULREC,DIREC,ISEQ
	INTEGER*4 CARDNO
	LOGICAL FLAG, userfl, fullf, nullf

C*************************************************************************
	STATUS = .TRUE.
C Read from a subfile or a userfile
170	userfl = .false.
	fullf = .false.
	nullf = .false.
	cnum = 0
	irec = 0
C Read from a subfile or a userfile
	IF (ln .gt. 0) THEN
	  irec = -1	! user supplied
	  userfl = .true.
	  INQUIRE(FILE=filename(1:ln),defaultfile='.usrpdf',
	1	exist=flag,name=filename)
	  ln = lench(filename)
	  IF (.not. FLAG) THEN
	    Write (lo,'(2A)') ' User PDF file not found:',
	1		filename(:lench(filename))
	    ln = 0
	    goto 170
	  ENDIF
	  goto 94
	ELSEIF (.not. PROMPT) THEN
C default in batch is FULL
	  iopt = 0
	ELSE
!	  write(lo,'(/A)') ' Select a starting subfile:'
	  j = max_sub+3
	  ln = lench(sublbl(j))
	  write(lo,162)  0,sublbl(j)(:ln),' [default]'
	  DO J=1,max_sub
	    ln = lench(sublbl(j))
	    IF (SUBREC(j) .gt. 0 .and. j .gt. 9) THEN
	      write(lo,163)  j,sublbl(j)(:ln),' subfile'
	    ELSEIF (SUBREC(j) .gt. 0) THEN
	      write(lo,162)  j,sublbl(j)(:ln),' subfile'
	    ENDIF
162	    format(4x,'(',i1,')  ',2A)
163	    format(3x,'(',i2,')  ',2A)
	  ENDDO
	  j = max_sub+1
	  ln = lench(sublbl(j))
	  write(lo,163)  j,sublbl(j)(:ln),' subfile'
	  j = max_sub+2
	  ln = lench(sublbl(j))
	  write(lo,163)  j,sublbl(j)(:ln),' subfile'
	  write(lo,163)  -1,'Enter and display PDF entry(s) by number'
	  write(lo,'(A)') 
	1    '$Choose a subfiles by # from the list above [Default=0]: '
	  iopt = 0
	  read(lo,'(i)',err=170,end=3) iopt
	ENDIF
C----------------------------------------------------------------------
172	IF (iopt .eq. max_sub+2) THEN
C option to read a user defined subfile
	  write(lo,'(a)') ' ',
	1	' Enter the file name root (default type = .USRPDF)',
	2	'$or * for a list of *.USRPDF filenames: '
	  read (li,fmt='(q,a)',end=170) ln,filename
	  if (ln .le. 0) GOTO 170
	  if (filename(1:1) .eq. '*') then 
	    call lib$spawn('$ directory/nosiz/bri/notra *.usrpdf')
	    goto 172
	  endif
C does the file exist?
	  INQUIRE(FILE=filename(1:ln),defaultfile='.usrpdf',
	1	exist=flag,name=filename)
	  ln = lench(filename)
	  IF (.not. FLAG) THEN
	    Write (lo,'(2A)') ' User PDF file not found:',
	1		filename(:lench(filename))
	    goto 172
	  ENDIF
	  irec = -1
	  userfl = .true.
C----------------------------------------------------------------------
	ELSEIF (iopt .eq. max_sub+1) THEN
	  irec = -1
	  nullf = .true.
C----------------------------------------------------------------------
	ELSEIF (iopt .eq. 0) THEN
	  irec = -1
	  fullf = .true.
C----------------------------------------------------------------------
	ELSEIF (iopt .ge. 1 .and. iopt .le. max_sub .and. 
	1	SUBREC(iopt) .gt. 0) THEN
	  irec = SUBREC(iopt)
C----------------------------------------------------------------------
	ELSEIF (iopt .lt. 0) then 
C option to read and display a card
	  CALL TBLCLR(TABLE,N_Lwords,nphase)
	  WRITE(lo,'(a)') ' ',
	1	' Enter one ICDD-JCPDS entry number per line as'//
	1	' a single 5-6 digit ',' number (set#*10000+entry#)'//
	1	' or as 2 numbers (set#, entry#). ',
	2	' Enter a blank line when done.'
	  cnum = cnum + 1
	  context(cnum) = '! Starting with /CARDS=('
	  clen(cnum) = lench(context(cnum))
101	  WRITE(lo,'(a)') '$NUMBER> '
	  READ(li,'(2i6)',END=200,err=101) CARDNO,i
	  if (i .gt. 0) cardno = cardno*10000 + i
	  IF (CARDNO .eq. 0) GOTO 200
C is CARDNO a valid JCPDS number?
	  IF (CARDNO .lt. 100 .or. CARDNO/10000 .gt. N_SETNO) then
	    write (lo,'(A,i)') ' Invalid ICDD-JCPDS entry number: ',cardno
	    goto 101
	  ELSE
C lookup a sequence number
	    CALL CARDLOC(CARDNO,NAMREC,FULREC,DIREC,ISEQ,N_cards,LUNM,*2)
	  ENDIF
C set bit number ISEQ in TABLE
	  CALL BITSET(TABLE,ISEQ,N_cards,1)
	  if (clen(cnum) .gt. 53) then 
	    clen(cnum) = clen(cnum) + 2
	    context(cnum)(clen(cnum)-1:clen(cnum)) = ' -'
	    cnum = cnum + 1
	    context(cnum) = '    '
	    clen(cnum) = 4
	  endif
	  write(context(cnum)(clen(cnum)+1:),'(i6.6,a1)') CARDNO,','
	  clen(cnum) = clen(cnum) + 7
	  GOTO 101
200	  CALL TBLCOUNT(TABLE,N_Lwords,nphase)
	  context(cnum)(clen(cnum):clen(cnum)) = ')'
	  IF (NPHASE .eq. 0) goto 170
	  call BROWSE(gparm,*3)
	  return
C-------
C card was not found (pattern could be deleted)
2	  write (lo,'(A,i6)') ' Entry not in found in ICDD-JCPDS: ',
	1   CARDNO,' (Number not assigned or pattern has been deleted)'
	  goto 101
C----------------------------------------------------------------------
	ELSE
	  WRITE (lo,'(A)') ' Invalid option, try again'
	  ln = 0
	  goto 170
	ENDIF
C*************************************************************************
C go get the new table
C---- 
94	IF (irec .eq. -1 .and. userfl) then 
C   Read in the contents of filename into array TABLE, load in comments
	  OPEN(UNIT=IN,STATUS='OLD',FORM='UNFORMATTED',FILE=filename(1:ln),
	1	READONLY,SHARED,ERR=999)
	  write (lo,'(a)') ' Reading file: '//filename(1:ln)
	  READ(IN,err=998) NCARDS,NWORDS,(TABLE(i),i=1,MIN(N_Lwords,NWORDS))
	  READ(IN,err=91) cnum
	  do i=1,cnum
	    READ(IN,err=91) CLEN(i),CONTEXT(i)(1:CLEN(i))
	  enddo
91	  CLOSE(IN)
	  IF (N_Lwords .lt. NWORDS) THEN
	    Write (lo,*) 'ERROR: too many PDF entries on file:'
	1	//filename(1:ln),
	1	NCARDS,N_cards
	    Write (lo,*) '       is this really a .USRPDF file?'
	    goto 170
	  ELSEIF (NWORDS .lt. N_Lwords) THEN
	    DO I=NWORDS+1,N_Lwords
	      TABLE(i) = 0
	    ENDDO
	  ENDIF
	  IF (NCARDS .ne. N_cards) then
	    Write (lo,*) 
	1	'ERROR: # of entries on file does not match JCPDS-ICDD:'
	    Write (lo,*) '     '//filename(1:ln),NCARDS,N_cards
	    Write (lo,*) 
	1  '      File written with different version of ICDD-JCPDS data base',
	2	' Recreate this file using the following LOGIC commands:',' '
	    do i=1,cnum
	      type *,'   '//CONTEXT(i)(1:CLEN(i))
	    ENDDO
	    CALL PS_PAUSE(prompt)
	    goto 170
	  ENDIF
	  cnum = cnum + 1
	  context(cnum) = '!... (above read from file '//filename(1:ln)//')'
	  clen(cnum) = lench(context(cnum))
	  cnum = cnum + 1
	  IF (Deleted) then
	    context(cnum) = 'DELETED/INCLUDE'
	    clen(cnum) = lench(context(cnum))
	  ELSE
	    context(cnum) = 'DELETED/EXCLUDE'
	    clen(cnum) = lench(context(cnum))
	  ENDIF
	  GOTO 180
C---- 
	ELSEIF (irec .eq. -1 .and. fullf) then 
	  IF (.not. DELETED) THEN
	    OPEN (UNIT=IN,NAME='PS_BITMAP:misc.bitmap',STATUS='OLD',
	1	FORM='UNFORMATTED',ACCESS='DIRECT',READONLY,SHARED,
	1	err=961)
	    goto 962
961	    WRITE(lo,'(a)') 
	1	' TBLINIT ERROR opening PDF Subfile bitmap',
	1	' 	Deleted entries will not be removed'
	    DELETED = .true.
	  ENDIF
962	  IF (.not. DELETED) THEN
	    WRITE(LO,'(A)') ' ...Removing deleted entries'
C load the deleted entries
	    READ (IN,rec=DL_sub) (TABLE(I),i=1,N_Lwords)
C remove them from table 
	    CALL TBLnot(TABLE,TABLE,N_cards)
	    CLOSE(unit=IN)
	  ELSE
	    CALL TBLSET(TABLE,N_cards,nphase)
	  ENDIF
	  iopt = max_sub+3
C---- 
	ELSEIF (irec .eq. -1 .and. nullf) then 
	  CALL TBLCLR(TABLE,N_Lwords,NPHASE)
	  iopt = max_sub+1
C---- 
	ELSEIF (IREC .gt. 0) THEN
C Open and read from Subfile
	  OPEN (UNIT=IN,NAME='PS_BITMAP:MISC.BITMAP',STATUS='OLD',
	1	FORM='UNFORMATTED',ACCESS='DIRECT',READONLY,SHARED,
	1	err=971)
	  READ (IN,REC=irec,err=199)(TABLE(I),I=1,N_Lwords)
C check if this is the deleted subfile entry
	  IF (Irec .EQ. DL_sub .and. .NOT. DELETED) THEN
	    WRITE(LO,'(A)') 
	1	' Setting DELETED/ENABLE ... to use deleted entries'
	    DELETED = .true.
	  ELSEIF (.not. DELETED) THEN
	    WRITE(LO,'(A)') ' ...Removing deleted entries'
C load the deleted entries
	    READ (IN,rec=DL_sub) (TABLE2(I),i=1,N_Lwords)
C remove them from table 
	    CALL TBLnot(TABLE2,TABLE2,N_cards)
	    CALL TBLand(TABLE,TABLE2,TABLE,N_Lwords)
	  ENDIF
	  CLOSE (UNIT=IN)
	ELSE
	  WRITE(lo,'(A)') ' This should not happen'
	  GOTO 170
	ENDIF
C add history records
	cnum = cnum + 1
	IF (Deleted) then
	  context(cnum) = 'DELETED/INCLUDE'
	  clen(cnum) = lench(context(cnum))
	ELSE
	  context(cnum) = 'DELETED/EXCLUDE'
	  clen(cnum) = lench(context(cnum))
	ENDIF
	cnum = cnum + 1
	context(cnum) = 'READ/REPL/SUB='//subpdf(iopt)
	clen(cnum) = lench(context(cnum))
	context(cnum) = context(cnum)(:clen(cnum))//' !  '// sublbl(iopt)
	clen(cnum) = lench(context(cnum))
	IF (.not. DELETED) THEN
	  context(cnum) = context(cnum)(:clen(cnum))//' (w/o deleted)'
	  clen(cnum) = lench(context(cnum))
	ENDIF
	context(cnum) = context(cnum)(:clen(cnum))//' entries'
	clen(cnum) = lench(context(cnum))
C**********************************************************************
C  Count the number of bits in the table
180	CALL TBLCOUNT(TABLE,N_Lwords,nphase)
	WRITE(LO,100) nphase,N_cards
100	FORMAT(/,' The current table contains',i6,' entries, out of',I6)
	CALL PS_PAUSE(prompt)
3	RETURN
C*************************************************************************
C error opening misc bitmap file 
999	WRITE(lo,'(A)') ' Error opening file '//filename(1:ln)
	ln = 0
	goto 170
998	WRITE(lo,'(A)') ' Error reading file '//filename(1:ln)
	CLOSE(IN)
	ln = 0
	goto 170
199	WRITE(lo,'(A,i3)') ' Error reading SUBFILE file REC=',irec
	CLOSE(IN)
	STATUS = .false.
	RETURN
C error opening misc bitmap file 
971	WRITE(lo,'(a)') ' TBLINIT ERROR opening PS_BITMAP:MISC.BITMAP'
	fullf = .true.
	IREC = -1
	DELETED = .true.
	goto 94
	END
