options /extend_source program mcl c Multi Column Lister: Version 2.1 implicit integer*4 (a-z) parameter (maximum_file_name_length = 255) parameter (maximum_io_line_length = 132) parameter (maximum_lines_per_page = 66) 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) 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 integer*4 longest_line(maximum_number_of_columns) character*(maximum_page_width) header_line character*(maximum_io_line_length) new_line character*(maximum_io_line_length) next_line character*10 scratch logical column_is_full,ftab_expand,wrap,fort_cc structure /line/ integer*4 line_length character*132 input_line end structure record /line/ lines(maximum_number_of_lines_to_read) 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) lines_to_write = min(lib$lp_lines(),maximum_lines_per_page) - 8 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,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' if (cli$present('COLUMNS')) then call cli$get_value('COLUMNS',scratch) call str$trim(scratch,scratch,ll) read (scratch,'(i)') 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 end if else number_of_columns_requested = 0 end if ftab_expand = cli$present('FTAB_EXPAND') 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 if (cli$present('WIDTH')) then call cli$get_value('WIDTH',scratch) call str$trim(scratch,scratch,ll) read (scratch,'(i)') page_width if (page_width.gt.maximum_page_width) then write (6,*) '%MCL-F-PAGTOOWIDE, 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 wrap = cli$present('WRAP') if (number_of_columns_requested.eq.0) then column_width = 0 maximum_line_length = page_width else column_width = page_width / number_of_columns_requested - 3 maximum_line_length = column_width end if header_line = 'MCL Ver 2.1 ' header_line(page_width-26:page_width) = ' '//date_time(1:17)//' Page ' if (input_file_name_length.lt.page_width-38) then first_character = (page_width-input_file_name_length)/2 - 7 last_character = first_character + input_file_name_length + 1 header_line(first_character:last_character) = 1 ' '//input_file_name(1:input_file_name_length)//' ' else header_line(13:page_width-26) = 1 input_file_name(input_file_name_length-page_width+38: 1 input_file_name_length) end if 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 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) if (input_length.ge.-1) then if (input_length.ge.0) then input_line_pointer = input_line_pointer + 1 number_of_lines_this_column = number_of_lines_this_column + 1 lines(input_line_pointer).line_length = input_length longest_line(this_column) = max(input_length, 1 longest_line(this_column)) if (input_length.gt.0) lines(input_line_pointer).input_line = 1 new_line(1:input_length) else if (number_of_lines_this_column.gt.1) then ! next column only if we are beyond line one already 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 if (number_of_lines_this_column.ge.lines_to_write) then if (column_width.ne.0) longest_line(this_column) = column_width sum_of_long_lines = -3 ! last column needs no separator do i=1,this_column sum_of_long_lines = sum_of_long_lines + longest_line(i) + 3 end do if (sum_of_long_lines.gt.page_width-6 .or. 1 this_column.ge.maximum_number_of_columns) then call write_page_header(input_file_name,input_file_name_length, 1 output_file_name,output_file_name_length, 1 header_line,page_width) if (sum_of_long_lines.gt.page_width) then sum_of_long_lines = sum_of_long_lines - 1 longest_line(this_column) - 3 use_through_column = this_column - 1 else use_through_column = this_column end if call write_page(lines,lines_to_write,page_width,longest_line, 1 use_through_column,input_line_pointer, 1 sum_of_long_lines) 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 = 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 = input_line_pointer - 1 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 do while (input_line_pointer.gt.0) call write_page_header(input_file_name,input_file_name_length, 1 output_file_name,output_file_name_length, 1 header_line,page_width) if (number_of_lines_this_column.eq.0) this_column = this_column - 1 if (column_width.ne.0) longest_line(this_column) = column_width if (lines_to_write.lt.input_line_pointer) then ltw = lines_to_write else ltw = input_line_pointer end if sum_of_long_lines = -3 do i=1,this_column sum_of_long_lines = sum_of_long_lines + longest_line(i) + 3 end do if (sum_of_long_lines.gt.page_width) then sum_of_long_lines = sum_of_long_lines - 1 longest_line(this_column) - 3 use_through_column = this_column - 1 else use_through_column = this_column end if call write_page(lines,ltw,page_width,longest_line, 1 use_through_column,input_line_pointer, 1 sum_of_long_lines) 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 = mod(input_line_pointer,lines_to_write) this_column = 1 end if end do call exit 200 write (6,*) '%MCL-F-ERROPINPUT: Error opening input file of name: '// 1 source_file(1:i) call exit end options /extend_source character*(*) function next_line(return_length,column_width, 1 wrap,ftab_expand,fort_cc) implicit none integer return_length,column_width logical wrap,ftab_expand,fort_cc logical continue integer current_length/0/ integer form_feed_count/0/ character*1 tab,lf,ff,cr,this_character parameter (tab = char( 9)) parameter (lf = char(10)) parameter (ff = char(12)) parameter (cr = char(13)) integer space_count character*8 spaces/' '/ character*250 current_line integer input_pointer,output_pointer logical pause if (form_feed_count.gt.0) then form_feed_count = form_feed_count - 1 return_length = 0 return end if input_pointer = 1 if (current_length.le.0) then read (1,10,end=100) current_length,current_line 10 format (q,a) 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 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(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 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 else if (this_character.eq.lf) then pause = .true. input_pointer = input_pointer + 1 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 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 return_length = output_pointer - 1 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 100 return_length = -2 return end logical function continue(char) implicit none character char c c Function to determine if a character is c a number indicating a Fortran continue c continue = ((char .le. '9') .and. (char .gt. '0')) return end options /extend_source subroutine write_page_header(input_file_name,input_file_name_length, 1 output_file_name,output_file_name_length, 1 header_line,page_width) implicit none character*(*) input_file_name character*(*) output_file_name character*(*) header_line integer input_file_name_length integer output_file_name_length integer page_width character*17 default_output_file/'SYS$DISK:[].MCL;0'/ integer page_number/0/ integer k 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 write (header_line(page_width-3:page_width),10) page_number 10 format (i4) if (header_line(page_width-2:page_width-2).eq.' ') then header_line(page_width-2:page_width) = 1 header_line(page_width-1:page_width) end if call str$trim(header_line,header_line(1:page_width),k) write (2,20) header_line(1:k) 20 format ('1',a,/) return end options /extend_source subroutine write_page(lines,lines_to_write,page_width,longest_line, 1 use_through_column,input_line_pointer, 1 sum_of_long_lines) implicit none integer maximum_lines_per_page integer maximum_number_of_columns integer maximum_number_of_lines_to_read parameter (maximum_lines_per_page = 66) parameter (maximum_number_of_columns = 9) parameter (maximum_number_of_lines_to_read = 1 maximum_lines_per_page * maximum_number_of_columns) structure /line/ integer*4 line_length character*132 input_line end structure record /line/ lines(maximum_number_of_lines_to_read) integer lines_to_write integer page_width integer longest_line(maximum_number_of_columns) integer use_through_column integer input_line_pointer integer sum_of_long_lines integer maximum_io_line_length parameter (maximum_io_line_length = 132) character*(maximum_io_line_length) output_line integer i,k,l,m,first_character,last_character integer output_line_length,add_per_column add_per_column = (page_width - sum_of_long_lines)/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 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 first_character = last_character + 1 last_character = first_character + 2 output_line(first_character:last_character) = ' | ' 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) write (2,10) output_line(1:output_line_length) 10 format (' ',a) end do return end