	PROGRAM SUPERVISOR
	PARAMETER (NBR=4)
C
C PROGRAM TO LOAD OPERATING CODE AND DIAGNOSTICS
C
	BYTE MENU(4,nbr),RESP(4),iresp
C
	DATA MENU/'B','O','O','T'  ,'D','I','A','G'  ,'L','O','A','D' ,
     1  'E','X','I','T'/
C
	TYPE 4
4	FORMAT('0GEOLAB Diffractometer Supervisor Program - '
	1,'V2.11 (1-Jun-92)'/)
	call terminal
C
1000	continue
	TYPE 6
6	FORMAT(/'$SUPER>')
	read(5,8)I,RESP
8	FORMAT(Q,4A1)
	IF(I.LE.0)call exit
	do 1002 i=1,4
	  if(resp(i).gt."137)resp(i)=resp(i)-"40
1002	continue
	DO 1010 I=1,NBR
	  do 1005 j=1,4
	    IF(MENU(j,I).ne.RESP(j))GO TO 1010
1005	  continue
	go to 1030
1010	CONTINUE
	TYPE 10,((MENU(J,I),J=1,4),I=1,NBR)
10	FORMAT('0Available Commands are:',(T30,5(4A1,5X)))
	GO TO 1000
1030	GO TO (5000,6000,7000,8000),I
C
C BOOT SYSTEM
C
5000	CALL BOOT
	GO TO 1000
C
C DIAGNOSE SYSTEM
C
6000	CALL DIAG
	GO TO 1000
c
C LOAD SUPERVISOR PROGRAM IN PDP-11
c
7000	call load_super
	go to 1000
c
c EXIT
c
8000	call exit
	END
	options /extend
	subroutine terminal
c
c Program to interconnect between VAX and PDP-11/23 operating the
c	X-ray diffractometers at Geophysical Laboratory.
c
	implicit none
	include 'trmprg.inc'
	include 'newdif.inc'
	integer*4 difno,status,sys$assign
	character difname*8,diffile*24 
c
	type 2
2	format('$Type Diffractometer Number (1-3)?')
100	read(5,4)difno
4	format(i10)
	if (difno.lt.1.or.difno.gt.3)then
	  type 6
6	  format(' Incorrect Diffractometer NUmber!'
	1//'$Type Diffractometer Number (1-3)?')
	  go to 100
	endif
c
c Form Logical Name for Diffractometer and assign LUN's for QIO's
c
	write(difname,8)difno
8	format('DIFRAC$',i1)
	status = sys$assign(difname,lun2,,)
	if (.not. status)call lib$signal(%val(status))
	status = sys$assign('sys$output',lun1,,)
	if (.not. status)call lib$signal(%val(status))
c
c set diffractometer interface speed at 9600
c
	call set_speed(15)
	dif_lock=0
c
c initialize buffer pointer and start AST routine running
c
	bufpnti=1
	bufpnto=1
	call next_char2
	return
	end
	options /extend
	subroutine break
	implicit none
	include 'trmprg.inc'
	integer*2 null(5)
	data null/5*0/
c
c routine to generate a "BREAK" on the PDP-11/23
c
c	call sys$cancel(%val(lun2))
c	call set_speed(1)	!set baud rate = 50
c	call sys$qiow(,%val(lun2),%val("460),,,,null,%val(5),,,,)
c	call delay(500)
c	call set_speed(15)	!reset baud rate to 9600
c	call next_char2		!restore ast
	return
	end
	options /extend
	subroutine delay(msec)
c
c delay for msec milliseconds...uses system services
c sys$setimr,sys$waitfr   see system services reference manual
c chapter 8, for example and definition of delta time
c
	integer*2 msec
	integer*4 qtim(2)
	qtim(2)=-1
	qtim(1)=msec
	qtim(1)= -10000*qtim(1)
c in 100 nanosecond units, use event flag 15
	call sys$setimr(%val(15),qtim,,)
	call sys$waitfr(%val(15))
	return
	end
	options /extend
	subroutine diag
c
c Routine to load diagnostic programs
c
	implicit none
	character*80 filename
	byte bufout(80)
	integer*4 i,j
	include 'trmprg.inc'
c
	echo = .false.
c
c load the bootstrap loader
c
	call boot
	echo = .true.
	type 4
4	format('$Type Name of Diagnostic File?')
	read(5,6)filename
6	format(a)
	open(unit=11,file=filename,type='old',readonly)
	type 8
8	format(' Loading file: When loaded, diagnostic routine will'
	1,' be started.'/' Type <CR> to stop diagnostic')
c
c Transfer the diagnostic binary program.
c
	call load_bin
	read(5,6)filename
	echo=.false.
	call break
c
c start echo loop
c
	return
	end
	options /extend
	subroutine load_super
c
c Routine to load supervisor programs
c
	implicit none
	character*80 filename
	byte bufout(80)
	integer*4 i,j
	include 'trmprg.inc'
	include 'newdif.inc'
c
	echo = .false.
c
c load the bootstrap loader
c
	call boot
	type 2
2	format(' Loading Supervisor Code.')
	echo = .true.
	open(unit=11,file='single$base:newdif.hex',type='old',readonly)
c
c Transfer the supervisor binary program.
c
	call load_bin
	echo=.false.
	return
	end
	options /extend
	subroutine halt
c
c Routine to halt the PDP-11/23
c
	implicit none
	include 'trmprg.inc'
c
	type 2
2	format('0Halting the PDP-11/23'/)
c
c Halt the PDP-11/23 
c
	call break
	echo = .true.
	return
	end
	options /extend
	subroutine boot
	implicit none
	character*1 char
	byte laalph(6),dalph(6),start(5)
	integer*4 i
	include 'trmprg.inc'
	data start/'1','0','0','0','G'/
c
c Routine to halt the PDP-11/23 by issuing a BREAK and load the bootstrap loader
c
	type 2
2	format('0Bootstrapping PDP-11/23')
	call break
	open(unit=11,name='single$base:boot.bot',type='old',readonly)
100	read(11,4,end=1000)laalph,dalph
4	format(2(1x,6a1))
c
c output load address
c
	do i=1,6
	  if(laalph(i).ne.'0')go to 200
	end do
	i=6
200	call outstring(laalph(i),7-i)
c
c examine it
c
	call delay(20)
	call outstring('/',1)
	call delay(300)
c
c load new value
c
	do i=1,6
	  if(dalph(i).ne.'0')go to 300
	end do
	i=6
300	call outstring(dalph(i),7-i)
	call outstring("15,1)
	call delay(100)
	go to 100
1000	call delay(300)
	call outstring(start,5)
	call delay(1500)
	close (unit=11)
	return
	end
	options /extend
	subroutine outstring(alph,n)
c
c output the string of 'n' characters in 'alph'
c
	implicit none
	include 'trmprg.inc'
	include '($iodef)'
	byte alph(*)
	integer*4 n
c
	call sys$qioW(%val(15),%val(lun2),%val(io$_writevblk .or.
     1	    io$m_noformat),,,,alph,%val(n),,,,)
	return
	end
	options /extend
	subroutine set_speed(speed)
	implicit none
	integer*4 speed,Charbuf(2),sys$qiow,status
	include 'trmprg.inc'
c
c set speed of line by sensing characteristics and writing back with speed set
c
c	call sys$qiow(,%val(lun2),%val('27'X),,,,Charbuf,,,,,)
c	status = sys$qiow(%val(1),%val(lun2),%val('23'X),,,,Charbuf,,%val(speed),,,)
c	if(.not.status)call lib$signal(%val(status))
	return
	end
	options /extend
	subroutine next_char2
	implicit none
	include 'trmprg.inc'
	integer*4 status,sys$qio
	external term_ast2
c
	status = sys$qio(,%val(lun2),%val("1161),iosb2,term_ast2,,inmsg2,%val(1),,,,)
	if (.not.status)call lib$signal(%val(status))
	return
	end
	options /extend
	subroutine term_ast2(ast_arg)
c
	include 'trmprg.inc'
	integer*4 ast_arg,i
c
c check for i/o canceled
c
	if(iosb2(1).ne.1)return
c
c terminate character to 7 bits
c
	inmsg2 = inmsg2 .and. '177'O
	if(inmsg2.eq.'7'O)then
	  bufact=.true.
	else
	  if(bufact)then
c
c add character to buffer
c
	    bufpnti=bufpnti+1
	    if(bufpnti.gt.bufsz)bufpnti=1	!handle wraparound
	    buffer(bufpnti)=inmsg2
	    if(inmsg2.eq.'15'O)then
	      call sys$setef(%val(11))
	      bufact=.false.
	    endif
	  else
c
c copy character to sys$output
c
	    if(echo)call sys$qioW(,%val(lun1),%val("460),,,,inmsg2,%val(1),,,,)
	  endif
	endif
c
c start next character in
c
	call next_char2
	return
	end
	options /extend
	subroutine load_bin
c
c routine to load a binary program
c
	implicit none
	integer*4 i,j,k,l
	logical eightbit
	byte bufout(80)
	include 'trmprg.inc'
	include '($iodef)'
	parameter (eightbit = .true.)
c
100	read(11,8,end=200)i,bufout
8	format(q,80a1)
	if(eightbit)then
	  k=0
	  do j=1,i,2
	    k=k+1
	    l=(bufout(j+1).and."17)
	    l=l*"20+(bufout(j).and."17)
	    if(l.gt.127)l=l-256
	    bufout(k)=l
	  end do
	  i=k
	end if
	do j=1,i
	  call sys$qiow(,%val(lun2),%val(io$_writevblk .or.
     1	    io$m_noformat),,,,bufout(j),%val(1),,,,)
	end do
	go to 100
200	close(unit=11)
	return
	end
