
C** XREF1 ** SUBROUTINE TO PREPARE A CROSS REFERENCE LISTING
C
C
	SUBROUTINE XREF1
C
	DIMENSION IHOLD(3),INAME(3,140),DOS(13)
	LOGICAL*1 ICON,FFEED,IC,IEQ,DOT,HYF,HOLD(6),EXTRA,LEXPT,LCOM
	LOGICAL*1 COUNT(140),HEADER(106),NAME(6,140),FLAG,DEBUG,ID
	LOGICAL*1 LOST,INSIDE,SLASH,INSID,COMA
	LOGICAL*1 TEST(57),DONE,FIRST
	LOGICAL*1 LINE(134),PACK(78),KEYWD(240),TAB,NBLK,HEAD(4)
	LOGICAL*1 IE,LPARN,RPARN,IPRINT,JPRINT,IZERO,NEW,IU,IO
	COMMON LINEN,MAXLIN,IPAGE,INC,IERROR,IBEGIN,ICOUNT,DEBUG,LOST,
	$ NUMBER(140,30),NAME,HEADER,COUNT,IPRINT,JPRINT
	EQUIVALENCE (IHOLD,HOLD),(INAME,NAME)
	DATA NBLK/' '/,IC/'C'/,IEQ/'='/,DOT/'.'/,IZERO/'0'/,SLASH/'/'/
	DATA HEAD/'C',2*'*',' '/,HYF/''''/,IE/'E'/,COMA/','/
	DATA LPARN/'('/,RPARN/')'/,LEXPT/'!'/,ID/'D'/,IU/'U'/,IO/'O'/
	DATA TAB/"11/,FFEED/"14/
C
	DATA TEST/3,'E','Q','.',3,'L','T','.',3,'G','T','.',
	13,'L','E','.',3,'G','E','.',3,'O','R','.',3,'N','E','.',
	24,'A','N','D','.',4,'N','O','T','.',4,'X','O','R','.',5,'T',
	3'R','U','E','.',6,'F','A','L','S','E','.',0/
C
	DATA KEYWD/9,'D','I','M','E','N','S','I','O','N',4,'D','A',
	1'T','A',6,'C','O','M','M','O','N',11,'E','Q','U','I','V',
	2'A','L','E','N','C','E',7,'L','O','G','I','C','A','L',7,
	3'I','N','T','E','G','E','R',4,'R','E','A','L',10,'D','E','F',
	4'I','N','E','F','I','L','E',8,'E','X','T','E','R','N','A','L',
	54,'T','Y','P','E',15,'D','O','U','B',
	6'L','E','P','R','E','C','I','S','I','O','N',7,'C','O','M',
	7'P','L','E','X',10,'S','U','B','R','O','U','T','I','N',
	8'E',8,'F','U','N','C','T','I','O','N',2,'D','O',3,'I','F',
	9'(',6,'W','R','I','T','E','(',5,'R','E','A','D','(',
	14,'G','O','T','O',4,'C','A','L','L',7,'D','E','C','O','D',
	2'E','(',7,'E','N','C','O','D','E','(',5,'F','I','N','D',
	3'(',6,'R','E','W','I','N','D',7,'E','N','D','F','I','L',
	4'E',9,'B','A','C','K','S','P','A','C','E',6,'A','S',
	5'S','I','G','N',6,'A','C','C','E','P','T',5,'P',
	6'R','I','N','T',7,'F','O','R','M','A','T','(',4,'B',
	7'Y','T','E',4,'E','N','D','!',0/
C
C
C	CAPACIY IS 140 VARIABLE NAMES EACH WITH UP TO 30 REFERENCES EACH.
C	THE FORTRAN KEYWORDS AND CERTAIN OTHER SYSTAX ELEMENTS MUST
C	BE ENTIRELY CONTAINED ON THE FIRST (OR ONLY) LINE OF THE
C	STATEMENT TO BE PROPERLY RECOGNIZED, EXCEPT FOR
C	STATEMENTS FOLLOWING LOGICAL IF()S AND GO TO'S.
C
C	VARIABLES TO THE RIGHT OF A LITERAL'!' IN DATA STATEMENTS MAY
C	NOT BE XREFED.
C	VARIABLE NAMES >6 CHARACTERS LONG WILL NOT BE XREFED CORRECTLY.
C	IN DATA STATEMENTS, A LITERAL '/' WILL CONFUSE THE SCAN FOR THE REST
C	OF THAT LINE.
C	ASSIGNMENT STATEMENTS WITH 'TYPE','PRINT','ACCEPT',
C	OR 'DO' ON THE LEFT OF THE "=" WILL HAVE THESE
C	VARIABLES TREATED AS KEYWORDS.
C	'READ LUN,LIST' STATEMENTS WILL NOT BE XREFED UNLESS THE LIST
C	CONTAINS A "=", IN WHICH CASE THEY WILL BE TREATED AS ARITHMETIC
C	ASSIGNMENTS AND XREFED INCORRECTLY.
C	'STOP' AND 'PAUSE' STATEMENTS THAT INCLUDE A DISPLAY CONTAINING
C	A "=" WILL BE TREATED AS CONTAINING VARIABLE NAMES
C	FORTRAN 4 PLUS-UNIQUE KEYWORDS ARE NOT SUPPORTED.
C	OTHER ODDBALL AND UNWISE BUT LEGAL CONSTRUCTIONS MAY ALSO
C	CAUSE STRANGE ERRORS.
C	DEBUG (D) LINES ARE TREATED AS COMMENTS UNLESS /D SWITCH IS USED
C	INAME,NAME,NUMBER,COUNT AND 1 STATEMENT MUST BE CHANGED TO 
C	CHANGE THE CAPACITY (AND SIZE) OF THIS PROGRAM.
C
C------VERSION 2, JAN 76, ADDS DOTTED KEYWORD SIVE
C------VERSION 3, MAR 76, CHANGES HANDLING OF FORM FEEDS
C------VERSION 4, MAY 76, ADDS FLAGGING OF DO LOOPS,PAGE FORMATTING
C
	ITYPE=99
	LINEN=60
	NUMDO=0		!COUNT OF CURRENTLY PENDING DO LOOPS
	NUM=0
	FLAG=.FALSE.
	FIRST=.TRUE.
	EXTRA=.FALSE.
	LOST=.FALSE.
	DONE=.FALSE.
C
C============================== READ A LINE ========
C
2	READ (2,4,END=110,ERR=112) IQ,LINE
4	FORMAT (Q,134A1)
	IF (IQ .EQ. 0) GO TO 2
	IF (IQ .GT. 80) IQ=80			!TRUNCATE LONG LINES
	IF(LINE(1) .EQ. FFEED)GO TO 2			!SKIP  FF
	IF (.NOT. FIRST) GO TO 8
C
C-- FIRST LINE, LOOK FOR HEADER ("C** ") IN COL 1-4
C
	DO 6 I=1,4
	IF (LINE(I) .NE. HEAD(I)) GO TO 8
6	CONTINUE
	CALL MOVEB (LINE,2,80,HEADER,2)			!SAVE THE HEADER
	FIRST=.FALSE.
	GO TO 2
C
C
8	ICON=.TRUE.
	LCOM=.TRUE.
	JSTART=0
	FIRST=.FALSE.
C
C--IF A COMMENT LINE, JUST GO PRINT IT
C
	IF (LINE(1) .EQ. IC) GO TO 78
	IF (.NOT. DEBUG .AND. LINE(1) .EQ. ID) GO TO 78
C
C--LOOK FOR CONTINUATION LINES, 
C
	LCOM=.FALSE.
	ICON=.FALSE.
	CALL CHARB (1,LINE,1,6,TAB,ICOL)	!FIND A TAB
	IF (ICOL .GT. 0) GO TO 10		!FOUND ONE
C
C--NO TAB, SO CHECK COL 6  FOR 0 OR BLANK
C
	ICOL=7
	IF (LINE(6) .NE. IZERO .AND. LINE(6) .NE. NBLK) ICON=.TRUE.
	GO TO 12
C
C--TAB FOUND, SO NEXT CHAR = NON ALPHABETIC = CONTINUATION LINE
C
10	ICOL=ICOL+1
	IF (LINE (ICOL) .GT. "40 .AND. LINE(ICOL) .LT. "101) 
	1ICON=.TRUE.
C
	IF (ICON) ICOL=ICOL+1
12	IF (.NOT. ICON) NUM=NUM+1
	NUMX=NUM
	IF (ICON .AND. (ITYPE .EQ. 30 .OR. ITYPE .EQ. 99)) GO TO 78
	IF (.NOT. ICON) GO TO 16
C
C==========SET UP CONTINUATION LINES
C
C--MOVE LEFTWARD LOOKING FOR SPECIAL CHAR AT END OF LAST LINE
C
	DO 14 I=IEND,MCOL,-1
	IF (PACK(I) .LT. "60 .OR. PACK(I) .GT. "132) GO TO 16
	IF (PACK(I) .LT. "101 .AND. PACK(I) .GT. "71) GO TO 16
14	CONTINUE
C
C--IF END OF OLD LINE TERMINATED A VARIABLE NAME, IT MAY BE CONTINUED
C--ON THIS NEW LINE, SO
C--MOVE THE ALFA CHAR FOUND FROM END OF LAST LINE,TO START OF NEW LINE
C
	CALL MOVEB (PACK,I+1,IEND,PACK,JSTART+1)
	JSTART=JSTART+(IEND-I)
C
C--ELEMINATE THE VARIABLE NAME FOUND AT END OF LAST LINE, IT'S GARBAGE
C
	IF (NEW) ICOUNT=ICOUNT-1
	COUNT(JSAVE)=COUNT(JSAVE)-1
C
C==PACK REST OF LINE FOR ANALYSIS, DELETING BLANKS AND CONTROL CHARACTER
C     STOP WHEN A '!' (COMMENT), END OF LINE OR COL 72 IS FOUND
C
16	IEND=JSTART
	MCOL=1
	NEW=.FALSE.
	J=IQ
	IF (IQ .GT. 72) J=72
	DO 18 I=ICOL,J
	IF (LINE(I) .LE. NBLK) GO TO 18
	IF (LINE(I) .EQ. LEXPT .AND. LINE(I-1) .NE. HYF) GO TO 20
	IEND=IEND+1
	PACK(IEND)=LINE(I)
18	CONTINUE
20	PACK(IEND+1)=LEXPT
	ICOL=0
D	WRITE (6,998) PACK
D998	FORMAT (/1X,78A1)
	M=1
	IF (ICON .AND. ITYPE .EQ. 16 .AND. NX .GT. 0) GO TO 42
	IF (ICON .AND. ITYPE .EQ. 16 .AND. NX .EQ. 0) GO TO 22
	IF (ICON) GO TO 48
C
C--RESOLVE TYPE OF IF() THAT ENDED AT END OF PREVIOUS LINE, IF
C--ARITHMETIC, JUST GO PRINT THIS LINE
C
22	CONTINUE
	IF (.NOT. FLAG) GO TO 24
	FLAG=.FALSE.
	IF (PACK(JSTART+1) .LT. "101) GO TO 78		!ARITHMETIC
	EXTRA=.TRUE.
C
C======================= FIND TYPE OF STATEMENT ==========
C
24	CONTINUE
	ISTART=1
26	IF (EXTRA) NUM=NUM+1
	EXTRA=.FALSE.
	JEND=0
	INSID=.FALSE.
	INSIDE=.FALSE.
	NX=0
C
C****CHECK TO SEE IF LINE STARTS WITH A FORTRAN KEYWORD
C
	CALL COMPAR (KEYWD,PACK,ISTART,ICOL,ITYPE)
	IF (ITYPE .GT. 0) GO TO 32			!GOT ONE
C
C--NOT FOUND IN KEYWD, IS IT AN ARITHMENTIC ASSIGNMENT??
C
28	CONTINUE
	CALL CHARB (1,PACK,ISTART,IEND,IEQ,I)		!LOOK FOR =
30	ICOL=ISTART-1
	ITYPE=0
	IF (I .GT. 0) GO TO 48				!FOUND ONE
C
C--OK, FOUND A STATEMENT THAT CAN'T CONTAIN VARIABLES, JUST PRINT IT
C
	ITYPE=99
	GO TO 78
C
C============================SPECIAL PROCESSING
C
32	CONTINUE
	IF (ITYPE .EQ. 30 .OR. ITYPE .EQ. 32) GO TO 78		!SKIP FORMATS & END
C
C--CHECK INTEGER, REAL, COMPLEX KEYWORDS TO SEE IF THEY ARE FUNCTIONS
C
	IF (ITYPE .NE. 6 .AND. ITYPE .NE. 7 .AND. ITYPE .NE. 12
	1 .AND. ITYPE .NE. 5) GO TO 36
	KCOL=ICOL
	DO 34 I=117,124
	KCOL=KCOL+1
	IF (PACK(KCOL) .NE. KEYWD(I)) GO TO 48
34	CONTINUE
	ICOL =KCOL
	GO TO 48
C
C--DOUBLE CHECK DO LOOPS
C
36	IF (ITYPE .NE. 15) GO TO 38
C
	I=999						!FLAG FOR GO TO
	CALL CHARB(1,PACK,ICOL,IEND,IEQ,J)	!LOOK FOR =
	IF (J .LE. 0) GO TO 30			!CANNOT BE A DO
	CALL CHARB(1,PACK,J,IEND,COMA,J)	!LOOK FOR ,
	IF (J .LE. 0) GO TO 30			!CANNOT BE A DO
	IF (NUMDO .EQ. 13) GO TO 48	!SKIP IF >13 NESTED DO'S
	J=ICOL+1
	IF (PACK(J) .LT. "60 .OR. PACK(J) .GT. "71) GO TO 30	!MUST BE DIGIT
	X=OLDNUM(PACK,IEND,J,M)
	IF (X .EQ. 0.) GO TO 30		!NO NUMBER AFTER THE 'DO'
	NUMDO=NUMDO+1			!COUNT PENDING DO'S
	DOS(NUMDO)=X			!REMEMBER TERMINATING STATMENT
	GO TO 48			!ASSUME IT'S A DO
C
C--DECIDE IF CERTAIN SHORT KEYWORDS ARE IN FACT VARIABLE NAMES
C
38	IF (ITYPE .NE. 3 .AND. ITYPE .NE. 7 .AND. ITYPE .NE. 19
	1 .AND. ITYPE .NE. 27 .AND. ITYPE .NE. 31) GO TO 40
	CALL CHARB (1,PACK,ISTART+4,IEND,IEQ,I)		!LOOK FOR =
	IF (I .GT. 0) GO TO 30				!FOUND ONE
C
C--GET PAST THE 'TO' IN ASSIGN STATEMENTS
C
	IF (ITYPE .NE. 27) GO TO 48
	CALL CHARB (1,PACK,ISTART+6,IEND,IO,ICOL)
	IF (ICOL .GT. 0) GO TO 48			!GOT IT
	I=999
	GO TO 30
C
C--FIND START OF SECOND PART OF LOGICAL IF'S
C
40	IF (ITYPE .NE. 16) GO TO 48
	M=3
42	DO 44 I=M,IEND
	IF (PACK(I) .EQ. LPARN) NX=NX+1
	IF (PACK(I) .EQ. RPARN) NX=NX-1
	IF (NX .EQ. 0) GO TO 46
44	CONTINUE
	GO TO 48
C
C--FOUND END OF 'IF(XX)', NOW A ALFA CHAR MEANS IT'S LOGICAL IF()
C--IF THE IF() ENDS AT THE END OF THE LINE, THE TYPE OF IF() CANNOT
C--BE DEFINED UNTIL THE NEXT LINE IS READ, SO FLAG IT FOR SPECIAL CHECK.
C
46	IF (PACK(I+1) .EQ. LEXPT) FLAG=.TRUE.
	IF (PACK(I+1) .GT. "100) JEND=IEND
	IEND=I
C
C============================= SCAN FOR VARIABLE NAMES =========
C
48	CONTINUE
	JCOL=ICOL
50	ICOL=JCOL
52	ICOL=ICOL+1
	IF (ICOL .GT. IEND) GO TO 76
C
C--SPECIAL PROCESSING TO SKIP JUNK BETWEEN // IN DATA STATEMENTS
C
	IF (ITYPE .NE. 2) GO TO 54
	IF (PACK(ICOL) .EQ. SLASH) INSIDE=.NOT. INSIDE
	IF (INSIDE) GO TO 52
C
C--SPECIAL PROCESSING TO SKIP LITERAL STRINGS IN CALL STATEMENTS
C
54	IF (ITYPE .NE. 20) GO TO 56
	IF (PACK(ICOL) .EQ. HYF) INSID=.NOT. INSID
	IF (INSID) GO TO 52
C
C===LOOK FOR FIRST ALFA CHAR, TO START A VARIABLE NAME
C
56	IF (PACK(ICOL) .LT. "101 .OR. PACK(ICOL) .GT. "132) GO TO 52
	JCOL=ICOL
	N=ICOL+5
	M=ICOL+1
C
C=====LOOK FOR A SPECIAL CHAR TO TERMINATE THE VARIALBE NAME
C
	DO 58 I=M,N
	IF (PACK(I) .LT. "60 .OR. PACK(I) .GT. "132) GO TO 60
	IF (PACK(I) .LT. "101 .AND. PACK(I) .GT. "71) GO TO 60
	JCOL=JCOL+1
58	CONTINUE
C
C--FOUND ONE BETWEEN ICOL AND JCOL
C--CHECK IT, ELIMATING DOTTED KEYWORDS, LITERALS, END=,ERR=
C     AND THE U IN DEFINE FILES,
C
60	IF (PACK(ICOL-1) .EQ. DOT .AND. PACK(JCOL+1) .EQ. DOT)GO TO 62
	IF (PACK(ICOL-1) .EQ. HYF .AND. PACK(JCOL+1) .EQ. HYF)GO TO 50
	IF (PACK(JCOL+1) .EQ. IEQ .AND. (ITYPE .EQ. 18 .OR. ITYPE .EQ.
	1 17) .AND. (JCOL-ICOL .EQ. 2) .AND. (PACK(ICOL) .EQ. IE))
	2 GO TO 50
	IF (ITYPE .EQ. 8 .AND. ICOL .EQ. JCOL .AND. PACK(ICOL) .EQ. IU)
	1GO TO 50
	GO TO 64
C
C--CHECK CAREFULLY TO THROW AWAY DOTTED KEYWORDS
C
62	CALL COMPAR (TEST,PACK,ICOL,I,JTYPE)
	IF (JTYPE .NE. 0) GO TO 50		!A LOGICAL OPERATOR, SKIP IT
C
C--IT'S GOOD, MOVE TO A TEMP AREA AND PAD WITH BLANKS
C
64	DO 66 I=2,6
66	HOLD(I)=NBLK
	CALL MOVEB (PACK,ICOL,JCOL,HOLD,1)
C
C--NOW LOOK FOR IT AMONG THE EXISTING NAMES
C
	IF (ICOUNT .EQ. 0) GO TO 72
	DO 70 I=1,ICOUNT
	DO 68 J=1,3
	IF (INAME(J,I) .NE. IHOLD(J)) GO TO 70
68	CONTINUE
C
C--FOUND IT, IF IT'S FULL, KEEP LOOKING
C
	IF (COUNT(I) .LT. 30) GO TO 74		!**CHANGE TO ADJUST CAPACITY
70	CONTINUE
C
C--COULD NOT FIND IT, SO ADD IT AT END
C
	IF (ICOUNT .LT. 140) GO TO 72		!**CHANGE TO ADJUST CAPACITY
	LOST=.TRUE.
	GO TO 50
C
C--ADD NEW VARIABLE NAME
C
72	ICOUNT=ICOUNT+1
	I=ICOUNT
	NEW=.TRUE.
	COUNT(I)=0
	CALL MOVEB (HOLD,1,6,NAME(1,I),1)
74	COUNT(I)=COUNT(I)+1
D	WRITE (6,999) ICOUNT,COUNT(I),NUM,HOLD
D999	FORMAT (3I9,6A1)
	JSAVE=I
	MCOL=ICOL
	NUMBER(I,COUNT(I))=NUM
	GO TO 50			!RESUME SEARCH
C
C--GO PROCESS THE LAST PART OF LOGICAL IF'S 
C
76	CONTINUE
	IF (JEND .EQ. 0) GO TO 78		!DIDN'T FIND END OF IF()
	EXTRA=.TRUE.			!FOUND END
	IF (JEND .EQ. IEND) GO TO 78	!FORGET IT IF IF TAKES FULL LINE
	ISTART=IEND+1
	IEND=JEND
	GO TO 26
C
C================================= PRINT THE SOURCE CODE
C
78	CONTINUE
	IF (.NOT. IPRINT) GO TO 102
	IF (LINEN .LT. MAXLIN) GO TO 88
	IF (ITYPE .EQ. 32) GO TO 88		!ALLOW 1 EXTRA LINE
80	IF (LINEN .LT. 9999 .AND. IPRINT) WRITE (6,82)
82	FORMAT (1H1)
C
84	LINEN=4
	WRITE (6,86)HEADER,IPAGE
86	FORMAT (/106A1,I4,' **'/)
	IPAGE=IPAGE+1
C
88	CONTINUE
	IF (NUMDO .GT. 0) WRITE (6,90) (HEAD(2),I=1,NUMDO)
90	FORMAT ('$',T14,' ',T2,13A1)
	IF (NUMDO .LE. 0) WRITE (6,92)
92	FORMAT ('$',T14,' ')
	IF (.NOT. ICON) WRITE (6,94) NUMX,TAB,(LINE(I),I=1,IQ)
94	FORMAT ('+',I4,100A1)
	IF (.NOT. ICON) GO TO 100
	IF (LCOM) WRITE (6,96) TAB,(LINE(I),I=1,IQ)
96	FORMAT ('+',A1,'  >>',80A1)
	IF (.NOT. LCOM) WRITE (6,98) TAB,TAB,(LINE(I),I=1,IQ)
98	FORMAT ('+',80A1)
100	LINEN=LINEN+1
C
	IF (ITYPE .NE. 32) GO TO 102		!ON 'END', ADVANCE PAGE
	WRITE (6,82)
	FIRST=.TRUE.			!LOOK FOR C** ON NEXT LINE
	LINEN=9999			!FLAG THIS ODD STATUS
	ITYPE=0
C
C
C--IF THIS LINE HAS A STATEMENT NUMBER WHICH IS ONE OF THE
C	TERMINATORS OF ONE OR MORE OF THE OUTSTANDING DO LOOPS,
C	REMOVE IT FROM DOS AND REDUCE THE NUMBER OF OUTSTANDING
C	DOS ACCORDINGLY.
C
102	CONTINUE
	IF (NUMDO .EQ. 0) GO TO 108
	N=1
	X=OLDNUM(LINE,5,N,M)		!LOOK FOR A NUMBER ON THIS LINE
	IF (X .LE. 0.) GO TO 108		!CAN'T BE END OF DO LOOP WITHOUT NUMBER
	J=NUMDO
	DO 106 I=1,J			!SEARCH VECTOR AND PACK
104	IF (DOS(I) .NE. X) GO TO 106
	DOS(I)=DOS(NUMDO)
	DOS(NUMDO)=0.
	NUMDO=NUMDO-1
	GO TO 104
106	CONTINUE
C
108	IF (.NOT. DONE) GO TO 2
C
110	IF (LINEN .LT. 9999) WRITE (6,82)		!OVERLAP SORT&PAGE ADVANCE
	RETURN
C
112	STOP '*ABORT--HARDWARE READ ERROR IN INPUT FILE*'
C
	END

