C File name: UNMAC3.FOR !Rev 8301.291 C C*********************** Support routines for UNMAC2 ****************** C SUBROUTINE RLD BLK (RELOC,B,TYPE) !Rev 8205.231 C IMPLICIT INTEGER (A-Z) C B = "40 !ascii space CALL RD BYTE (CODE) TYPE = CODE.AND."177 IF ((CODE.AND."200) .NE. 0) B="102 !ascii B CALL RD BYTE (CODE) RELOC = CODE C RETURN END SUBROUTINE TSTUFF (STRING) !Rev 8301.291 C C============>> Stuff a string in complex buffer <<====================== C COMMON /COMPLX/ NBUF, BUF(100) BYTE BUF BYTE STRING(1) C N = 1 10 LCHAR = STRING(N) IF (LCHAR .EQ. 0) GO TO 20 IF (NBUF .GT. 100) GO TO 99 BUF (NBUF) = LCHAR NBUF = NBUF + 1 N = N+1 GO TO 10 20 IF (NBUF .GT. 100) GO TO 99 BUF(NBUF) = N-1 NBUF = NBUF + 1 RETURN C 99 CALL FTL ERR ("23,'Complex buffer overflow (>100 bytes)') RETURN END SUBROUTINE OSTUFF (NVALUE) !Rev 8301.261 C C==========>> Write a value into the complex buffer <<=================== C COMMON /COMPLX/ NBUF, BUF(100) BYTE BUF BYTE STRING (7) INTEGER SPACE DATA SPACE /"40/, STRING /7*0/ C C----------------------- Translate NVALUE ----------------------------- C N = 1 IF (NVALUE .GE. 0) GO TO 1 N = 6 GO TO 3 1 NCODE = NVALUE 2 NCODE = NCODE/"10 IF (NCODE .EQ. 0) GO TO 3 N = N+1 GO TO 2 3 CONTINUE ENCODE (6,10,STRING) NVALUE 10 FORMAT (O6) C C---------------------- Find first non-zero space --------------------- C N PTR = 1 DO 20 I=1,5 LCHAR = STRING(I) IF (LCHAR .EQ. SPACE) NPTR = NPTR + 1 20 CONTINUE NN = N + NPTR IF (NN.GT.7) NN=7 STRING(NN) = 0 C C------------------------ Output string ------------------------------- C CALL TSTUFF (STRING(NPTR)) C RETURN END SUBROUTINE OPER (STRING) !Rev 8301.202 C C=============>> Position an operator in the complex buffer <<=========== C COMMON /COMPLX/ NBUF, BUF (100) BYTE BUF BYTE STRING(1) C C------------------- Move the last argument out of the way -------------- C NBUF = NBUF - 1 N = BUF (NBUF) M = 100 DO 10 I=1,N NBUF = NBUF - 1 BUF(M) = BUF(NBUF) M = M-1 10 CONTINUE C C-------------Back over the char count of earlier argument-------------- C IF (NBUF.LE.1) GO TO 999 NBUF = NBUF - 1 NN = BUF(NBUF) C C--------------------------Stick in operator----------------------------- C M = 1 20 LCHAR = STRING(M) IF (LCHAR .EQ. 0) GO TO 30 BUF(NBUF) = STRING(M) NBUF = NBUF + 1 IF (NBUF .GT. 100) GO TO 999 M = M + 1 NN = NN + 1 GO TO 20 30 CONTINUE C C-----------------------Replace the first argument----------------------- C M = 101-N DO 40 I=1,N BUF(NBUF) = BUF(M) M = M + 1 NBUF = NBUF + 1 IF (NBUF .GT. 99) GO TO 999 NN = NN + 1 40 CONTINUE C C-------------------------Put in the new count--------------------------- C BUF(NBUF) = NN NBUF = NBUF + 1 C 999 CONTINUE RETURN END SUBROUTINE UNOPER (STRING) C C==============> Put a unary operator in the complex buffer-------------- C COMMON /COMPLX/ NBUF, BUF(100) BYTE BUF BYTE STRING(1) C C--------------------Put in the trailing >------------------------------- C IF (NBUF .EQ. 100) RETURN BUF(100) = '>' C C-------------------Move the last argument------------------------------- C NBUF = NBUF - 1 N = BUF(NBUF) M = 99 DO 10 I=1,N NBUF = NBUF - 1 BUF(M) = BUF(NBUF) M = M - 1 10 CONTINUE C C-------------------Put in the leading <--------------------------------- C BUF(M) = '<' M = M-1 C C---------------------Put in the unary operator-------------------------- C NN = N + 2 M = 1 20 LCHAR = STRING(M) IF (LCHAR .EQ. 0) GO TO 30 BUF(NBUF) = STRING(M) M = M + 1 NBUF = NBUF + 1 IF (NBUF .GT. 100) RETURN NN = NN + 1 GO TO 20 30 CONTINUE C C--------------------Replace the argument-------------------------------- C M = 99-N DO 40 I=1,N+2 BUF(NBUF) = BUF(M) NBUF = NBUF + 1 M = M + 1 40 CONTINUE C C-------------------Put in the new count--------------------------------- C BUF(NBUF) = NN NBUF = NBUF + 1 C RETURN END SUBROUTINE STORE !Rev 8301.192 C C===============> Pass the complex buffer to the RLD buffer <============ C COMMON /COMPLX/ NBUF, BUF(100) BYTE BUF C C---------Move all items to end of buffer, stripping counts-------------- C IF (NBUF .EQ. 1) RETURN M = 100 10 NBUF = NBUF - 1 N = BUF(NBUF) DO 20 I=1,N NBUF = NBUF - 1 BUF(M) = BUF(NBUF) M = M - 1 20 CONTINUE IF (NBUF .GT. 1) GO TO 10 C C-----------Move all text to the beginning of buffer--------------------- C NBUF = 1 NCOUNT = 100 - M M = M + 1 DO 30 I=1,NCOUNT BUF(NBUF) = BUF(M) NBUF = NBUF + 1 M = M + 1 30 CONTINUE C C----------------------Put in the trailing 0----------------------------- C BUF(NBUF) = 0 C C------------------------Pass the string--------------------------------- C CALL RLD TXT (BUF) C RETURN END SUBROUTINE RLD TXT (STRING) !Rev 8212.291 C C===============> Writes a string into RLD buffer <==================== C COMMON /RLD/ NRLD,NRPTR,NPOFF(50),NBOFF(50),NRBUFF(512) BYTE NRBUFF BYTE STRING(1), SPACE DATA SPACE /"40/ C DO 10 N=1,132 LCHAR = STRING(N) IF (LCHAR.EQ. 0) GO TO 20 IF (LCHAR.EQ.SPACE) GO TO 20 N R BUFF (N R PTR) = LCHAR N R PTR = N R PTR + 1 10 CONTINUE 20 CONTINUE C RETURN END SUBROUTINE RLD OCT (NVALUE) !Rev 8301.2410 C C=====> Write a left justified octal value into the RLD buffer <======= C BYTE STRING (7) INTEGER SPACE DATA SPACE /"40/ DATA STRING /6*"40,"200/ C C----------------------- Translate NVALUE ----------------------------- C N = 1 IF (NVALUE .GE. 0) GO TO 1 N = 6 GO TO 3 1 NCODE = NVALUE 2 NCODE = NCODE/"10 IF (NCODE .EQ. 0) GO TO 3 N = N+1 GO TO 2 3 CONTINUE ENCODE (6,10,STRING) NVALUE 10 FORMAT (O6) C C---------------------- Find first non-zero space --------------------- C N PTR = 1 DO 20 I=1,5 LCHAR = STRING(I) IF (LCHAR .EQ. SPACE) NPTR = NPTR + 1 20 CONTINUE NN = N + NPTR IF (NN.GT.7) NN=7 STRING(NN) = 0 C C------------------------ Output string ------------------------------- C CALL RLD TXT (STRING(NPTR)) C RETURN END