c		plotspur.f
c===================================================

      subroutine rank_higher(nspurtot, nelastictot)
      implicit none
      include 'arraysize.inc'
      include 'spur_scan.inc'

c...	passed variables
      integer nspurtot, nelastictot
      
c...	local variables
      integer ihigh, ii, jj, i
      logical firstmatch

c...	Higher order spurions which hit bragg peaks.
	ihigh = 0
	do ii = 1, n_spur_max
	  do jj = 1, n_spur_max
	    firstmatch = .true.
	    do i = 1, nspurtot
	      if ((ii .eq. ispur(i))  .and. (jj .eq. jspur(i))) then
		if (firstmatch) then
	          ihigh = ihigh + 1
		  firstmatch = .false.
		endif
	        rankspot(i) = ihigh
c	        write (*,*) 'rank_higher: Bragg ', i,
c     &		   ispur(i), jspur(i), ihigh, rankspot(i)
	      endif
	    enddo
	  enddo
	enddo
	n_rankspot = ihigh
	
c	do i = 1, nspurtot
c	  write (*,*) 'rank_higher: Bragg ', i,
c     &		   ispot(i), jspot(i), rankspot(i)
c	enddo

c...	Higher order spurions which are elastic.
	ihigh = 0
	do ii = 1, n_spur_max
	  do jj = 1, n_spur_max
	    firstmatch = .true.
	    do i = 1, nelastictot
	      if ((ii .eq. ielst(i))  .and. (jj .eq. jelst(i))) then
		if (firstmatch) then
	          ihigh = ihigh + 1
		  firstmatch = .false.
		endif
	        rankelst(i) = ihigh
c	        write (*,*) 'rank_higher: Elastic ', i,
c     &		   ielst(i), jelst(i), ihigh, rankelst(i)
	      endif
	    enddo
	  enddo
	enddo
	n_rankelst = ihigh

c	do i = 1, nelastictot
c	  write (*,*) 'rank_higher: Elastic ', i,
c     &		   ielst(i), jelst(i), rankelst(i)
c	enddo


      
      return
      end

c===================================================
      subroutine prepspur(nn_spur, nspurtot,
     &	mm_rlv,qspur,espur,nspur,
     &  zeta,eta,hh,kk,ll,
     &  ki,kf,absent,replot, nelastic, nelastictot, iscan)

C  Prepare spurious Q's for plotting

      implicit none
      include 'arraysize.inc'
      include 'spur_color.inc'
      include 'spur_scan.inc'
      include 'io_files.inc'
      
c...	common blocks
      real tol, etol		!! spatial and energy tolerances   		
      common /spur/ tol, etol

c...	passed variables
      integer nn_spur		!!  = n_spur_max
      integer  nspurtot, mm_rlv
      real qspur(2,n_spur_max,n_spur_max)
      real espur(n_spur_max,n_spur_max)
      integer nspur
      real ki(2),kf(2)
      real zeta(m_rlv_max,m_rlv_max),eta(m_rlv_max,m_rlv_max)
      integer hh(m_rlv_max,m_rlv_max)
      integer kk(m_rlv_max,m_rlv_max)
      integer ll(m_rlv_max,m_rlv_max)
      logical absent(m_rlv_max,m_rlv_max)
      logical replot
      integer nelastic		
      integer nelastictot
      integer iscan
      character*80 aline

c...	local variables
      integer i,j,k,l
      integer iwhere
      
C  Count the number of spurion matches

c      write (*,*) 'plotspur: nn_spur = ', nn_spur
      nspur=0
      nelastic=0

      do i=1,nn_spur
        do j=1,nn_spur

C  Don't include the primary scattering as spurious.
          
          if ((i.ne.1).or.(j.ne.1)) then

C  Elastic spurions in red, others in yellow
c...		Exclude case of i=j
            
            if ((abs(espur(i,j)) .lt. etol) .and. (i .ne. j)) then

	      if (nelastic+nelastictot+1 .gt. n_spurbragg_max) goto 670
	      nelastic = nelastic + 1
ccc	      nelastictot = nelastictot + 1
	
	      iwhere = nelastic+nelastictot
              ielst(iwhere)=i
              jelst(iwhere)=j
              scanpt_elst(iwhere)=iscan	!! where in the scan
            else
cPlot              call pgsci(color_yellow)			!! yellow: inelastic
            endif

C  Show i*ki and -j*kf leading to spurious process.  There will
C  be overlaps and colour based on the earlier elastic condition.   

C  Now check to see if the spurious process matches a reciprocal
C  lattice point.
            do k=1,mm_rlv
              do l=1,mm_rlv
                if ((abs(zeta(k,l)-qspur(1,i,j)).lt.tol).and.
     &              (abs(eta(k,l)-qspur(2,i,j)).lt.tol).and.
     &               .not.absent(k,l)) then

		  if (nspur+nspurtot+1 .gt. n_spurbragg_max) goto 680

C  For a match increase the count by 1.
                  nspur=nspur+1

C  Record the spurion indicies (i and j) and the (hkl) of the
C  reciprocal lattice point.

		  iwhere = nspur+nspurtot
C...  		Show i*ki and -j*kf leading to spurious process.
		  ispur(iwhere)=i	!! higher spurion index 
                  jspur(iwhere)=j	!! higher spurion index

c...		Prepare q=(h,k,l) info for the lattice plot page
                  hspur(iwhere)=hh(k,l)
                  kspur(iwhere)=kk(k,l)
                  lspur(iwhere)=ll(k,l)

c...		Prepare stuff for scan plot page (new, March 2002)
                  ispot(iwhere)=k	!! Bragg index
                  jspot(iwhere)=l	!! Bragg index
                  scanpt_spot(iwhere)=iscan	!! where in the scan

cDon'tNeed                  int_spot(nspur+nspurtot)=sfhkl(k,l)	!! Bragg intens.

                endif
C  If no match just skip to the next reciprocal lattice point.
              enddo
            enddo

          endif
        enddo
      enddo

      goto 999

670   write (aline,*)  nelastictot, '# of elastic spurions', 
     &		' exceeds array length n_spurbragg_max', n_spurbragg_max
      write (unitlog,*) aline
      write (unitspur,*)  aline
      goto 999

680   write (aline,*)  nspurtot, '# of spurions matching Bragg peaks', 
     &		' exceeds array length n_spurbragg_max', n_spurbragg_max
      write (unitlog,*) aline
      write (unitspur,*)  aline

999   return
      end


c===============================================================================
      subroutine plotspur(nn_spur,
     &	mm_rlv,qspur,espur, circsize,
     &  zeta,eta,
     &  ki,kf,absent,replot, iscan)

C  Plot spurious Q's that have been prepared

      implicit none
      include 'arraysize.inc'
      include 'spur_color.inc'
      include 'spur_scan.inc'
      
c...	common blocks
      real tol, etol		!! spatial and energy tolerances   		
      common /spur/ tol, etol

c...	passed variables
      integer nn_spur		!!  = n_spur_max
      integer   mm_rlv
      real qspur(2,n_spur_max,n_spur_max)
      real espur(n_spur_max,n_spur_max)
      real circsize
      real ki(2),kf(2)
      real zeta(m_rlv_max,m_rlv_max),eta(m_rlv_max,m_rlv_max)
      logical absent(m_rlv_max,m_rlv_max)
      logical replot
      integer iscan

c...	local variables
      integer i,j,k,l
      real temp


      do i=1,nn_spur
        do j=1,nn_spur

C  Don't include the primary scattering as spurious.
          
          if ((i.ne.1).or.(j.ne.1)) then

C  Elastic spurions in red, others in yellow
c...	Exclude case of i=j for elastic spurions.
            
            call pgsfs(1)     ! solid fill style
            call pgsls(1)     ! solid outlines
            
            if ((abs(espur(i,j)) .lt. etol) .and. (i .ne. j)) then
              call pgsci(color_red)			!! red: elastic
            else
              call pgsci(color_yellow)			!! yellow: inelastic
            endif

	    temp = 1.1*circsize

cDebug	    write (*,*) 'plotspur: ', i, j, qspur(1,i,j),qspur(2,i,j), temp
            call pgcirc(qspur(1,i,j),qspur(2,i,j), temp)
c01Nov            call pgcirc(qspur(1,i,j),qspur(2,i,j),1.1*circsize)

C  Show i*ki and -j*kf leading to spurious process.  There will
C  be overlaps and colour based on the earlier elastic condition.   
C            call arrows(i,j,ki,kf)

C  Now check to see if the spurious process matches a reciprocal
C  lattice point.
            do k=1,mm_rlv
              do l=1,mm_rlv
                if ((abs(zeta(k,l)-qspur(1,i,j)).lt.tol).and.
     &              (abs(eta(k,l)-qspur(2,i,j)).lt.tol).and.
     &               .not.absent(k,l)) then


C  If the process matches display the arrows
                  if ((abs(espur(i,j)) .le. etol) .and. (i .ne. j))then
                     call pgsci(color_red)
                  else
                     call pgsci(color_yellow)
                  endif
                  call pgsls(2)
                  call arrows(i,j,ki,kf)

C  Plot ki and kf
                  call pgsci(color_ink)
                  call pgsls(2) ! dashed line 
                  CALL pgarro(0.0,0.0,ki(1),ki(2))
                  CALL pgarro(ki(1),ki(2),ki(1)-kf(1),ki(2)-kf(2))
                  call pgsls(1)

                endif
C  If no match just skip to the next reciprocal lattice point.
              enddo
            enddo

          endif
        enddo
      enddo

      return
      end

c=============================================================================
      subroutine reportspur(nn_spur, nspurtot, nelastictot, 
     &	qspur,espur, bmatuv_inv, ec, es, h, hc, hs, nscan, iscan)

      implicit none
      include 'arraysize.inc'
      include 'spur_color.inc'
      include 'spur_scan.inc'
      include 'spur_layout.inc'
      include 'io_files.inc'
      
c...	common blocks
      real tol, etol		!! spatial and energy tolerances   		
      common /spur/ tol, etol

c...	functions
      integer ilen

c...	passed variables
      integer nn_spur		!!  = n_spur_max
      integer  nspurtot, nelastictot
      real qspur(2,n_spur_max,n_spur_max)
      real espur(n_spur_max,n_spur_max)
      real bmatuv_inv(3,3)
      real ec, es
      REAL*4 h(3),hc(3),hs(3)
      integer nscan, iscan

c...	local variables
      integer i,j,ii, jj
      character*19 afloat_hkl
      character*(80)	line_scan, line_spur, line_info, aline
      logical firstbragg

C  		Print out the spurions


c...		Usually npts = nscan unless there was an error.
           do j=1,3
c             h(j)=hc(j)+(iscan-(float(npts)+1.0)/2.0)*hs(j)
             h(j)=hc(j)+(iscan-(float(nscan)+1.0)/2.0)*hs(j)
           enddo
	   
	   write (line_scan, 115) iscan,  
     &		   ec+(iscan-(float(nscan)+1.0)/2.0)*es, (h(j),j=1,3) 	   
c     &		   ec+(iscan-(float(npts)+1.0)/2.0)*es, (h(j),j=1,3) 	   
115	   format ('Scan point #=', i3, ' at dE=', f7.3, 
     &		' at Q=(',f6.2,1x,f6.2,1x,f6.2,')')
           write (unitspur, '(a)') line_scan
cWait!           write (*, '(a)') line_scan

	    firstbragg = .true.
	    
            do ii=1,nn_spur
             do jj=1,nn_spur
c	        if (( ii .ne. 1) .or. (jj .ne. 1)) then
	          call hkl_float(qspur(1,ii,jj), qspur(2,ii,jj), 
     &		    bmatuv_inv, afloat_hkl)
     		  write (line_spur, 124) ii, jj, afloat_hkl, espur(ii,jj)
124		  format (1x,i2, '*Ki - ', i2, '*Kf =',1x,
     &			a,' at E_spur=', f8.2)

		  if ( iscan .eq. nint(xmin_sc)) then
		    afloat_hkl_start(ii,jj) = afloat_hkl
		  endif
		  if ( iscan .eq. nint(xmax_sc)) then
		    afloat_hkl_end(ii,jj) = afloat_hkl
		  endif
c		endif

                  if (abs(espur(ii,jj)).lt. etol) then
     			if ( (firstbragg) .and. 
     &				(( ii .ne. 1) .or. (jj .ne. 1))) then
     			  firstbragg = .false.
			  write (*,*)
			  write (*, '(a80)') line_scan
			endif
		    write (line_info,*) ' Elastic red. '
c...		    Override  line_info, if there was match to a Bragg peak.		    
                     do i=1,nspurtot
		      if ((ispur(i).eq.ii) 
     &			 .and.(jspur(i).eq.jj) .and. 
     &			  (scanpt_spot(i) .eq. iscan) ) then

cMoved		    if (nspur .ne. 0) then
cMoved                     do i=nspurtot+1,nspurtot + nspur
cMoved		    if (nspur .ne. 0) then
cMoved		      if ((ispur(i+nspurtot).eq.ii) 
cMoved     &			 .and.(jspur(i+nspurtot).eq.jj) ) then

		        write (line_info,*) ' Elastic red.   Bragg'
		      endif
		     enddo
cMoved		    endif

c		report all those higher order spurions which are elastic
	            if (( ii .ne. 1) .or. (jj .ne. 1)) then
                      write (*, *) line_spur(1:ilen(line_spur)), 
     &		  	line_info(1:ilen(line_info))
     		    endif

		  else
		    write (line_info,*) ' Inelst yellow.'
c...		    Override  line_info, if there was match to a Bragg peak.
                     do i=1,nspurtot
		      if ((ispur(i).eq.ii) 
     &			 .and.(jspur(i).eq.jj) .and. 
     &			  (scanpt_spot(i) .eq. iscan) ) then

     			if (firstbragg) then
     			  firstbragg = .false.
			  write (*,*)
			  write (*, '(a)') line_scan
			endif

cMoved		    if (nspur .ne. 0) then
cMoved                     do i=nspurtot+1,nspurtot + nspur
cMoved		      if ((ispur(i+nspurtot).eq.ii) 
cMoved     &			 .and.(jspur(i+nspurtot).eq.jj)) then
		        write (line_info,*) ' Inelst yellow. Bragg'
c		        write (line_info,*) ' Inelastic (yellow) Bragg'
c		Only report those higher order spurions which hit Bragg peaks
	                if (( ii .ne. 1) .or. (jj .ne. 1)) then
c	                if (.not. (( ii .eq. 1) .and. (jj .eq. 1))) then
                          write (*, *) line_spur(1:ilen(line_spur)), 
     &			  	line_info(1:ilen(line_info))
     			endif
		      endif
		     enddo
		    endif
cMoved		  endif

c		  Write all higher order spurions to the file *.spur		  
                  write (unitspur, *) line_spur(1:ilen(line_spur)), 
     &		  	line_info(1:ilen(line_info))


             enddo
            enddo
	    
 26         format(a, f7.3, $)
 637        format(a,f6.2,1x,f6.2,1x,f6.2,a, $)
 24         format(1x,i2, '*Ki - ', i2, '*Kf =', $)
 25         format(1x,a,a,f8.2,a,i2,$)

cMoved            nspurtot=nspurtot+nspur


         write(unitspur,*) 		!! blank line between scan points
cAlready         write(*,*) 		!! blank line between scan points



C...  report if no spurions? At end of the scan, this summary.
      if (iscan .eq. nscan) then 
        write(*,*) 		!! blank line at end of scan points
	write(aline,200) nspurtot, ' matches of higher order spurions ', 
     &	 'to Bragg peaks, out of ',  n_spur_max, '^2 * ', nscan, 
     &		'=',  n_spur_max*n_spur_max*nscan
200     format (i4, a, a, i2, a, i4, a, i4)
        write (*,'(a80)') aline
        write (unitspur,'(a80)') aline
c	write(*,*) nspurtot, ' matches of higher order spurions ', 
c     &		'to Bragg peaks, out of ', n_spur_max*n_spur_max*nscan 
c	write(unitspur,*) nspurtot, ' matches of higher order spurions ', 
c     &		'to Bragg peaks, out of ', n_spur_max*n_spur_max*nscan 

	write(aline,200) nelastictot, ' elastic higher order spurions, ', 
     &		'out of ',  n_spur_max, '^2 * ', nscan, 
     &		'=',  n_spur_max*n_spur_max*nscan
        write (*,'(a80)') aline
        write (unitspur,'(a80)') aline
c	write(*,*) nelastictot, ' elastic higher order spurions, ', 
c     &		'out of ', n_spur_max*n_spur_max*nscan 
c	write(unitspur,*) nelastictot, ' matches of higher order spurions, ', 
c     &		'out of ', n_spur_max*n_spur_max*nscan 

      	write(*,*) ''
      	write(unitspur,*) ''

      endif
      
      return
      end
