C File Name: UNMACO.FOR !Rev 8302.051 C C All output routines for UNMAC are in this file C C******************************************************************** C SUBROUTINE FTL ERR (N,STRING) !Rev 8202.051 C C====================>> FATAL ERROR HANDLER <<===================== C IMPLICIT INTEGER (A-Z) C COMMON /INPUT/ BLOCK, COUNT, INPUT(512) BYTE INPUT BYTE STRING(1) C CALL CRLF CALL OUT TXT ('?UNMAC-F-Error ') CALL OUT OCT (N) CALL OUT TXT (', ') CALL OUT TXT (STRING) CALL CRLF CALL OUT TXT (' Error occurred at block ') CALL OUT OCT (BLOCK) CALL OUT TXT (', count ') CALL OUT OCT (COUNT) CALL CRLF CALL CRLF CALL OUT TXT ('Block contents:') DO 20 I = 0,31 NN = I*16 CALL NEWLIN CALL OUT OCR (NN) CALL OUT TXT (' ') DO 10 J = 1,16 NNN = NN + J CALL OUT TXT (' ') LOUT = INPUT(NNN) LOUT = LOUT.AND."377 CALL OUT BYT (LOUT) 10 CONTINUE 20 CONTINUE CALL CRLF C CALL EXIT END SUBROUTINE NEWLIN !Rev 8205.181 C C=======>> Output new line and if a listing also four tabs <<======== C COMMON /MACRO/ MACRO LOGICAL MACRO C CALL CRLF IF (.NOT.MACRO) CALL OUT TXT (' ') C RETURN END SUBROUTINE CRLF !Rev 8302.021 C C=================>> Flushes the output buffer <<=================== C COMMON /LUN/ LUN IN, LUN OUT, LUN TT COMMON /OUTPUT/ OUT(132), NOUT BYTE OUT D COMMON /REWIND/ RWND FL, DO RWND D LOGICAL RWND FL, DO RWND C BYTE SPACE DATA SPACE /"40/ C C---------------- If buffer is empty, put in a space ---------------- C IF (NOUT.NE.1) GO TO 10 OUT(1) = SPACE NOUT = 2 10 CONTINUE C C--------------------------- Write it out --------------------------- C NOUT = NOUT - 1 D IF (DO RWND) REWIND LUN OUT D DO RWND = .FALSE. WRITE (LUN OUT, 20) (OUT(I),I=1,NOUT) 20 FORMAT (132A1) C C----------------- Reset pointer for next character ----------------- C NOUT = 1 C RETURN END SUBROUTINE OUT INT (NVALUE) !Rev 8301.291 C C========>> Writes an integer value into the output file <<========= C BYTE STRING (7), SPACE DATA STRING /7*0/, SPACE /"40/ C C------------------------ Translate NVALUE ------------------------- C ENCODE (6,10,STRING) NVALUE 10 FORMAT (I6) C C---------------------- Find first non space ----------------------- C N PTR = 1 DO 20 I=1,5 LCHAR = STRING(I) IF (LCHAR .EQ. SPACE) N PTR = N PTR + 1 20 CONTINUE C C------------------------ Output the string ------------------------ C CALL OUT TXT (STRING(N PTR)) CALL OUT TXT ('.') C RETURN END SUBROUTINE OUT OCT (NVALUE) !Rev 8301.291 C C===>> Write a left justified octal value into the output file <<=== C BYTE STRING (7), SPACE DATA STRING /7*0/, SPACE /"40/ C C------------------------- Translate NVALUE ------------------------- C ENCODE (6,10,STRING) NVALUE 10 FORMAT (O6) C C----------------------- Find first non space ----------------------- C N PTR = 1 DO 20 I=1,5 LCHAR = STRING(I) IF (LCHAR .EQ. SPACE) N PTR = N PTR + 1 20 CONTINUE C C-------------------------- Output string --------------------------- C CALL OUT TXT (STRING(N PTR)) C RETURN END SUBROUTINE OUT TXT (STRING) !Rev 8302.021 C C==========>> Move a string of text to the output buffer <<========== C COMMON /OUTPUT/ OUT(132), NOUT BYTE OUT BYTE STRING(1) C C-------------------------------------------------------------------- C N = 1 10 IF (STRING(N).EQ.0) RETURN IF (NOUT.GT.132) NOUT = 132 OUT(NOUT) = STRING(N) NOUT = NOUT + 1 N = N + 1 GO TO 10 C END SUBROUTINE OUT GBL (NAME) !Rev 8301.291 C C Writes NAME to output file, padding it out with spaces to C six characters, then adds two additional spaces. C BYTE NAME(1), STRING(9), SPACE DATA STRING/9*0/, SPACE/"40/ C C---------------------------- Output name ---------------------------- C DO 20 I = 1,6 II = I LCHAR = NAME(I) STRING(I) = LCHAR IF (LCHAR .EQ. 0) GO TO 30 20 CONTINUE II = 7 C 30 CONTINUE C C---------------------------- Add spaces ----------------------------- C DO 40 J =II,8 STRING(J) = SPACE 40 CONTINUE C C------------------------- Output the string ------------------------- C CALL OUT TXT (STRING) C RETURN END SUBROUTINE OUT OCR (NVALUE) !Rev 8301.261 C C===>> Writes a right justified octal value into the output file <<=== C BYTE STRING(7) DATA STRING /7*0/ C C--------------------------------------------------------------------- C ENCODE (6,10,STRING) NVALUE 10 FORMAT (O6) CALL OUT TXT (STRING) C RETURN END SUBROUTINE OUT BYT (NVALUE) !Rev 8301.261 C C====>> Writes a right justified byte value to the output file <<==== C BYTE STRING(4) DATA STRING /4*0/ C C-------------------------------------------------------------------- C ENCODE (3,10,STRING) NVALUE 10 FORMAT (O3) CALL OUT TXT (STRING) C RETURN END SUBROUTINE SHORTN (STRING) !Rev 8302.031 C C============>> Strip trailing spaces from a string <<============= C BYTE STRING(1), SPACE DATA SPACE /"40/ C C--------------------------- Find the end --------------------------- C N = 1 10 LCHAR = STRING(N) IF (LCHAR .EQ. 0) GO TO 20 N = N+1 IF (N.GE.7) GO TO 20 GO TO 10 20 CONTINUE C C----------------------- Back up over spaces ------------------------ C 30 N = N-1 IF (N.EQ.0) GO TO 40 LCHAR = STRING(N) IF (LCHAR .EQ. SPACE) GO TO 30 40 CONTINUE C C---------------------- Put a null at the end ---------------------- C STRING(N+1) = 0 RETURN END