	SUBROUTINE ANGCAL
C
C ROUTINE TO CALCULATE ANGLES FOR A REFLECTION
C
	implicit none
	include 'single.inc'
	real*4 thphi(4)
	integer*4 i,j,ierr
C
100	if(stringin.eq.' ')then
c no indices on line
1	  TYPE 2
2	  FORMAT('$Type Indices(Blank to exit)?')
	  read(5,4,end=9999,err=1)I,FH
4	  FORMAT(Q,3F10.0)
	  IF(ABS(FH(1))+ABS(FH(2))+ABS(FH(3)).LE.0.001)RETURN
	else
	  read(stringin,4,err=9999)i,fh
	endif
	IF(ABS(FH(1))+ABS(FH(2))+ABS(FH(3)).LE.0.001)RETURN
	if(i.le.0)return
	CALL CALPHI(FH,THPHI)
	CALL CALCA(THPHI,CANGL,IERR)
	IF(IERR.eq.0)then
	  TYPE 6,(CANGL(J),J=1,4)
6	  FORMAT(' Calculated Angles:',4F9.3)
	else
	    TYPE 8
8	    FORMAT(' OUT-OF-BOUNDS')
	endif
	if(stringin.eq.' ')go to 100
9999	return
	END
	SUBROUTINE GETCL
C
C ROUTINE TO ACQUIRE UNIT CELL PARAMETERS
C
	implicit none
	include 'single.inc'
	real*4 temp(6)
	integer*4 i,j
C
c print old cell
c
	type 10,(cell(i),i=1,6)
10	format(/' Current Unit Cell: ',6f8.3)
	if(stringin.eq.' ')then
100		TYPE 2
2		FORMAT('$Type New Cell Edges and Angles, <CR> for no change? ')
		read(5, 4,end=9999,err=100)j,(temp(i),i=1,6)
4		FORMAT(q,6F10.0)
		if(j .eq. 0)return
	else
		read(stringin,'(6f10.0)',err=100)temp
	endif
	do i=1,6
		cell(i)=temp(i)
	enddo
	do i=4,6
		if(abs(cell(i)).lt.1.0)cell(i)=90.0
	enddo
	CALL CALCB(CELL,B)
c
c Make UB = B, i.e. U = I
c
	call pushom
	do i=1,3
	    do j=1,3
		ub(j,i)=b(j,i)
	    enddo
	enddo
	if(stringin.ne.' ')type 20,(cell(i),i=1,6)
20	format(/'     New Unit Cell: ',6f8.3)
	call update
	call omtob(1)
9999	RETURN
	END
	options/extend
	SUBROUTINE SETUP
C
C ROUTINE TO SET PARAMETERS
C
	implicit none
	include 'single.inc'
	include 'datacol.inc'
	include 'symmetry.inc'
	include 'device.inc'
	character*1 ans,t(3),ttitle(60),spgtemp(20)
	integer*4 itemp(6),iset,i,j,k,ierr,ispg,isum,itime
	real*4 ts(5),temp1,temp2,temp3,rtime
	character*80 tempa
	include 'alph.inc'
	BYTE RESP
C
C
9000	type 9010
9010	format(/1X,32('*'),'SETUP - TOP MENU',32('*')
     1  /'  INPUT 1 to set general parameters'
     2  /8x,'2 to set device constraints'
     3  /8x,'3 to set scan parameters'
     4  /8x,'4 to set data collection parameters'
     5  /8x,'5 to set filenames'
     6  /'$ INPUT? ')
9015	read(5,'(i1)',end=9999,err=9020)iset
	if(iset  .eq. 0)goto9999
        if(iset .gt. 0 .and. iset .lt. 6)goto9030
9020	type 9025
9025	format('$  Invalid value entered, try again:')
	goto9015
c
c branch on iset
9030	goto(1000,2000,3000,4000,5000),iset
c        
c general parameters
c
1000	type 1005
1005	FORMAT(/1X,28('*'),'SETUP GENERAL PARAMETERS',28('*')/)
1001    type 1011,title
1011	format('   Experiment Title is: ',60a1/
     1  '$  Type New Title, <RETURN> for NO Change?')
	read(5,106,end=9000,err=1001)i,ttitle
106	format(q,60a1)
	if(i .le.0)goto1
	do i=1,60
		title(i)=ttitle(i)
	enddo
c
1	TYPE 2,wavel
2	FORMAT(/'$  Type Value of Lambda, <RETURN> for ',f6.4,':')
	read(5,4,end=9000,err=1)I,TEMP1
4	FORMAT(Q,5F10.0)
	IF(I.GT.0)then
	  wavel=temp1
	  if(abs(wavel-1.542) .lt. 0.1)csep=0.141
	  if(abs(wavel-0.709) .lt. 0.1)csep=0.345
	endif
7	TYPE 8,scn1,scn2
8	FORMAT(/'$  Type New Scan Width Parameters, <RETURN> for',2f5.2,':')
 	read(5,4,err=7)I,TEMP1,TEMP2
	IF(I.LE.0)GO TO 100
	  SCN1=TEMP1
	  SCN2=TEMP2
100     type 101,nint(minct),maxmin,nint(tmax)
101	format(/'   Parameters for Peak Centering:'/
     1  3x,'Min Count Rate: ',i3,' cps, Max/Min Rate >',f4.1,', Max Time per step: ',i2, 'secs'/
     2  '$  Input new values, <RETURN> for no change:')
	read(5,4,end=9000,err=100)i,temp1,temp2,temp3
	if(i .gt. 0)then
		if(temp1 .gt. 0)minct=temp1
		if(temp2 .gt. 1. .and. temp2 .lt. 50.)maxmin=temp2
		if(temp3 .gt. 1. .and. temp3 .lt. 60.)tmax=temp3
	endif      
c
109	if(badcrystal)then
	  type 110
110	  format(/' Final omega scan on peak centering by PARABOLIC fit')
	else
	  type 111
111	  format(/' Final omega scan on peak centering by PROFILE fit')
	endif
	type 112
112	format('$  Input 1 to toggle to other method: ')
	read(5,4,end=9000,err=100)i,temp1
	if(i .lt. 1)goto9000
	if(badcrystal)then
	  badcrystal=.false.
	else
	  badcrystal=.true.
	endif
	goto109
c
c files                       
c
5000	type 5005
5005	format(/1x,32('*'),'SETUP FILE NAMES',32('*'))
c
	call read_orient
c
	TYPE 5010,filename
5010	FORMAT(/'  Reflection file is: ',a80/
     1  '$ Type New Reflection File Name, <RETURN> for NO Change?')
5020	read(5,5030,end=9000,err=5099)I,TEMPA
5030	FORMAT(Q,a80)
	IF(I.gt.0)FILeNAMe=TEMPA
	goto9000
5099	type 5098
5098	format('$  Error in Input - Retype Filename: ')
	goto5020
c
c device type
c
2000	TYPE 2001
2001	FORMAT(/1X,28('*'),'SETUP DEVICE CONSTRAINTS',28('*'))
	call printdevice
	call device_update
       goto9000
c
c
c section to enter data collection parameters
c
4000	TYPE 4001
4001	FORMAT(/1X,24('*'),'SETUP DATA COLLECTION PARAMETERS',24('*')/)
C
c get space group and call conversion routines
c
	ispg=0
4002	if(spg(ispg) .eq. ' ' .and. spg(ispg+1) .eq. ' ')goto4010
        ispg=ispg+1
	if(ispg .lt. 60)goto4002
c
c fix if null space group - ispg now =60
	ispg=1
4010	if(ispg.eq.0 .or. ispg.gt.59)then
	  type 4015
4015	  format('$ Type New Space Group ?')
	else
	  TYPE 4020,(spg(i),i=1,ispg)
4020	  FORMAT('$  Type New Space Group, <RETURN> for ',<ispg>a1,'?')
	endif
4030	read(5,16,end=9000,err=4010)i,spgtemp
16	format(q,20a1)
	if(i.gt.0)then
	  do j=1,20
		spg(j)=spgtemp(j)
	 enddo
	endif
	call symmetry(ierr)
	if(ierr  .eq. 0)goto320
	    type 18
18	    format('   Error in Space Group Processing -'/
     1       '$ Type New Space Group ')
        goto4030
c
c set collect absence/presence
c
320	type  322
322	format('/  Enter 1 to collect allowed reflections only'/
     1  '$        2 to collect absent reflections only:')
  	read(5,325,end=9000,err=320)i
325	format(i1)
	if(i .ne. 1 .and. i .ne. 2)goto320
	scan(8)=i
c
c get hkl collection ranges and increment order
c
140	type 200,hklr
200	format(/'   hkl ranges are: ',3(2i3,',')/
     1  '$  Input h,k,l ranges: <RETURN> for NO Change?')
	read(5,202,end=9000,err=140)i,itemp
202	format(q,6i3)
	if(i .ne. 0)then
	   do i=1,6
		hklr(i)=itemp(i)
	   enddo
	endif 
204	isum=0
	do 205 i=1,6
205	isum=isum+abs(hklr(i))
	if(isum .ne. 0)goto210
206	  type 208
208	  format('$  Range values incorrect - retype: ')
	  read(5,209,end=9000,err=206)hklr
209	  format(6i3)
	  goto204
c
210	do i=1,3
		if(iorder(i) .eq. 1)t(i)='h'
		if(iorder(i) .eq. 2)t(i)='k'
		if(iorder(i) .eq. 3)t(i)='l'
	enddo
c
211	type 212,t
212	format('$  Input h,k,l increment order (fastest first), <RETURN> for ',3a1,'?')
213	read(5,214,end=9000,err=211)t
214	format(3a1)
	isum=0
	do i=1,3
		if(t(i) .eq. 'h')iorder(i)=1
		if(t(i) .eq. 'k')iorder(i)=2
		if(t(i) .eq. 'l')iorder(i)=3
		isum=isum+iorder(i)
	enddo
	if(isum .eq.6)goto222
	  type 216
216	  format('$  Increment flags incorrect - re-enter:')
	goto213
c
c get shell information
c
222	TYPE *
	type *,' Data Collection Shells:'
	i=0
223	i=i+1
	if(shell(2,i) .lt. 0.01)goto340
	type 330,i,shell(1,i),shell(2,i)
330	format('  No:',i2,' From ',f6.2,' To ',f6.2,' 2-Theta')
	goto223 
340	if(i .eq. 1)then
	  type 341
341	  format('  No shells defined - Input shells -')
	else
224	  type 225
225	  format('$ Input 1 to modify data collection shells, <RETURN> for NO Change?')
	  read(5,325,end=9000,err=224)k
	  if(k .ne. 1)goto260
	endif
	i=0
230	i=i+1
234	type 235,i
235	format('$ Shell ',i2,':')
237	read(5,240,end=9000,err=234)k,ts(1),ts(2)
240	format(q,2f10.0)
	if(k .eq. 0)goto255
	if(ts(1) .lt. ts(2))goto241
		type 245
		goto237
c
241     do 250 j=1,2
		if(ts(j) .ge. 0. .and. ts(j) .le. 90.)goto250
	        type 245
245	  	format('$Illegal values - retype:')
   	  	goto237
250	shell(j,i)=ts(j)
	goto230 
c 
c check for at least one shell - if not request info again
255     if(i .eq. 1)goto340
c
c clear out old shell info 
	do j=i,10
		shell(1,j)=0.
		shell(2,j)=0.
	enddo                 
c
c get standards
c

260	if(nstd .eq. 0)then
	  type 266
266	  format(/'  No standard reflections')
	else
	  type 261,((ihkstd(i,j),i=1,3),j=1,nstd)
261	  format(/'  Standard Reflections Are: ',5(3i3,','))
	endif
265     type 262
262	format('$ Input 1 to change: ')
263	read(5,264,end=9000,err=265)i
264     format(i5)
	if(i .le. 0)goto267
	nstd=0
	type 24
24	format('  Enter Indices for Standard (<CR> TO END)- ')
25	  type 26,nstd+1
26	  format('$ ',i1,': ')
	  read(5,'(q,3f5.0)',end=9000,err=25)i,(ts(j),j=1,3) 
	  if(i .ne. 0)then
		nstd=nstd+1
		do j=1,3		
		 ihkstd(j,nstd)=ts(j)
		enddo
		if(nstd .lt. 5)goto25
		type *,' Limit of 5 Standards'
	  endif
c
267	if(nstd .ne. 0)then
268	  type 20,stdtime
20	  format(/'$ Input Freq (in mins), <RETURN> for ',i3,' mins? ')
	  read(5,264,end=9000,err=268)i
	  if(i.gt.0)stdtime=i
	endif
c                          
c
c reorientation removed until motorised detector slits available
c154	type 155
c155	format('$ Type 1 for Re-orientation during data collections: ')
c	read(5,405,end=9000,err=154)i
	scan(10)=0
c	if(i .eq. 1)scan(10)=1
c
c get scan type
c
3000	type  3001
3001	format(/1X,29('*'),'SETUP SCAN PARAMETERS',30('*')/)
160	type 400
400	format(/'$ Input 1 for om scan, 2 for om/tth scan:')
	read(5,405,end=9000,err=160)i
405	format(i5)
	if(i .ne. 1 .and. i .ne. 2)goto160
	scan(1)=i
c
c print step size etc
c
440	type 445,scan(3),scan(4)
445	format(/'  Scan Step Size =',f5.3,' Degeees, Time per step = ',f4.1,' secs'/
     1  $'  Input new values or <RETURN> for no change: ')
448	read(5,447,end=9000,err=449)i,ts(1),ts(2)
447	format(q,2f10.0)
	if(i .eq. 0)goto469
	scan(3)=ts(1)
	if(scan(3) .lt. 0.005 .or. scan(3) .gt. 1.0)then
449	  type *,'$ Illegal values - retype: '
	  goto448
	endif
	scan(3)=anint(scan(3)*200)/200.
	scan(4)=ts(2)
c
c estimate time per reflection
c
	itime=scan(4)*scn1/2./scan(3)
	rtime=float(itime)/60.
459	type 460,itime,rtime
460	format(/'  Estimated INITIAL scan time per reflection is ',i5,
     1   ' seconds'/$34x,f7.2,' minutes -is this ok?')
	read(5,465,end=9000,err=459)ans
465	format(a1)
	if( ans .ne. 'y' .and. ans .ne. 'Y')goto160
c
c get constant precision
c
469	if(scan(5).lt.0.5)then
		type 466
466		format(/'  Single Scan per Reflection')
	else
		j=scan(7)
		type 467,scan(6),j
467		format(/'  Constant precision mode at ',f4.1,' I/sigI, max reps =',i3)
	endif 		
471	type 470
470	format('$ Input 1 to change, <RETURN> for NO Change?')
	read(5,405,end=9000,err=471)i
	if(i .eq. 1)then	
473		type 472
472		format('$ Input 1 for constant precision mode,',
     1		       '0 for single scan:')
		read(5,405,err=473)i
		if(i .eq. 1)then
                  scan(5)=1
474		  type 475
475		  format('$ Input I/sigI precision:')
	   	  read(5,430,end=9000,err=474)scan(6)
430		  format(f10.0)
479		  type 480
480		  format('$ Input max no. repeat scans:')
		  read(5,405,end=9000,err=479)i
		  scan(7)=i
c
c trap 0 or 1 scans: set single scan
		  if(i .lt. 2)scan(5)=0
		else
		  scan(5)=0
		  scan(7)=1
		endif
	endif
c
c
	if(scan(2) .lt. 0.5)then
	  type 431
431	  format(/'  No multiple Psi positions in data collection scans')
        else
	  type 432,nint(scan(2)),scan(9)
432	  format(/i3,' Psi positions in data collection scans',
     1    ' spaced at ',f4.1,' degree intervals') 
	endif
	type 415
415	format(/'$ Input new values, <RETURN> for no change?')
414	read(5,434,end=9000,err=433)i,ts(1),ts(2)
434	format(q,2f10.0)	
	if(i .eq. 0)goto9000
	scan(2)=ts(1)
	scan(9)=ts(2)
	goto9000
433	type 435
435	format('$  Invalid values - Retype:')
	goto414
c	 
9999	CALL UPDATE
	RETURN
	END
	SUBROUTINE SNGINT
	implicit none
	include 'single.inc'
C
C INITIALIZE SYSTEM
C
	CALL KCINIT
C
	RETURN
	END
	options /extend
	SUBROUTINE MOTORU
C
C MOTOR UTILITY ROUTINE
C
	implicit none
	include 'single.inc'
	integer*4 i,ierr
	real*4 pos
C
	if(stringin.eq.' ')then
		TYPE 2
2		FORMAT(' Motor Utility - Type Number and Position(0 to Exit)')

100		type 3
3		format('$?')
		READ(5,4,end=9999,err=100)i,pos
4		format(i10,f10.0)
	else
		read(stringin,4)i,pos
	endif
	if(i.le.0.or.i.gt.4)goto9999
	call drive(i,pos,0,1,ierr)
	if(ierr .ne. 0)then
		type 5
5		format(' Target angle OUT OF BOUNDS')
		go to 100
	else
		if(stringin .eq. ' ')go to 100
	endif
9999	return
	end
	options/extend
	SUBROUTINE DRIVE_LIST
C
C LIST DRIVE ROUTINE
C
	implicit none
	include 'single.inc'
	integer*4 i,j,ierr
C
	if(stringin.eq.' ')then
		TYPE 2
2		FORMAT(' List Drive - Type Number(0 to Exit)')
100		type 3
3		format('$?')
		READ(5,4,end=9999,err=100)i
4		format(i10,f10.0)
	else
		read(stringin,4)i
	endif
	if(i.le.0)goto9999
	if(iuse(i).ne.1)then
		write(*,'(A,i3,a)')' Use Flag for Refl. No.',i
     1			,' Not Set. Drive Abandoned.'
		if(stringin .eq. ' ')goto100
		return
	endif
	do j = 1,4
		cangl(j)=anglst(j,i)
	enddo
	call drivep(0,ierr)
	if(ierr .ne. 0)then
		type 5
5		format(' Error in Drive')
	else
		if(stringin .eq. ' ')goto 100
	endif
9999	return
	end
