      options/extend
      subroutine calibrate
c
c routine to call various calibration/measurement routines
c
c written rja 12-feb-93 
c
	
c
c request calibration procedure
c
1	type 2
2	format(78('*')//25x,'CALIBRATION ROUTINES AVAILABLE'//)
6	type 3
3	format(5x,'1: DAC Transmission'/
     9  '$        Enter Selection:')
4	read(5,5,end=9999,err=10)isel
5	format(i10)
c
c test for valid selection
c
	if(isel .lt. 1)goto9999
	if(isel .lt. 2)goto100
c
c invalid selection
10	write(6,12)
12	format(/'$ *******INVALID SELECTION, Input new value:')
	goto4
c
c process valid selections
c
100	continue
110	call dacabsorb
	goto6
c
c exit
9999	return
	end
c
	SUBROUTINE DACABSORB
c
c  subroutine to scan dac's and measure transmission
c 
      implicit none
      include 'single.inc'
      include 'device.inc'
      include 'alph.inc'
      real*4 chist,chien,chistp,chipos,delchi,phist,phien,phistp,
     1       delphi,abs,rdsclr,rdtime,rdmtr,rate,temp,tempr,tempt,
     2       phipos,phiend,cttime,sgn

      integer*4 ierr,i,q
      byte resp
	character*80 tempname
c
c write information to terminal
c
      call prnt_on
	write(6,1)filename
1	format(78('*')/10x,'Measurement of DAC transmission ',
     1    'as function of omega and chi'//)
c
c Check file name
c
3	write(6,2)
2	format(10x,'Data will be written to file: ',a80/
     1  '$  Do you want to change the file (Y/<N>): ')
	read(5,6,end=9999,err=3)resp
6       format(a1)
7	if(resp.eq.'Y'.or.resp.eq.'y')then
8	   write(6,10)
10	   format('$  Input new filename: ')
	   read(5,12,err=8,end=9999)i,tempname
12	   format(q,a80)
	   if(q .gt. 0)then 
		filename=tempname
	   else
		filename='nl:'
	   endif
	   call update
	endif
	open(unit=20,file=filename,err=20,status='unknown',
     1       access='append',carriagecontrol='list')
	goto 100
c
c error on file open
c
20	write(6,22)filename
22	format(' *****Error opening file: ',a80)
	resp='y'
        goto7
c
c get two-theta and phi set to zero
c
100	call drive(1,0.0,0,1,ierr)
	if(ierr .eq. 1)goto9000
	call drive(4,0.0,0,1,ierr)
	if(ierr .eq. 1)goto9000
c
c request ranges
c
113    type 114
114    format('$Enter Initial, Final and Step in Chi: ')
      read(5,111,end=9999,err=113)chist,chien,chistp
111   format(3f10.0)
      delchi=abs(chistp)*sgn(chien-chist)
      call drive(3,chist,0,1,ierr)
	if(ierr .eq. 1)then
		type 115
115		format('  Starting Chi OUT-OF-BOUNDS')
		goto113
	endif
c
c set up omega
c
1020  	type 1025
1025    format('$Enter Initial, Final, and Step in Omega: ')
      	read(5,10,end=9999,err=1020)phist,phien,phistp
      	delphi=abs(phistp)*sgn(phien-phist)
      	call drive(2,phist,0,1,ierr)
	if(ierr .eq. 1)then
		type 1030
1030		format('  Starting Omega OUT-OF-BOUNDS')
		goto1020
	endif
c
c set up count time
c
1100	type 1105
1105	format('$Enter count time per step (secs): ')
1106	read(5,1110,end=9999,err=1100)cttime
1110	format(f10.0)
	if(cttime .lt. 0.5 .or. cttime .gt. 100.0)then
	   type 1115
1115	   format('$Invalid Count Time, Reinput (0.5-100.0): ')
	   goto1106
	endif
c
c start of loops over angles
c
      call wait
      call onbeam
      chipos=chist
C Enter Chi Loop
300   call drive(3,chipos,0,1,ierr)
      if(ierr .eq. 1)goto455
      call drive(2,phist,0,1,ierr)
      call wait
      phipos=phist
c
C Enter Omega Loop
c
400   call drive(4,phipos,0,1,ierr)
      if(ierr .eq. 1)goto455
      call wtmtr(2)
      call count(cttime)
      call sclwt
      tempr=rdsclr()
      tempt=rdtime()
      rate=tempr/tempt
      write(20,401)chipos,phipos,rate
401   format(3f10.3)
c 
c increment omega 
c
450   phipos=phipos+delphi
      if((phiend-phist)*(phien-phiend).gt.0.0)go to 400  !loop for more Phi's
c End of Phi Scan - Advance to Next Chi
455   delphi=-delphi
      temp=phist
      phist=phien
      phien=temp
      chipos=chipos+delchi
      if((chipos-chist)*(chien-chipos).gt.0.0)go to 300
C End of Chi Steps - Finished
c
500   call ofbeam
c
c drive to zero
      do i=1,4
		cangl(i)=0.
      enddo
      call drivep(0,ierr)
      type 30
30    format(/' End of Absorption Scans')
      call prnt_off
      goto9999
c
c error on initial drives
c
9000	type 9010
9010	format(' Drive error on initial drive')
c
9999  return
      end
