SUBROUTINE MAGTA ( IFUNC, LUNIT, ICODE, NWORDS, IARRAY ) C C************************************************************************ C C FORTRAN ACCESS TO MAG TAPE I/O CAPABILITIES UNDER RSX-11M. C C------------------------------------------------------------------------ C C IFUNC = -1 DETATCH UNIT C = 0 ATTATCH UNIT, MOUNT TAPE AND SET CHARACTERISTICS C = 1 READ A BLOCK OF -NWORDS- INTO -IARRAY- C = 2 WRITE A BLOCK OF -NWORDS- INTO -IARRAY- C = 3 WRITE AN END-OF-FILE C = 4 SPACE PAST -NWORDS- BLOCKS C = 5 SPACE PAST -NWORDS- FILES C = 6 REWIND AND UNLOAD C = 7 REWIND C = 8 SENSE TAPE CHARACTERISTICS C C------------------------------------------------------------------------ C C IMPLEMENTED APRIL '77 BY J. R. SOPKA C APPLIED PHYSICS LAB, HN-10 C UNIVERSITY OF WASHINGTON C SEATTLE, WASHINGTON, 98195 C C************************************************************************ C IMPLICIT INTEGER*2 ( A - Z ) C INTEGER*2 ICODE ( 2 ), IARRAY ( 1 ) C C . . . BIT FLAGS FOR MASKING OPERATIONS INTEGER*2 BIT0, BIT1, BIT2, BIT3, BIT4, BIT5, BIT6, BIT7, BIT8, . BIT9, BIT10, BIT11, BIT12, BIT13, BIT14, BIT15 DATA BIT0 / "000001 /, BIT1 / "000002 /, BIT2 / "000004 /, . BIT3 / "000010 /, BIT4 / "000020 /, BIT5 / "000040 /, . BIT6 / "000100 /, BIT7 / "000200 /, BIT8 / "000400 /, . BIT9 / "001000 /, BIT10 / "002000 /, BIT11 / "004000 /, . BIT12 / "010000 /, BIT13 / "020000 /, BIT14 / "040000 /, . BIT15 / "100000 / C C . . . SETTABLE AND CHECKABLE MAG TAPE CHARACTERISTICS INTEGER*2 BPI556, BPI200, CORE DUMP, EVEN PARITY, . PAST EOT, EOF DETECTED, WRITE PROTECT, . NO WRITE RECOVERY, WRITE RING OUT, . SEVEN TRACK, AT BOT, AT EOV EQUIVALENCE ( BPI556, BIT 0 ), . ( BPI200, BIT 1 ), . ( CORE DUMP, BIT 2 ), . ( EVEN PARITY, BIT 3 ), . ( PAST EOT, BIT 4 ), . ( EOF DETECTED, BIT 5 ), . ( WRITE PROTECT, BIT 6 ), . ( NO WRITE RECOVERY, BIT 7 ), . ( WRITE RING OUT, BIT10 ), . ( SEVEN TRACK, BIT12 ), . ( AT BOT, BIT13 ), . ( AT EOV, BIT14 ) C C . . . COMMON BLOCK CONTAINING THE STANDARD QIO FUNCTION CODES AND C THE DEVICE-SPECIFIC QIO FUNCTION CODES FOR MAGNETIC TAPE COMMON / IOFUNS / IOATT, IODET, IOKIL, IORLB, IORVB, . IOWLB, IOWVB, . IOEOF, IORWD, IORWU, IOSEC, IOSMO, . IOSPB, IOSPF, IOSTC C C . . . DEVICE DEPENDENT PARAMETERS BLOCK FOR USE WITH QIO INTEGER*2 DPARMS ( 6 ) EQUIVALENCE ( IOADDR, DPARMS(1) ), ( IOBYTS, DPARMS(2) ), . ( SETMTC, DPARMS(1) ), ( NSKIP , DPARMS(1) ) C C . . . FORTRAN ACCESS TO EXECUTIVE AND DEVICE DRIVER STATUS FLAGS INTEGER DSW LOGICAL*1 IOSTAT ( 4 ), IOERR EQUIVALENCE ( IOERR , IOSTAT( 1 ) ), ( NBTRAN, IOSTAT( 3 ) ), 1 ( MTC , IOSTAT( 3 ) ) C C . . . COMMON BLOCK CONTAINING THE EXECUTIVE DIRECTIVE STATUS CODES C RETURNED IN -DSW- ARGUMENT TO *QIO*. INTEGER*2 IXERNO ( 28 ), IXERMS ( 28 ) COMMON / DRERR / ISSUC, ISCLR, ISSET, IXERNO, IXERMS DATA NDRERR / 28 / C C . . . COMMON BLOCK CONTAINING THE I/O ERROR STATUS CODES RETURNED BY C THE MAG TAPE DRIVER IN -IOSTAT(1)- ARGUMENT TO *QIO*. LOGICAL*1 MTERNO ( 20 ) INTEGER*2 MTERMS ( 20 ) COMMON / MTERR / MTERNO, MTERMS DATA NMTERR / 20 / C C . . . DEFAULT EVENT FLAG NUMBER DATA IEVFLG / 1 / C C . . . SOME RADIX-50 CONSTANTS TO RETURN IN -ICODE(1)- DATA SUC / 3RSUC /, UNK / 3RUNK /, IFC / 3RIFC / C C . . . LOGICAL UNIT INFORMATION DATA BLOCK INTEGER*2 LUNDAT ( 6 ) DATA MT / 2HMT / LOGICAL*1 LUNNUM EQUIVALENCE ( LUNNUM, LUNDAT( 2 ) ) C C********************************************************************** C C . . . FUNCTION DISPATCH IF ( IFUNC .LT. 0 ) GO TO 10 IF ( IFUNC .GT. 8 ) GO TO 920 GO TO ( 100, 200, 300, 400, 500, 600, 700, 800 ), IFUNC C 10 CONTINUE IF ( IFUNC .EQ. 0 ) GO TO 11 IF ( IFUNC .LT. -1 ) GO TO 920 C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . DETATCH MAG TAPE UNIT FROM TASK IOCODE = IODET GO TO 900 C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . ATTATCH UNIT, MOUNT TAPE AND SET TAPE CHARACTERISTICS C C IARRAY( 1 ) = EVENT FLAG # C ( 2 ) = WRITE ACCESS IF NON-ZERO C ( 3 ) = 7-TRACK OPTIONS C 0 - NONE C 1 - 556 BPI C 2 - 200 BPI C <0 - CORE DUMP MODE C ( 4 ) = BYTE SWAP MODE IF NON-ZERO C *** NOT IMPLEMENTED YET *** C ( 5 ) = EVEN PARITY IF NON-ZERO C ( 6 ) = NO WRITE RECOVERY 11 CONTINUE IEVFLG = 1 IF ( NWORDS .LT. 1 ) GO TO 12 IF ( ( IARRAY( 1 ) .GT. 0 ) .AND. ( IARRAY( 1 ) .LE. 32 ) ) 1 IEVFLG = IARRAY( 1 ) 12 CONTINUE C . . . ATTATCH CALL QIO ( IOATT, LUNIT, IEVFLG, , IOSTAT, , DSW ) IF ( DSW .LT. ISSUC ) GO TO 930 CALL WAITFR ( IEVFLG ) IF ( IOERR .LT. ISSUC ) GO TO 910 C . . . IF NOT ASSIGNED TO MAG TAPE CAN'T SET CHARACTERISTICS CALL GETLUN ( LUNIT, LUNDAT, DSW ) IF ( LUNDAT( 1 ) .NE. MT ) GO TO 904 C . . . REWIND CALL QIO ( IORWD, LUNIT, IEVFLG, , IOSTAT, , DSW ) IF ( DSW .LT. ISSUC ) GO TO 930 CALL WAITFR ( IEVFLG ) IF ( IOERR .LT. ISSUC ) GO TO 910 C . . . CHECKING FOR 9TRK AND WRITE RING OUT CALL QIO ( IOSEC, LUNIT, IEVFLG, , IOSTAT, , DSW ) IF ( DSW .LT. ISSUC ) GO TO 930 CALL WAITFR ( IEVFLG ) IF ( IOERR .LT. ISSUC ) GO TO 910 C . . . SET UP REQUESTED CHARACTERISTICS BITS SETMTC = WRITE PROTECT IF ( NWORDS .LT. 2 ) GO TO 30 IF ( IARRAY( 2 ) .EQ. 0 ) GO TO 22 SETMTC = SETMTC .AND. .NOT. WRITE PROTECT IF ( .NOT.( MTC .AND. WRITE RING OUT ) ) GO TO 19 TYPE 5018, LUNDAT( 1 ), LUNNUM PAUSE 'TO CONTINUE TYPE "RES"' 19 CONTINUE 22 CONTINUE IF ( NWORDS .LT. 3 ) GO TO 30 I = IARRAY( 3 ) IF ( I .EQ. 0 ) GO TO 26 IF ( MTC .AND. SEVEN TRACK ) GO TO 23 TYPE 5023, LUNDAT( 1 ), LUNNUM PAUSE 'TO USE 9TRK TYPE "RES"' 23 CONTINUE IF ( I .GT. 0 ) GO TO 24 SETMTC = SETMTC .OR. CORE DUMP I = -I 24 CONTINUE IF ( I .EQ. 1 ) SETMTC = SETMTC .OR. BPI556 IF ( I .EQ. 2 ) SETMTC = SETMTC .OR. BPI200 26 CONTINUE C IF ( NWORDS .LT. 4 ) GO TO 30 C ****** BYTE SWAP MODE SELECTION NOT YET IMPLEMENTED ****** C IF ( NWORDS .LT. 5 ) GO TO 30 IF ( IARRAY( 5 ) .NE. 0 ) SETMTC = SETMTC .OR. EVEN PARITY C IF ( NWORDS .LT. 6 ) GO TO 30 IF ( IARRAY( 6 ) .NE. 0 ) 1 SETMTC = SETMTC .OR. NO WRITE RECOVERY C 30 CONTINUE IOCODE = IOSTC GO TO 900 C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . READ A LOGICAL BLOCK 100 CONTINUE IOCODE = IORLB GO TO 250 C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . WRITE A LOGICAL BLOCK 200 CONTINUE IOCODE = IOWLB C 250 CONTINUE CALL GETADR ( IOADDR, IARRAY ) IOBYTS = 2*NWORDS GO TO 900 C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . WRITE END OF FILE 300 CONTINUE IOCODE = IOEOF GO TO 900 C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . SKIP PAST BLOCKS 400 CONTINUE IOCODE = IOSPB NSKIP = NWORDS GO TO 900 C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . SKIP PAST FILES 500 CONTINUE IOCODE = IOSPF NSKIP = NWORDS GO TO 900 C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . REWIND AND UNLOAD TAPE 600 CONTINUE IOCODE = IORWU GO TO 900 C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . REWIND TAPE 700 CONTINUE IOCODE = IORWD GO TO 900 C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . SENSE DRIVE CHARACTERISTICS 800 CONTINUE IOCODE = IOSEC C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . NORMAL RETURN TO CALLING ROUTINE 900 CONTINUE CALL QIO ( IOCODE, LUNIT, IEVFLG, , IOSTAT, DPARMS, DSW ) IF ( DSW .LT. ISSUC ) GO TO 930 CALL WAITFR ( IEVFLG ) IF ( IOERR .LT. ISSUC ) GO TO 910 904 ICODE( 1 ) = SUC 905 ICODE( 2 ) = NBTRAN IF ( (IFUNC .EQ. 1) .OR. (IFUNC .EQ. 2) ) 1 ICODE( 2 ) = NBTRAN/2 RETURN C C*********************************************************************** C C . . . I/O ERROR HANDLING 910 CONTINUE DO 912 I = 1,NMTERR IF ( IOERR .EQ. MTERNO( I ) ) GO TO 913 912 CONTINUE ICODE( 1 ) = UNK GO TO 915 913 CONTINUE ICODE( 1 ) = MTERMS( I ) 915 CONTINUE GO TO 905 C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . INVALID FUNCTION CODE -IFUNC- PASSED TO *MAGTA* 920 CONTINUE ICODE( 1 ) = IFC ICODE( 2 ) = 0 RETURN C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C . . . EXECUTIVE ERROR HANDLER -- ABORT TASK 930 CONTINUE DO 932 I = 1,NDRERR IF ( DSW .EQ. IXERNO( I ) ) GO TO 933 932 CONTINUE DSW = UNK GO TO 935 933 CONTINUE DSW = IXERMS( I ) 935 CONTINUE CALL R50ASC ( 3, DSW, ICODE ) TYPE 5935, ICODE CALL EXIT C C*********************************************************************** C 5018 FORMAT ( / 1X, 5(1H*), 19H PUT WRITE RING IN , A2, I1 ) 5023 FORMAT ( / 1X, 5(1H*), 27H 7TRK OPTIONS ON 9TRK UNIT , A2, I1 ) 5935 FORMAT ( / 1X, 5(1H*), 1X, 'IE.', A2, A1, 1X, 1 'EXECUTIVE DIRECTIVE ERROR IN *MAGTA*.' 2 ' TASK TERMINATED.' ) C C*********************************************************************** C C T H E E N D