d 	PROGRAM CROSS !! <{@}In_file {Options}
È c.		Generate a Cross Reference of FORTRAN source
,c.
c.Input:
ôc.	<Source .or. <@File_of_Source_names {e.g. DIR/COL=1/OUT= ...}
Xc.	RATfor i.e. RatFor Source	-- Default FORTRAN
¼c.					-- Default trace MAIN PROGRAM
 c.	%Name .or. ALL .or. NOTrace	-- Trace options
„c.					-- Default show all tables
èc.	NOIncluded_file,	NOLogical_Units,	NOSubroutines
Lc.	NOOpens,		NOCommon_blocks,	NOAlphabetize
°c.					-- Default 132, NoCompress
c.	80,			REPort,			COMpress
xc.	TRIm			i.e. COMpress and TRIm tree
Üc.
@c.	This Outputs to FOR003.DAT the Calling - Called tree,
¤c. and Cross Reference tables for the files read.
c.
lc. Author:	Gary S. Lee
Ðc. Use:		$ DO OLDCROSS !! for the Older Version of Cross
4c----------------------------------------------------------end.of.info
˜C
üC	********************************************************
`	C	*	AUTHOR:		GARY S. LEE                    *
Ä	C	*	LANGUAGE:	FORTRAN FOUR PLUS              *
(
C	*	COMPUTER:	DIGITAL EQUIP. CORP. VAX       *
Œ
C	*	DATE:		10-JUN-80                      *
ð
C	********************************************************
TC
¸C		REVISION DATE	BY	DESCRIPTION
C		-------------	-------	-----------
€C		15-JUL-80	G. LEE	FIX BUG IN UNNAMED ROUTINE SECT.
äC		05-MAY-81	G/ LEE  CHANGE MAX COMM BLKS  50 => 100
Hc.		04-JUN-82	M. Liveright: In_files, Subs = 500
¬c.		04-JUN-82	M. Liveright: Permit <@File_list
c.		04-JUN-82	M. Liveright: Permit TRIm_tree
tC***************************************************************
ØC	CALLS:	ISCOMT	to DETERMINE IF A RATFOR OR FORTRAN 4+ COMMENT
<C	CALLS:	CURLEN 	to DETERMINE THE CURRENT LENGTH OF A STRING
 C	CALLS:	PRECHK	to CHECK THE CHARACTERS PRECEEDING A WORD
c.	CALLS:	JJLEN	to get non-blank length of string
hc.	CALLS:	JJCMD	to get user command
Ìc.	CALLS:	JJUPP	to uppercase a line
0C**************************************************************
”C		-- SETUP --
øC***************************************************************
\	PARAMETER 	 MXINP	=500	!MAX # INPUT FILES
À	1		,MXFILES=100	!MAX # FILES INCLUDED
$	2		,MXFILUN=100	!MAX # FILES OPENED
ˆ	3		,MXSUBS	=500	!MAX # SUBROUTINES CALLED
ì	4		,MXIO	=100	!MAX # READ/WRITE LUNS
P	5		,MXCB	=100	!MAX # COMMON BLOCKS
´C
	DIMENSION	 INPROG(MXINP)
|	1		,INTYPE(MXINP)
à	2		,FILES (MXFILES) , XFILES (MXFILES,MXINP)
D	3		,FILUN (MXFILUN) , XFILUN (MXFILUN,MXINP)
¨	4		,SUBS  (MXSUBS)  , XSUBS  (MXSUBS,MXINP)
	5		,IO    (MXIO)    , XIO    (MXIO,MXINP)
p	6		,CB    (MXCB)	 , XCB	  (MXCB,MXINP)
Ô	6		,TYPE  (11)
8	7		,LASTNS(MXINP)	! LAST ROW OF SUB USED BY PROG
œC
 	CHARACTER	 INPROG*10	!10 CHARACTER ROUTINE NAMES
d	1		,INTYPE*2	!2 CHR ROUTINE TYPE MNEMONIC
È	2		,FILES*25	!25 CHAR INCLUDED FILE NAME
,	3		,FILUN*30	!30 CHAR FILE//LUN OPENED
	3		,OPFIL*20	!20 CHAR OPEN FILE NAME
ô	3		,OPFILUN*30	!30 CHAR CURRENT FILE//LUN
X	4		,SUBS*10	!10 CHAR SUB NAME
¼	5		,IO*10		!10 CHAR LUN NAMES
 	6		,CB*15		!15 CHAR COMMON BLOCK NAME
„	6		,XFILES*1	!1 CHAR INDICATOR
è	7		,XFILUN*1	! DITTO
L	8		,XSUBS*1	! DITTO
°	9		,XIO*1		! DITTO
	9		,XCB*1		!DITTO
xC
Ü	CHARACTER	 FNAME*25	!CURRENT FILE NAME
@	1		,SNAME*10	!CURRENT SUBROUTINE NAME
¤	2		,ILUN*10		!LUN NAME
 	3		,KLUN*10		!LUN NAME
l 	4		,CMNBLK*15	!COMMON BLOCK NAME
Ð 	4		,RECORD*80	!INPUT BUFFER
4!	5		,TYPE*2		!ROUTINE TYPE CODES
˜!	6		,WORD*25	!SEARCH BUFFER
ü!	7		,CMTCHR*1	!COMMENT CHARACTER
`"C
Ä"	CHARACTER	FILAB*25	!LABEL FOR INCLUDED FILES
(#	1		,SLAB*20	!LABEL FOR SUBROUTINES
Œ#	2		,OPLAB*20	!LABEL FOR OPEN FILES
ð#	3		,IOLAB*15	!IO LABEL
T$	4		,CBLAB*15	!COMMON BLOCK LABEL
¸$C
%	CHARACTER*11	TR(10)		!TRACE ROUTINE NAMES
€%	1		,ISZ*7	!OUTPUT PAGE SIZE OPTION
ä%C
H&	character	PGMFILE*80
¬&c.
'	LOGICAL INC,OP,SUB,LUN,CBFLG,AZ, PRECHK, RAT,ISCOMT, ish
t'	LOGICAL COM		!COMPRESS TRACE FLAG
Ø'	INTEGER		CURLEN		!FUNCTION
<(	EQUIVALENCE	(OPFILUN(1:20),OPFIL)
 (	1	,	(OPFILUN(21:30),ILUN)
)	DIMENSION	IROW(MXINP),	ICOL(MXINP)
h)C
Ì)	DATA	TYPE/'??','FU','LF','CF','RF','IF','SU','PR','BD','EL','GR'/
0*C
”*	DATA FILAB	 /'INCLUDED FILE'/
ø*	1 ,SLAB		/'ROUTINES CALLED'/
\+	2 ,OPLAB	/'OPENED FILES'/
À+	3 ,IOLAB	/'I/O LUNS'/
$,	4 ,CBLAB	/'COMMON BLOCK'/
ˆ,c.
ì,41	format(80a)
P-C
´-C---------------------------------------------------------------
.C		-- INITIALIZE VARIABLES --
|.C---------------------------------------------------------------
à.	type *,'Cross 2.1'
D/c!ml!	NPROGS	= 0			!# INPUT ROUTINES SO FAR
¨/c!ml!	NFILES	= 0			!# INCLUDED FILES SO FAR
0c!ml!	NFILUN	= 0			!# OPENED FILES SO FAR
p0c!ml!	NSUBS	= 0			!# SUBROUTINES CALLED SO FAR
Ô0c!ml!	NIO	= 0			!# IO OPERATIONS SO FAR
81c!ml!	NCB	= 0			!# OF COMMOM BLOCKS SO FAR
œ1c!ml!	KINC = 0
 2c!ml!	KOPEN = 0
d2c!ml!	KREAD = 0
È2c!ml!	KWRITE=0
,3c!ml!	KCALL = 0
3c!ml!	KPRINT = 0
ô3c!ml!	KTYPE = 0
X4c!ml!	KACCEPT = 0
¼4c!ml!	KCB	= 0			!INDEX OF WORD "COMMON" IN LINE
 5	NONAMES	= 48			!ASCII CODE FOR ZERO(UNNAMEDS)
„5c!ml!	DO 10 JC = 1,MXINP
è5c!ml!	INPROG(JC) = ' '
L6c!ml!	LASTNS(JC) = 0			!LAST ROW USED BY THIS PROG
°6c!ml!	IROW(JC) = JC			!INITIALIZE ROW ORDER
7c!ml!	DO 20 JR = 1,MXIO		!BLANK OUT XIO
x7c!ml! 20	XIO(JR,JC) = ' '
Ü7c!ml!	DO 22 JR = 1,MXFILES
@8c!ml! 22	XFILES(JR,JC) = ' '
¤8c!ml!	DO 24 JR = 1,MXFILUN
9c!ml! 24	XFILUN(JR,JC) = ' '
l9c!ml!	DO 26 JR = 1,MXSUBS
Ð9c!ml! 26	XSUBS(JR,JC) = ' '
4:c!ml!	DO 28 JR = 1,MXCB
˜:c!ml! 28	XCB(JR,JC) = ' '
ü:c!ml! 10	CONTINUE
`;	do ii=1,mxinp
Ä;	  irow(ii) = ii
(<	enddo
Œ<	CALL GETOPT(PGMFILE,INC,OP,SUB,LUN,CBFLG,RAT,
ð<	1	AZ,TR,COM,NTR,ISZ,ish)	!GET OPTIONS
T=D	type 9696, INC,OP,SUB,LUN,AZ,NTR,CBFLG,RAT,ISZ
¸=D9696	FORMAT(' OPTIONS CHOSEN:',4X,'INC',2X,L3,
>D	1	4X,'OP',L2,4X,'SUB',L2,4X,'LUN',L2,
€>D	2	4X,'AZ',L2,3X,'NTR=',I3/' CBFLG=',L2,3X,'RAT=',L2
ä>D	3	,3X,'ISZ=',A)
H?D	IF (NTR .GE. 1.AND. NTR .LE. 10) type 887,(TR(KL),KL=1,NTR)
¬?D887	FORMAT(' TR=',<NTR>(A,2X))
@	IF (RAT) CMTCHR = '#'
t@	IF (.NOT. RAT) CMTCHR='!'
Ø@C
<AC---------------------------------------------------------------
 AC		-- READ INPUT RECORD --
BC---------------------------------------------------------------
hB	if( pgmfile(1:1).eq.'@' ) then !!Indirect file
ÌB	  isind = 1
0C	  type 41,' <',pgmfile(1:jjlen(pgmfile)),' {Indirect}'
”C	  open(unit=1,name=pgmfile(2:),type='old',err=8005,readonly)
øC	  goto 1500
\D	endif
ÀD	goto 1900
$Ec.
ˆE1000	continue
ìE	type 41,' Can''t open'
PFc.
´F1500	continue
G	close(unit=2)
|G	if( isind.eq.0 ) goto 2000 !!No indirect file
àGc.
DH1600	continue
¨H	read(1,9000,end=2000,err=8105) pgmfile
I	if( pgmfile.le.' ' .or. pgmfile(1:5).eq.'Total'
pI	1 .or. pgmfile(1:5).eq.'Direc' ) goto 1600
ÔIc.
8J1900	continue
œJ	type 41,' <',pgmfile(1:jjlen(pgmfile))
 K	OPEN (UNIT=2,NAME=PGMFILE,TYPE='OLD',ERR=1000,READONLY)
dK 100	READ(2,9000,END=1500,ERR=8105) RECORD
ÈK	IF (RECORD .eq. ' ') GO TO 100
,L	if( ichar(record).eq.12 ) goto 100 !!Form feed
L	call jjupp(record)
ôL 9000	FORMAT(A)
XM	IF (RECORD(1:5) .EQ. 'C/ELT') GO TO 140
¼M	IF (RECORD(1:5) .EQ. 'C/GRP') GO TO 140
 N	IF (ISCOMT(RECORD,RAT)) THEN	!SKIP COMMENTS
„N	  IF (SUB) CALL FCALLS(RECORD,SUBS,NSUBS,XUSBS,MXSUBS,MXINP
èN	1		,RAT,LASTNS,NPROGS)		!"CALLS" ?
LO	  GO TO 100
°O	ENDIF
P 140	CALL GETTYP ( RECORD , ITYPE , WORD )		!FIND ROUTINE TYPE
xP	IF (WORD .EQ. ' ') THEN				!PROCESS UNNAMED TYPES
ÜPC
@Q	NONAMES = NONAMES + 1
¤Q	IF (NONAMES .EQ. 58) NONAMES = NONAMES + 7	!SKIP DEL CHRS
R	IF (NONAMES .GT. 90) GO TO 8205			!TOO MANY
lR	WORD = '~UNNAMED '//CHAR(NONAMES)	!APPEND THE CO~UNTER
ÐR	ENDIF
4SC
˜SC STORE ROUTINE NAME
üSC
`T 150	CONTINUE
ÄT	NPROGS = NPROGS + 1			!INCREMENT ROUTINE CNTR
(U	type 6666, NPROGS, WORD(1:jjlen(word))
ŒU6666	FORMAT(1X,'WORKING ON ROUTINE ',I3, ' - ',A)
ðU	INTYPE (NPROGS) = TYPE(ITYPE + 1)		!SAVE TYPE
TV	INPROG (NPROGS) = WORD			!SAVE NAME
¸V	IF (WORD(1:8) .EQ. '~UNNAMED') GO TO 350	!STILL MUST CHECK OPTINS
WC---------------------------------------------------------------
€WC		-- LOOK FOR END STATEMENT --
äWC---------------------------------------------------------------
HX 200	NPOS = 1
¬X	READ(2,9000,END=2000,ERR=8105) RECORD
Y	IF (RECORD .EQ. ' ') GO TO 200
tY	call jjupp(record)
ØY	IF (ISCOMT(RECORD,RAT)) THEN	!SKIP COMMENTS
<Z	  IF (SUB) CALL FCALLS(RECORD,SUBS,NSUBS,XSUBS,MXSUBS,MXINP
 Z	1		,RAT,LASTNS,NPROGS)		!"CALLS" ?
[	  GO TO 200
h[	ENDIF
Ì[ 300	CALL GETNEXT(RECORD,NPOS,WORD,)		!SKIP IF NOT END
0\	IF (WORD .NE. 'END') GO TO 350		!SKIP IF NOT END
”\		CALL GETNEXT(RECORD,NPOS,WORD,)	!CHECK FOR "END IF"
ø\		IF (WORD .EQ. ' ' .OR. 
\]	1	    WORD(1:1) .EQ. CMTCHR) GO TO 100	!WAS END
À]C---------------------------------------------------------------
$^C		-- LOOK FOR OPTIONS --
ˆ^C---------------------------------------------------------------
ì^ 350	IF(INC) KINC = INDEX(RECORD,'INCLUDE')
P_	IF (KINC .NE. 0) GO TO 400	!"INCLUDE" FOUND IN LINE
´_ 352	IF(CBFLG) KCB = INDEX(RECORD,'COMMON')
`	IF (KCB .NE. 0) GO TO 480	!FOUND "COMMON" IN RECORD
|` 355	IF(OP) KOPEN = INDEX(RECORD,'OPEN')
à`	IF (KOPEN .NE. 0) GO TO 500	!"OPEN" FOUND IN LINE
Da 365	IF(LUN) KREAD = INDEX (RECORD,'READ')
¨a	IF (KREAD .NE. 0) GO TO 600	!"READ" FOUND IN LINE
b 375	IF(LUN) KWRITE = INDEX(RECORD,'WRITE')	
pb	IF (KWRITE .NE. 0)GO TO 700	!"WRITE" FOUND IN LINE
Ôb 380	IF(LUN) KTYPE = INDEX(RECORD,'TYPE')
8c	IF(KTYPE .NE. 0) GO TO 720
œc 382	IF(LUN) KACCEPT = INDEX(RECORD,'ACCEPT')
 d	IF (KACCEPT .NE. 0) GO TO 730
dd 384	IF (LUN) KPRINT = INDEX(RECORD,'PRINT')
Èd	IF (KPRINT .NE. 0) GO TO 740
,e 385	IF(SUB .OR. NTR .GE. 0) KCALL = INDEX(RECORD,'CALL ')
e	IF (KCALL .NE. 0) GO TO 800	!"CALL " FOUND IN LINE
ôe	GO TO 200
XfC---------------------------------------------------------------
¼fC		-- PROCESS INCLUDED FILE --
 gC---------------------------------------------------------------
„g 400	CONTINUE
èg	IF(.NOT. PRECHK(RECORD,KINC,RAT,.FALSE.)) GO TO 352
Lh	KCMT = INDEX(RECORD,CMTCHR)
°h	IF(KCMT .NE. 0.AND. KCMT.LT.KINC) GO TO 352
i	KINC1 = KINC + 7
xi	CALL GETNEXT(RECORD,KINC1,WORD,)
Üi	IF (WORD(1:1) .NE. '''') GO TO 352	!"'" MUST FOLLOW
@j 	KSTART = INDEX(RECORD(KINC:72),'''')
¤j	KSTART = KSTART + KINC - 1
k	KEND = INDEX(RECORD(KSTART+1:72),'''')
lk	KEND = KEND + KSTART
Ðk	NFILES = NFILES + 1
4lD	IF (NFILES .GT. MXFILES) type 2222, NFILES
˜lD2222	FORMAT(2X,I3,' EXCEEDS MAX NUMBER OF FILES')
ül	FNAME = RECORD(KSTART:KEND)
`mC
ÄmC SEE IF WE ALREADY HAVE THIS FILE NAME
(nC
Œn	IF (NFILES .EQ. 1) GO TO 415	!DONT CHECK IF THIS IS FIRST
ðn	DO 410 IFILE = 1,NFILES-1
To	IF (FILES(IFILE) .EQ. FNAME) THEN
¸o		KFILE = IFILE			!ALREADY HAVE THIS NAME
p		NFILES = NFILES - 1		!DECREMENT COUNTER
€p		XFILES (KFILE,NPROGS) = 'X'	!SET INDICATOR
äp		GO TO 200			!CONTINUE 
Hq	ENDIF
¬q 410	CONTINUE
r 415	FILES(NFILES) = FNAME			!SAVE FILE NAME
tr	XFILES(NFILES,NPROGS) = 'X'		!SET INDICATOR
Ør	GO TO 200				!LOOK FOR MORE OPTIONS
<sC---------------------------------------------------------------
 sC		-- COMMON BLOCK --
tC --------------------------------------------------------------
ht 480	CONTINUE
Ìt	IF (.NOT. PRECHK(RECORD,KCB,RAT,.FALSE.)) GO TO 355
0u	KPOS = KCB + 6
”u	CALL GETNEXT(RECORD,KPOS,CMNBLK,)	!GET NEXT CHARACTERS
øu	IF (CMNBLK .EQ. '/') THEN		!IF '/' : NAMED COMMON.
\v	  K1 = KPOS - 1				!SLASH AT KPOS - 1
Àv	  CALL GETDEL(RECORD,KPOS,CMNBLK)	!FIND NEXT DELIMITER
$w	  IF (CMNBLK .EQ. '/') THEN		!FOUND SECOND SLASH
ˆw	    CMNBLK = RECORD(K1:KPOS-1)		!GET THE BLOCK NAME
ìw	    GO TO 482
Px	  ENDIF
´x	ENDIF
y	CMNBLK = 'BLANK'			!NO SLASH, BLANK COMMON
|yC
àyC SEE IF WE ALREADY HAVE THIS COMMON BLOCK NAME
DzC
¨z 482	CONTINUE
{	NCB = NCB + 1
p{	IF (NCB .EQ. 1) GO TO 487		!SKIP CHECK IF FIRST
Ô{	DO 485 ICB = 1,NCB - 1
8|	IF (CB(ICB) .EQ. CMNBLK) THEN		!ALREADY HAVE
œ|	  XCB(ICB,NPROGS) = 'X'			!SET INDICATOR
 }	  NCB = NCB - 1				!DECR COUNTER
d}	  GO TO 200				!BRANCH & CONTINUE
È}	ENDIF
,~ 485	CONTINUE
~ 487	CB(NCB) = CMNBLK			!SET NAME IN CB
ô~	XCB(NCB,NPROGS) = 'X'
X	GO TO 200
¼C---------------------------------------------------------------
 €C		-- OPENED FILE --
„€C---------------------------------------------------------------
è€ 500	CONTINUE
L	IF (.NOT. PRECHK(RECORD,KOPEN,RAT,.TRUE.)) GO TO 365
°	KCMT = INDEX(RECORD,CMTCHR)
‚	IF (KCMT .NE. 0 .AND. KCMT .LT. KOPEN) GO TO 365
x‚	KOPEN1 = KOPEN + 4
Ü‚	CALL GETNEXT(RECORD,KOPEN1,WORD,)
@ƒ	IF (WORD(1:1) .NE. '(') GO TO 365	!"(" MUST FOLLOW
¤ƒ	KUNIT = INDEX (RECORD,'UNIT')
„	KEQAL = INDEX (RECORD(KUNIT:72),'=')
l„	IF (KEQAL .EQ. 0 .OR .KEQAL . GT. 7) GO TO 365
Ð„	IF (KUNIT .EQ. 0) GO TO 365
4…	KOPOS = KUNIT + KEQAL
˜…	CALL GETNEXT(RECORD,KOPOS,ILUN,)
ü…C
`†	INAME = INDEX (RECORD(KOPEN:72),'NAME')
Ä†	IF (INAME .NE. 0) THEN
(‡C
Œ‡C GET FILE NAME
ð‡C
Tˆ		IPOS = KOPEN + INAME - 1
¸ˆ		IEQAL = INDEX (RECORD(IPOS:72),'=')
‰		IF (IEQAL .EQ. 0 .OR. IEQAL .GT. 7) THEN
€‰			OPFIL = ' '
ä‰		ELSE 
HŠ			IPOS = IPOS + IEQAL
¬Š	IIPOS = IPOS
‹	CALL GETNEXT(RECORD,IIPOS,OPFIL,)
t‹	IF (OPFIL(1:1) .NE. '''') THEN		!IF NAME=XXXX USE THIS
Ø‹		LTIC = IPOS
<Œ		ITIC = IPOS
 Œ		DO 550 IZ = IPOS,72
 550	IF(RECORD(IZ:IZ).EQ.','.OR.RECORD(IZ:IZ).EQ.')') GOTO 551
h	OPFIL = RECORD(IPOS:)	!NEVER FOUND ' OR )
Ì	GO TO 505
0Ž 551	ITIC = IZ - 1
”Ž	GO TO 553
øŽ	ENDIF
\	LTIC = INDEX(RECORD(IPOS:),'''') !NAME='XXX' 
À	ITIC = INDEX(RECORD(IPOS + LTIC:),'''')
$	LTIC = LTIC + IPOS - 1
ˆ	ITIC = ITIC + LTIC
ì 553	OPFIL=RECORD(LTIC:ITIC)
P‘	IF (OPFIL(1:1) .EQ. '''') ITWO = 2
´‘	IF (OPFIL(1:1) .NE. '''') ITWO = 1
’	KTWO = ITWO
|’		DO 555 KK = ITWO,20
à’		JJ = KK
D“ 555		IF(OPFIL(KK:KK) .ne. ' ') GO TO 556
¨“ 556		OPFIL(ITWO:20) = OPFIL(JJ:20)
”C
p” 504		CONTINUE
Ô”		ENDIF
8•	ELSE
œ•		OPFIL = ' '
 –	ENDIF
d– 505	NFILUN = NFILUN + 1		!INCREMENT NUM OF OPEN FILES
È–D	IF (NFILUN .GT. MXFILUN) type 3333, NFILUN
,—D3333	FORMAT(2X,I3,' EXCEEDS MAX NUMBER OPEN FILES')
—C
ô—C SEE IF WE ALREADY HAVE THIS FILE//LUN COMBINATION
X˜C
¼˜	IF (NFILUN .EQ. 1) GO TO 515	!SKIP IF FIRST ONE
 ™	DO 510 IFILUN = 1,NFILUN - 1
„™	IF (FILUN(IFILUN) .EQ. OPFILUN)	THEN
è™		XFILUN(IFILUN,NPROGS) = 'X'	!SET INDICATOR
Lš		NFILUN = NFILUN - 1		!DECREMENT CNTR
°š		GO TO 200
›	ENDIF
x› 510	CONTINUE
Ü› 515	FILUN(NFILUN) = OPFILUN		!STORE FILE//LUN NAME
@œ	XFILUN(NFILUN,NPROGS) = 'X'	!SET INDICATOR
¤œ	GO TO 200
C---------------------------------------------------------------
lC		-- "READ" FOUND --
ÐC---------------------------------------------------------------
4ž 600	KPOS = KREAD + 4	!4 CHARACTERS IN READ
˜ž	IF (.NOT. PRECHK(RECORD,KREAD,RAT,.TRUE.)) GO TO 375
üž	IOFLAG = 1
`Ÿ	GO TO 750
ÄŸC---------------------------------------------------------------
( C		-- "WRITE" FOUND --
Œ C---------------------------------------------------------------
ð  700	KPOS = KWRITE + 5	!5 CHARACTERS IN WRITE
T¡	IF (.NOT. PRECHK(RECORD,KWRITE,RAT,.TRUE.)) GO TO 385
¸¡	IOFLAG = 2
¢	GO TO 750
€¢C---------------------------------------------------------------
ä¢C		-- "TYPE" FOUND --
H£C---------------------------------------------------------------
¬£ 720	KPOS = KTYPE + 4
¤	IOFLAG = 3
t¤	IF (.NOT. PRECHK(RECORD,KTYPE,RAT,.TRUE.)) GO TO 382
Ø¤	GO TO 745
<¥C---------------------------------------------------------------
 ¥C		-- "ACCEPT" FOUND --
¦C---------------------------------------------------------------
h¦ 730	KPOS = KACCEPT + 6
Ì¦	IOFLAG = 4
0§	IF (.NOT. PRECHK(RECORD,KACCEPT,RAT,.TRUE.)) GO TO 384
”§	GO TO 745
ø§C---------------------------------------------------------------
\¨C		-- "PRINT" FOUND --
À¨C---------------------------------------------------------------
$© 740	KPOS = KPRINT + 5
ˆ©	IOFLAG = 5
ì©	IF (.NOT. PRECHK(RECORD,KPRINT,RAT,.TRUE.)) GO TO 385
PªC--------------------------------------------------------------
´ªC		-- PRINT,TYPE ACCEPT --
«C--------------------------------------------------------------
|« 745	CONTINUE
à«	KOLD = KPOS 
D¬	CALL GETDEL(RECORD,KPOS,WORD)
¨¬	IF (WORD .NE. ',' .AND. KOLD .NE. KPOS)
­	1	GO TO (382,384,385) , (IOFLAG-2)
p­C
Ô­C IT WAS AN I/O FROM A PRINT, ACCEPT, OR TYPE
8®C
œ®	IF (IOFLAG .EQ. 3) KLUN = 'TYPE'
 ¯	IF (IOFLAG .EQ. 4) KLUN = 'ACCEPT'
d¯	IF (IOFLAG .EQ. 5) KLUN = 'PRINT'
È¯	GO TO 755
,°C---------------------------------------------------------------
°C		-- READ OR WRITE --
ô°C---------------------------------------------------------------
X± 750	JPOS = KPOS		!SAVE FOR LATER USE
¼±	KCMT = INDEX(RECORD,CMTCHR)
 ²	IF (KCMT .NE. 0 .AND. KCMT .LT. KPOS) GO TO (375,385),IOFLAG
„²	CALL GETNEXT(RECORD,KPOS,KLUN,)
è²	IF (KLUN(1:1) .NE. '(') GO TO (375,385) ,IOFLAG
L³	KLPAR = INDEX(RECORD(JPOS:80),'(')
°³	KRPAR = INDEX(RECORD(JPOS:80),')')
´	KCOMMA = INDEX(RECORD(JPOS:80),',')
x´	KAPOST = INDEX(RECORD(JPOS:80),'''')
Ü´	IF (KLPAR .EQ. 0 .OR. KRPAR .EQ. 0) GO TO (375,385) ,IOFLAG
@µ	IF (KCOMMA .EQ. 0 .AND. KAPOST .EQ. 0)GOTO (375,385),IOFLAG
¤µ	IF (KAPOST .EQ. 0) KAPOST = KCOMMA
¶	IF (KCOMMA .EQ. 0) KCOMMA = KAPOST
l¶	IDEL = MIN0(KCOMMA,KAPOST)
Ð¶	JS = JPOS + KLPAR
4·	JE = JPOS + IDEL - 2
˜·	ILUN = RECORD(JS:JE)
ü·	KPOS = 1
`¸	CALL GETNEXT(ILUN,KPOS,KLUN,)	!SQUEEZE LEADING BLANKS OUT
Ä¸C---------------------------------------------------------------
(¹C		-- GENERAL I/O --
Œ¹C---------------------------------------------------------------
ð¹ 755	CONTINUE
Tº	NIO = NIO + 1
¸ºD	IF (NIO .GT. MXIO) type 4444, NIO
»D4444	FORMAT(2X,I3,' EXCEEDS MAXIMUN NUMBER OF READ/WRITES')
€»C
ä»C SEE IF WE ALREADY HAVE THIS LUN
H¼C
¬¼	IF (NIO .EQ. 1) GO TO 761
½	DO 760 IIO = 1,NIO-1
t½	IF (IO(IIO) .EQ. KLUN) THEN
Ø½		KIO = IIO
<¾		NIO = NIO - 1
 ¾		GO TO (780,775,775,780,775) ,IOFLAG
¿	ENDIF
h¿ 760	CONTINUE
Ì¿ 761	KIO = NIO
0À 	IO (KIO) = KLUN
”À	IF (IOFLAG .EQ. 1 .OR. IOFLAG .EQ. 4) GO TO 780
øÀ 775	IF (XIO(KIO,NPROGS) .EQ. 'R') XIO(KIO,NPROGS) = 'X'
\Á	IF (XIO(KIO,NPROGS) .le. ' ') XIO(KIO,NPROGS) = 'W'
ÀÁ	GO TO 200
$Â 780	IF (XIO(KIO,NPROGS) .EQ. 'W') XIO(KIO,NPROGS) = 'X'
ˆÂ	IF (XIO(KIO,NPROGS) .le. ' ') XIO(KIO,NPROGS) = 'R'
ìÂ	GO TO 200
PÃC---------------------------------------------------------------
´ÃC		-- CALLED A SUBROUTINE --
ÄC---------------------------------------------------------------
|Ä 800	CONTINUE
àÄ	IF (.NOT. PRECHK(RECORD,KCALL,RAT,.TRUE.)) GO TO 200	!NOT A CALL
DÅ 	KCMT = INDEX(RECORD,CMTCHR)
¨Å	IF (KCALL .GT. KCMT .AND. KCMT .NE. 0) GO TO 200  !FALSE ALARM
Æ	KPOS = KCALL + 4		!4 CHRS IN "CALL"
pÆ	CALL GETNEXT(RECORD,KPOS,SNAME,1H$)	!GET SUB NAME
ÔÆC
8ÇC SEE IF WE ALREADY HAVE THIS SUBROUTINE NAME
œÇC
 È	NSUBS = NSUBS + 1
dÈ	IF (NSUBS .EQ. 1) GO TO 815	!DONT CHECK IF THIS IS FIRST
ÈÈ	DO 810 ISUB = 1,NSUBS - 1
,É	IF (SUBS(ISUB) .EQ. SNAME) THEN
É		KSUB = ISUB
ôÉ		NSUBS = NSUBS - 1
XÊ		XSUBS(KSUB,NPROGS) = 'X'
¼Ê		IF(KSUB .GT. LASTNS(NPROGS)) LASTNS(NPROGS) = KSUB
 Ë		GO TO 200
„Ë	ENDIF
èË 810	CONTINUE
LÌD	IF (NSUBS .GT. MXSUBS) type 5555, NSUBS
°ÌD5555	FORMAT(2X,I3,'EXCEEDS MAX NUMBER OF SUBS CALED')
Í 815	SUBS(NSUBS) = SNAME		!SAVE SUBROUTINE NAME
xÍ	XSUBS(NSUBS,NPROGS) = 'X'	!SET INDICATOR
ÜÍ		IF(NSUBS .GT. LASTNS(NPROGS)) LASTNS(NPROGS) = NSUBS
@Î	GO TO 200
¤ÎC---------------------------------------------------------------
ÏC		-- PRINT THE CROSS REFERENCE ARRAY --
lÏC---------------------------------------------------------------
ÐÏ 2000	CONTINUE
4ÐC TRACE
˜Ð	IF(NTR.GE.0.AND.NSUBS.GT.0) CALL TRACE(INPROG,SUBS,XSUBS,NPROGS
üÐ	1		,NSUBS,MXSUBS,INTYPE,TR,NTR,LASTNS,COM,ish)
`ÑC SUBROUTINES
ÄÑ	IF(AZ.AND.NSUBS .GT. 0) CALL SORT2D(XSUBS,INPROG,SUBS,NPROGS,NSUBS
(Ò	1			,MXSUBS,ICOL,IROW,.TRUE.,.FALSE.)
ŒÒ	IF(SUB.AND.NSUBS .GT. 0) CALL PRINT(INTYPE,INPROG,SUBS,XSUBS
ðÒ	1		,NPROGS,NSUBS,MXSUBS,MXINP,SLAB,IROW,ISZ)
TÓC COMMON BLOCKS
¸Ó	IF (AZ .AND. NCB .GT. 0) CALL SORT2D(XCB,INPROG,CB,NPROGS,
Ô	1	NCB,MXCB,ICOL,IROW,.TRUE.,.FALSE.)
€Ô	IF (CBFLG .AND. NCB .GT. 0) CALL PRINT(INTYPE,INPROG,CB,XCB,
äÔ	1	NPROGS,NCB,MXCB,MXINP,CBLAB,IROW,ISZ)
HÕC INCLUDE FILES
¬Õ	IF(AZ .AND. NFILES .GT. 0) CALL SORT2D(XFILES,INPROG,FILES
Ö	1	,NPROGS,NFILES,MXFILES,ICOL,IROW,.TRUE.,.FALSE.)
tÖ	IF(INC.AND.NFILES.GT.0) CALL PRINT(INTYPE,INPROG,FILES,XFILES
ØÖ	1		,NPROGS,NFILES,MXFILES,MXINP,FILAB,IROW,ISZ)
<×C I/O LUNS
 ×	IF(AZ.AND.NIO .GT. 0) CALL SORT2D(XIO,INPROG,IO,NPROGS,NIO,MXIO,
Ø	1			ICOL,IROW,.TRUE.,.FALSE.)
hØ	IF(LUN.AND.NIO .GT. 0) CALL PRINT(INTYPE,INPROG,IO,XIO,NPROGS,
ÌØ	1		NIO,MXIO,MXINP,IOLAB,IROW,ISZ)
0ÙC OPEN FILES
”Ù	IF(AZ.AND.NFILUN .GT. 0) CALL SORT2D(XFILUN,INPROG,FILUN,NPROGS,NFILUN
øÙ	1			,mxfilun,ICOL,IROW,.TRUE.,.FALSE.)
\Ú	IF(OP.AND.NFILUN .GT. 0) CALL PRINT(INTYPE,INPROG,FILUN,XFILUN
ÀÚ	1		,NPROGS,NFILUN,MXFILUN,MXINP,OPLAB,IROW,ISZ)
$ÛC SUMMARY
ˆÛ	WRITE(3,9100) 
ìÛ 9100	FORMAT('1',T20,'C R O S S   R E F E R E N C E   S U M M A R Y'/
PÜ	1T20,'---------------------------------------------'//)
´Ü	WRITE(3,9105) NPROGS
Ý 9105	FORMAT(25X,'Input Routines',T50,I4)
|Ý	IF( SUB ) WRITE(3,9110) NSUBS
àÝ 9110	FORMAT(25X,'Routines Referenced',T50,I4)
DÞ	IF( CBFLG ) WRITE(3,9115) NCB
¨Þ 9115	FORMAT(25X,'Common Blocks',T50,I4)
ß	IF( INC ) WRITE(3,9120) NFILES
pß 9120	FORMAT(25X,'Included Files',T50,I4)
Ôß	IF( LUN ) WRITE(3,9130) NIO
8à 9130	FORMAT(25X,'I/O Units',T50,I4)
œà	IF( OP  ) WRITE(3,9140) NFILUN
 á 9140	FORMAT(25X,'Opened Files',T50,I4)
dá	STOP '--- Cross outputs to --- FOR003.dat'
ÈáC---------------------------------------------------------------
,âC		-- ERROR EXITS --
âC---------------------------------------------------------------
ôâ 8005	type 8006
Xã 8006	FORMAT('  **  ERROR OPENING INFILE - ABORTING  **')
¼ã	CALL EXIT
 ä 8105	type 8106
„ä 8106	FORMAT('  **  ERROR READING INFILE - ABORTING  **')
èä	CLOSE(UNIT=2)
Lå	CALL EXIT
°å 8205	type 8206
æ 8206	FORMAT('  **  TOO MANY UNNAMED FILES - ABORTING  **')
xæ	CLOSE(UNIT=2)
Üæ	CALL EXIT
@ç	END
ÿÿ
d 	FUNCTION CURLEN( STRING )
È 	integer curlen !!ML!! type of function
,C
C	THIS FUNCTION FINDS THE CURRENT LENGTH OF 'STRING'
ôC	     NOT COUNTING TRAILING BLANKS.
XC
¼C	THE VALUE OF THE FUNCTION BECOMES THE CURRENT LENGTH
 C
„	CHARACTER *(*) STRING
èC
L	CURLEN = LEN( STRING )
°C
	DO 100 I = LEN( STRING ), 1, -1
x		IF( STRING(I:I) .NE. ' ' ) RETURN
Ü		CURLEN = CURLEN - 1
@100	CONTINUE
¤C
	RETURN
l	END
ÿÿ
d 	SUBROUTINE FCALLS(RECORD,SUBS,NSUBS,XSUBS,MXSUBS,MXINP,RAT
È 	1		 ,LASTNS,NPROGS)
,C
C		SUBROUTINE SEARCHES THE INPUT LINE FOR LINE OF FORM:
ôC
XC	C CALLS FUNC1,FUNC2,...FUNCn
¼C
 C		OR, FOR RATFOR LINES
„C	# CALLS FUNC1,FUNC2,...FUNCN
èC
LC	AND THEN: Place FUNC1, FUNC2,... in the called routines list.
°C		  ( this should help define functions called )
C===============================================================
x	CHARACTER*(*)	RECORD,SUBS(MXSUBS),XSUBS(MXSUBS,MXINP)
Ü	CHARACTER*15	NEXT
@	DIMENSION	LASTNS(MXINP)
¤	LOGICAL RAT
C===============================================================
l	IF (.NOT. RAT) KSTART=INDEX(RECORD,'C') + 1
Ð	IF (RAT) KSTART=INDEX(RECORD,'#') + 1
4C	WAS "CALLS" ON THE COMMENT LINE ?
˜C===============================================================
ü	KPOS = KSTART
`		CALL GETNEXT(RECORD,KPOS,NEXT,1H$)
Ä		IF (NEXT .NE. 'CALLS') RETURN		!NOT A "CALLS"
(
C
Œ
C GET FUNCTION NAME
ð
C
T 100	CONTINUE
¸	KOLD = KPOS
	CALL GETNEXT(RECORD,KPOS,NEXT,1H$)	!LOOK UNTIL NEXT DELMTR
€	IF (NEXT(1:1) .LT. 'A' .OR. NEXT(1:1) .GT. 'Z') RETURN
äC
HC SEE IF WE ALREADY HAVE THIS ROUTINE NAME
¬C
	NSUBS = NSUBS + 1
t	IF (NSUBS .EQ. 1) GO TO 815	!DONT CHECK IF THIS IS FIRST
Ø	DO 810 ISUB = 1,NSUBS - 1
<	IF (SUBS(ISUB) .EQ. NEXT) THEN
 		KSUB = ISUB
		NSUBS = NSUBS - 1
h		XSUBS(KSUB,NPROGS) = 'X'
Ì		IF(KSUB .GT. LASTNS(NPROGS)) LASTNS(NPROGS) = KSUB
0		GO TO 820	!CHECK IF THERE ARE MORE ON THIS LINE
”	ENDIF
ø 810	CONTINUE
\D	IF (NSUBS .GT. MXSUBS) type 5555, NSUBS
ÀD5555	FORMAT(2X,I3,'EXCEEDS MAX NUMBER OF SUBS CALED')
$ 815	SUBS(NSUBS) = NEXT		!SAVE SUBROUTINE NAME
ˆ	XSUBS(NSUBS,NPROGS) = 'X'	!SET INDICATOR
ì		IF(NSUBS .GT. LASTNS(NPROGS)) LASTNS(NPROGS) = NSUBS
P 820	CALL GETNEXT(RECORD,KPOS,NEXT, )
´	IF (NEXT .NE. ',') RETURN
	GO TO 100
|	END
ÿÿ
d       SUBROUTINE  GETDEL ( LINE, IPOS, DEL )
È C
,C
C               THIS ROUTINE PARSES THE STRING LINE, USES BLANKS,TABS,$
ôC               ,!,/, =, (, ) OR COMMA AS DELIMETERS AND RETURNS NEXT
XC		DELIMITER AS DEL.
¼C
 C
„C               LINE - THE INPUT STRING
èC
LC               IPOS - THE LOCATION TO START LOOKING, SET TO THE
°C                      LOCATION AFTER THE DELIMITER FOUND
C
xC               DEL - THE RETURNED DELIMITER
ÜC
@C
¤      CHARACTER*(*)  LINE, DEL
C
lC               IF NOTHING THERE RETURN A BLANK
ÐC
4      WORD = ' '
˜      LINELEN = LEN(LINE)
ü      IF ( IPOS .GT. LINELEN )  RETURN
`	C
Ä	C               NOW FIND FIRST NON-BLANK CHARACTER
(
C
Œ
      IPOS1 = IPOS
ð
      IPOS2 = LINELEN
T      DO 10 I = IPOS1, IPOS2
¸   10   IF ( ( LINE(I:I) .NE. ' ' ) .AND. 
     .       ( ICHAR(LINE(I:I)) .NE. 9 ) )  GO TO 20
€      RETURN
äC
HC               NOW FIND A VALID DELIMETER
¬C
   20 IPOS1 = I
t      DO 30 I = IPOS1, IPOS2
Ø      IF ( ( LINE(I:I) .EQ. ' ' ) .OR.
<     .       ( ICHAR(LINE(I:I)) .EQ. 9 ) .OR.
      .       ( LINE(I:I) .EQ. '/' ) .OR.
     .       ( LINE(I:I) .EQ. '(' ) .OR.
h     .       ( LINE(I:I) .EQ. ')' ) .OR.
Ì     .       ( LINE(I:I) .EQ. ',' ) .OR.
0     .       ( LINE(I:I) .EQ. '!' ) .OR.
”     .       ( LINE(I:I) .EQ. '$' ) .OR.
ø     .       ( LINE(I:I) .EQ. '=' ) )  GO TO 40
\ 30	CONTINUE
ÀC
$C               NOW SET WORD AND IPOS
ˆC
ì 40	CONTINUE
P      DEL = LINE(I:I)
´      IPOS = I + 1
      RETURN
|      END
ÿÿ
d       SUBROUTINE  GETNEXT ( LINE, IPOS, NEXT ,EXCEPT )
È C
,C
C               THIS ROUTINE PARSES THE STRING LINE, USES BLANKS,
ôC               /, =, (, ) OR COMMA AS DELIMETERS AND RETURNS NEXT
XC               CONTIGUOUS STRING AS NEXT.
¼C
 C
„C               LINE - THE INPUT STRING
èC
LC               IPOS - THE LOCATION TO START LOOKING, SET TO THE
°C                      LOCATION AFTER THE WORD FOUND
C
xC               NEXT - THE RETURNED STRING
ÜC
@C		EXCEPT - IF PRESENT, REMOVE THIS DELIMITER FROM
¤C			 THE LIST OF ONES TO CHECK.  MUST BE PASSED
C			 AS A LOGICAL*1, OR 1H^, NOT AS '^', WHERE
lC			 THE ^ IS THE DELEIMTER TO BE NEGLECTED.
ÐC
4      CHARACTER*(*)  LINE, NEXT
˜	BYTE EXCEPT
ü	LOGICAL NULL
`	C
Ä	C               IF NOTHING THERE RETURN A BLANK
(
C
Œ
      NEXT = ' '
ð
      LINELEN = LEN(LINE)
T      IF ( IPOS .GT. LINELEN )  RETURN
¸C
C               NOW FIND FIRST NON-BLANK CHARACTER
€C
ä      IPOS1 = IPOS
H      IPOS2 = LINELEN
¬      DO 10 I = IPOS1, IPOS2
   10   IF ( ( LINE(I:I) .NE. ' ' ) .AND. 
t     .       ( ICHAR(LINE(I:I)) .NE. 9 ) )  GO TO 20
Ø      RETURN
<C
 C               NOW FIND A VALID DELIMETER
C
h   20 IPOS1 = I
Ì      DO 30 I = IPOS1, IPOS2
0      IF ( ( LINE(I:I) .EQ. ' ' ) .OR.
”     .       ( ICHAR(LINE(I:I)) .EQ. 9 ) .OR.
ø     .       ( LINE(I:I) .EQ. '/' ) .OR.
\     .       ( LINE(I:I) .EQ. '(' ) .OR.
À     .       ( LINE(I:I) .EQ. ')' ) .OR.
$     .       ( LINE(I:I) .EQ. ',' ) .OR.
ˆ     .       ( LINE(I:I) .EQ. '$' ) .OR.
ì     .       ( LINE(I:I) .EQ. '=' ) ) THEN
P		IF(.NOT. NULL(EXCEPT)) THEN
´		  IF(LINE(I:I) .EQ. CHAR(EXCEPT)) GO TO 30
		  GO TO 40	!WASNT EXCEPT CHARACTER
|		ELSE
à		  GO TO 40
D		ENDIF
¨	ENDIF
 30	CONTINUE
p      I = IPOS2
ÔC
8C               NOW SET NEXT AND IPOS
œC
    40 IF ( I .NE. IPOS1 )  I = I - 1
d      NEXT = LINE(IPOS1:I)
È      IPOS = I + 1
,      RETURN
      END
ÿÿ
d 	SUBROUTINE GETOPT(pgmfile,INC,OP,SUB,LUN,CB,RAT
È 	1	,AZ,TR,COM,NTR,isize,ish)
,c.
c!ML! Check input file
ôC
XC	IF ANY OF THE FOLLOWING ARE ON THE COMMAND LINE, 
¼C	ONLY THE INDICATED OPERATIONS ARE PERFORMED.  
 C	DEFAULT:  ALL TRUE.
„C
èc		pgmfile	- program file name
LC	(D)	'INC'	- SEARCH FOR ALL INCLUDED FILES
°C	(D)	'LUN'	- SEARCH FOR READ/WRITE LUNS
C	(D)	'SUB'	- SUEARCH FOR SUBS CALLED
xC	(D)	'OP'	- SEARCH FOR OPEN FILES
ÜC	(D)	'CB'	- SEARCH FOR COMMON BLOCKS
@C
¤C	(D)	'PR'	- ONLY MAIN PROGS ARE TRACED.
C		'%name'	- THE ROUTINE NAMED 'name' IS TRACED.
lC		'ALL'	- A FULL SUBROUTINE TRACE IS PERFORMED.
ÐC		'NOT'	- NO TRACING IS DONE
4C
˜C
üC	IF	'NOA'	- NO ALPHABETIZATION IS PERFORMED.
`	C			  DEFAULT IS TO ALWAYS TO ALPHEBETIZE,
Ä	C			  REGARDLESS OF PREVIOUS OPTIONS.
(
C
Œ
C	IF	'80'	- 80 COLUMN OUTPUT
ð
C	    (D) '132'	- 132 COLUMN OUTPUT
TC		'REPORT'- 8 1/2 BY 11 INCH, WITH ROOM FOR PUNCHED HOLES.
¸C		'COM'   - COMPRESS TRACE OUTPUT
C		'TRI'	- Trim the tree
€C		'RAT'	- RATFOR COMMENT CHARACTER (#) RECOGNIZED,
äC			  INSTEAD FO THE FORTRAN FORU PLUS (!).
HC			  ALSO, CONTINUATION CONVENTION CHANGE.
¬C
	character*(*) pgmfile
t	CHARACTER*11	TR(10)			!TR(10)ACE OPTION FLAG
Ø	CHARACTER	OPTION*80, COMMAND*80
<	CHARACTER*3	VALID(4),op3
 	CHARACTER*(*)	ISIZE			!OUTPUT SIZE
	LOGICAL		INC,OP,SUB,LUN,AZ,CB,RAT,COM,ish
h	DATA	VALID	/'INC','OP','LUN','SUB'/
ÌC
0	NPC = 0					!# OF %name OPTIONS
”	LPOS = 1
ø	inc = .true.
\	op  = .true.
À	COM = .FALSE.				!NO COMPRESS DEFAULT
$	ish = .FALSE.
ˆ	lun = .true.
ì	sub = .true.
P	cb = .true.
´	rat= .false.		!DEFAULT IS NOT RATFOR CONVENTIONS
	NTR = 0			!DEFAULT TRACE OTPION
|	AZ = .TRUE.
àc.
Dc... Request next command line
¨c.
1000	continue
p	lpos = 1
Ô	command = '$CROSS {?=Help} <{@}File {Opts} ?'
8	CALL JJCMD(COMMAND)
œ	call jjupp(command)
 c.
dc... Process a new command line
Èc.
, 25	IF (COMMAND(1:1) .EQ. '?') GO TO 300	!USER NEEDS HELP
	if( command.eq.' ' ) goto 300		!!Null = Help
ô	LOLD = LPOS
X	CALL GETWORD(COMMAND,LPOS,OPTION)
¼D	type 777, COMMAND,LPOS,OPTION
 D777	FORMAT(1X,A/1X,'LPOS = ',I3,10X,'OPTION = ',A)
„	IF(LPOS .eq. LOLD) GO TO 9000
èC
LC OPTIONS PRESENT - TRY TO MATCH WITH VALID OPTIONS
°C
100	continue
xC
Ü	LEGAL = .FALSE.		!FOUND A LEGAL OPTION YET ?
@	LPOS = 1
¤ 110	CONTINUE
 	LOLD = LPOS
l 	CALL GETWORD(COMMAND,LPOS,OPTION)
Ð 	call jjupp(command)
4!D	type 777, COMMAND,LPOS,OPTION
˜!	IF(LPOS .EQ. LOLD) GO TO 9000
ü!C
`"	op3 = option
Ä"	IF (op3 .eq. 'NOI') INC = .FALSE.
(#	IF (op3 .eq. 'NOO')  OP = .FALSE.
Œ#	IF (op3 .eq. 'NOS') SUB = .FALSE.
ð#	IF (op3 .eq. 'NOL') LUN = .FALSE.
T$	IF (op3 .eq. 'NOA')  AZ = .FALSE.
¸$	IF (op3 .eq. 'NOC') NOCB = .FALSE.
%	IF (op3 .EQ. '80')  ISIZE = '80'
€%	IF (op3 .EQ. 'REP') ISIZE = 'REPORT'
ä%	IF (op3 .EQ. 'ALL') NTR = 99
H&	IF (op3 .EQ. 'PR')  NTR = 0
¬&	If (op3 .eq. 'RAT') RAT = .true.
'	if (OP3 .EQ. 'NOT') NTR = -99
t'	IF (OP3 .EQ. 'COM') COM = .TRUE.
Ø'	if( op3 .eq. 'TRI') ish = .TRUE.
<(	IF (OPTION(1:1) .EQ. '%') THEN
 (		NPC = NPC + 1
)		TR(NPC) = OPTION
h)		NTR = NPC
Ì)	ENDIF
0*	if( option(1:1) .eq. '<' ) then
”*		pgmfile = option(2:)
ø*	endif
\+C
À+	IF(LEGAL) GO TO 110
$,		DO 120 IV = 1,4
ˆ, 		IF(OPTION .EQ. VALID(IV) .OR. NTR . NE. -99)
ì,	1	LEGAL = .TRUE.
P- 120	CONTINUE
´-	GO TO 110
.c.
|.c... Print out the help
à.c.
D/300	continue
¨/	type 305
0305	format(
p0	1 /,'.	<Source .or.     <@File_of_Source_File_Names'
Ô0	1//,'.	RATfor           FORTRAN = Default -- Source_form'
81	1//,'.	                 Main    = Default -- Trace_Tree_option'
œ1	1 /,'.	NOTrace .or.     ALL .or.          %Routine_name'
 2	1//,'.	                 ALL     = Default -- Tables_Shown'
d2	1 /,'.	NOInclude_file,  NOLogical_units,  NOSubroutines,'
È2	1 /,'.	NOOpens,         NOCommon_blocks,  NOAlphabitizing'
,3	1//,'.	                 132     = Default -- Output_format'
3	1 /,'.	80 cols  .or.    REPort_form,'
ô3	1 /,'.	COMpress .or.    TRIm_tree'
X4	1/
¼4	2 )
 5	goto 1000
„5c.
è5c... Error on file open
L6c.
°68000	continue
7	type 8010,' Can''t open <',pgmfile(1:jjlen(pgmfile))
x78010	format( 132a )
Ü7	goto 1000
@8c.
¤8c... Ready to exit
9c.
l99000	continue
Ð9	if( pgmfile(1:1).ne.'@' ) then
4:	  open(unit=1,name=pgmfile,type='old',readonly,err=8000)
˜:	else
ü:	  open(unit=1,name=pgmfile(2:),type='old',err=8000)
`;	endif
Ä;	close(unit=1)
(<c.
Œ<	return
ð<	END
ÿÿ
d 	SUBROUTINE GETTYP(RECORD,ITYPE,NAME)
È C
,C	RETURNS  VARIABLE ITYPE AS THE INTEGER CODE BELOW, IF THE
C	CORRESPONDING DEFINING TEXT IS THE FIRST TEXT ON THE RECORD.
ôC
XC	CODE		DEFINING TEXT
¼C	----		-------------
 C
„C	ITYPE =	0 - NONE OF THE FOLLOWING FOUND.
èC		1 - "FUNCTION"
LC		2 - "LOGICAL FUNCTION"
°C		3 - "CHARACTER FUNCTION"
C		4 - "REAL FUNCTION"
xC		5 - "INTEGER FUNCTION"
ÜC		6 - "SUBROUTINE"
@C		7 - "PROGRAM"
¤C		8 - "BLOCK DATA"
C		9 - "C/ELT"
lC	       10 - "C/GRP"
ÐC
4C	NAME IS RETURNED AS THE NEXT "WORD" FOUND AFTER THE
˜C	     DEFINING TEXT IS FOUND.
üC==============================================================
`	C
Ä		CHARACTER*(*)	RECORD,NAME
(
	KPOS = 1		!FIRST POSITION ON RECORD TO SEARCH
Œ
	ITYPE = 0		!TYPE CODE FOR NOTHING FOUND
ð
C
T	CALL GETNEXT(RECORD,KPOS,NAME,1H/)		!GET FIRST WORD
¸	IF (NAME .EQ. 'LOGICAL') ITYPE = 1
	IF (NAME .EQ. 'CHARACTER')	ITYPE = 2
€	IF (NAME .EQ. 'REAL') 		ITYPE = 3
ä	IF (NAME .EQ. 'INTEGER')	ITYPE = 4
HC
¬	IOLD = ITYPE
	IF(ITYPE .NE. 0) CALL GETNEXT(RECORD,KPOS,NAME,)
t	IF (NAME .EQ. 'FUNCTION') ITYPE = ITYPE + 1
Ø	IF (NAME .EQ. 'PROGRAM')  ITYPE = 7
<	IF (NAME .EQ. 'SUBROUTINE') ITYPE = 6
 	IF (NAME .EQ. 'BLOCK') THEN
	   CALL GETNEXT(RECORD,KPOS,NAME,)
h	   IF (NAME .EQ. 'DATA')  ITYPE = 8
Ì	ENDIF
0	IF (NAME .EQ. 'C/ELT')    ITYPE = 9
”	IF (NAME .EQ. 'C/GRP')	  ITYPE = 10
øC
\	CALL GETNEXT(RECORD,KPOS,NAME,1H$)
À	IF (ITYPE .EQ. IOLD) ITYPE = 0
$	RETURN
ˆ	END
ÿÿ
d       SUBROUTINE  GETWORD ( LINE, IPOS, WORD )
È C
,C
C               THIS ROUTINE PARSES THE STRING LINE, USES BLANKS,
ôC               /, =, (, ) OR COMMA AS DELIMETERS AND RETURNS NEXT
XC               CONTIGUOUS STRING AS WORD.
¼C
 C
„C               LINE - THE INPUT STRING
èC
LC               IPOS - THE LOCATION TO START LOOKING, SET TO THE
°C                      LOCATION AFTER THE WORD FOUND
C
xC               WORD - THE RETURNED STRING
ÜC
@C
¤      CHARACTER*(*)  LINE, WORD
C
lC               IF NOTHING THERE RETURN A BLANK
ÐC
4      WORD = ' '
˜      LINELEN = LEN(LINE)
ü      IF ( IPOS .GT. LINELEN )  RETURN
`	C
Ä	C               NOW FIND FIRST NON-BLANK CHARACTER
(
C
Œ
      IPOS1 = IPOS
ð
      IPOS2 = LINELEN
T      DO 10 I = IPOS1, IPOS2
¸   10   IF ( ( LINE(I:I) .NE. ' ' ) .AND. 
     .       ( ICHAR(LINE(I:I)) .NE. 9 ) )  GO TO 20
€      RETURN
äC
HC               NOW FIND A VALID DELIMETER
¬C
   20 IPOS1 = I
t      DO 30 I = IPOS1, IPOS2
Ø   30   IF ( ( LINE(I:I) .EQ. ' ' ) .OR.
<     .       ( ICHAR(LINE(I:I)) .EQ. 9 ) .OR.
      .       ( LINE(I:I) .EQ. '/' ) .OR.
     .       ( LINE(I:I) .EQ. '(' ) .OR.
h     .       ( LINE(I:I) .EQ. ')' ) .OR.
Ì     .       ( LINE(I:I) .EQ. ',' ) .OR.
0     .       ( LINE(I:I) .EQ. '$' ) .OR.
”     .       ( LINE(I:I) .EQ. '=' ) )  GO TO 40
ø      I = IPOS2
\C
ÀC               NOW SET WORD AND IPOS
$C
ˆ   40 IF ( I .NE. IPOS1 )  I = I - 1
ì      WORD = LINE(IPOS1:I)
P      IPOS = I + 1
´      RETURN
      END
ÿÿ
d 	FUNCTION IPOP(ISTACK,IVAL,ISP)
È 	logical ipop !!ML!! type
,	DIMENSION 	ISTACK(1)
	ISP = ISP - 1		!DCR STACK POINTER FOR CURRENT LOC
ô	IF(ISP .LE. 0) THEN
X		IPOP = .FALSE.
¼		RETURN
 	ELSE
„		IVAL = ISTACK(ISP)
è		IPOP = .TRUE.
L	ENDIF
°	RETURN
	END
ÿÿ
d 	SUBROUTINE IPUSH(ISTACK,IVAL,ISP)
È 	DIMENSION ISTACK(1)
,	ISTACK(ISP) = IVAL
	ISP = ISP + 1
ô	RETURN
X	END
ÿÿ
d 	FUNCTION ISCOMT(RECORD,RAT)
È 	logical ISCOMT
,C
C	DETERMINES IF THIS IS A COMMENT LINE.
ôC
XC	RAT SHOULD BE SENT .TRUE. IF THIS IS A RATFOR SOURCE LINE,
¼C	AND .FALSE. IF FORTRAN FOUR PLUS.
 C
„	CHARACTER*(*) RECORD
è	LOGICAL RAT
LC
°	MXCOL = LEN(RECORD)
	ISCOMT = .FALSE.	!UNTIL WE KNOW BETTER
x	IF (RAT) THEN
Ü	  DO 100 ICOL = 1,MXCOL
@	  IF (RECORD(ICOL:ICOL) .NE. ' ' .AND.
¤	1 RECORD(ICOL:ICOL) .NE. '	') THEN
	    IF(RECORD(ICOL:ICOL) .EQ. '#') ISCOMT = .TRUE.
l	  ENDIF
Ð 100	CONTINUE
4	RETURN
˜C
ü	ELSE
`		  IF (RECORD(1:1) .EQ. 'C' .OR.
Ä		1 RECORD(1:1) .EQ. '!') ISCOMT = .TRUE.
(
	  RETURN
Œ
	ENDIF
ð
	END
ÿÿ
d 	FUNCTION NULL(IARG)
È 	logical null !!ml!!type
,C
C		FORTRAN VARIABLES PASSED TO SUBROUTINES AS NULL
ôC		ARGUMENTS ARE GIVEN A ZERO ADDRESS BY THE 
XC		COMPILER AND LINKER, AND THEREFORE ARE UNUSABLE.
¼C
 C		NULL RETURNS	.TRUE.	IF THIS IS THE CASE,
„C				.FALSE.	OTHERWISE.
èC
L	NULL = (%LOC(IARG) .EQ. 0)
°	RETURN
	END
ÿÿ
d 	FUNCTION PRECHK(RECORD,IPOS,RAT,PFLAG)
È 	logical prechk !!ML!! type
,C
C		CHECKS TO SEE IF THE FIRST NON-BLANK,NON BLANK
ôC		CHARACTER PREECEDING IPOS IS EITHER A ")" OR
XC		IS THE CONTINUATION CHARACTER.
¼C
 C	RAT SHOULD BE SENT .TRUE.  IF LINE IS A RATFOR LINE;
„C			   .FALSE. IF A FORTRAN 4+ LINE
èC
LC	PFLAG SHOULD BE .TRUE. IF ")" IS A LEGAL PREECEEDING CHAR;
°C			.FALSE. IF NOT.  
C
x	CHARACTER*(*)	RECORD
Ü	LOGICAL RAT,PFLAG
@C
¤C DETERMINE IF A RATFOR LINE
C
l	IF (RAT)  THEN
Ð	  LAST = 1
4	  GO TO 400
˜	ENDIF
üC
`	C FIRST, FIND THE CONTINUATION COLUMN
Ä	C
(
	DO 100 J = 1,5
Œ
 100	IF ( RECORD(J:J) .EQ. '	') GO TO 200	!CHECK FOR TABS
ð
	LAST = 7			!LAST COLUMN TO CHECK
T	GO TO 400
¸ 200	IF (RECORD(J+1:J+1) .GE. '1'	!DIGIT 1 TO 9 ?
	1 .AND. RECORD(J+1:J+1) .LE. '9') THEN
€		LAST = J + 2
ä	ELSE
H		LAST = J + 1
¬	ENDIF
C
tC CHECK PREECEDING CHARACTERS UNTIL NON-BLANK OR CONTINUATION COL
ØC
< 400	IF (IPOS .EQ. LAST) GO TO 500	!STARTS IN FIRST LEGAL COLUMN
 	IF (IPOS .LT. LAST) GO TO 600	!STARTS BEFORE CONTINUATION
	DO 450 J = IPOS-1,LAST,-1
h	IF (RECORD(J:J) .NE. ' ' .AND.
Ì	1	RECORD(J:J) .NE. '	') GO TO 460	!NON BLANK
0 450	CONTINUE
”	GO TO 500				!OK
ø 460	IF (.NOT. PFLAG) GO TO 600		!DONT CHK ")"
\ 	IF(RECORD(J:J) .NE. ')') GO TO 600	!NOT OK
À 500	PRECHK = .TRUE.
$	RETURN
ˆ 600	PRECHK = .FALSE.
ì	RETURN
P	END
´	SUBROUTINE PRINT(TWO,TOP,SIDE,XSIDE,NTOP,NSIDE,NR,NC,SLAB
	1		,IROW,ISIZE)
|	CHARACTER*(*)	TWO(1),TOP(1),SIDE(1),XSIDE(NR,NC)
à	CHARACTER	SLAB*(*)	,ISIZE*(*)
D	INTEGER 	CURLEN
¨	DIMENSION	IROW(NTOP)
C
p	KBLK = 5		!# PRINTS PER BLOCK
Ô	IOFF=1		!=1 NORMALLY, 10 LEAVES ROOM FOR PUNCH HOLES
8	MARGINR = 132		!DEFAULT RIGHT MARGIN
œ	IF (ISIZE .EQ. '80') MARGINR = 80
 	IF (ISIZE .EQ. 'REPORT') THEN
d		MARGINR = 85
È		IOFF = 10
,	ENDIF
	IBLK = KBLK*2 + 1	!# COLUMNS NEEDED PER PRINT BLOCK
ô	MARGINL = LEN(SIDE(1)) + 5 + IOFF
X	ML = MARGINL
¼	MR = MARGINR
 C
„	NCOLS	= MARGINR - MARGINL + 1		!N COLS/PRINT PAGE
è	MXTOPBLK = (NCOLS + 1)/IBLK		!MAX BLOCKS ACROSS TOP
L	MXTOP = MXTOPBLK * KBLK
°C
	MXLINES = 42		!MAXIMUM PRINT LINES/PAGR
x	MXSIDEBLK = (MXLINES + 1)/(KBLK + 1)
Ü	MXSIDE = MXSIDEBLK*KBLK
@C
¤	NTOPBLK = (NTOP-1)/KBLK + 1
 	NSIDEBLK = (NSIDE-1)/KBLK + 1
l 	NPGRT = (NTOPBLK - 1)/MXTOPBLK + 1
Ð 	NPGDN = (NSIDEBLK - 1)/MXSIDEBLK + 1
4!C
˜!	DO 1000 IPGRT = 1,NPGRT			!CYCLE THRU PAGE RIGHTS
ü!	DO 1000 IPGDN = 1,NPGDN			!CYCLE THRU PAGE DOWNS
`"		IIS = (IPGRT-1)*MXTOP + 1	!START COL
Ä"		IIE = IPGRT*MXTOP		!PAGE END COL
(#	IIL = NTOPBLK*KBLK			!PHYS END COL
Œ#	IIE = MIN0(IIE,IIL)
ð#		NBLKS = (IIE-IIS )/KBLK + 1	!# BLOCKS NEEDED
T$		ICOLS = NBLKS*IBLK
¸$	MXCH = 0
%	DO 200 I = IIS,MIN0(IIE,NTOP)
€% 200	MXCH = MAX0(MXCH,CURLEN(TOP(IROW(I))))
ä%	LENLAB = CURLEN(SLAB)
H&	WRITE(3,1001) SLAB(1:LENLAB),IPGDN,IPGRT,NPGDN,NPGRT
¬& 1001	FORMAT('1',T<MR-34-LENLAB>
'	1,'XREF OF ',A,' - PAGE (',I2,',',I2,') of (',I2,',',I2,')')
t'		WRITE(3,1005)' ROUTINE TYPE:',((TWO(IROW(II))(ICH:ICH),II=IIS
Ø'	1	,IIE),ICH=1,2)
<(		WRITE(3,1005)' ROUTINE NAME:',((TOP(IROW(II))(ICH:ICH),II=IIS
 (	1	,IIE),ICH=1,MXCH)
) 1005		FORMAT(<IOFF>X,A,10(T<MARGINL>,<NBLKS>(<KBLK>(1X,A1)
h)	1	,1X)/1X))
Ì)		IRS = (IPGDN-1)*MXSIDE + 1
0*		IRE = MIN0(NSIDE,(IPGDN)*MXSIDE)
”*		MXLAB = CURLEN(SLAB)
ø*		WRITE(3,1010) SLAB(1:MXLAB)
\+ 1010	FORMAT('+',<IOFF>X,A/<IOFF+1>X,<ML-5-IOFF>('-')/1X,T<ML-1>
À+	1		,<ICOLS+1>('.'))
$,	  do ii=iis,iie
ˆ,	    do il=irs,ire
ì,	      if( xside(il,ii).lt.' ' ) xside(il,ii) = ' '
P-	    enddo
´-	  enddo
.		WRITE(3,1015)(SIDE(IL),(XSIDE(IL,II),
|.	1			II=IIS,IIE),IL=IRS,IRE)
à. 1015		FORMAT(<MXSIDEBLK>(<KBLK>(<IOFF+1>X,A,T<MARGINL-1>,'.'
D/	1		,<NBLKS>(<KBLK>(1X,A1),'.'),:/)
¨/	2		1X,T<MARGINL-1>,<ICOLS+1>('.')/))
0		WRITE(3,1019)
p0 1019		FORMAT(1X,T<MARGINL-1>,<ICOLS+1>('.'))
Ô0 1020		CONTINUE
81 1000		CONTINUE
œ1	RETURN
 2	END
ÿÿ
d 	SUBROUTINE SORT2D(XARRAY,ROW,COL,NR,NC,MR
È 	1			,ICOL,IROW,CFLAG,RFLAG)
,C
C THE FOLLOWING PARAMETERS ARE USED TO SIZE LOCAL ARRAYS SIMILAR TO
ôC THOSE IN THE CALLING PROGRAM. IF THE CALLING PROG'S ARRAYS ARE LARGER
XC THAN THOSE SHOWN HERE, AN ERROR RESULTS, AND THE USER MUST RECOMPILE
¼C THIS SUBROUTINE WITH LARGER PARAMETERS.
 c.
„c. I think that these must be bigger than any of the MX... in CROSS
èc.
LC
°	PARAMETER	 MROW = 500	!MAX ROW DIMENSION OF XARRAY
	1		,MCOL = 500	!MAX COL  "	"	"
x	2		,NXCH = 1	!# CHARACTERS IN XARRAY 
Ü	3		,NCH  = 30	!# CHARS IN 1-D ARRAYS
@C
¤C
	CHARACTER*(*)	XARRAY(MR,1),COL(NC),ROW(NR)
l	CHARACTER*(NCH)	TEMP,TROW(MCOL)		!(NCH) FOR DEFAULT
Ð	CHARACTER*(NXCH)	XTEMP(MROW,MCOL)	!TEMP X ARRAY
4	LOGICAL		CFLAG,RFLAG		!COL,ROW CONTROL FLAG
˜	DIMENSION	ICOL(NC), IROW(NR)
üC
`		IF(NC .GT. MCOL) GO TO 1010
Ä		IF(MR .GT. MROW) GO TO 1020
(
	IF(NCH .LT. LEN(COL(1))) GO TO 1030
Œ
	IF(NCH .LT. LEN(ROW(1))) GOT O 1030
ð
	IF(NXCH.GT. LEN(XARRAY(1,1))) GO TO 1040
TC
¸C
	DO 10 I = 1,NC
€ 10	ICOL(I) = I
ä	DO 20 I = 1,NR
H 20	IROW(I) = I
¬C
C ARRANGE ACCORDING TO THE COL ARRAY. SAVE ORDER IN ICOL FOR LATER USE.
tC
Ø	IF (NC .GT. 1) THEN
<	DO 100 I = 1,NC-1
 	DO 100 I1 = I+1,NC
	  IF(COL(ICOL(I)) .LE. COL(ICOL(I1))) GO TO 100
h		ITEMP = ICOL(I)
Ì		ICOL(I) = ICOL(I1)
0		ICOL(I1) = ITEMP
” 100	CONTINUE
ø	ENDIF
\C
ÀC ARRANGE ACCORDING TO THE ROW ARRAY, SAVE ORDER IN IROW FOR LATER USE.
$C
ˆ	IF (NR .GT. 1) THEN
ì	DO 200 I = 1,NR-1
P	DO 200 I1 = I,NR
´	  IF(ROW(IROW(I)) .LE. ROW(IROW(I1))) GO TO 200
		ITEMP = IROW(I)
|		IROW(I) = IROW(I1)
à		IROW(I1) = ITEMP
D 200	CONTINUE
¨	ENDIF
C
pC NOW ARANGE THE 2-D ARRAY ACCORDINGE TO ORDER SAVED IN ICOL AND IROW
ÔC
8	DO 300 IR = 1,NC	!NC ACTUALLY # ROWS
œ	DO 300 IC = 1,NR	!NR ACTUALLY # COLS
  300	XTEMP(IR,IC) = XARRAY(ICOL(IR),IROW(IC))
dC
È	DO 400 IR = 1,NC	!NC ACTUALLY # ROWS
,	DO 400 IC = 1,NR	!NR ACTUALLY # COLS
 400	XARRAY(IR,IC) = XTEMP(IR,IC)	!PUT BACK IN USERS ARRAY.
ô	IF(RFLAG) THEN
X	 DO 500 I = 1,NR
¼ 500	TROW(I) = ROW(IROW(I))
 	DO 550 I = 1,NR
„ 550	ROW(I) = TROW(I)
è	ENDIF
L	IF(CFLAG) THEN
°	 DO 600 I = 1,NC
 600	TROW(I) = COL(ICOL(I))
x	DO 650 I = 1,NC
Ü 650	COL(I) = TROW(I)
@	ENDIF
¤C ALL DONE
 C
l 	RETURN
Ð C
4!C ERROR EXITS
˜!C
ü! 1010	WRITE(5,1015) NC,MCOL
`" 1015	FORMAT(' PASSED VALUE NC=',I3,' .GT. MAXIMUM, ',I3/
Ä"	1' ** YOU MUST INCREASE PARAMETER "MCOL" IN PRINT SUBROUTINE')
(#	GO TO 1099
Œ# 1020	WRITE(5,1025) MR,MROW
ð# 1025	FORMAT(' PASSED VALUE MR=',I3,' .GT. MAXIMUM, ',I3/
T$	1' ** YOU MUXT INCREASE PARAMETER "MROW" IN PRINT SUBROUTINE')
¸$	GO TO 1099
% 1030	WRITE(5,1035) LEN(COL(1)),NCH
€% 1035	FORMAT(' LEN OF 1-D ARRAYS=',I3,' .GT. MAXIMUM, ',I3/
ä%	1' *** YOU MUST INCREASE PARAMETER "NCH" IN PRINT SUBROUTINE')
H&	GO TO 1099
¬& 1040	WRITE(5,1045) LEN(XARRAY(1,1)),NXCH
' 1045	FORMAT(' LEN OF 2-D ARRAYS=',I3,' .GT. MAXIMUM, ',I3/
t'	1' *** YOU MUST INCREASE PARAMETER "NXCH" IN PRINT SUBROUTINE')
Ø' 1099	CALL EXIT
<(	END
ÿÿ
d 	SUBROUTINE TRACE(PROGS,SUBS,XSUBS,NPROGS,NSUBS,MXSUBS,ITYP
È 	1		,TR,NTR,LAST,com,ish)
,	PARAMETER	MXSTACK=100	!MAXIMUM STACK LENGTH
	DIMENSION 	ISSTACK(MXSTACK), IPSTACK(MXSTACK)
ô	CHARACTER*(*)	PROGS(NPROGS),SUBS(NSUBS),XSUBS(MXSUBS,NPROGS)
X	CHARACTER*(*)	ITYP(NPROGS)
¼	CHARACTER	PLINE*132	!PRINT BUFFER
 	DIMENSION	LAST(NPROGS)	!LAST ROW IN SUBS USED BY PROGS
„	CHARACTER*(*)	TR(1)		!TRACE OPTIONS
è	CHARACTER	TNAME*10	!TRACE ROUTINE NAME
L	integer numlin(500)		!!Number of subroutines
°	LOGICAL IPOP,com,ish
C
xC FIND LOOP PARAMETERS DEPENDING UPON TRACE OPTION
ÜC
@	IF (NTR .LT. 0) RETURN		!NO TRACE WANTED
¤C
	N1=0
l	NR=0
Ð	IPASS = 0			!PASS COUNTER
4 5	IPASS = IPASS + 1		!INCR
˜	IF (IPASS .GT. NTR.AND. NTR.NE. 0) RETURN	!SKIP IF GREATER THAN NEEDED
ü	TNAME = TR(IPASS)(2: )
`		IF (NTR .EQ. 99 .OR. NTR .EQ. 0) THEN
Ä			N1 = 1
(
		NR = NPROGS
Œ
	ELSE IF (NTR .GE. 1 .AND. NTR .LE. 10) THEN
ð
			DO 111 I = 1,NPROGS
T 			IF(PROGS(I) .NE. TNAME) GO TO 111
¸			N1 = I
			NR = I
€			GO TO 130
ä 111			CONTINUE
H			GO TO 130
¬ 	ENDIF
 130	IF (N1 .EQ. 0) THEN
t		WRITE(3,133) TNAME
Ø 133		FORMAT(1X,A,' NOT FOUND IN INPUT ROUTINES')
<		RETURN
 	ENDIF
C
hC START LOOP
ÌC
0	DO 199 I=N1,NR
”C
øC INITIALIZE VARIABLES
\C
À	ISSP	= 1		!NEXT LOCATION IN SUB STACK
$	IPSP	= 1		!NEXT LOCATION IN PROG STACK
ˆ	LEVEL 	= 1		!PRINT LEVEL
ì	ISUB	= 1		!START SEARCH LOC IN SUBS
P	NP = I
´	IF (NTR .EQ. 0 .AND. ITYP(I) .NE. 'PR') GO TO 199
	if( ish ) then
|	  write( 3,1915 ) progs(np)
à1915	  format(/'1',12x,a,$)
D	else
¨	  WRITE(3,15) PROGS(NP)	  !WRITE THE INITIAL PROGRAM
 15	  FORMAT(/'1',6x,A,$)
p	endif
Ô 10	CONTINUE
8	DO 100 NS = ISUB,NSUBS	!LOOP FROM ISUB TO END OF SUBS
œ	IF (XSUBS(NS,NP) .gt. ' ') THEN		!FOUND A SUB CALLED
 		if( ls.ne.0 ) then
d		  if( numlin(ls).lt.0 ) numlin(ls) = -numlin(ls)
È		endif
,		CALL IPUSH(ISSTACK,NS+1,ISSP)	!SAVE NEXT ISUB
		CALL IPUSH(IPSTACK,NP,IPSP)	!SAVE CURRENT IPROG
ô		IF (NS .LT. LAST(NP)) THEN
X		PLINE((LEVEL-1)*7+1:LEVEL*7) = '      :'
¼		ELSE
 		PLINE((LEVEL-1)*7+1:LEVEL*7) = '       '
„		ENDIF
è		LEVEL = LEVEL + 1
L	if( ish ) then			!!TRIM tree
°	  if( level.eq. levlast-1 ) then
	    write(3,1925) pline(1:((level-1)*7)-1)
x1925	    format(' ',5x,' ',a,':' )
Ü	  endif
@	  levlast = level
¤	  nline = nline+1
 	  if( numlin(ns).gt.0 ) then
l 	    write(3,1932) nline, pline(1:((level-1)*7)-1)
Ð 	1	,numlin(ns)
4!	1	,subs(ns)
˜!1932	    format('$',i5,' ',a,':-',i3,'- ',a)
ü!	  else
Ä"	    write(3,1933) nline, pline(1:((level-1)*7)-1),subs(ns)
(#1933	    format('$',i5,' ',a,':----- ',a,i5)
Œ#	  endif
ð#	else if (com) then
T$		write(3,33)  pline(1:((level-1)*7)-1) ,subs(ns)
¸$ 33		format('$',a,':----- ',a )
%	else !!Not Compressed plot
€%		WRITE(3,25) PLINE(1:((LEVEL-1)*7)-1)
ä%	1	,PLINE(1:((LEVEL-1)*7)-1) , SUBS(NS)
H& 25	FORMAT(1X,A,':'/'$',A,':----- ',A)
¬&	endif
'		ISUB = 1			!RESET STARTING POINT
t'		if( ish ) then
Ø'			if( numlin(ns).gt. 0 ) then
<(				goto 150
 (			else if( numlin(ns).eq.0 ) then
)				numlin(ns) = -nline
h)			endif
Ì)			ls = ns
0*		endif
”*		DO 50 NP = 1,NPROGS		!SEARCH PROGS FOR SUB
ø* 50		IF(PROGS(NP) .EQ. SUBS(NS))GOTO 10!IF FOUND, ITS NEXT
\+C
À+C NOT FOUND IN INPUT LIST. PTINE A '?'
$,C
ˆ,	WRITE(3,55)
ì, 55	FORMAT('+ ?')
P-		GO TO 150			!IF NOT, BACK UP
´-	ENDIF
. 100	CONTINUE
|. 150	IF(.NOT. IPOP(ISSTACK,ISUB,ISSP)) CONTINUE !DONT WORRY
à.	IF(.NOT. IPOP(IPSTACK,NP,IPSP)) GOTO 199	!WORRY
D/	LEVEL = LEVEL - 1
¨/	ls = 0
0	GO TO 10				!START OVER WON PREV NP  
p0 199	CONTINUE
Ô0C
81	IF (N1 .EQ. NR .AND. NPROGS .NE. 1) GO TO 5
œ1C
 2 	RETURN
d2	END