C---------------------------------------------------------------------------
C
C	Program to copy the JCPDS from CDROM to a disk file 
C
C	            =================================
C optionally removes deleted patterns while copying
C
C	   By: Brian Toby (Nov 1988)
C
C-------------------------------------------------------------------------
	IMPLICIT INTEGER (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

 	INCLUDE  'CDROM.CMN'
!	INCLUDE 'PDFDATA.CMN'
!	INCLUDE 'PDFDATA.init'

C The next number determines the amount of space requested by the
C program. The assumption used is -- grab lots of space and release
C the unused portions -- so that the file is mostly contiguous. It does
C assume that you do have plenty of extra space on your disk...
	integer max_siz
	logical deltf
C

	INCLUDE '($FORIOSDEF)/nolist'
	WRITE (*,'(A)') ' ','$Enter T to include deleted patterns: (T/F)? '
	read(*,'(L1)') deltf
	WRITE (*,'(A)') '$Enter the approximate size of file (blocks): '
	read(*,'(I10)') max_siz

	WRITE (*,'(A)') ' ',' Copy from the PDF-2 on CDROM to disk'
C
C	...Open files and perform initialization
C	... Open cdrom file

C ...get the definition of PS_PDF2_CDROM
	flag = get_logical('PS_PDF2_CDROM',file,80,ln,lgprc)
	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
	CALL CDOPEN (FILE, CDROM_CHAN, CDROM_SBLK, CDROM_FSIZE,ierr)
	IF(ierr .NE. 0) 
	1	STOP '<<< UNABLE TO OPEN THE PDF-2 CD-ROM >>>'
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 would 
C be even faster but ...)
C
C	logical name	file(s)		use
C	------------	-------		---
C	PDF_2		JCPDS.LIBRARY	output database file 

	OPEN (UNIT=2,FILE='PS_PDF2_DISK:',defaultfile='JCPDS.DIRECT',
	1 FORM='FORMATTED',RECL=80,RECORDTYPE='FIXED',STATUS='NEW',
	1 CARRIAGECONTROL='none',
	2 initialsize=max_siz,extendsize=10000,USEROPEN=USEROPEN)

C =========================================================================
C
C	... Begin production of search files.
C
	NPAT = 0
	NPATD = 0
	NCRDL = -1
C read what should be the start of set of records
	NBYTES = 0
	STARTING_BYTE = 0
C---------------------------------------------------------------------------
100	STARTING_BYTE = STARTING_BYTE + NBYTES
C is the record within the length of the file?
	IF (STARTING_BYTE+511 .ge. CDROM_FSIZE) GOTO 9000
	CALL GETPAT_CD(STARTING_BYTE,BUFFER,NBYTES,STATUS)
	IF(STATUS .NE. 0) then
	  write (*,'(1x,a)') 'Error reading card(s): '
	1	,(BUFFER(j),j=1,NBYTES/80)
	  goto 100
	ENDIF
	NPATD = NPATD + 1

C  get the card and set number
	read (buffer(1)(73:78), '(I2,I4)')  set, number
C----------------------------------------------------------------------------

C	SKIP DELETED PATTERN
	IF (buffer(1)(72:72).NE.'P' .and. .not. deltf) THEN
D	  type *,'DELETED PATTERN: ',set,number
	  GO TO 100
	ENDIF

	READ(buffer(1)(73:78),'(i6)') NCRD
	IF (NCRD .eq. NCRDL) then 
	  write (*,*) 'REPEATED CARD NUMBER: ',NCRD,' at ',NPAT
	  GOTO 100
	ELSEIF(NCRD .lt. NCRDL) then
	  WRITE (*,*) 'Incorrect order of input cards: ',NCRD,
	1		' follows ',NCRDL
	  STOP 'PROGRAM STOPPING -- DISASTER'
	ENDIF
	NCRDL = NCRD

	NPAT = NPAT + 1

	write (2,'(a80)') (BUFFER(j),j=1,NBYTES/80)

	IF(NPAT/1000*1000 .EQ. NPAT) THEN
	   CALL TIME (CHTIME)
	   TYPE *,NPAT,'. ',buffer(1)(73:78),'   ',CHTIME
	ENDIF

	GO TO 100
C-------------------------------------------------------------------------
9000	CONTINUE

	CLOSE (UNIT=2)
	WRITE(6,1602) NPATd,npat
1602	FORMAT ('0Total patterns processed:',I6,' Retained patterns: ',i6)
	STOP ' '
	END
C=======================================================================
	INTEGER FUNCTION USEROPEN(FAB,RAB,LUN)
C=======================================================================
C
C User file open routine -- releases unused allocated space when the 
C file is closed by setting a bit in the RMS file definitions
C
C=======================================================================
	INCLUDE '($FABDEF)'
	INCLUDE '($RABDEF)'
	INCLUDE '($SYSSRVNAM)'
	RECORD /FABDEF/ FAB
	RECORD /RABDEF/ RAB
C set the "truncate at end-of-file" bit to release the extra space
	FAB.FAB$L_FOP = FAB.FAB$L_FOP .or. FAB$M_TEF
	USEROPEN = sys$create(FAB)
	IF (.not. USEROPEN) RETURN
	USEROPEN = sys$connect(RAB)
	RETURN	 
	END
