SUBROUTINE UTILITY COMMON // NF, LOCB0, B (1103) INTEGER NF, LOCB0, B (})G,,- 18:5VN, ] 5>4H5/VFP})I,,-( )5>4}[D,,- COMMON /ARGS/ LA, NA, ARG, A (51) INTEGER LA, NA, ARG, A INTEGER LETTER (5) DATA LETTER / 1LB, 1LE, 1LR, 1LS, 1LU / C---- SEARCH FOR FIRST NON-NULL, NON-NUMERIC ARGUMENT, ABORT IF NONE. 10 CALL ARG CONV ARG = ARG .AND. 7777 7777 7777 7700 0000 B IF (ARG .NE. 0) GO TO 30 IF (NA .LT. LA) GO TO 10 CALL ERROR (30HNULL OR INVALID ARGUMENT LIST.) C---- SEARCH FOR NEXT NON-NULL, NON-NUMERIC ARGUMENT, EXIT IF NONE. 20 CALL ARG CONV ARG = ARG .AND. 7777 7777 7777 7700 0000 B IF (ARG .NE. 0) GO TO 30 IF (NA .LT. LA) GO TO 20 RETURN C---- EXAMINE FIRST LETTER OF ARGUMENT AND CALL PROCESSING SUBROUTINE. 30 L = ARG .AND. 7700 0000 0000 0000 0000 B IF (L .EQ. 1LC) GO TO 40 DO 31 I = 1, 5 IF (L .EQ. LETTER (I)) GO TO 50 31 CONTINUE CALL ERROR (26HINVALID FUNCTION ARGUMENT.) C---- FIRST LETTER IS C. 40 CALL COPY GO TO 20 C---- FIRST LETTER IS B, E, R, S, OR U. 50 CALL REPOS GO TO 20 END SUBROUTINE ARG CONV 40 CALL COPY COMMON /ARGS/ LA, NA, ARG, A (51) INTEGER LA, NA, ARG, A INTEGER DIGIT (8) 50 CALL REPOS ARG = 0 IF (NA .GE. LA) RETURN NA = NA + 1 ARG = A (NA) .AND. 7777 7777 7777 7700 0000 B C---- RETURN IF ARGUMENT IS NULL OR ALPHAMERIC. IF (ARG .GE. 0 .AND. ARG .LT. 1L0) RETURN C---- ARGUMENT IS NUMERIC, STORE DIGITS ONE PER WORD. ARG = 0 N = 0 30 ARG = ISHIFT (ARG, 6) DIGIT (N+1) = ARG .AND. 77 B IF (DIGIT (N+1) .EQ. 0) GO TO 40 DIGIT (N+1) = DIGIT (N+1) - 1R0 IF (DIGIT (N+1) .LT. 0) GO TO 50 N = N + 1 GO TO 30 C---- ARGUMENT IS NUMERIC, STORE DIGITS ONE PER WORD. C---- NO B SUFFIX, CONVERT DECIMAL TO BINARY. 40 ARG = 0 DO 41 I = 1, N IF (DIGIT (I) .GE. 10) GO TO 70 ARG = ARG * 10 + DIGIT (I) 41 CONTINUE GO TO 60 GO TO 30 C---- LETTER SUFFIX, IF B CONVERT OCTAL TO BINARY. C---- NO B SUFFIX, CONVERT DECIMAL TO BINARY. 50 ARG = 0 IF (DIGIT (N+1) .NE. -31 B) GO TO 70 DO 51 I = 1, N IF (DIGIT (I) .GE. 8) GO TO 70 ARG = ARG * 8 + DIGIT (I) 51 CONTINUE C---- RETURN IF NUMBER IS IN REASONABLE RANGE. 60 IF (ARG .LT. 400000 B) RETURN 70 CALL ERROR (25HINVALID NUMERIC ARGUMENT.) END SUBROUTINE COPY COMMON // NF, LOCB0, B (1070) INTEGER NF, LOCB0, B RANGE. COMMON /ARGS/ LA, NA, ARG, A (51) INTEGER LA, NA, ARG, A COMMON /COPYCOM/ S, M1, M2, T, F1, F2, N INTEGER S, M1, M2, T, F1, F2, N INTEGER TC (3), L DATA TC / 1RR, 1RF, 1RZ / C---- ANALYZE FUNCTION ARGUMENT C(OPY)(S)(B/C)(B/C)(F/R/Z) COMMON /ARGS/ LA, NA, ARG, A (51) S = M1 = M2 = NF = 0 M = 12 L = ARG .AND. 7777 7777 0000 0000 0000 B IF (L .EQ. 4LCOPY) M = 30 ARG = ISHIFT (ARG, M) L = ARG .AND. 77 B IF (L .NE. 1RS) GO TO 10 S = 1 ARG = ISHIFT (ARG, 6) L = ARG .AND. 77 B 10 IF (L .EQ. 1RC) GO TO 20 IF (L .NE. 1RB) GO TO 900 M1 = 2 20 ARG = ISHIFT (ARG, 6) L = ARG .AND. 77 B IF (L .EQ. 1RC) GO TO 40 IF (L .EQ. 1RB) GO TO 30 M2 = M1 GO TO 50 30 M2 = 2 40 ARG = ISHIFT (ARG, 6) L = ARG .AND. 77 B 50 M2 = M2 + 4 DO 60 T = 1, 3 IF (L .EQ. TC (T)) GO TO 70 60 CONTINUE T = 4 GO TO 80 70 ARG = ISHIFT (ARG, 6) L = ARG .AND. 77 B 80 IF (L .NE. 0) GO TO 900 C---- OBTAIN FILE NAMES AND OPTIONAL COUNT. CALL ARG CONV F1 = ARG .AND. 7777 7777 7777 7700 0000 B IF (F1 .EQ. 0) GO TO 910 CALL ARG CONV F2 = ARG .AND. 7777 7777 7777 7700 0000 B IF (F2 .EQ. 0) GO TO 910 CALL ARG CONV N = ARG .AND. 7777 7777 7777 7700 0000 B IF (N .NE. 0) NA = NA - 1 N = ARG .AND. 37 7777 B IF (N .EQ. 0) N = 1 NF = 2 B (1) = F1 + 1 B (6) = F2 + 1 IF (S) 200, 100, 200 IF (F2 .EQ. 0) GO TO 910 C---- COPY WITHOUT SHIFTING. 100 CALL COPY X NF = 0 RETURN C---- COPY SHIFTED.1 B (6) = F2 + 1 200 CALL COPY S NF = 0 RETURN C---- ERROR EXITS - ABORT. NF = 0 900 CALL ERROR (31HINVALID COPY FUNCTION ARGUMENT.) 910 CALL ERROR (26HMISSING FILENAME ARGUMENT.) END SUBROUTINE COPY S NF = 0 COMMON // NF, LOCB0, B (1070) INTEGER NF, LOCB0, B COMMON /COPYCOM/ S, M1, M2, T, F1, F2, N INTEGER S, M1, M2, T, F1, F2, N INTEGER RECCT, RECLEN, BLKLEN, BUFSIZE, IN, OUT, ST, CH, L INTEGER BA1,FIRST1,IN1,OUT1,LIMIT1,BA2,FIRST2,IN2,OUT2,LIMIT2 EQUIVALENCE 1(B(1),BA1), (B(2),FIRST1), (B(3),IN1), (B(4),OUT1), (B(5),LIMIT1), 2(B(6),BA2), (B(7),FIRST2), (B(8),IN2), (B(9),OUT2), (B(10),LIMIT2) LOGICAL ENDLINE C---- INITIALIZE COUNTERS AND CIO PARAMETERS. RECCT = RECLEN = 0 CH = 1L BUFSIZE = 530 FIRST1 = IN1 = OUT1 = LOCB0 + 11 LIMIT1 = FIRST2 = IN2 = OUT2 = LOCB0 + 541 LIMIT2 = LOCB0 + 1071 LOGICAL ENDLINE C---- START READING NEXT BLOCK, WAIT FOR ALL C---- I/O TO STOP, AND BUMP RECORD LENGTH. 10 IN = IN1 BA1 = F1 + 10B + M1 CALL XCIO (BA1) CALL WAIT BLKLEN = IN1 - IN IF (BLKLEN .LT. 0) BLKLEN = BUFSIZE + BLKLEN RECLEN = RECLEN + BLKLEN C---- MOVE AND SHIFT DATA FROM BUFFER 1 TO BUFFER 2. ST = BA1 .AND. 170 B IF (IN1 .EQ. OUT1) GO TO 120 20 DO 30 I = 2, 5 B (I) = B (I) - LOCB0 B (I+5) = B (I+5) - LOCB0 30 CONTINUE OUT = OUT2 IF (OUT .EQ. FIRST2) OUT = LIMIT2 OUT = OUT - 1 40 IF (B (OUT1) .AND. 7777 B) GO TO 60 B (IN2) = ISHIFT (B (OUT1), 54) + CH ENDLINE = .TRUE. CH = 1L L = B (IN2) .AND. 7777 B IF (L .EQ. 0) GO TO 70 IF (L .NE. 5500 B) GO TO 50 B (IN2) = B (IN2) - L GO TO 70 50 ENDLINE = .FALSE. B (OUT1) = CH = 0 GO TO 80 60 B (IN2) = ISHIFT (B (OUT1), 54) L = B (IN2) .AND. 7700 0000 0000 0000 0000 B B (IN2) = B (IN2) - L + CH CH = L ENDLINE = .FALSE. 70 OUT1 = OUT1 + 1 IF (OUT1 .EQ. LIMIT1) OUT1 = FIRST1 80 IN2 = IN2 + 1 IF (IN2 .EQ. LIMIT2) IN2 = FIRST2 IF (OUT1 .NE. IN1) GO TO 90 IF (ENDLINE) GO TO 100 IF (ST .EQ. 10 B) GO TO 100 IF (OUT1 .EQ. FIRST1) OUT1 = LIMIT1 OUT1 = OUT1 - 1 B (OUT1) = 0 90 IF (IN2 .NE. OUT) GO TO 40 100 DO 110 I = 2, 5 B (I) = B (I) + LOCB0 B (I+5) = B (I+5) + LOCB0 110 CONTINUE IF (ENDLINE) GO TO 100 C---- START WRITING SHIFTED DATA AND SEE IF TERMINAL CONDITION IS MET. 120 IF (ST .EQ. 10 B) GO TO 130 IF (IN1 .EQ. OUT1) GO TO 130 BA2 = F2 + 10B + M2 CALL XCIO (BA2) CALL WAIT GO TO 20 130 BA2 = F2 + ST + M2 CALL XCIO (BA2) IF (ST .EQ. 10 B) GO TO 10 IF (ST .EQ. 20 B) GO TO (210, 240, 230, 240), T IF (ST .EQ. 30 B) GO TO (360, 320, 360, 340), T CALL ERROR (24HSYSTEM OR MACHINE ERROR.) C---- END/OF-RECORD, LOOP UNTIL N RECORDS OR EOF. 210 N = N - 1 IF (N) 240, 400, 240 CALL XCIO (BA2) C---- END-OF-RECORD, LOOP UNTIL N ZERO-LENGTH RECORDS OR EOF. 230 IF (RECLEN) 240, 400, 240 C---- END-OF-RECORD, LOOP UNTIL DOUBLE EOF. 240 RECCT = RECCT + 1 RECLEN = 0 GO TO 10 CALL XCIO (BA2) C---- END-OF-FILE, LOOP UNTIL N FILES OR DOUBLE EOF. 320 IF (RECCT) 330, 360, 330 330 N = N - 1 IF (N) 350, 400, 350 C---- END-OF-FILE, LOOP UNTIL DOUBLE EOF. 340 IF (RECCT) 350, 360, 350 350 RECCT = RECLEN = 0 GO TO 10 C---- BACKSPACE BOTH FILES OVER LAST EOF MARK. 360 CALL WAIT IN1 = OUT1 BA1 = F1 + 40B + M1 BA2 = F2 + 40B + M2 CALL XCIO (BA1) CALL XCIO (BA2) GO TO 10 C---- FINISHED, COMPLETE I/O AND PROCEED TO NEXT ARGUMENT. 400 CALL WAIT RETURN END SUBROUTINE COPY X COMMON // NF, LOCB0, B (1070) INTEGER NF, LOCB0, B COMMON /COPYCOM/ S, M1, M2, T, F1, F2, N INTEGER S, M1, M2, T, F1, F2, N INTEGER RECCT, RECLEN, BLKLEN, BUFSIZE, IN, ST INTEGER BA1, FIRST, IN1, OUT1, LIMIT, BA2, IN2, OUT2 EQUIVALENCE (B(1),BA1), (B(2),FIRST), (B(3),IN1), (B(4),OUT1), X (B(5),LIMIT), (B(6),BA2), (B(8),IN2), (B(9),OUT2) C---- INITIALIZE COUNTERS AND CIO PARAMETERS. RECCT = RECLEN = ST = 0 B(2) = B(7) = LOCB0 + 11 B(5) = B(10) = LOCB0 + 1071 IN1 = OUT1 = IN2 = OUT2 = FIRST BUFSIZE = LIMIT - FIRST C---- START READING NEXT BLOCK. (9),OUT2) 10 IN = IN1 BLKLEN = OUT1 - IN1 IF (BLKLEN .LE. 0) BLKLEN = BUFSIZE + BLKLEN IF (BLKLEN .GT. 529) OUT1 = IN1 + 529 IF (OUT1 .GE. LIMIT) OUT1 = OUT1 - BUFSIZE BA1 = F1 + 10B + M1 CALL XCIO (BA1) C---- WAIT FOR I/O TO STOP THEN START WRITING BLOCK THAT WAS JUST READ. CALL WAIT IN2 = IN1 IF (ST .NE. 10 B) OUT2 = IN OUT1 = OUT2 ST = BA1 .AND. 170 B BA2 = F2 + ST + M2 CALL XCIO (BA2) C---- BUMP RECORD LENGTH AND SEE IF TERMINAL CONDITION IS MET. BLKLEN = IN1 - IN IF (BLKLEN .LT. 0) BLKLEN = BUFSIZE + BLKLEN RECLEN = RECLEN + BLKLEN IF (ST .EQ. 10 B) GO TO 10 IF (ST .EQ. 20 B) GO TO (21, 24, 23, 24), T IF (ST .EQ. 30 B) GO TO (36, 32, 36, 34), T CALL ERROR (24HSYSTEM OR MACHINE ERROR.) C---- END-OF-RECORD, LOOP UNTIL N RECORDS OR EOF. ET. 21 N = N - 1 IF (N) 24, 40, 24 C---- END-OF-RECORD, LOOP UNTIL N ZERO-LENGTH RECORDS OR EOF. 23 IF (RECLEN) 24, 21, 24 C---- END-OF-RECORD, LOOP UNTIL DOUBLE EOF. 24 RECCT = RECCT + 1 RECLEN = 0 GO TO 10 0, 24 C---- END-OF-FILE, LOOP UNTIL N FILES OR DOUBLE EOF. 32 IF (RECCT) 33, 36, 33 33 N = N - 1 IF (N) 35, 40, 35 EOF. C---- END-OF-FILE, LOOP UNTIL DOUBLE EOF. 34 IF (RECCT) 35, 36, 35 35 RECCT = RECLEN = 0 GO TO 10 C---- BACKSPACE BOTH FILES OVER LAST EOF MARK. 36 CALL WAIT IN1 = OUT1 BA1 = F1 + 40B + M1 BA2 = F2 + 40B + M2 CALL XCIO (BA1) CALL XCIO (BA2) GO TO 10 C---- FINISHED, COMPLETE I/O AND PROCEED TO NEXT ARGUMENT. 40 CALL WAIT RETURN IN1 = OUT1 END SUBROUTINE REPOS COMMON // NF, LOCB0, FCB (5,49), PROCNO (49), BUF (513), 2 SAVEN (49), FILENO (49), OPCODE (49), MODE (49), 3 COUNT (49), RECL (49) INTEGER NF, LOCB0, FCB, PROCNO, BUF, SAVEN, FILENO, 2 OPCODE, MODE, COUNT, RECL COMMON /ARGS/ LA, NA, ARG, A (51) INTEGER LA, NA, ARG, A COMMON /RPCOM/ NP, FILE, CUR OP, FIRST, LS, NS INTEGER NP, FILE, CUR OP, FIRST, LS, NS INTEGER CIO CODE (7), PN, PC, T, STATUS DATA CIO CODE / 34B, 50B, 60B, 60B, 40B, 10B, 0 / C---- EF, REW, UNL, SAVE, BACK, SKIP INTEGER MNEM (30) DATA MNEM / 1LE, 1, 2LEF, 1, 7LENDFILE, 1, 2 1LR, 2, 3LREW, 2, 6LREWIND, 2, 3 1LU, 3, 3LUNL, 3, 6LUNLOAD, 3, 4 1LS, 4, 4LSAVE, 4, 5 1LB, 5, 4LBACK, 5, 6 1LS, 6, 4LSKIP, 6 / INTEGER TLETTER (3), SAVE MSG (5) DATA TLETTER / 1RZ, 1RR, 1RF /, SAVE MSG / 6H* SAVE, 4 * 0 / C---- INITIALIZE. NP = NF = LS = NS = 0 NA = NA - 1 FIRST = LOCB0 + 295 C---- SEARCH FOR NEXT FUNCTION ARGUMENT. 10 CALL ARG CONV ARG = ARG .AND. 7777 7777 7777 7700 0000 B IF (ARG .NE. 0) GO TO 20 IF (NA .LT. NA) GO TO 10 GO TO 100 NA = NA - 1 C---- SEE IF FUNCTION IS ENDFILE, REWIND, UNLOAD, OR SAVE. 20 DO 22 I = 1, 21, 2 IF (ARG .EQ. MNEM (I)) GO TO 24 22 CONTINUE GO TO 50 C---- YES, PROCESS FILENAME LIST. 24 CUR OP = MNEM (I+1) T = 0 26 CALL ARG CONV FILE = ARG .AND. 7777 7777 7777 7700 0000 B IF (FILE .EQ. 0) GO TO 28 T = T + 1 NP = NP + 1 CALL SET PROC GO TO 26 28 IF (T) 10, 91, 10 24 CUR OP = MNEM (I+1) C---- NO, SEE IF FUNCTION IS BACK OR SKIP. 50 M = 30 L = ARG .AND. 7777 7777 0000 0000 0000 B DO 52 I = 25, 29, 4 IF (L .EQ. MNEM (I)) GO TO 60 52 CONTINUE M = 12 L = ARG .AND. 7700 0000 0000 0000 0000 B DO 56 I = 23, 27, 4 IF (L .EQ. MNEM (I)) GO TO 60 56 CONTINUE C---- NO, MAKE THIS THE NEXT ARGUMENT FOR UTIL. NA = NA - 1 GO TO 100 C---- YES, GET MODE AND TERMINAL CONDITION. 60 CUR OP = MNEM (I+1) ARG = ISHIFT (ARG, M) L = ARG .AND. 77 B NP = NP + 1 MODE (NP) = RECL (NP) = 0 IF (L .EQ. 1RC) GO TO 62 IF (L .NE. 1RB) GO TO 90 MODE (NP) = 2 62 ARG = ISHIFT (ARG, 6) L = ARG .AND. 77 B J = 7 - CUR OP DO 64 I = J, 3 IF (L .EQ. TLETTER (I)) GO TO 66 64 CONTINUE GO TO 90 66 MODE (NP) = MODE (NP) + ISHIFT (I, 3) IF (ARG .AND. 7700 0000 0000 0000 0000 B) GO TO 90 C---- GET FILE NAME AND OPTIONAL RECORD/FILE COUNT. CALL ARG CONV FILE = ARG .AND. 7777 7777 7777 7700 0000 B IF (FILE .EQ. 0) GO TO 91 CALL ARG CONV IF (ARG .AND. 7777 7777 7777 7700 0000 B) NA = NA - 1 COUNT (NP) = ARG .AND. 37 7777 B IF (COUNT (NP) .EQ. 0) COUNT (NP) = 1 CALL SET PROC GO TO 10 /FILE COUNT. 90 CALL ERROR (26HINVALID FUNCTION ARGUMENT.) 91 CALL ERROR (26HMISSING FILENAME ARGUMENT.) C---- ALL ACTIONS TO BE PERFORMED ARE RECORDED IN TABLES. C---- NOW INITIATE AS MANY OF THEM AS POSSIBLE. 1 COUNT (NP) = ARG .AND. 37 7777 B 100 PN = PC = 0 110 IF (PN .EQ. NP) GO TO 200 PN = PN + 1 FILE = FILENO (PN) IF (FILE .EQ. 0) GO TO 110 IF (PROCNO (FILE) .NE. 0) GO TO 110 PROCNO (FILE) = PN CUR OP = OPCODE (PN) FCB (1,FILE) = FCB (1,FILE) .AND. 7777 7777 7777 7700 0000 B X .OR. CIO CODE (CUR OP) FCB (3,FILE) = FCB (4,FILE) = FIRST GO TO (150, 150, 150, 120, 130, 140, 110), CUR OP C---- OPCODE IS SAVE, SET WAIT FLAG AND RECORD PROC NO. 120 OPCODE (PN) = 7 LS = LS + 1 SAVEN (LS) = PN GO TO 150 0000 B X .OR. CIO CODE (CUR OP) C---- OPCODE IS BACKSPACE, CHANGE CIO CODE IF BS FILES. 130 IF ((MODE(PN).AND.70B) .EQ. 30B) FCB(1,FILE) = FCB(1,FILE) + 70B C---- OPCODE IS SKIP OR BACKSPACE, SET MODE BIT. 140 FCB (1,FILE) = FCB (1,FILE) .OR. MODE (PN) .AND. 2 C---- INITIATE I/O OPERATION, BUMP ACTION-INITIATED COUNT, AND LOOP. 150 CALL XCIO (FCB (1,FILE)) PC = PC + 1 GO TO 110 FCB(1,FILE) = FCB(1,FILE) + 70B C---- IF ANY ACTIONS WERE INITIATED, WAIT FOR COMPLETION OF ALL C---- AND CANCEL EACH ACTION WHOSE TERMINAL CONDITION IS MET. 200 IF (PC .EQ. 0) GO TO 300 CALL WAIT FILE = 0 210 IF (FILE .EQ. NF) GO TO 100 FILE = FILE + 1 PN = PROCNO (FILE) IF (PN .EQ. 0) GO TO 210 PROCNO (FILE) = 0 CUR OP = OPCODE (PN) GO TO (240, 240, 240, 240, 230, 250, 210), CUR OP 220 RECL (PN) = RECL (PN) + 1 GO TO 210 230 COUNT (PN) = COUNT (PN) - 1 IF (COUNT (PN)) 210, 240, 210 240 FILENO (PN) = 0 GO TO 210 250 T = ISHIFT (MODE (PN), -3) .AND. 3 STATUS = FCB (1,FILE) .AND. 170 B IF (STATUS .EQ. 10 B) GO TO (260, 210, 210), T IF (STATUS .EQ. 20 B) GO TO (270, 230, 220), T IF (STATUS .EQ. 30 B) GO TO (290, 290, 280), T CALL ERROR (24HSYSTEM OR MACHINE ERROR.) 260 RECL (PN) = RECL (PN) + FCB (3,FILE) - FIRST GO TO 210 270 RECL (PN) = RECL (PN) + FCB (3,FILE) - FIRST IF (RECL (PN) .EQ. 0) GO TO 230 RECL (PN) = 0 GO TO 210 280 IF (RECL (PN) .EQ. 0) GO TO 290 RECL (PN) = 0 GO TO 230 290 OPCODE (PN) = 5 COUNT (PN) = 1 MODE (PN) = MODE (PN) .AND. 2 .OR. 20 B GO TO 210 ECL (PN) + FCB (3,FILE) - FIRST IF (RECL (PN) .EQ. 0) GO TO 230 C---- NO ACTIONS WERE INITIATED. IF NO FILES ARE C---- WAITING TO BE SAVED, PROCEED TO NEXT ARGUMENT. 300 IF (NS .NE. LS) GO TO 310 NF = 0 RETURN COUNT (PN) = 1 C---- DISPLAY SAVE MESSAGE AND WAIT FOR OPERATOR RESPONSE. 310 DO 320 I = 2, 4 NS = NS + 1 PN = SAVEN (NS) FILE = FILENO (PN) FILENO (PN) = PROCNO (FILE) = 0 SAVE MSG (I) = IPADBL (FCB (1,FILE)) SAVE MSG (I+1) = 0 IF (NS - LS) 320, 330, 330 320 CONTINUE 330 CALL XMSG (SAVE MSG) PAUSE IF (NS - LS) 310, 100, 100 END SUBROUTINE SET PROC ILE)) SAVE MSG (I+1) = 0 COMMON // NF, LOCB0, FCB (5,49), PROCNO (49), BUF (513), 2 SAVEN (49), FILENO (49), OPCODE (49), MODE (49), 3 COUNT (49), RECL (49) INTEGER NF, LOCB0, FCB, PROCNO, BUF, SAVEN, FILENO, 2 OPCODE, MODE, COUNT, RECL COMMON /RPCOM/ NP, FILE, CUR OP, FIRST, LS, NS INTEGER NP, FILE, CUR OP, FIRST, LS, NS C---- SEE IF FILENAME ALREADY HAS A CONTROL BLOCK. IF (NF .EQ. 0) GO TO 20 DO 10 I = 1, NF IF (FILE .EQ. (FCB(1,I) .AND. 77777777777777000000B)) GO TO 30 10 CONTINUE C---- NO, CREATE A FILE CONTROL BLOCK FOR THIS FILE. 20 FILENO (NP) = NF = NF + 1 PROCNO (NF) = 0 FCB (1,NF) = FILE + 1 FCB (2,NF) = FIRST FCB (5,NF) = FIRST + 513 GO TO 40 C---- YES, PUT FILE ORDINAL IN ACTION BLOCK. 30 FILENO (NP) = I 20 FILENO (NP) = NF = NF + 1 C---- PUT OPERATION CODE IN ACTION BLOCK. 40 OPCODE (NP) = CUR OP RETURN END SUBROUTINE WAIT COMMON // NF, LOCB0, B (5,49) INTEGER NF, LOCB0, B 1 IF (NF .EQ. 0) RETURN K = 1 DO 2 I = 1, NF 2 K = K .AND. B (1,I) IF (K .NE. 0) RETURN COMMON // NF, LOCB0, B (5,49) 3 CALL XRCL GO TO 1 END 7 ASCENT UTIL ENTRY UTIL,END,EXIT,STOP EXT INITIAL,UTILITY,WAIT SPACE 3 . MAIN PROGRAM OF FILE UTILITY PACKAGE. SPACE 3 VFD D42/UTIL,N18/64 UTIL NO + RJ INITIAL CALL INITIAL - LT UTIL-1 + RJ UTILITY CALL UTILITY - LT UTIL-1 SPACE 3 END BSS 0 TERMINATION... EXIT BSS 0 STOP NO + RJ WAIT CALL WAIT - LT UTIL-1 + SA1 1 NZ X1,* SX6 051604B SEND *END* LX6 42 TO MONITOR SA6 A1 HALT PS JP HALT SPACE 3 END UTIL ASCENT INITIAL ENTRY INITIAL EXT ERROR SPACE 3 . CALL INITIAL SPACE 3 COMMON NF,1,LOCB0,1,B,1103 SPACE 1 ARGS COMMON LA,1,NA,1,ARG,1,A,51 ORG LA BSSZ 54 ORG * SPACE 3 VFD D42/INITIAL,N18/0 INITIAL NO + SB1 B+1103 SX1 A0-B1 IS FIELD LENGTH SUFFICIENT. MX7 0 NG X1,ERR1 NO, ERROR. SB1 1 SX6 B-1 YES. SA7 NF CLEAR FILE COUNT. SA6 LOCB0 STORE LOC OF B(0). SA7 76B CLEAR ASA MODE SWITCH. SX6 A0 SA1 64B SA6 A7+B1 STORE FL IN ABS 77B. SB2 B1+B1 SX6 X1 STORE NUMBER SB4 B0 OF ARGUMENTS SB5 X1 IN LA AND SA6 LA CLEAR NA. SA7 A6+B1 SB3 A7+B2 INIT1 SA1 B2+B4 BX6 X1 MOVE ARGUMENTS TO SA6 B3+B4 FORTRAN-ADDRESSABLE SB4 B4+B1 ARRAY IN /ARGS/. LT B4,B5,INIT1 SA7 B3+B4 FOLLOW WITH ZERO WORD. JP INITIAL SPACE 3 ERR1 SX1 B1 FIELD LENGTH ERROR... SX2 77B BX3 X1*X2 ROUND UP REQUIRED ZR X3,ERR1A FIELD LENGTH TO A SX1 X1+100B MULTIPLE OF 100B. ERR1A AX1 6 AX2 3 CONVERT SA3 ERR1M+3 REQUIRED SB2 36 FIELD SB3 60 LENGTH ERR1B BX4 X1*X2 TO OCTAL LX4 B2,X4 DISPLAY SB2 B2+6 CODE. IX3 X3+X4 AX1 3 INSERT NE B2,B3,ERR1B IN ERROR BX6 X3 MESSAGE. SA6 A3 SB1 ERR1M ABORT VIA + RJ ERROR ERROR ROUTINE. - LT B0,B1,INITIAL-1 SPACE 3 ERR1M DPC *FIELD LENGTH TOO SMALL - NEED 000000B.* CON 0 SPACE 3 END ASCENT IPADBL ENTRY IPADBL SPACE 3 . K = IPADBL (NAME) SPACE 3 VFD D42/IPADBL,N18/1 IPADBL NO + SA1 B1 SX0 77B MX6 42 SX5 55B BX6 X6*X1 SB1 B0 SB2 60 SB3 6 LOOP EQ B1,B2,IPADBL LX6 6 BX2 X6*X0 SB1 B1+B3 NZ X2,LOOP BX6 X6+X5 JP LOOP SPACE 3 END ASCENT ISHIFT ENTRY ISHIFT SPACE 3 . K = ISHIFT (WORD, N) SPACE 3 VFD D42/ISHIFT,N18/2 ISHIFT NO + SA2 B2 SA1 B1 SB2 X2 LX6 B2,X1 JP ISHIFT SPACE 3 END ASCENT PAUSE ENTRY PAUSE EXT XRCL SPACE 3 . CALL PAUSE SPACE 3 VFD D42/PAUSE,N18/0 PAUSE NO + SA1 0 SX6 010000B BX6 X6+X1 SA6 0 LOOP RJ XRCL - LT PAUSE-1 SA1 B0 LX1 47 NG X1,LOOP JP PAUSE SPACE 3 END ASCENT ERROR ENTRY ERROR,ACGOER EXT XMSG,WAIT SPACE 3 . CALL ERROR (MESSAGE) SPACE 3 VFD D42/ACGOER,N18/0 ACGOER NO + SA1 ACGOER BX6 X1 SIMULATE SA6 ERROR CALL ERROR (ACGMSG) SB1 ACGMSG JP ERROR+1 SPACE 3 VFD D42/ERROR,N18/1 ERROR NO + RJ XMSG CALL XMSG (MESSAGE) - LT B0,B1,ERROR-1 SA1 ERROR AX1 30 GET NAME OF THE SA1 X1-1 SUBROUTINE THAT SA3 X1 CALLED ERROR. MX6 42 BX6 X6*X3 PUT NAME IN MESSAGE. SA6 ERRMSG+2 SB1 ERRMSG + RJ XMSG CALL XMSG (ERRMSG) - LT B0,B1,ERROR-1 + SB1 ABTMSG + RJ XMSG CALL XMSG (ABTMSG) - LT B0,B1,ERROR-1 + RJ WAIT CALL WAIT - LT ERROR-1 + SA1 1 NZ X1,* SX6 010224B SEND *ABT* LX6 42 TO MONITOR. SA6 A1 HALT PS JP HALT SPACE 3 ACGMSG DPC *ASSIGNED OR COMPUTED GO TO* CON 0 ERRMSG DPC *ERROR IN SUBROUTINE XXXXXXX* CON 0 ABTMSG DPC *JOB ABORTED BY UTIL PROGRAM.* CON 0 SPACE 3 END ASCENT XCIO ENTRY XCIO SPACE 3 . CALL XCIO (BA) SPACE 3 VFD D42/XCIO,N18/1 XCIO NO + SA1 1 NZ X1,* SX6 031117B CIO SX7 B1 LX6 42 BX6 X6+X7 SA6 A1 JP XCIO SPACE 3 END ASCENT XMSG ENTRY XMSG EXT XRCL SPACE 3 . CALL XMSG (MESSAGE) SPACE 3 VFD D42/XMSG,N18/1 XMSG NO + SB3 B0 SB4 4 SB7 1 L1 GE B3,B4,L2 SA1 B1+B3 SB3 B3+B7 NZ X1,L1 L2 SB3 B3-B7 MX0 48 ZR B3,XMSG SA1 B1+B3 BX6 -X0*X1 ZR X6,L3 SX6 X6-5555B ZR X6,L3 SA1 A1+B7 ZR X1,L3 SA1 A1-B7 L3 BX6 X0*X1 SA6 A1 SX6 152307B + SA1 1 NZ X1,* LX6 42 SX7 B1 BX6 X6+X7 SA6 A1 + RJ XRCL DELAY TO KEEP - LT XMSG-1 MESSAGES IN ORDER. + RJ XRCL - LT XMSG-1 JP XMSG SPACE 3 END FINIS +X7