	subroutine cntr(iflag)
c routine to initiate keyboard centering
c if iflag=0 then do +/- ttheta, =1 just current position
	include 'single.inc'
	dimension pos(4),TH(3)
	byte iresp
c get beam on and initiate centering
	call wait
	call onbeam
	call center(ifnd,iflag,width,tthzero)
	if(ifnd.ne.0)go to 200
	call count(5.0)
	call RdAllMTR(pos)
	if(iflag .eq. 1)tthzero=0.
	pos(1)=pos(1)-tthzero
	call sclwt
	call ofbeam
	rate=rdsclr()/rdtime()
	CALL HCALC(POS,TH)
	type 2,pos,rate
2	format(' Angles: ',4f9.3,', Rate:',f10.3)
	if(iflag .eq. 0)then
		type 3,tthzero,width
3		format('   Zero: ',f9.3,', Width: ',f6.3)
	else
		type 5,width
5		format(20x,'Width: ',f6.3)
	endif
	type 7,th
7	format(' Calculated indices:',3f7.2)
8	type 4
4	format('$Add to Reflection List<Y,N>? ')
	read(5,6,end=9999,err=8)iresp
6	format(a1)
	if(iresp.ne.'Y'.and.iresp.ne.'y')go to 300
	if(nlst.ge.LISTLEN)go to 210
	nlst=nlst+1
	do 110 i=1,3
	  ihlst(i,nlst)=th(i)
	  anglst(i,nlst)=pos(i)
110	continue
	  anglst(4,nlst)=pos(4)
	  iref(nlst)=2
	  if(iflag .eq. 1)iref(nlst)=1
	  iuse(nlst)=1
	  lstcount(nlst)=rate
9999	RETURN
200	call ofbeam
	TYPE 20
20	format(' Peak Not Centered.')
	RETURN
210	type 22
22	format(' Maximum Number of List Items, Not Added.')
300	return
	END
	options/extend
	subroutine edit(ityp)
C
C Routine to edit the reflection list
C
	character*1 iresp
	include 'single.inc'
	dimension pos(4),listno(listlen),itlist(listlen),th(3),tphi(3)
	real tangl(4),tihlst(3)
c
	go to (100,200,300,400,500,600,700,800),ityp
C
C DELETE ITEMS
C          -first clear delete list
100	do i=1,listlen
		itlist(i)=0
		listno(i)=0
	enddo
	IF(STRINGIN.EQ.' ')THEN
c Read Info from Keyboard
11	    TYPE 12
12	    FORMAT('$TYPE LIST NOS. OF ITEMS TO DELETE:')
	    read(5,14,end=9999,err=11)(ITLIST(i),i=1,nlst)
14	    FORMAT(<NLST>I5)
	else
	    read(stringin,14,err=9999)(itlist(i),i=1,nlst)
	endif
	if(itlist(1) .le. 0)return
c
c check for inclusive list
c
	listno(1)=itlist(1)
	ientry=1
	DO i=2,nlst
	if(itlist(i) .eq. 0)goto99
c if entry is negative, we have inclusive list
	if(itlist(i) .lt. 0)then
		is=itlist(i-1)+1
		if=abs(itlist(i))
		do j=is,if
		ientry=ientry+1
		listno(ientry)=j
		enddo
	else
		ientry=ientry+1
		listno(ientry)=itlist(i)
	endif
	enddo
99	continue
c
c sort items in decreasing order
c
	do i=1,listlen-1
	  imax=listno(i)
	  jpnt=i
	  do 110 j=i+1,listlen
	    if(listno(j).le.imax)go to 110
	    imax=listno(j)
	    jpnt=j
110	  continue
	  if(jpnt.ne.i)then
c swap entries
	    listno(jpnt)=listno(i)
	    listno(i)=imax
	  endif
	enddo
c delete entries
	do 160 i=1,listlen
	  if(listno(i).eq.0.or.listno(i).gt.nlst)go to 160
	  if(listno(i).eq.nlst)go to 150
	  do 140 j=listno(i)+1,nlst
	    do 130 k=1,3
	      ihlst(k,j-1)=ihlst(k,j)
	      anglst(k,j-1)=anglst(k,j)
130	    continue
	    iuse(j-1)=iuse(j)
	    iref(j-1)=iref(j)
	    lstcount(j-1)=lstcount(j)
	    anglst(4,j-1)=anglst(4,j)
140	  continue
150	nlst=nlst-1
160	continue
c update stored file
	call update
	go to 9999
C
C INSERT INDICES INTO LIST
C
200	TYPE 16
16	FORMAT(' INSERT REFLECTION INDICES IN LIST,'
	1,' TYPE H,K,L WITH BLANK TO END')
210	TYPE 18
18	FORMAT('$?   ')
	read(5,'(3f10.0)',end=9999,err=210)(TH(i),i=1,3)
	IF(ABS(TH(1))+ABS(TH(2))+ABS(TH(3)).EQ.0)GO TO 250
	IF(NLST.LT.LISTLEN)GO TO 1262
	TYPE 20
20	FORMAT(' REFLECTION LIST FULL')
	GO TO 250
1262	DO I=1,3
	  IHLST(I,NLST+1)=TH(I)
	enddo
	CALL CALPHI(TH,TPHI)		!CALCULATE H(PHI)
	CALL CALCA(TPHI,CANGL,IERR)	!CONVERT TO ANGLES
	IF(IERR.eq.0)GO TO 235
	   type 231
231	   format(' REFLECTION OUT-OF-BOUNDS')
	   goto210
235	NLST=NLST+1
	DO 240 I=1,4
	  ANGLST(I,NLST)=CANGL(I)
240	CONTINUE
	  IUSE(NLST)=1
	  IREF(NLST)=0
	  LSTCOUNT(NLST)=0
	GO TO 210
250	CALL UPDATE
	GO TO 9999
C
C INSERT ANGLES IN LIST
C
300	TYPE 22
22	FORMAT(' INSERT REFLECTION ANGLES IN LIST,'
	1/' TYPE 2THETA, OMEGA, CHI, PHI WITH BLANK TO END')
310	TYPE 18
	read(5,24,end=9999,err=310)I,POS
24	FORMAT(Q,4F10.0)
	IF(I.LE.0)GO TO 340
	call softlimits(pos,0,ierr)
	if(ierr .eq. 0)goto315
		type 231
		goto310
315	IF(NLST.LT.listlen)GO TO 320
	TYPE 20
	GO TO 340
320	NLST=NLST+1
	DO 330 I=1,4
	  ANGLST(I,NLST)=POS(I)
330	CONTINUE
	  IUSE(NLST)=1
	  IREF(NLST)=0
	  LSTCOUNT(NLST)=0
	  CALL HCALC(POS,TH)
	  DO I=1,3
	   	IHLST(I,NLST)=TH(I)
	  ENDDO
	GO TO 310
340	CALL UPDATE
	GO TO 9999
C
C LIST REFLECTION LIST
C
400	if(nlst.eq.0)go to 420
	TYPE 26
26	FORMAT(/' NO     H     K     L    TTH      OMEGA     CHI      PHI',
     1  '   REF  USE INTENSITY'/)
	is=1
	if=15
405	if(nlst-is .le. 15)if=nlst
        DO 410 I=is,if
	  TYPE 28,I,(IHLST(J,I),J=1,3),(ANGLST(J,I),J=1,4),IREF(I),IUSE(I),
     1            LSTCOUNT(I)
28	  FORMAT(I3,3F6.1,4F9.3,2I5,I9)
410	CONTINUE
	if(if .eq. nlst)GO TO 9999
414	type 415
415	format('$Type <CR> to Continue, E to exit...')
	read(5,416,end=9999,err=414)iresp
416	format(a1)
	if(iresp .eq. 'E' .or. iresp .eq. 'e')goto9999
	is=is+15
	if=if+15
	goto405
c
420	type 29
29	format(' List is Empty.')
	go to 9999
C
C INPUT REFLECTION DATA - HKL AND ANGLES
C
500	TYPE 30
30	FORMAT(' INSERT REFLECTION DATA IN LIST,'
	1/' TYPE H, K, L, 2THETA, OMEGA, CHI, PHI WITH BLANK TO END')
510	TYPE 18
	read(5,32,end=9999,err=510)I,(IHLST(J,NLST+1),J=1,3),(ANGLST(J,NLST+1),J=1,4)
32	FORMAT(Q,7F10.0)
	if (i.le. 0) go to 530
	iuse(nlst+1)=1
	iref(nlst+1)=0
	lstcount(nlst+1)=0
	IF(I.LE.0)GO TO 530
	IF(NLST.LT.listlen)GO TO 520
	TYPE 20
	GO TO 530
520	NLST=NLST+1
	GO TO 510
530	CALL UPDATE
	GO TO 9999
C
C MODIFY USE FLAGS ON REFLECTIONS
C
600     TYPE 620
620	FORMAT('  UNSET USE FLAGS IN REFLECTION LIST,'/
     1	'$ TYPE LIST NOS: ')
	read(5,14,end=9999,err=600)(ITLIST(i),i=1,nlst)
	DO 630 I=1,NLST
           IF(ITLIST(I) .GT. NLST)GOTO630
	   IF(ITLIST(I) .EQ. 0)GOTO640
           IF(ITLIST(I) .LT. 0)THEN
		DO J=ITLIST(I-1),ABS(ITLIST(I))
		IUSE(J)=0
		ENDDO
	   ELSE
	        IUSE(ITLIST(I))=0
	   ENDIF
630	CONTINUE
C
640	TYPE 34
34	FORMAT(/'  SET USE FLAGS IN REFLECTION LIST,'/
     1  '$ TYPE LIST NOS:')
	read(5,14,end=9999,err=640)(ITLIST(i),i=1,nlst)
	DO 610 I=1,NLST
           IF(ITLIST(I) .GT. NLST)GOTO610
	   IF(ITLIST(I) .EQ. 0)GOTO650
           IF(ITLIST(I) .LT. 0)THEN
		DO J=ITLIST(I-1),ABS(ITLIST(I))
		IUSE(J)=1
		ENDDO
	   ELSE
	        IUSE(ITLIST(I))=1
	   ENDIF
610	CONTINUE
650	CALL UPDATE
	GOTO9999
C
C MANIPULATE REFLECTION INDICES ON LIST
C
700	TYPE 710
710	FORMAT(' Input: 1 for manual indexing'/
     1  8x,'2 for indexing by UB matrix'/
     2  '$       3 to clear all indices:')
	read(5,720,end=9999,err=700)INO
720	FORMAT(I2)
	IF(INO  .Lt. 0 .or. ino .gt. 3)GOTO700
	if(INO .EQ. 0)goto790
	go to(722,750,770),ino
c
c manual indexing
c
722	TYPE 725
725	FORMAT('$Input ISEQ,H,K,L, For Refln: ')
	read(5,730,end=9999,err=722)ino,(th(j),j=1,3)
730	format(i3,3f5.0)
	if(ino .eq. 0)goto700
	if(ino .gt. nlst)goto722
	do i=1,3
		ihlst(i,INO)=th(i)
	enddo
	goto722
c
c indexing from UB matrix
c
750	DO I=1,NLST
 	  CALL HCALC(ANGLST(1,I),IHLST(1,I))
	ENDDO
	goto790
c
c clear all indices
c
770	DO I=1,NLST
		DO J=1,3
		  IHLST(J,I)=0
		ENDDO
	ENDDO
790	CALL UPDATE
	GOTO9999
c
c sort reflections into ascending 2-theta order
800	i=1
810	j=i
820	j=j+1
	if(j .gt. nlst)then
	  i=i+1
	  if(i .lt. nlst)goto810
	  call update
	  goto9999
	endif
	if(anglst(1,j).ge.anglst(1,i))goto820
c
c here if swap
        do k=1,3
	  tangl(k)=anglst(k,i)
	  tihlst(k)=ihlst(k,i)
	enddo
	tangl(4)=anglst(4,i)
	tiuse=iuse(i)
	tiref=iref(i)
	tcount=lstcount(i)
	do k=1,3
	  anglst(k,i)=anglst(k,j)
          anglst(k,j)=tangl(k)
	  ihlst(k,i)=ihlst(k,j)
          ihlst(k,j)=tihlst(k)
	enddo
	anglst(4,i)=anglst(4,j)
        anglst(4,j)=tangl(4)
	iuse(i)=iuse(j)
        iuse(j)=tiuse
	iref(i)=iref(j)
	iref(j)=tiref
	lstcount(i)=lstcount(j)
	lstcount(j)=tcount
	goto810
c	    		
9999	return
	END
	subroutine zref
c
c routine to refine diffractometer zeroes; 
c IFLAG=0 for keyboard call, =1 if called from program
c
	include 'single.inc'
	include 'device.inc'
	character*1 resp
	dimension tphi(3),th(3),angl(4),zsum(10),rot(3,3),off(3),tangl(4)
	data rad/57.295/,u0/215/,v0/215/
c
	if(nlst.gt.0)go to 110
	type 2
2	format(' Reflection List Empty, ZREF Aborted.')
	return
c
c check limits
c
110	if(chi_flag .eq. 1 .and. abs(chimx-abs(chimn)) .gt. 0.1)then
109	      	type 111
111		format('$  WARNING: CHI LIMITS ASYMMETRIC - INPUT 1 TO CONTINUE:')
		read(5,112,end=9999,err=109)i
112		format(i5)
		if(i .ne. 1)return
	endif
c
c print peak centering parameters
c
117	type  113,int(minct),maxmin,int(tmax)
113	format('/  Peak Centering Parameters -'/
     1	'   Minimum Count Rate: ',i3,' cps, Max/Min Ratio: ',f4.1,
     2  ', Max Time/Step: ',i3,' secs'/'$  Are these OK(<Y>,N)? ')
	read(5,114,end=9999,err=117)i,resp
114	format(q,a1)
	if(i.le.0)resp='Y'
	if(resp .ne. 'y' .and. resp .ne. 'Y')then
119	  type 115
115	  format('$ Input new values: ')
	  read(5,116,end=9999,err=119)minct,maxmin,tmax
116	  format(3f10.0)
	  goto117
	endif
c
c count use flags
	j=0
	do i=1,nlst
	  if(iuse(i) .ne.0)j=j+1
	enddo
	type 120,j
120	format('$There are',i3,' reflections with the USE flag set'
     1	  ,'. Continue (Y,N)<Y>:')
	read(5,'(a)',end=9999)resp
	if(resp.eq.'n'.or.resp.eq.'N')return
	do 200 i=1,nlst
c
c check iuse flag
	  if(iuse(i) .eq. 0)goto200
c set iuse flag zero -reset to 1 at end if successful
	  iuse(i)=0
	  do j=1,10
	    zsum(j)=0.0
	  enddo
	  j=abs(ihlst(1,i))+abs(ihlst(2,i))+abs(ihlst(3,i))
	  if(j.eq.0)then
c reflection not indexed - use list angles
	    do k=1,4
	      angl(k)=anglst(k,i)
	    enddo
	    call softlimits(angl,0,ierr)
	  else
	    do j=1,3
	      th(j)=ihlst(j,i)
	    enddo
	    call calphi(th,tphi)
	    call calca(tphi,angl,ierr)
	  endif
	  if(ierr.eq.0)go to 130
	    type 6,i
6	    format(' Reflection ',i2,' not Accessible.')
	    go to 200
c
c for restricted chi check if four or eight accessible
c (first chi value accesible because past softlimits)
130	  nequivs=8
	  iphi=-1
	  ichi=0
	  if(chi_flag .eq. 0)goto135
          chi2=180-abs(angl(3))
	  if(chi2 .lt. chimn  .or. chi2 .gt. chimx)then
		nequivs=4
		ichi=1
	  endif
135	  if(phi_flag .eq. 0)goto140
	       	fphi2=angl(4)-180.
		if(fphi2 .ge. phimn)goto140
		fphi2=angl(4)+180.
                if(fphi2 .lt. phimn .or. fphi2 .gt. phimx)then
		  nequivs=nequivs/2
		  if(nequivs .eq. 4)then
			iphi=0
		  else
			type 136,i
136	format('  Only two equivalents of reflection ',i2,
     1	' accessible - use  REF')
			goto200
		  endif
		else
		  iphi=1
		endif
c
c start 8 reflection loop
c
140	  type 7,i,(ihlst(j,i),j=1,3)
7	  format(/' Centering Reflection No. ',i2,' : hkl= ',3f5.1)
	  do 180 nq1=0,7
	    if(nq1.eq.0)go to 145
	    ni=1
	    if(nq1.gt.3)ni=-ni
	    if(mod(nq1,2).eq.0)go to 141
	      angl(1)=-angl(1)
	      go to 145
141	    if(nq1.ne.4)go to 142
	      if(iphi .eq. 0)goto181
	      angl(4)=angl(4)+iphi*180.0
	      angl(3)=-angl(3)
	      go to 145
142	    angl(2)=-angl(2)
	    if(nq1.ne.6)go to 143
	      angl(3)=angl(3)+180.0
	      go to 145
143	    angl(3)=angl(3)+180.0
c 
c extra bit for non-circular chi
c	
145	    nq2=0
	    if(chi_flag .eq. 0)goto6098
6093		del=rdmtr(3)-angl(3)-360*nq2
		if(abs(del) .le. 180.)goto6096
		  nq2=nq2+sgn(del)
		  goto6093
6096		del=angl(3)+nq2*360
		if(abs(del).le.180)goto6098
		  nq2=nq2-sgn(del)
		  goto6096
6098	    angl(3)=angl(3)+nq2*360
c
c now check against softlimits
	    call softlimits(angl,0,ierr)
	    if(ierr .eq. 1)then
		if(ichi .eq. 1)then
		  angl(3)=angl(3)-nq2*360
		  goto180
	        else
	 	  type 149
149	 	  format(' Reflection OUT-OF-BOUNDS')
         	  goto200
		endif
	    endif
	    do 150 j=1,4
	      cangl(j)=angl(j)
150	    continue
	    call drivep(0,ierr)
	    call wait
	    call center(ifnd,1,width,tthzero)
155	    if(ifnd.eq.0)go to 160
	      type 8
8	      format(' Reflection Not Found')
	      go to 200
160	    call count(5.0)
	    call RdAllMTR(angl)
	    call sclwt
	    call ofbeam
	    rate=rdsclr()/rdtime()
	    type 10,angl,rate
10	    format(10x,4f9.3,f12.1)
c
c add reflection data to sums
c
	    angl(2)=angl(2)+0.5*angl(1)
	    nq=nq1
	    if(mod(nq,2).ne.0)nq=8-nq
	    angl(3)=angl(3)-nq2*360.0
	    angl(4)=angl(4)-nq3*360.0
	    zsum(4)=zsum(4)+angl(1)
	    zsum(5)=zsum(5)+angl(2)
	    zsum(6)=zsum(6)+angl(3)
	    ni=1
	    if(nq.gt.1.and.nq.lt.6)ni=-1
	    zsum(2)=zsum(2)+ni*angl(2)
	    ni=1
	    if(mod(nq,2).ne.0)ni=-1
	    if(nq.gt.3)ni=-ni
	    zsum(3)=zsum(3)+ni*angl(3)
	    ni=1
	    nj=mod(nq,4)
	    if(nj.gt.1)ni=-1
	    zsum(1)=zsum(1)+2.0*ni*angl(2)
	    zsum(7)=zsum(7)+ni*angl(3)
	    ni=1
	    if(nq.gt.3)ni=-1
	    zsum(8)=zsum(8)+ni*angl(3)
	    ni=-1
	    if(mod(nq,2).eq.0)ni=1
	    zsum(10)=zsum(10)+ni*angl(2)
	    ni=1
	    if(nj.gt.0.and.nj.lt.3)ni=-1
	    if(nq.gt.3)ni=-ni
	    zsum(9)=zsum(9)+ni*angl(2)
	    angl(2)=angl(2)-0.5*angl(1)
180	  continue
c
c convert sums to angles and zeros
c
181	  do 182 j=1,10
	    zsum(j)=zsum(j)/nequivs
182	  continue
	  if(ichi .eq. 0)zsum(3)=zsum(3)-90.0
	  angl(1)=zsum(1)
	  angl(2)=zsum(2)
	  angl(3)=zsum(3)
	  angl(4)=rdmtr(4)-iphi*180.0
	  cosphi=cos(angl(4)/rad)
	  sinphi=sin(angl(4)/rad)
	  coschi=cos(angl(3)/rad)
	  sinchi=sin(angl(3)/rad)
	  cosomg=cos(angl(2)/rad)
	  sinomg=sin(angl(2)/rad)
	  type 12,angl
12	  format('0Corrected Angles: ',4f9.3)
c 
c if all 8 calculate and print zero errors and offsets
c
	  if(nequivs .eq. 8)then
	    type 14,(zsum(j),j=4,6)
14	    format(' Zeros:            ',4f9.3)
	    theta=0.5*zsum(1)/rad
	    delh=2.0*u0*sin(theta)*zsum(7)/cosomg/rad
	    type 16,delh
16	    format(' Delta H(mm):      ',f9.3)
	    tphi(1)=v0*zsum(9)/sin(theta)/rad
	    tphi(2)=v0*zsum(10)/cos(theta)/rad
	    tphi(3)=zsum(8)*sin(theta)*2.0/(cosomg*(1.0/u0+1.0/v0)*rad)
	    rot(1,1)=cosphi*cosomg-sinphi*sinomg*coschi
	    rot(2,1)=cosphi*cosomg+cosphi*sinomg*coschi
	    rot(3,1)=-sinchi*sinomg
	    rot(1,2)=-cosphi*sinomg-sinphi*cosomg*coschi
	    rot(2,2)=-sinomg*sinphi+cosomg*cosphi*coschi
	    rot(3,2)=-sinchi*cosomg
	    rot(1,3)=-sinphi*sinchi
	    rot(2,3)=cosphi*sinchi
	    rot(3,3)=coschi
	    do 184 j=1,3
	      off(j)=0.0
	      do 183 k=1,3
	        off(j)=off(j)+rot(j,k)*tphi(k)
183	      continue
184	    continue
	    type 18,off
18	    format(' XTL Offsets:      ',3f9.3)
	  else
c only four equivalents
	    if(ichi .eq. 1)then
	    	type 15,zsum(4),zsum(6)
15	    	format(' Zeros:            ',f9.3,9x,f9.3)
	    else
		type 17,zsum(5)
17		format(' Zeros:            ',9x,f9.3)
	    endif
  	  endif
c
c update stored angles
	  do 190 j=1,4
	    anglst(j,i)=angl(j)
190	  continue
c update flags on list, print final rate on list
	  iref(i)=nequivs
	  lstcount(i)=rate
	  iuse(i)=1
	  call update
200	continue
9999	do j=1,4
	cangl(j)=0.
	enddo
	call drivep(0,ierr)
	return
	end
