! To do: ! 2) integrate logerithms and other axis options. !+ ! Module quick_plot ! ! Module that defines the QUICK_PLOT graphics plotting routines. ! These routines use the PGPLOT graphics suroutine library. ! To tell the difference: QUICK_PLOT subroutines start with "QP_" ! PGPLOT routines start with "PG" and do not have any "_". ! !-------------------------------------------------------------------- ! ! QUICK_PLOT uses the following concepts: ! PAGE -- The entire drawing serface. ! BOX -- The area that the graph with axes, titles, etc. is placed into. ! GRAPH -- The actual plotting area within the bounds of the axes. ! ! The correspondence between this and PGPLOT is: ! QUICK_PLOT PGPLOT ! ---------- ------ ! PAGE VIEW SURFACE ! BOX No corresponding entity. ! GRAPH VIEWPORT and WINDOW ! ! Essentially the VIEWPORT is the region outside of which lines and symbols ! will be clipped (if clipping is turned on) and the WINDOW defines the ! plot area. I'm not sure why PGPLOT makes a distingtion but VIEWPORT and ! WINDOW always are the same region. ! !-------------------------------------------------------------------- ! ! To set the defaults used for optional arguments use the routines: ! qp_set_line_attrib ! gp set_symbol_attrib ! qp_set_text_attrib ! !-------------------------------------------------------------------- ! ! A "justify" argumnet is a character string with 2 characters. ! The first character gives the horizontal justification: ! 'L' -- Left justify ! 'C' -- Center justify ! 'R' -- Right justify ! The second character gives the vertical justification ! 'B' -- Bottom justify ! 'C' -- Center justify ! 'T' -- Top justify ! !-------------------------------------------------------------------- ! ! The "units" argument in GP routines is a character string which is divided ! up into three parts. The syntax of the string is: ! 'unit_type/ref_object/corner' ! Where ! unit_type -- Type of units: ! '%' - Percent. ! 'DATA' - Data units. (Draw default) ! 'MM' - milimeters. ! 'INCH' - Inches. (Set default) ! 'POINTS' - Printers points (72 points = 1 inch, 1pt ~ 1pixel). ! ! ref_object -- Reference object (optional except if unit_type = "%"). ! 'PAGE' - Relative to the page (Set default). ! 'BOX' - Relative to the box. ! 'GRAPH' - Relative to the graph (Draw default). ! ! corner -- Origin location (optional). ! 'LB' -- Left Bottom (Set and Draw default). ! 'LT' -- Left Top. ! 'RB' -- Right Bottom. ! 'RT' -- Right Top. ! ! Notes: ! 1) The DATA unit type, by definition, is always referenced to the ! lower left corner of the GRAPH. ! 2) For the '%" unit_type the '/' between unit_type and ref_object ! can be omitted. ! 3) If the corner is specified then the ref_opject but appear also. ! 4) Everything must be in upper case. ! 5) For some routines (qp_set_margin, etc.) only a relative distance is ! needed. In this case the ref_object/corner part, if present, is ignored. ! 6) There are two defaults: One for drawing and another for setting ! margins, etc. Initially the draw default is 'DATA/GRAPH/LB' and the ! set default is 'INCH/PAGE/LB'. use qp_set_default to change this. ! ! ! Examples: ! 'DATA' -- This is the draw default. ! 'DATA/GRAPH/LB' -- Same as above. ! 'DATA/BOX/RT' -- ILLEGAL: DATA must always go with GRAPH/LB. ! '%PAGE/LT' -- Percentage of page so (0.0, 1.0) = RT of page. ! '%BOX' -- Percentage of box so (1.0, 1.0) = RT of box. ! 'INCH/PAGE' -- Inches from LB of page. ! !-------------------------------------------------------------------- ! ! The line styles: ! 1 - solid$ Solid ! 2 - dashed$ Dashed ! 3 - dash_dot$ Dash dot ! 4 - dotted$ Dotted ! 5 - dash_dot3$ Dash dot dot dot ! !-------------------------------------------------------------------- ! ! The colors in PGPLOT are: ! 0 - White$ (actually the background color) ! 1 - Black$ (actually the foreground color) ! 2 - Red$ ! 3 - Green$ ! 4 - Blue$ ! 5 - Cyan$ ! 6 - Magenta$ ! 7 - Yellow$ ! 8 - Orange$ ! 9 - Yellow_Green$ ! 10 - Light_Green$ ! 11 - Navy_Blue$ ! 12 - Purple$ ! 13 - Redish_Purple$ ! 14 - Dark_Grey$ ! 15 - Light_Grey$ ! !-------------------------------------------------------------------- ! ! The fill styles are: ! 1 - solid_fill$ ! 2 - no_fill$ ! 3 - hatched$ ! 4 - cross_hatched$ ! !-------------------------------------------------------------------- ! ! The symbols are: ! 0 - square$ ! 1 - dot$ ! 2 - plus$ ! 3 - times$ ! 4 - circle$ ! 5 - x_symbol$ ! 7 - triangle$ ! 8 - circle_plus$ ! 9 - circle_dot$ ! 10 - square_concave$ ! 11 - diamond$ ! 12 - star5$ ! 13 - triangle_filled$ ! 14 - red_cross$ ! 15 - star_of_david$ ! 16 - square_filled$ ! 17 - circle_filled$ ! 18 - star5_filled$ ! !-------------------------------------------------------------------- ! ! The following are the symbol types: ! -3 ... -31 - a regular polygon with abs(type) edges. ! -2 - Same as -1. ! -1 - Dot with diameter = current line width. ! 0 ... 31 - Standard marker symbols. ! 32 ... 127 - ASCII characters (in current font). ! E.G. to use letter F as a marker, set type = ICHAR('F'). ! > 127 - A Hershey symbol number. ! !-------------------------------------------------------------------- ! ! The text background index is: ! -1 - Transparent background. ! 0 - Erase underlying graphics beforedrawing text. ! 1 to 255 - Opaque with the number specifying the color index. ! !-------------------------------------------------------------------- ! ! Notes: ! 1) PGPLOT uses real(4) units, QUICK_PLOT tries to interface between ! real(4) and real(rp). Watch out for mixed units in subroutines. !- module quick_plot use precision_def use physical_constants use dcslib_interface !------------------------------------ integer, parameter :: White$ = 0, Black$ = 1, Red$ = 2, Green$ = 3 integer, parameter :: Blue$ = 4, Cyan$ = 5, Magenta$ = 6, Yellow$ = 7 integer, parameter :: Orange$ = 8, Yellow_Green$ = 9, Light_Green$ = 10 integer, parameter :: Navy_Blue$ = 11, Purple$ = 12, Redish_Purple$ = 13 integer, parameter :: Dark_Grey$ = 14, Light_Grey$ = 15 Character(16) :: qp_color_name(0:15) = (/ 'White ', & 'Black ', 'Red ', 'Green ', 'Blue ', & 'Cyan ', 'Magenta ', 'Yellow ', 'Orange ', & 'Yellow_Green ', 'Light_Green ', 'Navy_Blue ', 'Purple ', & 'Redish_Purple', 'Dark_Grey ', 'Light_Grey ' /) integer, parameter :: solid$ = 1, dashed$ = 2, dash_dot$ = 3 integer, parameter :: dotted$ = 4, dash_dot3$ = 5 integer, parameter :: solid_fill$ = 1, no_fill$ = 2 integer, parameter :: hatched$ = 3, cross_hatched$ = 4 integer, parameter :: square$ = 0, dot$ = 1, plus$ = 2, times$ = 3 integer, parameter :: circle$ = 4, x_symbol$ = 5, triangle$ = 7 integer, parameter :: circle_plus$ = 8, circle_dot$ = 9 integer, parameter :: square_concave$ = 10, diamond$ = 11 integer, parameter :: star5$ = 12, triangle_filled$ = 13, red_cross$ = 14 integer, parameter :: star_of_david$ = 15, square_filled$ = 16 integer, parameter :: circle_filled$ = 17, star5_filled$ = 18 integer, parameter :: dflt_draw$ = 1, dflt_set$ = 2 !------------------------------------ type qp_axis_struct character(80) :: label = ' ' type (qp_axis_struct), pointer :: mirror ! other side real(rp) :: min = 0, max = 10 real(rp) :: number_offset = 0.05 ! offset from axis line in inches. real(rp) :: label_offset = 0.05 ! offset from numbers in inches. real(rp) :: major_tick_len = 0.10 ! in inches. real(rp) :: minor_tick_len = 0.06 ! in inches. integer :: major_div = 5 integer :: minor_div = 0 ! 0 = auto choose. integer :: minor_div_max = 5 ! max number for auto choose. integer :: places = 0 character(16) :: type = 'LINEAR' ! 'LOG', 'CUSTOM' integer :: tick_side = +1 ! +1 = up or right, 0 = both, -1 = down or left. integer :: number_side = -1 logical :: draw_label = .true. logical :: draw_numbers = .true. logical :: mirror_on = .false. end type type qp_plot_struct character(80) :: title = ' ' type (qp_axis_struct) x, y, x2, y2 logical :: draw_box = .true. logical :: draw_title = .true. logical :: draw_grid = .true. logical limit_plot end type type qp_rect_struct ! or for graphs real(rp) x1, x2, y1, y2 ! coords of rectangle in inches endtype type qp_text_struct real(rp) height ! in points integer color logical uniform_spacing end type type qp_line_struct integer :: width = 1 integer :: color = black$ integer :: style = solid$ end type type qp_symbol_struct integer :: type = circle_dot$ real(rp) :: height = 6.0 ! in points (same as text height) integer :: color = black$ integer :: fill = solid_fill$ integer :: line_width = 1 end type type qp_struct type (qp_plot_struct) plot type (qp_rect_struct) :: page type (qp_rect_struct) :: box = qp_rect_struct (1.0, 2.0, 1.0, 2.0) type (qp_rect_struct) :: graph = qp_rect_struct (1.0, 2.0, 1.0, 2.0) type (qp_rect_struct) :: margin = qp_rect_struct (0.0, 0.0, 0.0, 0.0) type (qp_rect_struct) :: border = qp_rect_struct (0.0, 0.0, 0.0, 0.0) type (qp_text_struct) :: main_title = qp_text_struct(18.0, black$, .false.) type (qp_text_struct) :: graph_title= qp_text_struct(20.0, black$, .false.) type (qp_text_struct) :: legend = qp_text_struct(13.0, black$, .false.) type (qp_text_struct) :: text = qp_text_struct(18.0, black$, .false.) type (qp_text_struct) :: axis_number= qp_text_struct(10.0, black$, .false.) type (qp_text_struct) :: axis_label = qp_text_struct(15.0, black$, .false.) type (qp_text_struct) :: this_text ! current settings. type (qp_symbol_struct) :: symbol type (qp_line_struct) :: std_line = qp_line_struct (2, black$, solid$) type (qp_line_struct) :: plot_line = qp_line_struct (2, black$, solid$) type (qp_line_struct) :: axis_line = qp_line_struct (2, black$, solid$) type (qp_line_struct) :: grid_line = qp_line_struct(1, light_grey$, solid$) real(rp) text_height_factor ! pgplot text height units / points real(rp) :: text_spacing_factor = 0.6 integer :: text_background = -1 logical :: subgraph_on = .false. logical :: clip = .false. logical :: buffer = .false. ! to be used by qp_save_state only logical :: uniform_symbol_size = .true. character(16) page_type ! 'PS', 'X', etc. character(8) :: dflt_draw_units(3) = (/ 'DATA ', 'GRAPH', 'LB ' /) character(8) :: dflt_set_units(3) = (/ 'INCH ', 'PAGE ', 'LB ' /) integer :: dflt_units = dflt_draw$ end type !--------------------------------------------------------------------------- ! common block ! GENERAL NOTE: qp_com is made private so that you cannot change it directly. ! This was done since the layout of qp_com can change. type (qp_struct), target, save :: qp_com type (qp_struct), save :: qp_save_com(10) integer :: i_save_com = 0 logical :: quick_init_needed = .true. private qp_save_com, i_save_com, quick_init_needed, qp_com contains !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_get_layout_attrib (who, x1, x2, y1, y2, units) ! ! Subroutine to get the attributes of the layout. ! ! Input: ! who -- Character(*): ! "PAGE" = Page size. In this case x1 and y1 are 0. ! "BOX" = Placement of the box on the page. ! "GRAPH" = Placement of the Graph on the page. ! "MARGIN" = Distances between the edges of the graph and ! edges of the box. ! "BORDER" = Distances between the edges of the page and the ! area where boxes are placed. ! units -- Character(*), optional: Units of returned numbers. ! Default is "INCH" ! ! Output: ! x1 -- Real(rp): Left distance. ! x2 -- Real(rp): Right distance or page width. ! y1 -- Real(rp): Bottom distance. ! y2 -- Real(rp): Top distance or page height. !- subroutine qp_get_layout_attrib (who, x1, x2, y1, y2, units) implicit none type (qp_rect_struct) rect real(rp) x1, x2, y1, y2 character(*) who character(*), optional :: units ! if (who == 'PAGE') then rect = qp_com%page elseif (who == 'BOX') then rect = qp_com%box elseif (who == 'GRAPH') then rect = qp_com%graph elseif (who == 'MARIGN') then rect = qp_com%margin elseif (who == 'BORDER') then rect = qp_com%border else print *, 'ERROR IN QP_GET_LAYOUT_ATTRIB: BAD "WHO": ', who call err_exit endif qp_com%dflt_units = dflt_set$ call qp_from_inch_abs (rect%x1, rect%y1, x1, y1, units) call qp_from_inch_abs (rect%x2, rect%y2, x2, y2, units) qp_com%dflt_units = dflt_draw$ end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_set_default (default_draw_units, default_set_units) ! ! Subroutine to set the default units for drawing and setting. ! ! Input: ! default_draw_units -- Character(*), optional: Initial default is: ! 'DATA/GRAPH/LB' ! default_set_units -- Character(*), optional: Initial default is: ! 'INCH/PAGE/LB' !- subroutine qp_set_default (default_draw_units, default_set_units) implicit none character(*), optional :: default_draw_units, default_set_units ! qp_com%dflt_units = dflt_set$ call qp_split_units_string (qp_com%dflt_set_units(1), & qp_com%dflt_set_units(2), qp_com%dflt_set_units(3), default_set_units) qp_com%dflt_units = dflt_draw$ call qp_split_units_string (qp_com%dflt_draw_units(1), & qp_com%dflt_draw_units(2), qp_com%dflt_draw_units(3), default_draw_units) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_init_struct (qp) ! ! Subroutine to initialize the qp_struct. ! ! Output: ! qp -- qp_struct: Initialized structure !- subroutine qp_init_struct (qp) implicit none type (qp_struct) qp ! call qp_set_pointers (qp) qp%plot%x2%number_side = +1 qp%plot%x2%tick_side = -1 qp%plot%x2%draw_numbers = .false. qp%plot%x2%mirror_on = .true. qp%plot%y2 = qp%plot%x2 quick_init_needed = .false. end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_set_pointers (qp) ! ! Subroutine to set the pointers correctly ! ! Output: ! qp -- qp_struct: structure with pointers corrected !- subroutine qp_set_pointers (qp) implicit none type (qp_struct) qp qp_com%plot%x%mirror => qp_com%plot%x2 qp_com%plot%y%mirror => qp_com%plot%y2 qp_com%plot%x2%mirror => qp_com%plot%x qp_com%plot%y2%mirror => qp_com%plot%y end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_equal_qp (qp1, qp2) ! ! Subroutine to set qp1 = qp2. ! ! Input: ! qp2 -- Qp_struct: ! ! Output: ! qp1 -- Qp_struct: !- subroutine qp_equal_qp (qp1, qp2) implicit none type (qp_struct), intent(out) :: qp1 type (qp_struct), intent(in) :: qp2 ! qp1 = qp2 call qp_set_pointers (qp1) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_save_state (buffer) ! ! Subroutine to save the current attributes. ! Use qp_restore_state to reastore the saved state. ! Note: Buffering can make things go faster but with buffering the display ! will not be updated until you call qp_restore_state. ! ! Input: ! buffer -- Logical: If True then buffer PGPLOT commands. !- subroutine qp_save_state (buffer) implicit none logical buffer ! i_save_com = i_save_com + 1 if (i_save_com > size(qp_save_com)) then print *, 'ERROR IN QP_SAVE_STATE: TRYING TO SAVE TOO MANY STATES!' call err_exit endif if (buffer) call pgbbuf ! buffer commands qp_com%buffer = buffer call qp_equal_qp (qp_save_com(i_save_com), qp_com) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_restore_state ! ! Subroutine to restore saved attributes. ! Use qp_save_state to reastore the saved state. !- subroutine qp_restore_state implicit none if (i_save_com < 1) then print *, 'ERROR IN QP_RESTORE_STATE: NO STATE TO RESTORE!' call err_exit endif call qp_equal_qp (qp_com, qp_save_com(i_save_com)) i_save_com = i_save_com - 1 if (qp_com%buffer) call pgebuf ! flush buffer qp_com%buffer = .false. ! for diagnostic end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_set_axis (axis, a_min, a_max, div, frac, label, draw_label, ! draw_numbers, minor_div, minor_div_max, mirror, ! number_offset, label_offset, major_tick_len, minor_tick_len) ! ! Subroutine to set (but not plot) the min, max and divisions for the ! X and Y axes. Note: ! ! Input: ! axis -- Character(*): ! 'X' to set the Left x-axis ! 'Y' to set the Bottom y-axis. ! 'X2' to set the Right x-axis ! 'Y2' to set the Top y-axis. ! a_min -- Real(rp), optional: Axis minimum. ! a_max -- Real(rp), optional: Axis maximum. ! div -- Integer, optional: Number of major divisions. ! frac -- Integer, optional: Number of decmal places after the decimal ! point. A Negative number surpresses that number of zeros. ! E.g. For the number 30 then ! frac = 2 -> Output is: "30.00" ! frac = 0 -> Output is: "30" ! frac = -1 -> Output is: "3" ! label -- Character(*), optional: Axis label. ! draw_label -- Logical, optional: Draw axis label. ! draw_numbers -- Logical, optional: Draw axis numbers ! minor_div -- Integer, optional: Number of minor divisions. ! minor_div_max -- Integer, optional: Maximum number of minor divisions. ! This is used when you want Quick_Plot to pick the ! actual number of minor divisions ! mirror -- Logical, optional: Mirror other axis in terms of min, ! max, divisions, etc. ! Note: draw_label and draw_numbers are never mirrored. ! This is only used for X2 and Y2. ! number_offset -- Real(rp), optional: Offset from axis line in inches. ! label_offset -- Real(rp), optional: Offset form numbers in inches. ! major_tick_len -- Real(rp), optional: Major tick length in inches. ! minor_tick_len -- Real(rp), optional: Minor tick length in inches. !- subroutine qp_set_axis (axis, a_min, a_max, div, frac, label, draw_label, & draw_numbers, minor_div, minor_div_max, mirror, & number_offset, label_offset, major_tick_len, minor_tick_len) implicit none type (qp_axis_struct), pointer :: this_axis real(rp), optional :: a_min, a_max, number_offset real(rp), optional :: label_offset, major_tick_len, minor_tick_len integer, optional :: div, frac, minor_div, minor_div_max logical, optional :: draw_label, draw_numbers, mirror character(*), optional :: label character(*) axis ! if (axis == 'X') then this_axis => qp_com%plot%x elseif (axis == 'Y') then this_axis => qp_com%plot%y elseif (axis == 'X2') then this_axis => qp_com%plot%x2 elseif (axis == 'Y2') then this_axis => qp_com%plot%y2 else print *, 'ERROR IN SET_AXIS: INVALID AXIS: ', axis stop endif if (present(a_min)) this_axis%min = a_min if (present(a_max)) this_axis%max = a_max if (present(div)) this_axis%major_div = div if (present(frac)) this_axis%places = frac if (present(label)) this_axis%label = label if (present(draw_label)) this_axis%draw_label = draw_label if (present(draw_numbers)) this_axis%draw_numbers = draw_numbers if (present(minor_div)) this_axis%minor_div = minor_div if (present(minor_div_max)) then this_axis%minor_div_max = minor_div_max this_axis%minor_div = 0 endif if (present(mirror)) this_axis%mirror_on = mirror if (present(number_offset)) this_axis%number_offset = number_offset if (present(label_offset)) this_axis%label_offset = label_offset if (present(major_tick_len)) this_axis%major_tick_len = major_tick_len if (present(minor_tick_len)) this_axis%minor_tick_len = minor_tick_len ! set world coords call pgswin (real(qp_com%plot%x%min), real(qp_com%plot%x%max), & real(qp_com%plot%y%min), real(qp_com%plot%y%max)) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_calc_axis_params (data_min, data_max, div_min, div_max, how, ! places, axis_min, axis_max, divisions) ! ! Subroutine to calculate a "nice" plot scale given the minimum and maximum ! of the data. This is similar to CALC_AXIS_SCALE but here the subroutine will ! pick the number of divisions. ! ! Input: ! data_min -- Real(rp): Minimum of the data ! data_max -- Real(rp): Maximum of the data ! div_min -- Integer: Minimum number of divisions. ! div_max -- Integer: Maximum number of divisions. ! how -- Character(*): ! 'ZERO_SCALE' -- Make AXIS_MIN or AXIS_MAX zero. ! 'ZERO_SYMMETRIC' -- Make AXIS_MIN = -AXIS_MAX ! 'GENERAL_BOUNDS' -- No restriction on min or max. ! ! Output: ! places -- Integer: Number of places after the decimal point needed ! to display the axis numbers. Note: PLACES can be ! negative if the axis numbers are divisible by powers ! of 10. ! axis_min -- Real(rp): Axis minimum. ! axis_max -- Real(rp): Axis maximum. ! divisions -- Integer: How many divisions the axis is divided up into ! ! ! Example: ! call qp_CALC_AXIS_PARAMS (352, 378, 4, 6, ZERO_SCALE, & ! places, axis_min, axis_max, divisions) ! Gives: ! axis_min = 0 ! axis_max = 400 ! places = -2 ! since the scale numbers: (0, 100, 200, 300, 400) are all ! ! divisible by 100 = 10^2 ! divisions = 4 !- subroutine qp_calc_axis_params (data_min, data_max, div_min, div_max, how, & places, axis_min, axis_max, divisions) implicit none integer divisions, places, i integer div_min, div_max real(rp) data_max, data_min, axis_max, axis_min, width_min real(rp) d_max, d_min, score, score_max character(*) how ! score_max = -1e20 divisions = 0 d_min = data_min d_max = data_max do i = div_min, div_max call qp_calc_axis_scale (d_min, d_max, i, how, places, & axis_min, axis_max, score) if (score_max < score) then score_max = score divisions = i endif enddo call qp_calc_axis_scale (d_min, d_max, divisions, how, & places, axis_min, axis_max) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_calc_axis_places (axis_min, axis_max, divisions, places) ! ! Subroutine to calculate the number of decmal places needed to display the ! axis numbers. ! ! Input: ! data_min -- Real(rp): Minimum of the data ! data_max -- Real(rp): Maximum of the data ! divisions -- Integer: How many divisions the axis is divided up into ! ! Output: ! places -- Integer: Number of places after the decimal point needed ! to display the axis numbers. Note: PLACES can be ! negative if the axis numbers are divisible by powers of 10. !- subroutine qp_calc_axis_places (axis_min, axis_max, divisions, places) implicit none integer divisions, places, i real(rp) axis_min, axis_max, width, num, num2 ! error check if (axis_min == axis_max) then print *, 'ERROR IN CALC_AXIS_PLACES: AXIS_MAX EQUAL TO AXIS_MIN' call err_exit endif ! First calculation: Take each axis number and find how many digits it has. ! The number of places is the maximum number of digits needed places = -10 do i = 0, divisions num = axis_min + i * (axis_max - axis_min) / divisions if (num /= 0) then places = max(places, floor(-log10(abs(num)))) do num2 = num * 10.0**places if (abs(num2 - nint(num2)) > 0.01 .and. places <= 7) then places = places + 1 else exit endif enddo endif enddo ! Second calculation: Places based upon the width of the plot. ! The number of places returned by the subroutine is the maximum of the ! two calculations width = abs(axis_max - axis_min) / divisions places = max(places, floor(-log10(width)+0.9)) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_calc_axis_scale (data_min, data_max, divisions, how, & ! places, axis_min, axis_max, niceness_score) ! ! Subroutine to calculate a "nice" plot scale given the minimum and maximum ! of the data. If DATA_MAX - DATA_MIN < 1e-30 then AXIS_MAX - AXIS_MIN will ! be at least DIVISIONS * 1e-30 ! ! Input: ! data_min -- Real(rp): Minimum of the data ! data_max -- Real(rp): Maximum of the data ! divisions -- Integer: How many divisions the axis is divided up into ! how -- Character(*): ! 'ZERO_AT_END' -- Make AXIS_MIN or AXIS_MAX zero. ! 'ZERO_SYMMETRIC' -- Make AXIS_MIN = -AXIS_MAX ! 'GENERAL_BOUNDS' -- No restriction on min or max. ! ! Output: ! places -- Integer: Number of places after the decimal point needed ! to display the axis numbers. Note: PLACES can be ! negative if the axis numbers are divisible by power of 10. ! axis_min -- Real(rp): Axis minimum. ! axis_max -- Real(rp): Axis maximum. ! niceness_score -- Real(rp), optional: Score as to how "nice" ! axis_min and axis_max are. The larger the number the nicer. ! ! Example: ! ! call qp_CALC_AXIS_SCALE (3.52, 3.78, 4, 'GENERAL_BOUNDS', places, ! axis_min, axis_max) ! Gives: ! AXIS_MIN = 3.4 ! AXIS_MAX = 3.8 ! PLACES = 1 ! ! call qp_CALC_AXIS_SCALE (352, 378, 4, 'ZERO_AT_END', places, ! axis_min, axis_max) ! Gives: ! axis_min = 0 ! axis_max = 400 ! places = -2 ! since the scale numbers: (0, 100, 200, 300, 400) are all ! ! divisible by 100 = 10^2 !- subroutine qp_calc_axis_scale (data_min, data_max, divisions, how, & places, axis_min, axis_max, niceness_score) implicit none integer divisions, places, floor, div_eff integer min1, min2, max1, max2, imin, imax, j, ave real(rp), optional :: niceness_score real(rp) data_max, data_min, axis_max, axis_min real(8) data_width, data_width10, min_width, max_score, score, log_width real(8) aa character(*) how ! error check if (how == 'ZERO_AT_END' .and. data_max*data_min < 0) then print *, 'WARNING IN CALC_AXIS_SCALE: DATA ABOVE AND BELOW ZERO!' print *, ' WITH "ZERO_AT_END"' niceness_score = -1 return endif if (data_max < data_min) then print *, 'ERROR IN CALC_AXIS_SCALE: DATA_MAX LESS THAN DATA_MIN' call err_exit endif ! find width of data if (how == 'ZERO_AT_END') then data_width = max(abs(data_max), abs(data_min)) axis_max = max(abs(data_max), abs(data_min)) axis_min = 0 elseif (how == 'ZERO_SYMMETRIC') then data_width = max(abs(data_max), abs(data_min)) axis_max = max(abs(data_max), abs(data_min)) axis_min = 0 elseif (how == 'GENERAL_BOUNDS') then data_width = data_max - data_min axis_max = data_max axis_min = data_min else print *, 'ERROR IN CALC_AXIS_SCALE: I DO NOT UNDERSTAND "HOW": ', how call err_exit endif ! find possible candidates min_width = divisions * max(abs(axis_max)*1e-5, abs(axis_min)*1e-5, 1e-29_rp) data_width = max(data_width, min_width) log_width = log10(data_width) data_width10 = 10.0**(floor(log_width)-1) ! print *, 'data_width10:', data_width10 if (how == 'ZERO_SYMMETRIC') then div_eff = divisions / 2 else div_eff = divisions endif min_width = data_width10 * divisions if (how == 'ZERO_AT_END') then min1 = 0 min2 = 0 else min1 = floor(axis_min / (100 * data_width10)) * 100 min2 = floor(axis_min / data_width10 + 0.01) min1 = min(min1, min2 - 10*div_eff) endif aa = axis_max/data_width10 + 0.99 max1 = floor(aa) aa = axis_max / (100 * data_width10) + 0.99 max2 = max(floor(aa) * 100, max1 + 10*div_eff) ave = nint((axis_max + axis_min)/data_width10) min1 = max(min1, 2*min2 - max1) min1 = min(min1, (ave - divisions)/2 - 1) max2 = min(max2, 2*max1 - min2) max2 = max(max2, min1+divisions+1) ! go through and rate all the possibilities and choose the one ! with the highest score max_score = -1000 do imin = min1, min2 do imax = max1, max2 if (imin == imax) cycle if (mod(imax - imin, div_eff) /= 0) cycle score = 0 if (imin == 0) score = score + 1 if (imax == 0) score = score + 1 do j = imin, imax, (imax - imin) / div_eff if (mod(j, 10) == 0) score = score + 1.5 if (mod(j, 100) == 0) score = score + 2 if (mod(j, div_eff) == 0) score = score + 0.5 if (mod(j, 2) == 0) score = score + 1 enddo if (mod(imin, 5) == 0 .and. mod(imax, 5) == 0) score = score + 2 score = score + 10 * (2 - log10(float(imax - imin))) * divisions if (score > max_score) then max_score = score axis_min = imin * data_width10 axis_max = imax * data_width10 endif enddo enddo if (present(niceness_score)) niceness_score = max_score / divisions ! adjust the scale if necessary if (how == 'ZERO_AT_END' .and. data_min < 0) then axis_min = -axis_max axis_max = 0 elseif (how == 'ZERO_SYMMETRIC') then axis_min = -axis_max endif ! find number of places needed call qp_calc_axis_places (axis_min, axis_max, divisions, places) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_set_graph_limits ! ! Subroutine to calculate the offsets for the graph. ! This subroutine also sets the PGPLOT window size = The graph size. ! ! Note: This subroutine is for internal use only. !- subroutine qp_set_graph_limits implicit none real(rp) x_div, y_div ! qp_com%graph%z1 is the lower left corner of plot ! qp_com%graph%z2 is the upper right corner of plot if (.not. qp_com%subgraph_on) then ! if no subgraph qp_com%graph%x1 = qp_com%box%x1 + qp_com%margin%x1 qp_com%graph%y1 = qp_com%box%y1 + qp_com%margin%y1 qp_com%graph%x2 = qp_com%box%x2 - qp_com%margin%x2 qp_com%graph%y2 = qp_com%box%y2 - qp_com%margin%y2 endif ! only call pgvsiz if the coords look reasonable if (qp_com%graph%x1 < qp_com%graph%x2 .and. & qp_com%graph%y1 < qp_com%graph%y2) then call pgvsiz (real(qp_com%graph%x1), real(qp_com%graph%x2), & real(qp_com%graph%y1), real(qp_com%graph%y2)) endif end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_clear_page ! ! Subroutine to clear all drawing from the page. !- subroutine qp_clear_page call pgpage end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_clear_box ! ! Subroutine to clear all drawing from the current box. ! That is, white out the box region. ! The current box is determined by QP_SET_BOX !- subroutine qp_clear_box implicit none integer ci, fs real xv1, xv2, yv1, yv2, xw1, xw2, yw1, yw2, xb1, xb2, yb1, yb2 ! call pgbbuf ! Buffer the following calls call pgqci(ci) ! save present color index call pgqfs(fs) ! save present fill-area style call pgsci(0) ! Set color index to background call pgsfs(1) ! Set fill-area style to solid call pgqwin (xw1, xw2, yw1, yw2) ! get graph data min/max call pgqvp (0, xv1, xv2, yv1, yv2) ! get viewport coords ! set the viewport to the box call pgvsiz (real(qp_com%box%x1), real(qp_com%box%x2), & real(qp_com%box%y1), real(qp_com%box%y2)) call pgrect (xw1, xw2, yw1, yw2) ! clear the box call pgsvp (xv1, xv2, yv1, yv2) ! reset the viewport coords call pgsci(0) ! reset color index call pgsfs(1) ! reset fill-area style call pgebuf ! Flush the buffer. end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_set_box (ix, iy, ix_tot, iy_tot) ! ! Subroutine to set the box on the physical page. ! This routine divides the page into a grid of boxes. ! There are IX_TOT boxes horizontally and IY_TOT boxes vertically. ! the (IX, IY) = (1, 1) box is the lower left box and the ! (IX, IY) = (IX_TOT, IY_TOT) box is at the upper right. ! ! Use this routine with QP_SET_MARGIN and QP_SET_PAGE_BORDER. ! ! Input: ! ix_tot, iy_tot -- Integer: X and Y box divisions. ! ix, iy -- Integer: Index for box to be used. ! !- subroutine qp_set_box (ix, iy, ix_tot, iy_tot) implicit none integer ix, iy, ix_tot, iy_tot real(rp) w_x, w_y ! calculate the placement of the box w_x = qp_com%page%x2 - qp_com%border%x1 - qp_com%border%x2 w_y = qp_com%page%y2 - qp_com%border%y1 - qp_com%border%y2 qp_com%box%x1 = qp_com%border%x1 + w_x * (ix - 1) / ix_tot qp_com%box%y1 = qp_com%border%y1 + w_y * (iy - 1) / iy_tot qp_com%box%x2 = qp_com%border%x1 + w_x * ix / ix_tot qp_com%box%y2 = qp_com%border%y1 + w_y * iy / iy_tot ! finally calculate placement of the graph within the box ! set QP_COM%SUBGRAPH_ON so QP_SET_GRAPH_LIMITS will calculate the ! graph boundry qp_com%subgraph_on = .false. call qp_set_graph_limits end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_set_page_border (x1_b, x2_b, y1_b, y2_b, units) ! ! Subroutine to set the border around the physical page. ! ! Input: ! x1_b -- Real(rp): Left border. ! y1_b -- Real(rp): Bottom border. ! x2_b -- Real(rp): Right border. ! y2_b -- Real(rp): Top border. ! units -- Character(*), optional: border units: ! '%PAGE' - Percent of page. ! 'MM' - milimeters. ! 'INCH' - Inches (default). ! 'POINTS' - Points. !- subroutine qp_set_page_border (x1_b, x2_b, y1_b, y2_b, units) implicit none real(rp) x1_b, y1_b, x2_b, y2_b character(*), optional :: units ! qp_com%dflt_units = dflt_set$ call qp_to_inch_rel (x1_b, y1_b, qp_com%border%x1, qp_com%border%y1, units) call qp_to_inch_rel (x2_b, y2_b, qp_com%border%x2, qp_com%border%y2, units) qp_com%dflt_units = dflt_draw$ call qp_set_graph_limits end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_to_datum_abs (x, y, x_dat, y_dat, units) ! ! Subroutine to convert an (x, y) point on the page to data units. ! ! Input: ! x, y -- Real(rp): Point on the page. ! units -- Character(*), optional: Units of (x, y) ! ! Output: ! x_dat, y_dat -- Real(rp): Point in data units !- subroutine qp_to_datum_abs (x, y, x_dat, y_dat, units) implicit none real(rp) x, y real(rp) x_dat, y_dat character(*), optional :: units character(8) u_type, region, corner ! Do the easy case call qp_split_units_string (u_type, region, corner, units) if (u_type == 'DATA') then x_dat = x y_dat = y return endif ! convert to inches referenced to the LB corner of the graph call qp_to_inch_abs (x, y, x_dat, y_dat, units) x_dat = x_dat - qp_com%graph%x1 y_dat = y_dat - qp_com%graph%y1 ! convert to data units x_dat = x_dat * (qp_com%plot%x%max - qp_com%plot%x%min) / & (qp_com%graph%x2 - qp_com%graph%x1) y_dat = y_dat * (qp_com%plot%y%max - qp_com%plot%y%min) / & (qp_com%graph%y2 - qp_com%graph%y1) ! add offset from LB graph corner x_dat = x_dat + qp_com%plot%x%min y_dat = y_dat + qp_com%plot%y%min end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_to_datum_rel (x, y, x_dat, y_dat, units) ! ! Subroutine to convert an (x, y) delta to data units. ! ! Input: ! x, y -- Real(rp): Deltas. ! units -- Character(*), optional: Units of (x, y). ! ! Output: ! x_dat, y_dat -- Real(rp): Deltas in data units. !- subroutine qp_to_datum_rel (x, y, x_dat, y_dat, units) implicit none real(rp) x, y real(rp) x_dat, y_dat character(*), optional :: units character(8) u_type, region, corner ! Do the easy case call qp_split_units_string (u_type, region, corner, units) if (u_type == 'DATA') then x_dat = x y_dat = y return endif ! convert to inches call qp_to_inch_rel (x, y, x_dat, y_dat, units) ! and then convert to data units x_dat = x_dat * (qp_com%plot%x%max - qp_com%plot%x%min) / & (qp_com%graph%x2 - qp_com%graph%x1) y_dat = y_dat * (qp_com%plot%y%max - qp_com%plot%y%min) / & (qp_com%graph%y2 - qp_com%graph%y1) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_to_data_abs (x, y, x_dat, y_dat, units) ! ! Subroutine to convert (x, y) points on the page to data units. ! ! Input: ! x(:), y(:) -- Real(rp): Array of points on the page. ! units -- Character(*), optional: Units of (x, y) ! ! Output: ! x_dat(:), y_dat(:) -- Real(rp): Points in data units !- subroutine qp_to_data_abs (x, y, x_dat, y_dat, units) implicit none real(rp) x(:), y(:) real(rp) x_dat(:), y_dat(:) real(rp) x0, y0, rx, ry character(*), optional :: units ! Let qp_to_datum do all the work call qp_to_datum_abs (0.0_rp, 0.0_rp, x0, y0, units) call qp_to_datum_rel (1.0_rp, 1.0_rp, rx, ry, units) x_dat = x0 + x * rx y_dat = y0 + y * ry end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_to_data_rel (x, y, x_dat, y_dat, units) ! ! Subroutine to convert (x, y) deltas to data units. ! ! Input: ! x(:), y(:) -- Real(rp): Deltas. ! units -- Character(*), optional: Units of (x, y). ! ! Output: ! x_dat(:), y_dat(:) -- Real(rp): Deltas in data units. !- subroutine qp_to_data_rel (x, y, x_dat, y_dat, units) implicit none real(rp) x(:), y(:) real(rp) x_dat(:), y_dat(:) real(rp) rx, ry character(*), optional :: units ! Let qp_to_datum_rel do all the work call qp_to_datum_rel (1.0_rp, 1.0_rp, rx, ry, units) x_dat = x * rx y_dat = y * ry end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_from_inch_rel (x_inch, y_inch, x, y, units) ! ! Subroutine to convert from a relative position (an offset) in inches ! to other units. ! ! Input: ! x, y -- Real(rp): Lengths to convert. ! units -- Character(*), optional: Units of x and y ! ! Output: ! x_inch, y_inch -- Real(rp): lengths in inches. !- Subroutine qp_from_inch_rel (x_inch, y_inch, x, y, units) real(rp) x, y real(rp) x_inch, y_inch character(*), optional :: units character(8) u_type, region, corner ! call qp_split_units_string (u_type, region, corner, units) if (u_type == 'MM') then x = x_inch * 25.4 y = y_inch * 25.4 elseif (u_type == 'INCH') then x = x_inch y = y_inch elseif (u_type == 'POINTS') then x = x_inch * 72 y = y_inch * 72 elseif (u_type == '%' .and. region == 'PAGE') then x = x_inch / (qp_com%page%x2) y = y_inch / (qp_com%page%y2) elseif (u_type == '%' .and. region == 'GRAPH') then x = x_inch / (qp_com%graph%x2 - qp_com%graph%x1) y = y_inch / (qp_com%graph%y2 - qp_com%graph%y1) elseif (u_type == '%' .and. region == 'BOX') then x = x_inch / (qp_com%box%x2 - qp_com%box%x1) y = y_inch / (qp_com%box%y2 - qp_com%box%y1) elseif (u_type == 'DATA') then x = x_inch * (qp_com%plot%x%max - qp_com%plot%x%min) / & (qp_com%graph%x2 - qp_com%graph%x1) y = y_inch * (qp_com%plot%y%max - qp_com%plot%y%min) / & (qp_com%graph%y2 - qp_com%graph%y1) endif end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_from_inch_abs (x_inch, y_inch, x, y, units) ! ! Subroutine to convert to absolute position (x, y) from inches referenced ! to the Left Bottom corner of the page ! ! Input: ! x_inch, y_inch -- Real(rp): Position in inches from LB corner of the page. ! units -- Character(*), optional: Units of x and y ! ! Output: ! x, y -- Real(rp): Position in new coords !- subroutine qp_from_inch_abs (x_inch, y_inch, x, y, units) implicit none type (qp_rect_struct) ref real(rp) x, y, x0, y0 real(rp) x_inch, y_inch, x_in, y_in character(*), optional :: units character(8) u_type, region, corner ! Init call qp_split_units_string (u_type, region, corner, units) ! Data units case. if (u_type == 'DATA') then x0 = x_inch - qp_com%graph%x1 y0 = y_inch - qp_com%graph%y1 call qp_from_inch_rel (x0, y0, x, y, units) x = x + qp_com%plot%x%min y = y + qp_com%plot%y%min return endif ! All other cases if (region == 'PAGE') then ref = qp_com%page elseif (region == 'BOX') then ref = qp_com%box else ref = qp_com%graph endif if (corner(1:1) == 'L') then x0 = x_inch - ref%x1 else x0 = x_inch - ref%x2 endif if (corner(2:2) == 'B') then y0 = y_inch - ref%y1 else y0 = y_inch - ref%y2 endif call qp_from_inch_rel (x0, y0, x, y, units) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_to_inch_rel (x, y, x_inch, y_inch, units) ! ! Subroutine to convert a relative (x, y) into inches. ! ! Input: ! x, y -- Real(rp): Lengths to convert. ! units -- Character(*), optional: Units of x and y ! ! Output: ! x_inch, y_inch -- Real(rp): lengths in inches. !- subroutine qp_to_inch_rel (x, y, x_inch, y_inch, units) implicit none real(rp) x, y real(rp) x_inch, y_inch character(*), optional :: units character(8) u_type, region, corner ! call qp_split_units_string (u_type, region, corner, units) if (u_type == 'MM') then x_inch = x / 25.4 y_inch = y / 25.4 elseif (u_type == 'INCH') then x_inch = x y_inch = y elseif (u_type == 'POINTS') then x_inch = x / 72 y_inch = y / 72 elseif (u_type == '%' .and. region == 'PAGE') then x_inch = x * (qp_com%page%x2) y_inch = y * (qp_com%page%y2) elseif (u_type == '%' .and. region == 'GRAPH') then x_inch = x * (qp_com%graph%x2 - qp_com%graph%x1) y_inch = y * (qp_com%graph%y2 - qp_com%graph%y1) elseif (u_type == '%' .and. region == 'BOX') then x_inch = x * (qp_com%box%x2 - qp_com%box%x1) y_inch = y * (qp_com%box%y2 - qp_com%box%y1) elseif (u_type == 'DATA') then x_inch = x * (qp_com%graph%x2 - qp_com%graph%x1) / & (qp_com%plot%x%max - qp_com%plot%x%min) y_inch = y * (qp_com%graph%y2 - qp_com%graph%y1) / & (qp_com%plot%y%max - qp_com%plot%y%min) endif end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_to_inch_abs (x, y, x_inch, y_inch, units) ! ! Subroutine to convert an absolute position (x, y) into inches referenced ! to the Left Bottom corner of the page. ! ! Input: ! x, y -- Real(rp): Position to convert. ! units -- Character(*), optional: Units of x and y ! ! Output: ! x_inch, y_inch -- Real(rp): Position in inches referenced to the page. !- subroutine qp_to_inch_abs (x, y, x_inch, y_inch, units) implicit none type (qp_rect_struct) ref real(rp) x, y, x0, y0 real(rp) x_inch, y_inch character(*), optional :: units character(8) u_type, region, corner ! Init call qp_split_units_string (u_type, region, corner, units) ! Data units case if (u_type == 'DATA') then x0 = x - qp_com%plot%x%min y0 = y - qp_com%plot%y%min call qp_to_inch_rel (x0, y0, x_inch, y_inch, units) x_inch = x_inch + qp_com%graph%x1 y_inch = y_inch + qp_com%graph%y1 return endif ! Other cases. call qp_to_inch_rel (x, y, x_inch, y_inch, units) if (region == 'PAGE') then ref = qp_com%page elseif (region == 'BOX') then ref = qp_com%box else ref = qp_com%graph endif if (corner(1:1) == 'L') then x_inch = x_inch + ref%x1 else x_inch = x_inch + ref%x2 endif if (corner(2:2) == 'B') then y_inch = y_inch + ref%y1 else y_inch = y_inch + ref%y2 endif end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_split_units_string (u_type, region, corner, units) ! ! Subroutine to split a units string into its components. ! ! Input: ! units -- Character(*), optional: Units string to split. ! If not present then 'DATA/GRAPH/LB' is assumed. ! ! Output: ! u_type -- Character(*): Unit type. ! region -- Character(*): Region. ! corner -- Character(*): Origin Corner. !- subroutine qp_split_units_string (u_type, region, corner, units) implicit none character(*) u_type, region, corner character(*), optional :: units character(20) u character(8) dflt_units(3) integer i, ix ! Default if (qp_com%dflt_units == dflt_draw$) then dflt_units = qp_com%dflt_draw_units else dflt_units = qp_com%dflt_set_units endif u_type = dflt_units(1) region = dflt_units(2) corner = dflt_units(3) ! if (.not. present(units)) return u = units ! strip '/' do i = 1, 2 ix = index(u, '/') if (ix /= 0) u(ix:ix) = ' ' enddo ! get u_type call string_trim (u, u, ix) if (ix == 0) return if (u(1:1) == '%') ix = 1 u_type = u(:ix) if (all(u_type /= (/ 'DATA ', 'MM ', 'INCH ', 'POINTS', '% ' /))) then print *, 'ERROR IN QP_SPLIT_UNITS_STRING: BAD UNITS TYPE: "', & trim(units), '"' call err_exit endif ! get region call string_trim (u(ix+1:), u, ix) if (ix == 0) return region = u(:ix) if (all(region /= (/ 'PAGE ', 'BOX ', 'GRAPH' /))) then print *, 'ERROR IN QP_SPLIT_UNITS_STRING: BAD REGION: "', trim(units), '"' call err_exit endif ! get corner call string_trim (u(ix+1:), u, ix) if (ix == 0) return corner = u(:ix) if (all(corner /= (/ 'LB', 'LT', 'RB', 'RT' /))) then print *, 'ERROR IN QP_SPLIT_UNITS_STRING: BAD CORNER: "', trim(units), '"' call err_exit endif call string_trim (u(ix+1:), u, ix) if (ix /= 0) then print *, 'ERROR IN QP_SPLIT_UNITS_STRING: EXTRA CHARACTERS IN UNITS: "', & trim(units), '"' call err_exit endif end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_set_margin (x1_marg, x2_marg, y1_marg, y2_marg, units) ! ! Subroutine to set up the margins from the sides of the box (see SET_BOX) ! to the edges of the actual graph. ! ! Input: ! x1_marg, y1_marg -- Real(rp): offset from the lower left corner ! of the box to the lower left corner of the plotting region. ! x2_marg, y2_marg -- Real(rp): offset from the upper right corner ! of the box to the upper right corner of the plotting region. ! units -- Character(*), optional: Units of the margins. ! Default is: 'DATA/GRAPH' ! See quick_plot writeup for more details. ! ! Use this routine with SET_BOX and SET_PAGE_BORDER. !- subroutine qp_set_margin (x1_marg, x2_marg, y1_marg, y2_marg, units) implicit none Real(rp) x1_marg, y1_marg, x2_marg, y2_marg character(*), optional :: units ! qp_com%dflt_units = dflt_set$ call qp_to_inch_rel (x1_marg, y1_marg, qp_com%margin%x1, & qp_com%margin%y1, units) call qp_to_inch_rel (x2_marg, y2_marg, qp_com%margin%x2, & qp_com%margin%y2, units) qp_com%dflt_units = dflt_draw$ call qp_set_graph_limits end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_rectangle (x1, x2, y1, y2, units, color, width, ! style, clip) ! ! Subroutine to draw a rectangular box. ! ! Input: ! x1, y1 -- Real(rp): (x, y) corner of box. ! x2, y2 -- Real(rp): (x, y) opposite corner of box. ! units -- Character(*), optional: Units of x and y. ! Default is: 'DATA/GRAPH/LB' ! See quick_plot writeup for more details. ! color -- Integer, optional: Color index for the box ! width -- Integer, optional: Width of the line. Default = 1 ! style -- Integer, optional: Line style. ! clip -- Logical, optional: Clip at the graph boundary? !- subroutine qp_draw_rectangle (x1, x2, y1, y2, units, color, width, style, clip) implicit none real(rp) x1, y1, x2, y2 integer, optional :: color, width, style character(*), optional :: units logical, optional :: clip ! call qp_draw_polyline ((/ x1, x1, x2, x2, x1 /), (/ y1, y2, y2, y1, y1 /), & units, width, color, style, clip) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_symbol (x, y, units, type, height, color, ! fill, line_width, clip) ! ! Draws a symbol at (x, y) ! Note: To convert to data units from something else use the qp_to_data routine. ! ! Input: ! x, y -- Real(rp): Symbol coordinates in data units. ! x and y may be vectors. ! units -- Character(*), optional: Units of (x, y) ! type -- Integer, optional: Symbol type. ! height -- Real(rp), optional: Size of the symbol. ! color -- Integer, optional: Symbol color. ! fill -- Integer, optional: fill pattern. ! line_width -- Integer, optional: Line width. ! clip -- Logical, optional: Clip at the graph boundary? !- subroutine qp_draw_symbol (x, y, units, type, height, color, & fill, line_width, clip) implicit none integer, optional :: type, color, fill, line_width real(rp) x, y, x_dat, y_dat real(rp), optional :: height character(*), optional :: units logical, optional :: clip ! call qp_save_state (.false.) call qp_set_symbol_attrib (type, height, color, fill, line_width, clip) call qp_to_datum_abs (x, y, x_dat, y_dat, units) call pgpt1 (real(x_dat), real(y_dat), qp_com%symbol%type) call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_symbols (x, y, units, type, height, color, ! fill, line_width, clip) ! ! Draws a symbol at the (x, y) points. ! Data units are assumed. ! Note: To convert to data units from something else use the qp_to_data routine. ! ! Input: ! x, y -- Real(rp): Symbol coordinates in data units. ! x and y may be vectors. ! type -- Integer, optional: Symbol type. ! height -- Real(rp), optional: Size of the symbol. ! color -- Integer, optional: Symbol color. ! fill -- Integer, optional: fill pattern. ! line_width -- Integer, optional: Line width. ! clip -- Logical, optional: Clip at the graph boundary? !- subroutine qp_draw_symbols (x, y, units, type, height, color, & fill, line_width, clip) implicit none integer, optional :: type, color, fill, line_width integer i real(rp) x(:), y(:), x_dat, y_dat real(rp), optional :: height character(*), optional :: units logical, optional :: clip ! do i = 1, size(x) call qp_draw_symbol (x(i), y(i), units, type, height, color, fill, & line_width, clip) enddo end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_graph (x, y, x_lab, y_lab, title, & ! draw_line, draw_symbol, clip) ! ! Subroutine to plot data, axes with labels, a grid, and a title. ! ! Input: ! x(:), y(:) -- Real(rp): data arrays. ! x_lab, y_lab -- Character(*), optional: x and y axes labels. ! title -- Character(*), optional: Graph Title. ! draw_line -- Logical, optional: Default = T. ! draw_symbol -- Logical, optional: Default = T. ! clip -- Logical, optional: Clip at the graph boundary? ! ! See: ! QP_OPEN_PAGE for setting up the plot page. ! QP_SET_BOX for setting up the box within the page. ! QP_SET_MARGIN for setting up the graph margins within the box. ! QP_SET_SYMBOL_ATTRIB for setting the symbol attributes. ! QP_SET_LINE_ATTRIB for setting the line attributes. ! QP_SET_AXIS for setting up the axis scales. !- subroutine qp_draw_graph (x_dat, y_dat, x_lab, y_lab, title, & draw_line, draw_symbol, clip) implicit none real(rp) x_dat(:), y_dat(:) character(*), optional :: x_lab, y_lab, title logical, optional :: draw_line, draw_symbol, clip logical draw ! Error check if (qp_com%plot%x%max == qp_com%plot%x%min) then print *, 'ERROR IN QP_DRAW_GRAPH: X_MAX = X_MIN' call err_exit endif if (qp_com%plot%y%max == qp_com%plot%y%min) then print *, 'ERROR IN QP_DRAW_GRAPH: Y_MAX = Y_MIN' call err_exit endif ! init call qp_save_state (.true.) ! axes if (present(x_lab)) qp_com%plot%x%label = x_lab if (present(y_lab)) qp_com%plot%y%label = y_lab if (present(title)) qp_com%plot%title = title call qp_draw_axes ! plot a polyline if (size(x_dat) > 0) then draw = .true. if (present(draw_line)) draw = draw_line if (draw) then call qp_set_clip (clip) call qp_set_line_attrib ('PLOT') call qp_draw_polyline_basic (x_dat, y_dat) endif endif ! plot symbols if (size(x_dat) > 0) then draw = .true. if (present(draw_symbol)) draw = draw_symbol if (draw) then call qp_set_clip (clip) call qp_draw_symbols (x_dat, y_dat) endif endif ! call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_axes ! ! Subroutine to plot the axes, title, etc. of a plot. !- subroutine qp_draw_axes implicit none ! if (qp_com%plot%draw_grid) call qp_draw_grid call qp_draw_x_axis ('X', 0.0_rp) call qp_draw_x_axis ('X2', 1.0_rp) call qp_draw_y_axis ('Y', 0.0_rp) call qp_draw_y_axis ('Y2', 1.0_rp) if (qp_com%plot%draw_title) call qp_draw_graph_title (qp_com%plot%title) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_graph_title (title) ! ! Subroutine to draw the title for a graph. ! ! Input: ! title -- Character(*): Title !- subroutine qp_draw_graph_title (title) implicit none character(*) title real(rp) xl, yl, xt, yt, dum ! if (len_trim(title) == 0) return call qp_set_text_attrib ('GRAPH_TITLE') call qp_to_inch_rel (0.5_rp, 1.0_rp, xt, yt, '%GRAPH') call qp_draw_text_basic (title, xt, yt+0.05, 'INCH', 'CB') end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_histogram (x_dat, y_dat, x_lab, y_lab, title) ! ! Subroutine to plot data, axes with labels, a grid, and a title. ! ! Input: ! x_dat(:), y_dat(:) -- Real(rp): Data arrays. ! x_lab, y_lab -- Character(*), optional: x and y axis labels. ! title -- Character(*), optional: Graph Title. ! ! See: ! QP_OPEN_PAGE for setting up the plot page. ! QP_SET_BOX for setting up the box within the page. ! QP_SET_MARGIN for setting up the graph margins within the box. ! QP_SET_SYMBOL_ATTRIB for setting the symbol attributes. ! QP_SET_LINE_ATTRIB for setting the line attributes. ! QP_SET_AXIS for setting up the axis scales. !- subroutine qp_draw_histogram (x_dat, y_dat, x_lab, y_lab, title) implicit none integer i, n real(rp) x_dat(:), y_dat(:) real(rp) :: xh_dat(2*size(x_dat)), yh_dat(2*size(x_dat)) character(*), optional :: x_lab, y_lab, title ! error check if (qp_com%plot%x%max == qp_com%plot%x%min) then print *, 'ERROR IN PLOT_DATA: X_MAX = X_MIN' call err_exit endif if (qp_com%plot%y%max == qp_com%plot%y%min) then print *, 'ERROR IN PLOT DATA: Y_MAX = Y_MIN' call err_exit endif ! axes ! init call qp_save_state (.true.) if (present(x_lab)) qp_com%plot%x%label = x_lab if (present(y_lab)) qp_com%plot%y%label = y_lab if (present(title)) qp_com%plot%title = title call qp_draw_axes ! compute lines and draw histogram n = size(x_dat) if (n == 0) return xh_dat(1) = qp_com%plot%x%min xh_dat(2*n) = qp_com%plot%x%max xh_dat(2:2*n-2:2) = (x_dat(1:n-1) + x_dat(2:n)) / 2 xh_dat(3:2*n-1:2) = (x_dat(1:n-1) + x_dat(2:n)) / 2 yh_dat(1:2*n-1:2) = y_dat(1:n) yh_dat(2:2*n:2) = y_dat(1:n) call qp_set_clip (.true.) call qp_draw_polyline_basic (xh_dat, yh_dat) call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_legend (lines, x, y, units) ! ! Subroutine to draw a legend. ! Note: If (x, y) is not given then by default the legend is drawn ! starting just to the right of the graph. ! Note: If the units are not specified then data units are assumed. ! ! Input: ! lines(:) -- Character(*): Array of lines to print. ! x, y -- Real(rp), optional: Postion of start of the first line. ! units -- Character(*), optional: Units of x, y. ! Default is: 'DATA/GRAPH/LB' ! See quick_plot writeup for more details. !- subroutine qp_draw_legend (lines, x, y, units) implicit none real(rp), optional :: x, y real(rp) xc, yc, height character(*) lines(:) character(*), optional :: units integer i ! call qp_save_state (.true.) call qp_set_text_attrib ('LEGEND') height = qp_com%this_text%height / 72.0 if (present(x)) then call qp_to_inch_abs (x, y, xc, yc, units) else call qp_to_inch_abs (0.2_rp, 0.0_rp, xc, yc, 'INCH/GRAPH/RT') endif do i = 1, size(lines) yc = yc - 1.2 * height call qp_draw_text_basic (lines(i), xc, yc, 'INCH/PAGE/LB') enddo call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_arc (x0, y0, r_x, r_y, ang1, ang2, ! units, width, color, style, clip) ! ! Subroutine to plot a section of an ellipse. ! Drawn is: ! (x, y) = (x0, y0) + (r_x * cos(theta), r_y * sin(theta)) ! Where theta starts at ang1 and increases til it reaches ang2 (modulo twopi). ! Think of the drawing pen as traveling counter-clockwise starting at ang1. ! ! Currently this routine can only draw solid lines. ! ! Input: ! x0, y0 -- Real(rp): Center of arc. ! r_x -- Real(rp): Horizontal radius. ! r_y -- Real(rp): Vertical radius. ! ang1 -- Real(rp): Starting angle in radians. ! ang2 -- Real(rp): Ending angle in radians ! units -- Character(*), optional: Units of x, y. ! Default is: 'DATA/GRAPH/LB' ! See quick_plot writeup for more details. ! width -- Integer, optional: Width of line ! color -- Integer, optional: Line color. ! style -- Integer, optional: Line style. ! Currently can only be 1 (solid line). ! clip -- Logical, optional: Clip at graph boundary? !- subroutine qp_draw_arc (x0, y0, r_x, r_y, ang1, ang2, & units, width, color, style, clip) implicit none real(rp) x0, y0, r_x, r_y, ang1, ang2 real(rp) x_(1000), y_(1000), ang22, del, ang real(rp) xx0, yy0, rr_x, rr_y, rxi, ryi integer, optional :: width, color integer i character(*), optional :: units, style logical, optional :: clip ! call qp_save_state (.false.) call qp_to_inch_abs (x0, y0, xx0, yy0, units) call qp_to_inch_rel (r_x, r_y, rr_x, rr_y, units) ! This gives about a 0.03" line segment length del = max(twopi/1000, twopi / (100 * (rr_x + rr_y))) ! adjust angle if ang2 < ang1 ang22 = ang2 - twopi * floor((ang2 - ang1) / twopi) ! draw ang = ang1 do i = 1, size(x_) x_(i) = xx0 + rr_x * cos(ang) y_(i) = yy0 + rr_y * sin(ang) if (ang >= ang22) exit ang = ang + del if (ang > ang22) ang = ang22 enddo call qp_set_line_attrib ('STD', width, color, 1, clip) ! solid line call qp_draw_polyline_basic (x_(1:i), y_(1:i), 'INCH/PAGE/LB') call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_polyline (x, y, units, width, color, style, clip) ! ! Subroutine to draw a polyline. ! ! Input: ! x(:), y(:) -- Real(rp): (x, y) points for the polyline. ! units -- Character(*), optional: Units of x, y. ! Default is: 'DATA/GRAPH/LB' ! See quick_plot writeup for more details. ! width -- Integer, optional: Width of line ! color -- Integer, optional: Line color. ! style -- Integer, optional: Line style. ! clip -- Logical, optional: Clip at graph boundary? !- subroutine qp_draw_polyline (x, y, units, width, color, style, clip) implicit none real(rp) :: x(:), y(:) integer, optional :: width, color, style character(*), optional :: units logical, optional :: clip ! call qp_save_state (.true.) call qp_set_line_attrib ('STD', width, color, style, clip) call qp_draw_polyline_basic (x, y, units) call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_line (x1, x2, y1, y2, units, width, color, style, clip) ! ! Subroutine to draw a line. ! ! Input: ! x1, x2 -- Real(rp): X-coords of line endpoints ! y1, y2 -- Real(rp): Y-coords of line endpoints ! units -- Character(*), optional: Units of x, y. ! Default is: 'DATA/GRAPH/LB' ! See quick_plot writeup for more details. ! width -- Integer, optional: Width of line ! color -- Integer, optional: Line color. ! style -- Integer, optional: Line style. ! clip -- Logical, optional: Clip at graph boundary? !- subroutine qp_draw_line (x1, x2, y1, y2, units, width, color, style, clip) implicit none real(rp) :: x1, x2, y1, y2 integer, optional :: width, color, style character(*), optional :: units logical, optional :: clip ! call qp_save_state (.true.) call qp_set_line_attrib ('STD', width, color, style, clip) call qp_draw_polyline_basic ((/ x1, x2 /), (/ y1, y2 /), units) call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_polyline_basic (x, y, units) ! ! Subroutine to draw a polyline. ! See also qp_draw_polyline ! ! Input: ! x(:), y(:) -- Real(rp): (x, y) points for the polyline. ! units -- Character(*), optional: Units of x, y. ! Default is: 'DATA/GRAPH/LB' ! See quick_plot writeup for more details. !- subroutine qp_draw_polyline_basic (x, y, units) implicit none real(rp) :: x(:), y(:) real(rp) :: xd(size(x)), yd(size(y)) character(*), optional :: units ! call qp_to_data_abs (x, y, xd, yd, units) call pgline (size(x), real(xd), real(yd)) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_open_page (page_type, i_chan, x_len, y_len, units) ! ! Subroutine to Initialize a page (window) for plotting. ! ! Input: ! page_type -- Character(*). Device name for the type of plot. ! TYPE is passed to GG_SETUP. E.g. ! TYPE = 'X' --> Open an X-window. ! TYPE = 'GIF' --> To create a gif file. ! TYPE = 'PS' --> To create a Color PostScript file. ! TYPE = 'PS-L' --> PostScript w/ landscape page orientation. ! x_len -- Real(rp), optional: Horizontal width, Not used with PS. ! y_len -- Real(rp), optional: Vertical width, Not used with PS. ! units -- Character(*), optional: units for x_len and y_len. ! 'MM' - milimeters. ! 'INCH' - Inches. ! 'POINTS' - Point ! ! Output: ! i_chan -- Inteter, optional: Plot channel. ! Like a unit number for a fortran OPEN. ! To be used with qp_select_page. !- subroutine qp_open_page (page_type, i_chan, x_len, y_len, units) implicit none type (qp_struct), pointer, save :: q real(rp), optional :: x_len, y_len real(rp) x1p, x2p, y1p, y2p, x_inch, y_inch real x1i, x2i, y1i, y2i, h, xi, yi integer, optional :: i_chan integer pgopen, iw character(*) page_type character(*), optional :: units ! This is for debugging only q => qp_com ! if (quick_init_needed) call qp_init_struct (qp_com) qp_com%dflt_units = dflt_set$ ! set plot type if (page_type == 'X') then iw = pgopen ('/XWINDOW') call pgscr (0, 1.0, 1.0, 1.0) ! white background call pgscr (1, 0.0, 0.0, 0.0) ! black foreground elseif (page_type == 'PS') then iw = pgopen ('quick_plot.ps/VCPS') elseif (page_type == 'PS-L') then iw = pgopen ('quick_plot.ps/CPS') elseif (page_type == 'GIF') then iw = pgopen ('/GIF') else print *, 'ERROR IN QP_OPEN_PAGE: UNKNOWN PAGE_TYPE: ', page_type stop endif if (present(i_chan)) i_chan = iw call pgask (.false.) ! do not pause when clearing the screen. qp_com%page_type = page_type if (iw <= 0) then print *, 'ERROR IN QP_OPEN_PAGE: CANNONT OPEN OUTPUT DEVICE!' stop endif ! set page size if (page_type == 'X' .or. page_type == 'GIF') then call qp_to_inch_rel (x_len, y_len, x_inch, y_inch, units) call pgpap (real(x_inch), real(y_inch/x_inch)) endif ! Stuff info into common block call pgqvsz (1, x1i, x2i, y1i, y2i) ! page in inches qp_com%page%x1 = 0 qp_com%page%y1 = 0 qp_com%page%x2 = x2i qp_com%page%y2 = y2i ! clear page and set graph min/max call pgenv (real(qp_com%plot%x%min), real(qp_com%plot%x%max), & real(qp_com%plot%y%min), real(qp_com%plot%y%max), 0, -2) ! get the conversion factor for character height. call pgqch (h) ! text height in pgplot units. call pgqcs (1, xi, yi) ! size in inches qp_com%text_height_factor = h / (xi * 72) ! set the graph parameters call qp_set_box (1, 1, 1, 1) qp_com%dflt_units = dflt_draw$ end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_select_page (iw) ! ! Subroutine to switch to a particular page for drawing graphics. ! ! Input: ! iw -- Integer: ID of page obtained from qp_open_page !- subroutine qp_select_page (iw) implicit none integer iw ! call pgslct(iw) end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_close_page ! ! Subroutine to finish plotting on a page. ! For X this closes the window. ! You will need to call qp_open_page to do further graphics. ! ! Input: ! to_printer -- Logical, optional: If T and the page type is PostScript ! Then make a hardcopy. !- subroutine qp_close_page implicit none ! call pgclos if (qp_com%page_type(1:2) == 'PS') then print *, 'Written: quick_plot.ps' if (qp_com%page_type(3:3) == '/') then print *, 'QP_CLOSE_PAGE: TO_PRINTER SPAWN COMMAND DISABLED.' ! call lib$spawn ('@com:ccwplot quick_plot.ps/noflag') endif endif end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_text (text, x, y, units, justify, height ! color, angle, background, uniform_spacing, spacing_factor) ! ! Subroutine to draw text. ! ! Input: ! text -- Character(*): Character: Text to be displayed. ! x, y -- Real(rp): position of the text. ! units -- Character(*), optional: Units of x and y. ! Default is: 'DATA/GRAPH/LB' ! See quick_plot writeup for more details. ! justify -- Character(*), optional: Horizontal/vertical justification. ! Default is 'LB' (Left Bottom). ! height -- Real(rp), optional: height in points. ! color -- Integer, optional: Color index for the box ! angle -- Real(rp), optional: Angle to the horizontal (in degrees). ! Positive angle is CCW. ! background -- Integer, optional: Background color. ! uniform_spacing -- Logical, optional: If T then the distance between ! characters is uniform. ! spacing_factor -- Real(rp), optional: Spacing factor if uniform_spacing ! is used. !- subroutine qp_draw_text (text, x, y, units, justify, height, color, & angle, background, uniform_spacing, spacing_factor) implicit none real(rp) x, y real(rp), optional :: angle, height, spacing_factor integer, optional :: color, background character(*) text character(*), optional :: units, justify logical, optional :: uniform_spacing ! call qp_save_state (.false.) call qp_set_text_attrib ('TEXT', height, color, background, uniform_spacing) if (present(spacing_factor)) qp_com%text_spacing_factor = spacing_factor call qp_draw_text_basic (text, x, y, units, justify, angle) call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_text_basic (text, x, y, units, justify, angle) ! ! Subroutine to display on a plot a character string. ! See also: qp_draw_text. ! ! Input: ! text -- Character(*): Character: Text to be displayed. ! x, y -- Real(rp): position of the text. ! units -- Character(*), optional: Units of x and y. ! Default is: 'DATA/GRAPH/LB' ! See quick_plot writeup for more details. ! justify -- Character(*), optional: Horizontal/Vertical justification. ! Default is 'LB' (Left Bottom). ! angle -- Real(rp), optional: Angle to the horizontal (in degrees). ! Positive angle is CCW. ! uniform_spacing -- Logical, optional: If T then the distance between ! characters is uniform. !- subroutine qp_draw_text_basic (text, x, y, units, justify, angle) implicit none real(rp) x, y real(rp), optional :: angle real(rp) ang, just, x_dat, y_dat, dx, dy, x1, y1, yl integer ix, ixx, i character(*) text character(*), optional :: units, justify ! if (len_trim(text) == 0) return call qp_to_inch_abs (x, y, x1, y1, units) call qp_save_state (.false.) ang = 0 if (present(angle)) ang = angle if (present(justify)) then yl = qp_com%this_text%height / 72.0 dx = -yl * sin(twopi*ang) dy = yl * cos(twopi*ang) if (justify(2:2) == 'C') then x1 = x1 - dx / 2 y1 = y1 - dy / 2 elseif (justify(2:2) == 'T') then x1 = x1 - dx y1 = y1 - dy elseif (justify(2:2) /= 'B') then print *, 'ERROR IN QP_DRAW_TEXT_BASIC: UNKNOWN "JUSTIFY": ', justify call err_exit endif endif if (qp_com%this_text%uniform_spacing) then ixx = len(trim(text)) + 1 yl = qp_com%this_text%height / 72.0 dx = yl * cos(twopi*ang) * qp_com%text_spacing_factor dy = yl * sin(twopi*ang) * qp_com%text_spacing_factor x1 = x1 - dx * (ixx * qp_justify(justify) - 0.5) y1 = y1 - dy * (ixx * qp_justify(justify) - 0.5) do i = 1, len(trim(text)) call qp_to_datum_abs (x1+i*dx, y1+i*dy, x_dat, y_dat, 'INCH/PAGE/LB') call pgptxt (real(x_dat), real(y_dat), real(ang), 0.5, text(i:i)) enddo else call qp_to_datum_abs (x1, y1, x_dat, y_dat, 'INCH/PAGE/LB') call pgptxt (real(x_dat), real(y_dat), real(ang), & qp_justify(justify), trim(text)) endif call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Function qp_justify (justify) ! ! Function to convert a justify character string to a real value ! representing the horizontal justification. ! This is used in the subroutine pgptxt. ! ! Input: ! justify(1:1) -- Character(*), optional: Possibilities are: ! 'L' Left (Default) ! 'C' Center ! 'R' Right ! ! Output: ! qp_justify -- Real(rp): Between 0.0, 0.5, or 1.0. !- function qp_justify (justify) result (horiz_justy) implicit none character(*), optional :: justify real horiz_justy ! horiz_justy = 0.0 if (present(justify)) then if (justify(1:1) == 'C') then horiz_justy = 0.5 elseif (justify(1:1) == 'R') then horiz_justy = 1.0 elseif (justify(1:1) /= 'L') then print *, 'ERROR IN QP_JUSTIFY: BAD "JUSTIFY": ', justify call err_exit endif endif end function !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_main_title (lines, justify) ! ! Subroutine to plot the main title at the top of the page. ! ! Input: ! lines(:) -- Character(*): Array of lines to print ! justify -- Character(*), optional: Horizontal justification ! Vertical justification is ignored. ! 'L' is default. !- subroutine qp_draw_main_title (lines, justify) implicit none real(rp) rx real(rp) xt, yt, dx, dy, x_dat, y_dat integer i character(*) lines(:) character(*), optional :: justify ! call qp_save_state (.true.) call qp_set_text_attrib ('MAIN_TITLE') rx = 0.1 + 0.8 * qp_justify(justify) call qp_to_inch_abs (rx, 1.0_rp, xt, yt, '%PAGE') dy = qp_com%this_text%height / 72 do i = 1, size(lines) yt = yt - 1.5 * dy call qp_to_datum_abs (xt, yt, x_dat, y_dat, 'INCH/PAGE/LB') call pgptxt (real(x_dat), real(y_dat), 0.0, & qp_justify(justify), trim(lines(i))) enddo call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! subroutine qp_set_symbol_attrib (type, height, color, fill, line_width, clip) ! ! Subroutine to set the type and size of the symbols used in plotting data. ! See the pgplot documentation for more details. ! ! Input: ! type -- Integer, optional: Symbol type. ! height -- Real(rp), optional: Size of the symbol. ! color -- Integer, optional: Symbol color. ! fill -- Integer, optional: fill pattern. ! line_width -- Integer, optional: Line width. ! clip -- Logical, optional: Clip at graph boundary? ! Note: This sets the line clip also. !- subroutine qp_set_symbol_attrib (type, height, color, fill, line_width, clip) implicit none integer, optional :: type, line_width, fill, color real(rp), optional :: height real h logical, optional :: clip ! if (present(type)) then qp_com%symbol%type = type endif if (present(height)) then qp_com%symbol%height = height endif if (present(color)) then qp_com%symbol%color = color endif if (present(fill)) then qp_com%symbol%fill = fill endif if (present(line_width)) then qp_com%symbol%line_width = line_width endif call qp_set_clip (clip) ! The PGPLOT symbol set does not have a constant symbol size. ! This generally does not look nice so renormalize to get a consistant size. ! This excludes the set of circles with different sizes. h = qp_com%symbol%height * qp_com%text_height_factor if (qp_com%uniform_symbol_size) then if (qp_com%symbol%type == dot$) h = h * 2.0 ! I like bigger dots if (qp_com%symbol%type == triangle_filled$) h = h * 8.0 / 7.5 if (qp_com%symbol%type == square_filled$) h = h * 7.0 / 4.5 if (qp_com%symbol%type == circle_filled$) h = h * 8.0 / 5.0 if (qp_com%symbol%type == star5_filled$) h = h * 11.0 / 8.5 if (qp_com%symbol%type == square_concave$) h = h * 8.0 / 11.0 endif call pgsch (h) ! set symbol size ! set other parameters call pgsci (qp_com%symbol%color) ! set color call pgsfs (qp_com%symbol%fill) ! set fill call pgslw (qp_com%symbol%line_width) ! set line width end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! subroutine qp_set_line_attrib (who, width, color, style, clip) ! ! Subroutine to set the default line attributes. ! See the pgplot documentation for more details. ! ! Input: ! who -- Character(*): ! 'PLOT' -- Plot data lines. ! 'GRID' -- Graph grid. ! 'AXIS' -- Graph axis. ! 'STD' -- Everything else. ! style -- Integer, optional: Line style. ! width -- Integer, optional: Size of the line. ! color -- Integer, optional: Line color. ! clip -- Logical, optional: Clip at graph boundary? ! Note: This sets the symbol clip also. !- subroutine qp_set_line_attrib (who, width, color, style, clip) implicit none type (qp_line_struct), pointer :: this character(*) who integer, optional :: style, width, color logical, optional :: clip ! if (who == 'STD') then this => qp_com%std_line elseif (who == 'GRID') then this => qp_com%grid_line elseif (who == 'PLOT') then this => qp_com%plot_line elseif (who == 'AXIS') then this => qp_com%axis_line else print *, 'ERROR IN QP_SET_LINE_ATTRIB: UNKNOWN LINE "WHO": ', who call err_exit endif if (present(width)) then this%width = width endif if (present(color)) then this%color = color endif if (present(style)) then this%style = style endif call qp_set_clip (clip) ! call pgsci (this%color) ! set color call pgslw (this%width) ! set line width call pgsls (this%style) ! Set style end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_set_clip (clip) ! ! Subroutine to set the default clipping state. ! Note: This affects both lines and symbols. ! ! Input: ! clip -- Logical, optional: Clip at graph boundary? !- subroutine qp_set_clip (clip) implicit none logical, optional :: clip if (present(clip)) then qp_com%clip = clip endif if (qp_com%clip) then call pgsclp (1) ! Clip on else call pgsclp (0) ! Clip off endif end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_subset_box (ix, iy, ix_tot, iy_tot, x_marg, y_marg) ! ! Subroutine to set the box for a graph. This is the same as ! QP_SET_BOX but the boundries of the page are taken to be the box boundries ! set by QP_SET_BOX. The margins between the graphs and the edges of the "page" ! are what is set by QP_SET_MARGIN. The distance between graphs is given by the ! arguments X_MARG, Y_MARG. SUBGRAPH is used to cluster graphs together. ! ! Input: ! ix_tot, iy_tot -- Integer: X and Y box divisions of the "page". ! ix, iy -- Integer: Index for box to be used. ! x_marg, y_marg -- Real(rp): Margins between boxes !- subroutine qp_subset_box (ix, iy, ix_tot, iy_tot, x_marg, y_marg) implicit none integer ix, iy, ix_tot, iy_tot real(rp) x_marg, y_marg real(rp) x_width, y_width ! x_width and y_width are the size of the graphs x_width = (qp_com%box%x2 - qp_com%box%x1 - qp_com%margin%x1 - & qp_com%margin%x2 - (ix_tot - 1) * x_marg) / ix_tot y_width = (qp_com%box%y2 - qp_com%box%y1 - qp_com%margin%y1 - & qp_com%margin%y2 - (iy_tot - 1) * y_marg) / iy_tot qp_com%graph%x1 = qp_com%box%x1 + qp_com%margin%x1 + & (ix - 1) * (x_marg + x_width) qp_com%graph%x2 = qp_com%graph%x1 + x_width qp_com%graph%y1 = qp_com%box%y1 + qp_com%margin%y1 + & (iy - 1) * (y_marg + y_width) qp_com%graph%y2 = qp_com%graph%y1 + y_width ! set QP_COM%SUBGRAPH_ON so SET_GRAPH_LIMITS will not ! recalculate the graph boundry qp_com%subgraph_on = .true. call qp_set_graph_limits end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_set_text_attrib (who, height, color, background, & ! uniform_spacing, spacing_factor) ! ! Subroutine to set the default text attributes. ! See the pgplot documentation for more details. ! Note: The background color index is common to all types of text. ! If you set it you set it for all text. ! ! Input: ! who -- Character(*): Used by: Comment ! "TEXT" QP_DRAW_TEXT General text. ! "MAIN_TITLE" QP_DRAW_MAIN_TITLE Title at top of page. ! "GRAPH_TITLE" QP_DRAW_GRAPH_TITLE Title above a graph. ! "LEGEND" QP_DRAW_LEGEND Legend. ! "AXIS_NUMBERS" QP_DRAW_GRAPH Axes Numbers. ! "AXIS_LABEL" QP_DRAW_GRAPH Axis label. ! height -- Real(rp), optional: Character height. ! color -- Integer, optional: Color index. ! background -- Integer, optional: Background color index. ! uniform_spacing -- Logical, optional: If T then the distance between ! characters is uniform. ! spacing_factor -- Real(rp), optional: Spacing factor for the ! uniform_spacing option. This is set globally for all "who". !- subroutine qp_set_text_attrib (who, height, color, background, & uniform_spacing, spacing_factor) implicit none integer, optional :: color, background real(rp), optional :: height, spacing_factor logical, optional :: uniform_spacing character(*) who ! if (who == "MAIN_TITLE") then call qp_set_this_char_size (qp_com%main_title) elseif (who == "GRAPH_TITLE") then call qp_set_this_char_size (qp_com%graph_title) elseif (who == "LEGEND") then call qp_set_this_char_size (qp_com%legend) elseif (who == "TEXT") then call qp_set_this_char_size (qp_com%text) elseif (who == "AXIS_NUMBERS") then call qp_set_this_char_size (qp_com%axis_number) elseif (who == "AXIS_LABEL") then call qp_set_this_char_size (qp_com%axis_label) else print *, 'ERROR IN QP_SET_TEXT_ATTRIB: BAD "WHO": "', trim(who), '"' call err_exit endif contains subroutine qp_set_this_char_size (this_text) type (qp_text_struct) this_text if (present(spacing_factor)) qp_com%text_spacing_factor = spacing_factor if (present(height)) then this_text%height = height endif if (present(color)) then this_text%color = color endif if (present(background)) then qp_com%text_background = background endif if (present(uniform_spacing)) then this_text%uniform_spacing = uniform_spacing endif call pgsch(real(this_text%height * qp_com%text_height_factor)) ! set height call pgsci(this_text%color) ! set color call pgstbg (qp_com%text_background) ! set text background color qp_com%this_text = this_text end subroutine end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! subroutine qp_draw_x_axis (who, y_pos) ! ! Subroutine to draw a horizontal axis. ! ! Input: ! who -- Character(*): Which axis: ! 'X' -- Normal x-axis. ! 'X2' -- Secondary x-axis. ! y_pos -- Real: Vertical position (%GRAPH): ! 0.0 = Bottom ! 1.0 = Top !- subroutine qp_draw_x_axis (who, y_pos) implicit none type (qp_axis_struct) axis, ax real(rp) del, dx0, dum, x1, y1, dy, x0, y0, y_pos, dy1, dy2 real(rp) dy11, dy22, x11 integer i, j, m_div character(*) who character(16) justify, str ! save state call qp_save_state (.false.) call qp_set_clip (.false.) ! no clipping of axis ! who? if (who == 'X') then axis = qp_com%plot%x elseif (who == 'X2') then axis = qp_com%plot%x2 else print *, 'ERROR IN QP_DRAW_X_AXIS: BAD AXIS NAME: ', who endif ! mirror? if (axis%mirror_on) then ax = axis%mirror else ax = axis endif ! the axis line itself call qp_set_line_attrib ('AXIS') call qp_set_text_attrib ('AXIS_NUMBERS') call qp_draw_polyline_basic ((/ 0.0_rp, 1.0_rp /), & (/y_pos, y_pos /), '%GRAPH') del = (ax%max - ax%min) / ax%major_div if (ax%minor_div == 0) then call qp_calc_minor_div (del, ax%minor_div_max, m_div) else m_div = ax%minor_div endif if (axis%tick_side == 0) then dy1 = ax%major_tick_len dy2 = -ax%major_tick_len dy11 = ax%minor_tick_len dy22 = -ax%minor_tick_len else dy1 = 0 dy2 = ax%major_tick_len * axis%tick_side dy11 = 0 dy22 = ax%minor_tick_len * axis%tick_side endif call qp_to_inch_rel (0.0_rp, y_pos, x0, y0, '%GRAPH') call qp_to_inch_rel (1.0_rp / ax%major_div, 0.0_rp, dx0, dum, '%GRAPH') if (ax%number_side == +1) then justify = 'CB' else justify = 'CT' endif ! axis ticks and numbers do i = 0, ax%major_div x1 = i*dx0 y1 = y0 + axis%number_side * ax%number_offset ! numbers if (axis%draw_numbers) then call qp_to_axis_number_text (ax, i, str) if (i == 0) then call qp_draw_text_basic (str, x1, y1, 'INCH', justify) elseif (i == ax%major_div) then call qp_draw_text_basic (str, x1, y1, 'INCH', justify) else call qp_draw_text_basic (str, x1, y1, 'INCH', justify) endif endif ! major ticks call qp_draw_polyline_basic ((/x1, x1 /), (/ y0+dy1, y0+dy2 /), 'INCH') enddo ! minor ticks do i = 0, ax%major_div - 1 do j = 1, m_div - 1 x11 = (i + real(j) / m_div) * dx0 call qp_draw_polyline_basic ((/ x11, x11 /), & (/ y0+dy11, y0+dy22 /), 'INCH') enddo enddo if (axis%draw_label) then call qp_set_text_attrib ('AXIS_LABEL') call qp_to_inch_rel (0.5_rp, y_pos, x0, y0, '%GRAPH') dy = ax%number_side * (qp_com%axis_number%height/72 + & ax%number_offset + ax%label_offset) call qp_draw_text_basic (axis%label, x0, y0+dy, 'INCH', justify) endif ! call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! subroutine qp_draw_y_axis (who, x_pos) ! ! Subroutine to draw a horizontal axis. ! ! Input: ! who -- Character(*): Which axis: ! 'Y' -- Normal y-axis. ! 'Y2' -- Secondary y-axis. ! x_pos -- Real: Horizontal position (%GRAPH): ! 0.0 = Left ! 1.0 = Right !- subroutine qp_draw_y_axis (who, x_pos) implicit none type (qp_axis_struct) axis, ax real(rp) del, dx0, dum, x1, y1, dx, x0, y0, x_pos, dx1, dx2, dx11, dx22 real(rp) number_len, dy0, y11 integer i, j, m_div character(*) who character(2) justify character(16) str ! save state call qp_set_clip (.false.) ! no clipping of axis call qp_save_state (.true.) ! who? if (who == 'Y') then axis = qp_com%plot%y elseif (who == 'Y2') then axis = qp_com%plot%y2 else print *, 'ERROR IN QP_DRAW_Y_AXIS: BAD AXIS NAME: ', who endif ! mirror? if (axis%mirror_on) then ax = axis%mirror else ax = axis endif ! draw axis line itself call qp_set_line_attrib ('AXIS') call qp_set_text_attrib ('AXIS_NUMBERS') call qp_draw_polyline_basic ((/x_pos, x_pos/), & (/0.0_rp, 1.0_rp/), '%GRAPH') ! major and minor divisions calc del = (ax%max - ax%min) / ax%major_div if (ax%minor_div == 0) then call qp_calc_minor_div (del, ax%minor_div_max, m_div) else m_div = ax%minor_div endif if (axis%tick_side == 0) then dx1 = ax%major_tick_len dx2 = -ax%major_tick_len dx11 = ax%minor_tick_len dx22 = -ax%minor_tick_len else dx1 = 0 dx2 = ax%major_tick_len * axis%tick_side dx11 = 0 dx22 = ax%minor_tick_len * axis%tick_side endif call qp_to_inch_rel (x_pos, 0.0_rp, x0, y0, '%GRAPH') call qp_to_inch_rel (0.0_rp, 1.0_rp / ax%major_div, dum, dy0, '%GRAPH') ! draw axis ticks and numbers number_len = 0 ! length in inches do i = 0, ax%major_div x1 = x0 + axis%number_side * ax%number_offset y1 = i*dy0 ! numbers if (axis%draw_numbers) then call qp_to_axis_number_text (ax, i, str) if (ax%number_side == +1) then justify = 'L' else justify = 'R' endif if (i == 0) then justify(2:2) = 'B' elseif (i == ax%major_div) then justify(2:2) = 'T' else justify(2:2) = 'C' endif call qp_draw_text_basic (str, x1, y1, 'INCH', justify) number_len = max (number_len, text_len(str)) endif ! major ticks call qp_draw_polyline_basic ((/ x0+dx1, x0+dx2 /), (/ y1, y1 /), 'INCH') enddo ! minor ticks do i = 0, ax%major_div-1 do j = 1, m_div - 1 y11 = (i + real(j) / m_div) * dy0 call qp_draw_polyline_basic ((/ x0+dx11, x0+dx22 /), & (/ y11, y11 /), 'INCH') enddo enddo ! draw label if (axis%draw_label) then call qp_set_text_attrib ('AXIS_LABEL') call qp_to_inch_rel (x_pos, 0.5_rp, x0, y0, '%GRAPH') dx = axis%number_side * & (axis%number_offset + axis%label_offset + number_len) call qp_draw_text_basic (axis%label, x0+dx, y0, 'INCH', 'CB', & angle = -90.0_rp*axis%number_side) endif ! call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_to_axis_number_text (axis, ix_n, text) ! ! Subroutine to form the text string for an axis number. ! ! Input: ! axis -- qp_axis_struct: ! ix_n -- Integer: Index of particular number. ! ! Output: ! text -- Character(*): Character string. !- subroutine qp_to_axis_number_text (axis, ix_n, text) implicit none type (qp_axis_struct) axis integer ix_n, id, ip real(rp) val character(*) text character(20) fmt ! id is the number of characters we need to draw id = max(0.0_rp, 1.01*log10(max(abs(axis%max), abs(axis%min)))) + 1 if (axis%max < 0 .or. axis%min < 0) id = id + 1 id = id + axis%places if (axis%places > 0) then ip = axis%places ! number of digits after the decimal place id = id + 1 ! for decimal place else ip = 0 endif val = axis%min + ix_n * (axis%max - axis%min) / axis%major_div if (axis%places < 0) val = val * 10**axis%places if (ip == 0) then write (fmt, '(a, i2.2, a)') '(i', id, ')' write (text, fmt) nint(val) else write (fmt, '(a, i2.2, a, i2.2, a)') '(f', id, '.', ip, ')' write (text, fmt) val endif end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Function text_len (text) ! ! Function to find the length of a text string. ! ! input: ! text -- Character(*): Text string. ! ! Output: ! text_len -- Real(rp): Length of text in inches. !- function text_len (text) result (t_len) implicit none real(rp) t_len real tl, dum character(*) text ! call pglen (1, trim(text), tl, dum) t_len = tl end function !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_set_graph_attrib (draw_grid, draw_title) ! ! Subroutine to set attributes of the current graph ! ! Input: ! draw_grid -- Logical, optional: Draw a grid? ! draw_title -- Logical, optional: Draw the title? !- Subroutine qp_set_graph_attrib (draw_grid, draw_title) implicit none logical, optional :: draw_grid, draw_title ! if (present(draw_grid)) qp_com%plot%draw_grid = .true. if (present(draw_title)) qp_com%plot%draw_title = .true. end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_draw_grid ! ! Subroutine to draw a grid on the current graph. !- subroutine qp_draw_grid implicit none real(rp) z(2), r01(2) integer i ! call qp_save_state (.true.) call qp_set_line_attrib ('GRID') r01 = (/ 0.0, 1.0 /) ! horizontal lines do i = 1, qp_com%plot%x%major_div - 1 z = real(i) / qp_com%plot%x%major_div call qp_draw_polyline_basic (z, r01, '%GRAPH') enddo ! vertical lines do i = 1, qp_com%plot%y%major_div - 1 z = real(i) / qp_com%plot%y%major_div call qp_draw_polyline_basic (r01, z, '%GRAPH') enddo ! call qp_restore_state end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_calc_minor_div (delta, div_max, divisions) ! ! Subroutine to calculate the number of minor divisions an axis should have. ! This routine picks the maximum number of minor divisions consistant with ! the restrictions that the number of divisions is "nice" and that ! divisions <= div_max ! ! Input: ! delta -- Real(rp): Axis width between main divisions. ! div_max -- Integer: Maximum number divisions can be. ! ! Output: ! divisions -- Integer: Number of minor divisions. ! Minimum number this can be is 1. !- subroutine qp_calc_minor_div (delta, div_max, divisions) implicit none real(rp) delta real(8) log_del integer div_max, divisions, idel ! scale delta so it is in the range of [10, 100) log_del = log10 (delta * 1.000000001_8) idel = nint(delta / 10.0**(floor(log_del)-1)) ! start with the maximum allowed and work downward until we get a nice number do divisions = div_max, 1, -1 if (idel == 10 .and. divisions == 4) return ! Is nice if (idel == 40 .and. divisions == 5) cycle ! Not nice if (idel == 60 .and. divisions == 5) cycle ! Not nice if (idel == 80 .and. divisions == 5) cycle ! Not nice if (mod(idel, divisions) == 0) return enddo divisions = 1 end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_translate_to_color_index (name, index) ! ! Subroutine to translate from a string to a color index. ! Translation is case insensitive. ! ! Input: ! name -- Character(*): Name of the color. ! ! Output: ! index -- Integer: Color index. -1 => Unknown name. !- subroutine qp_translate_to_color_index (name, index) implicit none character(*) name character(16) color, this integer index ! call str_upcase (this, name) do index = lbound(qp_color_name, 1), ubound (qp_color_name, 1) call str_upcase (color, qp_color_name(index)) if (color == this) return enddo print *, 'ERROR IN QP_TRANSLATE_TO_COLOR_INDEX: UNKNOWN COLOR NAME: ', name index = -1 end subroutine !----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+ ! Subroutine qp_read_data (iu, err_flag, x, ix_col, y, iy_col, z, iz_col, ! t, it_col) ! ! Subroutine to read columns of data. ! Note: This routine assumes that the file has already been opened. ! The routine will read from the current record down until data is ! encountered and then will read until an end-of-file or a non-data line ! is encountered. A non-data line is a line whose first non-blank character ! is not a digit or a ".", "-", or "+". ! ! By repeated calls to qp_read_data you can read in multiple data sets. ! A data set can be skipped by using only the first 2 arguments: ! call qp_read_data (iu, err_flag) ! ! Input: ! iu -- Integer: File unit number. ! err_flag -- Logical: Set True if there is an error reading data. ! ix_col -- Integer, optional: Column number of the x data. ! iy_col -- Integer, optional: Column number of the y data. ! iz_col -- Integer, optional: Column number of the z data. ! it_col -- Integer, optional: Column number of the t data. ! ! Output: ! x -- Real(rp), allocatable, optional: Array to put data. The array ! size will be changed to match the number of data points. ! y -- Real(rp), allocatable, optional: Another array for data. ! z -- Real(rp), allocatable, optional: Another array for data. ! t -- Real(rp), allocatable, optional: Another array for data. ! ! !- subroutine qp_read_data (iu, err_flag, x, ix_col, y, iy_col, & z, iz_col, t, it_col) implicit none integer, parameter :: i_del = 100 real(rp), allocatable, optional :: x(:), y(:), z(:), t(:) real(rp), allocatable, save :: xyz(:) real(rp) :: x1(i_del), y1(i_del), z1(i_del), t1(i_del) integer i, j, ix integer iu, i_size integer, optional :: ix_col, iy_col, iz_col, it_col logical err_flag, good_x, good_y, good_z, good_t character(140) line, line_in ! call skip_header (iu, err_flag) if (err_flag) return allocate (xyz(0)) ! loop over lines i_size = 0 ! size of x, y, and z arrays if (present(x)) then if (allocated(x)) deallocate(x) allocate (x(0)) endif if (present(y)) then if (allocated(y)) deallocate(y) allocate (y(0)) endif if (present(z)) then if (allocated(z)) deallocate(z) allocate (z(0)) endif if (present(t)) then if (allocated(t)) deallocate(t) allocate (t(0)) endif do do i = 1, i_del read (iu, '(a)', end = 8000) line_in call string_trim (line_in, line, ix) if (index('1234567890-+.', line(1:1)) == 0) goto 8000 ! loop over columns good_x = .false.; good_y = .false.; good_z = .false.; good_t = .false. do j = 1, 200 if (present(x)) then if (ix_col == j) then read (line, *, err = 9000) x1(i) good_x = .true. endif endif if (present(y)) then if (iy_col == j) then read (line, *, err = 9000) y1(i) good_y = .true. endif endif if (present(z)) then if (iz_col == j) then read (line, *, err = 9000) z1(i) good_z = .true. endif endif if (present(t)) then if (it_col == j) then read (line, *, err = 9000) t1(i) good_t = .true. endif endif call string_trim (line(ix+1:), line, ix) if (ix == 0) exit enddo if (.not. good_x .and. present(x)) goto 9000 if (.not. good_y .and. present(y)) goto 9000 if (.not. good_z .and. present(z)) goto 9000 if (.not. good_t .and. present(t)) goto 9000 enddo ! transfer x1, y1, and z1 arrays to x, y, and z. if (present(x)) call load_data(x, x1) if (present(y)) call load_data(y, y1) if (present(z)) call load_data(z, z1) if (present(t)) call load_data(t, t1) i_size = i_size + i_del enddo ! last transfer 8000 continue if (present(x)) call load_data(x, x1(1:i-1)) if (present(y)) call load_data(y, y1(1:i-1)) if (present(z)) call load_data(z, z1(1:i-1)) if (present(t)) call load_data(t, t1(1:i-1)) deallocate(xyz) return ! 9000 continue print *, 'ERROR IN QP_READ_DATA: ERROR READING DATA LINE: ' print *, ' ', trim(line_in) err_flag = .true. deallocate(xyz) !-------------------------------------------------------------------------- contains subroutine load_data (t, t1) real(rp), allocatable :: t(:) real(rp) :: t1(:) integer id id = size(t1) if (size(xyz) < i_size+id) then deallocate (xyz) allocate (xyz(i_size+id)) endif xyz(1:i_size) = t xyz(i_size+1:i_size+id) = t1 deallocate (t) allocate (t(i_size+id)) t = xyz(1:i_size+id) end subroutine end subroutine end module