C*************************************************************************
	SUBROUTINE REPORT(dname,d_ln,sname,s_ln,lssname,lss_ln,wavel,
	1	bitmap,bitmap_ln,STATUS)
C*************************************************************************
C Subroutine to print a figure of merit for each selected pattern
C and to reduce the number of "hits" to a specifed number with the
C highest FOM.
C*************************************************************************
C
	include '[-.shared]jcpds.parms'
	include 'SEARCH.cmn'
	include 'SEARCH.par'
	character*(*) sname,lssname,dname,bitmap
	INTEGER ls_ln,s_ln,d_ln,bitmap_ln
	INTEGER STATUS

	INTEGER CLI$PRESENT
	LOGICAL flag,DTOTT,TTTOD,DTOPDF,PDFTOD,DTOIND,INDTOD
	LOGICAL PDFTOCU,CUTOPDF
	integer*2 sortinfo(5)/1,0,0,4,4/
	integer SOR$PASS_FILES,SOR$BEGIN_SORT,SOR$SORT_MERGE,SOR$END_SORT
	EXTERNAL DSC$K_DTYPE_F
	logical sortf,printf,graphf
	INTEGER*4 NAMREC,FULREC,DIREC,ISEQ,JCARD,ntable
	integer*4 jmatch,jmiss,NDSINT
	CHARACTER filename*80,QM*1
	INTEGER LN,LP
	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
	real peak
C---------------------------------------------------------------------------
	ltmp = 99
	LP = out
	PRINTF = .false.
	IF (CLI$PRESENT('PRINT')) PRINTF = .true.

	SORTF = .true.
	IF (NSORT .lt. 0) SORTF = .false.
	graphF = .false.
c----------------------------------------------------------------------
C if REDUCE has not been run first, read in the starting bitmap into TABLE1
C and then transfer to TABLE
34	IF (NSTEP .eq. 0) then
	  write (lo,'(A)') ' WARNING -- you are skipping the REDUCE '//
	1	'and MATCH steps'
	  IF (PROMPT) then
	    CALL GETbit(Nset,BITMAP,bitmap_ln,*3)
	    write(lo,'(A,i6,a)') ' The report will be computed for'
	1	,nph1,' cards'
	    write(lo,'(A)') '$Continue? ([Y]/N) '
	    read(li,'(a1)',end=3) ians
	    if (ians .eq. 'N' .or. ians .eq. 'n') goto 3
	  ENDIF
	  CALL TBLMOVE(TABLE1,TABLE,N_Lwords)
	  nphase = nph1
C if MATCH has not been run first, transfer TABLE2 to TABLE
	ELSEIF (NSTEP .eq. 1) then
	  write (lo,'(A)') ' WARNING -- you are skipping the MATCH step'
	  IF (PROMPT) then
	    write(lo,'(A,i6,a)') ' The report will be computed for'
	1	,nph2,' cards'
	    write(lo,'(A)') '$Continue? ([Y]/N) '
	    read(li,'(a1)',end=3) ians
	    if (ians .eq. 'N' .or. ians .eq. 'n') goto 3
	  ENDIF
	  CALL TBLMOVE(TABLE2,TABLE,N_Lwords)
	  nphase = nph2
	ENDIF

	if (nphase .eq. 0) then
	  TYPE *,'There are no cards left to search'
	  goto 3
	ENDIF

	write (lo,'(/,a,i6,a,i6,a)') 
	1	' *** REPORT step beginning.  Processing',nphase,
	2	' of',N_cards,' cards'

C if a diffractogram data file name has been defined, read in the raw data
	IF (d_ln .gt. 0) call GETDATA(dname,d_ln,*33)
C---------------------------------------------------------------------------
C compute usable peak positions in PDF units
	CALL USEPEAK

C---------------------------------------------------------------------------
	OPEN (UNIT=ltmp,NAME='PS_TMP:REPORT.TEMP',
	1	FORM='UNFORMATTED',err=921,
	2	TYPE='NEW',DISPOSE='DELETE',RECL=12,RECORDTYPE='FIXED')
	IPAGE = 0
	ICARDNO = 0 

	iline = 1
	IF (.not. (printf .or. sortf)) then
	  IF (PROMPT) then 
	    call ps_pause(prompt)
	    CALL TERASE(ICRT,lo,li)
	  ENDIF
	  IF (NPTS .eq. 0) then 
	    write(lo,141)
141	    FORMAT('  card #   mat/mis/tot   Overall   Intensity   Angle',
	1	'    I(O/J)')
	  ELSE
	    write(lo,142)
142	    FORMAT('  card #   mat/mis/tot   Overall   Intensity   Angle',
	1	'  Full-Pat    I(O/J)')
	 ENDIF
	else
	  if (prompt) write (lo,'(A)') ' preparing REPORT'
	endif

	DO 10 N=1,N_Lwords
	  NTABLE = TABLE(N)
	  IF (NTABLE.EQ.0) GOTO 10
	  DO 20 J=0,31
	    IF (IBITS(NTABLE,J,1).EQ.1) THEN
C	convert bit# and word# to seq#
	      ISEQ = 32*(N-1) + J + 1
C 	get record numbers from seq#
	      READ (LUNM,rec=ISEQ) JCARD,NAMREC,FULREC,DIREC
C	compute the FOM 
	      Q = 9.999e30
	      CALL FOM(DIREC,jmiss,jmatch,NDSINT,FOMI,FOMA,FOMF,AVEI,
	1	STATUS)
	      IF (.NOT. STATUS) GOTO 21
	      IF (NFOM .eq. 1 .or. FOMA .eq. 0) then 
		Q = FOMI * ((jmatch+jmiss)*1./jmatch)**2 
	1		 * numob*1./jmatch
	      ELSEIF (NFOM .eq. 2 .or. FOMI .eq. 0) then
		Q = FOMA * ((jmiss+jmatch)*1./jmatch)**2 
	1		 * SQRT(numob*1./jmatch)
	      ELSE
		Q = FOMA * FOMI * ((jmatch+jmiss)*1./jmatch)**2 
	1		 * SQRT(numob*1./jmatch)
	      ENDIF
21	      ICARDNO = ICARDNO + 1
		
	      WRITE(ltmp) JCARD,Q,jmiss,jmatch,NDSINT,FOMI,FOMA,FOMF,
	1	avei,namrec,ISEQ,DIREC
	      IF (.not. (printf .or. sortf .or. graphf)) then 
		IF (Q .ge. 9.999e30) then
		  WRITE(lo,131) JCARD,jmatch,jmiss,NDSINT
		ELSEIF (NPTS .eq. 0) then 
		  WRITE(lo,131) JCARD,jmatch,jmiss,NDSINT,Q,FOMI,FOMA,avei
		ELSE
		  WRITE(lo,131) JCARD,jmatch,jmiss,NDSINT,Q,FOMI,FOMA,fomf,avei
		ENDIF
131		FORMAT(' [',I6.6,']  ',i3,'/',i3,'/',i3,5f10.3)
C	get name info
		CALL READNAM(NAMREC,LUNN,QM,FCOR,CHFORM,LCHFORM,
	1	CHNAME,LCHNAME)
		WRITE(lo,132) (CHFORM(i),i=1,LCHFORM),' ','/',' ',
	1		(CHNAME(i),i=1,LCHNAME)
132		FORMAT(1x,72a1)
		iline = iline + 3 + (3+lchform+lchname)/72
		IF (ILINE .gt. 20 .and. prompt) THEN
		  write(lo,'(A1)') 
	1	    '$Next Page/Stop/Print report/Graph? ([N]/S/P/G): '
		  read(li,'(A)',end=3) ians
		  CALL TERASE(ICRT,lo,li)
		  iline = 0
		  IF (ians .eq. 'S' .or. ians .eq. 's') goto 1
		  IF (ians .eq. 'P' .or. ians .eq. 'p') then
		    printf = .true.
		    WRITE (lo,'(A,i5,a)') 
	1	'$Print report with all',nphase,' entries? (Y/[N]): '
	            read(li,'(A)',end=250) ians
		    IF (IANS .ne. 'y' .and. IANS .ne. 'Y') goto 250
		  ELSEIF (ians .eq. 'G' .or. ians .eq. 'g') then
		    graphf = .true.
		    WRITE (lo,'(A,i5,a)') '$Graph all',
	1		nphase,' entries? (Y/[N]): '
	            read(li,'(A1)',end=250) ians
		    IF (IANS .ne. 'y' .and. IANS .ne. 'Y') goto 250
		  endif
		  IF (NPTS .eq. 0) then 
		    write(lo,141)
		  ELSE
		    write(lo,142)
		  ENDIF
	        ELSE
	          WRITE(lo,132) 
	        ENDIF
	      ENDIF
	    ENDIF
20	  CONTINUE
10	CONTINUE
C----------------------------------------------------------------------------
201	IF (prompt .and. .not. (sortf .or. printf)) then
	  REWIND(UNIT=ltmp)
	  write(lo,'(A)') '$Print listing? (Y/[N]): '
	  read(li,'(A)',end=250) ians
	  IF (ians .eq. 'Y' .or. ians .eq. 'y') printf = .true.
	endif
	IF (sortf) then
	  CLOSE(UNIT=ltmp,DISPOSE='KEEP')
	  if (prompt) type *,'sorting hits by FOM...'
C	pass names of files to sort
	  status = SOR$PASS_FILES('PS_TMP:REPORT.TEMP','PS_TMP:REPORT.SORT')
	  If (.not. status) Goto 919
C	pass sort information
	  sortinfo(2) = %LOC(DSC$K_DTYPE_F)
	  status = SOR$BEGIN_SORT(sortinfo)
	  If (.not. status) Goto 919
C	perform sort 
	  status = SOR$SORT_MERGE()
	  If (.not. status) Goto 919
	  status = SOR$END_SORT()
	  If (.not. status) Goto 919
C	delete old file
	  OPEN (UNIT=ltmp,NAME='PS_TMP:REPORT.TEMP',TYPE='OLD',
	1	DISPOSE='DELETE',err=922)
	  CLOSE(UNIT=ltmp,DISPOSE='DELETE',err=922)
	  OPEN (UNIT=ltmp,NAME='PS_TMP:REPORT.SORT',FORM='UNFORMATTED'
	1	,TYPE='OLD',DISPOSE='DELETE',err=923)
C the sort has been completed, now set the number of cards to be displayed
C and if the number is less than the total number of hits, write a new bit
C map file
	  i = icardno
	  if (NSORT .gt. 0 .and. NSORT .lt. icardno) then
	    CALL TBLCLR(TABLE3,N_Lwords,NPH3)
	    i = MIN(icardno,NSORT)
	    DO N=1,i
	      read(ltmp,end=221) JCARD,Q,jmiss,jmatch,NDSINT,FOMI,FOMA,
	1		FOMF,avei,namrec,iseq
	      CALL BITSET(TABLE3,ISEQ,N_cards,1)
	    ENDDO
	    
221	    WRITE(filename,'(i8)') NSORT 
	    call press(filename,ln)
	    call fparse(sname(:s_ln),node,len_node,device,len_device,
	1	dir,len_dir,name,len_name,type,len_type,ver,len_ver)
	    filename = node(:len_node)//device(:len_device)//dir(:len_dir)
	1	//name(:len_name)//'_top'//filename(:ln)
	    ln = len_node + len_device + len_dir + len_name + ln + 4
	    CALL WRBIT(table3,filename,LN,bitmap,bitmap_ln,dname,d_ln,
	1	lssname,lss_ln,*3)
	  ENDIF
C    Display sorted list on terminal
	  call ps_pause(prompt)
	  CALL TERASE(ICRT,lo,li)
	  IF (NPTS .eq. 0) then 
	    write(lo,141)
	  ELSE
	    write(lo,142)
	  ENDIF
	  iline = 1
	  REWIND(UNIT=ltmp)
	  ICARDNO = 0
	  DO N=1,i
	    read(ltmp,end=250) JCARD,Q,jmiss,jmatch,NDSINT,FOMI,FOMA,FOMF,
	1	avei,namrec
	    ICARDNO = ICARDNO + 1
	    IF (Q .ge. 9.999e30) then
	      WRITE(lo,131) JCARD,jmatch,jmiss,NDSINT
	    ELSEIF (NPTS .eq. 0) then 
	      WRITE(lo,131) JCARD,jmatch,jmiss,NDSINT,Q,FOMI,FOMA,avei
	    ELSE
	      WRITE(lo,131) JCARD,jmatch,jmiss,NDSINT,Q,FOMI,FOMA,fomf,avei
	    ENDIF
C	get name info
	    CALL READNAM(NAMREC,LUNN,QM,FCOR,CHFORM,LCHFORM,CHNAME,LCHNAME)
	    WRITE(lo,132) (CHFORM(i),i=1,LCHFORM),' ','/',' ',
	1		(CHNAME(i),i=1,LCHNAME)
	    iline = iline + 3 + (3+lchform+lchname)/72
	    IF (ILINE .gt. 20 .and. prompt) THEN
	      write(lo,'(A1)') 
	1	    '$Next Page/Stop/Print report/Graph? ([N]/S/P/G): '
	      read(li,'(A)',end=250) ians
	      CALL TERASE(ICRT,lo,li)
	      iline = 1
	      IF (ians .eq. 'S' .or. ians .eq. 's') goto 1
	      IF (ians .eq. 'P' .or. ians .eq. 'p') then
		PRINTF = .TRUE.
		goto 250
	      ELSEIF (ians .eq. 'G' .or. ians .eq. 'g') then
		graphf = .true.
		goto 250
	      ENDIF
	      IF (NPTS .eq. 0) then 
	        write(lo,141)
	      ELSE
	        write(lo,142)
	      ENDIF
	    ELSE
	      WRITE(lo,132) 
	    ENDIF
	  ENDDO
	  IF (prompt) then
	    write(lo,'(A)') '$Print listing? (Y/[N]): '
	    read (li,'(A)',end=250) ians
	    IF (ians .eq. 'Y' .or. ians .eq. 'y') printf = .true.
	  ENDIF
	ENDIF
C---------------------------------------------------------------------------
C    Display sorted list on printer
250	IF (printf) then 
	  REWIND(ltmp)
	  IPAGE = 0
	  iline = 50
	  if (NSORT .gt. 0) icardno = MIN(icardno,NSORT)
	  call opnpr(lo,li,lp,'search.report',ncol,nlines)
	  DO N=1,ICARDNO 
	    read(ltmp,end=251) JCARD,Q,jmiss,jmatch,NDSINT,FOMI,FOMA,FOMF,
	1	avei,namrec
	    IF (ILINE .ge. 50) THEN
	      iline = 3
	      IPAGE = IPAGE + 1
	      IF (NPTS .eq. 0) then 
		WRITE(lp,721) IPAGE
	      ELSE
		WRITE(lp,722) IPAGE
	      ENDIF
721	      FORMAT('1',70x,'Page',i4,/,
	1	'   card         JCPDS lines       Overall    Intensity',
	2	'     Angle    Int. Ratio',/,
	3	'  number      match/miss/total      FOM         FOM   ',
	4	'      FOM      Obs/JCPDS',/,1x,77('-'))
722	      FORMAT('1',85x,'Page',i4,/,
	1	'   card         JCPDS lines       Overall    Intensity',
	2	'     Angle       Full     Int. Ratio',/,
	3	'  number      match/miss/total      FOM         FOM   ',
	4	'      FOM     Pattern FOM  Obs/JCPDS',/,1x,89('-'))
	    ENDIF
	    IF (Q .ge. 9.999e30) then
	      WRITE(lp,231) JCARD,jmatch,jmiss,NDSINT
	    ELSEIF (NPTS .eq. 0) then 
	      WRITE(lp,231) JCARD,jmatch,jmiss,NDSINT,Q,FOMI,FOMA,avei
231		  FORMAT(' [',I6.6,']',5x,i4,'/',i4,'/',i4,5f12.3)
	    ELSE
	      WRITE(lp,231) JCARD,jmatch,jmiss,NDSINT,Q,FOMI,FOMA,fomf,avei
	    ENDIF
C	get name info
	    CALL READNAM(NAMREC,LUNN,QM,FCOR,CHFORM,LCHFORM,CHNAME,LCHNAME)
	    WRITE(lp,132) (CHFORM(i),i=1,LCHFORM)
	    WRITE(lp,132) (CHNAME(i),i=1,LCHNAME)
	    WRITE(lp,132) 
	    iline = iline + 4 + lchform/72 + lchname/72
C now queue the file, if PS_PCOM has been defined
	  ENDDO
251	  CALL CLPR(lo,li,lp)
	ENDIF	   
C---------------------------------------------------------------------------
300	IF (PROMPT .and. ICRT .gt. 0 .AND. .not. GRAPHF) THEN 
	  WRITE(lo,'(A)') '$Display entries graphically? (Y/[N]): '
	  read(li,'(A1)',end=1) IANS
	  if (ians .eq. 'y' .or. ians .eq. 'Y') GRAPHF = .TRUE.
	ENDIF	   
	IF (GRAPHF  .and. ICRT .GT. 0) THEN 
	  REWIND(ltmp)
	  CALL quickPLT(ltmp,NPHASE,dname,sname,wavel)
	  GRAPHF = .false.
	  IF (.not. printf) then
	    write(lo,'(A)') '$Print listing? (Y/[N]): '
	    read (li,'(A)',end=250) ians
	    IF (ians .eq. 'Y' .or. ians .eq. 'y') printf = .true.
	    goto 250
	  ENDIF
	  goto 300
	ENDIF	   
C---------------------------------------------------------------------------
1	CLOSE (UNIT=ltmp,DISPOSE='DELETE')
	STATUS= .TRUE.
	RETURN
C---------------------------------------------------------------------------
919	type *,'REPORT ERROR performing sort'
	call LIB$SIGNAL(%VAL(STATUS))
3	CLOSE (UNIT=ltmp,DISPOSE='DELETE')
	lss_ln = 0 
	STATUS = .FALSE.
	RETURN
C---------------------------------------------------------------------------
921	type *,'REPORT ERROR -- Unable to open file PS_TMP:REPORT.TEMP'
	STATUS = .FALSE.
	RETURN
C---------------------------------------------------------------------------
922	type *,'REPORT ERROR -- Unable to delete file PS_TMP:REPORT.TEMP'
	STATUS = .FALSE.
	RETURN
C---------------------------------------------------------------------------
923	type *,'REPORT ERROR -- Unable to open file PS_TMP:REPORT.SORT'
	STATUS = .FALSE.
	RETURN
C------------------------------------------------------------------------
33	write (lo,'(A)') ' REPORT ERROR -- error reading raw data file',
	1	'      Program will continue without raw data'
	d_ln = 0
	GOTO 34
	END
