[COY.USER_MAINTAINED.MCL]2CL.FOR;72 · Wednesday, November 25, 1987 1:46 PM · Page 1 [1;3665;100;5660;3!| Program Mcl_2up call fulltime(neattime,l_day) c c Multi Column Lister (2-column LN03 version) c Examine command line for source file name. C c C Code originated by Gerson Cohen, National Institutes of Health call cli$get_value('P1',source_file) C Via Pageswapper. sfl = index(source_file,' ') - 1 C open (unit=1,file=source_file(1:sfl),status='old',readonly,err=900) C Mods by Dale E. Coy, Los Alamos National Laboratory, 23-NOV-1987 inquire (unit=1,name=input_file_name) C Tailored for 2-column listing specifically to LN03 printer. call str$trim(input_file_name,input_file_name,input_file_name_length) inquire (unit=1,carriagecontrol=scratch) implicit integer*4 (a-z) If (scratch(1:7) .EQ. 'FORTRAN') then parameter (maximum_file_name_length = 255) fort_cc = .true. parameter (maximum_io_line_length = 133) Else parameter (maximum_lines_per_page = 63) fort_cc = .false. parameter (lines_to_write = maximum_lines_per_page - 2) End If parameter (page_width = 172) parameter (header_width = 105) C Get information from cli, etc. parameter (column_width = 83) parameter (maximum_number_of_columns = 2) status = cli$present('WRAP') parameter (maximum_number_of_lines_to_read = wrap = status.eq.%loc(cli$_present) .and. status.ne.%loc(cli$_negated) 1 lines_to_write * maximum_number_of_columns) status = cli$present('FTAB_EXPAND') character*(*) csi ftab_expand = status.eq.%loc(cli$_present) .and. parameter (csi = char(27)//'[') 1 status.ne.%loc(cli$_negated) character*(*) write_bold C Get information about the output file. parameter (write_bold = csi//'10m'//csi//'1w'//csi//'1m' ) if (cli$present('OUTPUT')) then call cli$get_value('OUTPUT',output_file_name) character*(*) write_normal_tiny call str$trim parameter (write_normal_tiny = csi//'0m'//csi//'15m'//csi//'4w'//csi// 1 (output_file_name,output_file_name,output_file_name_length) 1 '1;3665;100;5660;3!|' ) else output_file_name = ' ' character*(*) wrap_ind output_file_name_length = 0 parameter (wrap_ind = '==wrap==') end if parameter (wrap_ind_length = 6) C Open the output file if (output_file_name_length.gt.0) then character*1 bullet open (unit=2,status='new',defaultfile=default_output_file, parameter (bullet = char(183)) 1 file=output_file_name(1:output_file_name_length), 2 recl=page_width, err=950 ) external cli$_negated,cli$_present else character*44 neattime open (unit=2,file=default_output_file,status='new', character*(maximum_file_name_length) source_file 1 defaultfile=input_file_name(1:input_file_name_length), character*(maximum_file_name_length) input_file_name 2 recl=page_width, err=950 ) character*(maximum_file_name_length) output_file_name end if character*(header_width) header_line character*(maximum_io_line_length) new_line character*((page_width -1)-(2*column_width)) separator /' '/ C Construct header line character*17 default_output_file/'SYS$DISK:[].2CL;0'/ C character*10 scratch C Get rid of Device Name, if present (designer's choice) logical column_is_full, ftab_expand, wrap, leftover, fort_cc if (input_file_name(1:1) .EQ. '$') then logical paging, finished colon = index (input_file_name, ':') if (colon .GT. 0) then structure /line/ input_file_name = integer*2 line_length 1 input_file_name character*(column_width) output_line 2 (colon+1 : input_file_name_length) end structure input_file_name_length = record /line/ lines(maximum_number_of_lines_to_read) 1 input_file_name_length - colon record /line/ leftover_line end if end if C Get the date-time string [COY.USER_MAINTAINED.MCL]2CL.FOR;72 · Wednesday, November 25, 1987 1:46 PM · Page 2 [1;3665;100;5660;3!| date_offset = l_day + 14 End If 101 if (input_file_name_length .GE. 1 (header_width - date_offset )) then output_line_pointer = output_line_pointer + 1 number_of_lines_this_column = number_of_lines_this_column + 1 C Get rid of device name, if not done above if (number_of_lines_this_column.gt.lines_to_write) then colon = index (input_file_name, ':') number_of_lines_this_column = 1 if (colon .GT. 0) then this_column = this_column + 1 input_file_name = end if 1 input_file_name 2 (colon+1 : input_file_name_length) C Handle one input line input_file_name_length = if (input_length.gt.0) then 1 input_file_name_length - colon Call DeTab (New_Line, FTab_Expand) Go to 101 Call str$trim(new_line, new_line, trimmed_length) end if 11 If (trimmed_length .GT. 0) then if (this_column .EQ. 1) then rt_bracket = index (input_file_name, ']') Lines_C1 = number_of_lines_this_column if (rt_bracket .GT. 0) then else input_file_name = Lines_C2 = number_of_lines_this_column 1 input_file_name end if 2 (rt_bracket+1 : input_file_name_length) input_file_name_length = If (new_line(1:1) .eq. char(12)) then ! Form feed 1 input_file_name_length - rt_bracket new_line(1:) = new_line(2:) end if trimmed_length = trimmed_length - 1 end if if (this_column .lt. maximum_number_of_columns) then do 12 jj = number_of_lines_this_column, header_line = input_file_name 1 lines_to_write lines(jj).output_line = ' ' if (input_file_name_length .lt. (header_width - date_offset)) then lines(jj).line_length = 0 header_line(header_width - date_offset:header_width) = 12 continue 1 ' '//bullet//' '// output_line_pointer = lines_to_write + 1 2 neattime(:l_day)//' '//bullet//' Page ' this_column = this_column + 1 else number_of_lines_this_column = 1 header_line(header_width-11:header_width) = Go to 11 1 ' '//bullet//' Page ' else end if do 13 jj = 1 number_of_lines_this_column + lines_to_write, C Initialize 1 (lines_to_write * 2) output_line_pointer = 0 lines(jj).output_line = ' ' number_of_lines_this_column = 0 lines(jj).line_length = 0 this_column = 1 13 continue page_number = 0 paging = .true. lines_c1 = 0 Go to 200 ! to write a line lines_c2 = 0 14 Continue ! and return here column_is_full = .false. paging = .false. leftover = .false. output_line_pointer = 1 paging = .false. this_column = 1 finished = .false. number_of_lines_this_column = 1 Go to 11 C Now, read the input until we run out of lines End If End If do while (.true.) read (1,10,end=100) input_length,new_line lines(output_line_pointer).output_line = 10 format (q,a) 1 new_line(:trimmed_length) If (Fort_CC .AND. (input_length .GT. 0)) then If (trimmed_length .GT. column_width) then C Strip the leading character unless it's a '1' lines(output_line_pointer).line_length = column_width If (new_line(1:1) .EQ. '1') then Else new_line(1:1) = Char(12) ! Substitute FF lines(output_line_pointer).line_length = trimmed_length Else End If new_line = new_line(2:input_length) Else input_length = input_length - 1 lines(output_line_pointer).output_line = ' ' End If lines(output_line_pointer).line_length = 0 [COY.USER_MAINTAINED.MCL]2CL.FOR;72 · Wednesday, November 25, 1987 1:46 PM · Page 3 [1;3665;100;5660;3!| End If end if ! through with column If (trimmed_length .GT. column_width) then end do if (wrap) then output_line_pointer = output_line_pointer + 1 from = column_width + 1 100 continue ! ran out of input lines if (output_line_pointer .LE. 1 maximum_number_of_lines_to_read) then finished = .true. ! signal the page processor C we have enough room on the page do 110 k = output_line_pointer + 1, maximum_number_of_lines_to_read lines(output_line_pointer).output_line = lines(k).output_line = ' ' 1 wrap_ind//new_line(from:trimmed_length) lines(k).line_length = 0 lines(output_line_pointer).line_length = 110 continue 1 trimmed_length - column_width Go to 200 2 + wrap_ind_length + 2 number_of_lines_this_column = 200 continue ! write output page 1 number_of_lines_this_column + 1 If (finished .and. (Lines_C1 .LE. 0) .and. if (this_column .EQ. 1) then 1 (Lines_C2 .LE. 0)) Go To 57 if (number_of_lines_this_column.le. C WRITE A PAGE 1 lines_to_write) then C Header Line: (plus one blank line) Lines_C1 = number_of_lines_this_column page_number = page_number + 1 else write (header_line(header_width-4:header_width),20) number_of_lines_this_column = 1 1 page_number this_column = this_column + 1 20 format (i5) Lines_C2 = 1 25 if (header_line(header_width-3:header_width-3).eq.' ') then end if header_line(header_width-3:header_width) = else 1 header_line(header_width-2:header_width) Lines_C2 = number_of_lines_this_column Go to 25 end if end if else ! totally full call str$trim(header_line,header_line(1:header_width),k) leftover = .true. if (page_number .NE. 1) then leftover_line.output_line = write (2,30) write_bold//header_line(1:k) 1 wrap_ind//new_line(from:trimmed_length) 30 format ('1',a) leftover_line.line_length = else 1 trimmed_length - column_width write (2,40) write_bold//header_line(1:k) 2 + wrap_ind_length + 2 end if end if ! maximum_number_of_lines_to_read end if ! wrap write (2,40) write_normal_tiny End If ! trimmed_width else ! length = 0 C The rest of the lines: lines(output_line_pointer).line_length = 0 do L=1,MAX(Lines_C1, Lines_C2) end if ! length <> 0 Right_Line = L + Lines_to_write Right_Line_Length = Lines(Right_Line).Line_Length if (output_line_pointer .GE. If (Right_Line_Length .GT. 0) then 1 maximum_number_of_lines_to_read) then Go to 200 ! to write the page If (Lines(L).Line_Length .GT. 0) then 90 Continue ! and come back to here. write(2,40) Lines(L).output_Line // separator // 1 Lines(Right_Line).output_Line this_column = 1 2 (:Right_Line_Length) Lines_C2 = 0 Else if (leftover) then write(2,44) separator // lines(1).output_line = leftover_line.output_line 1 Lines(Right_Line).output_Line lines(1).line_length = leftover_line.line_length 2 (:Right_Line_Length) leftover = .false. End If number_of_lines_this_column = 1 output_line_pointer = 1 Else If (Lines(L).Line_Length .GT. 0) then Lines_C1 = 1 write(2,40) Lines(L).output_Line else number_of_lines_this_column = 0 Else output_line_pointer = 0 write(2,41) Lines_C1 = 0 41 format (a) end if End If [COY.USER_MAINTAINED.MCL]2CL.FOR;72 · Wednesday, November 25, 1987 1:46 PM · Page 4 [1;3665;100;5660;3!| 40 format (' ',a) 44 format (' ',X,a) end do Else ! Not fortran Lines_C1 = 0 Lines_C2 = 0 20 Tab_Position = index (line,tab) If (Tab_Position .LE. 0) Return 57 If (finished) then Num_Spaces = 8 - MOD((Tab_Position - 1),8) close (unit=1) New_Text_Position = Tab_Position + Num_Spaces close (unit=2) Line (New_Text_Position:) = Line (Tab_Position + 1:) call exit Line (Tab_Position:New_Text_Position-1) = Spaces Else If (paging) then Go To 20 Go to 14 ! FF processing Else End If Go to 90 ! keep processing file End End If 900 write (6,*) Logical Function Number (Char) 1 '%2CL-F-ERROPINPUT: Error opening input file of name: '// Character Char 2 source_file(1:sfl) C call exit C Function to determine if a character is a number. C 950 write (6,*) '%2CL-F-ERROPINPUT: Error opening output file' Number = ((Char .LE. '9') .AND. (Char .GT. '0')) close (unit=1) Return call exit End end C This subroutine returns a string with the day, date, and time formatted C (for example) as: Tuesday, August 4, 1987 10:30 PM Subroutine DeTab (Line,Fortran) C subroutine fulltime(neattime,l_n) C Replaces tabs in Line with Spaces (according to either the character*(*) neattime C regular 8-column, or the FORTRAN pattern). character*2 hour, day, ampm Character*(*) Line C character*2 min Logical Fortran, Number character*3 month Character*8 Spaces/' '/ C character*4 year Character*1 Tab character*10 newmon, dayname Parameter (Tab = char(9)) character*23 d Integer Tab_Position, New_Text_Position integer*4 today /0/ integer*4 dayint If (Fortran) then integer l_day 10 Tab_Position = index (line,tab) If (Tab_Position .LE. 0) Return call lib$day_of_week(%Val(today),%Ref(dayint)) If (Tab_Position .LE. 6) then If (Number(Line(Tab_Position+1:Tab_Position+1))) then goto (1,2,3,4,5,6,7) dayint Num_Spaces = 6 - Tab_Position Else 1 dayname = 'Monday ' Num_Spaces = 7 - Tab_Position l_day = 6 End IF goto 200 Else Num_Spaces = 8 - MOD((Tab_Position - 1),8) 2 dayname = 'Tuesday ' End If l_day = 7 goto 200 New_Text_Position = Tab_Position + Num_Spaces Line (New_Text_Position:) = Line (Tab_Position + 1:) 3 dayname = 'Wednesday ' If (Num_Spaces .GT. 0) l_day = 9 1 Line (Tab_Position:New_Text_Position-1) = Spaces goto 200 Go To 10 [COY.USER_MAINTAINED.MCL]2CL.FOR;72 · Wednesday, November 25, 1987 1:46 PM · Page 5 [1;3665;100;5660;3!| 4 dayname = 'Thursday ' l_nm = 3 l_day = 8 elseif (month.eq.'JUN') then goto 200 newmon = 'June' l_nm = 4 5 dayname = 'Friday ' elseif (month.eq.'JUL') then l_day = 6 newmon = 'July' goto 200 l_nm = 4 elseif (month.eq.'AUG') then 6 dayname = 'Saturday ' newmon = 'August' l_day = 8 l_nm = 6 goto 200 elseif (month.eq.'SEP') then newmon = 'September' 7 dayname = 'Sunday ' l_nm = 9 l_day = 6 elseif (month.eq.'OCT') then goto 200 newmon = 'October' l_nm = 7 elseif (month.eq.'NOV') then 200 call lib$date_time(d) newmon = 'November' day = d(1:2) l_nm = 8 month = d(4:6) elseif (month.eq.'DEC') then C year =d(8:11) newmon = 'December' hour = d(13:14) l_nm = 8 C min = d(16:17) endif read (hour,'(i2)') ihour neattime = dayname(1:l_day)//', '// if (ihour.gt.12) then 1 newmon(1:l_nm)//' '//day(1:l_days)// ihour = ihour - 12 1 ', '//d(8:11)//' '// ampm = 'PM' 1 hour(1:l_h)//':'//d(16:17)//' '//ampm hour = ' ' write (hour,'(i2)') ihour call str$trim(neattime,neattime,l_n) else return ampm = 'AM' end endif if (ihour.eq.12) ampm = 'PM' l_h = 2 if (ihour.lt.10) then hour(1:1) = hour(2:2) l_h = 1 endif if (day(1:1) .eq. ' ') then day(1:1) = day(2:2) l_days = 1 else l_days = 2 endif if (month.eq.'JAN') then newmon = 'January' l_nm = 7 elseif (month.eq.'FEB') then newmon = 'February' l_nm = 8 elseif (month.eq.'MAR') then newmon = 'March' l_nm = 5 elseif (month.eq.'APR') then newmon = 'April' l_nm = 5 elseif (month.eq.'MAY') then newmon = 'May'