SUBROUTINE GETFOR C IMPLICIT INTEGER (A - Z) LOGICAL*1 LABEL, LIST, CONLBL, LINE, PL, B, LDASH LOGICAL*1 LPAR, RPAR, QUOTE, LE, COM, II, STAR, CL, CN, CS, CC LOGICAL*1 CI, C1, C9, CR, LHEAD, X COMMON /FORCOM/ ERRS, ITYPE, L, KIND, IP, INFILE, OUTFIL, LOUT, + LISTNG, PLINES, LPPAGE, LABEL(66), LHEAD(6), LIST(1320), CONLBL(6) C Dimension input line buffer, ? arrays DIMENSION LINE(80), PL(136) DATA LDASH / '-' / DATA PL(6)/' '/,SL/80/,SL1/81/,SL2/82/,CML/62/,PL(81)/' '/ DATA BEGIN/81/, B/' '/, LNUM/0/ DATA LPAR/'('/, RPAR/')'/, QUOTE/1H'/ DATA LE/':'/ DATA COM/';'/ DATA II/'|'/, IIC/0/ DATA STAR/'*'/, CL/'L'/, CN/'N'/, CS/'S'/, CC/'C'/, CI/'I'/ DATA DEPTH/0/, IICX/1/ DATA C1/'1'/, C9/'9'/, CR/'R'/, LTAB/' '/ 98 FORMAT (' ERROR: Unmatched parens or quotes.') C C **************************************************************** C LC = 0 L = 0 CONT = 0 PLEV = 0 QFLAG = 0 32097 IF (BEGIN .LT. 81) GO TO 32095 C Read in a line of IFTRAN from the input file READ (INFILE, 3, END=100) LINE 3 FORMAT(80A1) CALL PTAB (LINE) C Increment the line number LNUM = LNUM + 1 C Set beginning column to column 7 BEGIN = 7 C Set continuation card to OFF CONT = 0 C If this is not a comment card, jump to 32093 32095 IF (LINE(1) .NE. CC) GO TO 32093 C This is a comment card. Convert line number to alpha. CALL INTALP (LNUM, PL) C Echo line and line number to output file IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER IF (LISTNG .EQ. 1) WRITE (LOUT, 4) (PL(Z), Z=1, 6), B, B, B, LINE PLINES = PLINES + 1 4 FORMAT (135A1) BEGIN = 81 GO TO 32097 C C Is this a IFTRAN control card (* in column 1)? 32093 IF (LINE(1) .NE. STAR) GO TO 32092 C An IFTRAN control card; if *L(ist), turn listing ON. IF (LINE(2) .EQ. CL) LISTNG = 1 C If *N(olist), turn listing OFF. IF (LINE(2) .EQ. CN) LISTNG = 0 C If *S (statement end), reset LE to given character IF (LINE(2) .EQ. CS) LE = LINE(3) C If *C (comment delimiter), reset COM to given character IF (LINE(2) .EQ. CC) COM = LINE(3) C If *I (indent indicator), reset II to given character IF (LINE(2) .EQ. CI) II = LINE(3) C If *n (frequency of indent), reset IICX to N C Get number from alpha by wiping off top four bits IF ((LINE(2) .GE. C1) .AND. (LINE(2) .LE. C9)) + IICX = LINE(2) .AND. 15 C If not a *R (reset line counter), flush card IF (LINE(2) .NE. CR) GO TO 32090 C A *R card; reset line number to 0 for now LNUM = 0 I = 3 C Find new line number from given alphas 32089 IF ((LINE(I) .LT. C1) .OR. (LINE(I) .GT. C9)) GO TO 32090 LNUM = (10 * LNUM) + (LINE(I) .AND. 15) I = I + 1 GO TO 32089 C 32090 BEGIN = 81 C Finished, go back for another card GO TO 32097 C C Not a control card or a comment, must be a statement 32092 I = 5 C Flush spaces and tabs 32087 IF ((LINE(I) .NE. B) .OR. (LINE(I) .NE. LTAB) .OR. + (I .LE. 0)) GO TO 32086 I = I - 1 GO TO 32087 C C If I = 0, no stmt number preceding statement 32086 J = 5 C If no stmt number, or finished with pushup, skip 32085 IF ((I .LE. 0) .OR. (I .GE. 5)) GO TO 32083 C Push up statement numbers to end in column 5 LINE(J) = LINE(I) LINE(I) = B I = I - 1 J = J - 1 GO TO 32085 C C Find the first non-blank column 32083 IF ((BEGIN .GT. 80) .OR. (LINE(BEGIN) .NE. B)) GO TO 32082 C If not this column, increment pointer BEGIN = BEGIN + 1 GO TO 32083 C C Convert line number to alphanumeric 32082 CALL INTALP(LNUM, PL) C If card blank and listing ON, write line # and blank line IF ((BEGIN .LT. 81) .OR. (LISTNG .NE. 1)) GO TO 31999 IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER WRITE (LOUT, 4) (PL(Z), Z = 1, 6) PLINES = PLINES + 1 C If card blank, go get another 31999 IF (BEGIN .GE. 81) GO TO 32097 C Non-blank card? Copy cols 1-5 from LINE to LABEL CALL COPY (5, LINE, LABEL) C Blank first 5 columns of LINE DO 2 LOOP = 1,5 LINE(LOOP) = B 2 CONTINUE C 32080 M = 0 ENDCOL = BEGIN C If entire card image has been processed, exit loop 32079 IF (ENDCOL .GT. 80) GO TO 32078 C Set X to character in column ENDCOL X = LINE(ENDCOL) C If parenthesis level 0, skip IF (PLEV .EQ. 0) GO TO 32076 C Left paren? Increment parenthesis level IF (X .EQ. LPAR) PLEV = PLEV + 1 C Right paren? Decrement parenthesis level IF (X .EQ. RPAR) PLEV = PLEV - 1 GO TO 32077 C C Found a quote previously; looking for close quote now 32076 IF (QFLAG .NE. 1) GO TO 32075 C Quote? Toggle the quote flag IF (X .EQ. QUOTE) QFLAG = 1 - QFLAG GO TO 32077 C C Left paren? Increment parenthesis level 32075 IF (X .EQ. LPAR) PLEV = PLEV + 1 C Quote? Toggle the quote flag IF (X .EQ. QUOTE) QFLAG = 1 - QFLAG C Comment delimiter? Set M to ENDCOL IF (X .EQ. COM) M = ENDCOL C End-of-stmt character? Skip IF (X .EQ. LE) GO TO 32078 C Else this is not the end of statement; increment ENDCOL 32077 ENDCOL = ENDCOL + 1 GO TO 32079 C C If M = 0, no inline comments; set M to ENDCOL; else M points C at beginning of inline comment 32078 IF (M .EQ. 0) M = ENDCOL C I points to beginning of statement I = BEGIN C C Skip on non-space or end of statement 32074 IF ((LINE(I) .NE. B) .OR. (I .GE. ENDCOL)) GO TO 32073 C I points to true beginning of statement I = I + 1 GO TO 32074 C C J points to column preceding inline comment 32073 J = M - 1 C Find last character in IFTRAN statement preceding inline comment 32072 IF ((J .LT. I) .OR. (LINE(J) .NE. B)) GO TO 32071 C J points to end of IFTRAN statement J = J - 1 GO TO 32072 C C N points to column preceding full statement end column 32071 N = ENDCOL - 1 C Find last character in full statement including inline comment 32070 IF ((N .LE. M) .OR. (LINE(N) .NE. B)) GO TO 32069 C N points to end of full statement N = N - 1 GO TO 32070 C C K = number of characters in IFTRAN statement 32069 K = J - I + 1 C KC = number of characters in inline comment KC = N - M + 1 IF (LC .NE. 0) GO TO 32067 C If inline comment only, skip IF (K .LE. 0) GO TO 32065 C Copy pure IFTRAN statement from LINE to LIST CALL COPY(K, LINE(I), LIST(L+1)) C Number of characters in buffer increases by K L = L + K C If no inline comment, skip 32065 IF (KC .LE. 0) GO TO 32063 C Copy inline comment from LINE to LIST immediately following C pure IFTRAN statement CALL COPY(KC, LINE(M), LIST(L+1)) C End of inline comment in column LC LC = L + KC 32063 GO TO 32068 C 32067 CALL COPY(K, LINE(I), LIST(LC+1)) LC = LC + KC C 32068 BEGIN = ENDCOL + 1 IF (BEGIN .LT. 81) GO TO 32061 C Read next card image into LINE READ (INFILE,3,END=100) LINE CALL PTAB (LINE) C Increment line number LNUM = LNUM + 1 CONT = 0 BEGIN = 7 C If statement is a comment, an IFTRAN control card, or is not a C continuation card, skip IF ((LINE(1) .EQ. CC) .OR. (LINE(1) .EQ. STAR) .OR. (LINE(6) .EQ. B)) + GO TO 32061 C It must be a continuation card, set CONT to 1 CONT = 1 C Locate first non-blank column on this card image or skip at end 32058 IF ((BEGIN .GT. 80) .OR. (LINE(BEGIN) .NE. B)) GO TO 32061 C BEGIN points at first non-blank column BEGIN = BEGIN + 1 GO TO 32058 C C If a continuation card, skip back and process card 32061 IF (CONT .NE. 0) GO TO 32080 1 CALL DECIDE NDENT = DEPTH IF (NDENT .GT. 15) NDENT = 15 IF (KIND .GT. 0) GO TO(10,12,12,11,10,11,13,20,20,10,11,20,10,11,20 -),KIND GO TO 20 C 10 DEPTH = DEPTH + 1 GO TO 20 C 11 DEPTH = DEPTH - 1 IF (DEPTH .LT. 0) DEPTH = 0 GO TO 20 C 12 NDENT = NDENT - 1 IF (NDENT .LT. 0) NDENT = 0 GO TO 20 C 13 DEPTH = 0 GO TO 20 C 20 IF (LISTNG .NE. 1) GO TO 32055 IIC = IIC + 1 IF (IIC .NE. IICX) GO TO 32053 IIC = 0 IX = II GO TO 32054 C 32053 IX = B 32054 CALL COPY(5, LABEL, PL(7)) P = 12 PL(P) = B IF (NDENT .LE. 0) GO TO 32051 DO 21 LOOP = 1,NDENT P = P + 1 PL(P) = IX P = P + 1 PL(P) = B 21 CONTINUE 32051 I = 0 J = SL - P C 32050 IF ((L - I) .LE. J) GO TO 32049 CALL COPY(J, LIST(I+1), PL(P+1)) IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER WRITE (LOUT,4) (PL(Z),Z=1,6), B, B, B, (PL(Z),Z=7,SL) PLINES = PLINES + 1 I = I + J DO 30 LOOP = 2,11 PL(LOOP) = B 30 CONTINUE PL(12) = LDASH GO TO 32050 C 32049 J = L - I CALL COPY(J, LIST(I+1), PL(P+1)) P = P + J + 1 DO 31 LOOP = P,SL PL(LOOP) = B 31 CONTINUE IF (LC .LE. 0) GO TO 32047 J = LC - L IF (J .GT. CML) J = CML CALL COPY(J, LIST(L+1), PL(SL2)) P = SL1 + J 32047 IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER WRITE (LOUT,4) (PL(Z),Z=1,6), B, B, B, (PL(Z),Z=7,P) PLINES = PLINES + 1 C If entire statement processed and parens or quotes unbalanced, C write error message 32055 IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER IF ((PLEV + QFLAG) .EQ. 0) GO TO 31998 WRITE (LOUT, 98) PLINES = PLINES + 1 ERRS = ERRS + 1 31998 RETURN C 100 ITYPE = -1 GO TO 1 C END