Category : Communication (modem) tools and utilities
Archive   : VTRANS.ZIP
Filename : F7VMS.FOR

 
Output of file : F7VMS.FOR contained in archive : VTRANS.ZIP
C **************************************************************************
C
C Copyright (C) 1984
C
C COEFFICIENT SYSTEMS CORPORATION
C 611 Broadway New York, NY 10012
C
C PROGRAM NAME: F7VMS.FOR
C
C VERSION : 1.57
C
C ABSTRACT : HOST SOFTWARE FOR COEFFICIENT SYSTEMS CORP.
C VTRANS (7-BIT) PROPRIETARY FILE TRANSFER
C SLIDING WINDOW PROTOCOL WITH ADJUSTABLE PACKET
C SIZE, SELECTABLE CRC-16 OR CHECKSUM ERROR
C DETECTION, AND AUTOMATIC RE-TRANSMISSION.
C
C HOST SYSTEM : VAX-11/7** UNDER VMS.
C
C LANGUAGE : FORTRAN/77 WITH VAX/VMS EXTENSIONS.
C
C FILE NEEDED : DATA DECLARATIONS IN DISTRIBUTION DISKETTE
C FILE "F7VMS.DEC," WHICH MUST EXIST ON THE
C SAME DIRECTORY AS THIS SOURCE FILE AT COMPILATION
C TIME AND MUST BEAR THAT NAME.
C
C PRIVILEGE : NONE.
C
C CAPABILITY : *THIS PROGRAM WILL TRANSFER FOR IMMEDIATE USE
C (1) ALL VAX TEXT FILES;
C (2) ALL PC FILES;
C (3) ALL VAX FORTRAN-TYPE DATA FILES;
C (4) ALL VAX BINARY FILES WITH FIXED-LENGTH
C 512-BYTE RECORDS -- SEQUENTIAL ORGANIZATION
C (SUCH AS VAX/VMS *.EXE IMAGES).
C
C *THIS PROGRAM WILL TRANSFER FOR USE ON THE VAX
C AFTER THE USER RUNS THE VMS "CONVERT" UTILITY
C (1) ALL VAX BINARY FILES WITH FIXED-LENGTH
C RECORDS OF ANY SIZE -- SEQUENTIAL
C ORGANIZATION;
C (2) ALL VAX BINARY FILES WITH FIXED-LENGTH
C RECORDS OF ANY SIZE -- INDEXED
C ORGANIZATION;
C (3) ALL VAX BINARY FILES WITH FIXED-LENGTH
C RECORDS OF ANY SIZE -- RELATIVE
C ORGANIZATION.
C
C *THIS PROGRAM WILL STORE ON THE VAX FOR LATER
C RETRIEVAL AND TRANSFER ALL FILES FROM FOREIGN
C OPERATING SYSTEMS.
C
C LIMITATIONS: *THIS PROGRAM CANNOT SUCCESFULLY TRANSFER
C (1) VAX VARIABLE LENGTH RECORD FORMAT FILES
C THAT ARE NON-TEXT AND NON-FORTRAN TYPE
C (SUCH AS VAX/VMS OBJECT MODULES);
C (2) VAX VFC RECORD FORMAT FILES THAT ARE
C NON-TEXT AND NON-FORTRAN TYPE.
C
C (THIS IS BECAUSE THIS PROGRAM IS DESIGNED FOR
C USE BY ANYONE AUTHORIZED TO LOG ONTO A VAX/VMS
C SYSTEM, EVEN IF THEY LACK ALL SPECIAL "PRIVILEGES"
C AVAILABLE TO SOME USERS OF THE COMPUTER. SUCH
C UNIVERSAL USEFULNESS PREVENTS ACCESS TO CERTAIN
C FILE "CONTROL" INFORMATION WHICH WOULD BE NEEDED
C TO TRANSFER SUCH FILES IN UNCORRUPTED FORM.)
C
C USER'S NOTE: SOME HEAVILY-USED VAX INSTALLATIONS ARE CONFIGURED
C WITH SMALL TERMINAL TYPE-AHEAD BUFFERS. IN SUCH
C CASES, USERS MAY FIND THAT SEVERAL RETRANSMISSIONS
C ARE BEING FORCED EACH TIME THE BUFFER IS OVERRUN,
C ESPECIALLY AT THE HIGHER PACKET-LENGTH SETTINGS.
C ENABLING "ALTTYPEAHD" FOR THE TERMINAL WILL CORRECT
C THIS. OTHERWISE, CHOOSING A SMALLER PACKET-SIZE
C ON THE VTERM SET-UP SCREEN WILL ALLEVIATE THE
C PROBLEM.
C
C CUSTOMIZING: NO SUPPORT CAN BE GIVEN FOR ANY CHANGES MADE IN
C THIS PROGRAM BY ANY USER.
C
C
C
C **************************************************************************
C
PROGRAM F7VMS
C
C
C Data declarations
C
INCLUDE 'F7VMS.DEC' ! Program-wide
EXTERNAL CCAST ! Address of ctrl-c ast
INTEGER*4 DEV_SAVE(3) ! Terminal set saver
INTEGER*4 DEV_ARRAY(3) ! Terminal set area
INTEGER*2 DEV_ARRAYW(6) ! Same area word access
C
EQUIVALENCE (DEV_ARRAY, DEV_ARRAYW)
C
LOGICAL F_EX ! Host file exists = .T.
DATA DEV_ARRAYW/6*0/ ! Zero out before load
C
C
C Initialization
C
CALL LIB$CRC_TABLE('120001'O, CRC_TABLE)
C Load table per CRC-16 polynomial
C
CRLF=CHAR(13)//CHAR(10)
C Will be doing own carriage return/line feed
C
OPEN (UNIT=10,FILE='SYS$OUTPUT',CARRIAGECONTROL='NONE',
X STATUS='UNKNOWN')
CALL SYS$ASSIGN('TT:',CHAN,,)
C Open terminal for FORTRAN I/O and VMS syscalls
C
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SENSEMODE),,,,
X %REF(DEV_ARRAY(2)),,,,,)
C Get terminal current settings
C
DO 5 I=1,3
DEV_SAVE(I)=DEV_ARRAY(I)
5 CONTINUE
C Store in save area
C
9 OPEN (UNIT=9,FILE='SYS$INPUT',CARRIAGECONTROL='NONE',
X STATUS='OLD')
IOLDCOM=0
C Initialize/reinitialize indicator for skipping q's.
C
WRITE (10,10)CRLF,CRLF
10 FORMAT(A2,A2,'**VTRANS 1.57 -- HOST ')
WRITE (10,11)
11 FORMAT('SOFTWARE FOR 7-BIT VTRANS: VAX/VMS ')
WRITE (10,12)CRLF
12 FORMAT('SYSTEMS (FORTRAN)**',A2)
WRITE (10,121)CRLF
121 FORMAT( A2,'VTERM''s File Transfer ',
X 'Setup options will be set automatically ')
WRITE (10,122)CRLF,CRLF
122 FORMAT('by this dialogue.',A2,'There is no need to ',
X 'use the file transfer setup screen.',A2)
13 WRITE (10,14)CRLF,CRLF,CRLF
14 FORMAT(A2,'WHICH WAY IS TRANSFER?',A2,A2)
WRITE (10,15)CRLF,CRLF
15 FORMAT(' 1 = PC TO HOST',A2,' 2 = HOST TO PC',A2)
WRITE (10,16)CRLF,CRLF,CRLF
16 FORMAT(' 3 = PROGRAM DIAGNOSTIC',A2,
X ' 4 = EXIT PROGRAM',A2,A2,'OPTION: ')
C Paint screen with menu
C
17 READ (9,18,END=9)I_INP_LEN,UT_BUF(1:80)
18 FORMAT(Q,A)
C Get choice into utility character area
C (simple i/o limited to 80-bytes...)
C
IF (UT_BUF(1:80) .EQ. '1') THEN
MODE_SW=1
ELSE IF (UT_BUF(1:80) .EQ. '2') THEN
MODE_SW=2
ELSE IF (UT_BUF(1:80) .EQ. '3') THEN
MODE_SW=3
ELSE IF (UT_BUF(1:80) .EQ. '4') THEN
MODE_SW=4
ELSE IF (UT_BUF(1:1) .EQ. '@') THEN
MODE_SW=5
ELSE IF (UT_BUF(1:1) .EQ. '~') THEN
MODE_SW=6
ELSE
MODE_SW=7
ENDIF
C Prepare for computed GOTO
C
IF (MODE_SW .EQ. 6) THEN
IOLDCOM=4
ENDIF
C We'll skip ctl-z and collision q's.
C
IF ((MODE_SW .EQ. 5) .OR. (MODE_SW .EQ. 6)) THEN
I_DOT = INDEX(UT_BUF(1:80),'.')
IF ( I_DOT .EQ. 0 ) THEN
UT_BUF(I_INP_LEN+1:I_INP_LEN+4)='.COM'
I_INP_LEN=I_INP_LEN+4
ENDIF
CLOSE(9)
OPEN (UNIT=9,FILE=UT_BUF(2:I_INP_LEN),
X CARRIAGECONTROL='LIST',STATUS='OLD')
ENDIF
C
C
C
IF (MODE_SW .EQ. 3) THEN
PRG_CSMW = 0
CALL DIAG
WRITE(10,19)CRLF,CRLF,PRG_CSMW,CRLF,CRLF
19 FORMAT(A2,A2,'*DIAGNOSTIC CODE = ',I,A2,A2)
ENDIF
C First, if diagnosing, initialize program checksum,
C calculate and display
C
GO TO (20,20,13,2200,17,17,13),MODE_SW
C Either go on or get choice again
C
20 WRITE (10,21)CRLF,CRLF
21 FORMAT(A2,A2,'WHAT IS THE NAME OF THE FILE ON THE HOST? ')
READ (9,22,END=9)IILEN,UT_BUF(1:80)
22 FORMAT(Q,A)
C Get host file name for transfer either way
C
IF (UT_BUF(IILEN:IILEN) .EQ. ';') THEN
IILEN=IILEN-1
ENDIF
C Optional semicolon is not part of filename.
C
IF (MODE_SW .EQ. 2) THEN
C If host => pc
C
INQUIRE(FILE=UT_BUF(1:80),EXIST=F_EX,
X CARRIAGECONTROL=F_CC)
C Exists? "List" or "Fortran" or "None"?
C
IF (F_EX) THEN
OPEN(UNIT=11,FILE=UT_BUF(1:80),
X CARRIAGECONTROL=F_CC,STATUS='OLD')
C Exists! Open it for transfer!
C
ELSE
WRITE(10,23)CRLF,CRLF
23 FORMAT(A2,A2,'*FILE NOT FOUND.')
GOTO 20
C Error... Advise and try again
C
ENDIF
ELSE
C If pc => host, instead
C
IF (UT_BUF(IILEN+1:IILEN+1) .EQ. ';') THEN
UT_BUF(78:79)='Y;'
GOTO 271
ENDIF
24 WRITE (10,25)CRLF,CRLF
25 FORMAT(A2,A2,'WILL HOST FILE BE TERMINAL FORMAT ')
WRITE (10,26)
26 FORMAT('TEXT? ')
READ (9,27,END=9)UT_BUF(78:80)
27 FORMAT(A)
C Find out if file coming with CR/LF's we have to
C strip for correct storage on the VAX
C
271 IF (UT_BUF(78:78) .EQ. 'Y' .OR. UT_BUF(78:78) .EQ. ' '
X .OR. UT_BUF(78:78) .EQ. 'y')
X THEN
F_CC='LIST'
OPEN(UNIT=11,FILE=UT_BUF(1:77),
X CARRIAGECONTROL=F_CC,
X RECL=1024,STATUS='NEW',ERR=28)
C They're coming...
C
ELSE IF (UT_BUF(78:78) .EQ. 'N' .OR.
X UT_BUF(78:78) .EQ. 'n')
X THEN
F_CC='NONE'
OPEN(UNIT=11,FILE=UT_BUF(1:77),
X CARRIAGECONTROL=F_CC,
X RECORDTYPE='FIXED',
X RECL=512,STATUS='NEW',ERR=28)
C They're not.
C
ELSE
GOTO 24
ENDIF
ENDIF
GOTO 30
C Skip over ERR handler.
C
28 WRITE(10,29)CRLF,CRLF
29 FORMAT(A2,A2,'*UNABLE TO OPEN FILE.')
GOTO 20
C Error... Advise and try again
C
30 IF (UT_BUF(IILEN+1:IILEN+1) .EQ. ';') THEN
IPCNML=0
GOTO 321
ENDIF
C
C
WRITE (10,31)CRLF,CRLF,UT_BUF(1:IILEN)
31 FORMAT(A2,A2,'WHAT IS THE NAME OF THE FILE ON THE PC <',A,'>? ')
READ (9,32,END=9)IPCNML,KB_BUFFER(1:80)
32 FORMAT(Q,A)
321 IF (IPCNML .LT. 1) THEN
IPCNML=IILEN
KB_BUFFER(1:80)=UT_BUF(1:80)
ENDIF
C Find out file desired to be set on VTERM
C
IF (KB_BUFFER(IPCNML:IPCNML) .EQ. ';') THEN
IPCNML=IPCNML-1
UT_BUF(IILEN+1:IILEN+1)=';'
ENDIF
C Optional semicolon is not part of filename.
C
DO 322 I=1,IPCNML
II=ICHAR(KB_BUFFER(I:I))
IF (II .GE. 97 .AND. II .LE. 122) THEN
KB_BUFFER(I:I)=CHAR(II-32)
ENDIF
322 CONTINUE
C Convert to upper case
C
DEV_ARRAY(3) = DEV_ARRAY(3) .OR. TT$M_SCOPE
DEV_ARRAY(3) = DEV_ARRAY(3) .OR. TT$M_LOWER
DEV_ARRAY(3) = DEV_ARRAY(3) .OR. TT$M_ESCAPE
DEV_ARRAY(3) = DEV_ARRAY(3) .OR. TT$M_NOECHO
DEV_ARRAYW(4) = 511 ! (Width)
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE),,,,
X %REF(DEV_ARRAY(2)),,,,,)
C Superimpose needed terminal settings
C
UT_BUF(81:160) = CHAR(155)//'[>0f'//KB_BUFFER(1:IPCNML)
X //CHAR(13)
C
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK),,,,
X %REF(UT_BUF(81:81)),%VAL(6+IPCNML),,,,)
C Send set-pcfile escape sequence to VTERM
C
UT_BUF(81:85) = CHAR(155)//'[>1f'
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK),,,,
X %REF(UT_BUF(81:81)),%VAL(5),,,,)
C Send ask-pcfile escape sequence to VTERM
C
IN_PTR = 80
33 CALL GETBYTES(IN_PTR,1,100)
C Get pcfile one byte at a time
C
IF (WAIT_ERR .GT. 0) THEN
GO TO 2100
ELSE IF (KB_BUFFER(IN_PTR+1:IN_PTR+1) .NE. CHAR(13)
X .AND. KB_BUFFER(IN_PTR+1:IN_PTR+1) .NE.
X CHAR(10)) THEN
IN_PTR = IN_PTR + 1
GO TO 33
ENDIF
C Timed out, abort, else look for CR or LF
C
IF (KB_BUFFER(1:IPCNML) .NE. KB_BUFFER(81:IN_PTR))
X THEN
WRITE(10,34)CRLF,CRLF,CRLF
34 FORMAT(A2,A2,'*PC FILE NOT SET.',A2)
GO TO 2100
ENDIF
C We failed to set pc file name
C
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE),,,,
X %REF(DEV_SAVE(2)),,,,,)
C Restored saved terminal settings
C
IF (UT_BUF(IILEN+1:IILEN+1) .EQ. ';') THEN
UT_BUF(1:12)=CHAR(27)//'[>3;256;0;2'
IF (F_CC .EQ. 'LIST') THEN
UT_BUF(13:16)=';1;2'
ELSE
UT_BUF(13:16)=';0;2'
ENDIF
IF (MODE_SW .EQ. 1) THEN
UT_BUF(17:17)='s'
ELSE
UT_BUF(17:17)='r'
ENDIF
IOLDCOM=0 ! ;'s are new-fangled.
PACKET_LEN = 256
CRC_FLAG=1
GOTO 361
ENDIF
C All this if they semi-coloned.
C
CALL BUILD_ESC(IOLDCOM)
C Also load parameters
C
IF (UT_BUF(18:18) .EQ. ';') THEN
UT_BUF(18:18)=' '
GOTO 361
ENDIF
C Flag that ; was used in bldesc.
C
WRITE (10,35)CRLF,CRLF
35 FORMAT(A2,A2,'PRESS TO BEGIN TRANSFER.')
C Get ok to start
C
READ (9,36)KB_BUFFER(1:80)
36 FORMAT(A)
C Anything is go-ahead
C
361 WRITE (10,37)CRLF,CRLF,CRLF
37 FORMAT(A2,A2,'TRANSFER IN PROGRESS...',A2)
C Operator feedback
C
DEV_ARRAY(3) = DEV_ARRAY(3) .OR. TT$M_SCOPE
DEV_ARRAY(3) = DEV_ARRAY(3) .OR. TT$M_LOWER
DEV_ARRAY(3) = DEV_ARRAY(3) .OR. TT$M_ESCAPE
DEV_ARRAY(3) = DEV_ARRAY(3) .OR. TT$M_NOECHO
DEV_ARRAYW(4) = 511 ! (Width)
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE),,,,
X %REF(DEV_ARRAY(2)),,,,,)
C Superimpose needed terminal settings
C
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK),,,,
X %REF(UT_BUF),%VAL(17-IOLDCOM),,,,)
C Send startup escape sequence to VTERM
C
IN_PTR = 80
38 CALL GETBYTES(IN_PTR,1,100)
C Get VTERM go-ahead one byte at a time
C
IF (KB_BUFFER(81:81) .NE. 'Y' .OR. WAIT_ERR .GT. 0) THEN
WRITE(10,39)CRLF,CRLF,CRLF
39 FORMAT(A2,A2,'*HOST ABORTING.',A2)
GO TO 2100
ENDIF
C Timed out or not 'Y', abort
C
DEV_ARRAY(3) = DEV_ARRAY(3) .AND. 'FFFFFFF7'X
C Not TT$M_ESCAPE
DEV_ARRAY(3) = DEV_ARRAY(3) .OR. TT$M_SCOPE
DEV_ARRAY(3) = DEV_ARRAY(3) .OR. TT$M_LOWER
DEV_ARRAY(3) = DEV_ARRAY(3) .OR. TT$M_NOECHO
DEV_ARRAYW(4) = 511 ! (Width)
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE),,,,
X %REF(DEV_ARRAY(2)),,,,,)
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE .OR.
X IO$M_CTRLCAST .OR. IO$M_CTRLYAST),,,,CCAST,,,,,)
C Superimpose needed terminal settings
C
IF (MODE_SW .EQ. 1) THEN
CALL VTSEND
ELSE
CALL VTRECEIVE
ENDIF
C Mode_sw can only be 1 or 2 here -- do
C main processing
C
2000 IF (WAIT_ERR .EQ. 0) THEN
WRITE(10,2001)CRLF,CRLF
2001 FORMAT(A2,A2,'TRANSFER COMPLETE.')
ENDIF
C Give good news if error condition not
C returned from processing
C
2100 CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE),,,,
X %REF(DEV_SAVE(2)),,,,,)
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE .OR.
X IO$M_CTRLCAST .OR. IO$M_CTRLYAST),,,,,,,,,)
C Restored saved terminal settings
C
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
C Purge terminal typeahead buffer of CR/LF's
C
WRITE(10,2101)CRLF,CRLF,TOT_BYTES,CRLF,CRLF
2101 FORMAT(A2,A2,'TOTAL BYTES TRANSFERRED = ',I,A2,A2)
IF (TRUNC_FLAG .GT. 0) THEN
WRITE(10,2102)CRLF,CRLF,CRLF,CRLF
2102 FORMAT(A2,'*SOME RECORDS TRUNCATED TO ',
X '1022 DATA BYTES (PLUS CR/LF)',A2,
X ' BECAUSE THEY WERE TOO LONG.',A2,A2)
ENDIF
TRUNC_FLAG = 0
TOT_BYTES = 0
PACKET_LEN = 0
CRC_FLAG = 0
CSM_FLAG = 0
MODE_SW = 0
CLOSE(11)
GO TO 13
C Back for more files
C
2200 CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE),,,,
X %REF(DEV_SAVE(2)),,,,,)
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE .OR.
X IO$M_CTRLCAST .OR. IO$M_CTRLYAST),,,,,,,,,)
C Restored saved terminal settings
C
CALL SYS$DASSGN('TT:',CHAN,,)
CLOSE(9)
CLOSE(10)
CLOSE(11)
C Orderly exit on processing or abort
C Last loose ends and get out
C
END
C
C **************************************************************************
C
C VTSEND -- PC => Host Main Processing Module
C
C **************************************************************************
C
SUBROUTINE VTSEND
C
C
C Data declarations
C
INCLUDE 'F7VMS.DEC' ! Program-wide
CHARACTER*2 TEST_BYTES ! String: crc conversion
CHARACTER*2 HEX_BYTES ! String: hex input
CHARACTER*1 TMP_BYTE_S ! String: hex conversion
BYTE TMP_BYTE ! Byte: hex conversion
EQUIVALENCE (TMP_BYTE_S,TMP_BYTE)
C
C Initialization
C
I_LST_SEQ = 9 ! Last packet no.
I_HST_PTR = 0 ! Start clean
I_EOF = 0 ! Start new
IN_END_PACK = 0 ! No EOF from VTERM
KB_BUFFER(1:2) = 'S9'
C In case we never get going, prepare for aborting
C
C Main loop begins here
C

10 IF (WAIT_ERR .GT. 0) THEN
C Look at watch
C
KB_BUFFER(3:5) = 'D'//CRLF
WRITE (10,11)KB_BUFFER(1:5)
11 FORMAT(A5)
WRITE(10,12)CRLF,CRLF
12 FORMAT(A2,A2,'*HOST ABORTING...')
WAIT_ERR = 1
GO TO 2000
ENDIF
C Time check above more than 20 secs elapsed since
C last data, or input routine timed out w/
C no data -- send abort packet to VTERM and pass
C error return to mainline, then exit
C
20 CALL GETBYTES(0,1,20)
IF (WAIT_ERR .NE. 0) THEN
GO TO 10
ELSE IF (KB_BUFFER(1:1) .NE. 'S') THEN
GO TO 20
ENDIF
C Call input routine for one byte -- if
C time-out goto time trapping, else we loop
C looking for SOH (ascii 1)
C
CALL GETBYTES(1,1,20)
IF (WAIT_ERR .NE. 0) THEN
GO TO 10
ENDIF
C One more byte, standard time trapping
C
I_TEST=ICHAR(KB_BUFFER(2:2))
IF ((I_TEST .LT. 49) .OR. (I_TEST .GT. 57)) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='C'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
GO TO 10
ENDIF
STS=OTS$CVT_TI_L(%DESCR(KB_BUFFER(2:2)),%REF(IN_SEQ_NO))
C Byte two is incoming sequence no. -- so
C send NAK packet with last good sequence no.
C if conversion not correct and start over
C
CALL GETBYTES(2,1,20)
IF (WAIT_ERR .NE. 0) THEN
GO TO 10
ELSE IF (KB_BUFFER(3:3) .EQ. 'D') THEN
WRITE(10,25)CRLF,CRLF
25 FORMAT(A2,A2,'*PC ABORTING...')
WAIT_ERR=1
GO TO 2000
ENDIF
C Get third byte with standard time trapping --
C if abort signal from VTERM jump
C without trying more input
C
CALL GETBYTES(3,2,20)
IF (WAIT_ERR .NE. 0) THEN
GO TO 10
ENDIF
C Otherwise, get two bytes w/ time-out
C
IF (KB_BUFFER(3:3) .EQ. 'F') THEN
IN_END_PACK = 1
IN_PACK_LEN = 0
IF (CRC_FLAG .GT. 0) THEN
CALL GETBYTES(5,2,20)
IF (WAIT_ERR .NE. 0) THEN
GO TO 10
ENDIF
ENDIF
GO TO 30
ENDIF
C If packet-type is "orderly end", set EOF flag,
C zero packet length variable, and get two
C bytes (second CRC byte) if we're doing CRC
C checking -- trapping for time, of course
C
CALL GETBYTES(5,1,20)
IF (WAIT_ERR .NE. 0) THEN
GO TO 10
ENDIF
C Otherwise, get byte w/ time-out
C
DO 27 III=4,6
I_TEST=ICHAR(KB_BUFFER(III:III))
IF ((I_TEST .LT. 48) .OR. (I_TEST .GT. 57)) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='C'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
GO TO 10
ENDIF
27 CONTINUE
STS=OTS$CVT_TI_L(%DESCR(KB_BUFFER(4:6)),%REF(IN_PACK_LEN))
IN_PACK_LEN=IN_PACK_LEN+1
C Bytes four to six are incoming packet length-- so
C send NAK packet with last good sequence no.
C if conversion not correct and start over, else
C correct for zero-relativity
C
CALL GETBYTES(6,IN_PACK_LEN + 4 - (2*CSM_FLAG),20)
IF (WAIT_ERR .NE. 0) THEN
GO TO 10
ENDIF
C Otherwise, find out how many data bytes in this
C packet, and get that many plus two extra for
C checksum or four extra for CRC (w/time trapping)
C
30 IF ((I_LST_SEQ .EQ. 9 .AND. IN_SEQ_NO .EQ. 1)
X .OR. (I_LST_SEQ .EQ. IN_SEQ_NO)) THEN
GO TO 40
ENDIF
C Protocol calls for stepping from sequence no.
C 9 to no. 1 -- also, if it's a repeat of last
C packet, we're just going to ACK it and go on
C
IF (IN_SEQ_NO .NE. I_LST_SEQ + 1) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='C'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
GO TO 10
ENDIF
C However, if not special case of 9/1 and not
C repeat of last good packet, NAK it w/last good
C sequence no. if packet not in proper sequence
C
40 J=IN_PACK_LEN + 6 - (3*IN_END_PACK)
C Pre-calculation for program optimization
C covering EOF packet case as well
C
IF (CSM_FLAG .GT. 0) THEN
GO TO 50
ENDIF
C Skip next if we're checksumming
C
CRC_RESULT = LIB$CRC(CRC_TABLE(1), 0, KB_BUFFER(2:J))
C Calculate CRC for packet bytes 2 to end of data
C
JJJ=0
IVAL=1
DO 42 I=J+1,J+4,2
HEX_BYTES=KB_BUFFER(I:I+1)
DO 41 III=1,2
I_TEST=ICHAR(HEX_BYTES(III:III))
IF ((I_TEST .LT. 48) .OR. ((I_TEST .GT. 57) .AND. (I_TEST
X .LT. 65)) .OR. (I_TEST .GT. 70)) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='C'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
GO TO 10
ENDIF
41 CONTINUE
C NAK it w/last good sequence no. if packet not
C in proper hex format
C
STS=OTS$CVT_TZ_L(%DESCR(HEX_BYTES),%REF(
X TMP_BYTE),%VAL(IVAL),)
JJJ=JJJ+1
TEST_BYTES(JJJ:JJJ)=TMP_BYTE_S
42 CONTINUE
C Convert hex to ascii routine
C
IF (TEST_BYTES .NE. CRC_BYTES(1:2)) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='C'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
GO TO 10
ENDIF
C If CRC doesn't check out, NAK w/ last no. and
C back to top of loop
C
50 IF (CRC_FLAG .GT. 0) THEN
GO TO 60
ENDIF
C Skip next if we're CRCing
C
CALL CSUM(KB_BUFFER(2:J), J-1)
IVAL=1
HEX_BYTES=KB_BUFFER(J+1:J+2)
DO 52 III=1,2
I_TEST=ICHAR(HEX_BYTES(III:III))
IF ((I_TEST .LT. 48) .OR. ((I_TEST .GT. 57) .AND. (I_TEST
X .LT. 65)) .OR. (I_TEST .GT. 70)) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='C'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
GO TO 10
ENDIF
52 CONTINUE
C NAK it w/last good sequence no. if packet not
C in proper hex format
C
STS=OTS$CVT_TZ_L(%DESCR(HEX_BYTES),%REF(
X TMP_BYTE),%VAL(IVAL),)
C
IF (TMP_BYTE_S .NE. CSUM_RESULT(1:1)) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='C'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
GO TO 10
ENDIF
C NAK w/last no. if checksum doesn't check out
C and back to top of loop
C
60 IF (I_LST_SEQ .EQ. IN_SEQ_NO) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='B'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
GO TO 10
ENDIF
C Here's where we ACK the repeat packet, repeat loop
C
J=6
IVAL=1
DO 65 I=7,IN_PACK_LEN+5,2
J=J+1
HEX_BYTES=KB_BUFFER(I:I+1)
DO 62 III=1,2
I_TEST=ICHAR(HEX_BYTES(III:III))
IF ((I_TEST .LT. 48) .OR. ((I_TEST .GT. 57) .AND. (I_TEST
X .LT. 65)) .OR. (I_TEST .GT. 70)) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='C'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
GO TO 10
ENDIF
62 CONTINUE
C NAK it w/last good sequence no. if packet not
C in proper hex format
C
STS=OTS$CVT_TZ_L(%DESCR(HEX_BYTES),%REF(
X TMP_BYTE),%VAL(IVAL),)
KB_BUFFER(J:J)=TMP_BYTE_S
65 CONTINUE
C Convert hex to ascii routine
C
IN_PACK_LEN = IN_PACK_LEN/2
C Adjust for nibble doubling
C
IF (KB_BUFFER(3:3) .EQ. 'F') THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(IN_SEQ_NO),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='B'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
I_EOF = 1
CALL WRITEHOST(I_HST_PTR,I_EOF)
GO TO 2000
C Case 1: EOF packet received which checked out --
C notify routine that writes host file to write
C whatever data is in its buffer without any
C blocking it might normally do, send ACK, exit
C
ELSE IF (KB_BUFFER(3:3) .EQ. 'A') THEN
IF (TRUNC_FLAG .EQ. 2) THEN
I_IND=INDEX(KB_BUFFER(7:IN_PACK_LEN+6),CRLF)
IF (I_IND .GT. 0) THEN
HST_BUFFER=KB_BUFFER(I_IND+7:
X IN_PACK_LEN+6)
I_HST_PTR=IN_PACK_LEN-I_IND-1
TRUNC_FLAG = 1
ENDIF
ELSE IF (I_HST_PTR .EQ. 0 ) THEN
HST_BUFFER=KB_BUFFER(7:IN_PACK_LEN+6)
I_HST_PTR = I_HST_PTR + IN_PACK_LEN
ELSE IF (I_HST_PTR+IN_PACK_LEN .LE. 1024) THEN
HST_BUFFER=HST_BUFFER(1:I_HST_PTR)//
X KB_BUFFER(7:IN_PACK_LEN+6)
I_HST_PTR = I_HST_PTR + IN_PACK_LEN
ELSE
HST_BUFFER=HST_BUFFER(1:I_HST_PTR)
IF (I_HST_PTR .LT. 1024) THEN
HST_BUFFER(I_HST_PTR+1:1024)=
X KB_BUFFER(7:1028-I_HST_PTR)
ENDIF
HST_BUFFER(1023:1024)=CRLF
TRUNC_FLAG=2
I_HST_PTR = 1024
ENDIF
C Handle case of too-long or maximum terminal format
C lines
C
I_EOF = 0
CALL WRITEHOST(I_HST_PTR,I_EOF)
IF (TRUNC_FLAG .EQ. 2) THEN
I_IND=INDEX(KB_BUFFER(6:IN_PACK_LEN+5),CRLF)
IF (I_IND .GT. 0) THEN
HST_BUFFER=KB_BUFFER(I_IND+7:
X IN_PACK_LEN+5)
I_HST_PTR=IN_PACK_LEN-I_IND-1
TRUNC_FLAG = 1
ENDIF
ENDIF
C Correct pointers if CRLF in disregarded data
C when terminal format line too long.
C
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(IN_SEQ_NO),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='B'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
I_LST_SEQ = IN_SEQ_NO
GO TO 10
C Case #2: Data-packet type which checked out --
C start filling buffer if it's empty or add to
C buffer; advance pointer to new end-of-buffer;
C send ACK w/ new sequence no.; do whatever writing
C of host file is triggered by new data bytes;
C reinitialize time-out baseline and go to top
C
ELSE
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='C'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
GO TO 10
ENDIF
C Case #3: Garbage collector NAK's w/last good no.
C (probably received unrecognized packet-type)
C
2000 RETURN
END
C Module exit
C
C **************************************************************************
C
C VTRECEIVE -- Host => PC Main Processing Module
C
C **************************************************************************
C
SUBROUTINE VTRECEIVE
C
C
C Data declarations
C
INCLUDE 'F7VMS.DEC' ! Program-wide
CHARACTER*2 HEX_BYTES ! String: hex output
CHARACTER*1 TMP_BYTE_S ! String: hex conversion
BYTE TMP_BYTE ! Byte: hex conversion
EQUIVALENCE (TMP_BYTE_S,TMP_BYTE)
C
C
C Initialization
C
IVAL=1 ! For conversion to hex
IMIN=2 ! For conversion to hex
I_LST_SEQ = 1 ! Last ACKed packet #
I_HST_PTR = 0 ! Host buffer pointer
I_SEND_CT = 0 ! No send tries yet
I_OUT_SEQ = 1 ! Outgoing packet #
J=(PACKET_LEN/2) + 6 ! Pre-calc for optimization
C (last data byte postion)
JJ=PACKET_LEN+12-(2*CSM_FLAG) ! Pre-calc for optimization
C (last packet byte pos.)
C
C
C Main loop begins here
C
10 IF (I_HST_PTR .LT. PACKET_LEN/2) THEN
READ(11, 11, END=100)I_REC_LEN,
X HST_BUFFER(I_HST_PTR+1:1024)
11 FORMAT(Q,A)
IF (F_CC .EQ. 'NONE') THEN
I_HST_PTR=I_HST_PTR+I_REC_LEN
ELSE IF (I_HST_PTR+I_REC_LEN .GT. 1022) THEN
TRUNC_FLAG=1
HST_BUFFER(1023:1024)=CRLF
I_HST_PTR=1024
ELSE
HST_BUFFER(I_HST_PTR+I_REC_LEN+1:
X I_HST_PTR+I_REC_LEN+2)=CRLF
I_HST_PTR=I_HST_PTR+I_REC_LEN+2
ENDIF
GO TO 10
ENDIF
C Loop and read host file until host buffer contains
C at least as many data bytes as packet length/2;
C each read advances host buffer pointer by retrieved
C record length; if carriage control is "LIST" or
C "FORTRAN" we embed CR/LF's and adjust pointer;
C when we encounter EOF we jump out to 100
C
UT_BUF(1:1)='S'
STS=OTS$CVT_L_TI(%REF(I_OUT_SEQ),%DESCR(UT_BUF(2:2)))
UT_BUF(3:3)='A'
I_OUT_LEN=PACKET_LEN-1
STS=OTS$CVT_L_TI(%REF(I_OUT_LEN),%DESCR(UT_BUF(4:6)))
IF (I_OUT_LEN .LT. 100) THEN
UT_BUF(4:4)='0'
ENDIF
JJJ=7
DO 15 I=1,PACKET_LEN/2
TMP_BYTE_S=HST_BUFFER(I:I)
CALL OTS$CVT_L_TZ(%REF(TMP_BYTE),%DESCR(HEX_BYTES),%VAL(IMIN),
X %VAL(IVAL))
UT_BUF(JJJ:JJJ+1)=HEX_BYTES
JJJ=JJJ+2
15 CONTINUE
C Prepare outgoing packet to last data byte
C
IF (CRC_FLAG .GT. 0) THEN
CRC_RESULT = LIB$CRC(CRC_TABLE(1), 0,
X UT_BUF(2:PACKET_LEN+6))
TMP_BYTE_S=CRC_BYTES(1:1)
CALL OTS$CVT_L_TZ(%REF(TMP_BYTE),
X %DESCR(HEX_BYTES),%VAL(IMIN),%VAL(IVAL))
UT_BUF(JJ-5:JJ-4)=HEX_BYTES
TMP_BYTE_S=CRC_BYTES(2:2)
CALL OTS$CVT_L_TZ(%REF(TMP_BYTE),
X %DESCR(HEX_BYTES),%VAL(IMIN),%VAL(IVAL))
UT_BUF(JJ-3:JJ-2)=HEX_BYTES
UT_BUF(JJ-1:JJ)=CRLF
ELSE
CALL CSUM(UT_BUF(2:PACKET_LEN+6), PACKET_LEN+5)
TMP_BYTE_S=CSUM_RESULT(1:1)
CALL OTS$CVT_L_TZ(%REF(TMP_BYTE),
X %DESCR(HEX_BYTES),%VAL(IMIN),%VAL(IVAL))
UT_BUF(JJ-3:JJ-2)=HEX_BYTES
UT_BUF(JJ-1:JJ)=CRLF
ENDIF
C Append checksum or CRC (bytes 2 thru end-of-data)
C
HST_BUFFER=HST_BUFFER((PACKET_LEN/2)+1:1024)
I_HST_PTR=I_HST_PTR - (PACKET_LEN/2)
C Left justify remains of host buffer and
C calculate new pointer
C
20 IF (I_SEND_CT .GE. 10) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='D'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
WRITE(10,25)CRLF,CRLF
25 FORMAT(A2,A2,'*HOST ABORTING...')
WAIT_ERR = 1
GO TO 2000
ENDIF
C Each time we check if we've sent the same packet
C ten times; if so, send "abort" & to mainline
C with error indicator
C
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK),,,,
X %REF(UT_BUF),
X %VAL(JJ),,,,)
C Send packet
C
I_SEND_CT = I_SEND_CT + 1
C Up send counter
C
I_RESP_ERR = 0
WAIT_ERR = 0
C Establish time-out basis, no error yet
C
CALL PARSE_RESP(I_OUT_SEQ, I_RESP_ERR)
C Get VTERM's response and interpret it
C
IF (I_RESP_ERR .EQ. 1) THEN
GO TO 20
C If it's not the ACK we want and not an abort
C try again
C
ELSE IF (I_RESP_ERR .EQ. 2) THEN
WRITE(10,1500)CRLF,CRLF
WAIT_ERR = 1
GO TO 2000
C Obey the abort, pass flag
C
ELSE
TOT_BYTES=TOT_BYTES + PACKET_LEN/2
I_SEND_CT = 0
I_LST_SEQ = I_OUT_SEQ
ENDIF
C All ok, so up byte counter and reinitialize
C
IF (I_LST_SEQ .EQ. 9) THEN
I_OUT_SEQ = 1
ELSE
I_OUT_SEQ = I_LST_SEQ + 1
ENDIF
GO TO 10
C Up outgoing sequence #, note 9 => 1
C
100 IF (I_HST_PTR .EQ. 0) THEN
GO TO 200
ENDIF
C Host file EOF reached, skip all this if no
C data bytes left unsent
C
J=I_HST_PTR + 6
JJ=(2*I_HST_PTR) + 12 - (2*CSM_FLAG)
C Pre-calculations in terms of no. of remaining
C data bytes
C
UT_BUF(1:1)='S'
STS=OTS$CVT_L_TI(%REF(I_OUT_SEQ),%DESCR(UT_BUF(2:2)))
UT_BUF(3:3)='A'
I_OUT_LEN=(2*I_HST_PTR)-1
STS=OTS$CVT_L_TI(%REF(I_OUT_LEN),%DESCR(UT_BUF(4:6)))
IF (I_OUT_LEN .LT. 100) THEN
UT_BUF(4:4)='0'
ENDIF
IF (I_OUT_LEN .LT. 10) THEN
UT_BUF(5:5)='0'
ENDIF
JJJ=7
DO 115 I=1,I_HST_PTR
TMP_BYTE_S=HST_BUFFER(I:I)
CALL OTS$CVT_L_TZ(%REF(TMP_BYTE),%DESCR(HEX_BYTES),%VAL(IMIN),
X %VAL(IVAL))
UT_BUF(JJJ:JJJ+1)=HEX_BYTES
JJJ=JJJ+2
115 CONTINUE
C Prepare outgoing packet to last data byte
C
IF (CRC_FLAG .GT. 0) THEN
CRC_RESULT = LIB$CRC(CRC_TABLE(1), 0,
X UT_BUF(2:(2*I_HST_PTR)+6))
TMP_BYTE_S=CRC_BYTES(1:1)
CALL OTS$CVT_L_TZ(%REF(TMP_BYTE),
X %DESCR(HEX_BYTES),%VAL(IMIN),%VAL(IVAL))
UT_BUF(JJ-5:JJ-4)=HEX_BYTES
TMP_BYTE_S=CRC_BYTES(2:2)
CALL OTS$CVT_L_TZ(%REF(TMP_BYTE),
X %DESCR(HEX_BYTES),%VAL(IMIN),%VAL(IVAL))
UT_BUF(JJ-3:JJ-2)=HEX_BYTES
UT_BUF(JJ-1:JJ)=CRLF
ELSE
CALL CSUM(UT_BUF(2:(2*I_HST_PTR)+6),(2*I_HST_PTR)+5)
TMP_BYTE_S=CSUM_RESULT(1:1)
CALL OTS$CVT_L_TZ(%REF(TMP_BYTE),
X %DESCR(HEX_BYTES),%VAL(IMIN),%VAL(IVAL))
UT_BUF(JJ-3:JJ-2)=HEX_BYTES

UT_BUF(JJ-1:JJ)=CRLF
ENDIF
C Append checksum or CRC bytes
C
120 IF (I_SEND_CT .GE. 10) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='D'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
WRITE(10,25)CRLF,CRLF
125 FORMAT(A2,A2,'*HOST ABORTING...')
WAIT_ERR = 1
GO TO 2000
ENDIF
C Each time we check if we've sent the same packet
C ten times; if so, send "abort" & to mainline
C with error indicator
C
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK),,,,
X %REF(UT_BUF),
X %VAL(JJ),,,,)
C Send packet
C
I_SEND_CT = I_SEND_CT + 1
C Up send counter
C
I_RESP_ERR = 0
WAIT_ERR = 0
C Initialize time-out basis, no error
C
CALL PARSE_RESP(I_OUT_SEQ, I_RESP_ERR)
C What does VTERM have to say?
C
IF (I_RESP_ERR .EQ. 1) THEN
GO TO 120
C "No good", "got previous", or nothing
C
ELSE IF (I_RESP_ERR .EQ. 2) THEN
WRITE(10,1500)CRLF,CRLF
WAIT_ERR = 1
GO TO 2000
C "Abort", pass flag
C
ELSE
TOT_BYTES=TOT_BYTES + I_HST_PTR
I_LST_SEQ = I_OUT_SEQ
I_SEND_CT = 0
C "Fine, thanks"
ENDIF
IF (I_LST_SEQ .EQ. 9) THEN
I_OUT_SEQ = 1
ELSE
I_OUT_SEQ = I_LST_SEQ + 1
ENDIF
C Get ready to send EOT packet
C
200 J=3
JJ=J + 6 - (2*CSM_FLAG)
C Pre-calcs: error-detection will be based on
C byte 2 thru byte 3
C
UT_BUF(1:1)='S'
STS=OTS$CVT_L_TI(%REF(I_OUT_SEQ),%DESCR(UT_BUF(2:2)))
UT_BUF(3:3)='F'
IF (CRC_FLAG .GT. 0) THEN
CRC_RESULT = LIB$CRC(CRC_TABLE(1), 0,
X UT_BUF(2:J))
TMP_BYTE_S=CRC_BYTES(1:1)
CALL OTS$CVT_L_TZ(%REF(TMP_BYTE),
X %DESCR(HEX_BYTES),%VAL(IMIN),%VAL(IVAL))
UT_BUF(JJ-5:JJ-4)=HEX_BYTES
TMP_BYTE_S=CRC_BYTES(2:2)
CALL OTS$CVT_L_TZ(%REF(TMP_BYTE),
X %DESCR(HEX_BYTES),%VAL(IMIN),%VAL(IVAL))
UT_BUF(JJ-3:JJ-2)=HEX_BYTES
UT_BUF(JJ-1:JJ)=CRLF
ELSE
CALL CSUM(UT_BUF(2:J), J-1)
TMP_BYTE_S=CSUM_RESULT(1:1)
CALL OTS$CVT_L_TZ(%REF(TMP_BYTE),
X %DESCR(HEX_BYTES),%VAL(IMIN),%VAL(IVAL))
UT_BUF(JJ-3:JJ-2)=HEX_BYTES
UT_BUF(JJ-1:JJ)=CRLF
ENDIF
C Finish it
C
220 IF (I_SEND_CT .GE. 10) THEN
KB_BUFFER(1:1) = 'S'
STS=OTS$CVT_L_TI(%REF(I_LST_SEQ),%DESCR(KB_BUFFER
X (2:2)))
KB_BUFFER(3:5)='D'//CRLF
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK
X .OR. IO$M_CANCTRLO),,,,%REF(KB_BUFFER),%VAL(5),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
WRITE(10,25)CRLF,CRLF
225 FORMAT(A2,A2,'*HOST ABORTING...')
WAIT_ERR = 1
GO TO 2000
ENDIF
C Each time we check if we've sent the same packet
C ten times; if so, send "abort" & to mainline
C with error indicator
C
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK),,,,
X %REF(UT_BUF),
X %VAL(JJ),,,,)
C Send it
C
I_SEND_CT = I_SEND_CT + 1
C Keep track how many times
C
I_RESP_ERR = 0
WAIT_ERR = 0
C What time is it? No problem yet...
C
CALL PARSE_RESP(I_OUT_SEQ, I_RESP_ERR)
C Listen to VTERM
C
IF (I_RESP_ERR .EQ. 1) THEN
GO TO 220
ELSE IF (I_RESP_ERR .EQ. 2) THEN
WRITE(10,1500)CRLF,CRLF
1500 FORMAT(A2,A2,'*PC ABORTING...')
WAIT_ERR = 1
GO TO 2000
C Trap unsuccessful transmission/abort, pass flag
C
ENDIF
C
C We did it! Back to mainline.
C
2000 RETURN
END
C
C **************************************************************************
C
C PARSE_RESP -- Host => PC: Get and analyze VTERM response
C
C **************************************************************************
C
SUBROUTINE PARSE_RESP(I_OUT_SEQ, I_RESP_ERR)
C
C
C Arguments
C
C I_OUT_SEQ (input) -- Sequence # of packet sent to VTERM
C I_RESP_ERR (output) -- 2=abort, 0=ACK, 1=all else
C
C
C Returns
C
C I_RESP_ERR (See Arguments)
C
C
C Data declarations
C
INCLUDE 'F7VMS.DEC' ! Program-wide
INTEGER*4 I_DELTA_TIME(2) ! For last good packet
INTEGER*4 SYS$READEF ! Read event flags service
C
C
CALL SYS$BINTIM('0 ::10',I_DELTA_TIME(1))
CALL SYS$SETIMR(1,I_DELTA_TIME(1),,)
C Initialize for time checking
C
C Main loop begins here
C

10 STS=SYS$READEF(%VAL(1),I_EV_FLAGS)
IF (((STS .AND. SS$_NORMAL) .EQ. 0) .OR. (WAIT_ERR .NE. 0))
X THEN
C Look at watch
C
I_RESP_ERR = 1
GO TO 2000
ENDIF
C Ten-second time-out while getting garbage, or
C input routine timed out, so go back with flag
C
WAIT_ERR = 0
20 CALL GETBYTES(0,1,10)
IF (WAIT_ERR .NE. 0) THEN
GO TO 10
ELSE IF (KB_BUFFER(1:1) .NE. 'S') THEN
GO TO 10
ENDIF
C Get one byte w/time-out; must be 'S'
C
CALL GETBYTES(1,1,10)
IF (WAIT_ERR .NE. 0) THEN
GO TO 10
ENDIF
C Get byte 2, w/time-out
C
I_TEST=ICHAR(KB_BUFFER(2:2))
IF ((I_TEST .LT. 49) .OR. (I_TEST .GT. 57)) THEN
GO TO 10
ENDIF
C Bad conversion
C
STS=OTS$CVT_TI_L(%DESCR(KB_BUFFER(2:2)),%REF(IN_SEQ_NO))
CALL GETBYTES(2,1,10)
C Byte 3 is response type
C
IF (WAIT_ERR .NE. 0) THEN
GO TO 10
C Timed out
C
ELSE IF (KB_BUFFER(3:3) .EQ. 'D') THEN
I_RESP_ERR=2
GO TO 2000
C Abort type
C
ELSE IF (KB_BUFFER(3:3) .EQ. 'C') THEN
I_RESP_ERR=1
GO TO 2000
C It's a NAK
C
ELSE IF (IN_SEQ_NO .NE. I_OUT_SEQ) THEN
GO TO 10
C Not germane to last transmission
C
ELSE IF (KB_BUFFER(3:3) .EQ. 'B') THEN
GO TO 2000
C What we want to hear
C
ELSE
GO TO 10
C Catch-all case, try again
C
ENDIF
2000 RETURN
END
C
C **************************************************************************
C
C WRITEHOST -- PC => Host: Write host file Module
C
C **************************************************************************
C
SUBROUTINE WRITEHOST(I_HST_PTR,I_EOF)
C
C
C Arguments
C
C I_HST_PTR (both) -- Position of last data byte in buffer
C I_EOF (input) -- Flag that EOT received from VTERM
C
C
C
C Returns
C
C No return
C
C
C Data declarations
C
INCLUDE 'F7VMS.DEC' ! Program-wide
C
C
C Loop starts
C
IF (F_CC .EQ. 'LIST') THEN
10 I_CRPOS = INDEX(HST_BUFFER,CRLF)
IF (I_CRPOS .GT. 0) THEN
TOT_BYTES=TOT_BYTES + I_CRPOS + 1
WRITE(11,11)HST_BUFFER(1:I_CRPOS-1)
11 FORMAT(A)
HST_BUFFER=HST_BUFFER(I_CRPOS+2:1024)
I_HST_PTR=I_HST_PTR - I_CRPOS - 1
GO TO 10
ELSE IF (I_EOF .GT. 0 .AND. I_HST_PTR .GT. 0) THEN
WRITE(11,12)HST_BUFFER(1:I_HST_PTR)
12 FORMAT(A)
TOT_BYTES=TOT_BYTES + I_HST_PTR
I_HST_PTR=0
ENDIF
GO TO 2000
C If we're stripping CR/LF's, loop and write all
C data in the buffer followed by them, adjust
C pointer and left justify remains; EOT flag is
C write anything in buffer and add to total bytes
C transferred.
C
ENDIF
15 IF (I_HST_PTR .GE. 512) THEN
WRITE(11,20)HST_BUFFER(1:512)
20 FORMAT(A)
HST_BUFFER=HST_BUFFER(513:1024)
TOT_BYTES=TOT_BYTES + 512
I_HST_PTR=I_HST_PTR - 512
GO TO 15
ELSE IF (I_EOF .GT. 0 .AND. I_HST_PTR .GT. 0) THEN
DO 21 II=I_HST_PTR+1,512
HST_BUFFER(II:II)=CHAR(0)
21 CONTINUE
WRITE(11,22)HST_BUFFER(1:I_HST_PTR)
22 FORMAT(A)
TOT_BYTES=TOT_BYTES + I_HST_PTR
I_HST_PTR=0
ENDIF
C Otherwise, write 512-byte blocks, left justify
C buffer, adjust pointer and loop to catch EOT
C condition (write anything in buffer and add to
C total bytes transferred)
C
2000 RETURN
END
C
C **************************************************************************
C
C BUILD_ESC -- Make escape sequence for VTERM & load parameters
C
C **************************************************************************
C
SUBROUTINE BUILD_ESC(IOLDCOM)
C
C
C Arguments
C
C IOLDCOM = 1 IF IN OLD COMMAND FILE COMPATIBILTY MODE
C (I.E. SKIP CTRL-Z AND COLLISION Q'S).
C
C
C
C Returns
C
C
C
C
C Data declarations
C
INCLUDE 'F7VMS.DEC' ! Program-wide
CHARACTER*17 TMP_ESC ! To build sequence
C
C
C Loop starts
C
TMP_ESC(1:5) = CHAR(27)//'[>3;'
TMP_ESC(9:9) = ';'
TMP_ESC(11:13) = ';2;'
C Always true
C
9 WRITE(10,10)CRLF,CRLF
10 FORMAT(A2,A2,'PACKET SIZE (32, 64, 128, 256 ) '//
X '<256>? ')
READ (9,11)I_INP_LEN,UT_BUF(1:80)
11 FORMAT(Q,A)
IF ((UT_BUF(1:80) .EQ. '32') .OR.
X (UT_BUF(1:80) .EQ. '32;')) THEN
PACKET_LEN = 32
TMP_ESC(6:8) = '032'
ELSE IF ((UT_BUF(1:80) .EQ. '64') .OR.
X (UT_BUF(1:80) .EQ. '64;')) THEN
PACKET_LEN = 64
TMP_ESC(6:8) = '064'
ELSE IF ((UT_BUF(1:80) .EQ. '128') .OR.
X (UT_BUF(1:80) .EQ. '128;')) THEN
PACKET_LEN = 128
TMP_ESC(6:8) = '128'
ELSE IF ((UT_BUF(1:80) .EQ. '256') .OR.
X (UT_BUF(1:80) .EQ. '256;')) THEN
PACKET_LEN = 256
TMP_ESC(6:8) = '256'
ELSE IF (I_INP_LEN .EQ. 0) THEN
PACKET_LEN = 256
TMP_ESC(6:8) = '256'
ELSE
GO TO 9
ENDIF
C Get packet length
C
IF (UT_BUF(I_INP_LEN:I_INP_LEN) .EQ. ';') THEN
IOLDCOM=0 ! ;'s are new-fangled.
CRC_FLAG=1
TMP_ESC(10:12)='0;2'
IF (F_CC .EQ. 'LIST') THEN
TMP_ESC(13:16)=';1;2'
ELSE
TMP_ESC(13:16)=';0;2'
ENDIF
UT_BUF(18:18)=';'
GOTO 1000
ENDIF
C Set defaults and skip q's.
C
C
19 WRITE(10,20)CRLF,CRLF
20 FORMAT(A2,A2,'ERROR DETECTION (CH-ecksum or CR-c) '//
X '? ')
READ (9,21)I_INP_LEN,UT_BUF(1:80)
21 FORMAT(Q,A)
IF (UT_BUF(1:80) .EQ. 'CH' .OR. UT_BUF(1:80) .EQ. 'Ch'
X .OR. UT_BUF(1:80) .EQ. 'cH' .OR. UT_BUF(1:80) .EQ. 'ch'
X .OR. UT_BUF(1:80) .EQ. 'CH;' .OR. UT_BUF(1:80) .EQ. 'Ch;'
X .OR. UT_BUF(1:80) .EQ. 'cH;' .OR. UT_BUF(1:80) .EQ. 'ch;')
X THEN
CSM_FLAG = 1
TMP_ESC(10:10) = '1'
ELSE IF (UT_BUF(1:80) .EQ. 'CR' .OR. UT_BUF(1:80) .EQ. 'Cr'
X .OR. UT_BUF(1:80) .EQ. 'cR' .OR. UT_BUF(1:80) .EQ. 'cr'
X .OR. UT_BUF(1:80) .EQ. 'CR;' .OR. UT_BUF(1:80) .EQ. 'Cr;'
X .OR. UT_BUF(1:80) .EQ. 'cR;' .OR. UT_BUF(1:80) .EQ. 'cr;')
X THEN
CRC_FLAG = 1
TMP_ESC(10:10) = '0'
ELSE IF (I_INP_LEN .EQ. 0) THEN
CRC_FLAG = 1
TMP_ESC(10:10) = '0'
ELSE
GO TO 19
ENDIF
C Get error detection choice
C
IF (UT_BUF(I_INP_LEN:I_INP_LEN) .EQ. ';') THEN
IOLDCOM=0 ! ;'s are new-fangled.
IF (F_CC .EQ. 'LIST') THEN
TMP_ESC(13:16)=';1;2'
ELSE
TMP_ESC(13:16)=';0;2'
ENDIF
UT_BUF(18:18)=';'
GOTO 1000
ENDIF
C Set defaults and skip q's.
C
IF (IOLDCOM .NE. 0) THEN
GOTO 1000
ENDIF
C Let's let old com files work.
C
C
119 WRITE(10,120)CRLF,CRLF
120 FORMAT(A2,A2,'IS CONTROL-Z END OF PC FILE ')
IF (F_CC .EQ. 'LIST') THEN
WRITE(10,121)
121 FORMAT('? ')
TMP_ESC(14:15)='1;'
ELSE
WRITE(10,122)
122 FORMAT('? ')
TMP_ESC(14:15)='0;'
ENDIF

READ (9,123)IILEN,UT_BUF(1:80)
123 FORMAT(Q,A)
IF (UT_BUF(1:80) .EQ. 'Y' .OR. UT_BUF(1:80) .EQ. 'Y;'
X .OR. UT_BUF(1:80) .EQ. 'y' .OR. UT_BUF(1:80) .EQ. 'y;')
X THEN
TMP_ESC(14:15)='1;'
ELSE IF (UT_BUF(1:80) .EQ. 'N' .OR. UT_BUF(1:80) .EQ. 'N;'
X .OR. UT_BUF(1:80) .EQ. 'n' .OR. UT_BUF(1:80) .EQ. 'n;')
X THEN
TMP_ESC(14:15)='0;'
ELSE IF (IILEN .EQ. 0) THEN
GOTO 219
ELSE
GO TO 119
ENDIF
C Get Control-z choice
C
IF (UT_BUF(IILEN:IILEN) .EQ. ';') THEN
IOLDCOM=0 ! ;'s are new-fangled.
TMP_ESC(16:16)='2'
UT_BUF(18:18)=';'
GOTO 1000
ENDIF
C Set defaults and skip q's.
C
219 IF (MODE_SW .EQ. 1) THEN
TMP_ESC(16:16) = '2'
GOTO 1000
ENDIF
C

WRITE(10,220)CRLF,CRLF
220 FORMAT(A2,A2,'IF PC FILE EXISTS (P-rompt, O-verwrite or ' //
X 'R-ename) '//
X '? ')
READ (9,221)IILEN,UT_BUF(1:80)
221 FORMAT(Q,A)
IF (UT_BUF(1:80) .EQ. 'P' .OR. UT_BUF(1:80) .EQ. 'P;'
X .OR. UT_BUF(1:80) .EQ. 'p' .OR. UT_BUF(1:80) .EQ. 'p;')
X THEN
TMP_ESC(16:16) = '0'
ELSE IF (UT_BUF(1:80) .EQ. 'O' .OR. UT_BUF(1:80) .EQ. 'O;'
X .OR. UT_BUF(1:80) .EQ. 'o' .OR. UT_BUF(1:80) .EQ. 'o;')
X THEN
TMP_ESC(16:16) = '1'
ELSE IF (UT_BUF(1:80) .EQ. 'R' .OR. UT_BUF(1:80) .EQ. 'R;'
X .OR. UT_BUF(1:80) .EQ. 'r' .OR. UT_BUF(1:80) .EQ. 'r;')
X THEN
TMP_ESC(16:16) = '2'
ELSE IF (IILEN .EQ. 0) THEN
TMP_ESC(16:16) = '2'
ELSE
GO TO 219
ENDIF
C Get collision choice
C
IF (UT_BUF(IILEN:IILEN) .EQ. ';') THEN
IOLDCOM=0 ! ;'s are new-fangled.
UT_BUF(18:18)=';'
ENDIF
C Set defaults and skip q's.
C
1000 IF (MODE_SW .EQ. 1) THEN
TMP_ESC(17-IOLDCOM:17-IOLDCOM)='s'
ELSE
TMP_ESC(17-IOLDCOM:17-IOLDCOM)='r'
ENDIF
2000 UT_BUF(1:17-IOLDCOM) = TMP_ESC(1:17-IOLDCOM)
RETURN
END
C
C **************************************************************************
C
C DIAG -- Module that controls program diagnostic
C
C **************************************************************************
C
SUBROUTINE DIAG
C
C
C
C Returns
C
C Source file checksum in byte 1 of PRG_CSM
C
C
C Data declarations
C
INCLUDE 'F7VMS.DEC' ! Program-wide
LOGICAL D_EX ! Source file exists = .T.
C
C
C Main loop begins here
C
20 WRITE (10,21)CRLF,CRLF
21 FORMAT(A2,A2,'WHAT IS THE FILE CONTAINING THE VTRANS SOURCE ')
WRITE (10,22)
22 FORMAT('CODE? ')
UT_BUF=' '
READ (9,23)UT_BUF(1:80)
23 FORMAT(A)
C Get the source file name
C
INQUIRE(FILE=UT_BUF(1:80),EXIST=D_EX,RECL=I_LEN)
IF (D_EX) THEN
OPEN(UNIT=12,FILE=UT_BUF(1:80),STATUS='OLD')
ELSE
WRITE(10,24)CRLF,CRLF
24 FORMAT(A2,A2,'*FILE NOT FOUND.')
GOTO 20
C Open it if it exists, or ask again
C
ENDIF
WRITE (10,25)CRLF,CRLF,CRLF,CRLF
25 FORMAT(A2,A2,'*PLEASE WAIT...',A2,A2)
C It might take a while...
C
30 READ (12,31, END=1000) UT_BUF
31 FORMAT(A)
DO 50 I=1,I_LEN
J=ICHAR(UT_BUF(I:I))
IF (J .EQ. 32 .OR. J .EQ. 27 .OR. J .EQ. 127
X .OR. (J .GE. 9 .AND. J .LE. 13)) THEN
UT_BUF(I:I) = CHAR(0)
ELSE
IF (J .GE. 97 .AND. J .LE. 122) THEN
UT_BUF(I:I) = CHAR( J - 32 )
ENDIF
ENDIF
C Input lines of code and eliminate spaces,
C tabs, control characters, and convert lc
C to upper case
C
50 CONTINUE
CALL CSUM(UT_BUF, I_LEN)
C Take checksum of altered line
C
CALL CSUM(PRG_CSM(1:1)//CSUM_RESULT(1:1), 2)
C Take checksum of old sum + new sum
C
PRG_CSM(1:1) = CSUM_RESULT(1:1)
UT_BUF=' '
C Replace program checksum & wipe buffer
C
GO TO 30
C Back to top of loop
C
1000 CLOSE(12)
RETURN
END
C
C **************************************************************************
C
C CSUM -- Module that calculates checksums
C
C **************************************************************************
C
SUBROUTINE CSUM(ARG_CHARS, IARG_LEN)
C
C
C Arguments
C
C ARG_CHARS (input) -- String to be checksummed
C IARG_LEN (input) -- Length of string to be checksummed
C
C
C Returns
C
C Checksum in byte 1 of CSM_RESULT
C
C
C Data declarations
C
INCLUDE 'F7VMS.DEC' ! Program-wide
CHARACTER*512 ARG_CHARS ! Local string argument
C
C
C Initialization
C
NEW_BYTW = 0 ! Integer for string bytes
RESULT_BYTEW = 0 ! Integer for result
C
C
C Loop starts
C
DO 10 I=1,IARG_LEN
CSUM_SBYTS(1:1) = ARG_CHARS(I:I)
C Move to string equivalent converts to integer
C
RESULT_BYTEW = MOD(RESULT_BYTEW + NEW_BYTEW, 256)
C Lop off carry bit -- keep 8 bits only
C
10 CONTINUE
C Loop ends
C
RETURN
END
C
C **************************************************************************
C
C GETBYTES -- Module to do unformatted input from VTERM
C
C **************************************************************************
C
SUBROUTINE GETBYTES(I_ARG_PTR, I_ARG_CNT,I_ARG_WAIT)
C
C
C Arguments
C
C I_ARG_PTR (input) -- Last byte of data in KB_BUFFER
C I_ARG_CNT (input) -- Number of bytes to get
C I_ARG_WAIT (input) -- Half of time-out limit (used twice)
C
C
C Returns
C
C Either requested bytes placed after KB_BUFFER's previous
C last data byte, or non-zero WAIT_ERR (time-out signal)
C
C
C Data declarations
C
INCLUDE 'F7VMS.DEC' ! Program-wide
C
BUFF_SZ(1) = I_ARG_CNT ! ARG bytes at a time
TMOUT(1)=I_ARG_WAIT ! Time limit per QIOW
C
20 CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_TIMED .OR. IO$M_NOFILTR),
X %REF(IOSB(1)),,,
X %REF(KB_BUFFER(I_ARG_PTR+1:I_ARG_PTR+1)),
X %VAL(BUFF_SZ(1)),%VAL(TMOUT(1)),
X %REF(TERMTOR(1)),,)
IF ((IOSB(1) .AND. SS$_NORMAL) .NE. 0) THEN
WAIT_ERR = 0
ELSE IF ((IOSB(1) .AND. SS$_TIMEOUT) .EQ. SS$_TIMEOUT) THEN
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
WAIT_ERR = 1
GO TO 2000
ELSE
WAIT_ERR = -1
GOTO 2000
ENDIF
C
2000 RETURN
END
C
C **************************************************************************
C
C CCAST -- Module to trap control-c's
C
C **************************************************************************
C
SUBROUTINE CCAST
C
C
C Arguments
C
C
C Returns
C
C
C Data declarations
C
INCLUDE 'F7VMS.DEC' ! Program-wide
C
C
CALL ASTENABLE
C Renable the ast
C
C
2000 RETURN
END
C
C **************************************************************************
C
C ASTENABLE -- Module to reanable control-c trap
C
C **************************************************************************
C
SUBROUTINE ASTENABLE
C
C
C Arguments
C
C
C Returns
C
C
C Data declarations
C
INCLUDE 'F7VMS.DEC' ! Program-wide
EXTERNAL CCAST ! Address of ctrl-c ast
C
C
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE .OR.
X IO$M_CTRLCAST .OR. IO$M_CTRLYAST),,,,CCAST,,,,,)
C Renable the ast
C
C
2000 RETURN
END
C
C **************************************************************************
C
C BLOCK DATA -- Initialize commons
C
C **************************************************************************
C
BLOCK DATA
C
C See 'F7VMS.DEC' for description of program-wide variables
C
INCLUDE 'F7VMS.DEC' ! Program-wide
C
DATA TERMTOR,WAIT_ERR,TMOUT,IOSB,STS,TOT_BYTES,
X MODE_SW,CRC_FLAG,CSM_FLAG,
X PACKET_LEN,TRUNC_FLAG/16*0/
DATA IO$_READVBLK,IO$_WRITEVBLK,IO$_SETMODE,
X IO$_SENSEMODE,IO$M_TIMED,IO$M_PURGE,
X IO$M_CTRLCAST,IO$M_CTRLYAST,IO$M_NOFILTR,
X IO$M_CANCTRLO,
X TT$M_WRAP,TT$M_EIGHTBIT,TT$M_HOSTSYNC,
X TT$M_TTSYNC,TT$M_SCOPE,TT$M_ESCAPE,
X TT$M_LOWER,TT$M_NOECHO,TT$M_PASSALL,
X SS$_NORMAL,SS$_TIMEOUT/'00000031'X,
X '00000030'X,'00000023'X,'00000027'X,
X '00000080'X,'00000800'X,'00000100'X,
X '00000080'X,'00000200'X,'00000040'X,
X '00000200'X,
X '00008000'X,'00000010'X,'00000020'X,
X '00001000'X,'00000008'X,'00000080'X,
X '00000002'X,'00000001'X,'00000001'X,
X '0000022C'X/
END


  3 Responses to “Category : Communication (modem) tools and utilities
Archive   : VTRANS.ZIP
Filename : F7VMS.FOR

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/