	subroutine trans(trn,iread)
c
c routine to transform cell and indices
c
	include 'single.inc'
	dimension trn(3,3),umat(3,3),temp(3,3)
     1   ,gp(3,3),celnew(6),g(3,3),tinv(3,3),trntsp(3,3),fhh(3)
	character*1 iresp
c
c Read Transformation Matrix
c
100	if(iread.eq.0)then
	  type 2
2	  format(' Cell Transformation, Type Matrix by Row')
	  do i=1,3
3	    type 4,i
4	    format('$',i1,'?  ')
	    read(5,6,end=9999,err=3)(trn(i,j),j=1,3)
6	    format(3f10.0)
	  enddo
	endif
c Check Validity of transformation
	call minv(trn,tinv,det)
	type 8,det
8	format(' Modulus of Transformation:',f8.2)
	if(abs(det).le.0.1)then
c singular transformation
	  type 10
10	  format(' Transformation Matrix is Singular: Try Again.')
	  if(iread.eq.0)then
	    go to 100
	  else
	    return
	  endif
	endif
	if(det.lt.0.0)then
	  write(*,11)
11	  format(' Transformation to a Left-handed System'/
     1	'$Is That What You Really Wish (Y,<N>)?')
	  read(5,'(a)')iresp
	  if(iresp.ne.'Y'.and.iresp.ne.'y')then
	    if(iread.eq.0)then
	      go to 100
	    else
	      return
	    endif
	  endif
	endif
	call MatTsp(ub,temp)
	call matmul(temp,ub,g)
	call minv(g,g,det)
c Transform G
	call MatTsp(trn,trntsp)
	call matmul(g,trntsp,temp)
	call matmul(trn,temp,gp)
	do i=1,3
	  celnew(i)=sqrt(gp(i,i))
	enddo
	celnew(4)=acos(gp(3,2)/(celnew(2)*celnew(3)))*57.2958
	celnew(5)=acos(gp(3,1)/(celnew(1)*celnew(3)))*57.2958
	celnew(6)=acos(gp(1,2)/(celnew(2)*celnew(1)))*57.2958
	type 14,celnew
14	format(' Transformed Lattice Values: ',3f8.4,3f8.2)
15	type 16
16	format('$Do You Wish to Apply Transformation<Y,N>?  ')
	read(5,18,end=9999,err=15)iresp
18	format(a1)
	if(iresp.ne.'Y'.and.iresp.ne.'y')return
	type 20
20	format(' Transforming Cell and List Indices')
c
C Save Old Orientation Matrix
	call pushom
c
c Calculate  new UB = old UB * (transform)-1
c
	call minv(trn,temp,det)
	call matmul(ubo,temp,ub)
c Get New Value of B
	call omtob(0)
c Transform List Indices
	do i=1,nlst
	  do j=1,3
	    fhh(j)=0
	    do k=1,3
	      fhh(j)=fhh(j)+trn(j,k)*ihlst(k,i)
	    enddo
	  enddo
	  do j=1,3
	    ihlst(j,i)=fhh(j)
	  enddo
	enddo
	call update
9999	return
	end
	options/extend
	subroutine grid
c
c Routine to prepare grid of reciprocal space
c
	implicit none
	include 'single.inc'
	real*4 fh0(3),dfhh(3),dfhv(3),time,temp,thphi(3),angl(4),rdsclr
     1	,fhmx(3)
	character filename*80,iresp*1
	integer*4 nh,nv,istep(400),ih,iv,i,ierr,icmax
c
1000	write(5,10)
10	format(/' Reciprocal Space Grid Routine'
     1	//'$Enter Miller Indices of Central Point:')
	read(5,'(3f10.0)',err=1000,end=9999)fh0
1010	write(5,20)
20	format('$Enter Number of Horizontal Points and Delta hkl:')
	read(5,'(i10,3f10.0)',err=1010,end=9999)nh,dfhh
1020	write(5,22)
22	format('$Enter Number of Vertical Points and Delta hkl:')
	read(5,'(i10,3f10.0)',err=1020,end=9999)nv,dfhv
c Make Number of intervals even - Upper value odd
	nh=(nh/2)*2+1
	nv=(nv/2)*2+1
1030	write(5,30)
30	format('$Enter Time (sec) per Step: ')
	read(5,'(f10.0)',err=1030,end=9999)time
c calculate total time of run
	temp = ((nh+1)*(nv+1)*time)/60.0
	write(5,40)temp
40	format(' Total Time for Experiment is ',f6.1, ' Minutes.'
     1	/'$Is this OK (Y,<N>)? ')
	read(5,'(a)',end=9999)iresp
	if(iresp.ne.'y'.and.iresp.ne.'Y')go to 1010
c Get file name of output file
	write(5,50)
50	format('$Enter Name of Output File: ')
	read(5,'(a)',end=9999)filename
	open(unit=99,name=filename,status='new',carriagecontrol='list')
	write(99,60)fh0,nh,dfhh,nv,dfhv
60	format(' Intensity around ',3f7.3,2(i5,3f6.3))
	close(unit=99)
c Calculate Initial Position
	call calphi(fh0,thphi)
	call calca(thphi,angl,ierr)
	if(ierr.ne.0)go to 9000
c Drive to position
	do i=4,1,-1
	    call drive(i,angl(i),0.0,1,ierr)
	    if(ierr.ne.0)go to 9000
	enddo
	call wait
	call onbeam
	icmax=0
c
c Start step scan
c
	do iv = 1,nv
	    do ih=1,nh
c Calculate indices for this point
		do i=1,3
		    fh(i)=fh0(i)+(int(nh/2+1)-ih)*dfhh(i)
     1			+(int(nv/2+1)-iv)*dfhv(i)
		enddo
c Calculate angles
		call calphi(fh,thphi)
		call calca(thphi,angl,ierr)
		if(ierr.ne.0)go to 9000
c Drive to position
		do i=1,4
		    call drive(i,angl(i),0.0,1,ierr)
		    if(ierr.ne.0)go to 9000
		enddo
		call wait
c Count
		call count(time)
		call wait
		istep(ih)=rdsclr()
		if(istep(ih).gt.icmax)then
		    icmax=istep(ih)
		    do i=1,3
			fhmx(i)=fh(i)
		    enddo
		endif
	    enddo
	    open(unit=99,file=filename,access='append',status='unknown')
	    write(99,'(20i6)')(istep(i),i=1,nh)
	    close(unit=99)
	enddo
	call ofbeam
	write(5,70)icmax,fhmx
70	format(' Maximum Count Value: ',i6,' at ',3f7.3)
	return
9000	write(5,'(a)')' Position Out-of-Bounds'
	call ofbeam
9999	return
	end	
