	OPTIONS /EXTEND_SOURCE
	PROGRAM mcl
C
C	Multi Column Lister: Version 3.0
C
	IMPLICIT    INTEGER*4 (A-Z)
C
	PARAMETER   (maximum_file_name_length  = 255)
	PARAMETER   (maximum_io_line_length    = 132)
	PARAMETER   (maximum_lines_per_page    =  88)
	PARAMETER   (minimum_page_width        =  60)
	PARAMETER   (maximum_page_width        = 132)
	PARAMETER   (maximum_number_of_columns =   9)
	PARAMETER   (maximum_number_of_lines_to_read =
	1		maximum_lines_per_page * maximum_number_of_columns)
C
	INTEGER*4   longest_line(maximum_number_of_columns)
C
	LOGICAL	    column_is_full,
	1	    ftab_expand,
	1	    wrap,
	1	    fort_cc,
	1	    header_flag,
	1	    footer_flag,
	1	    pause_flag
C
	CHARACTER	sep_char /'|'/
	CHARACTER	dummy
	CHARACTER*10	scratch
	CHARACTER*23	date_time
	CHARACTER*(maximum_file_name_length)	source_file
	CHARACTER*(maximum_file_name_length)	input_file_name
	CHARACTER*(maximum_file_name_length)	output_file_name
	CHARACTER*(maximum_page_width)		header_line
	CHARACTER*(maximum_page_width)		footer_line
	CHARACTER*(maximum_io_line_length)	new_line
	CHARACTER*(maximum_io_line_length)	next_line
	CHARACTER*(maximum_io_line_length)	blanks
C
	STRUCTURE   /line/
	    INTEGER*4	    line_length
	    CHARACTER*132   input_line
	END STRUCTURE
C
	RECORD	    /line/  lines(maximum_number_of_lines_to_read)
C
	DATA	    case_flag		/0/,
	1	    form_feed_flag	/0/,
	1	    right_shift		/0/,
	1	    use_through_column	/0/
C
C	Format statements
C
10	FORMAT (/x, a<footer_line_length>)
20	FORMAT (a1)
30	FORMAT (/'$%MCL-I-PAUSING, Press RETURN to continue ')
C
C
C	Begin
C
	CALL lib$date_time (date_time)
	date_time(5:5) = CHAR (ICHAR (date_time(5:5)) + 32)
	date_time(6:6) = CHAR (ICHAR (date_time(6:6)) + 32)
C
C	Examine command line for source file name.
C
	CALL cli$get_value ('P1', source_file)
	i = INDEX (source_file, ' ') - 1
	OPEN (UNIT=1, FILE=source_file(1:i), STATUS='OLD', READONLY,
	1	ERR=200)
	INQUIRE (UNIT=1, NAME=input_file_name, CARRIAGECONTROL=scratch)
	CALL str$trim (input_file_name, input_file_name, input_file_name_length)
	fort_cc = scratch(1:7) .EQ. 'FORTRAN'
C
C	Process command qualifiers
C
	IF (cli$present ('COLUMNS')) THEN
	    CALL cli$get_value ('COLUMNS', scratch)
	    CALL str$trim (scratch, scratch, ll)
	    READ (scratch, '(i<ll>)') number_of_columns_requested
	    IF (number_of_columns_requested .GT. maximum_number_of_columns) THEN
		WRITE (6,'(xa,i2)')
	1	    '%MCL-F-TOOMANYCOLUMNS, Number of columns is limited to',
	1	    maximum_number_of_columns
		CALL EXIT
	    ELSE IF (number_of_columns_requested .LT. 1) THEN
		WRITE (6,*) '%MCL-F-TOOFEWCOLUMNS, ' //
	1	    'Must output at least 1 column'
		CALL EXIT
	    END IF
	ELSE
	    number_of_columns_requested = 2
	END IF
C
	ftab_expand = cli$present ('FTAB_EXPAND')
C
	IF (cli$present('OUTPUT')) THEN
	    CALL cli$get_value ('OUTPUT', output_file_name)
	    CALL str$trim (output_file_name, output_file_name,
	1	output_file_name_length)
	ELSE
	    output_file_name = ' '
	    output_file_name_length = 0
	END IF
C
	IF (cli$present ('WIDTH')) THEN
	    CALL cli$get_value ('WIDTH', scratch)
	    CALL str$trim (scratch, scratch, ll)
	    READ (scratch, '(i<ll>)') page_width
	    IF (page_width .GT. maximum_page_width) THEN
		WRITE (6,*) '%MCL-F-PAGTOOWIDE, ' //
	1	    'Page width greater than permitted'
		CALL EXIT
	    ELSE IF (page_width .LT. minimum_page_width) THEN
		WRITE (6,*) '%MCL-F-PAGTOONARROW, Page width is too narrow'
		CALL EXIT
	    END IF
	ELSE
	    page_width = maximum_page_width
	END IF
C
	IF (cli$present ('RIGHT')) THEN
	    CALL cli$get_value ('RIGHT', scratch)
	    CALL str$trim (scratch, scratch, ll)
	    READ (scratch, '(i<ll>)') right_shift
	    IF (right_shift .LT. 0) THEN
		WRITE (6,*) '%MCL-F-NEGRIGHT, Negative right shift not allowed'
		CALL EXIT
	    END IF
	END IF
C
	column_width =
	1   (page_width - right_shift - 3 * (number_of_columns_requested - 1)) /
	1   number_of_columns_requested
	IF (column_width .LT. 5) THEN
	    WRITE (6,*)
	1	'%MCL-F-COLTOONARROW, calculated column width is too narrow'
	    CALL EXIT
	END IF
	maximum_line_length = column_width
C
	wrap = cli$present ('WRAP')
	pause_flag = cli$present ('PAUSE')
	IF (cli$present ('LOWER_CASE')) THEN
	    case_flag = -1
	ELSE IF (cli$present ('UPPER_CASE')) THEN
	    case_flag = +1
	END IF
C
	IF (cli$present ('SEPARATOR')) THEN
	    CALL cli$get_value ('SEPARATOR', sep_char)
	END IF
C
	IF (cli$present ('FF')) THEN
	    CALL cli$get_value ('FF', scratch)
	    CALL str$trim (scratch, scratch, ll)
	    IF (scratch(1:ll) .EQ. 'COLUMN') THEN
		form_feed_flag = 1
	    ELSE IF (scratch(1:ll) .EQ. 'PAGE') THEN
		form_feed_flag = 2
	    END IF
	END IF
C
	footer_flag = cli$present ('FOOTER')
	IF (footer_flag) THEN
	    CALL cli$get_value ('FOOTER', footer_line)
	    CALL str$trim (footer_line, footer_line, footer_line_length)
	    IF (footer_line_length .GE. page_width - right_shift) THEN
		CALL str$left (footer_line, footer_line, 
	1	    page_width - right_shift)
		footer_line_length = page_width - right_shift - 1
	    END IF
	    IF (right_shift .GT. 0) THEN
		CALL str$dupl_char (blanks, right_shift, %REF(' '))
		footer_line = blanks(1:right_shift) //
	1	    footer_line(1:footer_line_length)
		footer_line_length = footer_line_length + right_shift
	    END IF
	END IF
C
	header_flag = cli$present ('HEADER')
	IF (header_flag) THEN
	    CALL cli$get_value ('HEADER', header_line)
	    CALL str$trim (header_line, header_line, ll)
	    IF (ll .EQ. 0) THEN
		header_line(right_shift+1:right_shift+11) = 'MCL Ver 3.0'
		header_line(page_width-26:page_width) =
	1	    ' ' // date_time(1:17) // ' Page    '
		temp_file_name_length = input_file_name_length
		IF (temp_file_name_length .GT. page_width - right_shift - 39)
	1	    temp_file_name_length = page_width - right_shift - 39
		first_character = 
	1	    (page_width - right_shift - temp_file_name_length - 39) /
	1	    2 + 12 + right_shift
		last_character = first_character+temp_file_name_length+1
		header_line(first_character:last_character) =
	1	    ' '//input_file_name(1:temp_file_name_length)//' '
	    ELSE 
		IF (ll .GT. (page_width - right_shift - 4)) THEN
		    ll = page_width - right_shift - 4
		    CALL str$left (header_line, header_line, ll)
		END IF
		IF (right_shift .GT. 0) THEN
		    CALL str$dupl_char (blanks, right_shift, %REF(' '))
		    header_line = blanks(1:right_shift) // header_line(1:ll)
		END IF
	    END IF
	END IF

	IF (cli$present ('LENGTH')) THEN
	    CALL cli$get_value ('LENGTH', scratch)
	    CALL str$trim (scratch, scratch, ll)
	    READ (scratch, '(i<ll>)') lines_to_write
	    IF (lines_to_write .GT. maximum_lines_per_page) THEN
		WRITE (6,'(xa,i2)')
	1	    '%MCL-F-TOOMANYLINES, Number of lines is limited to',
	1	    maximum_lines_per_page
		CALL EXIT
	    END IF
	    lines_to_write = lines_to_write - 2
	ELSE
	    lines_to_write = lib$lp_lines() - 8
	END IF
	IF (.NOT. header_flag) lines_to_write = lines_to_write + 1
	IF (footer_flag) lines_to_write = lines_to_write - 2
C
C	Finished with the command line - Now process the input file
C
	input_line_pointer = 0
	this_column = 1
	number_of_lines_this_column = 0
	column_is_full = .FALSE.
	DO i=1,maximum_number_of_columns
	   longest_line(i) = 0
	END DO
	input_length = 0
C
	DO WHILE (input_length .GE. -1) ! -1 flags ff, -2 flags eof on read
	    new_line = next_line (input_length, maximum_line_length, wrap,
	1	ftab_expand, fort_cc, case_flag, form_feed_flag)
	    IF (input_length .GE. -1) THEN
		IF (input_length .GE. 0) THEN
		    input_line_pointer = input_line_pointer + 1
		    number_of_lines_this_column =
	1		number_of_lines_this_column + 1
		    lines(input_line_pointer).line_length = input_length
		    longest_line(this_column) =
	1		MAX (input_length, longest_line(this_column))
		    IF (input_length .GT. 0)
	1		lines(input_line_pointer).input_line = 
	1		new_line(1:input_length)
C
		ELSE IF (number_of_lines_this_column .GT. 1) THEN
		    DO i = number_of_lines_this_column+1, lines_to_write
			input_line_pointer = input_line_pointer + 1
			lines(input_line_pointer).line_length = 0
		    END DO
		    number_of_lines_this_column = lines_to_write
		END IF
C
		IF (number_of_lines_this_column .GE. lines_to_write) THEN
		    longest_line(this_column) = column_width
		    sum_of_long_lines = -3	!last column needs no separator
C
		    DO i = 1, this_column
			sum_of_long_lines =
	1		    sum_of_long_lines + longest_line(i) + 3
		    END DO
C
		    DO i = this_column+1, number_of_columns_requested
			sum_of_long_lines =
	1		    sum_of_long_lines + column_width + 3
		    END DO
		    IF (sum_of_long_lines .GT. (page_width - right_shift) .OR.
	1		this_column .GE. maximum_number_of_columns .OR.
	1		(input_length .EQ. -1 .AND. form_feed_flag .EQ. 2)) THEN
			CALL write_page_header
	1		    (input_file_name, input_file_name_length,
	1		    output_file_name, output_file_name_length,
	1		    header_line, page_width, header_flag)
C
			IF (sum_of_long_lines.GT.(page_width-right_shift)) THEN
			    sum_of_long_lines = sum_of_long_lines -
	1			longest_line(this_column) - 3
			    use_through_column =
	1			MAX (use_through_column, this_column - 1)
			ELSE
			    use_through_column =
	1			MAX (use_through_column, this_column)
			END IF
C
			CALL write_page
	1		    (lines, lines_to_write, page_width, longest_line,
	1		    use_through_column, input_line_pointer,
	1		    sum_of_long_lines, sep_char, right_shift)
			IF (footer_flag) WRITE (2,10) footer_line
			IF (pause_flag) THEN
			    WRITE (6,30)
			    READ (5,20) dummy
			END IF
C
			IF (use_through_column .EQ. this_column) THEN
			    this_column = 1
			    number_of_lines_this_column = 0
			    input_line_pointer = 0
			    longest_line(this_column) = 0
			ELSE
			    source_pointer = 
	1			use_through_column * lines_to_write + 1
			    DO i = source_pointer, input_line_pointer
				lines(i-source_pointer+1).line_length =
	1			   lines(i).line_length
				lines(i-source_pointer+1).input_line  =
	1			   lines(i).input_line
			    END DO
			    longest_line(1) = longest_line(this_column)
			    longest_line(2) = 0
			    input_line_pointer =
	1			input_line_pointer - source_pointer + 1
			    number_of_lines_this_column =
	1			mod(input_line_pointer,lines_to_write)
			    IF (input_line_pointer .LT. lines_to_write) THEN
				this_column = 1
			    ELSE
				this_column = 2
			    END IF
			END IF
		    ELSE
			number_of_lines_this_column = 0
			this_column = this_column + 1
			longest_line(this_column) = 0
		    END IF
		END IF
	    END IF
	END DO
C
C	Finish up last page
C
	DO WHILE (input_line_pointer .GT. 0)
	    CALL write_page_header
	1	(input_file_name, input_file_name_length, output_file_name,
	1	output_file_name_length, header_line, page_width, header_flag)
	    IF (number_of_lines_this_column .EQ. 0) 
	1	this_column = this_column - 1
	    longest_line(this_column) = column_width
C
	    IF (lines_to_write .LT. input_line_pointer) THEN
		ltw = lines_to_write
	    ELSE
		ltw = input_line_pointer
	    END IF
C
	    sum_of_long_lines = -3
	    DO i = 1, this_column
		sum_of_long_lines = sum_of_long_lines + longest_line(i) + 3
	    END DO
	    DO i = this_column+1, number_of_columns_requested
		sum_of_long_lines = sum_of_long_lines + column_width + 3
	    END DO
C
	    IF (sum_of_long_lines .GT. (page_width - right_shift)) THEN
		sum_of_long_lines = sum_of_long_lines -
	1	    longest_line(this_column) - 3
		use_through_column = MAX (use_through_column, this_column - 1)
	    ELSE
		use_through_column = MAX (use_through_column, this_column)
	    END IF
C
	    CALL write_page
	1	(lines, ltw, page_width, longest_line, use_through_column,
	1	input_line_pointer, sum_of_long_lines, sep_char, right_shift)
	    IF (footer_flag) WRITE (2,10) footer_line
	    IF (pause_flag) THEN
		WRITE (6,30)
		READ (5,20) dummy
	    END IF
C
	    IF (use_through_column .EQ. this_column) THEN
		input_line_pointer = 0
	    ELSE
		source_pointer = use_through_column*ltw + 1
		DO i = source_pointer, input_line_pointer
		    lines(i-source_pointer+1).line_length = lines(i).line_length
		    lines(i-source_pointer+1).input_line  = lines(i).input_line
		END DO
		longest_line(1) = longest_line(this_column)
		longest_line(2) = 0
		input_line_pointer = input_line_pointer - source_pointer + 1
		number_of_lines_this_column = 
	1	    MOD (input_line_pointer, lines_to_write)
		this_column = 1
	    END IF
	END DO
	CALL EXIT
C
200	WRITE (6,*) '%MCL-F-ERROPINPUT: Error opening input file of name: '//
	1    source_file(1:i)
	CALL EXIT
	END
C
C-------------------------------------------------------------------------------
C
	OPTIONS	/EXTEND_SOURCE
	CHARACTER*(*) FUNCTION next_line (return_length, column_width, wrap,
	1   ftab_expand, fort_cc, case_flag, form_feed_flag)
C
C	Function to return the next line from the input file
C
	IMPLICIT    NONE
C
	CHARACTER   tab,lf,ff,cr
	PARAMETER   (tab = char( 9))
	PARAMETER   (lf  = char(10))
	PARAMETER   (ff  = char(12))
	PARAMETER   (cr  = char(13))
C
	INTEGER	    return_length,
	1	    column_width,
	1	    case_flag,
	1	    form_feed_flag,
	1	    current_length /0/,
	1	    form_feed_count /0/,
	1	    space_count,
	1	    input_pointer,
	1	    output_pointer
C
	LOGICAL	    wrap,
	1	    ftab_expand,
	1	    fort_cc,
	1	    continue,
	1	    pause
C
	CHARACTER*1	this_character
	CHARACTER*8	spaces/'	  '/
	CHARACTER*250	current_line
C
C	Format statements
C
10	FORMAT (q,a)
C
C	Begin NEXT_LINE
C
	IF (form_feed_count .GT. 0) THEN
	    form_feed_count = form_feed_count - 1
	    return_length = 0
	    RETURN
	END IF
C
	input_pointer = 1
	IF (current_length .LE. 0) THEN
	    READ (1,10,END=100) current_length, current_line
	    IF (case_flag .GT. 0) THEN
		CALL str$upcase (current_line, current_line)
	    ELSE IF (case_flag .LT. 0) THEN
		CALL str$translate (current_line, current_line,
	1	'abcdefghijklmnopqrstuvwxyz', 'ABCDEFGHIJKLMNOPQRSTUVWXYZ')
	    END IF
C
	    output_pointer = 1
	    IF (fort_cc) THEN		    ! Fortran carriage control expected
		IF (current_line(1:1) .EQ. '1') THEN
		    current_line(1:1) = ff  ! set FF
		ELSE IF (current_line(1:1) .EQ. '0') THEN
		    current_line(1:1) = cr  ! set CR
		ELSE
		    input_pointer = 2
		END IF
	    END IF
	ELSE
	    IF (pause) THEN
		output_pointer = 1
	    ELSE
		next_line(1:3) = '-->'
		output_pointer = 4
	    END IF
	END IF
C
	pause = .FALSE.
	DO WHILE ((input_pointer .LE. current_length .AND.
	1	    output_pointer .LE. column_width) .AND. .NOT.pause)
	    this_character = current_line(input_pointer:input_pointer)
	    IF (this_character .EQ. tab) THEN
		IF (ftab_expand .AND. output_pointer .LE. 6) THEN
		    IF (continue
	1		(current_line(input_pointer+1:input_pointer+1))) THEN
			space_count = 6 - output_pointer
		    ELSE
			space_count = 7 - output_pointer
		    END IF
		ELSE
		    space_count = 8 - MOD (output_pointer-1,8)
		END IF
C
		IF (space_count .GT. 0) THEN
		    next_line(output_pointer:output_pointer+space_count-1) =
	1		spaces(1:space_count)
		    output_pointer = output_pointer + space_count
		END IF
		input_pointer = input_pointer + 1
C
	    ELSE IF (this_character .EQ. lf) THEN
		pause = .TRUE.
		input_pointer = input_pointer + 1
C
	    ELSE IF (this_character .EQ. cr) THEN
		pause = .TRUE.
		input_pointer = input_pointer + 1
		IF (current_line(input_pointer:input_pointer) .EQ. lf) THEN
		    input_pointer = input_pointer + 1
		END IF
C
	    ELSE IF (this_character .EQ. ff) THEN
		pause = .TRUE.
		IF (output_pointer .EQ. 1) THEN		! return FF indicator only
		    input_pointer = input_pointer + 1	! when at beginning of line
		    output_pointer = 0			! to avoid wiping out data
		END IF					! at beginning of line
	    ELSE
		next_line(output_pointer:output_pointer+1) = this_character
		output_pointer = output_pointer + 1
		input_pointer = input_pointer + 1
	    END IF
	END DO
C
	return_length = output_pointer - 1
	IF ((return_length .EQ. -1) .AND. (form_feed_flag .EQ. 0))
	1   return_length = 0
	current_line = current_line(input_pointer:len(current_line))
	current_length = current_length - input_pointer + 1
	IF (.NOT. (pause .OR. wrap)) THEN
	    current_length = 0
	END IF
	RETURN
C
100	return_length = -2
	RETURN
	END
C
C	Function to determine if a CHARACTER is a number indicating a
C	Fortran continue
C
	LOGICAL FUNCTION continue (char)
	IMPLICIT NONE
	CHARACTER char
	continue = ((char .LE. '9') .AND. (char .GT. '0'))
	RETURN
	END
C
C-------------------------------------------------------------------------------
C
	OPTIONS /EXTEND_SOURCE
	SUBROUTINE write_page_header
	1   (input_file_name, input_file_name_length, output_file_name,
	1   output_file_name_length, header_line, page_width, header_flag)
C
C	Subroutine to write the page heading to the output file
C
	IMPLICIT NONE
C
	INTEGER	    input_file_name_length,
	1	    output_file_name_length,
	1	    page_width,
	1	    page_number /0/,
	1	    k
C
	LOGICAL	    header_flag
C
	CHARACTER*17	default_output_file /'SYS$DISK:[].MCL;0'/
	CHARACTER*(*)	input_file_name,
	1		output_file_name,
	1		header_line
C
C	Format statements
C
10	FORMAT (i4)
20	FORMAT ('1',a,/)
30	FORMAT ('1')
C
C	Begin WRITE_PAGE_HEADER
C
	page_number = page_number + 1
	IF (page_number .EQ. 1) THEN
	    IF (output_file_name_length .GT. 0) THEN
		OPEN (UNIT=2, STATUS='NEW', DEFAULTFILE=default_output_file,
	1	    FILE=output_file_name(1:output_file_name_length))
	    ELSE
		OPEN (UNIT=2, FILE=default_output_file, STATUS='NEW',
	1	    DEFAULTFILE=input_file_name(1:input_file_name_length))
	    END IF
	END IF
C
	IF (header_flag) THEN
	    WRITE (header_line(page_width-3:page_width),10) page_number
	    IF (header_line(page_width-2:page_width-2) .EQ. ' ') 
	1	header_line(page_width-2:page_width) =
	1	header_line(page_width-1:page_width)
	    CALL str$trim (header_line, header_line(1:page_width), k)
	    WRITE (2,20) header_line(1:k)
	ELSE
	    WRITE (2,30)
	END IF
	RETURN
	END
C
C-------------------------------------------------------------------------------
C
	OPTIONS /EXTEND_SOURCE
	SUBROUTINE write_page (lines, lines_to_write, page_width, longest_line,
	1	use_through_column, input_line_pointer, sum_of_long_lines,
	1	sep_char, right_shift)
C
C	Subroutine to write the page to the output file
C
	IMPLICIT NONE
C
	INTEGER
	1	maximum_number_of_columns,
	1	maximum_number_of_lines_to_read,
	1	maximum_lines_per_page,
	1	lines_to_write,
	1	page_width,
	1	use_through_column,
	1	input_line_pointer,
	1	sum_of_long_lines,
	1	maximum_io_line_length,
	1	i,k,l,m,
	1	first_character,
	1	last_character,
	1	output_line_length,
	1	add_per_column,
	1	right_shift
C
	PARAMETER   (maximum_lines_per_page    =  88)
	PARAMETER   (maximum_number_of_columns =   9)
	PARAMETER   (maximum_io_line_length    = 132)
	PARAMETER   (maximum_number_of_lines_to_read =
	1		maximum_lines_per_page * maximum_number_of_columns)
C
	INTEGER	    longest_line(maximum_number_of_columns)
C
	CHARACTER   sep_char
	CHARACTER*(maximum_io_line_length)  output_line
	CHARACTER*(maximum_io_line_length)  blanks
C
	STRUCTURE /line/
	    INTEGER*4 line_length
	    CHARACTER*132 input_line
	END STRUCTURE
	RECORD /line/ lines(maximum_number_of_lines_to_read)
C
C	Format statements
C
10	FORMAT (' ',a)
C
C	Begin WRITE_PAGE
C
	CALL str$dupl_char (blanks, maximum_io_line_length, %REF(' '))
	add_per_column = (page_width - sum_of_long_lines - right_shift) /
	1   use_through_column
	DO l = 1, lines_to_write
	    first_character = 1
	    m = l
	    DO i = 1, use_through_column
		last_character = first_character + longest_line(i) +
	1	    add_per_column - 1
		k = lines(m).line_length
C
		IF (k .GT. 0 .AND. m .LE. input_line_pointer) THEN
		    output_line(first_character:last_character) =
	1		lines(m).input_line(1:k)
		ELSE
		    output_line(first_character:last_character) = ' '
		END IF
C
		first_character = last_character + 1
		last_character = first_character + 2
		output_line(first_character:last_character) = 
	1	    ' ' // sep_char // ' '
		first_character = last_character + 1
		m = m + lines_to_write
	    END DO
	    output_line_length = first_character - 4
	    CALL str$trim (output_line, output_line(1:output_line_length),
	1	output_line_length)
	    IF (right_shift .GT. 0) THEN
		output_line = blanks(1:right_shift) //
	1	    output_line(1:output_line_length)
		output_line_length = output_line_length + right_shift
	    END IF
	    WRITE (2,10) output_line(1:output_line_length)
	END DO
	RETURN
	END
