C C C C FORTRAN IV PLUS CROSS REFERENCE PROGRAM C C SAMUEL W. RUSS MS 73-07 237-2691 C C VARIABLE DEFINITION LISTING C C ILMAX # OF PRINT LINES/PAGE C C ISTEP STEP SIZE EACH PASS I=7,72 C C J1 FLAG EXCESSIVE OCCURENCE OF SOME LABEL C C J3 FLAG EXCESSIVE LABELS PROGRAM TERMINATES C C LN() ARRAY FOR STMT NUMBERS C C LPC LINE COUNTER FOR FORMAT CONTROL C C LVMAX MAX # OF (OCCURENCES+1)/LABEL C LVMAX SHOULD BE INTERGER MULTIPLE OF NLNUM C C NC NCIF CURRENT CHARACTER STRING C C NCOL NUMBER OF COLUMNS IN OCCURENCES PRINTOUT C C NL() # OF OCCURENCES FOR NTH LABEL C C NLNUM NUMBER OF LINE #/PRINT LINE IN CROSS REF PRINTOUT C C NVMAX MAX NUMBER OF LABELS+1 C C V() LABEL VECTOR C C VN CURRENT LABEL C C C C C DOUBLE PRECISION V(315),VN,VBL,VMAX DIMENSION IFILE(17),LN(315,60),NL(315),IP(315) BYTE ID(80),IT DATA VBL/' '/ DATA VMAX/']]]]]]]]'/ DATA IFILE/17*"000000/ DATA IEOF/0/ DATA N/0/ C C C 9000 FORMAT(18X,80A1) 9010 FORMAT(5X,I8,5X,80A1) 9020 FORMAT(80A1) 9040 FORMAT(/'$ENTER FILE SPECS ') 9050 FORMAT(17A2) 9210 FORMAT(10X,A8,'(',I3,')',20I5) 9220 FORMAT(10X,A8,'(',I3,')',19I5,2X,A8) 9240 FORMAT(10X,'* MAXIMUM OCCURENCES EXCEEDED FOR THIS LABEL') 9250 FORMAT(5X,4(10X,A8,2X,I5)) 9260 FORMAT(10X,'MAXIMUM NUMBER OF LABELS EXCEEDED') 9270 FORMAT(10X,'NOTE: FORMAT STMTS, SOME FORTRAN KEYWORDS AND THEIR S &TRINGWISE VARIABLE EQUIVALENTS, HOLLERITH CONSTANTS, AND') 9280 FORMAT(10X,'LABELS NOT CLEANLY BROKEN WHEN STMTS ARE CONTINUED MAY & NOT BE PROPERLY CROSS REFERENCED.') 9290 FORMAT(/'$ERROR - REENTER FILE SPECS ') 9310 FORMAT(/) 9330 FORMAT('1') C C C WRITE(5,9040) 10 CONTINUE READ(5,9050)IFILE OPEN(UNIT=1,NAME=IFILE,TYPE='OLD',ERR=20) GOTO 30 20 WRITE(5,9290) GOTO 10 30 CONTINUE L=0 IF (N.EQ.0) GO TO 40 DO 35 I=1,N NL(I)=0 35 V(I)=0. 40 NVMAX=315 LVMAX=60 NLNUM=20 ILMAX=50 NCOL=4 LPC=0 IPAGE=0 J1=0 J3=0 DO 50 I=1,NVMAX V(I)=VMAX 50 CONTINUE CALL PAGE(IFILE,IPAGE,LPC,1) 1000 CONTINUE VN=VBL ISTEP=1 READ(1,9020,END=5000)ID 1010 CONTINUE C C CHECK FOR CTRL I (HORIZONITAL TAB) C ISTART=7 DO 1020 I=1,6 IF(ID(I).EQ."11)GOTO 1030 1020 CONTINUE GOTO 1040 1030 ISTART=I+1 1040 CONTINUE C C C LPC=LPC+1 IF(LPC.LE.ILMAX)GOTO 1090 CALL PAGE(IFILE,IPAGE,LPC,1) 1090 CONTINUE IF(ID(1).EQ.'C')GOTO 1100 IF(ID(1).EQ.'D')GOTO 1100 IF(ID(6).EQ."11)GOTO 1200 IF(ISTART.NE.7)GOTO 1200 IF(ID(6).EQ.'0')GOTO 1200 IF(ID(6).NE.' ')GOTO 1300 GOTO 1200 1100 CONTINUE WRITE(6,9000)ID GOTO 1000 1200 CONTINUE L=L+1 NC=0 WRITE(6,9010)L,ID GOTO 1400 1300 WRITE(6,9000)ID 1400 CONTINUE C C START PASS THROUGH CURRENT FORTRAN STMT C DO 3000 I=ISTART,72,ISTEP IT=ID(I) IF(ISTEP.EQ.1)GOTO 1430 ISTEP=ISTEP-1 GOTO 3000 1430 CONTINUE C C LITERAL STRING EXCULSION LOGIC C IF(IT.NE."047)GOTO 1440 CALL STRING(ID,I,ISTEP) IF(ISTEP.EQ.1)GOTO 1440 GOTO 3000 1440 CONTINUE C C TEST ON CURRENT CHARACTER C IF(IT.LT.'0')GOTO 1500 IF(IT.GT.'Z')GOTO 1500 IF(IT.GT.'9'.AND.IT.LT.'A')GOTO 1500 NC=NC+1 CALL STRMOV(IT,1,1,VN,NC) IF(NC.EQ.8)GOTO 1500 GOTO 3000 1500 CONTINUE C C ISTEP SET HERE UNLESS RESET DOWNSTREAM C ISTEP=1 IF(KOMSTR(VN,1,1,'A',1).EQ.-1)GOTO 1900 C C STANDARD FORTRAN USAGE LOGIC C IF(VN .EQ. 'IF')GOTO 1900 IF(VN .EQ. 'CONTINUE')GOTO 1900 IF(VN .EQ. 'FORMAT')GOTO 1690 IF(VN .EQ. 'CALL')GOTO 1900 IF(VN .EQ. 'SUBROUTI')GOTO 1610 IF(VN .EQ. 'PRECISIO')GOTO 1600 IF(VN .EQ. 'DIMENSIO')GOTO 1600 IF(VN.EQ.'COMMON')GOTO 1900 IF(VN.EQ.'FUNCTION')GOTO 1900 IF(VN.EQ.'IMPLICIT')GOTO 1900 IF(VN.EQ.'PRINT')GOTO 1900 IF(VN .EQ. 'DATA')GOTO 1900 IF(VN .EQ. 'GOTO')GOTO 1900 IF(VN .EQ. 'GO')GOTO 1900 IF(VN .EQ. 'TO')GOTO 1900 IF(VN .EQ. 'STOP')GOTO 1900 IF(VN .EQ. 'DO')GOTO 1900 IF(VN .EQ. 'STRMOV')GOTO 1900 IF(VN .EQ. 'KOMSTR')GOTO 1900 IF(VN .EQ. 'RETURN')GOTO 1900 IF(VN .EQ. 'WRITE')GOTO 1900 IF(VN .EQ. 'READ')GOTO 1900 IF(VN.EQ.'RECORDSI')GOTO 1610 IF(VN.EQ.'BUFFERCO')GOTO 1620 IF(VN.EQ.'INITIALS')GOTO 1620 IF(VN.EQ.'EXTENDSI')GOTO 1610 IF(VN.EQ.'NOSPANBL')GOTO 1630 IF(VN.EQ.'BACKSPAC')GOTO 1600 IF(VN.EQ.'ASSOCIAT')GOTO 1650 IF(VN.EQ.'CARRIAGE')GOTO 1640 IF(VN.EQ.'EQUIVALE')GOTO 1620 IF(VN.EQ.'PARAMETE')GOTO 1600 IF (VN.NE.'END') GO TO 1700 IF (ID(I+1).EQ.' ') GO TO 5100 GOTO 1700 C C C 1600 ISTEP=2 GOTO 1900 1610 ISTEP=3 GOTO 1900 1620 ISTEP=4 GOTO 1900 1630 ISTEP=5 GOTO 1900 1640 ISTEP=8 GOTO 1900 1650 ISTEP=10 GOTO 1900 1690 CONTINUE C C FORMAT CONTINUATION EXCLUSION LOGIC C VN=VBL READ(1,9020,END=5000)ID IF(ID(1).EQ."11)GOTO 1010 IF(ID(2).EQ."11)GOTO 1010 IF(ID(3).EQ."11)GOTO 1010 IF(ID(4).EQ."11)GOTO 1010 IF(ID(5).EQ."11)GOTO 1010 IF(ID(6).EQ."11)GOTO 1010 IF(ID(6).EQ.'0')GOTO 1010 IF(ID(6).EQ.' ')GOTO 1010 LPC=LPC+1 IF(LPC.LE.ILMAX)GOTO 1695 CALL PAGE(IFILE,IPAGE,LPC,1) 1695 CONTINUE WRITE(6,9000)ID GOTO 1690 1700 CONTINUE C C LOCATE LABEL IN V() VECTOR C CALL SEARCH(V,VN,N,NVMAX,VMAX) IF(N.LT.NVMAX)GOTO 1750 J3=1 GOTO 1960 1750 CONTINUE C C UPDATE LABEL, NUMBER OF LABELS AND LINE NUMBER ARRAYS C V(N)=VN NL(N)=NL(N)+1 IF(NL(N) .GT. LVMAX-1)GOTO 1800 LN(N,NL(N))=L GOTO 1900 1800 CONTINUE C C SET * IN L() MAX LINE NUMBERS EXCEEDED C LN(N,LVMAX)='*' 1900 CONTINUE C C LOGICAL VERB EXCLUSION C IF(IT.NE.'.')GOTO 1960 IF((I+3).GT.72)GOTO 1960 IF(ID(I+3).EQ.'.')GOTO 1920 IF((I+4).GT.72)GOTO 1960 IF(ID(I+4).EQ.'.')GOTO 1940 GOTO 1960 1920 CONTINUE CALL IFTEST(ID,ISTEP,2,I,VBL) GOTO 1960 1940 CONTINUE CALL IFTEST(ID,ISTEP,3,I,VBL) 1960 CONTINUE C C PREPARE FOR NEXT LABEL C NC=0 VN=VBL 3000 CONTINUE GOTO 1000 C C END OF PROGRAM C 5000 CONTINUE IEOF=1 IF (L.EQ.0) GO TO 8600 5100 CONTINUE C C FIND TOTAL NUMBER OF LABELS C CALL SEARCH(V,'[[[[[[[[',N,NVMAX,VMAX) N=N-1 C C SORT V() CREATE POINTER VECTOR IP() C CALL SORT(V,IP,N,NVMAX) C C WRITE CROSS REFERENCE C CALL PAGE(IFILE,IPAGE,LPC,2) DO 8200 L=1,N I=IP(L) NLD=IMIN0(NL(I),LVMAX) IF(MOD(NLD,NLNUM).EQ.0)GOTO 8010 LC=IINT(FLOATI(NLD)/FLOATI(NLNUM))+1 GOTO 8020 8010 CONTINUE LC=NLD/NLNUM 8020 CONTINUE DO 8100 J=1,LC LPC=LPC+1 IF(LPC.LE.ILMAX)GOTO 8030 CALL PAGE(IFILE,IPAGE,LPC,2) 8030 CONTINUE KL=J*NLNUM IF(KL.LE.NLD)GOTO 8080 KL=NLD 8080 CONTINUE C C TEST FOR EXCESSIVE OCCURENCES C IF(LN(I,KL).EQ.'*')GOTO 8090 WRITE(6,9210)V(L),NL(IP(L)),(LN(I,K),K=NLNUM*(J-1)+1,KL) GOTO 8100 8090 CONTINUE J1=1 WRITE(6,9220)V(L),NL(IP(L)),(LN(I,K),K=NLNUM*(J-1)+1,KL) 8100 CONTINUE 8200 CONTINUE IF(J1.EQ.0)GOTO 8250 WRITE(6,9310) WRITE(6,9240) 8250 CONTINUE IF(J3.EQ.0)GOTO 8300 WRITE(6,9310) WRITE(6,9260) 8300 CONTINUE WRITE(6,9310) WRITE(6,9270) WRITE(6,9280) 8500 CONTINUE IF (IEOF.EQ.0) GO TO 30 8600 CALL CLOSE(1) WRITE(6,9330) WRITE(6,9330) WRITE(6,9330) STOP END C C SORT ROUTINE 'DIMINISHING INCREMENTS' C SUBROUTINE SORT(V,IP,N,NVMAX) DOUBLE PRECISION V(1),VN DIMENSION IP(1) DIMENSION IH(5) DATA IH/1,4,13,40,121/ IF(N.EQ.1)GOTO 400 DO 50 I=1,NVMAX IP(I)=I 50 CONTINUE K=4 IF(N.GT.121)GOTO 100 K=3 IF(N.GT.40)GOTO 100 K=2 IF(N.GT.13)GOTO 100 K=1 100 CONTINUE DO 300 L=K,1,-1 IHD=IH(L) DO 150 J=IHD+1,N I=J-IHD VN=V(J) IPN=IP(J) 110 CONTINUE IF(KOMSTR(VN,1,8,V(I),1).GE.0)GOTO 120 V(I+IHD)=V(I) IP(I+IHD)=IP(I) I=I-IHD IF(I.GT.0)GOTO 110 120 CONTINUE V(I+IHD)=VN IP(I+IHD)=IPN 150 CONTINUE 300 CONTINUE 400 CONTINUE RETURN END C C C SUBROUTINE SEARCH(V,VN,N,NVMAX,VMAX) DOUBLE PRECISION V(1),VN,VMAX DO 1000 I=1,NVMAX IF(V(I).EQ.VMAX)GOTO 800 IF(V(I).NE.VN)GOTO 1000 800 CONTINUE N=I GOTO 1200 1000 CONTINUE 1200 CONTINUE RETURN END C C C SUBROUTINE PAGE(IFILE,IPAGE,LPC,IPF) DIMENSION D(3),T(2),IFILE(17) DATA D/3*4H /,T/2*4H / 1000 FORMAT('1') 1100 FORMAT(/) 2100 FORMAT(1X,'PROGRAM LISTING ',17A2,5X,'PAGE',I3,10X,3A4,6X, &'TIME ',2A4) 2200 FORMAT(1X,'CROSS REFERENCE ',17A2,5X,'PAGE',I3,10X,3A4,6X, &'TIME ',2A4) LPC=0 IPAGE=IPAGE+1 WRITE(6,1000) CALL DATE(D) CALL TIME(T) IF(IPF.EQ.1)GOTO 1300 IF(IPF.EQ.2)GOTO 1400 1300 WRITE(6,2100)IFILE,IPAGE,D,T GOTO 1600 1400 WRITE(6,2200)IFILE,IPAGE,D,T 1600 CONTINUE WRITE(6,1100) RETURN END C C C SUBROUTINE STRING(ID,I,ISTEP) BYTE ID(1) ISTEP=1 IF(I.EQ.72)GOTO 2000 DO 1000 J=I+1,72 ISTEP=ISTEP+1 IF(ID(J).EQ."047)GOTO 2000 1000 CONTINUE ISTEP=1 2000 CONTINUE RETURN END C C C SUBROUTINE IFTEST(ID,ISTEP,NCIF,I,VBL) BYTE ID(1) DOUBLE PRECISION VNIF,VBL NC=0 VNIF=VBL DO 1000 J=1,NCIF NC=NC+1 CALL STRMOV(ID,I+J,1,VNIF,NC) 1000 CONTINUE IF(VNIF .EQ. 'EQ')GOTO 1900 IF(VNIF .EQ. 'LT')GOTO 1900 IF(VNIF .EQ. 'GT')GOTO 1900 IF(VNIF .EQ. 'LE')GOTO 1900 IF(VNIF .EQ. 'GE')GOTO 1900 IF(VNIF .EQ. 'NE')GOTO 1900 IF(VNIF .EQ. 'AND')GOTO 1910 IF(VNIF.EQ.'OR')GOTO 1900 IF(VNIF.EQ.'XOR')GOTO 1910 IF(VNIF.EQ.'EQV')GOTO 1910 IF(VNIF.EQ.'NOT')GOTO 1910 GOTO 2000 1900 ISTEP=4 GOTO 2000 1910 ISTEP=5 2000 CONTINUE RETURN END