Category : Miscellaneous Language Source Code
Archive   : XMODEMAU.ZIP
Filename : XMODEMAU.FOR

 
Output of file : XMODEMAU.FOR contained in archive : XMODEMAU.ZIP
program xmodem_au
c MODEM7-type program to send and
c receive files with checksums or CRC and automatic
c re-transmission of bad blocks.
c translated to VAX Fortran V3.0 from TMODEM.C
c and enhanced according to time-outs and CRC
c in XMODEM50.ASM
c J.James Belonis II
c Physics Hall FM-15
c University of Washington
c Seattle, WA 98195
c (206) 545-8695
c
c modified somewhat beginning 9/2/86 by
c
c David Swanger
c Academic Computing Services
c 200 L Building
c Auburn University, AL 36849
c (205)-826-4813
c
c TMODEM.C written by Richard Conn, Eliot Moss, and Lauren
c Weinstein
c
c Should include 1k block size capability.
c Should remove unused variable declaration 'ic' several places
c
c 9/11/86 Modified front-end structure, Added following commands: !AU
c SEND, RECEIVE !AU
c 9/ 3/86 Changed prompt to XMODEM>, added following commands: !AU
c EXIT, HELP, SHOW, BINARY, TEXT, CRC, NOCRC !AU
c 9/ 2/86 Replaced blank stripping routines with STR$TRIM routines. !AU
c
c 11/30/85 Version 5.60 JJB merged 3/5/85 Doug W. Potter text conv "on the fly"
c 11/14/85 added error message if neither SEND nor RECEIVE
c 10/6/85 added blocknumber printout if getack fails.
c 2/ 4/84 Version 5.54 fixed handling of CR without LF in CTOV
c so now CR passed through ok if not part of CRLF.
c 6/23/84 fixed improper READONLY, open .WRK files carriagecontrol='NONE'
c made EAT routine continue eating 'til nothing left to eat.
c increased text conversion capability to 500 character lines.
c All known bugs are again fixed.
c 6/20/84 Version 5.53 increased filename ttyinlim's to 2 seconds which
c greatly improved reliability of BATCH mode on heavy loaded VAX
c 5/18/84 Version 5.52 makes OPENs of OLD files READONLY so can work in
c unowned directories
c 3/21/84 Version 5.51 replaces non-alphanumeric CP/M filename characters
c by letter "A" when making a VAX filename,
c commented out bad PRINT.
c 3/17/84 miscellaneous error messages added.
c 3/13/84 reserved space in cancel for eating characters to avoid access viol
C 3/13/84 increased RECVFILE data block timeout to 2 sec
c 2/27/84 Version 5.5 incorporated improvements by Steve Gill
c GETACK timeout and garbage loop and NAK, CAN detection
c RECVFILE receive data block with timeout
c TTYIN routine removed since replaced everywhere by TTYINLIM
c 1/25/84 properly placed CALL PASSALL in main program so not miss parity bit
c in sendfn filename checksum
c 1/ 8/84 corrected last known bugs
c 1/ 2/84 Version 5.4 Added batch
c 12/31/83 Version 5.3 Added wildcard filenames(but not yet batch) and
c streamlined option parsing and allowed CRC TEXT
c found and fixed blank trim miscalculation
c again (CONN apparently got old version)
c XMODEM.LOG and XMODEM.WRK put in SYS$SCRATCH directory
c (usually user's main) if can't open in current directory
c 12/27/83 Version 5.2 Speeded up SEND by doing only one TTYOUT call per block.
c no longer hogs CPU at 9600 baud (only 15-20 percent of cpu time)
c included QIO.DCK so only one file XMODEM.FOR is needed.
c 6/30/83 Modified, restructured, and VAX/VMS text file
c conversion added by Richard Conn
c 1/17/83 touched up filename display and comments.
c 1/14/83 including timeouts and CTRL-X cancellation
c and CRC capability
c
c keeps a log file of error messages ( deletes it if no errors )
c sets terminal driver to eightbit, passall
c may need altypeahd if faster than 1200 baud works to 9600 baud at least.
c needs PHY_IO privilege for passall ? apparently not on UWPhys VAX
c nor on ACC VAX
c many debugging statements left in as comments

c declare variables

include '($rmsdef)' ! for LIB$FIND_FILE
INTEGER*2 CHAN,STATUS(4),counter,start,dot
COMMON /QIO/ CHAN,STATUS

character*128 line, filein, file, filec, filed, options, new_line
integer seploc, context, istat, length, lengthin, oplength
logical openok, sendopt, recvopt, textopt
logical getfn, sendfn
logical*1 continue, loop

logical batchopt,firstbatch
common /batch/batchopt,firstbatch

integer errorcount
common /err/errorcount

integer high,low
byte highbyte,lowbyte
common /crcval/high,low
equivalence (high,highbyte)
equivalence (low,lowbyte)

logical crc
byte checksumbyte
integer checksum
common /checks/checksum,crc
equivalence (checksum,checksumbyte)

equivalence (ic,c)

external giveup

c define ascii characters
parameter NUL=0 !ignore at SOH time
parameter SOH=1 !start of header for sector
parameter EOT=4 !end of transfer
parameter ACK=6 !acknowlege sector
parameter BEL=7 !bell warning if stupid
parameter NAK=21 !not acknowlege sector
parameter CAN=24 !cancel transfer
parameter CRCCHAR='C' !CRC indicating character

c timeouts
parameter respnaklim=10 !seconds to allow for response to NAK
parameter naklim=10 !seconds to allow to receive first NAK
parameter eotlim=10 !seconds to wait for EOT acknowlege

parameter errlim=10 !max errors on a sector

c logicals

batchopt=.false.
firstbatch=.false.
textopt=.false.
sendopt=.false.
recvopt=.false.
crc=.false.

c define an exit routine to get control on all exits to turn off
c passall and for debug cleanup
call userex( giveup )

c assign terminal channel for QIO calls to send raw bytes.
call sys$assign('TT',chan,,)

c get command line
10 loop = .true.
do while (loop .eq. .true.)
sendopt=.false.
recvopt=.false.
continue=.false.
length=0
do while (length .eq. 0)
call lib$get_foreign(line,'XMODEM>',,)

c Trim leading blanks. STR$FIND_FIRST_NOT_IN_SET should work here but
c I couldn't get it to work properly.

do counter = 1,128
if(line(counter:counter).ne.' ') then
goto 20
endif
enddo
20 line = line(counter:128)

c Trim trailing blanks and convert string to upper case.

istat=str$trim(line,line,length)
if(length .ne. 0) then
istat=str$upcase(line,line)
filein = ' '
seploc = index( line(1:length+1),' ' ) ! +1 so find end if one argument
options=line(1:seploc-1)
istat=str$trim(options,options,oplength)
filein=line(seploc+1:length)
lengthin=length-seploc
if(lengthin.gt.0) then ! make sure not index infinite length string
if( index( filein(1:lengthin), ' ' ) .ne. 0 ) then
print *,char(bel)//' Too many arguments.'
length = 0
endif
endif
endif
enddo

c Set file type BINARY
if((line(1:length).eq.'BINARY').or.
* (line(1:length).eq.'BINAR') .or.
* (line(1:length).eq.'BINA') .or.
* (line(1:length).eq.'BIN') .or.
* (line(1:length).eq.'BI')) then
textopt = .false.

c Enable CRC checking
elseif((line(1:length).eq.'CRC').or.
* (line(1:length).eq.'CR') .or.
* (line(1:length).eq.'C')) then
crc = .true.

c exit
elseif((line(1:length).eq.'EXIT').or.
* (line(1:length).eq.'EXI') .or.
* (line(1:length).eq.'EX')) then
call exit

c help
elseif((line(1:length).eq.'HELP').or.
* (line(1:length).eq.'HEL') .or.
* (line(1:length).eq.'HE') .or.
* (line(1:length).eq.'H') .or.
* (line(1:length).eq.'?')) then
c type *
c type *,'COMMANDS - Definitions'
c type *,'-------- -----------'
c type *
c type *,'BINARY - Default file type set to BINARY'
c type *,'CRC - CRC checking set to default'
c type *,'EXIT - Leave XMODEM'
c type *,'HELP - Display this help screen'
c type *,'NOCRC - Disable CRC checking'
c type *,'RECEIVE - Receive file'
c type *,'SEND - Send file'
c type *,'SHOW - Show Default settings'
c type *,'TEXT - Default file type set to BINARY'
c type *

istat=lib$spawn('HELP XMODEM')
if (.not. istat) call lib$stop (%val(istat))

c Disable CRC checking
elseif((line(1:length).eq.'NOCRC').or.
* (line(1:length).eq.'NOCR') .or.
* (line(1:length).eq.'NOC')) then
crc = .false.
c Receive file
elseif((options(1:oplength).eq.'RECEIVE').or.
* (options(1:oplength).eq.'RECEIV') .or.
* (options(1:oplength).eq.'RECEI') .or.
* (options(1:oplength).eq.'RECE') .or.
* (options(1:oplength).eq.'REC') .or.
* (options(1:oplength).eq.'RE') .or.
* (options(1:oplength).eq.'R')) then
recvopt = .false.
if(filein.eq.' ') then

istat=lib$get_foreign(new_line,'_Enter filename: ',,)
if(new_line .eq. ' ') then
recvopt = .false.
type *,char(bel),' Receive aborted.'
else
filein=new_line
recvopt=.true.
continue = .true.
istat=str$trim(filein,filein,lengthin)
endif
else
recvopt=.true.
continue=.true.
endif
c Send file
elseif((options(1:oplength).eq.'SEND').or.
* (options(1:oplength).eq.'SEN') .or.
* (options(1:oplength).eq.'SE') .or.
* (options(1:oplength).eq.'S')) then
if(filein.eq.' ') then
istat=lib$get_foreign(new_line,'_Enter filename: ',,)
if(new_line .eq. ' ') then
sendopt = .false.
type *,char(bel),' Send aborted.'
else
filein=new_line
sendopt = .true.
continue = .true.
istat=str$trim(filein,filein,lengthin)
endif
else
sendopt=.true.
continue=.true.
endif
c show defaults
elseif((line(1:length).eq.'SHOW').or.
* (line(1:length).eq.'SHO') .or.
* (line(1:length).eq.'SH')) then
type *
type *,' Defaults:'
type *
if(textopt.eq..false.) then
type *,' BINARY File Type'
else
type *,' TEXT File Type'
endif
if(crc.eq..false.) then
type *,' CRC checking disabled'
else
type *,' CRC checking enabled'
endif
type *

c Set file type TEXT
elseif((line(1:length).eq.'TEXT').or.
* (line(1:length).eq.'TEX') .or.
* (line(1:length).eq.'TE') .or.
* (line(1:length).eq.'T')) then
textopt = .true.

c Compatibility (somewhat) with earlier XMODEM user interface.

else

i=0
if( index(options,'B').NE.0 ) then
batchopt=.true.
firstbatch=.true.
i=i+1
endif
if( index(options,'T').NE.0 ) then
textopt=.true.
i=i+1
endif
if( index(options,'S').NE.0 ) then
sendopt=.true.
i=i+1
endif
if( index(options,'R').NE.0 ) then
recvopt=.true.
i=i+1
endif
if( index(options,'C').NE.0 ) then
crc=.true.
i=i+1
endif

c check options
continue = .false.
if(i.ne.seploc-1) then
print *,char(BEL),' Incorrect syntax ignored.'
elseif(sendopt.and.recvopt) then ! send and receive simultaneously
print *,char(BEL),' Incompatible options SEND and RECEIVE'
elseif( lengthin.gt.0 .and. (recvopt.and.batchopt) ) then
print *,char(BEL),' Filename ignored on batch receive',char(BEL)
else
continue = .true.
endif
endif


c If we entered a permissable SEND or RECEIVE command, then SEND or RECEIVE.

if((sendopt.or.recvopt).and.continue.eq..true.) then
context=0 ! initial FAB pointer for LIB$FILE_FIND
call passall(CHAN,.TRUE.) ! turn on passall so typeahead
! not strip parity on unsolicited chars
c BATCH option loop comes here
100 continue !GOTO at end comes here for next filename

c open separate log file for each transferred file.
openok=.true.
open(8,file='XMODEM.LOG', iostat=istat,
1 carriagecontrol='LIST',status='NEW')
if(istat.ne.0) then
if(firstbatch) then
print *,' Can''t open XMODEM.LOG in this directory,'
print *,' putting it in your main directory.',char(BEL)
endif
open(8,file='SYS$SCRATCH:XMODEM.LOG',
1 carriagecontrol='LIST',status='NEW')
openok=.false.
endif

if(recvopt) then ! wildcards done on other computer
if(.not.batchopt) then
file=filein
length=lengthin
endif
else ! sending, need name(s)
istat=lib$find_file(filein(1:lengthin),file,context,,)
if(istat.eq.rms$_nmf) then ! no more files
if(batchopt) then !await rcvr's request for filename
call waitnlp(80)
call ttyout(ACK,1) ! tell yes file
endif
call ttyout(EOT,1) ! tell other computer no more
! it receives EOT as first
! char of expected filename
write(8,*) ' All transfers complete.'
close(8,dispose='delete') ! .LOG file
call exit
endif
if(.not.istat) then
if(firstbatch.or..not.batchopt) then
type *,' File not found -- Incorrect file name.',char(bel)
type *
recvopt = .false.
sendopt = .false.
endif
endif
istat = str$trim(line,line,length)
endif

if( sendopt ) then
c send
if(batchopt) then
c make a reasonable filename for CP/M
call cleansfn( file(1:length),filec,leng)
if(firstbatch) then
print *,' sending BATCH mode, please run receiver'
endif
endif
if(textopt) then
if(.not.batchopt) then ! not batch
print *,' Sending Text File: ',file
c print *,' Do not run your receiver yet.'
endif
if(batchopt) call sendfn( filec(1:leng) )
call sendfile( file(1:length) , textopt)
else ! not text
if(.not.batchopt) then
print *,' Sending File: ',file
else ! batchopt
call sendfn( filec(1:leng) )
endif
call sendfile( file(1:length) , textopt)
endif

elseif(recvopt) then
c receive
if(batchopt) then
if(firstbatch) then
print *, ' Receiving BATCH please run sender'
endif
if(.not.getfn(filed,leng)) then
call ttyout(EOT,1)
write(8,*) ' All transfers complete.'
close(8,dispose='delete') ! log file
call exit
endif
call cleangfn(filed(1:leng),file,length)
endif
if(textopt) then
if(.not.batchopt) then
print *,' Receiving Text File: ',file(1:length)
endif
call recvfile( file(1:length) , textopt)
else ! not text
if(.not.batchopt) then
print *,' Receiving File: ',file(1:length)
endif
call recvfile( file(1:length) , textopt)
endif
endif

if( batchopt ) then
firstbatch=.false. ! don't print informational messages
! from now on
goto 100 ! get next filename
endif

call passall(CHAN,.FALSE.)
sendopt=.false.
recvopt=.false.
endif
enddo

end
c------------------------------------------------------
subroutine cleansfn(file,fileclean,length)
character*(*) file, fileclean
integer length
c clean send file name
c remove too-specific parts of filename (directory and version)
c and make understandable by CP/M 11 char no dot, last 3 for type

fileclean=' '
start=index( file,']' )+1
end=index( file, ';' )-1
dot = start-1 + index( file(start:end),'.' ) ! VMS guarantees a dot
if(start.ne.dot) fileclean(1:)=file(start:dot-1)
if(dot.ne.end) fileclean(9:)=file(dot+1:end)
! note: may overwrite last char of vax 9 char filename before dot
length=11
return

end

c-------------------------------------
subroutine sendfn(file)

character*(*) file
c sends name for batch checksummed send

byte c
integer ic
equivalence (ic,c)

logical ttyinlim

logical crc
byte checksumbyte
integer checksum
common /checks/checksum,crc
equivalence (checksum,checksumbyte)

parameter BDNMCH=117 ! badname character 'u'
parameter OKNMCH=6 ! good name character
parameter ACK=6 ! acknowlege character
parameter EOF=26 ! filename terminator

100 continue
call waitnlp(80) ! await NAK
call ttyout(ACK,1) ! tell receiver a filename follows

checksum=0
do i=1,len(file)
c=ichar( file(i:i) )
checksum=checksum+c
call ttyout(c,1)
200 if( .not.ttyinlim(c,1,2) ) then
write(8,*) ' timeout during name'
goto 300
endif
if(c.ne.ACK) goto 200 ! let it time out if bad eat chars ?
enddo
checksum=checksum+EOF
call ttyout(EOF,1)
if( .not.ttyinlim(c,1,2) ) then ! checksum from receiver (MODEM765.ASM
! did not check for timeout)
write(8,*) ' timeout awaiting checksum in sendfn'
goto 300
endif
if( checksumbyte.ne.c ) then
c bad filename transmission
write(8,*) ' checksum,byte,c='
write(8,'(3z10)') checksum,checksumbyte,c
300 continue
call ttyout(BDNMCH,1) ! lower case u (but receiver
! only cares that it was not ACK)
goto 100
endif
call ttyout(OKNMCH,1) ! ACK
return
end
c---------------------------------------------------------
subroutine waitnlp(sec)
integer sec
c Await NAK, Cancel if not here in sec seconds, or if CAN, ignore garbage

integer count
logical ttyinlim
byte c
parameter NAK=21
parameter CAN=24

count=0
100 if( .not.ttyinlim(c,1,1) ) then ! timeout
count=count+1
write(8,*) ' waitnlp passed limit'
if(count.ge.sec) call cancel ! passed limit
goto 100
elseif( c.eq.CAN ) then
write(8,*)' waitnlp canceled'
call cancel
elseif( c.ne.NAK ) then ! ignore garbage
write(8,*) ' waitnlp not NAK, got decimal=',c
goto 100
endif
c must have gotten NAK
return


end
c---------------------------------------
logical function getfn(file,length)
character*(*) file
integer length
c get the characters of the batch mode filename (return false if no more)
c note: must be declared in callers too.

logical ttyinlim, hsnak

integer ic ! so char(ic) works
byte c

logical crc
byte checksumbyte
integer checksum
common /checks/checksum,crc
equivalence (checksum,checksumbyte)

parameter EOT=4 ! end of batch transfer
parameter ACK=6 ! acknowledge character
parameter OKNMCH=6 ! OK name character ACK
parameter EOF=26 ! end of filename

getfn=.true.
flen=len(file)
100 checksum=0
length=0
file=' ' ! blank filename
c handshake to make sure synchronized
150 if( .not.hsnak() ) goto 150 ! may hang 'til CTRL-X

200 if( .not.ttyinlim(ic,1,2) ) then
write(8,*) ' Time out receiving filename=',file
goto 100 ! give up and restart handshaking
endif
length=length+1
file(length:length)=char(ic)
checksum=checksum+ic

if(ic.eq.EOT) then ! no more filenames
getfn=.false.
return
endif

if(ic.eq.EOF) then
length=length-1
call ttyout(checksumbyte,1) ! send calculated checksum
if(.not.ttyinlim(c,1,2) ) then ! get verification of checksum
! MODEM765 had no timeout check
write(8,*) ' timeout awaiting checksum ok'
goto 100 ! restart handshake
endif
if(c.eq.OKNMCH) return

write(8,*) ' Checksum error, verification c=',c
goto 100 ! restart handshaking
endif

if(length.ge.flen) then
write(8,*) ' Too many characters in filename'
goto 100 ! start again at NAK
endif

call ttyout(ACK,1)
goto 200 ! get next char

end

c--------------------------------------
logical function hsnak()
c true if get ACK in response to NAK, c returns null if timeout ???
c note: must be declared in callers too.

byte c
logical ttyinlim
parameter ACK=6
parameter CAN=24
parameter NAK=21

call ttyout(NAK,1)
c checking for CAN is the only way to get out of the loop that
c calls hsnak
if( .not.ttyinlim(c,1,2) ) then ! timeout don't care what c is
write(8,*) ' hsnak timeout'
hsnak=.false.
elseif(c.eq.ACK) then
hsnak=.true.
elseif(c.eq.CAN) then
write(8,*) ' hsnak canceled'
call cancel
c else ! bad character, ignore
endif
return

end
c------------------------------------------------------
subroutine cleangfn(file,fileclean,length)
character*(*) file, fileclean
integer length
c clean get file name
c and make understandable by VAX 13 char with dot, last 3 for type
c also replaces non-alphanumeric by "A"
integer leng

leng=index(file//' ',' ')-1 ! add blank in case none in filename
leng=min(leng,8) ! in case filename and type run together
fileclean(1:)=file(1:leng)//'.'//file(9:)
length=index(fileclean,' ')-1
do i=1,leng
if( (fileclean(i:i).ge.'A' .and. fileclean(i:i).le.'Z')
1 .or.
1 (fileclean(i:i).ge.'0' .and. fileclean(i:i).le.'9') )
1 then
c do nothing
else ! not alphanumeric, replace by legal character
fileclean(i:i)='A'
endif
enddo
do i=leng+2,length
if( (fileclean(i:i).ge.'A' .and. fileclean(i:i).le.'Z')
1 .or.
1 (fileclean(i:i).ge.'0' .and. fileclean(i:i).le.'9') )
1 then
c do nothing
else ! not alphanumeric, replace by legal character
fileclean(i:i)='A'
endif
enddo
return
end
c----------------------------------------------------------------
c send file
subroutine sendfile(file, textopt)
character*(*) file
logical textopt

c declare variables

INTEGER*2 CHAN,STATUS(4)
COMMON /QIO/ CHAN,STATUS

byte sectorread(128), sector(130), send(133), c
equivalence (send(4), sector(1), sectorread(1) )

integer nakwait, stat, ic
logical ttyinlim
logical charintime, acked
logical eof

logical batchopt, firstbatch
common /batch/batchopt,firstbatch

integer blocknumber
byte blockbyte
equivalence (blocknumber,blockbyte)

integer notblocknumber
byte notblockbyte
equivalence (notblocknumber,notblockbyte)

integer errorcount
common /err/errorcount

integer high,low
byte highbyte,lowbyte
common /crcval/high,low
equivalence (high,highbyte)
equivalence (low,lowbyte)

logical crc
byte checksumbyte
integer checksum
common /checks/checksum,crc
equivalence (checksum,checksumbyte)

equivalence (ic,c)

c define ASCII characters
parameter NUL=0
parameter SOH=1
parameter EOT=4
parameter ACK=6
parameter NAK=21
parameter CAN=24
parameter CRCCHAR='C'
c timeouts
parameter respnaklim=10
parameter naklim=10
parameter eotlim=10
parameter errlim=10

if (textopt) then
call vtocopen(file, stat)
else ! should not delete, so readonly is ok
open(9,name=file,iostat=stat,status='OLD',readonly)
endif

if(stat) then
if(.not.batchopt) then
print *,'Can''t open ',file,' for send.'
endif
write(8,*) 'Can''t open ',file,' for send.'
call cancel
endif
if( .not.batchopt ) then
print *,' Please Run Your Receiver --'
type *
type *
endif
errorcount=0
blocknumber=1
nakwait=0

c await first NAK (or 'C') indicating receiver is ready
200 charintime=ttyinlim(c,1,naklim) ! return NUL if timeout
if( .NOT.charintime ) then
write(8,*) 'initial NAK or C timeout, trying again'
nakwait=nakwait+1
c give the turkey 80 seconds to figure out how to receive a file
if(nakwait.ge.80/naklim) call cancel
goto 200
elseif(c.EQ.NAK) then
crc=.false.
write(8,*) ' CHECKSUM mode'
elseif(c.EQ.CRCCHAR) then
crc=.true.
write(8,*) ' CRC mode'
elseif(c.EQ.CAN) then
call cancel
else
c unrecognized character
write(8,*) 'unrecognized first NAK=',c
nakwait=nakwait+1
if(nakwait.ge.80/naklim) call cancel
goto 200
endif

300 continue
c send new sector
c use equivalence so not need to do inefficient implicit do loop in read
if (textopt) then
call vtocbuf(sectorread, eof)
if (eof) goto 500
else
read(9, 1000, end=500) sectorread
endif
1000 format(128a)
errorcount=0
400 continue
c send sector
send(1)=SOH
c note: equivalence used for fast integer to byte conversion
c without byte overflow problems
send(2)=blockbyte
notblocknumber=not(blocknumber)
send(3)=notblockbyte

c sector already in sending buffer done by equivalence

checksum=0
call clrcrc
c calc checksum or crc
if(crc) then
c put all bytes + two finishing zero bytes through updcrc
sector(129)=0
sector(130)=0
call updcrc( sector,130 )
send(132)=highbyte
send(133)=lowbyte
c actually send
call ttyout(send,133)
else
do i=1,128
checksum=checksum+sector(i)
enddo
c this sends low order byte of checksum
send(132)=checksumbyte
call ttyout(send,132)
endif

c sector sent, see if receiver acknowleges
c getack attempts to get ACK
c if not, repeat sector

call getack(acked)
if(.NOT.acked) then
write(8,*) ' not acked blocknumber=',blocknumber
goto 400
endif

c ACK received, send next sector
blocknumber=blocknumber+1
goto 300

c end of file during read. finish up sending.
500 continue
call ttyout(EOT,1)
c getack attempts to get ACK up to errlim times
call getack(acked)
if( .NOT.acked ) goto 500

c print *,' This file Sending complete.'
write(8,*) ' This file Sending complete.'
close(9)
close(8,dispose='DELETE') ! the .LOG file
return
end

c----------------------------------------------------------------
c receive file
subroutine recvfile(file, textopt)
character*(*) file
logical textopt

c declare variables

INTEGER*2 CHAN,STATUS(4)
COMMON /QIO/ CHAN,STATUS

byte c, notc, ck
integer blocknumber, inotc, notnotc, secbytes, stat
integer testblock, testprev, ic
logical ttyinlim, errwrite
logical charintime, firstsoh

byte sector(130),sectorwrite(128)
equivalence (sector,sectorwrite)

logical batchopt,firstbatch
common /batch/batchopt,firstbatch

integer errorcount
common /err/errorcount

integer high,low
byte highbyte,lowbyte
common /crcval/high,low
equivalence (high,highbyte)
equivalence (low,lowbyte)

logical crc
byte checksumbyte
integer checksum
common /checks/checksum,crc
equivalence (checksum,checksumbyte)

equivalence (ic,c)

c define ASCII characters
parameter NUL=0
parameter SOH=1
parameter EOT=4
parameter ACK=6
parameter NAK=21
parameter CAN=24
parameter CRCCHAR='C'
c timeouts
parameter respnaklim=10
parameter naklim=10
parameter eotlim=10
parameter errlim=10
parameter datalim=2 ! timeout for data block receive
! 1 second wouldn't work on moderately loaded
! VAX, more may be necessary if heavily loaded

if (textopt) then
call ctovopen(file, stat)
else
open(7,name=file,recl=128,status='NEW',iostat=stat,
1 carriagecontrol='NONE',recordtype='FIXED')
endif
if(stat) then
if(batchopt) then
print *,' Can''t open ',file,' for receive.'
endif
write(8,*) ' Can''t open ',file,' for receive.'
call cancel
endif

if(.not.batchopt) then
print *,' Please Send Your File --'
type *
type *
endif

if(crc) then
secbytes=130
else ! checksum mode
secbytes=129
endif

firstsoh=.false.
errorcount=0
blocknumber=1

c start the sender by letting ttyinlim time-out in getack routine
c so it sends a NAK or C
goto 999

800 continue
c must allow enough time for other's disk read (xmodem50.asm allows 10sec)
charintime=ttyinlim(c,1,respnaklim)
c if no char for a while, try NAK or C again
if( .NOT.charintime ) then
write(8,*) ' no response to NAK or C, trying again'
goto 999
endif
c else received a char so see what it is
if(c.eq.NUL) goto 800 ! ignore nulls here for compatablity with old
! versions of modem7
if(c.EQ.CAN) then
write(8,*) ' Canceled. Aborting.'
call exit
endif

if(c.NE.EOT) then
if(c.NE.SOH) then
write(8,*) ' Not SOH, was decimal ',c
goto 999
endif
firstsoh=.true.

c character was SOH to indicate start of header
c get block number and complement
charintime=ttyinlim(c,1,1)
if(.not.charintime) then
write(8,*) ' timeout awaiting block number'
goto 999
endif

charintime=ttyinlim(notc,1,1)
if(.not.charintime) then
write(8,*) ' timeout awaiting block complement'
goto 999
endif
inotc=notc ! make integer for "not" function
notnotc=iand( not(inotc),255 ) ! mask back to byte

c c is low order byte of ic via equivalence statement
if(ic.NE.notnotc) then
write(8,*) ' block check bad.'
goto 999
endif
c block number valid but not yet checked against expected

c clear checksum and CRC
checksum=0
call clrcrc

c receive the sector and checksum bytes in one call (for speed) and to
c keep from hogging VAX cpu time at high baud rates.
c secbytes is 129 for checksum, 130 for CRC
charintime=ttyinlim(sector,secbytes,datalim)
C check for time out
if(.not.charintime) then
c print *,' Timeout on data block read'
write (8,*) ' Timeout on data block read'
goto 999
endif

if(crc) then
c put data AND CRC bytes through updcrc
call updcrc(sector,secbytes)
c if result non-zero, BAD.
if(highbyte.NE.0 .OR.
1 lowbyte.NE.0 ) then
c print *,' CRC, high,low='
write(8,*) ' CRC, high,low='
c print 3000, highbyte,lowbyte
write(8,3000) highbyte,lowbyte
3000 format(2z10)
goto 999
endif
else
c don't add received checksum byte to checksum
do i=1,secbytes-1
checksum=checksum+sector(i)
enddo
ck=sector(129)

if( checksumbyte.NE.ck ) then
write(8,*) ' bad checksum'
goto 999
endif
endif

c received OK so we can believe the block number, see which block it was
c mask it to be one byte
testblock=iand(blocknumber,255)
testprev=iand( blocknumber-1 ,255)
if( ic.EQ.testprev) then
write(8,*) ' prev. block again, out of synch'
c already have this block so don't write it, but ACK anyway to resynchronize
goto 985
elseif( ic.NE.testblock ) then
write(8,*) ' block number bad.'
goto 999
endif
c else was expected block

c write before acknowlege so not have to listen while write.
c equivalence so not need inefficient implicit do loop
if (textopt) then
call ctovbuf(sectorwrite, errwrite, .false.)
if(errwrite) goto 900
else
write(7,2000,err=900) sectorwrite
endif
2000 format(128a)
goto 975

900 write(8,*) ' Can''t write sector. Aborting.'
call cancel

975 continue
c received sector ok, wrote it ok, so acknowlege it to request next.
blocknumber=blocknumber+1
c comes here if re-received the previous sector
985 continue
errorcount=0
call ttyout(ACK,1)
goto 800

c else error so eat garbage in case out of synch and try again
999 continue
call eat
write(8,*) ' receive error NAK, block=',blocknumber
if(crc.AND..NOT.firstsoh) then
c keep sending 'C' 'til receive first SOH
call ttyout(CRCCHAR,1)
else
call ttyout(NAK,1)
endif
errorcount=errorcount+1
998 if(errorcount.GE.errlim) then
write(8,*) ' Not receive block. Aborting.'
c delete incompletely received file
close(7,dispose='DELETE')
call cancel
endif
c retry
goto 800
endif

c EOT received instead of SOH so file receive done.
c should keep sending ACK 'til no more EOT's ?
if (textopt) call ctovbuf(sectorwrite, err, .true.)
close(7)
call ttyout(ACK,1)
call ttyout(ACK,1)
call ttyout(ACK,1)

write(8,*) ' Completed.'
c transfer ok, so delete the error log file.
close(8,dispose='DELETE')
return
end

c-------------------------------------------------------------
subroutine ctovopen(output, stat)
c open text file for write
c dwp 3/4/85
implicit none
character*80 output
integer stat

parameter linelen=2000 ! if longer lines needed, change this
! and the ctovbuf routine 'line' declaration

c set maximum output record length (fortran default is 133)
open(7,file=output,status='NEW',carriagecontrol='LIST',
1 iostat=stat,recl=linelen)

return
end
c-------------------------------------------------------------
subroutine ctovbuf(record, err, eof)
c write received record in text format
c dwp 3/4/85
implicit none
byte record(128)
logical err, eof

parameter linelen=2000 ! if longer lines needed, change this
! and the 'line' declaration below
character*2000 line
byte lastchar, rchar
integer len, i, rtmp

data len/0/
parameter CR=13
parameter LF=10
parameter CTRLZ=26

c The following is proper logic. DWP did not follow it in this routine.
c getchar (read new record if no input characters left)
c if EOF on input, write line and exit
c if CR then
c if getchar LF then write line
c else put back char and putchar CR into line (error if too long)
c endif
c else putchar (write error message if line too long)
c endif
c loop

if (eof) then
if(len.gt.0) then ! flush last line
write(7,2000) line(1:len)
write(8, *) 'incomplete last line'
len=0
endif
return
endif

do i = 1,128
rtmp = record(i)
rchar = iand(rtmp, 127) ! strip parity
if (rchar .eq. CTRLZ) then
c may not properly output CR if last char before CTRLZ
return ! eof (CTRLZ)
elseif (rchar .eq. LF) then
c should do this only if CRLF !
write(7, 2000, err=2100) line(1:len)
len = 0
elseif (rchar .eq. CR) then ! do nothing at all
else
if(len.ge.linelen) then
write(8,*)' Out line too long.'
len=linelen ! avoid writing beyond bounds
c print *,' too long line=',line
write(7, 2000, err=2100) line(1:len)
len = 0
endif
if (lastchar .eq. CR) then ! it won't be here on LF
len = len + 1
line(len:len) = char(CR)
endif
len = len + 1
line(len:len) = char(rchar)
endif
lastchar = rchar
enddo
err = .false.
return

2100 err = .true.
return

2000 format(a)
end
c-------------------------------------------------------------
subroutine vtocopen(input, stat)
c open text file for read
c dwp 3/4/85
implicit none
character*80 input
integer stat

open(9,file=input,status='OLD',iostat=stat,READONLY)

return
end
c-------------------------------------------------------
subroutine vtocbuf(record, eof)
c read record from text file for send
c dwp 3/4/85
implicit none
byte record(128)
logical eof

integer point, i
parameter CTRLZ=26
character*1 c
logical eofflag

data eofflag /.false./

if (eofflag) then
eof = .true.
eofflag = .false.
return
endif
eof=.false.
do point=1,128
call getv(c,eofflag)
if (eofflag) then
if (point .eq. 1) then
eof = .true.
eofflag = .false.
return
endif
do i=point,128
record(i)=CTRLZ
enddo
return
else
c strip parity
record(point) = iand(ichar(c), 127)
endif
enddo
return

end
c----------------------------------------------
subroutine getv(inchar,eof)
c dwp 3/4/85
c get character from text file
c returns eof if end of file (no character)
implicit none
character*1 inchar
logical eof

character*255 line
integer len, pos
logical firsttime
common/lincom/pos,len,line

data pos, len /0, -1/ ! read on first try

200 continue
pos=pos+1
if(pos.gt.len) then
read(9,1000,end=100)len,line(1:len)
1000 format(q,a)
line(len+1:len+2) = char(13) // char(10) ! append CR-LF
len = len + 2
pos = 1
endif
inchar=line(pos:pos)
c DWP wants to reject NUL, I do not.
return
c EOF
100 continue
pos=0 ! ready for next file
len=-1
eof=.true.
return
end
c-----------------------------------------------------------
subroutine clrcrc
c clears CRC
integer high,low
byte highbyte,lowbyte
common /crcval/high,low
equivalence (high,highbyte)
equivalence (low,lowbyte)

high=0
low=0
return
end
c-----------------------------------------------------------
subroutine updcrc(bbyte,n)
byte bbyte(*)
integer n
c updates the Cyclic Redundancy Code
c uses x^16 + x^12 + x^5 + 1 as recommended by CCITT
c and as used by CRCSUBS version 1.20 for 8080 microprocessor
c and incorporated into the MODEM7 protocol of the CP/M user's group
c
c during sending:
c call clrcrc
c call updcrc for each byte
c call fincrc to finish (or just put 2 extra zero bytes through updcrc)
c result to send is low byte of high and low in that order.
c
c during reception:
c call clrcrc
c call updcrc all bytes PLUS the two received CRC bytes must be passed
c to this routine
c then zero in high and low means good checksum
c
c see Computer Networks, Andrew S. Tanenbaum, Prentiss-Hall, 1981
c
c must declare integer to allow shifting
integer byte
integer bit,bitl,bith

integer high,low
byte highbyte,lowbyte
common /crcval/high,low
equivalence (high,highbyte)
equivalence (low,lowbyte)

do i=1,n
byte=bbyte(i)

do j=1,8
c get high bits of bytes so we don't lose them when shift
c positive is left shift
bit =ishft( iand(128,byte), -7)
bitl=ishft( iand(128,low), -7)
bith=ishft( iand(128,high), -7)
c get ready for next iteration
newbyte=ishft(byte,1)
byte=newbyte ! introduced dummy variable newbyte
! to avoid "access violation"
c shift those bits in
low =ishft(low ,1)+bit
high=ishft(high,1)+bitl

if(bith.eq.1) then
high=ieor(16,high)
low=ieor(33,low)
endif
enddo
enddo
return
end
c-----------------------------------------------------------
c subroutine fincrc
c finish CRC calculation for sending result in high, low
c merely runs updcrc with two zero bytes
c NEVER ACTUALLY USED, I JUST PASS TWO EXTRA ZERO BYTES TO UPDCRC WITH SECTOR
c integer high,low
c byte highbyte,lowbyte
c common /crcval/high,low
c equivalence (high,highbyte)
c equivalence (low,lowbyte)
c
c byte=0
c call updcrc(byte)
c call updcrc(byte)
c return
c end
c-----------------------------------------------------------
subroutine eat
c eats extra characters 'til pause used to re-synch after error
c in case error was in header, allow at least 1 block of garbage
parameter numchar=135 ! allow a few noise bytes beyond 1 block
byte buffer(numchar)
logical i,ttyinlim
c
parameter maxtime=2

100 i=ttyinlim(buffer,numchar,maxtime)
if(istat) goto 100 ! didn't timeout, so char's still coming
return
end
c-----------------------------------------------------------
LOGICAL FUNCTION TTYINLIM(LINE,N,LIMIT)
BYTE LINE(*)
INTEGER N,LIMIT
C READ CHARACTERS FROM TERMINAL
C WITH TIME LIMIT, RETURN FALSE IF NO CHARACTERS
C RECEIVED FOR LIMIT SECONDS
C MODIFIED BY BELONIS TO REMOVE PRIVILEGE PROBLEM
C MAY HAVE PROBLEM WITH TYPE-AHEAD
c apparent typeahead problem: in SENDFN, remote can send checksum
c too soon after we send EOF, it is seen by typeahead since
c this routine has not yet activated, so high bit already stripped
c This was solved by using PASSALL routine.

INTEGER*2 CHAN,STATUS(4)
COMMON /QIO/ CHAN,STATUS

INCLUDE '($SSDEF)' ! defines error status returns
INTEGER I
INTEGER SYS$QIOW
INTEGER*4 terminators(2)
EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
DATA TERMINATORS/0,0/
C
TTYINLIM=.TRUE. ! DEFAULT no delay over LIMIT seconds
I = SYS$QIOW(, !EVENT FLAG
- %VAL(CHAN), !CHANNEL
- %VAL(%LOC(IO$_TTYREADALL).OR.
- %LOC(IO$M_NOECHO).OR.%LOC(IO$M_TIMED)),
- STATUS,,,
- LINE, !BUFFER
- %VAL(N), !LENGTH
- %VAL(LIMIT), !time limit in seconds
- terminators,,) !no terminators
if(STATUS(1).EQ.SS$_TIMEOUT) THEN
TTYINLIM=.FALSE.
write(8,*) ' ttyinlim timeout'
return
ENDIF

IF (I) THEN
return
endif
C
C ERROR
write(8,*) ' ttyinlim error.'
CALL SYS$EXIT( %VAL(I) )
END
c-----------------------------------------------------------
SUBROUTINE TTYOUT(LINE,N)
BYTE LINE(*)
INTEGER*2 N
C output N characters without interpretation

INTEGER*2 CHAN,STATUS(4)
COMMON /QIO/ CHAN,STATUS

INTEGER I
INTEGER SYS$QIOW
EXTERNAL IO$M_NOFORMAT
EXTERNAL IO$_WRITEVBLK
C
IF( N.LE.0 ) THEN
WRITE(8,*) ' ttyout called with strange number of char ',N
RETURN
ENDIF
C
I = SYS$QIOW(,
- %VAL(CHAN),
- %VAL(%LOC(IO$_WRITEVBLK).OR.
- %LOC(IO$M_NOFORMAT)),
- STATUS,,,
- LINE,
- %VAL(N),,
- %VAL(0),, ) !NO CARRIAGE CONTROL
if(I) then
return
endif
C
C ERROR
write(8,*) ' ttyout error.'
CALL SYS$EXIT( %VAL(I) )
END
c--------------------------------------------------
subroutine giveup
c this exit routine used especially in case exited via QIO problem

INTEGER*2 CHAN,STATUS(4)
COMMON /QIO/ CHAN,STATUS

c note: if want log file message, must re-open since
c system already closed all files before this exit handler got control

c turn off passall
call passall(CHAN,.FALSE.)
return
end
c-----------------------------------------------------
SUBROUTINE PASSALL(CHAN,SWITCH)
C sets PASSALL mode for terminal connected to chanel CHAN, ON if switch true
IMPLICIT INTEGER (A-Z)
INCLUDE '($TTDEF)'
INCLUDE '($IODEF)'
LOGICAL SWITCH
COMMON/CHAR/CLASS,TYPE,WIDTH,CHARAC(3),LENGTH !byte reversed LENGTH
BYTE CLASS,TYPE,CHARAC,LENGTH
INTEGER*2 WIDTH,SPEED
EQUIVALENCE(CHARACTER,CHARAC)

c sense current terminal driver mode
ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE),,,,
1 CLASS,,,,,)
IF (.NOT.ISTAT) CALL ERROR('TERMINAL SENSEMODE',ISTAT)

IF(SWITCH) THEN
c turn on 8 bit passall
CHARACTER=CHARACTER.OR.TT$M_PASSALL.OR.
1 TT$M_EIGHTBIT
ELSE
c turn off 8 bit passall
CHARACTER=CHARACTER.AND..NOT.TT$M_PASSALL.AND.
1 .NOT.TT$M_EIGHTBIT
ENDIF
SPEED=0 !LEAVE SPEED UNCHANGED
PAR=0 !LEAVE PARITY UNCHANGED

c set terminal mode with desired passall
ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE),,,,
1 CLASS,,%VAL(SPEED),,%VAL(PAR),)
IF (.NOT.ISTAT) CALL ERROR('TERMINAL SETMODE',ISTAT)
RETURN
END
c---------------------------------------------------
SUBROUTINE ERROR(STRING,MSGID)
c Types error message
IMPLICIT INTEGER(A-Z)
CHARACTER*(*) STRING
CHARACTER*80 MESSAGE

TYPE *,' *** ERROR: ',STRING
write(8,*) ' *** ERROR: ',STRING
CALL SYS$GETMSG(%VAL(MSGID),MSGLEN,MESSAGE,%VAL(15),)
TYPE *,MESSAGE(1:MSGLEN),CRLF
write(8,*) MESSAGE(1:MSGLEN),CRLF
RETURN
END
c-----------------------------------------------------------
subroutine cancel
c called to cancel send (at least)
logical ttyinlim
byte c(135) ! enough space to eat everything
parameter CAN=24
parameter SPACE=32

c eat garbage
100 if( ttyinlim(c,135,1) ) goto 100
c cancel other end
call ttyout(CAN,1)

c eat garbage again in case it didn't understand ?
200 if( ttyinlim(c,135,1) ) goto 200
c clear the CAN from far end's input in case he has already cancelled and so
c has not yet read it.
c ???? why ? xmodem50.asm does it

call ttyout(SPACE,1)

write(8,*)' XMODEM program canceled'
call exit
end
c------------------------------------------------------
subroutine getack(acked)
c returns .TRUE. if gets ACK
logical charintime, ttyinlim, acked
byte sector(130),c

integer errorcount
common /err/errorcount

parameter ACK=6
parameter NAK=21
parameter CAN=24
parameter errlim=10 ! max number of errors
parameter acklim=15 ! seconds to wait for ACK (xmodem.asm uses 10?)
! but Stern's Northstar takes longer
! to write 128 sectors

c allow time for disk file write at other end. Typically 128 sectors.
c Sometimes only 1 track.
10 charintime=ttyinlim(c,1,acklim)

if( .NOT.charintime ) then
write(8,*) ' timeout in GETACK'
errorcount=errorcount+1
if(errorcount.GE.errlim) then
write(8,*) ' not acknowleged in 10 tries.'
call cancel
endif
goto 10 ! try again
elseif( c.EQ.ACK ) then
c received ACK
acked=.TRUE.
elseif( c.EQ.NAK ) then
write(8,*) ' not ACK, decimal=',c
errorcount=errorcount+1
if(errorcount.GE.errlim) then
write(8,*) ' not acknowleged in 10 tries.'
call cancel
endif
acked=.FALSE.

elseif(c.EQ.CAN) then
write (8,*) 'Cancel received while waiting for ACK'
call cancel
else
c received garbage, ignore it and try again.
c note: this risks seeing ACK inside the burst of garbage, possibly should EAT
write(8,*) ' not ACK, decimal=',c
goto 10
endif
return
end


  3 Responses to “Category : Miscellaneous Language Source Code
Archive   : XMODEMAU.ZIP
Filename : XMODEMAU.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/