program plot_to_ps ! !******************************************************************************* ! !! PLOT_TO_PS converts plot commands into a PostScript file. ! ! ! Discussion: ! ! The program can be invoked by: ! ! plot_to_ps plot_file_name ps_file_name ! ! or: ! ! plot_to_ps plot_file_name ! ! in which case the output file name will be constructed by replacing ! the extension of PLOT_FILE_NAME by ".ps", or: ! ! plot_to_ps ! ! in which case the user will be asked to supply both file names. ! ! Reference: ! ! Henry McGilton and Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Modified: ! ! 27 September 2001 ! ! Author: ! ! John Burkardt ! implicit none ! logical, parameter :: debug = .false. character ( len = 10 ) ext character ( len = 256 ) filein_name integer filein_unit character ( len = 256 ) fileout_name integer iarg integer iargc integer ierror integer ilen integer ios integer ipxfargc integer lens integer num_arg ! ! Initialize. ! filein_name = ' ' fileout_name = ' ' ierror = 0 ! ! Get the number of command line arguments. ! ! Old style: ! ! num_arg = iargc ( ) ! ! New style: ! num_arg = ipxfargc ( ) ! ! If at least one command line argument, it's the input file name. ! if ( num_arg < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter the input PLOT file name:' read ( *, '(a)', iostat = ios ) filein_name if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PLOT_TO_PS - Fatal error!' write ( *, '(a)' ) ' Unexpected read error!' stop else if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The input file is ' // trim ( filein_name ) end if else iarg = 1 ! ! Old style: ! ! call getarg ( iarg, filein_name ) ! ! New style: ! call pxfgetarg ( iarg, filein_name, ilen, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PLOT_TO_PS - Fatal error!' write ( *, '(a)' ) ' Could not read command line argument.' stop end if end if ! ! If two command line arguments, the second one is the output file name. ! if ( num_arg < 2 ) then fileout_name = filein_name ext = 'ps' call file_name_ext_swap ( fileout_name, ext ) if ( debug ) then write ( *, '(a)' ) ' The output file is ' // trim ( fileout_name ) end if else iarg = 2 ! ! Old style: ! ! call getarg ( iarg, fileout_name ) ! ! New style: ! call pxfgetarg ( iarg, fileout_name, ilen, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PLOT_TO_PS - Fatal error!' write ( *, '(a)' ) ' Could not read command line argument.' stop end if end if ! ! Open the input file. ! call get_unit ( filein_unit ) open ( unit = filein_unit, file = filein_name, status = 'old', & iostat = ios ) if ( ios /= 0 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PLOT_TO_PS - Fatal error!' write ( *, '(a)' ) ' Could not open the input file:' write ( *, '(a)' ) trim ( filein_name ) stop else if ( debug ) then write ( *, '(a)' ) ' The input file has been opened.' end if ! ! Process the commands. ! call process ( filein_unit, fileout_name, ierror ) close ( unit = filein_unit ) if ( num_arg < 2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PLOT_TO_PS:' write ( *, '(a)' ) ' Normal end of execution.' end if stop end subroutine ch_cap ( c ) ! !******************************************************************************* ! !! CH_CAP capitalizes a single character. ! ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to capitalize. ! implicit none ! character c integer itemp ! itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end function ch_eqi ( c1, c2 ) ! !******************************************************************************* ! !! CH_EQI is a case insensitive comparison of two characters for equality. ! ! ! Examples: ! ! C_EQI ( 'A', 'a' ) is .TRUE. ! ! Modified: ! ! 14 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C1, C2, the characters to compare. ! ! Output, logical C_EQI, the result of the comparison. ! implicit none ! logical ch_eqi character c1 character c2 character cc1 character cc2 ! cc1 = c1 cc2 = c2 call ch_cap ( cc1 ) call ch_cap ( cc2 ) if ( cc1 == cc2 ) then ch_eqi = .true. else ch_eqi = .false. end if return end subroutine ch_to_digit ( c, digit ) ! !******************************************************************************* ! !! CH_TO_DIGIT returns the integer value of a base 10 digit. ! ! ! Example: ! ! C DIGIT ! --- ----- ! '0' 0 ! '1' 1 ! ... ... ! '9' 9 ! ' ' 0 ! 'X' -1 ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the decimal digit, '0' through '9' or blank ! are legal. ! ! Output, integer DIGIT, the corresponding integer value. If C was ! 'illegal', then DIGIT is -1. ! implicit none ! character c integer digit ! if ( lge ( c, '0' ) .and. lle ( c, '9' ) ) then digit = ichar ( c ) - 48 else if ( c == ' ' ) then digit = 0 else digit = -1 end if return end subroutine file_name_ext_get ( file_name, i, j ) ! !******************************************************************************* ! !! FILE_NAME_EXT_GET determines the "extension" of a file name. ! ! ! Definition: ! ! The "extension" of a filename is the string of characters ! that appears after the LAST period in the name. A file ! with no period, or with a period as the last character ! in the name, has a "null" extension. ! ! Note: ! ! Blanks are unusual in filenames. This routine ignores all ! trailing blanks, but will treat initial or internal blanks ! as regular characters acceptable in a file name. ! ! Examples: ! ! FILE_NAME I J ! ! bob.for 4 7 ! N.B.C.D 6 7 ! Naomi. 6 6 ! Arthur 0 0 ! .com 1 1 ! ! Modified: ! ! 17 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, a file name to be examined. ! ! Output, integer I, J, the indices of the first and last characters ! in the file extension. ! ! If no period occurs in FILE_NAME, then ! I = J = 0; ! Otherwise, ! I is the position of the LAST period in FILE_NAME, and J is the ! position of the last nonblank character following the period. ! implicit none ! character ( len = * ) file_name integer i integer j integer s_index_last ! i = s_index_last ( file_name, '.' ) if ( i /= 0 ) then j = len_trim ( file_name ) else j = 0 end if return end subroutine file_name_ext_swap ( file_name, ext ) ! !******************************************************************************* ! !! FILE_NAME_EXT_SWAP replaces the current "extension" of a file name. ! ! ! Definition: ! ! The "extension" of a filename is the string of characters ! that appears after the LAST period in the name. A file ! with no period, or with a period as the last character ! in the name, has a "null" extension. ! ! Examples: ! ! Input Output ! ================ ========= ! FILE_NAME EXT FILE_NAME ! ! bob.for obj bob.obj ! bob.bob.bob txt bob.bob.txt ! bob yak bob.yak ! ! Modified: ! ! 09 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) FILE_NAME, a file name. ! On output, the extension of the file has been changed. ! ! Input, character ( len = * ) EXT, the extension to be used on the output ! copy of FILE_NAME, replacing the current extension if any. ! implicit none ! character ( len = * ) ext character ( len = * ) file_name integer i integer j integer len_max integer len_name ! len_max = len ( file_name ) len_name = len_trim ( file_name ) call file_name_ext_get ( file_name, i, j ) if ( i == 0 ) then if ( len_name + 1 > len_max ) then return end if len_name = len_name + 1 file_name(len_name:len_name) = '.' i = len_name + 1 else i = i + 1 file_name(i:j) = ' ' end if file_name(i:) = ext return end subroutine get_unit ( iunit ) ! !******************************************************************************* ! !! GET_UNIT returns a free FORTRAN unit number. ! ! ! Discussion: ! ! A "free" FORTRAN unit number is an integer between 1 and 99 which ! is not currently associated with an I/O device. A free FORTRAN unit ! number is needed in order to open a file with the OPEN command. ! ! Modified: ! ! 02 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IUNIT. ! ! If IUNIT = 0, then no free FORTRAN unit could be found, although ! all 99 units were checked (except for units 5 and 6). ! ! Otherwise, IUNIT is an integer between 1 and 99, representing a ! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 ! are special, and will never return those values. ! implicit none ! integer i integer ios integer iunit logical lopen iunit = 0 do i = 1, 99 if ( i /= 5 .and. i /= 6 ) then inquire ( unit = i, opened = lopen, iostat = ios ) if ( ios == 0 ) then if ( .not. lopen ) then iunit = i return end if end if end if end do return end subroutine process ( filein_unit, fileout_name, ierror ) ! !******************************************************************************* ! !! PROCESS processes the user input. ! ! ! Modified: ! ! 28 September 2001 ! ! Author: ! ! John Burkardt ! ! Parameters ! ! Input, integer FILEIN_UNIT, the unit number associated with the input ! file. This will be 0 in the case of an interactive session, when ! input comes from the user, and not a file. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output ! plot file. ! ! Output, integer IERROR, error flag. ! 0, no error detected, ! nonzero, an error occurred. ! implicit none ! integer, parameter :: maxn = 50 ! real angle real angle_max real angle_min real b logical, save :: debug = .false. integer filein_badlines integer filein_linecount integer filein_unit character ( len = * ) fileout_name integer fileout_unit real g real, save :: hist_fat = 1.0E+00 integer ierror integer ios integer lchar integer lenc character ( len = 80 ) line integer n integer n1 integer n2 real r real r1 real r2 logical s_eqi real theta1 real theta2 character ( len = 80 ) word real :: xmax = 1.0E+00 real :: xmin = 0.0E+00 real xvec(maxn) real x1 real x2 real x3 real :: ymax = 1.0E+00 real :: ymin = 0.0E+00 real yvec(maxn) real y1 real y2 real y3 ! ierror = 0 call get_unit ( fileout_unit ) ! ! Read the next line of input. ! filein_badlines = 0 filein_linecount = 0 do if ( filein_unit > 0 ) then read ( filein_unit, '(a)', iostat = ios ) line else read ( *, '(a)', iostat = ios ) line end if if ( debug ) then write ( *, '(a)' ) trim ( line ) end if if ( ios /= 0 ) then exit end if filein_linecount = filein_linecount + 1 if ( line(1:1) == '#' ) then cycle end if if ( len_trim ( line ) <= 0 ) then cycle end if ! ! Read the first word of the input line. ! call word_extract ( line, word ) ! ! Determine what command the first word represents, read its arguments, ! and write the appropriate instructions to the file. ! if ( s_eqi ( word, 'ARC' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, theta1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, theta2, ierror, lchar ) call ps_circle_arc ( x1, y1, r1, theta1, theta2 ) else if ( s_eqi ( word, 'ARROW' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, x2, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y2, ierror, lchar ) call ps_arrow ( x1, y1, x2, y2 ) else if ( s_eqi ( word, 'CIRCLE' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call ps_circle ( x1, y1, r1 ) else if ( s_eqi ( word, 'CIRCLE_FILL' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call ps_circle_fill ( x1, y1, r1 ) else if ( s_eqi ( word, 'DEBUG' ) ) then debug = .not. debug if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROCESS:' write ( *, '(a)' ) ' Debugging turned on.' else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROCESS:' write ( *, '(a)' ) ' Debugging turned off.' end if else if ( s_eqi ( word, 'ELLIPSE' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r2, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, theta1, ierror, lchar ) n = maxn call ellipse_points ( x1, y1, r1, r2, theta1, n, xvec, yvec ) call ps_line_closed ( n, xvec, yvec ) else if ( s_eqi ( word, 'ELLIPSE_FILL' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r2, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, theta1, ierror, lchar ) n = maxn call ellipse_points ( x1, y1, r1, r2, theta1, n, xvec, yvec ) call ps_polygon_fill ( n, xvec, yvec ) else if ( s_eqi ( word, 'ENDFILE' ) .or. s_eqi ( word, 'END_FILE' ) ) then call ps_file_tail call ps_file_close ( fileout_unit ) else if ( s_eqi ( word, 'ENDPAGE' ) .or. s_eqi ( word, 'END_PAGE' ) ) then call ps_page_tail else if ( s_eqi ( word, 'FILE' ) ) then if ( fileout_name == ' ' ) then call word_extract ( line, word ) if ( word /= ' ' ) then fileout_name = word else fileout_name = 'plot_to_ps.ps' end if end if call get_unit ( fileout_unit ) call ps_file_open ( fileout_name, fileout_unit, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROCESS' write ( *, '(a,i6)' ) ' File creation error ', ierror return end if else if ( s_eqi ( word, 'FILL_GRAY' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call ps_fill_gray ( x1 ) else if ( s_eqi ( word, 'FILL_RGB' ) ) then call word_extract ( line, word ) call s_to_r ( word, r, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, g, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, b, ierror, lchar ) call ps_color_fill_set ( r, g, b ) else if ( s_eqi ( word, 'FONT_SIZE' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call ps_font_size ( x1 ) else if ( s_eqi ( word, 'GRID' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, x2, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y2, ierror, lchar ) call word_extract ( line, word ) call s_to_i ( word, n1, ierror, lchar ) call word_extract ( line, word ) call s_to_i ( word, n2, ierror, lchar ) call ps_grid_cartesian ( x1, x2, n1, y1, y2, n2 ) else if ( s_eqi ( word, 'HIST_FAT' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) hist_fat = x1 else if ( s_eqi ( word, 'HISTOGRAM' ) ) then call process_histogram ( filein_linecount, filein_unit, hist_fat, & ierror ) else if ( s_eqi ( word, 'LABEL' ) ) then call ps_label ( line ) else if ( s_eqi ( word, 'LABEL_SLANT' ) ) then call word_extract ( line, word ) call s_to_r ( word, angle, ierror, lchar ) call ps_label_slant ( line, angle ) else if ( s_eqi ( word, 'LINE' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, x2, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y2, ierror, lchar ) call ps_moveto ( x1, y1 ) call ps_lineto ( x2, y2 ) else if ( s_eqi ( word, 'LINE_GRAY' ) ) then call word_extract ( line, word ) call s_to_r ( word, r, ierror, lchar ) g = r b = r call ps_color_line_set ( r, g, b ) else if ( s_eqi ( word, 'LINE_RGB' ) ) then call word_extract ( line, word ) call s_to_r ( word, r, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, g, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, b, ierror, lchar ) call ps_color_line_set ( r, g, b ) else if ( s_eqi ( word, 'LINE_WIDTH' ) .or. & s_eqi ( word, 'LINEWIDTH' ) .or. & s_eqi ( word, 'LINE_THICK' ) .or. & s_eqi ( word, 'LINETHICK' ) ) then call word_extract ( line, word ) call s_to_i ( word, n1, ierror, lchar ) call ps_line_width ( n1 ) else if ( s_eqi ( word, 'LINETO' ) .or. & s_eqi ( word, 'DRAWTO' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call ps_lineto ( x1, y1 ) else if ( s_eqi ( word, 'MOVE' ) .or. & s_eqi ( word, 'MOVETO' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call ps_moveto ( x1, y1 ) else if ( s_eqi ( word, 'PAGE' ) ) then call ps_page_head ( xmin, ymin, xmax, ymax ) else if ( s_eqi ( word, 'POINT' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call ps_mark_circle ( x1, y1 ) else if ( s_eqi ( word, 'POINT_LIST' ) ) then do if ( filein_unit > 0 ) then read ( filein_unit, '(a)', iostat = ios ) line else read ( *, '(a)', iostat = ios ) line end if if ( ios /= 0 ) then exit end if filein_linecount = filein_linecount + 1 if ( line(1:1) == '#' ) then cycle end if if ( len_trim ( line ) <= 0 ) then cycle end if call word_extract ( line, word ) if ( s_eqi ( word, 'POINT_LIST_END' ) ) then exit end if call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call ps_mark_circle ( x1, y1 ) end do else if ( s_eqi ( word, 'POLYGON' ) ) then call process_polygon ( filein_linecount, filein_unit, ierror, MAXN, & xvec, yvec ) else if ( s_eqi ( word, 'SECTOR' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, angle_min, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, angle_max, ierror, lchar ) call ps_sector ( x1, y1, r1, angle_min, angle_max ) else if ( s_eqi ( word, 'SECTOR_FILL' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, angle_min, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, angle_max, ierror, lchar ) call ps_sector_fill ( x1, y1, r1, angle_min, angle_max ) else if ( s_eqi ( word, 'SPACE' ) ) then if ( debug ) then write ( *, '(a)' ) 'Begin processing the SPACE command.' end if call word_extract ( line, word ) call s_to_r ( word, xmin, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, ymin, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, xmax, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, ymax, ierror, lchar ) call ps_file_head ( fileout_name ) else if ( s_eqi ( word, 'SQUARE' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call ps_square ( x1, y1, r1 ) else if ( s_eqi ( word, 'SQUARE_FILL' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call ps_square_fill ( x1, y1, r1 ) else if ( s_eqi ( word, 'STAR' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call ps_star ( x1, y1, r1 ) else if ( s_eqi ( word, 'STAR_CIRCLE' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call ps_star_circle ( x1, y1, r1 ) else if ( s_eqi ( word, 'STAR_DISK' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, r1, ierror, lchar ) call ps_star_disk ( x1, y1, r1 ) else if ( s_eqi ( word, 'TRIANGLE' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, x2, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y2, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, x3, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y3, ierror, lchar ) call ps_triangle ( x1, y1, x2, y2, x3, y3 ) else if ( s_eqi ( word, 'TRIANGLE_FILL' ) ) then call word_extract ( line, word ) call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, x2, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y2, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, x3, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y3, ierror, lchar ) call ps_triangle_fill ( x1, y1, x2, y2, x3, y3 ) else if ( debug ) then lenc = len_trim ( line ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROCESS - DEBUG:' write ( *, '(a)' ) trim ( line ) end if filein_badlines = filein_badlines + 1 end if end do if ( filein_badlines > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROCESS - Warning:' write ( *, '(a,i6)' ) ' Number of input lines: ', filein_linecount write ( *, '(a,i6)' ) ' Number of BAD input lines: ', filein_badlines end if return end subroutine process_histogram ( filein_linecount, filein_unit, hist_fat, & ierror ) ! !******************************************************************************* ! !! PROCESS_HISTOGRAM processes the input defining a histogram. ! ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters ! ! Input/output, integer FILEIN_LINECOUNT, the number of lines of ! input that were read. ! ! Input, integer FILEIN_UNIT, the unit number associated with the input ! file. This will be 0 in the case of an interactive session, when ! input comes from the user, and not a file. ! ! Input, real HIST_FAT, the width of each histogram bar. ! ! Output, integer IERROR, error flag. ! 0, no error detected, ! nonzero, an error occurred. ! implicit none ! integer, parameter :: maxpoly = 4 ! integer filein_linecount integer filein_unit real hist_fat integer ierror integer ios integer lchar integer lenc character ( len = 80 ) line integer npoly logical s_eqi character ( len = 80 ) word real xvec(maxpoly) real x1 real yvec(maxpoly) real y1 real y1_old ! ierror = 0 y1_old = 0.0E+00 ! ! Read the next line of input. ! do if ( filein_unit > 0 ) then read ( filein_unit, '(a)', iostat = ios ) line else read ( *, '(a)', iostat = ios ) line end if if ( ios /= 0 ) then exit end if filein_linecount = filein_linecount + 1 if ( line(1:1) == '#' ) then cycle end if lenc = len_trim ( line ) if ( len_trim ( line ) <= 0 ) then cycle end if ! ! Read the first word of the input line. ! call word_extract ( line, word ) if ( s_eqi ( word(1:3), 'END' ) ) then ! ! if fill color reversed, reverse it again. ! return end if call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) if ( y1 /= 0.0E+00 ) then xvec(1) = x1 - 0.5E+00 * hist_fat yvec(1) = 0.0E+00 xvec(2) = x1 - 0.5E+00 * hist_fat yvec(2) = y1 xvec(3) = x1 + 0.5E+00 * hist_fat yvec(3) = y1 xvec(4) = x1 + 0.5E+00 * hist_fat yvec(4) = 0.0E+00 if ( y1_old <= 0.0E+00 .and. y1 > 0.0E+00 ) then ! !...set fill color ! else if ( y1_old >= 0.0E+00 .and. y1 < 0.0E+00 ) then ! !..set fill color ! end if npoly = 4 call ps_polygon_fill ( npoly, xvec, yvec ) call ps_line_closed ( npoly, xvec, yvec ) y1_old = y1 end if end do ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROCESS_HISTOGRAM - Fatal error!' write ( *, '(a)' ) ' Unexpected end of input.' return end subroutine process_polygon ( filein_linecount, filein_unit, ierror, MAXN, & xvec, yvec ) ! !******************************************************************************* ! !! PROCESS_POLYGON processes the input defining a polygon. ! ! ! Modified: ! ! 18 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters ! ! Input/output, integer FILEIN_LINECOUNT, the number of lines of ! input that were read. ! ! Input, integer FILEIN_UNIT, the unit number associated with the input ! file. This will be 0 in the case of an interactive session, when ! input comes from the user, and not a file. ! ! Output, integer IERROR, error flag. ! 0, no error detected, ! nonzero, an error occurred. ! implicit none ! integer MAXN ! integer filein_linecount integer filein_unit integer ierror integer ios integer lchar integer lenc character ( len = 80 ) line integer npoly logical s_eqi character ( len = 80 ) word real xvec(MAXN) real x1 real yvec(MAXN) real y1 ! ierror = 0 npoly = 0 ! ! Read the next line of input. ! do if ( filein_unit > 0 ) then read ( filein_unit, '(a)', iostat = ios ) line else read ( *, '(a)', iostat = ios ) line end if if ( ios /= 0 ) then exit end if filein_linecount = filein_linecount + 1 if ( line(1:1) == '#' ) then cycle end if if ( len_trim ( line ) <= 0 ) then cycle end if ! ! Read the first word of the input line. ! call word_extract ( line, word ) if ( s_eqi ( word, 'ENDPOLYGON' ) .or. s_eqi ( word, 'END_POLYGON' ) ) then npoly = min ( npoly, MAXN ) if ( npoly >= 3 ) then call ps_polygon_fill ( npoly, xvec, yvec ) end if return end if call s_to_r ( word, x1, ierror, lchar ) call word_extract ( line, word ) call s_to_r ( word, y1, ierror, lchar ) npoly = npoly + 1 if ( npoly <= MAXN ) then xvec(npoly) = x1 yvec(npoly) = y1 end if end do ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROCESS_POLYGON - Fatal error!' write ( *, '(a)' ) ' Unexpected end of input.' return end function s_eqi ( strng1, strng2 ) ! !******************************************************************************* ! !! S_EQI is a case insensitive comparison of two strings for equality. ! ! ! Examples: ! ! S_EQI ( 'Anjana', 'ANJANA' ) is .TRUE. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRNG1, STRNG2, the strings to compare. ! ! Output, logical S_EQI, the result of the comparison. ! implicit none ! integer i integer len1 integer len2 integer lenc logical s_eqi character s1 character s2 character ( len = * ) strng1 character ( len = * ) strng2 ! len1 = len ( strng1 ) len2 = len ( strng2 ) lenc = min ( len1, len2 ) s_eqi = .false. do i = 1, lenc s1 = strng1(i:i) s2 = strng2(i:i) call ch_cap ( s1 ) call ch_cap ( s2 ) if ( s1 /= s2 ) then return end if end do do i = lenc + 1, len1 if ( strng1(i:i) /= ' ' ) then return end if end do do i = lenc + 1, len2 if ( strng2(i:i) /= ' ' ) then return end if end do s_eqi = .true. return end function s_index_last ( s, sub ) ! !******************************************************************************* ! !! S_INDEX_LAST finds the LAST occurrence of a given substring. ! ! ! Discussion: ! ! It returns the location in the string at which the substring SUB is ! first found, or 0 if the substring does not occur at all. ! ! The routine is also trailing blank insensitive. This is very ! important for those cases where you have stored information in ! larger variables. If S is of length 80, and SUB is of ! length 80, then if S = 'FRED' and SUB = 'RED', a match would ! not be reported by the standard FORTRAN INDEX, because it treats ! both variables as being 80 characters long! This routine assumes that ! trailing blanks represent garbage! ! ! This means that this routine cannot be used to find, say, the last ! occurrence of a substring 'A ', since it assumes the blank space ! was not specified by the user, but is, rather, padding by the ! system. However, as a special case, this routine can properly handle ! the case where either S or SUB is all blanks. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be searched. ! ! Input, character ( len = * ) SUB, the substring to search for. ! ! Output, integer S_INDEX_LAST. 0 if SUB does not occur in ! the string. Otherwise S_INDEX_LAST = I, where S(I:I+LENS-1) = SUB, ! where LENS is the length of SUB, and is the last place ! this happens. ! implicit none ! integer i integer j integer llen1 integer llen2 character ( len = * ) s integer s_index_last character ( len = * ) sub ! s_index_last = 0 llen1 = len_trim ( s ) llen2 = len_trim ( sub ) ! ! In case S or SUB is blanks, use LEN ! if ( llen1 == 0 ) then llen1 = len ( s ) end if if ( llen2 == 0 ) then llen2 = len ( sub ) end if if ( llen2 > llen1 ) then return end if do j = 1, llen1+1-llen2 i = llen1 + 2 - llen2 - j if ( s(i:i+llen2-1) == sub ) then s_index_last = i return end if end do return end subroutine s_to_i ( s, ival, ierror, last ) ! !******************************************************************************* ! !! S_TO_I reads an integer value from a string. ! ! ! Modified: ! ! 28 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string to be examined. ! ! Output, integer IVAL, the integer value read from the string. ! If STRING is blank, then IVAL will be returned 0. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, an error occurred. ! ! Output, integer LAST, the last character of S used to make IVAL. ! implicit none ! character c integer i integer ierror integer isgn integer istate integer ival integer last character ( len = * ) s ! ierror = 0 istate = 0 isgn = 1 ival = 0 do i = 1, len_trim ( s ) c = s(i:i) ! ! Haven't read anything. ! if ( istate == 0 ) then if ( c == ' ' ) then else if ( c == '-' ) then istate = 1 isgn = -1 else if ( c == '+' ) then istate = 1 isgn = + 1 else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if ! ! Have read the sign, expecting digits. ! else if ( istate == 1 ) then if ( c == ' ' ) then else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if ! ! Have read at least one digit, expecting more. ! else if ( istate == 2 ) then if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then ival = 10 * ival + ichar ( c ) - ichar ( '0' ) else ival = isgn * ival last = i - 1 return end if end if end do ! ! If we read all the characters in the string, see if we're OK. ! if ( istate == 2 ) then ival = isgn * ival last = len_trim ( s ) else ierror = 1 last = 0 end if return end subroutine s_to_r ( s, r, ierror, lchar ) ! !******************************************************************************* ! !! S_TO_R reads a real number from a string. ! ! ! Discussion: ! ! This routine will read as many characters as possible until it reaches ! the end of the string, or encounters a character which cannot be ! part of the real number. ! ! Legal input is: ! ! 1 blanks, ! 2 '+' or '-' sign, ! 2.5 spaces ! 3 integer part, ! 4 decimal point, ! 5 fraction part, ! 6 'E' or 'e' or 'D' or 'd', exponent marker, ! 7 exponent sign, ! 8 exponent integer part, ! 9 exponent decimal point, ! 10 exponent fraction part, ! 11 blanks, ! 12 final comma or semicolon. ! ! with most quantities optional. ! ! Examples: ! ! S R ! ! '1' 1.0 ! ' 1 ' 1.0 ! '1A' 1.0 ! '12,34,56' 12.0 ! ' 34 7' 34.0 ! '-1E2ABCD' -100.0 ! '-1X2ABCD' -1.0 ! ' 2E-1' 0.2 ! '23.45' 23.45 ! '-4.2E+2' -420.0 ! '17d2' 1700.0 ! '-14e-2' -0.14 ! 'e2' 100.0 ! '-12.73e-9.23' -12.73 * 10.0**(-9.23) ! ! Modified: ! ! 12 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate at the end of the string, or when no more ! characters can be read to form a legal real. Blanks, ! commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! Output, real R, the real value that was read from the string. ! ! Output, integer IERROR, error flag. ! ! 0, no errors occurred. ! ! 1, 2, 6 or 7, the input number was garbled. The ! value of IERROR is the last type of input successfully ! read. For instance, 1 means initial blanks, 2 means ! a plus or minus sign, and so on. ! ! Output, integer LCHAR, the number of characters read from ! the string to form the number, including any terminating ! characters such as a trailing comma or blanks. ! implicit none ! logical ch_eqi character c integer ierror integer ihave integer isgn integer iterm integer jbot integer jsgn integer jtop integer lchar integer nchar integer ndig real r real rbot real rexp real rtop character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! nchar = len_trim ( s ) ierror = 0 r = 0.0E+00 lchar = - 1 isgn = 1 rtop = 0.0E+00 rbot = 1.0E+00 jsgn = 1 jtop = 0 jbot = 1 ihave = 1 iterm = 0 do lchar = lchar + 1 c = s(lchar+1:lchar+1) ! ! Blank or TAB character. ! if ( c == ' ' .or. c == TAB ) then if ( ihave == 2 ) then else if ( ihave == 6 .or. ihave == 7 ) then iterm = 1 else if ( ihave > 1 ) then ihave = 11 end if ! ! Comma. ! else if ( c == ',' .or. c == ';' ) then if ( ihave /= 1 ) then iterm = 1 ihave = 12 lchar = lchar + 1 end if ! ! Minus sign. ! else if ( c == '-' ) then if ( ihave == 1 ) then ihave = 2 isgn = - 1 else if ( ihave == 6 ) then ihave = 7 jsgn = - 1 else iterm = 1 end if ! ! Plus sign. ! else if ( c == '+' ) then if ( ihave == 1 ) then ihave = 2 else if ( ihave == 6 ) then ihave = 7 else iterm = 1 end if ! ! Decimal point. ! else if ( c == '.' ) then if ( ihave < 4 ) then ihave = 4 else if ( ihave >= 6 .and. ihave <= 8 ) then ihave = 9 else iterm = 1 end if ! ! Exponent marker. ! else if ( ch_eqi ( c, 'E' ) .or. ch_eqi ( c, 'D' ) ) then if ( ihave < 6 ) then ihave = 6 else iterm = 1 end if ! ! Digit. ! else if ( ihave < 11 .and. lge ( c, '0' ) .and. lle ( c, '9' ) ) then if ( ihave <= 2 ) then ihave = 3 else if ( ihave == 4 ) then ihave = 5 else if ( ihave == 6 .or. ihave == 7 ) then ihave = 8 else if ( ihave == 9 ) then ihave = 10 end if call ch_to_digit ( c, ndig ) if ( ihave == 3 ) then rtop = 10.0E+00 * rtop + real ( ndig ) else if ( ihave == 5 ) then rtop = 10.0E+00 * rtop + real ( ndig ) rbot = 10.0E+00 * rbot else if ( ihave == 8 ) then jtop = 10 * jtop + ndig else if ( ihave == 10 ) then jtop = 10 * jtop + ndig jbot = 10 * jbot end if ! ! Anything else is regarded as a terminator. ! else iterm = 1 end if ! ! If we haven't seen a terminator, and we haven't examined the ! entire string, go get the next character. ! if ( iterm == 1 .or. lchar+1 >= nchar ) then exit end if end do ! ! If we haven't seen a terminator, and we have examined the ! entire string, then we're done, and LCHAR is equal to NCHAR. ! if ( iterm /= 1 .and. lchar+1 == nchar ) then lchar = nchar end if ! ! Number seems to have terminated. Have we got a legal number? ! Not if we terminated in states 1, 2, 6 or 7! ! if ( ihave == 1 .or. ihave == 2 .or. ihave == 6 .or. ihave == 7 ) then ierror = ihave return end if ! ! Number seems OK. Form it. ! if ( jtop == 0 ) then rexp = 1.0E+00 else if ( jbot == 1 ) then rexp = 10.0E+00**( jsgn * jtop ) else rexp = jsgn * jtop rexp = rexp / jbot rexp = 10.0E+00**rexp end if end if r = isgn * rexp * rtop / rbot return end subroutine word_extract ( s, w ) ! !******************************************************************************* ! !! WORD_EXTRACT extracts the next word from a string. ! ! ! Discussion: ! ! A "word" is a string of characters terminated by a blank or ! the end of the string. ! ! Modified: ! ! 31 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string. On output, the first ! word has been removed, and the remaining string has been shifted left. ! ! Output, character ( len = * ) W, the leading word of the string. ! implicit none ! integer iget1 integer iget2 integer lchar character ( len = * ) s character ( len = * ) w ! w = ' ' lchar = len_trim ( s ) ! ! Find the first nonblank. ! iget1 = 0 do iget1 = iget1 + 1 if ( iget1 > lchar ) then return end if if ( s(iget1:iget1) /= ' ' ) then exit end if end do ! ! Look for the last contiguous nonblank. ! iget2 = iget1 do if ( iget2 >= lchar ) then exit end if if ( s(iget2+1:iget2+1) == ' ' ) then exit end if iget2 = iget2 + 1 end do ! ! Copy the word. ! w = s(iget1:iget2) ! ! Shift the string. ! s(1:iget2) = ' ' s = adjustl ( s(iget2+1:) ) return end