#%A-RCB-0077-SL-13 LSTSUB -- SUBROUTINES FOR LST # Useful definitions # DEFINE MAXHEAD 120 DEFINE PAGEWIDTH 132 DEFINE PAGENOWIDTH 7 DEFINE HTAB "011 DEFINE BLANK "040 DEFINE CHAR LOGICAL*1 #%%A-RCB-0077-SL-13 LSTSUB -- GETREC: Read a record LOGICAL FUNCTION GETREC(LUDI,BUFFER) # COMMON /RECIO/ NCHAR,NHALF,INDENT CHAR BUFFER(NHALF) # # Reads a line from LUDI into BUFFER and returns character count in NCHAR. # Function value is true for end-of-file. # READ(LUDI,110,END=200) NCHAR,BUFFER 110 FORMAT(Q,PAGEWIDTH A1) RETURN (.FALSE.) # 200 RETURN (.TRUE.) END #%%A-RCB-0077-SL-13 LSTSUB -- PUTREC: Write a record SUBROUTINE PUTREC(LUW,BCC,ISTRT,BUFFER) COMMON /RECIO/ NCHAR,NHALF,INDENT COMMON /INTERN/ NLONG CHAR BCC,BUFFER(1) CHAR BUFOUT(PAGEWIDTH) # Formats NCHAR characters from BUFFER and calls PUTTER to print them. # BCC is used for carriage control. The printed line is truncated # at the right-hand side of the page. DO I = 1,INDENT [ BUFOUT(I) = BLANK ] NLONG = NCHAR + ISTRT - 1 CALL TABBER (BUFFER, BUFOUT(INDENT+1), ISTRT, PAGEWIDTH-INDENT, NLONG) NLONG = NLONG + INDENT CALL PUTTER (LUW, BCC, BUFOUT) RETURN END #%%A-RCB-0077-SL-13 LSTSUB -- PUTTER: Print a record SUBROUTINE PUTTER (LUW,BCC,BUFOUT) COMMON /INTERN/ NLONG CHAR BCC, BUFOUT(NLONG) # PUTTER is a trick to avoid an implied DO in a WRITE. WRITE (LUW,10) BCC, BUFOUT; 10 FORMAT (A1,PAGEWIDTH A1) RETURN END #%%A-RCB-0077-SL-13 LSTSUB -- TABBER: Fill header and interpret tabs SUBROUTINE TABBER(BUFFER,BHEAD,ISTRT,ISTOP,NCHAR) # # Moves characters from BUFFER to BHEAD. Tabs are converted to spaces to # give the same appearance as BUFFER had when created by EDI. # CHAR BUFFER(1), # Input line BHEAD(1) # Output record INTEGER ISTRT, # Starting position in BUFFER ISTOP, # Stopping position in BHEAD NCHAR # Entry: number of characters in BUFFER # Return: number of of last non-blank character in # BHEAD # CHAR BCHAR; INTEGER IPTR,IMARK,I,J,N # IPTR = 0 IMARK = ISTRT - 1 FOR (I=ISTRT; I<=NCHAR & IPTR<>1 & BHEAD(IPTR)==BLANK; IPTR=IPTR-1) ; # Remove trailing blanks NCHAR = IPTR RETURN END #%%A-RCB-0077-SL-13 LSTSUB -- COMPAR: Compare two strings LOGICAL FUNCTION COMPAR (STRNG1,STRNG2,N1,N2) # CHAR STRNG1(N1),STRNG2(N2); INTEGER N1,N2 # # Returns .TRUE. iff N1=N2 and the strings match exactly. # IF (N1~=N2) RETURN (.FALSE.) # FOR (I=1; I<=N1 && STRNG1(I)==STRNG2(I); I=I+1) ; IF (I>>N1) RETURN (.TRUE.) ELSE RETURN (.FALSE.) END