c	spur_qbuf.f
c	This is a re-write of files qbufin.f and qbufout.f, using 
c	common block variables in spur_buf.inc. 
c	No other variables are initialized here.
c	Idea: use a naming scheme so that it is obvious when 
c	variables from buffer are being modified.
c	Then we can be more confident that values keep up to date when output.
c	Also, output routine write_qbuf is not changed so that the whole
c	buffer can be written out to any unit number (file or screen)
c	or optionally a single line.

c234567
      subroutine qbuf_default()
c      Fills in qbuffer variables with default values, so
c      no input file is necessary.
 
      implicit none
      include 'spur_buf.inc'

c...	local variables
      integer i
            
600   write(*,*) 'qbuf_default: ',
     & 'Using default values: cubic (hhl) scattering plane'
      write(*,*) 'qbuf_default: ',
     & 'Fixed analyzer ANA, fixed Ei=14.7 meV, a=2*pi'
      write(*,*) 'qbuf_default: ',
     & '3-point scan from E=-1 to 1 at (1.1 1.1 0)'

      do i = 1, 3
	qb_lattice_a(i) = 4.0*atan(1.0)	!! crystal cell lengths = 2 * pi
	qb_lattice_angle(i) = 90.0	!! cubic crystal angles
	qb_space_hc(i) = 1.1		!! h, k, l center 
	qb_space_hs(i) = 0.0		!! h, k, l step
	qb_orient_u(i) = 0		!! Plane of scattering
	qb_orient_v(i) = 0		!! Plane of scattering
      enddo
      qb_space_hc(3) = 0.0	!! Override
      qb_orient_u(1) = 1	!! Override	scattering plane
      qb_orient_u(2) = 1	!! Override	(hkl) =(110)
      qb_orient_v(3) = 1	!! Override	(hkl)' = (001)

      qb_energy_fe = 14.7	!! Fixed energy [meV]
      qb_energy_ec = 14.7	!! scan energy center [meV]
c      qb_energy_ec = 0.0	!! scan energy center [meV]
      qb_energy_es = 1.0	!! scan energy step [meV]
      qb_time_scanpts = 3	!! Number of ponts in scan 
      qb_energy_fix = '(ANA)'   !! Which mono-chrometer e is fixed?
      qb_energy_dM = 3.354	!! xtl spacing on monitor
      qb_energy_dA = 3.354	!! xtl spacing on analyzer
      
c...	Items not currently used by spurion program
      qb_bufnum = 'Qbuffer No:  1   '
      qb_comment = 'Comment: SPURION defaults'
C      qb_comment = 'Comment: SPURION buffer output'
      qb_orient_angle = 0.0	!! Unused by ICP.
      qb_temp_T0 = 300.0	!! Temperature  [K]  
      qb_temp_incT = 0.0	!! Increment temperature [K]
      qb_temp_wait = 10.0	!! Wait time for T to settle down (or less) [min]
      qb_temp_err = 0.2		!! Tolerance for temperature [K]
      qb_temp_hold0 = 0.0	!! Wait time before 1st point [min]
      qb_temp_hold = 0.0	!! Wait time between points [min]
      qb_temp_str1 = 'FIELD'
      qb_time_monitor = 10000	!! Number of monitor events [unitless]
      qb_time_prefact = 1.0	!! Monitor counts prefactor [unitless]
      qb_time_mtype = 'NEUT'	!!Length of run det'd by 'TIME' or mon events 'NEUT'
      qb_time_str1 = 'AMON'
      qb_time_str2 = 'POLA'
      qb_time_str3 = 'PKEY'
      
c...	Also fill in some data file header items
      qd_filename = 'nosample000.btx'
      qd_date = '01-NON-200? 12:00'
      qd_scanstyle = '?'
      qd_TYPE = 'NON'
      qd_fileprefix = 'nosample'
      qd_comment = 'Artifical run'
      do i = 1, 4
        qd_collimation(i) = 0
      enddo
      do i = 1, 3
        qd_mosaic(i) = 0.0
      enddo
      qd_ana_or_mon = 'EM'
      qd_hfield = 0.0
                  
      return
      end
      
c=========================================================================
      logical function read_qbuf(whichqbuf)
c      Reads in qbuffer file from ICP program. 
 
      implicit none
      include 'io_files.inc'
      include 'spur_buf.inc'
      include 'spur_warn.inc'

c...	constants
      logical  noLabel, getLabel
      parameter (getLabel = .true.)
      parameter (noLabel = .false.)

c..	functions
      integer ilen
      logical write_qbuf
      logical input_data, input_datahdr
      logical readreal, readinteger, readstring

c...	passed variables
      character*1 whichqbuf
           
c...	local variables
      integer i
      CHARACTER*9 bufrow		!! Name of the buffer line 
      CHARACTER*24 title(6)		!! temporary storage of labels
      character*80 aline, alabel, lastOK, whichCommand
      character*3 hkl_bits(3)
      character*3 hklprime_bits(3)
      character*1 astring		!! dummy parameter

      read_qbuf = .true.


cDebug      write (*,*) 'read_qbuf: whichqbuf = ', whichqbuf
      if (whichqbuf .eq. 'd') then
cDebug        write (*,*) 'read_qbuf: has qbuf_default() been called?'
        return
      else if (whichqbuf .eq. 'c') then
cDebug        write (*,*) 'read_qbuf: Do nothing, use current values'
	return
      else if (whichqbuf .eq. 'b') then
cDebug         write (*,*) 'read_qbuf: Loading buffer file'
      else if ( (ichar(whichqbuf) .ge. ichar('0')) .and. 
     &		(ichar(whichqbuf) .le. ichar('9')) ) then
cDebug	 write (*,*) 'read_qbuf: Loading data file.'
cObsolete	 read_qbuf = .false.
cObsolete	 return
      else
	 write (*,*) 'read_qbuf: Unrecognized option'
         stop
      endif
            

c===================================================
c...	read from a triple axis file
      if ( (ichar(whichqbuf) .ge. ichar('0')) .and. 
     &		(ichar(whichqbuf) .le. ichar('9')) ) then
        if (.not. input_datahdr(whichqbuf)) goto 680
        if (.not. input_data(whichqbuf)) goto 682

      endif

c===================================================
c...	read from a q-buffer
      if (whichqbuf .eq. 'b') then
      OPEN(UNIT=unitbufin,FILE=file_bufin,STATUS='OLD',err=661)
      write(*,*) 'Opened: ', 'Q buffer input file: ', 
     &	file_bufin(1:ilen(file_bufin))


C     Opening line:
 209  READ(unitbufin,210) qb_bufnum, qb_comment
 210  FORMAT(A17,A60)
c      write(unitspur,210) qb_bufnum, qb_comment
      if (.not. write_qbuf( unitspur, 'Qbuffer', astring)) goto 670	!! Echo to file
      if (.not. write_qbuf( 0, 'Qbuffer', astring)) goto 670	!! Echo to screen

C     Lattice:
      whichCommand = 'Lattice: '
      lastOK = 'Last part that was OK: <NONE>'
      READ (unitbufin,fmt=('(a)'),err=666,end=666) aline
      if (.not. readstring(bufrow, aline, alabel, 
     &		'~', noLabel, lastOK)) goto 666		!! Command Lattice:
c...	Check that command is what we think should be there.
      call supper(bufrow)
      if (bufrow(1:8) .ne. 'LATTICE:') then
      	write (*,*) '"Lattice:" command seems to be mismatched. ', 
     &		'File has "', bufrow(1:8), '"'
      endif

      do i = 1, 3			!! lattice parameters a, b, c
	   if (.not. readreal(qb_lattice_a(i), aline, title(i), 
     &		':', getLabel, lastOK)) then
c		write (*,*) aline
c		write (*,*) title(i)
c		write (*,*) lastOK
c		write (*,*) getlabel
     		goto 666
	   endif
      enddo
      do i = 1, 3			!! lattice angles alpha, beta, gamma
	   if (.not. readreal(qb_lattice_angle(i), aline, title(i+3), 
     &		':', getLabel, lastOK)) goto 666
      enddo
      if (.not. write_qbuf( unitspur, 'Lattice', astring)) goto 670	!! Echo to file
      if (.not. write_qbuf( 0, 'Lattice', astring)) goto 670	!! Echo to screen


C     Energy:
      whichCommand = 'Energy: '
      lastOK = 'Last part that was OK: <NONE>'
      READ (unitbufin,fmt=('(a)'),err=666,end=666) aline
      if (.not. readstring(bufrow, aline, alabel, 
     &		'~', noLabel, lastOK)) goto 666		!! Command Lattice:
c...	Check that command is what we think should be there.
      call supper(bufrow)
      if (bufrow(1:7) .ne. 'ENERGY:') then
      	write (*,*) '"Energy:" command seems to be mismatched. ', 
     &		'File has "', bufrow(1:7), '"'
      endif

      if (.not. readreal(qb_energy_ec, aline, title(1), 
     &		':', getLabel, lastOK)) goto 666	!! Ec and label
      if (.not. readreal(qb_energy_es, aline, title(2), 
     &		':', getLabel, lastOK)) goto 666	!! Es and label
      if (.not. readreal(qb_energy_fe, aline, title(3), 
     &		':', getLabel, lastOK)) goto 666	!! Fs and label
      if (.not. readstring(qb_energy_fix, aline, alabel, !! Monitor
     &		'~', noLabel, lastOK)) goto 666
      if (.not. readreal(qb_energy_dm, aline, title(4), 
     &		'=', getLabel, lastOK)) goto 666	!! dM and label
      if (.not. readreal(qb_energy_da, aline, title(5), 
     &		'=', getLabel, lastOK)) goto 666	!! dA and label

      if (.not. write_qbuf( unitspur, 'Energy', astring)) goto 670	!! Echo to file
      if (.not. write_qbuf( 0, 'Energy', astring)) goto 670	!! Echo to screen

C     Space (reciprocal lattice):
      whichCommand = 'Space: '
      lastOK = 'Last part that was OK: <NONE>'
      READ (unitbufin,fmt=('(a)'),err=666,end=666) aline
c      READ (2,fmt=('(a)'),err=666,end=666) aline
      if (.not. readstring(bufrow, aline, alabel, 
     &		'~', noLabel, lastOK)) goto 666		!! Command Space:
c...	Check that command is what we think should be there.
      call supper(bufrow)
      if (bufrow(1:6) .ne. 'SPACE:') then
      	write (*,*) '"SPACE:" command seems to be mismatched. ', 
     &		'File has "', bufrow(1:6), '"'
      endif

      do i = 1, 3			!! Reciprocal lattice Hc, Kc, Lc
	   if (.not. readreal(qb_space_hc(i), aline, title(i), 
     &		':', getLabel, lastOK)) goto 666
      enddo
      do i = 1, 3			!! Reciprocal lattice Hs, Ks, Ls
	   if (.not. readreal(qb_space_hs(i), aline, title(i+3), 
     &		':', getLabel, lastOK)) goto 666
      enddo
      if (.not. write_qbuf( unitspur, 'Space', astring)) goto 670	!! Echo to file
      if (.not. write_qbuf( 0, 'Space', astring)) goto 670	!! Echo to screen

C     Orient:
      whichCommand = 'Orient: '
      lastOK = 'Last part that was OK: <NONE>'
      READ (unitbufin,fmt=('(a)'),err=666,end=666) aline
c      READ (2,fmt=('(a)'),err=666,end=666) aline
      if (.not. readstring(bufrow, aline, alabel, 
     &		'~', noLabel, lastOK)) goto 666		!! Command Orient:
c...	Check that command is what we think should be there.
      call supper(bufrow)
      if (bufrow(1:7) .ne. 'ORIENT:') then
      	write (*,*) '"ORIENT:" command seems to be mismatched. ', 
     &		'File has "', bufrow(1:7), '"'
      endif

      do i = 1, 3			!! strings  "(h k l):"
	   if (.not. readstring(hkl_bits(i), aline, title(i), 
     &		'~', noLabel, lastOK)) goto 666
      enddo
      do i = 1, 3			!! Orientation hkl
	   if (.not. readinteger(qb_orient_u(i), aline, title(i), 
     &		'~', noLabel, lastOK)) goto 666
      enddo
      if (.not. readreal(qb_orient_angle, aline, title(1),
     &		':', getLabel, lastOK)) goto 666
      do i = 1, 3			!! strings  "(h k l)':"
	   if (.not. readstring(hklprime_bits(i), aline, title(i), 
     &		'~', noLabel, lastOK)) goto 666
      enddo
      do i = 1, 3			!! Orientation hkl
	   if (.not. readinteger(qb_orient_v(i), aline, title(i), 
     &		'~', noLabel, lastOK)) goto 666
      enddo
      if (.not. write_qbuf( unitspur, 'Orient', astring)) goto 670	!! Echo to file
      if (.not. write_qbuf( 0, 'Orient', astring)) goto 670		!! Echo to screen


C     Temp/H:  (not used)
      whichCommand = 'Temp/H: '
      lastOK = 'Last part that was OK: <NONE>'
      READ (unitbufin,fmt=('(a)'),err=666,end=666) aline
      if (.not. readstring(bufrow, aline, alabel, 
     &		'~', noLabel, lastOK)) goto 666		!! Command Temp/H:
c...	Check that command is what we think should be there.
      call supper(bufrow)
      if (bufrow(1:7) .ne. 'TEMP/H:') then
      	write (*,*) '"TEMP/H:" command seems to be mismatched. ', 
     &		'File has "', bufrow(1:7), '"'
      endif

      if (.not. readreal(qb_temp_T0, aline, title(i), 
     &		':', getLabel, lastOK)) goto 666
      if (.not. readreal(qb_temp_T0, aline, title(i), 
     &		'T', getLabel, lastOK)) goto 666  !!  neither space nor : as delim
      if (.not. readreal(qb_temp_wait, aline, title(i), 
     &		':', getLabel, lastOK)) goto 666  
      if (.not. readreal(qb_temp_err, aline, title(i), 
     &		':', getLabel, lastOK)) goto 666  
      if (.not. readreal(qb_temp_hold0, aline, title(i), 
     &		':', getLabel, lastOK)) goto 666  
      if (.not. readreal(qb_temp_hold, aline, title(i), 
     &		':', getLabel, lastOK)) goto 666  
      if (.not. readstring(qb_temp_str1, aline, title(i), 
     &		':', noLabel, lastOK)) goto 666  

      if (.not. write_qbuf( unitspur, 'Temp/H', astring)) goto 670	!! Echo to file
      if (.not. write_qbuf( 0, 'Temp/H', astring)) goto 670		!! Echo to screen

C     Time:
      whichCommand = 'Time: '
      lastOK = 'Last part that was OK: <NONE>'
      READ (unitbufin,fmt=('(a)'),err=666,end=666) aline
      if (.not. readstring(bufrow, aline, alabel, 
     &		'~', noLabel, lastOK)) goto 666		!! Command Temp/H:
c...	Check that command is what we think should be there.
      call supper(bufrow)
      if (bufrow(1:5) .ne. 'TIME:') then
      	write (*,*) '"TIME:" command seems to be mismatched. ', 
     &		'File has "', bufrow(1:5), '"'
      endif

      if (.not. readinteger(qb_time_monitor, aline, title(1), 
     &		':', getLabel, lastOK)) goto 666
      if (.not. readreal(qb_time_prefact, aline, title(2), 
     &		':', getLabel, lastOK)) goto 666
      if (.not. readstring(qb_time_mtype, aline, title(3), 
     &		':', getLabel, lastOK)) goto 666
      if (.not. readinteger(qb_time_scanpts, aline, title(4), 
     &		':', getLabel, lastOK)) goto 666
      if (.not. readstring(qb_time_str1, aline, title(3), 
     &		'~', noLabel, lastOK)) goto 666
      if (.not. readstring(qb_time_str2, aline, title(3), 
     &		'~', noLabel, lastOK)) goto 666
      if (.not. readstring(qb_time_str3, aline, title(3), 
     &		'~', noLabel, lastOK)) goto 666

      if (.not. write_qbuf( unitspur, 'Time', astring)) goto 670	!! Echo to file
      if (.not. write_qbuf( 0, 'Time', astring)) goto 670	!! Echo to screen

      write(unitspur,*)

      CLOSE(unitbufin)
      endif 		!! (whichqbuf .eq. 'b') then

      goto 999
 661  write (*,*) 'Can not open file: ', file_bufin(1:ilen(file_bufin))
      goto 699
      
 666  write (*,*) 'read_qbuf: Error: ', 
     &		whichCommand(1:ilen(whichcommand)), ' ', 
     &		lastOK(1:ilen(lastOK))

      goto 699      
 670  write (*,*) 'read_qbuf: Error: Failed to echo to unit ', unitspur,
     &		whichCommand(1:ilen(whichcommand)), ' ', 
     &		lastOK(1:ilen(lastOK))

      goto 699      
 680  write (*,*) 'read_qbuf: Error reading data file header ', unitdata

      goto 699      
 682  write (*,*) 'read_qbuf: Error reading data in data file ',unitdata

 699  read_qbuf = .false.
c...		 			 123456789_123456789_
      call set_warning(wbit_other, 1,   'buf/data file error ')	 
 
 999  return 
      end      
      
c=========================================================================
      logical function write_qbuf(whichunit, selection, astring)
c      writes out either 1 line of qbuffer stored in memory, 
c	For qbuffer format:
c	  Write when selection = 'Qbuffer', 'Lattice', 'Energy', 'Sapce', 
c		'Orient', 'Temp/H' or 'Time'
c	  or the whole thing (selection = 'All').
c	For header of *.BT* data file format:
c	  Write when selection = 'hdrRun', 'hdrRunInfo', 
c		'hdrSample', ''hdrSampleInfo', 'hdrOrient', 'hdrOrientInfo',
c		'hdrLattice', 'hdrLatticeInfo', 'hdrEnergy', hdrEnergyInfo',
c		'hdrSpace', or 'hdrSpaceInfo' 
c	  or the whole thing (selection = 'HeaderAll').
c	If whichunit = 0, then to standard output.
c	If whichunit is neg, output to astring (not OK for 'All' or 'hdrAll')
c	Returns true if successful
 
      implicit none
      include 'io_files.inc'
      include 'spur_buf.inc'
      include 'spur_warn.inc'
      
c...	passed variables
      integer	whichunit	!! 0 is standard out. 
      character*(*) selection	!! 'All' special case
c      character*20 selection	!! 'All' special case
      character*(*) astring	!!if whichunit is neg, output to string instead.

c...	local variables
      integer thisunit, nlines
      
      write (*,*) 'write_qbuf: ', whichunit, ' "', selection, 
     &      '" "', astring, '"'
      write_qbuf = .true.
      nlines = 0
      
      thisunit = whichunit
      if (thisunit .eq. 0) thisunit = 6		!! Standard output.

      if ((thisunit .lt. 0) .and. 
     &    ((selection(1:3) .eq. 'All') .or. 
     &	   (selection(1:6) .eq. 'hdrAll')) ) then 
     	write (*,*) 'write_hdr: Error: Can only output 1 line ', 
     &	' at a time into a string.'
        return
      endif

c------------------------------------------------------------------------------
c...	qbuffer data file style from ICP

c...	Only open file in this case. Otherwise, assume the unit is already opened.
      if ((selection(1:3) .eq. 'All') .and. 
     &    (thisunit .eq.unitbufout )) then
        OPEN(UNIT=thisunit,FILE=file_bufout,STATUS='UNKNOWN', err=660)
        write(unitspur,'(2a)')
     &		'write_qbuf: Spurion output buffer file: ',
     &		file_bufout
cDebug        write(*,'(2a)')'write_qbuf: Spurion output buffer file: ',
cDebug     &		file_bufout
      else
cDebug          write(*,*) 'write_qbuf: Spurion output buffer unit #: ',
cDebug     &		thisunit
cDebug          write (*,*) 'write_qbuf: Selection = "', selection, '"'
      endif

c------------------------------------------------------------------------------
c...	Data file header style for files *.BT*, not implimented yet.
c...	Note: no unit number and file name yet for *.BT* files
c      if ((selection .eq. 'hdrAll') .and. (thisunit .eq.unitdatout )) then
c        OPEN(UNIT=thisunit,FILE=file_datout,STATUS='UNKNOWN', err=660)
c        write(unitspur,'(2a)') 'Spurion output data file: ',file_datout
c      endif

c------------------------------------------------------------------------------
c...	qbuffer data file style from ICP

C     Opening line:
      if ((selection(1:3) .eq. 'All') .or. 
     &    (selection(1:7) .eq. 'Qbuffer')) then
	nlines = nlines + 1
	if (thisunit .lt. 0) then
	  if (warn_options .ne. 0) then
            write(astring,210, err=666) qb_bufnum, qb_comment, 
     &		' output buffer with WARNINGS'
	  else
            write(astring,210, err=666) qb_bufnum, qb_comment, 
     &		' output buffer'
	  endif
	else
	  if (warn_options .ne. 0) then
            write(thisunit,210, err=666) qb_bufnum, qb_comment, 
     &		' output buffer with WARNINGS'
	  else
            write(thisunit,210, err=666) qb_bufnum, qb_comment, 
     &		' output buffer'
	  endif
	endif
 210    FORMAT(A17,A30, A)
      endif

C     Lattice:
      if ((selection(1:3).eq. 'All') .or. 
     &    (selection(1:7) .eq. 'Lattice')) then
	nlines = nlines + 1
	if (thisunit .lt. 0) then
          write(astring,211, err=666) 'Lattice: ',
     &   ' a:', qb_lattice_a(1),
     &   ' b:', qb_lattice_a(2),
     &	 ' c:', qb_lattice_a(3),
     &   'aa:', qb_lattice_angle(1),
     &   'bb:', qb_lattice_angle(2),
     &   'cc:', qb_lattice_angle(3)
	else
          write(thisunit,211, err=666) 'Lattice: ',
     &   ' a:', qb_lattice_a(1),
     &   ' b:', qb_lattice_a(2),
     &	 ' c:', qb_lattice_a(3),
     &   'aa:', qb_lattice_angle(1),
     &   'bb:', qb_lattice_angle(2),
     &   'cc:', qb_lattice_angle(3)
 211    FORMAT(a9,a3,f7.4,1x,a3,f7.4,1x,a3,f7.4,2x,
     &          a3,f7.3,2x,a3,f7.3,2x,a3,f7.3)
        endif
      endif

C     Energy:
      if ((selection(1:3) .eq. 'All') .or.
     &    (selection(1:6) .eq. 'Energy')) then
	nlines = nlines + 1
	if (thisunit .lt. 0) then
          write(astring,212, err=666) 'Energy:  ',
     &		'EC:', qb_energy_ec,
     &		'ES:', qb_energy_es,
     &		'FE:', qb_energy_fe,
     &           qb_energy_fix, 
     &		'dM=',qb_energy_dM,
     &		'dA=',qb_energy_dA
	else
          write(thisunit,212, err=666) 'Energy:  ',
     &		'EC:', qb_energy_ec,
     &		'ES:', qb_energy_es,
     &		'FE:', qb_energy_fe,
     &           qb_energy_fix, 
     &		'dM=',qb_energy_dM,
     &		'dA=',qb_energy_dA
     	endif
 212    FORMAT(a9,a3,f7.3,1x,a3,f6.3,1x,a3,f7.3,1x,
     &          a5,2x,a3,f7.4,2x,a3,f7.4)
c 212    FORMAT(a9,a3,f7.3,1x,a3,f7.4,1x,a3,f7.3,1x,
c     &          a5,2x,a3,f7.4,3x,a3,f7.4)
      endif

C     Space (reciprocal lattice):
      if ((selection(1:3) .eq. 'All') .or. 
     &    (selection(1:5) .eq. 'Space')) then
	nlines = nlines + 1
	if (thisunit .lt. 0) then
          write(astring,213, err=666) 'Space:   ',
     &		'HC:',qb_space_hc(1),
     &		'KC:',qb_space_hc(2),
     &  	'LC:',qb_space_hc(3),
     &		'HS:',qb_space_hs(1),
     &		'KS:',qb_space_hs(2),
     &		'LS:',qb_space_hs(3)
	else
          write(thisunit,213, err=666) 'Space:   ',
     &		'HC:',qb_space_hc(1),
     &		'KC:',qb_space_hc(2),
     &  	'LC:',qb_space_hc(3),
     &		'HS:',qb_space_hs(1),
     &		'KS:',qb_space_hs(2),
     &		'LS:',qb_space_hs(3)
        endif
 213    FORMAT(a9,a3,f7.4,1x,a3,f7.4,1x,a3,f7.4,2x,
     &          a3,f7.4,2x,a3,f7.4,2x,a3,f7.4)
      endif

C     Orient:
      if ((selection(1:3) .eq. 'All') .or. 
     &    (selection(1:6) .eq. 'Orient')) then
	nlines = nlines + 1
	if (thisunit .lt. 0) then
          write(astring,214, err=666) 'Orient:  ','(h k l):',
     &    qb_orient_u(1), qb_orient_u(2), qb_orient_u(3),
     &	 'Angl:',qb_orient_angle,
     &   '(h k l)', qb_orient_v(1), qb_orient_v(2), qb_orient_v(3)
	else
          write(thisunit,214, err=666) 'Orient:  ','(h k l):',
     &    qb_orient_u(1), qb_orient_u(2), qb_orient_u(3),
     &	 'Angl:',qb_orient_angle,
     &   '(h k l)', qb_orient_v(1), qb_orient_v(2), qb_orient_v(3)
        endif
 214    FORMAT(a9,a8,i2,1h,, i2,1h,, i2,2x,a5, f7.3, 4x,a7,2h':,
     &	 	i2, 1h,,i2,1h,,i2)
	ENDIF

C     Temp/H:
      if ((selection(1:3) .eq. 'All') .or. 
     &    (selection(1:6) .eq. 'Temp/H')) then
	nlines = nlines + 1
	if (thisunit .lt. 0) then
          write(astring, 215, err=666) qb_temp_T0, qb_temp_incT, 
     &		qb_temp_wait, qb_temp_err, 
     &		qb_temp_hold0, qb_temp_hold, qb_temp_str1
	else
          write(thisunit, 215, err=666) qb_temp_T0, qb_temp_incT, 
     &		qb_temp_wait, qb_temp_err, 
     &		qb_temp_hold0, qb_temp_hold, qb_temp_str1
        endif
c 215    format ( 'Temp/H:  T0:', f7.3, 1x, 'Inc-T', f6.4, 2x, 
 215    format ( 'Temp/H:  T0:', f7.3, 1x, 'Inc-T', f6.2, 2x, 
     &		'Wait:', f4.1, 1x, 'Err:', f4.2, 1x, 
     &         'Hld0:', f4.1, 1x, 'Hld:', f4.1, 1x, a) 
c 215    format ( 'Temp/H:  T0:', f7.3, 2x, 'Inc-T', f5.3, 2x, 
c     &		'Wait:', f4.1, 'Err:', f4.1, 1x, 
c     &         'Hld0:', f4.1, 1x, 'Hld:', f4.1, 1x, a) 
c      write(thisunit,'(2a)', err=666) 
c     &	'Temp/H:  T0:12.000  Inc-T.00000', 
c     &     '  Wait:  0  ', 'Err:2.0  Hld0:  0  Hld:  0 Field'
c                   12345        1234x     1234x    123x
      endif

C     Time:
      if ((selection(1:3) .eq. 'All') .or. 
     &    (selection(1:4) .eq. 'Time')) then
	nlines = nlines + 1
	if (thisunit .lt. 0) then
          write(astring, 216, err=666) qb_time_monitor, qb_time_prefact,
     &		qb_time_mtype, qb_time_scanpts,
     &		qb_time_str1, qb_time_str2, qb_time_str3
	else
          write(thisunit,216, err=666) qb_time_monitor, qb_time_prefact,
     &		qb_time_mtype, qb_time_scanpts,
     &		qb_time_str1, qb_time_str2, qb_time_str3
cDebug        write (*,*) 'write_qbuf: debug qb_time_prefact=',qb_time_prefact    
	endif
 216    format('Time:    Monit:', i8, 1x, 'Prefac:', f4.1, 1x, 
     &      'M-typ:', a4, 2x, '#pts:', i6,
     &     2x, a4, 4x, a4, 1x, a4)
c 216    format('Time:    Monit:', i8, 1x, 'Prefac:', i4, 1x, 
c     &      'M-typ:', a4, 2x, '#pts:', i4,
c     &     2x, a4, 4x, a4, 1x, a4)
c        write(unitbufout,'(3a,i3,a)', err=666) 'Time:    Monit:  10000  ', 
c     &	   'M-typ:NEUT  #pts: ',npts,'   AMON    POLA '
      endif

c------------------------------------------------------------------------------
c...	Data file header style for files *.BT*

c------------------------------------------------------------------------------
c...	Error handling.

      go to 999
 660  write (*,*) 'qbufout: Error opening file:', file_bufout

      go to 699
 666  write (*,*) 'qbufout: Error writing to unit number:', whichunit
      write (*,*) 'qbufout: Selection = ', selection

 699  write_qbuf = .false.
 
 999  continue

cDebug      WRITE (*,*) 'write_qbuf: debug # of lines proceesed = ', nlines

      if ((selection(1:3) .eq. 'All') .and. 
     &	  (thisunit .eq. unitbufout )) then
	write (thisunit, *) ' '
        close (thisunit)
      endif

      write (*,*) 'write_qbuf: end', whichunit, ' "', selection, 
     &      '" "', astring, '"'

      return
      end
      
      
c====================================================================
      logical function qbuf_consistent()
c	 Double check that contents of q-buffer are consistent,
c	 especially after being modified.

      implicit none
      include 'arraysize.inc'
      include 'io_files.inc'
      include 'spur_buf.inc'
      include 'spur_warn.inc'

c...	local variables
      character*20 subwarn
      integer i
            
      qbuf_consistent = .true.
         do i = 1, 3
           if (qb_lattice_a(i) .lt. 1.0e-5) then 
	     qbuf_consistent = .false.
c....			123456789_123456789_
	     subwarn = 'Lattice parm not +  '
	     call set_warning(wbit_other, 1, subwarn)	 
	   endif
           if ((qb_lattice_angle(i) .ge. 180.0) .or.
     &	       (qb_lattice_angle(i) .lt. 0.0) ) then 
	     qbuf_consistent = .false.
c....			123456789_123456789_
	     subwarn = 'Lattice angle silly '
	     call set_warning(wbit_other, 1, subwarn)	 
	   endif
	 enddo

         if ((qb_time_scanpts .le. 0) .or. 
     &	     (qb_time_scanpts .gt. maxnpts)) then 
	     qbuf_consistent = .false.
c....			123456789_123456789_
	     subwarn = '# of scan pts silly '
	   call set_warning(wbit_npts, 1, subwarn)	 
	 endif

	 if ((abs(qb_space_hs(1)) .le. 1.0e-7) .and. 
     &	     (abs(qb_space_hs(2)) .le. 1.0e-7) .and.
     &	     (abs(qb_space_hs(3)) .le. 1.0e-7) ) then 
     	   if ((abs(qb_energy_es)  .le. 1.0e-7) .and. 
     &	       (abs(qb_temp_incT) .le. 1.0e-7) ) then
	     qbuf_consistent = .false.
c....			123456789_123456789_
	     subwarn = 'Nothing is stepped! '
	     call set_warning(wbit_step, 1, subwarn)	 
	   endif
	 endif

      return
      end
      
c====================================================================
      logical function verify_qbuf(a,aa,hc,hs,fe,ec,es,u,v,npts,mon,
     &      dm,da, updatebuf)
c	 Double check that we have not forgotten to update something
c	in qbuffer. 
c	updatebuf = true means copy passed variables to qb_* common block vars.
c	updatebuf = false means copy qb_* common block variables to passed vars

      implicit none
      include 'io_files.inc'
      include 'spur_buf.inc'

c...	passed variables
      REAL*4 a(3),aa(3),hc(3),hs(3)
      real fe, ec, es, dm, da
      INTEGER u(3),v(3), npts
      CHARACTER*5 mon !,monochromator
      logical updatebuf

c...      local variables
      integer i
      
      verify_qbuf = .true.

c	 Double check that we have not forgotten to update something.
         do i = 1, 3
           if (a(i) .ne. qb_lattice_a(i)) then 
	     if (updatebuf) then
	       qb_lattice_a(i) = a(i)
	     else
	       a(i) = qb_lattice_a(i)
	     endif
	     verify_qbuf = .false.
	     write (*,*) 'verify_qbuf: Hey programmer! Update qb_lattice_a', i  
	   endif
           if (aa(i) .ne. qb_lattice_angle(i)) then 
	     if (updatebuf) then
	       qb_lattice_angle(i) = aa(i)
	     else
	       aa(i) = qb_lattice_angle(i)
	     endif
	     verify_qbuf = .false.
	     write (*,*) 'verify_qbuf: Hey programmer! Update qb_lattice_angle', i  
	   endif
           if (hc(i) .ne. qb_space_hc(i)) then 
	     if (updatebuf) then
	       qb_space_hc(i) = hc(i)
	     else
	       hc(i) = qb_space_hc(i) 
	     endif
	     verify_qbuf = .false.
	     write (*,*) 'verify_qbuf: Hey programmer! Update qb_space_hc', i  
	   endif
           if (hs(i) .ne. qb_space_hs(i)) then 
	     if (updatebuf) then
	       qb_space_hs(i) = hs(i)
	     else
	       hs(i) = qb_space_hs(i)
	     endif
	     verify_qbuf = .false.
	     write (*,*) 'verify_qbuf: Hey programmer! Update qb_space_hs', i  
	   endif
           if (u(i) .ne. qb_orient_u(i)) then 
	     if (updatebuf) then
	       qb_orient_u(i) = u(i)
	     else
	       u(i) = qb_orient_u(i) 
	     endif
	     verify_qbuf = .false.
	     write (*,*) 'verify_qbuf: Hey programmer! Update qb_orient_u', i  
	   endif
           if (v(i) .ne. qb_orient_v(i)) then 
	     if (updatebuf) then
	       qb_orient_v(i) = v(i)
	     else
	       v(i) = qb_orient_v(i) 
	     endif
	     verify_qbuf = .false.
	     write (*,*) 'verify_qbuf: Hey programmer! Update qb_orient_v', i  
	   endif
	 enddo

         if (ec .ne. qb_energy_ec) then 
	     if (updatebuf) then
	        qb_energy_ec = ec
	     else
	       ec = qb_energy_ec 
	     endif
	     verify_qbuf = .false.
	   write (*,*) 'verify_qbuf: Hey programmer! Update qb_energy_ec'
	 endif
         if (es .ne. qb_energy_es) then 
	     if (updatebuf) then
	       qb_energy_es = es
	     else
	       es = qb_energy_es 
	     endif
	     verify_qbuf = .false.
	   write (*,*) 'verify_qbuf: Hey programmer! Update qb_energy_es'
	 endif
         if (fe .ne. qb_energy_fe) then 
	     if (updatebuf) then
	       qb_energy_fe = fe
	     else
	       fe = qb_energy_fe 
	     endif
	     verify_qbuf = .false.
	   write (*,*) 'verify_qbuf: Hey programmer! Update qb_energy_fe'
	 endif
         if (mon .ne. qb_energy_fix) then 
	     if (updatebuf) then
	       qb_energy_fix = mon
	     else
	       mon = qb_energy_fix 
	     endif
	     verify_qbuf = .false.
	   write (*,*) 'verify_qbuf: Hey programmer! Update qb_energy_fix'
	 endif
         if (dm .ne. qb_energy_dM) then 
	     if (updatebuf) then
	       qb_energy_dM  = dm
	     else
	      dm = qb_energy_dM 
	     endif
	     verify_qbuf = .false.
	   write (*,*) 'verify_qbuf: Hey programmer! Update qb_energy_dM' 
	 endif
         if (da .ne. qb_energy_dA) then 
	     if (updatebuf) then
	       qb_energy_dA  = da
	     else
	       da = qb_energy_dA  
	     endif
	     verify_qbuf = .false.
	   write (*,*) 'verify_qbuf: Hey programmer! Update qb_energy_dA' 
	 endif
         if (npts.ne. qb_time_scanpts) then 
	     if (updatebuf) then
	       qb_time_scanpts  = npts
	     else
	       npts = qb_time_scanpts 
	     endif
	     verify_qbuf = .false.
	   write (*,*) 'verify_qbuf: Hey programmer! Update qb_time_scanpts' 
	 endif

      return
      end
