!
!       This is a set of FORTRAN subroutines for PDP11/02 and
!               VAX/VMS CAD4 application.
!
!                                       H. Lenk         8-Jun-1983
	Subroutine cad4_io (io_func,io_pre,io_post0,io_post1,io_post2,
     1          io_post3,io_post4,io_post5,io_post6,io_post7)
!
!       Subroutine for protocol I/O with LSI 11
!
!       io_func (byte)  - function code from VAX to 11/02
!       io_pre  (addr)  - address of pre-processing routine
!       io_postn(addr)  - address of post-processing routine n 
!                         depending on function bits in input_header
!                         (received from 11/02)
!
	integer*2       head02          !input header in word mode
!
	include 'CAD4COMM'  !Include common block
!
!    input:
!       io_coswr (word) - switch options register from vax to 11/02
!       io_cobnr (word) - no. of calls to 11/02
!       io_cohex (byte) - header from VAX to 11/02
!
!       IO_COHEX is copied into OUTPUT_HEADER byte
!
!  Prepare for next protocol message:
!    a) previous result is assumed to be successfull
!    b) block number of protocol message is one higher than previous one
!
	result = e_suc
	io_cobnr = io_cobnr + 1
!
  10    continue
!  Define header of protocol message
!                  bit 0-1 :    seq. no. of the calls to LSI-11
!                  bit 2-4 :    result code
!                  bit 5-7 :    function
!       
	  io_cohex = io_func + result + iand(io_cobnr,m_seq)
!
!  Call pre processing routine to fill the output_buffer
!
	  call io_pre
!
!  Move transmit header to transfer buffer
!
	  output_header = io_cohex
!
!  Transfer buffer to LSI-11 and wait for answer
!
	  call  cad4_readprompt (result)
!
!  Check for succesfull reception of answer
!
	if (result .ne. e_suc) go to 10
!
!  Check if LSI-11 was able to interprete our transmitted data well
!
	  head02 = input_header           !integer*2 header for IAND's
	  if (iand(head02,m_efl) .eq. e_suc) go to 30
!
!  Now we are disappointed but check if LSI-11 wants a new start
!
	if (iand(head02,m_efl+m_fun).ne.
     1          iand(#ff,f_req_mem+e_typ)) goto 10
!
!
!       If seq. no. correct
!
30      if (iand(io_cobnr,m_seq).eq.iand(head02,m_seq)) go to 40
!
!       Transfer sequence error
!
	result = e_seq
	go to 10
!
!       Select the post processing routine
!
40      n = iand(head02,m_fun) / #20
!
!       write (l_unit,10010) n
10010   format(' cad4_io        : received function dispatch = ',z2)
!
	go to (100,101,102,103,104,105,106,107) n+1
100     call io_post0(result)
	go to 200
101     call io_post1(result)
	go to 200
102     call io_post2(result)
	go to 200
103     call io_post3(result)
	go to 200
104     call io_post4(result)
	go to 200
105     call io_post5(result)
	go to 200
106     call io_post6(result)
	go to 200
107     call io_post7(result)
!
!       Check post processing error and eventual
!       initialization of 11/02
!
200     if (result .eq. e_typ) then
	  if (io_func .eq. f_init) result = e_suc
	  goto 10
	else
	  if (result .ne. e_suc) goto 10
	end if
	return
	end
!
!
	subroutine cad4_load_syspar
!
!       Pre processing routine to copy syspar values from syspar_val
!       to output buffer
!
	include 'CAD4COMM'
!
! Copy syspar data to output_buffer
!
	do i=1,((nr_load_byte+1)/2)
	   output_data_w(i+1) = syspar_val(i)
	end do
!
! Set load address
!
	output_data_w(1) = slave_load_address
!
! Set output length
!
	output_length = nr_load_byte + 2
!
	return
	end
!
!
	Subroutine      cad4_send_oper4 (text)
!
! Routine to send message to operator
!        
	character*(*)   text            ! Input string
!
	include 'CAD4COMM'          ! Include common block
!
	print *,text
	return
	end
!
!
	Subroutine      cad4_get_instrument
!
! Subroutine to insert ASCII instrument name and logical*1
! unit number to CAD4 instrument into fortran common block
!
!       modified: 03-jan-1985 LCB Adaption for SBC-21 (Falcon processor)
!
! A process name of 'CAD4?_CAn' is required !!!!!!
!
	include 'CAD4COMM'  ! Include common block
!
	ibycan_c(2:4) = 'CA0'           ! Set default
	ibycan_b(1)   = 0               ! name and unit
!
!  For now assume a Falcon by setting UIC = #40
!
	process_uic_w(1) = #40
!
	if ((process_uic_w(1).and.#40).ne.0) then
	  lsypar = sbc_bottom - #40
	else
	  lsypar = lsi_bottom - #40
	end if
	if ((process_uic_w(1).and.#20).ne.0) then
	  lsypar = sbcp_bottom - #40
	end if
!
!       write (l_unit,10020) ibycan_c(2:4), ibycan_b(1)
10020   format (' Instrument name =  ',a3,'   Unit = ',i3)
!
	return
	end
!
!
	Subroutine      cad4_ini_terminal       ! Initialize terminal
!
      CHARACTER PORT*4   
      COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR,
     $                IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF,
     $                VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD
	include 'CAD4COMM'          ! Include common block
!
	cad4_terminator(1) = 0                  ! Short form
	cad4_terminator(2) = 0                  ! No terminator characters
!
      PORT = 'COM'//CHAR(IPORT+48)        
	call io_init (PORT,IBAUD,8,'n',1)
	write (l_unit,10060) PORT,IBAUD
10060   format (' Port ',A,': set to 'I5,',8,n,1')
!
	return
	end
!
	Subroutine      cad4_exit_handler(exit_status)  ! Exit handler
!
	include 'CAD4COMM'          ! Include common block
!
!
!       if (l_unit_open) close (unit=l_unit)    ! Close Log file if open
	l_unit_open = .false.                   ! Set false
!
	exit_status = exit_status
	return                          ! Return
	end
!
!
	Subroutine      cad4_reset_terminal ! Routine to reset cad4 terminal
!
	include 'CAD4COMM'          ! Include common block
!
	qio_status = io_done ()
!
!       de-allocate cad4 communication channel
!
	return                          ! Return to caller
	end
!
!
	Subroutine      cad4_readprompt(result)
!
! Arguments used :
!       
!       prompt_buffer           ! Buffer to save prompt
!       prompt_length           ! No of data bytes to send
!       input_buffer            ! Input buffer to read record
!
	include 'CAD4COMM'          ! Include common block
!
! First compute checksum and insert it at the end of output buffer
! (compute total prompt size)
!
	call    cad4_prepare_output
!
!       write (l_unit,10010) (prompt_buffer(l),l=1,prompt_size)
10010   format (' ttyreadpall - Prompt = ',20(z4,1x))
!       write (l_unit,10020) prompt_header
10020   format ('             - Header = ',z4)
!       write (l_unit,10030) prompt_length
10030   format ('             - Length = ',z7)
!       write (l_unit,10035) isum_w
10035   format ('             - CRC    = ',z8,'   sending header')
!
! Perform QIO to send prompt and read header
!
!       qio_status = sys$qiow (%val(cad4_efn),%val(cad4_chan),
!    1                          %val(io_funct),cad4_iosb,,,
!    2                          %ref(input_buffer),     ! p1 = input buffer
!    3                          %val(1),                ! p2 = input size
!    4                          %val(cad4_l_timo),      ! p3 = timeout count
!    5                          %ref(cad4_terminator(1)), ! p4 = term. mask
!    6                          %val(%loc(prompt_buffer)), ! p5 = prompt buffer
!    7                          %val(prompt_size) )     ! p6 = prompt b. size
!
	qui_status = io_prompt (cad4_iosb,
     $                          input_buffer,
     $                          1,
     $                          cad4_l_timo,
     $                          prompt_buffer,
     $                          prompt_size)
!
	if (iand(cad4_iosb_i2(1),1) .eq. 1) then
!
! Now read length and crc or data bytes from PDP11/02
!
	    cad4_iosb(1) = 0                    ! Be sure length and
	    cad4_iosb(2) = 0                    !  io-status is zero
!
!         qio_status = sys$qiow (%val(cad4_efn),%val(cad4_chan),
!    1                          %val(io_funct),cad4_iosb,,,
!    2                          %ref(input_buffer(2)),  ! p1 = input buffer
!    3                          %val(4),                ! p2 = input size
!    4                          %val(cad4_timeout),     ! p3 = timeout count
!    5                          %ref(cad4_terminator(1)),,) ! p4 = term. mask
!
!
	  qio_status = io_read (cad4_iosb,
     $                          input_buffer(2),
     $                          4,
     $                          cad4_timeout)
!
!         write (l_unit,10040) input_header
10040     format ('             - InpHdr = ',z4)
!         write (l_unit,10050) input_length
10050     format ('             - InpLen = ',z7)
!
	  input_size = 4
	  if((iand(cad4_iosb_i2(1),1) .eq. 1) .and.
     $                   input_length .ne. 0) then
!
! Now read data bytes from PDP11/02
!
	    cad4_iosb(1) = 0                    ! Be sure length and
	    cad4_iosb(2) = 0                    !  io-status is zero
!
	    input_size = input_length   !(n-2)Data bytes and checksum
	    if(input_size.lt.0.or.input_size .gt. 516)input_size=516
!
!           qio_status = sys$qiow (%val(cad4_efn),%val(cad4_chan),
!    1                          %val(io_funct),cad4_iosb,,,
!    2                          %ref(input_buffer(6)),  ! p1 = input buffer
!    3                          %val(input_size),       ! p2 = input size
!    4                          %val(cad4_timeout),     ! p3 = timeout count
!    5                          %ref(cad4_terminator(1)),,) ! p4 = term. mask
!
	    qio_status = io_read (cad4_iosb,
     $                          input_buffer(6),
     $                          input_size,
     $                          cad4_timeout)
!
	  end if
	end if
!
! Check CRC and set up return status
!
	call cad4_check_crc (result)
!
!       write (l_unit,10070) (input_buffer(l),l=1,10)
10070   format ('             - Input  = ',10(z4,1x))
!       write (l_unit,10080) qio_status,cad4_iosb
10080   format ('             - IOSB   = ',z8,2x,z8,2x,z8)
!
	return
	end                     
!
	Subroutine      cad4_prepare_output
!
	include 'CAD4COMM'          ! Include common block
!
! Prepare output buffer for output
!       1. set output_size to to no of bytes output in QIO
!       2. computes 16. bit CRC and store it at end of buffer
!       3. clear iosb
!
!
! 1. Set output_size
!
	output_size = 1 + 2 + output_length + 2 ! Header byte
						! No. of data bytes (word)
						!  n data bytes
						! 16 bit CRC
!
! 2. Compute CRC
!
	isum_w = 0                              ! First use 16 bit sum
	do l = 1, output_length + 3
	    crchar=ichar(output_buffer_c(l:l))
	    crchar=iand(crchar,#ff)
	    isum_w = ieor (isum_w,crchar)
	    do m = 1, 8
		if (iand(isum_w,1) .eq. 1) then
		  isum_w = isum_w/2
		  isum_w = ieor (isum_w,iconst)
		else
		  isum_w = isum_w / 2
		end if
	    end do
	end do
!
	output_buffer(output_length+3+1) = isum_b(1)    ! Copy CRC to
	output_buffer(output_length+3+2) = isum_b(2)    !  end of buffer
!
! 3. Clear IOSB
!
	cad4_iosb(1) = 0                        ! Be sure length and
	cad4_iosb(2) = 0                        !  io-status is zero
!
	return
	end
!
!
	Subroutine      cad4_check_crc (result)
!
	include 'CAD4COMM'          ! Include common block
!
! Check answer from cad4
!
!       input:  cad4_iosb       - I/O status block
!               input_buffer    - input data and CRC
!
!       output: cad4_iosb       
!
!       1. word         2. word   result
!
!       ss$_xxxxxx      0        e_pnd          system service failed
!       ss$_normal      0        e_tol          no data within timeout seconds
!       ss$_normal      icnt     e_tos          not enough data to meet protcol
!                                               icnt = no. of bytes received
!       ss$_normal      rcnt     e_ovf          buffer ovf but trans. not. fin.
!                                               rcnt = no. of rec. bytes is max
!       ss$_normal      pcnt     e_crc          enough data rec. but CRC error
!                                               pcnt = hd.byte + length + data
!       ss$_normal      pcnt     e_suc          success
!
!
!
!       qio_status = cad4_iosb_i2(1)            ! Copy status code
!
! Here if no timeout or any other error
!
	if (cad4_iosb_i2(1) .ne. 0) then
!
!
	  if(cad4_iosb_i2(2).eq.input_size)then
!
! Subtract CRC
!
	    if (input_length.lt.0 .or. input_length.gt.516)
     1                  input_length = 516      !protect memory
	    isum_b(1) = input_buffer(input_length+3+1)
	    isum_b(2) = input_buffer(input_length+3+2)
	    isum = isum_w       !save received crc
!
!
!       Check checksum of received data
!
	    isum_w = 0                          ! First use 16 bit sum
	    do l = 1, input_length + 3
	      crchar=ichar(input_buffer_c(l:l))
	      crchar=iand(crchar,#ff)
	      isum_w = ieor (isum_w,crchar)
	      do m = 1, 8
		if (iand(isum_w,1) .eq. 1) then
		  isum_w = isum_w / 2
		  isum_w = ieor (isum_w,iconst)
		else
		  isum_w = isum_w / 2
		end if
	      end do
	    end do
!
!           write (l_unit,10010) isum_w, isum
10010       format (13x,'- Computed Sum = ',z8,' Received CRC = ',z8)
!
!       Set status code into third word of IOSB
!
	    if (isum_w.eq.isum) then
	      result = e_suc
	    else
	      result = e_crc
	    end if
	  else
	    result=e_ovf
	  end if
!
! Here if any qio error except timeout
!
	else
	  if (qio_status.ne.ss$_timeout) then
	    result = e_pnd
!
! Here if timeout
!
	  else
	    cad4_iosb_i2(1) = ss$_normal        ! Set success in first word
	    if (cad4_iosb_i2(2).eq.0) then
	      result = e_tol                    ! No data for zero byte count
	    else
	      result = e_tos                    ! Not enoght data received
	    end if
!
	  end if
	end if
	qio_status = cad4_iosb_i2(1)            ! Copy status code!
!
!       write (l_unit,10020) result
10020   format (13x,'- Result = ',z4)
!
	return
	end
!
	Subroutine      cad4_open_log_file
!
	include 'CAD4COMM'          ! Include common block
!
	l_unit_open = .true.                         ! File open flag
	return
	end
!
	Subroutine      cad4_post_dummy(result)
!
!       Post proc. routine - just to meet standard call sequence
!
	include 'CAD4COMM'
	result = result
	return
	end
!
	Subroutine      cad4_pre_dummy
!
!       Pre proc. routine - just to meet standard call sequence
!
	include 'CAD4COMM'
	output_length = 0
	return
	end
!
	Subroutine      cad4_type_error(result)
!
!       Post proc. routine
!
	include 'CAD4COMM'
	result = e_typ
	return
	end