C C VAXSUB - VAX/VMS subroutines to be used with SNDRCV program. C SUBROUTINE SETUP C C Do special setup stuff. C INCLUDE 'SNDRCV.INC' INCLUDE 'VAXDEF.FOR' CHARACTER*50 TERMINAL IOSTAT = SS$_NORMAL DSW = SYS$TRNLOG('SYS$INPUT',I,TERMINAL,,,) CALL CHKSTA('TRNLOG',DSW,IOSTAT) DSW = SYS$ASSIGN(TERMINAL(5:I),CHANNEL,,) CALL CHKSTA('ASSIGN',DSW,IOSTAT) RETURN END SUBROUTINE READIT(IBUFF,NBYTES) C C Reads an input line from the host. C INCLUDE 'SNDRCV.INC/NOLIST' INCLUDE 'VAXDEF.FOR/NOLIST' LOGICAL*1 IBUFF(1) IBUFF(1) = 0 ! Clear the first byte. ASSIGN 100 TO RETRY ! Loop for retrys. ASSIGN 500 TO ERROR ! For various errors. 100 DSW = SYS$QIOW(,%VAL(CHANNEL), 1 %VAL(IO$_TTYREADALL + IO$M_NOECHO + IO$M_TIMED), 1 RIOSB,,,IBUFF,%VAL(BUFSIZ), 1 %VAL(TIMOUT),TTBL,,) IOSTAT = RIOSB(1) ! Copy I/O status. NBYTES = RIOSB(2) ! Copy the byte count. IF (NBYTES .LT. 2 .AND. IBUFF(1) .EQ. CAN) 1 CALL ABORT ! Abort transmission. IF (IOSTAT .EQ. SS$_TIMEOUT) THEN ! Timeout ? TMOERR = TMOERR + 1 ! Yes, count it, GO TO ERROR ! and continue. ELSEIF (IOSTAT .EQ. SS$_PARITY) THEN ! Parity error ? VERERR = VERERR + 1 ! Count # of parity errors, GO TO ERROR ! and continue. ENDIF 230 CALL CHKSTA('READIT',DSW,IOSTAT)! Check status code. RETURN C C Here for timeout and hardware errors. C 500 IBUFF(1) = 0 ! Force bad transmission NBYTES = 0 ! by clearing buffer & BC. CALL FLUSH ! Flush the typeahead buffer, RETURN ! and finally return. END SUBROUTINE WRITIT(IBUFF,NBYTES,WAIT) C C This routine writes a buffer to the host. C INCLUDE 'SNDRCV.INC/NOLIST' INCLUDE 'VAXDEF.FOR/NOLIST' LOGICAL*1 IBUFF(1), CODE(1) LOGICAL WAIT ASSIGN 100 TO RETRY ! Retry on transmission error. 100 CALL FLUSH ! Flush the typeahead buffer. DSW = SYS$QIOW(,%VAL(CHANNEL), 1 %VAL(IO$_WRITELBLK + IO$M_NOFORMAT + IO$M_CANTRLO), 1 XIOSB,,,IBUFF,%VAL(NBYTES),,%VAL(43),,) IOSTAT = XIOSB(1) ! Copy the I/O status. CALL CHKSTA('WRITIT',DSW,IOSTAT)! Check the status. IF (.NOT. WAIT) RETURN ! Don't wait for response. C C Get response back from the host. C CALL GETRES(CODE(1)) ! Get the response. IF (CODE(1) .EQ. NAK) GO TO RETRY ! Transmission error. RETURN END SUBROUTINE FLUSH C C This subroutine flushs the typeahead buffer. C INCLUDE 'SNDRCV.INC/NOLIST' INCLUDE 'VAXDEF.FOR/NOLIST' DSW = SYS$QIOW(,%VAL(CHANNEL), 1 %VAL(IO$_READLBLK + IO$M_NOECHO + IO$M_PURGE), 2 XIOSB,,,TBUFF,%VAL(0),,,,) IOSTAT = XIOSB(1) ! Copy the I/O status. CALL CHKSTA('FLUSH',DSW,IOSTAT) ! Check the status. RETURN END SUBROUTINE OPERR C C This subroutine returns the error text to the host. C C CALL ERRSNS(num,rmssts,rmsstv,iunit,) C C Where: num = fortran error code, C rmssts = RMS completion status code. C rmsstv = RMS status code. C iunit = logical unit number. C INCLUDE 'SNDRCV.INC/NOLIST' CHARACTER*80 MESSAGE C C Set flags for GETMSG for: C - Include text of message C - Include message identifier C - Include severity indicator C - Include facility name C FLAGS = "17 CALL ERRSNS(FERR,RMSSTS,RMSSTV,LUN,) CALL SYS$GETMSG(%VAL(RMSSTS),MSGLEN,MESSAGE,%VAL(FLAGS),) WRITE (TOLUN,100) NAK, MESSAGE 100 FORMAT ('+', A1, A) RETURN END SUBROUTINE CHKSTA(NAME,DSW,IOSTAT) C C This subroutine checks the status of a QIO. C C If success then simply return, else send the error code C to the host and cancel the transmission. C INCLUDE 'SNDRCV.INC/NOLIST' INCLUDE 'VAXDEF.FOR/NOLIST' CHARACTER*(*) NAME IF (DSW .EQ. SS$_NORMAL .AND. 1 IOSTAT .EQ. SS$_NORMAL) RETURN ! Return if success code, WRITE (TOLUN,100) CAN, NAME, DSW, IOSTAT! else cancel transmission. 100 FORMAT ('+',A1,'ERROR detected in ', A, ' DSW =', Z4, 1 ', IOSTAT =', Z4) IF (FILOPN) CLOSE (UNIT=IOLUN) ! Close file if open, CALL EXIT ! and exit. END