MODULE DAdobe_Illustrator !================================================= ! ! Initial letter "D" indicates a DOUBLE PRECISION (REAL*8) version, ! created 2015.02 as part of a systematic upgrade of several of my codes ! (Shells, NeoKinema, FiniteMap, & NeoKineMap) to 64-bit precision. ! It is intended that the "D" FUNCTIONs and SUBROUTINEs here should be ! logically equivalent to those in MODULE Adobe_Illustrator, ! just more precise. Naturally, they now all take REAL*8 arguments ! in place of the old REAL arguments. ! ! Updated versions copyright 2015 by Peter Bird and the ! Regents of the University of California. ! !---------------------------------------------------------------------- ! ! Contains routines to produce graphics files readable by ! Adobe Illustrator for Windows, versions 4, 7, ...? ! ! Requires the assistance of a "frame" or "model" Adobe ! Illustrator file containing standard macro definitions, ! standard font definitions, custom color definitions ! (matching those used here), custom pattern definitions ! (matching those used here), but no visible graphics. ! Examples of such files are: LanModel.ai, AI4Frame.ai, ! and AI7Frame.ai. (If you want to include bitmaps, you ! must use AI7Frame.ai and open illustrations in AI 7.) ! ! The measurement unit for this module is the point ! (1/72 of an inch). Positions are measured from ! the lower-left corner of the paper. ! ! The original MODULE Adobe_Illustrator was created ! by Peter Bird, UCLA, May-August 1997 and April-November 1999. ! Copyright (c) 1997, 1999 by Peter Bird and the ! Regents of the University of California. !---------------------------------------------------------------------- ! ! Correct order of use for these USER SUBROUTINES: ! CALL DSelect_Paper ! CALL DSet_Background ! CALL DDefine_Margins ! CALL DBegin_Page ! CALL DSet_Window [ optional; Begin_Page computes best window ] ! CALL DBegin_Group {optional} ! CALL DSet_Line_Style ! CALL DSet_Stroke_Color ! CALL DSet_Fill_or_Pattern {OR} ! CALL DSet_Custom_Fill ! CALL DBegin_Compound_Path {optional} ! CALL DNew_L12_Path ! CALL DLine_To_L12 ! CALL DCurve_To_L12 ! CALL DEnd_L12_Path ! CALL DNew_L12_Path ! CALL DLine_To_L12 ! CALL DCurve_To_L12 ! CALL DEnd_L12_Path ! CALL DEnd_Compound_Path {optional} ! CALL DCircle_on_L12 ! CALL DL12_Text ! CALL DEnd_Group {optional} ! CALL DBitmap_on_L1 [ not available with AI 4; needs AI 7] ! CALL DEnd_Page ! ! Following are UTILITY SUBROUTINES AND FUNCTIONS: ! REAL*8 FUNCTION DATAN2F ! SUBROUTINE DAI_Pack_Ints_Left ! SUBROUTINE DBezier_Fragment ! SUBROUTINE DCircle_and_Line ! SUBROUTINE DCubic_Roots ! CHARACTER*1 FUNCTION DIn_Path ! CHARACTER*1 FUNCTION DIn_Window ! SUBROUTINE DMid_Bezier ! INTEGER FUNCTION DNext_Free_Path ! INTEGER FUNCTION DNext_Path ! SUBROUTINE DPath_Area ! SUBROUTINE DProcess_L2_Paths ! SUBROUTINE DProcess_L2_Text ! SUBROUTINE DSateh ! SUBROUTINE DSet_Join_to_Mitre ! SUBROUTINE DSet_Join_to_Round ! SUBROUTINE DSet_Join_to_Bevel ! SUBROUTINE DSort_Lists ! SUBROUTINE DTraceback ! SUBROUTINE DTrace_Boundary ! SUBROUTINE DUpdate_Fill_or_Pattern ! LOGICAL FUNCTION DValid_Color ! SUBROUTINE DWrite_L1_Paths ! SUBROUTINE DWrite_L1_Text ! SUBROUTINE DX_Marks !---------------------------------------------- IMPLICIT NONE !Minimum amplitude (deviation from straight line) for a curve ! segment to be output as a curveto. Straighter segments ! will be replaced with lineto's. REAL*8, PARAMETER :: ai_min_amplitude_points = 0.5D0 INTEGER :: ai_version = 4 !This value will be replaced by a value inferred from the model .ai file, !if this inference is possible. The only difference between versions is !that version 4 does not support placed bitmaps; you need version 7 for this. LOGICAL :: ai_paper_selected = .FALSE. REAL*8 :: ai_paper_width_points = 792.0D0, & & ai_paper_height_points = 612.0D0 LOGICAL :: ai_background_set = .FALSE., & & ai_black_background = .FALSE. LOGICAL :: ai_margins_defined = .FALSE. REAL*8 :: ai_top_limit_points = 596.0D0, & & ai_left_limit_points = 14.0D0, & & ai_right_limit_points = 781.0D0, & & ai_bottom_limit_points = 14.0D0, & & ai_lonlatlabel_points = 10.0D0, & & ai_toptitles_points = 28.0D0, & & ai_rightlegend_points = 72.0D0, & & ai_bottomlegend_points = 50.0D0 LOGICAL :: ai_toptitles_reserved = .FALSE., & & ai_bottomlegend_reserved = .FALSE., & & ai_rightlegend_reserved = .FALSE. REAL*8 :: ai_window_x1_points = 14.0D0, & & ai_window_x2_points = 781.0D0, & & ai_window_y1_points = 14.0D0, & & ai_window_y2_points = 596.0D0, & & ai_window_xc_points = 397.5D0, & & ai_window_yc_points = 305.0D0 INTEGER, PARAMETER :: ai_in_unit = 100 INTEGER, PARAMETER :: ai_out_unit = 101 LOGICAL :: ai_page_open = .FALSE. INTEGER :: ai_groups_open = 0 LOGICAL :: ai_last_line_was_u = .FALSE. INTEGER :: ai_compound_paths_open = 0 LOGICAL :: ai_last_line_was_star_u = .FALSE. LOGICAL :: ai_current_line_dashed = .FALSE., & & ai_next_line_dashed = .FALSE. REAL*8 :: ai_current_line_width_points = 1.0D0, & & ai_current_line_on_points = 4.0D0, & & ai_current_line_off_points = 4.0D0, & & ai_next_line_width_points = 1.0D0, & & ai_next_line_on_points = 4.0D0, & & ai_next_line_off_points = 4.0D0 CHARACTER*10 :: ai_current_line_color = 'undefined_', & & ai_next_line_color = 'foreground' REAL*8 :: ai_last_L12_x_points = -9999.D0, & ! last "pen" position, & ai_last_L12_y_points = -9999.D0 ! used to decide which lineto's ! are degenerate; -9999.D0 is "undefined" LOGICAL :: ai_current_using_pattern = .FALSE., & & ai_next_using_pattern = .FALSE., & & ai_output_new_fill = .TRUE. REAL*8 :: ai_C_R8, ai_M_R8, ai_Y_R8, ai_K_R8 CHARACTER*10 :: ai_current_fill = 'undefined_', & & ai_next_fill = 'undefined_' LOGICAL :: ai_in_path = .FALSE. INTEGER :: ai_current_path_level = 0, & & ai_current_path_index = 1 ! AI path library; holds a number of paths as they are ! processed through the various levels, and finally written. INTEGER :: ai_total_paths = 0 ! (sum of paths at all levels, currently in the library) INTEGER, DIMENSION(7) :: ai_Ln_paths = 0 ! (counts of the number of paths in ai_pathlib at level n = 1,..., 7) INTEGER, PARAMETER :: ai_max_paths = 100 ! number of paths stored ! Notes: Hard to anticipate exact need; increase if required. ! This value (100) was increased from the previous value (10) in the older REAL version. INTEGER, PARAMETER :: ai_longest = 100000 ! max points in each path ! Note: 4000 seems excessive, but Baffin Island requires 1400, ! Alaska_state.dig requires 1800, Canada_nation.dig requires 3800, ! USA_nation.dig requires 3600, and Mexico_nation.dig requires 1900. ! Worst case: Processing Outcrops_xy.dig --> Outcrops_lonlat.dig ! (derived from Geologic Map of North America; area within WNA outline_xy.dig ONLY) ! required 4,000 to be increased to 100,000 in 2018.10. REAL*8, DIMENSION(1:6, 0:ai_longest, 1:ai_max_paths) :: ai_pathlib ! 1st subscript (1:6,,) is: *(x,y) of level 1/2/3 moveto/lineto (+4 empty); ! OR *(x1,y1,x2,y2,x3,y3) of level 1/2/3 curveto; ! OR *(x,y,z) of level 4/5 great_to (+3 empty); ! OR *(x,y,z,xp,yp,zp) of level 4/5 small_to; ! OR *(theta,phi) of level 6 great_to (+4 empthy); ! OR *(theta,phi,theta_p,phi_p) of level 6 small_to (+2 empty); ! OR *(lon,lat) of level 7 great_to (+4 empty); ! OR *(lon,lat,lon_p,lat_p) of level 7 small_to (+2 empty). ! 2nd subscript (,0:ai_longest,) is: 0 for initial point of path; ! 1:ai_longest for end points of segments. ! 3rd subscript (,,1:ai_max_paths) is library-bin index; not all bins ! necessarily contain valid paths. INTEGER, DIMENSION(ai_max_paths) :: ai_path_level = 0 ! -1 = temporary working storage; 0 = free; 1,2,...,7 = level INTEGER, DIMENSION(ai_max_paths) :: ai_segments ! length of path in segments (not counting initial point) LOGICAL, DIMENSION(ai_longest, ai_max_paths) :: ai_bent ! at levels 1/2/3 indicates curveto instead of lineto; ! at levels 4/5/6/7 indicates small_to instead of great_to. ! Note that this is a property of the segment, not of the control points. LOGICAL, DIMENSION(ai_max_paths) :: ai_closed, ai_stroked, ai_filled ! Is this whole path to be closed, stroked, filled? ! Note that every path must be: stroked, or filled, or both stroked and filled. ! Filled paths are normally closed. Indicating ai_closed = T is NOT a replacement ! for programming moveto/lineto/great_to/small_to operations that actually ! bring the path back to its initial point; you need both! LOGICAL :: ai_using_color = .TRUE. ! (alternative is grey-scale) TYPE ai_custom_color CHARACTER*10 color_name ! use _ instead of space(s) at end REAL*8, DIMENSION(4) :: cmyk ! cyan, magenta, yellow, black INTEGER, DIMENSION(3) :: rgb ! red, green, blue END TYPE ai_custom_color ! (all in range 0.00 to 1.00) TYPE (ai_custom_color) :: white = & ! absolute & ai_custom_color('white_____',(/0.00,0.00,0.00,0.00/),(/255,255,255/)) TYPE (ai_custom_color) :: black = & ! absolute & ai_custom_color('black_____',(/0.00,0.00,0.00,1.00/),(/ 0, 0, 0/)) TYPE (ai_custom_color) :: ai_background, ai_foreground ! defined at run-time INTEGER, PARAMETER :: ai_spectrum_count = 12 TYPE (ai_custom_color), DIMENSION(0:ai_spectrum_count+1) :: ai_spectrum = (/ & & ai_custom_color('off_white_',(/0.00,0.00,0.00,0.10/),(/230,230,230/)), & ! 0 & ai_custom_color('magenta___',(/0.00,0.35,0.00,0.00/),(/249,167,210/)), & ! 1 & ai_custom_color('red_______',(/0.00,1.00,0.60,0.00/),(/249, 2, 51/)), & ! 2 & ai_custom_color('brick_____',(/0.20,1.00,0.60,0.05/),(/190, 1, 48/)), & ! 3 & ai_custom_color('brown_____',(/0.20,0.55,0.60,0.00/),(/202,106, 75/)), & ! 4 & ai_custom_color('bronze____',(/0.10,0.25,0.80,0.00/),(/229,183, 47/)), & ! 5 & ai_custom_color('yellow____',(/0.00,0.00,1.00,0.00/),(/255,255, 0/)), & ! 6 & ai_custom_color('yellowgree',(/0.50,0.00,0.90,0.00/),(/128,196, 48/)), & ! 7 & ai_custom_color('green_____',(/1.00,0.10,1.00,0.00/),(/ 0,122, 50/)), & ! 8 & ai_custom_color('blue_green',(/0.80,0.00,0.30,0.00/),(/ 52,173,160/)), & ! 9 & ai_custom_color('sky_blue__',(/0.40,0.00,0.00,0.00/),(/154,217,232/)), & ! 10 & ai_custom_color('mid_blue__',(/0.85,0.00,0.00,0.00/),(/ 40,174,206/)), & ! 11 & ai_custom_color('dark_blue_',(/1.00,0.00,0.00,0.25/),(/ 1,120,148/)), & ! 12 & ai_custom_color('gray______',(/0.00,0.00,0.00,0.50/),(/128,128,128/)) & ! 13 & /) INTEGER, PARAMETER :: ai_pattern_count = 12 ! This indicates how many shading patterns are predefined in ! model_ai_filename, read by Begin_Page; it should normally be equal ! to ai_spectrum_count so that changes caused by switching ! ai_using_color(?) are minimized. CONTAINS !------------------------------------------------------- ! =============================================== ! | USER ROUTINES | ! | (in the typical order of use) | ! =============================================== SUBROUTINE DSelect_Paper (paper_width_points, paper_height_points) IMPLICIT NONE REAL*8, INTENT(IN) :: paper_width_points, paper_height_points IF (MIN(paper_width_points,paper_height_points) < 72.0D0) THEN WRITE (*,"(' ERROR: Minimum paper size is 72.0 points.')") CALL DTraceback ELSE ai_paper_selected = .TRUE. ai_paper_width_points = paper_width_points ai_paper_height_points = paper_height_points END IF END SUBROUTINE DSelect_Paper SUBROUTINE DSet_Background (black) ! Every page will begin with a rectangle of custom color ! 'background' placed at the back. ! IF (black), redefines custom color 'background' from white to black, ! and custom color 'foreground' from black to white. ! The resulting graphic is white + colors on black, which is ! sometimes desired for slide copy and/or computer displays. IMPLICIT NONE LOGICAL, INTENT(IN) :: black IF (ai_paper_selected) THEN ai_background_set = .TRUE. ai_black_background = black ai_foreground%color_name = 'foreground' ai_background%color_name = 'background' IF (black) THEN ai_background%cmyk = (/ 0.D0, 0.D0, 0.D0, 1.D0 /) ! black ai_background%rgb = (/ 0, 0, 0 /) ! black ai_foreground%cmyk = (/ 0.D0, 0.D0, 0.D0, 0.D0 /) ! white ai_foreground%rgb = (/ 255, 255, 255 /) ! white ELSE ai_background%cmyk = (/ 0.D0, 0.D0, 0.D0, 0.D0 /) ! white ai_background%rgb = (/ 255, 255, 255 /) ! white ai_foreground%cmyk = (/ 0.D0, 0.D0, 0.D0, 1.D0 /) ! black ai_foreground%rgb = (/ 0, 0, 0 /) ! black END IF ELSE WRITE (*,"(' ERROR: must Select_Paper before Black_Background.')") CALL DTraceback END IF END SUBROUTINE DSet_Background SUBROUTINE DDefine_Margins (top_margin_points, & & left_margin_points, right_margin_points, & & bottom_margin_points) ! Note: These margins refer to the white space around the ! whole graphic file. The map window (if any) is smaller. IMPLICIT NONE REAL*8, INTENT(IN) :: top_margin_points, & left_margin_points, right_margin_points, & bottom_margin_points IF (ai_paper_selected) THEN IF (ai_background_set) THEN IF (MIN(top_margin_points,left_margin_points, & right_margin_points,bottom_margin_points) >= 0.0D0) THEN IF ((top_margin_points+bottom_margin_points) < ai_paper_height_points) THEN IF ((left_margin_points+right_margin_points) < ai_paper_width_points) THEN ai_margins_defined = .TRUE. ai_top_limit_points = ai_paper_height_points - top_margin_points ai_left_limit_points = left_margin_points ai_right_limit_points = ai_paper_width_points - right_margin_points ai_bottom_limit_points = bottom_margin_points ELSE WRITE (*,"(' ERROR: Left and right margins overlap.')") CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: Top and bottom margins overlap.')") CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: Negative margins not allowed.')") CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: Must Set_Background before DDefine_Margins.')") CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: must Select_Paper before DDefine_Margins.')") CALL DTraceback END IF END SUBROUTINE DDefine_Margins SUBROUTINE DBegin_Page (model_ai_filename, in_ok, & & new_ai_filename, out_ok, & & using_color, & & plan_toptitles, & & plan_rightlegend, & & plan_bottomlegend) ! Initializes a page by copying "boiler-plate" PostScript commands ! in .AI dialect from model_ai_filename to new_ai_filename (created), ! deciding whether the page will be in color or b/w, ! and reserving space (if desired) for top titles, right and ! bottom legends around the (remaining) map window. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: model_ai_filename LOGICAL, INTENT(OUT):: in_ok CHARACTER*(*), INTENT(IN) :: new_ai_filename LOGICAL, INTENT(OUT):: out_ok LOGICAL, INTENT(IN) :: using_color, plan_toptitles, & & plan_rightlegend, plan_bottomlegend CHARACTER*3 :: c3 CHARACTER*200 :: line INTEGER :: i, ios, last LOGICAL :: desirable REAL*8 :: r1, r2, r3, r4, t, x1_points, x2_points, y1_points, y2_points IF (ai_margins_defined) THEN IF (ai_page_open) THEN WRITE (*,"(' ERROR: Must DEnd_Page before another DBegin_Page.')") CALL DTraceback ELSE ai_page_open = .TRUE. ! OPEN the model ai file OPEN (UNIT=ai_in_unit,FILE=model_ai_filename, & PAD='YES',STATUS='OLD',IOSTAT=ios) in_ok = (ios == 0) ! Trial READ, to discover any problems before another file is ! OPENed for output, adding confusion. READ (ai_in_unit,'(A)',IOSTAT=ios) line in_ok = (ios == 0) IF (.NOT. in_ok) THEN CLOSE (ai_in_unit) out_ok = .TRUE. ! for now; trouble may appear later ai_page_open = .FALSE. RETURN END IF BACKSPACE (ai_in_unit) ! OPEN the new, output ai file OPEN (UNIT=ai_out_unit,FILE=new_ai_filename, & STATUS='NEW',IOSTAT=ios) out_ok = (ios == 0) IF (.NOT. out_ok) THEN CLOSE (ai_in_unit) CLOSE (ai_out_unit) ai_page_open = .FALSE. RETURN END IF WRITE (*,"(/' ---------------------------------------------------------' & &/' OPENING model .ai (input) file and new .ai (output) file,' & &/' and copying standard boiler-plate PostScript of the' & &/' Adobe Illustrator dialect from one to the other.' & &/' ---------------------------------------------------------')") ! Begin indefinate loop, copying preface lines, ! adjusting paper size, margins, and custom colors ! 'foreground' and 'ai_background', and watching for the ! flag that indicates the end of the preface. desirable = .TRUE. copying: DO line = ' ' ! (Note: = causes right-padding with blanks.) READ (ai_in_unit,"(A)",IOSTAT=ios) line in_ok = (ios == 0) IF (.NOT. in_ok) THEN CLOSE (ai_in_unit) CLOSE (ai_out_unit) RETURN END IF IF (line(1:32) == '%%Creator: Adobe Illustrator(TM)') THEN last = LEN_TRIM(line) c3 = line((last-2):last) READ (c3, *) t ai_version = INT(t) ! typically 4 or 7 WRITE (ai_out_unit,"(A)") TRIM(line) ELSE IF (line(1:10) =='%%Title: (') THEN WRITE (ai_out_unit,"('%%Title: (',A,')')") TRIM(new_ai_filename) ELSE IF (line(1:14) == '%%BoundingBox:') THEN ! box used for .EPS cut-and-past of whole figure: WRITE (ai_out_unit,"('%%BoundingBox:',4(1X,F6.1))") & & ai_left_limit_points, ai_bottom_limit_points, & & ai_right_limit_points, ai_top_limit_points ELSE IF (line(1:19) == '%%HiResBoundingBox:') THEN ! box used for .EPS cut-and-past of whole figure; ! parameter occurs in AI7, but not in AI4 WRITE (ai_out_unit,"('%%HiResBoundingBox:',4(1X,F6.1))") & & ai_left_limit_points, ai_bottom_limit_points, & & ai_right_limit_points, ai_top_limit_points ELSE IF (line(1:18) == '%%CMYKCustomColor:') THEN ! definition of custom color 'background' in cmyk: WRITE (ai_out_unit,"('%%CMYKCustomColor:',4(1X,F4.2),' (background)')") & & (ai_background%cmyk(i),i=1,4) ELSE IF ((line(1:5) == '%%+ 0').AND.(INDEX(line,'(foreground)') /= 0)) THEN ! definition of custom color 'foreground' in cmyk: WRITE (ai_out_unit,"('%%+',4(1X,F4.2),' (foreground)')") & & (ai_foreground%cmyk(i),i=1,4) ELSE IF (line(1:13) == '%AI3_TileBox:') THEN WRITE (ai_out_unit,"('%AI3_TileBox:',4(1X,F6.1))") & & ai_left_limit_points, ai_bottom_limit_points, & & ai_right_limit_points, ai_top_limit_points ELSE IF (line(1:13) == '%AI5_ArtSize:') THEN !This statement in AI7, but not in AI4. !DO NOT copy this statement; let artboard size !default to 1296 by 1296. If you try to specify !it as smaller, alignment of page on artboard is !very difficult and confusing. ELSE IF (line(1:13) == '%%PageOrigin:') THEN r1 = 0.0D0 r2 = 0.0D0 CALL DAI_Pack_Ints_Left('%%PageOrigin:',13, r1, r2) ELSE IF (line(1:16) == '%%AI3_PaperRect:') THEN r1 = 0.0D0 r2 = ai_paper_height_points r3 = ai_paper_width_points r4 = 0.0D0 CALL DAI_Pack_Ints_Left('%%AI3_PaperRect:',16, r1, r2, r3, r4) ELSE IF (line(1:13) == '%%AI3_Margin:') THEN r1 = 0.0D0 r2 = 0.0D0 r3 = 0.0D0 r4 = 0.0D0 CALL DAI_Pack_Ints_Left('%%AI3_Margin:',13, r1, r2, r3, r4) ELSE IF (line(1:17) == 'u % GPB begin cut') THEN ! beginnning of dummy-map group, which ! includes small samples of all colors and ! patterns (so they won't be dropped from ! AIxframe.ai if someone opens it in AI and ! saves it again!) desirable = .FALSE. ELSE IF (line(1:15) == 'U % GPB end cut') THEN desirable = .TRUE. ELSE IF (line(1:13) == '%%PageTrailer') THEN ! end of the preface BACKSPACE ai_in_unit EXIT copying ELSE ! normal copying mode IF (desirable) THEN IF (LEN_TRIM(line) > 0) WRITE (ai_out_unit,"(A)") TRIM(line) END IF END IF END DO copying ! Begin page with a locked rectangle of 'background' color CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'background') WRITE (ai_out_unit,"('1 A')") ! begin locked section CALL DNew_L12_Path (level = 1, x_points = 0.D0, y_points = 0.D0) CALL DLine_To_L12 (x_points = ai_paper_width_points, & & y_points = 0.D0) CALL DLine_To_L12 (x_points = ai_paper_width_points, & & y_points = ai_paper_height_points) CALL DLine_To_L12 (x_points = 0.D0, & & y_points = ai_paper_height_points) CALL DLine_To_L12 (x_points = 0.D0, & & y_points = 0.D0) CALL DEnd_L12_Path (close = .TRUE., stroke = .FALSE., & & fill = .TRUE.) WRITE (ai_out_unit,"('0 A')") ! end locked section !Reset fill color to foreground, so text will be visible ! if the user forgets to choose a fill color. CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ! Set flag regarding choice of color versus black/white/grey: ai_using_color = using_color ! Set default map window (clipping window), smaller than margins; ! reserve space (if desired) for top titles, bottom legend, and ! right legend. ai_toptitles_reserved = plan_toptitles ai_bottomlegend_reserved = plan_bottomlegend ai_rightlegend_reserved = plan_rightlegend x1_points = ai_left_limit_points + ai_lonlatlabel_points + 1.5D0 ! the +1.5 points is needed because the degree sign is a superscript x2_points = ai_right_limit_points - ai_lonlatlabel_points - 1.5D0 ! the -1.5 points is needed because the degree sign is a superscript IF (plan_rightlegend) x2_points = x2_points - ai_rightlegend_points y1_points = ai_bottom_limit_points + ai_lonlatlabel_points + 1.5D0 ! the +1.5 points is needed because the degree sign is a superscript IF (plan_bottomlegend) y1_points = y1_points + ai_bottomlegend_points y2_points = ai_top_limit_points - ai_lonlatlabel_points - 3.0D0 ! the -3.0 points guarantees that titles will print completely. IF (plan_toptitles) y2_points = y2_points - ai_toptitles_points CALL DSet_Window (x1_points, x2_points, y1_points, y2_points) END IF ! page is open ELSE ! margins not defined WRITE (*,"(' ERROR: Must DDefine_Margins before DBegin_Page.')") CALL DTraceback END IF END SUBROUTINE DBegin_Page SUBROUTINE DSet_Window (x1_points, x2_points, y1_points, y2_points) ! Sets the edges of a rectangular clipping window !(through which paths and text at level 2 or higher must ! pass in order to become level 1 paths or text). ! All coordinates are in points from lower left of paper. IMPLICIT NONE REAL*8, INTENT(IN) :: x1_points, x2_points, y1_points, y2_points ai_window_x1_points = x1_points ai_window_x2_points = x2_points ai_window_y1_points = y1_points ai_window_y2_points = y2_points ai_window_xc_points = (x1_points + x2_points)/2.D0 ai_window_yc_points = (y1_points + y2_points)/2.D0 END SUBROUTINE DSet_Window SUBROUTINE DBegin_Group () IMPLICIT NONE IF (ai_page_open) THEN ai_groups_open = ai_groups_open + 1 WRITE (ai_out_unit,"('u')") ai_last_line_was_u = .TRUE. ai_last_line_was_star_u = .FALSE. ELSE WRITE (*,"(' ERROR: Must DBegin_Page before DBegin_Group.')") CALL DTraceback END IF END SUBROUTINE DBegin_Group SUBROUTINE DSet_Line_Style (width_points, dashed, on_points, off_points) IMPLICIT NONE REAL*8, INTENT(IN) :: width_points LOGICAL, INTENT(IN) :: dashed REAL*8, INTENT(IN), OPTIONAL :: on_points, off_points REAL*8 :: limited_width_points ! Note: This merely registers the requested line type. ! Nothing will be written to ai_out_unit until a valid path ! using a stroke is written. limited_width_points = MIN(width_points, 99.9D0) ! Limit is imposed to avoid "****" (from F4.1) in .ai file when width is excessive, ! and also to prevent an unreasonably-wide line from obscuring the whole plot! ai_next_line_width_points = limited_width_points ai_next_line_dashed = dashed IF (dashed) THEN IF (PRESENT(on_points).AND.PRESENT(off_points)) THEN ai_next_line_on_points = on_points ai_next_line_off_points = off_points ELSE WRITE (*,"(' ERROR: CALL DSet_Line_Style w/ dashed = T but no spec.s.')") CALL DTraceback END IF END IF END SUBROUTINE DSet_Line_Style SUBROUTINE DSet_Stroke_Color (color_name) ! Note: This merely registers the requested line color. ! Nothing will be written to ai_out_unit until a valid path ! using a stroke is written. IMPLICIT NONE CHARACTER*10, INTENT(IN) :: color_name LOGICAL :: valid valid = DValid_Color(color_name) IF (valid) THEN ai_next_line_color = color_name ELSE WRITE (*,"(' ERROR: Invalid 10-byte color name: ',A)") color_name CALL DTraceback END IF END SUBROUTINE DSet_Stroke_Color SUBROUTINE DSet_Fill_or_Pattern (use_pattern, color_name, pattern) ! Note: This merely registers the requested pre-defined fill color or pattern. ! Nothing will be written to ai_out_unit until a valid path ! using fill is written, or until text is written. ! (N.B. Text is always filled, but not stroked.) ! To define a new custom color by its CMYK components, use ! DSet_Custom_Fill instead. IMPLICIT NONE LOGICAL, INTENT(IN) :: use_pattern CHARACTER*10, INTENT(IN), OPTIONAL :: color_name CHARACTER*(*), INTENT(IN), OPTIONAL :: pattern LOGICAL :: valid INTEGER :: which CHARACTER*6 :: right IF (use_pattern) THEN IF (.NOT.PRESENT(pattern)) THEN WRITE (*,"(' ERROR: Missing pattern argument to DSet_Fill_or_Pattern.')") CALL DTraceback END IF ! User doing a b/w picture might consider the bounding colors ! of the spectrum to be patterns. Avoid an interrupt: IF ((pattern == ai_spectrum(0)%color_name).OR. & &(pattern == ai_spectrum(ai_spectrum_count+1)%color_name)) THEN ai_next_using_pattern = .FALSE. ai_next_fill = pattern ! User doing a b/w picture might consider the 4 standard b/w ! colors (black_____, white_____, foreground, background) ! to be patterns. Avoid an interrupt: ELSE IF ((pattern == 'black_____').OR. & &(pattern == 'white_____').OR. & &(pattern == 'foreground').OR. & &(pattern == 'background')) THEN ai_next_using_pattern = .FALSE. ai_next_fill = pattern ELSE ! usual case when a pattern is requested: right = ' ' right = pattern(5:LEN(pattern)) !Since following line sometimes abends under !Digital Visual Fortran 5.0D: !READ (right,*) which !I have switched to the following kludgy work-around: OPEN (UNIT = 72, FILE = 'trash') WRITE (72,"(A)") TRIM(right) CLOSE (72) OPEN (UNIT = 72, FILE = 'trash', PAD = 'YES') READ (72, *) which CLOSE (UNIT = 72, STATUS = 'DELETE') valid = (pattern(1:4) == 'Gray').AND. & & ((which >= 0).AND.(which <= (ai_pattern_count + 1))) IF (valid) THEN IF (which == 0) THEN ! We want the low-end bounding color ai_next_using_pattern = .FALSE. ai_next_fill = ai_spectrum(0)%color_name ELSE IF (which == (ai_pattern_count + 1)) THEN ! We want the high-end bounding color ai_next_using_pattern = .FALSE. ai_next_fill = ai_spectrum(ai_spectrum_count+1)%color_name ELSE ! normal case ai_next_using_pattern = .TRUE. ai_next_fill = pattern END IF ELSE WRITE (*,"(' ERROR: Invalid 10-byte pattern name: ',A)") pattern CALL DTraceback END IF END IF ELSE ! NOT use_pattern; (using color) IF (.NOT.PRESENT(color_name)) THEN WRITE (*,"(' ERROR: Missing color_name argument to DSet_Fill_or_Pattern.')") CALL DTraceback END IF valid = DValid_Color(color_name) IF (valid) THEN ai_next_using_pattern = .FALSE. ai_next_fill = color_name ELSE WRITE (*,"(' ERROR: Invalid 10-byte color name: ',A)") color_name CALL DTraceback END IF END IF END SUBROUTINE DSet_Fill_or_Pattern SUBROUTINE DSet_Custom_Fill(C, M, Y, K) !Alternate routine to DSet_Fill_or_Pattern; allows solid-color (non-patterned) fills of any hue. IMPLICIT NONE REAL*8, INTENT(IN) :: C, M, Y, K ! All should be REAL*8s in the range of 0.0~1.0. ai_next_fill = "customCMYK" ai_C_R8 = C ai_M_R8 = M ai_Y_R8 = Y ai_K_R8 = K END SUBROUTINE DSet_Custom_Fill SUBROUTINE DBegin_Compound_Path () IMPLICIT NONE IF (ai_page_open) THEN ai_compound_paths_open = ai_compound_paths_open + 1 WRITE (ai_out_unit,"('*u')") ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .TRUE. !This sets reminder that a compound-path bracket was opened; !if nothing else is written before closing it, it should be removed. ELSE WRITE (*,"(' ERROR: Must DBegin_Page before DBegin_Compound_Paath.')") CALL DTraceback END IF END SUBROUTINE DBegin_Compound_Path SUBROUTINE DNew_L12_Path (level, x_points, y_points) ! Level 1 is data after/not-subject-to windowing, in page points. ! Level 2 is data that will require windowing, in page points. IMPLICIT NONE INTEGER, INTENT(IN) :: level REAL*8, INTENT(IN) :: x_points, y_points INTEGER :: path IF ((level == 1).OR.(level == 2)) THEN IF (ai_page_open) THEN IF (.NOT. ai_in_path) THEN ! USUAL CASE: ai_in_path = .TRUE. path = DNext_Free_Path() ! Note: this function will check for full library. ai_current_path_index = path ai_current_path_level = level ai_path_level(path) = level ai_Ln_paths(level) = ai_Ln_paths(level) + 1 ai_total_paths = ai_total_paths + 1 ai_segments(path) = 0 ai_pathlib(1:6,0,path) = 0.0D0 ai_pathlib(1,0,path) = x_points ai_pathlib(2,0,path) = y_points ai_last_L12_x_points = x_points ! (memory) ai_last_L12_y_points = y_points ELSE ! ai_in_path already WRITE (*,"(' ERROR: Cannot DNew_L12_Path with a path open.')") CALL DTraceback END IF ELSE ! no page open WRITE (*,"(' ERROR: Cannot DNew_L12_Path before DBegin_Page.')") CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: Level ',I2,' not allowed in DNew_L12_Path.')") level CALL DTraceback END IF END SUBROUTINE DNew_L12_Path SUBROUTINE DLine_To_L12 (x_points, y_points) IMPLICIT NONE REAL*8, INTENT(IN) :: x_points, y_points INTEGER :: next, path IF (ai_in_path) THEN IF ((ai_current_path_level == 1).OR.(ai_current_path_level == 2)) THEN path = ai_current_path_index IF (ai_segments(path) < ai_longest) THEN ! ignore degenerate lineto's (of zero length): IF (x_points == ai_last_L12_x_points) THEN IF (y_points == ai_last_L12_y_points) RETURN END IF ! USUAL CASE: next = ai_segments(path) + 1 ai_segments(path) = next ai_pathlib(1:6,next,path) = 0.0D0 ai_pathlib(1,next,path) = x_points ai_pathlib(2,next,path) = y_points ai_bent(next,path) = .FALSE. ai_last_L12_x_points = x_points ! (memory) ai_last_L12_y_points = y_points ELSE WRITE (*,"(' ERROR: Increase ai_longest from current ',I6)") ai_longest CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: Cannot DLine_To_L12 in path on level ',I2)") & & ai_current_path_level CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: Cannot DLine_To_L1 before DNew_L1_Path.')") CALL DTraceback END IF END SUBROUTINE DLine_To_L12 SUBROUTINE DCurve_To_L12 (x1_points,y1_points, x2_points,y2_points, & & x3_points,y3_points) ! The initial control point is the current point (not input). ! The Bezier handle on the initial control point is (x1,y1). ! The Bezier handle on the final control point is (x2,y2). ! The final control point is (x3,y3). ! NOTE: This routine is not strictly clerical. It checks ! all curves to see that they deviate by at least ! "min_amplitude_points" from a straight line. If not, ! it replaces curveto with lineto. IMPLICIT NONE REAL*8, INTENT(IN) :: x1_points,y1_points, x2_points,y2_points, & & x3_points,y3_points INTEGER :: next, path LOGICAL :: inline1, inline2 REAL*8 :: crossx, crossy, dot, length, offline, ux, uy, vx, vy IF (ai_in_path) THEN IF ((ai_current_path_level == 1).OR.(ai_current_path_level == 2)) THEN path = ai_current_path_index IF (ai_segments(path) < ai_longest) THEN ! Simplify degenerate curveto's !(those which are straight within a tolerance) ! by converting them to lineto's. !(This will also cover the case of handle points ! that erroneously coincide with end points.) IF ((x3_points /= ai_last_L12_x_points).OR. & &(y3_points /= ai_last_L12_y_points)) THEN ! straight line is defined; test can proceed: ux = x3_points - ai_last_L12_x_points uy = y3_points - ai_last_L12_y_points length = DSQRT(ux**2 + uy**2) ! > 0.D0 ux = ux / length ! unit vector of baseline uy = uy / length vx = x1_points - ai_last_L12_x_points ! lever1 vector vy = y1_points - ai_last_L12_y_points dot = vx * ux + vy * uy ! length of // component crossx = vx - dot * ux ! perpendicular component crossy = vy - dot * uy offline = DSQRT(crossx**2 + crossy**2) inline1 = (offline <= ai_min_amplitude_points) vx = x3_points - x2_points ! -lever2 vector vy = y3_points - y2_points dot = vx * ux + vy * uy ! length of // component crossx = vx - dot * ux ! perpendicular component crossy = vy - dot * uy offline = DSQRT(crossx**2 + crossy**2) inline2 = (offline <= ai_min_amplitude_points) IF (inline1.AND.inline2) THEN CALL DLine_To_L12 (x3_points, y3_points) RETURN END IF END IF ! in-line test was possible ! USUAL CASE (in-line test impossible or false): next = ai_segments(path) + 1 ai_segments(path) = next ai_pathlib(1,next,path) = x1_points ai_pathlib(2,next,path) = y1_points ai_pathlib(3,next,path) = x2_points ai_pathlib(4,next,path) = y2_points ai_pathlib(5,next,path) = x3_points ai_pathlib(6,next,path) = y3_points ai_bent(next,path) = .TRUE. ai_last_L12_x_points = x3_points ! (memory) ai_last_L12_y_points = y3_points ELSE WRITE (*,"(' ERROR: Increase ai_longest from current ',I6)") ai_longest CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: Cannot DCurve_To_L12 in path on level ',I2)") & & ai_current_path_level CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: Cannot DCurve_To_L12 before DNew_L1_Path.')") CALL DTraceback END IF END SUBROUTINE DCurve_To_L12 SUBROUTINE DEnd_L12_Path (close, stroke, fill) IMPLICIT NONE LOGICAL, INTENT(IN) :: close, stroke, fill INTEGER :: level, path ! Note: The .AI macros which include "closepath" ! don't close it as one would like, with an extra ! "lineto". Instead, they do a curveto, which somehow ! misses the last point you specified. ! Therefore, it is not enough to specify close = T, ! you must also program so that the path actually ! comes back to its initial point! IF (ai_in_path) THEN path = ai_current_path_index level = ai_current_path_level IF ((level == 1).OR.(level == 2)) THEN IF (stroke .OR. fill) THEN ! USUAL ROUTE: IF ((close.OR.fill).AND.(level == 2)) THEN ! Logic of Process_L2_Paths requires these paths ! to end at their initial points: IF ((ai_last_L12_x_points /= ai_pathlib(1,0,path)).OR. & &(ai_last_L12_y_points /= ai_pathlib(2,0,path))) THEN CALL DLine_To_L12(ai_pathlib(1,0,path),ai_pathlib(2,0,path)) END IF ! completion of L2 path needed END IF ! filled L2 path ai_closed(path) = close ai_stroked(path) = stroke ai_filled(path) = fill ai_in_path = .FALSE. ai_last_L12_x_points = -9999.D0 ! (undefined) ai_last_L12_y_points = -9999.D0 IF (level == 1) THEN CALL DWrite_L1_Paths ELSE ! level 2 CALL DProcess_L2_Paths END IF ELSE !neither stroked nor filled WRITE (*,"(' ERROR: DEnd_L12_path with neither fill nor stroke.')") CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: Cannot DEnd_L12_path when other level open.')") CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: Cannot DEnd_L12_Path when path not open.')") CALL DTraceback END IF END SUBROUTINE DEnd_L12_Path SUBROUTINE DEnd_Compound_Path () IMPLICIT NONE IF (ai_in_path) THEN WRITE (*,"(' ERROR: Cannot DEnd_Compound_Path with a path still open.')") CALL DTraceback ELSE IF (ai_compound_paths_open >= 1) THEN ai_compound_paths_open = ai_compound_paths_open - 1 IF (ai_last_line_was_star_u) THEN ! Whoa! Eliminate empty compound-path bracket, instead of adding to it! BACKSPACE(ai_out_unit) ELSE ! Something was written while this bracket was open, so just close it normally: WRITE (ai_out_unit,"('*U')") ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ! because this refers to lower-case 'u' of "*u". END IF ! ai_last_line_was_star_u, or NOT ELSE WRITE (*,"(' ERROR: More calls to DEnd_Compund_Path than DBegin_Compound_Path.')") CALL DTraceback END IF END IF END SUBROUTINE DEnd_Compound_Path SUBROUTINE DCircle_on_L12 (level, x,y, radius, stroke, fill) ! Draws a complete circle centered at (x,y) [in points], ! with radius "radius" [in points]. ! Note that stroke width and color (if used) and ! fill color or pattern (if used) must be predefined. IMPLICIT NONE INTEGER, INTENT(IN) :: level REAL*8, INTENT(IN) :: x, y, radius LOGICAL, INTENT(IN) :: stroke, fill IF (.NOT.ai_page_open) THEN WRITE (*,"(' ERROR: Cannot DCircle_on_L12 before DBegin_Page.')") CALL DTraceback END IF IF (ai_in_path) THEN WRITE (*,"(' ERROR: Cannot DCircle_on_L12 with another path already open.')") CALL DTraceback END IF IF ((level < 1).OR.(level > 2)) THEN WRITE (*,"(' ERROR: Illegal level to DCircle_on_L12: ',I4)") level CALL DTraceback END IF IF (radius < 0.0D0) THEN WRITE (*,"(' ERROR: Negative radius to Circle_on_L12: ',1P,E9.2)") radius CALL DTraceback END IF IF (radius >= 0.1D0) THEN CALL DNew_L12_Path (level, x + radius, y) CALL DCurve_to_L12 (x + radius, y + 0.5523D0 * radius, & & x + 0.5523D0 * radius, y + radius, & & x, y + radius) CALL DCurve_to_L12 (x - 0.5523D0 * radius, y + radius, & & x - radius, y + 0.5523D0 * radius, & & x - radius, y) CALL DCurve_to_L12 (x - radius, y - 0.5523D0 * radius, & & x - 0.5523D0 * radius, y - radius, & & x, y - radius) CALL DCurve_to_L12 (x + 0.5523D0 * radius, y - radius, & & x + radius, y - 0.5523D0 * radius, & & x + radius, y) CALL DEnd_L12_Path (.TRUE., stroke, fill) END IF END SUBROUTINE DCircle_on_L12 SUBROUTINE DL12_Text (level, x_points, y_points, angle_radians, & & font_points, lr_fraction, ud_fraction, & & text) ! Accepts text strings on either level 1 (after or without ! windowing) or level 2 (requires windowing). ! Note that level-2 text is either entirely plotted or ! entirely omitted, based on whether the fiducial point ! (for which coordinates are given) is in the window or not. ! Coordinates of fiducial point (x_points,y_points) are in points ! from the lower left corner of the page (physical page, ! not margin). ! Angle_radians is the angle of the baseline from horizontal, ! measured in radians, counterclockwise. ! Font_points is the font size in points (1/72 inch); remember ! that this is NOT the I-height, but the spacing between ! consecutive lines of text (if it includes CR's). ! An integer value must be chosen. ! Lr_fraction (left/right fraction) is the relative position of ! the fiducial point in the text string: 0. for left, 0.5 ! for middle, or 1. for right-end. Values outside this range ! will also work, within reason. Note that alignment is ! most accurate at values of 0., 0.5, or 1., because Adobe ! Illustrator has better algorithms to estimate the length ! of the text string than I do! ! Ud_fraction (up/down fraction) is the relative position of ! the fiducial point from base to top of characters: ! 0. gives alignment with base of characters (normal); ! -0.4 puts fiducial point below baseline, roughly at the ! base of the "tails" of y, p, g, j; this is useful if ! there is a stroked line at the y_points of the fiducial ! point, and you want the text to clear. ! +1.0 gives fiducial point over the tops of the capitals ! (actually on the baseline of an imaginary preceding line ! of text). ! Text is the character string. ! The string length is automatically detected; trailing blanks ! are ignored. ! IMPLICIT NONE INTEGER, INTENT(IN) :: level, font_points REAL*8, INTENT(IN) :: x_points, y_points, angle_radians, & & lr_fraction, ud_fraction CHARACTER*(*),INTENT(IN) :: text INTEGER :: bytes bytes = LEN_TRIM(text) IF (bytes < 1) RETURN IF ((level == 1).OR.(level == 2)) THEN IF (level == 2) THEN CALL DProcess_L2_Text (x_points, y_points, angle_radians, & & font_points, lr_fraction, ud_fraction, & & text) ELSE ! level 1 CALL DWrite_L1_Text (x_points, y_points, angle_radians, & & font_points, lr_fraction, ud_fraction, & & text) END IF ELSE WRITE (*,"(' ERROR: DL12_Text cannot handle level ',I2)") level CALL DTraceback END IF END SUBROUTINE DL12_Text SUBROUTINE DEnd_Group () IMPLICIT NONE IF (ai_in_path) THEN WRITE (*,"(' ERROR: Cannot DEnd_Group with a path still open.')") CALL DTraceback ELSE IF (ai_groups_open >= 1) THEN ai_groups_open = ai_groups_open - 1 IF (ai_last_line_was_u) THEN BACKSPACE (ai_out_unit) ! to eliminate last "u" ELSE WRITE (ai_out_unit,"('U')") END IF ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE WRITE (*,"(' ERROR: More calls to DEnd_Group than DBegin_Group.')") CALL DTraceback END IF END IF END SUBROUTINE DEnd_Group SUBROUTINE DBitmap_on_L1 (bitmap, x0_points, x1_points, y0_points, y1_points) !Places a bitmap on level 1 (anywhere on/off the paper). !Bitmap has subscripts (RGB, row, column). !x0_points gives the left side of the bitmap window, from left edge of paper. !x1_points gives the right side of the bitmap window, from left edge of paper. !y0_points gives the bottom side of the bitmap window, from bottom edge of paper. !y1_points gives the top side of the bitmap window, from bottom edge of paper. IMPLICIT NONE CHARACTER(LEN=3), DIMENSION(:,:), INTENT(IN) :: bitmap REAL*8, INTENT(IN) :: x0_points, x1_points, y0_points, y1_points CHARACTER(LEN=2) :: c2 CHARACTER(LEN=80) :: line = '%' INTEGER :: byte_count, column, columns, in_line, lines, p1, p2, rgb, row, rows REAL*8 :: x_points_per_column, y_points_per_row IF (ai_version <= 4) THEN WRITE (*,"(' ERROR: Cannot place DBitmap_on_L1 with Adobe Illustrator 4;')") WRITE (*,"(' restart with a model .ai file from Adobe Illustrator 7.')") CALL DTraceback END IF IF (ai_page_open) THEN IF (.NOT. ai_in_path) THEN ! USUAL CASE: ELSE ! ai_in_path already WRITE (*,"(' ERROR: Cannot DBitmap_on_L1 with a path open.')") CALL DTraceback END IF ELSE ! no page open WRITE (*,"(' ERROR: Cannot DBitmap_on_L1 before DBegin_Page.')") CALL DTraceback END IF !Normal case: rows = UBOUND(bitmap, 1) - LBOUND(bitmap, 1) + 1 columns = UBOUND(bitmap, 2) - LBOUND(bitmap, 2) + 1 IF (MOD(3*rows*columns, 30) == 0) THEN ! divides exactly into full lines lines = (3 * rows * columns) / 30 ELSE ! normal case; last line is incomplete lines = ((3 * rows * columns) / 30 ) + 1 END IF !Note: byte_count is the length of the hexadecimal output !string, including its formatting and end-of-line characters. byte_count = 2 * 3 * rows * columns + 3 * lines + 4 !where 3/line is for '%' CR LF; and 4 is for 'XI' CR LF. x_points_per_column = (x1_points - x0_points) / columns y_points_per_row = (y1_points - y0_points) / rows WRITE (ai_out_unit,"('%AI5_File:')") WRITE (ai_out_unit,"('%AI5_BeginRaster')") WRITE (ai_out_unit,"('(RGB_bitmap.tif) 0 XG')") WRITE (ai_out_unit,"('[ ',F8.3,' 0 0 ',F8.3,' ',F7.1,' ',F7.1,' ] ',I5,' ',I5,' 0 Xh')") & & x_points_per_column, y_points_per_row, x0_points, y1_points, & & columns, rows WRITE (ai_out_unit,"('[ ',F8.3,' 0 0 ',F8.3,' ',F7.1,' ',F7.1,' ] 0 0',4I6,' 8 3 0 0 0 0')") & & x_points_per_column, y_points_per_row, x0_points, y1_points, & & columns, rows, columns, rows WRITE (ai_out_unit,"('%%BeginData: ',I12)") byte_count WRITE (ai_out_unit,"('XI')") in_line = 0 DO row = LBOUND(bitmap,1),UBOUND(bitmap,1) DO column = LBOUND(bitmap,2),UBOUND(bitmap,2) DO rgb = 1, 3 WRITE (c2,"(Z2)") ICHAR(bitmap(row,column)(rgb:rgb)) IF (c2(1:1) == ' ') c2(1:1) = '0' in_line = in_line + 1 p1 = 2 * in_line p2 = p1 + 1 line(p1:p2) = c2(1:2) IF (in_line == 30) THEN WRITE (ai_out_unit,"(A)") TRIM(line) line = '%' in_line = 0 END IF END DO ! rgb END DO ! columns END DO ! rows IF (in_line > 0) THEN WRITE (ai_out_unit,"(A)") TRIM(line) END IF WRITE (ai_out_unit,"('%%EndData')") WRITE (ai_out_unit,"('XH')") WRITE (ai_out_unit,"('%AI5_EndRaster')") WRITE (ai_out_unit,"('N')") WRITE (ai_out_unit,"('LB')") END SUBROUTINE DBitmap_on_L1 SUBROUTINE DEnd_Page () IMPLICIT NONE CHARACTER*200 :: line INTEGER :: ios IF (ai_page_open) THEN IF (ai_groups_open == 0) THEN copying: DO line = ' ' ! (Note: = causes right-padding with blanks.) READ (ai_in_unit,"(A)",IOSTAT=ios) line IF (ios == -1) EXIT Copying ! end-of-file IF (LEN_TRIM(line) > 0) WRITE (ai_out_unit,"(A)") TRIM(line) END DO copying CLOSE (ai_out_unit) WRITE (*,"(/' ------------------------------------------------------' & &/' SUCCESS! .AI graphic file completed.')") IF (ai_version == 4) THEN WRITE (*,"( ' Note: When opened in Adobe Illustrator, the file' & &/' will be correctly placed on the page.' & &/' However, if you Print/Setup in Adobe Illustrator' & &/' version 4 for Windows 3.1, it will jump!' & &/' Use the Page tool to realign before printing' & &/' or saving the file.')") END IF WRITE (*,"( ' ------------------------------------------------------')") REWIND (ai_in_unit) ai_page_open = .FALSE. ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE WRITE (*,"(' ERROR: Cannot DEnd_Page with ',I2,' groups still open.')") ai_groups_open CALL DTraceback END IF ELSE WRITE (*,"(' ERROR: Cannot DEnd_Page when no page open.')") CALL DTraceback END IF END SUBROUTINE DEnd_Page ! =============================================== ! | INTERNAL UTILITY ROUTINES | ! | (in alphabetical order ) | ! =============================================== SUBROUTINE DAI_Pack_Ints_Left (prefix, prefix_length, real1, real2, real3, real4) ! used to write certain lines of the AI output file, in which ! the only acceptable format for the arguments is integers, ! packed leftward as far as possible (i.e., no space before ! the first, and only one space before the others) IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: prefix INTEGER, INTENT(IN) :: prefix_length REAL*8, INTENT(IN) :: real1 REAL*8, INTENT(IN), OPTIONAL :: real2, real3, real4 INTEGER, PARAMETER :: max_line = 200 CHARACTER*(max_line) :: line INTEGER :: i, length, size CHARACTER*10 :: buffer DO i = 1, max_line line(i:i) = ' ' END DO IF (prefix_length > 0) THEN IF (prefix_length < max_line) THEN line(1:prefix_length) = prefix(1:prefix_length) size = prefix_length ELSE WRITE (*,"(' ERROR: Prefix length ',I4, & & ' is too large compared to max_line of ',I4)") & &prefix_length, max_line CALL DTraceback END IF ELSE size = 0 END IF WRITE (buffer,"(I10)") NINT(real1) buffer = ADJUSTL(buffer) length = LEN_TRIM(buffer) IF ((size+length) <= max_line) THEN line(size+1:size+length) = buffer(1:length) size = size + length ELSE WRITE (*,"(' ERROR: Increase max_line in AI_Pack_Ints_Left')") CALL DTraceback END IF IF (PRESENT(real2)) THEN WRITE (buffer,"(I10)") NINT(real2) buffer = ADJUSTL(buffer) length = LEN_TRIM(buffer) IF ((size+1+length) <= max_line) THEN line(size+2:size+1+length) = buffer(1:length) size = size + 1 + length ELSE WRITE (*,"(' ERROR: Increase max_line in DAI_Pack_Ints_Left')") CALL DTraceback END IF END IF IF (PRESENT(real3)) THEN WRITE (buffer,"(I10)") NINT(real3) buffer = ADJUSTL(buffer) length = LEN_TRIM(buffer) IF ((size+1+length) <= max_line) THEN line(size+2:size+1+length) = buffer(1:length) size = size + 1 + length ELSE WRITE (*,"(' ERROR: Increase max_line in DAI_Pack_Ints_Left')") CALL DTraceback END IF END IF IF (PRESENT(real4)) THEN WRITE (buffer,"(I10)") NINT(real4) buffer = ADJUSTL(buffer) length = LEN_TRIM(buffer) IF ((size+1+length) <= max_line) THEN line(size+2:size+1+length) = buffer(1:length) size = size + 1 + length ELSE WRITE (*,"(' ERROR: Increase max_line in DAI_Pack_Ints_Left')") CALL DTraceback END IF END IF WRITE (ai_out_unit,"(A)") line(1:size) ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. END SUBROUTINE DAI_Pack_Ints_Left REAL*8 FUNCTION DAtan2F (y, x) ! corrects for possible abend in case of (0.D0, 0.D0) IMPLICIT NONE REAL*8, INTENT(IN) :: x, y IF ((x /= 0.0D0).OR.(y /= 0.0D0)) THEN DAtan2F = ATAN2(y,x) ELSE DAtan2F = 0.0D0 END IF END FUNCTION DAtan2F SUBROUTINE DBezier_Fragment(x0,y0, x1,y1, x2,y2, x3,y3, & & t1, t2, & ! input & xt0,yt0, xt1,yt1, xt2,yt2, xt3,yt3) ! Excerpts the part of a Bezier curve between internal ! coordinates t1 and t2 (both 0.0D0 <= t <= 1.00D0). ! Notation follows page 393 of: ! PostScript Language Reference Manual, ! by Adobe Systems Incorporated, ! 1990 (2nd edition), Addison-Wesley, Menlo Park, CA. IMPLICIT NONE REAL*8, INTENT(IN) :: t1, t2, x0,y0,x1,y1,x2,y2,x3,y3 REAL*8, INTENT(OUT):: xt0,yt0, xt1,yt1, xt2,yt2, xt3,yt3 REAL*8 :: ax, ay, bx, bxn, by, byn, cx, cxn, cy, cyn, dt IF ((t1 == t2) .OR. & &(t1 < 0.0D0) .OR. (t1 > 1.00D0) .OR. & &(t2 < 0.0D0) .OR. (t2 > 1.00D0)) THEN WRITE (*,"(' ERROR: Internal coordinates out of range: ',2F10.5)") t1, t2 CALL DTraceback ELSE ax = -x0 + 3.D0*x1 - 3.D0*x2 + x3 bx = 3.D0*x0 - 6.D0*x1 + 3.D0*x2 cx = 3.D0*(x1 - x0) ay = -y0 + 3.D0*y1 - 3.D0*y2 + y3 by = 3.D0*y0 - 6.D0*y1 + 3.D0*y2 cy = 3.D0*(y1 - y0) ! The endpoints are easy: IF (t1 == 0.0D0) THEN xt0 = x0 yt0 = y0 ELSE CALL DMid_Bezier(x0,y0,x1,y1,x2,y2,x3,y3, & & t1,xt0,yt0) END IF IF (t2 == 1.00D0) THEN xt3 = x3 yt3 = y3 ELSE CALL DMid_Bezier(x0,y0,x1,y1,x2,y2,x3,y3, & & t2,xt3,yt3) END IF ! Handle points are found by algebra, using new variable tn: ! t = t1 + tn * dt ; dt = (t2 - t1), so in ! the original interval t1 <= t <= t2, 0.0D0 <= tn <= 1.00D0. ! Substitute this for t in: ! x(t) = ax * t**3 + bx * t**2 + cx * t + x0, ! and you get the new polynomial coefficients for the ! polynomial x(t) = cubic(tn): dt = t2 - t1 ! axn = (ax) * dt**3 bxn = (3.D0 * ax * t1 + bx) * dt**2 cxn = (3.D0 * ax * t1**2 + 2.D0 * bx * t1 + cx) * dt ! ayn = (ay) * dt**3 byn = (3.D0 * ay * t1 + by) * dt**2 cyn = (3.D0 * ay * t1**2 + 2.D0 * by * t1 + cy) * dt xt1 = xt0 + cxn/3.D0 xt2 = xt1 + (cxn + bxn)/3.D0 yt1 = yt0 + cyn/3.D0 yt2 = yt1 + (cyn + byn)/3.D0 END IF END SUBROUTINE DBezier_Fragment SUBROUTINE DCircle_and_Line (xc, yc, r, & ! defines circle & x1,y1, x2,y2, & ! defines line segment & number, argument_list, tls_list, x_list, y_list) ! output ! Finds 0, 1, or 2 points of intersection between a circle and a line segment ! in the (x, y) plane. ! The circle is centered at (xc, yc) with radius r. ! The line segment is from (x1, y1)-(x2, y2). ! Result "number" is the number of intersections found. ! Result "argument_list" gives the positions of these points in terms of argument ! around the circle (radians counterclockwise from +x axis: 0.0 to Two_Pi). ! Result "tls_list" gives the positions of these points in terms of the dimensionless ! internal variable along the line segment (0.0 at (x1,y1) to 1.0 at (x2, y2)). ! Results "x_list" and "y_list" give the positions of these points in Cartesian coordinates. ! NOTE that osculation (tangency) is reported as two intersections with identical positions, ! to distinguish it from an intersection where the circle crosses the line. ! Also note that intersections with the end points are reported if found, but may occasionally ! fail to be found due to numerical errors. IMPLICIT NONE REAL*8, INTENT(IN) :: xc, yc, r, x1, y1, x2, y2 INTEGER, INTENT(OUT) :: number REAL*8, DIMENSION(:), INTENT(OUT) :: argument_list, tls_list, x_list, y_list ! must be at least (1:2) in size !--------------------------------- INTEGER :: roots REAL*8 :: constant, dxdt, dydt, linear, quadratic, t1, t2, t3 ! Note: t3 is never used. dxdt = x2 - x1 dydt = y2 - y1 !Define d as distance of any (x, y) on the line segment from (xc, yc). !Express: d**2 - r**2 = (x1 + dxdt * t - xc)**2 + (y1 + dydt * t - yc)**2 - r**2 = 0 (at intersections) !as a quadratic polynomial of t: quadratic = dxdt**2 + dydt**2 linear = 2.0D0 * dxdt * (x1 - xc) + 2.0D0 * dydt * (y1 - yc) constant = x1**2 - 2.0D0 * x1 * xc + xc**2 + y1**2 - 2.0D0 * y1 * yc + yc**2 - r**2 CALL DCubic_Roots(0.0D0, quadratic, linear, constant, & ! input & roots, t1, t2, t3) ! output IF (roots == 0) THEN number = 0 ELSE ! roots is either 1 or 2, but at least 1 number = 0 IF ((t1 >= 0.0D0).AND.(t1 <= 1.0D0)) THEN number = 1 tls_list(1) = t1 x_list(1) = x1 + dxdt * t1 y_list(1) = y1 + dydt * t1 argument_list(1) = DATAN2F((y_list(1) - yc), (x_list(1) - xc)) END IF IF (roots == 2) THEN IF ((t2 >= 0.0D0).AND.(t2 <= 1.0D0)) THEN number = number + 1 tls_list(number) = t2 x_list(number) = x1 + dxdt * t2 y_list(number) = y1 + dydt * t2 argument_list(number) = DATAN2F((y_list(number) - yc), (x_list(number) - xc)) END IF END IF ! roots == 2 END IF ! roots == 0, or > 0 END SUBROUTINE DCircle_and_Line SUBROUTINE DCubic_Roots(cubic, quadratic, linear, constant, & ! input & number, x1, x2, x3) ! output ! Finds the real roots of a cubic polynomial ! equation with REAL*8 coefficients: ! ! cubic * x**3 + quadratic * x**2 + linear * x + constant = 0.0D0 ! !"Number" is the number of real roots found. ! If "cubic" is not zero, it will be either 1 or 3; ! if "cubic" is zero, then number = 0 or number = 2 ! become possible outcomes. ! Note that in the case of multiple roots, both will be ! counted, and duplicate answers will appear. ! If number < 3 on output, then the last of the x1, x2, x3 ! values are undefined. ! Internal notation and method after pages 145-146 of ! Numerical Recipes: The Art of Scientific Computing, ! by William H. Press et al., Cambridge Univ. Press, 1986. IMPLICIT NONE REAL*8, INTENT(IN) :: cubic, quadratic, linear, constant INTEGER, INTENT(OUT) :: number REAL*8, INTENT(OUT) :: x1, x2, x3 DOUBLE PRECISION, PARAMETER :: Pi = 3.14159265358979323846D0 DOUBLE PRECISION :: TwoPi, FourPi REAL*8 :: a, b, c, discriminant DOUBLE PRECISION :: a1, a1_over_3, a2, a3, cubic_noise, Q, R, R2, root_Q, Q3, t, theta ![ N.B. DOUBLE PRECISION statements were originally present in MODULE Adobe_Illustrator. ] ! Note: This DOUBLE does not imply high precision; it is to ! prevent overflow abends when "cubic" is very small! cubic_noise = 1.D-6 * MAX(DABS(quadratic), DABS(linear), DABS(constant)) ! Note: Assumption that independent variable t is of order 1 in the range of interest! IF (DABS(cubic) < cubic_noise) THEN ! not (really) cubic; so: quadratic, trivial, or impossible equation IF (quadratic == 0.D0) THEN ! trivial or impossible equation IF (linear == 0.D0) THEN ! zero or infinite solutions IF (constant == 0.D0) THEN WRITE (*,"(' ERROR: Infinite number of solutions to: 0. * x = 0.')") CALL DTraceback ELSE number = 0 ! no solution END IF ELSE ! trivial equation: linear * x + constant = 0. number = 1 x1 = -constant / linear END IF ELSE ! real quadratic equation: 0, 1(double), or 2 roots a = quadratic b = linear c = constant discriminant = (b*b) - (4.D0*a*c) IF (discriminant >= 0.D0) THEN number = 2 IF (discriminant > 0.D0) THEN Q = -0.5D0 * (b + SIGN(1.D0,b)*DSQRT(discriminant) ) ELSE Q = -0.5D0 * b END IF x1 = Q / a x2 = c / Q ELSE number = 0 END IF END IF ELSE ! real, full-fledged cubic equation: 1 or 3 real roots a1 = quadratic / cubic a2 = linear / cubic a3 = constant / cubic a1_over_3 = a1/3. Q = (a1**2 - 3.D0*a2)/9.D0 R = (2.D0*a1**3 - 9.D0*a1*a2 + 27.D0*a3)/54.D0 R2 = R*R Q3 = Q**3 IF (R2 > Q3) THEN ! single root number = 1 t = ( DSQRT(R2 - Q3) + DABS(R) )**0.333333D0 x1 = -SIGN(1.D0,R)*(t + Q/t) - a1_over_3 ELSE ! three roots; Q and Q3 are positive number = 3 theta = DACOS(R/DSQRT(Q3)) root_Q = DSQRT(Q) TwoPi = 2.D0 * Pi FourPi = 2.D0 * TwoPi x1 = -2.D0 * root_Q * DCOS(theta/3.D0) - a1_over_3 x2 = -2.D0 * root_Q * DCOS((theta+TwoPi)/3.D0) - a1_over_3 x3 = -2.D0 * root_Q * DCOS((theta+FourPi)/3.D0) - a1_over_3 END IF END IF END SUBROUTINE DCubic_Roots CHARACTER*1 FUNCTION DIn_Path(x_points, y_points, path) ! returns 'I' for inside, 'O' for outside, 'B' for on-boundary. IMPLICIT NONE REAL*8, INTENT(IN) :: x_points, y_points INTEGER, INTENT(IN) :: path REAL*8, PARAMETER :: big_num = 99999.D0 INTEGER :: crossings, i, intersections, j, number REAL*8 :: f_a_1, f_a_2, f_b_1, f_b_2, x_last, xm1, xm2, x_out, y_last, y_out, ym1, ym2 REAL*8, DIMENSION(3) :: t_vec, tls_vec, x_list, y_list intersections = 0 x_last = ai_pathlib(1,0,path) y_last = ai_pathlib(2,0,path) !Steer test line away from start point of path to reduce chance !of incorrect results. [That is, reduce chance of ANY intersections !with a path that is confined to a small area in (x,y) space.] !Also, slant test line at an irrational angle, to reduce chances !of a problematic tangency with the path. IF (x_last < x_points) THEN ! path starts L of center x_out = big_num * 0.90731D0 ! so, direct test line to R ELSE x_out = -big_num * 0.90731D0 ! else, direct test line to L END IF IF (y_last < y_points) THEN ! path starts below center y_out = big_num * 1.053637D0 ! so, direct test line upward ELSE y_out = -big_num * 1.053637D0 ! else, direct test line downward END IF DO i = 1, ai_segments(path) IF (ai_bent(i,path)) THEN CALL DSateh(x_last, y_last, & & ai_pathlib(1,i,path),ai_pathlib(2,i,path), & & ai_pathlib(3,i,path),ai_pathlib(4,i,path), & & ai_pathlib(5,i,path),ai_pathlib(6,i,path), & & x_points, y_points, x_out, y_out, & !input & number, t_vec, tls_vec, x_list, y_list) ! output DO j = 1,number IF ((x_list(j) == x_points).AND.(y_list(j) == y_points)) THEN DIn_Path = 'B' RETURN ELSE intersections = intersections + 1 END IF END DO x_last = ai_pathlib(1,i,path) y_last = ai_pathlib(2,i,path) ELSE ! straight segment CALL DX_Marks(x_points, y_points, x_out, y_out, & & x_last, y_last, & & ai_pathlib(1,i,path), ai_pathlib(2,i,path), & ! input & crossings, xm1,ym1, xm2,ym2, f_a_1, f_a_2, f_b_1, f_b_2) ! output IF (crossings >= 1) THEN IF ((xm1 == x_points).AND.(ym1 == y_points)) THEN DIn_Path = 'B' RETURN ELSE intersections = intersections + 1 END IF END IF IF (crossings == 2) THEN IF ((xm2 == x_points).AND.(ym2 == y_points)) THEN DIn_Path = 'B' RETURN ELSE intersections = intersections + 1 END IF END IF x_last = ai_pathlib(1,i,path) y_last = ai_pathlib(2,i,path) END IF ! bent / straight END DO ! on segments in path IF (MOD(intersections,2) == 1) THEN DIn_Path = 'I' ! (x_points, y_points) is inside path ELSE DIn_Path = 'O' ! outside the path END IF END FUNCTION DIn_Path CHARACTER*1 FUNCTION DIn_Window(x_points, y_points) ! returns 'I' for inside, 'O' for outside, 'B' for on-boundary. IMPLICIT NONE REAL*8, INTENT(IN) :: x_points, y_points INTEGER :: i REAL*8 :: upper_limit, value DIn_Window = 'I' DO i = 1, 4 SELECT CASE(i) CASE(1) ! top boundary value = y_points upper_limit = ai_window_y2_points CASE(2) ! left boundary value = -x_points upper_limit = -ai_window_x1_points CASE(3) ! right boundary value = x_points upper_limit = ai_window_x2_points CASE(4) ! bottom boundary value = -y_points upper_limit = -ai_window_y1_points END SELECT IF (value > upper_limit) THEN DIn_Window = 'O' ! outside RETURN ELSE IF (value == upper_limit) THEN DIn_Window = 'B' ! ELSE ! value < upper_limit ! DIn_Window remains as 'I' or 'B' END IF END DO END FUNCTION DIn_Window SUBROUTINE DMid_Bezier(x0,y0,x1,y1,x2,y2,x3,y3, & & t,x,y) ! Returns a point (x,y) on a Bezier curve defined by ! the 4 x- and 4 y-values. The internal coordinate of the ! curve is t, which varies from 0.0D0 at the (x0,y0) end ! to 1.00D0 at the (x3,y3) end. ! Point (x1,y1) is the "handle" on the t=0.D0 end, ! and point (x2,y2) is the "handle" on the t=1.D0 end. ! Notation follows page 393 of: ! PostScript Language Reference Manual, ! by Adobe Systems Incorporated, ! 1990 (2nd edition), Addison-Wesley, Menlo Park, CA. IMPLICIT NONE REAL*8, INTENT(IN) :: t, x0,y0,x1,y1,x2,y2,x3,y3 REAL*8, INTENT(OUT):: x, y REAL*8 :: ax, ay, bx, by, cx, cy, t2, t3 IF ((t >= 0.0D0).AND.(t <= 1.00D0)) THEN ax = -x0 + 3.D0*x1 - 3.D0*x2 + x3 bx = 3.D0*x0 - 6.D0*x1 + 3.D0*x2 cx = 3.D0*(x1 - x0) ay = -y0 + 3.D0*y1 - 3.D0*y2 + y3 by = 3.D0*y0 - 6.D0*y1 + 3.D0*y2 cy = 3.D0*(y1 - y0) t2 = t*t t3 = t2*t x = ax*t3 + bx*t2 + cx*t + x0 y = ay*t3 + by*t2 + cy*t + y0 ELSE WRITE (*,"(' ERROR: Invalid t = ',1P,E10.3, & &' sent to DMid_Bezier.')") t CALL DTraceback END IF END SUBROUTINE DMid_Bezier INTEGER FUNCTION DNext_Free_Path () ! returns index of any unused path in ai_pathlib (and associated arrays) IMPLICIT NONE INTEGER :: i IF (ai_total_paths < ai_max_paths) THEN DO i = 1, ai_max_paths IF (ai_path_level(i) == 0) THEN DNext_Free_Path = i RETURN END IF END DO WRITE (*,"(' ERROR: Inconsistent state variables.')") CALL DTraceback ELSE WRITE (*,"(' ERROR: Increase ai_max_paths over current ',I4)") ai_max_paths CALL DTraceback END IF END FUNCTION DNext_Free_Path INTEGER FUNCTION DNext_Path (level) IMPLICIT NONE INTEGER, INTENT(IN) :: level INTEGER :: i DO i = 1, ai_max_paths IF (ai_path_level(i) == level) THEN DNext_Path = i RETURN END IF END DO WRITE (*,"(' ERROR: No path found at requested level ',I2)") level CALL DTraceback END FUNCTION DNext_Path SUBROUTINE DPath_Area(path, a, clockwise) ! Determines the area within a path made of straight line ! segments and/or Bezier curves, and also whether the ! path goes clockwise or counterclockwise. ! Based on theorom that the area (positive when going ! counterclockwise) is the line integral of x * dy. ! In the case of Bezier curves, both x and y are expressed ! in terms of internal variable 0.0D0 <= t <= 1.00D0. ! Note that self-crossing paths like a figure "8" ! will be computed with some sub-areas positive and ! some negative, possibly adding to net area of zero. ! In this case, "clockwise" may be unpredictable. IMPLICIT NONE INTEGER, INTENT(IN) :: path REAL*8, INTENT(OUT) :: a LOGICAL, INTENT(OUT) :: clockwise INTEGER :: i REAL*8 :: ax, ay, bx, by, cx, cy, c0, c1, c2, c3, c4, c5, & & x0,y0, x1,y1, x2,y2, x3,y3, x_last, y_last a = 0.D0 x_last = ai_pathlib(1,0,path) y_last = ai_pathlib(2,0,path) DO i = 1, ai_segments(path) IF (ai_bent(i,path)) THEN x0 = x_last y0 = y_last x1 = ai_pathlib(1,i,path) y1 = ai_pathlib(2,i,path) x2 = ai_pathlib(3,i,path) y2 = ai_pathlib(4,i,path) x3 = ai_pathlib(5,i,path) y3 = ai_pathlib(6,i,path) ax = -x0 + 3.D0*x1 - 3.D0*x2 + x3 bx = 3.D0*x0 - 6.D0*x1 + 3.D0*x2 cx = 3.D0*(x1 - x0) ay = -y0 + 3.D0*y1 - 3.D0*y2 + y3 by = 3.D0*y0 - 6.D0*y1 + 3.D0*y2 cy = 3.D0*(y1 - y0) ! the following are the coefficients of a 5th-order polynomial ! in internal coordinate 0.0D0 <= t <= 1.00D0, ! which expresses the product: x (dy/dt): c5 = 3.D0*ay*ax c4 = 3.D0*ay*bx + 2.D0*by*ax c3 = 3.D0*ay*cx + 2.D0*by*bx + cy*ax c2 = 3.D0*ay*x0 + 2.D0*by*cx + cy*bx c1 = 2.D0*by*x0 + cy*cx c0 = cy*x0 ! Integrating this polynomial from t=0.D0 to t=1.D0: a = a + c5/6.D0 + c4/5.D0 + c3/4.D0 + c2/3.D0 + c1/2.D0 + c0 x_last = x3 y_last = y3 ELSE ! straight segment x0 = x_last y0 = y_last x1 = ai_pathlib(1,i,path) y1 = ai_pathlib(2,i,path) a = a + 0.5D0 * (x0 + x1) * (y1 - y0) x_last = x1 y_last = y1 END IF END DO clockwise = (a < 0.0D0) a = DABS(a) END SUBROUTINE DPath_Area SUBROUTINE DProcess_L2_Paths () ! Apply (pre-defined) window to truncate or eliminate L2 path(s) ! if they stray outside the window. ! Then send resulting L1 path(s) to output file. IMPLICIT NONE CHARACTER*1 :: abyte CHARACTER*1, DIMENSION(1:ai_longest) :: seg_memo ! O, B, I CHARACTER*1, DIMENSION(0:ai_longest) :: point_memo ! O, B, I INTEGER :: crossings, first, i, intersections, inout_list_count, & & ip1, j, k, & & kp1, last, n_area, new_path, & & new_segments, number, old_segments, path, trial_first, trial_last LOGICAL :: all_segs_in, all_segs_out, area_done, & & clockwise, connects, curve_shows, encircled, filled, & & found_in_list, last_shown, line_shows, next_is_out, & & point0_shows, point1_shows, seg_shows, this_is_out, this_shown, unchanged LOGICAL(1), DIMENSION(ai_longest) :: new_segment_used REAL*8, PARAMETER :: tolerance = 1.0D0 ! points error allowed in closures REAL*8 :: a, base_of_t, f_a_1, f_a_2, f_b_1, f_b_2, t1, t2, x_closure, & & x_last, x0, x1, x2, x3, xa, xa0, xa1, xb, xb0, xb1, xm1, xm2, xp, & & x_start, xt0, xt1, xt2, xt3, y_closure, & & y_last, y0, y1, y2, y3, ya, ya0, ya1, yb, yb0, yb1, ym1, ym2, yp, & & y_start, yt0, yt1, yt2, yt3 REAL*8, DIMENSION(3) :: t_vec, tls_vec REAL*8, DIMENSION(16) :: r2, t_list, x_list, y_list REAL*8, DIMENSION(16) :: t_edge, t04_edge, x_edge, y_edge REAL*8, DIMENSION(1:ai_longest) :: t04_memo INTEGER, PARAMETER :: inout_list_limit = 400 ! maximum number of intersections with boundary INTEGER, PARAMETER :: patience = 20 ! length of debugging arrays REAL*8, DIMENSION(inout_list_limit) :: t_0_to_4, x_inout_list, y_inout_list TYPE debugger LOGICAL :: bent REAL*8 :: x REAL*8 :: y END TYPE debugger TYPE(debugger), DIMENSION(0:patience) :: old_route, new_route !Note: These two arrays are used ONLY to display paths for debugging. !-------------------------------------------------------------- ! Debugging utility: assigns a unique number to each CALL here, ! so you can trap the one CALL that will crash. INTEGER :: calling = 0 SAVE calling calling = calling + 1 IF (calling == -1) THEN ! set the bad CALL count here j = 0 ! put breakpoint on this line! END IF !----------------------------------------------------------------- ! Empty the debugging arrays, to avoid confusion with old numbers: DO i = 0, patience old_route(i)%bent = .FALSE. old_route(i)%x = -999.999D0 old_route(i)%y = -999.999D0 new_route(i)%bent = .FALSE. new_route(i)%x = -999.999D0 new_route(i)%y = -999.999D0 END DO !----------------------------------------------------------------- DO WHILE (ai_Ln_paths(2) > 0) path = DNext_Path(level = 2) old_segments = ai_segments(path) ! for debugging visibility ! Shortcut complex logic (below) if path has only an initial point, ! but no segments. Pass it through (even though it has no ! graphical effect) if it falls in the window. IF (old_segments == 0) THEN ! path has only an initial point point_memo(0) = DIn_Window(ai_pathlib(1,0,path),ai_pathlib(2,0,path)) IF ((point_memo(0) == 'I').OR.(point_memo(0) == 'B')) THEN !Transform path to level 1, and call for Writing: ai_path_level(path) = 1 ai_Ln_paths(2) = ai_Ln_paths(2) - 1 ai_Ln_paths(1) = ai_Ln_paths(1) + 1 CALL DWrite_L1_Paths() ELSE ! just eliminate this path: ai_path_level(path) = 0 ai_Ln_paths(2) = ai_Ln_paths(2) - 1 ai_total_paths = ai_total_paths - 1 END IF ! inside, or outside CYCLE ! so as to consider the next L2 path in library END IF ! path had no segments, but just an initial point filled = ai_filled(path) ! Copy path to a new slot at level -1 (because it may expand), ! adding new control points WITHIN SEGMENTS where they cross ! the window boundary. (If a segment coincides with the ! boundary for some distance, both initial and final points ! will be in the new list, either as original or added points.) ! While working, record whether each point (either an original ! control point, or an added control point) is outside ('O'), ! on the boundary ('B'), or inside ('I'). new_path = DNext_Free_Path() ai_path_level(new_path) = -1 ! temporary working array, not to be written ai_total_paths = ai_total_paths + 1 ai_closed(new_path) = ai_closed(path) ai_stroked(new_path) = ai_stroked(path) ai_filled(new_path) = ai_filled(path) ai_pathlib(1,0,new_path) = ai_pathlib(1,0,path) ai_pathlib(2,0,new_path) = ai_pathlib(2,0,path) point_memo(0) = DIn_Window(ai_pathlib(1,0,path),ai_pathlib(2,0,path)) unchanged = (point_memo(0) == 'I').OR.(point_memo(0) == 'B') new_segments = 0 x_last = ai_pathlib(1,0,path) y_last = ai_pathlib(2,0,path) old_route(0)%x = x_last old_route(0)%y = y_last new_route(0)%x = x_last new_route(0)%y = y_last DO i = 1, old_segments intersections = 0 IF (i <= patience) old_route(i)%bent = ai_bent(i,path) IF (ai_bent(i,path)) THEN abyte = DIn_Window(ai_pathlib(5,i,path),ai_pathlib(6,i,path)) IF (abyte == 'O') unchanged = .FALSE. !must assume possibility of intersections regardless of endpoints x0 = x_last y0 = y_last x1 = ai_pathlib(1,i,path) y1 = ai_pathlib(2,i,path) x2 = ai_pathlib(3,i,path) y2 = ai_pathlib(4,i,path) x3 = ai_pathlib(5,i,path) y3 = ai_pathlib(6,i,path) IF (i <= patience) old_route(i)%x = x3 IF (i <= patience) old_route(i)%y = y3 !check for any intersections (0...3 each) with each side of window DO j = 1, 4 ! 4 sides of window, going around counterclockwise SELECT CASE(j) CASE(1) ! bottom, going right xb0 = ai_window_x1_points yb0 = ai_window_y1_points xb1 = ai_window_x2_points yb1 = ai_window_y1_points base_of_t = 0.D0 CASE(2) ! right, going up xb0 = ai_window_x2_points yb0 = ai_window_y1_points xb1 = ai_window_x2_points yb1 = ai_window_y2_points base_of_t = 1.D0 CASE(3) ! top, going left xb0 = ai_window_x2_points yb0 = ai_window_y2_points xb1 = ai_window_x1_points yb1 = ai_window_y2_points base_of_t = 2.D0 CASE(4) ! left, going down xb0 = ai_window_x1_points yb0 = ai_window_y2_points xb1 = ai_window_x1_points yb1 = ai_window_y1_points base_of_t = 3.D0 END SELECT CALL DSateh(x0,y0, x1,y1, x2,y2, x3,y3, & & xb0,yb0, xb1, yb1, & !input & number, t_vec, tls_vec, x_list, y_list) ! output IF (number >= 1) THEN unchanged = .FALSE. DO k = 1, number intersections = intersections + 1 t_edge(intersections) = t_vec(k) t04_edge(intersections) = base_of_t + tls_vec(k) x_edge(intersections) = x_list(k) y_edge(intersections) = y_list(k) END DO ! k = 1, intersections END IF END DO !sort the list of intersections by t (of Bezier curve) IF (intersections > 1) CALL DSort_Lists(intersections, t_edge, t04_edge, x_edge, y_edge) IF (intersections > 0) THEN ! (Note: Case of no intersections is an ELSE, far below.) DO j = 1, intersections IF (j == 1) THEN t1 = 0.0D0 ELSE t1 = t_edge(j-1) END IF t2 = t_edge(j) IF (t2 <= 0.0D0) CYCLE IF (t1 >= 1.0D0) CYCLE IF (t1 >= t2) CYCLE CALL DBezier_Fragment(x0,y0, x1,y1, x2,y2, x3,y3, & & t1, t2, & ! input & xt0,yt0, xt1,yt1, xt2,yt2, xt3,yt3) new_segments = new_segments + 1 IF (new_segments >= ai_longest) THEN WRITE (*,"(' ERROR: Path length > ai_longest =',I6)") ai_longest CALL DTraceback END IF ai_pathlib(1,new_segments,new_path) = xt1 ai_pathlib(2,new_segments,new_path) = yt1 ai_pathlib(3,new_segments,new_path) = xt2 ai_pathlib(4,new_segments,new_path) = yt2 ai_pathlib(5,new_segments,new_path) = xt3 ai_pathlib(6,new_segments,new_path) = yt3 ai_bent(new_segments,new_path) = .TRUE. IF (new_segments <= patience) THEN new_route(new_segments)%bent = .TRUE. new_route(new_segments)%x = xt3 new_route(new_segments)%y = yt3 END IF CALL DMid_Bezier(xt0,yt0,xt1,yt1,xt2,yt2,xt3,yt3, & & 0.500D0,xp,yp) seg_memo(new_segments) = DIn_Window(xp,yp) point_memo(new_segments) = 'B' ! border point t04_memo(new_segments) = t04_edge(j) x_last = xt3 y_last = yt3 END DO ! j = 1, intersections IF (t2 < 1.0) THEN ! complete the segment t1 = t2 CALL DBezier_Fragment(x0,y0, x1,y1, x2,y2, x3,y3, & & t1, 1.00D0, & ! input & xt0,yt0, xt1,yt1, xt2,yt2, xt3,yt3) new_segments = new_segments + 1 IF (new_segments >= ai_longest) THEN WRITE (*,"(' ERROR: Path length > ai_longest =',I6)") ai_longest CALL DTraceback END IF ai_pathlib(1,new_segments,new_path) = xt1 ai_pathlib(2,new_segments,new_path) = yt1 ai_pathlib(3,new_segments,new_path) = xt2 ai_pathlib(4,new_segments,new_path) = yt2 ai_pathlib(5,new_segments,new_path) = xt3 ai_pathlib(6,new_segments,new_path) = yt3 ai_bent(new_segments,new_path) = .TRUE. IF (new_segments <= patience) THEN new_route(new_segments)%bent = .TRUE. new_route(new_segments)%x = xt3 new_route(new_segments)%y = yt3 END IF CALL DMid_Bezier(xt0,yt0,xt1,yt1,xt2,yt2,xt3,yt3, & & 0.500D0,xp,yp) seg_memo(new_segments) = DIn_Window(xp,yp) point_memo(new_segments) = abyte t04_memo(new_segments) = 0. x_last = xt3 y_last = yt3 END IF ELSE ! no intersections found for this curved segment new_segments = new_segments + 1 IF (new_segments >= ai_longest) THEN WRITE (*,"(' ERROR: Path length > ai_longest =',I6)") ai_longest CALL DTraceback END IF ai_pathlib(1,new_segments,new_path) = ai_pathlib(1,i,path) ai_pathlib(2,new_segments,new_path) = ai_pathlib(2,i,path) ai_pathlib(3,new_segments,new_path) = ai_pathlib(3,i,path) ai_pathlib(4,new_segments,new_path) = ai_pathlib(4,i,path) ai_pathlib(5,new_segments,new_path) = ai_pathlib(5,i,path) ai_pathlib(6,new_segments,new_path) = ai_pathlib(6,i,path) ai_bent(new_segments,new_path) = .TRUE. IF (new_segments <= patience) THEN new_route(new_segments)%bent = .TRUE. new_route(new_segments)%x = ai_pathlib(5,i,path) new_route(new_segments)%y = ai_pathlib(6,i,path) END IF CALL DMid_Bezier(x_last, y_last, & & ai_pathlib(1,i,path), & & ai_pathlib(2,i,path), & & ai_pathlib(3,i,path), & & ai_pathlib(4,i,path), & & ai_pathlib(5,i,path), & & ai_pathlib(6,i,path), & & 0.500D0,xp,yp) seg_memo(new_segments) = DIn_Window(xp,yp) point_memo(new_segments) = abyte END IF x_last = ai_pathlib(5,i,path) y_last = ai_pathlib(6,i,path) ELSE ! lineto segment abyte = DIn_Window(ai_pathlib(1,i,path),ai_pathlib(2,i,path)) IF ((point_memo(new_segments) == 'O').OR.(abyte == 'O')) THEN unchanged = .FALSE. ! since path went outside. ! Intersections (1 or 2) may occur within segment: xa0 = x_last ya0 = y_last xa1 = ai_pathlib(1,i,path) ya1 = ai_pathlib(2,i,path) IF (i <= patience) old_route(i)%x = xa1 IF (i <= patience) old_route(i)%y = ya1 DO j = 1, 4 SELECT CASE(j) !going counterclockwise: CASE(1) ! bottom, going right xb0 = ai_window_x1_points yb0 = ai_window_y1_points xb1 = ai_window_x2_points yb1 = ai_window_y1_points base_of_t = 0.D0 CASE(2) ! right, going up xb0 = ai_window_x2_points yb0 = ai_window_y1_points xb1 = ai_window_x2_points yb1 = ai_window_y2_points base_of_t = 1.D0 CASE(3) ! top, going left xb0 = ai_window_x2_points yb0 = ai_window_y2_points xb1 = ai_window_x1_points yb1 = ai_window_y2_points base_of_t = 2.D0 CASE(4) ! left, going down xb0 = ai_window_x1_points yb0 = ai_window_y2_points xb1 = ai_window_x1_points yb1 = ai_window_y1_points base_of_t = 3.D0 END SELECT CALL DX_Marks(xa0,ya0, xa1,ya1, & & xb0,yb0, xb1,yb1, & ! input & crossings, xm1,ym1, xm2,ym2, & & f_a_1, f_a_2, f_b_1, f_b_2) ! output IF (crossings >= 1) THEN intersections = intersections + 1 x_list(intersections) = xm1 y_list(intersections) = ym1 t_list(intersections) = base_of_t + f_b_1 END IF IF (crossings >= 2) THEN intersections = intersections + 1 x_list(intersections) = xm2 y_list(intersections) = ym2 t_list(intersections) = base_of_t + f_b_2 END IF END DO ! 4 sides of window DO j = 1, intersections ! compute distances (squared) from beginning of segment r2(j) = (x_list(j)-x_last)**2 + (y_list(j)-y_last)**2 END DO IF (intersections > 1) CALL DSort_Lists(intersections, r2, t_list, x_list, y_list) DO j = 1, intersections ! avoid duplicating previous point IF ((x_list(j) == x_last).AND.(y_list(j) == y_last)) CYCLE ! avoid duplicating end control point !IF ((x_list(j) == ai_pathlib(1,i,path)).AND. & ! &(y_list(j) == ai_pathlib(2,i,path))) CYCLE ! add an intersection to the expanded path new_segments = new_segments + 1 IF (new_segments >= ai_longest) THEN WRITE (*,"(' ERROR: Path length > ai_longest =',I6)") ai_longest CALL DTraceback END IF ai_pathlib(1,new_segments,new_path) = x_list(j) ai_pathlib(2,new_segments,new_path) = y_list(j) ai_bent(new_segments,new_path) = .FALSE. IF (new_segments <= patience) THEN new_route(new_segments)%bent = .FALSE. new_route(new_segments)%x = x_list(j) new_route(new_segments)%y = y_list(j) END IF point_memo(new_segments) = 'B' ! new border point t04_memo(new_segments) = t_list(j) xp = 0.5 *(x_last + x_list(j)) yp = 0.5 *(y_last + y_list(j)) seg_memo(new_segments) = DIn_Window(xp,yp) x_last = x_list(j) y_last = y_list(j) END DO ! on sorted intersections !Complete line segment if any remains IF ((x_last /= ai_pathlib(1,i,path)).OR. & & (y_last /= ai_pathlib(2,i,path))) THEN new_segments = new_segments + 1 IF (new_segments >= ai_longest) THEN WRITE (*,"(' ERROR: Path length > ai_longest =',I6)") ai_longest CALL DTraceback END IF ai_pathlib(1,new_segments,new_path) = ai_pathlib(1,i,path) ai_pathlib(2,new_segments,new_path) = ai_pathlib(2,i,path) ai_bent(new_segments,new_path) = .FALSE. IF (new_segments <= patience) THEN new_route(new_segments)%bent = .FALSE. new_route(new_segments)%x = ai_pathlib(1,i,path) new_route(new_segments)%y = ai_pathlib(2,i,path) END IF point_memo(new_segments) = abyte t04_memo(new_segments) = 0. xp = 0.5 *(x_last + ai_pathlib(1,i,path)) yp = 0.5 *(y_last + ai_pathlib(2,i,path)) seg_memo(new_segments) = DIn_Window(xp,yp) x_last = ai_pathlib(1,i,path) y_last = ai_pathlib(2,i,path) END IF ! any last piece of line to be added ELSE ! whole line inside (or on border); no intersections possible IF (i <= patience) old_route(i)%x = ai_pathlib(1,i,path) IF (i <= patience) old_route(i)%y = ai_pathlib(2,i,path) new_segments = new_segments + 1 IF (new_segments >= ai_longest) THEN WRITE (*,"(' ERROR: Path length > ai_longest =',I6)") ai_longest CALL DTraceback END IF ai_pathlib(1,new_segments,new_path) = ai_pathlib(1,i,path) ai_pathlib(2,new_segments,new_path) = ai_pathlib(2,i,path) ai_bent(new_segments,new_path) = .FALSE. IF (new_segments <= patience) THEN new_route(new_segments)%bent = .FALSE. new_route(new_segments)%x = ai_pathlib(1,i,path) new_route(new_segments)%y = ai_pathlib(2,i,path) END IF point_memo(new_segments) = abyte t04_memo(new_segments) = 0.D0 xp = 0.5 *(x_last + ai_pathlib(1,i,path)) yp = 0.5 *(y_last + ai_pathlib(2,i,path)) seg_memo(new_segments) = DIn_Window(xp,yp) x_last = ai_pathlib(1,i,path) y_last = ai_pathlib(2,i,path) END IF ! possible intersections in straight segment, or not? END IF ! bent or straight END DO ! i = 1, ai_segments(path) IF (filled) THEN ! Filled (and maybe stroked?) paths may require ! completions along the window boundary!!! ! First, decide whether path is all-in, all-out, ! or some complex mixture: all_segs_in = .TRUE. all_segs_out = .TRUE. DO i = 1, new_segments IF (seg_memo(i) == 'O') all_segs_in = .FALSE. IF ((seg_memo(i) == 'I').OR.(seg_memo(i) == 'B')) all_segs_out = .FALSE. END DO IF (all_segs_in) THEN ! No need to modify path at all! Just change level. ai_Ln_paths(2) = ai_Ln_paths(2) - 1 ai_path_level(path) = 1 ai_Ln_paths(1) = ai_Ln_paths(1) + 1 CALL DWrite_L1_Paths !{Note: Clean-up of the copied new-path will occur at end of this routine.} ELSE IF (all_segs_out) THEN ! Probably no action*, but check for special case: ! Does path encircle the center of the window??? !(This tests for special case where ENTIRE WINDOW is ! inside the path, even though it has no points in the ! window, and never crosses the boundary.) !{*Other than deleting the path and the copied new-path, ! which will happen at the end of this routine.} encircled = (DIn_Path(ai_window_xc_points,ai_window_yc_points,path) == 'I') IF (encircled) THEN ! Special case; path surrounds window without ! ever touching it! Fill whole window. CALL DNew_L12_Path(1,ai_window_x1_points,ai_window_y1_points) CALL DLine_To_L12(ai_window_x2_points,ai_window_y1_points) CALL DLine_To_L12(ai_window_x2_points,ai_window_y2_points) CALL DLine_To_L12(ai_window_x1_points,ai_window_y2_points) CALL DLine_To_L12(ai_window_x1_points,ai_window_y1_points) CALL DEnd_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! encircled, or not ELSE ! filled path crosses boundary; complex logic! ! Does path circulate clockwise or counterclockwise??? CALL DPath_Area(path, a, clockwise) ! Build a short list of boundary-crossing points, and ! then sort them into the order needed for interpolation: inout_list_count = 0 DO i = 1, new_segments ip1 = MOD(i,new_segments) + 1 this_is_out = (seg_memo(i) == 'O') next_is_out = (seg_memo(ip1) == 'O') IF (this_is_out .NEQV. next_is_out) THEN inout_list_count = inout_list_count + 1 IF (inout_list_count > inout_list_limit) THEN WRITE (*,"(' ERROR: Increase parameter inout_list_limit.')") CALL DTraceback END IF t_0_to_4(inout_list_count) = t04_memo(i) IF (ai_bent(i,new_path)) THEN x_inout_list(inout_list_count) = ai_pathlib(5,i,new_path) y_inout_list(inout_list_count) = ai_pathlib(6,i,new_path) ELSE ! straight segment x_inout_list(inout_list_count) = ai_pathlib(1,i,new_path) y_inout_list(inout_list_count) = ai_pathlib(2,i,new_path) END IF END IF ! got another inout point at end of segment END DO ! i = 1, new_segments IF (clockwise) THEN ! reverse definition of t to get points in clockwise order: DO j = 1, inout_list_count t_0_to_4(j) = 4.00 - t_0_to_4(j) END DO END IF IF (inout_list_count > 2) CALL DSort_Lists(inout_list_count, & & t_0_to_4, x_inout_list, y_inout_list) DO i = 1, new_segments new_segment_used(i) = (seg_memo(i) == 'O') END DO all_areas: DO n_area = 1, 10 ! probably not this many areas, but we'll EXIT ! Find an unused starting segment which is in, but follows ! a segment which is out. Thus, its initial point will ! be a loose end on the boundary that ultimately needs to ! be the end point of the last segment in a path. first = 0 ! will be a sign of failure if not changed find_first: DO i = 1, new_segments trial_first = i IF (.NOT.new_segment_used(i)) THEN trial_last = MOD((i - 2 + new_segments),new_segments) + 1 IF (((seg_memo(trial_first)=='I').OR.(seg_memo(trial_first)=='B')) & & .AND.(seg_memo(trial_last)=='O')) THEN first = trial_first last = trial_last EXIT find_first END IF ! this segment visible, but last wasn't END IF ! trial_first not used yet END DO find_first IF (first == 0) EXIT all_areas ! no more starting segments last_shown = .FALSE. DO i = 1, new_segments ! but j, below, is real loop variable j = MOD((first + i - 2), new_segments) + 1 ! j = first...last seg_shows = ((seg_memo(j) == 'I').OR.(seg_memo(j) == 'B')) IF (seg_shows) THEN IF (ai_in_path) THEN ! Does this segment start at where we are? IF (j == 1) THEN x_start = ai_pathlib(1,0,new_path) y_start = ai_pathlib(2,0,new_path) ELSE ! j > 1 IF (ai_bent(j-1,new_path)) THEN x_start = ai_pathlib(5,j-1,new_path) y_start = ai_pathlib(6,j-1,new_path) ELSE ! previous segment straight x_start = ai_pathlib(1,j-1,new_path) y_start = ai_pathlib(2,j-1,new_path) END IF ! previous seg bent / straight END IF ! j == 1 or greater connects = last_shown .OR. & ! internal segs in order, or good match & ((DABS(x_start - ai_last_L12_x_points) <= tolerance).AND. & & (DABS(y_start - ai_last_L12_y_points) <= tolerance)) this_shown = connects ! set switch for code below ELSE ! not ai_in_path; must start one this_shown = .TRUE. ! Need to start new path (and remember the closure point, ! which should always be a boundary point) IF (j == 1) THEN x_closure = ai_pathlib(1,0,new_path) y_closure = ai_pathlib(2,0,new_path) ELSE ! j > 1 IF (ai_bent(j-1,new_path)) THEN x_closure = ai_pathlib(5,j-1,new_path) y_closure = ai_pathlib(6,j-1,new_path) ELSE ! previous segment straight x_closure = ai_pathlib(1,j-1,new_path) y_closure = ai_pathlib(2,j-1,new_path) END IF ! previous seg bent / straight END IF ! j == 1 or greater CALL DNew_L12_Path(1,x_closure,y_closure) END IF ! new path needed IF (this_shown) THEN ! show it! IF (ai_bent(j,new_path)) THEN CALL DCurve_To_L12(ai_pathlib(1,j,new_path), & & ai_pathlib(2,j,new_path), & & ai_pathlib(3,j,new_path), & & ai_pathlib(4,j,new_path), & & ai_pathlib(5,j,new_path), & & ai_pathlib(6,j,new_path)) new_segment_used(j) = .TRUE. ELSE ! segment j is straight CALL DLine_To_L12(ai_pathlib(1,j,new_path),ai_pathlib(2,j,new_path)) new_segment_used(j) = .TRUE. END IF ! segment j is bent / straight END IF ! this_shown ELSE ! segment j is not visable this_shown = .FALSE. IF (last_shown) THEN ! Need to complete (along boundary) and close segment!!! ! Starting point of boundary loop is (xa, xb): IF (j == 1) THEN xa = ai_pathlib(1,0,new_path) ya = ai_pathlib(2,0,new_path) ELSE ! j > 1 IF (ai_bent(j-1,new_path)) THEN xa = ai_pathlib(5,j-1,new_path) ya = ai_pathlib(6,j-1,new_path) ELSE ! previous segment straight xa = ai_pathlib(1,j-1,new_path) ya = ai_pathlib(2,j-1,new_path) END IF ! previous seg bent / straight END IF ! j == 1 or greater ! Ending point of boundary loop (xb,yb) may be ! either (x_closure,y_closure) where this path started, ! or else a different boundary point (where path re-enters): ! Use the ordered list of boundary points to find the next ! re-entry in the "clockwise"(?) direction: found_in_list = .FALSE. lookup: DO k = 1, inout_list_count IF ((xa == x_inout_list(k)).AND.(ya == y_inout_list(k))) THEN ! found (xa, xb) found_in_list = .TRUE. ! next point (cyclically) in list: kp1 = MOD(k,inout_list_count) + 1 xb = x_inout_list(kp1) yb = y_inout_list(kp1) EXIT lookup END IF ! found current (xa, xb) in list END DO lookup ! k = 1, inout_list_count IF (.NOT.found_in_list) THEN WRITE (*,"(' ERROR: Boundary point not found in ordered list.')") CALL DTraceback END IF CALL DTrace_Boundary(xa,ya,clockwise,xb,yb) area_done = (ABS(xb - x_closure) <= tolerance).AND. & & (ABS(yb - y_closure) <= tolerance) IF (area_done) THEN CALL DEnd_L12_Path(close = .TRUE., stroke = ai_stroked(path), fill = .TRUE.) CYCLE all_areas END IF ! area_done END IF END IF ! segment j is visible / not visible last_shown = this_shown ! prepare to loop END DO ! on all segments in filled, boundary-cutting path END DO all_areas ! distinct filled areas !All areas should now be closed, but check this! IF (ai_in_path) THEN WRITE (*,"(' WARNING: A filled path did not close as expected, in DProcess_L2_Paths.')") WRITE (*, *) ! so "Working on gridded data...DONE." does not overwrite this warning. !CALL DTraceback !Instead of Traceback and halt; attempt recovery... CALL DEnd_L12_Path(close = .TRUE., stroke = ai_stroked(path), fill = .TRUE.) END IF END IF ! path is all-in / all-out / crosses boundary ELSE ! path is only stroked x_last = ai_pathlib(1,0,new_path) y_last = ai_pathlib(2,0,new_path) point0_shows = (point_memo(0) == 'I').OR.(point_memo(0) == 'B') IF (point0_shows) CALL DNew_L12_Path(1, ai_pathlib(1,0,new_path), & & ai_pathlib(2,0,new_path)) DO i = 1, new_segments point1_shows = (point_memo(i) == 'I').OR.(point_memo(i) == 'B') IF (ai_bent(i,new_path)) THEN IF ((point_memo(i-1) == 'I').OR.(point_memo(i) == 'I')) THEN curve_shows = .TRUE. ELSE IF ((point_memo(i-1) == 'O').OR.(point_memo(i) == 'O')) THEN curve_shows = .FALSE. ELSE ! both control points are on the boundary; ! which way does the line bulge? curve_shows = (seg_memo(i) == 'I') END IF IF (curve_shows) THEN IF (ai_in_path) THEN CALL DCurve_To_L12(ai_pathlib(1,i,new_path), & & ai_pathlib(2,i,new_path), & & ai_pathlib(3,i,new_path), & & ai_pathlib(4,i,new_path), & & ai_pathlib(5,i,new_path), & & ai_pathlib(6,i,new_path)) ELSE ! not in path IF (ai_bent(i-1,new_path)) THEN CALL DNew_L12_Path(1,ai_pathlib(5,i-1,new_path), & & ai_pathlib(6,i-1,new_path)) ELSE ! last segment not bent CALL DNew_L12_Path(1,ai_pathlib(1,i-1,new_path), & & ai_pathlib(2,i-1,new_path)) END IF ! last segment bent or not CALL DCurve_To_L12(ai_pathlib(1,i,new_path), & & ai_pathlib(2,i,new_path), & & ai_pathlib(3,i,new_path), & & ai_pathlib(4,i,new_path), & & ai_pathlib(5,i,new_path), & & ai_pathlib(6,i,new_path)) END IF ! in path or not ELSE ! curve doesn't show IF (ai_in_path) THEN CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! in path END IF ! curve shows or not x_last = ai_pathlib(5,i,new_path) y_last = ai_pathlib(6,i,new_path) ELSE ! lineto line_shows = point0_shows .AND. point1_shows IF (line_shows) THEN IF (ai_in_path) THEN CALL DLine_To_L12(ai_pathlib(1,i,new_path), & & ai_pathlib(2,i,new_path)) ELSE ! was not in path IF (ai_bent(i-1,new_path)) THEN CALL DNew_L12_Path(1,ai_pathlib(5,i-1,new_path), & & ai_pathlib(6,i-1,new_path)) ELSE ! last segment not bent CALL DNew_L12_Path(1,ai_pathlib(1,i-1,new_path), & & ai_pathlib(2,i-1,new_path)) END IF ! last segment bent or not CALL DLine_To_L12(ai_pathlib(1,i,new_path), & & ai_pathlib(2,i,new_path)) END IF ! in path or not ELSE ! line doesn't show IF (ai_in_path) THEN CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF END IF ! line shows or not x_last = ai_pathlib(1,i,new_path) y_last = ai_pathlib(2,i,new_path) END IF ! curveto or lineto point0_shows = point1_shows END DO ! i = 1, segments2 IF (ai_in_path) CALL DEnd_L12_Path( close = (ai_closed(path).AND.unchanged), & & stroke = .TRUE., fill = .FALSE.) END IF ! filled? or only stroked? ! Free up original L2 path (if still L2, and not passed-through intact as L1): IF (ai_path_level(path) == 2) THEN ai_path_level(path) = 0 ai_Ln_paths(2) = ai_Ln_paths(2) - 1 ai_total_paths = ai_total_paths - 1 END IF ! Free up temporary L(-1) path: ai_path_level(new_path) = 0 ai_total_paths = ai_total_paths - 1 CALL DWrite_L1_Paths END DO ! on all L2 paths presented END SUBROUTINE DProcess_L2_Paths SUBROUTINE DProcess_L2_Text (x_points, y_points, angle_radians, & & font_points, lr_fraction, ud_fraction, & & text) IMPLICIT NONE INTEGER, INTENT(IN) :: font_points REAL*8, INTENT(IN) :: x_points, y_points, angle_radians, & & lr_fraction, ud_fraction CHARACTER*(*),INTENT(IN) :: text INTEGER :: bytes LOGICAL in bytes = LEN_TRIM(text) in = (x_points >= ai_window_x1_points).AND. & & (x_points <= ai_window_x2_points).AND. & & (y_points >= ai_window_y1_points).AND. & & (y_points <= ai_window_y2_points) IF (in) CALL DWrite_L1_Text (x_points, y_points, angle_radians, & & font_points, lr_fraction, ud_fraction, & & text) END SUBROUTINE DProcess_L2_Text SUBROUTINE DSateh(x0,y0, x1,y1, x2,y2, x3,y3, & & xls0,yls0, xls1,yls1, & !input & number, t_vec, tls_vec, x_list, y_list) ! output ! Counts and locates all the intersections (0, 1, 2, or 3) ! between a Bezier curve from (x0,y0)~(x3,y3) !(whose "handle" control points are (x1,y1) and (x2,y2)), ! and a straight line segment (xls0,yls0)-(xls1,yls1). ! The routine is named for the resemblence to a piece of ! Indonesian sateh skewered on bamboo for grilling. !"Number" is the count of intersections found, and ! t1, t2, t3 (as many as needed) are the internal coordinates ! of the intersection points along the Bezier curve ! (always between 0.0D0 and 1.0D0, by definition of t). ! Array tls_vec has similar internal coordinates for the same ! intersections in the internal coordinate system of the line segment. ! The (x,y) coordinates of the intersections are in x_list, y_list. ! Notation for the Bezier curve follows page 393 of: ! PostScript Language Reference Manual, ! by Adobe Systems Incorporated, Addison-Wesley, ! second edition, 1990. IMPLICIT NONE REAL*8, INTENT(IN) :: x0,y0, x1,y1, x2,y2, x3,y3, & & xls0,yls0, xls1, yls1 INTEGER, INTENT(OUT) :: number REAL*8, DIMENSION(3), INTENT(OUT):: t_vec, tls_vec, x_list, y_list INTEGER :: good_ones, i REAL*8, PARAMETER :: Pi_over_2 = 1.5707963267948965D0 REAL*8 :: alpha0, alpha1, alpha_t, angle, ax, ay, & & beta_ls, bx, by, constant, cubic, cx, cy, & & linear, quadratic, x, y REAL*8, DIMENSION(2) :: alpha, beta ! Reject problem if (xls0,yls0) = (xls1,yls1): IF ((xls0 == xls1).AND.(yls0 == yls1)) THEN WRITE (*,"(' ERROR: Line segment has zero length.')") CALL DTraceback END IF ! slope of line segment: angle = DATAN2(yls1-yls0, xls1-xls0) ! alpha is a unit vector along the line: alpha(1) = DCOS(angle) alpha(2) = DSIN(angle) ! beta is 90 degrees counterclockwise from alpha: beta(1) = -alpha(2) beta(2) = alpha(1) ! two alpha limits on line segment: alpha0 = alpha(1)*xls0 + alpha(2)*yls0 alpha1 = alpha(1)*xls1 + alpha(2)*yls1 ! (constant) beta value of line segment: beta_ls = beta(1)*xls0 + beta(2)*yls0 ! 6 coefficients of the Bezier polynomials in the (x,y) system: ax = -x0 + 3.D0* (x1 - x2) + x3 bx = 3.D0*x0 - 6.D0*x1 + 3.*x2 cx = 3.D0*(x1 - x0) ay = -y0 + 3.D0* (y1 - y2) + y3 by = 3.D0*y0 - 6.D0*y1 + 3.D0*y2 cy = 3.D0*(y1 - y0) ! coefficients of a new polynomial: ! beta(t) - beta_ls = cubic_polynomial(t) = 0 cubic = beta(1)*ax + beta(2)*ay quadratic = beta(1)*bx + beta(2)*by linear = beta(1)*cx + beta(2)*cy constant = beta(1)*x0 + beta(2)*y0 - beta_ls ! get real roots of this cubic problem: CALL DCubic_Roots(cubic, quadratic, linear, constant, & & number, t_vec(1), t_vec(2), t_vec(3)) IF (number == 0) RETURN ! test each root for: 0.D0 <= t <= 1.D0, AND: alpha0 <= alpha <= alpha1. good_ones = 0 DO i = 1, number IF ((t_vec(i) >= 0.).AND.(t_vec(i) <= 1.D0)) THEN CALL DMid_Bezier(x0,y0,x1,y1,x2,y2,x3,y3, & & t_vec(i),x,y) alpha_t = alpha(1) * x + alpha(2) * y tls_vec(i) = (alpha_t - alpha0) / (alpha1 - alpha0) IF ((tls_vec(i) >= 0.D0).AND.(tls_vec(i) <= 1.D0)) THEN good_ones = good_ones + 1 t_vec(good_ones) = t_vec(i) tls_vec(good_ones) = tls_vec(i) x_list(good_ones) = x y_list(good_ones) = y END IF END IF END DO ! redefine number of roots as only those within range: number = good_ones END SUBROUTINE DSateh SUBROUTINE DSet_Join_to_Mitre () ! Issues command that will cause subsequent polylines to have their ! individual straight-line parts joined together in ! Mitre style. This is good for boxes, but bad for coastlines !(see Set_Join_to_Round). IMPLICIT NONE IF (ai_page_open) THEN WRITE (ai_out_unit,"('0 j')") ! 0 is Mitre stye; j is "join type". ELSE WRITE (*,"(' ERROR: Must Begin_Page before Set_Join_to_Mitre.')") CALL DTraceback END IF END SUBROUTINE DSet_Join_to_Mitre SUBROUTINE DSet_Join_to_Round () ! Issues command that will cause subsequent polylines to have their ! individual straight-line parts joined together in ! Round style. This is good for coastlines, but bad for boxes !(see Set_Join_to_Mitre). IMPLICIT NONE IF (ai_page_open) THEN WRITE (ai_out_unit,"('1 j')") ! 1 is Round stye; j is "join type". ELSE WRITE (*,"(' ERROR: Must Begin_Page before Set_Join_to_Round.')") CALL DTraceback END IF END SUBROUTINE DSet_Join_to_Round SUBROUTINE DSet_Join_to_Bevel () ! Issues command that will cause subsequent polylines to have their ! individual straight-line parts joined together in ! Bevel style. See also Set_Join_to_Mitre and Set_Join_to_Round IMPLICIT NONE IF (ai_page_open) THEN WRITE (ai_out_unit,"('2 j')") ! 2 is Bevel stye; j is "join type". ELSE WRITE (*,"(' ERROR: Must Begin_Page before Set_Join_to_Bevel.')") CALL DTraceback END IF END SUBROUTINE DSet_Join_to_Bevel SUBROUTINE DSort_Lists (number, a, b, c, d, e) ! Sorts 1 to 5 REAL*8 arrays a, b, c, d, e: each of length "number" !(or longer, but the extra portions will not be touched). ! Array a will be arranged in ascending order, while ! the same swapping operations will be performed on b, c, d, and e ! (if present) regardless of the values of their elements. ! NOTE that this swap-sort algorithm is inefficient for large number. IMPLICIT NONE REAL*8, DIMENSION(:), INTENT(INOUT) :: a REAL*8, DIMENSION(:), INTENT(INOUT), OPTIONAL :: b, c, d, e INTEGER, INTENT(IN) :: number INTEGER :: i, j LOGICAL :: got_b, got_c, got_d, got_e REAL*8 :: t IF (number < 2) RETURN got_b = PRESENT(b) got_c = PRESENT(c) got_d = PRESENT(d) got_e = PRESENT(e) DO i = 1, number-1 DO j = i+1, number IF (a(j) < a(i)) THEN ! swap t = a(i) a(i) = a(j) a(j) = t IF (got_b) THEN t = b(i) b(i) = b(j) b(j) = t END IF IF (got_c) THEN t = c(i) c(i) = c(j) c(j) = t END IF IF (got_d) THEN t = d(i) d(i) = d(j) d(j) = t END IF IF (got_e) THEN t = e(i) e(i) = e(j) e(j) = t END IF END IF END DO END DO END SUBROUTINE DSort_Lists SUBROUTINE DTrace_Boundary(xa,ya, clockwise, xb,yb) ! Traces around the window edge from (xa,ya) to (xb,yb) ! (both in page points, from the lower left of physical page), ! in the "clockwise" (or opposite) direction. ! Assumes that a level 1 path is open, and that it ! will be closed by calling program later. ! Also assumes that (xa,ya) and (xb,yb) are on ! (or approximately on) the window boundary! IMPLICIT NONE REAL*8, INTENT(IN) :: xa, xb, ya, yb LOGICAL, INTENT(IN) :: clockwise INTEGER :: i, initial, final REAL*8, PARAMETER :: tolerance = 1.0D0 REAL*8 :: dx, dy, sense, rx, ry IF ((xa == xb).AND.(ya == yb)) THEN ! no action required ! RETURN ELSE IF ((DABS(xa-xb) < tolerance).AND.(DABS(ya-yb) < tolerance)) THEN ! use a simple direct lineto CALL DLine_To_L12 (xb, yb) ELSE ! normal case; action required ! Determine start and end points, using an integer code ! which goes clockwise: 0 = lower left corner, 1 = left side, ! 2 = upper left corner, 3 = top side, 4 = upper right corner, ! 5 = right side, 6 = lower right corner, 7 = bottom side: ! Initial point (xa,ya): IF (xa <= (ai_window_x1_points + tolerance)) THEN ! left side or corners IF (ya <= (ai_window_y1_points + tolerance)) THEN ! LL initial = 0 ELSE IF (ya >= (ai_window_y2_points - tolerance)) THEN initial = 2 ELSE initial = 1 END IF ELSE IF (xa >= (ai_window_x2_points - tolerance)) THEN ! right side or corners IF (ya <= (ai_window_y1_points + tolerance)) THEN ! LL initial = 6 ELSE IF (ya >= (ai_window_y2_points - tolerance)) THEN initial = 4 ELSE initial = 5 END IF ELSE ! initial is somewhere along top or bottom side IF (ABS(ya - ai_window_y2_points) < & &ABS(ya - ai_window_y1_points)) THEN initial = 3 ELSE initial = 7 END IF END IF ! initial is L, R, or center ! final point (xb,yb) IF (xb <= (ai_window_x1_points + tolerance)) THEN ! left side or corners IF (yb <= (ai_window_y1_points + tolerance)) THEN ! LL final = 0 ELSE IF (yb >= (ai_window_y2_points - tolerance)) THEN final = 2 ELSE final = 1 END IF ELSE IF (xb >= (ai_window_x2_points - tolerance)) THEN ! right side or corners IF (yb <= (ai_window_y1_points + tolerance)) THEN ! LL final = 6 ELSE IF (yb >= (ai_window_y2_points - tolerance)) THEN final = 4 ELSE final = 5 END IF ELSE ! final is somewhere along top or bottom side IF (ABS(yb - ai_window_y2_points) < & &ABS(yb - ai_window_y1_points)) THEN final = 3 ELSE final = 7 END IF END IF ! final is L, R, or center IF (clockwise) THEN IF (initial > final) THEN final = final + 8 ! go through origin and start around again ELSE IF (initial == final) THEN IF (MOD(initial,2) == 1) THEN ! on a side dx = xb - xa dy = yb - ya rx = xa - ai_window_xc_points ry = ya - ai_window_yc_points sense = dx*ry - dy*rx ! + is clockwise IF (sense < 0.0D0) final = final + 8 ! go long way around END IF END IF DO i = initial+1, final-1 SELECT CASE (MOD(i,8)) CASE (0) CALL DLine_To_L12(ai_window_x1_points,ai_window_y1_points) CASE (2) CALL DLine_To_L12(ai_window_x1_points,ai_window_y2_points) CASE (4) CALL DLine_To_L12(ai_window_x2_points,ai_window_y2_points) CASE (6) CALL DLine_To_L12(ai_window_x2_points,ai_window_y1_points) END SELECT END DO ELSE ! counterclockwise IF (initial < final) THEN initial = initial + 8 ! go through origin ELSE IF (initial == final) THEN IF (MOD(initial,2) == 1) THEN ! on a side dx = xb - xa dy = yb - ya rx = xa - ai_window_xc_points ry = ya - ai_window_yc_points sense = dx*ry - dy*rx ! + is clockwise IF (sense > 0.0D0) initial = initial + 8 ! go long way around END IF END IF DO i = initial-1, final+1, -1 SELECT CASE (MOD(i,8)) CASE (0) CALL DLine_To_L12(ai_window_x1_points,ai_window_y1_points) CASE (2) CALL DLine_To_L12(ai_window_x1_points,ai_window_y2_points) CASE (4) CALL DLine_To_L12(ai_window_x2_points,ai_window_y2_points) CASE (6) CALL DLine_To_L12(ai_window_x2_points,ai_window_y1_points) END SELECT END DO END IF ! cw or ccw CALL DLine_To_L12 (xb, yb) END IF ! complex action required END SUBROUTINE DTrace_Boundary SUBROUTINE DTraceback () ! The sole function of this unit is to cause a traceable error, ! so that the route into the unit that called it is also traced. ! This unit is a good place to put a breakpoint while debugging! ! The intentional error must NOT be detected during compilation, ! but MUST cause a traceable error at run-time. ! If this routine has any error detected during compilation, ! then change its code to cause a different intentional error. IMPLICIT NONE CHARACTER*80 instring INTEGER :: i REAL*8, DIMENSION(3) :: y WRITE (*,"(' -----------------------------------------------------')") WRITE (*,"(' Traceback was called to execute an intentional error:')") WRITE (*,"(' An array subscript will be intentionally out-of-range.')") WRITE (*,"(/' After you read this notice, press [Enter]' & & /' to stop the program (no other option): '\)") READ (*,"(A)") instring DO i = 1, 4 y(i) = 1.0D0 * i END DO STOP ' ' END SUBROUTINE DTraceback SUBROUTINE DUpdate_Fill_or_Pattern () ! Set_Fill_or_Pattern already qualified the names, ! and adjusted for some common "patterns" which are really ! "colors"! IMPLICIT NONE INTEGER :: i, j ai_output_new_fill = (ai_next_using_pattern.NEQV.ai_current_using_pattern) .OR. & & (ai_next_fill /= ai_current_fill) .OR. & & (ai_current_fill == "customCMYK") .OR. & & (ai_next_fill == "customCMYK") ! N.B. We PRESUME that each customCMYK is different from the last, because it MIGHT BE. IF (ai_output_new_fill) THEN IF (ai_next_using_pattern) THEN WRITE (ai_out_unit,"('(',A,') 0 0 1 1 0 0 0 0 0 [1 0 0 1 0 0] p')") TRIM(ai_next_fill) ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE IF (ai_next_fill == "customCMYK") THEN IF (ai_K_R8 == 0.0D0) THEN ! Use a slightly more compact command-line: WRITE (ai_out_unit, "(F8.6, 2F9.6, ' 0 k')") ai_C_R8, ai_M_R8, ai_Y_R8 ELSE WRITE (ai_out_unit, "(F8.6, 3F9.6, ' k')") ai_C_R8, ai_M_R8, ai_Y_R8, ai_K_R8 END IF !N.B. A similar command using "K" would set a custom stroke color. ELSE ! new fill color is a pre-defined one: IF (ai_next_fill == 'black_____') THEN WRITE (ai_out_unit,"('0 g')") ! sic; lightness value! ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE IF (ai_next_fill == 'white_____') THEN WRITE (ai_out_unit,"('1 g')") ! sic; lightness value! ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE IF (ai_next_fill == 'foreground') THEN WRITE (ai_out_unit,"(F4.2,3(1X,F4.2),' (foreground) 0 x')") & & (ai_foreground%cmyk(j),j=1,4) ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE IF (ai_next_fill == 'background') THEN WRITE (ai_out_unit,"(F4.2,3(1X,F4.2),' (background) 0 x')") & & (ai_background%cmyk(j),j=1,4) ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE ! look for color in spectrum, including end-brackets ! Since Set_Fill_or_Pattern already qualified the name, it ! really should be there! DO i = 0, ai_spectrum_count + 1 IF (ai_next_fill == ai_spectrum(i)%color_name) THEN WRITE (ai_out_unit,"(F4.2,3(1X,F4.2),' (',A,') 0 x')") & & (ai_spectrum(i)%cmyk(j),j=1,4), & & ai_spectrum(i)%color_name ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. END IF ! found color in spectrum END DO ! searching spectrum END IF ! different ways to define fill color END IF ! is new fill color or pattern? ai_current_using_pattern = ai_next_using_pattern ai_current_fill = ai_next_fill END IF ! switch in fill color or pattern END SUBROUTINE DUpdate_Fill_or_Pattern LOGICAL FUNCTION DValid_Color (color_name) IMPLICIT NONE CHARACTER*10, INTENT(IN) :: color_name LOGICAL valid INTEGER :: i valid = (color_name == 'black_____') .OR. & & (color_name == 'white_____') .OR. & & (color_name == 'foreground') .OR. & & (color_name == 'background') IF (valid) THEN DValid_Color = .TRUE. ELSE DO i = 0, ai_spectrum_count + 1 IF (color_name == ai_spectrum(i)%color_name) THEN DValid_Color = .TRUE. RETURN END IF END DO DValid_Color = .FALSE. END IF END FUNCTION DValid_Color SUBROUTINE DWrite_L1_Paths () ! This is the ONLY route for a path to get to the output .AI file! ! Normally this will be called when there is only 1 path at ! Level 1 in ai_pathlib; however, because clipping sometimes ! leads to path segmentation, this routine is written to clear ! ALL Level 1 paths. (The order of writing is undefined, but ! this doesn't matter, since pieces split from one path all ! share the same group/color/fill/linewidth/dashing.) ! Note that line style, line color, and fill color/pattern are ! only written to the output file when absolutely necessary. ! Also, "pen moves" which would not change position (at the ! current precision level of the output) are suppressed. IMPLICIT NONE CHARACTER*6 :: x0_str, x1_str, x2_str, x3_str, & & y0_str, y1_str, y2_str, y3_str INTEGER :: i, j, path DO WHILE (ai_Ln_paths(1) > 0) path = DNext_Path(level = 1) ! If necessary, reset stroke and fill colors, pen weight, etc. IF (ai_stroked(path)) THEN IF (ai_next_line_width_points /= ai_current_line_width_points) THEN IF (ai_next_line_width_points >= 9.9) THEN ! wide line (up to 99.9 points); use F4.1 WRITE (ai_out_unit,"(F4.1,' w')") ai_next_line_width_points ELSE ! fine line; use F4.2 WRITE (ai_out_unit,"(F4.2,' w')") ai_next_line_width_points END IF ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ai_current_line_width_points = ai_next_line_width_points END IF ! need to change line width IF (ai_next_line_dashed.NEQV.ai_current_line_dashed) THEN IF (ai_next_line_dashed) THEN WRITE (ai_out_unit, "('[',F4.1,3(1X,F4.1),']0 d')") & & ai_next_line_on_points, ai_next_line_off_points, & & ai_next_line_on_points, ai_next_line_off_points ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ai_current_line_on_points = ai_next_line_on_points ai_current_line_off_points = ai_next_line_off_points ELSE ! turning off dashes WRITE (ai_out_unit, "('[]0 d')") ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. END IF ai_current_line_dashed = ai_next_line_dashed ELSE IF (ai_current_line_dashed) THEN ! still need to check whether dash length has changed IF ((ai_next_line_on_points /= ai_current_line_on_points).OR. & &(ai_next_line_off_points /= ai_current_line_off_points)) THEN WRITE (ai_out_unit, "('[',F4.1,3(1X,F4.1),']0 d')") & & ai_next_line_on_points, ai_next_line_off_points, & & ai_next_line_on_points, ai_next_line_off_points ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ai_current_line_on_points = ai_next_line_on_points ai_current_line_off_points = ai_next_line_off_points END IF ! dash length has changed END IF ! need to adjust dashing IF (ai_next_line_color /= ai_current_line_color) THEN IF (ai_next_line_color == 'black_____') THEN WRITE (ai_out_unit,"('0 G')") ! sic; lightness value! ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE IF (ai_next_line_color == 'white_____') THEN WRITE (ai_out_unit,"('1 G')") ! sic; lightness value! ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE IF (ai_next_line_color == 'foreground') THEN WRITE (ai_out_unit,"(F4.2,3(1X,F4.2),' (foreground) 0 X')") & & (ai_foreground%cmyk(j),j=1,4) ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE IF (ai_next_line_color == 'background') THEN WRITE (ai_out_unit,"(F4.2,3(1X,F4.2),' (background) 0 X')") & & (ai_background%cmyk(j),j=1,4) ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE ! look for color in spectrum, including end-brackets ! Since Set_Stroke_Color already qualified the name, it ! really should be there! DO i = 0, ai_spectrum_count + 1 IF (ai_next_line_color == ai_spectrum(i)%color_name) THEN WRITE (ai_out_unit,"(F4.2,3(1X,F4.2),' (',A,') 0 X')") & & (ai_spectrum(i)%cmyk(j),j=1,4), & & ai_spectrum(i)%color_name ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. END IF ! found color in spectrum END DO ! searching spectrum END IF ! different ways to define stroke color ai_current_line_color = ai_next_line_color END IF ! need to reset line color END IF ! path is stroked IF (ai_filled(path)) THEN CALL DUpdate_Fill_or_Pattern END IF ! path is filled !Finished with preliminary adjustments to color, fill, width, ... ! Actually write the path! !(But eliminate segments that don't really move!) !(Also, check for numerical overflows, seen as '****') WRITE (x0_str,"(F6.1)") ai_pathlib(1,0,path) IF (SCAN(x0_str,'*') /= 0) GOTO 900 WRITE (y0_str,"(F6.1)") ai_pathlib(2,0,path) IF (SCAN(y0_str,'*') /= 0) GOTO 900 WRITE (ai_out_unit,"(F6.1,1X,F6.1,' m')") & & ai_pathlib(1,0,path), ai_pathlib(2,0,path) ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. DO i = 1, ai_segments(path) IF (ai_bent(i,path)) THEN WRITE (x1_str,"(F6.1)") ai_pathlib(1,i,path) IF (SCAN(x1_str,'*') /= 0) GOTO 900 WRITE (y1_str,"(F6.1)") ai_pathlib(2,i,path) IF (SCAN(y1_str,'*') /= 0) GOTO 900 WRITE (x2_str,"(F6.1)") ai_pathlib(3,i,path) IF (SCAN(x2_str,'*') /= 0) GOTO 900 WRITE (y2_str,"(F6.1)") ai_pathlib(4,i,path) IF (SCAN(y2_str,'*') /= 0) GOTO 900 WRITE (x3_str,"(F6.1)") ai_pathlib(5,i,path) IF (SCAN(x3_str,'*') /= 0) GOTO 900 WRITE (y3_str,"(F6.1)") ai_pathlib(6,i,path) IF (SCAN(y3_str,'*') /= 0) GOTO 900 IF ((x3_str /= x0_str).OR.(y3_str /= y0_str).OR. & &(x2_str /= x0_str).OR.(y2_str /= y0_str).OR. & &(x1_str /= x0_str).OR.(y1_str /= y0_str)) THEN WRITE (ai_out_unit,"(F6.1,5(1X,F6.1),' c')") & & ai_pathlib(1,i,path), ai_pathlib(2,i,path), & & ai_pathlib(3,i,path), ai_pathlib(4,i,path), & & ai_pathlib(5,i,path), ai_pathlib(6,i,path) ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. x0_str = x3_str ! memory, for next loop y0_str = y3_str END IF ELSE ! lineto WRITE (x1_str,"(F6.1)") ai_pathlib(1,i,path) IF (SCAN(x1_str,'*') /= 0) GOTO 900 WRITE (y1_str,"(F6.1)") ai_pathlib(2,i,path) IF (SCAN(y1_str,'*') /= 0) GOTO 900 IF ((x1_str /= x0_str).OR.(y1_str /= y0_str)) THEN WRITE (ai_out_unit,"(F6.1,1X,F6.1,' l')") & & ai_pathlib(1,i,path), ai_pathlib(2,i,path) ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. x0_str = x1_str ! memory, for next loop y0_str = y1_str END IF END IF ! curveto or lineto END DO ! Terminate the path properly; we can assume at least one of ! ai_stroked and ai_filled are true, because End_L1_Path checked. IF (ai_closed(path)) THEN IF (ai_stroked(path).AND.ai_filled(path)) THEN ! close, stroke, fill WRITE (ai_out_unit,"('b')") ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE IF (ai_stroked(path)) THEN ! close, stroke only WRITE (ai_out_unit,"('s')") ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE IF (ai_filled(path)) THEN ! close, fill only WRITE (ai_out_unit,"('f')") ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. END IF ! whether closed path is stroked and/or filled ELSE ! end without closing IF (ai_stroked(path).AND.ai_filled(path)) THEN ! stroke, fill WRITE (ai_out_unit,"('B')") ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE IF (ai_stroked(path)) THEN ! stroke only WRITE (ai_out_unit,"('S')") ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. ELSE IF (ai_filled(path)) THEN ! fill only WRITE (ai_out_unit,"('F')") ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. END IF ! whether open path is stroked and/or filled END IF ! closed or not closed ! Eliminate the path from ai_pathlib and associated variables ai_path_level(path) = 0 ! marks that it is empty and available ai_Ln_paths(1) = ai_Ln_paths(1) - 1 ai_total_paths = ai_total_paths - 1 END DO ! on all paths waiting RETURN ! This section deals with too-large numbers: 900 WRITE(*,"(' ERROR: x or y too large for format in DWrite_L1_Paths.')") CALL DTraceback END SUBROUTINE DWrite_L1_Paths SUBROUTINE DWrite_L1_Text (x_points, y_points, angle_radians, & & font_points, lr_fraction, ud_fraction, & & text) IMPLICIT NONE INTEGER, INTENT(IN) :: font_points REAL*8, INTENT(IN) :: x_points, y_points, angle_radians, & & lr_fraction, ud_fraction CHARACTER*(*),INTENT(IN) :: text INTEGER, PARAMETER :: limit = 200 CHARACTER*limit safe_text INTEGER :: bytes, i, ialign, j, last_byte REAL*8 :: ai_x_points, ai_y_points, cos_a, length, rf, rfl, rfc, rfr, sin_a bytes = LEN_TRIM(text) IF (bytes == 0) RETURN IF (bytes > limit) THEN WRITE (*,"(' ERROR: Increase limit in Write_L1_Text.')") CALL DTraceback END IF ! Adobe Illustrator will fail to open the file !(and will give a very confusing error message) ! if the text string includes unpaired "(" or ")". ! Therefore, convert "(" to "\(" and ")" to "\)". ! Another source of problems is a single "\" in text, which ! AI assumes to be an escape character, and combines with the ! next character. So, "\" must be converted to "\\". ! However, we NEED an unmodified "\260" to represent the degree mark! safe_text = TRIM(text) i = 0 last_byte = bytes 10 i = i + 1 IF ((safe_text(i:i) == '(').OR. & & (safe_text(i:i) == ')').OR. & & ((safe_text(i:i) == '\').AND.(safe_text(i+1:i+3) /= '260'))) THEN !must right-shift (i:limit) part of string, R to L IF(safe_text(limit:limit) /= ' ') THEN WRITE (*,"(' ERROR: Increase limit in Write_L1_Text.')") CALL DTraceback END IF DO j = limit, i+1, -1 safe_text(j:j) = safe_text(j-1:j-1) END DO safe_text(i:i) = '\' i = i + 1 ! to prevent re-discovering same (, ), or \ last_byte = last_byte + 1 END IF IF (i < last_byte) GO TO 10 bytes = LEN_TRIM(safe_text) cos_a = DCOS(angle_radians) sin_a = DSIN(angle_radians) ! Fiducial point used in .AI file is at baseline and either ! left-end, center, or right-end. Therefore, AI fiducial point ! may have to be adjusted from my fiducial point. ! LEFT-RIGHT ALIGNMENT rfl = lr_fraction - 0.0D0 rfc = lr_fraction - 0.5D0 rfr = lr_fraction - 1.0D0 IF ((DABS(rfl) < DABS(rfc)).AND.(DABS(rfl) < DABS(rfr))) THEN ! left-alignment is the best approximation ialign = 0 rf = rfl ELSE IF ((DABS(rfc) < DABS(rfl)).AND.(DABS(rfc) < DABS(rfr))) THEN ! center-alignment is the best approximation ialign = 1 rf = rfc ELSE ! right-alignment is the best approximation ialign = 2 rf = rfr END IF IF (DABS(rf) > 0.01) THEN length = 0.6D0 * bytes * font_points ! estimated length of text string, in points ai_x_points = x_points - rf * length * cos_a ai_y_points = y_points - rf * length * sin_a ELSE ai_x_points = x_points ai_y_points = y_points END IF ! VERTICAL ALIGNMENT IF (DABS(ud_fraction) > 0.01D0) THEN ai_x_points = ai_x_points + ud_fraction * font_points * sin_a ai_y_points = ai_y_points - ud_fraction * font_points * cos_a END IF ! CHECK WHETHER FILL COLOR/PATTERN NEEDS TO BE UPDATED: CALL DUpdate_Fill_or_Pattern WRITE (ai_out_unit,"('0 To'/4F7.3,2F8.1,' 0 Tp'/'TP')") & & cos_a, sin_a, -sin_a, cos_a, ai_x_points, ai_y_points WRITE (ai_out_unit,"(I1,' Ta'/'0 Tr'/'0 O')") ialign WRITE (ai_out_unit,"('/_Helvetica ',I4,' Tf'/'(',A,') Tx'/'(\r) TX'/'TO')") & & font_points, safe_text(1:bytes) ai_last_line_was_u = .FALSE. ai_last_line_was_star_u = .FALSE. END SUBROUTINE DWrite_L1_Text SUBROUTINE DX_Marks(xa0,ya0, xa1,ya1, & & xb0,yb0, xb1,yb1, & ! input & crossings, xm1,ym1, xm2,ym2, f_a_1, f_a_2, f_b_1, f_b_2) ! output ! Find any point(s) of intersection between the ! finite-length line segment (xa0,ya0)---(xa1,ya1) and the ! finite-length line segment (xb0,yb0)---(xb1,yb1). ! The number ("crossings") is usually 0 for none, or ! 1 for a single intersection at (xm1,ym1). ! However, if the two segments overlap, then the ! common segment is reported as (xm1,ym1)--(xm2,ym2), ! and "crossings" = 2. ! Intersection measure f_a is the dimensionless coordinate along line a, ! = 0.D0 at (xa0,ya0) and = 1.D0 at (xa1,ya1). ! Intersection measure f_b is the dimensionless coordinate along line b, ! = 0.D0 at (xb0,yb0) and = 1.D0 at (xb1,yb1). ! Values outside the range [0.D0, 1.D0] are reported even if crossings = 0 IMPLICIT NONE REAL*8, INTENT(IN) :: xa0,ya0, xa1,ya1, & & xb0,yb0, xb1,yb1 INTEGER, INTENT(OUT) :: crossings REAL*8, INTENT(OUT) :: f_a_1, f_a_2, f_b_1, f_b_2, xm1,ym1, xm2,ym2 LOGICAL :: parallel, same_line REAL*8, PARAMETER :: Pi_over_2 = 1.5707963267948965D0 REAL*8, PARAMETER :: tolerance = 1.0D-4 ! difference in radians allowed for "//" lines REAL*8 :: alpha_a0, alpha_a1, alpha_a_max, alpha_a_min, & & alpha_b0, alpha_b1, alpha_b_max, alpha_b_min, & & alpha_left, alpha_right, angle_a, angle_b, & & beta_a, beta_b, determinant, r2a0b1, r2a1b0, t REAL*8, DIMENSION(2) :: alpha, beta, rhs REAL*8, DIMENSION(2,2) :: matrix, inverse ! Reject problem if (xa0,ya0) == (xa1,ya1): IF ((xa0 == xa1).AND.(ya0 == ya1)) THEN !Originally I wrote: !WRITE (*,"(' ERROR: Line a has zero length.')") !CALL DTraceback !but I later decided that this is too drastic. !After all, a small feature in a map of small scale can !involve zero-length line segments due to rounding error. !Let these pass; if there is a crossing, find it on the !next (or previous) segment which has finite length. crossings = 0 RETURN END IF ! Reject problem if (xb0,yb0) == (xb1,yb1): IF ((xb0 == xb1).AND.(yb0 == yb1)) THEN !WRITE (*,"(' ERROR: Line b has zero length.')") !CALL DTraceback crossings = 0 RETURN END IF ! Check slopes of lines: IF (xa0 == xa1) THEN angle_a = Pi_over_2 ELSE angle_a = DATAN((ya1-ya0)/(xa1-xa0)) END IF IF (xb0 == xb1) THEN angle_b = Pi_over_2 ELSE angle_b = DATAN((yb1-yb0)/(xb1-xb0)) END IF IF (DABS(angle_a - angle_b) <= tolerance) THEN parallel = .TRUE. ELSE ! last chance; check for +Pi/2 and -Pi/2 parallel = ((DABS(DCOS(angle_a)) <= tolerance).AND. & &(DABS(DCOS(angle_b)) <= tolerance)) END IF IF (parallel) THEN ! alpha is a unit vector along the line alpha(1) = DCOS(angle_a) alpha(2) = DSIN(angle_a) ! beta is 90 degrees counterclockwise from alpha beta(1) = -alpha(2) beta(2) = alpha(1) ! find beta-coordinates of the 2 segments beta_a = beta(1)*xa0 + beta(2)*ya0 beta_b = beta(1)*xb0 + beta(2)*yb0 same_line = (beta_a == beta_b) IF (same_line) THEN alpha_a0 = alpha(1)*xa0 + alpha(2)*ya0 alpha_a1 = alpha(1)*xa1 + alpha(2)*ya1 IF (alpha_a0 > alpha_a1) THEN alpha_a_max = alpha_a0 alpha_a_min = alpha_a1 ELSE alpha_a_max = alpha_a1 alpha_a_min = alpha_a0 END IF alpha_b0 = alpha(1)*xb0 + alpha(2)*yb0 alpha_b1 = alpha(1)*xb1 + alpha(2)*yb1 IF (alpha_b0 > alpha_b1) THEN alpha_b_max = alpha_b0 alpha_b_min = alpha_b1 ELSE alpha_b_max = alpha_b1 alpha_b_min = alpha_b0 END IF alpha_left = MAX(alpha_a_min,alpha_b_min) alpha_right = MIN(alpha_a_max,alpha_b_max) IF ((alpha_right - alpha_left) > 0.) THEN ! there is an overlap region crossings = 2 xm1 = alpha_left*alpha(1) + beta_a*beta(1) ym1 = alpha_left*alpha(2) + beta_a*beta(2) xm2 = alpha_right*alpha(1) + beta_a*beta(1) ym2 = alpha_right*alpha(2) + beta_a*beta(2) f_a_1 = (alpha_left - alpha_a0) / (alpha_a1 - alpha_a0) f_b_1 = (alpha_left - alpha_b0) / (alpha_b1 - alpha_b0) f_a_2 = (alpha_right - alpha_a0) / (alpha_a1 - alpha_a0) f_b_2 = (alpha_right - alpha_b0) / (alpha_b1 - alpha_b0) ELSE IF (alpha_left == alpha_right) THEN ! segments just touch at their ends crossings = 1 xm1 = alpha_left*alpha(1) + beta_a*beta(1) ym1 = alpha_left*alpha(2) + beta_a*beta(2) xm2 = 0.D0 ym2 = 0.D0 r2a0b1 = (xa0-xb1)**2 + (ya0-yb1)**2 r2a1b0 = (xa1-xb0)**2 + (ya1-yb0)**2 IF (r2a0b1 < r2a1b0) THEN f_a_1 = 0.D0 f_b_1 = 1.D0 ELSE f_a_1 = 1.D0 f_b_1 = 0.D0 END IF f_a_2 = 0.D0 f_b_2 = 0.D0 ELSE ! no intersection crossings = 0 f_a_1 = 0.D0 f_b_1 = 0.D0 f_a_2 = 0.D0 f_b_2 = 0.D0 xm1 = 0.D0 ym1 = 0.D0 xm2 = 0.D0 ym2 = 0.D0 END IF ELSE ! not same line crossings = 0 f_a_1 = 0.D0 f_b_1 = 0.D0 f_a_2 = 0.D0 f_b_2 = 0.D0 xm1 = 0.D0 ym1 = 0.D0 xm2 = 0.D0 ym2 = 0.D0 END IF ELSE ! lines extended from segments intersect; where? ! Set up 2 x 2 linear system. ! The two unknowns are f_a (the fractional position ! from (xa0,ya0) toward (xa1,ya1) on line a, dimensionless, ! and f_b (the same measure, along segment b). ! The first equation is that the x's are equal. ! The second equation is that the y's are equal. matrix(1,1) = xa1 - xa0 matrix(1,2) = xb0 - xb1 matrix(2,1) = ya1 - ya0 matrix(2,2) = yb0 - yb1 rhs(1) = xb0 - xa0 rhs(2) = yb0 - ya0 determinant = matrix(1,1)*matrix(2,2) - matrix(2,1)*matrix(1,2) ! (we already know that this is not zero, or tiny) t = 1.0D0 / determinant inverse(1,1) = t * matrix(2,2) inverse(1,2) = -t * matrix(1,2) inverse(2,1) = -t * matrix(2,1) inverse(2,2) = t * matrix(1,1) f_a_1 = inverse(1,1)*rhs(1) + inverse(1,2)*rhs(2) f_b_1 = inverse(2,1)*rhs(1) + inverse(2,2)*rhs(2) IF ((f_a_1 >= 0.D0).AND.(f_a_1 <= 1.D0)) THEN ! intersection is within segment a IF ((f_b_1 >= 0.D0).AND.(f_b_1 <= 1.D0)) THEN ! intersection is within segment b crossings = 1 xm1 = xa0 + f_a_1 * (xa1 - xa0) ym1 = ya0 + f_a_1 * (ya1 - ya0) ELSE crossings = 0 END IF ELSE crossings = 0 END IF f_a_2 = 0.D0 f_b_2 = 0.D0 ENDIF ! lines containing segments cross somewhere END SUBROUTINE DX_Marks END MODULE DAdobe_Illustrator !===============================================