C C THIS PROGRAM WILL CROSS REFERENCE VARIABLE NAMES IN C FORTRAN. RUN IT AND GIVE IT THE PROGRAM NAME; THE C CROSS-REFERENCE WILL BE PRINTED ON THE PRINTER. C C AUTHOR: WRIGHT DATE: JAN-76 C INTEGER IREFS(200,30) INTEGER VARBS(6,200) INTEGER NREFS(200) INTEGER CARD(80) INTEGER CARD2(80) INTEGER LINE(300) INTEGER STNO INTEGER TAB INTEGER BLANK INTEGER IFILE(17) DATA TAB/' '/ DATA IZ/'0'/ DATA I9/'9'/ DATA IC/'C'/ DATA BLANK/' '/ DATA CARD2/80*' '/ WRITE(1,6) 6 FORMAT('$ENTER FILE - ') READ(1,5,END=9999)IFILE 5 FORMAT(17A2) CALL ASSIGN(4,IFILE,34) STNO=0 IFIRST=1 IPTR=0 NVAR=0 IPRNT=0 LINENO=1 1000 READ(4,1,END=3000)CARD 1 FORMAT(80A1) IF(IPRNT.EQ.1.AND.CARD2(1).NE.IC)WRITE(3,2)STNO,CARD2 2 FORMAT(1X,I5,3X,80A1) IF(IPRNT.EQ.0.OR.CARD2(1).EQ.IC)WRITE(3,3)CARD2 3 FORMAT(9X,80A1) LINENO=LINENO+1 IF(LINENO.LT.60)GO TO 1088 LINENO=1 WRITE(3,8) 8 FORMAT('1') 1088 DO 1100 I=1,80 1100 CARD2(I)=CARD(I) IF(CARD(1).EQ.IC)GO TO 1000 DO 1200 I=1,7 IF(CARD(I).NE.TAB)GO TO 1150 IF(CARD(I+1).GT.IZ.AND.CARD(I+1).LE.I9)GO TO 1300 GO TO 1201 1150 IF(I.GT.6.AND.CARD(6).GT.IZ)GO TO 1300 1200 CONTINUE 1201 IF(IFIRST.NE.1) 1 CALL XREF(LINE,IPTR,NVAR,STNO,IREFS,NREFS,VARBS) IF(IPTR.LT.0.OR.IEOF.GT.0)GO TO 2000 IFIRST=0 IPTR=0 STNO=STNO+1 IPRNT=1 GO TO 1301 1300 IPRNT=0 1301 MODE=0 DO 1400 I=1,80 IF(MODE.NE.1)GO TO 1350 IF(CARD(I).EQ.BLANK)GO TO 1350 IPTR=IPTR+1 IF(IPTR.GT.300)GO TO 9000 LINE(IPTR)=CARD(I) 1350 IF(MODE.EQ.2)MODE=1 IF(CARD(I).EQ.TAB)MODE=1 IF(CARD(I).EQ.TAB.AND.CARD(I+1).GT.IZ.AND.CARD(I+1).LT.I9) 1 MODE=2 IF(I.GT.6.AND.MODE.EQ.0)MODE=1 1400 CONTINUE GO TO 1000 2000 CALL SORT(VARBS,NVAR,LINE) WRITE(3,9) 9 FORMAT('1 *** C R O S S - R E F E R E N C E ***') LINENO=1 DO 2100 I=1,NVAR II=LINE(I) IF (I .EQ. 1) GO TO 2010 IF(NCOMP(VARBS(1,II),1,6,VARBS(1,LINE(LPTR)),1).NE.0)GO TO 2010 DO 2005 J=1,6 2005 VARBS(J,II)=BLANK GO TO 2011 2010 LPTR = I 2011 ITOP = NREFS(II) IF (ITOP .GT. 15) ITOP = 15 WRITE(3,4)(VARBS(J,II),J=1,6),(IREFS(II,J),J=1,ITOP) 4 FORMAT(1X,6A1,1X,15I4) LINENO = LINENO + 1 IF (LINENO .LT. 60 .OR. I .EQ. NVAR)GO TO 2020 LINENO=1 WRITE(3,9) 2020 IF (NREFS(II) .LE. 15) GO TO 2100 WRITE(3,4)(BLANK,J=1,6),(IREFS(II,J),J=16,NREFS(II)) LINENO=LINENO+1 IF(LINENO.LT.60.OR.I.EQ.NVAR)GO TO 2100 LINENO=1 WRITE(3,9) 2100 CONTINUE STNO=1 NVAR=0 IPRNT=1 IPTR=0 LINENO=1 IF(IEOF.EQ.0)WRITE(3,8) IF(IEOF.EQ.0)GO TO 1301 CALL EXIT 3000 IEOF=1 WRITE(3,3)CARD GO TO 1201 9000 WRITE(1,7) 7 FORMAT(' SEVERE ERROR, STATEMENT TOO LONG TO SCAN.') 9999 CONTINUE CALL EXIT END SUBROUTINE XREF(LINE,IPTR,NVAR,STNO,IREFS,NREFS,VARBS) INTEGER LINE(300) INTEGER STNO INTEGER IREFS(200,30) INTEGER NREFS(200) INTEGER VARBS(6,200) INTEGER NPAR,LPAR,RPAR INTEGER COMMA INTEGER LREAD(5) INTEGER LWRIT(6) INTEGER LDO(2) INTEGER LIF(3) INTEGER LEND(3) INTEGER LGOTO(4) INTEGER LCALL(4) INTEGER LDATA(4) INTEGER VARB(6) INTEGER BLANK DATA L0/'0'/ DATA L9/'9'/ DATA BLANK/' '/ DATA COMMA/','/ DATA LA/'A'/ DATA LPAR/'('/ DATA RPAR/')'/ DATA LEQ/'='/ C C THE STATEMENT KEYWORD LITERALS. C DATA LREAD/'R','E','A','D','('/ DATA LWRIT/'W','R','I','T','E','('/ DATA LDO/'D','O'/ DATA LIF/'I','F','('/ DATA LEND/'E','N','D'/ DATA LGOTO/'G','O','T','O'/ DATA LCALL/'C','A','L','L'/ DATA LDATA/'D','A','T','A'/ IF(NCOMP(LINE,1,4,LDATA,1).EQ.0)RETURN JPTR=1 C C DECIDE WHAT KIND OF STATEMENT IT IS. C C STATEMENT BRANCH TABLE: C 2000 ASSIGNMENT C 3000 DO C 4000 READ C 5000 WRITE C 6000 IF C 7000 GOTO C 8000 CALL C C FIRST TRY AN ASSIGNMENT STATEMENT. C 800 NPAR=0 DO 1000 I=JPTR,IPTR IF(LINE(I).EQ.LPAR)NPAR=NPAR+1 IF(LINE(I).NE.RPAR)GO TO 1100 NPAR=NPAR-1 IF(NPAR.EQ.0.AND.LINE(I+1).NE.LEQ.AND. 1 NCOMP(LINE,JPTR,3,LIF,1).EQ.0)GO TO 6000 1100 IF(LINE(I).EQ.LEQ.AND.NPAR.EQ.0)GO TO 2000 1000 CONTINUE C C IT IS NEITHER AN ASSIGNMENT NOR A 'DO' STATEMENT. TRY I/O C STATEMENTS. C IF(NCOMP(LINE,JPTR,5,LREAD,1).EQ.0)GO TO 4000 IF(NCOMP(LINE,JPTR,6,LWRIT,1).EQ.0)GO TO 5000 IF(NCOMP(LINE,JPTR,4,LGOTO,1).EQ.0)GO TO 7000 IF(NCOMP(LINE,JPTR,4,LCALL,1).EQ.0)GO TO 8000 IF(NCOMP(LINE,1,3,LEND,1).EQ.0)IPTR=-1 RETURN C C IS EITHER ASSIGNMENT OR 'DO'. FIRST TEST FOR 'DO'. C 2000 I=I+1 DO 2010 J=I,300 IF(LINE(J).LT.L0.OR.(LINE(J).LT.LA.AND.LINE(J).GT.L9)) 1 GO TO 2020 2010 CONTINUE 2020 IF(LINE(J).EQ.COMMA.AND.NCOMP(LINE,1,2,LDO,1).EQ.0)GO TO 3000 CALL XRSTMT(LINE(JPTR),IPTR-JPTR+1,NVAR,STNO,IREFS,NREFS,VARBS) RETURN C C PROCESS FOR 'DO' STATEMENT C 3000 JPTR=JPTR+2 DO 3010 I=JPTR,IPTR IF(LINE(I).GE.LA)GO TO 3020 3010 CONTINUE 3020 JPTR=I CALL XRSTMT(LINE(JPTR),IPTR-JPTR+1,NVAR,STNO,IREFS,NREFS,VARBS) RETURN C C PROCESS FOR 'READ' STATEMENT. C 4000 JPTR=JPTR+5 CALL XRSTMT(LINE(JPTR),IPTR-JPTR+1,NVAR,STNO,IREFS,NREFS,VARBS) RETURN C C PROCESS FOR 'WRITE' STATEMENT. C 5000 JPTR=JPTR+6 CALL XRSTMT(LINE(JPTR),IPTR-JPTR+1,NVAR,STNO,IREFS,NREFS,VARBS) RETURN C C PROCESS FOR 'IF' STATEMENT. C 6000 JPTR=JPTR+3 DO 6008 I=1,6 6008 VARB(I)=BLANK ISW=0 NPAR=1 DO 6100 I=JPTR,IPTR IF(LINE(I).EQ.LPAR)NPAR=NPAR+1 IF(LINE(I).NE.RPAR)GO TO 6020 NPAR=NPAR-1 IF(NPAR.EQ.0)GO TO 6200 6020 IF(LINE(I).LT.LA.AND.ISW.EQ.0)GO TO 6100 IF((LINE(I).GT.L9.OR.LINE(I).LT.L0).AND.LINE(I).LT.LA) 1 GO TO 6070 ISW=ISW+1 VARB(ISW)=LINE(I) IF(ISW.LT.6)GO TO 6100 6070 CALL ADD(NVAR,NREFS,VARBS,IREFS,VARB,STNO) ISW=0 6100 CONTINUE 6200 JPTR=I+1 IF(LINE(JPTR).LT.LA)RETURN STNO=STNO+1 IF(JPTR.GE.IPTR)RETURN GO TO 800 C C PROCESS FOR 'GOTO' STATEMENT. C 7000 JPTR=JPTR+4 CALL XRSTMT(LINE(JPTR),IPTR-JPTR+1,NVAR,STNO,IREFS,NREFS,VARBS) RETURN C C PROCESS FOR 'CALL' STATEMENT. C 8000 JPTR=JPTR+4 CALL XRSTMT(LINE(JPTR),IPTR-JPTR+1,NVAR,STNO,IREFS,NREFS,VARBS) RETURN END SUBROUTINE XRSTMT(LINE,IPTR,NVAR,STNO,IREFS,NREFS,VARBS) INTEGER LINE(300) INTEGER STNO INTEGER IREFS(200,30) INTEGER NREFS(200) INTEGER VARBS(6,200) INTEGER VARB(6) INTEGER BLANK DATA BLANK/' '/ DATA LA/'A'/ DATA I9/'9'/ DATA IZ/'0'/ IF(IPTR.LE.0)RETURN C C SCAN THE LINE FOR ANY ALPHABETICS. C DO 800 I=1,6 800 VARB(I)=BLANK ISW=0 DO 1000 I=1,IPTR IF(LINE(I).LT.LA.AND.ISW.EQ.0)GO TO 1000 IF((LINE(I).GT.I9.OR.LINE(I).LT.IZ).AND.LINE(I).LT.LA)GO TO 900 ISW=ISW+1 VARB(ISW)=LINE(I) IF(ISW.LT.6)GO TO 1000 900 CALL ADD(NVAR,NREFS,VARBS,IREFS,VARB,STNO) ISW=0 1000 CONTINUE IF(ISW.NE.0)CALL ADD(NVAR,NREFS,VARBS,IREFS,VARB,STNO) RETURN END SUBROUTINE ADD(NVAR,NREFS,VARBS,IREFS,VARB,STNO) INTEGER NREFS(200) INTEGER VARBS(6,200) INTEGER VARB(6) INTEGER IREFS(200,30) INTEGER STNO INTEGER BLANK DATA BLANK/' '/ IF(NVAR.EQ.0)GO TO 960 DO 950 J=1,NVAR IF(NCOMP(VARB,1,6,VARBS(1,J),1).NE.0)GO TO 950 IF(NREFS(J).GE.30)GO TO 950 GO TO 965 950 CONTINUE 960 NVAR=NVAR+1 NREFS(NVAR)=0 J=NVAR 965 DO 970 K=1,6 VARBS(K,J)=VARB(K) 970 VARB(K)=BLANK NREFS(J)=NREFS(J)+1 IREFS(J,NREFS(J))=STNO RETURN END FUNCTION NCOMP(IARR,I1,I2,JARR,J1) INTEGER IARR(1) INTEGER JARR(1) J=J1 DO 1000 I=I1,I2 K=IARR(I)-JARR(J) IF(K.NE.0)GO TO 2000 1000 J=J+1 2000 IF(K.LT.0)NCOMP=-1 IF(K.GT.0)NCOMP=1 IF(K.EQ.0)NCOMP=0 RETURN END SUBROUTINE SORT(VARBS,NVAR,LINE) INTEGER VARBS(6,200) INTEGER LINE(300) INTEGER USED(200) INTEGER DLE INTEGER TEMP(6) DATA DLE/'^'/ DO 1000 I=1,NVAR 1000 USED(I)=0 DO 3000 I=1,NVAR DO 2100 J=1,6 2100 TEMP(J)=DLE IPT=1 DO 2000 J=1,NVAR IF(USED(J).NE.0.OR.NCOMP(TEMP,1,6,VARBS(1,J),1).LE.0) 1 GO TO 2000 DO 2200 K=1,6 2200 TEMP(K)=VARBS(K,J) IPT=J 2000 CONTINUE USED(IPT)=1 LINE(I)=IPT 3000 CONTINUE RETURN END