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

C **************************************************************************
C
C Copyright (C) 1984
C
C COEFFICIENT SYSTEMS CORPORATION
C 611 Broadway New York, NY 10012
C
C PROGRAM NAME: F8VMS.FOR
C
C VERSION : 1.58
C
C ABSTRACT : HOST SOFTWARE FOR COEFFICIENT SYSTEMS CORP.
C VTRANS (8-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 "F8VMS.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 F8VMS
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC' ! Program-wide
LOGICAL FEX ! Host file exists = .T.
C
C
C Initialization
C
CALL SPCINT
C Load table per CRC-16 polynomial
C
CRLF=CHAR(13)//CHAR(10)
C Will be doing own carriage return/line feed
C
CALL TRMSET(1)
C Initialize for later calls to set terminal
C characteristics, and save current settings
C
OPEN (UNIT=10,FILE='SYS$OUTPUT',CARRIAGECONTROL='NONE',
X STATUS='UNKNOWN')
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.58 -- HOST ')
WRITE (10,11)
11 FORMAT('SOFTWARE FOR 8-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)IILEN,UTBUF(1:80)
18 FORMAT(Q,A)
C Get choice into utility character area
C (simple i/o limited to 80-bytes...)
C
IF (UTBUF(1:80) .EQ. '1') THEN
MODESW=1
ELSE IF (UTBUF(1:80) .EQ. '2') THEN
MODESW=2
ELSE IF (UTBUF(1:80) .EQ. '3') THEN
MODESW=3
ELSE IF (UTBUF(1:80) .EQ. '4') THEN
MODESW=4
ELSE IF (UTBUF(1:1) .EQ. '@') THEN
MODESW=5
ELSE IF (UTBUF(1:1) .EQ. '~') THEN
MODESW=6
ELSE
MODESW=7
ENDIF
C Prepare for computed GOTO
C
IF (MODESW .EQ. 6) THEN
IOLDCOM=4
ENDIF
C We'll skip ctl-z and collision q's.
C
IF ((MODESW .EQ. 5) .OR. (MODESW .EQ. 6)) THEN
IDOT = INDEX(UTBUF(1:80),'.')
IF ( IDOT .EQ. 0 ) THEN
UTBUF(IILEN+1:IILEN+4)='.COM'
IILEN=IILEN+4
ENDIF
CLOSE(9)
OPEN (UNIT=9,FILE=UTBUF(2:IILEN),
X CARRIAGECONTROL='LIST',STATUS='OLD')
ENDIF
C
C
C
IF (MODESW .EQ. 3) THEN
PCSMW = 0
CALL DIAG
PCSMW=ICHAR(PCSM)
WRITE(10,19)CRLF,CRLF,PCSMW,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),MODESW
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,UTBUF(1:80)
22 FORMAT(Q,A)
C Get host file name for transfer either way
C
IF (UTBUF(IILEN:IILEN) .EQ. ';') THEN
IILEN=IILEN-1
ENDIF
C Optional semicolon is not part of filename.
C
IF (MODESW .EQ. 2) THEN
C If host => pc
C
INQUIRE(FILE=UTBUF(1:80),EXIST=FEX,
X CARRIAGECONTROL=FCC)
C Exists? "List" or "Fortran" or "None"?
C
IF (FEX) THEN
OPEN(UNIT=11,FILE=UTBUF(1:80),
X CARRIAGECONTROL=FCC,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 (UTBUF(IILEN+1:IILEN+1) .EQ. ';') THEN
UTBUF(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)UTBUF(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 (UTBUF(78:78) .EQ. 'Y' .OR. UTBUF(78:78) .EQ. ' '
X .OR. UTBUF(78:78) .EQ. 'y')
X THEN
FCC='LIST'
OPEN(UNIT=11,FILE=UTBUF(1:77),
X CARRIAGECONTROL=FCC,
X RECORDTYPE='VARIABLE',
X RECL=32767,STATUS='NEW',ERR=28,
X IOSTAT=IERR)
C They're coming...
C
ELSE IF (UTBUF(78:78) .EQ. 'N' .OR.
X UTBUF(78:78) .EQ. 'n')
X THEN
FCC='NONE'
OPEN(UNIT=11,FILE=UTBUF(1:77),
X CARRIAGECONTROL=FCC,
X RECORDTYPE='FIXED',
X RECL=512,STATUS='NEW',ERR=28,
X IOSTAT=IERR)
C They're not.
C
ELSE
GOTO 24
ENDIF
ENDIF
GOTO 30
C Skip over ERR handler.
C
28 WRITE(10,29)CRLF,CRLF,IERR
29 FORMAT(A2,A2,'*UNABLE TO OPEN FILE.',I)
GOTO 20
C Error... Advise and try again
C
30 IF (UTBUF(IILEN+1:IILEN+1) .EQ. ';') THEN
IPCNML=0
GOTO 321
ENDIF
C
C
WRITE (10,31)CRLF,CRLF,UTBUF(1:IILEN)
31 FORMAT(A2,A2,'WHAT IS THE NAME OF THE FILE ON THE PC <',A,'>? ')
READ (9,32,END=9)IPCNML,KBBUF(1:80)
32 FORMAT(Q,A)
321 IF (IPCNML .LT. 1) THEN
IPCNML=IILEN
KBBUF(1:80)=UTBUF(1:80)
ENDIF
C Find out file desired to be set on VTERM
C
IF (KBBUF(IPCNML:IPCNML) .EQ. ';') THEN
IPCNML=IPCNML-1
UTBUF(IILEN+1:IILEN+1)=';'
ENDIF
C Optional semicolon is not part of filename.
C
DO 322 I=1,IPCNML
II=ICHAR(KBBUF(I:I))
IF (II .GE. 97 .AND. II .LE. 122) THEN
KBBUF(I:I)=CHAR(II-32)
ENDIF
322 CONTINUE
C Convert to upper case
C
CALL TRMSET(2)
C Superimpose needed terminal settings to handle
C escape sequences
C
UTBUF(81:160) = CHAR(155)//'[>0f'//KBBUF(1:IPCNML)
X //CHAR(13)
CALL ESCSND(6+IPCNML)
C Send set-pcfile escape sequence to VTERM
C
UTBUF(81:85) = CHAR(155)//'[>1f'
CALL ESCSND(5)
C Send ask-pcfile escape sequence to VTERM
C
INPTR = 80
33 CALL GTBYTS(INPTR,1,100)
C Get pcfile one byte at a time
C
IF (WAITER .GT. 0) THEN
GO TO 2100
ELSE IF (KBBUF(INPTR+1:INPTR+1) .NE. CHAR(13)
X .AND. KBBUF(INPTR+1:INPTR+1) .NE.
X CHAR(10)) THEN
INPTR = INPTR + 1
GO TO 33
ENDIF
C Timed out, abort, else look for CR or LF
C
IF (KBBUF(1:IPCNML) .NE. KBBUF(81:INPTR))
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 TRMSET(3)
C Restored saved terminal settings
C
IF (UTBUF(IILEN+1:IILEN+1) .EQ. ';') THEN
UTBUF(1:10)=CHAR(27)//'[>0;256;0'
IF (FCC .EQ. 'LIST') THEN
UTBUF(11:14)=';1;2'
ELSE
UTBUF(11:14)=';0;2'
ENDIF
IF (MODESW .EQ. 1) THEN
UTBUF(15:15)='s'
ELSE
UTBUF(15:15)='r'
ENDIF
IOLDCOM=0 ! ;'s are new-fangled.
PLEN = 256
CRCFLG=1
GOTO 361
ENDIF
C All this if they semi-coloned.
C
CALL BLDESC(IOLDCOM)
C Also load parameters
C
IF (UTBUF(16:16) .EQ. ';') THEN
UTBUF(16:16)=' '
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)KBBUF(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
CALL TRMSET(2)
C Superimpose needed terminal settings to handle
C escape sequences
C
UTBUF(81:160)=UTBUF(1:15-IOLDCOM)
CALL ESCSND(15-IOLDCOM)
C Send startup escape sequence to VTERM
C
INPTR = 80
38 CALL GTBYTS(INPTR,1,100)
C Get VTERM go-ahead one byte at a time
C
IF (KBBUF(81:81) .NE. 'Y' .OR. WAITER .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
CALL TRMSET(4)
C Set terminal for data transmission
C

IF (MODESW .EQ. 1) THEN
CALL VTSEND
ELSE
CALL VTRECEIVE
ENDIF
C Modesw can only be 1 or 2 here -- do
C main processing
C
2000 IF (WAITER .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 TRMSET(3)
C Restore saved terminal settings
C
WRITE(10,2101)CRLF,CRLF,TBYTES,CRLF,CRLF
2101 FORMAT(A2,A2,'TOTAL BYTES TRANSFERRED = ',I,A2,A2)
TBYTES = 0
PLEN = 0
CRCFLG = 0
CSMFLG = 0
MODESW = 0
CLOSE(11)
GO TO 13
C Back for more files
C
2200 CALL TRMSET(3)
C Restore saved terminal settings
C
CALL TRMSET(5)
C Deassign terminal for system
C
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 'F8VMS.DEC' ! Program-wide
C
C Initialization
C
ILSTSQ = 16 ! Last packet no.
IHSPTR = 0 ! Start clean
IEOF = 0 ! Start new
INDPK = 0 ! No EOF from VTERM
KBBUF(1:3) = CHAR(1)//CHAR(1)//CHAR(254)
C In case we never get going, prepare for aborting
C
C Main loop begins here
C

10 IF (WAITER .GT. 0) THEN
C Look at watch
C
KBBUF(4:4) = 'D'
WRITE (10,11)KBBUF(1:4)
11 FORMAT(A4)
WRITE(10,12)CRLF,CRLF
12 FORMAT(A2,A2,'*HOST ABORTING...')
WAITER = 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 GTBYTS(0,1,20)
IF (WAITER .NE. 0) THEN
GO TO 10
ELSE IF (KBBUF(1:1) .NE. CHAR(1)) 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 GTBYTS(1,2,20)
IF (WAITER .NE. 0) THEN
GO TO 10
ENDIF
C Two more bytes, standard time trapping
C
ISQNO = ICHAR(KBBUF(2:2))
IONCMP = ICHAR(KBBUF(3:3))
IF (IONCMP + ISQNO .NE. 255) THEN
CALL NAKIT(ILSTSQ)
GO TO 10
ENDIF
C Byte two is incoming sequence no., and byte
C three should be its ones complement -- so
C send NAK packet with last good sequence no.
C if relation not correct and start over
C
CALL GTBYTS(3,1,20)
IF (WAITER .NE. 0) THEN
GO TO 10
ELSE IF (KBBUF(4:4) .EQ. 'D') THEN
WRITE(10,25)CRLF,CRLF
25 FORMAT(A2,A2,'*PC ABORTING...')
WAITER=1
GO TO 2000
ENDIF
C Get fourth byte with standard time trapping --
C if abort signal from VTERM jump to sequence no.
C checking without trying more input
C
CALL GTBYTS(4,1,20)
IF (WAITER .NE. 0) THEN
GO TO 10
ENDIF
C Otherwise, get a fifth byte w/ time-out
C
IF (KBBUF(4:4) .EQ. 'F') THEN
INDPK = 1
IPKLN = 0
IF (CRCFLG .GT. 0) THEN
CALL GTBYTS(5,1,20)
IF (WAITER .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 sixth
C byte (second CRC byte) if we're doing CRC
C checking -- trapping for time, of course
C
IPKLN = ICHAR(KBBUF(5:5)) + 1
CALL GTBYTS(5,IPKLN + 2 - CSMFLG,20)
IF (WAITER .NE. 0) THEN
GO TO 10
ENDIF
C Otherwise, find out how many data bytes in this
C packet, and get that many plus one extra for
C checksum or two extra for CRC (w/time trapping)
C
30 IF ((ILSTSQ .EQ. 16 .AND. ISQNO .EQ. 1)
X .OR. (ILSTSQ .EQ. ISQNO)) THEN
GO TO 40
ENDIF
C Protocol calls for stepping from sequence no.
C 16 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 (ISQNO .NE. ILSTSQ + 1) THEN
CALL NAKIT(ILSTSQ)
GO TO 10
ENDIF
C However, if not special case of 16/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=IPKLN + 5 - INDPK
C Pre-calculation for program optimization
C covering EOF packet case as well
C
IF (CSMFLG .GT. 0) THEN
GO TO 50
ENDIF
C Skip next if we're checksumming
C
CALL MAKCRC(J)
C Calculate CRC for packet bytes 2 to end of data
C
IF (KBBUF(J+1:J+2) .NE. CRCBTS(1:2)) THEN
CALL NAKIT(ILSTSQ)
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 (CRCFLG .GT. 0) THEN
GO TO 60
ENDIF
C Skip next if we're CRCing
C
CALL CSUM(KBBUF(2:J), J-1)
IF (KBBUF(J+1:J+1) .NE. CSMRES(1:1)) THEN
CALL NAKIT(ILSTSQ)
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 (ILSTSQ .EQ. ISQNO) THEN
CALL ACKIT(ISQNO)
GO TO 10
ENDIF
C Here's where we ACK the repeat packet, repeat loop
C
IF (KBBUF(4:4) .EQ. 'F') THEN
CALL ACKIT(ISQNO)
IEOF = 1
CALL WRTHST(IHSPTR,IEOF)
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 (KBBUF(4:4) .EQ. 'A') THEN
IF (IHSPTR .EQ. 0 ) THEN
HSTBUF=KBBUF(6:IPKLN+5)
ELSE
HSTBUF=HSTBUF(1:IHSPTR)//
X KBBUF(6:IPKLN+5)
ENDIF
IHSPTR = IHSPTR + IPKLN
IEOF = 0
CALL WRTHST(IHSPTR,IEOF)
CALL ACKIT(ISQNO)
ILSTSQ = ISQNO
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
CALL NAKIT(ILSTSQ)
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 'F8VMS.DEC' ! Program-wide
C
C
C Initialization
C
ILSTSQ = 1 ! Last ACKed packet #
IHSPTR = 0 ! Host buffer pointer
ISNDCT = 0 ! No send tries yet
IOSQNO = 1 ! Outgoing packet #
J=PLEN + 5 ! Pre-calc for optimization
C (last data byte postion)
JJ=J + 2 - CSMFLG ! Pre-calc for optimization
C (last packet byte pos.)
C
C
C Main loop begins here
C
10 IF (IHSPTR .LT. PLEN) THEN
READ(11, 11, END=100)IRCLEN,
X HSTBUF(IHSPTR+1:32767)
11 FORMAT(Q,A)
IF (FCC .EQ. 'NONE') THEN
IHSPTR=IHSPTR+IRCLEN
ELSE
HSTBUF(IHSPTR+IRCLEN+1:
X IHSPTR+IRCLEN+2)=CRLF
IHSPTR=IHSPTR+IRCLEN+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;
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
UTBUF=CHAR(1)//CHAR(IOSQNO)//CHAR(255-IOSQNO)//
X 'A'//CHAR(PLEN-1)//HSTBUF(1:PLEN)
C Prepare outgoing packet to last data byte
C
IF (CRCFLG .GT. 0) THEN
CALL MAKCRC(J)
UTBUF(J+1:J+2)=CRCBTS(1:2)
ELSE
CALL CSUM(UTBUF(2:J), J-1)
UTBUF(J+1:J+1)=CSMRES(1:1)
ENDIF
C Append checksum or CRC (bytes 2 thru end-of-data)
C
HSTBUF=HSTBUF(PLEN+1:32767)
IHSPTR=IHSPTR - PLEN
C Left justify remains of host buffer and
C calculate new pointer
C
20 IF (ISNDCT .GE. 10) THEN
UTBUF(1:4) = CHAR(1)//CHAR(ILSTSQ)//
X CHAR(255-ILSTSQ)//'D'
WRITE (10,21)UTBUF(1:4)
21 FORMAT(A4)
WRITE(10,25)CRLF,CRLF
25 FORMAT(A2,A2,'*HOST ABORTING...')
WAITER = 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
CALL SNDPAK(JJ)
C Send packet
C
ISNDCT = ISNDCT + 1
C Up send counter
C
IRSPER = 0
WAITER = 0
C Establish time-out basis, no error yet
C
CALL PRSRES(IOSQNO, IRSPER)
C Get VTERM's response and interpret it
C
IF (IRSPER .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 (IRSPER .EQ. 2) THEN
WRITE(10,1500)CRLF,CRLF
WAITER = 1
GO TO 2000
C Obey the abort, pass flag
C
ELSE
TBYTES=TBYTES + PLEN
ISNDCT = 0
ILSTSQ = IOSQNO
ENDIF
C All ok, so up byte counter and reinitialize
C
IF (ILSTSQ .EQ. 16) THEN
IOSQNO = 1
ELSE
IOSQNO = ILSTSQ + 1
ENDIF
GO TO 10
C Up outgoing sequence #, note 16 => 1
C
100 IF (IHSPTR .EQ. 0) THEN
GO TO 200
ENDIF
C Host file EOF reached, skip all this if no
C data bytes left unsent
C
J=IHSPTR + 5
JJ=J + 2 - CSMFLG
C Pre-calculations in terms of no. of remaining
C data bytes
C
UTBUF=CHAR(1)//CHAR(IOSQNO)//CHAR(255-IOSQNO)//
X 'A'//CHAR(IHSPTR-1)//HSTBUF(1:IHSPTR)
C Prepare packet to end-of-data
C
IF (CRCFLG .GT. 0) THEN
CALL MAKCRC(J)
UTBUF(J+1:J+2)=CRCBTS(1:2)
ELSE
CALL CSUM(UTBUF(2:J), J-1)
UTBUF(J+1:J+1)=CSMRES(1:1)
ENDIF
C Append checksum or CRC bytes
C
120 IF (ISNDCT .GE. 10) THEN
UTBUF(1:4) = CHAR(1)//CHAR(ILSTSQ)//
X CHAR(255-ILSTSQ)//'D'
WRITE (10,121)UTBUF(1:4)
121 FORMAT(A4)
WRITE(10,125)CRLF,CRLF
125 FORMAT(A2,A2,'*HOST ABORTING...')
WAITER = 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
CALL SNDPAK(JJ)
C Send packet
C
ISNDCT = ISNDCT + 1
C Up send counter
C
IRSPER = 0
WAITER = 0
C Initialize time-out basis, no error
C
CALL PRSRES(IOSQNO, IRSPER)
C What does VTERM have to say?
C
IF (IRSPER .EQ. 1) THEN
GO TO 120
C "No good", "got previous", or nothing
C
ELSE IF (IRSPER .EQ. 2) THEN
WRITE(10,1500)CRLF,CRLF
WAITER = 1
GO TO 2000
C "Abort", pass flag
C
ELSE
TBYTES=TBYTES + IHSPTR
ILSTSQ = IOSQNO
ISNDCT = 0
C "Fine, thanks"
ENDIF
IF (ILSTSQ .EQ. 16) THEN
IOSQNO = 1
ELSE
IOSQNO = ILSTSQ + 1
ENDIF
C Get ready to send EOT packet
C
200 J=4
JJ=J + 2 - CSMFLG
C Pre-calcs: error-detection will be based on
C byte 2 thru byte 4
C
UTBUF=CHAR(1)//CHAR(IOSQNO)//CHAR(255-IOSQNO)//
X 'F'
C Build it
C
IF (CRCFLG .GT. 0) THEN
CALL MAKCRC(J)
UTBUF(J+1:J+2)=CRCBTS(1:2)
ELSE
CALL CSUM(UTBUF(2:J), J-1)
UTBUF(J+1:J+1)=CSMRES(1:1)
ENDIF
C Finish it
C
220 IF (ISNDCT .GE. 10) THEN
UTBUF(1:4) = CHAR(1)//CHAR(ILSTSQ)//
X CHAR(255-ILSTSQ)//'D'
WRITE (10,221)UTBUF(1:4)
221 FORMAT(A4)
WRITE(10,225)CRLF,CRLF
225 FORMAT(A2,A2,'*HOST ABORTING...')
WAITER = 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
CALL SNDPAK(JJ)
C Send it
C
ISNDCT = ISNDCT + 1
C Keep track how many times
C
IRSPER = 0
WAITER = 0
C What time is it? No problem yet...
C
CALL PRSRES(IOSQNO, IRSPER)
C Listen to VTERM
C
IF (IRSPER .EQ. 1) THEN
GO TO 220
ELSE IF (IRSPER .EQ. 2) THEN
WRITE(10,1500)CRLF,CRLF
1500 FORMAT(A2,A2,'*PC ABORTING...')
WAITER = 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 PRSRES -- Host => PC: Get and analyze VTERM response
C
C **************************************************************************
C
SUBROUTINE PRSRES(IOSQNO, IRSPER)
C
C
C Arguments
C
C IOSQNO (input) -- Sequence # of packet sent to VTERM
C IRSPER (output) -- 2=abort, 0=ACK, 1=all else
C
C
C Returns
C
C IRSPER (See Arguments)
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC' ! Program-wide
C
C
CALL TENSEC(1)
C Initialize for time checking
C
C Main loop begins here
C
10 CALL TENSEC(2)
IF (WAITER .NE. 0) THEN
C Look at watch
C
IRSPER = 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
WAITER = 0
20 CALL GTBYTS(0,1,10)
IF (WAITER .NE. 0) THEN
GO TO 10
ELSE IF (KBBUF(1:1) .NE. CHAR(1)) THEN
GO TO 10
ENDIF
C Get one byte w/time-out; must be SOH (ascii 1)
C
CALL GTBYTS(1,2,100)
IF (WAITER .NE. 0) THEN
GO TO 10
ENDIF
C Get bytes 2, 3, w/time-out
C
ISQNO = ICHAR(KBBUF(2:2))
IONCMP = ICHAR(KBBUF(3:3))
IF (IONCMP + ISQNO .NE. 255) THEN
GO TO 10
ENDIF
C Byte 2 and Byte 3 have to be ones
C complementary
C
CALL GTBYTS(3,1,100)
C Byte 4 is response type
C
IF (WAITER .NE. 0) THEN
GO TO 10
C Timed out
C
ELSE IF (KBBUF(4:4) .EQ. 'D') THEN
IRSPER=2
GO TO 2000
C Abort type
C
ELSE IF (KBBUF(4:4) .EQ. 'C') THEN
IRSPER=1
GO TO 2000
C It's a NAK
C
ELSE IF (ISQNO .NE. IOSQNO) THEN
GO TO 10
C Not germane to last transmission
C
ELSE IF (KBBUF(4:4) .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 WRTHST -- PC => Host: Write host file Module
C
C **************************************************************************
C
SUBROUTINE WRTHST(IHSPTR,IEOF)
C
C
C Arguments
C
C IHSPTR (both) -- Position of last data byte in buffer
C IEOF (input) -- Flag that EOT received from VTERM
C
C
C
C Returns
C
C No return
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC' ! Program-wide
C
C
C Loop starts
C
IF (FCC .EQ. 'LIST') THEN
10 ICRPOS = INDEX(HSTBUF,CRLF)
IF (ICRPOS .GT. 0) THEN
TBYTES=TBYTES + ICRPOS + 1
WRITE(11,11)HSTBUF(1:ICRPOS-1)
11 FORMAT(A)
HSTBUF=HSTBUF(ICRPOS+2:32767)
IHSPTR=IHSPTR - ICRPOS - 1
GO TO 10
ELSE IF (IEOF .GT. 0 .AND. IHSPTR .GT. 0) THEN
WRITE(11,12)HSTBUF(1:IHSPTR)
12 FORMAT(A)
TBYTES=TBYTES + IHSPTR
IHSPTR=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 (IHSPTR .GE. 512) THEN
WRITE(11,20)HSTBUF(1:512)
20 FORMAT(A)
HSTBUF=HSTBUF(513:32767)
TBYTES=TBYTES + 512
IHSPTR=IHSPTR - 512
GO TO 15
ELSE IF (IEOF .GT. 0 .AND. IHSPTR .GT. 0) THEN
WRITE(11,21)HSTBUF(1:IHSPTR)
21 FORMAT(A)
TBYTES=TBYTES + IHSPTR
IHSPTR=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 BLDESC -- Make escape sequence for VTERM & load parameters
C
C **************************************************************************
C
SUBROUTINE BLDESC(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 'F8VMS.DEC' ! Program-wide
CHARACTER*15 TMPESC ! To build sequence
C
C
C Loop starts
C
TMPESC(1:5) = CHAR(27)//'[>0;'
TMPESC(9:9) = ';'
C Always true
C
IF (MODESW .EQ. 1) THEN
WRITE (10,5)CRLF,CRLF
5 FORMAT(A2,A2,'*NOTE: LARGER PACKET SIZES ',
X 'MAY NOT WORK AT HIGHER BAUD RATES')
WRITE(10,6)CRLF
6 FORMAT(A2,' UNLESS YOUR TERMINAL LINE',
X ' IS SET TO ALTYPEAHD.')
ENDIF
9 WRITE(10,10)CRLF,CRLF
10 FORMAT(A2,A2,'PACKET SIZE (32, 64, 128, 256 ) '//
X '<256>? ')
READ (9,11)IILEN,UTBUF(1:80)
11 FORMAT(Q,A)
IF ((UTBUF(1:80) .EQ. '32') .OR.
X (UTBUF(1:80) .EQ. '32;')) THEN
PLEN = 32
TMPESC(6:8) = '032'
ELSE IF ((UTBUF(1:80) .EQ. '64') .OR.
X (UTBUF(1:80) .EQ. '64;')) THEN
PLEN = 64
TMPESC(6:8) = '064'
ELSE IF ((UTBUF(1:80) .EQ. '128') .OR.
X (UTBUF(1:80) .EQ. '128;')) THEN
PLEN = 128
TMPESC(6:8) = '128'
ELSE IF ((UTBUF(1:80) .EQ. '256') .OR.
X (UTBUF(1:80) .EQ. '256;')) THEN
PLEN = 256
TMPESC(6:8) = '256'
ELSE IF (IILEN .EQ. 0) THEN
PLEN = 256
TMPESC(6:8) = '256'
ELSE
GO TO 9
ENDIF
C Get packet length
C
IF (UTBUF(IILEN:IILEN) .EQ. ';') THEN
IOLDCOM=0 ! ;'s are new-fangled.
CRCFLG=1
TMPESC(10:10)='0'
IF (FCC .EQ. 'LIST') THEN
TMPESC(11:14)=';1;2'
ELSE
TMPESC(11:14)=';0;2'
ENDIF
UTBUF(16:16)=';'
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)IILEN,UTBUF(1:80)
21 FORMAT(Q,A)
IF (UTBUF(1:80) .EQ. 'CH' .OR. UTBUF(1:80) .EQ. 'Ch'
X .OR. UTBUF(1:80) .EQ. 'cH' .OR. UTBUF(1:80) .EQ. 'ch'
X .OR. UTBUF(1:80) .EQ. 'CH;' .OR. UTBUF(1:80) .EQ. 'Ch;'
X .OR. UTBUF(1:80) .EQ. 'cH;' .OR. UTBUF(1:80) .EQ. 'ch;')
X THEN
CSMFLG = 1
TMPESC(10:10) = '1'
ELSE IF (UTBUF(1:80) .EQ. 'CR' .OR. UTBUF(1:80) .EQ. 'Cr'
X .OR. UTBUF(1:80) .EQ. 'cR' .OR. UTBUF(1:80) .EQ. 'cr'
X .OR. UTBUF(1:80) .EQ. 'CR;' .OR. UTBUF(1:80) .EQ. 'Cr;'
X .OR. UTBUF(1:80) .EQ. 'cR;' .OR. UTBUF(1:80) .EQ. 'cr;')
X THEN
CRCFLG = 1
TMPESC(10:10) = '0'
ELSE IF (IILEN .EQ. 0) THEN
CRCFLG = 1
TMPESC(10:10) = '0'
ELSE
GO TO 19
ENDIF
C Get error detection choice
C
IF (UTBUF(IILEN:IILEN) .EQ. ';') THEN
IOLDCOM=0 ! ;'s are new-fangled.
IF (FCC .EQ. 'LIST') THEN
TMPESC(11:14)=';1;2'
ELSE
TMPESC(11:14)=';0;2'
ENDIF
UTBUF(16:16)=';'
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
119 WRITE(10,120)CRLF,CRLF
120 FORMAT(A2,A2,'IS CONTROL-Z END OF PC FILE ')
IF (FCC .EQ. 'LIST') THEN
WRITE(10,121)
121 FORMAT('? ')
TMPESC(11:13)=';1;'
ELSE
WRITE(10,122)
122 FORMAT('? ')
TMPESC(11:13)=';0;'
ENDIF

READ (9,123)IILEN,UTBUF(1:80)
123 FORMAT(Q,A)
IF (UTBUF(1:80) .EQ. 'Y' .OR. UTBUF(1:80) .EQ. 'Y;'
X .OR. UTBUF(1:80) .EQ. 'y' .OR. UTBUF(1:80) .EQ. 'y;')
X THEN
TMPESC(11:13)=';1;'
ELSE IF (UTBUF(1:80) .EQ. 'N' .OR. UTBUF(1:80) .EQ. 'N;'
X .OR. UTBUF(1:80) .EQ. 'n' .OR. UTBUF(1:80) .EQ. 'n;')
X THEN
TMPESC(11:13)=';0;'
ELSE IF (IILEN .EQ. 0) THEN
GOTO 219
ELSE
GO TO 119
ENDIF
C Get Control-z choice
C
IF (UTBUF(IILEN:IILEN) .EQ. ';') THEN
IOLDCOM=0 ! ;'s are new-fangled.
TMPESC(14:14)='2'
UTBUF(16:16)=';'
GOTO 1000
ENDIF
C Set defaults and skip q's.
C
219 IF (MODESW .EQ. 1) THEN
TMPESC(14:14) = '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,UTBUF(1:80)
221 FORMAT(Q,A)
IF (UTBUF(1:80) .EQ. 'P' .OR. UTBUF(1:80) .EQ. 'P;'
X .OR. UTBUF(1:80) .EQ. 'p' .OR. UTBUF(1:80) .EQ. 'p;')
X THEN
TMPESC(14:14) = '0'
ELSE IF (UTBUF(1:80) .EQ. 'O' .OR. UTBUF(1:80) .EQ. 'O;'
X .OR. UTBUF(1:80) .EQ. 'o' .OR. UTBUF(1:80) .EQ. 'o;')
X THEN
TMPESC(14:14) = '1'
ELSE IF (UTBUF(1:80) .EQ. 'R' .OR. UTBUF(1:80) .EQ. 'R;'
X .OR. UTBUF(1:80) .EQ. 'r' .OR. UTBUF(1:80) .EQ. 'r;')
X THEN
TMPESC(14:14) = '2'
ELSE IF (IILEN .EQ. 0) THEN
TMPESC(14:14) = '2'
ELSE
GO TO 219
ENDIF
C Get collision choice
C
IF (UTBUF(IILEN:IILEN) .EQ. ';') THEN
IOLDCOM=0 ! ;'s are new-fangled.
UTBUF(16:16)=';'
ENDIF
C Set defaults and skip q's.
C
1000 IF (MODESW .EQ. 1) THEN
TMPESC(15-IOLDCOM:15-IOLDCOM)='s'
ELSE
TMPESC(15-IOLDCOM:15-IOLDCOM)='r'
ENDIF
2000 UTBUF(1:15-IOLDCOM) = TMPESC(1:15-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 PCSM
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC' ! Program-wide
LOGICAL DEX ! 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? ')
UTBUF=' '
READ (9,23)UTBUF(1:80)
23 FORMAT(A)
C Get the source file name
C
INQUIRE(FILE=UTBUF(1:80),EXIST=DEX,RECL=ILEN)
IF (DEX) THEN
OPEN(UNIT=12,FILE=UTBUF(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) UTBUF
31 FORMAT(A)
DO 50 I=1,ILEN
J=ICHAR(UTBUF(I:I))
IF (J .EQ. 32 .OR. J .EQ. 27 .OR. J .EQ. 127
X .OR. (J .GE. 9 .AND. J .LE. 13)) THEN
UTBUF(I:I) = CHAR(0)
ELSE
IF (J .GE. 97 .AND. J .LE. 122) THEN
UTBUF(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(UTBUF, ILEN)
C Take checksum of altered line
C
CALL CSUM(PCSM(1:1)//CSMRES(1:1), 2)
C Take checksum of old sum + new sum
C
PCSM(1:1) = CSMRES(1:1)
UTBUF=' '
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(ARGCHS, IALEN)
C
C
C Arguments
C
C ARGCHS (input) -- String to be checksummed
C IALEN (input) -- Length of string to be checksummed
C
C
C Returns
C
C Checksum in byte 1 of CSMRES
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC' ! Program-wide
CHARACTER*512 ARGCHS ! Local string argument
C
C
C Initialization
C
NBYTW = 0 ! Integer for string bytes
RBYTW = 0 ! Integer for result
C
C
C Loop starts
C
DO 10 I=1,IALEN
NBYTW = ICHAR(ARGCHS(I:I))
C Converts to integer
C
RBYTW = MOD(RBYTW + NBYTW, 256)
C Lop off carry bit -- keep 8 bits only
C
10 CONTINUE
C Loop ends
C
CSMRES(1:1) = CHAR(RBYTW)
RETURN
END
C
C **************************************************************************
C
C GTBYTS -- Module to do unformatted input from VTERM
C
C **************************************************************************
C
SUBROUTINE GTBYTS(IAPTR,IACNT,IAWAIT)
C
C
C Arguments
C
C IAPTR (input) -- Last byte of data in KBBUF
C IACNT (input) -- Number of bytes to get
C IAWAIT (input) -- Time-out limit
C
C
C Returns
C
C Either requested bytes placed after KBBUF's previous
C last data byte, or non-zero WAITER (time-out signal)
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC' ! Program-wide
C
C
BUFFSZ(1)=IACNT ! Argument bytes at a time
TMOUT(1)=IAWAIT ! Time limit per QIOW
C
C
20 CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_TIMED ),
X %REF(IOSB(1)),,,
X %REF(KBBUF(IAPTR+1:IAPTR+1)),
X %VAL(BUFFSZ(1)),%VAL(TMOUT(1)),
X %REF(TERTOR(1)),,)
IF ((IOSB(1) .AND. SS$_NORMAL) .NE. 0) THEN
WAITER = 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),,,,,,,,,)
WAITER = 1
GO TO 2000
ELSE
WAITER = -1
GOTO 2000
ENDIF
C
2000 RETURN
END
C
C **************************************************************************
C
C TRMSET -- Black box to do system calls for terminal settings
C
C **************************************************************************
C
SUBROUTINE TRMSET( IARG )
C
C
C Arguments
C
C
C IARG -- Which subfunction is to be done:
C (1) Associate terminal with program and
C save terminal settings
C (2) Set terminal to handle escape sequences
C (3) Restore terminal to original settings
C (4) Set terminal for data transmission which
C will be in "raw" mode
C (5) Disassociate terminal with porgram
C
C
C Returns
C
C none
C
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC'
C
C
C Initialization
C


C
C
C Loop starts
C

GOTO (10,20,30,40,50),IARG
C Computed goto for which settings we need
C
10 CALL SYS$ASSIGN('TT:',CHAN,,)
C Assign terminal for VMS syscalls
C

CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SENSEMODE),,,,
X %REF(DVARR(2)),,,,,)
C Get terminal current settings
C
DO 15 I=1,3
DVSAVE(I)=DVARR(I)
15 CONTINUE
GOTO 2000
C Store in save area and exit
C
20 DVARR(3) = DVARR(3) .OR. TT$M_SCOPE
DVARR(3) = DVARR(3) .OR. TT$M_LOWER
DVARR(3) = DVARR(3) .OR. TT$M_ESCAPE
DVARR(3) = DVARR(3) .OR. TT$M_NOECHO
DVARRW(4) = 511 ! (Width)
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE),,,,
X %REF(DVARR(2)),,,,,)
GOTO 2000
C Superimpose needed terminal settings and exit
C
30 CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE),,,,
X %REF(DVSAVE(2)),,,,,)
GOTO 2000
C Restore saved terminal settings and exit
C
40 DVARR(3) = DVARR(3) .AND. 'FFFFF7FF'X
C Not TT$M_WRAP
DVARR(3) = DVARR(3) .AND. 'FFFFFFF7'X
C Not TT$M_ESCAPE
DVARR(3) = DVARR(3) .AND. 'FFFFFFDF'X
C Not TT$M_TTYSYNC
DVARR(3) = DVARR(3) .AND. 'FFFFFFEF'X
C Not TT$M_HOSTSYNC
DVARR(3) = DVARR(3) .OR. TT$M_EIGHTBIT
DVARR(3) = DVARR(3) .OR. TT$M_PASSALL
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_SETMODE),,,,
X %REF(DVARR(2)),,,,,)
GOTO 2000
C Set terminal for data transmission and exit
C
50 CALL SYS$DASSGN('TT:',CHAN,,)
C Disassociate terminal
C
2000 RETURN
END
C
C **************************************************************************
C
C ESCSND -- Black box to send escape sequences to VTERM
C
C **************************************************************************
C
SUBROUTINE ESCSND( IARG )
C
C
C Arguments
C
C IARG -- Length of escape sequence
C
C Returns
C
C none
C
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC'
C
C
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK),,,,
X %REF(UTBUF(81:81)),%VAL(IARG),,,,)
C Send escape sequence to VTERM
C
2000 RETURN
END
C
C **************************************************************************
C
C NAKIT -- Send NAK packet to VTERM
C
C **************************************************************************
C
SUBROUTINE NAKIT(ILSTSQ)
C
C
C Arguments
C
C ILSTSQ -- Sequence number of last successfully received
C packet
C
C Returns
C
C None.
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC'
C
C
C
KBBUF = CHAR(1)//CHAR(ILSTSQ)//
X CHAR(255-ILSTSQ)//'C'
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK),,,,
X %REF(KBBUF),%VAL(4),,,,)
CALL SYS$QIOW(,%VAL(CHAN), %VAL(IO$_READVBLK .OR.
X IO$M_PURGE),,,,,,,,,)
C NAK packet sent via Syscall (for throughput,
C and because Syscall required anyway for required
C purging of device driver buffer)
C
2000 RETURN
END
C
C **************************************************************************
C
C ACKIT -- Send ACK packet to VTERM
C
C **************************************************************************
C
SUBROUTINE ACKIT(ISQNO)
C
C
C Arguments
C
C ISQNO -- Sequence number of current successfully received
C packet
C
C Returns
C
C None.
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC'
C
C
C
KBBUF = CHAR(1)//CHAR(ISQNO)//
X CHAR(255-ISQNO)//'B'
STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK),,,,
X %REF(KBBUF),%VAL(4),,,,)
C ACK packet sent via Syscall (for throughput)
C
2000 RETURN
END
C
C **************************************************************************
C
C SPCINT -- Special initializations
C
C **************************************************************************
C
SUBROUTINE SPCINT
C
C
C Arguments
C
C None.
C
C Returns
C
C None.
C
C Data declarations
C
INCLUDE 'F8VMS.DEC'
C
C
C
CALL LIB$CRC_TABLE('120001'O, CRC_TABLE)
C Load table per CRC-16 polynomial
C
C
2000 RETURN
END
C
C **************************************************************************
C
C SNDPAK -- Routine to output packets of data
C
C **************************************************************************
C
SUBROUTINE SNDPAK(JJ)
C
C
C Arguments
C
C JJ -- Number of bytes to queue for output via device driver
C
C Returns
C
C None.
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC'
C
C

STS = SYS$QIOW(,%VAL(CHAN), %VAL(IO$_WRITEVBLK),,,,
X %REF(UTBUF),
X %VAL(JJ),,,,)
C Send packet of JJ bytes
C
C
2000 RETURN
END
C
C **************************************************************************
C
C MAKCRC -- Calculate CRC
C
C **************************************************************************
C
SUBROUTINE MAKCRC(J)
C
C
C Arguments
C
C J -- Last byte in buffer to be used in calculation
C
C
C Returns
C
C Calculated CRC-16 bytes in character form in CRCBTS
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC'
C
C
IF (MODESW .EQ. 1) THEN
CRCRES = LIB$CRC(CRC_TABLE(1), 0, KBBUF(2:J))
ELSE
CRCRES = LIB$CRC(CRC_TABLE(1), 0, UTBUF(2:J))
ENDIF
C Calculate CRC for packet bytes 2 to end of data
C in right buffer via table-driven system call
C
CRCBTS(1:1)=CHAR(CRCRES .AND. 255)
CRCBTS(2:2)=CHAR(CRCRES/256)
C Convert to character data as per storage on this
C machine
C
2000 RETURN
END
C
C **************************************************************************
C
C TENSEC -- Ten seconds on wall clock time out routine
C
C **************************************************************************
C
SUBROUTINE TENSEC(IARG)
C
C
C Arguments
C
C IARG -- Subfunction, 1 = Set timer going
C 2 = Check if past 10 sec limit
C
C
C Returns
C
C Non-zero WAITER if subfunction 2 and time-out.
C
C
C
C Data declarations
C
INCLUDE 'F8VMS.DEC' ! Program-wide
INTEGER*4 IDELTA(2) ! For last good packet
INTEGER*4 SYS$READEF ! Read event flag service
C
C
IF (IARG .EQ. 1) THEN
CALL SYS$BINTIM('0 ::10',IDELTA(1))
CALL SYS$SETIMR(1,IDELTA(1),,)
C Initialize for time checking
C
ELSE
STS=SYS$READEF(%VAL(1),IEVFLG)
IF ((STS .AND. SS$_NORMAL) .EQ. 0) THEN
WAITER = -1
ENDIF
ENDIF
C Look at watch
C
C
2000 RETURN
END
C
C **************************************************************************
C
C BLOCK DATA -- Initialize commons
C
C **************************************************************************
C
BLOCK DATA
C
C See 'F8VMS.DEC' for description of program-wide variables
C
INCLUDE 'F8VMS.DEC' ! Program-wide
C
DATA TERTOR,WAITER,TMOUT,IOSB,STS,TBYTES,
X MODESW,CRCFLG,CSMFLG,
X PLEN,DVARR,DVSAVE/21*0/
DATA IO$_READVBLK,IO$_WRITEVBLK,IO$_SETMODE,
X IO$_SENSEMODE,IO$M_TIMED,IO$M_PURGE,
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,'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