C THIS PROGRAM WILL BE USED TO PRACTICE DOING 'QIO' WITH C MAG TAPES. THE FOLLOWING FUNCTIONS WILL BE SUPPORTED: C C RLB READ LOGICAL BLOCK C WLB WRITE LOGICAL BLOCK C ATT ATTACH C DET DETACH C RWD REWIND C RWU REWIND AND UNLOAD C EOF WRITE EOF MARK C SPB SKIP N RECORDS (FORWARD OR BACKWARDS) C SPF SKIP N FILES (FORWARDS OR BACKWARDS) C STC SET CHARACTERISTICS C SEC SENSE CHARACTERISTICS C SMO VERIFY AT LOAD POINT AND STC C KIL CANCEL ALL REQUESTS C C DPB DUMP QIOBUF IN BYTES AND ASCII CHARACTERS C DPW DUMP QIOBUF IN WORDS C DPA DUMP QIOBUF IN ASCII CHARACTERS C D76 DUMP QIOBUF IN PACKED 7600 DISPLAY CODE C DPI DUMP QIOBUF IN INTERNAL BCD C DXB DUMP QIOBUF IN EXTERNAL BCD CODE C DEB DUMP QIOBUF IN EBCDIC C DPS DUMP QIOBUF IN SPECIAL (UNKNOWN) IBM CODE C OFL OUTLINE N FILES C COP COPY N FILES FROM TAPE TO TAPE C UNI SET PRIMARY UNIT NUMBER C PAT WRITE N RECORDS OF SPECIFIED OCTAL PATTERN C C BYTE BUF(80),QIOBFB(16384) INTEGER*2 KEYW,BYTCNT LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) EQUIVALENCE (QIOBUF(1),QIOBFB(1)) C C INITIALIZE IO FUNCTION CODES FOR QIO CALLS C IOWLB="001*"400+"000 IORLB="002*"400+"000 IOATT="003*"400+"000 IODET="004*"400+"000 IORWD="005*"400+"000 IOSPB="005*"400+"020 IOSPF="005*"400+"040 IOSTC="005*"400+"100 IOSEC="005*"400+"120 IORWU="005*"400+"140 IOSMO="005*"400+"160 IOEOF="006*"400+"000 IOKIL="000*"400+"012 IOWVB="022*"400+"000 IORVB="021*"400+"000 C ILUN=1 IEFN=1 ICNT=8192*2 C C THE MAIN EXECUTION LOOP C 10 WRITE(5,95000) READ(5,90000,END=100) ILEN,BUF C C WRITE (5,900) ILEN,BUF 900 FORMAT(' Ilen = ',I5,' string = ',80A1) 910 FORMAT(' 910ilen = ',I5,' string = ',80A1) 920 FORMAT(' 920ilen = ',I5,' string = ',80A1) IF(ILEN.LE.2.OR.ILEN.GE.8)GO TO 500 C Clean a spot in qiobuf CALL SMOV(QIOBFB,1,' ',1,6) C Copy input buffer CALL SMOV(QIOBFB,1,BUF,3,ILEN-2) C WRITE(5,910)ILEN,(QIOBFB(M),M=1,8) C Clean out number section of input buffer CALL SMOV(BUF,3,' ',1,6) C Find first non-alpha char in input string K=ILEN-2 DO 250 J=1,K IF(QIOBFB(J).LT.'A')GO TO 300 250 CONTINUE 300 CONTINUE C Move first nonalpha thur remainder back to input buffer right justified CALL SMOV(BUF,10+J-ILEN,QIOBFB,J,1-J+ILEN) C WRITE (5,920) ILEN,BUF 500 FLAG=.FALSE. DECODE(2,90005,BUF) KEYW IF (KEYW.EQ.'RL'.OR.KEYW.EQ.'rl') CALL RLB IF (KEYW.EQ.'WL'.OR.KEYW.EQ.'wl') CALL WLB IF (KEYW.EQ.'AT'.OR.KEYW.EQ.'at') CALL ATT IF (KEYW.EQ.'DE'.OR.KEYW.EQ.'de') CALL DET IF (KEYW.EQ.'RW'.OR.KEYW.EQ.'rw') CALL RWD IF (KEYW.EQ.'RU'.OR.KEYW.EQ.'ru') CALL RWU IF (KEYW.EQ.'EO'.OR.KEYW.EQ.'eo') CALL EOF IF (KEYW.EQ.'SB'.OR.KEYW.EQ.'sb') CALL SPB IF (KEYW.EQ.'SF'.OR.KEYW.EQ.'sf') CALL SPF IF (KEYW.EQ.'ST'.OR.KEYW.EQ.'st') CALL STC IF (KEYW.EQ.'SE'.OR.KEYW.EQ.'se') CALL SEC IF (KEYW.EQ.'SM'.OR.KEYW.EQ.'sm') CALL SMO IF (KEYW.EQ.'KI'.OR.KEYW.EQ.'ki') CALL KIL IF (KEYW.EQ.'DB'.OR.KEYW.EQ.'db') CALL DPB IF (KEYW.EQ.'DW'.OR.KEYW.EQ.'dw') CALL DPW IF (KEYW.EQ.'DA'.OR.KEYW.EQ.'da') CALL DPA IF (KEYW.EQ.'D7'.OR.KEYW.EQ.'d7') CALL D76 IF (KEYW.EQ.'DI'.OR.KEYW.EQ.'di') CALL DPI IF (KEYW.EQ.'DX'.OR.KEYW.EQ.'dx') CALL DXB IF (KEYW.EQ.'D8'.OR.KEYW.EQ.'d8') CALL DEB IF (KEYW.EQ.'DS'.OR.KEYW.EQ.'ds') CALL DPS IF (KEYW.EQ.'OF'.OR.KEYW.EQ.'of') CALL OFL IF (KEYW.EQ.'CO'.OR.KEYW.EQ.'co') CALL COP IF (KEYW.EQ.'CF'.OR.KEYW.EQ.'cf') CALL COF IF (KEYW.EQ.'RI'.OR.KEYW.EQ.'ri') CALL RDINT IF (KEYW.EQ.'HE'.OR.KEYW.EQ.'he') CALL HELP IF (KEYW.EQ.'UN'.OR.KEYW.EQ.'un') CALL UNI IF (KEYW.EQ.'PA'.OR.KEYW.EQ.'pa') CALL PAT IF (KEYW.EQ.' ') FLAG=.TRUE. C IF (.NOT.FLAG) WRITE(5,95005) KEYW GO TO 10 C 100 WRITE(5,95010) CALL EXIT C 90000 FORMAT(Q,80A1) 90005 FORMAT(A2) 95000 FORMAT(' Tape>',$) 95005 FORMAT(' Tape>[Unknown function:''',A2,'''] type HE for help') 95010 FORMAT('+Tape>[Exit]') END SUBROUTINE RLB BYTE BUF(80) INTEGER*2 KEYW,BYTCNT,N,IREC LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90010,BUF) N IF (N.LE.0) N=1 CALL GETADR(IPRM,QIOBUF) IPRM(2)=ICNT C DO 10 IREC=1,N CALL WTQIO(IORLB,ILUN,IEFN,,ISTAT,IPRM,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) WRITE(5,90005) ISTAT(2) BYTCNT=ISTAT(2) IF ((ISW+ISTB(1)).NE.+2) RETURN 10 CONTINUE C RETURN 90000 FORMAT(' *** Read logical block ***') 90005 FORMAT(' # Bytes transfered =',I5) 90010 FORMAT(4X,I3) END SUBROUTINE WLB BYTE BUF(80) INTEGER*2 KEYW,BYTCNT,N LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) N IF (N.LE.0.OR.N.GT.BYTCNT) N=BYTCNT CALL GETADR(IPRM,QIOBUF) IPRM(2)=N CALL WTQIO(IOWLB,ILUN,IEFN,,ISTAT,IPRM,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) WRITE (5,90010) N C RETURN 90000 FORMAT(' *** WRITE LOGICAL BLOCK ***') 90005 FORMAT(3X,I5) 90010 FORMAT(' # Bytes transfered =',I5) END SUBROUTINE PAT BYTE BUF(80) INTEGER*2 KEYW,BYTCNT,N,CNT,PATT LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C DECODE(13,90005,BUF) CNT,PATT IF (CNT.LE.0) CNT=50 C WRITE (5,90000) PATT FLAG=.TRUE. C DO 10 I=1,256 10 QIOBUF(I)=PATT CALL GETADR(IPRM,QIOBUF) IPRM(2)=512 C DO 20 I=1,CNT CALL WTQIO(IOWLB,ILUN,IEFN,,ISTAT,IPRM,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) 20 CONTINUE C RETURN 90000 FORMAT(' *** Write 512 bytes of octal ',O6, ' ***') 90005 FORMAT(3X,I5,O6) END SUBROUTINE ATT BYTE BUF(80) INTEGER*2 KEYW,BYTCNT LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C CALL WTQIO(IOATT,ILUN,IEFN,,ISTAT,,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) C RETURN 90000 FORMAT(' *** Attach ***') END SUBROUTINE DET BYTE BUF(80) INTEGER*2 KEYW,BYTCNT LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C CALL WTQIO(IODET,ILUN,IEFN,,ISTAT,,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) C RETURN 90000 FORMAT(' *** Detach ***') END SUBROUTINE RWD BYTE BUF(80) INTEGER*2 KEYW,BYTCNT LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C CALL WTQIO(IORWD,ILUN,IEFN,,ISTAT,,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) C RETURN 90000 FORMAT(' *** Rewind ***') END SUBROUTINE RWU BYTE BUF(80) INTEGER*2 KEYW,BYTCNT LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C CALL WTQIO(IORWU,ILUN,IEFN,,ISTAT,,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) C RETURN 90000 FORMAT(' *** Rewind and unload ***') END SUBROUTINE EOF BYTE BUF(80) INTEGER*2 KEYW,BYTCNT LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C CALL WTQIO(IOEOF,ILUN,IEFN,,ISTAT,,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) C RETURN 90000 FORMAT(' *** Write eof mark ***') END SUBROUTINE SPB BYTE BUF(80) INTEGER*2 KEYW,BYTCNT LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) NBS IPRM(1)=NBS CALL WTQIO(IOSPB,ILUN,IEFN,,ISTAT,IPRM,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) WRITE(5,90010) ISIGN(ISTAT(2),NBS) C RETURN 90000 FORMAT(' *** Skip n blocks ***') 90005 FORMAT(3X,I5) 90010 FORMAT(' # BLOCKS SKIPPED =',I5) END SUBROUTINE SPF BYTE BUF(80) INTEGER*2 KEYW,BYTCNT LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) NFS IPRM(1)=NFS CALL WTQIO(IOSPF,ILUN,IEFN,,ISTAT,IPRM,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) WRITE(5,90010) ISIGN(ISTAT(2),NFS) RETURN 90000 FORMAT(' *** Skip n files ***') 90005 FORMAT(3X,I5) 90010 FORMAT(' # Files skipped =',i5) END SUBROUTINE STC BYTE BUF(80) INTEGER*2 KEYW,BYTCNT,CB LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C C C DEFINITIONS OF THE BITS IN THE CHARACTERISTICS WORD C C BIT # MEANING C ----- ------- C C 15 TAPE IS PAST LOGICAL EOV C 14 TAPE IS AT LOGICAL EOV C 13 SET WHEN TAPE IS AT LOAD POINT C 12 SET IF UNIT IS 7 CHANNEL C 11 TAPE IS 1600 BPI PE (TU16 ONLY). C 10 SET IF TAPE IS PHYSICALLY WRITE LOCKED C 9 UNIT IS REWINDING C 8 SELECT ERROR ON UNIT C 7 SET IF WRITE-WITH-EXTENDED IRG IS PROHIBITED. C 6 SET IF WRITING IS PROHIBITED C 5 LAST TAPE COMMAND ENCOUNTERED EOF C 4 TAPE IS PAST EOT MARKER C 3 SET IF EVEN PARITY C 2 SET IF CORE-DUMP MODE C 1 SET IF 200 BPI C 0 SET IF 556 BPI C C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) CB IPRM(1)=CB CALL WTQIO(IOSTC,ILUN,IEFN,,ISTAT,IPRM,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) CALL WTQIO(IOSEC,ILUN,IEFN,,ISTAT,,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) WRITE (5,90010) ISTAT(2) C RETURN 90000 FORMAT(' *** Set characteristics ***') 90005 FORMAT(3X,O5) 90010 FORMAT(' Characteristic bits= ',o6) END SUBROUTINE SEC BYTE BUF(80) INTEGER*2 KEYW,BYTCNT LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C CALL WTQIO(IOSEC,ILUN,IEFN,,ISTAT,,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) WRITE(5,90005) ISTAT(2) C RETURN 90000 FORMAT(' *** Sense characteristics ***') 90005 FORMAT(' Characteristics bits = ',o6) END SUBROUTINE SMO BYTE BUF(80) INTEGER*2 KEYW,BYTCNT,CB LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) CB IPRM(1)=CB CALL WTQIO(IOSMO,ILUN,IEFN,,ISTAT,IPRM,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) C RETURN 90000 FORMAT(' *** Verify at load point and stc ***') 90005 FORMAT(3X,O5) END SUBROUTINE DIRSTA(ISW) INTEGER*2 ISW IF (ISW.EQ.+1) RETURN C WRITE(5,90000) ISW C IF (ISW.EQ.+1) WRITE(5,90005) IF (ISW.EQ.-1) WRITE(5,90010) IF (ISW.EQ.-5) WRITE(5,90015) IF (ISW.EQ.-6) WRITE(5,90020) IF (ISW.EQ.-95)WRITE(5,90025) IF (ISW.EQ.-96)WRITE(5,90030) IF (ISW.EQ.-97)WRITE(5,90035) IF (ISW.EQ.-98)WRITE(5,90040) IF (ISW.EQ.-99)WRITE(5,90045) C RETURN 90000 FORMAT('$Dir. status (',i3,'): ') 90005 FORMAT('+Ok') 90010 FORMAT('+No pool nodes') 90015 FORMAT('+Unassigned LUN') 90020 FORMAT('+Handler not resident') 90025 FORMAT('+Invalid priority') 90030 FORMAT('+Invalid LUN') 90035 FORMAT('+Invalid EFN') 90040 FORMAT('+DPB out of address space') 90045 FORMAT('+DIC or DPB size invalid') END SUBROUTINE DEVSTA(IST) BYTE IST IF (IST.EQ.+1) RETURN C WRITE(5,90000) IST C IF (IST.EQ.+1) WRITE(5,90005) IF (IST.EQ.-1) WRITE(5,90010) IF (IST.EQ.-2) WRITE(5,90015) IF (IST.EQ.-3) WRITE(5,90020) IF (IST.EQ.-4) WRITE(5,90025) IF (IST.EQ.-6) WRITE(5,90030) IF (IST.EQ.-7) WRITE(5,90035) IF (IST.EQ.-8) WRITE(5,90040) IF (IST.EQ.-9) WRITE(5,90045) IF (IST.EQ.-10)WRITE(5,90050) IF (IST.EQ.-11)WRITE(5,90055) IF (IST.EQ.-12)WRITE(5,90060) IF (IST.EQ.-13)WRITE(5,90065) IF (IST.EQ.-14)WRITE(5,90070) IF (IST.EQ.-15)WRITE(5,90075) IF (IST.EQ.-16)WRITE(5,90080) IF (IST.EQ.-19)WRITE(5,90085) IF (IST.EQ.-20)WRITE(5,90090) IF (IST.EQ.-56)WRITE(5,90095) IF (IST.EQ.-59)WRITE(5,91000) IF (IST.EQ.-62)WRITE(5,91005) C RETURN 90000 FORMAT('$Dev. status (',i3,'): ') 90005 FORMAT('+Ok') 90010 FORMAT('+Bad parameters') 90015 FORMAT('+Invalid function code') 90020 FORMAT('+Device not ready') 90025 FORMAT('+Parity error') 90030 FORMAT('+Illegal user buffer') 90035 FORMAT('+Device not attached') 90040 FORMAT('+Device already attached') 90045 FORMAT('+Device not attachable') 90050 FORMAT('+Eof detected') 90055 FORMAT('+End of volume detected') 90060 FORMAT('+Write lock out') 90065 FORMAT('+Data overrun') 90070 FORMAT('+Send/receive failure') 90075 FORMAT('+Request terminated') 90080 FORMAT('+Privilege violation') 90085 FORMAT('+Odd byte count or address') 90090 FORMAT('+Logical block number too large') 90095 FORMAT('+Bad block error') 91000 FORMAT('+Fatal hardware error!') 91005 FORMAT('+End of tape detected') END SUBROUTINE KIL BYTE BUF(80) INTEGER*2 KEYW,BYTCNT LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C CALL WTQIO(IOKIL,ILUN,IEFN,,ISTAT,,ISW) CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) C RETURN 90000 FORMAT(' *** Cancel all requests ***') END SUBROUTINE DPB BYTE BUF(80),QIOBFB(16384),ALFA INTEGER*2 KEYW,BYTCNT,N1,N2 LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) EQUIVALENCE (QIOBUF(1),QIOBFB(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) N1 IF (N1.LE.0.OR.N1.GT.BYTCNT) N1=BYTCNT N2=N1 C WRITE(3,90007) N1 DO 5 I=1,N1,20 KLUDGE=I+(AMIN0(20,N2)-1) WRITE(3,90010) I,(QIOBFB(J),J=I,KLUDGE) WRITE(3,90012) (ALFA(QIOBFB(J)),J=I,KLUDGE) N2=N2-20 5 CONTINUE C RETURN 90000 FORMAT(' *** Dump qiobuf in bytes ***') 90005 FORMAT(3X,I5) 90007 FORMAT('0Qiobuf(*), bytes: 1 -',I5) 90010 FORMAT(' ',I5,': ',20(O3,X)) 90012 FORMAT('+',T92,20A1) END SUBROUTINE DPA BYTE BUF(80),QIOBFB(16384),ALFA INTEGER*2 KEYW,BYTCNT,N1,N2 LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) EQUIVALENCE (QIOBUF(1),QIOBFB(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) N1 IF (N1.LE.0.OR.N1.GT.BYTCNT) N1=BYTCNT N2=N1 C WRITE(3,90007) N1 DO 5 I=1,N1,64 KLUDGE=I+(AMIN0(64,N2)-1) WRITE(3,90012) I,(ALFA(QIOBFB(J)),J=I,KLUDGE) N2=N2-64 5 CONTINUE C RETURN 90000 FORMAT(' *** Dump qiobuf in ascii ***') 90005 FORMAT(3X,I5) 90007 FORMAT('0Qiobuf(*), bytes: 1 -',I5) 90012 FORMAT(' ',I5,,': ',64A1) END C C This routine controls printable char range C BYTE FUNCTION ALFA(C) BYTE C,C1 C1=C IF (C.LT."040.OR.C.GT."176) C1='?' ALFA=C1 RETURN END SUBROUTINE DEB BYTE BUF(80),QIOBFB(16384),EBCASC INTEGER*2 KEYW,BYTCNT,N1,N2 LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) EQUIVALENCE (QIOBUF(1),QIOBFB(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) N1 IF (N1.LE.0.OR.N1.GT.BYTCNT) N1=BYTCNT N2=N1 C WRITE(3,90007) N1 DO 5 I=1,N1,20 KLUDGE=I+(AMIN0(20,N2)-1) WRITE(3,90010) I,(QIOBFB(J),J=I,KLUDGE) WRITE(3,90012) (EBCASC(QIOBFB(J)),J=I,KLUDGE) N2=N2-20 5 CONTINUE C RETURN 90000 FORMAT(' *** Dump qiobuf in ebcdic ***') 90005 FORMAT(3X,I5) 90007 FORMAT('0Qiobuf(*), bytes: 1 -',I5) 90010 FORMAT(' ',I5,': ',20(O3,X)) 90012 FORMAT('+',T92,20A1) END SUBROUTINE DPW BYTE BUF(80) INTEGER*2 KEYW,BYTCNT,N1,N2 LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) N1 IF (N1.LE.0.OR.(N1*2).GT.BYTCNT) N1=BYTCNT/2 N2=N1 C WRITE(3,90007) N2 DO 5 I=1,N1,10 WRITE(3,90010) I,(QIOBUF(J),J=I,I+(AMIN0(10,N2)-1)) N2=N2-10 5 CONTINUE C RETURN 90000 FORMAT(' *** Dump qiobuf in words ***') 90005 FORMAT(3X,I5) 90007 format('0qiobuf(*), words: 1 -',i5) 90010 FORMAT(X,I5,': ',10(O6,X)) END SUBROUTINE D76 BYTE BUF(80),QIOBFB(16384),BCDBUF(11000),BCDASC INTEGER*2 KEYW,BYTCNT,N1,N2 LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) EQUIVALENCE (QIOBUF(1),QIOBFB(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) N1 IF (N1.LE.0.OR.N1.GT.BYTCNT) N1=BYTCNT N2=(N1+2)*4/3 C CALL BYTBCD(QIOBFB,BCDBUF,N1) WRITE(3,90007) N2 C N1=N2 DO 5 I=1,N1,20 WRITE(3,90010) I,(BCDBUF(J),J=I,I+(AMIN0(20,N2)-1)) WRITE(3,90012) (BCDASC(BCDBUF(J)),J=I,I+(AMIN0(20,N2)-1)) N2=N2-20 5 CONTINUE RETURN C 90000 FORMAT(' *** Dump qiobuf in 7600 display code ***') 90005 FORMAT(3X,I5) 90007 FORMAT('0Qiobuf(*), bytes: 1 -',I5) 90010 FORMAT(' ',I5,': ',20(O3,X)) 90012 FORMAT('+',T92,20A1) END SUBROUTINE DPI BYTE BUF(80),QIOBFB(16384),BCDASC INTEGER*2 KEYW,BYTCNT,N1,N2 LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) EQUIVALENCE (QIOBUF(1),QIOBFB(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) N1 IF (N1.LE.0.OR.N1.GT.BYTCNT) N1=BYTCNT N2=N1 C WRITE(3,90007) N1 DO 5 I=1,N1,20 KLUDGE=I+(AMIN0(20,N2)-1) WRITE(3,90010) I,(QIOBFB(J),J=I,KLUDGE) WRITE(3,90012) (BCDASC(QIOBFB(J)),J=I,KLUDGE) N2=N2-20 5 CONTINUE C RETURN 90000 FORMAT(' *** Dump qiobuf in internal bcd ***') 90005 FORMAT(3X,I5) 90007 FORMAT('0Qiobuf(*), bytes: 1 -',I5) 90010 FORMAT(' ',I5,': ',20(O3,X)) 90012 FORMAT('+',T92,20A1) END SUBROUTINE DXB BYTE BUF(80),QIOBFB(16384) INTEGER*2 KEYW,BYTCNT,N1,N2 LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) EQUIVALENCE (QIOBUF(1),QIOBFB(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) N1 IF (N1.LE.0.OR.N1.GT.BYTCNT) N1=BYTCNT N2=N1 C WRITE(3,90007) N1 DO 5 I=1,N1,20 KLUDGE=I+(AMIN0(20,N2)-1) WRITE(3,90010) I,(QIOBFB(J),J=I,KLUDGE) WRITE(3,90012) (EXTASC(QIOBFB(J)),J=I,KLUDGE) N2=N2-20 5 CONTINUE C RETURN 90000 FORMAT(' *** Dump qiobuf in external bcd ***') 90005 FORMAT(3X,I5) 90007 FORMAT('0Qiobuf(*), bytes: 1 -',I5) 90010 FORMAT(' ',I5,': ',20(O3,X)) 90012 FORMAT('+',T92,20A1) END SUBROUTINE DPS BYTE BUF(80),QIOBFB(16384),SPLASC INTEGER*2 KEYW,BYTCNT,N1,N2 LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) EQUIVALENCE (QIOBUF(1),QIOBFB(1)) C WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) N1 IF (N1.LE.0.OR.N1.GT.BYTCNT) N1=BYTCNT N2=N1 C WRITE(3,90007) N1 DO 5 I=1,N1,20 KLUDGE=I+(AMIN0(20,N2)-1) WRITE(3,90010) I,(QIOBFB(J),J=I,KLUDGE) WRITE(3,90012) (SPLASC(QIOBFB(J)),J=I,KLUDGE) N2=N2-20 5 CONTINUE C RETURN 90000 FORMAT(' *** Dump qiobuf in special (unknown) code ***') 90005 FORMAT(3X,I5) 90007 format('0qiobuf(*), bytes: 1 -',I5) 90010 FORMAT(' ',I5,': ',20(O3,X)) 90012 FORMAT('+',T92,20A1) END SUBROUTINE BYTBCD(BYTBUF,BCDBUF,CNT) BYTE BYTBUF(6000),BCDBUF(6000),XIOR,XIAND,XISHFT INTEGER*2 CNT,IBYT,IBCD C C THIS ROUTINE TREATS THE BYTBUF ARRAY AS A STRING OF BITS WHICH C IT BREAKS INTO 6-BIT PIECES AND STORES THEM INTO CONSECUTIVE BYTES C OF BCDBUF. THUS, 3 BYTES OF BYTBUF ARE STORED INTO 4 C BYTES OF BCDBUF. C IBCD=1 BYTBUF(CNT+1)=0 BYTBUF(CNT+2)=0 BYTBUF(CNT+3)=0 DO 10 IBYT=1,CNT,3 BCDBUF(IBCD+0)=XISHFT(BYTBUF(IBYT),-2) BCDBUF(IBCD+1)=XIOR(XISHFT(XIAND(BYTBUF(IBYT),"3),+4), 1 XISHFT(BYTBUF(IBYT+1),-4)) BCDBUF(IBCD+2)=XIOR(XISHFT(XIAND(BYTBUF(IBYT+1),"17),+2), 1 XISHFT(BYTBUF(IBYT+2),-6)) BCDBUF(IBCD+3)=XIAND(BYTBUF(IBYT+2),"77) IBCD=IBCD+4 10 CONTINUE RETURN END BYTE FUNCTION BCDASC(C) BYTE C,C1 BYTE CVTBL(64) C C THE FOLLOWING CONVERSION TABLE CONVERTS FROM 7600 DISPLAY CODE TO ASCII C DATA CVTBL / 1 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 2 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 3 'U', 'V', 'W', 'X', 'Y', 'Z', '0', '1', '2', '3', 4 '4', '5', '6', '7', '8', '9', '+', '-', '*', '/', 5 '(', ')', '$', '=', ' ', ',', '.', '?', '[', ']', 6 '%', '?', '?', '?', '?', '?', '?', '<', '>', '?', 7 '?', '?', ';', '?' / C1=C IF (C.LE.0.OR.C.GT.64) C1=64 BCDASC=CVTBL(C1) RETURN END BYTE FUNCTION EBCASC(C) BYTE C BYTE CVTBL(192) INTEGER*2 C1 C C THE FOLLOWING CONVERSION TABLE CONVERTS FROM EBCDIC TO ASCII C DATA CVTBL / 1 ' ', 9*'?', '[', '.', '<', '(', '+', '|', 2 10*'?', ']', '$', '*', ')', ';', '?', 3 '-', '/', 9*'?', ',', '%', '?', '>', '?', 4 10*'?', ':', '#', '@','''', '=', '"', 64*'?', 5 '?', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 6*'?', 6 '?', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 6*'?', 7 '?', '?', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 6*'?', 8 '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 6*'?' / C1=C C1=IAND(C1,"377) IF (C1.LT.64) C1=255 EBCASC=CVTBL(C1-63) RETURN END BYTE FUNCTION EXTASC(C) BYTE C BYTE CVTBL(64) C C THE FOLLOWING CONVERSION TABLE CONVERTS FROM EXTERNAL BCD TO ASCII C DATA CVTBL / 1 '1', '2', '3', '4', '5', '6', '7', '8', '9', '0', 2 '=', '#', '@', ':', '[', ' ', '/', 'S', 'T', 'U', 3 'V', 'W', 'X', 'Y', 'Z', ']', ',', '(', '''', '"', 4 '&', '-', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 5 'R', '%', '$', '*', '^', '!', '>', '+', 'A', 'B', 6 'C', 'D', 'E', 'F', 'G', 'H', 'I', '<', '.', ')', 7 '?', '?', ';', '?' / IF (C.LE.0.OR.C.GE.64) C=64 EXTASC=CVTBL(C) RETURN END BYTE FUNCTION SPLASC(C) BYTE C,C1 BYTE CVTBL(64) C C THE FOLLOWING CONVERSION TABLE CONVERTS FROM SOME UNKNOWN FORM C OF IBM TAPE ENCODING TO ASCII. THIS CONVERSION TABLE WAS C DERIVED FROM CLOSE EXAMINATION OF ONE TAPE AND RESULTED FROM THE C COMBINED EFFORTS OF GEORGE WALLER AND GENE WAGENBRETH WHOSE C HELP IS GREATLY APPRECIATED! C DATA CVTBL / 1 ' ', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 2 'H', 'I', '?', '.', ')', '?', '?', '?', 3 '+', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 4 'Q', 'R', '?', '?', '*', '?', '?', '?', 5 '-', '/', 'S', 'T', 'U', 'V', 'W', 'X', 6 'Y', 'Z', '?', ',', '(', '?', '?', '?', 7 '0', '1', '2', '3', '4', '5', '6', '7', 8 '8', '9', '?', '=', '''','?', '?', '?' / C1=C IF (C.LT.0.OR.C.GE.64) C1=63 SPLASC=CVTBL(C1+1) RETURN END BYTE FUNCTION XIOR(M,N) BYTE M,N INTEGER*2 M1,N1,X M1=M N1=N X=IOR(M1,N1) XIOR=X RETURN END BYTE FUNCTION XIAND(M,N) BYTE M,N INTEGER M1,N1,X M1=M N1=N X=IAND(M1,N1) XIAND=X RETURN END BYTE FUNCTION XISHFT(M,N) BYTE M,N INTEGER*2 M1,N1,X,MX MX="377 M1=M N1=N X=ISHFT(IAND(M1,MX),N1) XISHFT=X RETURN END SUBROUTINE OFL BYTE BUF(80) INTEGER*2 KEYW,BYTCNT,N,IFILE,IREC LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) WRITE(5,90000) FLAG=.TRUE. C DECODE(9,90005,BUF) N IF (N.LE.0) N=1000 CALL GETADR(IPRM,QIOBUF) IPRM(2)=ICNT C DO 250 IFILE=1,N WRITE(3,90010) IFILE C DO 100 IREC=1,10000 CALL WTQIO(IORLB,ILUN,IEFN,,ISTAT,IPRM,ISW) IF (ISW.EQ.+1) GOTO 5 CALL DIRSTA(ISW) GOTO 10 5 IF (ISTB(1).EQ.+1) GOTO 15 IF (ISTB(1).NE.-10) GOTO 10 WRITE(3,90015) GOTO 200 10 CALL DEVSTA(ISTB(1)) GOTO 100 15 WRITE(3,90020) IREC,ISTAT(2) 100 CONTINUE C 200 CONTINUE CALL WTQIO(IOSEC,ILUN,IEFN,,ISTAT,ISW) IF (IAND(ISTAT(2),"020).EQ.0) GOTO 250 WRITE(3,90025) GOTO 300 250 CONTINUE 300 CALL WTQIO(IORWD,ILUN,IEFN,,ISTAT,,ISW) RETURN C 90000 FORMAT(' *** Outline n files ***') 90005 FORMAT(3X,I5) 90010 FORMAT('0*File #',I3) 90015 FORMAT(' ***Eof') 90020 FORMAT(' ***Record #',I6,' contains ',I6,' bytes') 90025 FORMAT('0*Past physical eot marker') END SUBROUTINE COP BYTE BUF(80) INTEGER*2 KEYW,BYTCNT,CNT,IFILE,ILUNW,NF,LEN LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C ILUNW=2 IF (ILUN.EQ.2) ILUNW=1 C CALL GETADR(IPRM,QIOBUF) DECODE (8,90005,BUF) NF IF (NF.LE.0) NF=1000 C DO 50 IFILE=1,NF 5 IPRM(2)=ICNT CALL WTQIO(IORLB,ILUN,IEFN,,ISTAT,IPRM,ISW) LEN=ISTAT(2) C IF (ISW.EQ.+1) GO TO 10 CALL DIRSTA(ISW) RETURN 10 IF (ISTB(1).EQ.+1) GO TO 30 IF (ISTB(1).EQ.-10) GO TO 20 CALL DEVSTA(ISTB(1)) RETURN C WRITE TAPE MARK 20 CALL WTQIO(IOEOF,ILUNW,IEFN,,ISTAT,,ISW) IF ((ISW+ISTB(1)).EQ.+2) GO TO 50 CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) RETURN C 30 IF (LEN.GT.0) GO TO 40 WRITE(5,90010) GO TO 50 C 40 IPRM(2)=LEN CALL WTQIO(IOWLB,ILUNW,IEFN,,ISTAT,IPRM,ISW) IF ((ISW+ISTB(1)).EQ.+2) GO TO 5 CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) RETURN 50 CONTINUE C RETURN C 90000 FORMAT(' *** Copy tape to tape ***') 90005 FORMAT(3X,I5) 90010 FORMAT(' *** Zero length record not copied') END C Copy an interdata format tape to disk as indiviual files SUBROUTINE RDINT BYTE BUF(80),QIOBFB(16384) INTEGER*2 KEYW,BYTCNT,CNT,IFILE,ILUNW,NF,LEN LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) EQUIVALENCE (QIOBUF(1),QIOBFB(1)) C FLAG=.TRUE. C Rewind the tape C CALL RWD C ILUNW=2 IF (ILUN.EQ.2) ILUNW=1 C CALL GETADR(IPRM,QIOBUF) DECODE (8,90005,BUF) NF IF (NF.LE.0) NF=1000 C Get rid of first block on tape, disk name CALL WTQIO(IORLB,ILUN,IEFN,,ISTAT,IPRM,ISW) C Pick up second block for file name 1000 CALL WTQIO(IORLB,ILUN,IEFN,,ISTAT,IPRM,ISW) C Now parse construct a filespec CALL SMOV(QIOBFB,1,QIOBFB,13,8) CALL STRNGS('.',QIOBFB,9) CALL SMOV(QIOBUF,10,QIOBFB,21,3) CALL STRNGS(' ',QIOBFB,13) WRITE (5,95000)(QIOBFB(J),J=1,13) 95000 FORMAT (' Filename is ',13A1) IF(ISW.EQ.+1) GO TO 2000 C If we get here we just got two eof's in a row, must be end of tape RETURN 2000 CALL ASSIGN (ILUNW,QIOBFB(1),12) OPEN (UNIT=ILUNW) C DO 50 IFILE=1,NF 5 IPRM(2)=ICNT CALL WTQIO(IORLB,ILUN,IEFN,,ISTAT,IPRM,ISW) WRITE (5,91000)ISTAT(2) 91000 FORMAT (' Read a block ',I5) LEN=ISTAT(2) C IF (ISW.EQ.+1) GO TO 10 CALL DIRSTA(ISW) RETURN 10 IF (ISTB(1).EQ.+1) GO TO 30 IF (ISTB(1).EQ.-10) GO TO 20 CALL DEVSTA(ISTB(1)) RETURN C Just hit eof 20 CONTINUE CALL CLOSE(ILUNW) C Debug C RETURN GO TO 1000 C 30 IF (LEN.GT.0) GO TO 40 WRITE(5,90010) GO TO 50 C 40 IPRM(2)=LEN DO 45 I=1,LEN,80 WRITE (ILUNW,92000)(QIOBFB(J),J=I,MIN0(LEN,I+79)) C WRITE (5,92000)(QIOBFB(K),K=I,MIN0(LEN,I+79)) 92000 FORMAT (80A1) 45 CONTINUE IF ((ISW+ISTB(1)).EQ.+2) GO TO 5 CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) RETURN 50 CONTINUE C RETURN C 90000 FORMAT(' *** Copy interdata format tape to disk ***') 90005 FORMAT(3X,I5) 90010 FORMAT(' *** Zero length record not copied') END C COF - copy from tape to one disk file named image.tap SUBROUTINE COF BYTE BUF(80),QIOBFB(16384) INTEGER*2 KEYW,BYTCNT,CNT,IFILE,ILUNW,NF,LEN LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) EQUIVALENCE (QIOBUF(1),QIOBFB(1)) C FLAG=.TRUE. C Rewind the tape C CALL RWD C ILUNW=2 IF (ILUN.EQ.2) ILUNW=1 C CALL GETADR(IPRM,QIOBUF) DECODE (8,90005,BUF) NF IF (NF.LE.0) NF=1000 2000 CALL ASSIGN (ILUNW,'IMAGE.TAP',9) OPEN (UNIT=ILUNW) C DO 50 IFILE=1,NF 5 IPRM(2)=ICNT CALL WTQIO(IORLB,ILUN,IEFN,,ISTAT,IPRM,ISW) WRITE (5,91000)ISTAT(2) 91000 FORMAT (' Read a block ',I5) LEN=ISTAT(2) C IF (ISW.EQ.+1) GO TO 10 CALL DIRSTA(ISW) RETURN 10 IF (ISTB(1).EQ.+1) GO TO 30 IF (ISTB(1).EQ.-10) GO TO 20 CALL DEVSTA(ISTB(1)) RETURN C Just hit eof 20 CONTINUE CALL CLOSE(ILUNW) C end reading on eof RETURN C GO TO 1000 C 30 IF (LEN.GT.0) GO TO 40 WRITE(5,90010) GO TO 20 C 40 IPRM(2)=LEN C Output buffer to disk as image CALL WTQIO(IOWVB,ILUNW,IEFN,,ISTAT,IPRM,ISW) IF ((ISW+ISTB(1)).EQ.+2) GO TO 5 CALL DIRSTA(ISW) CALL DEVSTA(ISTB(1)) RETURN 50 CONTINUE RETURN C 90000 FORMAT(' *** Copy tape file to disk ***') 90005 FORMAT(3X,I5) 90010 FORMAT(' *** Zero length record not copied') END SUBROUTINE UNI BYTE BUF(80) INTEGER*2 KEYW,BYTCNT,N LOGICAL*1 FLAG C INTEGER*2 IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF INTEGER*2 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL C INTEGER*2 ILUN,IEFN,ISTAT(2),IPRM(6),QIOBUF(8192),ICNT,ISW BYTE ISTB(4) C COMMON BUF,KEYW,BYTCNT,FLAG COMMON /IOFNC/ IOWLB,IORLB,IOATT,IODET,IORWD,IOSPB,IOSPF, 1 IOSTC,IOSEC,IORWU,IOSMO,IOEOF,IOKIL COMMON /QIOPRM/ ILUN,IEFN,ISTAT,IPRM,QIOBUF,ICNT,ISW C EQUIVALENCE (ISTB(1),ISTAT(1)) C WRITE(5,90000) FLAG=.TRUE. C ILUN=1 DECODE (8,90005,BUF) N IF (N.EQ.1) ILUN=2 WRITE(5,90010) ILUN-1 C RETURN 90000 FORMAT(' *** Set unit number ***') 90005 FORMAT(3X,I5) 90010 FORMAT(' *** Unit set to mt',I1,' ***') END SUBROUTINE HELP BYTE BUF(80) INTEGER*2 KEYW,BYTCNT,IREC LOGICAL*1 FLAG COMMON BUF,KEYW,BYTCNT,FLAG FLAG=.TRUE. TYPE 10 TYPE 20 TYPE 30 TYPE 40 TYPE 50 TYPE 60 TYPE 70 TYPE 80 TYPE 90 TYPE 100 TYPE 110 TYPE 120 TYPE 130 TYPE 140 TYPE 150 TYPE 160 TYPE 170 TYPE 180 TYPE 190 TYPE 200 TYPE 210 TYPE 220 10 FORMAT (' RL - Read logical block WL - Write logical block') 20 FORMAT (' AT - Attach DE - Detach') 30 FORMAT (' RW - Rewind RU - Rewind and unload') 40 FORMAT (' EO - Write Eof mark') 50 FORMAT (' ST - Set characteristics SE - Sense characteristics') 60 FORMAT (' SB - Skip n records (forward or backwards)') 70 FORMAT (' SF - Skip n files (forwards or backwards)') 80 FORMAT (' SM - Verify at load point and STC') 90 FORMAT (' KI - Cancel all requests') 100 FORMAT (' DB - Dump qiobuf in bytes and ascii characters') 110 FORMAT (' DW - Dump qiobuf in words') 120 FORMAT (' DA - Dump qiobuf in ascii characters') 130 FORMAT (' D7 - Dump qiobuf in packed 7600 display code') 140 FORMAT (' DI - Dump qiobuf in internal BCD') 150 FORMAT (' DX - Dump qiobuf in external BCD code') 160 FORMAT (' D8 - Dump qiobuf in EBCDIC') 170 FORMAT (' DS - Dump qiobuf in special (unknown) IBM code') 180 FORMAT (' OF - Outline n files') 190 FORMAT (' CO - Copy n files from tape to tape') 200 FORMAT (' UN - Set primary unit number') 210 FORMAT (' PA - Write n records of specified octal pattern') 220 FORMAT (' Commands are XXn where n can be from 1-5 digits long') RETURN END