C XMODEM EMULATION PROGRAMS FOR DEC FORTRAN
C FROM JIM BRIGGS ORIGINALS
C
C
C  RECEIVE.FTN
C THIS PROGRAM RECEIVES A FILE SENT BY MODEM7, STORING IT IN
C A DIRECT ACCESS FILE OF 128 BYTE RECORDS (AS FOUND ON CP/M DISK)
C IT MUST THEN BE CONVERTED FOR PDP11 SEPARATELY.
C J. BRIGGS  8/17/82
C NOTE: TERMINAL CHARACTERISTICS MUST BE SET:
C
C LOWERCASE, NOWRAP, NOFILL, 8 BIT, PASSALL, BINARY, HARDWARE HORIZ TAB,
C WIDTH 133 (OR MORE)
	LOGICAL*1 REDBUF(132),NAKBUF,ACKBUF,EOT
	DATA NCHAR/132/ ! BUFF SIZE
	DATA ITIME/1/	! 10 SEC TIMEOUT
	DATA NAKBUF/21/,ACKBUF/6/,EOT/4/,MAXRTY/4/
	WRITE(5,1)
1	FORMAT('$NAME OF FILE TO BE RECEIVED?')
	READ(5,2,END=90)NC,(REDBUF(I),I=1,72)
2	FORMAT(Q,72A1)
	IF(NC.LE.0)GOTO 90
	REDBUF(NC+1)=0
	CLOSE(UNIT=5)
C OPEN FILE TO GET DATA
	OPEN(UNIT=1,NAME=REDBUF,FORM='UNFORMATTED',TYPE='NEW',
     1  CARRIAGECONTROL='NONE',ACCESS='DIRECT',RECORDSIZE=32)
C 
C THIS IS THE MAIN READ LOOP
C READS DATA (IN BINARY SO IF YOUR NET WON'T HANDLE 8 BITS YOU LOSE)
	NWRT=0
	NREC=1 ! REC # EXPECTED
10	CONTINUE
	NTRY=0
20	CONTINUE
	CALL READEM(REDBUF,NCHAR,ITIME,NREAD,IERROR)
	IF((IERROR.NE.1).AND.(IERROR.NE.2))GOTO 70
	IF(IERROR.EQ.2)GOTO 50
C GOT 132 CHARS - CHECK THE CHECKSUM
	ICHECK=0
	DO 25 I=1,131
	IT=REDBUF(I)
25	ICHECK=(ICHECK+(IT.AND.255)).AND.255
	IT=REDBUF(132)
	IF(ICHECK.NE.IT)GOTO 70
	NWRT=NWRT+1
	WRITE(1'NREC)(REDBUF(I),I=4,131)
	CALL WRTALL(ACKBUF,1,IERROR)
	NREC=NREC+1
	GOTO 10
50	CONTINUE
	IF(NCHAR.LE.0)GOTO 70
	IF(REDBUF(1).NE.EOT)GOTO 70
	CALL WRTALL(ACKBUF,1,IERROR)
	GOTO 90
70	CONTINUE
	NTRY=NTRY+1
	IF(NTRY.GT.MAXRTY)GOTO 90
C IF TOO MANY ERRORS, GIVE UP
	CALL WRTALL(NAKBUF,1,IERROR)
	GOTO 20
90	CALL EXIT
	END
	SUBROUTINE READEM(BUF,NBUF,NTIME,NREAD,IERROR)
C PURPOSE:
C  DOES QIO$ TYPE READ-ALL WITH NO ECHO AND NTIME*10 TIMEOUT
C PARAMETERS:
C	BUF - BYTE ARRAY WITH TERMINAL INPUT
C	NBUF - # CHARS IN BUF
C	NREAD - # CHARS READ DURING QIO
C	IERROR - ERROR STATUS. 1 ==> OK
	LOGICAL*1 BUF(1),STAT(4)
	INTEGER*2 ISTAT(2),IPRM(6)
	EQUIVALENCE(ISTAT,STAT)
	DATA IOCODE/"1230/ ! IO.RNE!TF.TMO!TF.RAL
	DATA IEFN/1/,ILUN/5/
	NREAD=0
	IERROR=0
	IF(NBUF.LE.0)RETURN
C SET UP PARAM LIST
	CALL GETADR(IPRM(1),BUF)
	IPRM(2)=NBUF
	IPRM(3)=NTIME ! TIMEOUT
C DO THE QIO
	CALL WTQIO(IOCODE,ILUN,IEFN,,ISTAT,IPRM)
C GET STATUS AND CHARS READ
	IERROR=STAT(1)
	NREAD=ISTAT(2)
	RETURN
	END
	SUBROUTINE WRTALL(BUF,NBUF,IERROR)
C PURPOSE:
C WRITE TO TERMINAL VIA QIO (WITH PASSALL)
C PARAMETERS:
C	BUF - BYTE ARRAY OF CHARS TO WRITE
C	NBUF - NUMBER CHARS TO WRITE
C	IERROR - I/O STATUS BYTE, 1 = OK
C CALLS:
C	GETADR, WTQIO
	BYTE STAT(4),BUF(1)
	INTEGER*2 ISTAT(2),IPRM(3)
	EQUIVALENCE(ISTAT,STAT)
	DATA IOCODE/"410/ ! IO.WAL
	DATA IEFN/1/,ILUN/5/
	IF(NBUF.LE.0)RETURN
	CALL GETADR(IPRM,BUF)
	IPRM(2)=NBUF
	IPRM(3)=0
C DO QIO
	CALL WTQIO(IOCODE,ILUN,IEFN,,ISTAT,IPRM)
	IERROR=STAT(1)
	RETURN
	END
C
C SEND.FTN
C THIS PROGRAM SENDS A CPM FORMAT FILE ON PDP11 TO THE MODEM
C PROGRAM ON CP/M
C  JIM BRIGGS 8/17/82
C  IAS V3.0
	LOGICAL*1 SNDBUF(132),REDBUF,NAKBUF,ACKBUF,EOTBUF,SOH
	LOGICAL ENDFIL
	DATA NCHAR/132/,ITIME/1/,NAKBUF/21/
	DATA ACKBUF/6/,EOTBUF/4/,MAXRTY/4/ ! 4 RETRIES MAX
	DATA SOH/1/,LENSND/132/,ENDFIL/.FALSE./
	WRITE(5,1)
1	FORMAT('$NAME OF FILE TO BE SENT?')
	READ(5,2,END=90)NC,(SNDBUF(I),I=1,72)
2	FORMAT(Q,72A1)
	IF(NC.LE.0)GOTO 90
	SNDBUF(NC+1)=0
	CLOSE(UNIT=5)
C OPEN FILE TO BE SENT
	OPEN(UNIT=1,NAME=SNDBUF,FORM='FORMATTED',TYPE='OLD',
     1  READONLY)
C THIS IS THE MAJOR LOOP
	NWRT=0
	NREC=0 ! REC # TO BE SENT
C WAIT FOR INITIAL NAK
	NTRY=0
8	NTRY=NTRY+1
	IF(NTRY.GT.MAXRTY)GOTO 90
	CALL READEM(REDBUF,1,ITIME,NREAD,IERROR)
	IF(IERROR.NE.1)GOTO 8
	IF(REDBUF.NE.NAKBUF)GOTO 8
10	CONTINUE
	IF(ENDFIL)GOTO 90
	NREC=NREC+1
	NWRT=(NWRT+1).AND.255
C READ NEXT FILE RECORD AND EMBED IN THE PROTOCOL
	SNDBUF(1)=SOH
	SNDBUF(2)=NWRT
	SNDBUF(3)=(.NOT.NWRT).AND.255
	READ(1,13,END=60)(SNDBUF(I),I=4,131)
13	FORMAT(128A1)
	ICHECK=0
	DO 15 I=1,131
	IT=SNDBUF(I)
15	ICHECK=(ICHECK+(IT.AND.255)).AND.255
	SNDBUF(132)=ICHECK
C SIMPLE CHECKSUM ALGORITHM
12	CONTINUE
	NTRY=0
20	CONTINUE
	NTRY=NTRY+1
	IF(NTRY.GT.MAXRTY)GOTO 90
	CALL WRTALL(SNDBUF,LENSND,IERROR) ! RETRANSMIT
C WAIT FOR ACK OR NAK
25	CALL READEM(REDBUF,1,ITIME,NREAD,IERROR)
	IF(IERROR.NE.1.AND.IERROR.NE.2)GOTO 20
	IF(IERROR.EQ.2)GOTO 20
	IF(REDBUF.EQ.ACKBUF)GOTO 10 ! POSITIVE ACK, OK
	IF(REDBUF.EQ.NAKBUF)GOTO 25 ! NEGATIVE ACK, GOBBLE THE CHARACTER
	GOTO 20 !ELSE JUST TRY SOME MORE...LOOKS LIKE GARBAGE
60	CONTINUE
	SNDBUF(1)=EOTBUF
	LENSND=1
	ENDFIL=.TRUE.
	GOTO 12
90	CALL EXIT
	END
C
C PROGRAM CNVCPM
C JIM BRIGGS
C AUGUST 15,1982
C THIS PROGRAM IS USED TO FORMAT CP/M SOURCE FILES INTO REGULAR
C PDP11 TYPE PROGRAMS. JUST ENTER INPUT AND OUTPUT FILE NAMES.
	LOGICAL*1 RECBUF9128),BUFFER(132),INNAME(50),OUTNAM(50)
	LOGICAL*1 BLANK,CR,LF,CHAR,EOF
	DATA BLANK/' '/,CR,LF/13,10/,EOF/26/,NCHAR/0/,IPTR/133/
C SUPPRESS SOME COMMON FILE OPEN MESSAGES (OPTIONAL ON OTHER SYSTEMS)
	CALL ERRSET(29,,.FALSE.,,.FALSE.)
	CALL ERRSET(30,,.FALSE.,,.FALSE.)
	CALL ERRSET(43,,.FALSE.,,.FALSE.)
C GET NAMES & OPEN FILE
10	CONTINUE
	WRITE(5,11)
11	FORMAT('$INPUT FILE NAME:')
	READ(5,12,END=90)NC,INNAME
12	FORMAT(Q,50A1)
	IF(NC.LE.0)GOTO 90
	INNAME(NC+1)=0
	OPEN(UNIT=1,NAME=INNAME,TYPE='OLD',READONLY,ACCESS='DIRECT',
     1  ERR=15)
	GOTO 20
15	WRITE(5,16)
16	FORMAT(' FILE OPEN ERROR - TRY AGAIN OR ^Z TO EXIT:')
	GOTO 10
20	CONTINUE
	WRITE(5,21)
21	FORMAT('$OUTPUT FILE NAME:')
	READ(5,12,END=90)NC,OUTNAM
	IF(NC.LE.0)GOTO 90
	OUTNAM(NC+1)=0
	OPEN(UNIT=2,NAME=OUTNAM,TYPE='NEW',CARRIAGECONTROL='LIST',
     1  ERR=25)
	GOTO 30
25	WRITE(5,26)
26	FORMAT(' FILE OPEN ERROR - TRY AGAIN OR ^Z TO EXIT:')
	GOTO 20
C THIS LOOP READS RECORDS FROM LUN 1 TO LUN 2 TILL EOF ON UNIT 1
30	CONTINUE
	IPTR=IPTR+1
	IF(IPTR.LE.128)GOTO 31
	NREC=NREC+1
	READ91'NREC)RECBUF
	IPTR=1
31	CONTINUE
	CHAR=RECBUF(IPTR)
	IF(CHAR.EQ.LF)GOTO 30 ! IGNORE LF'S
	IF(CHAR.EQ.EOF.OR.CHAR.EQ.CR) GOTO 36
	NCHAR=NCHAR+1
	IF(NCHAR.LE.132)BUFFER(NCHAR)=CHAR
	GOTO 30
36	CONTINUE
	IF(NCHAR.LE.0)GOTO 48
C STRIP TRAILING BLANKS
	DO 40 I=1,NCHAR
	IF(BUFFER(NCHAR+1-I).NE.BLANK)GOTO 45
40	CONTINUE
	I=NCHAR
45	LENGTH=NCHAR+1-I
	WRITE(2,46)(BUFFER(J),J=1,LENGTH)
46	FORMAT(132A1)
	NCHAR=0
	GOTO 30
48	CONTINUE
	IF(CHAR.NE.EOF)GOTO 30
90	CALL EXIT
	END
C
C PROGRAM TOCPM - CONVERT PDP11 SOURCE FILES TO CP/M TYPE
C FILES FOR TRANSMISSION VIA SEND PROGRAM
C
	LOGICAL*1 RECBUF(128),BUFFER(134),INNAME(50),OUTNAM(50)
	LOGICAL*1 BLANK,CR,LF,CHAR,EOF
	DATA BLANK/' '/,CR,LF/13,10/,EOF/26/,NCHAR/0/,IPTR/133/
C SUPPRESS SOME COMMON FILE OPEN MESSAGES (OPTIONAL ON OTHER SYSTEMS)
	CALL ERRSET(29,,.FALSE.,,.FALSE.)
	CALL ERRSET(30,,.FALSE.,,.FALSE.)
	CALL ERRSET(43,,.FALSE.,,.FALSE.)
C GET NAMES & OPEN FILE
10	CONTINUE
	WRITE(5,11)
11	FORMAT('$INPUT FILE NAME:')
	READ(5,12,END=90)NC,INNAME
12	FORMAT(Q,50A1)
	IF(NC.LE.0)GOTO 90
	INNAME(NC+1)=0
	OPEN(UNIT=1,NAME=INNAME,TYPE='OLD',READONLY,
     1  ERR=15)
	GOTO 20
15	WRITE(5,16)
16	FORMAT(' FILE OPEN ERROR - TRY AGAIN OR ^Z TO EXIT:')
	GOTO 10
20	CONTINUE
	WRITE(5,21)
21	FORMAT('$OUTPUT FILE NAME:')
	READ(5,12,END=90)NC,OUTNAM
	IF(NC.LE.0)GOTO 90
	OUTNAM(NC+1)=0
	OPEN(UNIT=2,NAME=OUTNAM,TYPE='NEW',CARRIAGECONTROL='NONE',
     1  RECORDSIZE=32
     1  ACCESS='DIRECT',ERR=25)
	GOTO 30
25	WRITE(5,26)
26	FORMAT(' FILE OPEN ERROR - TRY AGAIN OR ^Z TO EXIT:')
	GOTO 20
C THIS LOOP READS RECORDS FROM LUN 1 TO LUN 2 TILL EOF ON UNIT 1
30	CONTINUE
	IPTR=IPTR+1
	IF(IPTR.LE.NREAD)GOTO 40
	READ(1,31,END=60)NREAD,(BUFFER(I),I=1,132)
31	FORMAT(Q,132A1)
	IF(NREAD.LE.0)GOTO 35 ! I E , A NULL LINE
C STRIP TRAILING BLANKS
	DO 34 I=1,NREAD
	IF(BUFFER(NREAD+I-1).NE.BLANK)GOTO 36
34	CONTINUE
35	I=NCHAR ! RESET I TO ALLOW 1 BLANK OUT
	BUFFER(1)=BLANK ! A TRANSFER POINT FROM EARLIER EMPTY LINE
36	NREAD=NREAD+1-I
	BUFFER(NREAD+1)=CR
	BUFFER(NREAD+2)=LF ! ADD CRLF TO BUFFER
	NREAD=NREAD+2
	IPTR=1
40	CONTINUE
C STORE THIS CHAR IN OUTPUT BUFFER, WRITING BUFFER WHEN FILLED
	NCHAR=NCHAR+1
	RECBUF(NCHAR)=BUFFER(IPTR)
	IF(NCHAR.LT.128)GOTO 30
	NREC=NREC+1
	WRITE(2'NREC)RECBUF
	NCHAR=0
	GOTO 30
60 CONTINUE
C FILL WITH EOF'S TO END OF BUFFER
	NCHAR=NCHAR+1
	DO 62 I=NCHAR,128
62	RECBUF(I)=EOF
	NREC=NREC+1
	WRITE(2'NREC)RECBUF
90	CALL EXIT
	END