C---------------------------------------------------------------------------
C	PDF1 ENCODE (PART 2) for the PDF-2 on DISK/CDROM 
C
C	Program for adding PDF-1 entries to the PDF-1 database
C	also updates the main index file,
C	and the subfile bitmap file
C
C	            =================================
C	   By: Brian H. Toby	Nov-1990
C
C---------------------------------------------------------------------------
C---------------------------------------------------------------------------
C logical name	  file	use           *** INPUT ***
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---------------------------------------------------------------------------
	IMPLICIT INTEGER*4 (A-Z)

	EXTERNAL USEROPEN

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 defined subfiles
	INTEGER MAX_SUB
	PARAMETER (max_sub=10)

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

C  BITMAP records
	INTEGER*4 MISC_OLD(max_sub,max_words)
	INTEGER*4 MISC(max_sub,max_words)
	INTEGER*4 ISUB(max_sub)
C
	INTEGER*4 ncrd,start,start1,ncrdold,ncrdnew,ncrdPREV
	INTEGER*4 dicnt1,dicnt,diold
	INTEGER*4 namcnt1,namcnt
	INTEGER*4 IW,WO,BT,BO
C
	CHARACTER*80  PFORM
	CHARACTER*160 PNAME
C
	BYTE          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
C
	PARAMETER (MAXOBS = 201)
	INTEGER*2    NDSP
	BYTE  	    IREL(MAXOBS)
	INTEGER*2    PDF2T(MAXOBS)
	REAL*4 INT(MAXOBS),D(MAXOBS),imax

	INTEGER*2    namrec(32)
	INTEGER*2    direc(64)
	LOGICAL FLAG,DTOPDF
	INTEGER	     STATUS
	LOGICAL moreold,morenew,gotold,gotnew
C---------------------------------------------------------------------------
C initialize the bitmaps and counter variables
	DO J=1,max_words
	  DO I=1,max_sub
	    MISC_OLD(I,J) = 0
	    MISC(I,J) = 0
	  ENDDO
	ENDDO
	NPAT = 0

C==========================================================================
C Open the input files
C---------------------------------------------------------------------------
	OPEN (UNIT=22,FILE='PS_JCPDS:NAME.DIRECT',STATUS='OLD',
     1		 FORM='UNFORMATTED',RECL=16,RECORDTYPE='FIXED',
     1		 access='direct')

	OPEN (UNIT=23,FILE='PS_JCPDS:DI.library',STATUS='OLD',
     1		FORM='UNFORMATTED',RECL=32,RECORDTYPE='FIXED',
     1		 access='direct')
	READ (23,rec=1) npat,nword,ncrd,max_old,N_REGIONS,MAX_ELEMC
	IF (MAX_OLD .gt. MAX_SUB) STOP 'previous MAX_SUB exceeds current'

	OPEN (UNIT=24,FILE='PS_JCPDS:jcpds.INDEX',STATUS='OLD',
     1		FORM='UNFORMATTED',ACCESS='SEQUENTIAL',
     2		recl=4,recordtype='fixed')
C---------------------------------------------------------------------------
C Open the output files
C---------------------------------------------------------------------------
C Read and then close the previous bitmap file
	OPEN (UNIT=25,FILE='PS_BITMAP:MISC.BITMAP',STATUS='OLD',
	1 FORM='UNFORMATTED',RECORDTYPE='FIXED')
	DO I=1,max_sub
	  read(25) (MISC_OLD(I,J),J=1,nword)
	ENDDO
	CLOSE (UNIT=25)
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 USEROPEN releases any extra space not needed,
C
	WRITE (*,'(A)') '$Enter approximate size of NAME file (blocks): '
	READ(*,'(I10)') isize
	OPEN (UNIT=32,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=33,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 (33) 0
	dicnt = 2
C
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=34,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==========================================================================
	moreold = .true.
	morenew = .true.
	gotold = .false.
	gotnew = .false.
	ncrdPREV = 100
	nnew = 0
	ipat = 0
	jpat = 0

100	DO WHILE(moreold .or. morenew)

C read an index record
	  IF (moreold .and. .not. gotold) THEN
	    ipat = ipat + 1
	    IF (ipat .gt. npat) THEN
	      moreold = .false.
	      gotold = .false.
	      goto 100
	    ELSE
	      READ (24,err=999) ncrdold,namold,start,diold
	      gotold = .true.
	    ENDIF
	  ENDIF

C read a new PDF-1 entry
	  IF (morenew .and. .not. gotnew) THEN
	    READ(5,*,end=200,err=190) ncrdnew
	    IF (ncrdnew .lt. 0) goto 200
D	    write (*,'(A,i6.6)') ' Processing new entry ',ncrdnew
	    READ(5,'(A)',end=201,err=190) PFORM
	    READ(5,'(A)',end=201,err=190) PNAME
C quality is not appropriate for a user entry
	    QUALTY = ' '
	    READ(5,'(i10,f10.2)',end=201,err=190) NDSP,FC
	    READ(5,*,end=200,err=190) (D(J),INT(J),J=1,NDSP)
	    READ(5,'(20i4)',end=201,err=190) (isub(j),j=1,max_sub)
	    nnew = nnew + 1
C   check for out of order new PDF-1 entries
	    IF (ncrdnew .le. ncrdPREV) THEN
	      WRITE (*,'(A,i6)') 
     1		' ERROR reading new PDF-1 entry number',nnew
	      IF (ncrdnew .le. 100) 
     1	STOP 'ADDPDF1 ERROR - input PDF1 card number is below 100'
	      write (*,'(A,i6.6,a,i6.6)') ' ERROR in PDF-1 input, card',
     1		ncrdnew,' follows ',ncrdPREV
	      STOP 'ADDPDF1 ERROR - input PDF1 cards are out of sequence'
	    ENDIF
C check that we can parse the chemical formula
	    CALL PARSELEM (PFORM, ELEMS, NELEMS, CHECKLIST, STATUS)
	    IF(STATUS .NE. 0) THEN
	      write(*,'(A,i6.6)') 
	1	'ERROR unable to parse formula in new entry',ncrdnew
	      write (*,'(1x,2a)') ' Formula: ',PFORM(:lench(Pform))
	      write (*,'(1x,2a)') ' Name:    ',PNAME(:lench(PNAME))
	      GO TO 100
	    ENDIF
	    gotnew = .true.
	  ENDIF

	  jpat = jpat + 1
C-----------------------------------------------------------------------
C----  write the new entry if:  ----------------------------------------
C    (1)  the new entry has a lower PDF number than the old
C    (2)  the new entry has the same PDF number as the old
C or (3)  there are only new entries
	  IF (gotnew .and. ((gotold .and. ncrdnew .le. ncrdold)
     1		.or. .not. gotold)) THEN
C  If the new entry has the same PDF number as the old, set GOTOLD to 
C  false, to skip over the old entry
	    IF (gotold .and. ncrdnew .eq. ncrdold) THEN 
	      WRITE (*,'(A,i7.6,a)') ' Warning: overiding PDF1 entry for'
     1		,ncrdnew,' with PDF-1 input'
	      GOTOLD = .false.
	    ENDIF
C flag that new entry has been processed
	    GOTNEW = .false.
C   process the D/I information
	    IMAX = INT(1)
	    DO J=1,NDSP
	      IMAX = MAX(IMAX,INT(J))
	    ENDDO
	    K = 0
	    DO J=1,NDSP
	      IREL(K+1) = 100. * INT(J)/IMAX
	      FLAG = DTOPDF(PDF2T(K+1),D(J))
	      IF (FLAG) THEN
	        K = K + 1
	      ELSE
	        WRITE (*,'(A,f10.3,a,i6.6)') ' Error: invalid d-space '
     1		,d(J),' for card ',ncrdnew
	      ENDIF
	    ENDDO
	    NDSP = K
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 (33) ndsp,(PDF2T(N),N=NB,NE),(IREL(N),N=NB,NE)
	        dicnt=dicnt+1
	        NB=NE+1
	      ENDDO
	    ELSE
	      dicnt1 = 0
	    ENDIF
C process the NAME records
C   convert the formula/name(s) from character to byte to prepare to 
C   write them on the NAMES file
	    IF (pform .eq. ' ') THEN
	      NFORM = 0
	      JB=10
	    ELSE
	      NFORM = LENCH(PFORM)
	      READ (PFORM,'(300a1)') (LINE(J),J=10,(NFORM+9))
	      JB=10+NFORM
	    ENDIF
	    CALL UPPER(PNAME)
	    LCHN = LENCH(PNAME)
	    READ (PNAME,'(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 compute the number of NAME records
	    NBYTES=9+NFORM+LCHN
	    NLINES=NBYTES/64
	    IF (MOD(NBYTES,64).NE.0) NLINES=NLINES+1
C write the NAME records
	    JE=0
	    namcnt1 = namcnt
	    DO NL=1,NLINES
	      JB=JE+1
	      JE=64*NL
	      WRITE (32) (LINE(J),J=JB,JE)
	      namcnt = namcnt + 1
	    ENDDO
C set bitmap entries
	    IW=(JPAT-1)/32 + 1
	    BT=MOD(JPAT-1,32)
	    DO I=1,MAX_SUB
	      IF (Isub(I) .le. max_sub .and. isub(i) .gt. 0) 
     1		MISC(Isub(I),IW)=IBSET(MISC(Isub(I),IW),BT)
	    ENDDO
C Always set the LOCAL bit
	    MISC(10,IW)=IBSET(MISC(10,IW),BT)
C write the index file record
	    start1 = 0
	    WRITE (34) ncrdnew,namcnt1,start1,dicnt1
	    NCRD = ncrdnew
	    ncrdPREV = ncrdnew
D	    WRITE(*,'(A,i6.6,3x,2i9)') ' Adding entry: ',ncrdnew,jpat
C-----------------------------------------------------------------------
C----  Otherwise: Write the old entry  ---------------------------------
	  ELSEIF (gotold) THEN
C flag that entry has been processed
	    GOTOLD = .false.
C copy DI record(s)
	    IF (diold .le. 0) THEN
	      dicnt1 = 0
	    ELSE
	      dicnt1 = dicnt
	      READ(23,REC=diold) (direc(k),k=1,64)
	      WRITE(33) (direc(k),k=1,64)
	      dicnt=dicnt+1
	      NUMD=direc(1)/42 - 1
	      IF ((MOD(direc(1),42)).NE.0) NUMD=NUMD+1
	      DO J=1,NUMD
	        diold = diold + 1
	        READ(23,REC=diold) (direc(k),k=1,64)
	        WRITE(33) (direc(k),k=1,64)
	        dicnt=dicnt+1
	      ENDDO
	    ENDIF
C copy NAME record(s)
	    IF (namold .gt. 0) THEN
	      namcnt1 = namcnt
	      READ(22,REC=namold) (namrec(k),k=1,32)
	      WRITE(32) (namrec(k),k=1,32)
	      namcnt=namcnt+1
	      NLINES=(8+namrec(1)+namrec(2))/64
	      DO J=1,NLINES
	        namold = namold + 1
	        READ(22,REC=namold) (namrec(k),k=1,32)
	        WRITE(32) (namrec(k),k=1,32)
	        namcnt=namcnt+1
	      ENDDO
	    ELSE
	      namcnt1 = 0
	    ENDIF
C copy bitmap entries
	    WO = (IPAT-1)/32 + 1
	    BO= MOD(IPAT-1,32)
	    IW=(JPAT-1)/32 + 1
	    BT=MOD(JPAT-1,32)
	    DO I=1,MAX_SUB
	      IF (IBITS(MISC_OLD(I,WO),BO,1).EQ.1)
	1		MISC(I,IW)=IBSET(MISC(I,IW),BT)
	    ENDDO
C write new index record
	    WRITE (34) ncrdold,namcnt1,start,dicnt1
	    NCRD = ncrdold
	    ncrdPREV = ncrdold
D	    WRITE(*,'(A,i6.6,3x,2i9)') ' Copying entry: ',ncrdold,ipat,jpat
C--------
	  ELSE
	    STOP 'ERROR -- this should not happen'
	  ENDIF
	ENDDO
C-----------------------------------------------------------------------

C------------------------------------------------------------------------
C close the name/D-space files
C-------------------------------------------------------------------------
	CLOSE (UNIT=22)
	CLOSE (UNIT=23)
	CLOSE (UNIT=24)
	CLOSE (UNIT=32)
	CLOSE (UNIT=33)
	CLOSE (UNIT=34)
C-------------------------------------------------------------------------
C------------------------------------------------------------------------
C record the number of entries as the first record on the DI file
	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 = (jpat-1)/32 + 1
	WRITE (23,rec=1) jpat,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 * Nbytes * nrec, where nrec is the # records/file

C write the SUBFILE bitmap
	isize = max_sub * jpat / (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(I,J),J=1,nword)
	ENDDO
	CLOSE (UNIT=25)

	WRITE(6,1602) JPAT
1602	FORMAT ('0Total patterns processed:',I6)
	STOP 'Normal End of Program'
C end of file on the PDF-1 input
200	WRITE (*,'(1x,i6,A)') nnew,' New PDF-1 entries were read'
	morenew = .false.
	gotnew = .false.
	GOTO 100
C Fatal ERRORS
201	WRITE (*,'(A,i6,A)') 
     1		' ERROR, unexpected end-of-file after reading ',nnew,
     1		' entries'
	GOTO 900
999	write (*,'(A)') 
     1	' ERROR reading or unexpected end-of-file on INDEX file'
	goto 900
190	write (*,'(A)') 
     1	' ERROR reading user supplied PDF-1 entries'
	goto 900
C remove new files
900	CLOSE(unit=32,disp='delete')
	CLOSE(unit=33,disp='delete')
	CLOSE(unit=34,disp='delete')
	STOP 'FATAL ERROR'
	END
