PROGRAM UNDEF C C THIS PROGRAM MAKES A TEST FOR UNDEFINED VARIABLES USING A C FORTRAN LISTING LI:2 PRINT FILE C C CHANGES: C 21-APR-79 MODIFIED PROGRAM TO ACCEPT COMMAND LINE C 15-MAY-79 FORTRAN COMPILATION OF SOURCE PROGRAM IS C AUTOMATICALLY DONE TO GET LISTING PROGRAM, C UNLESS '/LI' OPTION IS USED AFTER FILENAME. C '/LI' OPTION MEANS INPUT PROGRAM IS LISTING C PROGRAM CREATED BY FOR/LIST:FNAME/SW:(/LI:2) C DEFAULT EXTENSION IS .FTN, WITH NO OPTION C " " IS .LST, WITH /LI OPTION C C 24-JUN-79 MODIFIED PROGRAM TO HANDLE EQUIVALENCE GROUPS C CORRECTLY, I.E., IF ONE VARIABLE IF A GROUP C HAS BEEN DEFINED, ALL VARIABLES IN GROUP ARE C CONSIDERED DEFINED C C 27-JUN-79 MODIFIED PROGRAM TO ACCEPT "DECODE" STATEMENT C ALSO, VARIABLES IN A SUBROUTINE CALL STATEMENT C THAT ARE NOT DEFINED ELSEWHERE IN A PROGRAM C ARE OUTPUT TO THE TERMINAL C C 01-JUL-79 MODIFIED PROGRAM SO THAT VARIABLES APPEARING C IN A SUBROUTINE CALL STATEMENT ARE FLAGGED. C IF THEY ARE NOT DEFINED ELSEWHERE IN PROGRAM C A MESSAGE IS OUTPUT -- THE FOLLOWING VARIABLES C ARE ASSUMED TO BE DEFINED BY CALLED ROUTINE-- C THE VARIABLES ARE THEN LISTED C C 01-AUG-79 ALL USER FUNCTION REFERENCES ARE LISTED C C 04-AUG-79 '/LP' OPTION AFTER FILENAME ROUTES OUTPUT TO C PRINTER C C 05-APR-80 INDEX VARIABLES IN AN IMPLIED DO LOOP IN A C WRITE STATEMENT ARE NOW DEFINED C C BYTE FNAME(35),FILE(36),LINE(132),FORT(7),VARI(9),VARS(8) BYTE BFILE(36) BYTE ARRY(6),LABL(6),CARD(80),IA,IT,IB,I4,STRING,ISTR,VAR BYTE BBLANK, FFNAME(36), BDEF(5) BYTE BUF(80) REAL*8 CMD(10) LOGICAL*1 LABELL DIMENSION IOK(13),ITBS(30) COMMON STRING(660),ISTR(660),VAR(6),NV COMMON/EQUIV/ IEQG, IEQDEF, IEQARR(30) ! 24-JUN-79 COMMON/ISUBC/ ISUBC ! 27-JUN-79 COMMON/FUNCT/ NFUNC,NFUNCT,BSUBNM(6),BFUNCT(6,50) COMMON/OUTPUT/ NTOUT BYTE BFUNCT, BSUBNM BYTE FUNC(9), TOTL(11) EQUIVALENCE (FNAME(1),FILE(1)) EQUIVALENCE (BUF(1), CMD(1)) C DATA IOK/2,3,9,10,12,16,17,30,31,36,45,47,48/ DATA NTTY,NINU,NFOR,NVAR,NOUT/5,1,2,3,6/ DATA NTOUT/5/, ILIST/0/ DATA FILE/35*1H ,0/ DATA IA/1H*/,IT/9/,IB/32/,I4/1H4/ DATA FORT/1HF,1HO,1HR,1HT,1HR,1HA,1HN/ DATA VARI/1HV,1HA,1HR,1HI,1HA,1HB,1HL,1HE,1HS/ DATA ARRY/1HA,1HR,1HR,1HA,1HY,1HS/ DATA LABL/1HL,1HA,1HB,1HE,1HL,1HS/ DATA FUNC/1HF,1HU,1HN,1HC,1HT,1HI,1HO,1HN,1HS/ DATA TOTL/'T','O','T','A','L',' ','S','P','A','C','E'/ DATA LABELL/.FALSE./ DATA BBLANK/ ' '/ DATA BDEF/ '.', 'L', 'S', 'T', 0/ DATA CMD/ 'FOR ,X.T', 'MP/-SP/L' , 'I:2= ', 7*' '/ C DATA CMD/FOR ,X.TMP/-SP/LI:2= / C C FORMATS 1000 FORMAT(12H LI:2 FILE: ,$) 1003 FORMAT('0'//1X, 'UND ',36A1) 1010 FORMAT(132A1) 1015 FORMAT('0'//43X,' *** ROUTINE ', I2, ' ***') 1020 FORMAT(26H LOCALLY DEFINED VARIABLES) 1040 FORMAT(18H END OF PROCESSING) 1050 FORMAT('0', 'NO UNDEFINED VARIABLES') 1060 FORMAT('0', 'UNDEFINED VARIABLES') 1080 FORMAT(4X,8A1) 2000 FORMAT(1X,120A1) 2010 FORMAT(1X,120I1) C C CALL READMC TO GET FILE NAME IN MCR COMMAND LINE CALL READMC (FNAME, IEND, 35) IF (IEND .GT. 0) GO TO 5 2 WRITE(NTTY,1005) 1005 FORMAT(' UND> '$) READ(NTTY,1010) FNAME DO 3 I = 1,35 IF (FNAME(I) .NE. BBLANK) GO TO 5 3 CONTINUE GO TO 2 5 CONTINUE C C ENTER FILESPEC NAME, STRIP TRAILING BLANKS, AND OPEN LISTING FILE DO 10 I=1,35 BFILE(I) = FILE(I) J=36-I IF (FILE(J).NE.IB) GO TO 10 JJ = J-1 FILE(J)=FILE(J+1) 10 CONTINUE C C SEE IF '/LI' OPTION HAS BEEN USED 12 J = JJ ISLASH = IBLUF('/', FNAME) C WRITE(6,6700) ISLASH, (FNAME(I), I = 1,J) D6700 FORMAT('0', 'ISLASH = ', I2, 5X, 'FNAME: ',35A1) IF (ISLASH .LE. 0) GO TO 19 ! NO OPTION, GO TO 19 C C CHECK FOR 'LI' AFTER SLASH IF (FNAME(ISLASH+1) .EQ. 'L' .AND. FNAME(ISLASH+2) .EQ. 'I') $ GO TO 17 C C CHECK FOR 'LP' AFTER SLASH IF (FNAME(ISLASH+1) .EQ. 'L' .AND. FNAME(ISLASH+2) .EQ. 'P') $ GOTO 15 STOP 'INVALID OPTION' C C OUTPUT IS TO GO TO THE PRINTER 15 NTOUT = 6 IEND = ISLASH + 2 DO 16 I = ISLASH,IEND FNAME(I) = ' ' 16 CONTINUE J = J-3 C WRITE(6,6700) ISLASH, FNAME GOTO 12 C C INPUT PROGRAM IS LIST PROGRAM, DO NOT COMPILE 17 IEND = ISLASH + 2 DO 18 I = ISLASH,IEND FNAME(I) = ' ' 18 CONTINUE J = J-3 C WRITE(6,6700) ISLASH, FNAME ILIST = 1 GOTO 12 19 FNAME(J+1) = 0. IF (ILIST .EQ. 0) GOTO 22 C C CALL FPARS TO GET COMPLETE FILE SPECIFICATION FOR LISTING C FILE, WITH '.LST' AS DEFAULT EXTENSION IPT = 1 CALL FPARS(4,FNAME,IPT,BDEF,NER,FFNAME,NCH) C WRITE(6,6710) (FFNAME(I), I = 1,NCH) C6710 FORMAT('0', 'FFNAME: ', 35A1) IF (NER .NE. 0) WRITE(NTTY,5555) NER 5555 FORMAT('0', 'NER = ', I2) 555 FORMAT('0', 'NER = ', I3) IF (NER .NE. 0) STOP 'INVALID FILE NAME' FFNAME(NCH+1) = 0. C C 20 OPEN (UNIT=NINU,NAME=FFNAME,TYPE='OLD',CARRIAGECONTROL='NONE', $ ERR=21) GO TO 28 21 STOP 'INVALID LISTING FILE' C C BRANCH HERE IF NO LISTING FILE EXISTS FOR FORTRAN PROGRAM C C GET NUMBER OF CHARACTERS IN FFNAME C STORE IN BUF AFTER '=' 22 NCHAR = J DO 25 I = 1,NCHAR BUF(I+20) = FNAME(I) 25 CONTINUE NTOTCH = 21 + NCHAR BUF(NTOTCH) = 0 ! ADD ZERO BYTE C WRITE(6,6720) NTOTCH, (BUF(I), I = 1,NTOTCH) C6720 FORMAT('0', 'NCH, BUF: ', I2, 5X, 35A1) C C CALL SUBROUTINES TO CREATE LISTING FILE CALL DECTDB(1) ! DECLARE TDB CALL RUNTS(BUF,1,2,,'WAIT') ! SUBTASK FORTRAN COMPILER, C WAIT FOR ITS TERMINATION CALL RDETS(ISTAT,1) ! FIND OUT EXIT STATUS CALL RELTDB(1) ! RELEASE TDB C WRITE(6,6730) ISTAT C6730 FORMAT('0', 'ISTAT', I3) IF (ISTAT .EQ. 1) GO TO 26 OPEN(UNIT=NINU, NAME='X.TMP', TYPE='OLD') CLOSE(UNIT=NINU, DISPOSE='DELETE') ! DELETE X.TMP AS COMPILE STOP 'UNSUCCESSFUL COMPILATION' ! PRODUCED ERRORS C C BRANCH HERE IF COMPILATION WAS SUCCESSFUL 26 OPEN(UNIT=NINU, NAME='X.TMP', TYPE='OLD', $ CARRIAGECONTROL='NONE', ERR=27, DISPOSE='DELETE') GO TO 28 27 STOP 'OPEN ERROR ON LISTING FILE' C 28 CONTINUE C OPEN SCRATCH STORAGE FILE FOR FORTRAN LISTING OPEN (UNIT=NFOR,NAME='UNDEF1.MET',TYPE='SCRATCH', $ ACCESS='DIRECT',NOSPANBLOCKS,RECORDSIZE=20) C OPEN SCRATCH STORAGE FILE FOR LOCAL VARIABLES OPEN (UNIT=NVAR,NAME='UNDEF2.MET',TYPE='SCRATCH', $ ACCESS='DIRECT',RECORDSIZE=3) ISUBC = 0 ! ADDED 27-JUN-79 NL=0 IROUT = 0 WRITE(NTOUT,1003) BFILE 30 NR=0 IROUT = IROUT + 1 WRITE(NTOUT,1015) IROUT J=0 NOUNDW = 0 IZERO = 0 IEQG = 0 ! ADDED 24-JUN-79 IEQDEF = 0 ! ADDED 24-JUN-79 IFUNCT = 0 NFUNC = 0 NFUNCT = 0 IZERO = 0 IEQG = 0 ! ADDED 24-JUN-79 IEQDEF = 0 ! ADDED 24-JUN-79 ISUBC = 0 ! ADDED 27-JUN-79 C C READ FILE, STRIPPING BELOW TABS, AND CHECK FORTRAN AND NAME 40 READ (NINU,1010,END=410) LINE NL=NL+1 CALL STRIP(LINE) IF (NL-2) 60,40,80 60 DO 65 N=1,7 IF (LINE(N+1).NE.FORT(N)) GO TO 410 65 CONTINUE GO TO 40 C SET UP 80 CHARACTER STRINGS, SAVING PERTINENT ONES IN SCRATCH FILE 80 CALL SBVMV(LINE(9),CARD,80) CALL CLRTAB(CARD,.TRUE.) 82 IS=1 C WRITE(6,6000) CARD, I, IS, IE 6000 FORMAT('0', 'CLSA2 (85): CARD,I,IS,IE ',80A1,5X,3I4) 85 CALL CLSA2(CARD,I,IS,IE) C WRITE(6,6000) CARD, I, IS, IE C WRITE(6,6000) CARD, I, IS, IE DO 90 N=1,13 ! 1,12 CHANGED 1,13 02-APR-80 IF (I.EQ.IOK(N)) GO TO 100 90 CONTINUE IF (I.EQ.35) GO TO 110 J=0 GO TO 40 100 IF (I.EQ.2.AND.J.EQ.0) GO TO 40 IF (I.EQ.2.AND.J.EQ.-1) GO TO 104 IF (I.NE.9) GO TO 105 IS=IE DO 102 I=IS,72 IF (CARD(I).NE.IB) GO TO 85 102 CONTINUE J=-1 GO TO 40 104 CARD(6)=IB J=0 GO TO 82 105 NR=NR+1 WRITE (NFOR'NR) CARD D WRITE(6,6010) NR, CARD D6010 FORMAT(' ', 5X, 'NR,CARD (105) ', I4, 2X, 80A1) J=1 GO TO 40 C C END STATEMENT IS REACHED; NOW SEARCH DOWN TO 'VARIABLES' 110 READ (NINU,1010,END=410) LINE CALL STRIP(LINE) DO 120 N=1,9 IF (LINE(N).NE.VARI(N)) GO TO 110 120 CONTINUE C WRITE(6,6803) C6803 FORMAT('0', 'ARRIVED AT VARIABLES') C USE TAB LOCATIONS TO SET VARIABLE LOCATIONS NV=0 JJ=0 VARS(7)=IB VARS(8)=IB 130 READ (NINU,1010,END=410) LINE CALL STRIP(LINE) JT=0 DO 132 I=1,132 IF (LINE(I).NE.IT) GO TO 132 JT=JT+1 ITBS(JT)=I 132 CONTINUE C WRITE(6,6132) (LINE(N), N = 1,20) C C TEST FOR START OF NEW PAGE DO 131 I = 1,7 IF (LINE(I+1) .NE. FORT(I)) GOTO 133 131 CONTINUE C C NEW PAGE HAS BEEN REACHED IN LISTING FILE, SKIP THIS AND NEXT LINE READ(NINU,1010,END=410) LINE GOTO 130 133 CONTINUE IF (IFUNCT .EQ. 1) GO TO 170 ! ADDED 21-JUL-79 IF (JT.EQ.0) GO TO 134 C WRITE(6,6132) (LINE(N), N = 1,20) 6132 FORMAT(' ', '132 - LINE(1-20) =', 20A1) I=ITBS(1)+2 IF (LINE(I).EQ.IA) GO TO 150 C CHECK FOR 'ARRAYS' 134 DO 135 N=1,6 IF (LINE(N).NE.ARRY(N)) GO TO 140 135 CONTINUE JJ=1 C WRITE(6,6800) C6800 FORMAT('0', 'ARRIVED AT ARRAYS') GO TO 130 C CHECK FOR 'LABELS' 140 DO 145 N=1,6 IF (LINE(N).NE.LABL(N)) GO TO 146 145 CONTINUE LABELL = .TRUE. C WRITE(6,6810) GOTO 130 C6810 FORMAT('0', 'ARRIVED AT LABELS') C C CHECK FOR FUNCTION, SUBROUTINE REFERENCES 21-JUL-79 146 DO 147 N = 1,9 IF (LINE(N) .NE. FUNC(N)) GO TO 148 147 CONTINUE IFUNCT = 1 C WRITE(6,6146) GOTO 130 C6146 FORMAT('0', 'ARRIVED AT ''FUNCTION, SUBROUTINE REFERENCES''') C C CHECK FOR 'TOTAL SPACE', NEAR THE END OF SUBPROGRAM LISTING 148 CONTINUE C WRITE(6,6148) C6148 FORMAT('0', 'ARRIVED AT STATEMENT 148') DO 149 N = 1,11 IF (LINE(N) .NE. TOTL(N)) GOTO 130 149 CONTINUE C WRITE(6,6149) C6149 FORMAT('0', 'ARRIVED AT ''TOTAL SPACE'' ') GO TO 200 C C PROCESS VARIABLE/ARRAY NAMES 150 JE=(JT+1)/2-JJ NVS=2 C WRITE(6,6015) CARD, JE, JT, JJ, ITBS C6015 FORMAT(' ',10X, 'CARD,JE,JT,JJ,ITBS (150) ',80A1/11X,3I4,5X,10I4) DO 160 J=1,JE I=2*J-1 NVE=ITBS(I)-1 NTP=ITBS(I)+7 IF (LINE(NTP).NE.I4) GO TO 155 DO 152 K=1,6 VARS(K)=IB 152 CONTINUE K=1 DO 154 N=NVS,NVE VARS(K)=LINE(N) K=K+1 154 CONTINUE NV=NV+1 WRITE (NVAR'NV) VARS, IZERO, IZERO ! ADDED 24-JUN-79 C WRITE(6,6020) VARS, NVS, NVE, N 6020 FORMAT(' ', 20X, 'VARS,NVS,NVE,N (154) ',8A1, 3I4) 155 NVS=ITBS(I+1)+2 160 CONTINUE GO TO 130 C C TEST FOR FUNCTION, SUBROUTINE NAME 170 IF (JT .NE. 0) GOTO 171 ! TABS EXIST, MUST BE F,S REF C C TABS DO NOT EXIST, MAY STILL BE A SINGLE FUNC OR SUB REFERENCE D WRITE(6,6171) LINE(1), LINE(2), ISPCB(LINE(1)), ISPCB(LINE(2)) D6171 FORMAT(' ', '170 - LINE(1,2), ISPCB(LINE(1&2)) = ', 2(A1,1X),2I2) IF (ISPCB(LINE(2)) .EQ. 1 .AND. LINE(2) .NE. '$') GOTO 148 IF (ISPCB(LINE(1)) .EQ. 1 .AND. ISPCB(LINE(2)) .EQ. 0) GOTO 171 GOTO 148 C C PROCESS FUNCTION, SUBROUTINE NAMES 21-JUL-79 171 NVS = 2 D WRITE(6,6170) JT, (ITBS(J), J = 1,JT) D6170 FORMAT(' ', '170 - JT,ITBS:', I3, 20I4) DO 180 J = 1,JT+1 IF (LINE(NVS) .EQ. '$') GOTO 180 NFUNC = NFUNC + 1 NVE = ITBS(J) - 1 IF (J .EQ. JT+1) NVE = NVS + 5 K = 1 DO 174 N = NVS, NVE IF (LINE(N) .NE. '$') GOTO 172 C NOT USER FUNCTION, DO NOT SAVE IN BFUNCT NFUNC = NFUNC - 1 GOTO 178 172 IF (J .NE. JT+1) GOTO 173 IGOOD = ISPCB(LINE(N)) IF (IGOOD .EQ. 1) GOTO 175 ! BRANCH OUT IF NOT ALPHANUMERIC 173 BFUNCT(K,NFUNC) = LINE(N) K = K + 1 174 CONTINUE 175 CONTINUE IF (K .GT. 6) GOTO 178 DO 176 K1 = K,6 BFUNCT(K1,NFUNC) = ' ' 176 CONTINUE 178 CONTINUE C WRITE(6,6710) NVS, NVE,NFUNC, (BFUNCT(N,NFUNC), N = 1,6) NVS = ITBS(J) + 2 180 CONTINUE C6710 FORMAT('0', 'NVS,NFUNC,BFUNCT(NFUNC,*) ', 3I4,5X, 6A1) GOTO 130 C C C ALL PERTINENT CODE LINES AND VARIABLES HAVE BEEN SAVED 200 DO 205 N=1,NR READ (NFOR'N) CARD D WRITE (NOUT,2000) (CARD(I),I=1,72) 205 CONTINUE IF (NV.EQ.0) GO TO 380 D WRITE (NOUT,1020) DO 210 N=1,NV READ (NVAR'N) VARS D WRITE (NOUT,2000) VARS 210 CONTINUE C REREAD FORTRAN FILE, SUPPRESSING BLANKS, ADDING CONTINUATIONS (TO 9), C AND CODING PERTINENT SEPARATORS TO OBTAIN UNDEFINED VARIABLES N=0 J=0 NFUNCT = NFUNC ! 21-JUL-79 220 N=N+1 IF (N.GT.NR) GO TO 240 READ (NFOR'N) CARD ISC=1 C WRITE(6,6030) ITY,ISC, IEC, CARD C6030 FORMAT(' ',25X, 'CLSA2: ITY,ISC,IEC,CARD (220) ',3I4/26X,80A1) CALL CLSA2(CARD,ITY,ISC,IEC) C WRITE(6,6030) ITY,ISC,IEC,CARD IF (ITY.NE.9) GO TO 230 ISC=IEC CALL CLSA2(CARD,ITY,ISC,IEC) 230 IF (J.EQ.0) GO TO 360 IF (ITY.NE.2) GO TO 240 J=J+1 IF (J.GT.10) GO TO 220 CALL BLANK(CARD,7,IEC,ISTE) GO TO 220 C C PROCESS STRING ARRAY FOR VARIABLES 240 CALL TEXT(ISTE) ISTE=ISTE+1 STRING(ISTE)=IB ISTR(ISTE)=9 DO 250 IS=1,ISTE,120 IE=MIN0(IS+119,ISTE) D WRITE (NOUT,2000) (STRING(I),I=IS,IE) D WRITE (NOUT,2010) (ISTR(I),I=IS,IE) 250 CONTINUE C WRITE(6,6045) ITYP, CARD C6045 FORMAT(' ', 'UNDEF - 250: ITYP, CARD = ', I3, 1X, 80A1) IF (ITYP.EQ.3) CALL AC(ISTE) ! ASSIGNMENT STATEMENT IF (ITYP.EQ.36) CALL ACTEST(ISTE) ! UNKNOWN, MAY BE ASSIGNMENT IF (ITYP.EQ.10) CALL LC(ISTE) ! DO STATEMENT IF (ITYP.EQ.12) CALL CC(ISTE) ! CALL STATEMENT IF (ITYP.EQ.16.OR.ITYP.EQ.45)CALL RC(ISTE)! READ/REREAD STATEMENT IF (ITYP.EQ.47) CALL ENCODE(ISTE) ! ENCODE STATEMENT IF (ITYP.EQ.48) CALL RC(ISTE) ! DECODE STATEMENT IF (ITYP.EQ.30) CALL EC(ISTE) ! EQUIVALENCE STATEMENT IF (ITYP.EQ.31) CALL DC(ISTE) ! DATA STATEMENT IF (ITYP.EQ.17) CALL WC(ISTE) ! WRITE STATEMENT C WRITE(6,6040) ITYP, IESTE, VAR D6040 FORMAT(' ',30X, 'ITYP,ISTE,VAR (360) ', 2I4,5X,6A1) IF (NV.LE.0 .AND. NFUNCT .LE. 0) GO TO 380 IF (N.GT.NR) GO TO 390 360 J=1 ITYP=ITY ISTE=0 C WRITE(6,6050) ISC,IEC,ISTE,CARD D6050 FORMAT(' ',35X, 'BLANK: ISC,IEC,ISTE,CARD ',3I4/36X,80A1) CALL BLANK(CARD,ISC,IEC,ISTE) C WRITE(6,6050) ISC,IEC,ISTE,CARD GO TO 220 C C CHECK FOR REMAINING (UNDEFINED) VARIABLES 380 WRITE (NTOUT,1050) NOUNDW = 1 GO TO 398 C C IF A VARIABLE IN AN EQUIVALENCE GROUP HAS BEEN DEFINED, REMOVE 390 IF (IEQDEF .GT. 0) CALL ECREM ! ADDED 24-JUN-79 IF (NV .LE. 0) GOTO 398 CALL SUBOUT ! ADDED 24-JUN-79 398 IF (NFUNCT .LE. 0) GOTO 399 CALL FUNCWR 399 IF (NV .LE. 0 .AND. NOUNDW .EQ. 1) GOTO 400 IF (NV .GT. 0) GOTO 394 WRITE(NTOUT,1050) GOTO 400 394 WRITE (NTOUT,1060) DO 395 N=1,NV READ (NVAR'N) VARS WRITE (NTOUT,1080) VARS 395 CONTINUE C CONTINUE READING FILE FOR MORE SOURCE 'FORTRAN' 400 LABELL = .TRUE. READ (NINU,1010,END=410) LINE CALL STRIP(LINE) DO 405 N=1,7 IF (LINE(N+1).NE.FORT(N)) GO TO 400 405 CONTINUE LABELL = .FALSE. !ADDED BY JANA ! NL=1 GO TO 30 410 IF ( LABELL) GOTO 420 LABELL = .TRUE. 420 WRITE (NTOUT,1040) CALL EXIT END