C
C  FILE TRANSFER PROGRAM FROM CP/M TO RSX AND BACK USING XMODEM TYPE
C  PROTOCOL. FOR TEXT FILES ONLY @ THIS TIME.
C  THIS FORTRAN PROGRAM WAS SLEAZED TOGETHER BY:
C  JEFF BERGER 6/15/83 OF BATTLE CREEK, MI.
C
C  Program works well with standard source files.
C  Remember, the data goes thru the RSX Full Duplex Terminal Driver
C  and as much as I tweak it with the SMC QIO there are still some 
C  binary codes it can not tolerate. If you must send a .COM file 
C  to your RSX system (ie. you have a CP/M emulator like the BRIDGE)
C  use the UNLOAD program and ship the .HEX file over. This holds true
C  back to your CP/M system also. If somebody would like to write a 
C  routine using the WRITE$ macro for RSX binary disk block writes
C  this would clean up some of these problems (just make sure there
C  is nothing of any value on your RSX disk durring developement !!)
C   
C  The obvious problem now is how to get this source code to your DEC
C  (or somebody elses DEC what ever the case may be) so you can compile
C  task build and run this program. I would suggest a single character/
C  wait for echo transmition to EDT, EDI or PIP (some comm programs
C  have this facility such as MICRO-LINK ect.) Remember this method has no
C  error detection so if you have bad phone line you will have to do some
C  clean up. Direct connect if possible. If you do not have this type of
C  program available, please let me know via this board and it's just 
C  a matter of finding the two that I coded for this purpose in June.
C
C  1. Load this source to the RSX system.
C  2. Compile and task build (TKB WITH MAXBUF = 255).
C  3. Run your CP/M modem program in terminal mode.
C  4. Run this program and follow directions
C
C  !!! NO CRC  !!!
C  
C
      BYTE ANS
C
      WRITE(5,100)
100   FORMAT(//' 1. DEC receive - CP/M send',
     +/,' 2. CP/M receive - DEC send',/,' 3. EXIT',//,
     +'$ENTER OPTION:')
      READ(5,110)ANS
110   FORMAT(1A1)
C
      IF(ANS.EQ.'1')CALL TODEC
      IF(ANS.EQ.'2')CALL TOCPM
      IF(ANS.EQ.'3')CALL EXIT
C
      STOP
      END

C****************************************************************
C
C  SUBROUTINE TOCPM: DEC SEND - CP/M RECEIVE.
C
C***************************************************************
C
      SUBROUTINE TOCPM
C
      BYTE RBUFF(128)                   !REC READ FROM SOURCE FILE.
      BYTE SBUFF(132)                   !RECORD SENT TO MICRO.
      BYTE FNAME(30)                    !FILE NAME.
      BYTE BLOCK                        !BLOCK NUMBER.
      BYTE NAK
      BYTE SMC(8)                       !SET MULTIPLE CHARACTERISTICS.
      BYTE VT100(2)                     !SET BACK TO VT100.
C
      INTEGER TEMP1                     !TEMP STORSGE.
      INTEGER TOTAL                     !NUM OF BYTES IN SREC.
      INTEGER N                         !NUM OF CHARS READ FROM DEC FILE.
      INTEGER REMAIN                    !REMAINING BYTES IN BUFFER.
      INTEGER IP(6)                     !PARAMATER BLOCK FOR QIO.
      INTEGER EOF                       !IF = 1 THEN EOF.
C
      EOF = 0
      TEMP1=0
      TOTAL=0
      BLOCK=0
C
      DO 50 I=1,30
50    FNAME(I)=0
C
      WRITE(5,100)
100   FORMAT(//,'$ENTER SOURCE FILE NAME:')
      READ(5,110)FNAME
110   FORMAT(30A1)
C
      OPEN(UNIT=1,NAME=FNAME,TYPE='OLD',ERR=999)
C**********************************************************
C  TRY SET /RPA=TI: INSTEAD OF THE REST OF THIS !!!       *
C  THAT IS  SMC(1)="65 , SMC(2)=1                         *
C**********************************************************
      SMC(1)="12                      !SET TO 
      SMC(2)= 0                       !NO CRT.
      SMC(3)="10                      !TERMINAL TYPE,
      SMC(4)= 0                       !UNKNOWN.
      SMC(5)="17                      !HARDWARE FORMFEED,
      SMC(6)= 1                       !YES.
      SMC(7)= 1                       !BUFFER SIZE,
      SMC(8)="377                     !255.
C
C***      SMC(1)="65
C***      SMC(2)=1
      CALL GETADR(IP(1),SMC(1))
      IP(2)=8
      CALL WTQIO("2440,5,1,,,IP)
C
      WRITE(5,40)
40    FORMAT(/,/,' WAITING FOR INITIAL "NAK" FROM RECEIVER.')
C
      IP(2)=1                         !LENGTH OF QIO READ.
      CALL GETADR(IP(1),NAK)          !ADDRESS OF QIO READ BUFFER.
113   CALL WTQIO("1030,5,1,,,IP)      !QIO READ PASS ALL BITS DO NOT ECHO.
C                                     !WAITS FOR 
C                                     !10 SEC TIMEOUT AND NAK FROM RECEIVER.
      IF(NAK.NE."25)GO TO 113         !IF NOT NAK TRY AGAIN.
C
115   READ(1,120,END=3000)N,RBUFF
120   FORMAT(Q,128A1)
C
      RBUFF(N+1)="15                  !ADD CR-LF FOR CP/M.
      RBUFF(N+2)="12
      N=N+2
C
      TEMP1=TOTAL                     !TEMP STORAGE OF TOTAL.
      TOTAL=TOTAL+N
C
      IF(TOTAL.GE.128)GO TO 1000      !HANDLE CROSSING CP/M BLOCKS.
C
      DO 500 I=1,N
        SBUFF(I+3+TEMP1)=RBUFF(I)     !
500   CONTINUE
C
      GO TO 115                       !READ ANOTHER RECORD.
C
1000  REMAIN=128-TEMP1
      DO 1100 I=1,REMAIN
        SBUFF(I+3+TEMP1)=RBUFF(I)     !PUT FIRST PORTION OF REC INTO SBUFF.
1100  CONTINUE
C
      BLOCK=BLOCK+1                   !INC BLOCK.
      CALL SEND(SBUFF,BLOCK,EOF)                !SEND TO MICRO.
C
      DO 2000 I=1,N-REMAIN            !PUT THE REST OF THE REC IN NEXT SBUFF.
        SBUFF(I+3)=RBUFF(I+REMAIN)
2000  CONTINUE
C
      TOTAL=N-REMAIN
C
      GO TO 115                       !READ NEXT REC.
C
3000  DO 3100 I=TOTAL+4,131
        SBUFF(I)="32                  !CP/M EOF.
3100  CONTINUE
      BLOCK=BLOCK+1
      CALL SEND(SBUFF,BLOCK,EOF)
      EOF=1
      CALL SEND(SBUFF,BLOCK,EOF)      !TELL SEND TO SEND EOT.
C
999   CONTINUE
6000  CONTINUE
C
      SMC(1)="10                      !TERMINAL TYPE
      SMC(2)="15                      !IS VT100.
      CALL GETADR(IP(1),SMC(1))       !
      IP(2)=2                         !
      CALL WTQIO("2440,5,1,,,IP)      !SET /VT100=TI:
C
      RETURN
      END

C****************************************************************************
C
C   SUBROUTINE SEND: SENDS DATA TO MICRO W/ PROTOCOL USING QIO READ
C                    WITH PROMPT. LOOKING FOR ACK OR NAK.
C
C***************************************************************************
C
      SUBROUTINE SEND(SBUFF,BLOCK,EOF)
C
      INTEGER ISTAT(2)               !STATUS BLOCK FOR QIO.
      INTEGER IPARAM(6)              !PARAMETER BLOCK FOR QIO.
      INTEGER FLAG1,FLAG2            !EVENT FLAGS.
      INTEGER EOF
C
      BYTE BLOCK                     !BLOCK NUMBER OF TRANSFER.
      BYTE SBUFF(132)                !SEND BUFFER.
      BYTE ACKNAK                    !QIO READ BUFFER (ACK OR NAK).
C
      DATA IFUN/"4430/               !QIO READ(NO ECHO) W/ PROMPT 
C                                    !PASS ALL BITS.
      DATA ILUN/5/                   !LOGICAL UNIT NUMBER.
      DATA FLAG1/1/                 !EVENT FLAG NUMBER.
      DATA FLAG2/2/                 !ANOTHER EVENT FLAG NUMBER.
C
      SBUFF(132)=0                  !RESET CHECKSUM.
C
      SBUFF(1)=1                     !ASCII SOH
      IF (EOF.EQ.1)SBUFF(1)=4        !EOT.
      SBUFF(2)=BLOCK                 !BLOCK NUMBER.
      SBUFF(3)=255-BLOCK             !BLOCK CHECK CHARACTER.
C
      DO 100 I=4,131                 !CALCULATE CHECKSUM
        SBUFF(132)=SBUFF(132)+SBUFF(I)
100   CONTINUE
C
      IPARAM(2)=1                    !LENGTH OF QIO READ BUFFER.
      IPARAM(5)=132                  !LENGTH OF PROMPT BUFFER (WRITE DATA).
      IF(EOF.EQ.1)IPARAM(5)=1        !JUST SEND ONE CHAR (EOT) AT EOF.
      CALL GETADR(IPARAM(1),ACKNAK)  !ADDRESS OF READ BUFFER.
      CALL GETADR(IPARAM(4),SBUFF(1)) !ADDRESS OF PROMPT (WRITE) BUFFER.
C
C**************************************
C      WRITE(5,101)SBUFF(1),SBUFF(2),SBUFF(3),SBUFF(132)
101   FORMAT(' ',4(O6))
C**************************************
200   CALL MARK(FLAG2,10,2)          !MARK TIME FOR 10 SECS.
C
      CALL QIO(IFUN,ILUN,FLAG1,,ISTST,IPARAM) !READ W/ PROMPT.
C                                     !PROMPT IS THE 128 BYTES DATA .
      CALL WFLOR(FLAG1,FLAG2)         !WAIT FOR FIRST FLAG (QIO OR TIMEOUT).
      CALL CANMT(FLAG2)               !CANCEL MARK TIME.
      CALL WTQIO("12,ILUN,3,,,,)      !CANCEL QIO READ W/ PROMPT.
      CALL READEF(FLAG2,IDS)          !READ EVENT FLAG STATUS.
C
C***      WRITE(5,10)IDS
10    FORMAT(' IDS = ',I2)
      IF(IDS.EQ.2)GO TO 200           !TIMEOUT !! RETRY.
C
C***      WRITE(5,11)ACKNAK
11    FORMAT(' ACKNAK = ',O6)
      IF(ACKNAK.EQ.6) RETURN          !ACK !! GO GET ANOTHER RECORD
C
      GO TO 200                       !NAK !! RETRY.
C
      END

C****************************************************************
C
C  SUBROUTINE TODEC: DEC RECEIVE - CP/M SEND.
C
C***************************************************************
C
      SUBROUTINE TODEC
C
      BYTE BIGBUF(256,128)              !FILE BUFFER (32K).
      BYTE RBUFF(132)                   !RECORD RECEIVED FROM MICRO.
      BYTE FNAME(30)                    !FILE NAME.
      BYTE BLOCK                        !BLOCK NUMBER.
      BYTE ACKNAK
      BYTE SMC(10)                       !SET MULTIPLE CHARACTERISTICS.
      BYTE SMC2(4)
      BYTE VT100(2)                     !SET BACK TO VT100.
      BYTE CHKSUM                       !CHECK SUM BYTE.
      BYTE ACK,NAK,EOT,CR,LF,EOF
      BYTE TBUFF                        !SINGLE CHAR TEMP BUFF.
C
      INTEGER IPARAM(6)                 !PARAMATER BLOCK FOR QIO.
      INTEGER IP(6)                     !""
      INTEGER ERRLIM                    !ALLOWABLE NUMBER OF ERRORS.
      INTEGER FLAG1                     !EVENT FLAG.
      INTEGER FLAG2                     !""
      INTEGER COUNT                     !TEMP COUNTER.
      INTEGER ISTST(2)                  !QIO IO STATUS.
      INTEGER IOSTAT(2)                 !
C
      COMMON /BLOCK1/BIGBUF
C
      DATA FLAG1/1/
      DATA FLAG2/2/
      DATA NAK/"025/                    !ASCII NAK.
      DATA ACK/"006/                    !ASCII ACK.
      DATA EOT/"004/                    !ASCII END OF TRANSMISSION.
      DATA EOF/"032/                    !CP/M END OF FILE.
      DATA CR/"15/                      !ASCII CARRIAGE RETURN.
      DATA LF/"12/                      !ASCII LINE FEED.
      DATA ILUN/5/                      !LOGICAL UNIT NUMBER.
      DATA IFUN/"4430/                  !QIO READ W/ PROMOT, PASS ALL BITS,
C                                       !NO ECHO.
C
      ERRLIM = 10                       !SET NUMBER OF ERRORS ALLOWED.
      BLOCK=0                           !INITIALIZE.
C
      DO 50 I=1,30
50    FNAME(I)=0
C
      WRITE(5,100)
100   FORMAT(//,'$ENTER DESTINATION FILE NAME:')
      READ(5,110)FNAME
110   FORMAT(30A1)
C
      OPEN(UNIT=1,NAME=FNAME,TYPE='NEW',CARRIAGECONTROL='LIST',
     +ERR=999,RECL=255)
C
      write (5,102)
102   format(' OK... WAITING FOR DATA.')
C
      SMC(1)="12                      !SET TO 
      SMC(2)= 0                       !NO CRT.
      SMC(3)="10                      !TERMINAL TYPE,
      SMC(4)= 0                       !UNKNOWN.
      SMC(5)="17                      !HARDWARE FORMFEED,
      SMC(6)= 1                       !YES.
      SMC(7)= 1                       !BUFFER SIZE,
      SMC(8)="377                     !255.
      SMC(9)="50                      !SLAVE,
      SMC(10)=1                       !YES.
C
C
      CALL GETADR(IPARAM(1),SMC(1))
      IPARAM(2)=10                   !SEND 10 CHARACTERS.
      CALL WTQIO("2440,5,1,,,IPARAM) !SET MULTIPLE TERMINAL 
C                                              !CHARACTERISTICS.
C
      IPARAM(2)=132                  !LENGTH OF QIO READ BUFFER.
      IPARAM(5)=1                    !LENGTH OF PROMPT BUFFER (ACK OA NAK).
C
      CALL GETADR(IPARAM(1),RBUFF(1))!ADDRESS OF READ BUFFER.
      CALL GETADR(IPARAM(4),ACKNAK) !ADDRESS OF PROMPT BUFFER.
C
C
      ACKNAK = NAK                   !FIRST TIME PROMPT W/ NAK.
C
200   CALL MARK(FLAG2,4,2)           !MARK TIME FOR 4 SECS.
C
      CALL QIO(IFUN,ILUN,FLAG1,,ISTST,IPARAM) !READ W/ PROMPT.
C                                     !PROMPT IS ACK OR NAK .
      CALL WFLOR(FLAG1,FLAG2)         !WAIT FOR FIRST FLAG (QIO OR TIMEOUT).
      CALL CANMT(FLAG2)               !CANCEL MARK TIME.
      CALL WTQIO("12,ILUN,3,,,,)      !CANCEL QIO READ W/ PROMPT.
      CALL READEF(FLAG2,IDS)          !READ EVENT FLAG STATUS.
C
C
      IF(IDS.NE.2)GO TO 300           !NOT TIMEOUT, CONTINUE.
        IF(RBUFF(1).EQ.EOT)GO TO 900  !END OF TRANSMISSION.(YES ! THIS
C                                     !CHARACTER WILL BE IN THE QIO BUFFER.)
        NAKNUM = NAKNUM + 1           !INCREMENT NAK COUNT.
        IF (NAKNUM .GE. ERRLIM)GO TO 999 !IF TOO LARGE, EXIT.
        ACKNAK = NAK                  !SET PROMPT TO NAK AND
        GO TO 200                     !TRY AGAIN.
C
300   CHKSUM = 0                      !ZERO CHECKSUM.
      DO 400 I=4,131                  !CALCULATE CHECKSUM.
        CHKSUM=CHKSUM+RBUFF(I)        !
400   CONTINUE                        !
C
      IF(CHKSUM.EQ.RBUFF(132))GO TO 500 !IF GOOD CHECKSUM, CONTINUE.
        NAKNUM = NAKNUM + 1            !INC ERROR COUNT.
        IF(NAKNUM .GE. ERRLIM)GO TO 999!IF TOO LARGE EXIT.
        ACKNAK = NAK                   !ELSE TRY AGAIN.
        GO TO 200                        
C
500   BLOCK = BLOCK + 1                !
      IF (BLOCK.EQ.RBUFF(2))GO TO 600  !IF GOOD BLOCKNUMBER, CONTINUE.
        NAKNUM = NAKNUM +1             !ELSE INC ERROR COUNT.
        BLOCK = BLOCK - 1              !
        IF(NAKNUM .GE. ERRLIM)GO TO 999!IF TOO LARGE, EXIT.
        ACKNAK = NAK                   !ELSE TRY AGAIN.
        GO TO 200                      !

C
600   COUNT = BLOCK
      IF(BLOCK .EQ. 0)COUNT = 256     !BLOCK WRAPS TO 0, NOT 1 !
      DO 650 I = 1,128
       BIGBUF(COUNT,I) = RBUFF(I+3)    !STUFF DATA INTO BLOCKBUFFER.
650   CONTINUE
      IF(COUNT.EQ.256)CALL WRITE      !WHEN BIGBUF IS FULL WRITE IT TO DISK.
C
      NAKNUM = 0                      !RESET ERROR COUNT.
      ACKNAK = ACK                    !PROMPT W/ ACK.
      GO TO 200                       !GET ANOTHER BLOCK FROM THE MICRO.
C
C

900   CALL GETADR(IP(1),ACK)        !ADDRESS OF WRITE BUFFER.
      IP(2)=1                       !LENGTH OF WRITE BUFFER.
      CALL WTQIO("410,ILUN,1,,,IP)  !WRITE FINAL ACK.
C
      CALL WRITE                    !WRITE FINAL BLOCK.
C
C999   WRITE(5,777)NAKNUM
C777   FORMAT(' *** ',I2)
999   CLOSE(UNIT = 1)
C
      SMC2(1)="10                      !TERMINAL TYPE
      SMC2(2)="15                      !IS VT100.
      SMC2(3)="50                      !SLAVE,
      SMC2(4)=0                        !NO.
C
      CALL GETADR(IP(1),SMC2(1))       !
      IP(2)=4                          !SEND 4 CHARACTERS.
      CALL WTQIO("2440,5,1,,IOSTAT,IP,IDS)      !SET /VT100=TI:
C      WRITE(5,2000)IOSTAT(1),IOSTAT(2),IDS
C2000  FORMAT(' ',3O6)
C
      CALL EXIT
      END
C

C*********************************************************************
C
C SUBROUTINE WRITE: WRITES TO DEC DISK.
C
C*********************************************************************
C
      SUBROUTINE WRITE
C
      BYTE BIGBUF(256,128)
      BYTE WBUFF(255)
      BYTE CR,LF,EOF 
C
      COMMON/BLOCK1/BIGBUF
C
      DATA CR/"15/
      DATA LF/"12/
      DATA EOF/"32/
C
      K=0
      DO 920 I = 1,256
        DO 930 J = 1,128
          IF(BIGBUF(I,J).EQ.CR)GO TO 915    !CP/M END OF RECORD.
          IF(BIGBUF(I,J).EQ.EOF)GO TO 940   !LOOK OUT FOR CP/M END OF FILE.
          IF(BIGBUF(I,J).EQ.LF)GO TO 930    !IGNORE LINE FEEDS.
          K=K+1
C***
          IF(K.EQ.256)GO TO 915             !WATCH OUT FOR BIG RECORD.
C***
          WBUFF(K)=BIGBUF(I,J)      
          GO TO 930
C915***   IF(K.EQ.0)K=1
915       WRITE(1,918)(WBUFF(L),L=1,K)  !WRITE RECORD TO DISK.
918       FORMAT(255A1)
          K=0                               !RESET COUNT AFTER WRITE.
930     CONTINUE
920   CONTINUE
C
940   RETURN
      END
