	PROGRAM COMFILES
C***************************************************************************
C***
C***	This program prompts for a command file name, and prints out a
C***	calling tree of the command files called within it. In the calling
C***	tree listing, you are given the options to print out the original
C***	DCL calling line, just the specified filename, the actual physical
C***	filename (if it exists), and the number of lines counted in each
C***	command file opened.
C***
C***	The program listing will tell you if a command file could not be
C***	opened due to the file not existing, or denied privleges. This 
C***	program is limited to 16 levels of command procedure nesting.
C***
C***	If a call to a command procedure is commented out, it will not
C***	be processed.
C***
C***	The resulting tree is listed out to SYS$OUTPUT
C***
C***	Autor :	Jeff Cameron
C***		jcam90502@jcameron.com
C***		http://www.jcameron.com/vms/
C***
C***	Modification history :
C***
C***	Programmer	Date		Description
C*** ----------------------------------------------------------------------
C***	Jeff Cameron	25-JAN-1987	Initially written
C*** ----------------------------------------------------------------------
C***
C***************************************************************************
	INTEGER*4 TYO /6/, TYI /5/, RPT /7/
	INTEGER*4 COM (16), LC (16), LINE_COUNT (16)
	CHARACTER*255 CFILES (16)
	CHARACTER*255 COMLINE,FILENAME
	CHARACTER*132 BLANKS 
	CHARACTER*1 TAB, RESP
	INTEGER*4 LEVEL
	LOGICAL*1 FILE_OPEN (16)
	LOGICAL*1 LDCL, LFIL, LPHY, LLIN
C
C***	INITIALIZE 
	TAB = CHAR (9)
C
	DO I = 1,16
	    COM (I) = I + 20
	    FILE_OPEN (I) = .FALSE.
	END DO
C
	BLANKS = '   .   .   .   .   .   .   .   . ' //
	1	 '  .   .   .   .   .   .   .   .  ' //
	2	 ' .   .   .   .   .   .   .   .   ' //
	3	 '.   .   .   .   .   .   .   .    '
C
C***	OPEN BASIC LOGICAL UNITS
	OPEN (TYI,FILE='SYS$INPUT',TYPE='NEW',IOSTAT=ISTAT)
	IF (ISTAT .NE. 0) THEN
	    CALL RT_ERROR (0,ISTAT)
	    STOP '%COMFILES-F-FAILOPENIN, failed to open SYS$INPUT.'
	ELSE
	ENDIF
C
	OPEN (TYO,FILE='SYS$COMMAND',TYPE='NEW',IOSTAT=ISTAT)
	IF (ISTAT .NE. 0) THEN
	    CALL RT_ERROR (0,ISTAT)
	    STOP '%COMFILES-F-FAILOPENCOM, failed to open SYS$COMMAND.'
	ELSE
	ENDIF
C
	OPEN (RPT,FILE='SYS$OUTPUT',TYPE='NEW',IOSTAT=ISTAT)
	IF (ISTAT .NE. 0) THEN
	    CALL RT_ERROR (0,ISTAT)
	    STOP '%COMFILES-F-FAILOPENOUT, failed to open SYS$OUTPUT.'
	ELSE
	ENDIF
C
C***	GET THE NAME OF A COMMAND FILE TO READ
 10	LEVEL = 0
C
	WRITE (TYO,11)
 11	FORMAT (' _Command file:',$)
	READ (TYI,12,END=1000) CFILES (1)
 12	FORMAT (A)
C
	CALL UPCASE (CFILES(1))
	WRITE (TYO,1)
 1	FORMAT (' List original DCL command line?    (Y or N):',$)
	READ (TYI,12,END=1000) RESP
	CALL UPCASE (RESP)
	LDCL = (RESP .EQ. 'Y')
C
	WRITE (TYO,2)
 2	FORMAT (' List original specified file name? (Y or N):',$)
	READ (TYI,12,END=1000) RESP
	CALL UPCASE (RESP)
	LFIL = (RESP .EQ. 'Y')
C
	WRITE (TYO,3)
 3	FORMAT (' List actual physical file name?    (Y or N):',$)
	READ (TYI,12,END=1000) RESP
	CALL UPCASE (RESP)
	LPHY = (RESP .EQ. 'Y')
C
	WRITE (TYO,4)
 4	FORMAT (' List command file line count?      (Y or N):',$)
	READ (TYI,12,END=1000) RESP
	CALL UPCASE (RESP)
	LLIN = (RESP .EQ. 'Y')
C
C***	OPEN THE FILE AT THE NEXT LEVEL
 20	LEVEL = LEVEL + 1
	LC (LEVEL) = LENGTH (CFILES(LEVEL))
	OPEN (COM(LEVEL),FILE=CFILES(LEVEL)(:LC(LEVEL)),
	1	TYPE='OLD',READONLY,IOSTAT=ISTAT)
C
	INDENT = LEVEL * 4
C
	IF (ISTAT .EQ. 0) THEN
	    INQUIRE (UNIT=COM(LEVEL),NAME=FILENAME)
	    LFN = LENGTH (FILENAME)
	    IF (LFIL) WRITE (RPT,21) LEVEL,BLANKS(:INDENT),CFILES(LEVEL)(:LC(LEVEL))
	    IF (LPHY) WRITE (RPT,21) LEVEL,BLANKS(:INDENT),FILENAME(:LFN)
 21	    FORMAT (' ',I2,':',A,'@',A,' opened.')
C
	    FILE_OPEN (LEVEL) = .TRUE.
	    LINE_COUNT (LEVEL) = 0
	ELSE
	    IF (LFIL .OR. LPHY) WRITE (RPT,22) LEVEL,BLANKS(:INDENT),CFILES(LEVEL)(:LC(LEVEL))
 22	    FORMAT (' ',I2,':',A,'@',A,' not opened.')
C
	    LEVEL = LEVEL - 1
	ENDIF
C
C***	Read a record from the current file.
 30	READ (COM(LEVEL),12,END=40) COMLINE
	LINE_COUNT (LEVEL) = LINE_COUNT (LEVEL) + 1
	LL = LENGTH (COMLINE)
C
	IF (LL .LE. 0) GO TO 30		! Next line if no characters.
C
	IF (COMLINE(1:1) .NE. '$') GO TO 30	! Next line if not DCL line.
C
	IDX = INDEX (COMLINE,'@')
	IF (IDX .EQ. 0) GO TO 30	! Next line if No Command file activate
C
	LDX = INDEX (COMLINE,'!')	! Next line if commented out
	IF ((LDX .GT. 0) .AND. (LDX .LT. IDX)) GO TO 30
C
	I = IDX + 1
	DO WHILE ((I .LE. LL) .AND. 
	1	 ((COMLINE(I:I) .EQ. ' ') .OR.
	2	 (COMLINE(I:I) .EQ. TAB)))
	    I = I + 1
	END DO
C
	IST = I
	DO WHILE ((I .LE. LL) .AND. 
	1	   (COMLINE(I:I) .NE. ' ') .AND. 
	1	   (COMLINE(I:I) .NE. '/') .AND. 
	1	   (COMLINE(I:I) .NE. '"') .AND. 
	1	   (COMLINE(I:I) .NE. '''') .AND. 
	2	   (COMLINE(I:I) .NE. TAB) .AND. 
	3	   (COMLINE(I:I) .NE. '!'))
	    I = I + 1
	END DO
C
	IEND = I - 1
	CFILES (LEVEL+1) = COMLINE (IST:IEND)
C
	INDENT = LEVEL * 4
	IF (LDCL) WRITE (RPT,39) LEVEL,BLANKS(:INDENT),COMLINE(:LL)
 39	FORMAT (' ',I2,':',A,'|',A)
C
	GO TO 20
C
C***	EOF
 40	CLOSE (COM(LEVEL))
	FILE_OPEN (LEVEL) = .FALSE.
C
	INDENT = LEVEL * 4
	IF (LLIN) WRITE (RPT,41) LEVEL,BLANKS (:INDENT),LINE_COUNT(LEVEL)
 41	FORMAT (' ',I2,':',A,'|[EOF]',I<ISIZ(LINE_COUNT(LEVEL))>,' lines.',/)
C
	LEVEL = LEVEL - 1
	IF (LEVEL .GT. 0) GO TO 30
C
	WRITE (RPT,42)
 42	FORMAT (' [EOF]',//)
	GO TO 10
C
C***	ALL DONE
 1000	CALL EXIT
	END
	INTEGER*4 FUNCTION LENGTH (STRING) !	SUBROUTINE LENGTH
	CHARACTER *(*) STRING
C************************************************************************
C***
C***	THIS FUNCTION DIFFERS FROM THE STANDARD LEN FUNCTION ONLY
C***	IN THAT IT RETURNS THE POSITION OF THE LAST NON-BLANK CHARACTER
C***	IN THE STRING, RATHER THAN THE CAPACITY OF THE STRING.
C***
C************************************************************************
C*MCT
C
C***	FIRST DETERMINE THE ACTUAL SIZE OF THE STRING VARIABLE
	I = LEN (STRING)
C
10      IF (STRING (I:I) .NE. ' ' .AND.
	1   ICHAR (STRING(I:I)) .GT. 32) THEN
	   LENGTH = I
	   RETURN
	ELSE
	   I = I - 1
	ENDIF
	IF (I .LE. 0) THEN
	   LENGTH = 0
	   RETURN
	ELSE
	ENDIF
	GO TO 10
	END
	SUBROUTINE UPCASE (STRING)
	IMPLICIT NONE
	CHARACTER*(*)	STRING
C************************************************************************
C***
C***	THIS ROUTINE WILL CONVERT ALL LOWERCASE CHARACTERS IN A STRING
C***	TO UPPERCASE
C***
C***	PARAMETER :
C***
C***		STRING	(C*?)	CHARACTER STRING TO BE CONVERTED
C***
C************************************************************************
C*VIS
C
	CALL STR$UPCASE (STRING,STRING)
C
	RETURN
	END
	INTEGER*4 FUNCTION ISIZ (INTEGER_VALUE) !	SUBROUTINE ISIZ
	IMPLICIT NONE
	INTEGER*4	INTEGER_VALUE
C************************************************************************
C***
C***	THIS FUNCTION RETURS THE FIELD WIDTH OF THE INTEGER VALUE PASSED
C***	SO THAT IT CAN BE USED IN THE FORMAT STATEMENTS TO SPECIFY THE
C***	ACTUAL WIDTH OF THE VALUE.
C***
C***	PARAMETER :
C***
C***		INTEGER_VALUE	(I*4)	INTEGER VALUE OF WHICH THE SIZE
C***					 IS TO BE DETERMINED.
C***
C************************************************************************
C*VIS
	REAL*4		VALUE,LOGVAL
C
C***	Use log
	IF (INTEGER_VALUE .EQ. 0) THEN
	    ISIZ = 1
	ELSE
	    VALUE = ABS (FLOAT (INTEGER_VALUE))
	    LOGVAL = LOG10 (VALUE)
	    IF (INTEGER_VALUE .LT. 0) THEN
		ISIZ = LOGVAL + 2.0	! Add room for negative sign
	    ELSE
		ISIZ = LOGVAL + 1.0
	    ENDIF
	ENDIF
	RETURN
	END
	SUBROUTINE RT_ERROR (OUT,ERROR)
	INTEGER*4 OUT		! LOGICAL UNIT TO REPORT TO
	INTEGER*4 ERROR		! FORTRAN RUNTIME ERROR NUMBER
C************************************************************************
C***
C***	THIS ROUTINE WILL REPORT THE RUN-TIME ERROR TO THE LOGICAL UNIT
C***	SPECIFIED.
C***    TWO ERROR TYPES ARE SUPPORTED, 1-68 = SYSTEM: 100-126 = NRTC
C***
C************************************************************************
C*MCT
C
	CHARACTER*40 MESS
	CHARACTER*40 MESSAGE (68), DSK_TAPE (27)
C
	DATA	MESSAGE	/'Not a FORTRAN specific error            ', !  1
	1		 ' * Undefined *                          ', !  2
	1		 ' * Undefined *                          ', !  3
	1		 ' * Undefined *                          ', !  4
	1		 ' * Undefined *                          ', !  5
	1		 ' * Undefined *                          ', !  6
	1		 ' * Undefined *                          ', !  7
	1		 ' * Undefined *                          ', !  8
	1		 ' * Undefined *                          ', !  9
	1		 ' * Undefined *                          ', ! 10
	1		 ' * Undefined *                          ', ! 11
	1		 ' * Undefined *                          ', ! 12
	1		 ' * Undefined *                          ', ! 13
	1		 ' * Undefined *                          ', ! 14
	1		 ' * Undefined *                          ', ! 15
	1		 ' * Undefined *                          ', ! 16
	1		 'Syntax error in NAMELIST input          ', ! 17
	1		 'Too many values for NAMELIST variable   ', ! 18
	1		 'Inv. ref. to variable in NAMELIST input ', ! 19
	1		 'REWIND error                            ', ! 20
	1		 'Duplicate file specifications           ', ! 21
	1		 'Input record too long                   ', ! 22
	1		 'BACKSPACE error                         ', ! 23
	1		 'End-Of-File during read                 ', ! 24
	1		 'Record number outside of range          ', ! 25
	1		 'OPEN or DEFINE FILE required            ', ! 26
	1		 'Too many records in I/O statement       ', ! 27
	1		 'CLOSE error                             ', ! 28
	1		 'File not found                          ', ! 29
	1		 'Open failure                            ', ! 30
	1		 'Mixed file access modes                 ', ! 31
	1		 'Invalid Logical Unit Number             ', ! 32
	1		 'ENDFILE error                           ', ! 33
	1		 'Unit already open                       ', ! 34 
	1		 'Segmented record format error           ', ! 35
	1		 'Attempt to access non-existent record   ', ! 36
	1		 'Inconsistent record number              ', ! 37
	1		 'Error during write operation            ', ! 38
	1		 'Error during read operation             ', ! 39 
	1		 'Recursive I/O operation                 ', ! 40
	1		 'Insufficient virtual memory             ', ! 41
	1		 'No such device                          ', ! 42
	1		 'File name specification error           ', ! 43
	1		 'Inconsistent record type                ', ! 44
	1		 'Keyword value error in OPEN statement   ', ! 45
	1		 'Inconsistent OPEN/CLOSE parameters      ', ! 46
	1		 'Write to READONLY file                  ', ! 47
	1		 'Invalid argument to Runtime lib routine ', ! 48
	1		 'Invalid key specification               ', ! 49
	1		 'Inconsistent key change or duplication  ', ! 50
	1		 'Inconsistent file organization          ', ! 51
	1		 'Specified record locked                 ', ! 52
	1		 'No current record                       ', ! 53
	1		 'REWRITE error                           ', ! 54
	1		 'DELETE error                            ', ! 55
	1		 'UNLOCK error                            ', ! 56
	1		 'FIND error                              ', ! 57
	1		 ' * Undefined *                          ', ! 58
	1		 'List directed I/O syntax error          ', ! 59
	1		 'Infinite format loop                    ', ! 60
	1		 'Format/variable-type mismatch           ', ! 61
	1		 'Syntax error in format                  ', ! 62
	1		 'Output conversion error                 ', ! 63
	1		 'Input conversion error                  ', ! 64
	1		 ' * Undefined *                          ', ! 65
	1		 'Output statement overflows record       ', ! 66
	1		 'Input statement requires too much data  ', ! 67
	1		 'Variable format expression value error  '/ ! 68
C
	DATA   DSK_TAPE /'DSK_OPEN: LUN less than 1               ', ! 100
	1		 'DSK_OPEN: LUN greater than 40		  ', ! 101
	1		 'DSK_OPEN: LUN previously opened by DSK  ', ! 102
	1		 'DSK_OPEN: Record Size too Small	  ', ! 103
	1		 'DSK_OPEN: Record Size Exceedes 8192	  ', ! 104
	1		 'DSK_OPEN: File previosly OPENED by Sys. ', ! 105
	1		 'DSK_OPEN: Accessing Formatted File	  ', ! 106
	1		 'DSK_LINK: LUN Less than 1		  ', ! 107
	1		 'DSK_LINK: LUN Greater than 40		  ', ! 108
	1		 'DSK_LINK: LUN Previously Opened by DSK  ', ! 109
	1		 'DSK_LINK: Record Size too small	  ', ! 110
	1		 'DSK_LINK: Record Size Exceedes 8192	  ', ! 111
	1		 'DSK_LINK: Access is UNKNOWN File no OPEN', ! 112
	1		 'DSK_LINK: File not Opened UNFORMATTED	  ', ! 113
	1		 'DSK_LINK: File not Created SEQUENTIAL	  ', ! 114
	1		 'DSK_LINK: File Access not Opened DIRECT ', ! 115
	1		 'DSK_LINK: FILENAME =not LUN Filename    ', ! 116
	1		 'DSK_LINK: REC_SIZE =not File Record Size', ! 117
	1		 'DSK_CLOSE: LUN  not Opened by DSK_SUBS  ', ! 118
	1		 'DSK_I/O: Inconsistant Record Length	  ', ! 119
	1		 'DSK_OPEN: *** not defined	***	  ', ! 120
	1                'ADSK_: File NOT Accessed - Record Size 0', ! 121
	1                'ADSK_: No Available DSK_ Luns           ', ! 122
	1                'ADSK_: Mis-Match of File-Array-Crop Size', ! 123
	1		 'ADSK_: File NOT Opened Successfully     ', ! 124
	1		 'ADSK_: I/O ERROR - Transfer Terminated  ', ! 125
	1		 'ADSK_: DSK_CLOSE Error Return           '/ ! 126
C
	LOGICAL MESS_ONLY
C
C **********************************************************************
C 
C **    PROCESS THE CALL
C
C **********************************************************************
C
	MESS_ONLY = .FALSE.
	GO TO 10
C
	ENTRY RT_MESSAGE (MESS,ERROR)
	MESS_ONLY = .TRUE.
	GO TO 10
C	
 10	IF (ERROR .EQ. 0) THEN
	   IF (MESS_ONLY) MESS = ' '
	   RETURN
	ELSE IF ( ERROR .GE. 100 .AND. ERROR .LT. 127 ) THEN
	   ERRP = ERROR - 99
	   IF (MESS_ONLY) THEN
		MESS = DSK_TAPE(ERRP)
	   ELSE
           	IF ( OUT .EQ. 0 ) THEN 
              	    TYPE 13,ERROR,DSK_TAPE(ERRP)
           	ELSE
	      	    WRITE (OUT,13) ERROR,DSK_TAPE(ERRP)
	   	ENDIF
 13	   FORMAT (' %%% DISK_SUBS or TAPE_SUBS Run-Time Error Number ',
     1     I5,'. %%%',/,
     2     1X,'(',A40,')' )
	   ENDIF
	ELSE IF (ERROR .LT. 0 .OR. ERROR .GT. 68) THEN
	   IF (MESS_ONLY) THEN
	       ENCODE (40,11,MESS) ERROR
	   ELSE
	       IF ( OUT .EQ. 0 ) THEN
	          TYPE 11,ERROR
	       ELSE
	          WRITE (OUT,11) ERROR
	       ENDIF
 11	       FORMAT (' %FORTRAN Run-Time error : ',I5,'.')
	   ENDIF
	ELSE
	   IF (MESS_ONLY) THEN
		MESS = MESSAGE (ERROR)
	   ELSE
	        IF ( OUT .EQ. 0 ) THEN
	            TYPE 12,ERROR, MESSAGE(ERROR)
	        ELSE
	            WRITE (OUT,12) ERROR, MESSAGE (ERROR)
	        ENDIF
	   ENDIF
 12	   FORMAT (' %%% FORTRAN Run-Time error number : ',I5,'. %%%',/,
	1          1X,'(',A40,')')
	ENDIF
C
	RETURN
	END
