C---------------------------------------------------------------------------
C	PDF1 ENCODE -- PART 3b   for the PDF-2 on DISK/CDROM 
C
C	Program for reading the PDF-1 JCPDS-ICDD NAME data file
C	to create the chemistry and the element count bitmap files.
C
C	            =================================
C	   Written by: Brian H. Toby	Oct-1990
C
C---------------------------------------------------------------------------
C logical name	  file	use           *** INPUT ***
C---------------------------------------------------------------------------
C PS_JCPDS	  DI.LIBRARY	output database file containing the D/I info
C 				for each card 1st record (updated)
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---------------------------------------------------------------------------
C logical name	  file	use          *** OUTPUT ***
C---------------------------------------------------------------------------
C PS_BITMAP	  CHEM.BITMAP	chemistry index 
C 		ELMCOUNT.BITMAP	index by number of elements
C---------------------------------------------------------------------------
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
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  BITMAP INFORMATION
	INTEGER*4 CHEM(104,max_words)
	INTEGER*4 ELCNT(MAX_ELEMC,max_words)

	INTEGER*4 ncrd,namcnt,start,dicnt1,dicnt

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

	CHARACTER*1   QUALTY
	CHARACTER*80  PFORM1
	CHARACTER*160 PNAME
	CHARACTER*80  MINNAM
	REAL FC

C!	BYTE          ELEM(201),LINE(414)
	logical*1          ELEM(201),LINE(414)
	INTEGER*2 NFORM,LCHN
	CHARACTER*300  FNAME

	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,104
	    CHEM(I,J) = 0
	  ENDDO
	  DO I=1,MAX_ELEMC
	    ELCNT(I,J) = 0
	  ENDDO
	ENDDO
	NPAT = 0
C---------------------------------------------------------------------------
C---------------------------------------------------------------------------
C Open the input file(s)
C---------------------------------------------------------------------------
	OPEN (UNIT=22,FILE='PS_JCPDS:DI.library',STATUS='OLD',
     1		FORM='UNFORMATTED',RECL=32,ACCESS='DIRECT')
C read the sizes from the file and write the actual value for MAX_ELEMC
	READ (22,rec=1) npat,nword,ncrd,max_sub,N_REGIONS
	WRITE (22,rec=1) npat,nword,ncrd,max_sub,N_REGIONS,MAX_ELEMC
	CLOSE(unit=22)
	OPEN (UNIT=22,FILE='PS_JCPDS:NAME.DIRECT',STATUS='OLD',
     1		FORM='UNFORMATTED',RECL=16,ACCESS='DIRECT',READONLY)
	OPEN (UNIT=24,FILE='PS_JCPDS:jcpds.INDEX',STATUS='OLD',
     1		FORM='UNFORMATTED',ACCESS='DIRECT',readonly,
     2		recl=4,recordtype='fixed')
C---------------------------------------------------------------------------
C---------------------------------------------------------------------------

C==========================================================================
C
C	... Begin reading the PDF-1 files.
C
	DO 100 IPAT=1,NPAT

	  READ (24,rec=IPAT) ncrd,namcnt,start,dicnt1
C get the NAME info from the entry
C ... if there is no name entry -- don't include any bitmap info
	  IF (namcnt .LE. 0) GOTO 100
C get the name information
	  call RDNAM(NAMcnt,22,QUALTY,FC,PFORM1,FNAME)
C------------------------------------------------------------------------
C now process the entry
C------------------------------------------------------------------------
C initialize the ICDD Processing routines (may not be necessary)
!	  CALL ONCE
C-----------------------------------------------------------------------
D	  type *,'Quality, I/Ic: ',QUALTY,FC
D	  type *,'Formula 1: ---',PFORM1(:lench(PFORM1)),'---'
D	  type *,'Name     : ---',FNAME(:lench(FNAME)),'---'
C-----------------------------------------------------------------------
C parse the chemical formula
	  CALL PARSELEM (PFORM1, ELEMS, NELEMS, CHECKLIST, STATUS)
	  IF(STATUS .NE. 0) THEN
	      write(*,*) 'ERROR FROM PARSELEM WITH ENTRY: ',ncrd
	      write (*,'(1x,2a)') ' Formula: ',PFORM1(:lench(Pform1))
	      write (*,'(1x,2a)') ' Name:    ',FNAME(:lench(FNAME))
	      GO TO 100
	  ENDIF
D	  write (*,*) PFORM1(:lench(PFORM1)),NELEMS,'ELEMENTS = '
D	1	,(ELEMS(J),j=1,NELEMS)
C-----------------------------------------------------------------------
C   Set the bit(s) for the subfile indices
	  IW=(IPAT-1)/32 + 1
	  IBT=MOD(IPAT-1,32)
C-------
C   Set the appropriate bit in the element count bitmap array
	  J = MIN(MAX_ELEMC,NELEMS+1)
	  ELCNT(J,IW)=IBSET(ELCNT(J,IW),IBT)
C-------
C   Set the appropriate bits in the chemistry arrays
	  DO J=1,104
	    IF (CHECKLIST(J)) THEN
	      CHEM(J,IW)=IBSET(CHEM(J,IW),IBT)
	      IF (J.GE.57.AND.J.LE.71) 
     1		CHEM(104,IW) = IBSET(CHEM(104,IW),IBT)
	      IF (J.EQ.104) THEN
	        DO K=57,71
	          CHEM(K,IW) = IBSET(CHEM(K,IW),IBT)
	        ENDDO
	      ENDIF
	    ENDIF
	  ENDDO
100	CONTINUE
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C close the name/D-space files
C-------------------------------------------------------------------------
	CLOSE (UNIT=24)
	CLOSE (UNIT=22)
C---------------------------------------------------------------------------
C WRITE OUT THE INDEX 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-------------------------------------------------------------------------
C file sizes are computed in blocks (512 bytes/block) 
C    using:  NPAT * Nbytes * nrec, where nrec is the # records/file
C-------------------------------------------------------------------------
C write the CHEMISTRY bitmap
	isize = 104. * npat / (8.*512.) + 1.5
	OPEN (UNIT=25,FILE='PS_BITMAP:CHEM.BITMAP',STATUS='NEW',
     1		FORM='UNFORMATTED',RECL=nword,RECORDTYPE='FIXED',
     2		initialsize=isize,extendsize=isize/10,USEROPEN=USEROPEN)
	DO I=1,104
	  WRITE (25) (CHEM(I,J),J=1,nword)
	ENDDO
	CLOSE (UNIT=25)

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

	WRITE(6,1602) NPAT
1602	FORMAT ('0Total patterns processed:',I6 //,
	1	' Number of patterns by element count')
C show a table of hits by element count
	DO I=1,MAX_ELEMC
	  NHITS = 0
	  DO 10 N=1,NWORD
	    NTABLE = elcnt(I,N)
	    IF (NTABLE.EQ.0) GO TO 10
	    IF (NTABLE.EQ.-1) then
	        NHITS = NHITS + 32
		GO TO 10
	    ENDIF
	    DO J=0,31
	      IF (IBITS(NTABLE,J,1).EQ.1) NHITS = NHITS + 1
	    ENDDO
10	  CONTINUE
	  WRITE(6,'(2I10)') I-1,nhits
	ENDDO
	STOP 'Normal End of Program'
	END
