C*************************************************************************
	Subroutine REDUCE(wavel,bitmap_ln,bitmap,STATUS)
C*************************************************************************
C  VERSION 3 -- 7/88 (B.H. Toby)
C  Uses bit maps for reduce the number of entries for search and match 
C*************************************************************************
C
	include '[-.shared]jcpds.parms/list'
	include 'SEARCH.cmn/list'
	include 'SEARCH.par/list'

	REAL wavel
	CHARACTER*(*) bitmap
	INTEGER bitmap_ln
	INTEGER STATUS

	integer*4 ret_stat,timstor,code
	integer*4 lib$show_timer,lib$free_timer,lib$init_timer,tim_prt
	external  lib$show_timer,lib$free_timer,lib$init_timer,tim_prt
	LOGICAL flag,DTOTT,TTTOD,DTOPDF,PDFTOD,DTOIND,INDTOD
	LOGICAL PDFTOCU,CUTOPDF,PDFTOIND
	LOGICAL EXRtst
	LOGICAL pflag,iflag
	INTEGER*4 ind1,ind2
	INTEGER*4 ind1p,ind2p
	CHARACTER*7 str1,str2
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C use VMS routine to initalize the timer -- later display processing time
	ret_stat = lib$init_timer(timstor)
	if (.not. ret_stat) call lib$signal(%val(ret_stat))
	WRITE(LO,'(a)') ' ',' *** REDUCE Step started'
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

C read in the starting bitmap into TABLE1
	CALL GETbit(Nset,BITMAP,bitmap_ln,*3)
C copy to TABLE2 in case pindex and iindex are above 100
	CALL TBLMOVE(TABLE1,TABLE2,N_Lwords)
	nph2 = nph1
C--------------------------------------------------------------------------
C Drop observed reflections that are totally contained in an excluded area
	CALL USEPEAK	
	if (nobs .eq. 0) then
	  TYPE *,'There are no observed lines that are not excluded'
	  goto 3
	ENDIF

	pflag = .false.
C open a BITMAP index to select using strong peaks
	IF (pindex .lt. 100) THEN
	  pflag = .true.
C   get the appropriate index file
21	  call getindex(pindex,ind,LUND)
	  IF (ind .gt. 99 .and. pindex .eq. -1) THEN
C no three strongest file -- error!
	    write(*,'(2a)') ' ERROR -- Unable to open d-space INDEX',
	1   ' file: PS_BITMAP:DSP3S.BITMAP'
	    write(*,'(2a)') '       -- Will continue using 70% file'
	    pindex = 70
	    goto 21
	  ELSEIF (ind .gt. 99) THEN
C unable to open a lower intensity peak threshold file -- error!
	    write(*,'(2a)') ' ERROR -- Unable to open d-space INDEX',
	1  ' file (PS_BITMAP:DSP00.BITMAP)'
	    pflag = .false.
	  ELSEIF (ind .ne. pindex) THEN
C warn
	    write(*,'(/a,i2,a,i2,a/)') ' *** Unable to open the ',pindex
	1	,'% Index file, will substitute the ',ind,'% file.'
	    pindex = ind
	  ENDIF
	ENDIF

C----------------------------------------------------------------------
C Do the strong peak search
C----------------------------------------------------------------------
	IF (pflag) THEN
	  CALL TBLCLR(TABLE2,N_Lwords,nph2)
	  IF (pindex .lt. 0) THEN
	    write (lo,'(/A)') 
	1	' Using the "3 Strongest Lines Index" to find entries'
	  ELSE
	    write (lo,'(/A,i2,A)') 
	1	' Using the "> ',pindex,'% Lines Index" to find entries'
	  ENDIF
	  IF (wavel .le. 0.0) THEN 
	    write (lo,'(A/)') 
	2	' matching the strong observed peaks (listed as d-spaces):'
	  ELSE
	    write (lo,'(A,f8.5,A,/)') 
	2	' matching the strong observed peaks at 2-theta '//
	1	'angles (lamda=',wavel,'):'
	  ENDIF
C----------------------------------------------------------------------
	  ind1p = 0
	  ind2p = 0
	  DO 10 I=1,nobs
	    IF (iobs(i) .ge. pimin) then
	      flag = PDFTOIND(OBH(i),ind2,N_REGIONS)
	      flag = PDFTOIND(OBL(i),ind1,N_REGIONS)
	      IF (ind1 .eq. ind1p .and. ind2 .eq. ind2p) then
	        write (lo,'(5x,A,i3,a)') ' Peak #',I,' - same as previous'
	        GOTO 10
	      ENDIF
	      ind1p = ind1
	      ind2p = ind2
C look up peaks in the JCPDS strong line index bitmap
	      CALL TBLCLR(TABLE3,N_Lwords,nph2)
	      DO j=ind1,ind2
	        read(lund,rec=j) (TABLE(k2),k2=1,N_Lwords)
	        CALL TBLOR(TABLE,TABLE3,TABLE3,N_Lwords)
	      ENDDO
	      CALL TBLCOUNT(TABLE3,N_Lwords,nph3)
	      FLAG = INDTOD(ind1,ind2,DMAX,DMIN,N_REGIONS)
	      if (wavel .le. 0.0) THEN 
	        write (lo,'(5x,A,i3,a,F7.4,a,f7.4,A,i6)') 
	1	' Peak #',I,' - range',dmax,' to',Dmin,
	1	' Ang.   # Entries=',nph3
	      ELSE
	        str2 = '  ???  '
	        flag = dtott(dmin,dmin,wavel)
	        IF (FLAG) write(str2,'(f7.3)') dmin
	        str1 = '  ???  '
	        flag = dtott(dmax,dmax,wavel)
	        IF (FLAG) write(str1,'(f7.3)') dmax
	        write (lo,'(5x,A,i3,a,A7,a,a7,A,i6)') 
	1	' Peak #',I,' - range',str1,' to',str2,
	1	' deg.   # Entries=',nph3
	      ENDIF
	      CALL TBLOR(TABLE2,TABLE3,TABLE2,N_Lwords)
	    ENDIF
10	  CONTINUE
C--------------------------------------------------------------------------
C count the number of matching entries
	  CALL TBLCOUNT(TABLE2,N_Lwords,nph2)
	  CLOSE(UNIT=lund)
	  write (lo,'(/,a,i6,a)') ' There are only',nph2,
	1	' entries with strong peaks matching the observed peaks'
	  CALL TBLAND(TABLE1,TABLE2,TABLE2,N_Lwords)
	  CALL TBLCOUNT(TABLE2,N_Lwords,nph2)
	  write (lo,'(a,i6,a)') 
	1	' The "Strong Line Step" reduces the search down to',
	1	nph2,' entries'
	ENDIF
C--------------------------------------------------------------------------
C now use regions without peaks to reduce the # of entries to be examined
C--------------------------------------------------------------------------
	iflag = .false.
C open a BITMAP index to select using strong peaks
	IF (iindex .lt. 100) THEN
	  iflag = .true.
C   get the appropriate index file
22	  call getindex(iindex,ind,LUND)
	  IF (ind .gt. 99 .and. iindex .eq. -1) THEN
C no three strongest file -- error!
	    write(*,'(2a)') ' ERROR -- Unable to open d-space INDEX',
	1   ' file: PS_BITMAP:DSP3S.BITMAP'
	    write(*,'(2a)') '       -- Will continue using 70% file'
	    iindex = 70
	    goto 22
	  ELSEIF (ind .gt. 99) THEN
C unable to open a lower intensity peak threshold file -- error!
	    write(*,'(2a)') ' ERROR -- Unable to open d-space INDEX',
	1  ' file (PS_BITMAP:DSP00.BITMAP)'
	    iflag = .false.
	  ELSEIF (ind .ne. iindex) THEN
C warn
	    write(*,'(/a,i2,a,i2,a/)') ' *** Unable to open the ',iindex
	1	,'% Index file, will substitute the ',ind,'% file.'
	    iindex = ind
	  ENDIF
	ENDIF
	IF (iflag) THEN
	  IF (iindex .lt. 0) THEN
	    write (lo,'(/A)') 
	1   ' Using the "3 Strongest Lines Index" to exclude entries'
	  ELSE
	    write (lo,'(/A,i2,A)') 
	1   ' Using the "> ',iindex,'% Lines Index" to exclude entries'
	  ENDIF
	  IF (wavel .le. 0.0) THEN 
	    write (lo,'(A/)') 
	2	' with one or more strong peaks in region(s) '//
	1	'(listed as d-spaces):'
	  ELSE
	    write (lo,'(A,f8.5,A,/)') 
	2	' with one or more strong peaks in 2theta region(s) '//
	2	'(lamda=',wavel,'):'
	  ENDIF
C--------------------------------------------------------------------------
C Set the NULL regions table where there are no peaks or excluded areas
	  CALL SETNULL
C--------------------------------------------------------------------------
	  write (lo,'(A/)') 
	  n = 0
	  CALL TBLCLR(TABLE3,N_Lwords,nph3)
200	  DO j=N+1,N_REGIONS
	    IF (NULLREG(j)) then
	      k1 = j
	      j1 = j 
	      N = j
	      DO k=J+1,N_REGIONS
		N = K
		IF (.not. NULLREG(K)) GOTO 201
		j1 = k
	      ENDDO
201	      FLAG = INDTOD(k1,j1,DMAX,DMIN,N_REGIONS)
	      CALL TBLCLR(TABLE1,N_Lwords,nph1)
!	      write (lo,'(10x,F6.3,a,f6.3,A)') dmax,' to',dmin,' Angstrom'
	      DO k=k1,j1
		read(lund,rec=k) (TABLE(k2),k2=1,N_Lwords)
		CALL TBLOR(TABLE,TABLE1,TABLE1,N_Lwords)
	      ENDDO
	      CALL TBLCOUNT(TABLE1,N_Lwords,nph1)
	      CALL TBLOR(TABLE1,TABLE3,TABLE3,N_Lwords)
	      if (wavel .le. 0.0) THEN 
	        write (lo,'(5x,A,F7.4,a,f7.4,A,i6)') 
	1	' Null region ',dmax,' to',Dmin,
	1	' Ang.   # Entries=',nph1
	      ELSE
	        str2 = '  ???  '
	        flag = dtott(dmin,dmin,wavel)
	        IF (FLAG) write(str2,'(f7.3)') dmin
	        str1 = '  ???  '
	        flag = dtott(dmax,dmax,wavel)
	        IF (FLAG) write(str1,'(f7.3)') dmax
	        write (lo,'(5x,A,A7,a,a7,A,i6)') 
	1	' Null region '	,str1,' to',str2,
	1	' deg.   # Entries=',nph1
	      ENDIF
	      goto 200
	    ENDIF
	  ENDDO

	  CLOSE(UNIT=lund)
	  CALL TBLCLR(TABLE,N_Lwords,NPHASE)
	  CALL TBLCOUNT(TABLE3,N_Lwords,nph3)
	  CALL TBLnot(TABLE3,TABLE3,N_cards)
	  write (lo,'(/,a,i6,a)') ' There are',nph3,
	1	' entries with strong peaks in the area(s) devoid of intensity'
	  CALL TBLand(TABLE2,TABLE3,TABLE2,N_Lwords)
	  CALL TBLCOUNT(TABLE2,N_Lwords,nph2)
	  write (lo,'(a,i6,a)') 
	1	' The "Forbidden Line Step" reduces the search down to',
	2	nph2,' entries'
	ENDIF
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
	IF (.not. (pflag .or. iflag)) THEN
	  write (lo,'(/A)') ' Note: No Reduce steps performed.'
	  write (lo,'(/,a,i6,a,i6,a)') ' The program will search',nph2,
	1	' of',N_cards,' entries'
	ENDIF
C----------------------------------------------------------------------
	if (nph2 .eq. 0) then
	  TYPE *,'There are no entries left to search'
	  goto 3
	ENDIF
C use VMS routine to display processing time
	WRITE(LO,'(a)') ' *** REDUCE step ended, Statistics for this step:'
	ret_stat = lib$show_timer(timstor,1,tim_prt)
	ret_stat = lib$show_timer(timstor,2,tim_prt)
C release timer storage
	ret_stat = lib$free_timer(timstor)
C------------------------------------------------------------------------
	STATUS = .TRUE.
	RETURN
C------------------------------------------------------------------------
3	STATUS = .FALSE.
C release timer storage
	ret_stat = lib$free_timer(timstor)
	RETURN
C------------------------------------------------------------------------
	END 
