Initial revision
This commit is contained in:
cvs
204
difrac/qio.f
Normal file
204
difrac/qio.f
Normal file
@@ -0,0 +1,204 @@
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user