C---------------------------------------------------------------------------
C	PDF1 ENCODE (PART 1) for the PDF-2 on DISK/CDROM 
C
C	Program for reading the full JCPDS-ICDD data base and
C	creating the DI and NAME files with the main index file,
C	and the subfile bitmap file
C
C	            =================================
C	   By: Richard Harlow     1-Oct-1987
C	   Rewritten by: Brian H. Toby	Oct-1990
C
C	This program was derived in part from Mark Holomany's SEARCHTP
C	program which condensed parts of the full data base into an ASCII
C	file more suitable for search/match procedures.  Codes have also
C	been borrowed from Ray Goehner and Mary Garbauskas.  The logic
C	file concept used by subsequent search/match software asscoiated
C	with the files that are about to be created was taken from codes
C	written by Gerry Johnson and Richard Harlow for search/match
C	procedures on the NBS Crystal-data data base.  Discussions of the
C	approach used here have been held with Mary, Gerry, and Brian
C	Toby.
C---------------------------------------------------------------------------
C---------------------------------------------------------------------------
C logical name	  file(s)	use           *** OUTPUT ***
C---------------------------------------------------------------------------
C PS_JCPDS	  DI.LIBRARY	PDF-1 database file containing the D/I info
C 				for each card
C 		  NAME.DIRECT	PDF-1 database file with the composition/name 
C 				for each card
C 		  JCPDS.INDEX	index file, one record per JCPDS card
C
C PS_BITMAP	  MISC.BITMAP	bitmap index to special collections (NBS...)
C---------------------------------------------------------------------------
C logical name	  file	use           *** INPUT ***
C---------------------------------------------------------------------------
C PS_PDF2_CDROM  PDF-2 CDROM	device/filename for the JCPDS/ICDD data base
C   -- or --
C PS_PDF2_DISK	  disk PDF-2 	device/filename for the JCPDS/ICDD data base
C
C PS_PDF2_INDEX  PDF-2 misc	device/filename for the PDF2 support files
C					VAXPDF.BIN and CODENS.DAT
C
C -- optional-- 
C PS_PDF2_LOCAL  local PDF-2 	device/filename for the local PDF-2 data base
C---------------------------------------------------------------------------
	IMPLICIT INTEGER*4 (A-Z)

	EXTERNAL USEROPEN

	CHARACTER*8 CHTIME
	LOGICAL      LISTEM

	CHARACTER*80  BUFFER(135)
	logical flag,get_logical
	character*11 lgprc
	parameter (lgprc='lnm$process')
	character*80 file
	character*40 node,device,dir,name*60,type*20,ver*5
	integer*2 len_node,len_device,len_dir,len_name,len_type,len_ver
	INTEGER icddopt


	INCLUDE  'IORET.CMN'
	INCLUDE 'PDFDATA.CMN'
	INCLUDE 'CDROM.CMN'
C=======================================================================
	INCLUDE 'subfile.par'
C=======================================================================
C for most efficient use memory, keep the following number close to 
C the actual number of cards. 
	PARAMETER (max_cards = 80000)
	PARAMETER (max_words = max_cards/32 + 1)
C Number of records in element count bitmap file
	PARAMETER (max_ELEMC = 10)
C Number of records in the D-space BITMAP file
	PARAMETER (N_REGIONS=262)
C N.B. N_REGIONS is not used directly in this program
C  BITMAP INFORMATION
	INTEGER*4 MISC(max_words,max_sub)
C
	INTEGER*4 ncrd,start
	INTEGER*4 dicnt1,dicnt
	INTEGER*4 namcnt1,namcnt

	logical LOCAL,CDROM,DISK,SKIPDEL,DELETED,USEDEL

	LOGICAL*1     CHECKLIST(104)
	CHARACTER*2   ELEMS(25)
	INTEGER       NELEMS

	CHARACTER*80  PFORM1
	CHARACTER*80  PFORM2
	CHARACTER*160 PNAME
	CHARACTER*80  MINNAM

	BYTE          ELEM(201),LINE(414)
	EQUIVALENCE (LINE(1),NFORM),(LINE(3),LCHN),(LINE(5),QUALTY),
     1           (LINE(6),FC)
	INTEGER*2 NFORM,LCHN
	CHARACTER*1   QUALTY
	REAL*4 FC

	CHARACTER*300  FNAME

	PARAMETER (MAXOBS = 201)
	BYTE  	    IREL(MAXOBS)
	INTEGER*2    PDF2T(MAXOBS)
	INTEGER*2    NDSP
	INTEGER	     STATUS
C---------------------------------------------------------------------------
C initialize the RET3 routines
	CALL INITRET3(STATUS)
C initialize the bitmaps and counter variables
	DO J=1,max_words
	  DO I=1,max_sub
	    MISC(J,I) = 0
	  ENDDO
	ENDDO
	NPAT = 0

	NCRDprev = -1
C Debug option -- causes cards to be displayed as processed
	LISTEM=.FALSE.
C DISK/CDROM variables
	START = 0
	OFFSET_BYTE = 0
	STARTING_BYTE = 0
C output options: ignore deleted patterns completely 
C                                     (SKIPDEL = .true.)
C OR: index them, but don't include D/I's in the PDF-1 
C                                     (SKIPDEL = USEDEL = .false.)
C OR: index them and include D/I's in the PDF-1 
C                                     (SKIPDEL = .false., USEDEL = .true.)
	SKIPDEL = .true.
	USEDEL = .false.
	WRITE(*,'(A,$)') 
     1		' Include DELETED patterns in the PDF-1? (Y/[N]): '
	READ(*,'(A1)') ians
	IF (IANS .eq. 'y' .OR. IANS .eq. 'Y') THEN
	  SKIPDEL = .false.
	  WRITE(*,'(A,$)') 
     1     ' Include D/I info for DELETED patterns in PDF-1? (Y/[N]): '
	  READ(*,'(A1)') ians
	  IF (IANS .eq. 'y' .OR. IANS .eq. 'Y') USEDEL = .true.
	ENDIF
C version for ICDD Headquarters:
!	WRITE(*,'(A)') 
!     1		' Enter processing option: ',
!     1		' 	0 Process all patterns',
!     1		' 	1 Process Inorganic patterns only',
!     1		' 	2 Process Minerals patterns only',
!     1		'$	3 Process Metals/Alloys patterns only'
!	READ(*,'(I1)',err=123) icddopt
!123	IF (icddopt .eq. 1) THEN
!	  WRITE(*,'(A)') ' Process Inorganic patterns only'
!	ELSEIF (icddopt .eq. 2) THEN
!	  WRITE(*,'(A)') ' Process Minerals patterns only'
!	ELSEIF (icddopt .eq. 3) THEN
!	  WRITE(*,'(A)') ' Process Metals/Alloys patterns only'
!	ELSE
!	  WRITE(*,'(A)') ' Process all patterns'
!	ENDIF

C---------------------------------------------------------------------------
C---------------------------------------------------------------------------
C Open the input file(s)
C---------------------------------------------------------------------------
C Try to open the PDF-2 on disk, then try the CDROM
	  OPEN (UNIT=20,FILE='PS_PDF2_DISK:',defaultfile='JCPDS.DIRECT',
     1		FORM='FORMATTED',ERR=191,STATUS='OLD',
     2		RECL=80,SHARED,READONLY)
	  DISK = .true.
	  WRITE (*,'(/A/)') ' Reading from the PDF-2 on DISK'
	  inquire(unit=20,name=file)
	  write (*,'(2A)') ' file: ',file(:lench(file))
	  goto 200
C Disk was not successful, try the CDROM
C ...get the definition of PS_PDF2_CDROM
191	flag = get_logical('PS_PDF2_CDROM',file,80,ln,lgprc)
C ...fill in unspecified fields with PDF2.DAT
	if (flag) then
	  call fparse(file,node,len_node,device,len_device,
     1		dir,len_dir,name,len_name,type,len_type,ver,len_ver)
	  if (name(:len_name) .eq. ' ') then
	    name = 'pdf2'
	    len_name = 4
	  endif
	  if (type(:len_type) .eq. ' ') then
	    type = '.dat'
	    len_type = 4
	  endif
	  file = device(:len_device)//dir(:len_dir)
     1		//name(:len_name)//type(:len_type)
	else
C no logical name specified
	  file = 'pdf2.dat'
	endif
C	...Open files and perform initialization
	CALL CDOPEN (FILE, CDROM_CHAN, CDROM_SBLK, CDROM_FSIZE, ierr)
	IF(ierr .NE. 0) THEN
	  WRITE(6,1611)
1611	  FORMAT(//'<<< UNABLE TO OPEN THE PDF-2 ON CDROM or DISK >>>'//)
	  STOP 'ERROR -- NO JCPDS PDF-2 FILE'
	ELSE
	  CDROM = .true.
	  DISK = .FALSE.
	  WRITE (*,'(/A/)') ' Reading from the PDF-2 on CDROM'
	ENDIF
C---------------------------------------------------------------------------
C Open the local PDF-2 file, if one exists
200	LOCAL = .false.
	OPEN (UNIT=21,FILE='PS_PDF2_LOCAL:',defaultfile='LOCAL.JCPDS',
     1		FORM='FORMATTED',ERR=1000,STATUS='OLD',
     2		RECL=80,SHARED,READONLY)
	inquire(unit=21,name=file)
	write (*,'(2A)') ' Opening local file: ',file(:lench(file))
	LOCAL = .true.
1000	continue
C---------------------------------------------------------------------------
C---------------------------------------------------------------------------
C Open the output files
C---------------------------------------------------------------------------
C The advantage of having an INITIALSIZE in the OPEN to specify the size 
C is that potential fragmentation is reduced by grabbing contiguous blocks
C wherever possible, this results in the fastest possible read access.
C Choosing actual cylinder addresses for optimum file placement could 
C be even faster but ...)
C
	WRITE (*,'(A)') '$Enter approximate size of NAME file (blocks): '
	READ(*,'(I10)') isize
	OPEN (UNIT=22,FILE='PS_JCPDS:NAME.DIRECT',STATUS='NEW',
     1		 FORM='UNFORMATTED',RECL=16,RECORDTYPE='FIXED',
     2		initialsize=isize,extendsize=1000,USEROPEN=USEROPEN)
	namcnt = 1

	WRITE (*,'(A)') '$Enter approximate size of DI file (blocks): '
	READ(*,'(I10)') isize
	OPEN (UNIT=23,FILE='PS_JCPDS:DI.library',STATUS='NEW',
     1		FORM='UNFORMATTED',RECL=32,RECORDTYPE='FIXED',
     2		initialsize=isize,extendsize=2000,USEROPEN=USEROPEN)
C skip over the first record, which will be used later
	WRITE (23) 0
	dicnt = 2

C estimate the size of the index file based on MAX_cards. This 
C will be an overestimate.
C
	isize = max_cards * 16. / 512 + 5.
	OPEN (UNIT=24,FILE='PS_JCPDS:jcpds.INDEX',STATUS='NEW',
     1		FORM='UNFORMATTED',ACCESS='SEQUENTIAL',
     2		recl=4,recordtype='fixed',
     3	initialsize=isize,extendsize=isize/10,USEROPEN=USEROPEN)
C==========================================================================
C
C	... Begin production of PDF-1 files.
C
C set location to read the initial PDF-2 data
	IF (LOCAL) THEN
	  PDFDAT = 21
	ELSE
	  PDFDAT = 20
	ENDIF
C------------------------------------------------------------------------
100	DO WHILE (LOCAL .OR. CDROM .OR. DISK)

C	Read then next entry from the appropriate file
	  IF (LOCAL) THEN
C-----
	    STARTING_BYTE = STARTING_BYTE + OFFSET_BYTE
	    START = -(STARTING_BYTE/80) - 1
	    CALL GETPAT_DISK(STARTING_BYTE,BUFFER,OFFSET_BYTE,STATUS)
	    IF(STATUS .EQ. 1) GOTO 102
C if we hit an end-of-file we are done
	    IF(STATUS .EQ. 3) THEN
	      WRITE (*,'(A)') ' END OF FILE on Local database'
	      LOCAL = .false.
	      PDFDAT = 20
	      OFFSET_BYTE = 0
	      STARTING_BYTE = 0
	      GOTO 100
	    ELSEIF(STATUS .EQ. 5) THEN
	      WRITE (*,'(A)') ' I/O ERROR Reading from the Local database'
	      LOCAL = .false.
	      PDFDAT = 20
	      OFFSET_BYTE = 0
	      STARTING_BYTE = 0
	      GOTO 100
	    ENDIF
C-----
	  ELSEIF (CDROM) THEN
	    STARTING_BYTE = STARTING_BYTE + OFFSET_BYTE
	    START = STARTING_BYTE/80 + 1
	    CALL GETPAT_CD(STARTING_BYTE,BUFFER,OFFSET_BYTE,STATUS)
C is the next record within the length of the file?
	    IF ((STARTING_BYTE+OFFSET_BYTE)/512 .GT. CDROM_FSIZE/512) THEN
	      CDROM = .false.
	    ENDIF
	    IF(STATUS .EQ. 1) GOTO 102
C-----
	  ELSEIF (DISK) THEN 
	    STARTING_BYTE = STARTING_BYTE + OFFSET_BYTE
	    START = STARTING_BYTE/80 + 1
	    CALL GETPAT_DISK(STARTING_BYTE,BUFFER,OFFSET_BYTE,STATUS)
	    IF(STATUS .EQ. 1) GOTO 102
C if we hit an end-of-file we are done
	    IF(STATUS .EQ. 3) THEN
	      WRITE (*,'(A)') ' END OF FILE on DISK database'
	      DISK = .false.
	      GOTO 100
    	    ENDIF
	    IF(STATUS .EQ. 5) THEN
	      WRITE (*,'(A)') ' I/O ERROR Reading from the Disk database'
	      STOP 'ERROR -- This should not happen'
	    ENDIF
C-----
	  ELSE
	    STOP 'ERROR 1 -- This should not happen'
	  ENDIF
C------------------------------------------------------------------------
C now process the entry
C------------------------------------------------------------------------
C  get the card and set number for this entry
	  read (buffer(1)(73:78), '(I2,I4)')  set, number
C transfer the entry from the buffer to the production arrays
	  CALL READBF (BUFFER, OFFSET_BYTE, READBF_STATUS)
	  IF(READBF_STATUS .NE. 0) then
	    write(*,'(A,i2.2,i4.4)') ' *** READBF ERROR: ',set,number
102	    write (*,'(1x,a)') '*** Error reading AIDS entry: '
     1		,(BUFFER(j),j=1,OFFSET_BYTE/80)
	    goto 100
	  ENDIF
	  STATUS = 0
C initialize the ICDD Processing routines (may not be necessary)
	  CALL ONCE
C-------
C check the integrity of the database
	  READ(CARD1(1)(73:78),'(i6)') NCRD
	  IF (NCRD .eq. NCRDprev) then 
	    write (*,*) 'REPEATED CARD NUMBER: ',NCRD,' at ',NPAT+1
	    GOTO 100
	  ELSEIF(NCRD .lt. NCRDprev) then
	    WRITE (*,'(A,i6.6,a,i6.6)') 
     1    'Incorrect order of input cards: ',NCRD,' follows ',NCRDprev
	    STOP 'PROGRAM STOPPING -- DISASTER'
	  ENDIF
	  NCRDprev = NCRD
C-------
C IS ENTRY FLAGGED AS "DELETED"?
C   handle deleted patterns -- either skip them entirely (if SKIPDEL is TRUE)
C   or process, but flag as deleted
	  IF (CARD1(1)(72:72).NE.'P') THEN
D!	    type *,'DELETED PATTERN: ',CARD1(1)(73:78),
D!	1	' code = ',CARD1(1)(72:72)
	    IF (SKIPDEL) GO TO 100
	    DELETED = .true.
C does the pattern have a name, a chemical formula and d-spaces? 
C Skip deleted patterns which do not.
	    IF ((NUMC(7).LE.0 .and. NUMC(6) .EQ. 0) .or.
     1			NUMC(18).LE.0) goto 100
	  ELSE
	    DELETED = .false.
	  ENDIF
C-----------------------------------------------------------------------
C test for ICDD subfile
!	  IF (icddopt .eq. 1) THEN
!	    IF (CARD5(1)(1:1).NE.'I') GOTO 100
!	  ELSEIF (icddopt .eq. 2) THEN
!	    IF (CARD5(1)(3:3).NE.'M') GOTO 100
!	  ELSEIF (icddopt .eq. 3) THEN
!	    IF (CARD5(1)(4:4).NE.'A') GOTO 100
!	  ENDIF
C-----------------------------------------------------------------------
C	GET THE FORMULA, CHEMICAL NAME, PATTERN QUALITY
C reject patterns without a formula or name
	  CALL GETNAME (QUALTY,PFORM1,PFORM2,PNAME,MINNAM,FC,STATUS)
	  IF(STATUS .EQ. 10) THEN
	    write(*,*) 'GETNAME WARNING FOR ENTRY: ',CARD1(1)(73:78)
D!	  write (*,'(1x,a)') 	(BUFFER(j),j=1,OFFSET_BYTE/80)
	  ELSEIF(STATUS .EQ. 3) THEN
D!	    write(*,*) 'GETNAME WARNING: no name for: ',CARD1(1)(73:78)
	    GO TO 100
	  ELSEIF(STATUS .EQ. 4) THEN
	    write(*,*) 'GETNAME WARNING: no formula for: '
	1	,CARD1(1)(73:78)
C	    GO TO 100
	  ELSEIF(STATUS .NE. 0) THEN
	    write(*,*) 'GETNAME PROCESSING ERROR FOR ENTRY: ',
	1	CARD1(1)(73:78)
	    GO TO 100
	  ENDIF
D!	  type *,'Quality, I/Ic: ',QUALTY,FC
D!	  type *,'Formula 1: ---',PFORM1(:lench(PFORM1)),'---'
D!	  type *,'Formula 2: ---',PFORM2(:lench(PFORM2)),'---'
D!	  type *,'Name     : ---',PNAME(:lench(PNAME)),'---'
D!	  type *,'Min. Name: ---',MINNAM(:lench(MINNAM)),'---'

C parse the chemical formula -- check that it can be read properly
	  CALL PARSELEM (PFORM1, ELEMS, NELEMS, CHECKLIST, STATUS)
	    IF(STATUS .NE. 0) THEN
	      write(*,*) 'ERROR FROM GETELEM WITH ENTRY: ',CARD1(1)(73:78)
	      write (*,'(1x,2a)') ' Formula: ',PFORM1(:lench(Pform1))
D!	  write (*,'(1x,a)') 	(BUFFER(j),j=1,OFFSET_BYTE/80)
	      GO TO 100
	    ENDIF
C-----------------------------------------------------------------------
C extract the d-spaces from the entry
	  IF ((.NOT. DELETED) .or. USEDEL) THEN 
	    CALL GETDI (PDF2T,IREL,ndsp,STATUS)
	    IF(STATUS .NE. 0) THEN
	      write(*,*) 'ERROR FROM GETDI WITH ENTRY: ',CARD1(1)(73:78)
	      GO TO 100
	    ENDIF
	  ELSE
	    NDSP = 0
	  ENDIF

C-----------------------------------------------------------------------
C Entry has been accepted
	  NPAT = NPAT + 1
	  if (NPAT .gt. max_cards) stop 
     1		'PROGRAM DIMENSIONS EXCEEDED: Increase MAX_CARDS'
C-------
C Print status messages
	  IF (LISTEM) write(*,*) NPAT,': ',CARD1(1)(73:78)
	  IF(MOD(NPAT,1000) .EQ. 0  .AND.  (.NOT. LISTEM) ) THEN
	    CALL TIME (CHTIME)
	    write(*,*) NPAT,'. ',CARD1(1)(73:78),'   ',CHTIME
	  ENDIF
C-----------------------------------------------------------------------
C   Set the bit(s) for the subfile indices
	  IW=(NPAT-1)/32 + 1
	  IBT=MOD(NPAT-1,32)
C Inorganic (In_sub) 
	  IF (CARD5(1)(1:1).EQ.'I') 
	1	MISC(IW,IN_sub)=IBSET(MISC(IW,IN_sub),IBT)
C Organic (Or_sub) 
	  IF (CARD5(1)(2:2).EQ.'O') 
	1	MISC(IW,or_sub)=IBSET(MISC(IW,or_sub),IBT)
C Minerals (Mn_sub) 
	  IF (CARD5(1)(3:3).EQ.'M') 
	1	MISC(IW,Mn_sub)=IBSET(MISC(IW,Mn_sub),IBT)
C Alloy/Metal/Intermetallic (MA_sub) 
	  IF (CARD5(1)(4:4).EQ.'A') 
	1	MISC(IW,MA_sub)=IBSET(MISC(IW,MA_sub),IBT)
C Deleted entries -- no deleted entries in CD (DL_sub) 
	  IF (DELETED) MISC(IW,DL_sub)=IBSET(MISC(IW,DL_sub),IBT)
C Local entries (LC_sub) 
	  IF (LOCAL) MISC(IW,LC_sub)=IBSET(MISC(IW,LC_sub),IBT)
	  DO J=1,NUMC(5)
	    DO IB=6,22,4
	      IE=IB+2
C Common Phases (Cp_sub) 
	      IF (CARD5(j)(IB:IE).EQ.'CP ') THEN
	        MISC(IW,Cp_sub)=IBSET(MISC(IW,Cp_sub),IBT)
	      ELSEIF (CARD5(j)(IB:IE).EQ.' CP') THEN
	        MISC(IW,Cp_sub)=IBSET(MISC(IW,Cp_sub),IBT)
C NIST [NBS] (NB_sub)
	      ELSEIF (CARD5(j)(IB:IE).EQ.'NBS') THEN 
	        MISC(IW,NB_sub)=IBSET(MISC(IW,NB_sub),IBT)
C Forensics (FO_sub) 
	      ELSEIF (CARD5(j)(IB:IE).EQ.'FOR') THEN
	        MISC(IW,FO_sub)=IBSET(MISC(IW,FO_sub),IBT)
C Zeolites (Ze_sub) 
	      ELSEIF (CARD5(j)(IB:IE).EQ.'ZEO') THEN
	        MISC(IW,Ze_sub)=IBSET(MISC(IW,Ze_sub),IBT)
C Superconductors (SC_sub) 
	      ELSEIF (CARD5(j)(IB:IE).EQ.'SCM') THEN
	        MISC(IW,SC_sub)=IBSET(MISC(IW,SC_sub),IBT)
C Explosives (EX_sub) 
	      ELSEIF (CARD5(j)(IB:IE).EQ.'EXP') THEN
	        MISC(IW,EX_sub)=IBSET(MISC(IW,EX_sub),IBT)
C Educational (ED_sub) 
	      ELSEIF (CARD5(j)(IB:IE).EQ.'EDU') THEN
	        MISC(IW,ED_sub)=IBSET(MISC(IW,ED_sub),IBT)
C Cement (CM_sub) 
	      ELSEIF (CARD5(j)(IB:IE).EQ.'CEM') THEN
	        MISC(IW,CM_sub)=IBSET(MISC(IW,CM_sub),IBT)
C Corrosion subgroup (COR_sub) 
	      ELSEIF (CARD5(j)(IB:IE).EQ.'COR') THEN
	        MISC(IW,COR_sub)=IBSET(MISC(IW,COR_sub),IBT)
C Unassigned -- warn
	      ELSEIF (CARD5(j)(IB:IE).ne.'   ') THEN
	        write(*,*) 'unexpected subfile for entry ',
	1	CARD1(1)(73:78),j,':  ',CARD5(j)(IB:IE)
	      ENDIF
	    ENDDO
	  ENDDO
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C convert the formula/name(s) from character to byte and write them on 
C the NAMES file
	  IF (PFORM1 .eq. ' ') THEN
	    NFORM = 0
	    JB=10
	  ELSE
	    NFORM = LENCH(PFORM1)
	    READ (PFORM1,'(300a1)') (LINE(J),J=10,(NFORM+9))
	    JB=10+NFORM
	  ENDIF
	  CALL UPPER(PNAME)
	  IF (DELETED) THEN 
	    FNAME = '(Deleted) '//PNAME
	  ELSE
	    FNAME = PNAME
	  ENDIF
	  LCHN = LENCH(FNAME)
	  IF (MINNAM .ne. ' ') THEN
	    CALL UPPER(MINNAM)
	    FNAME(LCHN+1:) = ' / '//MINNAM
	    LCHN = LENCH(FNAME)
	  ENDIF
	  READ (FNAME,'(300a1)') (LINE(J),J=JB,(JB+LCHN-1))
C zero out the rest of the record
	  DO i=JB+LCHN,414
	    LINE(I) = 0
	  ENDDO

C-----------------------------------------------------------------------
C compute the number of NAME records and write them
	  NBY=9+NFORM+LCHN
	  NLINES=NBY/64
	  IF (MOD(NBY,64).NE.0) NLINES=NLINES+1
	  JE=0
	  namcnt1 = namcnt
	  DO NL=1,NLINES
	    JB=JE+1
	    JE=64*NL
	    WRITE (22) (LINE(J),J=JB,JE)
	    namcnt = namcnt + 1
	  ENDDO
C-----------------------------------------------------------------------
C compute the number of D/I records and write them
	  IF (NDSP .GT. 0) THEN 
	    NUMD=NDSP/42
	    IF ((MOD(ndsp,42)).NE.0) NUMD=NUMD+1
	    NB=1
	    dicnt1 = dicnt
	    DO I=1,NUMD
	      NE=NB+41
	      WRITE (23) ndsp,(PDF2T(N),N=NB,NE),(IREL(N),N=NB,NE)
	      dicnt=dicnt+1
	      NB=NE+1
	    ENDDO
	  ELSE
	    dicnt1 = 0
	  ENDIF
C-----------------------------------------------------------------------
C write the index file record
D!	WRITE (*,*) 'index: ',ncrd,namcnt1,start,dicnt1
	  WRITE (24) ncrd,namcnt1,start,dicnt1
C NB: a Negative START value indicates an entry in the local PDF-2 database
C     if dicnt1 is 0, there is no D/I entry for this card
C     if namcnt1 is 0, there is no name entry for this card (not implemented)
C
C for debug, end early
D	IF (NPAT .le. 5) THEN
D	  type *,'index: ',ncrd,namcnt1,start,dicnt1
D	  type *,'Quality, I/Ic: ',QUALTY,FC
D	  type *,'Formula 1: ---',PFORM1(:lench(PFORM1)),'---'
D	  type *,'Name     : ---',PNAME(:lench(PNAME)),'---'
D	  type *,'Min. Name: ---',MINNAM(:lench(MINNAM)),'---'
D	ENDIF
D	  IF (NPAT .gt. 2000) THEN
D	      CDROM = .false.
D	      DISK = .false.
D	      LOCAL = .false.
D	  ENDIF
	ENDDO
C------------------------------------------------------------------------
C close the name/D-space files
C-------------------------------------------------------------------------
	CLOSE (UNIT=21)
	CLOSE (UNIT=20)
	CLOSE (UNIT=24)
	CLOSE (UNIT=22)
C-------------------------------------------------------------------------
C------------------------------------------------------------------------
C record the number of entries as the first record on the DI file
	CLOSE(unit=23)
	OPEN (UNIT=23,FILE='PS_JCPDS:DI.library',STATUS='OLD',
     1		FORM='UNFORMATTED',RECL=32,ACCESS='DIRECT')
C compute the number of words needed to store the bitmaps
	nword = (npat-1)/32 + 1
	WRITE (23,rec=1) npat,nword,ncrd,max_sub,N_REGIONS,MAX_ELEMC
	CLOSE (UNIT=23)
C-------------------------------------------------------------------------
C	WRITE OUT THE BITMAP INDEX FILE
C-------------------------------------------------------------------------
C file sizes are computed in blocks (512 bytes/block) 
C    using:  NPAT * # bytes * nrec, where nrec is the # records/file

C write the SUBFILE bitmap
	isize = max_sub * npat / (8.*512.) + 2.5
	OPEN (UNIT=25,FILE='PS_BITMAP:MISC.BITMAP',STATUS='NEW',
	1 FORM='UNFORMATTED',RECL=nword,RECORDTYPE='FIXED',
	2 initialsize=isize,extendsize=isize/10,USEROPEN=USEROPEN)
	DO I=1,max_sub
	  WRITE (25) (MISC(J,I),J=1,nword)
	ENDDO
	CLOSE (UNIT=25)

	WRITE(6,1602) NPAT
1602	FORMAT ('0Total patterns processed:',I6,//,
	1	' Number of patterns by subfile number')
	DO I=1,MAX_SUB
	  CALL TBLCOUNT(MISC(1,I),nword,J)
	  IF (J .gt. 0) type *,I,J
	ENDDO
	STOP 'Normal End of Program'
	END
