	options/check=bounds
	SUBROUTINE SCANREF(ierr)
C
C ROUTINE TO PERFORM INTEGRATION SCAN
C
	integer ih(3),icount(400)
	include 'single.inc'
	include 'datacol.inc'
	include 'alph.inc'
	character*1 flag(3)
	character*8 timestring
C notes: 
C	scanref must be called after driving to reflection position
c	In common: cangl holds position of reflection
c		   fh holds hkl of reflection (optional)
c       Ierr set to 2 if open statement times out
c            set to 1 if drive goes outside softlimits
	ierr=0
c transfer parameters 
c
	tanth=tan(cangl(1)/114.5916)
        itype=nint(scan(1))
	maxrep=scan(7)
	irep=0
	iprec=scan(5)
	if(itype .eq. 1)then
		wscan=scn1/2.
	else
		wscan=scn1+scn2*tanth
	endif
	nstep=wscan/scan(3)+1      
	nbg=nstep/10
	timeps=scan(4)
c
c clear matrices
c 
	do i=1,nstep
	   icount(i)=0
	enddo
c	call wait
c
c back off from mean position of alpha1 and alpha2
c
50	if(itype .eq. 1)then
		posi = cangl(2)-wscan/2.+csep*tanth/2.
		call drive(2,posi,0,0,ierr)
	else
		posi = cangl(1)-wscan/2.+csep*tanth
		call drive(1,posi,0,0,ierr)
	endif
	if(ierr .eq. 1)return
C
C WAIT FOR DRIVE TO START POSITION COMPLETED
	call wait
	call onbeam
c
C START SCAN: COUNT AT STARTING POSITION
c
	irep=irep+1
	call count(timeps)
	call sclwt
	icount(1)=icount(1)+rdsclr()
C
	do 200 i=2,nstep
	  pos=(i-1)*scan(3)+posi		! CALC STEP POSTION
	  if(itype .eq. 1)then			! DRIVE TO IT
		call drive(2,pos,0,0,ierr)
		if(ierr .eq. 1)return
		call wtmtr(2)
	  else
		call drive(1,pos,0,0,ierr)
		if(ierr .eq. 1)return
		call wtmtr(1)
	  endif
C COUNT
	  call count(timeps)			! COUNT AT STEP POSITION
	  call sclwt
	  icount(i)=icount(i)+rdsclr()		! ADD COUNT TO ARRAY
200	continue
c
c estimate I, sigI
c
	sumcent=0.
	sumbg1=0.
	sumbg2=0.
 	do i=1,nbg
	  sumbg1=sumbg1+icount(i)
	  sumbg2=sumbg2+icount(nstep+1-i)
	enddo
	sumbg=sumbg1+sumbg2
	is=nbg+1
	if=nstep-nbg
	ncent=nstep-2*nbg
	do i=is,if
	  sumcent=sumcent+icount(i)
	enddo
	rint=sumcent - (ncent/2/nbg)*sumbg
	sigi=sqrt(sumcent + sumbg*(ncent/2/nbg)**2.)
c
c scale by count time, nstep, and total no. repetitions
	scalef=1./nstep/timeps/irep
	rint=rint*scalef
	sigi=sigi*scalef
	itime=timeps*irep
c
c check for constant precision mode
c if not skip to printing
c
	if(iprec .eq. 0)goto500
c
c check for max repetitions
   	if(irep .ge. maxrep)goto500
c
c check precision: repeat scan if necessary
	if(rint/sigi .lt. scan(6))goto50
c
c precision met....
C
C WRITE TO SCREEN
C
500     call ofbeam
	do i=1,3
		ih(i)=nint(fh(i))
		flag(i)=' '
	enddo
c
c set flags
c
	if(rint/sigi .lt. 3.0)flag(1)='L'
	if(istd .ne. 0)flag(2)='S'
c uneven bg's
	bsig=sqrt(sumbg1+sumbg2)
	if(abs(sumbg1-sumbg2) .gt. 5.*bsig)flag(3)='B'
	sumbg1=sumbg1/nbg/irep/timeps
	sumbg2=sumbg2/nbg/irep/timeps
c time
      	call time(timestring)
c
	type 510,iseq,ih,cangl,psi,rint,sigi,flag,timestring(1:5)
510	format(i5,':',3i4,2f7.2,2f8.2,f7.1,':',f9.1,f5.1,1x,3a1,1x,a5)
c
c write to file
c
515	open(unit=20,file=filename,status='unknown',access='append',
     1       carriagecontrol='list',err=600)
	iwait=0
c
	write(20,520)nstep,itime,(icount(i),i=1,21)
520	format('*',i3,i2,21i6)
	if(nstep .gt. 21)then
		write(20,530)(icount(i),i=22,nstep)
530		format('*',5x,21i6)
	endif
	unity=1.0
	write(20,540)iseq,istd,ih,cangl,sumbg1,sumbg2,rint,sigi,
     1   unity,unity
540	format(i5,i1,3i3,4f8.3,2f8.1,4f10.3)
	close(unit=20)
C INCRMENT ISEQ
	ISEQ=ISEQ+1
	RETURN
c
c here if error on open file
c - wait in case temporary lock-out
600	if(iwait .gt. 300)then
		ierr=2
		type 610
610		format(' **********DATA FILE LOCKED - DATA COLLECTION ABORTED')
		return
	else
		iwait=iwait+1
        	call delay(1000)
		goto515
	endif
	END
	options/extend
	SUBROUTINE INTEGR
C
C ROUTINE TO INTEGRATE A SINGLE REFLECTION
C
	character*1 iresp
	include 'single.inc'
	include 'datacol.inc'
c
c first list scan parameters
c
	call listscan(2)
9	type 10
10	format(//'$ Do you wish to continue? ')
	read(5,20,end=9999,err=9)iresp
20	format(a1)
	if(iresp .ne. 'y' .and. iresp .ne. 'Y')return
c
c start loop over indices: request indices
c
	call setiseq
	call printheader
100	type 110
110	format('$ Input indices:')
	read(5,120,end=9999,err=100)i,fh
120	format(q,3f6.0)
	if(i .eq. 0)goto9999
c
	call calphi(fh,thphi)
	call calca(thphi,cangl,ierr)
	if(ierr .eq. 0)then
		psi=0.
		call drivep(0,ierr)
		call scanref(ierr)
		if(ierr .eq. 1)return
	else
		type 130
130		format(5x,' Reflection Inaccessable')
	endif
	goto100
9999	return
	END
C
C ROUTINE TO INITIATE DATA COLLECTION: AUTO GENERATION OF INDICES
C
	options/check=bounds/extend
	SUBROUTINE INTALL
c
	integer*4 lib$stat_timer,jtime(2),elaptime(2),deltime(2)
	real*4 pmat(3,3),psistart
	integer hkl(3),idirn(3)
	character*20 string
	character*9 datestring
	character*1 iresp
	include 'single.inc'
	include 'datacol.inc'
C
C FIRST LIST ALL SCAN/COLLECTION PARAMETERS
	CALL LISTSCAN(1)
9	type 10
10	format(//'$ Do You Want to Start Data Collection? ')
	read(5,20,end=9999,err=9)iresp
20	format(a1)
	if(iresp .ne. 'Y' .and. iresp .ne. 'y')return
c
c now initiate data collection
c
25	type 30
30	format(/'$ Input Shell No. to Collect First: ')
	read(5,40,end=9999,err=25)initsh
40	format(i5)
	if(initsh .lt. 1)goto25
	if(shell(1,initsh) .lt. 0.001 .and. shell(2,initsh) .lt. 0.001)return
49	type 50
50	format('$ Input Indices of First Reflection: ')
	read(5,60,end=9999,err=49)hkl
60	format(3i5)
	call setiseq
c
c encode  stdtime
c
	ihtime=stdtime/60
	imtime=int(stdtime-ihtime*60)
	write(string,66)ihtime,imtime
66	format('0 ',i2.2,':',i2.2,':00.00')
	call sys$bintim(string,jtime)

c
c**********
c duplicate hklr into reals rhklr
	do i=1,6
	  rhklr(i)=hklr(i)
	enddo
c calculate initial and final indices: 
c 
	call setindex
c
c check indices in requested shell - set up initial indices and increment flags
c
	i=abs(hkl(1))+abs(hkl(2))+abs(hkl(3))
	if(i .ne. 0)then
		call inshell(hkl,ierr)
		if(ierr .ne. 0)then
		 type 70
70		 format(' Initial reflection not in shell!'
     1		  /'        Use 0,0,0 to initialize shell.')
	   	 goto25
	        endif
	        call setindexfast(hkl(iorder(3)))
	else
c
c here if 0,0,0 entered as initial indices
		do i=1,3
		  hkl(i)=hklinit(i)
		enddo
 	endif
c
c set increment directions
c
	do i=1,3
		idirn(i)=sign(1,hklr(2*i)-hklr(2*i-1))
	enddo
c
c initialise psi-scan info
c
	npsi=scan(2)
	psistart=-1.*float((npsi-1)/2)*scan(9)
c
c
c start data collection - initialise counters
c
	call date(datestring)
 	type 100,title,initsh,shell(1,initsh),shell(2,initsh),datestring
100	format(/1x,80('*')/10x,60a1/2x,'SHELL NO ',i2,' FROM ',F5.2,' TO ',F5.2,' TWO-THETA',
     1  ' STARTED ON ',A9)
	call printheader
c
c collect initial standards
c
	call standard(iorient)
	if(iorient .eq. 2)return
	goto300
c
c
c **********START OF LOOP OVER SHELL
c
200	continue
c
c write shell header
c
	call date(datestring)
	type 100,title,initsh,shell(1,initsh),shell(2,initsh),datestring
	call printheader
c
c       test reflection for being in shell
c 	
300	call inshell(hkl,ierr)
310	if(ierr .ne. 0)goto500
	call allowed(iabsent)
c check iabsent against collection flag scan(8)
	if(iabsent.eq.1.and.scan(8).gt.1.5 .or. iabsent.eq.0.and.scan(8).lt.1.5)goto500
	if(iseq-iprint .gt. 60)call printheader
c
c collect reflection
c (calphi already called from inshell to get thphi)
c 
	call calca(thphi,cangl,ierr)
	if(ierr .ne. 0)goto500
c
c branch on multiple/single psi value
	if(npsi .gt. 1)then
		call psimat(cangl,pmat)
		do 400 k=1,npsi
		   psi=psistart+(k-1)*scan(9)
		   call psiang(pmat,psi,cangl,ierr)
		   if(ierr .ne. 0)goto400
		   call drivep(0,ierr)
		   call scanref(ierr)
		   if(ierr .eq. 2)return
400		continue
	else
		   psi=0.0
		   call drivep(0,ierr)
		   call scanref(ierr)
		   if(ierr .eq. 2)return
	endif
c
c test for time to do standard
c
c
	call lib$stat_timer(%ref(1),%ref(elaptime),)
c NB: times are DELTA TIMES AND THEREFORE NEGATIVE
	call subquad(jtime,elaptime,deltime)
	if(deltime(2) .ge. 0)then
		     call standard(iorient)
		     if(iorient .eq. 2)return
	endif
c
c increment fastest index:test for exceeding top limit
c
500	hkl(iorder(1))=hkl(iorder(1))+idirn(iorder(1))	
	if(irngchk(hkl,iorder(1)) .ge. 0)goto300
c
c fastest index reached limit
c
c
c first reset fastest
	hkl(iorder(1))=hklinit(iorder(1))
c
c increment 2nd fastest
	hkl(iorder(2))=hkl(iorder(2))+idirn(iorder(2))
	if(irngchk(hkl,iorder(2)) .ge. 0)goto300
c 
c 2nd fastest index reached limit
c increment slowest
c
	hkl(iorder(3))=hkl(iorder(3))+idirn(iorder(3))
	if(irngchk(hkl,iorder(3)) .ge. 0)then
c
c reset limits to fastest, 2nd fastest
	call setindexfast(hkl(iorder(3)))
c set hkl to lower limit
	hkl(iorder(1))=hklinit(iorder(1))
	hkl(iorder(2))=hklinit(iorder(2))
	goto300
	endif
c **********************
c got here if end of shell
c first do standards
			call standard(iorient)
			if(iorient .eq. 2)return
c 
c increment shell number and check for collection
c
	initsh=initsh+1
	if(shell(1,initsh) .gt. 0.001 .and. shell(2,initsh) .gt. 0.001)then
c
c reset indeces for new shell
c
	call setindex
c
c set hkl to initial values
	   do i=1,3
		hkl(i)=hklinit(i)
	   enddo
	   goto200
	endif
c
c end of data collection
c
	do i=1,4
		cangl(i)=0.
	enddo
	call drivep(0,ierr)
	type 999
999	format(/30x'****END OF DATA****')
9999	RETURN
	END
C
C ROUTINE TO INITIATE DATA COLLECTION OF INDICES FROM LIST:
C EITHER AN ASCII FILE LISTING OR THE CENTERED REFLECTION LIST
C
	options/extend
	SUBROUTINE INTLIST
c
	integer*4 lib$stat_timer,jtime(2),elaptime(2),deltime(2)
	real*4 pmat(3,3),psistart,thkl(3)
	character*20 string
        character*40 listname
	character*9 datestring
	character*1 iresp
	include 'single.inc'
	include 'datacol.inc'
C
C FIRST LIST ALL SCAN/COLLECTION PARAMETERS
	CALL LISTSCAN(2)
9	type 10
10	format(//'$ Do You Want to Start Data Collection? ')
	read(5,20,end=9999,err=9)iresp
20	format(a1)
	if(iresp .ne. 'Y' .and. iresp .ne. 'y')return
c
c now initiate data collection
c
25	type 30
30	format(/'  Input Name of File With Indices '/
     1	'$  or <CR> for reflections from centering list: ')
35	read(5,40,end=9999,err=25)iflag,listname
40	format(q,a40)
	if(iflag .ne. 0)then
	  open(unit=30,status='old',file=listname,err=45,readonly)
	  rewind 30
	  goto49
45	  type 41,listname
41	  format(' Error opening file ',a40/'$ Input new filename: ')
	  goto35
49	  type 50
50	  format('$ Input Indices of First Reflection: ')
	  read(5,60,end=9999,err=49)fh
60	  format(3f6.0)
c
c find indices of first reflection
c
	  test=abs(fh(1))+abs(fh(2))+abs(fh(3))
	  do i=1,3
		thkl(i)=fh(i)
	  enddo
	  if(test .ne. 0)then
65		read(30,60,end=900,err=9990)fh
		do i=1,3
		  if(abs(thkl(i)-fh(i)) .gt. 0.01)goto65
                enddo
	  else
		read(30,60,end=900,err=9990)fh
	  endif
	endif
	call setiseq
c
c encode  stdtime
c
	ihtime=stdtime/60
	imtime=int(stdtime-ihtime*60)
	write(string,66)ihtime,imtime
66	format('0 ',i2.2,':',i2.2,':00.00')
	call sys$bintim(string,jtime)
c
c initialise psi-scan info
c
	npsi=scan(2)
	psistart=-1.*float((npsi-1)/2)*scan(9)
	in=0
c
c
c start data collection - initialise counters
c
	call date(datestring)
 	type 100,title,datestring
100	format(/1x,80('*')/10x,60a1/10x,'LIST-BASED DATA COLLECTION'
     1  ' STARTED ON ',A9)
	call printheader
c
c collect initial standards
c
	call standard(iorient)
	if(iorient .eq. 2)return
c
c if doing reflections from internal list, go get the first
	in=0
	if(iflag .eq. 0)goto500
C
C top of loop over reflections
c
300	if(iseq-iprint .gt. 60)call printheader
c
c collect reflection
c       
	call calphi(fh,thphi)
	call calca(thphi,cangl,ierr)
	if(ierr .ne. 0)goto500
c
c branch on multiple/single psi value
	if(npsi .gt. 1)then
		call psimat(cangl,pmat)
		do 400 k=1,npsi
		   psi=psistart+(k-1)*scan(9)
		   call psiang(pmat,psi,cangl,ierr)
		   if(ierr .ne. 0)goto400
		   call drivep(0,ierr)
		   call scanref(ierr)
		   if(ierr .eq. 2)return
400		continue
	else
		   psi=0.
		   call drivep(0,ierr)
		   call scanref(ierr)
		   if(ierr .eq. 2)return
	endif
c
c test for time to do standard
c
c
	call lib$stat_timer(%ref(1),%ref(elaptime),)
c NB: times are DELTA TIMES AND THEREFORE NEGATIVE
	call subquad(jtime,elaptime,deltime)
	if(deltime(2) .ge. 0)then
		     call standard(iorient)
		     if(iorient .eq. 2)return
	endif
c
c read next reflection from file
c
500	if(iflag .ne. 0)then
	  read(30,60,end=890,err=9990)fh
	else
550	  in=in+1
	  if(in .gt. nlst)goto890
	  if(iuse(in) .eq. 0)goto550
	  do i=1,3
		fh(i)=ihlst(i,in)
	  enddo
	endif
        goto300
c
c end of data collection
c
890	call standard(iorient)
891	do i=1,4
		cangl(i)=0.
	enddo
	call drivep(0,ierr)
900	type 999
999	format(/30x'****END OF DATA****')
	close(unit=30)
9999	RETURN
9990	type 9991,fh
9991	format(' ************DATA COLLECTION STOPPED BY ERROR IN LIST FILE*******'/
     1	'      LAST REFLECTION READ WAS: ',3F7.2)
   	GOTO891
	END
C
C ROUTINE TO PERFORM PSI-SCAN
C
	SUBROUTINE PSISCAN
	include 'single.inc'
	include 'datacol.inc'
	real*4 hkl(3,30)
	character*1 iresp
	real pmat(3,3),psimin,psimax,psistep
c
c
c first list scan parameters
c
	call listscan(3)
9	type 10
10	format(//'$ Do you wish to continue? ')
	read(5,20,end=9999,err=9)iresp
20	format(a1)
	if(iresp .ne. 'Y' .and. iresp .ne. 'y')return
	call setiseq
c
c request start,finish and step
c
25	type 30
30	format(/'$ Input psi min,max, and step :')
	read(5,35,end=9999,err=25)psimin,psimax,psistep
35	format(3f10.0)
	if(sign(psimax-psimin,psistep) .gt. 0)goto99
	type 40
40	format('  Input values invalid....')
	goto25
c
c start loop to request indices: 
c
99	no=0
100	type 110
110	format('$ Input indices:')
	read(5,120,end=9999,err=100)i,(hkl(j,no+1),j=1,3)
120	format(q,3f6.0)
	if(i .eq. 0 )goto150
	no=no+1
	if(no .lt. 30)goto100
c
150	call printheader
c
c loop over reflections
c
	do 300  i=1,no
		do j=1,3
		  fh(j)=hkl(j,i)
		enddo
	    	call calphi(fh,thphi)
		call calca(thphi,cangl,ierr)
		if(ierr .eq. 1)goto300		
		call psimat(cangl,pmat)
c 
c start psi loop
c
 		do 400 psi=psimin,psimax,psistep
		   if(iseq-iprint .gt. 60)call printheader
		   call psiang(pmat,psi,cangl,ierr)
		   if(ierr .ne. 0)goto400
		   call drivep(0,ierr)
		   call scanref(ierr)
		   if(ierr .eq. 2)return
400		continue		  		  		  
300	continue
9999	RETURN
	END
C
C ROUTINE TO LIST SCAN/COLLECTION PARAMETERS
C
	SUBROUTINE LISTSCAN(iflag)
c
c IFLAG determines what information is printed:
c	=1  All information (for complete data collection)
c	=2  Scan information (For list-based or single reflections)
c	=3  Scan information without psi-scan info (For psi-scans)
c
	integer iflag
	CHARACTER*20 STRING
	byte filenam(80)
	character*1 hklstring(3),t(3)
	include 'single.inc'
	include 'datacol.inc'
	include 'symmetry.inc'
	common/alph/filenam
	data hklstring/'h','k','l'/
c
	TYPE 10
10	FORMAT(/80('*')/30X,'SCAN PARAMETERS')
c
c print scan type
c
	if(int(scan(1)) .eq. 1)then
	   sw=scn1/2.
	   type 20,sw
20	   format(/'  Scan type is omega, scan width = ',f5.2)
	else
	   type 25,scn1,scn2
25	   format(/'  Scan type is omega/2theta, width = ',f5.2,'+'
     1     ,f5.2,' 2theta')
	endif
c
c print scan step/time
	type 30,scan(3),scan(4)
30	format('  In Steps of ',f5.3,' degrees; ',f5.2,' secs per step')
c
c multiple psi scans
	if(iflag .eq. 3)goto42
	if(abs(scan(2)-1) .lt. 0.0001)then
	  type 35
35	  format('  No multiple psi scans')
	else
	  i=int(scan(2))
	  type 40,i,scan(9)
40	  format(1x,i3,' scans each refln at ',f7.2,' degree intervals'
     1    ,' in psi')
	endif
c
c constant precision
42      if(scan(5) .lt. 0.001)then
	   type 45
45	   format('  Each reflection with fixed scan time')
	else
	   j=int(scan(7))
           type 50,scan(6),j
50	   format('  Constant precision mode: min(I/sigI) = ',f4.1,
     1     ' Max no. scans = ',i3)
	endif
c
c bisecting/fixed phi mode
c
	call printdevice
c
c now data collection parameters
c
	  type 100
100	  format(/22x,'DATA COLLECTION PARAMETERS'//)
c
c filename
	type 60,filenam
60	format('  Reflection File: ',80a1)
	type 70,title
70	format('            Title: ',60a1)
c
c standards
	if(nstd .ne. 0)then
	  type 80,nstd,stdtime
80	  format(/'  Number Std Reflns: ',i2,' Time between stds: ',i4)
	  type 90,((ihkstd(j,i),j=1,3),i=1,nstd)
90	  format('  Standard Indices:',5(3i3,3x))
	else
	  type 95
95	  format(/' No standard reflections ')
	endif
c
c remainder only for full data collection
c
	if(iflag .ne. 1)return
c
c re-orientation (disabled)
c	if(scan(10) .gt. 0.5)type 95
c95	format('  Reorientation if standards move')
c
c data range/incr order
c
	type 105,hklr
105	format(/'  Ranges of h,k,l will be: ',6i3)
	do i=1,3
	  	t(i)=hklstring(iorder(i))
	enddo
	type 110,t
110	format('  Increment order (fastest first): ',3(a1,2x))
c
c shell info
	ish=0
115	ish=ish+1
	if(shell(1,ish) .gt. 0.0001 .or. shell(2,ish) .gt. 0.0001)
     1    goto115
	ish=ish-1
	type 120,ish
120	format(/'  Data will be collected in ',i2,
     1  ' shells of 2theta ranges:')
	do i=1,ish
	  type 125,i,shell(1,i),shell(2,i)
125	  format(i5,':',f6.2,' to ',f6.2,' degrees two-theta')
	enddo
c	
c space group information
c
	type 128,spg
128	format(/' Space group is ',20a1)
	if(abs(scan(8)-1.0) .lt. 0.001)then
	    type 130
130	    format(/'  Space Group Violations will NOT be collected')
	else
	    type 135
135	    format(/'  ONLY Space Group Violations will be collected')
	endif

	RETURN
	END
c
c 	
	options/check=bounds
	SUBROUTINE INSHELL(hkl,ierr)
C
	integer hkl(3)
	include 'single.inc'
	include 'datacol.inc'
c
c subroutine to check for reflection being in given two-theta shell
c
c returns ierr=0 if inside, ierr=1 if outside
c
	ierr=0
	isum=0
	do i=1,3
              isum=isum+abs(hkl(i))
	      fh(i)=hkl(i)
	enddo
	if(isum .eq. 0)then
		ierr=1
	else
		call calphi(fh,thphi)
                tangle=ttheta(ierr)
		if(ierr .eq. 1)return
		if(tangle .lt. shell(1,initsh))ierr=1
		if(tangle .ge. shell(2,initsh))ierr=1
	endif
	return
	end
c
	options/check=bounds
	FUNCTION TTHETA(ierr)
	include 'single.inc'
	include 'datacol.inc'
c
c subroutine to calculate 2theta given Hphi matrix
c
	ierr=0
 	sum=0.
	do i=1,3
		sum=sum+thphi(i)*thphi(i)
	enddo
	STH=(WAVEL*SQRT(SUM)/2.)
	if(abs(sth).gt.1)then
	  ierr=1
	   ttheta=90.
	else
	   TTHETA=114.5916*ASIN(STH)
	endif
	RETURN
	END
c
c
	options/check=bounds
	SUBROUTINE ALLOWED(iabsent)
c
	include 'single.inc'
c
c subroutine to check if reflection allowed by space group
c
c returns iabsent=1 if allowed, iabsent=0 if not allowed
c
	iabsent=0
	if(latabs(fh).eq.0)return
	if(ispabs(fh).eq.0)return
	iabsent=1
	return
	end
 
	options/check=bounds/extend
	subroutine setindex
c
c subroutine to set limits to slowest index at start of shell
c
	include 'single.inc'
	include 'datacol.inc'
c
	   sthmax=sin(shell(2,initsh)/114.5916)
	   slowmax=1+(2.*cell(iorder(3))*sthmax/wavel)
c initial
 	   if(hklr(2*iorder(3)-1).eq.0)then
		hklinit(iorder(3))=0
           else
		hklinit(iorder(3))=sign(slowmax,rhklr(2*iorder(3)-1))
	   endif
c final
	   if(hklr(2*iorder(3)).eq.0)then
		hklend(iorder(3))=0
	   else
		hklend(iorder(3))=sign(slowmax,rhklr(2*iorder(3)))
	   endif
c now do other two for initial value of slowest index
c
	call setindexfast(hklinit(iorder(3)))
	return
	end
c
c
	options/check=bounds/extend
	SUBROUTINE SETINDEXFAST(ihslow)
c
c subroutine to set limits on fastest and 2nd fastest
c indeces given value of slowest index in ihslow
c
c called every time slowest index is changed
c
	include 'single.inc'
	include 'datacol.inc'
c
	term1=(2.*sin(shell(2,initsh)/114.5916)/wavel)**2.
	do i=1,2
	   term2=term1-(ihslow/cell(iorder(3)))**2.
	   if(term2 .lt. 0)then
		term2=0
	   else
		term2=sqrt(term2)
	   endif
c set initial values 
	   if(hklr(2*iorder(i)-1).eq. 0)then
	   	hklinit(iorder(i))=0
	   else
	 	hklinit(iorder(i))=sign(term2*cell(iorder(i))+1.,rhklr(2*iorder(i)-1))
	   endif
c set final values
	   if(hklr(2*iorder(i)) .eq. 0)then
		hklend(iorder(i))=0
	   else
		hklend(iorder(i))=sign(term2*cell(iorder(i))+1.,rhklr(2*iorder(i)))
	   endif
	enddo
	return
	end
	function irngchk(hkl,n) 
c
	include 'datacol.inc'
	integer hkl(3),n
c
	irngchk=(hkl(n)-hklinit(n))*(hklend(n)-hkl(n))
	return
	end
c
	options/check=bounds
	SUBROUTINE STANDARD(iorient)
c
	include 'single.inc'
	include 'datacol.inc'
	real pos(4),del(2)
	integer*4 lib$init_timer,laststd
	save laststd
	data laststd/0/
c
	iorient=0
	if(iseq .eq. laststd)return
c
1	ierr=0
	do i=1,nstd
		do j=1,3
			fh(j)=ihkstd(j,i)
		enddo
		call calphi(fh,thphi)
		call calca(thphi,cangl,ierr)
		if(ierr .eq. 0)then
		   call drivep(0,ierr)
c centre reflection
		   call wait
		   call onbeam
		   call minicenter(ifnd,width)
		   if(ifnd .ne. 0)then
c problem- peak not found
			call ofbeam
			ierr=1
			type 10,(ihkstd(j,i),j=1,3)
10			format(6x,3i4,' Standard not found -',
     1			' recentering')
			goto200
		   else
c peak found and centred
			call rdallmtr(pos)
			del(1)=pos(2)-cangl(2)
			del(2)=pos(3)-cangl(3)
c test centred position if requested -commented out until motorised 
c    detector slits available
c			if(scan(10) .gt. 0.5)then
c			  if(abs(del(1)) .gt. 0.1)goto150
c			  if(abs(del(2)) .gt. 0.2)goto150
c			endif
c if centring ok - scan
			istd=i
			call scanref(ierr)
			if(ierr .eq. 1)type 30,(ihkstd(j,i),j=1,3)
			if(ierr .eq. 2)goto300
			type 15,del
15			format(18x,'DELTAS:',f7.2,f8.2)
	 	   endif
		else
c standard out-of-bounds
		   type 30,(ihkstd(j,i),j=1,3)
30		   format(6x,3i4,' Standard out of bounds')  
		endif
	enddo
c reset timer
c
	call lib$init_timer()
	istd=0
	laststd=iseq
	return
c
c peak has moved
c
c150	type 20,(ihkstd(j,i),j=1,3),cangl,pos
20	format(6x,3i4,2f7.2,2f8.2,'   Standard refln moved',
     1		' to-'/18x,2f7.2,2f8.2)
c
200	if(iorient .ne. 0)goto250
C	call zref
C	call lsq
	iorient=1
	goto1
c
250	type 260
260	format(' Reorientation failed -abort data collection')
	iorient=2
	return
c
c open file timed out
300	iorient=2
	return
	end
c
c
	options/check=bounds
	SUBROUTINE PRINTHEADER
c
c  puts header on screen for data collection
c
	include 'datacol.inc'
c
	type 10
10	format(/2x,'SEQ',4X,'H',3X,'K',3X,'L',' 2THETA',2X,
     1  'OMEGA',5X,'CHI',5X,'PHI','    PSI    INT    SIGI FLAG TIME'/)
	iprint=iseq
	return
	end
c
	options/check=bounds
	SUBROUTINE SETISEQ
c
c sets iseq at beginning of data collection etc

	include 'datacol.inc'
c
c on intial startup iseq=0:set to 1
c
	if(iseq .eq. 0)iseq=1
9	type 10,iseq
10	format('$ Input Initial Sequence Number, <return> for',i5, ':')
	read(5,20,end=9999,err=9)i
20	format(i5)
	if(i .le. 0)return
        iseq=i
9999	return
	end
