	options/extend
	PROGRAM SINGLE
C
C PROGRAM TO OPERATE SINGLE CRYSTAL CELL
C
	include 'single.inc'
	include 'newdif.inc'
	include 'datacol.inc'
	include 'symmetry.inc'
	include 'alph.inc'
	include 'device.inc'
c
	integer*4 status,sys$ASSIGN,allow_ctrlc
	byte chout(18)
	common /astcom/iotchn,ndif,ncomd,ictrlc,allow_ctrlc,chout
c
	data wavel,scn1,scn2/0.7093,2.0,0.70/
	data minct,maxmin,tmax/30.,2.,10./
C
	TYPE 4
4	FORMAT('0GEOLAB/UCL Diffractometer Control Program - '
	1,'V2.1 ( 8-Nov-93)'/)
	call terminal(ndif)
C
C READ STORED PARAMETER FILE
C
2900	call read_orient
C
C INITIALIZE SYSTEM
C
110	if(ndif.gt.0)CALL SNGINT
c
c Assign channel to terminal
c
	status = sys$assign('tt:',iotchn,,)
	if(status.ne.1)call lib$signal(%val(status))
c
c Set CTRL/C AST
c
	call set_ctrlc
	ictrlc=0
c
c Set CTRL/Y AST
c
	call set_ctrly
c
c Allow CTRL/C to be processed
c
1000	allow_ctrlc=1
c
c Call Exit Handler, which calls SNGL_DISP to get commands
c
	call sethandler
	allow_ctrlc=0
	if(ictrlc.ne.0)then
	    close(unit=5)
	    open(unit=5,file='tt:',status='unknown')
	    ictrl=0
	endif
	go to 1000
	end
	options/extend
	subroutine sngl_disp
c
c Routine to Get and Dispatch a Keyboard Command
c
	include 'single.inc'
	external lib$put_output,lib$get_input
	character datest*9,timest*8,resp*4
	integer allow_ctrlc
	byte chout(18)
	common /astcom/iotchn,ndif,ncomd,ictrlc,allow_ctrlc,chout
	real*4 trns(3,3)
c
c Command Name Table
c
	integer nbr
	PARAMETER (NBR=45)
	character*80 tempstring
	character*4 MENU(nbr)
	DATA MENU/'HELP','EXIT','CELL','OM  ','COM ','CALC'
     1		 ,'DRIV','INTS','MOT ','SETU','CNTR','INDX'
     2		 ,'INTA','LDMT','OPSH','CLSH','DEL ','INH '
     3		 ,'INA ','REF ','AUTO','LSQ ','LIST','TRAN'
     4		 ,'IND ','SRCH','ZREF','HALT','PROF','USE '
     5		 ,'INDL','CONE','PSI ','PRNT','CLSQ','CENT'
     6           ,'ANGL','INTL','SORT','BRAV','NOTE','GRID'
     7		 ,'DVLS','ZERO','FACE'/
c
1000	call date(datest)
	call time(timest)
	if(ndif.ne.0)then
	  TYPE 6,datest,timest
6	  FORMAT(/'$',1x,a,1x,a5,': SINGLE>')
	else
	  type 17,datest,timest
17	  FORMAT(/'$',1x,a,1x,a5,': DMSINGLE>')
	endif
	read(5,8,end=1100)I,RESP,j,stringin
8	FORMAT(Q,A4,q,A)
	IF(I.LE.0)GO TO 1000
	if(j.gt.0)stringin(j+1:j+1)=','
	call str$upcase(resp,resp)
	DO I=1,NBR
	  if(menu(i).eq.resp)go to 1030
	enddo
c
c Unknown command - go to help
c
	GO TO 1020
C
C HELP - Use VMS System routine for help
c
1020	call lbr$output_help(lib$put_output,,
     1	,'single$base:single.hlb',,lib$get_input)
	GO TO 1000
C
C QUIT
C
c restore normal screen
c
1100	call scr_restore
	call exit
c
c Branch to appropriate entry
c
1030	GO TO (1020,1100,1110,1120,1130,1140,1150,1160,1170,1180
     1,1190,1200,1210,1220,1230,1240,1250,1260,1270,1280,1290
     2,1300,1310,1320,1330,1340,1350,1360,1370,1380,1390,1400
     3,1410,1420,1430,1440,1450,1460,1470,1480,1490,1500,1510
     4,1520,1530),i
C
C ENTER CELL
C
1110	CALL GETCL
	GO TO 1000
C
C ENTER ORIENTATION MATRIX
C
1120	CALL ENTOM
	GO TO 1000
C
C CALCULATE ORIENTATION MATRIX
C
1130	CALL CALCOM
	GO TO 1000
C
C CALCULATE ANGLES
C
1140	CALL ANGCAL
	GO TO 1000
C
C DRIVE TO POSITION
C
1150	if(ndif.gt.0)CALL DRIVEP(1,ierr)
	if(ierr .eq. 1)type 1151
1151	format('    Target angle(s) OUT OF BOUNDS')
	GO TO 1000
C
C INTEGRATE SINGLE INTENSITY
C
1160	if(ndif.gt.0)CALL INTEGR
	GO TO 1000
C
C MOTOR UTILITY PROGRAM
C
1170	if(ndif.gt.0)CALL MOTORU
	GO TO 1000
C
C CALL SETUP ROUTINE
C
1180	CALL SETUP
	GO TO 1000
C
C CENTER REFLECTION
C
1190	if(ndif.gt.0)CALL CNTR(0)
 	GO TO 1000
C
C CALCULATE APPARENT INDICES
C
1200	CALL GETIDX
	GO TO 1000
C
C INTEGRATE ALL INTENSITIES
C
1210	if(ndif.gt.0)CALL INTALL
	GO TO 1000
C
C RESET MOTOR POSITIONS
C
1220	if(ndif.gt.0)CALL MTINIT
	GO TO 1000
C
C OPEN SHUTTER
C
1230	if(ndif.gt.0)CALL ONBEAM
	GO TO 1000
C
C CLOSE SHUTTER
C
1240	if(ndif.gt.0)CALL OFBEAM
	GO TO 1000
C
C DELETE ITEMS
C
1250	call edit(1)
	call edit(4)
	GO TO 1000
C
C INSERT INDICES INTO LIST
C
1260	call edit(2)
	call edit(4)
	GO TO 1000
C
C INSERT ANGLES IN LIST
C
1270	call edit(3)
	call edit(4)
	GO TO 1000
C
C REFINE ANGLES IN LIST
C
1280	if(ndif.gt.0)then
	  CALL REFINE
	  CALL UPDATE
	endif
	GO TO 1000
C
C AUTOINDEX REFLECTION LIST
C
1290	CALL AUTOIN
	CALL UPDATE
	GO TO 1000
C
C DO LEAST SQUARES ON REFLECTION LIST
C
1300	CALL LSQ(0)
	CALL UPDATE
	GO TO 1000
C
C LIST REFLECTION LIST
C
1310	call edit(4)
	GO TO 1000
C
C PERFORM CELL TRANSFORMATION
C
1320	CALL TRANS(trns,0)
	GO TO 1000
C
C INPUT REFLECTION DATA - HKL AND ANGLES
C
1330	call edit(5)
	call edit(4)
	GO TO 1000
C
C SEARCH FOR REFLECTIONS
C
1340	if(ndif.gt.0)CALL SEARCH
	GO TO 1000
C
C REFINE DIFFRACTOMETER ZEROS, ETC.
C
1350	if(ndif.gt.0)CALL ZREF
	GO TO 1000
C
C HALT EVERYTHING
C
1360	if(ndif.gt.0)CALL STPALL
	GO TO 1000
C
C PROFILE A PEAK
C
1370	if(ndif.gt.0)CALL PROFST
	GO TO 1000
C
C SET/UNSET USE FLAGS
C
1380    CALL EDIT(6)
	call edit(4)
	GO TO 1000
C
C REINDEX ALL REFLECTIONS IN LIST
C
1390	CALL EDIT(7)
	CALL EDIT(4)
	GO TO 1000
C
C INITIATE CONE SEARCH
C
1400	if(ndif.gt.0)CALL CONE
	GO TO 1000
C
C INITIATE PSI SCAN
C
1410	if(ndif.gt.0)CALL PSISCAN
	GO TO 1000
c
c Turn Printer on
c
1420	call prnt_on
	go to 1000
c
c Do constrained least squares
c
1430	call lsvec
	go to 1000
c
c center refln at current position only
c
1440	if(ndif.gt.0)CALL CNTR(1)
	go to 1000
c
c Print table of inter-reflection angles
c
1450	call angletable
	go to 1000
c
c integrate reflections from list in file
c
1460	if(ndif.gt.0)call intlist
	go to 1000
c
c sort reflections in refln list
c
1470	call edit(8)
	call edit(4)
	go to 1000
c
c Find Bravais Lattice
c
1480	call bravais
	go to 1000
c
c note facility
c
1490	write(*,1492)
1492	format(//1x,70('*')/1x,'***',64x,'***'/
     1	  1x,'***',30x,'NOTE',30x,'***'/1x,'***',64x,'***'/
     2	  1x,70('*')//)
1493	read(5,1491,end=1495)tempstring
1491	format(a80)
	if(tempstring(1:4) .eq. 'exit')goto1495
	if(tempstring(1:4) .eq. 'EXIT')goto1495
	goto1493
1495	write(*,1496)
1496	format(//2(1x,70('*')/)/)
	go to 1000
c
c Grid Reciprocal Cell
c
1500	if(ndif.gt.0)call grid
	go to 1000
c
c Drive to List Item
c
1510	if(ndif.gt.0)call drive_list
	go to 1000
c
c Zero the diffractometer
c
1520	if(ndif.gt.0)then
	   do i = 1,4
	      cangl(i) = 0.0
	   enddo
	   call drivep(0,ierr)
	endif
	go to 1000
c
c Calculate Equations of crystal faces
c
1530	call face
	go to 1000
c
c Exit Routine
c
9000	return
	end
	options/extend
	subroutine read_orient
	implicit none
	include 'single.inc'
	include 'device.inc'
	include 'datacol.inc'
	include 'alph.inc'
	include 'symmetry.inc'
	character*80 tempname,parname
	real*4 temp(6),wave2
	integer n_parname,ierr,i,j
c
c if new file then read it, otherwise exit
c
	if(n_parname .eq. 0)then
2880	  type 2890
2890	  format(//'$ Input name of parameter file ?')
	  read(5,2920,err=2880)i,tempname
	  if(i .eq. 0)goto2880
	else
2900	  type 2910,parname(1:n_parname)
2910	  format(//'$ Input name of parameter file, <RETURN> for '
     1    ,a,' ?')
	  read(5,2920,err=2900)i,tempname
2920	  format(q,a)
	  if(i .eq. 0)return
	endif
c
c new file ....read it
c
	n_parname=i
	parname=tempname
c
2940	OPEN(UNIT=3,NAME=parname,TYPE='UNKNOWN',ERR=90
	1,CARRIAGECONTROL='LIST',INITIALSIZE=4,shared)
	read(3,3331,err=90,end=90)title
3331	format(60a1)
	READ(3,1,ERR=90,END=90)UB,temp,UBO
1	FORMAT(3(3E14.7/)6F12.6,3(/3E14.7))
	if(temp(1).ne.0.)wavel=temp(1)
	if(temp(2).ne.0.)scn1=temp(2)
	if(temp(3).ne.0.)scn2=temp(3)
	if(temp(4).ne.0.)minct=temp(4)
	if(temp(5).ne.0.)maxmin=temp(5)
	if(temp(6).ne.0.)tmax=temp(6)
	csep=0
	if(abs(wavel-0.709) .lt. 0.1)csep=0.345
	if(abs(wavel-1.542) .lt. 0.1)csep=0.141
	READ(3,2,ERR=90,END=90)NLST,((IHLST(J,I),J=1,3),I=1,LISTLEN)
2	FORMAT(I4,10F7.2/(4X,10F7.2))
	READ(3,3,ERR=90,END=90)((ANGLST(J,I),J=1,4),I=1,LISTLEN)
3	FORMAT(8F8.3)
	READ(3,2220,ERR=90,END=90)(LSTCOUNT(I),I=1,LISTLEN)
2220	FORMAT(8I9)
	READ(3,3333,ERR=90,END=90)(IREF(I),IUSE(I),I=1,LISTLEN)
3333	FORMAT(40I2)
	CALL OMTOB(0)	!CALCULATE CELL PARAMETERS
	READ(3,5)FILeNAMe
5	FORMAT(a80)
	READ(3,2222,END=90)NLAT,NSTD,STDtime,IHKSTD
2222	FORMAT(20I4)
	READ(3,2224,ERR=90,END=90)SPG
2224	FORMAT(20A1)
	call symmetry(ierr)
	if(ierr .ne. 0)type 2225
2225	format(' ****Error in space group symbol read; reset with SETU')
	READ(3,2226,ERR=90,END=90)HKLR,IORDER
2226	FORMAT(9I3)
	READ(3,2228,ERR=90,END=90)(SCAN(i),i=1,10)
2228	FORMAT(10F8.4)
	READ(3,2230,ERR=90,END=90)SHELL
2230	FORMAT(10F8.3/10F8.3)
	READ(3,2240,ERR=90,END=90)device_no,fixed_phi,chi_flag,phi_flag
     1                           ,dc_psimax,chimn,chimx,phimn,phimx
2240	FORMAT(4I2,5F10.3)
C
	wave2=wavel*(1.0+csep*0.01753)
	TYPE 7,WAVEL,wave2,SCN1,SCN2,nint(MINCT),MAXMIN,nint(TMAX),SPG,NSTD,STDtime
7	FORMAT('0Wavelength: ',f7.5,', Alpha2: ',f7.5,
     1   ', Scan Constants: ',2f7.2/' Peak Centering: Min Rate = ',i3
     1  ,' cps, Max/Min Rate = ',f4.1,', Max Time = ',i3,' secs'  
     2  /' Space Group: ',20a1/' Number Std. Refl: ',i2
     3  ,', Time Between Std: ',i3)
	if(nstd.ne.0)type 9,((ihkstd(j,i),j=1,3),i=1,nstd)
9	format(' Standard Indices:',5(3i3,3x))
	TYPE 13,FILeNAMe,title
13	FORMAT(' Reflection Data File Name: ',a80/
     1  ' Experiment Title: ',60a1)
	call printdevice
	type 11
11	format(/' Type SETU to change any of these parameters.')
	REWIND 3
c
	GO TO 110
C
C MATRIX NOT AVAILABLE
C
90	CALL GETCL
	REWIND 3
	type *, ' Errors in .MAT File - Use SETUP to correct.'
110	return
	end
	subroutine ctrlc(i)
	integer allow_ctrlc
	byte chout(18)
	common /astcom/iotchn,ndif,ncomd,ictrlc,allow_ctrlc,chout
	real*8 motor_quad
	common /mtr_com/ motor_quad,posm(4),imchn
c
c reset ast
	call set_ctrlc
c set ctrl/c flag
	ictrlc=1
	if(allow_ctrlc.ne.0)then
c Signal CTRL/C Entered
		call lib$signal(%val(9999))
	else
		if(ndif.ne.0)call stpall
	endif
	return
c
	entry ctrly(i)
c
c CTRL/Y Typed - Stop Diffractometer if not VIRTUAL system
c
c	if(allow_ctrlc.ne.0)then
c Signal CTRL/Y Entered
		if(ndif.ne.0)call stpall
		call scr_restore
		call lib$signal(%val(9997))
c	else
c		call exit
c	endif
	return
	end
	subroutine scr_restore
	byte chout(18)
	common /astcom/iotchn,ndif,ncomd,ictrlc,allow_ctrlc,chout
	data iwrite /'130'x/
c
C Output screen clearing string
	    call sys$qiow(,%val(iotchn),%val(iwrite),,,,chout
	1    ,%val(18),,,,)
	return
	end
	subroutine set_ctrly
c
	include '($iodef)'
	byte esc /27/
	integer*4 status,sys$qiow,allow_ctrlc
	external ctrlc,ctrly
	byte chout(18)
	common /astcom/iotchn,ndif,ncomd,ictrlc,allow_ctrlc,chout
c
	status = sys$qiow(,%val(iotchn)
	1,%val(io$_setmode .or. io$m_ctrlyast),,,
	2,%ref(ctrly),%val(1),%val(3),,,)
	if(status.ne.1)call lib$signal(%val(status))
c
c Build string to clear screen
c
	encode(18,12,chout)esc,esc,esc
12	format(1x,a1,'[1;1H',a1,'[0J',a1,'[1;24r')
	return
	entry set_ctrlc
c
	status = sys$qiow(,%val(iotchn)
	1,%val(io$_setmode.or.io$m_ctrlcast),,,
	2,%ref(ctrlc),%val(1),%val(3),,,)
	if(status.ne.1)call lib$signal(%val(status))
	return
	end
	subroutine stopdif
	integer allow_ctrlc
	byte chout(18)
	common /astcom/iotchn,ndif,ncomd,ictrlc,allow_ctrlc,chout
c
c Routine to issue stop to diffractometer from AST level if NOT virtual
c
	if(ndif.ne.0)call stpall
	return
	end
