204 lines
5.2 KiB
Fortran
204 lines
5.2 KiB
Fortran
INTERFACE TO INTEGER*2 FUNCTION SIOBAUD [c,alias:'_SioBaud']
|
||
$ (Port, BaudCode)
|
||
INTEGER*2 Port [value]
|
||
INTEGER*2 BaudCode [value]
|
||
END
|
||
|
||
INTERFACE TO INTEGER*2 FUNCTION SIODONE [c,alias:'_SioDone']
|
||
$ (Port)
|
||
INTEGER*2 Port [value]
|
||
END
|
||
|
||
INTERFACE TO INTEGER*2 FUNCTION SIOERROR [c,alias:'_SioError']
|
||
$ (Code)
|
||
INTEGER*2 Code [value]
|
||
END
|
||
|
||
INTERFACE TO INTEGER*2 FUNCTION SIOGETC [c,alias:'_SioGetc']
|
||
$ (Port, TimeOut)
|
||
INTEGER*2 Port [value]
|
||
INTEGER*2 TimeOut [value]
|
||
END
|
||
|
||
INTERFACE TO INTEGER*2 FUNCTION SIOPARMS [c,alias:'_SioParms']
|
||
$ (Port, Parity, StopBits, WordLength)
|
||
INTEGER*2 Port [value]
|
||
INTEGER*2 Parity [value]
|
||
INTEGER*2 StopBits [value]
|
||
INTEGER*2 WordLength [value]
|
||
END
|
||
|
||
INTERFACE TO INTEGER*2 FUNCTION SIOPUTC [c,alias:'_SioPutc']
|
||
$ (Port, Byte)
|
||
INTEGER*2 Port [value]
|
||
CHARACTER*1 Byte [value]
|
||
END
|
||
|
||
INTERFACE TO INTEGER*2 FUNCTION SIORESET [c,alias:'_SioReset']
|
||
$ (Port, BaudCode)
|
||
INTEGER*2 Port [value]
|
||
INTEGER*2 BaudCode [value]
|
||
END
|
||
|
||
INTERFACE TO INTEGER*2 FUNCTION SIORXBUF [c,alias:'_SioRxBuf']
|
||
$ (Port, Buffer, Size)
|
||
INTEGER*2 Port [value]
|
||
INTEGER*1 Buffer [reference]
|
||
INTEGER*2 Size [value]
|
||
END
|
||
|
||
INTERFACE TO INTEGER*2 FUNCTION SIORXFLUSH
|
||
$ [c,alias:'_SioRxFlush'] (Port)
|
||
INTEGER*2 Port [value]
|
||
END
|
||
|
||
INTERFACE TO INTEGER*2 FUNCTION SIORXQUE [c,alias:'_SioRxQue']
|
||
$ (Port)
|
||
INTEGER*2 Port [value]
|
||
END
|
||
!
|
||
!
|
||
! Routines to simulate VAX QIOs
|
||
!
|
||
integer function io_init (cport, speed, width, parity, bits)
|
||
integer*2 SioRxBuf, SioReset, SioParms, SioError, SioRxFlush
|
||
character cport*(*), parity*(*)
|
||
integer speed, width, bits
|
||
integer*2 prty, dwidth, dbits, dspeed, rc
|
||
integer*1 RxBuffer(1024)
|
||
integer*2 Port
|
||
common /QioConst/ Port
|
||
common /QioBuf/ RxBuffer
|
||
|
||
Port = 0
|
||
if (cport(1:3) .eq. 'COM' .or. cport(1:3) .eq. 'com') then
|
||
if (len(cport) .ge. 4) then
|
||
if (cport(4:4) .eq. '2') Port = 1
|
||
endif
|
||
endif
|
||
|
||
prty = 0
|
||
if (parity(1:1) .eq. 'o' .or. parity(1:1) .eq. 'O') prty = 1
|
||
if (parity(1:1) .eq. 'e' .or. parity(1:1) .eq. 'E') prty = 3
|
||
|
||
dbits = 0
|
||
if (bits .eq. 2) dbits = 1
|
||
|
||
dwidth = 3
|
||
if (width .eq. 7) dwidth = 2
|
||
|
||
dspeed = 5
|
||
if (speed .eq. 19200) dspeed = 6
|
||
if (speed .eq. 4800) dspeed = 4
|
||
if (speed .eq. 2400) dspeed = 3
|
||
if (speed .eq. 1200) dspeed = 2
|
||
if (speed .eq. 300) dspeed = 0
|
||
|
||
rc = SioRxBuf (Port, RxBuffer(1), 7)
|
||
if (rc .lt. 0) i = SioError (rc)
|
||
rc = SioParms (Port, prty, dbits, dwidth)
|
||
if (rc .lt. 0) i = SioError (rc)
|
||
rc = SioReset (Port, dspeed)
|
||
if (rc .lt. 0) i = SioError (rc)
|
||
rc = SioRxFlush (Port)
|
||
|
||
io_init = 1
|
||
return
|
||
end
|
||
|
||
integer function io_done ()
|
||
integer*2 SioDone, rc
|
||
integer*2 Port
|
||
common /QioConst/ Port
|
||
|
||
rc = SioDone (Port)
|
||
|
||
io_done = 1
|
||
return
|
||
end
|
||
|
||
|
||
integer function io_read (iosb, in_buff, in_size, itime)
|
||
integer in_size, itime
|
||
integer*2 iosb(4)
|
||
integer*1 in_buff(*)
|
||
integer*2 SioGetc, j
|
||
integer*2 Port
|
||
common /QioConst/ Port
|
||
|
||
M_time = itime * 18
|
||
L_time = M_time/in_size
|
||
if (L_time .le. 0) L_time = 5
|
||
J_time = 0
|
||
|
||
do 100 i = 1, in_size
|
||
110 j = SioGetc (Port, L_time)
|
||
if (j .eq. -1) then
|
||
J_time = J_time + L_time
|
||
if (J_Time .gt. M_time) go to 500
|
||
go to 110
|
||
endif
|
||
in_buff(i) = iand (j, #ff)
|
||
100 continue
|
||
iosb(1) = 1
|
||
iosb(2) = in_size
|
||
io_read = 1
|
||
return
|
||
500 continue
|
||
iosb(1) = 0
|
||
iosb(2) = i - 1
|
||
io_read = #22c
|
||
return
|
||
end
|
||
|
||
|
||
integer function io_prompt (iosb, in_buff, in_size, itime,
|
||
$ out_buf, out_size)
|
||
integer in_size, itime, out_size
|
||
integer*2 iosb(4)
|
||
integer*1 in_buff(*), out_buf(*)
|
||
integer*2 SioGetc, SioPutc, SioRxFlush, j
|
||
integer*2 Port
|
||
common /QioConst/ Port
|
||
|
||
j = SioRxFlush (Port)
|
||
do 50 i = 1, out_size
|
||
jc = out_buf(i)
|
||
j = SioPutc (Port, char(jc))
|
||
50 continue
|
||
|
||
M_time = itime * 18
|
||
L_time = M_time/in_size
|
||
if (L_time .le. 0) L_time = 5
|
||
J_time = 0
|
||
|
||
do 100 i = 1, in_size
|
||
110 j = SioGetc (Port, L_time)
|
||
if (j .eq. -1) then
|
||
J_time = J_time + L_time
|
||
if (J_Time .gt. M_time) go to 500
|
||
go to 110
|
||
endif
|
||
in_buff(i) = iand (j, #ff)
|
||
100 continue
|
||
iosb(1) = 1
|
||
iosb(2) = in_size
|
||
io_read = 1
|
||
return
|
||
500 continue
|
||
iosb(1) = 0
|
||
iosb(2) = i - 1
|
||
io_prompt = #22c
|
||
return
|
||
end
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|