MODULE Map_Tools !========================================================= ! Component parts of typical maps, such as graticule (lon/lat) ! grids and x/y grids, frames with km or lon/lat in degrees, ! digitised basemaps, vectors, strain(-rate) tensors, ! (integrated) stress tensors, and contour maps of scalars on ! either the sphere or the plane, plus color-bar (or pattern-bar) ! and other sample Explanation items for the margin. ! These may be layered and arranged as desired by the user, ! who provides the calling sequence in the main program. ! That is, most routines plot a single symbol, or contour ! a single element. The user's calling program will typically ! CALL these inside a DO loop, and bracket the loop with CALLs ! to Begin_Group and End_Group, as desired. (Exceptions: ! Plot_Dig plots the entire .dig file in one call. Also, the ! contouring routines can be called in one of 3 modes: ! group = 0: plots both colored/shaded areas and contours; ! group = 1: plots only colored/shaded areas; ! group = 2: plots only contour lines. ! This is to permit the calling program to create a graphic ! group with nothing but contour lines, if desired. However, ! the cost of this is about twice as much computation.) ! Another general principle is that most of these routines do ! not change the current line-width, line-color, dashing(?), ! or fill color/pattern, so these should be set before calling. ! An exception is made in routines that contour a scalar inside ! an element: these must frequently change fill color/pattern ! and contour-line color. However, contour-line weight and ! continuity are assumed to be set previously, and externally. ! If this module is to be used in an interactive application, ! then an excellent way to begin is to CALL Prompter, ! which uses a simple text-mode interface to prompt the ! real-time user for the parameters needed by the Adobe_ ! Illustrator and Map_Projections modules, such as paper size, ! margins, use of color, type of map, scale, center point, etc. ! This routine also "remembers" the most recent past choices ! by writing a simple Map_Tools.ini file in the current directory. ! ! by Peter Bird, UCLA, January 1999 to May 2009. ! copyright (c) 1997, 1998, 1999, 2001, 2009 by ! Peter Bird and the Regents of the University of California. ! USE Adobe_Illustrator ! provided as Adobe_Illustrator.f90 USE Map_Projections ! provided as Map_Projections.f90 ! USE DFLIB, ARCQQ => ARC ! provided with Digital Visual Fortran: ! ! Using GETFILEINFOQQ, which provides names of files ! ! matching spec.s like "*.grd". Helps user select correct file. ! ! If no substitute is available on your system when you compile, ! ! just omit SUBROUTINE Grd_List (and any CALLs to it). ! ! However, not using ARC, because I have my own Arc; so I am ! ! renaming their ARC to ARCQQ to avoid conflicts. ! !---------------------------------------------- ! !CONTENTS ! Following are the ROUTINES CALLED BY THE USER: ! SUBROUTINE Bar_in_BottomLegend ! SUBROUTINE Bar_in_RightLegend ! SUBROUTINE Bumpy_Bitmap ! SUBROUTINE Check_for_TABs ! SUBROUTINE Contour_3Node_Scalar_in_Plane ! SUBROUTINE Contour_3Node_Scalar_on_Sphere ! SUBROUTINE Contour_3Node_Sphere_Velocity ! SUBROUTINE Contour_6Node_Scalar_in_Plane ! SUBROUTINE DipTick_in_Plane ! SUBROUTINE DipTick_on_Sphere ! SUBROUTINE Graticule ! SUBROUTINE Grd_List ! SUBROUTINE GreatCircle_Point ! SUBROUTINE Group_or_Bitmap ! SUBROUTINE Kilometer_Frame ! SUBROUTINE LonLat_Frame ! SUBROUTINE Plot_Dig ! SUBROUTINE Press_Enter ! SUBROUTINE Prompter ! CHARACTER*3 FUNCTION RGB_Kansas ! CHARACTER*3 FUNCTION RGB_Munsell ! CHARACTER*3 FUNCTION RGB_UNAVCO ! SUBROUTINE Report_BottomLegend_Frame ! SUBROUTINE Report_RightLegend_Frame ! SUBROUTINE Set_Fill_by_Value ! SUBROUTINE Set_Stroke_by_Value ! SUBROUTINE Spectrum_in_BottomLegend ! SUBROUTINE Spectrum_in_RightLegend ! SUBROUTINE Strain_in_Plane ! SUBROUTINE Strain_on_Sphere ! SUBROUTINE Stress_in_Plane ! SUBROUTINE Stress_on_Sphere ! SUBROUTINE Thin_on_Sphere ! SUBROUTINE ThreeNodeCurve_Point ! SUBROUTINE ThreeNodeCurve_2_Bezier ! SUBROUTINE Top_Titles ! SUBROUTINE Vector_in_Plane ! SUBROUTINE Vector_on_Sphere ! SUBROUTINE Velocity_Size_in_3Node_Sphere ! SUBROUTINE Velocity_Vector_on_Sphere ! SUBROUTINE Which_Spherical_Triangle ! SUBROUTINE Wire_Mesh ! ! Following are UTILITY SUBROUTINES AND FUNCTIONS (called internally): ! CHARACTER FUNCTION ASCII8 (2 significant digits; <= 8 bytes) ! CHARACTER FUNCTION ASCII9 (3 significant digits; <= 9 bytes) ! CHARACTER FUNCTION ASCII10 (4 significant digits; <= 10 bytes) ! SUBROUTINE Curve_Through_3Nodes_in_Plane ! SUBROUTINE Del_Gjxy_del_thetaphi ! SUBROUTINE DoLine ! SUBROUTINE DoPart ! SUBROUTINE DoSide ! SUBROUTINE Dumb_s123 ! SUBROUTINE Gjxy ! SUBROUTINE In_Element ! INTEGER FUNCTION Int_Above ! INTEGER FUNCTION Int_Below ! REAL FUNCTION Plane_Area_Radian2s ! SUBROUTINE Plane_2_Sphere ! SUBROUTINE Principal_Axes_22 ! SUBROUTINE Prompt_for_Integer ! SUBROUTINE Prompt_for_Logical ! SUBROUTINE Prompt_for_Real ! SUBROUTINE Prompt_for_String ! SUBROUTINE Pull_in ! REAL FUNCTION Round ! SUBROUTINE Set_Sphere_2_Plane ! SUBROUTINE Sphere_2_Plane ! SUBROUTINE Upper_Case ! SUBROUTINE Value_On_3Node_Side !--------------------------------------------------------- IMPLICIT NONE LOGICAL :: mt_flashby = .FALSE. ! take default answer to all ! subsequent questions; don't wait ! for user to respond. !(This is set .TRUE. by answering ! "'" to any question.) LOGICAL :: mt_shingled_brightness = .FALSE. ! option is useful when quantity ! in a Bumpy_Bitmap has range from ! 0 to 10~100, as when velocity magnitudes ! in mm/a are displayed. This module-level ! variable passes the choice from Bumpy_Bitmap ! to Spectrum_in_BottomLegend or Spectrum_in_RightLegend. INTEGER :: mt_flashby_count = 0, mt_flashby_limit = 100 ! to quash inf.-loop REAL :: mt_meters_per_user = 1. ! number of meters per per ! unit in user's (x,y) .dig files; e.g., 1000. if user's ! .dig files are in kilometers. CONTAINS SUBROUTINE Bar_in_BottomLegend (low_value, high_value, & & contour_interval, & & midspectrum_value, low_is_blue, & & units) ! Places a color-bar (or, for b/w plots, a pattern-bar) ! in the bottom legend area to identify the shading ! of countour plots. ! Note that all spatial variables in this routine are in ! level-1 points. ! The units string can be cancelled (if not wanted) by setting ! units = ' ' ! (regardless of the declared length of units). IMPLICIT NONE REAL, INTENT(IN) :: low_value, high_value, & & contour_interval, & & midspectrum_value LOGICAL, INTENT(IN) :: low_is_blue CHARACTER*(*), INTENT(IN) :: units CHARACTER*9 :: string9a, string9b CHARACTER*10 :: string10a, string10b INTEGER :: bytes_wide, i, i1, i2, units_bytes LOGICAL :: label_all, need_ASCII10 REAL, PARAMETER :: aspect = 0.5 ! typical character width/nominal height REAL :: bar_height, bar_length, limit1, limit2, limit3, scale, & & v_left, v_right, v_center, v_line, & & x_left, x_right, x_line, & & x1_bar, x2_bar, y1_bar, y2_bar, & & x1_frame, x2_frame, y1_frame, y2_frame units_bytes = LEN_TRIM(units) IF (.NOT.ai_bottomlegend_reserved) THEN WRITE (*,"(' ERROR: No space reserved (in Begin_Page) for bottom legend.')") CALL Traceback END IF IF (contour_interval <= 0.) THEN WRITE (*,"(' ERROR: Non-positive contour interval in Bar_in_BottomLegend.')") CALL Traceback END IF ! check adequacy of space CALL Report_BottomLegend_Frame (x1_frame, x2_frame, y1_frame, y2_frame) IF ((y2_frame - y1_frame) < (2. * ai_lonlatlabel_points + 7.)) THEN WRITE (*,"(' ERROR: ',F6.0,' < y < ',F6.0,' points is too tight for Bar_in_BottomLegend.')") y1_frame, y2_frame CALL Traceback END IF IF ((x2_frame - x1_frame) < ((19 + units_bytes) * ai_lonlatlabel_points * aspect + 7.)) THEN WRITE (*,"(' ERROR: ',F6.0,' < x < ',F6.0,' points is too tight for Bar_in_BottomLegend.')") x1_frame, x2_frame CALL Traceback END IF ! decide length and x-placement of bar limit1 = 16. * 72. ! regardless of paper size limit2 = 10 * ai_lonlatlabel_points * aspect * (high_value - low_value) / contour_interval limit3 = (x2_frame - x1_frame) - (19 + units_bytes) * ai_lonlatlabel_points * aspect bar_length = MIN(limit1, limit2, limit3) IF (bar_length == limit3) THEN ! shift to left to allow for units x1_bar = 0.5 *(x1_frame + x2_frame) - 0.5 * bar_length - & & 0.5 * (units_bytes + 1) * ai_lonlatlabel_points * aspect ELSE ! center in frame x1_bar = 0.5 *(x1_frame + x2_frame) - 0.5 * bar_length END IF x2_bar = x1_bar + bar_length ! Find integer limits on countour lines: i1 = 1 + Int_Below(low_value/contour_interval) i2 = Int_Below(high_value/contour_interval) ! Decide whether 4 significant digits (ASCII10) are needed to keep values distinct: need_ASCII10 = .FALSE. ! unless it becomes .TRUE. in loop below: IF (i2 > i1) THEN DO i = i1+1, i2 string9a = ASCII9((i-1) * contour_interval) string9b = ASCII9( i * contour_interval) IF (string9a == string9b) need_ASCII10 = .TRUE. END DO END IF ! decide if all numbers can be written in, or just end-values IF (need_ASCII10) THEN IF (i2 >= i1) THEN ! normal case string10a = ASCII10(i1 * contour_interval) string10b = ASCII10(i2 * contour_interval) ELSE ! no contours string10a = ASCII10(low_value) string10b = ASCII10(high_value) END IF string10a = ADJUSTL(string10a) string10b = ADJUSTL(string10b) bytes_wide = 1 + MAX(LEN_TRIM(string10a), LEN_TRIM(string10b)) ELSE ! ASCII9 (3 sig fig) will do IF (i2 >= i1) THEN ! normal case string9a = ASCII9(i1 * contour_interval) string9b = ASCII9(i2 * contour_interval) ELSE ! no contours string9a = ASCII9(low_value) string9b = ASCII9(high_value) END IF string9a = ADJUSTL(string9a) string9b = ADJUSTL(string9b) bytes_wide = 1 + MAX(LEN_TRIM(string9a), LEN_TRIM(string9b)) END IF ! ASCII10 (4 sig fig) or ASCII9 (3 sig fig) IF (high_value /= low_value) THEN label_all = (bytes_wide * ai_lonlatlabel_points * aspect) <= & & (bar_length * contour_interval / (high_value - low_value)) ELSE label_all = .TRUE. END IF ! decide height and y-placement of bar limit1 = 28. ! 1 centimeter IF (label_all) THEN limit2 = (y2_frame - y1_frame) - ai_lonlatlabel_points ELSE limit2 = (y2_frame - y1_frame) - 2. * ai_lonlatlabel_points END IF bar_height = MIN(limit1, limit2) IF (label_all) THEN y1_bar = y1_frame + ai_lonlatlabel_points ELSE y1_bar = y1_frame + 2. * ai_lonlatlabel_points END IF y2_bar = y1_bar + bar_height ! Set horizontal scaling (points / data units) scale = bar_length / MAX((high_value - low_value), 1.E-30) ! Graphics CALL Begin_Group ! whole legend CALL Begin_Group ! colored/patterned blocks ! partial block on left? v_left = low_value v_right = MIN(i1 * contour_interval, high_value) IF (v_left < v_right) THEN v_center = 0.5 * (v_left + v_right) CALL Set_Fill_by_Value (v_center, contour_interval, & & midspectrum_value, low_is_blue) x_left = x1_bar x_right = x1_bar + scale * (v_right - low_value) CALL New_L12_Path (1, x_left, y1_bar) CALL Line_to_L12 (x_right, y1_bar) CALL Line_to_L12 (x_right, y2_bar) CALL Line_to_L12 (x_left, y2_bar) CALL Line_to_L12 (x_left, y1_bar) CALL End_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! many complete blocks DO i = i1, (i2-1) v_left = i * contour_interval v_right = v_left + contour_interval v_center = 0.5 * (v_left + v_right) CALL Set_Fill_by_Value (v_center, contour_interval, & & midspectrum_value, low_is_blue) x_left = x1_bar + scale * (v_left - low_value) x_right = x1_bar + scale * (v_right - low_value) CALL New_L12_Path (1, x_left, y1_bar) CALL Line_to_L12 (x_right, y1_bar) CALL Line_to_L12 (x_right, y2_bar) CALL Line_to_L12 (x_left, y2_bar) CALL Line_to_L12 (x_left, y1_bar) CALL End_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END DO ! partial block on right? v_left = i2 * contour_interval v_right = high_value IF (v_left < v_right) THEN v_center = 0.5 * (v_left + v_right) CALL Set_Fill_by_Value (v_center, contour_interval, & & midspectrum_value, low_is_blue) x_left = x1_bar + scale * (v_left - low_value) x_right = x2_bar CALL New_L12_Path (1, x_left, y1_bar) CALL Line_to_L12 (x_right, y1_bar) CALL Line_to_L12 (x_right, y2_bar) CALL Line_to_L12 (x_left, y2_bar) CALL Line_to_L12 (x_left, y1_bar) CALL End_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF CALL End_Group ! colored/patterned blocks CALL Begin_Group ! contour lines CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) DO i = i1, i2 v_line = i * contour_interval CALL Set_Stroke_by_Value (v_line, contour_interval, & & midspectrum_value, low_is_blue) x_line = x1_bar + scale * (v_line - low_value) CALL New_L12_Path (1, x_line, y2_bar) CALL Line_to_L12 (x_line, y1_bar) CALL End_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO CALL End_Group ! contour lines ! box around color/pattern bar: CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL New_L12_Path (1, x1_bar, y1_bar) CALL Line_to_L12 (x2_bar, y1_bar) CALL Line_to_L12 (x2_bar, y2_bar) CALL Line_to_L12 (x1_bar, y2_bar) CALL Line_to_L12 (x1_bar, y1_bar) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) CALL Begin_Group ! number labels CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! always label low_value IF (need_ASCII10) THEN string10a = ASCII10(low_value) string10a = ADJUSTL(string10a) CALL L12_Text (level = 1, x_points = x1_bar, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 1.0, & & text = TRIM(string10a)) ELSE string9a = ASCII9(low_value) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x1_bar, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 1.0, & & text = TRIM(string9a)) END IF ! always label high_value, adding units IF (need_ASCII10) THEN string10a = ASCII10(high_value) string10a = ADJUSTL(string10a) bytes_wide = LEN_TRIM(string10a) CALL L12_Text (level = 1, x_points = x2_bar, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.0, ud_fraction = 1.0, & & text = string10a(1:bytes_wide)//' '//units(1:units_bytes)) ELSE string9a = ASCII9(high_value) string9a = ADJUSTL(string9a) bytes_wide = LEN_TRIM(string9a) CALL L12_Text (level = 1, x_points = x2_bar, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.0, ud_fraction = 1.0, & & text = string9a(1:bytes_wide)//' '//units(1:units_bytes)) END IF ! routine contour labelling IF (label_all) THEN DO i = i1, i2 v_line = i * contour_interval IF (v_line /= high_value) THEN x_line = x1_bar + scale * (v_line - low_value) IF (need_ASCII10) THEN string10a = ASCII10(v_line) string10a = ADJUSTL(string10a) CALL L12_Text (level = 1, x_points = x_line, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(string10a)) ELSE string9a = ASCII9(v_line) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x_line, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(string9a)) END IF END IF END DO ELSE ! label only one contour; add c.i. line below i = NINT((i1 + i2)/2.) v_line = i * contour_interval x_line = x1_bar + scale * (v_line - low_value) string9a = ASCII9(v_line) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x_line, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(string9a)) ! add little ticks to identify labelled contour CALL Set_Stroke_by_Value (v_line, contour_interval, & & midspectrum_value, low_is_blue) x_line = x1_bar + scale * (v_line - low_value) CALL New_L12_Path (1, x_line, y2_bar + 2.) CALL Line_to_L12 (x_line, y1_bar - 2.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! 2nd line will have contour interval string9a = ASCII9(contour_interval) string9a = ADJUSTL(string9a) bytes_wide = LEN_TRIM(string9a) CALL L12_Text (level = 1, x_points = 0.5 * (x1_bar + x2_bar), & & y_points = y1_bar - ai_lonlatlabel_points, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'contour interval '//string9a(1:bytes_wide)// & & ' '//units) END IF CALL End_Group ! number labels CALL End_Group ! whole legend END SUBROUTINE Bar_in_BottomLegend SUBROUTINE Bar_in_RightLegend (low_value, high_value, & & contour_interval, & & midspectrum_value, low_is_blue, & & units) ! Places a color-bar (or, for b/w plots, a pattern-bar) ! in the right legend area to identify the shading ! of countour plots. ! Note that all spatial variables in this routine are in ! level-1 points. ! The units string can be cancelled (if not wanted) by setting ! units = ' ' ! (regardless of the declared length of units). IMPLICIT NONE REAL, INTENT(IN) :: low_value, high_value, & & contour_interval, & & midspectrum_value LOGICAL, INTENT(IN) :: low_is_blue CHARACTER*(*), INTENT(IN) :: units CHARACTER*9 :: string9a, string9b CHARACTER*10 :: string10 INTEGER :: bytes_wide, i, i1, i2, need_ASCII10, units_bytes LOGICAL :: label_all REAL, PARAMETER :: aspect = 0.5 ! typical character width/nominal height REAL :: bar_width, bar_length, limit1, limit2, limit3, scale, & & v_low, v_high, v_center, v_line, & & y_low, y_high, y_line, & & x1_bar, x2_bar, y1_bar, y2_bar, & & x1_frame, x2_frame, y1_frame, y2_frame units_bytes = LEN_TRIM(units) IF (.NOT.ai_rightlegend_reserved) THEN WRITE (*,"(' ERROR: No space reserved (in Begin_Page) for right legend.')") CALL Traceback END IF IF (contour_interval <= 0.) THEN WRITE (*,"(' ERROR: Non-positive contour interval in Bar_in_RightLegend.')") CALL Traceback END IF ! check adequacy of space CALL Report_RightLegend_Frame (x1_frame, x2_frame, y1_frame, y2_frame) IF ((x2_frame - x1_frame) < (9. * ai_lonlatlabel_points * aspect + 2. + 7.)) THEN WRITE (*,"(' ERROR: ',F6.0,' < x < ',F6.0,' points is too tight for Bar_in_RightLegend.')") x1_frame, x2_frame CALL Traceback END IF IF ((y2_frame - y1_frame) < (6 * ai_lonlatlabel_points + 36)) THEN WRITE (*,"(' ERROR: ',F6.0,' < y < ',F6.0,' points is too tight for Bar_in_RightLegend.')") y1_frame, y2_frame CALL Traceback END IF ! decide length and y-placement of bar limit1 = 16. * 72. ! regardless of paper size limit2 = 28. * (high_value - low_value) / contour_interval ! 1 cm/step limit3 = (y2_frame - y1_frame) - 6 * ai_lonlatlabel_points bar_length = MIN(limit1, limit2, limit3) IF (bar_length == limit3) THEN ! shift up to allow for "contour / interval / 1 km" if needed at base y1_bar = 0.5 *(y1_frame + y2_frame) - 0.5 * bar_length + & & 1.5 * ai_lonlatlabel_points ELSE ! center in frame y1_bar = 0.5 *(y1_frame + y2_frame) - 0.5 * bar_length END IF y2_bar = y1_bar + bar_length ! decide if all numbers can be written in IF (high_value /= low_value) THEN label_all = ai_lonlatlabel_points <= & & (bar_length * contour_interval / (high_value - low_value)) ELSE label_all = .TRUE. END IF ! decide width and x-placement of bar limit1 = 28. ! 1 centimeter limit2 = (x2_frame - x1_frame) - 9. * ai_lonlatlabel_points * aspect bar_width = MIN(limit1, limit2) x1_bar = x1_frame + 9. * ai_lonlatlabel_points * aspect x2_bar = x1_bar + bar_width ! Set vertical scaling (points / data units) scale = bar_length / MAX((high_value - low_value), 1.E-30) ! Find integer limits on countour lines: i1 = 1 + Int_Below(low_value/contour_interval) i2 = Int_Below(high_value/contour_interval) ! Decide whether 4 significant digits (ASCII10) are needed to keep values distinct: need_ASCII10 = .FALSE. ! unless it becomes .TRUE. in loop below: IF (i2 > i1) THEN DO i = i1+1, i2 string9a = ASCII9((i-1) * contour_interval) string9b = ASCII9( i * contour_interval) IF (string9a == string9b) need_ASCII10 = .TRUE. END DO END IF ! Graphics CALL Begin_Group ! whole legend CALL Begin_Group ! colored/patterned blocks ! partial block at bottom? v_low = low_value v_high = MIN(i1 * contour_interval, high_value) IF (v_low < v_high) THEN v_center = 0.5 * (v_low + v_high) CALL Set_Fill_by_Value (v_center, contour_interval, & & midspectrum_value, low_is_blue) y_low = y1_bar y_high = y1_bar + scale * (v_high - low_value) CALL New_L12_Path (1, x1_bar, y_low) CALL Line_to_L12 (x2_bar, y_low) CALL Line_to_L12 (x2_bar, y_high) CALL Line_to_L12 (x1_bar, y_high) CALL Line_to_L12 (x1_bar, y_low) CALL End_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! many complete blocks DO i = i1, (i2-1) v_low = i * contour_interval v_high = v_low + contour_interval v_center = 0.5 * (v_low + v_high) CALL Set_Fill_by_Value (v_center, contour_interval, & & midspectrum_value, low_is_blue) y_low = y1_bar + scale * (v_low - low_value) y_high = y1_bar + scale * (v_high - low_value) CALL New_L12_Path (1, x1_bar, y_low) CALL Line_to_L12 (x2_bar, y_low) CALL Line_to_L12 (x2_bar, y_high) CALL Line_to_L12 (x1_bar, y_high) CALL Line_to_L12 (x1_bar, y_low) CALL End_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END DO ! partial block at top? v_low = i2 * contour_interval v_high = high_value IF (v_low < v_high) THEN v_center = 0.5 * (v_low + v_high) CALL Set_Fill_by_Value (v_center, contour_interval, & & midspectrum_value, low_is_blue) y_low = y1_bar + scale * (v_low - low_value) y_high = y2_bar CALL New_L12_Path (1, x1_bar, y_low) CALL Line_to_L12 (x2_bar, y_low) CALL Line_to_L12 (x2_bar, y_high) CALL Line_to_L12 (x1_bar, y_high) CALL Line_to_L12 (x1_bar, y_low) CALL End_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF CALL End_Group ! colored/patterned blocks CALL Begin_Group ! contour lines CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) DO i = i1, i2 v_line = i * contour_interval CALL Set_Stroke_by_Value (v_line, contour_interval, & & midspectrum_value, low_is_blue) y_line = y1_bar + scale * (v_line - low_value) CALL New_L12_Path (1, x1_bar, y_line) CALL Line_to_L12 (x2_bar, y_line) CALL End_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO CALL End_Group ! contour lines ! box around color/pattern bar: CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL New_L12_Path (1, x1_bar, y1_bar) CALL Line_to_L12 (x2_bar, y1_bar) CALL Line_to_L12 (x2_bar, y2_bar) CALL Line_to_L12 (x1_bar, y2_bar) CALL Line_to_L12 (x1_bar, y1_bar) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) CALL Begin_Group ! number labels CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! always label low_value IF (need_ASCII10) THEN string10 = ASCII10(low_value) string10 = ADJUSTL(string10) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.7, & & text = TRIM(string10)) ELSE string9a = ASCII9(low_value) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.7, & & text = TRIM(string9a)) END IF ! always label high_value, adding units (2 points higher) IF (need_ASCII10) THEN string10 = ASCII10(high_value) string10 = ADJUSTL(string10) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y2_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.0, & & text = TRIM(string10)) ELSE string9a = ASCII9(high_value) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y2_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.0, & & text = TRIM(string9a)) END IF CALL L12_Text (level = 1, x_points = x1_bar, & & y_points = y2_bar + 2., angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.0, ud_fraction = 0.0, & & text = units) IF (label_all) THEN DO i = i1, i2 v_line = i * contour_interval IF (v_line /= high_value) THEN y_line = y1_bar + scale * (v_line - low_value) IF (need_ASCII10) THEN string10 = ASCII10(v_line) string10 = ADJUSTL(string10) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y_line, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.35, & & text = TRIM(string10)) ELSE string9a = ASCII9(v_line) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y_line, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.35, & & text = TRIM(string9a)) END IF END IF END DO ELSE ! label only one contour; add c.i. line below i = NINT((i1 + i2)/2.) v_line = i * contour_interval y_line = y1_bar + scale * (v_line - low_value) string9a = ASCII9(v_line) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y_line, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.35, & & text = TRIM(string9a)) ! add little ticks to identify labelled contour CALL Set_Stroke_by_Value (v_line, contour_interval, & & midspectrum_value, low_is_blue) y_line = y1_bar + scale * (v_line - low_value) CALL New_L12_Path (1, x1_bar - 2., y_line) CALL Line_to_L12 (x2_bar + 2., y_line) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! 3 lines at bottom will have contour interval string9a = ASCII9(contour_interval) string9a = ADJUSTL(string9a) bytes_wide = LEN_TRIM(string9a) CALL L12_Text (level = 1, x_points = 0.5 * (x1_bar + x2_bar), & & y_points = y1_bar - ai_lonlatlabel_points, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'contour') CALL L12_Text (level = 1, x_points = 0.5 * (x1_bar + x2_bar), & & y_points = y1_bar - 2. * ai_lonlatlabel_points, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'interval') CALL L12_Text (level = 1, x_points = 0.5 * (x1_bar + x2_bar), & & y_points = y1_bar - 3. * ai_lonlatlabel_points, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = string9a(1:bytes_wide)//' '//units) END IF ! label_all, or not CALL End_Group ! number labels CALL End_Group ! whole legend END SUBROUTINE Bar_in_RightLegend SUBROUTINE Bumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & units, minimum, maximum, & & bitmap_color_mode, interval, midvalue, lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) ! Many types of mosaic layer can be represented as a bitmap, ! where color variations are used to represent scalar values. ! While matrix bitmap_value is set before this routine is called, ! this routine has control of the brightness of each pixel. ! This creates the possibility of reading a topographic ! DEM from a .grd file, and superposing topography with shaded ! relief. ! Another option is to create "contours" of brightness by ! determining brightness in proportion to MOD(bitmap_value, 1.0). ! This routine provides the common code to create a colored ! bitmap, optionally with shades of lightness/darkness ! representing either a topographic DEM or contour levels. ! It reads the topographic .grd file (if used), ! allocates and writes the bitmap, ! obtaining the scalar "value" for each pixel from ! array bitmap_value(irow,jcol) ( IF (bitmap_success(irow,jcol) ). ! It is suggested that the last thing the calling program should ! do is to show the user a histogram of the values contained in ! array bitmap_value, and define the "minimum" and ! "maximum" values expected. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: path_in, units CHARACTER*(*), INTENT(INOUT) :: grd2_file INTEGER, INTENT(IN) :: bitmap_height, bitmap_width INTEGER, INTENT(INOUT) :: bitmap_color_mode LOGICAL, INTENT(INOUT) :: lowblue, shaded_relief LOGICAL(1),DIMENSION(:,:), INTENT(IN) :: bitmap_success REAL, INTENT(IN) :: minimum, maximum REAL, INTENT(INOUT) :: intensity, interval, midvalue, & & bitmap_color_lowvalue, bitmap_color_highvalue REAL ,DIMENSION(:,:), INTENT(IN) :: bitmap_value !Reads these global values from module Adobe_Illustrator: ! ai_black_background, ! ai_paper_height_points, ai_paper_width_points, ! ai_spectrum_count, ai_using_color, ! ai_window_x1_points, ai_window_x2_points, ! ai_window_y1_points, ai_window_y2_points !Reads this global value from module Map_Tools: ! mt_meters_per_user CHARACTER*3 :: c3 CHARACTER*79 :: line CHARACTER*132 :: grd2_pathfile CHARACTER(LEN=3), DIMENSION(:,:), ALLOCATABLE :: bitmap ! array of RGB pixels INTEGER :: grd2_ncols, grd2_nrows, & & i, i1, i2, ios, irow, j, j1, j2, jcol, k, & & train_length LOGICAL :: bottom, grd1_success, grd2_lonlat, grd2_success, & & problem, right, success REAL :: above, below, brightness, & & grd2_d_EW, grd2_d_lat, grd2_d_lon, grd2_d_x, grd2_d_y, & & grd2_lat_max, grd2_lat_min, grd2_lon_max, grd2_lon_min, grd2_lon_range, & & grd2_x_max, grd2_x_min, grd2_y_max, grd2_y_min, & & inner, fin, fout, fx1, fx2, fy1, fy2, & & lat, lon, outer, RMS_slope, slope, sum, t, value, & & x_meters, x_points, y_meters, y_points REAL, DIMENSION(3) :: uvec REAL, DIMENSION(:,:), ALLOCATABLE :: grid2 IF (.NOT.ai_using_color) THEN WRITE (*,"(' ERROR: Called Bumpy_Bitmap for a black/white graphic.')") CALL Traceback END IF !Define how "value" from bitmap_values will be colored: !NOTE: We are assuming that the calling program showed the user a ! preview histogram of the values in bitmap_value, ! and also provided the limits "minimum" and "maximum". ! These are needed to decide on the color scale, under some coloring modes. 2 WRITE (*,"(' How shall the bitmap be colored?')") WRITE (*,"(' mode 0: Munsell: smooth spectrum (but values of 0 not colored')") WRITE (*,"(' mode 1: Munsell: smooth spectrum (with values of 0 colored normally)')") WRITE (*,"(' mode 2: Kansas: 44-color scale of atlas-type colors')") WRITE (*,"(' mode 3: UNAVCO: 20-color absolute scale (only for topography in m)')") WRITE (*,"(' mode 4: AI: ',I2,'-color discrete scale, based on contour interval')") ai_spectrum_count WRITE (*,"(' -------------------------------------------------------')") CALL Prompt_for_Integer('Which coloring mode?',bitmap_color_mode,bitmap_color_mode) IF ((bitmap_color_mode < 0).OR.(bitmap_color_mode > 4)) THEN WRITE (*,"(/' ERROR: Select mode index from list!' )") GOTO 2 END IF bitmap_color_lowvalue = minimum bitmap_color_highvalue = maximum IF (bitmap_color_mode <= 2) THEN ! need to pin down ends of spectrum 3 CALL Prompt_for_Real('What (low?) value anchors the blue end of the spectrum?',bitmap_color_lowvalue,bitmap_color_lowvalue) CALL Prompt_for_Real('What (high?) value anchors the red end of the spectrum?',bitmap_color_highvalue,bitmap_color_highvalue) IF (bitmap_color_highvalue == bitmap_color_lowvalue) THEN WRITE (*,"(/' ERROR: Red value must differ from blue value!' )") GOTO 3 END IF ! bad range ELSE IF (bitmap_color_mode == 4) THEN IF (interval == 0.0) THEN interval = (maximum - minimum)/ai_spectrum_count midvalue = (maximum + minimum)/2. END IF 4 CALL Prompt_for_Real('What contour interval do you wish?',interval,interval) IF (interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") interval = (maximum - minimum)/ai_spectrum_count GOTO 4 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',midvalue,midvalue) CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',lowblue,lowblue) END IF ! bitmap_color_mode = 0/1,2 versus 4 CALL Prompt_for_Logical('Do you want shaded relief?',shaded_relief,shaded_relief) IF (shaded_relief) THEN ! get topography data into grid2: ! 5 CALL Grd_List (path_in, grd2_file) 5 CALL Prompt_for_String('Which .grd file has the topography (DEM)?',grd2_file,grd2_file) grd2_pathfile = TRIM(path_in)//TRIM(grd2_file) WRITE(*,"(/' Here are the first 5 lines of the file with the topography:' & &/' --------------------------------------------------------------')") OPEN (UNIT = 51, FILE = grd2_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') DO i = 1, 5 READ (51,"(A)", IOSTAT = ios) line WRITE (*,"(' ',A)") TRIM(line) END DO WRITE(*,"(' --------------------------------------------------------------')") CLOSE (51) CALL Prompt_for_Logical('Is this grid defined in (lon,lat) coordinates?',.TRUE.,grd2_lonlat) OPEN (UNIT = 51, FILE = grd2_pathfile, STATUS = 'OLD', IOSTAT = ios) problem = (ios /= 0) IF (grd2_lonlat) THEN READ (51, *, IOSTAT = ios) grd2_lon_min, grd2_d_lon, grd2_lon_max problem = problem .OR. (ios /= 0) IF (ABS(grd2_lon_max - grd2_lon_min - 360.0) < 0.01) THEN grd2_lon_range = 360.0 ELSE grd2_lon_range = Easting(grd2_lon_max - grd2_lon_min) END IF READ (51, *, IOSTAT = ios) grd2_lat_min, grd2_d_lat, grd2_lat_max problem = problem .OR. (ios /= 0) grd2_ncols = 1 + NINT((grd2_lon_max - grd2_lon_min) / grd2_d_lon) grd2_nrows = 1 + NINT((grd2_lat_max - grd2_lat_min) / grd2_d_lat) ELSE ! (x,y) format READ (51, *, IOSTAT = ios) grd2_x_min, grd2_d_x, grd2_x_max problem = problem .OR. (ios /= 0) grd2_x_min = grd2_x_min * mt_meters_per_user grd2_d_x = grd2_d_x * mt_meters_per_user grd2_x_max = grd2_x_max * mt_meters_per_user READ (51, *, IOSTAT = ios) grd2_y_min, grd2_d_y, grd2_y_max problem = problem .OR. (ios /= 0) grd2_y_min = grd2_y_min * mt_meters_per_user grd2_d_y = grd2_d_y * mt_meters_per_user grd2_y_max = grd2_y_max * mt_meters_per_user grd2_ncols = 1 + NINT((grd2_x_max - grd2_x_min) / grd2_d_x) grd2_nrows = 1 + NINT((grd2_y_max - grd2_y_min) / grd2_d_y) END IF problem = problem .OR. (grd2_nrows < 2) .OR. (grd2_ncols < 2) train_length = grd2_nrows * grd2_ncols ALLOCATE ( grid2(grd2_nrows, grd2_ncols) ) READ (51, *, IOSTAT = ios) ((grid2(i,j), j = 1, grd2_ncols), i = 1, grd2_nrows) problem = problem .OR. (ios /= 0) CLOSE (51) IF (problem) THEN WRITE (*,"(' ERROR: ',A' defective in structure or truncated.')") TRIM(grd2_file) CALL Press_Enter DEALLOCATE ( grid2 ) mt_flashby = .FALSE. GO TO 5 END IF ! problem with grd2 CALL Prompt_for_Real('Relative intensity of oblique lighting?',intensity,intensity) !find RMS E-W slope IF (grd2_lonlat) THEN grd2_d_EW = grd2_d_lon ELSE grd2_d_EW = grd2_d_x END IF sum = 0.0 DO irow = 1, grd2_nrows DO jcol = 2, grd2_ncols sum = sum + ((grid2(irow,jcol) - grid2(irow,jcol-1)) / grd2_d_EW)**2 END DO ! jcol END DO ! irow RMS_slope = SQRT(sum / train_length) IF (RMS_slope == 0.0) RMS_slope = 1.0 ! prevent /0.0 ELSE ! shaded_relief = .FALSE.; how about shingled_brightness? CALL Prompt_for_Logical('Do you want shingled brightness?',mt_shingled_brightness,mt_shingled_brightness) END IF ! shaded_relief, or not WRITE (*,"(' Working on bitmap....')") ALLOCATE ( bitmap(bitmap_height,bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) !---------------------------------------------- !Get "value" (basis for color of pixel) if possible: grd1_success = bitmap_success(irow, jcol) IF (grd1_success) THEN value = bitmap_value(irow, jcol) ELSE value = 0.0 END IF !---------------------------------------------- !Get "brightness" (basis for brightness of pixel) from grid2??? grd2_success = .FALSE. ! just in case; You can't succeed if you never try! IF (shaded_relief) THEN IF (grd2_lonlat) THEN CALL Reject (x_meters,y_meters, success, uvec) IF (success) THEN CALL Uvec_2_LonLat (uvec, lon, lat) !define grd2_success as falling within grid2 grd2_success = (lat >= grd2_lat_min).AND. & & (lat <= grd2_lat_max).AND. & & (Easting(lon - grd2_lon_min) <= grd2_lon_range) !note: insensitive to longitude cycle IF (grd2_success) THEN i1 = 1 + (grd2_lat_max - lat) / grd2_d_lat i1 = MAX(1,MIN(i1,grd2_nrows-1)) i2 = i1 + 1 fy2 = ((grd2_lat_max - lat) / grd2_d_lat) - i1 + 1.0 fy1 = 1.00 - fy2 j1 = 1 + Easting(lon - grd2_lon_min) / grd2_d_lon j1 = MAX(1,MIN(j1,grd2_ncols-1)) j2 = j1 + 1 fx2 = (Easting(lon - grd2_lon_min) / grd2_d_lon) - j1 + 1.0 fx1 = 1.00 - fx2 END IF ! point in grid2 ELSE ! Rejection failed; lon, lat undefined grd2_success = .FALSE. END IF ! successful Rejection or not ELSE ! .NOT.grd2_lonlat; grid2 is x,y grd2_success = (x_meters >= grd2_x_min).AND. & & (x_meters <= grd2_x_max).AND. & & (y_meters >= grd2_y_min).AND. & & (y_meters <= grd2_y_max) IF (grd2_success) THEN i1 = 1 + (grd2_y_max - y_meters) / grd2_d_y i1 = MAX(1,MIN(i1,grd2_nrows-1)) i2 = i1 + 1 fy2 = ((grd2_y_max - y_meters) / grd2_d_y) - i1 + 1.0 fy1 = 1.00 - fy2 j1 = 1 + (x_meters - grd2_x_min) / grd2_d_x j1 = MAX(1,MIN(j1,grd2_ncols-1)) j2 = j1 + 1 fx2 = ((x_meters - grd2_x_min) / grd2_d_x) - j1 + 1.0 fx1 = 1.00 - fx2 END IF ! point within x/y grid2 END IF ! grd2_lonlat, or not IF (grd2_success) THEN ! can compute brightness !Compute E-W slope in a way that gives a !result that is piecewise-linear in the E-W direction: fout = ABS(fx2 - 0.5) ! fraction for adjacent cell fin = 1.00 - fout ! fraction for the cell we're in inner = (grid2(i1,j2) - grid2(i1,j1)) / grd2_d_EW IF (fx2 > 0.5) THEN IF (j2 < grd2_ncols) THEN ! normal case outer = (grid2(i1,j2+1) - grid2(i1,j1+1)) / grd2_d_EW ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case outer = (grid2(i1,j2-1) - grid2(i1,j1-1)) / grd2_d_EW ELSE ! at left edge of grid outer = inner END IF END IF above = fin * inner + fout * outer !Repeat for row below the point: inner = (grid2(i2,j2) - grid2(i2,j1)) / grd2_d_EW IF (fx2 > 0.5) THEN IF (j2 < grd2_ncols) THEN ! normal case outer = (grid2(i2,j2+1) - grid2(i2,j1+1)) / grd2_d_EW ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case outer = (grid2(i2,j2-1) - grid2(i2,j1-1)) / grd2_d_EW ELSE ! at left edge of grid outer = inner END IF END IF below = fin * inner + fout * outer !Line below makes slope piecewise-linear in N-S direction: slope = fy1 * above + fy2 * below brightness = 1.0 + 0.5 * intensity * slope / RMS_slope brightness = MAX(0.0, MIN(2.0, brightness)) ELSE ! .NOT. dot2_success; so, point was not in grid2 brightness = 1.0 END IF ! point was in grid2 or not ELSE IF (mt_shingled_brightness) THEN brightness = 0.8 + 0.8 * MOD(value, 1.0) ELSE ! no shaded relief or shingling wanted brightness = 1.0 END IF ! shaded relief, mt_shingled_brightness, or uniform brightness !End of lookup (value and brightness); now use them! IF (grd1_success) THEN ! have "value" IF (bitmap_color_mode <= 1) THEN ! Munsell: smooth spectrum (0: don't color values of zero) IF ((bitmap_color_mode == 0).AND.(value == 0.0)) THEN c3 = CHAR(ai_background%rgb(1))//CHAR(ai_background%rgb(2))//CHAR(ai_background%rgb(3)) ELSE ! normal coloring t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = RGB_Munsell(warmth = t, brightness = brightness) END IF ELSE IF (bitmap_color_mode == 2) THEN ! Kansas: 44-color atlas-type scale t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = RGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = RGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = RGB_AI(value = value, contour_interval = interval, & & midspectrum_value = midvalue, low_is_blue = lowblue, & & brightness = brightness) END IF ! bitmap_color_mode selection bitmap(irow,jcol) = c3 ELSE IF (grd2_success) THEN ! b/w; gray depends only on slope k = brightness * 127.5 k = MAX(0,MIN(255,k)) bitmap(irow,jcol) = CHAR(k)//CHAR(k)//CHAR(k) ELSE ! fill in with background IF (ai_black_background) THEN ! slide copy bitmap(irow,jcol) = CHAR(0)//CHAR(0)//CHAR(0) ELSE ! white background (paper print) bitmap(irow,jcol) = CHAR(255)//CHAR(255)//CHAR(255) END IF END IF ! color, grey-scale, or background END DO ! jcol, left to right WRITE (*,"('+Working on bitmap....',I6,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Working on bitmap....Writing to .ai ')") CALL Bitmap_on_L1 (bitmap, ai_window_x1_points, ai_window_x2_points, & & ai_window_y1_points, ai_window_y2_points) DEALLOCATE ( bitmap ) IF (ALLOCATED( grid2 )) DEALLOCATE ( grid2 ) END SUBROUTINE Bumpy_Bitmap SUBROUTINE Check_for_TABs (iUnit) !Reads through an input file !which is already OPEN on device iUnit, !complains about any TAB characters found, and stops program. !If none are found, it REWINDs to top of file. IMPLICIT NONE INTEGER, INTENT(IN) :: iUnit CHARACTER*1 :: TAB_byte CHARACTER*512 :: line INTEGER :: ios, line_count, place TAB_byte = CHAR(9) ! ht = horizontal tab = decimal 009 = 0x09 line_count = 0 scanning: DO READ (iUnit, "(A)", IOSTAT = ios) line IF (ios == -1) EXIT scanning ! EOF found line_count = line_count + 1 place = SCAN(line, TAB_byte) IF (place > 0) THEN WRITE (*, 10) line_count, place 10 FORMAT (' ERROR: The TAB character (ht; ASCII decimal 009 = hexadecimal 0x09)' & &/' was found in this input file at line #',I7,', byte #',I4 & &/' TABs cause fatal errors in FORMATted READ operations, and must be' & &/' replaced by spaces. The program will now STOP.') WRITE (*,"(' Press [Enter]...'\)") READ (*,*) STOP END IF END DO scanning REWIND iUnit END SUBROUTINE Check_for_TABs SUBROUTINE Contour_3Node_Scalar_in_Plane (x1,y1, x2,y2, x3,y3, & & f1, f2, f3, & & low_value, high_value, & & contour_interval, & & midspectrum_value, & & low_is_blue, group, & & skip_0_contour) ! Contours a single triangular plane finite element using level-3 ! commands. ! Corner node locations (x1,y1), (x2,y2), x3,y3) are ! in units of map-plane meters (level-3), and must be given in ! counterclockwise order. ! Scalar function values are f1, f2, and f3 at corresponding nodes. ! Low_value and high_value are modified (if necessary) to ! encompass the ranges MIN(f1, f2, f3) to MAX(f1, f2, f3); ! after multiple calls to this routine, they may be used in ! CALL Bar_in_BottomLegend, or CALL Bar_in_RightLegend. ! Contour_interval is the delta_f used in contouring. ! Midspectrum_value is a value of f which should be assigned ! a mid-spectrum color. ! Low_is_blue (or dark grey) is a logical switch determining ! whether low values of f are assigned blue colors (.TRUE.) ! or red colors (.FALSE.). ! Group = 0, 1, or 2. This switch is used to arrange all contour ! lines into one graphics group, distinct from all colored areas, ! in case desired (so that contour lines can be dropped, or ! their width changed, during editing?). ! If group == 0, both colored areas and lines are drawn ! (most efficient, but does not give grouping). ! If group == 1, only colored areas are drawn. ! If group == 2, only contour lines are drawn. ! Thus, it takes twice as many calls, and twice as much computing, ! to achieve a neat graphical grouping. ! Note: In any case, CALL Begin_Group and CALL End_Group appear ! in the calling program (typically outside of a loop), not here! ! Be aware that this routine never changes the line width or ! style (dashed?); it only adjusts line color. IMPLICIT NONE REAL, INTENT(IN) :: x1,y1, x2,y2, x3,y3, f1, f2, f3 REAL, INTENT(INOUT) :: low_value, high_value REAL, INTENT(IN) :: contour_interval, midspectrum_value LOGICAL, INTENT(IN) :: low_is_blue INTEGER, INTENT(IN) :: group LOGICAL, INTENT(IN), OPTIONAL :: skip_0_contour CHARACTER*10 color_name INTEGER :: i_high, i_in, i_low, i_out, j, num_con LOGICAL :: inner, old_inner, skip_0 REAL :: f, f_con, f_high, f_low, f_mid, & & s_base, s_far, & & x_base, x_far, x_high, x_low, x_mid, x_old_far, x_old_base, & & y_base, y_far, y_high, y_low, y_mid, y_old_far, y_old_base IF (PRESENT(skip_0_contour)) THEN skip_0 = skip_0_contour ELSE skip_0 = .FALSE. END IF IF (contour_interval <= 0.) THEN WRITE (*,"(' ERROR: Positive contour interval required for Contour_3Node_Scalar_in_Plane.')") CALL Traceback END IF IF ((group < 0).OR.(group > 2)) THEN WRITE (*,"(' ERROR: Illegal group = ',I5,' to Contour_3Node_Scalar_in_Plane.')") group CALL Traceback END IF low_value = MIN(low_value, f1, f2, f3) high_value = MAX(high_value, f1, f2, f3) IF ((f1 == f2).AND.(f2 == f3)) THEN ! special case; one color IF (MOD(f1, contour_interval) == 0.0) THEN ! falls on contour IF ((group == 0).OR.(group == 2)) THEN ! drawing lines [sic] this time CALL Set_Stroke_by_Value (f1, contour_interval, & & midspectrum_value, low_is_blue) color_name = ai_next_line_color ! retrieve contour color just chosen CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = color_name) ! because this area is just a "fat area" on a contour line! CALL New_L3_Path(x1,y1) CALL Line_to_L3(x2,y2) CALL Line_to_L3(x3,y3) CALL Line_to_L3(x1,y1) CALL End_L3_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! drawing lines this time ELSE ! falls between contours IF ((group == 0).OR.(group == 1)) THEN ! doing colors this time CALL Set_Fill_by_Value (f1, contour_interval, & & midspectrum_value, low_is_blue) CALL New_L3_Path(x1,y1) CALL Line_to_L3(x2,y2) CALL Line_to_L3(x3,y3) CALL Line_to_L3(x1,y1) CALL End_L3_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! drawing areas this time END IF ! solid color is contour color, or not ELSE ! normal case; unequal nodal values f_low = MIN(f1, f2, f3) f_high = MAX(f1, f2, f3) ! i_low and i_high are associated with the lowest and highest colors ! (not contours): each is identified by the index of the contour below it. i_low = Int_Below(f_low / contour_interval) IF (MOD(f_high, contour_interval) == 0.0) THEN i_high = (f_high / contour_interval) - 1 ELSE ! normal case; f_high is between contours i_high = Int_Below(f_high / contour_interval) END IF IF (i_high <= i_low) THEN ! no contours; uniform color IF ((group == 0).OR.(group == 1)) THEN ! doing colors this time f = (f1 + f2 + f3) / 3. CALL Set_Fill_by_Value (f, contour_interval, & & midspectrum_value, low_is_blue) CALL New_L3_Path(x1,y1) CALL Line_to_L3(x2,y2) CALL Line_to_L3(x3,y3) CALL Line_to_L3(x1,y1) CALL End_L3_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! drawing areas this time ELSE ! contours must be located num_con = i_high - i_low !first, rotate to standard view: IF (f1 == f_low) THEN x_low = x1 y_low = y1 IF (f2 <= f3) THEN f_mid = f2 x_mid = x2 y_mid = y2 x_high = x3 y_high = y3 ELSE f_mid = f3 x_mid = x3 y_mid = y3 x_high = x2 y_high = y2 END IF ! f2 <= f3 or not ELSE IF (f2 == f_low) THEN x_low = x2 y_low = y2 IF (f1 <= f3) THEN f_mid = f1 x_mid = x1 y_mid = y1 x_high = x3 y_high = y3 ELSE ! f1 > f3 f_mid = f3 x_mid = x3 y_mid = y3 x_high = x1 y_high = y1 END IF ! f1 <= f3, or not ELSE ! f3 is the lowest value of the 3 x_low = x3 y_low = y3 IF (f1 <= f2) THEN f_mid = f1 x_mid = x1 y_mid = y1 x_high = x2 y_high = y2 ELSE ! f1 > f2 f_mid = f2 x_mid = x2 y_mid = y2 x_high = x1 y_high = y1 END IF ! f1 <= f2, or not END IF ! f1, f2, or f3 is the lowest !loop on contours to be found: DO j = 1, num_con i_in = i_low + j - 1 ! increases from i_low i_out = i_in + 1 ! always one more; ends at i_high f_con = i_out * contour_interval s_base = (f_con - f_low) / (f_high - f_low) x_base = x_low + s_base * (x_high - x_low) y_base = y_low + s_base * (y_high - y_low) inner = (f_con < f_mid) IF (inner) THEN s_far = (f_con - f_low) / (f_mid - f_low) x_far = x_low + s_far * (x_mid - x_low) y_far = y_low + s_far * (y_mid - y_low) ELSE s_far = (f_con - f_mid) / (f_high - f_mid) x_far = x_mid + s_far * (x_high - x_mid) y_far = y_mid + s_far * (y_high - y_mid) END IF IF (j == 1) THEN ! 1st polygon IF ((group == 0).OR.(group == 1)) THEN ! doing colors f = (i_in + 0.5) * contour_interval CALL Set_Fill_by_Value (f, contour_interval, & & midspectrum_value, low_is_blue) CALL New_L3_Path(x_low,y_low) CALL Line_to_L3(x_base,y_base) CALL Line_to_L3(x_far,y_far) IF (.NOT.inner) CALL Line_to_L3(x_mid,y_mid) CALL Line_to_L3(x_low,y_low) CALL End_L3_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! doing colors now IF ((group == 0).OR.(group == 2)) THEN ! doing lines now IF ((f_con /= 0.0).OR.(.NOT.skip_0)) THEN CALL Set_Stroke_by_Value (f_con, contour_interval, & & midspectrum_value, low_is_blue) CALL New_L3_Path(x_base,y_base) CALL Line_to_L3(x_far,y_far) CALL End_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! contour is non-zero, or zero contour is desired END IF ! doing lines now ELSE ! j > 1; not first polygon IF ((group == 0).OR.(group == 1)) THEN ! doing colors f = (i_in + 0.5) * contour_interval CALL Set_Fill_by_Value (f, contour_interval, & & midspectrum_value, low_is_blue) CALL New_L3_Path(x_old_base,y_old_base) CALL Line_to_L3(x_base,y_base) CALL Line_to_L3(x_far,y_far) IF (inner.NEQV.old_inner) CALL Line_to_L3(x_mid,y_mid) CALL Line_to_L3(x_old_far,y_old_far) CALL Line_to_L3(x_old_base,y_old_base) CALL End_L3_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! doing colors now IF ((group == 0).OR.(group == 2)) THEN ! doing lines now IF ((f_con /= 0.0).OR.(.NOT.skip_0)) THEN CALL Set_Stroke_by_Value (f_con, contour_interval, & & midspectrum_value, low_is_blue) CALL New_L3_Path(x_base,y_base) CALL Line_to_L3(x_far,y_far) CALL End_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! contour value is non-zero, or zero contour desired END IF ! doing lines now END IF ! 1st polygon, or later one? IF (j == num_con) THEN ! add one more polygon; no more lines! IF ((group == 0).OR.(group == 1)) THEN ! doing colors f = (i_out + 0.5) * contour_interval CALL Set_Fill_by_Value (f, contour_interval, & & midspectrum_value, low_is_blue) CALL New_L3_Path(x_base,y_base) CALL Line_to_L3(x_high,y_high) IF (inner) CALL Line_to_L3(x_mid,y_mid) CALL Line_to_L3(x_far,y_far) CALL Line_to_L3(x_base,y_base) CALL End_L3_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! doing colors now END IF ! j == num_con !set memory for next loop x_old_base = x_base y_old_base = y_base x_old_far = x_far y_old_far = y_far old_inner = inner END DO ! j = 1, num_con IF ((f_low == f_mid).AND.(MOD(f_low, contour_interval) == 0.0)) THEN ! Special case; add lowest contour along element side. !(Note convention: a contour along an element side is ! shown if and only if the element contains higher values. ! This prevents double-plotting of contours in adjacent ! elements, which fails if contour are dashed because ! the dashes don't necessarily line up. ! The only defect of this convention is that a ridge ! exactly at a contour level and exactly along an ! element boundary will not receive a contour, but ! then numerical roundoff could have the same effect.) IF ((group == 0).OR.(group == 2)) THEN IF ((f_low /= 0.0).OR.(.NOT.skip_0)) THEN CALL Set_Stroke_by_Value (f_low, contour_interval, & & midspectrum_value, low_is_blue) CALL New_L3_Path(x_low,y_low) CALL Line_to_L3(x_mid,y_mid) CALL End_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! f_low /= 0, or zero contours desired END IF ! doing lines now END IF ! special low contour along element side END IF ! several colors; contours must be located END IF ! constant value, or (potentially) several colors? END SUBROUTINE Contour_3Node_Scalar_in_Plane SUBROUTINE Contour_3Node_Scalar_on_Sphere(uvec1, uvec2, uvec3, & & f1, f2, f3, & & low_value, high_value, & & contour_interval, & & midspectrum_value, & & low_is_blue, group, & & skip_0_contour) ! Contours a scalar field in a single spherical-triangle finite ! element using level-5 commands. ! Values are linearly interpolated in an internal plane triangle, ! and then contours are radially projected to the sphere ! (where they become arcs of great circles). ! Corner node locations (uvec1, uvec2, uvec3) are dimensionless ! unit vectors from the center of the planet to the surface, ! and must be given in in counterclockwise order. ! Scalar function values are f1, f2, and f3 at corresponding nodes. ! Low_value and high_value are modified (if necessary) to ! encompass the ranges MIN(f1, f2, f3) to MAX(f1, f2, f3); ! after multiple calls to this routine, they may be used in ! CALL Bar_in_BottomLegend, or CALL Bar_in_RightLegend. ! Contour_interval is the delta_f used in contouring. ! Midspectrum_value is a value of f which should be assigned ! a mid-spectrum color. ! Low_is_blue (or dark grey) is a logical switch determining ! whether low values of f are assigned blue colors (.TRUE.) ! or red colors (.FALSE.). ! Group = 0, 1, or 2. This switch is used to arrange all contour ! lines into one graphics group, distinct from all colored areas, ! in case desired (so that contour lines can be dropped, or ! their width changed, during editing?). ! If group == 0, both colored areas and lines are drawn ! (most efficient, but does not give grouping). ! If group == 1, only colored areas are drawn. ! If group == 2, only contour lines are drawn. ! Thus, it takes twice as many calls, and twice as much computing, ! to achieve a neat graphical grouping. ! Note: In any case, CALL Begin_Group and CALL End_Group appear ! in the calling program (typically outside of a loop), not here! ! Be aware that this routine never changes the line width or ! style (dashed?); it only adjusts line color. IMPLICIT NONE REAL, DIMENSION(3), INTENT(IN) :: uvec1, uvec2, uvec3 REAL, INTENT(IN) :: f1, f2, f3 REAL, INTENT(INOUT) :: low_value, high_value REAL, INTENT(IN) :: contour_interval, midspectrum_value LOGICAL, INTENT(IN) :: low_is_blue INTEGER, INTENT(IN) :: group LOGICAL, INTENT(IN), OPTIONAL :: skip_0_contour CHARACTER*10 color_name INTEGER :: i_high, i_in, i_low, i_out, j, num_con LOGICAL :: inner, old_inner, skip_0 REAL :: f, f_con, f_high, f_low, f_mid, & & min_radius, s_base, s_far, & & x1, x2, x3, x_base, x_far, x_high, x_low, x_mid, x_old_far, x_old_base, & & y1, y2, y3, y_base, y_far, y_high, y_low, y_mid, y_old_far, y_old_base REAL, DIMENSION(3) :: east_uvec, normal_uvec, north_uvec, uvec IF (PRESENT(skip_0_contour)) THEN skip_0 = skip_0_contour ELSE skip_0 = .FALSE. END IF IF (contour_interval <= 0.) THEN WRITE (*,"(' ERROR: Positive contour interval required for Contour_3Node_Scalar_on_Sphere.')") CALL Traceback END IF IF ((group < 0).OR.(group > 2)) THEN WRITE (*,"(' ERROR: Illegal group = ',I5,' to Contour_3Node_Scalar_on_Sphere.')") group CALL Traceback END IF ! Establish correspondance of plane triangle to spherical one: CALL Set_Sphere_2_Plane(uvec1, uvec2, uvec3, & ! inputs & normal_uvec, min_radius, & ! outputs, & north_uvec, east_uvec) CALL Sphere_2_Plane(uvec1, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & x1,y1) ! outputs CALL Sphere_2_Plane(uvec2, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & x2,y2) ! outputs CALL Sphere_2_Plane(uvec3, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & x3,y3) ! outputs ! Rest of code almost == Contour_3Node_Scalar_in_Plane, ! except that calls are level-5, not level-3, and have passed ! through a CALL Plane_2_Sphere: low_value = MIN(low_value, f1, f2, f3) high_value = MAX(high_value, f1, f2, f3) IF ((f1 == f2).AND.(f2 == f3)) THEN ! special case; one color IF (MOD(f1, contour_interval) == 0.0) THEN ! falls on contour IF ((group == 0).OR.(group == 2)) THEN ! drawing lines [sic] this time CALL Set_Stroke_by_Value (f1, contour_interval, & & midspectrum_value, low_is_blue) color_name = ai_next_line_color ! retrieve contour color just chosen CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = color_name) ! because this area is just a "fat area" on a contour line! CALL Plane_2_Sphere(x1,y1, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL New_L45_Path(5,uvec) CALL Plane_2_Sphere(x2,y2, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL Plane_2_Sphere(x3,y3, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL Plane_2_Sphere(x1,y1, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! drawing lines this time ELSE ! falls between contours IF ((group == 0).OR.(group == 1)) THEN ! doing colors this time CALL Set_Fill_by_Value (f1, contour_interval, & & midspectrum_value, low_is_blue) CALL Plane_2_Sphere(x1,y1, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL New_L45_Path(5,uvec) CALL Plane_2_Sphere(x2,y2, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL Plane_2_Sphere(x3,y3, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL Plane_2_Sphere(x1,y1, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! drawing areas this time END IF ! solid color is contour color, or not ELSE ! normal case; unequal nodal values f_low = MIN(f1, f2, f3) f_high = MAX(f1, f2, f3) ! i_low and i_high are associated with the lowest and highest colors ! (not contours): each is identified by the index of the contour below it. IF (((f_low > 0.0).AND.(MOD(f_low, contour_interval)/contour_interval >= 0.99999)) .OR. & & ((f_low < 0.0).AND.(MOD(f_low, contour_interval)/contour_interval >= -0.00001))) THEN !Note: formerly there was no tolerance, but this caused abends due to topology problems; !it is better not to attempt coloring in extremely tiny slivers! i_low = Int_Below(f_low / contour_interval) + 1 ELSE ! normal case; f_low is between contours, more than 0.00001 intervals away from each i_low = Int_Below(f_low / contour_interval) END IF IF (((f_high > 0.0).AND.(MOD(f_high, contour_interval)/contour_interval <= 0.00001)) .OR. & & ((f_high < 0.0).AND.(MOD(f_high, contour_interval)/contour_interval <= -0.99999))) THEN !Note: formerly there was no tolerance, but this caused abends due to topology problems; !it is better not to attempt coloring in extremely tiny slivers! i_high = Int_Below(f_high / contour_interval) - 1 ELSE ! normal case; f_high is between contours, more than 0.00001 intervals away from each i_high = Int_Below(f_high / contour_interval) END IF IF (i_high <= i_low) THEN ! no contours; uniform color IF ((group == 0).OR.(group == 1)) THEN ! doing colors this time f = (f1 + f2 + f3) / 3. CALL Set_Fill_by_Value (f, contour_interval, & & midspectrum_value, low_is_blue) CALL Plane_2_Sphere(x1,y1, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL New_L45_Path(5,uvec) CALL Plane_2_Sphere(x2,y2, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL Plane_2_Sphere(x3,y3, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL Plane_2_Sphere(x1,y1, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! drawing areas this time ELSE ! contours must be located num_con = i_high - i_low !first, rotate to standard view: IF (f1 == f_low) THEN x_low = x1 y_low = y1 IF (f2 <= f3) THEN f_mid = f2 x_mid = x2 y_mid = y2 x_high = x3 y_high = y3 ELSE f_mid = f3 x_mid = x3 y_mid = y3 x_high = x2 y_high = y2 END IF ! f2 <= f3 or not ELSE IF (f2 == f_low) THEN x_low = x2 y_low = y2 IF (f1 <= f3) THEN f_mid = f1 x_mid = x1 y_mid = y1 x_high = x3 y_high = y3 ELSE ! f1 > f3 f_mid = f3 x_mid = x3 y_mid = y3 x_high = x1 y_high = y1 END IF ! f1 <= f3, or not ELSE ! f3 is the lowest value of the 3 x_low = x3 y_low = y3 IF (f1 <= f2) THEN f_mid = f1 x_mid = x1 y_mid = y1 x_high = x2 y_high = y2 ELSE ! f1 > f2 f_mid = f2 x_mid = x2 y_mid = y2 x_high = x1 y_high = y1 END IF ! f1 <= f2, or not END IF ! f1, f2, or f3 is the lowest !loop on contours to be found: DO j = 1, num_con i_in = i_low + j - 1 ! increases from i_low i_out = i_in + 1 ! always one more; ends at i_high f_con = i_out * contour_interval s_base = (f_con - f_low) / (f_high - f_low) x_base = x_low + s_base * (x_high - x_low) y_base = y_low + s_base * (y_high - y_low) inner = (f_con < f_mid) IF (inner) THEN IF (f_mid /= f_low) THEN ! normal case s_far = (f_con - f_low) / (f_mid - f_low) ELSE ! f_mid == f_low; contour to (x_mid, y_mid) s_far = 1.0 END IF x_far = x_low + s_far * (x_mid - x_low) y_far = y_low + s_far * (y_mid - y_low) ELSE ! f_con >= f_mid IF (f_high /= f_mid) THEN ! normal case s_far = (f_con - f_mid) / (f_high - f_mid) ELSE ! f_high == f_mid == f_con s_far = 0.0 ! contour to (x_mid, y_mid) END IF x_far = x_mid + s_far * (x_high - x_mid) y_far = y_mid + s_far * (y_high - y_mid) END IF IF (j == 1) THEN ! 1st polygon IF ((group == 0).OR.(group == 1)) THEN ! doing colors f = (i_in + 0.5) * contour_interval CALL Set_Fill_by_Value (f, contour_interval, & & midspectrum_value, low_is_blue) CALL Plane_2_Sphere(x_low,y_low, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL New_L45_Path(5,uvec) CALL Plane_2_Sphere(x_base,y_base, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL Plane_2_Sphere(x_far,y_far, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) IF (.NOT.inner) THEN CALL Plane_2_Sphere(x_mid,y_mid, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) END IF CALL Plane_2_Sphere(x_low,y_low, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! doing colors now IF ((group == 0).OR.(group == 2)) THEN ! doing lines now IF ((f_con /= 0.0).OR.(.NOT.skip_0)) THEN CALL Set_Stroke_by_Value (f_con, contour_interval, & & midspectrum_value, low_is_blue) CALL Plane_2_Sphere(x_base,y_base, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL New_L45_Path(5,uvec) CALL Plane_2_Sphere(x_far,y_far, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! f_con /= 0, or zero contours desired END IF ! doing lines now ELSE ! j > 1; not first polygon IF ((group == 0).OR.(group == 1)) THEN ! doing colors f = (i_in + 0.5) * contour_interval CALL Set_Fill_by_Value (f, contour_interval, & & midspectrum_value, low_is_blue) CALL Plane_2_Sphere(x_old_base,y_old_base, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL New_L45_Path(5,uvec) CALL Plane_2_Sphere(x_base,y_base, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL Plane_2_Sphere(x_far,y_far, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) IF (inner.NEQV.old_inner) THEN CALL Plane_2_Sphere(x_mid,y_mid, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) END IF CALL Plane_2_Sphere(x_old_far,y_old_far, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL Plane_2_Sphere(x_old_base,y_old_base, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! doing colors now IF ((group == 0).OR.(group == 2)) THEN ! doing lines now IF ((f_con /= 0.0).OR.(.NOT.skip_0)) THEN CALL Set_Stroke_by_Value (f_con, contour_interval, & & midspectrum_value, low_is_blue) CALL Plane_2_Sphere(x_base,y_base, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL New_L45_Path(5,uvec) CALL Plane_2_Sphere(x_far,y_far, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! f_con /= 0, or zero contours desired END IF ! doing lines now END IF ! 1st polygon, or later one? IF (j == num_con) THEN ! add one more polygon; no more lines! IF ((group == 0).OR.(group == 1)) THEN ! doing colors f = (i_out + 0.5) * contour_interval CALL Set_Fill_by_Value (f, contour_interval, & & midspectrum_value, low_is_blue) CALL Plane_2_Sphere(x_base,y_base, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL New_L45_Path(5,uvec) CALL Plane_2_Sphere(x_high,y_high, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) IF (inner) THEN CALL Plane_2_Sphere(x_mid,y_mid, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) END IF CALL Plane_2_Sphere(x_far,y_far, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL Plane_2_Sphere(x_base,y_base, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! doing colors now END IF ! j == num_con !set memory for next loop x_old_base = x_base y_old_base = y_base x_old_far = x_far y_old_far = y_far old_inner = inner END DO ! j = 1, num_con IF ((f_low == f_mid).AND.(MOD(f_low, contour_interval) == 0.0)) THEN ! Special case; add lowest contour along element side. !(Note convention: a contour along an element side is ! shown if and only if the element contains higher values. ! This prevents double-plotting of contours in adjacent ! elements, which fails if contour are dashed because ! the dashes don't necessarily line up. ! The only defect of this convention is that a ridge ! exactly at a contour level and exactly along an ! element boundary will not receive a contour, but ! then numerical roundoff could have the same effect.) IF ((group == 0).OR.(group == 2)) THEN IF ((f_low /= 0.0).OR.(.NOT.skip_0)) THEN CALL Set_Stroke_by_Value (f_low, contour_interval, & & midspectrum_value, low_is_blue) CALL Plane_2_Sphere(x_low,y_low, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL New_L45_Path(5,uvec) CALL Plane_2_Sphere(x_mid,y_mid, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output CALL Great_to_L45(uvec) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! f_low /= 0, or zero contours desired END IF ! doing lines now END IF ! special low contour along element side END IF ! several colors; contours must be located END IF ! constant value, or (potentially) several colors? END SUBROUTINE Contour_3Node_Scalar_on_Sphere SUBROUTINE Contour_3Node_Sphere_Velocity(uvec1, uvec2, uvec3, & & v1t,v1p, v2t,v2p, v3t,v3p,& & low_value, high_value, & & contour_interval, & & midspectrum_value, & & low_is_blue, group) ! Contours a velocity field in a single spherical-triangle finite ! element using level-5 commands. ! Corner node locations (uvec1, uvec2, uvec3) are dimensionless ! unit vectors from the center of the planet to the surface, ! and must be given in in counterclockwise order. ! Element number l_ is used to signal to lower-level routines ! (Djxy and Del_Gjxy_del_thetaphi) when a new element is being ! considered; value is not important, but it must change ! whenever any one of uvec1, uvec2, or uvec3 changes. ! As a convenience(?) to the user, a new fake element number ! is internally generated on each call to this routine. ! Velocity components are in the (theta, phi) = (South, East) ! orthogonal local coordinate system: ! (v1t,v1p) = (v1theta,v1phi) = (v_South, v_East)@node#1, etc. ! Low_value and high_value are modified (if necessary) to ! encompass the ranges MIN(f1, f2, f3) to MAX(f1, f2, f3); ! after multiple calls to this routine, they may be used in ! CALL Bar_in_BottomLegend, or CALL Bar_in_RightLegend. ! Contour_interval is the delta_f used in contouring. ! Midspectrum_value is a value of f which should be assigned ! a mid-spectrum color. ! Low_is_blue (or dark grey) is a logical switch determining ! whether low values of f are assigned blue colors (.TRUE.) ! or red colors (.FALSE.). ! Group = 0, 1, or 2. This switch is used to arrange all contour ! lines into one graphics group, distinct from all colored areas, ! in case desired (so that contour lines can be dropped, or ! their width changed, during editing?). ! If group == 0, both colored areas and lines are drawn ! (most efficient, but does not give grouping). ! If group == 1, only colored areas are drawn. ! If group == 2, only contour lines are drawn. ! Thus, it takes twice as many calls, and twice as much computing, ! to achieve a neat graphical grouping. ! Note: In any case, CALL Begin_Group and CALL End_Group appear ! in the calling program (typically outside of a loop), not here! ! Be aware that this routine never changes the line width or ! style (dashed?); it only adjusts line color. IMPLICIT NONE REAL, DIMENSION(3), INTENT(IN) :: uvec1, uvec2, uvec3 REAL, INTENT(IN) :: v1t,v1p, v2t,v2p, v3t,v3p REAL, INTENT(INOUT) :: low_value, high_value REAL, INTENT(IN) :: contour_interval, midspectrum_value LOGICAL, INTENT(IN) :: low_is_blue INTEGER, INTENT(IN) :: group !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Local parameters, variables, and arrays: INTEGER, PARAMETER :: WorkSpace = 1000 ! size of working arrays; ! memory usage about (22 words * WorkSpace) LOGICAL :: any_saved ! any segments yet stored for this contour? CHARACTER*1 :: c1, code ! used to accept [Enter]; returned from In_Element REAL :: con_azim, con_azim1 ! radians clockwise from N REAL :: con_dE, con_dE1, con_dS, con_dS1 ! components (South, East) of along-contour unit vectors LOGICAL :: contour_hileft REAL, DIMENSION(3,3) :: corners ! 3 nodal uvecs INTEGER :: crossings ! count of contour crossings in one sidestep REAL, DIMENSION(3) :: cvec1, cvec2, cvec3 ! uvecs of initial,final.other node along edge REAL :: dvdfa, dvdfb ! d_vsize_d_fs; derivitive with respect to fraction of a sidestep REAL :: dvdE, dvdE1, dvdE2, dvdEb, dvdEm ! returned from Velocity_Size_in_3Node_Sphere REAL :: dvdr, dvdr1, dvdr2, dvdra, dvdrb ! d_vsize_d_radians along a certain arc REAL :: dvdS, dvdS1, dvdS2, dvdSb, dvdSm ! returned from Velocity_Size_in_3Node_Sphere REAL :: edge_azim, edge_azim1, edge_azim2, edge_azim3, edge_azimb ! radians, clockwise from N REAL :: element_high, element_low ! extremes of vsize in this element LOGICAL :: ending ! contour has gone Two_Pi around extremum REAL :: extremum REAL :: f, f1, f2, f3 ! fraction of sidestep where contour crosses; ! or fraction of integration step where contour goes out. REAL, DIMENSION(WorkSpace) :: f_list ! list of all f's where contour crosses in a sidestep REAL, DIMENSION(WorkSpace) :: f_value ! list of all vsize's where contour crosses in a sidestep REAL :: fs_peak ! fraction of sidestep at which parabola has extremum INTEGER :: good_segments ! = fall-back value of segments, if trouble LOGICAL :: got_one REAL :: grad_azim ! azimuth of gradient, radians clockwise from N REAL :: high_contour INTEGER :: i INTEGER :: i_high, i_low ! integer identifiers of range of contours trapped REAL :: in_azim ! points into element; radians clockwise from North INTEGER :: in_play ! number of segments used to bound one color REAL, PARAMETER :: instep = 0.05 ! integration step, fraction to element length INTEGER :: integrator_count INTEGER :: j, j_current, j_next INTEGER :: k REAL :: local_high, local_low ! extremes of vsize within one sidestep REAL :: low_contour REAL :: lowest_valid_f2 ! tolerance, to prevent recounting a starting point INTEGER :: match REAL :: midcolor_v ! velocity, mid-way through color step LOGICAL :: must_write ! does a segment need to be recorded? REAL :: nudge ! length of correction step, in radians up-gradient INTEGER :: number ! solutions of cubic equation REAL, DIMENSION(3) :: omega_uvec ! returnd by Turn_To REAL :: pdvdf, pdvdfa, pdvdfb ! slopes (d.v/d.f) of close-fitting parabola REAL :: radians_around ! keeps track of angle swept, up to Two_Pi, around extremum LOGICAL :: reverse ! contour segment needs to be reversed before use REAL :: s1, s2, s3, sa, sb ! internal variable, 0.0 <= s <= 1.0 in element REAL :: s1old, s2old, s3old ! memory variables; see above REAL :: scalar, scale LOGICAL, DIMENSION (WorkSpace) :: seg_contour ! is segment a contour? REAL, DIMENSION(3,WorkSpace) :: seg_from ! initial uvec LOGICAL, DIMENSION (WorkSpace) :: seg_hileft ! contour: high value to left? / edge: inside to left? INTEGER, DIMENSION (WorkSpace) :: seg_next ! id # of connected next segment, or 0 REAL, DIMENSION(3,WorkSpace) :: seg_pole ! uvec of pole of small-circle INTEGER, DIMENSION (WorkSpace) :: seg_previous ! id # of connected previous segment, or 0 REAL, DIMENSION(3,WorkSpace) :: seg_to ! final uvec INTEGER, DIMENSION (WorkSpace) :: seg_uses ! 2, 1, or 0 uses remaining to bound color REAL, DIMENSION (WorkSpace) :: seg_value ! = i *, or (i + 0.5) * contour_interval INTEGER :: segments ! small-circle arcs in library INTEGER :: side ! 1,2,3 for sides of element (# = starting node) INTEGER :: side_plus ! 2, 3, 1 INTEGER :: side_plus_2 ! 3, 1, 2 REAL :: side_radians ! length of side LOGICAL :: skip_zero_f2 ! warns that starting point of segment was already counted REAL :: small_angle ! in radians, about tvec_low or tvec_high REAL :: step ! integration step, radians REAL, PARAMETER :: sidestep = 0.10 ! step in s within which vsize is approx. a parabola REAL :: t LOGICAL :: this_way_hileft ! compare to contour_hileft INTEGER :: todo_count ! how many entry points of contours along edge? INTEGER :: todo_lowcount ! how many internal closed contours about minimum? REAL, DIMENSION (WorkSpace) :: todo_azimuth ! initial (inward) contour azimuth REAL, DIMENSION(3,WorkSpace) :: todo_from ! initial uvec along edge LOGICAL,DIMENSION(WorkSpace) :: todo_still ! remains to be integrated? REAL, DIMENSION (WorkSpace) :: todo_value ! vsize defining contour REAL :: use_step ! begins as step, then reduced in last 6 jumps INTEGER :: whole_steps ! number of full-size steps in steepest ascent/descent REAL, DIMENSION(3) :: tvec, tvec1, tvec2, tvec3, tvec4, tvecb, tvecm ! temporary uvecs REAL, DIMENSION(3) :: tvec_high, tvec_low ! positions of extrema in element REAL, DIMENSION(3) :: tvec_old ! memory of last position REAL :: variance REAL :: vsize, vsize1, vsize2, vsize3, vsizea, vsizeb, vsizem ! velocity magnitudes !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Subprograms called from here (esp. Gjxy, del_Gjxy_del_thetaphi) ! require an element number in order to decide if the call is about ! the same element as the last call, or a new one. Here we ! generate an artificial (but hopefully unique) element number ! each time this routine is called: INTEGER :: l_ = 10000 SAVE l_ l_ = l_ + 1 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! #-1: Check for case of no motion, dispose quickly: IF (MAX(ABS(v1t),ABS(v1p),ABS(v2t),ABS(v2p),ABS(v3t),ABS(v3p)) == 0.0) THEN CALL Contour_3Node_Scalar_on_Sphere(uvec1, uvec2, uvec3, & & 0.0, 0.0, 0.0, & & low_value, high_value, & & contour_interval, & & midspectrum_value, & & low_is_blue, group) RETURN END IF !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! #0: Check for very slow motions, dispose quickly: vsize1 = SQRT(v1t*v1t + v1p*v1p) vsize2 = SQRT(v2t*v2t + v2p*v2p) vsize3 = SQRT(v3t*v3t + v3p*v3p) element_low = MIN(vsize1, vsize2, vsize3) element_high = MAX(vsize1, vsize2, vsize3) IF (element_high <= contour_interval) THEN CALL Contour_3Node_Scalar_on_Sphere(uvec1, uvec2, uvec3, & & vsize1, vsize2, vsize3, & & low_value, high_value, & & contour_interval, & & midspectrum_value, & & low_is_blue, group) RETURN END IF !(Note: On a sphere, values are unlikely to be equal when not all 0.) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! #1: Begin building segment library with edge segments (arcs of ! great circles, but recorded with formalism of small circles). ! Also note entry points ("todo_") of internal contours. segments = 0 ! total known segments (edge and internal) todo_count = 0 ! internal contour entry points (2 per contour) corners(1:3,1) = uvec1(1:3) corners(1:3,2) = uvec2(1:3) corners(1:3,3) = uvec3(1:3) DO side = 1, 3 ! work along 3 sides of finite element side_plus = MOD(side,3) + 1 side_plus_2 = 6 - side - side_plus !length of this side: cvec1 = corners(1:3,side) cvec2 = corners(1:3,side_plus) side_radians = Arc(cvec1,cvec2) !check whether this side is a contour: CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & cvec1, & ! position input & vsize1, dvdS1, dvdE1) ! outputs CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & cvec2, & ! position input & vsize2, dvdS2, dvdE2) ! outputs edge_azim1 = Relative_Compass(cvec1, cvec2) edge_azim2 = Pi + Relative_Compass(cvec2, cvec1) dvdr1 = -dvdS1 * COS(edge_azim1) + dvdE1 * SIN(edge_azim2) dvdr2 = -dvdS2 * COS(edge_azim2) + dvdE2 * SIN(edge_azim2) variance = MAX(ABS(dvdr1),ABS(dvdr2)) * side_radians IF ((vsize1 == vsize2).AND.(MOD(vsize1,contour_interval) == 0.).AND.(variance < (0.01*contour_interval))) THEN !this side is a contour CALL Bump_check(segments) seg_contour(segments) = .TRUE. seg_value(segments) = vsize1 seg_uses(segments) = 1 ! (not like other contours in interior) seg_previous(segments) = 0 seg_next(segments) = 0 seg_from(1:3,segments) = cvec1(1:3) seg_to(1:3,segments) = cvec2(1:3) CALL Cross(cvec1, cvec2, tvec1) CALL Make_Uvec(tvec1, tvec2) seg_pole(1:3,segments) = tvec2(1:3) in_azim = edge_azim2 - Pi_over_2 ! turn 90 deg. left; inwards dvdr2 = -dvdS2 * COS(in_azim) + dvdE2 * SIN(in_azim) seg_hileft(segments) = (dvdr2 >= 0.0) ! Note: When contour ! is a zero contour, dvdr2 will be exactly 0. However, we ! know from prior elimination that V is not zero at the 3rd node, ! so in this case, seg_hileft must be true. ELSE ! normal case; this side not a contour ! check whether a contour enters at initial node IF (MOD(vsize1,contour_interval) == 0.0) THEN ! check azimuth, too skip_zero_f2 = .TRUE. ! we are already checking out this point edge_azim2 = edge_azim1 ! points from node 1 to node 2 cvec3(1:3) = corners(1:3, side_plus_2) edge_azim3 = Relative_Compass(cvec1, cvec3) ! points from 1 to 3 IF (edge_azim2 < edge_azim3) edge_azim2 = edge_azim2 + Two_Pi con_azim = Atan2f(dvdS1,dvdE1) IF (con_azim < edge_azim3) con_azim = con_azim + Two_Pi got_one = .FALSE. IF ((con_azim > edge_azim3).AND.(con_azim < edge_azim2)) THEN got_one = .TRUE. ELSE ! try other end of contour con_azim = con_azim - Pi IF (con_azim < edge_azim3) con_azim = con_azim + Two_Pi IF ((con_azim > edge_azim3).AND.(con_azim < edge_azim2)) THEN got_one = .TRUE. END IF END IF IF (got_one) THEN ! a contour enters here CALL Bump_check(todo_count) todo_from(1:3,todo_count) = cvec1(1:3) todo_value(todo_count) = vsize1 todo_azimuth(todo_count) = con_azim END IF ! got_one ELSE skip_zero_f2 = .FALSE. ! start of side was not a contour intersection END IF ! possible contour entry at initial node ! Work along edge, looking for contour entries (anywhere ! EXCEPT at initial and final nodes-- treated above). ! Ignore contours which osculate without crossing. ! (If they osculate from outside, we don't need to know ! about them. If from inside, we can integrate them ! past this point without stopping, to final exit. ! Osculating contours touch at local extrema of vsize ! along any one side, so be cautious when along-edge ! slope of vsize is very small!) ! Wherever a crossing is found, record in todo list, and ! also define another completed edge segment. ! Lastly, define residual edge segment, up to ! the final node. (This may be the whole edge!) tvec1 = cvec1 ! beginning point for next segment, when found sa = 0.0 ! beginning s for sidestep vsizea = vsize1 ! beginning vsize for sidestep dvdra = dvdr1 ! beginning along-side derivitive for sidestep sidestepping: DO WHILE (sa < 0.999) ! indefinite loop in steps of 'sidestep' or less ! Trial point (ending "b") is just for forming local parabola; ! not (in general) a candidate contour crossing point. sb = MIN(0.999, sa + sidestep) CALL GreatCircle_Point (cvec1, cvec2, sb, & ! inputs & tvecb, edge_azimb) ! outputs CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvecb, & ! position input & vsizeb, dvdSb, dvdEb) ! outputs local_high = MAX(vsizea, vsizeb) local_low = MIN(vsizea, vsizeb) dvdrb = -dvdSb * COS(edge_azimb) + dvdEb * SIN(edge_azimb) scale = side_radians * (sb - sa) ! radians in sidestep dvdfa = dvdra * scale dvdfb = dvdrb * scale !slopes of closest-fitting parabola, with same end points: pdvdfa = (vsizeb - vsizea) + 0.5 * (dvdfa - dvdfb) pdvdfb = (vsizeb - vsizea) + 0.5 * (dvdfb - dvdfa) IF ((pdvdfa * pdvdfb) < 0.0) THEN ! local extremum in this parabola fs_peak = pdvdfa / (pdvdfa - pdvdfb) ! 0. to 1., within sidestep extremum = vsizea + fs_peak * pdvdfa + 0.5 * fs_peak**2 * (pdvdfb - pdvdfa) local_high = MAX(local_high, extremum) local_low = MIN(local_low, extremum) element_high = MAX(element_high, extremum) element_low = MIN(element_low, extremum) END IF ! local extremum in this step i_low = Int_Above(local_low / contour_interval) ! integer IDs of range i_high = Int_Below(local_high / contour_interval) ! of contours trapped IF (i_high >= i_low) THEN ! trapped 1 or more contours crossings = 0 ! find and count all contour crossings in this sidestep DO i = i_low, i_high CALL Cubic_Roots(0.0, 0.5*(pdvdfb-pdvdfa), pdvdfa, vsizea-i*contour_interval, & ! input & number, f1, f2, f3) ! output !assemble list of crossings (many outside range!) IF (number >= 1) THEN CALL Bump_check(crossings) f_list(crossings) = f1 f_value(crossings) = i * contour_interval END IF IF (number == 2) THEN CALL Bump_check(crossings) f_list(crossings) = f2 f_value(crossings) = i * contour_interval END IF END DO ! on i, contour level !sort the contour crossings just found "in" (?) this sidestep CALL Sort_Lists (crossings, f_list, f_value) IF (skip_zero_f2) THEN !Take first 1.E-3 <= f <= 1., with non-zero slope; ! disregard the rest (will catch in next sidestep!) !The reason for the 1.E-3 limit is to avoid recounting ! the previous solution! (I have seen erroneous f2 = 3.E-5) lowest_valid_f2 = 0.001 ELSE !Take first 0.0 <= f <= 1., with non-zero slope; ! disregard the rest (will catch in next sidestep!) lowest_valid_f2 = 0.0 END IF got_one = .FALSE. ! (unless changed below) read_thru: DO j = 1, crossings f2 = f_list(j) IF ((f2 >= lowest_valid_f2).AND.(f2 <= 1.00)) THEN !check and reject osculations: pdvdf = pdvdfa + f2 * (pdvdfb - pdvdfa) IF (pdvdf /= 0.0) THEN got_one = .TRUE. vsize2 = f_value(j) EXIT read_thru END IF ! slope is not zero END IF ! acceptable f_list entry END DO read_thru ! j = 1, crossings ELSE ! didn't trap any contours in this sidestep got_one = .FALSE. END IF ! trapped 1 or more contours? IF (got_one) THEN s2 = sa + f2 * (sb - sa) CALL GreatCircle_Point (cvec1, cvec2, s2, & ! inputs & tvec2, edge_azim2) ! outputs CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec2, & ! position input & vsize2, dvdS2, dvdE2) ! outputs dvdr2 = -dvdS2 * COS(edge_azim2) + dvdE2 * SIN(edge_azim2) !record a starting point for contour CALL Bump_check(todo_count) todo_from(1:3,todo_count) = tvec2(1:3) todo_value(todo_count) = contour_interval * Int_Below(vsize2/contour_interval + 0.5) IF (s2 < 0.5) THEN ! compute edge azimuth using goal point edge_azim = Relative_Compass(tvec2, cvec2) ELSE ! more than half-way along edge; refer to start point edge_azim = Pi + Relative_Compass(tvec2, cvec1) END IF in_azim = edge_azim - Pi_over_2 ! now pointing inward con_azim = Atan2f(dvdS2,dvdE2) IF ((COS(con_azim)*COS(in_azim) + SIN(con_azim)*SIN(in_azim)) > 0.0) THEN todo_azimuth(todo_count) = con_azim ELSE todo_azimuth(todo_count) = con_azim + Pi END IF !add an edge segment to the libarary CALL Bump_check(segments) seg_contour(segments) = .FALSE. tvec3(1:3) = 0.5 * (tvec1(1:3) + tvec2(1:3)) CALL Make_Uvec(tvec3, tvecm) CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvecm, & ! position input & vsizem, dvdSm, dvdEm) ! outputs seg_value(segments) = contour_interval * (0.5 + Int_Below(vsizem/contour_interval)) seg_uses(segments) = 1 seg_previous(segments) = 0 seg_next(segments) = 0 seg_from(1:3,segments) = tvec1(1:3) seg_to(1:3,segments) = tvec2(1:3) CALL Cross(cvec1, cvec2, tvec3) CALL Make_Uvec(tvec3, tvecm) seg_pole(1:3,segments) = tvecm(1:3) seg_hileft(segments) = .TRUE. !rename the endpoint as the next beginning point! tvec1 = tvec2 skip_zero_f2 = .TRUE. ! end point was a contour intersection !prepare memory for next sidestep sa = s2 vsizea = todo_value(todo_count) ! because vsize2 would be 15.997... dvdra = dvdr2 ELSE ! didn't find one !prepare memory for next sidestep sa = sb vsizea = vsizeb dvdra = dvdrb skip_zero_f2 = .FALSE. ! end point was not a contour intersection END IF ! got_one or didn't END DO sidestepping ! indefinite loop, stepping along side !Add final segment to complete the side: CALL Bump_check(segments) seg_contour(segments) = .FALSE. tvec3(1:3) = 0.5 * (tvec1(1:3) + cvec2(1:3)) CALL Make_Uvec(tvec3, tvecm) CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvecm, & ! position input & vsizem, dvdSm, dvdEm) ! outputs seg_value(segments) = contour_interval * (0.5 + Int_Below(vsizem/contour_interval)) seg_uses(segments) = 1 seg_previous(segments) = 0 seg_next(segments) = 0 seg_from(1:3,segments) = tvec1(1:3) seg_to(1:3,segments) = cvec2(1:3) CALL Cross(cvec1, cvec2, tvec3) CALL Make_Uvec(tvec3, tvec4) seg_pole(1:3,segments) = tvec4(1:3) seg_hileft(segments) = .TRUE. END IF ! side is/not a contour END DO ! side = 1, 3 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! #2: Integrate half of "todo" contours (crossing out ! out the other half where we exit), and add one or more ! segments to the seg_ library for each. DO i = 1, todo_count todo_still(i) = .TRUE. END DO step = instep * side_radians DO i = 1, todo_count IF (todo_still(i)) THEN ! not already done !initialize this integration tvec1(1:3) = todo_from(1:3,i) ! beginning for segment, when found con_azim1 = todo_azimuth(i) ! initial azim for segment, when found vsize1 = todo_value(i) ! contour value con_dS1 = -COS(con_azim1) ! used to check drift of contour con_dE1 = SIN(con_azim1) CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec1, & ! position input & vsize, dvdS, dvdE) ! outputs contour_hileft = ((con_dS1*dvdE - con_dE1*dvdS) > 0.0) tvec_old = tvec1 ! memory of moving integration point CALL In_Element (l_, uvec1, uvec2, uvec3, & ! initial internal coordinates & tvec_old, code, s1old, s2old, s3old) con_azim = con_azim1 ! shifting contour azimuth any_saved = .FALSE. ! determines linkage to previous segment integrator_count = 0 integrating: DO ! indefinite loop, tracing contour to end integrator_count = integrator_count + 1 ! guard against infinite loop !predictor step CALL Turn_To (con_azim, tvec_old, step, & ! inputs & omega_uvec, tvec) ! outputs CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec, & ! position input & vsize, dvdS, dvdE) ! outputs !corrector step IF (vsize /= vsize1) THEN dvdr = SQRT(dvdS*dvdS + dvdE*dvdE) IF (dvdr /= 0.0) THEN ! correction possible nudge = (vsize1 - vsize) / dvdr ! in radians, up-gradient grad_azim = Atan2f(dvdE, -dvdS) CALL Turn_To (grad_azim, tvec, nudge, & ! inputs & omega_uvec, tvec) ! tvec is replaced! CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec, & ! position input & vsize, dvdS, dvdE) ! outputs END IF ! correction possible END IF ! corrector needed !decide if contour has ended (gone out). !(Note that 'B' could be an osculation and is ignored.) CALL In_Element (l_, uvec1, uvec2, uvec3, & & tvec, code, s1, s2, s3) IF (code == 'O') THEN ! shorten the step IF (s1old > s1) THEN f1 = MIN(1., s1old / (s1old - s1)) ELSE f1 = 1. END IF IF (s2old > s2) THEN f2 = MIN(1., s2old / (s2old - s2)) ELSE f2 = 1. END IF IF (s3old > s3) THEN f3 = MIN(1., s3old / (s3old - s3)) ELSE f3 = 1. END IF f = MIN(f1, f2, f3) CALL GreatCircle_Point (tvec_old, tvec, f, & ! inputs & tvec, edge_azimb) ! tvec replaced! CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec, & ! position input & vsize, dvdS, dvdE) ! outputs END IF ! step must be shortened !Update con_azim (making sure we get the right end, !which can be tricky when a contour passes the pole). con_azim = Atan2f(dvdS, dvdE) con_dS = -COS(con_azim) con_dE = SIN(con_azim) scalar = con_dS*con_dS1 + con_dE*con_dE1 ! used to watch drift in azimuth this_way_hileft = ((con_dS*dvdE - con_dE*dvdS) > 0.0) IF (this_way_hileft.NEQV.contour_hileft) THEN ! go other way con_azim = con_azim + Pi con_dS = -con_dS con_dE = -con_dE scalar = -scalar END IF ! other direction !Decide whether to record a segment: must_write = ((code == 'O').OR. & & (scalar <= 0.7071)) & ! changed direction by 45 d. & .AND. & & ((tvec(1) /= tvec1(1)).OR.(tvec(2) /= tvec1(2)).OR.(tvec(3) /= tvec1(3))) !NEVER record a zero-length segment !(possible result of shortening); !it has no small-circle pole! IF (must_write) THEN !record the segment CALL Bump_check(segments) seg_contour(segments) = .TRUE. seg_value(segments) = vsize1 seg_uses(segments) = 2 IF (any_saved) THEN ! link with previous seg_previous(segments) = segments - 1 seg_next(segments - 1) = segments ELSE ! cannot link yet seg_previous(segments) = 0 END IF ! linkage possible seg_next(segments) = 0 ! [sic; same either way] seg_from(1:3,segments) = tvec1(1:3) seg_to(1:3,segments) = tvec(1:3) CALL Small_Pole(tvec1,con_dS1,con_dE1,tvec, & & tvec4) seg_pole(1:3,segments) = tvec4(1:3) seg_hileft(segments) = contour_hileft any_saved = .TRUE. END IF !segment is being written IF (code == 'O') THEN ! end of this countour todo_still(i) = .FALSE. !Check off starting point we ended at! !Note: Must be careful, because sometimes this ! expected starting point is absent due to the ! anti-osculation rule! Therefore, look for closest ! point, and THEN check whether the point is still active ! and if contour values match ! (instead of crossing off closest active point with matching ! contour value, which could be "far" away!) variance = 999. ! "huge"; intended that we will find smaller match = i ! (not expected to last) DO j = 1, todo_count ! look for a match IF (j == i) CYCLE t = (todo_from(1,j)-tvec(1))**2 + & & (todo_from(2,j)-tvec(2))**2 + & & (todo_from(3,j)-tvec(3))**2 IF (t < variance) THEN variance = t match = j END IF ! new low in separation**2 END DO ! j = 1, todo_count (looking for closest) IF (todo_still(match)) THEN ! only consider active entries IF (ABS(todo_value(match) - vsize1) < 0.1 * contour_interval) THEN todo_still(match) = .FALSE. !revise end point of segment to be the point just crossed off: tvec(1:3) = todo_from(1:3,match) seg_to(1:3,segments) = tvec(1:3) !revise pole of segment: CALL Small_Pole(tvec1,con_dS1,con_dE1,tvec, & & tvec4) seg_pole(1:3,segments) = tvec4(1:3) END IF ! contour level of "match" agrees END IF ! "match" not crossed off yet !---------------- EXIT integrating !---------------- END IF ! came to end of contour !if we are here, contour is continuing IF (must_write) THEN ! just ended a segment !update beginning-of-segment variables tvec1 = tvec con_azim1 = con_azim con_dS1 = con_dS con_dE1 = con_dE END IF !segment was just ended !memory, for next step in integration path tvec_old = tvec s1old = s1 s2old = s2 s3old = s3 !guard against infinite loop IF (integrator_count > 1000) THEN WRITE (*,"(/' ERROR: Integration of contour failed in element ',I6)") l_ WRITE (*,"( ' This element will not be colored/shaded/contoured.')") WRITE (*,"( ' This is not a problem unless the element is in the map window.')") WRITE (*,"( ' If it is, and there is a hole in the map, I suggest')") WRITE (*,"( ' that next time you use the bitmap option for this mosaic.')") CALL Press_Enter RETURN END IF END DO integrating ! one contour END IF ! not already done END DO ! i = 1, todo_count !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! #3: Build colored areas by assembling segments from library. IF ((group == 0).OR.(group == 1)) THEN i_low = Int_Below(element_low / contour_interval) i_high = Int_Above(element_high / contour_interval) - 1 DO i = i_low, i_high ! different colors/patterns midcolor_v = (i + 0.5) * contour_interval CALL Set_Fill_by_Value (midcolor_v, contour_interval, & & midspectrum_value, low_is_blue) in_play = 0 ! will count segments relevant to this color DO j = 1, segments todo_still(j) = (ABS(seg_value(j) - midcolor_v) < (0.75 * contour_interval)) & & .AND.(seg_uses(j) >= 1) !this array now marks segments which are "in play" IF (todo_still(j)) THEN in_play = in_play + 1 IF (seg_contour(j)) THEN ! Check whether it needs to be reversed? reverse = ((.NOT.seg_hileft(j)).AND.(seg_value(j) < midcolor_v)) & & .OR. ((seg_hileft(j)).AND.(seg_value(j) > midcolor_v)) IF (reverse) THEN k = seg_previous(j) seg_previous(j) = seg_next(j) seg_next(j) = k tvec(1:3) = seg_from(1:3,j) seg_from(1:3,j) = seg_to(1:3,j) seg_to(1:3,j) = tvec(1:3) seg_pole(1:3,j) = -seg_pole(1:3,j) seg_hileft(j) = .NOT.seg_hileft(j) END IF ! reverse END IF ! it is a contour END IF ! segment is in-play END DO ! j = 1, segments (initial scan) areas: DO WHILE (in_play >= 1) get_first: DO j = 1, segments IF (todo_still(j)) THEN j_current = j tvecb(1:3) = seg_from(1:3,j) !note: tvecb will remain the beginning point CALL New_L45_Path(5,tvecb) EXIT get_first END IF END DO get_first ! j = 1, segments; finding any in-play for a start linking : DO WHILE (in_play >=1) ! draw current segment, mark off, and decrement counters tvecm(1:3) = seg_pole(1:3,j_current) tvec2(1:3) = seg_to(1:3,j_current) CALL Small_to_L45(tvecm,tvec2) todo_still(j_current) = .FALSE. ! no longer in-play in_play = in_play - 1 seg_uses(j_current) = seg_uses(j_current) - 1 ! a life used up ! look for next segment? IF (seg_next(j_current) > 0) THEN j_next = seg_next(j_current) ELSE ! a search is neccessary, for point closest to tvec2 !is any start point closer than the beginning point? variance = (tvec2(1)-tvecb(1))**2 +(tvec2(2)-tvecb(2))**2 +(tvec2(3)-tvecb(3))**2 j_next = 0 ! to mark beginning point, if none closer found DO j = 1, segments IF (todo_still(j)) THEN IF (seg_previous(j) == 0) THEN tvec1(1:3) = seg_from(1:3,j) t = (tvec1(1)-tvec2(1))**2 +(tvec1(2)-tvec2(2))**2 +(tvec1(3)-tvec2(3))**2 IF (t < variance) THEN variance = t j_next = j END IF END IF ! candidate is not preceded END IF ! candidate is in-play END DO ! j = 1, segments; seaching for next IF (j_next == 0) EXIT linking ! since not connected, perhaps a short great-circle arc? tvec1(1:3) = seg_from(1:3,j_next) !GPBdebug IF ((tvec1(1) /= tvec2(1)).OR.(tvec1(2) /= tvec2(2)).OR.(tvec1(3) /= tvec2(3))) THEN !GPBdebug CALL Great_to_L45(tvec1) !GPBdebug END IF ! small link necessary !I commented these out when it appeared that extremely short (1.E-7 radians) !great-circles were causing abends way down inside Process_L45_Paths. END IF ! found next easily, or had to search? !prepare to loop j_current = j_next END DO linking CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END DO areas END DO ! i = i_low, i_high: color indeces END IF ! drawing colored/patterned areas now !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! #4: Draw contour lines for all contours in library. IF ((group == 0).OR.(group == 2)) THEN DO i = 1, segments IF (seg_contour(i)) THEN CALL Set_Stroke_by_Value (seg_value(i), contour_interval, & & midspectrum_value, low_is_blue) tvec(1:3) = seg_from(1:3,i) CALL New_L45_Path(5,tvec) tvec1(1:3) = seg_pole(1:3,i) tvec2(1:3) = seg_to(1:3,i) CALL Small_to_L45(tvec1,tvec2) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! this segment is a contour END DO ! i = 1, segments END IF ! drawing contour lines now !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! #5: Search element for interal extrema > or < than at edges, and ! find initial points for totally-internal contours (new todo_). !Begin new todo list todo_count = 0 !find lowest starting point- - - - - - - - - - local_low = seg_value(1) i_low = 1 low_contour = element_high ! (not!) DO i = 1, segments ! sic; see below IF (seg_value(i) < local_low) THEN local_low = seg_value(i) i_low = i END IF IF (seg_contour(i)) low_contour = MIN(low_contour, seg_value(i)) END DO ! search for lowest segment !starting point for steepest descent tvec1(1:3) = seg_from(1:3,i_low) CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec1, & ! position input & vsize1, dvdS1, dvdE1) ! outputs whole_steps = Int_Above(1.0 / instep) ! enough steps to cross element use_step = step winding_down: DO j = 1, (whole_steps + 8) ! steepest-descent steps IF (j > whole_steps) use_step = 0.6 * use_step grad_azim = Atan2f(dvdE1, -dvdS1) CALL Turn_To (grad_azim, tvec1, -use_step, & ! step back = down & omega_uvec, tvec2) ! tvec2 is new position CALL In_Element (l_, uvec1, uvec2, uvec3, & & tvec2, code, s1, s2, s3) IF (code == 'O') THEN ! there is no internal minimum! todo_count = 0 EXIT winding_down END IF ! path went out CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec2, & ! position input & vsize2, dvdS2, dvdE2) ! outputs IF (vsize2 <= (low_contour - contour_interval)) THEN ! Found 1 or more points i_low = Int_Above(vsize2 / contour_interval) i_high = NINT(low_contour / contour_interval) - 1 DO i = i_high, i_low, -1 CALL Bump_check(todo_count) todo_still(todo_count) = .TRUE. !(this flag now marks a contour about the low) todo_value(todo_count) = i * contour_interval f = (todo_value(todo_count) - vsize1) / (vsize2 - vsize1) CALL GreatCircle_Point (tvec1, tvec2, f, & ! inputs & tvec, edge_azim) ! outputs todo_from(1:3,todo_count) = tvec(1:3) CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec, & ! position input & vsize, dvdS, dvdE) ! outputs grad_azim = Atan2f(dvdE, -dvdS) todo_azimuth(todo_count) = grad_azim - Pi_over_2 ! counterclockwise around low END DO ! i = i_low, i_high low_contour = i_low * contour_interval END IF ! Found 1 or more new starting points! element_low = MIN(element_low, vsize2) !prepare to loop tvec1 = tvec2 vsize1 = vsize2 dvdS1 = dvdS2 dvdE1 = dvdE2 END DO winding_down ! j = 1, (whole_steps + 8): steepest-descent steps tvec_low = tvec2 ! save location of extreme low - - - - - -- - - - - - ! !Save current todo_count in case search for maximum goes out, fails. todo_lowcount = todo_count ! !find highest starting point- - - - - - - - - - - -- - - - - - - - - local_high = seg_value(1) i_high = 1 high_contour = element_low ! (not!) DO i = 1, segments ! sic; see below IF (seg_value(i) > local_high) THEN local_high = seg_value(i) i_high = i END IF IF (seg_contour(i)) high_contour = MAX(high_contour, seg_value(i)) END DO ! search for highest segment !starting point for steepest ascent tvec1(1:3) = seg_from(1:3,i_high) CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec1, & ! position input & vsize1, dvdS1, dvdE1) ! outputs whole_steps = Int_Above(1.0 / instep) ! enough steps to cross element use_step = step winding_up: DO j = 1, (whole_steps + 8) ! steepest-ascent steps IF (j > whole_steps) use_step = 0.6 * use_step grad_azim = Atan2f(dvdE1, -dvdS1) CALL Turn_To (grad_azim, tvec1, use_step, & ! step forward = up & omega_uvec, tvec2) ! tvec2 is new position CALL In_Element (l_, uvec1, uvec2, uvec3, & & tvec2, code, s1, s2, s3) IF (code == 'O') THEN ! there is no internal maximum! todo_count = todo_lowcount EXIT winding_up END IF ! path went out CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec2, & ! position input & vsize2, dvdS2, dvdE2) ! outputs IF (vsize2 >= (high_contour + contour_interval)) THEN ! Found 1 or more points i_low = NINT(high_contour / contour_interval) + 1 i_high = Int_Below(vsize2 / contour_interval) DO i = i_low, i_high CALL Bump_check(todo_count) todo_still(todo_count) = .FALSE. !(this flag now marks a contour about the high) todo_value(todo_count) = i * contour_interval f = (todo_value(todo_count) - vsize1) / (vsize2 - vsize1) CALL GreatCircle_Point (tvec1, tvec2, f, & ! inputs & tvec, edge_azim) ! outputs todo_from(1:3,todo_count) = tvec(1:3) CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec, & ! position input & vsize, dvdS, dvdE) ! outputs grad_azim = Atan2f(dvdE, -dvdS) todo_azimuth(todo_count) = grad_azim + Pi_over_2 ! counterclockwise around high END DO ! i = i_low, i_high high_contour = i_high * contour_interval END IF ! Found 1 or more new starting points! element_high = MAX(element_high, vsize2) !prepare to loop tvec1 = tvec2 vsize1 = vsize2 dvdS1 = dvdS2 dvdE1 = dvdE2 END DO winding_up ! j = 1, (whole_steps + 8): steepest-ascent steps tvec_high = tvec2 ! save location of extreme high !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! #6: Integrate all totally internal countours (new seg_). !clear and rebuild the library of segments segments = 0 IF (todo_count >= 1) THEN insiders: DO i = 1, todo_count !initialize this integration good_segments = segments ! in case of trouble (abandoning a contour) radians_around = 0.0 ! when it gets to Two_Pi, we are done tvec1(1:3) = todo_from(1:3,i) ! beginning for segment, when eventually written con_azim1 = todo_azimuth(i) ! initial azim for segment, when found vsize1 = todo_value(i) ! contour value [note: not exactly a contour, but agrees with todo_from!] con_dS1 = -COS(con_azim1) ! used to check drift of contour con_dE1 = SIN(con_azim1) tvec_old = tvec1 ! memory of moving integration point CALL In_Element (l_, uvec1, uvec2, uvec3, & ! initial internal coordinates & tvec_old, code, s1old, s2old, s3old) con_azim = con_azim1 ! shifting contour azimuth any_saved = .FALSE. ! determines linkage to previous segment reintegrating: DO ! indefinite loop, tracing contour to full circle !predictor step CALL Turn_To (con_azim, tvec_old, step, & ! inputs & omega_uvec, tvec) ! outputs CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec, & ! position input & vsize, dvdS, dvdE) ! outputs !corrector step IF (vsize /= vsize1) THEN dvdr = SQRT(dvdS*dvdS + dvdE*dvdE) IF (dvdr /= 0.0) THEN ! correction possible nudge = (vsize1 - vsize) / dvdr ! in radians, up-gradient grad_azim = Atan2f(dvdE, -dvdS) CALL Turn_To (grad_azim, tvec, nudge, & ! inputs & omega_uvec, tvec) ! tvec is replaced! CALL Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & tvec, & ! position input & vsize, dvdS, dvdE) ! outputs END IF ! correction possible END IF ! corrector needed !decide if contour has ended (gone out). !(Note that 'B' could be an osculation and is ignored.) CALL In_Element (l_, uvec1, uvec2, uvec3, & & tvec, code, s1, s2, s3) IF (code == 'O') THEN ! this should NOT happen; !if it does, abandon whole contour (all segments) segments = good_segments ! throwing out any on this contour CYCLE insiders END IF ! contour went out! abandon it! !Update con_azim (making sure we get the right end). con_azim = Atan2f(dvdS, dvdE) con_dS = -COS(con_azim) con_dE = SIN(con_azim) scalar = con_dS*con_dS1 + con_dE*con_dE1 IF (scalar < 0.0) THEN ! go other way con_azim = con_azim + Pi con_dS = -con_dS con_dE = -con_dE scalar = -scalar END IF ! other direction !Check for completion of full circle; ! find small_angle = tvec_old -- tvec_low/high -- tvec IF (todo_still(i)) THEN ! circling around a low small_angle = Relative_Compass(tvec_low, tvec_old) - & & Relative_Compass(tvec_low, tvec) ELSE ! circling around a high small_angle = Relative_Compass(tvec_high, tvec_old) - & & Relative_Compass(tvec_high, tvec) END IF ! circling a low or a high IF (small_angle < -Pi) small_angle = small_angle + Two_Pi IF (small_angle > Pi) small_angle = small_angle - Two_Pi radians_around = radians_around + ABS(small_angle) !(note: ABS is to also terminate contours which are "lost".) ending = (radians_around >= Two_Pi) !Decide whether to record a segment: !(note: Experience shows that 0.7071 is too low for scalar!) must_write = (ending.OR.(scalar <= 0.939)) & ! changed direction by 22 d. & .AND. & & ((tvec(1) /= tvec1(1)).OR.(tvec(2) /= tvec1(2)).OR.(tvec(3) /= tvec1(3))) !NEVER record a zero-length segment !(possible result of shortening); !it has no small-circle pole! IF (must_write) THEN !record the segment CALL Bump_check(segments) seg_contour(segments) = .TRUE. seg_value(segments) = vsize1 seg_uses(segments) = 1 ! we will layer discs, to avoid doughnut shapes! IF (any_saved) THEN ! link with previous seg_previous(segments) = segments - 1 seg_next(segments - 1) = segments ELSE ! cannot link yet seg_previous(segments) = 0 END IF ! linkage possible seg_next(segments) = 0 ! [sic; same either way] seg_from(1:3,segments) = tvec1(1:3) seg_to(1:3,segments) = tvec(1:3) CALL Small_Pole(tvec1,con_dS1,con_dE1,tvec, & & tvec4) seg_pole(1:3,segments) = tvec4(1:3) seg_hileft(segments) = .NOT.todo_still(i) ! new convention: we go ! counterclockwise, so hileft is true only around maxima any_saved = .TRUE. END IF ! must_write IF (ending) THEN ! end of this countour !---------------- EXIT reintegrating !---------------- END IF ! came to end of contour !if we are here, contour is continuing IF (must_write) THEN ! just ended a segment !update beginning-of-segment variables tvec1 = tvec con_azim1 = con_azim con_dS1 = con_dS con_dE1 = con_dE END IF !segment was just ended !memory, for next step in integration path tvec_old = tvec s1old = s1 s2old = s2 s3old = s3 END DO reintegrating ! steps within one contour END DO insiders ! i = 1, todo_count END IF ! any internal contours to be integrated !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! #7: Color in closed loops of totally-internal contours. ! If everything is working properly, then section (5) ! created these contours in order from mundane to extreme, ! and section (6) preserved this ordering when integrating ! segments. Thus, as we overlap discs of solid color, the ! smaller ones nearer the extrema should come out on top. IF ((group == 0).OR.(group == 1)) THEN i = 1 ! will count up to segments looping: DO WHILE (i <= segments) ! each pass draws one loop IF (seg_hileft(i)) THEN ! counterclockwise around a high midcolor_v = seg_value(i) + 0.5 * contour_interval ELSE ! counterclockwise around a low midcolor_v = seg_value(i) - 0.5 * contour_interval END IF ! around a high or a low? CALL Set_Fill_by_Value (midcolor_v, contour_interval, & & midspectrum_value, low_is_blue) tvec1(1:3) = seg_from(1:3,i) CALL New_L45_Path(5,tvec1) patching: DO tvecm(1:3) = seg_pole(1:3,i) tvec2(1:3) = seg_to(1:3,i) CALL Small_to_L45(tvecm,tvec2) IF (seg_next(i) > 0) THEN ! continue this loop i = i + 1 ELSE ! this loop is finished CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) EXIT patching END IF ! loop has more segments or not END DO patching ! together segments in one loop i = i + 1 ! consider next segment on future pass END DO looping ! different loops END IF ! drawing colored/patterned areas now !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! #8: Draw contour lines for totally-internal contours. IF ((group == 0).OR.(group == 2)) THEN DO i = 1, segments IF (seg_contour(i)) THEN CALL Set_Stroke_by_Value (seg_value(i), contour_interval, & & midspectrum_value, low_is_blue) tvec(1:3) = seg_from(1:3,i) CALL New_L45_Path(5,tvec) tvec1(1:3) = seg_pole(1:3,i) tvec2(1:3) = seg_to(1:3,i) CALL Small_to_L45(tvec1,tvec2) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! this segment is a contour END DO ! i = 1, segments END IF ! drawing contour lines now !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! #9: Update global extreme values found: low_value = MIN(low_value, element_low) high_value = MAX(high_value, element_high) CONTAINS ! repeated-use code of Contour_3Node_Sphere_Velocity SUBROUTINE Bump_check (segments) IMPLICIT NONE INTEGER, INTENT(INOUT) :: segments IF (segments < WorkSpace) THEN segments = segments + 1 ELSE WRITE (*,"(' ERROR: Space exhausted in Contour_3Node_Sphere_Velocity;')") WRITE (*,"(' increase parameter WorkSpace, or increase contour_interval.')") CALL Traceback END IF END SUBROUTINE Bump_check ! internal subr SUBROUTINE Small_Pole(uvec1, con_dS1, con_dE1, uvec2, & ! inputs & pole_uvec) ! output ! Find pole of small circle which departs uvec1 with ! initial horizontal 2-D unit vector (con_dS1, con_dE1) = ! (d_theta, d_phi) [with constant metric for d_phi] ! and arrives at uvec2. IMPLICIT NONE REAL, DIMENSION(3),INTENT(IN) :: uvec1, uvec2 REAL, INTENT(IN) :: con_dS1, con_dE1 REAL, DIMENSION(3), INTENT(OUT) :: pole_uvec REAL :: con_azim1, con_azim2, & & to_pole_azim1, to_pole_azim2, & & to_u2_azim1, to_u1_azim2, variation REAL, DIMENSION(3) :: result_uvec, vec1, vec2, vec3 con_azim1 = Atan2f(con_dE1, -con_dS1) to_pole_azim1 = con_azim1 - Pi_over_2 to_u2_azim1 = Relative_Compass(uvec1, uvec2) to_u1_azim2 = Relative_Compass(uvec2, uvec1) variation = con_azim1 - to_u2_azim1 con_azim2 = (to_u1_azim2 + Pi) - variation to_pole_azim2 = con_azim2 - Pi_over_2 CALL Turn_To (to_pole_azim1, uvec1, Pi_over_2, & ! inputs & vec1, result_uvec) CALL Turn_To (to_pole_azim2, uvec2, Pi_over_2, & ! inputs & vec2, result_uvec) !Now vec1 points to the pole of the great circle which holds ! the small-circle's radius to uvec1; ! vec2 points to the pole of the great circle which holds ! the small-circle's radius to uvec2. !The point where the two small-circle radii cross is ! perpendicular to both of them, and is the pole! CALL Cross(vec1, vec2, vec3) CALL Make_Uvec(vec3, pole_uvec) END SUBROUTINE Small_Pole ! internal subr END SUBROUTINE Contour_3Node_Sphere_Velocity SUBROUTINE Contour_6Node_Scalar_in_Plane (xy_6nodes, & ! coordinates of 6 nodes, in meters & f_6nodes, & ! 6 values of scalar, at these nodes & low_value, high_value, & ! (INOUT; will be updated) & contour_interval, & ! inputs... & midspectrum_value, & & low_is_blue, & & all_positive, & & group ) ! Contours a scalar in a single 6-node isoparametric planar finite ! element, using Level-3 graphical commands. ! The 6 node locations (xy_6nodes) are in meters from the ! origin of the map projection plane. ! Nodes are ordered corners-first, counter-clockwise; then ! midpoints, counter-clockwise, beginning ! with the midpoint between corner #1 and corner #2.) ! The six scalar values (f_6nodes) are given in the same order. ! Low_value and high_value are modified (if necessary) to ! encompass the range MIN(f_6nodes) to MAX(f_6nodes) ! and also any extremum found within the element; ! after multiple calls to this routine, they may be used in ! CALL Bar_in_BottomLegend, or CALL Bar_in_RightLegend. ! Contour_interval is the delta_f used in contouring. ! Midspectrum_value is a value of f which should be assigned ! a mid-spectrum color. ! Low_is_blue (or dark grey) is a logical switch determining ! whether low values of f are assigned blue colors (if .TRUE.) ! or red colors (if .FALSE.). ! Group = 0, 1, or 2. This switch is used to arrange all contour ! lines into one graphics group, distinct from all colored areas, ! if desired (so that contour lines can be dropped, or ! their width changed, during editing, for example). ! If group == 0, both colored areas and lines are drawn for this element. ! (This is most efficient, but does not give grouping.) ! (Also, in some cases, one-half of some contour lines will ! (be overlapped by the colored polygons of the adjacent element!) ! If group == 1, only colored areas are drawn. ! If group == 2, only contour lines are drawn. ! Thus, it takes twice as many calls, and twice as much computing, ! to achieve a neat graphical grouping. Still, this is recommended ! for more uniform and attractive contours, and best ease in editing. ! Note: In any case, CALL Begin_Group and CALL End_Group appear ! in the calling program (typically outside of a loop), not here! ! Be aware that this routine never changes the line width or ! style (dashed?); it only adjusts line color. !----------------------------------------------------------------------------- ! COMMENTS ON THE ALGORITHM: ! Because there is still some round-off error, any comparison of two numbers ! to see if they are "equal" allows a certain tolerance for numerical error. ! The special case of an element with only one color (and no contours) ! because all values in f_6nodes are equal is dealt with first. ! Next, I transform the scalar from a function of the 3 interdependent internal ! coordinates (s1, s2, s3; s1 + s2 + s3 == 1.00) to a general quadratic ! polynomial in two independent coordinates (s1, s2). This can be visualized ! as producing an equilateral right triangle with two equal sides of 1.00 ! along the s1 and s2 axes. At this point, I characterize the polynomial ! as being linear (planar), or singly-curved, or doubly-curved. In the latter ! case, it is further characterized as a bowl, dome, or hyperbolic saddle. ! Next, I transform the polynomial (and the element vertices) into (alpha, beta) ! coordinates by a linear transformation. In the linear case or singly-curved ! cases, the scalar is only a function of beta, and the contours are parallel ! to the alpha axis. In the bowl and dome cases, contours will be circles ! about the origin. In the hyperbolic-saddle case, the scalar is transformed ! so that the straight contours are alpha = +-beta. ! In this (alpha, beta) coordinate system I find intersections between each ! contour and the (linear) element sides, and represent contour segments by ! Bezier curves which cross the element in one step (except that contours ! circling around an extremum curve no more than 90 degrees in one step.) ! I then sort the points of contour intersection with the triangular element, ! and add non-contour Bezier curves (at this point, lines) to outline the ! element. ! Then I convert all control points of the Bezier curves to the (s1, s2) system ! by the inverse of the linear transform used previously, and then convert ! them to (x, y) [in meters, in the Level-3 map projection plane] by the ! nonlinear isoparametric transformation that (in general) bends the sides ! of the elements and all internal contours. ! Finally, I link contour and non-contour segments to outline colored areas, ! and/or also ink over all contour segments (depending on group = 1, 2, 3). ! Note that this algorithm is inexact in two ways: ! 1) Bezier curves cannot exactly represent the contours of a general ! quadratic polynomial (which are conic sections), although they can ! come so close that the unaided eye cannot tell the difference ! (e.g., circles in Adobe Illustrator are not really circles!) ! 2) A linear transformation of a Bezier curve by transforming its 4 ! control points is precise and exact. However, it does not work ! for a general quadratic (isoparametric) transformation. I have ! created a transformation which I GUESS is correct, by algebraically ! computing the azimuths and velocities of the control arms at each ! end using properties of the transformation at the end points (only); ! however, this has not been proven to be correct, and may produce ! small errors. (Perhaps finely-spaced contours might even cross!) ! However, contour locations and trends should be exact along element ! sides,and all areas should be closed (i.e., topology should be correct). ! ! NOTES to myself (to be read before changing program structure): ! (1) Element-side curves (%is_contour = F) are created in (x, y) space, ! using the s-type information in "around". Originally, they got their ! %half_steps value by sampling f(x, y). However, numerical error ! combined with projection error so that very short segments often ! got unexpected values, causing topological disaster. Now, while ! these element-side curves are still constructed in (x, y), they ! get their %half_steps values from the memory (in "real_steps" and ! "real_sense") of the values expected by their bounding contours. ! (The only exception is that full-side curves do not have a bounding ! contour, and so get their value from f(x, y); however, to avoid ! problems when this edge is a contour, we step into the element as ! far as necessary to get an f which is significantly different from ! a contour value.) ! (2) Improvement (1) above fixed the discrepancies in %half_steps between ! contours and element-side curves. Some discrepancies in end-point ! locations remain. These could be reduced by defining the element-side ! curves in (alpha, beta) space and projecting them. I have not done ! this yet because I fear that the approximate nature of the projection ! would introduce gaps between adjacent elements. However, it is ! something to try in the future if topological problems due to ! spatial gaps are a continuing problem. ! ! Peter Bird, UCLA, November-December 1999 !----------------------------------------------------------------------------- IMPLICIT NONE REAL, DIMENSION(2, 6), INTENT(IN) :: xy_6nodes ! (x, y) of each of 6 nodes, in meters REAL, DIMENSION(6), INTENT(IN) :: f_6nodes ! scalar values at these nodes REAL, INTENT(INOUT) :: low_value, high_value ! may be revised REAL, INTENT(IN) :: contour_interval, midspectrum_value LOGICAL, INTENT(IN) :: all_positive, low_is_blue INTEGER, INTENT(IN) :: group ! see comments above !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - INTEGER, PARAMETER :: max_curves = 312 ! Enough for max_contours = 103 (max_curves = 3 + 3 * max_contours) INTEGER, PARAMETER :: max_points = 210 ! Enough for max_contours = 103 (max_points = 4 + 2 * max_contours) INTEGER :: corner_number, crossings, current_halves, curve_count, & & i, i1, i2, i3, i4, i_best, i_first, & & i_flip, i_previous, i_start, i_step, i_stop, j, k, & & list_count, mside, n, n1, n2, n3, n4, n5, n6, number, & & point_count, subdivisions, test_halves, x_level LOGICAL :: anticline, bowl, dome, correct_quadrant, extremum_inside, & & f_defined, fold, forward, found_first, got_one, got_three, got_two, got_zero, & & in_corner, inside, linear, outgoing, plunging, point_inside, proceed, & & saddle, trouble, x_contours LOGICAL, DIMENSION(3) :: ignore_corner REAL, PARAMETER :: dimensionless_curvature_noise = 1.0E-4 ! dimensionless (/s**2) REAL, PARAMETER :: dimensionless_slope_noise = 1.0E-4 ! dimensionless (/s) REAL, PARAMETER :: huge = 3.E38 REAL, PARAMETER :: internal_tolerance = 1.0E-4 ! position noise, in dimensionless (s1, s2, s3) units REAL, PARAMETER :: step_tolerance = 0.001 ! (in units of contour intervals) !GPBTypes REAL :: a, a_alpha, a_beta, a_save, alpha, alpha0, alpha1, & & alpha_center, alpha_end, alpha_first, alpha_last, alpha_max, alpha_min, & & alpha_start, anticontour_argument, anticontour_winding, apex, & & arc_length, arg1, arg2, arm01, arm23, arm_factor, arm_length, & & at0, at1, at2, at3, ax1, ax2, & & b, b_alpha, b_beta, beta, beta0, beta1, beta_center, beta_end, & & beta_first, beta_last, beta_max, beta_min, beta_start, & & bt0, bt1, bt2, bt3, bx, by, bx1, bx2, & & c, c_alpha, c_beta, chord, contour_argument, contour_winding, curvature, cx, cy, & & dads, dadt, dbds, dbdt, dfds1, dfds2, distance12, distance23, distance31, & & dimensional_curvature_noise, dimensional_slope_noise, ds1, ds2, ds3, & & f, f1, f2, f3, f4, f5, f6, & & f_a_1, f_a_2, f_b_1, f_b_2, f_ca, f_cbb, f_crr, & & f_c0, f_c1, f_c2, f_c11, f_c12, f_c22, & & f_inf, f_max, f_min, f_scale, f_sup, f_test, final_argument, & & final_dsdt, final_ds1dt, final_ds2dt, final_dxds1, final_dxds2, final_dyds1, final_dyds2, & & final_dxdt, final_dydt, final_dzdt, & & geometric_mean_curvature, gradient, gradient_argument, & & high_on_side, highest_argument, & & initial_argument, initial_dbda, initial_dsdt, initial_ds1dt, initial_ds2dt, initial_dxds1, initial_dxds2, & & initial_dyds1, initial_dyds2, initial_dxdt, initial_dydt, initial_dzdt, & & J11, J12, J21, J22, & & linear_argument, low_on_side, lowest_argument, & & old_s1, old_s2, old_s3, & & p1, p2, pc1, pc1_argument, pc2, pc2_argument, PhiVal, pivot_f, pivot_s1, pivot_s2, pivot_s3, & & quadratic_argument, & & r, r1, r2, r2_limit, r2_min, rotation, & & s1, s1_test, s2, s2_test, s3, s3_test, step_angle, & & t, t_save, test_argument, tolerance_meters, & & u1x, u1y, u2x, u2y, & & wedge_winding, & & x1, x2, x3, x4, x5, x6, xa, xb, xc, xm1, xm2, & & x_c0, x_c1, x_c2, x_c11, x_c12, x_c22, & & x_first, x_meters, x_now, x_start, & & y1, y2, y3, y4, y5, y6, ya, yb, yc, ym1, ym2, & & y_c0, y_c1, y_c2, y_c11, y_c12, y_c22, & & y_first, y_meters, y_now, y_start REAL, DIMENSION(6) :: a_list, an, bn, fn, t_list, t_vec, tls_vec, x_list, xn, y_list, yn REAL, DIMENSION(2, 0:3) :: contour ! a Bezier curve with control points #0, #1, #2, and #3. REAL, DIMENSION(2,2) :: out_matrix, back_matrix ! pure rotation matrices in 2-D; mutual inverses REAL, DIMENSION(max_points) :: around ! 0.0 to 2.99999; distance around element perimeter ! in dimensionless units of elapsed sides, measured ! counterclockwise from node 1. REAL, DIMENSION(max_points) :: real_steps ! records i = f / contour_interval of the contour ! that intersects at the associated value of "around". !(This should logically be an integer array, but I ! make it real so I can sort it with Sort_Lists.) REAL, DIMENSION(max_points) :: real_sense ! records sign of derivititive of the function ! on a counterclockwise path around the element !(SIGN(d_f / d_around)) at the associated contour ! point in "around". +1.0 indicated increasing, ! -1.0 indicates decreasing, and 0.0 is a code used ! for element-corner points meaning "unknown." !(This should logically be an integer array, but I ! make it real so I can sort it with Sort_Lists.) TYPE :: Bezier REAL, DIMENSION(0:3) :: x, y ! Control points; depending on the context ! at a particular point in this subprogram, ! they may be (alpha, beta), (s1, s2), or (x_meter, y_meters). LOGICAL :: is_contour ! T for internal curves; F for element-bounding curves. INTEGER :: half_steps ! Value of f along the curve expressed in units of ! (contour_interval/2.); contours have even values; ! edge segments usually have odd values, unless they lie on contours. LOGICAL :: high_to_left ! Determines sense of slope perpendicular to a contour. LOGICAL :: forward ! Is curve in forward direction still available for bounding colors? LOGICAL :: backward ! Is curve in backward direction still available for bounding colors? LOGICAL :: in_play ! Is curve still available for selection in this particular polygon? END TYPE Bezier TYPE (Bezier), DIMENSION(max_curves) :: curve !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Statement function: Phival(s1, s2, s3, f1, f2, f3, f4, f5, f6) = & & f1 * (-s1 + 2. * s1**2) + & & f2 * (-s2 + 2. * s2**2) + & & f3 * (-s3 + 2. * s3**2) + & & f4 * (4. * s1 * s2) + & & f5 * (4. * s2 * s3) + & & f6 * (4. * s3 * s1) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF (contour_interval <= 0.0) THEN WRITE (*, "(' ERROR: Input parameter contour_interval must be positive')") WRITE (*, "(' in Contour_6Node_Scalar_in_Plane')") CALL Traceback() END IF !Copy function values to avoid passing back any changes, and to shorten the names! !=================================================================================== ! NOTE: In the earlier version of this program (CONTEL, which integrated contours), ! I found that many topologically-impossible situations could be avoided by ! making sure that vertex values were never exactly on a contour. ! This avoided the problem of not knowing whether the intersection would ! be detected 0, 1, or 2 times. It also eliminated the problem of ! contours that touch at only the vertex point, and don't bound any areas. ! However, it compromised the accuracy of the graphics, and made ! debugging more confusing. So, I have tried to program this routine ! without compromising nodal values. If, in the future, this routine ! proves to be unacceptably buggy in use, then that would be a last resort. !================================================================================== DO j = 1, 6 xn(j) = xy_6nodes(1, j) yn(j) = xy_6nodes(2, j) fn(j) = f_6nodes(j) END DO !Also copy data to non-subscripted names, for speed in calling PhiVal: f1 = fn(1) ; f2 = fn(2) ; f3 = fn(3) ; f4 = fn(4) ; f5 = fn(5) ; f6 = fn(6) x1 = xn(1) ; x2 = xn(2) ; x3 = xn(3) ; x4 = xn(4) ; x5 = xn(5) ; x6 = xn(6) y1 = yn(1) ; y2 = yn(2) ; y3 = yn(3) ; y4 = yn(4) ; y5 = yn(5) ; y6 = yn(6) !Decide on scale size of element, in meters, and select criterion for path-closure: distance12 = SQRT((x1 - x2)**2 + (y1 - y2)**2) distance23 = SQRT((x2 - x3)**2 + (y2 - y3)**2) distance31 = SQRT((x3 - x1)**2 + (y3 - y1)**2) tolerance_meters = internal_tolerance * MAX(distance12, distance23, distance31) r2_limit = tolerance_meters**2 !Local (this element) extreme values, and decide on scale size for scalar: f_sup = MAX(f1, f2, f3, f4, f5, f6) f_inf = MIN(f1, f2, f3, f4, f5, f6) f_scale = MAX(ABS(f_sup),ABS(f_min)) dimensional_slope_noise = dimensionless_slope_noise * f_scale dimensional_curvature_noise = dimensionless_curvature_noise * f_scale !SPECIAL TREATMENT FOR CASE WHERE WHOLE ELEMENT IS KNOWN TO BE ONE SOLID COLOR: IF (f_sup == f_inf) THEN IF (all_positive) THEN f_test = MAX(f_sup, 0.01 * contour_interval) ELSE f_test = f_sup END IF IF (MOD(f_test, contour_interval) == 0.0) THEN ! use color of contour lines IF (group == 1) RETURN CALL Set_Stroke_by_Value (f_test, contour_interval, & & midspectrum_value, low_is_blue) !correct color has now been placed in ai_next_line_color; !now, use this color to set the fill color! CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = ai_next_line_color) ELSE ! use a color from the standard color scale: IF (group == 2) RETURN CALL Set_Fill_by_Value (f_test, contour_interval, midspectrum_value, low_is_blue) END IF CALL New_L3_Path (x_meters = x1, y_meters = y1) CALL Curve_Through_3Nodes_in_Plane(x1,y1, x4,y4, x2,y2) CALL Curve_Through_3Nodes_in_Plane(x2,y2, x5,y5, x3,y3) CALL Curve_Through_3Nodes_in_Plane(x3,y3, x6,y6, x1,y1) CALL End_L3_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) high_value = MAX(high_value, f_sup) low_value = MIN(low_value, f_inf) RETURN END IF !NORMAL CASE: Values in this element are NOT constant. !Flag any corners which lie on a contour, so they will be ignored. !(Our convention is that edge contours are not considered in the main logic ! because they do not have any effect on the definition of colored areas. ! Of course, they are added to the line-segments group at the very end.) !These flags will be considered in the cases: ! -linear variation of function w.r.t. s1, s2; ! -non-plunging fold variation of function w.r.t. s1, s2; ! -X-contours of a hyperbolically-varying function of s1, s2 ! (except that ignore_corner = F at a corner which is the X-point) !because these cases involve straight contours (in s1, s2 space). !These flags will NOT be considered in the cases: ! -plunging-fold variation of function; ! -domal or basinal variation of function; ! -non-X contours of a hyperbolically-varying function !because these cases do not have any contours which are straight lines !in s1, s2 space. ignore_corner = .FALSE. ! for all 3 corners, unless... IF ((f1 == f4).AND.(f4 == f2)) THEN ignore_corner(1) = .TRUE. ignore_corner(2) = .TRUE. END IF IF ((f2 == f5).AND.(f5 == f3)) THEN ignore_corner(2) = .TRUE. ignore_corner(3) = .TRUE. END IF IF ((f3 == f6).AND.(f6 == f1)) THEN ignore_corner(3) = .TRUE. ignore_corner(1) = .TRUE. END IF !Express the PhiVal function for the scalar in terms of independent s1 and s2, ! eliminating redundant s3: ! f(s1, s2) = f_c0 + f_c1 * s1 + f_c2 * s2 + f_c11 * s1**2 + f_c12 * s1 * s2 + f_c22 * s2**2 f_c0 = f3 f_c1 = -f1 - 3.0 * f3 + 4.0 * f6 f_c2 = -f2 - 3.0 * f3 + 4.0 * f5 f_c11 = 2.0 * f1 + 2.0 * f3 - 4.0 * f6 f_c12 = 4.0 * (f3 + f4 - f5 - f6) f_c22 = 2.0 * f2 + 2.0 * f3 - 4.0 * f5 !Avoid very distant origins of very gently curved surfaces that are artifacts of round-off: IF (ABS(f_c11) < dimensional_curvature_noise) f_c11 = 0.0 IF (ABS(f_c12) < dimensional_curvature_noise) f_c12 = 0.0 IF (ABS(f_c22) < dimensional_curvature_noise) f_c22 = 0.0 !Create equivalent restatements of the formulas for x and y: ! x(s1, s2) = x_c0 + x_c1 * s1 + x_c2 * s2 + x_c11 * s1**2 + x_c12 * s1 * s2 + x_c22 * s2**2 x_c0 = x3 x_c1 = -x1 - 3.0 * x3 + 4.0 * x6 x_c2 = -x2 - 3.0 * x3 + 4.0 * x5 x_c11 = 2.0 * x1 + 2.0 * x3 - 4.0 * x6 x_c12 = 4.0 * (x3 + x4 - x5 - x6) x_c22 = 2.0 * x2 + 2.0 * x3 - 4.0 * x5 ! y(s1, s2) = y_c0 + y_c1 * s1 + y_c2 * s2 + y_c11 * s1**2 + y_c12 * s1 * s2 + y_c22 * s2**2 y_c0 = y3 y_c1 = -y1 - 3.0 * y3 + 4.0 * y6 y_c2 = -y2 - 3.0 * y3 + 4.0 * y5 y_c11 = 2.0 * y1 + 2.0 * y3 - 4.0 * y6 y_c12 = 4.0 * (y3 + y4 - y5 - y6) y_c22 = 2.0 * y2 + 2.0 * y3 - 4.0 * y5 !Find the Jacobian matrix of second derivitives at the extremum (where gradient is zero): J11 = 2.0 * f_c11 J12 = f_c12 J21 = f_c12 J22 = 2.0 * f_c22 !Find the two principal values of the curvature, using the fact that | J11 J12 | ! | J21 J22 | ! is a tensor which multiplies a small offset from the extremum to ! give the gradient at the offset point, and that principal curvature ! directions are those along which the gradient is parallel to the offset. CALL Principal_Axes_22 (J11, J12, J22, & ! inputs & pc1, pc2, u1x,u1y, u2x,u2y) ! outputs !pc1 = more negative principal curvature (2nd derivitive along principal direction) !pc2 = more positive principal curvature pc1_argument = ATAN2(u1y, u1x) pc2_argument = pc1_argument + Pi_over_2 !in radians counterclockwise from the +s1 axis (toward the +s2 axis). !Characterize the quadratic polynomial as linear, singly-curved, bowl, dome, or hyperbolic-saddle: linear = (MAX(ABS(pc1),ABS(pc2)) <= dimensional_curvature_noise) fold = (.NOT.linear) .AND. ((ABS(pc1) <= dimensional_curvature_noise).OR.(ABS(pc2) <= dimensional_curvature_noise)) bowl = (.NOT.linear) .AND. (.NOT.fold) .AND. (pc1 > 0.0) ! both pc1, pc2 are positive dome = (.NOT.linear) .AND. (.NOT.fold) .AND. (pc2 < 0.0) ! both pc1, pc2 are negative saddle = (.NOT.linear) .AND. (.NOT.fold) .AND. ((pc1 * pc2) < 0.0) ! pc1 negative; pc2 positive !Find the contour segments WITHIN the element (not along boundaries), ! using different strategies in each case. What each strategy has in ! common is the definition of the (s1, s2) <==> (alpha, beta) transformation: ! (pivot_s1, pivot_s2) are the (s1, s2) coordinates of the (alpha, beta) origin; ! rotation is the angle (in radians) by which the (alpha, beta) system ! is rotated counterclockwise with respect to the (s1, s2) system. ! out_matrix(2,2) & back_matrix(2,2) are created from "rotation" alone. ! dads & dbds are the scale changes along the new alpha and beta axes, respectively. !Express segments as Bezier curves in (alpha, beta) coordinates, ! and make a list of edge-piercing points in array "around". curve_count = 0 ! number of Bezier segments (top dimension of: curve) point_count = 0 ! number of edge-piercing points (top dimension of: around, real_steps, real_sense) IF (linear) THEN dfds1 = f_c1 dfds2 = f_c2 gradient = SQRT(dfds1**2 + dfds2**2) gradient_argument = ATAN2F(dfds2, dfds1) !Define the coordinate transformation (s1, s2) <==> (alpha, beta) pivot_s1 = 0.0 ; pivot_s2 = 0.0 ! (these are arbitrary, so keep it simple) pivot_f = f_c0 ! = f3 rotation = gradient_argument - Pi_over_2 ! now uphill means +beta out_matrix(1, 1) = +COS(rotation) ; out_matrix(1, 2) = +SIN(rotation) ! for (s1, s2) ==> (alpha, beta) out_matrix(2, 1) = -SIN(rotation) ; out_matrix(2, 2) = +COS(rotation) back_matrix(1, 1) = +COS(rotation) ; back_matrix(1, 2) = -SIN(rotation) ! for (alpha, beta) ==> (s1, s2) back_matrix(2, 1) = +SIN(rotation) ; back_matrix(2, 2) = +COS(rotation) dads = 1.0 ; dbds = 1.0 ! (no need for stretching; keep it a simple rotation) !Transform the 3 corner nodes: CALL S1S2_2_AlphaBeta(1.0, 0.0, an(1), bn(1)) CALL S1S2_2_AlphaBeta(0.0, 1.0, an(2), bn(2)) CALL S1S2_2_AlphaBeta(0.0, 0.0, an(3), bn(3)) alpha_min = MIN(an(1), an(2), an(3)) - 1.0 ! (-1 to be SURE line is long enough to touch sides) alpha_max = MAX(an(1), an(2), an(3)) + 1.0 ! (+1 to be SURE line is long enough to touch sides) !The scalar function is now: f(beta) = pivot_f + gradient * beta !Figure out how many horizontal contours are needed: f_min = MIN(fn(1), fn(2), fn(3)) f_max = MAX(fn(1), fn(2), fn(3)) i1 = Int_Above(f_min / contour_interval) IF (f_min == (i1 * contour_interval)) i1 = i1 + 1 i2 = Int_Below(f_max / contour_interval) IF (f_max == (i2 * contour_interval)) i2 = i2 - 1 IF (i2 >= i1) THEN ! at least one contour cuts the interior linear_contours: DO i = i1, i2 f = i * contour_interval beta = (f - pivot_f) / gradient got_one = .FALSE. ! initialize search got_two = .FALSE. DO mside = 1, 3 n1 = mside n2 = MOD(mside, 3) + 1 CALL X_Marks (an(n1),bn(n1), an(n2),bn(n2), & ! line a & alpha_min,beta, alpha_max,beta, & ! line b & crossings, ax1,bx1, ax2,bx2, f_a_1, f_a_2, f_b_1, f_b_2) IF (crossings == 2) THEN ! this contour equals one side of triangle IF (got_one.AND.(.NOT.got_two)) point_count = point_count - 1 CYCLE linear_contours ! after cleaining up any orphans END IF IF (crossings == 1) THEN !Record edge-crossing point: !(note: it will be erased later if we never got_two) point_count = Increment_Point_Count() around(point_count) = mside - 1 + f_a_1 real_steps(point_count) = i IF (bn(n2) > bn(n1)) THEN ! side has beta increasing, so f is increasing real_sense(point_count) = +1.0 ELSE real_sense(point_count) = -1.0 END IF IF (got_one) THEN ! this will make the second got_two = .TRUE. alpha_end = ax1 curve_count = Increment_Curve_Count() curve(curve_count)%x(0) = alpha_start curve(curve_count)%y(0) = beta curve(curve_count)%x(1) = alpha_start + (alpha_end - alpha_start) / 3.0 curve(curve_count)%y(1) = beta curve(curve_count)%x(2) = alpha_end - (alpha_end - alpha_start) / 3.0 curve(curve_count)%y(2) = beta curve(curve_count)%x(3) = alpha_end curve(curve_count)%y(3) = beta curve(curve_count)%is_contour = .TRUE. curve(curve_count)%half_steps = 2 * i curve(curve_count)%high_to_left = (alpha_end > alpha_start) curve(curve_count)%forward = .TRUE. curve(curve_count)%backward = .TRUE. curve(curve_count)%in_play = .FALSE. CYCLE linear_contours ELSE ! this is the first found got_one = .TRUE. alpha_start = ax1 END IF ! got_one (plus one more makes two), or else this is the first END IF ! got another (single) crossing END DO ! mside = 1, 3; looking for two crossings IF (got_one.AND.(.NOT.got_two)) point_count = point_count - 1 END DO linear_contours ! i = i1, i2 ; contours cutting interior END IF ! at least one contour cuts the interior ELSE IF (fold) THEN anticline = (ABS(pc1) > ABS(pc2)) ! alternative is "syncline" IF (anticline) THEN ! pc1 is the quadratic direction quadratic_argument = pc1_argument f_cbb = 0.5 * pc1 ELSE ! syncline; ABS(pc2) is larger, and pc2 is positive quadratic_argument = pc2_argument f_cbb = 0.5 * pc2 END IF linear_argument = quadratic_argument - Pi_over_2 ! the linear gradient will be along the alpha axis gradient = COS(linear_argument) * f_c1 + SIN(linear_argument) * f_c2 ! and this should be constant over all (s1, s2) plunging = (ABS(gradient) > dimensional_slope_noise) rotation = quadratic_argument - Pi_over_2 ! the quadratic_argument will along the beta axis IF (plunging.AND.((gradient * f_cbb) > 0.0)) THEN ! rotate coordinates another 180, so that contours are like: ((( ---> +alpha rotation = rotation + Pi quadratic_argument = quadratic_argument + Pi linear_argument = linear_argument + Pi gradient = -gradient END IF ! need to rotate coordinates another 180 degrees !The gradient perpendicular to the fold axis is: ! dfdb = COS(quadratic_argument) * dfds1 + SIN(quadratic_argument) * dfds2 = ! COS(quadratic_argument) * (f_c1 + 2.0 * f_c11 * s1 + f_c12 * s2) ! +SIN(quadratic_argument) * (f_c2 + 2.0 * f_c22 * s2 + f_c12 * s1). !This is zero along the line: ! (2.0 * f_c11 * COS() + f_c12 * SIN()) * s1 + (2.0 * f_c22 * SIN() + f_c12 * COS()) * s2 = -(f_c1 * COS() + f_c2 * SIN()). !And, for a general line, a * s1 + b * s2 = c, the closest point to the origin is ! determined from either s1 = c / (a + b**2/a) OR s2 = c / (b + a**2/b), ! with the choice depending on whether a or b has larger absolute value. a = 2.0 * f_c11 * COS(quadratic_argument) + f_c12 * SIN(quadratic_argument) b = 2.0 * f_c22 * SIN(quadratic_argument) + f_c12 * COS(quadratic_argument) c = -(f_c1 * COS(quadratic_argument) + f_c2 * SIN(quadratic_argument)) !Define the coordinate transformation (s1, s2) <==> (alpha, beta) IF (ABS(a) > ABS(b)) THEN pivot_s1 = c / (a + b**2/a) IF (b /= 0.0) THEN pivot_s2 = (c - a * pivot_s1) / b ELSE ! b == 0.0; above formula would be 0.0/0.0 pivot_s2 = 0.0 END IF ELSE ! use more stable solution for large b: pivot_s2 = c / (b + a**2/b) IF (a /= 0.0) THEN pivot_s1 = (c - b * pivot_s2) / a ELSE ! a == 0.0; above formula would be 0.0/0.0 pivot_s1 = 0.0 END IF END IF ! choice of solution method pivot_s3 = 1.0 - pivot_s1 - pivot_s2 pivot_f = PhiVal(pivot_s1, pivot_s2, pivot_s3, f1, f2, f3,f4, f5, f6) f_sup = MAX(f_sup, pivot_f) f_inf = MIN(f_inf, pivot_f) out_matrix(1, 1) = +COS(rotation) ; out_matrix(1, 2) = +SIN(rotation) ! for (s1, s2) ==> (alpha, beta) out_matrix(2, 1) = -SIN(rotation) ; out_matrix(2, 2) = +COS(rotation) back_matrix(1, 1) = +COS(rotation) ; back_matrix(1, 2) = -SIN(rotation) ! for (alpha, beta) ==> (s1, s2) back_matrix(2, 1) = +SIN(rotation) ; back_matrix(2, 2) = +COS(rotation) dads = 1.0 ; dbds = 1.0 ! (no need for stretching; keep it a simple rotation) !Transform the 3 corner nodes: CALL S1S2_2_AlphaBeta(1.0, 0.0, an(1), bn(1)) CALL S1S2_2_AlphaBeta(0.0, 1.0, an(2), bn(2)) CALL S1S2_2_AlphaBeta(0.0, 0.0, an(3), bn(3)) IF (plunging) THEN ! contours will be parabolas ! The function is: f(alpha, beta) = pivot_f + gradient * alpha + f_cbb * beta**2 ! and its contours are parabolas which open on the +alpha side: ((( ---> +alpha ! either because (gradient > 0, f_cbb < 0) or (gradient < 0, f_cbb > 0). ! Either way, the equation for one contour is: alpha = (1.0 / gradient) * (f - pivot_f - f_cbb * beta**2). ! ! Find range of values along element sides, which is also range of contours: CALL SixNode_Boundary_Range (fn, f_inf, f_sup) i1 = Int_Above(f_inf / contour_interval) IF (f_inf == (i1 * contour_interval)) i1 = i1 + 1 i2 = Int_Below(f_sup / contour_interval) IF (f_sup == (i2 * contour_interval)) i2 = i2 - 1 IF (i2 >= i1) THEN ! at least one contour intersects this element alpha_max = MAX(an(1), an(2), an(3)) + 1.0 ! alpha value for open ends of ( - shaped contours parabolic_contours: DO i = i1, i2 f = i * contour_interval alpha_min = (f - pivot_f) / gradient ! turning point of contour, at beta == 0 beta_max = SQRT((f - pivot_f - gradient * alpha_max) / f_cbb) ! upper end of parabola beta_min = - beta_max ! lower end of parabola !Determine cubic-polynomials of t which define the Bezier contour: a_alpha = 0.0 ! because contour is quadratic, not cubic b_alpha = 4.0 * (alpha_max - alpha_min) c_alpha = -b_alpha ! a coincidence, for the special symmetry of this parabola contour(1,0) = alpha_max contour(1,1) = contour(1,0) + c_alpha / 3.0 contour(1,2) = contour(1,1) ! again, by special symmetry contour(1,3) = alpha_max !Variation of beta along contour is linear. !Notice that I define contour as going from high to low beta, so that it !swings about in a counterclockwise sense, always turning left. a_beta = 0.0 ; b_beta = 0.0 ; c_beta = beta_min - beta_max ! c_beta < 0.0 contour(2,0) = beta_max contour(2,1) = beta_max + c_beta / 3.0 contour(2,2) = beta_min - c_beta / 3.0 contour(2,3) = beta_min list_count = 0 ! begin list of intersections of contour with element sides DO mside = 1, 3 ! for each of the 3 sides of the element, call Sateh n1 = mside ! index of initial node n2 = MOD(mside, 3) + 1 ! index of final node CALL Sateh (contour(1,0),contour(2,0), contour(1,1),contour(2,1), contour(1,2),contour(2,2), contour(1,3),contour(2,3), & & an(n1),bn(n1), an(n2),bn(n2), & !input & number, t_vec, tls_vec, x_list, y_list) ! output !Ignore osculations: IF ((number == 2).AND.(ABS(tls_vec(1) - tls_vec(2)) < internal_tolerance)) CYCLE !but add any other intersections to the temporary tables: IF (number >= 1) THEN list_count = list_count + 1 t_list(list_count) = t_vec(1) ! save internal coordinate of contour a_list(list_count) = mside - 1.0 + tls_vec(1) ! future "around" value of intersection in element coordinates END IF ! (at least) one intersection found on this side IF (number >= 2) THEN ! there was a second intersection as well (there should never be 3 with one side!) list_count = list_count + 1 t_list(list_count) = t_vec(2) ! save internal coordinate of contour a_list(list_count) = mside - 1.0 + tls_vec(2) ! future "around" value of intersection in element coordinates END IF ! a second intersection was found on this side END DO ! mside = 1, 3; counting intersections !Because Sateh has been known to miss intersections at vertices, !make sure that any vertex intersections are in the list !(not worrying about redundancies, which are dealt with later): DO j = 1, 3 IF ((ABS(fn(j) - f) / contour_interval) < step_tolerance) THEN list_count = list_count + 1 a_list(list_count) = j - 1.0 ! future "around" value of intersection in element coordinates !Hard part: find internal variable t along contour at this point: t = (bn(j) - beta_max) / c_beta ! negative over negative t = MIN(MAX(t, 0.0), 1.0) t_list(list_count) = t ! save internal coordinate of contour END IF ! vertex f is on a contour END DO ! j = 1, 3 vertices IF (list_count > 0) THEN ! normally, this should be true! (However, experience shows that misses !result from small numerical errors in the case where a contour is just grazing one vertex; !there is no loss in ignoring these-- in fact, it is probably better to do so! !If intersection was with "end of 3rd side", rename this as "beginning of first side": DO j = 1, list_count IF (a_list(j) >= (3.0 - internal_tolerance)) a_list(j) = 0.0 END DO ! j = 1, list_count !Sort the lists in counterclockwise order about the element: IF (list_count >= 2) THEN CALL Sort_Lists (list_count, a_list, t_list) !Eliminate any double-counting of intersections with ends of sides: j = 2 ! initializing a loop whose limit may be adjusted DO WHILE (j <= list_count) IF (ABS(a_list(j) - a_list(j-1)) < internal_tolerance) THEN ! eliminate one of the counts list_count = list_count - 1 DO k = j, list_count ! replace these values with the next-higher values: a_list(k) = a_list(k + 1) t_list(k) = t_list(k + 1) END DO ! k = j, (reduced) list_count ELSE j = j + 1 END IF ! fixing a double-counted point (presumably at a vertex) END DO ! WHILE j <= list_count END IF ! list_count >= 2 !Now, check any points at vertices to see whether contour passes into the !interior of the element, or just skims by without entering! j = 1 ! initializing a loop whose limit may shrink DO WHILE (j <= list_count) n = NINT(a_list(j)) IF (ABS(a_list(j) - (n * 1.0)) < internal_tolerance) THEN ! a vertex intersection !Find argument (radians, counterclockwise from +alpha) of contour direction(s): t = t_list(j) dadt = 2.0 * b_alpha * t + c_alpha ! when a_alpha == 0.0 dbdt = 2.0 * b_beta * t + c_beta ! when a_beta == 0.0 contour_argument = ATAN2F(dbdt, dadt) ! toward t --> 1.0 on contour anticontour_argument = contour_argument + Pi ! toward t --> 0.0 on contour !Find arguments of sides, ASSUMING that triangle has been rotated but not flipped! n1 = MOD(n, 3) + 1 ! vertex node, 1, 2, or 3 n2 = MOD(n1, 3) + 1 ! node giving direction of lowest_argument n3 = MOD(n2, 3) + 1 ! node giving direction of highest_argument lowest_argument = ATAN2F((bn(n2) - bn(n1)), (an(n2) - an(n1))) highest_argument = ATAN2F((bn(n3) - bn(n1)), (an(n3) - an(n1))) wedge_winding = Winding(highest_argument - lowest_argument) contour_winding = Winding(contour_argument - lowest_argument) anticontour_winding = Winding(anticontour_argument - lowest_argument) inside = (contour_winding < (wedge_winding - internal_tolerance)).OR. & & ((anticontour_winding > internal_tolerance).AND. & & (anticontour_winding <= wedge_winding)) !Note: Assymetry of the decision rule above is because contours always bend to the left ! when traveling in the contour_argument direction. IF (inside) THEN ! move on j = j + 1 ELSE ! eliminate this intersection list_count = list_count - 1 DO k = j, list_count ! replace these values with the next-higher values: a_list(k) = a_list(k + 1) t_list(k) = t_list(k + 1) END DO ! k = j, (reduced) list_count END IF ! intersection should be dropped ELSE ! move on j = j + 1 END IF ! a vertex intersection, or not END DO ! WHILE j <= list_count; checking for extraneous vertex intersections IF (list_count > 0) THEN ! intersections remain after editing! IF (MOD(list_count, 2) == 0) THEN ! topologically correct; procede !Re-sort intersection list by t within contour line: CALL Sort_Lists (list_count, t_list, a_list) DO j = 2, list_count, 2 ! select those fragments which are internal to triangle: point_count = Increment_Point_Count() around(point_count) = a_list(j-1) real_steps(point_count) = i IF (gradient > 0.0) THEN ! high values are inside the parabola real_sense(point_count) = -1.0 ELSE real_sense(point_count) = +1.0 END IF point_count = Increment_Point_Count() around(point_count) = a_list(j) real_steps(point_count) = i IF (gradient > 0.0) THEN ! high values are inside the parabola real_sense(point_count) = +1.0 ELSE real_sense(point_count) = -1.0 END IF !Determine revised coefficients of contour fragment: CALL Bezier_Fragment (contour(1,0),contour(2,0), contour(1,1),contour(2,1), contour(1,2),contour(2,2), contour(1,3),contour(2,3), & & t_list(j-1), t_list(j), & ! inputs & at0,bt0, at1,bt1, at2,bt2, at3,bt3) curve_count = Increment_Curve_Count() ! record parabolic contour fragment! curve(curve_count)%x(0) = at0 curve(curve_count)%y(0) = bt0 curve(curve_count)%x(1) = at1 curve(curve_count)%y(1) = bt1 curve(curve_count)%x(2) = at2 curve(curve_count)%y(2) = bt2 curve(curve_count)%x(3) = at3 curve(curve_count)%y(3) = bt3 curve(curve_count)%is_contour = .TRUE. curve(curve_count)%half_steps = 2 * i curve(curve_count)%high_to_left = (gradient > 0.0) curve(curve_count)%forward = .TRUE. curve(curve_count)%backward = .TRUE. curve(curve_count)%in_play = .FALSE. END DO ! j = 2, list_count, 2; selecting those fragments which are internal ELSE ! an odd number of intersections should NOT happen! WRITE (*, "(' ERROR: Odd number of intersections of parabolic contour with triangle.')") CALL Traceback END IF ! even or odd number of intersections after editing END IF ! any intersections remain after editing END IF ! list_count > 0 (there are intersections, at least before any editing) END DO parabolic_contours ! i = i1, i2 END IF ! there are contours intersecting this element ELSE ! not plunging; contours will be straight lines parallel to alpha axis !The new form of the scalar is: ! f(beta) = pivot_f + f_cbb * beta**2 alpha_min = MIN(an(1), an(2), an(3)) - 1.0 ! (-1 to be SURE line is long enough to touch sides) alpha_max = MAX(an(1), an(2), an(3)) + 1.0 ! (+1 to be SURE line is long enough to touch sides) beta_min = MIN(bn(1), bn(2), bn(3)) beta_max = MAX(bn(1), bn(2), bn(3)) IF (beta_min < 0.0) THEN ! create contours from beta = beta_min to 0.0 or beta_max (whichever comes first) f_min = pivot_f + f_cbb * beta_min**2 ! "min" refers to beta, not to f! IF (beta_max > 0.0) THEN f_max = pivot_f ! "max" refers to beta, not to f! ELSE ! beta_max is also < 0 f_max = pivot_f + f_cbb * beta_max**2 ! "max" refers to beta, not to f! END IF i1 = Int_Above(MIN(f_max,f_min) / contour_interval) IF (MIN(f_max,f_min) == (i1 * contour_interval)) i1 = i1 + 1 i2 = Int_Below(MAX(f_max,f_min) / contour_interval) IF (MAX(f_max,f_min) == (i2 * contour_interval)) i2 = i2 - 1 IF (i2 >= i1) THEN ! at least one contour in lower (negative beta) group lower_axial_contours: DO i = i1, i2 f = i * contour_interval beta = -SQRT(ABS(f - pivot_f) / ABS(f_cbb)) got_one = .FALSE. ! initialize search got_two = .FALSE. DO mside = 1, 3 n1 = mside n2 = MOD(mside, 3) + 1 CALL X_Marks (an(n1),bn(n1), an(n2),bn(n2), & ! line a & alpha_min,beta, alpha_max,beta, & ! line b & crossings, ax1,bx1, ax2,bx2, f_a_1, f_a_2, f_b_1, f_b_2) IF (crossings == 2) THEN ! this contour equals one side of triangle IF (got_one.AND.(.NOT.got_two)) point_count = point_count - 1 CYCLE lower_axial_contours ! after cleanup of any orphans END IF IF (crossings == 1) THEN !Check whether intersection is in a corner that we should ignore: in_corner = (f_a_1 < internal_tolerance).OR.(f_a_1 > (1.0 - internal_tolerance)) IF (in_corner) THEN corner_number = NINT(f_a_1) + mside IF (corner_number == 4) corner_number = 1 proceed = .NOT.ignore_corner(corner_number) ! which was set way up at the top ELSE ! no problem proceed = .TRUE. END IF ! in_corner IF (proceed) THEN ! not in a corner, or else this corner is legal !Record crossing point (if we never get a second, we will erase it): point_count = Increment_Point_Count() around(point_count) = mside - 1 + f_a_1 real_steps(point_count) = i IF ((f_cbb * (bn(n2) - bn(n1))) > 0.0) THEN ! a trough, and beta increasing on this side, OR ! a ridge, and beta decreasing on this side real_sense(point_count) = -1.0 ELSE real_sense(point_count) = +1.0 END IF IF (got_one) THEN ! this will make the second got_two = .TRUE. alpha_end = ax1 curve_count = Increment_Curve_Count() curve(curve_count)%x(0) = alpha_start curve(curve_count)%y(0) = beta curve(curve_count)%x(1) = alpha_start + (alpha_end - alpha_start) / 3.0 curve(curve_count)%y(1) = beta curve(curve_count)%x(2) = alpha_end - (alpha_end - alpha_start) / 3.0 curve(curve_count)%y(2) = beta curve(curve_count)%x(3) = alpha_end curve(curve_count)%y(3) = beta curve(curve_count)%is_contour = .TRUE. curve(curve_count)%half_steps = 2 * i IF (f_cbb < 0.0) THEN ! E-W anticline; we are on south limb curve(curve_count)%high_to_left = (alpha_end > alpha_start) ELSE ! E-W syncline; we are on the south limb curve(curve_count)%high_to_left = (alpha_end < alpha_start) END IF curve(curve_count)%forward = .TRUE. curve(curve_count)%backward = .TRUE. curve(curve_count)%in_play = .FALSE. CYCLE lower_axial_contours ELSE ! this is the first found got_one = .TRUE. alpha_start = ax1 END IF ! got_one already (plus one more makes two), or else this is the first END IF ! proceed (not in corner, or corner is legal) END IF ! got another (single) crossing END DO ! mside = 1, 3; looking for two crossings IF (got_one.AND.(.NOT.got_two)) point_count = point_count - 1 END DO lower_axial_contours ! i = i1, i2 ; contours cutting interior END IF ! at least one contour in this group END IF ! beta_min < 0.0; there is a lower group of lines in negative beta space IF (beta_max > 0.0) THEN ! create contours from beta = 0.0 or beta_min (whichever comes last) to positive beta_max f_max = pivot_f + f_cbb * beta_max**2 ! "max" refers to beta, not to f! IF (beta_min < 0.0) THEN f_min = pivot_f ! "min" refers to beta, not to f! ELSE ! beta_min is also positive, but smaller f_min = pivot_f + f_cbb * beta_min**2 ! "min" refers to beta, not to f! END IF i1 = Int_Above(MIN(f_max,f_min) / contour_interval) IF (MIN(f_max,f_min) == (i1 * contour_interval)) i1 = i1 + 1 i2 = Int_Below(MAX(f_max,f_min) / contour_interval) IF (MAX(f_max,f_min) == (i2 * contour_interval)) i2 = i2 - 1 IF (i2 >= i1) THEN ! at least one contour in upper (positive beta) group upper_axial_contours: DO i = i1, i2 f = i * contour_interval beta = +SQRT(ABS(f - pivot_f) / ABS(f_cbb)) got_one = .FALSE. ! initialize search got_two = .FALSE. DO mside = 1, 3 n1 = mside n2 = MOD(mside, 3) + 1 CALL X_Marks (an(n1),bn(n1), an(n2),bn(n2), & ! line a & alpha_min,beta, alpha_max,beta, & ! line b & crossings, ax1,bx1, ax2,bx2, f_a_1, f_a_2, f_b_1, f_b_2) IF (crossings == 2) THEN ! this contour equals one side of triangle IF (got_one.AND.(.NOT.got_two)) point_count = point_count - 1 CYCLE upper_axial_contours ! after cleanup of any orphan point END IF IF (crossings == 1) THEN !Check whether intersection is in a corner that we should ignore: in_corner = (f_a_1 < internal_tolerance).OR.(f_a_1 > (1.0 - internal_tolerance)) IF (in_corner) THEN corner_number = NINT(f_a_1) + mside IF (corner_number == 4) corner_number = 1 proceed = .NOT.ignore_corner(corner_number) ! which was set way up at the top ELSE ! no problem proceed = .TRUE. END IF ! in_corner IF (proceed) THEN ! not in a corner, or else this corner is legal !Record the crossing point (if we don't got_two, we will erase it) point_count = Increment_Point_Count() around(point_count) = mside - 1 + f_a_1 real_steps(point_count) = i IF ((f_cbb * (bn(n2) - bn(n1))) > 0.0) THEN ! a trough, and beta increasing on this side, OR ! a ridge, and beta decreasing on this side real_sense(point_count) = +1.0 ELSE real_sense(point_count) = -1.0 END IF IF (got_one) THEN ! this will make the second got_two = .TRUE. alpha_end = ax1 curve_count = Increment_Curve_Count() curve(curve_count)%x(0) = alpha_start curve(curve_count)%y(0) = beta curve(curve_count)%x(1) = alpha_start + (alpha_end - alpha_start) / 3.0 curve(curve_count)%y(1) = beta curve(curve_count)%x(2) = alpha_end - (alpha_end - alpha_start) / 3.0 curve(curve_count)%y(2) = beta curve(curve_count)%x(3) = alpha_end curve(curve_count)%y(3) = beta curve(curve_count)%is_contour = .TRUE. curve(curve_count)%half_steps = 2 * i IF (f_cbb < 0.0) THEN ! E-W anticline; we are on North limb curve(curve_count)%high_to_left = (alpha_end < alpha_start) ELSE ! E-W syncline; we are on the North limb curve(curve_count)%high_to_left = (alpha_end > alpha_start) END IF curve(curve_count)%forward = .TRUE. curve(curve_count)%backward = .TRUE. curve(curve_count)%in_play = .FALSE. CYCLE upper_axial_contours ELSE ! this is the first found got_one = .TRUE. alpha_start = ax1 END IF ! got_one (plus one more makes two), or else this is the first END IF ! proceed (not in corner, or corner is legal) END IF ! got another (single) crossing END DO ! mside = 1, 3; looking for two crossings IF (got_one.AND.(.NOT.got_two)) point_count = point_count - 1 END DO upper_axial_contours ! i = i1, i2 ; contours cutting interior END IF ! at least one contour in this group END IF ! beta_max > 0.0; there is an upper group of lines in positive beta space END IF ! fold is plunging, or not ELSE IF (bowl.OR.dome) THEN !Locate the extremum, which will become the center of the (alpha, beta) coordinate system: !First, df/ds1 = f_c1 + 2 * f_c11 * s1 + f_c12 * s2 = 0 !Second, df/ds2 = f_c2 + 2 * f_c22 * s2 + f_c12 * s1 = 0 !Solving these two simultaneously should give (s1, s2) of the pivot point. IF (ABS(f_c12) > ABS(f_c11)) THEN ! use the first to solve for s2, and substitute in second: ! s2 = -(f_c1 + 2 * f_c11 * s1) / f_c12 ! from the first equation pivot_s1 = (2.0 * f_c22 * f_c1 - f_c2 * f_c12) / (f_c12**2 - 4.0 * f_c22 * f_c11) ! after plugging this into the second equation pivot_s2 = -(f_c1 + 2 * f_c11 * pivot_s1) / f_c12 ! from the first equation, again ELSE ! solve by a more stable method using f_c11 as pivot ! s1 = -(f_c1 + f_c12 * s2) / (2 * f_c11) ! from the first equation pivot_s2 = (f_c1 * f_c12 - 2.0 * f_c2 * f_c11) / (4.0 * f_c11 * f_c22 - f_c12**2) ! after plugging this into the second equation pivot_s1 = -(f_c1 + f_c12 * pivot_s2) / (2 * f_c11) ! from the first equation, again END IF pivot_s3 = 1.0 - pivot_s1 - pivot_s2 pivot_f = PhiVal(pivot_s1, pivot_s2, pivot_s3, f1, f2, f3,f4, f5, f6) !Rotate to alpha and beta axes along the principal curvature directions: rotation = pc1_argument ! alpha will be the pc1 direction, beta the pc2 direction. IF (bowl) THEN geometric_mean_curvature = SQRT(pc1 * pc2) ELSE ! dome geometric_mean_curvature = -SQRT(pc1 * pc2) END IF !Scale the alpha and beta axes so that curvature is the same along both: dads = SQRT(pc1 / geometric_mean_curvature) dbds = SQRT(pc2 / geometric_mean_curvature) f_crr = 0.5 * geometric_mean_curvature !The scalar is now: f(alpha, beta) = pivot_f + f_crr * (alpha**2 + beta**2) = pivot_f + f_crr * r**2 !Finish defining the (alpha, beta) <==> (s1, s2) transformation: out_matrix(1, 1) = +COS(rotation) ; out_matrix(1, 2) = +SIN(rotation) ! for (s1, s2) ==> (alpha, beta) out_matrix(2, 1) = -SIN(rotation) ; out_matrix(2, 2) = +COS(rotation) back_matrix(1, 1) = +COS(rotation) ; back_matrix(1, 2) = -SIN(rotation) ! for (alpha, beta) ==> (s1, s2) back_matrix(2, 1) = +SIN(rotation) ; back_matrix(2, 2) = +COS(rotation) !Transform the 3 corner nodes: CALL S1S2_2_AlphaBeta(1.0, 0.0, an(1), bn(1)) CALL S1S2_2_AlphaBeta(0.0, 1.0, an(2), bn(2)) CALL S1S2_2_AlphaBeta(0.0, 0.0, an(3), bn(3)) !Is the extremum at the (alpha, beta) origin inside the triangle? (We don't count on-edge as inside.) extremum_inside = (((an(2)-an(1))*(-bn(1))-(bn(2)-bn(1))*(-an(1))) > 0.0).AND. & & (((an(3)-an(2))*(-bn(2))-(bn(3)-bn(2))*(-an(2))) > 0.0).AND. & & (((an(1)-an(3))*(-bn(3))-(bn(1)-bn(3))*(-an(3))) > 0.0) !Find range of values along element sides, which is also range of broken contours (indeces i1:i2): CALL SixNode_Boundary_Range (fn, f_min, f_max) i1 = Int_Above(f_min / contour_interval) IF (f_min == (i1 * contour_interval)) i1 = i1 + 1 i2 = Int_Below(f_max / contour_interval) IF (f_max == (i2 * contour_interval)) i2 = i2 - 1 !Find range i3:i4 of closed circular contours, if any: IF (extremum_inside) THEN f_sup = MAX(f_sup, pivot_f) f_inf = MIN(f_inf, pivot_f) IF (bowl) THEN ! extremum is a minimum, so range i3:i4 lies just below i1 i4 = i1 - 1 i3 = Int_Above(pivot_f / contour_interval) IF (pivot_f == (i3 * contour_interval)) i3 = i3 + 1 !I must check below to be sure i3 <= i4 ! ELSE ! dome; extremum is a maximum, so range i3:i4 lies just above i2 i3 = i2 + 1 i4 = Int_Below(pivot_f / contour_interval) IF (pivot_f == (i4 * contour_interval)) i4 = i4 -1 !I must check below to be sure i3 <= i4 ! END IF ! bowl, or dome IF (i3 <= i4) THEN ! create full-circle contours IF (dome) THEN i_start = i4 ! lay down smallest circle first, so that after reversal it is last drawn i_stop = i3 i_step = -1 ELSE ! bowl i_start = i3 i_stop = i4 i_step = +1 END IF ! dome, or bowl !Note: These contours are different from all others created in the subprogram: ! They bound colored areas with an internal hole (like "O", not like "U"), ! whose outline is not a single closed path, but two distinct paths. ! It will be simpler to color these by stacking colored disks ! (in the right order) than by deciphering Abobe Illustrator's codes for ! multiply-connected domains ("composite paths"). ! Thus, these contours will be created with %forward = T but %backward = F, ! so that each is only to be used once during the coloring phase. ! Also, they will be created first (and smallest-circle first), so that ! when the order of curves is reversed below, the smallest colored disk ! will be on the top of the stack, and will be visible! DO i = i_start, i_stop, i_step f = i * contour_interval r = SQRT((f - pivot_f) / f_crr) subdivisions = 4 step_angle = Pi_over_2 DO k = 1, subdivisions arg1 = (k - 1) * step_angle arg2 = k * step_angle !Determine coefficients of contour fragment: arc_length = r * (arg2 - arg1) at0 = r * COS(arg1) bt0 = r * SIN(arg1) at1 = at0 - 0.3516 * arc_length * SIN(arg1) bt1 = bt0 + 0.3516 * arc_length * COS(arg1) at3 = r * COS(arg2) bt3 = r * SIN(arg2) at2 = at3 + 0.3516 * arc_length * SIN(arg2) bt2 = bt3 - 0.3516 * arc_length * COS(arg2) curve_count = Increment_Curve_Count() ! record complete-circle-contour quartile! curve(curve_count)%x(0) = at0 curve(curve_count)%y(0) = bt0 curve(curve_count)%x(1) = at1 curve(curve_count)%y(1) = bt1 curve(curve_count)%x(2) = at2 curve(curve_count)%y(2) = bt2 curve(curve_count)%x(3) = at3 curve(curve_count)%y(3) = bt3 curve(curve_count)%is_contour = .TRUE. curve(curve_count)%half_steps = 2 * i curve(curve_count)%high_to_left = dome curve(curve_count)%forward = .TRUE. curve(curve_count)%backward = .FALSE. curve(curve_count)%in_play = .FALSE. END DO ! k = 1, 4 subdivisions of this compete-circle contour END DO ! i = i_start, i_stop, i_step; the complete-circe contours END IF ! there are full-circle contours inside the element END IF ! extremum_inside !Do the broken-circle contours, which intersect the sides of the element: IF (i2 >= i1) THEN ! at least one contour intersects the sides of this element broken_circle_contours: DO i = i1, i2 f = i * contour_interval r = SQRT((f - pivot_f) / f_crr) list_count = 0 ! initialize search for intersections DO mside = 1, 3 ! for each of the 3 sides of the element, call Circle_and_Line n1 = mside ! index of initial node n2 = MOD(mside, 3) + 1 ! index of final node CALL Circle_and_Line (0.0, 0.0, r, & ! defines circle & an(n1),bn(n1), an(n2),bn(n2), & ! defines line segment & number, t_vec, tls_vec, x_list, y_list) ! output !Ignore osculations: IF ((number == 2).AND.(ABS(tls_vec(1) - tls_vec(2)) < internal_tolerance)) CYCLE !but add any other intersections to the temporary tables: IF (number >= 1) THEN list_count = list_count + 1 t_list(list_count) = t_vec(1) ! save internal coordinate of contour (argument, counterclockwise from +alpha, in radians) a_list(list_count) = mside - 1.0 + tls_vec(1) ! future "around" value of intersection in element coordinates END IF ! (at least) one intersection found on this side IF (number >= 2) THEN ! there was a second intersection as well list_count = list_count + 1 t_list(list_count) = t_vec(2) a_list(list_count) = mside - 1.0 + tls_vec(2) END IF ! a second intersection was found on this side END DO ! mside = 1, 3; counting intersections IF (list_count > 0) THEN ! normally, this should be true! (However, intersection may fail !in case where the circle is just grazing one vertex; there is no harm is skipping such cases!) !If intersection was with "end of 3rd side", rename this as "beginning of first side": DO j = 1, list_count IF (a_list(j) >= 3.0) a_list(j) = 0.0 END DO ! j = 1, list_count !Sort the lists in counterclockwise order about element: CALL Sort_Lists (list_count, a_list, t_list) !Eliminate any double-counting of intersections with ends of sides: j = 1 ! initializing a loop whose limit may be adjusted DO WHILE (j < list_count) ! last execution will have i = list_count (after next line) j = j + 1 ! = 2 the first time through; = list_count the last time through IF (ABS(a_list(j) - a_list(j-1)) < internal_tolerance) THEN ! eliminate one of the counts list_count = list_count - 1 DO k = j, list_count ! replace these values with the next-higher values: a_list(k) = a_list(k + 1) t_list(k) = t_list(k + 1) END DO ! k = j, (reduced) list_count END IF ! fixing a double-counted point (presumably at a vertex) END DO ! WHILE j <= list_count !Now, check any points at vertices to see whether contour passes into the !interior of the element, or just skims by without entering! j = 1 ! initializing a loop whose limit may shrink DO WHILE (j <= list_count) n = NINT(a_list(j)) IF (ABS(a_list(j) - (n * 1.0)) < internal_tolerance) THEN ! a vertex intersection !Find argument (radians, counterclockwise from +alpha) of contour direction(s): contour_argument = t_list(j) + Pi_over_2 ! pointing forward along the counterclockwise rotation anticontour_argument = contour_argument - Pi ! pointing backward along the rotation !Find arguments of sides, ASSUMING that triangle has been rotated but not flipped! n1 = MOD(n, 3) + 1 ! vertex node, 1, 2, or 3 n2 = MOD(n1, 3) + 1 ! node giving direction of lowest_argument n3 = MOD(n2, 3) + 1 ! node giving direction of highest_argument lowest_argument = ATAN2F((bn(n2) - bn(n1)), (an(n2) - an(n1))) highest_argument = ATAN2F((bn(n3) - bn(n1)), (an(n3) - an(n1))) wedge_winding = Winding(highest_argument - lowest_argument) contour_winding = Winding(contour_argument - lowest_argument) anticontour_winding = Winding(anticontour_argument - lowest_argument) inside = (contour_winding < (wedge_winding - internal_tolerance)).OR. & & ((anticontour_winding > internal_tolerance).AND. & & (anticontour_winding <= wedge_winding)) !Note: Assymetry of the decision rule above is because contours always bend to the left ! when traveling in the contour_argument direction. IF (inside) THEN ! move on to consider the next j = j + 1 ELSE ! eliminate this intersection list_count = list_count - 1 DO k = j, list_count ! replace these values with the next-higher values: a_list(k) = a_list(k + 1) t_list(k) = t_list(k + 1) END DO ! k = j, (reduced) list_count END IF ! intersection should be dropped ELSE ! move on to consider the next j = j + 1 END IF ! a vertex intersection, or not END DO ! while j <= list_count; checking for extraneous vertex intersections IF (list_count > 0) THEN ! intersections remain after editing! IF (MOD(list_count, 2) == 0) THEN ! topologically correct; procede !Re-sort intersection list by argument-within-circle: CALL Sort_Lists (list_count, t_list, a_list) !Check phase (in/out), and, (if necessary), re-order so that first intersection is ENTERING the triangle! !First, find midpoint of first segment in list: test_argument = (t_list(1) + t_list(2)) / 2.0 ! We hope this is inside the triangle... at0 = r * COS(test_argument) bt0 = r * SIN(test_argument) point_inside = (((an(2)-an(1))*(bt0-bn(1))-(bn(2)-bn(1))*(at0-an(1))) > 0.0).AND. & & (((an(3)-an(2))*(bt0-bn(2))-(bn(3)-bn(2))*(at0-an(2))) > 0.0).AND. & & (((an(1)-an(3))*(bt0-bn(3))-(bn(1)-bn(3))*(at0-an(3))) > 0.0) IF (.NOT.point_inside) THEN ! must rotate the list by one point: a_save = a_list(1) t_save = t_list(1) DO j = 1, list_count-1 a_list(j) = a_list(j+1) t_list(j) = t_list(j+1) END DO a_list(list_count) = a_save t_list(list_count) = t_save + Two_Pi END IF ! shuffling the intersection list DO j = 2, list_count, 2 ! select those fragments which are internal to triangle: point_count = Increment_Point_Count() around(point_count) = a_list(j-1) real_steps(point_count) = i IF (bowl) THEN ! (circle is entering triangle, so we are leaving the circle) real_sense(point_count) = +1.0 ELSE real_sense(point_count) = -1.0 END IF point_count = Increment_Point_Count() around(point_count) = a_list(j) real_steps(point_count) = i IF (dome) THEN ! (circle is leaving the triangle, so we are entering the circle) real_sense(point_count) = +1.0 ELSE real_sense(point_count) = -1.0 END IF subdivisions = 1.0 + (t_list(j) - t_list(j-1)) / Pi_over_2 ! truncate to integer step_angle = (t_list(j) - t_list(j-1)) / subdivisions DO k = 1, subdivisions arg1 = t_list(j-1) + (k - 1) * step_angle arg2 = t_list(j-1) + k * step_angle IF (k == subdivisions) arg2 = t_list(j) ! to prevent rounding errors !Determine coefficients of contour fragment: arc_length = r * (arg2 - arg1) at0 = r * COS(arg1) bt0 = r * SIN(arg1) at1 = at0 - 0.3516 * arc_length * SIN(arg1) bt1 = bt0 + 0.3516 * arc_length * COS(arg1) at3 = r * COS(arg2) bt3 = r * SIN(arg2) at2 = at3 + 0.3516 * arc_length * SIN(arg2) bt2 = bt3 - 0.3516 * arc_length * COS(arg2) curve_count = Increment_Curve_Count() ! record broken-circle contour fragment! curve(curve_count)%x(0) = at0 curve(curve_count)%y(0) = bt0 curve(curve_count)%x(1) = at1 curve(curve_count)%y(1) = bt1 curve(curve_count)%x(2) = at2 curve(curve_count)%y(2) = bt2 curve(curve_count)%x(3) = at3 curve(curve_count)%y(3) = bt3 curve(curve_count)%is_contour = .TRUE. curve(curve_count)%half_steps = 2 * i curve(curve_count)%high_to_left = dome curve(curve_count)%forward = .TRUE. curve(curve_count)%backward = .TRUE. curve(curve_count)%in_play = .FALSE. END DO ! k = 1, subdivisions of this contour fragment END DO ! j = 2, list_count, 2; selecting those fragments which are internal ELSE ! an odd number of intersections should NOT happen! WRITE (*, "(' ERROR: Odd number of intersections of circular contour with triangle.')") CALL Traceback END IF ! even or odd number of intersections after editing END IF ! any intersections remain after editing END IF ! list_count > 0 (before any editing) END DO broken_circle_contours ! i = i1, i2 END IF ! there are broken-circle contours intersecting this element ELSE IF (saddle) THEN !Locate the extremum, which will become the center of the (alpha, beta) coordinate system: !First, df/ds1 = f_c1 + 2 * f_c11 * s1 + f_c12 * s2 = 0 !Second, df/ds2 = f_c2 + 2 * f_c22 * s2 + f_c12 * s1 = 0 !Solving these two simultaneously should give (s1, s2) of the pivot point. IF (ABS(f_c12) > ABS(f_c11)) THEN ! use the first to solve for s2, and substitute in second: ! s2 = -(f_c1 + 2 * f_c11 * s1) / f_c12 ! from the first equation pivot_s1 = (2.0 * f_c22 * f_c1 - f_c2 * f_c12) / (f_c12**2 - 4.0 * f_c22 * f_c11) ! after plugging this into the second equation pivot_s2 = -(f_c1 + 2 * f_c11 * pivot_s1) / f_c12 ! from the first equation, again ELSE ! solve by a more stable method using f_c11 as pivot ! s1 = -(f_c1 + f_c12 * s2) / (2 * f_c11) ! from the first equation pivot_s2 = (f_c1 * f_c12 - 2.0 * f_c2 * f_c11) / (4.0 * f_c11 * f_c22 - f_c12**2) ! after plugging this into the second equation pivot_s1 = -(f_c1 + f_c12 * pivot_s2) / (2 * f_c11) ! from the first equation, again END IF pivot_s3 = 1.0 - pivot_s1 - pivot_s2 pivot_f = PhiVal(pivot_s1, pivot_s2, pivot_s3, f1, f2, f3,f4, f5, f6) !Rotate to alpha and beta axes along the principal curvature directions: rotation = pc1_argument ! alpha will be the pc1 (down) direction, beta the pc2 (up) direction. geometric_mean_curvature = SQRT(-pc1 * pc2) !Scale the alpha and beta axes so that curvature is the same along both: dads = SQRT(-pc1 / geometric_mean_curvature) dbds = SQRT(pc2 / geometric_mean_curvature) f_crr = 0.5 * geometric_mean_curvature ! positive !The scalar is now: f(alpha, beta) = pivot_f + f_crr * (-alpha**2 + beta**2) !Finish defining the (alpha, beta) <==> (s1, s2) transformation: out_matrix(1, 1) = +COS(rotation) ; out_matrix(1, 2) = +SIN(rotation) ! for (s1, s2) ==> (alpha, beta) out_matrix(2, 1) = -SIN(rotation) ; out_matrix(2, 2) = +COS(rotation) back_matrix(1, 1) = +COS(rotation) ; back_matrix(1, 2) = -SIN(rotation) ! for (alpha, beta) ==> (s1, s2) back_matrix(2, 1) = +SIN(rotation) ; back_matrix(2, 2) = +COS(rotation) !Transform the 3 corner nodes: CALL S1S2_2_AlphaBeta(1.0, 0.0, an(1), bn(1)) CALL S1S2_2_AlphaBeta(0.0, 1.0, an(2), bn(2)) CALL S1S2_2_AlphaBeta(0.0, 0.0, an(3), bn(3)) alpha_min = MIN(an(1), an(2), an(3)) - 0.1 ! (-1 to be SURE lines are long enough to touch sides) alpha_max = MAX(an(1), an(2), an(3)) + 0.1 ! (+1 to be SURE lines are long enough to touch sides) beta_min = MIN(bn(1), bn(2), bn(3)) - 0.1 ! (-1 to be SURE lines are long enough to touch sides) beta_max = MAX(bn(1), bn(2), bn(3)) + 0.1 ! (+1 to be SURE lines are long enough to touch sides) !Is the extremum at the (alpha, beta) origin inside the triangle? (We don't count on-edge as inside.) extremum_inside = (pivot_s1 > internal_tolerance) .AND. & & (pivot_s2 > internal_tolerance) .AND. & & (pivot_s3 > internal_tolerance) !Do contours meet at the saddle point in an "X" (either inside or outside the element)? x_level = NINT(pivot_f / contour_interval) x_contours = (ABS(contour_interval * x_level - pivot_f) / contour_interval) < step_tolerance !Is it necessary to negate ignore_corner for one corner which is the X-point? IF (x_contours.AND.(.NOT.extremum_inside)) THEN IF ((pivot_s1 > (1.0 - internal_tolerance)).AND.(pivot_s1 < (1.0 + internal_tolerance))) ignore_corner(1) = .FALSE. IF ((pivot_s2 > (1.0 - internal_tolerance)).AND.(pivot_s2 < (1.0 + internal_tolerance))) ignore_corner(2) = .FALSE. IF ((pivot_s3 > (1.0 - internal_tolerance)).AND.(pivot_s3 < (1.0 + internal_tolerance))) ignore_corner(3) = .FALSE. END IF ! necessary to consider negating any ignore_corner !Proceed with the X-contours, one at a time: IF (x_contours) THEN four_arms: DO i = 1, 4 ! four arms of X SELECT CASE(i) CASE (1) ! +alpha, +beta arm alpha1 = MAX(alpha_max, beta_max) beta1 = alpha1 IF (alpha1 <= 0.0) CYCLE four_arms CASE (2) ! -alpha, +beta arm alpha1 = -MAX(-alpha_min, beta_max) beta1 = -alpha1 IF (alpha1 >= 0.0) CYCLE four_arms CASE (3) ! -alpha, -beta arm alpha1 = MIN(alpha_min, beta_min) beta1 = alpha1 IF (alpha1 >= 0.0) CYCLE four_arms CASE (4) ! +alpha, -beta arm alpha1 = MAX(alpha_max, -beta_min) beta1 = -alpha1 IF (alpha1 <= 0.0) CYCLE four_arms END SELECT ! (i); which arm? IF (extremum_inside) THEN ! play it kosher alpha0 = 0.0 beta0 = 0.0 ELSE ! extend arm slightly in other direction to avoid "just missing" an intersection near origin: alpha0 = -alpha1 * internal_tolerance beta0 = -beta1 * internal_tolerance END IF !Do we already know one end-point of this contour segment? IF (extremum_inside) THEN got_one = .TRUE. alpha_start = 0.0 beta_start = 0.0 ELSE ! extemum is outside the element got_one = .FALSE. END IF ! extremum_inside or not got_two = .FALSE. DO mside = 1, 3 ! sides of element n1 = mside n2 = MOD(mside, 3) + 1 CALL X_Marks (an(n1),bn(n1), an(n2),bn(n2), & ! line a; the element side & alpha0,beta0, alpha1,beta1, & ! line b; the arm & crossings, ax1,bx1, ax2,bx2, f_a_1, f_a_2, f_b_1, f_b_2) IF (crossings == 2) THEN ! this arm overlaps one side of triangle IF ((.NOT.extremum_inside).AND.got_one.AND.(.NOT.got_two)) point_count = point_count - 1 CYCLE four_arms ! after cleaning-up any orphan single crossing points END IF IF (crossings == 1) THEN !Check whether intersection is in a corner that we should ignore: in_corner = (f_a_1 < internal_tolerance).OR.(f_a_1 > (1.0 - internal_tolerance)) IF (in_corner) THEN corner_number = NINT(f_a_1) + mside IF (corner_number == 4) corner_number = 1 proceed = .NOT.ignore_corner(corner_number) ! which was set way up at the top ELSE ! no problem proceed = .TRUE. END IF ! in_corner IF (proceed) THEN ! not in a corner, or else this corner is legal !Record crossing point (if it turns out to be twins or an orphan, these will be scratched later): point_count = Increment_Point_Count() around(point_count) = mside - 1 + f_a_1 real_steps(point_count) = x_level IF (extremum_inside) THEN IF ((i == 1).OR.(i == 3)) THEN ! an alpha = beta arm; use (beta-alpha) as measure of side trend: IF ((bx1 * ((bn(n2) - an(n2)) - (bn(n1) - an(n1)))) > 0.0) THEN ! real_sense(point_count) = +1.0 ELSE real_sense(point_count) = -1.0 END IF ELSE ! an alpha = -beta arm; use (alpha+beta) as a measure of side trend: IF ((bx1 * ((an(n2) + bn(n2)) - (an(n1) + bn(n1)))) > 0.0) THEN ! real_sense(point_count) = +1.0 ELSE real_sense(point_count) = -1.0 END IF END IF ! and alpha = beta or an alpha = -beta type of arm END IF ! extremum_inside !Otherwise (.NOT.extremum_inside), these real_sense values will be decided below when contour is drawn: IF (got_one) THEN ! this will make the second end-point got_two = .TRUE. ! unless... IF (.NOT.extremum_inside) THEN ! worry about two coincident points at a vertex(?) IF ((ABS(around(point_count) - around(point_count - 1)) < internal_tolerance).OR. & & (ABS(around(point_count) - around(point_count - 1) - 3.0) < internal_tolerance)) THEN ! two coincident points; !Dump the coincident point! !(Perhaps a different, corrent match will be found on another side. ! If not, the orphan point will get dropped later, as usual. point_count = point_count - 1 got_two = .FALSE. END IF ! two coincident points; dumping this segment! END IF ! worrying about two coincident points at a vertex(?) IF (got_two) THEN ! (still, after testing for coincidence) alpha_end = ax1 beta_end = bx1 curve_count = Increment_Curve_Count() curve(curve_count)%x(0) = alpha_start curve(curve_count)%y(0) = beta_start curve(curve_count)%x(1) = alpha_start + (alpha_end - alpha_start) / 3.0 curve(curve_count)%y(1) = beta_start + (beta_end - beta_start ) / 3.0 curve(curve_count)%x(2) = alpha_end - (alpha_end - alpha_start) / 3.0 curve(curve_count)%y(2) = beta_end - (beta_end - beta_start ) / 3.0 curve(curve_count)%x(3) = alpha_end curve(curve_count)%y(3) = beta_end curve(curve_count)%is_contour = .TRUE. curve(curve_count)%half_steps = 2 * x_level !beginning of complex decision rule for %high_to_left: IF (extremum_inside) THEN outgoing = .TRUE. ELSE r1 = SQRT(alpha_start**2 + beta_start**2) r2 = SQRT(alpha_end**2 + beta_end**2) outgoing = (r2 > r1) END IF IF (outgoing) THEN curve(curve_count)%high_to_left = ((i == 1).OR.(i == 3)) ELSE ! incoming, toward origin curve(curve_count)%high_to_left = ((i == 2).OR.(i == 4)) END IF !end of decision rule; now use result to re-set values of sense_around !(because these can go wrong when one point is at or ~at the origin! IF (.NOT.extremum_inside) THEN IF (curve(curve_count)%high_to_left) THEN real_sense(point_count-1) = -1.0 ! starting point real_sense(point_count) = +1.0 ! ending point ELSE ! opposite sense; high-to-right real_sense(point_count-1) = +1.0 ! starting point real_sense(point_count) = -1.0 ! ending point END IF END IF ! .NOT.extremum_inside !Now, completely finished with sense! curve(curve_count)%forward = .TRUE. curve(curve_count)%backward = .TRUE. curve(curve_count)%in_play = .FALSE. CYCLE four_arms END IF ! got_two, still ELSE ! this is the first end-point found got_one = .TRUE. alpha_start = ax1 beta_start = bx1 END IF ! got_one end (plus one more makes two), or else this is the first end END IF ! proceed (not in a corner, or this corner is legal) END IF ! got another (single) crossing END DO ! mside = 1, 3; looking for crossings on all three sides of element IF ((.NOT.extremum_inside).AND.got_one.AND.(.NOT.got_two)) point_count = point_count - 1 END DO four_arms ! i = 1, 4: the four arms of the X END IF ! x_contours !Find range of values along element sides, which is also range of hyperbolic contours (indeces i1:i2): CALL SixNode_Boundary_Range (fn, f_min, f_max) i1 = Int_Above(f_min / contour_interval) IF (f_min == (i1 * contour_interval)) i1 = i1 + 1 i2 = Int_Below(f_max / contour_interval) IF (f_max == (i2 * contour_interval)) i2 = i2 - 1 IF (i2 >= i1) THEN ! there are hyperbolic contours !Create all hyperbolic contours (not including any straight contours involved in an X): DO i = i1, i2 ! consider all contour levels IF ((.NOT.x_contours).OR.(i /= x_level)) THEN ! not part of an X f = i * contour_interval DO i_flip = -1, 1, 2 ! both negative and positive ends of the relevant axis (depending on f < or f > pivot_f): list_count = 0 ! begin list of intersections of this hyperbolic contour with element sides DO mside = 1, 3 ! for each of the 3 sides of the element, call Sateh n1 = mside ! index of initial node (1, 2, or 3) n4 = n1 + 3 ! index of midpoint node (4, 5, or 6) n2 = MOD(mside, 3) + 1 ! index of final node (2, 3, or 1) CALL Value_On_3Node_Side (fn(n1), fn(n4), fn(n2), f, & ! inputs & number, p1, p2) ! outputs: number = 0, 1, or 2 !Ignore osculations: IF ((number == 2).AND.(ABS(p1 - p2) < internal_tolerance)) CYCLE !and evaluate other solutions according to their quadrant: IF (number >= 1) THEN alpha = an(n1) + p1 * (an(n2) - an(n1)) beta = bn(n1) + p1 * (bn(n2) - bn(n1)) IF (f < pivot_f) THEN ! contours intersecting the - and + alpha axes (depending on i_flip): correct_quadrant = (ABS(beta) < ABS(alpha)).AND.((i_flip * alpha) > 0.0) ELSE ! f > pivot_f; contours intersecting the - and + beta axes (depending on i_flip): correct_quadrant = (ABS(alpha) < ABS(beta)).AND.((i_flip * beta) > 0.0) END IF ! f < OR > pivot_f; contours intersecting the alpha OR the beta axes IF (correct_quadrant) THEN ! record this intersection point list_count = list_count + 1 a_list(list_count) = mside - 1.0 + p1 ! future "around" value of intersection in element coordinates x_list(list_count) = alpha; y_list(list_count) = beta END IF ! correct_quadrant for intersection 1 END IF ! (at least) one intersection found on this side IF (number >= 2) THEN ! there was a second intersection as well (there should never be 3 with one side!) alpha = an(n1) + p2 * (an(n2) - an(n1)) beta = bn(n1) + p2 * (bn(n2) - bn(n1)) IF (f < pivot_f) THEN ! contours intersecting the - and + alpha axes (depending on i_flip): correct_quadrant = (ABS(beta) < ABS(alpha)).AND.((i_flip * alpha) > 0.0) ELSE ! f > pivot_f; contours intersecting the - and + beta axes (depending on i_flip): correct_quadrant = (ABS(alpha) < ABS(beta)).AND.((i_flip * beta) > 0.0) END IF ! f < OR > pivot_f; contours intersecting the alpha OR the beta axes IF (correct_quadrant) THEN ! record this intersection point list_count = list_count + 1 a_list(list_count) = mside - 1.0 + p2 ! future "around" value of intersection in element coordinates x_list(list_count) = alpha; y_list(list_count) = beta END IF ! correct_quadrant END IF ! a second intersection was found between this side and the hyperbola END DO ! mside = 1, 3; counting intersections IF (list_count > 0) THEN ! not necessarily true for both values of i_flip! !If intersection was with "end of 3rd side", rename this as "beginning of first side": DO j = 1, list_count IF (a_list(j) >= 3.0) a_list(j) = 0.0 END DO ! j = 1, list_count IF (list_count >= 2) THEN !Sort the lists in counterclockwise order about element: CALL Sort_Lists (list_count, a_list, x_list, y_list) !Eliminate any double-counting of intersections with ends of sides: j = 2 ! initializing a loop whose limit may be adjusted DO WHILE (j <= list_count) IF (ABS(a_list(j) - a_list(j-1)) < internal_tolerance) THEN ! eliminate one of the counts list_count = list_count - 1 DO k = j, list_count ! replace these values with the next-higher values: a_list(k) = a_list(k + 1) x_list(k) = x_list(k + 1) y_list(k) = y_list(k + 1) END DO ! k = j, (reduced) list_count !Now loop and check on the NEW #j vs. j-1 ELSE ! move on j = j + 1 END IF ! fixing a double-counted point (presumably at a vertex) END DO ! WHILE j <= list_count END IF ! list_count >= 2 !Now, check any points at vertices to see whether contour passes into the !interior of the element, or just skims by without entering! j = 1 ! initializing a loop whose limit may shrink DO WHILE (j <= list_count) n = NINT(a_list(j)) IF (ABS(a_list(j) - (n * 1.0)) < internal_tolerance) THEN ! a vertex intersection !Find argument (radians, counterclockwise from +alpha) of contour direction(s): alpha = x_list(j); beta = y_list(j) !Note: Following formula is based on fact that dbeta/dalpha = alpha/beta: IF (f < pivot_f) THEN ! hyperbola intersects the alpha axis: contour_argument = ATAN2F(-alpha, -beta) ! clockwise about origin, but curving left ELSE ! hyperbola intersects the beta axis: contour_argument = ATAN2F(alpha, beta) ! clockwise about origin, but curving left END IF ! hyperbola intersects alpha or beta axis anticontour_argument = contour_argument + Pi ! reverse direction; counterclockwise about origin !Find arguments of sides, ASSUMING that triangle has been rotated but not flipped! n1 = MOD(n, 3) + 1 ! vertex node, 1, 2, or 3 n2 = MOD(n1, 3) + 1 ! node giving direction of lowest_argument n3 = MOD(n2, 3) + 1 ! node giving direction of highest_argument lowest_argument = ATAN2F((bn(n2) - bn(n1)), (an(n2) - an(n1))) highest_argument = ATAN2F((bn(n3) - bn(n1)), (an(n3) - an(n1))) wedge_winding = Winding(highest_argument - lowest_argument) contour_winding = Winding(contour_argument - lowest_argument) anticontour_winding = Winding(anticontour_argument - lowest_argument) inside = (contour_winding < (wedge_winding - internal_tolerance)).OR. & & ((anticontour_winding > internal_tolerance).AND. & & (anticontour_winding <= wedge_winding)) !Note: Assymetry of the decision rule above is because contours always bend to the left ! when traveling in the contour_argument direction. IF (inside) THEN ! move on j = j + 1 ELSE ! eliminate this intersection list_count = list_count - 1 DO k = j, list_count ! replace these values with the next-higher values: a_list(k) = a_list(k + 1) x_list(k) = x_list(k + 1) y_list(k) = y_list(k + 1) END DO ! k = j, (reduced) list_count END IF ! intersection should be dropped ELSE ! move on j = j + 1 END IF ! a vertex intersection, or not END DO ! WHILE j <= list_count; checking for extraneous vertex intersections IF (list_count > 0) THEN ! intersections remain after editing! IF (MOD(list_count, 2) == 0) THEN ! topologically correct; proceed !Rate points, in t_list, according to their counterclockwise progression angle about the hyperbola: !This requires defining a "center point" within the hyperbola that it "rotates" about: apex = SQRT(ABS(f - pivot_f) / f_crr) ! minimum distance from origin along alpha or beta axis IF (f < pivot_f) THEN ! this hyperbola intersects the alpha axis alpha_center = 2.0 * i_flip * apex beta_center = 0.0 ELSE ! this hyperbola intersects the beta axis alpha_center = 0.0 beta_center = 2.0 * i_flip * apex END IF ! intersecting alpha or beta axis DO j = 1, list_count alpha = x_list(j); beta = y_list(j) t_list(j) = ATAN2F((beta - beta_center), (alpha - alpha_center)) !Prevent errors due to the discontinuity in the ATAN2F function: IF (f < pivot_f) THEN ! this hyperbola intersects the alpha axis IF (i_flip < 0) THEN !no action required; the cut causes no problem in this case ELSE ! i_flip > 0; positive alpha axis IF (t_list(j) < 0.0) t_list(j) = t_list(j) + Two_Pi END IF ELSE ! this hyperbola intersects the beta axis IF (i_flip < 0) THEN ! negative beta axis IF (t_list(j) < -Pi_over_2) t_list(j) = t_list(j) + Two_Pi ELSE ! positive beta axis IF (t_list(j) > Pi_over_2) t_list(j) = t_list(j) - Two_Pi END IF END IF ! intersecting alpha or beta axis END DO ! j = 1, list_count; rating the points by counterclockwise progress about contour !Sort the lists in counterclockwise order about the hyperbolic contour: CALL Sort_Lists (list_count, t_list, a_list, x_list, y_list) !Take points two at a time to define contour fragments which are inside the element: DO j = 2, list_count, 2 ! j-1 is the initial point, j is the final point alpha_first = x_list(j-1); beta_first = y_list(j-1) IF (f < pivot_f) THEN ! hyperbola intersects the alpha axis: initial_argument = ATAN2F(-alpha_first, -beta_first) ! clockwise about origin, but curving left ELSE ! hyperbola intersects the beta axis: initial_argument = ATAN2F(alpha_first, beta_first) ! clockwise about origin, but curving left END IF ! hyperbola intersects alpha or beta axis alpha_last = x_list(j); beta_last = y_list(j) IF (f < pivot_f) THEN ! hyperbola intersects the alpha axis: final_argument = ATAN2F(-alpha_last, -beta_last) ! clockwise about origin, but curving left ELSE ! hyperbola intersects the beta axis: final_argument = ATAN2F(alpha_last, beta_last) ! clockwise about origin, but curving left END IF ! hyperbola intersects alpha or beta axis !Record intersection points of this hyperbolic contour with element sides: !entry point into the triangle: point_count = Increment_Point_Count() around(point_count) = a_list(j-1) real_steps(point_count) = i IF (f > pivot_f) THEN ! %high_to_left; contour intersects beta axis real_sense(point_count) = -1.0 ! side is leaving a high wedge ELSE real_sense(point_count) = +1.0 ! side is leaving a low wedge END IF !exit point from the triangle: point_count = Increment_Point_Count() around(point_count) = a_list(j) real_steps(point_count) = i IF (f > pivot_f) THEN ! %high_to_left; contour intersects beta axis real_sense(point_count) = +1.0 ! side is entering a high wedge ELSE real_sense(point_count) = -1.0 ! side is entering a low wedge END IF !Determine coefficients of Bezier curve for this contour fragment; !first, construct rays along control arms and find intersection: chord = SQRT((alpha_last - alpha_first)**2 + (beta_last - beta_first)**2) at1 = alpha_first + chord * COS(initial_argument) bt1 = beta_first + chord * SIN(initial_argument) at2 = alpha_last - chord * COS(final_argument) bt2 = beta_last - chord * SIN(final_argument) CALL X_Marks (alpha_first,beta_first, at1,bt1, & & alpha_last, beta_last, at2,bt2, & ! input & crossings, xm1,ym1, xm2,ym2, f_a_1, f_a_2, f_b_1, f_b_2) ! output IF (crossings == 0) THEN ! problem! !Experience shows that this is usually the result of accumulated !numerical error in the case of very short (d_alpha << alpha; d_beta << beta) !hyperbolic segments. The solution is to assume a very gentle curvature, !with the intersection point about half-way between the end points. !Here I will assign xm1 and ym1 to the midpoint of the straight line !between the end points, because the azimuth to this point is not used; !only the arm lengths are used: xm1 = (alpha_first + alpha_last) / 2.0 ym1 = (beta_first + beta_last ) / 2.0 END IF ! crossing not found !for both ends of the contour: rotation = MOD((final_argument - initial_argument + Two_Pi), Pi) arm_factor = 0.7 + 0.3 * (rotation / Pi_over_2)**2 ! 0.0 < rotation < Pi_over_2 !for the initial control arm: chord = SQRT((xm1 - alpha_first)**2 + (ym1 - beta_first)**2) arm_length = arm_factor * chord at1 = alpha_first + arm_length * COS(initial_argument) bt1 = beta_first + arm_length * SIN(initial_argument) !for the final control arm: chord = SQRT((xm1 - alpha_last)**2 + (ym1 - beta_last)**2) arm_length = arm_factor * chord at2 = alpha_last - arm_length * COS(final_argument) bt2 = beta_last - arm_length * SIN(final_argument) ! Record this hyperbolic contour fragment! curve_count = Increment_Curve_Count() curve(curve_count)%x(0) = alpha_first curve(curve_count)%y(0) = beta_first curve(curve_count)%x(1) = at1 curve(curve_count)%y(1) = bt1 curve(curve_count)%x(2) = at2 curve(curve_count)%y(2) = bt2 curve(curve_count)%x(3) = alpha_last curve(curve_count)%y(3) = beta_last curve(curve_count)%is_contour = .TRUE. curve(curve_count)%half_steps = 2 * i curve(curve_count)%high_to_left = (f > pivot_f) ! that is, we are working on a contour that intersects the beta axis curve(curve_count)%forward = .TRUE. curve(curve_count)%backward = .TRUE. curve(curve_count)%in_play = .FALSE. END DO ! j = 2, list_count, 2 (taking points in pairs to define hyperbolic segments inside the element ELSE ! an odd number of intersections should NOT happen! WRITE (*, "(' ERROR: Odd number of intersections of hyperbolic contour with triangle.')") CALL Traceback END IF ! even or odd number of intersections after editing END IF ! any intersections remain after editing END IF ! (list_count > 0); not always true for both values of i_flip END DO ! i_flip = -1, 1, 2 ; both negative and positive ends of the relevant axis (depending on f > or f < pivot_f) END IF ! this contour level is not the x-level END DO ! i = i1, i2; contour levels END IF ! there are hyperbolic contours ELSE ! should not happen! WRITE (*, "(' Logic error in Contour_6Node_Scalar_in_Plane: unknown quadratic type')") CALL Traceback() END IF ! type of quadratic function !Convert all control points of all contour curves from (alpha,beta) to (s1,s2) coordinates: DO i = 1, curve_count DO j = 0, 3 alpha = curve(i)%x(j) beta = curve(i)%y(j) CALL AlphaBeta_2_S1S2 (alpha, beta, s1, s2) curve(i)%x(j) = s1 curve(i)%y(j) = s2 END DO ! j = 0, 3 END DO ! i = 1, curve_count !Convert all control points of all contour curves from (s1,s2) to (x,y) coordinates: DO i = 1, curve_count !First, determine initial and final directions and velocities of curve in (s1,s2) space: initial_ds1dt = 3.0 * (curve(i)%x(1) - curve(i)%x(0)) initial_ds2dt = 3.0 * (curve(i)%y(1) - curve(i)%y(0)) initial_dsdt = SQRT(initial_ds1dt**2 + initial_ds2dt**2) ! d(length in s1,s2 space)/dt final_ds1dt = 3.0 * (curve(i)%x(3) - curve(i)%x(2)) final_ds2dt = 3.0 * (curve(i)%y(3) - curve(i)%y(2)) final_dsdt = SQRT(final_ds1dt**2 + final_ds2dt**2) !Then, determine initial and final directions and velocities of curve in (x,y) space: s1 = curve(i)%x(0) ; s2 = curve(i)%y(0) ! initial point initial_dxds1 = x_c1 + 2.0 * x_c11 * s1 + x_c12 * s2 initial_dxds2 = x_c2 + 2.0 * x_c22 * s2 + x_c12 * s1 initial_dyds1 = y_c1 + 2.0 * y_c11 * s1 + y_c12 * s2 initial_dyds2 = y_c2 + 2.0 * y_c22 * s2 + y_c12 * s1 initial_dxdt = initial_dxds1 * initial_ds1dt + initial_dxds2 * initial_ds2dt initial_dydt = initial_dyds1 * initial_ds1dt + initial_dyds2 * initial_ds2dt initial_argument = ATAN2F(initial_dydt, initial_dxdt) initial_dzdt = SQRT(initial_dxdt**2 + initial_dydt**2) ! d(length in x,y space)/dt s1 = curve(i)%x(3) ; s2 = curve(i)%y(3) ! final point final_dxds1 = x_c1 + 2.0 * x_c11 * s1 + x_c12 * s2 final_dxds2 = x_c2 + 2.0 * x_c22 * s2 + x_c12 * s1 final_dyds1 = y_c1 + 2.0 * y_c11 * s1 + y_c12 * s2 final_dyds2 = y_c2 + 2.0 * y_c22 * s2 + y_c12 * s1 final_dxdt = final_dxds1 * final_ds1dt + final_dxds2 * final_ds2dt final_dydt = final_dyds1 * final_ds1dt + final_dyds2 * final_ds2dt final_argument = ATAN2F(final_dydt, final_dxdt) final_dzdt = SQRT(final_dxdt**2 + final_dydt**2) !Determine lengths of Bezier control arms in (s1, s2) space: arm01 = SQRT((curve(i)%x(0) - curve(i)%x(1))**2 + (curve(i)%y(0) - curve(i)%y(1))**2) arm23 = SQRT((curve(i)%x(2) - curve(i)%x(3))**2 + (curve(i)%y(2) - curve(i)%y(3))**2) !Convert arm lengths to (x, y) space (avoiding 0.0 / 0.0): IF (initial_dsdt /= 0.0) THEN arm01 = arm01 * initial_dzdt / initial_dsdt ELSE arm01 = 0.0 END IF IF (final_dsdt /= 0.0) THEN arm23 = arm23 * final_dzdt / final_dsdt ELSE arm23 = 0.0 END IF !Apply (s1,s2) ==> (x,y) transformation to the end control points: DO j = 0, 3, 3 s1 = curve(i)%x(j) s2 = curve(i)%y(j) s3 = 1.0 - s1 - s2 x_meters = PhiVal(s1, s2, s3, x1, x2, x3, x4, x5, x6) y_meters = PhiVal(s1, s2, s3, y1, y2, y3, y4, y5, y6) curve(i)%x(j) = x_meters curve(i)%y(j) = y_meters END DO ! j = 0, 3 !Construct control points in (x,y) space from arm lengths and azimuths: curve(i)%x(1) = curve(i)%x(0) + arm01 * COS(initial_argument) curve(i)%y(1) = curve(i)%y(0) + arm01 * SIN(initial_argument) curve(i)%x(2) = curve(i)%x(3) - arm23 * COS(final_argument) curve(i)%y(2) = curve(i)%y(3) - arm23 * SIN(final_argument) END DO ! i = 1, curve_count IF (group /= 2) THEN ! element boundary segments (not contours) will be needed to bound colored areas: !Sort edge-piercing points in array "around" and fill in gaps with non-contour curve segments, ! creating these new (quadratic, not cubic) curves in the (x,y) coordinate system: !First, check that corners of the triangle are represented in the list of ! points that will bound the edge curves. (This is important for filling out ! the area of the element, although it should have no effect on sub-area topologies.) got_zero = .FALSE. got_one = .FALSE. got_two = .FALSE. got_three = .FALSE. DO j = 1, point_count IF (ABS(around(j) - 0.0) < internal_tolerance) got_zero = .TRUE. IF (ABS(around(j) - 1.0) < internal_tolerance) got_one = .TRUE. IF (ABS(around(j) - 2.0) < internal_tolerance) got_two = .TRUE. IF (ABS(around(j) - 3.0) < internal_tolerance) got_three = .TRUE. END DO ! j = 1, point_count IF (.NOT.got_zero) THEN point_count = Increment_Point_Count() around(point_count) = 0.0 real_steps(point_count) = 0.0 ! (will never be used) real_sense(point_count) = 0.0 ! flag indicating "unknown" END IF IF (.NOT.got_one) THEN point_count = Increment_Point_Count() around(point_count) = 1.0 real_steps(point_count) = 0.0 ! (will never be used) real_sense(point_count) = 0.0 ! flag indicating "unknown" END IF IF (.NOT.got_two) THEN point_count = Increment_Point_Count() around(point_count) = 2.0 real_steps(point_count) = 0.0 ! (will never be used) real_sense(point_count) = 0.0 ! flag indicating "unknown" END IF IF (.NOT.got_three) THEN point_count = Increment_Point_Count() around(point_count) = 3.0 real_steps(point_count) = 0.0 ! (will never be used) real_sense(point_count) = 0.0 ! flag indicating "unknown" END IF ! Minimum value of point_count is now 4; ! re-sort on "around": CALL Sort_Lists (point_count, around, real_steps, real_sense) old_s1 = 1.0 ! circuit begins at node 1, where around(1) = 0.0 old_s2 = 0.0 old_s3 = 0.0 DO j = 2, point_count ! note: this loop should run for at least j = 2, 3, 4 (3 sides). IF (around(j-1) /= around(j)) THEN ! are start and finish points distinct? IF (around(j) <= 1.0) THEN s1 = 1.0 - around(j) s2 = around(j) ELSE IF (around(j) <= 2.0) THEN s1 = 0.0 s2 = 2.0 - around(j) ELSE ! around(j) > 2.0, up to 3.0 s1 = around(j) - 2.0 s2 = 0.0 END IF ! which side of triangle? s3 = 1.0 - s1 - s2 !CREATE new element-edge (non-contour) curve (quadratic, not cubic): curve_count = Increment_Curve_Count() s1_test = (old_s1 + s1) / 2.0 s2_test = (old_s2 + s2) / 2.0 ! midpoint of segment (in s-space) s3_test = 1.0 - s1_test - s2_test xa = PhiVal(old_s1, old_s2, old_s3, x1, x2, x3, x4, x5, x6) ya = PhiVal(old_s1, old_s2, old_s3, y1, y2, y3, y4, y5, y6) xb = PhiVal(s1_test, s2_test, s3_test, x1, x2, x3, x4, x5, x6) yb = PhiVal(s1_test, s2_test, s3_test, y1, y2, y3, y4, y5, y6) xc = PhiVal(s1, s2, s3, x1, x2, x3, x4, x5, x6) yc = PhiVal(s1, s2, s3, y1, y2, y3, y4, y5, y6) bx = 2.0 * xa - 4.0 * xb + 2.0 * xc ! logic here follows Curve_Through_3Nodes_in_Plane by = 2.0 * ya - 4.0 * yb + 2.0 * yc cx = -3.0 * xa + 4.0 * xb - xc cy = -3.0 * ya + 4.0 * yb - yc curve(curve_count)%x(0) = xa curve(curve_count)%y(0) = ya curve(curve_count)%x(1) = xa + cx / 3.0 curve(curve_count)%y(1) = ya + cy / 3.0 curve(curve_count)%x(2) = curve(curve_count)%x(1) + (cx + bx) / 3.0 curve(curve_count)%y(2) = curve(curve_count)%y(1) + (cy + by) / 3.0 curve(curve_count)%x(3) = xc curve(curve_count)%y(3) = yc curve(curve_count)%is_contour = .FALSE. !Complex logic to assign correct %half_steps to element-edge curve; !whenever possible, this is based on memory of the contours which bounded !it, expressed in arrays "real_steps" and "real_sense": f_defined = .FALSE. ! to be changed when we find a method that works! IF ((real_sense(j-1) /= 0.0).OR.(real_sense(j) /= 0.0)) THEN ! preferred method IF ((real_sense(j-1) /= 0.0).AND.(real_sense(j) /= 0.0)) THEN !we are graced with two indicators; compare their information: i1 = 2 * NINT(real_steps(j-1)) + NINT(real_sense(j-1)) i2 = 2 * NINT(real_steps(j) ) - NINT(real_sense(j) ) IF (i1 == i2) THEN ! we hope! curve(curve_count)%half_steps = i1 f_defined = .TRUE. ELSE ! logic problem; bug in code WRITE (*,"(' ERROR: Conflicting %half_steps information.')") CALL Traceback() END IF ! agreement, or disagreement ELSE IF (real_sense(j-1) /= 0.0) THEN ! use information from the left: curve(curve_count)%half_steps = 2 * NINT(real_steps(j-1)) + NINT(real_sense(j-1)) f_defined = .TRUE. ELSE ! use information from the right curve(curve_count)%half_steps = 2 * NINT(real_steps(j) ) - NINT(real_sense(j) ) f_defined = .TRUE. END IF ! left/right, left, or right information END IF ! information is available at left and/or right end point IF (.NOT.f_defined) THEN ! second chance: try looking further to the left IF (j >= 3) THEN ! there is "further left" to look at stepping_left: DO k = j-2, 1, -1 IF (real_sense(k) /= 0.0) THEN curve(curve_count)%half_steps = 2 * NINT(real_steps(k)) + NINT(real_sense(k)) f_defined = .TRUE. EXIT stepping_left END IF ! found information END DO stepping_left END IF ! j >= 3 END IF ! necessary to try second method IF (.NOT.f_defined) THEN ! third chance: try looking further to the right IF (j < point_count) THEN ! there is "further right" to look at stepping_right: DO k = j+1, point_count IF (real_sense(k) /= 0.0) THEN curve(curve_count)%half_steps = 2 * NINT(real_steps(k)) - NINT(real_sense(k)) f_defined = .TRUE. EXIT stepping_right END IF ! found information END DO stepping_right END IF ! j >= 3 END IF ! necessary to try third method IF (.NOT.f_defined) THEN ! final fall-back method for triangles with no contours at all: f_test = PhiVal(s1_test, s2_test, s3_test, f1, f2, f3, f4, f5, f6) IF (Steps_Off(f_test, contour_interval) < step_tolerance) THEN ! unacceptable! Move inside and try again! ds1 = internal_tolerance * ((1.0/3.0) - s1_test) ! These will move the test point ds2 = internal_tolerance * ((1.0/3.0) - s2_test) ! VERY slowly toward the center ds3 = internal_tolerance * ((1.0/3.0) - s3_test) ! of the element. DO WHILE ((Steps_Off(f_test, contour_interval) < step_tolerance).AND. & & (s1_test > -0.01).AND.(s2_test > -0.01).AND.(s3_test > -0.01)) !that is, prevent infinite loop if element has almost-constant values of f! s1_test = s1_test + ds1 s2_test = s2_test + ds2 s3_test = s3_test + ds3 f_test = PhiVal(s1_test, s2_test, s3_test, f1, f2, f3, f4, f5, f6) END DO END IF ! necessary to move inside to get a useful f_test value curve(curve_count)%half_steps = 1 + 2 * Int_Below(f_test / contour_interval) ! report an odd value f_defined = .TRUE. ! (for consistency, although not used any further below) END IF ! fall-back method is required curve(curve_count)%high_to_left = .FALSE. ! (this value is never used for non-contours) curve(curve_count)%forward = .TRUE. ! (until cancelled, when segment is used) curve(curve_count)%backward = .FALSE. curve(curve_count)%in_play = .FALSE. ! (will be set T at appropriate time, below) !prepare to loop old_s1 = s1 old_s2 = s2 old_s3 = s3 END IF ! start and end point are distinct END DO ! j = 2, point_count; creating non-contour edge segments ! CONNECT OUTLINES OF COLORED AREAS, circling counterclockwise around them! ! Note: This logic only creates simply-connected domains (like "I", "L", "S"); ! it cannot handle multiply-connected domains (like "O" or "8" or "B"). ! Fortunately, such domains only occur in the case of "dome" or "bowl" ! elements with extremum_inside = T and a fine contour interval. ! In these particular cases, I can simulate "O" shaped domains by ! stacking colored disks in the correct order. (For all other cases, ! the colored areas are non-overlapping, so the order of drawing is unimportant.) ! To handle these cases properly, I note that such closed internal contours ! were created first, before any others, and so I now reverse the order of ! drawing to put these overlapping areas on top, in the correct order. 1000 found_first = .FALSE. ! begin loop on colored areas, by trying to find a color-defining segment find_first: DO i = curve_count, 1, -1 ! curve_count is at least 3; reverse order is needed (see above) IF (curve(i)%is_contour) THEN IF (curve(i)%forward) THEN IF (curve(i)%high_to_left) THEN current_halves = 1 + curve(i)%half_steps ! odd ELSE ! lower values to left current_halves = curve(i)%half_steps - 1 ! odd END IF ! high or low to left found_first = .TRUE. i_first = i i_previous = i x_first = curve(i)%x(0) ; y_first = curve(i)%y(0) curve(i)%forward = .FALSE. ! cannot be used again in this direction f_test = contour_interval * current_halves / 2.0 IF (all_positive) f_test = MAX(f_test, 0.5 * contour_interval) CALL Set_Fill_by_Value (f_test, contour_interval, midspectrum_value, low_is_blue) CALL New_L3_Path(curve(i)%x(0), curve(i)%y(0)) CALL Curve_to_L3(curve(i)%x(1),curve(i)%y(1), curve(i)%x(2),curve(i)%y(2), curve(i)%x(3),curve(i)%y(3)) x_now = curve(i)%x(3) ; y_now = curve(i)%y(3) EXIT find_first ELSE IF (curve(i)%backward) THEN IF (curve(i)%high_to_left) THEN ! lower to left when going backward current_halves = curve(i)%half_steps - 1 ! odd ELSE ! lower values to left (going forward); higher to left going backward current_halves = 1 + curve(i)%half_steps ! odd END IF ! high or low to left found_first = .TRUE. i_first = i i_previous = i x_first = curve(i)%x(3) ; y_first = curve(i)%y(3) curve(i)%backward = .FALSE. ! cannot be used again in this direction f_test = contour_interval * current_halves / 2.0 IF (all_positive) f_test = MAX(f_test, 0.5 * contour_interval) CALL Set_Fill_by_Value (f_test, contour_interval, midspectrum_value, low_is_blue) CALL New_L3_Path(curve(i)%x(3), curve(i)%y(3)) CALL Curve_to_L3(curve(i)%x(2),curve(i)%y(2), curve(i)%x(1),curve(i)%y(1), curve(i)%x(0),curve(i)%y(0)) x_now = curve(i)%x(0) ; y_now = curve(i)%y(0) EXIT find_first END IF ! forward, or backward ELSE ! this curve is an edge segment; always used in forward direction (but cannot start area if half_steps is even). IF (curve(i)%forward) THEN ! this edge segment has not been used yet IF (MOD(curve(i)%half_steps, 2) /= 0) THEN ! odd value, OK to start an area current_halves = curve(i)%half_steps ! odd found_first = .TRUE. i_first = i i_previous = i x_first = curve(i)%x(0) ; y_first = curve(i)%y(0) curve(i)%forward = .FALSE. ! cannot be used again f_test = contour_interval * current_halves / 2.0 IF (all_positive) f_test = MAX(f_test, 0.5 * contour_interval) CALL Set_Fill_by_Value (f_test, contour_interval, midspectrum_value, low_is_blue) CALL New_L3_Path(curve(i)%x(0), curve(i)%y(0)) CALL Curve_to_L3(curve(i)%x(1),curve(i)%y(1), curve(i)%x(2),curve(i)%y(2), curve(i)%x(3),curve(i)%y(3)) x_now = curve(i)%x(3) ; y_now = curve(i)%y(3) EXIT find_first END IF ! odd value of half_steps END IF ! this edge segment has not been used yet END IF ! contour or edge segment END DO find_first IF (found_first) THEN ! continue to link curves (at least 1 more) until area is closed. !Initialize logical array in_play, whose only function is to guard against ever using DO i = 1, curve_count ! the same contour twice in the outline of a single area. curve(i)%in_play = .TRUE. ! except... END DO curve(i_first)%in_play = .FALSE. add_more: DO r2 = (x_now - x_first)**2 + (y_now - y_first)**2 IF (r2 <= r2_limit) THEN ! path has closed CALL End_L3_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) EXIT add_more END IF ! path has closed i_best = 0 ! it is intended that this will be replaced below r2_min = huge ! initialized so that we will find a smaller value below find_best: DO i = 1, curve_count IF (curve(i)%in_play) THEN ! it is legal to consider this one further IF (curve(i)%is_contour) THEN IF (curve(i)%forward) THEN IF (curve(i)%high_to_left) THEN test_halves = 1 + curve(i)%half_steps ! odd ELSE ! lower values to left test_halves = curve(i)%half_steps - 1 ! odd END IF ! high or low to left IF (test_halves == current_halves) THEN ! correct color r2 = (curve(i)%x(0) - x_now)**2 + (curve(i)%y(0) - y_now)**2 IF (r2 < r2_min) THEN ! new best guess r2_min = r2 i_best = i forward = .TRUE. END IF ! new best guess END IF ! correct color END IF ! forward direction is still available IF (curve(i)%backward) THEN IF (curve(i)%high_to_left) THEN ! lower to left when going backward test_halves = curve(i)%half_steps - 1 ! odd ELSE ! lower values to left (going forward); higher to left going backward test_halves = 1 + curve(i)%half_steps ! odd END IF ! high or low to left IF (test_halves == current_halves) THEN ! correct color r2 = (curve(i)%x(3) - x_now)**2 + (curve(i)%y(3) - y_now)**2 IF (r2 < r2_min) THEN ! new best guess r2_min = r2 i_best = i forward = .FALSE. END IF ! new best guess END IF ! correct color END IF ! backward direction is still available ELSE ! edge segment, not a contour IF (curve(i)%forward) THEN ! this edge segment has not been used yet test_halves = curve(i)%half_steps ! usually odd, but could be even IF (ABS(test_halves - current_halves) <= 1) THEN ! correct color r2 = (curve(i)%x(0) - x_now)**2 + (curve(i)%y(0) - y_now)**2 IF (r2 < r2_min) THEN ! new best guess r2_min = r2 i_best = i forward = .TRUE. END IF ! new best guess END IF ! correct color END IF ! edge segment still available END IF ! contour or edge segment END IF ! curve(i)%in_play END DO find_best trouble = (i_best == 0).OR.(r2_min > r2_limit) IF (trouble) THEN ! is there a way out? !Sometimes an extra contour will occur which essentially duplicates an element side; !then after the element is outlined, this contour may be left with neither !forward nor backward direction used. When we start along one side of this !contour, we find nothing in_play to connect to. In this case, we can get out of !trouble by doubling back along the same contour, and outlining a region !of zero width and zero area. That is, we override the in_play rule, but !ONLY after checking that no other curve permits a better solution. IF (curve(i_previous)%is_contour) THEN IF (curve(i_previous)%forward) THEN i_best = i_previous ! so that we can double back forward = .TRUE. trouble = .FALSE. ELSE IF (curve(i_previous)%backward) THEN i_best = i_previous ! so that we can double back forward = .FALSE. trouble = .FALSE. END IF END IF END IF IF (trouble) THEN ! We STILL could not find a curve to continue the outline with! WRITE (*, "(' ERROR in Contour_6Node_Triangle_in_Plane:')") WRITE (*, "(' could not find curve(s) needed to close an area.')") CALL Traceback() ELSE ! normal case; no trouble, use curve i_best to continue the outline IF (forward) THEN CALL Curve_to_L3(curve(i_best)%x(1),curve(i_best)%y(1), curve(i_best)%x(2),curve(i_best)%y(2), curve(i_best)%x(3),curve(i_best)%y(3)) x_now = curve(i_best)%x(3) y_now = curve(i_best)%y(3) curve(i_best)%forward = .FALSE. ! so it cannot be used any more ELSE ! going backward on this curve CALL Curve_to_L3(curve(i_best)%x(2),curve(i_best)%y(2), curve(i_best)%x(1),curve(i_best)%y(1), curve(i_best)%x(0),curve(i_best)%y(0)) x_now = curve(i_best)%x(0) y_now = curve(i_best)%y(0) curve(i_best)%backward = .FALSE. ! so it cannot be used any more END IF ! forward, or backward curve(i_best)%in_play = .FALSE. ! so it cannot be used in the other direction for THIS colored area i_previous = i_best ! memory (in case it is necessary to double back to get out of trouble) END IF ! found more of the outline, or didn't END DO add_more GO TO 1000 ! indefinite loop, as long as we succeeded in starting a new colored area END IF ! found_first END IF ! group /= 2; creating colored areas IF (group /= 1) THEN ! plot contours !Plot all contour curves without bothering to link them together: DO i = 1, curve_count IF (curve(i)%is_contour) THEN f_test = contour_interval * curve(i)%half_steps / 2 IF ((f_test > 0.0).OR.(.NOT.all_positive)) THEN ! this contour should be seen CALL Set_Stroke_by_Value (f_test, contour_interval, midspectrum_value, low_is_blue) CALL New_L3_Path (curve(i)%x(0), curve(i)%y(0)) CALL Curve_to_L3(curve(i)%x(1),curve(i)%y(1), curve(i)%x(2),curve(i)%y(2), curve(i)%x(3),curve(i)%y(3)) CALL End_L3_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! this contour should be seen END IF ! curve(i)%is_contour END DO !Also, add contour line along any element side where all 3 nodes have value == contour; !the normal algorithm may miss these. DO mside = 1, 3 n1 = mside n4 = mside + 3 n2 = MOD(mside, 3) + 1 high_on_side = MAX(fn(n1), fn(n4), fn(n2)) low_on_side = MIN(fn(n1), fn(n4), fn(n2)) IF ((high_on_side - low_on_side) < (step_tolerance * contour_interval)) THEN !There is a constant value along this side of the element j = NINT(fn(n4) / contour_interval) IF (ABS(fn(n4) - j * contour_interval) < (step_tolerance * contour_interval)) THEN !This constant value is also a contour value. IF ((j > 0).OR.(.NOT.all_positive)) THEN ! this contour should be seen CALL Set_Stroke_by_Value (fn(n4), contour_interval, midspectrum_value, low_is_blue) CALL New_L3_Path (x_meters = xn(n1), y_meters = yn(n1)) CALL Curve_Through_3Nodes_in_Plane(xn(n1),yn(n1), xn(n4),yn(n4), xn(n2),yn(n2)) CALL End_L3_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! this contour should be seen END IF ! the constant value is a contour value END IF ! this side is a constant value END DO END IF ! group /= 1; plotting contours high_value = MAX(high_value, f_sup) low_value = MIN(low_value, f_inf) IF (all_positive) low_value = MAX(low_value, 0.0) CONTAINS ! code re-used multiple times within Contour_6Node_Scalar_in_Plane: SUBROUTINE AlphaBeta_2_S1S2 (alpha, beta, s1, s2) !coordinate change, using global: pivot_s1, pivot_s2, back_matrix(2,2), dads, dbds IMPLICIT NONE REAL, INTENT(IN) :: alpha, beta REAL, INTENT(OUT):: s1, s2 REAL :: t1, t2, u1, u2 !Scaling: u1 = alpha / dads u2 = beta / dbds !Rotation: t1 = back_matrix(1, 1) * u1 + back_matrix(1, 2) * u2 t2 = back_matrix(2, 1) * u1 + back_matrix(2, 2) * u2 !Restore original origin s1 = t1 + pivot_s1 ; s2 = t2 + pivot_s2 END SUBROUTINE AlphaBeta_2_S1S2 INTEGER FUNCTION Increment_Curve_Count() IF (curve_count < max_curves) THEN Increment_Curve_Count = curve_count + 1 ELSE WRITE (*, "(' ERROR: Contour interval is too small, causing too many contours,')") WRITE (*, "(' exhausting the working storage in Contour_6Node_Scalar_in_Plane.')") CALL Traceback() END IF END FUNCTION Increment_Curve_Count INTEGER FUNCTION Increment_Point_Count() IF (point_count < max_points) THEN Increment_Point_Count = point_count + 1 ELSE WRITE (*, "(' ERROR: Contour interval is too small, causing too many contour points,')") WRITE (*, "(' exhausting the working storage in Contour_6Node_Scalar_in_Plane.')") CALL Traceback() END IF END FUNCTION Increment_Point_Count SUBROUTINE SixNode_Boundary_Range (fn, f_inf, f_sup) !Finds range of quadratic scalar along sides of a 6-node plane triangle element. IMPLICIT NONE REAL, DIMENSION(6), INTENT(IN) :: fn REAL, INTENT(OUT) :: f_inf, f_sup INTEGER :: mside, n1, n2, n4 REAL :: a, b, c, f, s f_inf = fn(1) ; f_sup = f_inf ! initialize search DO mside = 1, 3 n1 = mside ! index of initial node on this side n4 = mside + 3 ! index of mid-point node on this side n2 = MOD(mside, 3) + 1 ! index of final node on this side !Along this side (0.0 <= s <= 1.0), f(s) = fn(n1) * (1 - 3 * s + 2 s**2) + ! fn(n4) * (4 s * (1 - s)) + ! fn(n2) * (-s + 2 * s**2) !or, to put it into standard quadratic notation, with f(s) = a * s**2 + b * s + c, a = 2.0 * fn(n1) - 4.0 * fn(n4) + 2.0 * fn(n2) b = -3.0 * fn (n1) + 4.0 * fn(n4) - fn(n2) c = fn(n1) IF (a == 0.0) THEN !linearly-varying or constant scalar along this side, no extremum f_sup = MAX(f_sup, fn(n1), fn(n2)) f_inf = MIN(f_inf, fn(n1), fn(n2)) ELSE ! scalar varies quadratically along this side; extremum exists !Derivitive df(s)/ds = 2 * a * s + b = 0 at extremum: s = -b / (2.0 * a) IF ((s > 0.0).AND.(s < 1.0)) THEN ! extremum is within the side f = a * s**2 + b * s + c f_sup = MAX(f_sup, f, fn(n1), fn(n2)) f_inf = MIN(f_inf, f, fn(n1), fn(n2)) ELSE ! extremum is beyond the ends of the side, and not relevant f_sup = MAX(f_sup, fn(n1), fn(n2)) f_inf = MIN(f_inf, fn(n1), fn(n2)) END IF ! extremum is within, or beyond ends of, this side END IF ! linear or quadratic variation along this side END DO END SUBROUTINE SixNode_Boundary_Range REAL FUNCTION Steps_Off (f, contour_interval) !reports 0.0 if f is divisible by countour_interval; !otherwise reports a positive real in range (0.0, 1.0) !showing how far we are from the nearest contour. IMPLICIT NONE REAL, INTENT(IN) :: f, contour_interval INTEGER :: i i = NINT(f / contour_interval) Steps_Off = ABS(f - i * contour_interval) / contour_interval END FUNCTION Steps_Off SUBROUTINE S1S2_2_AlphaBeta (s1, s2, alpha, beta) !coordinate change, using global: pivot_s1, pivot_s2, out_matrix(2,2), dads, dbds IMPLICIT NONE REAL, INTENT(IN) :: s1, s2 REAL, INTENT(OUT) :: alpha, beta REAL :: t1, t2, u1, u2 !Move to new origin t1 = s1 - pivot_s1 ; t2 = s2 - pivot_s2 !Rotation: u1 = out_matrix(1, 1) * t1 + out_matrix(1, 2) * t2 u2 = out_matrix(2, 1) * t1 + out_matrix(2, 2) * t2 !Scaling: alpha = u1 * dads beta = u2 * dbds END SUBROUTINE S1S2_2_AlphaBeta REAL FUNCTION Winding (argument) ! returns result 0.0 <= Winding < Two_Pi IMPLICIT NONE REAL, INTENT(IN) :: argument Winding = MOD((argument + 2.0 * Two_Pi), Two_Pi) END FUNCTION Winding END SUBROUTINE Contour_6Node_Scalar_in_Plane SUBROUTINE Curve_Through_3Nodes_in_Plane(xa,ya, xb,yb, xc,yc) ! Assuming that a path is open on level 3 (map plane, units of meters) ! and that the current point is (xa,ya), this routine will advance the ! path by a single Curve_to_L3 such that it passes through (xb,yb) and ! ends at (xc,yc). The curve used is a quadratic isoparametric curve, ! which is a special case of the general cubic isoparametric (Bezier) curve. IMPLICIT NONE REAL, INTENT(IN) :: xa,ya, xb,yb, xc,yc REAL :: bx, by, cx, cy, x0, y0, x1, x2, x3, y1, y2, y3 bx = 2.0 * xa - 4.0 * xb + 2.0 * xc by = 2.0 * ya - 4.0 * yb + 2.0 * yc cx = -3.0 * xa + 4.0 * xb - xc cy = -3.0 * ya + 4.0 * yb - yc x0 = xa y0 = ya x1 = x0 + cx / 3.0 y1 = y0 + cy / 3.0 x2 = x1 + (cx + bx) / 3.0 y2 = y1 + (cy + by) / 3.0 x3 = xc y3 = yc CALL Curve_to_L3(x1,y1, x2,y2, x3,y3) END SUBROUTINE Curve_Through_3Nodes_in_Plane SUBROUTINE DipTick_in_Plane (level, x, y, dip_angle_radians, & & style_byte, size_points, offset_points) ! Plots a single dip-tick at (x,y), whose units depend on level: ! level = 1: draws anywhere on paper; (x,y) coordinates in points. ! level = 2: draws only in map window; (x,y) coordinates in points. ! level = 3: draws only in map window; (x,y) ccordinates in meters. ! Dip_angle_radians is measured counterclockwise from +x. ! (Note that +x direction may differ for level = 3 vs. = 1 or 2.) ! Style_byte = (D)etachment/low-angle, (L)eft-lateral, (N)ormal/high-angle, ! (R)ight-lateral, high-angle (T)hrust/reverse, or ! low-angle (P)late or nappe or subduction zone. ! Size_points is the size of the symbol plotted. ! Offset_points is an offset of the beginning of the symbol ! from (x,y) in the direction dip_angle_radians; a good ! value is 40~50% of the width of the line used for fault traces; ! if this is uncertain, then use zero. (Note that L and R ! half-arrows are already moved away from the trace some ways; ! this parameter will give additional displacement for fat traces.) ! Note that the line-weight, line-color, fill-color/pattern ! are not set here, and should be pre-set. Typically, the ! fill color should match the line color, since P and D ! symbols are filled (only), while L, R, T, and N symbols are ! stroked (only). IMPLICIT NONE INTEGER, INTENT(IN) :: level REAL, INTENT(IN) :: x, y, dip_angle_radians, size_points, offset_points CHARACTER*1, INTENT(IN) :: style_byte REAL :: cos_dip, meters_per_point, offset, sin_dip, size, & & xe, x1, x2, x3, x4, & & ye, y1, y2, y3, y4 IF ((level < 1).OR.(level > 3)) THEN WRITE (*,"(' ERROR: Illegal level = ',I2,' for DipTick_in_Plane.')") level CALL Traceback END IF IF (level == 3) THEN ! must plot in meters meters_per_point = (3.527777E-4)*mp_scale_denominator size = meters_per_point * size_points offset = meters_per_point * offset_points ELSE ! level 1 or 2; plotting in points size = size_points offset = offset_points END IF cos_dip = COS(dip_angle_radians) sin_dip = SIN(dip_angle_radians) xe = x + offset * cos_dip ye = y + offset * sin_dip SELECT CASE (style_byte) CASE ('D') ! Detachment; filled rectangle (not stroked) x1 = xe + 0.5 * size * sin_dip y1 = ye - 0.5 * size * cos_dip x2 = x1 + 1.0 * size * cos_dip y2 = y1 + 1.0 * size * sin_dip x3 = x2 - 1.0 * size * sin_dip y3 = y2 + 1.0 * size * cos_dip x4 = x3 - 1.0 * size * cos_dip y4 = y3 - 1.0 * size * sin_dip IF (level == 3) THEN CALL New_L3_Path(x1,y1) CALL Line_to_L3(x2,y2) CALL Line_to_L3(x3,y3) CALL Line_to_L3(x4,y4) CALL Line_to_L3(x1,y1) CALL End_L3_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level, x1,y1) CALL Line_to_L12(x2,y2) CALL Line_to_L12(x3,y3) CALL Line_to_L12(x4,y4) CALL Line_to_L12(x1,y1) CALL End_L12_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF CASE ('L') ! Left-lateral; paired stroked half-arrows x1 = x + 0.5 * size * (+cos_dip +sin_dip) + offset * cos_dip ! point 1 is tail y1 = y + 0.5 * size * (+sin_dip -cos_dip) + offset * sin_dip ! moveout + half-length x2 = x1 - 1.0 * size * sin_dip ! point 2 is arrow tip y2 = y1 + 1.0 * size * cos_dip x3 = x2 + 0.2 * size * (+cos_dip +sin_dip) ! point 3 = barb y3 = y2 + 0.2 * size * (-cos_dip +sin_dip) IF (level == 3) THEN CALL New_L3_Path(x1,y1) CALL Line_to_L3(x2,y2) CALL Line_to_L3(x3,y3) CALL End_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level, x1,y1) CALL Line_to_L12(x2,y2) CALL Line_to_L12(x3,y3) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! same as above except +, - are flipped, as far left as possible x1 = x - 0.5 * size * (+cos_dip +sin_dip) - offset * cos_dip ! point 1 is tail y1 = y - 0.5 * size * (+sin_dip -cos_dip) - offset * sin_dip ! moveout + half-length x2 = x1 + 1.0 * size * sin_dip ! point 2 is arrow tip y2 = y1 - 1.0 * size * cos_dip x3 = x2 - 0.2 * size * (+cos_dip +sin_dip) ! point 3 = barb y3 = y2 - 0.2 * size * (-cos_dip +sin_dip) IF (level == 3) THEN CALL New_L3_Path(x1,y1) CALL Line_to_L3(x2,y2) CALL Line_to_L3(x3,y3) CALL End_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level, x1,y1) CALL Line_to_L12(x2,y2) CALL Line_to_L12(x3,y3) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF CASE ('N') ! Normal (high-angle); straight stroked line x1 = xe + size * cos_dip y1 = ye + size * sin_dip IF (level == 3) THEN CALL New_L3_Path(xe,ye) CALL Line_to_L3(x1,y1) CALL End_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level, xe,ye) CALL Line_to_L12(x1,y1) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF CASE ('R') ! Right-lateral; paired stroked half-arrows x1 = x + 0.5 * size * (+cos_dip -sin_dip) + offset * cos_dip ! point 1 is tail y1 = y + 0.5 * size * (+sin_dip +cos_dip) + offset * sin_dip ! moveout + half-length x2 = x1 + 1.0 * size * sin_dip ! point 2 is arrow tip y2 = y1 - 1.0 * size * cos_dip x3 = x2 + 0.2 * size * (+cos_dip -sin_dip) ! point 3 = barb y3 = y2 + 0.2 * size * (+cos_dip +sin_dip) IF (level == 3) THEN CALL New_L3_Path(x1,y1) CALL Line_to_L3(x2,y2) CALL Line_to_L3(x3,y3) CALL End_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level, x1,y1) CALL Line_to_L12(x2,y2) CALL Line_to_L12(x3,y3) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! same as above except +, - are flipped, as far left as possible x1 = x - 0.5 * size * (+cos_dip -sin_dip) - offset * cos_dip ! point 1 is tail y1 = y - 0.5 * size * (+sin_dip +cos_dip) - offset * sin_dip ! moveout + half-length x2 = x1 - 1.0 * size * sin_dip ! point 2 is arrow tip y2 = y1 + 1.0 * size * cos_dip x3 = x2 - 0.2 * size * (+cos_dip -sin_dip) ! point 3 = barb y3 = y2 - 0.2 * size * (+cos_dip +sin_dip) IF (level == 3) THEN CALL New_L3_Path(x1,y1) CALL Line_to_L3(x2,y2) CALL Line_to_L3(x3,y3) CALL End_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level, x1,y1) CALL Line_to_L12(x2,y2) CALL Line_to_L12(x3,y3) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF CASE ('T') ! high-angle Thrust; equilateral triangle (not filled) x1 = xe + 0.577 * size * sin_dip y1 = ye - 0.577 * size * cos_dip x2 = xe + 1.000 * size * cos_dip y2 = ye + 1.000 * size * sin_dip x3 = xe - 0.577 * size * sin_dip y3 = ye + 0.577 * size * cos_dip IF (level == 3) THEN CALL New_L3_Path(x1,y1) CALL Line_to_L3(x2,y2) CALL Line_to_L3(x3,y3) CALL Line_to_L3(x1,y1) CALL End_L3_Path(close = .TRUE., stroke = .TRUE., fill = .FALSE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level, x1,y1) CALL Line_to_L12(x2,y2) CALL Line_to_L12(x3,y3) CALL Line_to_L12(x1,y1) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF CASE ('P', 'S') ! Plate or nappe or Subduction zone; filled equilateral triangle (not stroked) x1 = xe + 0.577 * size * sin_dip y1 = ye - 0.577 * size * cos_dip x2 = xe + 1.000 * size * cos_dip y2 = ye + 1.000 * size * sin_dip x3 = xe - 0.577 * size * sin_dip y3 = ye + 0.577 * size * cos_dip IF (level == 3) THEN CALL New_L3_Path(x1,y1) CALL Line_to_L3(x2,y2) CALL Line_to_L3(x3,y3) CALL Line_to_L3(x1,y1) CALL End_L3_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level, x1,y1) CALL Line_to_L12(x2,y2) CALL Line_to_L12(x3,y3) CALL Line_to_L12(x1,y1) CALL End_L12_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF CASE DEFAULT WRITE (*,"(' ERROR: Illegal style_byte (',A,') to DipTick_in_Plane.')") style_byte CALL Traceback END SELECT END SUBROUTINE DipTick_in_Plane SUBROUTINE DipTick_on_Sphere (uvec, dip_azimuth_radians, & & style_byte, size_points, offset_points) ! Plots a single dip-tick at "uvec". ! Dip_azimuth_radians is measured clockwise from local North. ! Style_byte = (D)etachment, (L)eft-lateral, (N)ormal/high-angle; ! (R)ight-lateral, (T)hrust, or thrust (P)late/nappe. ! {but if this byte is a space, nothing is plotted} ! Size_points is the size of the symbol plotted. ! Offset_points is an offset of the beginning of the symbol ! from "uvec" in the direction dip_angle_radians; a good ! value is 40% of the width of the line used for fault traces; ! if this is uncertain, then use zero. (Note that L and R ! half-arrows are already moved away from the trace automatically; ! it is not necessary to give any more offset with this parameter.) ! Note that the line-weight, line-color, fill-color/pattern ! are not set here, and should be pre-set. Typically, the ! fill color should match the line color, since P and D ! symbols are filled (only), whereas T, L, R, and N symbols ! are stroked (only). IMPLICIT NONE REAL, DIMENSION(3), INTENT(IN) :: uvec REAL, INTENT(IN) :: dip_azimuth_radians, size_points, offset_points CHARACTER*1, INTENT(IN) :: style_byte REAL :: radians_per_point, offset_radians, Pi_over_4, & & size_radians REAL, DIMENSION(3) :: offset_uvec, omega_uvec, saved_uvec, t_uvec Pi_over_4 = Pi/4. radians_per_point = (3.527777E-4)*(mp_scale_denominator*Conformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) size_radians = radians_per_point * size_points offset_radians = radians_per_point * offset_points CALL Turn_To (dip_azimuth_radians, uvec, offset_radians, & ! inputs & omega_uvec, offset_uvec) SELECT CASE (style_byte) CASE ('D') ! Detachment; filled rectangle (not stroked) CALL Turn_To (dip_azimuth_radians+Pi_over_2, offset_uvec, 0.5*size_radians, & & omega_uvec, saved_uvec) CALL New_L45_Path(5, saved_uvec) CALL Turn_To (dip_azimuth_radians, saved_uvec, size_radians, & & omega_uvec, t_uvec) CALL Great_to_L45(t_uvec) CALL Turn_To (dip_azimuth_radians-Pi_over_2, t_uvec, size_radians, & & omega_uvec, t_uvec) CALL Great_to_L45(t_uvec) CALL Turn_To (dip_azimuth_radians+Pi, t_uvec, size_radians, & & omega_uvec, t_uvec) CALL Great_to_L45(t_uvec) CALL Great_to_L45(saved_uvec) CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) CASE ('L') ! Left-lateral; paired stroked half-arrows CALL Turn_To (dip_azimuth_radians, uvec, offset_radians, & & omega_uvec, t_uvec) ! offset to one side CALL Turn_To (dip_azimuth_radians+Pi_over_4, t_uvec, 0.707*size_radians, & & omega_uvec, t_uvec) ! tail of dip-side arrow CALL New_L45_Path(5, t_uvec) CALL Turn_To (dip_azimuth_radians, uvec, offset_radians, & & omega_uvec, t_uvec) ! offset to one side CALL Turn_To (dip_azimuth_radians-Pi_over_4, t_uvec, 0.707*size_radians, & & omega_uvec, t_uvec) ! head of dip-side arrow CALL Great_to_L45(t_uvec) CALL Turn_To (dip_azimuth_radians+Pi_over_4, t_uvec, 0.283*size_radians, & & omega_uvec, t_uvec) ! barb of dip-side arrow CALL Great_to_L45(t_uvec) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL Turn_To (dip_azimuth_radians+Pi, uvec, offset_radians, & & omega_uvec, t_uvec) ! offset to other side CALL Turn_To (dip_azimuth_radians+Pi+Pi_over_4, t_uvec, 0.707*size_radians, & & omega_uvec, t_uvec) ! tail of other-side arrow CALL New_L45_Path(5, t_uvec) CALL Turn_To (dip_azimuth_radians+Pi, uvec, offset_radians, & & omega_uvec, t_uvec) ! offset to other side CALL Turn_To (dip_azimuth_radians+Pi-Pi_over_4, t_uvec, 0.707*size_radians, & & omega_uvec, t_uvec) ! head of other-side arrow CALL Great_to_L45(t_uvec) CALL Turn_To (dip_azimuth_radians+Pi+Pi_over_4, t_uvec, 0.283*size_radians, & & omega_uvec, t_uvec) ! barb of other-side arrow CALL Great_to_L45(t_uvec) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CASE ('N') ! Normal (high-angle); straight stroked line CALL New_L45_Path(5, offset_uvec) CALL Turn_To (dip_azimuth_radians, offset_uvec, size_radians, & & omega_uvec, t_uvec) CALL Great_to_L45(t_uvec) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CASE ('R') ! Right-lateral; paired stroked half-arrows CALL Turn_To (dip_azimuth_radians, uvec, offset_radians, & & omega_uvec, t_uvec) ! offset to one side CALL Turn_To (dip_azimuth_radians-Pi_over_4, t_uvec, 0.707*size_radians, & & omega_uvec, t_uvec) ! tail of dip-side arrow CALL New_L45_Path(5, t_uvec) CALL Turn_To (dip_azimuth_radians, uvec, offset_radians, & & omega_uvec, t_uvec) ! offset to one side CALL Turn_To (dip_azimuth_radians+Pi_over_4, t_uvec, 0.707*size_radians, & & omega_uvec, t_uvec) ! head of dip-side arrow CALL Great_to_L45(t_uvec) CALL Turn_To (dip_azimuth_radians-Pi_over_4, t_uvec, 0.283*size_radians, & & omega_uvec, t_uvec) ! barb of dip-side arrow CALL Great_to_L45(t_uvec) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL Turn_To (dip_azimuth_radians+Pi, uvec, offset_radians, & & omega_uvec, t_uvec) ! offset to other side CALL Turn_To (dip_azimuth_radians+Pi-Pi_over_4, t_uvec, 0.707*size_radians, & & omega_uvec, t_uvec) ! tail of other-side arrow CALL New_L45_Path(5, t_uvec) CALL Turn_To (dip_azimuth_radians+Pi, uvec, offset_radians, & & omega_uvec, t_uvec) ! offset to other side CALL Turn_To (dip_azimuth_radians+Pi+Pi_over_4, t_uvec, 0.707*size_radians, & & omega_uvec, t_uvec) ! head of other-side arrow CALL Great_to_L45(t_uvec) CALL Turn_To (dip_azimuth_radians+Pi-Pi_over_4, t_uvec, 0.283*size_radians, & & omega_uvec, t_uvec) ! barb of other-side arrow CALL Great_to_L45(t_uvec) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CASE ('T') ! Thrust; stroked equilateral triangle (not filled) CALL Turn_To (dip_azimuth_radians+Pi_over_2, offset_uvec, 0.577*size_radians, & & omega_uvec, saved_uvec) CALL New_L45_Path(5, saved_uvec) CALL Turn_To (dip_azimuth_radians, offset_uvec, size_radians, & & omega_uvec, t_uvec) CALL Great_to_L45(t_uvec) CALL Turn_To (dip_azimuth_radians-Pi_over_2, offset_uvec, 0.577*size_radians, & & omega_uvec, t_uvec) CALL Great_to_L45(t_uvec) CALL Great_to_L45(saved_uvec) CALL End_L45_Path(close = .TRUE., stroke = .TRUE., fill = .FALSE.) CASE ('P', 'S') ! Plate or nappe or Subduction zone; filled equilateral triangle (not stroked) CALL Turn_To (dip_azimuth_radians+Pi_over_2, offset_uvec, 0.577*size_radians, & & omega_uvec, saved_uvec) CALL New_L45_Path(5, saved_uvec) CALL Turn_To (dip_azimuth_radians, offset_uvec, size_radians, & & omega_uvec, t_uvec) CALL Great_to_L45(t_uvec) CALL Turn_To (dip_azimuth_radians-Pi_over_2, offset_uvec, 0.577*size_radians, & & omega_uvec, t_uvec) CALL Great_to_L45(t_uvec) CALL Great_to_L45(saved_uvec) CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) CASE (' ') ! take no action; usually this is the second_dip_byte of a fault that has none CASE DEFAULT WRITE (*,"(' ERROR: Illegal style_byte (',A,') to DipTick_on_Sphere.')") style_byte WRITE (*,"(' No dip tick or movement sense will be displayed for this fault.')") !CALL Traceback END SELECT END SUBROUTINE DipTick_on_Sphere SUBROUTINE Graticule (minutes) ! Adds a graphics group at level 7, containing ! parallels of latitude and meridians of longitude ! with a spacing of "minutes" minutes of arc. !(Use 60 for 1-degree; 300 for 5-degree, etc.) ! The poles are marked with X's. ! Note that line width, color, dashing, etc. are ! not specified here and should be pre-defined IMPLICIT NONE INTEGER, INTENT(IN) :: minutes INTEGER :: i, i1, i2 LOGICAL :: saved_dashed REAL:: lat, lat1, lat2, lon, saved_off_points, saved_on_points, saved_width_points IF (minutes < 1) THEN WRITE (*,"(' ERROR: Integer parameter minutes sent to Graticule must be >= 1')") CALL Traceback END IF CALL Begin_Group ! parallels of latitude i1 = minutes * Int_Above((-90. * 60. + 1.) / minutes) i2 = minutes * Int_Below((+90. * 60. - 1.) / minutes) DO i = i1, i2, minutes lat = i / 60. CALL New_L67_Path (7, 0., lat) CALL Small_To_L67 (0., 90., 0., lat) CALL End_L67_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END DO ! parallels of latitude ! meridians of longitude i1 = minutes * Int_Above((-180. * 60.) / minutes) i2 = minutes * Int_Below((+180. * 60.) / minutes) lat1 = (minutes / 60.) * Int_Above((-90. * 60. + 1.) / minutes) lat2 = (minutes / 60.) * Int_Below((+90. * 60. - 1.) / minutes) DO i = i1, i2, minutes lon = i / 60. CALL New_L67_Path (7, lon, lat1) CALL Great_To_L67 (lon, lat2) CALL End_L67_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! meridians of longitude ! save current line style saved_width_points = ai_current_line_width_points saved_dashed = ai_current_line_dashed saved_on_points = ai_current_line_on_points saved_off_points = ai_current_line_off_points ! impose solid (non-dashed) line for polar X's: CALL Set_Line_Style (width_points = saved_width_points, & & dashed = .FALSE.) ! X at S pole: lat1 = -90. + (0.2 * minutes) / 60. CALL Begin_Group CALL New_L67_Path (7, 0., lat1) CALL Great_To_L67 (180., lat1) CALL End_L67_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL New_L67_Path (7, 90., lat1) CALL Great_To_L67 (-90., lat1) CALL End_L67_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL End_Group ! X at N pole: lat2 = +90. - (0.2 * minutes) / 60. CALL Begin_Group CALL New_L67_Path (7, 0., lat2) CALL Great_To_L67 (180., lat2) CALL End_L67_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL New_L67_Path (7, 90., lat2) CALL Great_To_L67 (-90., lat2) CALL End_L67_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL End_Group CALL End_Group ! restore line style as it was CALL Set_Line_Style (width_points = saved_width_points, & & dashed = saved_dashed, on_points = saved_on_points, off_points = saved_off_points) END SUBROUTINE Graticule ! SUBROUTINE Grd_List(path_in, suggested_file) ! ! Reports a list (on default device) of filenames of the ! ! gridded-data (*.grd) type in directory path_in ! ! (or in some other path temporarily set by user). ! ! ! ! Changes to CHARACTER*(*), INTENT(INOUT) :: suggested_file ! ! depend on how many files (of specified type) are ! ! found in the current directory: ! ! * If none are found, suggested_file is unchanged (it may ! ! be a correct file name in some other directory). ! ! * If one file is found, suggested_file is changed to its name. ! ! * If multiple files are found: ! ! -if suggested_file is one of them, it is unchanged. ! ! -if suggested_file is not one, it is changed to ' '. ! ! ! ! Uses GETFILEINFOQQ of module DFLIB.F90 ! ! (DIGITAL Visual Fortran 5.0). ! IMPLICIT NONE ! CHARACTER*(*), INTENT(IN) :: path_in ! CHARACTER*(*), INTENT(INOUT) :: suggested_file ! CHARACTER*70 :: line = ' ', old_name ! CHARACTER*80 :: string0, string1, string2, & ! & use_path_in ! temporary version, may be changed ! CHARACTER*255 :: files ! INTEGER :: count, full_to, handle, old_result, result ! LOGICAL :: duplicate, matched !! TYPE file$info ! this type as defined in DFLIB.F90 !! INTEGER(4) creation !! INTEGER(4) lastwrite !! INTEGER(4) lastaccess !! INTEGER(4) length !! INTEGER(4) permit ! CHARACTER(255) name !! END TYPE file$info ! TYPE (FILE$INFO) info ! this type as defined in DFLIB.F90 ! use_path_in = TRIM(path_in) !10 count = 0 ! matched = .FALSE. ! until we find a file == suggested_file ! WRITE (*,"(/' The following appear to be gridded data (.grd) files:')") ! files = TRIM(use_path_in) // '*.GRD' ! full_to = 0 ! keeps track of use of line ! handle = FILE$FIRST ! flag constant, defined in DFLIB as -1 ! old_result = -999 ! old_name = 'undefined' ! all_files: DO ! result = GETFILEINFOQQ (TRIM(files), info, handle) ! !check for duplicate return of last file (a bug in GETFILEINFOQQ): ! IF (result >= 1) THEN ! duplicate = (result == old_result) .AND. (info.name(1:result) == TRIM(old_name)) ! old_name = info.name(1:result) ! ELSE ! duplicate = .FALSE. ! old_name = ' ' ! END IF ! old_result = result ! !- - - - - - - - - - - - - - - - - - - ! IF (handle == FILE$ERROR) RETURN ! defined in DFLIB as -3 ! IF ((result == 0).OR.duplicate) THEN ! no (new) matching files found ! IF (full_to > 0) THEN ! WRITE (*,"(' ',A)") TRIM(line) ! GOTO 100 ! ELSE IF (count == 0) THEN ! WRITE (*,"(' No such files in the input directory.')") ! CALL Prompt_for_String('What path shall we search (for this file only)?',use_path_in,use_path_in) ! GO TO 10 ! ELSE ! count > 0, but line empty ! GOTO 100 ! END IF ! END IF ! !If we've gotten this far, we have a qualified file! ! count = count + 1 ! string0 = TRIM(suggested_file) ! CALL Upper_Case(string0) ! string1 = info.name(1:result) ! string2 = string1 ! CALL Upper_Case(string2) ! matched = matched .OR. (string0 == string2) ! IF ((full_to + 2 + result) > 70) THEN ! line would overflow ! WRITE (*,"(' ',A)") TRIM(line) ! full_to = 0 ! line = ' ' ! line = info.name(1:result) ! full_to = result ! ELSE ! line can accept this name ! IF (full_to == 0) THEN ! no leading spaces ! line = info.name(1:result) ! full_to = result ! ELSE ! use 2 leading spaces ! line = TRIM(line) // ' ' // info.name(1:result) ! full_to = full_to + 2 + result ! END IF ! END IF ! IF (handle == FILE$LAST) THEN ! IF (full_to > 0) WRITE (*,"(' ',A)") TRIM(line) ! GOTO 100 ! END IF ! END DO all_files ! 100 IF (count == 1) THEN ! collector point, replacing "RETURN" ! ! so that we can adjust suggested_file(?) ! suggested_file = TRIM(string1) ! ELSE IF (count > 1) THEN ! IF (.NOT.matched) THEN ! suggested_file = ' ' ! END IF ! END IF ! END SUBROUTINE Grd_List SUBROUTINE GreatCircle_Point (from_uvec, to_uvec, s, & ! inputs & point_uvec, azimuth_radians) ! outputs ! Finds a point within a lesser arc of a great circle from ! "from_uvec" to "to_uvec" identified by dimensionless variable ! "s", which is 0.00 at "from_uvec" and 1.00 at "to_uvec. ! Also returns "azimuth_radians" which is the azimuth of travel ! (with increasing s) at that point. ! Useful for placing tick marks along a great-circle fault, for example. IMPLICIT NONE REAL, DIMENSION(3), INTENT(IN) :: from_uvec, to_uvec REAL, INTENT(IN) :: s REAL, DIMENSION(3), INTENT(OUT) :: point_uvec REAL, INTENT(OUT) :: azimuth_radians REAL :: radians_to_s, radians_to_1, start_azimuth REAL, DIMENSION(3) :: omega_uvec, t_uvec start_azimuth = Relative_Compass(from_uvec, to_uvec) radians_to_1 = Arc(from_uvec, to_uvec) radians_to_s = s * radians_to_1 !save to_uvec, in case CALLer modifies it by repeating actual argument t_uvec = to_uvec CALL Turn_To (start_azimuth, from_uvec, radians_to_s, & ! inputs & omega_uvec, point_uvec) ! point_uvec might replace to_uvec! IF (s >= 0.5) THEN ! look back and add Pi azimuth_radians = Pi + Relative_Compass(point_uvec, from_uvec) ELSE ! s < 0.5; possibly negative; look forward azimuth_radians = Relative_Compass(point_uvec, t_uvec) END IF END SUBROUTINE GreatCircle_Point SUBROUTINE Group_or_Bitmap (latter_mosaic, method, bitmap_height, bitmap_width) !Reads these values from module Adobe_Illustrator: ! ai_spectrum_count ! ai_window_x1_points, ai_window_x2_points, ! ai_window_y1_points, ai_window_y2_points IMPLICIT NONE LOGICAL, INTENT(IN) :: latter_mosaic ! if so, no choice allowed! INTEGER, INTENT(INOUT) :: method, bitmap_height, bitmap_width IF (latter_mosaic) THEN method = 1 ! no choice allowed; a latter bitmap mosaic would hide the first! WRITE (*,*) WRITE (*,"(' NOTE: When additional mosaics are layered,')") WRITE (*,"(' you are not allowed to choose the bitmap format,')") WRITE (*,"(' because this would completely hide the first mosaic.')") WRITE (*,*) ELSE IF (ai_using_color) THEN WRITE (*,"(/' -----------------------------------------------------------')") WRITE (*,"( ' Which method should be used to create this mosaic?')") WRITE (*,"( ' 1 = group of opaque colored polygons using ',I2,' AI colors')") ai_spectrum_count WRITE (*,"( ' 2 = bitmap (choice of 4 spectra, optional shaded relief)')") WRITE (*,"( ' -----------------------------------------------------------')") 1 CALL Prompt_for_Integer('Which method should be used',method,method) IF ((method < 1).OR.(method > 2)) THEN WRITE (*,"( ' ERROR: Please enter 1 or 2.')") GOTO 1 END IF IF (method == 2) THEN bitmap_width = ai_window_x2_points - ai_window_x1_points ! suggest one column/point bitmap_height = ai_window_y2_points - ai_window_y1_points ! suggest one row/point 2 CALL Prompt_for_Integer('How many columns of pixels in bitmap?',bitmap_width,bitmap_width) IF (bitmap_width < 2) THEN WRITE (*,"(' ERROR: Bitmap_width must be >= 2')") GOTO 2 END IF 3 CALL Prompt_for_Integer('How many rows of pixels in bitmap?',bitmap_height,bitmap_height) IF (bitmap_height < 2) THEN WRITE (*,"(' ERROR: Bitmap_height must be >= 2')") GOTO 3 END IF END IF ELSE ! .NOT. ai_using_color method = 1 ! bitmap not allowed END IF ! ai_using_color, or not END IF ! latter_mosaic, or not END SUBROUTINE Group_or_Bitmap SUBROUTINE Kilometer_Frame (kilometers) ! Adds a thick frame around the map window, decorated with ! tick marks and numbers every "kilometers" of X and Y. ! (Note: Routine also works properly when X, Y axes are rotated ! with respect to the window.) ! Note that the frame color and line-width are assumed here, ! but can be easily changed interactively in Adobe Illustrator. IMPLICIT NONE CHARACTER*6 :: c6 INTEGER, INTENT(IN) :: kilometers INTEGER :: font_size_points, i1, i2, ipass, iside, itick, km_bytes, km_int LOGICAL :: km_written, watching_x REAL, PARAMETER :: tick_length_points = 7.2 REAL :: a_meters, b_meters, degrees, & & lr_frac, frac, tick_angle, ud_frac, & & xam, xap, xbm, xbp, xip, xop, & & yam, yap, ybm, ybp, yip, yop font_size_points = NINT(ai_lonlatlabel_points) ! the heavy frame line: CALL Set_Line_Style (width_points = 2.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL New_L12_Path (1, ai_window_x1_points, ai_window_y1_points) CALL Line_To_L12 (ai_window_x2_points, ai_window_y1_points) CALL Line_To_L12 (ai_window_x2_points, ai_window_y2_points) CALL Line_To_L12 (ai_window_x1_points, ai_window_y2_points) CALL Line_To_L12 (ai_window_x1_points, ai_window_y1_points) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) ! Tick marks and numbers around the 4 sides: CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') km_written = .FALSE. DO ipass = 1, 2 ! 2 passes for 2 graphics groups: ticks, numbers CALL Begin_Group DO iside = 1, 4 SELECT CASE (iside) CASE (1) ! bottom xap = ai_window_x1_points xbp = ai_window_x2_points yap = ai_window_y1_points ybp = ai_window_y1_points watching_x = (ABS(COS(mp_xy_wrt_page_radians)) >= 0.7071) tick_angle = Pi_over_2 + mp_xy_wrt_page_radians degrees = 0. lr_frac = 0.5 ud_frac = 1.0 CASE (2) ! right xap = ai_window_x2_points xbp = ai_window_x2_points yap = ai_window_y1_points ybp = ai_window_y2_points watching_x = (ABS(COS(mp_xy_wrt_page_radians)) < 0.7071) tick_angle = Pi + mp_xy_wrt_page_radians degrees = -90. lr_frac = 0.5 ud_frac = -0.3 CASE (3) ! top xap = ai_window_x2_points xbp = ai_window_x1_points yap = ai_window_y2_points ybp = ai_window_y2_points watching_x = (ABS(COS(mp_xy_wrt_page_radians)) >= 0.7071) tick_angle = -Pi_over_2 + mp_xy_wrt_page_radians degrees = 0. lr_frac = 0.5 ud_frac = -0.3 CASE (4) ! left xap = ai_window_x1_points xbp = ai_window_x1_points yap = ai_window_y2_points ybp = ai_window_y1_points watching_x = (ABS(COS(mp_xy_wrt_page_radians)) < 0.7071) tick_angle = mp_xy_wrt_page_radians degrees = 90. lr_frac = 0.5 ud_frac = -0.3 END SELECT CALL Points_2_Meters (xap,yap, xam,yam) CALL Points_2_Meters (xbp,ybp, xbm,ybm) IF (watching_x) THEN a_meters = xam b_meters = xbm ELSE ! watching y a_meters = yam b_meters = ybm END IF i1 = Int_Below(MIN(a_meters, b_meters)/(1000.*kilometers)) i2 = Int_Below(MAX(a_meters, b_meters)/(1000.*kilometers)) + 1 DO itick = i2, i1, -1 ! so that labelled number is first one km_int = itick * kilometers IF (a_meters /= b_meters) THEN frac = ((1000.*km_int) - a_meters) / (b_meters - a_meters) ELSE ! degenerate window! IF (NINT(a_meters/1000.) == km_int) THEN ! plot frac = 0. ELSE ! don't plot frac = -999. END IF END IF ! normal or degenerate window IF ((frac >= 0.0).AND.(frac <= 1.0)) THEN ! outer end of tick, in points xop = xap + frac * (xbp - xap) yop = yap + frac * (ybp - yap) ! inner end of tick, in points xip = xop + tick_length_points * COS(tick_angle) yip = yop + tick_length_points * SIN(tick_angle) IF (ipass == 1) THEN ! tick group CALL New_L12_Path (1, xop, yop) CALL Line_To_L12 (xip, yip) CALL End_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! type group, with numbers WRITE (c6,"(I6)") km_int c6 = ADJUSTL(c6) km_bytes = LEN_TRIM(c6) IF (km_written) THEN ! normal case, unlabelled number CALL Write_L1_Text & & (x_points = xop, y_points = yop, & & angle_radians = degrees * radians_per_degree, & & font_points = font_size_points, & & lr_fraction = lr_frac, ud_fraction = ud_frac, & & text = c6) ELSE ! label number with " km" CALL Write_L1_Text & & (x_points = xop, y_points = yop, & & angle_radians = degrees * radians_per_degree, & & font_points = font_size_points, & & lr_fraction = (lr_frac*km_bytes)/(km_bytes+3.), & & ud_fraction = ud_frac, & & text = c6(1:km_bytes) // ' km') km_written = .TRUE. END IF END IF ! ticks, or numbers END IF ! 0. <= frac <= 1. END DO ! itick END DO ! iside = 1, 4 CALL End_Group END DO ! ipass = 1, 2 :: tick group, number group END SUBROUTINE Kilometer_Frame SUBROUTINE Learn_Spherical_Triangles (numel, nodes, node_uvec, chatty, & & a_, center, neighbor) !Creates arrays needed by lookup subr. Which_Spherical_Triangle: ! a_ = area of plane triangle below element, when radius == 1.0 ! center = uvec pointing to center of element ! neighbor = neighboring spherical triangular elements on each ! side (or zero if none); note that algorithm ! depends on node-location match, not on node-number ! match, and therefore ignores intevening faults. !These arrays are only meaningful for finite element grids used ! with SHELLS and/or RESTORE. IMPLICIT NONE INTEGER, INTENT(IN) :: numel ! number of spherical triangle elements INTEGER, DIMENSION(:,:), INTENT(IN) :: nodes ! element definitions REAL, DIMENSION(:,:), INTENT(IN) :: node_uvec ! uvecs of nodes LOGICAL, INTENT(IN) :: chatty REAL, DIMENSION(:), INTENT(OUT) :: a_ REAL, DIMENSION(:,:), INTENT(OUT) :: center INTEGER, DIMENSION(:,:), INTENT(OUT) :: neighbor INTEGER :: furthest, i, ia, ib, i1, i2, i3, j, j1, j2, j3, k, l_, m, step_aside REAL, DIMENSION(3) :: a, b, c, t, u IF (chatty) WRITE (*,"(' Learning the spherical triangles...')") furthest = (numel + 1) / 2 neighbor = 0 ! whole array, initialized to "no neighbor on this side" homes: DO l_ = 1, numel !first, a_ i1 = nodes(1,l_) i2 = nodes(2,l_) i3 = nodes(3,l_) a = node_uvec(1:3,i2) - node_uvec(1:3,i1) b = node_uvec(1:3,i3) - node_uvec(1:3,i2) CALL Cross (a, b, c) a_(l_) = 0.5 * Magnitude(c) !second, compute center t(1:3) = (node_uvec(1:3,i1)+node_uvec(1:3,i2)+node_uvec(1:3,i3))/3.0 CALL Make_Uvec(t, u) center(1:3, l_) = u(1:3) !third, find neighbor(?) for each side of element sides: DO j = 1, 3 ! 3 sides k = 1 + MOD (j, 3) ia = nodes(k, l_) ! 1st node along side ib = nodes(1 + MOD (k, 3), l_) ! 2nd node along side strangers: DO step_aside = 1, furthest m = l_ + step_aside ! I also try -step_aside, below m = 1 + MOD(m-1, numel) ! wraps around j1 = nodes(1, m) j2 = nodes(2, m) j3 = nodes(3, m) IF (Same(j1, ib) .AND. Same(j2, ia)) THEN neighbor(j, l_) = m EXIT strangers ELSE IF (Same(j2, ib) .AND. Same(j3, ia)) THEN neighbor(j, l_) = m EXIT strangers ELSE IF (Same(j3, ib) .AND. Same(j1, ia)) THEN neighbor(j, l_) = m EXIT strangers END IF m = l_ - step_aside ! I also try +step_aside, above m = 1 + MOD(m-1+numel, numel) ! wraps around j1 = nodes(1, m) j2 = nodes(2, m) j3 = nodes(3, m) IF (Same(j1, ib) .AND. Same(j2, ia)) THEN neighbor(j, l_) = m EXIT strangers ELSE IF (Same(j2, ib) .AND. Same(j3, ia)) THEN neighbor(j, l_) = m EXIT strangers ELSE IF (Same(j3, ib) .AND. Same(j1, ia)) THEN neighbor(j, l_) = m EXIT strangers END IF END DO strangers END DO sides IF (chatty) WRITE (*,"('+Learning the spherical triangles...',I8)") l_ END DO homes IF (chatty) WRITE (*,"('+Learning the spherical triangles...DONE ')") CONTAINS LOGICAL FUNCTION Same(i,j) ! Are node_uvec #i and #j the same vector? INTEGER, INTENT(IN) :: i, j !the logic is: !Same = (node_uvec(1,i) == node_uvec(1,j)).AND. & ! & (node_uvec(2,i) == node_uvec(2,j)).AND. & ! & (node_uvec(3,i) == node_uvec(3,j)) !But, it is written this way for speed: IF (node_uvec(1,i) == node_uvec(1,j)) THEN IF (node_uvec(2,i) == node_uvec(2,j)) THEN IF (node_uvec(3,i) == node_uvec(3,j)) THEN Same = .TRUE. ELSE Same = .FALSE. END IF ELSE Same = .FALSE. END IF ELSE Same = .FALSE. END IF END FUNCTION Same END SUBROUTINE Learn_Spherical_Triangles SUBROUTINE Learn_6Node_Plane_Grid (numel, nodes, xy_node_meters, chatty, & ! inputs & center, neighbor) ! outputs !Creates arrays needed by LookUp: ! center = (x,y) positions of element centers; ! neighbor = neighboring plane-isometric-triangular element on each ! side (or zero if none); note that algorithm ! depends on node-location match, not on node-number ! match, and therefore ignores intevening faults. !These arrays are only meaningful for finite element grids used ! with FAULTS, PLATES, or LARAMY. IMPLICIT NONE INTEGER, INTENT(IN) :: numel ! number of isoparametric-triangle elements INTEGER, DIMENSION(:,:), INTENT(IN) :: nodes ! element definitions; (6, numel) REAL, DIMENSION(:,:), INTENT(IN) :: xy_node_meters ! positions of nodes LOGICAL, INTENT(IN) :: chatty REAL, DIMENSION(:,:), INTENT(OUT) :: center ! (2, numel) INTEGER, DIMENSION(:,:), INTENT(OUT) :: neighbor ! (3, numel) INTEGER :: furthest, i, ia, ib, i1, i2, i3, i4, i5, i6, j, j1, j2, j3, k, l_, m, step_aside REAL :: f1, f2, f3, f4, f5, f6, PhiVal, s1, s2, s3, x1, x2, x3, x4, x5, x6, y1, y2, y3, y4, y5, y6 !Statement function: PhiVal(s1, s2, s3, f1, f2, f3, f4, f5, f6) = & & f1 * (-s1 + 2. * s1**2) + & & f2 * (-s2 + 2. * s2**2) + & & f3 * (-s3 + 2. * s3**2) + & & f4 * (4. * s1 * s2) + & & f5 * (4. * s2 * s3) + & & f6 * (4. * s3 * s1) IF (chatty) WRITE (*,"(' Learning the planar grid of 6-node triangles...')") furthest = (numel + 1) / 2 neighbor = 0 ! whole array, initialized to "no neighbor on this side" homes: DO l_ = 1, numel !first, compute center i1 = nodes(1, l_) i2 = nodes(2, l_) i3 = nodes(3, l_) i4 = nodes(4, l_) i5 = nodes(5, l_) i6 = nodes(6, l_) x1 = xy_node_meters(1, i1) x2 = xy_node_meters(1, i2) x3 = xy_node_meters(1, i3) x4 = xy_node_meters(1, i4) x5 = xy_node_meters(1, i5) x6 = xy_node_meters(1, i6) y1 = xy_node_meters(2, i1) y2 = xy_node_meters(2, i2) y3 = xy_node_meters(2, i3) y4 = xy_node_meters(2, i4) y5 = xy_node_meters(2, i5) y6 = xy_node_meters(2, i6) center(1, l_) = PhiVal(0.3333, 0.3333, 0.3334, x1, x2, x3, x4, x5, x6) center(2, l_) = PhiVal(0.3333, 0.3333, 0.3334, y1, y2, y3, y4, y5, y6) !second, find neighbor(?) for each side of element sides: DO j = 1, 3 ! 3 sides k = 1 + MOD (j, 3) ia = nodes(k, l_) ! 1st node along side ib = nodes(1 + MOD (k, 3), l_) ! last node along side strangers: DO step_aside = 1, furthest m = l_ + step_aside ! I also try -step_aside, below m = 1 + MOD(m-1, numel) ! wraps around j1 = nodes(1, m) j2 = nodes(2, m) j3 = nodes(3, m) IF (Same(j1, ib) .AND. Same(j2, ia)) THEN neighbor(j, l_) = m EXIT strangers ELSE IF (Same(j2, ib) .AND. Same(j3, ia)) THEN neighbor(j, l_) = m EXIT strangers ELSE IF (Same(j3, ib) .AND. Same(j1, ia)) THEN neighbor(j, l_) = m EXIT strangers END IF m = l_ - step_aside ! I also try +step_aside, above m = 1 + MOD(m-1+numel, numel) ! wraps around j1 = nodes(1, m) j2 = nodes(2, m) j3 = nodes(3, m) IF (Same(j1, ib) .AND. Same(j2, ia)) THEN neighbor(j, l_) = m EXIT strangers ELSE IF (Same(j2, ib) .AND. Same(j3, ia)) THEN neighbor(j, l_) = m EXIT strangers ELSE IF (Same(j3, ib) .AND. Same(j1, ia)) THEN neighbor(j, l_) = m EXIT strangers END IF END DO strangers END DO sides IF (chatty) WRITE (*,"('+Learning the planar grid of 6-node triangles...',I6)") l_ END DO homes IF (chatty) WRITE (*,"('+Learning the planar grid of 6-node triangles...DONE ')") CONTAINS LOGICAL FUNCTION Same(i,j) ! Are xy_node_meters #i and #j the same 2-component vector? INTEGER, INTENT(IN) :: i, j !the logic is: !Same = (node_uvec(1,i) == node_uvec(1,j)).AND. & ! & (node_uvec(2,i) == node_uvec(2,j)) !But, it is written this way for speed: IF (xy_node_meters(1,i) == xy_node_meters(1,j)) THEN IF (xy_node_meters(2,i) == xy_node_meters(2,j)) THEN Same = .TRUE. ELSE Same = .FALSE. END IF ELSE Same = .FALSE. END IF END FUNCTION Same END SUBROUTINE Learn_6Node_Plane_Grid SUBROUTINE LonLat_Frame (minutes) ! Adds a thick frame around the map window, decorated with ! tick marks and numbers every "minutes" of longitude and ! latitude. If "minutes" is a multiple of 60, then integers ! in degrees are used. Otherwise, both degrees and minutes ! are provided for each tick mark. ! Note that the frame color and line-width are assumed here, ! but can be easily changed interactively in Adobe Illustrator. IMPLICIT NONE CHARACTER*1 :: c1 CHARACTER*2 :: c2 CHARACTER*3 :: c3 INTEGER, INTENT(IN) :: minutes INTEGER, PARAMETER :: nibbles = 200 ! small search steps in each side REAL, PARAMETER :: tick_length_points = 7.2 INTEGER :: across_cut, degree_bytes, font_size_points, ipass, iside, istep, & & j0, j1, jgoal, minute_bytes, tick_degrees, tick_minutes LOGICAL :: old_success, process, success, watching_lon REAL, PARAMETER :: reach_degrees = 1.0 REAL :: angle, degrees, dlon, dlat, fraction, & & inner_lat, inner_lon, lat, lon, lr_frac, & & old_lat, old_lon, part, & & tick_lat, tick_lon, ud_frac, & & x_meters, y_meters, & & xap, xbp, yap, ybp, & & x0p, x1p, y0p, y1p, & & xop, xip, yop, yip REAL, DIMENSION(3) :: uvec font_size_points = NINT(ai_lonlatlabel_points) ! the heavy frame line: CALL Set_Line_Style (width_points = 2.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL New_L12_Path (1, ai_window_x1_points, ai_window_y1_points) CALL Line_To_L12 (ai_window_x2_points, ai_window_y1_points) CALL Line_To_L12 (ai_window_x2_points, ai_window_y2_points) CALL Line_To_L12 (ai_window_x1_points, ai_window_y2_points) CALL Line_To_L12 (ai_window_x1_points, ai_window_y1_points) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) ! Tick marks and numbers around the 4 sides: CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') across_cut = ((360 * 60) / minutes) - 1 DO ipass = 1, 2 ! 2 passes for 2 graphics groups: ticks, numbers CALL Begin_Group DO iside = 1, 4 ! Define ray; ticks should point inward. SELECT CASE (iside) CASE (1) ! bottom xap = ai_window_x1_points xbp = ai_window_x2_points yap = ai_window_y1_points ybp = ai_window_y1_points watching_lon = .TRUE. dlon = 0. dlat = reach_degrees degrees = 0. lr_frac = 0.5 ud_frac = 1.0 CASE (2) ! right xap = ai_window_x2_points xbp = ai_window_x2_points yap = ai_window_y1_points ybp = ai_window_y2_points watching_lon = .FALSE. dlon = -reach_degrees dlat = 0. degrees = -90. lr_frac = 0.5 ud_frac = -0.3 CASE (3) ! top xap = ai_window_x2_points xbp = ai_window_x1_points yap = ai_window_y2_points ybp = ai_window_y2_points watching_lon = .TRUE. dlon = 0. dlat = -reach_degrees degrees = 0. lr_frac = 0.5 ud_frac = -0.3 CASE (4) ! left xap = ai_window_x1_points xbp = ai_window_x1_points yap = ai_window_y2_points ybp = ai_window_y1_points watching_lon = .FALSE. dlon = reach_degrees dlat = 0. degrees = 90. lr_frac = 0.5 ud_frac = -0.3 END SELECT ! work along side in small nibbles; plot ! if parallel or meridian occurs in interval. x0p = xap y0p = yap CALL Points_2_LonLat (x0p,y0p, old_success, old_lon, old_lat) DO istep = 1, nibbles IF (istep < nibbles) THEN fraction = istep/REAL(nibbles) x1p = xap + fraction * (xbp - xap) y1p = yap + fraction * (ybp - yap) ELSE x1p = xbp y1p = ybp END IF CALL Points_2_LonLat (x1p,y1p, success, lon, lat) IF (old_success .AND. success) THEN IF (watching_lon) THEN j0 = Int_Below((old_lon*60.)/minutes) j1 = Int_Below((lon*60.)/minutes) ELSE ! watching the latitude! j0 = Int_Below((old_lat*60.)/minutes) j1 = Int_Below((lat*60.)/minutes) END IF ! lon or lat IF (j0 /= j1) THEN ! caught one (or more) ticks IF (ABS(j1-j0) == 1) THEN ! normal case process = .TRUE. jgoal = MAX(j0, j1) ! compensates for Int_Below bias. ELSE IF (ABS(j1-j0) == across_cut) THEN process = (MOD((180*60),minutes) == 0) jgoal = (180*60)/minutes ELSE ! more than one is too many! process = .FALSE. END IF ! zero, one, or many, ticks in interval IF (process) THEN tick_minutes = jgoal * minutes IF (watching_lon) THEN part = ((tick_minutes/60.) - old_lon) / (lon - old_lon) ELSE ! watching latitude part = ((tick_minutes/60.) - old_lat) / (lat - old_lat) END IF ! lon or lat ! outer end of tick mark: tick_lon = old_lon + part * (lon - old_lon) tick_lat = old_lat + part * (lat - old_lat) xop = x0p + part * (x1p - x0p) yop = y0p + part * (y1p - y0p) IF (ipass == 1) THEN ! doing ticks ! find angle of tick by using temp. point inner_lon = tick_lon + dlon inner_lat = tick_lat + dlat CALL LonLat_2_Uvec (inner_lon, inner_lat, uvec) CALL Project (uvec = uvec, x = x_meters, y = y_meters) CALL Meters_2_Points (x_meters,y_meters, xip,yip) IF ((xip /= xop).OR.(yip /= yop)) THEN angle = ATAN2(yip - yop, xip - xop) ! find inner end of tick, using standard length: xip = xop + COS(angle)*tick_length_points yip = yop + SIN(angle)*tick_length_points c1 = In_Window(xip, yip) IF (c1 == 'I') THEN CALL New_L12_Path (1, xop, yop) CALL Line_To_L12 (xip, yip) CALL End_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! try reversing tick? angle = angle + Pi xip = xop + COS(angle)*tick_length_points yip = yop + SIN(angle)*tick_length_points c1 = In_Window(xip, yip) IF (c1 == 'I') THEN CALL New_L12_Path (1, xop, yop) CALL Line_To_L12 (xip, yip) CALL End_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! reversed tick lands inside END IF ! tick points inward END IF ! angle is defined ELSE ! doing numbers this pass tick_minutes = ABS(tick_minutes) ! always positive! tick_degrees = tick_minutes / 60 tick_minutes = tick_minutes - (tick_degrees * 60) ! redefine as remainder WRITE (c3,"(I3)") tick_degrees c3 = ADJUSTL(c3) degree_bytes = LEN_TRIM(c3) IF (tick_minutes == 0) THEN ! omit minutes; just degrees CALL Write_L1_Text & & (x_points = xop, y_points = yop, & & angle_radians = degrees * radians_per_degree, & & font_points = font_size_points, & & lr_fraction = lr_frac, ud_fraction = ud_frac, & & text = c3(1:degree_bytes) // '\260') ELSE ! minutes are needed WRITE (c2,"(I2)") tick_minutes c2 = ADJUSTL(c2) minute_bytes = LEN_TRIM(c2) CALL Write_L1_Text & & (x_points = xop, y_points = yop, & & angle_radians = degrees * radians_per_degree, & & font_points = font_size_points, & & lr_fraction = lr_frac, ud_fraction = ud_frac, & & text = c3(1:degree_bytes) // '\260' // c2(1:minute_bytes) // "'") END IF ! which number format? END IF ! ipass = 1, 2 (ticks, or numbers, to be plotted) END IF ! process (exactly one tick caught) END IF ! caught one (or more) ticks in nibble END IF ! success in transforming both end points of nibble ! set memory for next loop x0p = x1p y0p = y1p old_success = success old_lon = lon old_lat = lat END DO ! istep = 1, nibbles END DO ! iside = 1, 4 CALL End_Group END DO ! ipass = 1, 2 :: tick group, number group END SUBROUTINE LonLat_Frame SUBROUTINE LookUp (cold_start, x, y, & & center, neighbor, nodes, numel, xy_node_meters, & ! inputs & ie, s1, s2, s3, & ! to be modified & success) ! output flag ! Finds element and internal coordinates in a FAULTS, PLATES, or LARAMY grid ! matching location of a point (x,y), and reports them as ie and s1,s2,s3. ! IF (.NOT.cold_start) uses initial estimates provided to speed up the search. ! Modified from subprogram LOOKUP of the LARAMY program, with some ! changes to syntax from FORTRAN77 to Fortran 90. The principal ! logical change is that instead of computing the index of neighboring ! element from assumed grid regularity, it refers to integer array "neighbor", ! which identifies next 6-node planar continuum element (even across faults). ! Also, node locations are now stored in the single array "xy_node_meters". ! A returned value of atsea = T indicates that point fell off an edge ! of the grid. IMPLICIT NONE LOGICAL, INTENT(IN) :: cold_start REAL, INTENT(IN) :: x, y ! point to be searched for REAL, DIMENSION(:,:),INTENT(IN) :: center ! (2, numel) = (x,y) of each element center INTEGER, DIMENSION(:,:),INTENT(IN) :: neighbor ! (3, numel) INTEGER, DIMENSION(:,:),INTENT(IN) :: nodes ! (6, numel) INTEGER, INTENT(IN) :: numel REAL, DIMENSION(:,:),INTENT(IN) :: xy_node_meters ! (2, numnod) INTEGER, INTENT(INOUT) :: ie ! initial element estimate may be changed REAL, INTENT(INOUT) :: s1, s2, s3 ! initial internal coordinates WILL be changed LOGICAL, INTENT(OUT) :: success ! set F if search fails; T otherwise INTEGER :: i, i1, i2, i3, i4, i5, i6, iehist, limit, nrefin, ntried LOGICAL trubbl REAL cf11, cf12, cf13, cf21, cf22, cf23, coef11, coef12, coef13, coef21, coef22, coef23, & & delx, dely, det, deti, ds1, ds2, ds3, dstep, & & err, & & f1, f2, f3, f4, f5, f6, & & m11, m12, m13, m21, m22, m23, m31, m32, m33, & & PhiVal, & & r2, r2min, & & shist, step11, step12, step21, step22, step31, step32, & & xt, x1, x2, x3, x4, x5, x6, yt, y1, y2, y3, y4, y5, y6 DIMENSION iehist(500), shist(3, 500) ! STATEMENT FUNCTION: PhiVal(s1, s2, s3, f1, f2, f3, f4, f5, f6) = & & f1 * (-s1 + 2. * s1**2) + & & f2 * (-s2 + 2. * s2**2) + & & f3 * (-s3 + 2. * s3**2) + & & f4 * (4. * s1 * s2) + & & f5 * (4. * s2 * s3) + & & f6 * (4. * s3 * s1) IF (cold_start) THEN ! Find closest element center r2min = 3.3E38 DO i = 1, numel r2 = (x - center(1, i))**2 + (y - center(2, i))**2 IF (r2 < r2min) THEN ie = i r2min = r2 END IF END DO s1 = 1.0 / 3.0 s2 = s1 s3 = s1 END IF ntried = 0 ! LOOP AS MANY TIMES AS NEEDED: 100 ntried = ntried + 1 iehist(ntried) = ie IF (ntried >= 3) THEN trubbl = (ntried >= 9).AND.(iehist(ntried) == iehist(ntried - 2)) ELSE trubbl = .FALSE. END IF IF (trubbl) THEN success = .FALSE. RETURN END IF i1 = nodes(1, ie) i2 = nodes(2, ie) i3 = nodes(3, ie) i4 = nodes(4, ie) i5 = nodes(5, ie) i6 = nodes(6, ie) x1 = xy_node_meters(1, i1) x2 = xy_node_meters(1, i2) x3 = xy_node_meters(1, i3) x4 = xy_node_meters(1, i4) x5 = xy_node_meters(1, i5) x6 = xy_node_meters(1, i6) y1 = xy_node_meters(2, i1) y2 = xy_node_meters(2, i2) y3 = xy_node_meters(2, i3) y4 = xy_node_meters(2, i4) y5 = xy_node_meters(2, i5) y6 = xy_node_meters(2, i6) s3 = 1.00 - s1 - s2 limit = 3 nrefin = 0 ! LOOP TO REFINE ESTIMATE OF INTERNAL COORDINATES 150 nrefin = nrefin + 1 xt = PhiVal(s1, s2, s3, x1, x2, x3, x4, x5, x6) yt = PhiVal(s1, s2, s3, y1, y2, y3, y4, y5, y6) ! COEF:=MAT((DXDS1,DXDS2,DXDS3), ! (DYDS1,DYDS2,DYDS3),(1,1,1)); coef11 = 4. * s2 * x4 + 4. * s1 * x1 + 4. * x6 * s3 - x1 coef12 = 4. * s2 * x2 + 4. * s1 * x4 + 4. * x5 * s3 - x2 coef13 = 4. * s2 * x5 + 4. * s1 * x6 + 4. * x3 * s3 - x3 coef21 = 4. * s2 * y4 + 4. * s1 * y1 + 4. * y6 * s3 - y1 coef22 = 4. * s2 * y2 + 4. * s1 * y4 + 4. * y5 * s3 - y2 coef23 = 4. * s2 * y5 + 4. * s1 * y6 + 4. * y3 * s3 - y3 m11 = coef22 - coef23 m12 = coef21 - coef23 m13 = coef21 - coef22 m21 = coef12 - coef13 m22 = coef11 - coef13 m23 = coef11 - coef12 cf11 = + m11 cf12 = -m12 cf13 = + m13 cf21 = -m21 cf22 = + m22 cf23 = -m23 det = coef11 * cf11 + coef12 * cf12 + coef13 * cf13 IF (det == 0.0) THEN success = .TRUE. RETURN END IF deti = 1. / det step11 = cf11 step12 = cf21 step21 = cf12 step22 = cf22 step31 = cf13 step32 = cf23 delx = x - xt dely = y - yt ds1 = (step11 * delx + step12 * dely) * deti ds2 = (step21 * delx + step22 * dely) * deti ds3 = (step31 * delx + step32 * dely) * deti err = (ds1 + ds2 + ds3) / 3. ds1 = ds1 - err ds2 = ds2 - err ds3 = ds3 - err dstep = MAX(ABS(ds1), ABS(ds2), ABS(ds3)) IF (dstep > 0.10) THEN limit = limit + 1 ds1 = ds1 * 0.1 / dstep ds2 = ds2 * 0.1 / dstep ds3 = ds3 * 0.1 / dstep END IF s1 = s1 + ds1 s2 = s2 + ds2 s3 = s3 + ds3 IF ((nrefin < limit.AND.limit <= 40).AND. & & (s1 >= -0.1.AND.s1 <= 1.1).AND. & & (s2 >= -0.1.AND.s2 <= 1.1).AND. & & (s3 >= -0.1.AND.s3 <= 1.1)) GO TO 150 shist(1, ntried) = s1 shist(2, ntried) = s2 shist(3, ntried) = s3 IF (s1 > -0.0003) THEN IF (s2 > -0.0003) THEN IF (s3 > -0.0003) THEN success = .TRUE. RETURN ! ie and s1,s2,s3 are already adjusted ELSE ! went out of element toward negative s3 IF (neighbor(3, ie) > 0) THEN ie = neighbor(3, ie) s1 = 1.0 / 3.0 s2 = s1 s3 = s1 GO TO 100 ELSE success = .FALSE. RETURN END IF END IF ! s3 > -0.03, or not ELSE ! went out of element toward negative s2 IF (neighbor(2, ie) > 0) THEN ie = neighbor(2, ie) s1 = 1.0 / 3.0 s2 = s1 s3 = s1 GO TO 100 ELSE success = .FALSE. RETURN END IF END IF ! s2 > -0.03, or not ELSE ! went out of element toward negative s1 IF (neighbor(1, ie) > 0) THEN ie = neighbor(1, ie) s1 = 1.0 / 3.0 s2 = s1 s3 = s1 GO TO 100 ELSE success = .FALSE. RETURN END IF END IF ! s1 > -0.03, or not END SUBROUTINE LookUp SUBROUTINE Plot_Dig (level, dig_file_name, filled_polygons, & & free_unit, in_ok, group) ! Adds a base map to the current map ! (using predefined projection, pen, etc.) ! based on an input file with points as (either): ! Level = 3: (x, y) pairs in user units, OR ! Level = 7: (East-longitude, North-latitude) pairs in degrees, ! and each polyline terminated with: ! "*** END OF SEGMENT ***". ! If input parameter "group" is absent, or == 0, then ! title lines are ignored and the line(s) plotted. ! If group == 1, no lines are plotted, but titles are ! written right-side-up at the geometric center of ! each polyline. Title is truncated at 26 characters. ! If group == 2, no lines are plotted, but titles are ! written along each polyline (actually, beginning at ! the first point, and taking their direction from the ! second point, but not following the line in detail). ! Again, any title is truncated at 26 characters. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: dig_file_name LOGICAL, INTENT(IN) :: filled_polygons INTEGER, INTENT(IN) :: level, free_unit INTEGER, INTENT(IN), OPTIONAL :: group LOGICAL, INTENT(OUT) :: in_ok INTEGER, PARAMETER :: max_lines = 3 CHARACTER*26 :: blank, line CHARACTER*26, DIMENSION(max_lines) :: title_bank INTEGER :: i, ios, includes_TF, number_in_sum, & & titles_in_bank, use_group LOGICAL :: got_title, in_line REAL :: argument, first_ud, lat, lon, x_meters, x_user, y_meters, y_user REAL, DIMENSION(2) :: position_sum, position_1, position_2 REAL, DIMENSION(3) :: uvec1, uvec2 IF (.NOT.((level == 3).OR.(level == 7))) THEN WRITE (*,"(' ERROR: Incorrect level ',I2,' in CALL Plot_Dig.')") level CALL Traceback END IF IF (PRESENT(group)) THEN use_group = group ELSE use_group = 0 END IF blank = ' ' in_ok = .FALSE. in_line = .FALSE. titles_in_bank = 0 number_in_sum = 0 position_sum = (/ 0.0, 0.0 /) position_1 = (/ 0.0, 0.0 /) position_2 = (/ 0.0, 0.0 /) OPEN ( FILE = dig_file_name, UNIT = free_unit, & & STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) THEN CLOSE (free_unit, IOSTAT = ios) RETURN END IF CALL Set_Join_to_Round() ! better for coastlines than _Mitre (the default). CALL Begin_Group get_line: DO line = blank READ (free_unit, "(A)", IOSTAT = ios) line IF (ios == -1) EXIT get_line ! EOF IF (line(1:3) == '***') THEN ! end-of-polyline record IF (in_line) THEN IF (use_group == 0) THEN IF (level == 3) THEN CALL End_L3_Path (close = filled_polygons, stroke = .TRUE., fill = filled_polygons) ELSE ! level == 7 CALL End_L67_Path (close = filled_polygons, stroke = .TRUE., fill = filled_polygons) END IF ! level == 3 or 7 ELSE ! plot a title (or titles) IF (number_in_sum > 0) THEN position_sum = position_sum / number_in_sum IF (titles_in_bank > 1) CALL Begin_Group IF (use_group == 1) THEN ! centered title(s): first_ud = 0.4 - 0.5 * titles_in_bank + 0.5 IF (level == 3) THEN x_meters = position_sum(1) y_meters = position_sum(2) DO i = 1, titles_in_bank CALL L3_Text (x_meters, y_meters, & & angle_radians = 0.0, from_x = .FALSE., & & font_points = 10, lr_fraction = 0.5, & & ud_fraction = first_ud + i - 1, & & text = TRIM(title_bank(i))) END DO ELSE IF (level == 7) THEN lon = position_sum(1) lat = position_sum(2) DO i = 1, titles_in_bank CALL L67_Text (level = 7, r1 = lon, r2 = lat, & & angle_radians = 0.0, from_east = .FALSE., & & font_points = 10, lr_fraction = 0.5, & & ud_fraction = first_ud + i - 1, & & text = TRIM(title_bank(i))) END DO END IF ! level == 3 or 7 ELSE IF (use_group == 2) THEN ! titles along line first_ud = -0.2 - titles_in_bank + 1.0 IF (level == 3) THEN x_meters = position_1(1) y_meters = position_1(2) IF (number_in_sum >=2) THEN argument = ATAN2F(position_2(2) - position_1(2), & & position_2(1) - position_1(1)) ELSE argument = 0.0 END IF DO i = 1, titles_in_bank CALL L3_Text (x_meters, y_meters, & & angle_radians = argument, from_x = .TRUE., & & font_points = 10, lr_fraction = 0.0, & & ud_fraction = first_ud + i - 1, & & text = TRIM(title_bank(i))) END DO ELSE IF (level == 7) THEN lon = position_1(1) lat = position_1(2) CALL LonLat_2_Uvec(lon, lat, uvec1) IF (number_in_sum >= 2) THEN CALL LonLat_2_Uvec(position_2(1), position_2(2), uvec2) argument = Pi_over_2 - Relative_Compass(uvec1, uvec2) ELSE argument = 0.0 END IF DO i = 1, titles_in_bank CALL L67_Text (level = 7, r1 = lon, r2 = lat, & & angle_radians = argument, from_east = .TRUE., & & font_points = 10, lr_fraction = 0.0, & & ud_fraction = first_ud + i - 1, & & text = TRIM(title_bank(i))) END DO END IF ! level == 3 or 7 END IF ! use_group == 1 or 2 IF (titles_in_bank > 1) CALL End_Group END IF ! number_in_sum > 0 !Now, reset the accumulators for the next polyline: titles_in_bank = 0 number_in_sum = 0 position_sum = (/ 0.0, 0.0 /) position_1 = (/ 0.0, 0.0 /) position_2 = (/ 0.0, 0.0 /) END IF ! use_group == 0, or 1 END IF ! in_line in_line = .FALSE. got_title = .FALSE. ELSE ! This line is either a number pair or a title. !Test for 'T', 't', 'F', 'f' in the line; !when one of these begins a word, list-directed input !processing treats it as .TRUE. or .FALSE. and converts !this value to 1.0 or 0.0, causing mis-alignment of !data and/or ficticious data points. For example, !the title line "TX" was read as .TRUE., converted to REAL !1.0, and assigned to the longitude, and then the !first number of the next line was read for the latitude! !Another time, the title line " 129 Tonga-1" was !interpreted as (+129.00E, +1.00N), causing an unwanted !great-circle arc to that point! includes_TF = ((SCAN(line,'T') > 0).AND.(SCAN(line,'T') < 25)).OR. & & ((SCAN(line,'t') > 0).AND.(SCAN(line,'t') < 25)).OR. & & ((SCAN(line,'F') > 0).AND.(SCAN(line,'F') < 25)).OR. & & ((SCAN(line,'f') > 0).AND.(SCAN(line,'f') < 25)) IF (includes_TF) THEN ! this is a title line got_title = .TRUE. IF (in_line) THEN ! *** END OF SEGMENT *** is missing or mistyped WRITE (*,"(' ERROR in input .dig file: *** END OF SEGMENT *** is missing.')") CALL Traceback END IF ! in_line in_line = .FALSE. ELSE ! line does not include T/F; safe to try reading with (*): !Try to read line as two numbers, and see if you get an error? IF (level == 3) THEN BACKSPACE(free_unit) READ (free_unit, *, IOSTAT = ios) x_user, y_user ! Note: Originally, I wrote: ! READ (line, *, IOSTAT = ios) x_user, y_user ! instead of the two lines above, ! but after about 178 times through this code, ! there would be a mysterious memory error ! way down in the NTDLL's. ! Apparently, there is some bug in Digital Visual Fortran. x_meters = x_user * mt_meters_per_user y_meters = y_user * mt_meters_per_user ELSE ! level == 7 BACKSPACE(free_unit) READ (free_unit, *, IOSTAT = ios) lon, lat ! Note: Originally, I wrote: ! READ (line, *, IOSTAT = ios) lon, lat ! instead of the two lines above, ! but after about 178 times through this code, ! there would be a mysterious memory error ! way down in the NTDLL's. ! Apparently, there is some bug in Digital Visual Fortran. END IF IF ((ios == 0).AND.(line(1:1) == ' ')) THEN ! found a (lon, lat) or (x,y) pair! got_title = .FALSE. IF (use_group == 0) THEN IF (in_line) THEN IF (level == 3) THEN CALL Line_To_L3 (x_meters, y_meters) ELSE ! level == 7 CALL Great_To_L67 (lon, lat) END IF ELSE ! not in_line; start one IF (level == 3) THEN CALL New_L3_Path (x_meters, y_meters) ELSE ! level == 7 CALL New_L67_Path (7, lon, lat) END IF END IF ! in_line or not ELSE ! use_group > 0; add to sum number_in_sum = number_in_sum + 1 IF (level == 3) THEN position_sum(1) = position_sum(1) + x_meters position_sum(2) = position_sum(2) + y_meters IF (number_in_sum == 1) THEN position_1(1) = x_meters position_1(2) = y_meters ELSE IF (number_in_sum == 2) THEN position_2(1) = x_meters position_2(2) = y_meters END IF ELSE IF (level == 7) THEN position_sum(1) = position_sum(1) + lon position_sum(2) = position_sum(2) + lat IF (number_in_sum == 1) THEN position_1(1) = lon position_1(2) = lat ELSE IF (number_in_sum == 2) THEN position_2(1) = lon position_2(2) = lat END IF END IF END IF ! use_group == 0, or not in_line = .TRUE. ELSE ! This is a comment or title line! got_title = .TRUE. IF (in_line) THEN ! *** END OF SEGMENT *** is missing or mistyped WRITE (*,"(' ERROR in input .dig file: *** END OF SEGMENT *** is missing.')") CALL Traceback END IF ! in_line in_line = .FALSE. END IF ! success in reading 2 numbers, or NOT END IF ! includes_TF, or NOT END IF ! "*** end of segment ***", or NOT IF (got_title) THEN ! add(?) to bank IF (titles_in_bank < max_lines) THEN titles_in_bank = titles_in_bank + 1 title_bank(titles_in_bank) = line title_bank(titles_in_bank) = ADJUSTL(title_bank(titles_in_bank)) END IF ! room for more titles in bank END IF ! got_title, or not END DO get_line IF (in_line) THEN ! last *** was missing; clean up! IF (use_group == 0) THEN IF (level == 3) THEN CALL End_L3_Path (close = filled_polygons, stroke = .TRUE., fill = filled_polygons) ELSE ! level == 7 CALL End_L67_Path (close = filled_polygons, stroke = .TRUE., fill = filled_polygons) END IF END IF ! use_group == 0 END IF ! in_line CLOSE (free_unit, IOSTAT = ios) CALL End_Group CALL Set_Join_to_Mitre() ! Adobe Illustrator's default setting in_ok = .TRUE. END SUBROUTINE Plot_Dig SUBROUTINE Press_Enter !Requires user to press [Enter] before program continues. !Typically called after an important message, and/or !at successful conclusion of a program. IMPLICIT NONE CHARACTER*1 :: c1 WRITE (*, "(' Press [Enter]...'\)") READ (*, "(A)") c1 END SUBROUTINE Press_Enter SUBROUTINE Prompter (xy_mode, lonlat_mode, path_out, xy_defined) ! Prompts user to set all values required for initializing the ! Adobe_Illustrator module (page size, margins, color, etc.) ! and the Map_Projections module (planet radius, type of map, ! center point of map, map scale, custom x,y system, etc.). ! Records selections as file Map_Tools.ini in current directory. ! Looks for such a file when called to establish defaults. ! If (xy_mode), user may define an (x,y) flat-Earth system, ! enter such data files, and display them with or without ! computed parallels and meridians. ! If the user takes this option, xy_defined is set .TRUE.. ! If (lonlat_mode), user may only enter data in (lon,lat) form. ! Both modes may be .TRUE. (enabled), but both cannot be .FALSE. IMPLICIT NONE LOGICAL, INTENT(IN) :: xy_mode, lonlat_mode CHARACTER*(*), INTENT(INOUT), OPTIONAL :: path_out LOGICAL, INTENT(OUT), OPTIONAL :: xy_defined CHARACTER*1 :: c1 CHARACTER*11 :: string11, unit_name CHARACTER*14 :: xy_name CHARACTER*43 :: projection_name CHARACTER*80 :: model_ai_filename, new_ai_filename CHARACTER*160 :: new_ai_path_and_filename INTEGER :: i, i1, ios, format_choice, projection_choice, unit_choice, xy_choice LOGICAL :: AI_ok, black, custom_xy, default_xy, in_ok, MP_ok, out_ok, overwrite, & & plan_bottomlegend, plan_rightlegend, plan_toptitles, & & problem, using_color REAL :: belt_azimuth_degrees, belt_azimuth_radians, & & bottom_margin, bottom_margin_points, & & cone_lat, cone_lon, lat, lon, & & left_margin, left_margin_points, & & paper_height, paper_height_points, & & paper_width, paper_width_points, & & right_margin, right_margin_points, & & radius_meters, scale_denominator, & & standard_parallel_gap_degrees, standard_parallel_gap_radians, & & top_margin, top_margin_points, & & unit_points, & & x_center, x_center_meters, & & x_projpoint, x_projpoint_meters, & & xy_wrt_page_degrees, xy_wrt_page_radians, & & y_azimuth_degrees, y_azimuth_radians, & & y_center, y_center_meters, & & y_projpoint, y_projpoint_meters REAL, DIMENSION(3) :: cone_pole_uvec, projpoint_uvec !---------------------------------------------------------- IF (.NOT.(xy_mode.OR.lonlat_mode)) THEN WRITE (*,"(' ERROR: CALL Prompter(.FALSE.,FALSE.) is illegal.')") CALL Traceback END IF ! Retrieve data from Map_Tools.ini, or use standard defaults: OPEN (UNIT = 1, FILE = 'Map_Tools.ini', STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios == 0) THEN ! file was found problem = .FALSE. ! may change below READ (1, *,IOSTAT=ios) unit_choice problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) paper_width_points problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) paper_height_points problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) black problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) top_margin_points problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) left_margin_points problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) right_margin_points problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) bottom_margin_points problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) plan_toptitles problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) plan_rightlegend problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) plan_bottomlegend problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) using_color problem = problem.OR.(ios /= 0) READ (1,"(A)",IOSTAT=ios) model_ai_filename problem = problem.OR.(ios /= 0) READ (1,"(A)",IOSTAT=ios) new_ai_filename problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) scale_denominator problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) default_xy problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) xy_choice problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) x_center_meters problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) y_center_meters problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) xy_wrt_page_radians problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) projection_choice problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) radius_meters problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) lon problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) lat problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) belt_azimuth_radians problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) cone_lon problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) cone_lat problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) standard_parallel_gap_radians problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) x_projpoint_meters problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) y_projpoint_meters problem = problem.OR.(ios /= 0) READ (1, *,IOSTAT=ios) y_azimuth_radians problem = problem.OR.(ios /= 0) CLOSE(1) IF (problem) THEN WRITE (*,"(/' ERROR: Bad data, bad format, or missing lines in MapTools.ini.')") WRITE (*,"( ' The easiest way to recover from this is to:')") WRITE (*,"( ' (1) Print out MapTools.ini')") WRITE (*,"( ' (2) Delete MapTools.ini')") WRITE (*,"( ' (3) Restart this program, and enter your choices manually.')") CALL Press_Enter STOP ' ' END IF ELSE ! file was not found; use standard defaults unit_choice = 2 paper_width_points = 11. * 72. paper_height_points = 8.5 * 72. black = .FALSE. top_margin_points = 88. ! large, to force longitudes on default global Mercator left_margin_points = 15. right_margin_points = 18. bottom_margin_points = 18. plan_toptitles = .TRUE. plan_rightlegend = .FALSE. plan_bottomlegend = .TRUE. ! part of plan to force longitudes on default global Mercator using_color = .TRUE. model_ai_filename = 'AI7Frame.ai' new_ai_filename = 'map.ai' scale_denominator = 1.534E8 ! default is global Mercator default_xy = .TRUE. ! input data are all (lon,lat) format xy_choice = 1 x_center_meters = 0.0 y_center_meters = 0.0 xy_wrt_page_radians = 0.0 projection_choice = 1 ! Mercator radius_meters = 6371000. ! Earth lon = 180.00 lat = +00.00 belt_azimuth_radians = Pi_over_2 cone_lon = 0. cone_lat = 90. standard_parallel_gap_radians = 30. * radians_per_degree x_projpoint_meters = 0.0 y_projpoint_meters = 0.0 y_azimuth_radians = 0.0 END IF ! file found, or not? ! Regardless of the above, monitor permitted modes: IF (.NOT.xy_mode) default_xy = .TRUE. IF (.NOT.lonlat_mode) default_xy = .FALSE. !---------------------------------------------------------- ! Get output file name (frequently, the ONLY thing changed ! between two consecutive runs of Prompter, so don't bury ! where it won't be noticed! WRITE (*,*) CALL Prompt_for_String('New __.ai (output map) filename?',new_ai_filename,new_ai_filename) !----------------------------------------------------------- ! Display Adobe_Illustrator data 100 WRITE (*,"(' ')") WRITE (*,"(' ----------------------------------------------------------------------')") WRITE (*,"(' PAGE-DEFINITION SETTINGS')") SELECT CASE (unit_choice) CASE (1); unit_name = 'millimeters'; unit_points = 2.83465 CASE (2); unit_name = 'inches'; unit_points = 72. CASE (3); unit_name = 'points'; unit_points = 1. END SELECT WRITE (*,"(' Page-definition entries are in units of: ',A)") TRIM(unit_name) paper_width = paper_width_points / unit_points WRITE (*,"(' Paper width is: ',F8.2,' ',A)") paper_width, unit_name paper_height = paper_height_points / unit_points WRITE (*,"(' Paper height is: ',F8.2,' ',A)") paper_height, unit_name IF (black) THEN WRITE (*,"(' Basic format is: white marks on black background')") ELSE WRITE (*,"(' Basic format is: black marks on white background')") END IF top_margin = top_margin_points / unit_points left_margin = left_margin_points / unit_points right_margin = right_margin_points / unit_points bottom_margin = bottom_margin_points / unit_points WRITE (*,"(' Unprintable margins are:')") WRITE (*,"(' top margin: ',F8.2,' ',A)") top_margin, TRIM(unit_name) WRITE (*,"(' left margin: ',F8.2,' ',A,' right margin: ',F8.2,' ',A)") & & left_margin, TRIM(unit_name), right_margin, TRIM(unit_name) WRITE (*,"(' bottom margin: ',F8.2,' ',A)") bottom_margin, TRIM(unit_name) IF (plan_toptitles) THEN WRITE (*,"(' Reserve space for title lines at top?: Yes')") ELSE WRITE (*,"(' Reserve space for title lines at top?: No')") END IF IF (plan_rightlegend) THEN WRITE (*,"(' Reserve space for legend at right?: Yes')") ELSE WRITE (*,"(' Reserve space for legend lines at right?: No')") END IF IF (plan_bottomlegend) THEN WRITE (*,"(' Reserve space for legend at bottom?: Yes')") ELSE WRITE (*,"(' Reserve space for legend at bottom?: No')") END IF IF (using_color) THEN WRITE (*,"(' Use COLOR in this figure?: Yes')") ELSE WRITE (*,"(' Use COLOR in this figure?: No')") END IF WRITE (*,"(' Model .ai (input) filename: ',A)") TRIM(model_ai_filename) WRITE (*,"(' New .ai (output) filename: ',A)") TRIM(new_ai_filename) WRITE (*,"(' ----------------------------------------------------------------------')") CALL Prompt_for_Logical('ARE THESE SETTINGS ACCEPTABLE?',.TRUE.,AI_ok) IF (AI_ok) GOTO 200 !---------------------------------------------------------- ! Edit Adobe_Illustrator data 101 WRITE (*,"(' Available unit selections are:')") WRITE (*,"(' 1 :: millimeters')") WRITE (*,"(' 2 :: inches')") WRITE (*,"(' 3 :: points')") CALL Prompt_for_Integer('Which code do you wish?',unit_choice,unit_choice) IF ((unit_choice < 1).OR.(unit_choice > 3)) THEN WRITE (*,"(' ERROR: Choose an integer from the list above.')") unit_choice = 2 GOTO 101 END IF SELECT CASE (unit_choice) CASE (1); unit_name = 'millimeters'; unit_points = 2.83465 CASE (2); unit_name = 'inches'; unit_points = 72. CASE (3); unit_name = 'points'; unit_points = 1. END SELECT 102 paper_width = paper_width_points / unit_points CALL Prompt_for_Real('Width of paper?',paper_width,paper_width) paper_width_points = paper_width * unit_points IF (paper_width_points < 144.) THEN WRITE (*,"(' ERROR: Unreasonably small paper width.')") WRITE (*,"(' (Compose slides as normal-sized pages.)')") paper_width_points = 11. * 72. GOTO 102 END IF 103 paper_height = paper_height_points / unit_points CALL Prompt_for_Real('Height of paper?',paper_height,paper_height) paper_height_points = paper_height * unit_points IF (paper_height_points < 144.) THEN WRITE (*,"(' ERROR: Unreasonably small paper height.')") WRITE (*,"(' (Compose slides as normal-sized pages.)')") paper_height_points = 8.5 * 72. GOTO 103 END IF 104 WRITE (*,"(' Available basic formats are:')") WRITE (*,"(' 1 :: black marks on white background (for paper)')") WRITE (*,"(' 2 :: white marks on black background (for slides?)')") IF (black) THEN; format_choice = 2; ELSE; format_choice = 1; END IF CALL Prompt_for_Integer('Which format do you wish?',format_choice,format_choice) IF ((format_choice < 1).OR.(format_choice > 2)) THEN WRITE (*,"(' ERROR: Choose an integer from the list above.')") black = .FALSE. GOTO 104 END IF SELECT CASE (format_choice) CASE (1); black = .FALSE. CASE (2); black = .TRUE. END SELECT 105 top_margin = top_margin_points / unit_points CALL Prompt_for_Real('Top margin?',top_margin,top_margin) top_margin_points = top_margin * unit_points IF (top_margin_points < 0.) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") top_margin_points = 0. GOTO 105 END IF 106 left_margin = left_margin_points / unit_points CALL Prompt_for_Real('Left margin?',left_margin,left_margin) left_margin_points = left_margin * unit_points IF (left_margin_points < 0.) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") left_margin_points = 0. GOTO 106 END IF 107 right_margin = right_margin_points / unit_points CALL Prompt_for_Real('Right margin?',right_margin,right_margin) right_margin_points = right_margin * unit_points IF (right_margin_points < 0.) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") right_margin_points = 0. GOTO 107 END IF 108 bottom_margin = bottom_margin_points / unit_points CALL Prompt_for_Real('Bottom margin?',bottom_margin,bottom_margin) bottom_margin_points = bottom_margin * unit_points IF (bottom_margin_points < 0.) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") bottom_margin_points = 0. GOTO 108 END IF 109 CALL Prompt_for_Logical('Reserve space for title lines at top?',plan_toptitles,plan_toptitles) 110 CALL Prompt_for_Logical('Reserve space for legend at right?',plan_rightlegend,plan_rightlegend) 111 CALL Prompt_for_Logical('Reserve space for legend at bottom?',plan_bottomlegend,plan_bottomlegend) 112 CALL Prompt_for_Logical('Use COLOR in this figure?',using_color,using_color) 113 CALL Prompt_for_String('Model .ai (input) filename?',model_ai_filename,model_ai_filename) 114 CALL Prompt_for_String('New .ai (output) filename?',new_ai_filename,new_ai_filename) GOTO 100 ! review settings, ask again for changes? !---------------------------------------------------------- ! Display Map_Projection data 200 WRITE (*,"(' ')") WRITE (*,"(' ----------------------------------------------------------------------')") WRITE (*,"(' MAP PROJECTION')") IF (default_xy) THEN IF (PRESENT(xy_defined)) xy_defined = .FALSE. WRITE (*,"(' YOUR INPUT FILES ARE ALL IN ROUND-EARTH (lon,lat) FORMAT.')") IF (xy_mode) THEN WRITE (*,"(' (The alternative would be some or all in flat-Earth (x,y) format.)')") ELSE WRITE (*,"(' (If you have (x,y) data files, use PROJECTOR to convert them.)')") END IF WRITE (string11,"(1P,E11.3)") scale_denominator WRITE (*,"(' Map scale for new .ai plot (at center) is 1: ',A)") TRIM(ADJUSTL(string11)) xy_wrt_page_degrees = xy_wrt_page_radians * degrees_per_radian WRITE (*,"(' In new .ai plot, North will be rotated: ',F6.1,' degrees')") xy_wrt_page_degrees WRITE (*,"(' counterclockwise with respect to the usual straight-up direction.')") CALL Map_Type (projection_choice, projection_name) WRITE (*,"(' Map projection for new .ai plot: ',A)") TRIM(projection_name) ELSE ! custom (x,y) in use IF (PRESENT(xy_defined)) xy_defined = .TRUE. WRITE (*,"(' SOME OR ALL OF YOUR INPUT FILES ARE IN FLAT-EARTH (x,y) FORMAT.')") IF (lonlat_mode) THEN WRITE (*,"(' (The alternative would be all in round-Earth (lon,lat) format.)')") ELSE WRITE (*,"(' (If you have (lon,lat) data files, use PROJECTOR to convert them.)')") END IF SELECT CASE (xy_choice) CASE (1); xy_name = 'meters'; mt_meters_per_user = 1. CASE (2); xy_name = 'centimeters'; mt_meters_per_user = 0.01 CASE (3); xy_name = 'kilometers'; mt_meters_per_user = 1000. CASE (4); xy_name = 'statute miles'; mt_meters_per_user = 1609.344 CASE (5); xy_name = 'nautical miles'; mt_meters_per_user = 1852. CASE (6); xy_name = 'feet'; mt_meters_per_user = 0.3048 END SELECT WRITE (*,"(' Your digitised (x,y) data are in units of: ',A)") TRIM(xy_name) x_center = x_center_meters / mt_meters_per_user WRITE (*,"(' The x value you want at the center of new .ai plot is: ',1P,E10.3,' ',A)") x_center, TRIM(xy_name) y_center = y_center_meters / mt_meters_per_user WRITE (*,"(' The y value you want at the center of new .ai plot is: ',1P,E10.3,' ',A)") y_center, TRIM(xy_name) xy_wrt_page_degrees = xy_wrt_page_radians * degrees_per_radian WRITE (*,"(' In new .ai plot, the +x axis will be rotated: ',F6.1,' degrees')") xy_wrt_page_degrees WRITE (*,"(' counterclockwise with respect to the horizontal/right direction.')") CALL Map_Type (projection_choice, projection_name) WRITE (*,"(' Map projection used to create (x,y) data: ',A)") TRIM(projection_name) WRITE (string11,"(1P,E11.3)") scale_denominator WRITE (*,"(' Map scale for new .ai plot (at projection point) is 1: ',A)") TRIM(ADJUSTL(string11)) END IF IF (projection_choice > 0) THEN WRITE (*,"(' Radius of planet, in meters: ',1P,E10.3)") radius_meters IF (default_xy) THEN WRITE (*,"(' Longitude at center of new .ai plot (degrees, East = +): ',F8.3)") lon WRITE (*,"(' Latitude at center of new .ai plot (degrees, North = +): ',F8.3)") lat ELSE ! using custom (x,y) WRITE (*,"(' Longitude of projection point (degrees, East = +): ',F8.3)") lon WRITE (*,"(' Latitude of projection point (degrees, North = +): ',F8.3)") lat END IF ! default_xy or not IF (projection_choice == 1) THEN ! Mercator belt_azimuth_degrees = belt_azimuth_radians * degrees_per_radian WRITE (*,"(' Azimuth (in degrees, clockwise from North) of the circle')") WRITE (*,"(' of tangency, at the projection point: ',F8.3)") belt_azimuth_degrees END IF IF ((projection_choice >= 2).AND.(projection_choice <= 5)) THEN ! conic WRITE (*,"(' Longitude of axis of cone (East = +): ',F8.3)") cone_lon WRITE (*,"(' Latitude of axis of cone (North = +): ',F8.3)") cone_lat IF (projection_choice <= 3) THEN standard_parallel_gap_degrees = standard_parallel_gap_radians * degrees_per_radian WRITE (*,"(' Gap between 2 standard parallels: ',F8.3,' degrees')") standard_parallel_gap_degrees END IF END IF IF (.NOT.default_xy) THEN ! custom (x,y) in use x_projpoint = x_projpoint_meters / mt_meters_per_user WRITE (*,"(' At the projection point, your (x,y) system has x = ',1P,E10.3,' ',A)") x_projpoint, TRIM(xy_name) y_projpoint = y_projpoint_meters / mt_meters_per_user WRITE (*,"(' At the projection point, your (x,y) system has y = ',1P,E10.3,' ',A)") y_projpoint, TRIM(xy_name) y_azimuth_degrees = y_azimuth_radians * degrees_per_radian WRITE (*,"(' At the projection point, the azimuth of your +y axis is: ',F6.1,' degrees')") y_azimuth_degrees END IF ! custom (x,y) in use END IF ! any projection selected WRITE (*,"(' ----------------------------------------------------------------------')") CALL Prompt_for_Logical('ARE THESE SETTINGS ACCEPTABLE?',.TRUE.,MP_ok) IF (MP_ok) GOTO 300 !---------------------------------------------------------- ! Edit Map_Projection data 201 IF (xy_mode.AND.lonlat_mode) THEN ! mode switching allowed 2015 IF (default_xy) THEN WRITE (*,"(/' YOUR INPUT FILES ARE ALL IN ROUND-EARTH (lon,lat) FORMAT.')") WRITE (*,"(' (The alternative would be some or all in flat-Earth (x,y) format.)')") CALL Prompt_for_Logical('IS THIS CORRECT?',default_xy,default_xy) END IF ! default_xy; all input files are (lon,lat) IF (.NOT.default_xy) THEN custom_xy = .TRUE. WRITE (*,"(/' SOME INPUT FILES ARE IN FLAT-EARTH (x,y) FORMAT.')") WRITE (*,"(' (The alternative would be all in round-Earth (lon,lat) format.)')") CALL Prompt_for_Logical('IS THIS CORRECT?',custom_xy,custom_xy) default_xy = .NOT.custom_xy IF (default_xy) GOTO 2015 END IF END IF ! mode switching allowed IF (default_xy) THEN WRITE (*,"(' ')") 202 CALL Prompt_for_Real('Map scale for new .ai plot (at center) is 1:',scale_denominator,scale_denominator) IF (scale_denominator < 1.) THEN WRITE (*,"(' ERROR: Enter a scale denominator of 1. or more; usually 24000. to 4.E7!')") scale_denominator = 2.E7 GOTO 202 END IF ELSE ! custom (x,y) in use; get details 203 WRITE (*,"(/' Are your digitised (x,y) data in:')") WRITE (*,"(' 1 :: meters')") WRITE (*,"(' 2 :: centimeters')") WRITE (*,"(' 3 :: kilometers')") WRITE (*,"(' 4 :: statute miles')") WRITE (*,"(' 5 :: nautical miles')") WRITE (*,"(' 6 :: feet')") CALL Prompt_for_Integer('Which integer code describes your data?',xy_choice,xy_choice) IF ((xy_choice < 1).OR.(xy_choice > 6)) THEN WRITE (*,"(' ERROR: Enter an integer from the table; try again:')") xy_choice = 1 GOTO 203 END IF SELECT CASE (xy_choice) CASE (1); xy_name = 'meters'; mt_meters_per_user = 1. CASE (2); xy_name = 'centimeters'; mt_meters_per_user = 0.01 CASE (3); xy_name = 'kilometers'; mt_meters_per_user = 1000. CASE (4); xy_name = 'statute miles'; mt_meters_per_user = 1609.344 CASE (5); xy_name = 'nautical miles'; mt_meters_per_user = 1852. CASE (6); xy_name = 'feet'; mt_meters_per_user = 0.3048 END SELECT WRITE (*,"(/' Your answers to the next two questions should be in units of ',A,':')") TRIM(xy_name) 204 x_center = x_center_meters / mt_meters_per_user CALL Prompt_for_Real('What x value do you want at the center of new .ai plot?',x_center,x_center) x_center_meters = x_center * mt_meters_per_user 205 y_center = y_center_meters / mt_meters_per_user CALL Prompt_for_Real('What y value do you want at the center of new .ai plot?',y_center,y_center) y_center_meters = y_center * mt_meters_per_user 206 xy_wrt_page_degrees = xy_wrt_page_radians * degrees_per_radian WRITE (*,"(/' You can cause your (x,y) axes to appear at any angle in new .ai plot.')") CALL Prompt_for_Real('How many degrees should +x be rotated counterclockwise from right?', & & xy_wrt_page_degrees,xy_wrt_page_degrees) xy_wrt_page_radians = xy_wrt_page_degrees * radians_per_degree WRITE (*,"(' ')") 2065 CALL Prompt_for_Real('Map scale for new .ai plot (at projection point) is 1:',scale_denominator,scale_denominator) IF (scale_denominator < 1.) THEN WRITE (*,"(' ERROR: Enter a scale denominator of 1. or more; usually 24000. to 4.E7!')") scale_denominator = 2.E7 GOTO 2065 END IF END IF ! custom (x,y) in use 207 WRITE (*,"(/' Available map projections are:')") IF (default_xy) THEN i1 = 1 ! Projection = None is disallowed. ELSE i1 = 0 ! Projection = None is allowed. END IF DO i = i1, 10 CALL Map_Type (i, projection_name) WRITE (*,"(' ',I2,' :: ',A)") i, TRIM(projection_name) END DO CALL Prompt_for_Integer('Which projection type do you want?',projection_choice,i) IF ((i < i1).OR.(i > 10)) THEN WRITE (*,"(' ERROR: Please select an integer from list; try again:')") GOTO 207 ELSE projection_choice = i CALL Map_Type(projection_choice, projection_name) END IF IF (projection_choice > 0) THEN WRITE (*,"(' ')") 208 CALL Prompt_for_Real('Radius of planet, in meters?',radius_meters,radius_meters) WRITE (*,"(/' *** About Choosing the Projection Point: ***')") WRITE (*,"(' If your data is all in (lon,lat) form, you only need to choose')") WRITE (*,"(' where you want the center of the plot to be. The projection')") WRITE (*,"(' point will be placed there, for minimum distortion.')") WRITE (*,"(' If (any of) your data is in Cartesian (x,y) form, then you need')") WRITE (*,"(' to correctly describe the map that it came from. For azimuthal')") WRITE (*,"(' projections (6,7,8,9,10) the projection point is the point of')") WRITE (*,"(' tangency of the projection plane with the planet. For ')") WRITE (*,"(' Mercator(1) or Geometric Conic(5) maps, it is any point on the')") WRITE (*,"(' circle of tangency. For Polyconic(4) maps, it is any point')") WRITE (*,"(' on the principal meridian. For Lambert Conic(2) or Albers')") WRITE (*,"(' Conic(3) maps, it is any point on the small circle midway')") WRITE (*,"(' between the principal parallels.')") IF (default_xy) THEN 209 CALL Prompt_for_Real('Longitude at center of new .ai plot (degrees, East = +)?',lon,lon) 210 CALL Prompt_for_Real('Latitude at center of new .ai plot (degrees, North = +)?',lat,lat) IF ((lat > 90.).OR.(lat < -90.)) THEN WRITE (*,"(' ERROR: -90.0 <= latitude <= +90.0; try again:')") lat = MAX(MIN(lat,90.),-90.) GOTO 210 END IF xy_wrt_page_degrees = xy_wrt_page_radians * degrees_per_radian WRITE (*,"(/' You can cause the North direction to appear at any angle in new .ai plot.')") CALL Prompt_for_Real('How many degrees should North be rotated& & counterclockwise from the normal straight-up direction?', & & xy_wrt_page_degrees,xy_wrt_page_degrees) xy_wrt_page_radians = xy_wrt_page_degrees * radians_per_degree ELSE ! using custom (x,y) 211 CALL Prompt_for_Real('Longitude of projection point (degrees, East = +)?',lon,lon) 212 CALL Prompt_for_Real('Latitude of projection point (degrees, North = +)?',lat,lat) IF ((lat > 90.).OR.(lat < -90.)) THEN WRITE (*,"(' ERROR: -90.0 <= latitude <= +90.0; try again:')") lat = MAX(MIN(lat,90.),-90.) GOTO 212 END IF END IF ! default_xy or not IF (projection_choice == 1) THEN ! Mercator 213 belt_azimuth_degrees = belt_azimuth_radians * degrees_per_radian WRITE (*,"(' ')") CALL Prompt_for_Real('Azimuth (in degrees, clockwise from North) of the circle& & of tangency, at the projection point?',belt_azimuth_degrees,belt_azimuth_degrees) belt_azimuth_radians = belt_azimuth_degrees * radians_per_degree END IF IF ((projection_choice >= 2).AND.(projection_choice <= 5)) THEN ! conic WRITE (*,"(' ')") 214 CALL Prompt_for_Real('Longitude of axis of cone (East = +)?',cone_lon,cone_lon) 215 CALL Prompt_for_Real('Latitude of axis of cone (North = +)?',cone_lat,cone_lat) IF ((cone_lat > 90.).OR.(cone_lat < -90.)) THEN WRITE (*,"(' ERROR: -90.0 <= latitude <= +90.0; try again:')") cone_lat = MAX(MIN(cone_lat,90.),-90.) GOTO 215 END IF IF (projection_choice <= 3) THEN 216 standard_parallel_gap_degrees = standard_parallel_gap_radians * degrees_per_radian WRITE (*,"(' ')") CALL Prompt_for_Real('Gap between 2 standard parallels (degrees)?', & & standard_parallel_gap_degrees,standard_parallel_gap_degrees) IF (standard_parallel_gap_degrees < 0.) THEN WRITE (*,"(' ERROR: Enter a positive number.')") GOTO 216 END IF standard_parallel_gap_radians = standard_parallel_gap_degrees * radians_per_degree END IF ! projection_choice < 4 END IF ! Lambert Conformal Conic, Albers Equal Area Conic, or Polyconic IF (.NOT.default_xy) THEN ! custom (x,y) in use WRITE (*,"(/' Your answers to the next two questions are in units of ',A,':')") TRIM(xy_name) 217 x_projpoint = x_projpoint_meters / mt_meters_per_user CALL Prompt_for_Real('At the projection point, your (x,y) system has x = ?', & & x_projpoint,x_projpoint) x_projpoint_meters = x_projpoint * mt_meters_per_user 218 y_projpoint = y_projpoint_meters / mt_meters_per_user CALL Prompt_for_Real('At the projection point, your (x,y) system has y = ?', & & y_projpoint,y_projpoint) y_projpoint_meters = y_projpoint * mt_meters_per_user 219 y_azimuth_degrees = y_azimuth_radians * degrees_per_radian WRITE (*,"(/' Your azimuth in the next question is in degrees clockwise from North:')") CALL Prompt_for_Real('At the projection point, the azimuth of your +y axis is?', & & y_azimuth_degrees,y_azimuth_degrees) y_azimuth_radians = y_azimuth_degrees * radians_per_degree END IF ! custom (x,y) in use END IF ! any projection selected GOTO 200 ! review mp_ settings, ask again for changes? !---------------------------------------------------------- ! Issue initializing calls: 300 CALL Select_Paper (paper_width_points, paper_height_points) CALL Set_Background (black) CALL Define_Margins (top_margin_points, & & left_margin_points, right_margin_points, & & bottom_margin_points) 400 IF (PRESENT(path_out)) THEN new_ai_path_and_filename = TRIM(path_out)//TRIM(new_ai_filename) ELSE new_ai_path_and_filename = TRIM(new_ai_filename) END IF CALL Begin_Page (model_ai_filename, in_ok, & & new_ai_path_and_filename, out_ok, & & using_color, & & plan_toptitles, & & plan_rightlegend, & & plan_bottomlegend) IF ((.NOT.in_ok).OR.(.NOT.out_ok)) THEN IF (.NOT.in_ok) THEN WRITE (*,"(/' ERROR: Model .ai file named: ',A)") TRIM(model_ai_filename) WRITE (*,"(' was not found (in this directory).')") CALL Prompt_for_String('Model .ai (input) file [path\]name?','AI4Frame.ai',model_ai_filename) END IF IF (.NOT.out_ok) THEN ! error opening output file: deduce the reason and act! !First, try opening same file with STATUS = 'OLD', to see if it already exists: OPEN (UNIT = ai_out_unit, FILE = new_ai_path_and_filename, & STATUS = 'OLD', IOSTAT = ios) IF (ios == 0) THEN ! file already exists, and is now open WRITE (*,"(/' WARNING: An .ai file named: ',A,' already exists.')") TRIM(new_ai_filename) CALL Prompt_for_Logical('Do you want to overwrite it?',.TRUE.,overwrite) IF (overwrite) THEN CLOSE (UNIT = ai_out_unit, DISP = 'DELETE') !Now it is eliminated, and can be re-created by Begin_Page. ELSE ! don't overwrite; get new name CLOSE (UNIT = ai_out_unit, DISP = 'KEEP') 411 CALL Prompt_for_String('New .ai (output) file name?',' ',new_ai_filename) IF (LEN_TRIM(new_ai_filename) == 0) THEN WRITE (*,"(' ERROR: You must supply a non-blank name.')") GO TO 411 END IF ! no name entered END IF ! overwrite, or not ELSE ! file does not already exist; the problem is elsewhere !Test whether a file named "t9375" can be opened in this directory? new_ai_path_and_filename = TRIM(path_out)//'t9375' OPEN (UNIT = ai_out_unit, FILE = new_ai_path_and_filename, & & IOSTAT = ios) IF (ios == 0) THEN ! this file was successfully opened; the path is OK CLOSE (UNIT = ai_out_unit, DISP = 'DELETE') ! clean up WRITE (*, "(/' Apparently, the file name you requested: ',A,' is illegal.')") TRIM(new_ai_filename) 421 CALL Prompt_for_String('New .ai (output) file name?',' ',new_ai_filename) IF (LEN_TRIM(new_ai_filename) == 0) THEN WRITE (*,"(' ERROR: You must supply a non-blank name.')") GO TO 421 END IF ! no name entered ELSE ! most likely, the path is at fault! IF (PRESENT(path_out)) THEN WRITE (*, "(/' Apparently, the [Drive:][\path\] you requested, ' & /' ',A / ' is illegal. Please look for typos.')") TRIM(path_out) CALL Prompt_for_String('Revised [Drive:][\path\]?',' ',path_out) ELSE ! at this point, I am stumped! WRITE (*,"(/' ERROR: Prompter failed in attempt to create a new .ai file: ',A)") TRIM(new_ai_filename) CALL Traceback END IF ! PRESENT(path_out), or not END IF ! opening "t9375" succeeded or failed END IF ! file already exists, or not END IF GOTO 400 END IF IF (default_xy) THEN x_center_meters = 0.0 y_center_meters = 0.0 !(but, plot may still be rotated with xy_wrt_page_radians) END IF CALL Set_Zoom (scale_denominator, x_center_meters, & & y_center_meters, xy_wrt_page_radians) !Note: User units are defined by the value left in mt_meters_per_user. IF (projection_choice > 0) THEN CALL LonLat_2_Uvec (lon, lat, projpoint_uvec) IF (default_xy) THEN ! (easier than two CALL's per projection) x_projpoint_meters = 0.0 y_projpoint_meters = 0.0 y_azimuth_radians = 0.0 END IF SELECT CASE (projection_choice) CASE (1); CALL Set_Mercator (radius_meters, & & projpoint_uvec, belt_azimuth_radians, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (2) CALL LonLat_2_Uvec (cone_lon, cone_lat, cone_pole_uvec) CALL Set_Lambert_Conformal_Conic & & (radius_meters, & & projpoint_uvec, cone_pole_uvec, & & standard_parallel_gap_radians, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (3) CALL LonLat_2_Uvec (cone_lon, cone_lat, cone_pole_uvec) CALL Set_Albers_Equal_Area_Conic & & (radius_meters, & & projpoint_uvec, cone_pole_uvec, & & standard_parallel_gap_radians, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (4) CALL LonLat_2_Uvec (cone_lon, cone_lat, cone_pole_uvec) CALL Set_Polyconic (radius_meters, & & projpoint_uvec, cone_pole_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (5) CALL LonLat_2_Uvec (cone_lon, cone_lat, cone_pole_uvec) CALL Set_Geometric_Conic & & (radius_meters, & & projpoint_uvec, cone_pole_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (6); CALL Set_Stereographic (radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (7); CALL Set_Lambert_Azimuthal_EqualArea ( & & radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (8); CALL Set_Azimuthal_Equidistant ( & & radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (9); CALL Set_Orthographic ( radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE(10); CALL Set_Gnomonic ( radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) END SELECT ! projection_choice END IF ! any projection? !---------------------------------------------------------- ! Save choices in Map_Tools.ini OPEN (UNIT = 1, FILE = 'Map_Tools.ini') WRITE (1,"(I12,' = unit_choice')") unit_choice WRITE (1,"(F12.5,' = paper_width_points')") paper_width_points WRITE (1,"(F12.5,' = paper_height_points')") paper_height_points WRITE (1,"(L12,' = black')") black WRITE (1,"(F12.5,' = top_margin_points')") top_margin_points WRITE (1,"(F12.5,' = left_margin_points')") left_margin_points WRITE (1,"(F12.5,' = right_margin_points')") right_margin_points WRITE (1,"(F12.5,' = bottom_margin_points')") bottom_margin_points WRITE (1,"(L12,' = plan_toptitles')") plan_toptitles WRITE (1,"(L12,' = plan_rightlegend')") plan_rightlegend WRITE (1,"(L12,' = plan_bottomlegend')") plan_bottomlegend WRITE (1,"(L12,' = using_color')") using_color WRITE (1,"(A)") TRIM(model_ai_filename) WRITE (1,"(A)") TRIM(new_ai_filename) WRITE (1,"(1P,E12.5,' = scale_denominator')") scale_denominator WRITE (1,"(L12,' = default_xy')") default_xy WRITE (1,"(I12,' = xy_choice')") xy_choice WRITE (1,"(1P,E12.5,' = x_center_meters')") x_center_meters WRITE (1,"(1P,E12.5,' = y_center_meters')") y_center_meters WRITE (1,"(F12.5,' = xy_wrt_page_radians')") xy_wrt_page_radians WRITE (1,"(I12,' = projection_choice')") projection_choice WRITE (1,"(1P,E12.5,' = radius_meters')") radius_meters WRITE (1,"(F12.5,' = lon')") lon WRITE (1,"(F12.5,' = lat')") lat WRITE (1,"(F12.3,' = belt_azimuth_radians')") belt_azimuth_radians WRITE (1,"(F12.5,' = cone_lon')") cone_lon WRITE (1,"(F12.5,' = cone_lat')") cone_lat WRITE (1,"(F12.6,' = standard_parallel_gap_radians')") standard_parallel_gap_radians WRITE (1,"(1P,E12.5,' = x_projpoint_meters')") x_projpoint_meters WRITE (1,"(1P,E12.5,' = y_projpoint_meters')") y_projpoint_meters WRITE (1,"(F12.5,' = y_azimuth_radians')") y_azimuth_radians CLOSE (1) CONTAINS ! member subprograms (so tables only entered once!) SUBROUTINE Map_Type(projection_choice, projection_name) IMPLICIT NONE INTEGER, INTENT(IN) :: projection_choice CHARACTER*43, INTENT(OUT) :: projection_name SELECT CASE (projection_choice) CASE (0); projection_name = 'None; to plot (x,y) data without conversion' CASE (1); projection_name = 'Mercator' CASE (2); projection_name = 'Lambert Conformal Conic' CASE (3); projection_name = 'Albers Equal-Area Conic' CASE (4); projection_name = 'Polyconic' CASE (5); projection_name = 'Geometric Conic' CASE (6); projection_name = 'Stereographic' CASE (7); projection_name = 'Lambert Azimuthal Equal-Area' CASE (8); projection_name = 'Azimuthal Equidistant' CASE (9); projection_name = 'Orthographic' CASE (10); projection_name = 'Gnomonic' END SELECT END SUBROUTINE Map_Type ! contained in Prompter END SUBROUTINE Prompter CHARACTER*3 FUNCTION RGB_Kansas(warmth, brightness) !Returns a 3-byte (RGB, or red green blue) pixel color ! suitable for packing into a .tiff bitmap array. !Warmth ranges from 0.0 to 1.0, corresponding to a ! 44-color scale used by the University of Kansas: ! blues - greens - yellows - browns ! in which reds and purples are avoided, ! for an atlas-like effect. !Brightness varies from 0.0 to 2.0: ! -at brightness 1.0 there is full color saturation; ! -at brightness below 1.0 some black is mixed in; ! -at brightness above 1.0 some white is mixed in. !Off-scale values of the parameters are treated as equal ! to limiting values. IMPLICIT NONE REAL, INTENT(IN) :: warmth, brightness INTEGER :: blue_integer, green_integer, index, red_integer REAL :: blue_fraction, bright, fraction, green_fraction, & & red_fraction, warm REAL, DIMENSION(3,44) :: Kansas !color (warmth) section: DATA Kansas / 16., 0., 90., & ! 1 = dark blue & 24., 24., 107., & ! 2 & 0., 8., 123., & ! 3 & 0., 69., 123., & ! 4 & 16., 93., 140., & ! 5 & 57., 121., 156., & ! 6 & 24., 138., 156., & ! 7 & 82., 166., 173., & ! 8 & 74., 190., 181., & ! 9 & 82., 211., 189., & ! 10 & 123., 231., 206., & ! 11 = aqua & 115., 219., 189., & ! 12 & 99., 199., 165., & ! 13 & 74., 178., 140., & ! 14 & 33., 162., 107., & ! 15 & 66., 150., 107., & ! 16 & 66., 125., 90., & ! 17 & 57., 109., 74., & ! 18 & 24., 89., 49., & ! 19 & 0., 69., 0., & ! 20 & 0., 77., 0., & ! 21 & 0., 97., 0., & ! 22 = dark green & 74., 109., 49., & ! 23 & 90., 117., 49., & ! 24 & 107., 130., 57., & ! 25 & 107., 142., 41., & ! 26 & 140., 166., 49., & ! 27 & 148., 178., 24., & ! 28 & 173., 199., 16., & ! 29 & 198., 211., 107., & ! 30 & 222., 231., 132., & ! 31 & 247., 243., 140., & ! 32 = muted yellow & 255., 243., 173., & ! 33 & 255., 227., 156., & ! 34 & 247., 203., 132., & ! 35 & 239., 186., 115., & ! 36 & 239., 178., 107., & ! 37 = terra cotta & 222., 158., 82., & ! 38 & 206., 134., 57., & ! 39 & 181., 113., 49., & ! 40 & 132., 85., 41., & ! 41 & 123., 81., 49., & ! 42 & 99., 65., 41., & ! 43 & 74., 44., 16. / ! 44= dark brown warm = MAX(0.0, MIN(warmth, 1.0)) index = 1 + 44.0 * warm index = MIN(44,MAX(1,index)) red_fraction = Kansas(1,index) / 255.0 green_fraction = Kansas(2,index) / 255.0 blue_fraction = Kansas(3,index) / 255.0 !brightness section: bright = MAX(0.0, MIN(brightness, 2.0)) IF (bright < 1.0) THEN ! mix with black red_fraction = bright * red_fraction green_fraction = bright * green_fraction blue_fraction = bright * blue_fraction ELSE IF (bright > 1.0) THEN ! mix with white red_fraction = (2.-bright) * red_fraction + bright - 1.0 green_fraction = (2.-bright) * green_fraction + bright - 1.0 blue_fraction = (2.-bright) * blue_fraction + bright - 1.0 ENDIF !expand to range 0-255 and pack into 3 bytes: red_integer = MAX(0,MIN(NINT(255.0* red_fraction),255)) green_integer = MAX(0,MIN(NINT(255.0*green_fraction),255)) blue_integer = MAX(0,MIN(NINT(255.0* blue_fraction),255)) RGB_Kansas = CHAR(red_integer)//CHAR(green_integer)//CHAR(blue_integer) END FUNCTION RGB_Kansas CHARACTER*3 FUNCTION RGB_Munsell(warmth, brightness) !Returns a 3-byte (RGB, or red green blue) pixel color !suitable for packing into a .tiff bitmap array. !Warmth ranges from 0.0 to 1.0, corresponding to the range: ! purples - blues - greens - yellows - browns - reds !Brightness varies from 0.0 to 2.0: ! -at brightness 1.0 there is full color saturation; ! -at brightness below 1.0 some black is mixed in; ! -at brightness above 1.0 some white is mixed in. !Off-scale values of the parameters are treated as equal ! to limiting values. IMPLICIT NONE REAL, INTENT(IN) :: warmth, brightness INTEGER :: blue_integer, green_integer, left_index, red_integer, right_index REAL :: blue_fraction, bright, fraction, green_fraction, & & red_fraction, warm REAL, DIMENSION(3,10) :: Munsell !color (warmth) section: !using Munsell 10-color wheel (copied from Grolier Encyclopedia, ! by eye, so RGB values approximate) DATA Munsell / 255., 80., 255., & ! red-grape & 192., 127., 255., & ! purple & 0., 0., 255., & ! blue & 31., 233., 255., & ! cyan & 0., 215., 103., & ! green & 125., 255., 31., & ! Spring green & 255., 255., 0., & ! yellow & 255., 193., 31., & ! orange & 255., 0., 0., & ! red & 255., 80., 80. / ! lox warm = MAX(0.0, MIN(warmth, 1.0)) left_index = 1 + 9.0 * warm left_index = MIN(9,MAX(1,left_index)) right_index = left_index + 1 fraction = 9.0 * warm - (left_index - 1) fraction = MIN(1.0,MAX(0.0, fraction)) red_fraction = (Munsell(1,left_index) + & & fraction * (Munsell(1,right_index) - Munsell(1,left_index))) / 255.0 green_fraction =(Munsell(2,left_index) + & & fraction * (Munsell(2,right_index) - Munsell(2,left_index))) / 255.0 blue_fraction = (Munsell(3,left_index) + & & fraction * (Munsell(3,right_index) - Munsell(3,left_index))) / 255.0 !brightness section: bright = MAX(0.0, MIN(brightness, 2.0)) IF (bright < 1.0) THEN ! mix with black red_fraction = bright * red_fraction green_fraction = bright * green_fraction blue_fraction = bright * blue_fraction ELSE IF (bright > 1.0) THEN ! mix with white red_fraction = (2.-bright) * red_fraction + bright - 1.0 green_fraction = (2.-bright) * green_fraction + bright - 1.0 blue_fraction = (2.-bright) * blue_fraction + bright - 1.0 ENDIF !expand to range 0-255 and pack into 3 bytes: red_integer = MAX(0,MIN(NINT(255.0* red_fraction),255)) green_integer = MAX(0,MIN(NINT(255.0*green_fraction),255)) blue_integer = MAX(0,MIN(NINT(255.0* blue_fraction),255)) RGB_Munsell = CHAR(red_integer)//CHAR(green_integer)//CHAR(blue_integer) END FUNCTION RGB_Munsell CHARACTER*3 FUNCTION RGB_UNAVCO(elevation_meters, brightness) !Returns a 3-byte (RGB, or red green blue) pixel color !suitable for packing into a .tiff bitmap array. !Elevation_meters from -6000. to +6000., corresponding to the range: ! purples - blues - greens - yellows - browns - reds - lavenders !Note that color changes are abrupt, not smooth. !Brightness varies from 0.0 to 2.0: ! -at brightness 1.0 there is full color saturation; ! -at brightness below 1.0 black is mixed in; ! -at brightness above 1.0 white is mixed in. !Off-scale values of the parameters are treated as equal ! to limiting values. IMPLICIT NONE REAL, INTENT(IN) :: elevation_meters, brightness INTEGER :: blue_integer, green_integer, i, red_integer REAL :: blue_fraction, bright, fraction, green_fraction, & & red_fraction REAL, DIMENSION(20) :: highest_elevation_meters REAL, DIMENSION(3,20) :: UNAVCO !color (warmth) section: DATA highest_elevation_meters / -5000., -4000., -3000., & & -2500., -2000., -1500., & & -1000., -500., 0., & & 250., 500., 750., & & 1000., 1500., 2000., & & 2500., 3000., 4000., & & 5000., 6000. / DATA UNAVCO / 255., 75., 255., & ! 1: fuschia & 220., 0., 200., & ! 2: red wine grape & 180., 0., 255., & ! 3: Concord grape & 105., 0., 255., & ! 4: deep blue & 50., 5., 255., & ! 5: blue & 15., 50., 255., & ! 6: (brighter) blue & 0., 120., 255., & ! 7: teal & 50., 195., 255., & ! 8: pale blue & 100., 255., 255., & ! 9: cyan & 100., 230., 110., & ! 10: marshland green & 160., 245., 150., & ! 11: pale green & 247., 215., 104., & ! 12: terra cotta & 220., 255., 20., & ! 13: off-yellow & 255., 225., 0., & ! 14: tangerine & 255., 135., 0., & ! 15: dark orange & 255., 75., 0., & ! 16: brick red & 238., 80., 78., & ! 17: mauve & 255., 124., 124., & ! 18: dark pink & 245., 179., 174., & ! 19: muted pink & 255., 215., 215. / ! 20: lightest pink !warmth section (discontinuous, histogram-like) red_fraction = 0.9 green_fraction = 0.9 blue_fraction = 0.9 !(if higher than all upper limits, use off-white for peaks) DO i = 1, 20 IF (elevation_meters < highest_elevation_meters(i)) THEN red_fraction = UNAVCO(1,i) / 255.0 green_fraction = UNAVCO(2,i) / 255.0 blue_fraction = UNAVCO(3,i) / 255.0 EXIT ! the DO loop END IF END DO !brightness section: bright = MAX(0.0, MIN(brightness, 2.0)) IF (bright < 1.0) THEN ! mix with black red_fraction = bright * red_fraction green_fraction = bright * green_fraction blue_fraction = bright * blue_fraction ELSE IF (bright > 1.0) THEN ! mix with white red_fraction = (2.-bright) * red_fraction + bright - 1.0 green_fraction = (2.-bright) * green_fraction + bright - 1.0 blue_fraction = (2.-bright) * blue_fraction + bright - 1.0 ENDIF !expand to range 0-255 and pack into 3 bytes: red_integer = MAX(0,MIN(NINT(255.0* red_fraction),255)) green_integer = MAX(0,MIN(NINT(255.0*green_fraction),255)) blue_integer = MAX(0,MIN(NINT(255.0* blue_fraction),255)) RGB_UNAVCO = CHAR(red_integer)//CHAR(green_integer)//CHAR(blue_integer) END FUNCTION RGB_UNAVCO CHARACTER*3 FUNCTION RGB_AI (value, contour_interval, midspectrum_value, & & low_is_blue, brightness) !Returns a 3-byte (RGB, or red green blue) pixel color !suitable for packing into a .tiff bitmap array. !Color scale is from global ai_spectrum in module Adobe_Illustrator. !Note that color changes are abrupt, not smooth. !Brightness varies from 0.0 to 2.0: ! -at brightness 1.0 there is full color saturation; ! -at brightness below 1.0 black is mixed in; ! -at brightness above 1.0 white is mixed in. !Off-scale values of the parameters are treated as equal ! to limiting values. IMPLICIT NONE REAL, INTENT(IN) :: value, contour_interval, midspectrum_value, brightness LOGICAL, INTENT(IN) :: low_is_blue INTEGER :: blue_integer, green_integer, index, red_integer REAL :: blue_fraction, bright, fraction, green_fraction, & & pivot_value, red_fraction, steps_from_center IF (contour_interval <= 0.) THEN WRITE (*,"(' ERROR: Non-positive contour interval in RGB_AI.')") CALL Traceback END IF ! value / color / warmth section (discontinuous, histogram-like) IF (MOD(ai_spectrum_count,2) == 0) THEN ! even number of colors pivot_value = contour_interval * NINT(midspectrum_value / contour_interval) steps_from_center = (value - pivot_value) / contour_interval IF (low_is_blue) THEN index = (ai_spectrum_count/2) - Int_Below(steps_from_center) ELSE ! high is blue index = (ai_spectrum_count/2) + 1 + Int_Below(steps_from_center) END IF ELSE ! odd number of colors pivot_value = contour_interval * (0.5 + NINT((midspectrum_value / contour_interval) - 0.5)) steps_from_center = (value - pivot_value) / contour_interval IF (low_is_blue) THEN index = ((ai_spectrum_count+1)/2) - NINT(steps_from_center) ELSE ! high is blue index = ((ai_spectrum_count+1)/2) + NINT(steps_from_center) END IF END IF ! even/odd number of colors index = MAX(index, 0) index = MIN(index, ai_spectrum_count + 1) red_fraction = ai_spectrum(index)%rgb(1) / 256. green_fraction = ai_spectrum(index)%rgb(2) / 256. blue_fraction = ai_spectrum(index)%rgb(3) / 256. !brightness section: bright = MAX(0.0, MIN(brightness, 2.0)) IF (bright < 1.0) THEN ! mix with black red_fraction = bright * red_fraction green_fraction = bright * green_fraction blue_fraction = bright * blue_fraction ELSE IF (bright > 1.0) THEN ! mix with white red_fraction = (2.-bright) * red_fraction + bright - 1.0 green_fraction = (2.-bright) * green_fraction + bright - 1.0 blue_fraction = (2.-bright) * blue_fraction + bright - 1.0 ENDIF !expand to range 0-255 and pack into 3 bytes: red_integer = MAX(0,MIN(NINT(255.0* red_fraction),255)) green_integer = MAX(0,MIN(NINT(255.0*green_fraction),255)) blue_integer = MAX(0,MIN(NINT(255.0* blue_fraction),255)) RGB_AI = CHAR(red_integer)//CHAR(green_integer)//CHAR(blue_integer) END FUNCTION RGB_AI SUBROUTINE Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) ! Reports the frame (x1 <= x <= x2; y1 <= y <= y2) for the bottom legend, ! in level-1 points measured from bottom left corner of page. ! Takes into account paper size, margins, map window, and lonlat labels. ! Intended for the user who wants to design a custom bottom legend, ! writing to level 1 (outside the map window). ! If the reported box is null or too small, check that: ! * plan_bottomlegend = .TRUE. in most recent CALL Begin_Page; ! * ai_bottomlegend_points has adequate size in module data. IMPLICIT NONE REAL, INTENT(OUT) :: x1_points, x2_points, y1_points, y2_points x1_points = ai_left_limit_points x2_points = ai_window_x2_points + ai_lonlatlabel_points y1_points = ai_bottom_limit_points y2_points = ai_window_y1_points - ai_lonlatlabel_points END SUBROUTINE Report_BottomLegend_Frame SUBROUTINE Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) ! Reports the frame (x1 <= x <= x2; y1 <= y <= y2) for the right legend, ! in level-1 points measured from bottom left corner of page. ! Takes into account paper size, margins, map window, and lonlat labels. ! Intended for the user who wants to design a custom right legend, ! writing to level 1 (outside the map window). ! If the reported box is null or too small, check that: ! * plan_rightlegend = .TRUE. in most recent CALL Begin_Page; ! * ai_rightlegend_points has adequate size in module data. IMPLICIT NONE REAL, INTENT(OUT) :: x1_points, x2_points, y1_points, y2_points x1_points = ai_window_x2_points + ai_lonlatlabel_points x2_points = ai_right_limit_points y1_points = ai_window_y1_points - ai_lonlatlabel_points y2_points = ai_window_y2_points + ai_lonlatlabel_points END SUBROUTINE Report_RightLegend_Frame SUBROUTINE Set_Fill_by_Value (value, contour_interval, & & midspectrum_value, low_is_blue) ! Selects and sets fill (color or pattern) depending on ! current color or black/white mode (ai_using_color?), ! and on function value "value" (which may NOT be a multiple ! of "contour_interval", in such a way as to assign ! "midspectrum_value" a mid-spectrum color/pattern, and ! to observe the requested coloring sense (low_is_blue?). IMPLICIT NONE REAL, INTENT(IN) :: value, contour_interval, midspectrum_value LOGICAL, INTENT(IN) :: low_is_blue CHARACTER*6 :: string INTEGER :: index, small REAL :: pivot_value, steps_from_center IF (contour_interval <= 0.) THEN WRITE (*,"(' ERROR: Non-positive contour interval in Set_Fill_by_Value.')") CALL Traceback END IF IF (MOD(value, contour_interval) == 0.) THEN WRITE (*,"(' ERROR: Value ',1P,E12.5,' is exact multiple of contour interval ',E12.5)") value, contour_interval CALL Traceback END IF IF (ai_using_color) THEN IF (MOD(ai_spectrum_count,2) == 0) THEN ! even number of colors pivot_value = contour_interval * NINT(midspectrum_value / contour_interval) steps_from_center = (value - pivot_value) / contour_interval IF (low_is_blue) THEN index = (ai_spectrum_count/2) - Int_Below(steps_from_center) ELSE ! high is blue index = (ai_spectrum_count/2) + 1 + Int_Below(steps_from_center) END IF ELSE ! odd number of colors pivot_value = contour_interval * (0.5 + NINT((midspectrum_value / contour_interval) - 0.5)) steps_from_center = (value - pivot_value) / contour_interval IF (low_is_blue) THEN index = ((ai_spectrum_count+1)/2) - NINT(steps_from_center) ELSE ! high is blue index = ((ai_spectrum_count+1)/2) + NINT(steps_from_center) END IF END IF ! even/odd number of colors index = MAX(index, 0) index = MIN(index, ai_spectrum_count + 1) CALL Set_Fill_or_Pattern (use_pattern = .FALSE., & & color_name = ai_spectrum(index)%color_name) ELSE ! black/white page IF (MOD(ai_pattern_count,2) == 0) THEN ! even number of patterns pivot_value = contour_interval * NINT(midspectrum_value / contour_interval) steps_from_center = (value - pivot_value) / contour_interval IF (low_is_blue) THEN index = (ai_pattern_count/2) - Int_Below(steps_from_center) ELSE ! high is blue index = (ai_pattern_count/2) + 1 + Int_Below(steps_from_center) END IF ELSE ! odd number of patterns pivot_value = contour_interval * (0.5 + NINT((midspectrum_value / contour_interval) - 0.5)) steps_from_center = (value - pivot_value) / contour_interval IF (low_is_blue) THEN index = ((ai_pattern_count+1)/2) - NINT(steps_from_center) ELSE ! high is blue index = ((ai_pattern_count+1)/2) + NINT(steps_from_center) END IF END IF ! even/odd number of colors index = MAX(index, 0) index = MIN(index, ai_pattern_count + 1) IF (index == 0) THEN CALL Set_Fill_or_Pattern (use_pattern = .FALSE., & & color_name = ai_spectrum(0)%color_name) ELSE IF (index == (ai_pattern_count + 1)) THEN CALL Set_Fill_or_Pattern (use_pattern = .FALSE., & & color_name = ai_spectrum(ai_spectrum_count+1)%color_name) ELSE WRITE (string, "(I6)") index string = ADJUSTL(string) small = LEN_TRIM(string) CALL Set_Fill_or_Pattern (use_pattern = .TRUE., & & pattern = 'Gray'//string(1:small)) END IF END IF ! using color or not END SUBROUTINE Set_Fill_by_Value SUBROUTINE Set_Stroke_by_Value (value, contour_interval, & & midspectrum_value, low_is_blue) ! Selects and sets stroke color to one of: ! 'black_____' (on 'off_white_', or when a color is adjacent), ! or 'white_____' (when 'gray______' is adjacent on both sides). ! Used only for contouring. IMPLICIT NONE REAL, INTENT(IN) :: value, contour_interval, midspectrum_value LOGICAL, INTENT(IN) :: low_is_blue INTEGER :: low_index ! lower of two adjacent indeces of adjacent colors/patterns REAL :: pivot_value, steps_from_center IF (contour_interval <= 0.) THEN WRITE (*,"(' ERROR: Non-positive contour interval in Set_Fill_by_Value.')") CALL Traceback END IF IF (ai_using_color) THEN IF (MOD(ai_spectrum_count,2) == 0) THEN ! even number of colors pivot_value = contour_interval * NINT(midspectrum_value / contour_interval) steps_from_center = (value - pivot_value) / contour_interval IF (low_is_blue) THEN low_index = (ai_spectrum_count/2) - NINT(steps_from_center) ELSE ! high is blue low_index = (ai_spectrum_count/2) + NINT(steps_from_center) END IF ELSE ! odd number of colors pivot_value = contour_interval * (0.5 + NINT((midspectrum_value / contour_interval) - 0.5)) steps_from_center = (value - pivot_value) / contour_interval IF (low_is_blue) THEN low_index = ((ai_spectrum_count+1)/2) - 1 - Int_Below(steps_from_center) ELSE ! high is blue low_index = ((ai_spectrum_count+1)/2) + Int_Below(steps_from_center) END IF END IF ! even/odd number of colors IF (low_index >= (ai_spectrum_count+1)) THEN CALL Set_Stroke_Color ('white_____') ELSE CALL Set_Stroke_Color ('black_____') END IF ELSE ! black/white page IF (MOD(ai_pattern_count,2) == 0) THEN ! even number of patterns pivot_value = contour_interval * NINT(midspectrum_value / contour_interval) steps_from_center = (value - pivot_value) / contour_interval IF (low_is_blue) THEN low_index = (ai_pattern_count/2) - NINT(steps_from_center) ELSE ! high is blue low_index = (ai_pattern_count/2) + NINT(steps_from_center) END IF ELSE ! odd number of patterns pivot_value = contour_interval * (0.5 + NINT((midspectrum_value / contour_interval) - 0.5)) steps_from_center = (value - pivot_value) / contour_interval IF (low_is_blue) THEN low_index = ((ai_pattern_count+1)/2) - 1 - Int_Below(steps_from_center) ELSE ! high is blue low_index = ((ai_pattern_count+1)/2) + Int_Below(steps_from_center) END IF END IF ! even/odd number of colors IF (low_index >= (ai_pattern_count+1)) THEN CALL Set_Stroke_Color ('white_____') ELSE CALL Set_Stroke_Color ('black_____') END IF END IF ! using color or not END SUBROUTINE Set_Stroke_by_Value SUBROUTINE Spectrum_in_BottomLegend (low_value, high_value, units, & & bitmap_color_mode, bitmap_color_lowvalue, & & bitmap_color_highvalue, shaded_relief, & & contour_interval, midspectrum_value, low_is_blue) ! Places a color spectrum (using a bitmap) ! in the bottom legend area to identify the coloring ! of bitmap plots. ! Note that all spatial variables in this routine are in ! level-1 points. ! The units string can be cancelled (if not wanted) by setting ! units = ' ' ! (regardless of the declared length of units). ! Notice that the last 3 arguments are only needed if bitmap_color_mode == 4. IMPLICIT NONE INTEGER, INTENT(IN) :: bitmap_color_mode LOGICAL, INTENT(IN) :: shaded_relief REAL, INTENT(IN) :: bitmap_color_lowvalue, bitmap_color_highvalue, & & high_value, low_value CHARACTER*(*), INTENT(IN) :: units REAL, INTENT(IN), OPTIONAL :: contour_interval, midspectrum_value LOGICAL, INTENT(IN), OPTIONAL :: low_is_blue CHARACTER*3 :: c3 CHARACTER*9 :: string9a, string9b CHARACTER*10 :: string10a, string10b CHARACTER(LEN=3), DIMENSION(:,:), ALLOCATABLE :: bitmap INTEGER :: bytes_wide, denominator, i, irow, i1, i2, jcol, k, units_bytes LOGICAL :: label_all, label_this_one, need_ASCII10 REAL, PARAMETER :: aspect = 0.5 ! typical character width/nominal height REAL :: bar_height, bar_length, brightness, c_i, & & fraction, limit1, limit2, limit3, scale, t, value, & & v_left, v_right, v_center, v_line, & & x_left, x_right, x_line, & & x1_bar, x2_bar, y1_bar, y2_bar, & & x1_frame, x2_frame, y1_frame, y2_frame units_bytes = LEN_TRIM(units) IF (.NOT.ai_bottomlegend_reserved) THEN WRITE (*,"(' ERROR: No space reserved (in Begin_Page) for bottom legend.')") CALL Traceback END IF IF (low_value > high_value) THEN WRITE (*,"(' ERROR: low_value > high_value in Spectrum_in_BottomLegend.')") CALL Traceback END IF ! check adequacy of space CALL Report_BottomLegend_Frame (x1_frame, x2_frame, y1_frame, y2_frame) IF ((y2_frame - y1_frame) < (2. * ai_lonlatlabel_points + 7.)) THEN WRITE (*,"(' ERROR: ',F6.0,' < y < ',F6.0,' points is too tight for Bar_in_BottomLegend.')") y1_frame, y2_frame CALL Traceback END IF IF ((x2_frame - x1_frame) < ((19 + units_bytes) * ai_lonlatlabel_points * aspect + 7.)) THEN WRITE (*,"(' ERROR: ',F6.0,' < x < ',F6.0,' points is too tight for Bar_in_BottomLegend.')") x1_frame, x2_frame CALL Traceback END IF ! Decide reasonable contour interval (for tics & numbers only!) IF ((bitmap_color_mode == 4).AND.PRESENT(contour_interval).AND.(contour_interval /= 0.0)) THEN c_i = contour_interval ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO absolute elevation scale c_i = 1000. ELSE IF (high_value > low_value) THEN c_i = Round ((high_value - low_value) / 8.0) ELSE c_i = 1.0 END IF END IF END IF ! decide length and x-placement of bar limit1 = 10. * 72. ! regardless of paper size limit2 = 10 * ai_lonlatlabel_points * aspect * (high_value - low_value) / c_i limit3 = (x2_frame - x1_frame) - (19 + units_bytes) * ai_lonlatlabel_points * aspect bar_length = MIN(limit1, limit2, limit3) IF (bar_length == limit3) THEN ! shift to left to allow for units x1_bar = 0.5 *(x1_frame + x2_frame) - 0.5 * bar_length - & & 0.5 * (units_bytes + 1) * ai_lonlatlabel_points * aspect ELSE ! center in frame x1_bar = 0.5 *(x1_frame + x2_frame) - 0.5 * bar_length END IF x2_bar = x1_bar + bar_length ! Find integer limits on countour lines: i1 = 1 + Int_Below (low_value / c_i) i2 = Int_Below (high_value / c_i) ! Decide whether 4 significant digits (ASCII10) are needed to keep values distinct: need_ASCII10 = .FALSE. ! unless it becomes .TRUE. in loop below: IF (i2 > i1) THEN DO i = i1+1, i2 string9a = ASCII9((i-1) * contour_interval) string9b = ASCII9( i * contour_interval) IF (string9a == string9b) need_ASCII10 = .TRUE. END DO END IF ! decide if all numbers can be written in IF (need_ASCII10) THEN IF (i2 >= i1) THEN ! normal case string10a = ASCII10(i1 * c_i) string10b = ASCII10(i2 * c_i) ELSE ! no contours string10a = ASCII10(low_value) string10b = ASCII10(high_value) END IF string10a = ADJUSTL(string10a) string10b = ADJUSTL(string10b) bytes_wide = 1 + MAX(LEN_TRIM(string10a), LEN_TRIM(string10b)) ELSE ! ASCII9 (3 sig fig) will do IF (i2 >= i1) THEN ! normal case string9a = ASCII9(i1 * c_i) string9b = ASCII9(i2 * c_i) ELSE ! no contours string9a = ASCII9(low_value) string9b = ASCII9(high_value) END IF string9a = ADJUSTL(string9a) string9b = ADJUSTL(string9b) bytes_wide = 1 + MAX(LEN_TRIM(string9a), LEN_TRIM(string9b)) END IF ! ASCII10 (4 sig fig) or ASCII9 (3 sig fig) ! decide if all numbers can be written in IF (high_value /= low_value) THEN label_all = bytes_wide * ai_lonlatlabel_points * aspect <= & & (bar_length * c_i / (high_value - low_value)) IF (label_all) THEN denominator = 1 ELSE denominator = Int_Above(bytes_wide * ai_lonlatlabel_points * aspect / & &(bar_length * c_i / (high_value - low_value))) END IF ELSE label_all = .TRUE. denominator = 1 END IF ! decide height and y-placement of bar limit1 = 28. ! 1 centimeter IF (label_all) THEN limit2 = (y2_frame - y1_frame) - ai_lonlatlabel_points ELSE limit2 = (y2_frame - y1_frame) - 2. * ai_lonlatlabel_points END IF bar_height = MIN(limit1, limit2) IF (label_all) THEN y1_bar = y1_frame + ai_lonlatlabel_points ELSE y1_bar = y1_frame + 2. * ai_lonlatlabel_points END IF y2_bar = y1_bar + bar_height ! Set horizontal scaling (points / data units) scale = bar_length / MAX((high_value - low_value), 1.E-30) ! Graphics CALL Begin_Group ! whole legend !Bitmap can have fixed size because placement ! operator will stretch-to-fit: ALLOCATE ( bitmap(37, 360) ) DO irow = 1, 37 DO jcol = 1, 360 fraction = (jcol - 0.5) / 360.0 value = low_value + fraction * (high_value - low_value) t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) IF (shaded_relief) THEN brightness = 1.00 + (19 - irow) / 18. ! range 0. - 2. ELSE IF (mt_shingled_brightness) THEN brightness = 0.8 + 0.8 * MOD(value, 1.0) ELSE brightness = 1.00 END IF IF (bitmap_color_mode <= 1) THEN ! Munsell: smooth spectrum c3 = RGB_Munsell(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 2) THEN ! Kansas: 44-color atlas-type scale c3 = RGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = RGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = RGB_AI(value = value, contour_interval = c_i, & & midspectrum_value = midspectrum_value, low_is_blue = low_is_blue, & & brightness = brightness) ELSE IF (bitmap_color_mode == 101) THEN ! continuous gray-scale; black_is_high t = (value - low_value) / (high_value - low_value) k = NINT(255. - (255. * t)) k = MAX(0,MIN(255,k)) c3 = CHAR(k)//CHAR(k)//CHAR(k) ELSE IF (bitmap_color_mode == 102) THEN ! continuous gray-scale; white is high t = (value - low_value) / (high_value - low_value) k = NINT(255. * t) k = MAX(0,MIN(255,k)) c3 = CHAR(k)//CHAR(k)//CHAR(k) END IF ! bitmap_color_mode selection bitmap(irow,jcol) = c3 END DO END DO CALL Bitmap_on_L1 (bitmap, x1_bar, x2_bar, & & y1_bar, y2_bar) DEALLOCATE ( bitmap ) ! line of background color for zero contour? IF (bitmap_color_mode == 0) THEN IF ((bitmap_color_lowvalue <= 0.0).AND.(bitmap_color_highvalue >= 0.0)) THEN x_line = x1_bar + (x2_bar - x1_bar) * (0.0 - bitmap_color_lowvalue) / & & (bitmap_color_highvalue - bitmap_color_lowvalue) CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('background') CALL New_L12_Path (1, x_line, y1_bar) CALL Line_to_L12 (x_line, y2_bar) CALL End_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF END IF ! box around spectrum bar: CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL New_L12_Path (1, x1_bar, y1_bar) CALL Line_to_L12 (x2_bar, y1_bar) CALL Line_to_L12 (x2_bar, y2_bar) CALL Line_to_L12 (x1_bar, y2_bar) CALL Line_to_L12 (x1_bar, y1_bar) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) CALL Begin_Group ! number labels CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! always label low_value IF (need_ASCII10) THEN string10a = ASCII10(low_value) string10a = ADJUSTL(string10a) CALL L12_Text (level = 1, x_points = x1_bar, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 1.0, & & text = TRIM(string10a)) ELSE string9a = ASCII9(low_value) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x1_bar, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 1.0, & & text = TRIM(string9a)) END IF ! always label high_value, adding units IF (need_ASCII10) THEN string10a = ASCII10(high_value) string10a = ADJUSTL(string10a) bytes_wide = LEN_TRIM(string10a) CALL L12_Text (level = 1, x_points = x2_bar, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.0, ud_fraction = 1.0, & & text = string10a(1:bytes_wide)//' '//units(1:units_bytes)) ELSE string9a = ASCII9(high_value) string9a = ADJUSTL(string9a) bytes_wide = LEN_TRIM(string9a) CALL L12_Text (level = 1, x_points = x2_bar, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.0, ud_fraction = 1.0, & & text = string9a(1:bytes_wide)//' '//units(1:units_bytes)) END IF !label those contour levels which denominator tells you to include: DO i = i1, i2 IF (label_all) THEN label_this_one = .TRUE. ELSE label_this_one = (MOD(i, denominator) == 0) END IF IF (label_this_one) THEN v_line = i * c_i IF (v_line /= high_value) THEN x_line = x1_bar + scale * (v_line - low_value) ! add little ticks to identify labelled contour CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL New_L12_Path (1, x_line, y1_bar) CALL Line_to_L12 (x_line, y1_bar - 2.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) IF (need_ASCII10) THEN string10a = ASCII10(v_line) string10a = ADJUSTL(string10a) CALL L12_Text (level = 1, x_points = x_line, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(string10a)) ELSE string9a = ASCII9(v_line) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x_line, & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(string9a)) END IF END IF END IF ! label_this_one END DO CALL End_Group ! number labels CALL End_Group ! whole legend END SUBROUTINE Spectrum_in_BottomLegend SUBROUTINE Spectrum_in_RightLegend (low_value, high_value, units, & & bitmap_color_mode, bitmap_color_lowvalue, & & bitmap_color_highvalue, shaded_relief, & & contour_interval, midspectrum_value, low_is_blue) ! Places a color spectrum (using a bitmap) ! in the right legend area to identify the coloring ! of bitmap plots. ! Note that all spatial variables in this routine are in ! level-1 points. ! The units string can be cancelled (if not wanted) by setting ! units = ' ' ! (regardless of the declared length of units). ! Notice that the last 3 arguments are only needed if bitmap_color_mode == 4. IMPLICIT NONE INTEGER, INTENT(IN) :: bitmap_color_mode LOGICAL, INTENT(IN) :: shaded_relief REAL, INTENT(IN) :: bitmap_color_lowvalue, bitmap_color_highvalue, & & high_value, low_value CHARACTER*(*), INTENT(IN) :: units REAL, INTENT(IN), OPTIONAL :: contour_interval, midspectrum_value LOGICAL, INTENT(IN), OPTIONAL :: low_is_blue CHARACTER*3 :: c3 CHARACTER*9 :: string9a, string9b CHARACTER*10 :: string10 CHARACTER(LEN=3), DIMENSION(:,:), ALLOCATABLE :: bitmap INTEGER :: bytes_wide, denominator, i, irow, i1, i2, jcol, k, units_bytes LOGICAL :: label_all, need_ASCII10, label_this_one REAL, PARAMETER :: aspect = 0.5 ! typical character width/nominal height REAL :: bar_width, bar_length, brightness, c_i, & & fraction, limit1, limit2, limit3, scale, t, value, & & v_left, v_right, v_center, v_line, & & x_left, x_right, & & x1_bar, x2_bar, y_line, y1_bar, y2_bar, & & x1_frame, x2_frame, y1_frame, y2_frame units_bytes = LEN_TRIM(units) ! Decide reasonable contour interval (for tics & numbers only!) IF ((bitmap_color_mode == 4).AND.PRESENT(contour_interval).AND.(contour_interval /= 0.0)) THEN c_i = contour_interval ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO absolute elevation scale c_i = 1000. ELSE IF (high_value > low_value) THEN c_i = Round ((high_value - low_value) / 8.0) ELSE c_i = 1.0 END IF END IF END IF IF (.NOT.ai_rightlegend_reserved) THEN WRITE (*,"(' ERROR: No space reserved (in Begin_Page) for right legend.')") CALL Traceback END IF IF (low_value > high_value) THEN WRITE (*,"(' ERROR: low_value > high_value in Spectrum_in_RightLegend.')") CALL Traceback END IF ! check adequacy of space CALL Report_RightLegend_Frame (x1_frame, x2_frame, y1_frame, y2_frame) IF ((x2_frame - x1_frame) < (9. * ai_lonlatlabel_points * aspect + 2. + 7.)) THEN WRITE (*,"(' ERROR: ',F6.0,' < x < ',F6.0,' points is too tight for Bar_in_RightLegend.')") x1_frame, x2_frame CALL Traceback END IF IF ((y2_frame - y1_frame) < (6 * ai_lonlatlabel_points + 36)) THEN WRITE (*,"(' ERROR: ',F6.0,' < y < ',F6.0,' points is too tight for Bar_in_RightLegend.')") y1_frame, y2_frame CALL Traceback END IF ! decide length and y-placement of bar limit1 = 16. * 72. ! regardless of paper size limit2 = 28. * (high_value - low_value) / c_i ! 1 cm/step limit3 = (y2_frame - y1_frame) - 3 * ai_lonlatlabel_points bar_length = MIN(limit1, limit2, limit3) IF (bar_length == limit3) THEN y1_bar = 0.5 *(y1_frame + y2_frame) - 0.5 * bar_length ELSE ! center in frame y1_bar = 0.5 *(y1_frame + y2_frame) - 0.5 * bar_length END IF y2_bar = y1_bar + bar_length ! decide if all numbers can be written in IF (high_value /= low_value) THEN label_all = ai_lonlatlabel_points <= & & (bar_length * c_i / (high_value - low_value)) IF (label_all) THEN denominator = 1 ELSE denominator = Int_Above(ai_lonlatlabel_points / & &(bar_length * c_i / (high_value - low_value))) END IF ELSE label_all = .TRUE. denominator = 1 END IF ! decide width and x-placement of bar limit1 = 28. ! 1 centimeter limit2 = (x2_frame - x1_frame) - 9. * ai_lonlatlabel_points * aspect bar_width = MIN(limit1, limit2) x1_bar = x1_frame + 9. * ai_lonlatlabel_points * aspect x2_bar = x1_bar + bar_width ! Set vertical scaling (points / data units) scale = bar_length / MAX((high_value - low_value), 1.E-30) ! Find integer limits on countour lines: i1 = 1 + Int_Below ( low_value/ c_i) i2 = Int_Below (high_value / c_i) ! Decide whether 4 significant digits (ASCII10) are needed to keep values distinct: need_ASCII10 = .FALSE. ! unless it becomes .TRUE. in loop below: IF (i2 > i1) THEN DO i = i1+1, i2 string9a = ASCII9((i-1) * c_i) string9b = ASCII9( i * c_i) IF (string9a == string9b) need_ASCII10 = .TRUE. END DO END IF ! Graphics CALL Begin_Group ! whole legend !Bitmap can have fixed size because placement ! operator will stretch-to-fit: ALLOCATE ( bitmap(360, 37) ) DO jcol = 1, 37 DO irow = 1, 360 fraction = 1.00 - ((irow - 0.5) / 360.0) value = low_value + fraction * (high_value - low_value) t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) IF (shaded_relief) THEN brightness = 1.00 + (19 - jcol) / 18. ! range 0. - 2. ELSE IF (mt_shingled_brightness) THEN brightness = 0.8 + 0.8 * MOD(value, 1.0) ELSE brightness = 1.00 END IF IF (bitmap_color_mode <= 1) THEN ! Munsell: smooth spectrum c3 = RGB_Munsell(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 2) THEN ! Kansas: 44-color atlas-type scale c3 = RGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = RGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = RGB_AI(value = value, contour_interval = c_i, & & midspectrum_value = midspectrum_value, low_is_blue = low_is_blue, & & brightness = brightness) ELSE IF (bitmap_color_mode == 101) THEN ! continuous gray-scale; black_is_high t = (value - low_value) / (high_value - low_value) k = NINT(255. - (255. * t)) k = MAX(0,MIN(255,k)) c3 = CHAR(k)//CHAR(k)//CHAR(k) ELSE IF (bitmap_color_mode == 102) THEN ! continuous gray-scale; white is high t = (value - low_value) / (high_value - low_value) k = NINT(255. * t) k = MAX(0,MIN(255,k)) c3 = CHAR(k)//CHAR(k)//CHAR(k) END IF ! bitmap_color_mode selection bitmap(irow,jcol) = c3 END DO END DO CALL Bitmap_on_L1 (bitmap, x1_bar, x2_bar, & & y1_bar, y2_bar) DEALLOCATE ( bitmap ) ! line of background color for zero contour? IF (bitmap_color_mode == 0) THEN IF ((bitmap_color_lowvalue <= 0.0).AND.(bitmap_color_highvalue >= 0.0)) THEN y_line = y1_bar + (y2_bar - y1_bar) * (0.0 - bitmap_color_lowvalue) / & & (bitmap_color_highvalue - bitmap_color_lowvalue) CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('background') CALL New_L12_Path (1, x1_bar, y_line) CALL Line_to_L12 (x2_bar, y_line) CALL End_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF END IF ! box around color/pattern bar: CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL New_L12_Path (1, x1_bar, y1_bar) CALL Line_to_L12 (x2_bar, y1_bar) CALL Line_to_L12 (x2_bar, y2_bar) CALL Line_to_L12 (x1_bar, y2_bar) CALL Line_to_L12 (x1_bar, y1_bar) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) CALL Begin_Group ! number labels CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! always label low_value IF (need_ASCII10) THEN string10 = ASCII10(low_value) string10 = ADJUSTL(string10) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.7, & & text = TRIM(string10)) ELSE string9a = ASCII9(low_value) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y1_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.7, & & text = TRIM(string9a)) END IF ! always label high_value, adding units (2 points higher) IF (need_ASCII10) THEN string10 = ASCII10(high_value) string10 = ADJUSTL(string10) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y2_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.0, & & text = TRIM(string10)) ELSE string9a = ASCII9(high_value) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y2_bar, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.0, & & text = TRIM(string9a)) END IF CALL L12_Text (level = 1, x_points = x1_bar, & & y_points = y2_bar + 2., angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 0.0, ud_fraction = 0.0, & & text = units) !label those contour levels which denominator tells you to include: DO i = i1, i2 IF (label_all) THEN label_this_one = .TRUE. ELSE label_this_one = (MOD(i, denominator) == 0) END IF IF (label_this_one) THEN v_line = i * c_i IF (v_line /= high_value) THEN y_line = y1_bar + scale * (v_line - low_value) ! add little tics to identify labelled contour CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL New_L12_Path (1, x1_bar - 2., y_line) CALL Line_to_L12 (x1_bar, y_line) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) IF (need_ASCII10) THEN string10 = ASCII10(v_line) string10 = ADJUSTL(string10) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y_line, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.35, & & text = TRIM(string10)) ELSE string9a = ASCII9(v_line) string9a = ADJUSTL(string9a) CALL L12_Text (level = 1, x_points = x1_bar - 2., & & y_points = y_line, angle_radians = 0.0, & & font_points = NINT(ai_lonlatlabel_points), & & lr_fraction = 1.0, ud_fraction = 0.35, & & text = TRIM(string9a)) END IF END IF END IF ! label_this_one END DO CALL End_Group ! number labels CALL End_Group ! whole legend END SUBROUTINE Spectrum_in_RightLegend SUBROUTINE Strain_in_Plane (level, x, y, & & e11, e12, e22, & & ref_e3_minus_e1_SI, ref_diameter_points, & & mode012) ! Plots 2 conjugate-fault symbols at (x,y) for the state of: ! * anelastic/permanent strain [dimensionless], OR ! * anelastic/permanent strain-rate [per second]. ! Location coordinates (x,y) can be given on one of 3 levels: ! level = 1: draws anywhere on paper; (x,y) coordinates in points. ! level = 2: draws only in map window; (x,y) coordinates in points. ! level = 3: draws only in map window; (x,y) ccordinates in meters. ! A basic assumption is that one principal axis is vertical/radial, ! so no provision is made for plotting shear strains on ! horizontal surfaces. (One could call Vector_in_Plane for this.) ! Another assumption is incompressibility (because these are ! anelastic strains): ezz = -(e11 + e22) = -(e1h + e2h). ! The convention is that positive normal strain components indicate ! extension; negative normal strain components indicate compression. ! The 3 mutually perpendicular axes used to express the stress ! components are: ! 1 = x (horizontal; may be Eastward, but may not) ! 2 = y (horizontal, 90 degrees counterclockwise from x) ! 3 = z = up ! Notice that this is a right-handed system, as usual. ! Positive shear strain e12 elongates bodies in the +x/+y ! quadrant and shorten them in the +x/-y quadrant. ! Strike-slip faulting is shown by an "X" (2 conjugate faults). ! Normal faulting is shown by a narrow rectangle (a graben, ! flanked by conjugate normal faults). ! Thrust faulting is shown by a fault trace with triangular ! thrust-fault ticks on both sides (for conjugate thrusts). ! A general strain (-rate) requires superposing two symbols ! which are mutually perpendicular: ! thrust/thrust, thrust/strike-slip, strike-slip/normal, ! or normal/normal (but never thrust/normal!). ! If any of the 3 principal strain(-rate)s e11, e22, or e33 ! has a small absolute value, however, one of these symbols ! may not be large enough to notice. ! The scaling of the 2-symbol set is given by the parameters ! ref_e3_minus_e1_SI and ref_diameter_points. ! A strain (-rate?) of ref_e3_minus_e1_SI ! [ units are generically "SI" for either dimensionless or /sec ] ! is always plotted with a symbol of diameter ref_diameter_points. ! [ One point is 1/72 inch. ] ! The scaling of other strain (-rates) depends on "mode012": ! mode012 = 0 : All symbols are the same size (for legibility). ! mode012 = 1 : Symbol diameter is linearly proportional to strain. ! mode012 = 2 : Symbol area (diameter**2) is proportional to strain. IMPLICIT NONE INTEGER, INTENT(IN) :: level, mode012 REAL, INTENT(IN) :: e11, e12, e22, ref_diameter_points, & & ref_e3_minus_e1_SI, x, y INTEGER :: i LOGICAL :: e1h_partitioned, e2h_partitioned, ezz_partitioned REAL, PARAMETER :: friction = 0.85 ! used in strike-slip symbol REAL :: angle, big_diff, dx, dx1, dx2, dxp, dy, dy1, dy2, dyp, & & e1h, e2h, ezz, & & half_atan_fric_inv, meters_per_point, r, scale, & & u1x, u1y, u2x, u2y REAL, DIMENSION(5) :: xarray, yarray IF ((mode012 < 0).OR.(mode012 > 2)) THEN WRITE (*,"(' ERROR: Illegal mode012 = ',I2,' for Strain_in_Plane.')") mode012 CALL Traceback END IF IF ((ref_e3_minus_e1_SI == 0.).AND.(mode012 > 0)) THEN WRITE (*,"(' ERROR: ref_e3_minus_e1_SI = 0. in Strain_in_Plane.')") CALL Traceback END IF IF ((level < 1).OR.(level > 3)) THEN WRITE (*,"(' ERROR: Illegal level = ',I2,' for Strain_in_Plane.')") level CALL Traceback END IF IF (level == 3) meters_per_point = (3.527777E-4)*mp_scale_denominator half_atan_fric_inv = 0.5 * ATAN(1. / friction) ! Find principal strain(-rate)s in horizontal plane: CALL Principal_Axes_22 (e11, e12, e22, & & e1h, e2h, u1x,u1y, u2x,u2y) ! (Note that axis 1h is more compressive than axis 2h.) ! Quick exit if no strain: IF ((e1h == 0.).AND.(e2h == 0.)) RETURN ! Find vertical (principal) strain (-rate): ezz = -(e11 + e22) ! = -(e1h + e2h) ! Decide which principal strain(-rate) is partitioned: e1h_partitioned = (e1h /= 0.).AND.((e1h*e2h) <= 0.).AND.((e1h*ezz) <= 0.) e2h_partitioned = (e2h /= 0.).AND.((e2h*e1h) <= 0.).AND.((e2h*ezz) <= 0.) ezz_partitioned = (ezz /= 0.).AND.((ezz*e1h) <= 0.).AND.((ezz*e2h) <= 0.) ! Decide how big largest symbol is (in terms of partitioned e3-e1). big_diff = 0. IF (e1h*e2h < 0.) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(e2h)) ELSE big_diff = MAX(big_diff, 2.*ABS(e1h)) END IF END IF IF (e1h*ezz < 0.) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(ezz)) ELSE big_diff = MAX(big_diff, 2.*ABS(e1h)) END IF END IF IF (e2h*ezz < 0.) THEN IF (e2h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(ezz)) ELSE big_diff = MAX(big_diff, 2.*ABS(e2h)) END IF END IF !"angle" is measured from +x counterclockwise to e1h axis, in radians. angle = ATAN2(u1y,u1x) ! Determine scale (plot units/strain units) for 2-symbol set: SELECT CASE (mode012) CASE (0) scale = ref_diameter_points / big_diff CASE (1) scale = ref_diameter_points / ABS(ref_e3_minus_e1_SI) CASE (2) scale = ref_diameter_points * SQRT(big_diff/ABS(ref_e3_minus_e1_SI)) / big_diff END SELECT IF (level == 3) scale = scale * meters_per_point CALL Begin_Group ! of 2-symbol (4-fault) cluster IF ((e1h * e2h) < 0.) THEN ! STRIKE-SLIP FAULTS IF (e1h_partitioned) THEN r = scale * ABS(e2h) ELSE r = scale * ABS(e1h) END IF dx = r * COS(angle + half_atan_fric_inv) dy = r * SIN(angle + half_atan_fric_inv) IF (level == 3) THEN CALL New_L3_Path (x + dx, y + dy) CALL Line_to_L3 (x - dx, y - dy) CALL End_L3_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! level 1 or 2 CALL New_L12_Path (level, x + dx, y + dy) CALL Line_to_L12 (x - dx, y - dy) CALL End_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF dx = r * COS(angle - half_atan_fric_inv) dy = r * SIN(angle - half_atan_fric_inv) IF (level == 3) THEN CALL New_L3_Path (x + dx, y + dy) CALL Line_to_L3 (x - dx, y - dy) CALL End_L3_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! level 1 or 2 CALL New_L12_Path (level, x + dx, y + dy) CALL Line_to_L12 (x - dx, y - dy) CALL End_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ENDIF IF ((e1h < 0.).AND.(ezz > 0.)) THEN ! THRUST FAULTS PERP. TO e1h IF (e1h_partitioned) THEN r = scale * ABS(ezz) ELSE r = scale * ABS(e1h) END IF dx = r * COS(angle + 1.5708) dy = r * SIN(angle + 1.5708) dxp = 0.20 * r * COS(angle + 3.937) dyp = 0.20 * r * SIN(angle + 3.927) xarray(1) = x + dx xarray(2) = x + dx + dxp xarray(3) = x + dx + dxp - dyp xarray(4) = x + dx - dyp xarray(5) = x + dx yarray(1) = y + dy yarray(2) = y + dy + dyp yarray(3) = y + dy + dyp + dxp yarray(4) = y + dy + dxp yarray(5) = y + dy IF (level == 3) THEN CALL New_L3_Path(x + 0.86 * dx, y + 0.86 * dy) CALL Line_to_L3 (x - 0.86 * dx, y - 0.86 * dy) CALL End_L3_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL New_L3_Path(xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L3(xarray(i),yarray(i)) END DO CALL End_L3_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level, x + 0.86 * dx, y + 0.86 * dy) CALL Line_to_L12 (x - 0.86 * dx, y - 0.86 * dy) CALL End_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL New_L12_Path(level,xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L12(xarray(i),yarray(i)) END DO CALL End_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF xarray(1) =x - dx xarray(2) =x - dx - dxp xarray(3) =x - dx - dxp + dyp xarray(4) =x - dx + dyp xarray(5) =x - dx yarray(1) =y - dy yarray(2) =y - dy - dyp yarray(3) =y - dy - dyp - dxp yarray(4) =y - dy - dxp yarray(5) =y - dy IF (level == 3) THEN CALL New_L3_Path(xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L3(xarray(i),yarray(i)) END DO CALL End_L3_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level,xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L12(xarray(i),yarray(i)) END DO CALL End_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF END IF IF ((e2h < 0.).AND.(ezz > 0.)) THEN ! THRUST FAULTS PERP. TO e2h IF (ezz_partitioned) THEN r = scale * ABS(e2h) ELSE r = scale * ABS(ezz) END IF dx = r * COS(angle) dy = r * SIN(angle) dxp = 0.20 * r * COS(angle + 2.356) dyp = 0.20 * r * SIN(angle + 2.356) xarray(1) = x + dx xarray(2) = x + dx + dxp xarray(3) = x + dx + dxp - dyp xarray(4) = x + dx - dyp xarray(5) = x + dx yarray(1) = y + dy yarray(2) = y + dy + dyp yarray(3) = y + dy + dyp + dxp yarray(4) = y + dy + dxp yarray(5) = y + dy IF (level == 3) THEN CALL New_L3_Path(x + 0.86 * dx, y + 0.86 * dy) CALL Line_to_L3 (x - 0.86 * dx, y - 0.86 * dy) CALL End_L3_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL New_L3_Path(xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L3(xarray(i),yarray(i)) END DO CALL End_L3_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level, x + 0.86 * dx, y + 0.86 * dy) CALL Line_to_L12 (x - 0.86 * dx, y - 0.86 * dy) CALL End_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL New_L12_Path(level,xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L12(xarray(i),yarray(i)) END DO CALL End_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF xarray(1) =x - dx xarray(2) =x - dx - dxp xarray(3) =x - dx - dxp + dyp xarray(4) =x - dx + dyp xarray(5) =x - dx yarray(1) =y - dy yarray(2) =y - dy - dyp yarray(3) =y - dy - dyp - dxp yarray(4) =y - dy - dxp yarray(5) =y - dy IF (level == 3) THEN CALL New_L3_Path(xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L3(xarray(i),yarray(i)) END DO CALL End_L3_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level,xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L12(xarray(i),yarray(i)) END DO CALL End_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF END IF IF ((e1h > 0.).AND.(ezz < 0.)) THEN ! NORMAL FAULTS PERP. TO e1h IF (e1h_partitioned) THEN r = scale * ABS(ezz) ELSE r = scale * ABS(e1h) END IF dx1 = r * COS(angle + 1.7682) dy1 = r * SIN(angle + 1.7682) dx2 = r * COS(angle + 1.3734) dy2 = r * SIN(angle + 1.3734) xarray(1) = x + dx1 xarray(2) = x + dx2 xarray(3) = x - dx1 xarray(4) = x - dx2 xarray(5) = x + dx1 yarray(1) = y + dy1 yarray(2) = y + dy2 yarray(3) = y - dy1 yarray(4) = y - dy2 yarray(5) = y + dy1 IF (level == 3) THEN CALL New_L3_Path(xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L3(xarray(i),yarray(i)) END DO CALL End_L3_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level,xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L12(xarray(i),yarray(i)) END DO CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF END IF IF ((e2h > 0.).AND.(ezz < 0.)) THEN ! NORMAL FAULTS PERP. TO e2h IF (ezz_partitioned) THEN r = scale * ABS(e2h) ELSE r = scale * ABS(ezz) END IF dx1 = r * COS(angle + 0.1974) dy1 = r * SIN(angle + 0.1974) dx2 = r * COS(angle - 0.1974) dy2 = r * SIN(angle - 0.1974) xarray(1) = x + dx1 xarray(2) = x + dx2 xarray(3) = x - dx1 xarray(4) = x - dx2 xarray(5) = x + dx1 yarray(1) = y + dy1 yarray(2) = y + dy2 yarray(3) = y - dy1 yarray(4) = y - dy2 yarray(5) = y + dy1 IF (level == 3) THEN CALL New_L3_Path(xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L3(xarray(i),yarray(i)) END DO CALL End_L3_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) ELSE ! level = 1 or 2 CALL New_L12_Path(level,xarray(1),yarray(1)) DO i = 2, 5 CALL Line_to_L12(xarray(i),yarray(i)) END DO CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF END IF CALL End_Group ! of 2-symbol (4-fault) cluster END SUBROUTINE Strain_in_Plane SUBROUTINE Strain_on_Sphere (uvec, & & e11, e12, e22, & & ref_e3_minus_e1_SI, ref_diameter_points, & & mode012) ! Plots 2 conjugate-fault symbols at "uvec" for the state of: ! * anelastic/permanent strain [dimensionless], OR ! * anelastic/permanent strain-rate [per second]. ! Location is given as a Cartesian unit vector from center of sphere. ! A basic assumption is that one principal axis is vertical/radial, ! so no provision is made for plotting shear strains on ! horizontal surfaces. (One could call Vector_on_Sphere for this.) ! Another assumption is incompressibility (because these are ! anelastic strains): err = -(e11 + e22) = -(e1h + e2h). ! The convention is that positive normal strain components indicate ! extension; negative normal strain components indicate compression. ! The 3 mutually perpendicular axes used to express the stress ! components are: ! 1 = theta = locally horizontal and to South ! 2 = phi = locally horizontal and to East ! 3 = r = locally radial or vertical; up ! Notice that this is a right-handed system, as usual. ! Positive shear strain e12 elongates bodies in the SouthEast ! quadrant and shorten them in the NorthEast quadrant. ! Strike-slip faulting is shown by an "X" (2 conjugate faults). ! Normal faulting is shown by a narrow rectangle (a graben, ! flanked by conjugate normal faults). ! Thrust faulting is shown by a fault trace with triangular ! thrust-fault ticks on both sides (for conjugate thrusts). ! A general strain(-rate) requires superposing two symbols ! which are mutually perpendicular: ! thrust/thrust, thrust/strike-slip, strike-slip/normal, ! or normal/normal (but never thrust/normal!). ! If any of the 3 principal strain(-rate)s e11, e22, or e33 ! has a small absolute value, however, one of these symbols ! may not be large enough to notice. ! The scaling of the 2-symbol set is given by the parameters ! ref_e3_minus_e1_SI and ref_diameter_points. ! A strain(-rate) of ref_e3_minus_e1_SI ! [ units are generically "SI" for either dimensionless or /sec ] ! is always plotted with a symbol of diameter ref_diameter_points. ! [ One point is 1/72 inch. ] ! The scaling of other strain (-rates) depends on "mode012": ! mode012 = 0 : All symbols are the same size (for legibility). ! mode012 = 1 : Symbol diameter is linearly proportional to strain. ! mode012 = 2 : Symbol "area" (diameter**2) is proportional to strain. IMPLICIT NONE REAL, DIMENSION(3), INTENT(IN) :: uvec REAL, INTENT(IN) :: e11, e12, e22, ref_diameter_points, & & ref_e3_minus_e1_SI INTEGER, INTENT(IN) :: mode012 LOGICAL :: e1h_partitioned, e2h_partitioned, err_partitioned REAL, PARAMETER :: friction = 0.85 ! used in strike-slip symbol REAL :: angle, azimuth, big_diff, & & e1h, e2h, err, & & half_atan_fric_inv, r, radians_per_point, scale, & & u1theta, u1phi, u2theta, u2phi REAL, DIMENSION(3) :: omega_uvec, result_uvec, saved_uvec IF ((mode012 < 0).OR.(mode012 > 2)) THEN WRITE (*,"(' ERROR: Illegal mode012 = ',I2,' for Strain_on_Sphere.')") mode012 CALL Traceback END IF IF ((ref_e3_minus_e1_SI == 0.).AND.(mode012 > 0)) THEN WRITE (*,"(' ERROR: ref_e3_minus_e1_SI = 0. in Strain_on_Sphere.')") CALL Traceback END IF radians_per_point = (3.527777E-4)*(mp_scale_denominator*Conformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) half_atan_fric_inv = 0.5 * ATAN(1. / friction) ! Find principal strain(-rate)s in horizontal plane: CALL Principal_Axes_22 (e11, e12, e22, & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) ! (Note that axis 1h is more compressive than axis 2h.) ! Quick exit if no strain: IF ((e1h == 0.).AND.(e2h == 0.)) RETURN ! Find vertical (principal) strain (-rate): err = -(e11 + e22) ! = -(e1h + e2h) ! Decide which principal strain(-rate) is partitioned: e1h_partitioned = (e1h /= 0.).AND.((e1h*e2h) <= 0.).AND.((e1h*err) <= 0.) e2h_partitioned = (e2h /= 0.).AND.((e2h*e1h) <= 0.).AND.((e2h*err) <= 0.) err_partitioned = (err /= 0.).AND.((err*e1h) <= 0.).AND.((err*e2h) <= 0.) ! Decide how big largest symbol is (in terms of partitioned e3-e1). big_diff = 0. IF (e1h*e2h < 0.) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(e2h)) ELSE big_diff = MAX(big_diff, 2.*ABS(e1h)) END IF END IF IF (e1h*err < 0.) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(err)) ELSE big_diff = MAX(big_diff, 2.*ABS(e1h)) END IF END IF IF (e2h*err < 0.) THEN IF (e2h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(err)) ELSE big_diff = MAX(big_diff, 2.*ABS(e2h)) END IF END IF !"angle" is measured from +theta (South) counterclockwise to e1h axis, in radians. angle = ATAN2(u1phi, u1theta) ! Determine scale (radians/strain units) for 2-symbol set: SELECT CASE (mode012) CASE (0) scale = radians_per_point * ref_diameter_points / big_diff CASE (1) scale = radians_per_point * ref_diameter_points / ABS(ref_e3_minus_e1_SI) CASE (2) scale = radians_per_point * ref_diameter_points * SQRT(big_diff/ABS(ref_e3_minus_e1_SI)) / big_diff END SELECT CALL Begin_Group ! of 2-symbol (4-fault) cluster IF ((e1h * e2h) < 0.) THEN ! STRIKE-SLIP FAULTS IF (e1h_partitioned) THEN r = scale * ABS(e2h) ELSE r = scale * ABS(e1h) END IF azimuth = Pi - angle + half_atan_fric_inv CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) CALL New_L45_Path (5, result_uvec) azimuth = - angle + half_atan_fric_inv CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) CALL End_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) azimuth = Pi - angle - half_atan_fric_inv CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) CALL New_L45_Path (5, result_uvec) azimuth = - angle - half_atan_fric_inv CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) CALL End_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF IF ((e1h < 0.).AND.(err > 0.)) THEN ! THRUST FAULTS PERP. TO e1h IF (e1h_partitioned) THEN r = scale * ABS(err) ELSE r = scale * ABS(e1h) END IF ! crossbar only 86% of r (to center of diamonds): azimuth = Pi_over_2 - angle CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL New_L45_Path (5, result_uvec) azimuth = -Pi_over_2 - angle CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) CALL End_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! 1st diamond; each side 20% * r azimuth = Pi_over_2 - angle CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) saved_uvec = result_uvec CALL New_L45_Path (5, result_uvec) azimuth = Pi_over_2 - angle - 0.1614 CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = Pi_over_2 - angle CALL Turn_To (azimuth, uvec, 0.72 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = Pi_over_2 - angle + 0.1614 CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) CALL Great_to_L45 (saved_uvec) CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ! 2nd diamond; each side 20% * r ! (same code as above, except leading - on Pi_over_2) azimuth = -Pi_over_2 - angle CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) saved_uvec = result_uvec CALL New_L45_Path (5, result_uvec) azimuth = -Pi_over_2 - angle - 0.1614 CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = -Pi_over_2 - angle CALL Turn_To (azimuth, uvec, 0.72 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = -Pi_over_2 - angle + 0.1614 CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) CALL Great_to_L45 (saved_uvec) CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF IF ((e2h < 0.).AND.(err > 0.)) THEN ! THRUST FAULTS PERP. TO e2h IF (err_partitioned) THEN r = scale * ABS(e2h) ELSE r = scale * ABS(err) END IF !(following code copied from above, but Pi_over_2 was added to all azimuths) ! crossbar only 86% of r (to center of diamonds): azimuth = Pi - angle CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL New_L45_Path (5, result_uvec) azimuth = - angle CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) CALL End_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! 1st diamond; each side 20% * r azimuth = Pi - angle CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) saved_uvec = result_uvec CALL New_L45_Path (5, result_uvec) azimuth = Pi - angle - 0.1614 CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = Pi - angle CALL Turn_To (azimuth, uvec, 0.72 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = Pi - angle + 0.1614 CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) CALL Great_to_L45 (saved_uvec) CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ! 2nd diamond; each side 20% * r azimuth = - angle CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) saved_uvec = result_uvec CALL New_L45_Path (5, result_uvec) azimuth = - angle - 0.1614 CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = - angle CALL Turn_To (azimuth, uvec, 0.72 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = - angle + 0.1614 CALL Turn_To (azimuth, uvec, 0.86 * r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) CALL Great_to_L45 (saved_uvec) CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF IF ((e1h > 0.).AND.(err < 0.)) THEN ! NORMAL FAULTS PERP. TO e1h IF (e1h_partitioned) THEN r = scale * ABS(err) ELSE r = scale * ABS(e1h) END IF azimuth = Pi_over_2 - angle - 0.1974 CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) saved_uvec = result_uvec CALL New_L45_Path (5, result_uvec) azimuth = -Pi_over_2 - angle + 0.1974 CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = -Pi_over_2 - angle - 0.1974 CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = Pi_over_2 - angle + 0.1974 CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) CALL Great_to_L45 (saved_uvec) CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF IF ((e2h > 0.).AND.(err < 0.)) THEN ! NORMAL FAULTS PERP. TO e2h IF (err_partitioned) THEN r = scale * ABS(e2h) ELSE r = scale * ABS(err) END IF !(following code copied from above, but Pi_over_2 added to azimuths.) azimuth = Pi - angle - 0.1974 CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) saved_uvec = result_uvec CALL New_L45_Path (5, result_uvec) azimuth = - angle + 0.1974 CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = - angle - 0.1974 CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) azimuth = Pi - angle + 0.1974 CALL Turn_To (azimuth, uvec, r, & ! inputs & omega_uvec, result_uvec) CALL Great_to_L45 (result_uvec) CALL Great_to_L45 (saved_uvec) CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF CALL End_Group ! of 2-symbol (4-fault) cluster END SUBROUTINE Strain_on_Sphere SUBROUTINE Stress_in_Plane (level, x, y, s11, s12, s22, s33, & & ref_pressure_SI, ref_diameter_points) ! Plots a single 3-axis symbol at (x,y) for the state of: ! * stress [in Pa], OR ! * stress anomaly [(stress + reference pressure), in Pa], OR ! * vertical integral of stress anomaly [in N/m; most useful ! when integrated through the crust or the lithosphere]. ! Location coordinates (x,y) can be given on one of 3 levels: ! level = 1: draws anywhere on paper; (x,y) coordinates in points. ! level = 2: draws only in map window; (x,y) coordinates in points. ! level = 3: draws only in map window; (x,y) ccordinates in meters. ! A basic assumption is that one principal axis is vertical/radial, ! so no provision is made for plotting shear tractions on ! horizontal surfaces. (One could call Vector_in_Plane for this.) ! The convention is that positive normal stress components indicate ! (relative) tension, and are shown by diverging arrows. ! Negative normal stress components indicate (relative) compression ! and are shown with converging arrows. ! Negative or (relatively) compressive vertical stress is shown ! by circles. ! Positive or (relatively) tensile vertical stress is shown by ! by equilateral triangles; the radius from the center of the triangle ! to any vertex is comparable to the radius of the circle used for ! negative vertical stresses. ! The 3 mutually perpendicular axes used to express the stress ! components are: ! 1 = x (horizontal; may be Eastward, but may not) ! 2 = y (horizontal, 90 degrees counterclockwise from x) ! 3 = z = up ! Notice that this is a right-handed system, as usual. ! Positive shear stress s12 tends to elongate bodies in the +x/+y ! quadrant and shorten them in the +x/-y quadrant. ! The scaling of the symbols is given by the parameters ! ref_pressure_SI and ref_diameter_points. ! An (integrated?) isotropic pressure (anomaly?) of ref_pressure_SI ! [ units are generically "SI" for either Pa or N/m ] ! is always plotted with a symbol of diameter ref_diameter_points. ! [ One point is 1/72 inch. ] IMPLICIT NONE INTEGER, INTENT(IN) :: level REAL, INTENT(IN) :: s11, s12, s22, s33, ref_pressure_SI, ref_diameter_points, x, y REAL :: from_x, from_y, meters_per_point, radius, s1, s2, to_x, to_y, u1x, u1y, u2x, u2y IF ((level < 1).OR.(level > 3)) THEN WRITE (*,"(' ERROR: Illegal level = ',I2,' for Stress_in_Plane.')") level CALL Traceback END IF IF (level == 3) meters_per_point = (3.527777E-4)*mp_scale_denominator CALL Begin_Group ! Vertical stress IF (s33 < 0.) THEN ! circle for compression radius = (0.5*ref_diameter_points)*(-s33/ABS(ref_pressure_Si)) IF (level == 3) THEN radius = radius * meters_per_point CALL Circle_on_L3 (x,y,radius,.TRUE.,.FALSE.) ELSE ! level 1 or 2 CALL Circle_on_L12 (level,x,y,radius,.TRUE.,.FALSE.) END IF ! level 3, or less ELSE IF (s33 > 0.) THEN ! equilateral triangle for tension radius = (0.5*ref_diameter_points)*(s33/ABS(ref_pressure_Si)) IF (level == 3) THEN radius = radius * meters_per_point CALL New_L3_Path (x, y + radius) CALL Line_to_L3 (x - 0.8660 * radius, y - 0.5 * radius) CALL Line_to_L3 (x + 0.8660 * radius, y - 0.5 * radius) CALL Line_to_L3 (x, y + radius) CALL End_L3_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) ELSE ! level 1 or 2 CALL New_L12_Path (level, x, y + radius) CALL Line_to_L12 (x - 0.8660 * radius, y - 0.5 * radius) CALL Line_to_L12 (x + 0.8660 * radius, y - 0.5 * radius) CALL Line_to_L12 (x, y + radius) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF ! level 3, or less END IF ! circle or triangle for vertical stress ! Find principal stresses in horizontal plane: CALL Principal_Axes_22 (s11, s12, s22, & & s1, s2, u1x,u1y, u2x,u2y) ! Plot sigma1h axis radius = (0.5*ref_diameter_points)*(ABS(s1)/ABS(ref_pressure_Si)) IF (level == 3) radius = radius * meters_per_point IF (s1 < 0.) THEN ! compression: converging arrows from_x = x + radius * u1x from_y = y + radius * u1y CALL Vector_in_Plane (level, from_x, from_y, x, y) from_x = x - (from_x - x) from_y = y - (from_y - y) CALL Vector_in_Plane (level, from_x, from_y, x, y) ELSE IF (s1 > 0.) THEN ! extension; diverging arrows to_x = x + radius * u1x to_y = y + radius * u1y CALL Vector_in_Plane (level, x, y, to_x, to_y) to_x = x - (to_x - x) to_y = y - (to_y - y) CALL Vector_in_Plane (level, x, y, to_x, to_y) END IF ! Plot sigma2h axis radius = (0.5*ref_diameter_points)*(ABS(s2)/ABS(ref_pressure_Si)) IF (level == 3) radius = radius * meters_per_point IF (s2 < 0.) THEN ! compression: converging arrows from_x = x + radius * u2x from_y = y + radius * u2y CALL Vector_in_Plane (level, from_x, from_y, x, y) from_x = x - (from_x - x) from_y = y - (from_y - y) CALL Vector_in_Plane (level, from_x, from_y, x, y) ELSE IF (s2 > 0.) THEN ! extension; diverging arrows to_x = x + radius * u2x to_y = y + radius * u2y CALL Vector_in_Plane (level, x, y, to_x, to_y) to_x = x - (to_x - x) to_y = y - (to_y - y) CALL Vector_in_Plane (level, x, y, to_x, to_y) END IF CALL End_Group END SUBROUTINE Stress_in_Plane SUBROUTINE Stress_on_Sphere (uvec, azimuth, s1, s2, s33, & & ref_pressure_SI, ref_diameter_points) ! Plots a single 3-axis symbol at "uvec" for the state of: ! * stress [in Pa], OR ! * stress anomaly [(stress + reference pressure), in Pa], OR ! * vertical integral of stress anomaly [in N/m; most useful ! when integrated through the crust or the lithosphere]. ! A basic assumption is that one principal axis is vertical/radial, ! so no provision is made for plotting shear tractions on ! horizontal surfaces. (One could call Vector_on_Sphere for this.) ! The convention is that positive normal stress components indicate ! (relative) tension, and are shown by diverging arrows. ! Negative normal stress components indicate (relative) compression ! and are shown with converging arrows. ! Negative or (relatively) compressive vertical stress is shown ! by circles. ! Positive or (relatively) tensile vertical stress is shown by ! by equilateral triangles; the radius from the center of the triangle ! to any vertex is comparable to the radius of the circle used for ! negative vertical stresses. !"Azimuth" is in radians, clockwise from North to either end ! of the most-compressive horizontal principal stress (s1) axis. !"S1" is the more compressive (more negative) horizontal principal stress. !"S2" is the more tensile (more positive) horizontal principal stress. !"S33" is the vertical principal stress. ! The scaling of the symbols is given by the parameters ! ref_pressure_SI and ref_diameter_points. ! An (integrated?) isotropic pressure (anomaly?) of ref_pressure_SI ! [ units are generically "SI" for either Pa or N/m ] ! is always plotted with a symbol of diameter ref_diameter_points. ! [ One point is 1/72 inch. ] IMPLICIT NONE REAL, INTENT(IN) :: azimuth, s1, s2, s33, ref_pressure_SI, ref_diameter_points REAL, DIMENSION(3), INTENT(IN) :: uvec REAL :: big_r, radians_per_point, other_azimuth, radius, test_point_size, u1x, u1y, u2x, u2y REAL, DIMENSION(3) :: omega_uvec, result_uvec, save_uvec radians_per_point = (3.527777E-4)*(mp_scale_denominator*Conformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) CALL Begin_Group ! Vertical stress IF (s33 < 0.) THEN ! circle for compression test_point_size = (0.5*ref_diameter_points)*(-s33/ABS(ref_pressure_Si)) radius = (0.5*ref_diameter_points)*radians_per_point*(-s33/ABS(ref_pressure_Si)) big_r = radius IF (test_point_size > 1.) THEN ! prevent (numerical) singularities involving tiny small circle CALL Turn_To (azimuth_radians = 0., base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL New_L45_Path (5, result_uvec) CALL Small_to_L45 (uvec, result_uvec) ! complete small circle CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF ELSE IF (s33 > 0.) THEN ! equilateral triangle for tension test_point_size = (0.5*ref_diameter_points)*(s33/ABS(ref_pressure_Si)) radius = (0.5*ref_diameter_points)*radians_per_point*(s33/ABS(ref_pressure_Si)) big_r = radius IF (test_point_size > 1.) THEN ! prevent (numerical) singularities involving tiny triangle CALL Turn_To (azimuth_radians = 0., base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = save_uvec) CALL New_L45_Path (5, save_uvec) CALL Turn_To (azimuth_radians = 4.18879, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL Great_To_L45 (result_uvec) CALL Turn_To (azimuth_radians = 2.09440, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL Great_To_L45 (result_uvec) CALL Great_To_L45 (save_uvec) CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF END IF ! Plot sigma1h axis radius = (0.5*ref_diameter_points)*radians_per_point*(ABS(s1)/ABS(ref_pressure_Si)) big_r = MAX (big_r, radius) CALL Turn_To (azimuth_radians = azimuth, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = save_uvec) CALL Turn_To (azimuth_radians = azimuth, base_uvec = uvec, & & far_radians = -radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) IF (s1 < 0.) THEN ! compression: converging arrows CALL Vector_on_Sphere (save_uvec, uvec, 1) CALL Vector_on_Sphere (result_uvec, uvec, 1) ELSE IF (s1 > 0.) THEN ! extension; diverging arrows CALL Vector_on_Sphere (uvec, save_uvec, 1) CALL Vector_on_Sphere (uvec, result_uvec, 1) END IF ! Plot sigma2h axis other_azimuth = azimuth + Pi_over_2 radius = (0.5*ref_diameter_points)*radians_per_point*(ABS(s2)/ABS(ref_pressure_Si)) big_r = MAX (big_r, radius) CALL Turn_To (azimuth_radians = other_azimuth, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = save_uvec) CALL Turn_To (azimuth_radians = other_azimuth, base_uvec = uvec, & & far_radians = -radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) IF (s2 < 0.) THEN ! compression: converging arrows CALL Vector_on_Sphere (save_uvec, uvec, 1) CALL Vector_on_Sphere (result_uvec, uvec, 1) ELSE IF (s2 > 0.) THEN ! extension; diverging arrows CALL Vector_on_Sphere (uvec, save_uvec, 1) CALL Vector_on_Sphere (uvec, result_uvec, 1) END IF IF (big_r > 1.) THEN WRITE (*,"(' ERROR: Stress_on_Sphere symbol size is ',1P,E10.2,' radians.')") big_r CALL Traceback END IF CALL End_Group END SUBROUTINE Stress_on_Sphere SUBROUTINE Thin_on_Sphere (uvec_list, full_count, thinner, selected) ! Applies thinning factor "thinner" to a set of "full_count" ! locations in "uvec_list", and chooses an equally-spaced subset ! for which it marks "selected" as TRUE, others FALSE. IMPLICIT NONE REAL, DIMENSION(:,:), INTENT(IN) :: uvec_list INTEGER, INTENT(IN) :: full_count, thinner LOGICAL, DIMENSION(:),INTENT(OUT):: selected INTEGER :: done, goal, i, j REAL :: high, newr2 REAL, DIMENSION(:), ALLOCATABLE :: r2min ! verify input data IF (full_count <= 1) RETURN IF (thinner < 1) THEN WRITE(*,"(' Error: thinner must be a positive integer.')") CALL Traceback() END IF IF (thinner == 1) THEN selected = .TRUE. ! whole array RETURN END IF ! initialize; first point is always selected selected = .FALSE. ! whole array goal = NINT((1.0*full_count) / thinner) selected(1) = .TRUE. ALLOCATE ( r2min(full_count) ) r2min(1) = 0.0 DO i = 2, full_count r2min(i) = (uvec_list(1,i) - uvec_list(1,1))**2 + & & (uvec_list(2,i) - uvec_list(2,1))**2 + & & (uvec_list(3,i) - uvec_list(3,1))**2 END DO ! initializing r2min done = 1 ! main loop to select points #2...goal DO WHILE (done < goal) ! find highest r2min high = 0. j = 1 DO i = 1, full_count IF (r2min(i) >= high) THEN high = r2min(i) j = i END IF END DO ! i = 1, full_count ! mark this as another selected point selected(j) = .TRUE. done = done + 1 ! revise r2min array DO i = 1, full_count IF (r2min(i) > 0.) THEN ! might need reduction newr2 = (uvec_list(1,i) - uvec_list(1,j))**2 + & & (uvec_list(2,i) - uvec_list(2,j))**2 + & & (uvec_list(3,i) - uvec_list(3,j))**2 r2min(i) = MIN(r2min(i), newr2) END IF ! consider possible reduction END DO ! I = 1, full_count END DO ! while done < goal DEALLOCATE ( r2min ) END SUBROUTINE Thin_on_Sphere SUBROUTINE ThreeNodeCurve_Point (xa,ya, xb,yb, xc,yc, s, & ! inputs & xs,ys, angle) ! outputs ! In the plane, much use is made of curved lines defined by 3 nodes: ! a---------b---------c [curvature cannot be shown here], ! or equivalently, defined by the Cartesian (x,y) coordinates of each: ! (xa,ya)---(xb,yb)---(xc,yc) [curvature cannot be shown here]. ! For example, the trace of a 6-node fault element is such a curve, ! and so is any one side of a 6-node isoparametric triangle element. ! Points along this curve have internal coordinate s = ! 0.0-------0.5-------1.00 ! This routine returns internal point (xs,ys) for any s. ! It also returns the "angle" = ATAN2(dy/ds, dx/ds), which ! is the angle (counterclockwise from +x, in radians) ! of the tangent along the curve, in the +s direction. IMPLICIT NONE REAL, INTENT(IN) :: xa,ya, xb,yb, xc,yc, s REAL, INTENT(OUT) :: angle, xs,ys REAL :: cx1, cx2, cy1, cy2, dx_ds, dy_ds cx1 = -3. * xa + 4. * xb - xc cy1 = -3. * ya + 4. * yb - yc cx2 = 2. * xa - 4. * xb + 2. * xc cy2 = 2. * ya - 4. * yb + 2. * yc xs = xa + s * cx1 + s**2 * cx2 ys = ya + s * cy1 + s**2 * cy2 dx_ds = cx1 + 2. * s * cx2 dy_ds = cy1 + 2. * s * cy2 angle = Atan2f(dy_ds, dx_ds) END SUBROUTINE ThreeNodeCurve_Point SUBROUTINE ThreeNodeCurve_2_Bezier (xa,ya, xb,yb, xc,yc, & ! input & x0,y0, x1,y1, x2,y2, x3,y3) ! output ! In the plane, much use is made of curved lines defined by 3 nodes: ! a---------b---------c [curvature cannot be shown here], ! or equivalently, defined by the Cartesian (x,y) coordinates of each: ! (xa,ya)---(xb,yb)---(xc,yc) [curvature cannot be shown here]. ! For example, the trace of a 6-node fault element is such a curve, ! and so is any one side of a 6-node isoparametric triangle element. ! This routine converts the coordinates to Bezier control points, ! which might be used as follows: ! CALL New_L3_Path (x0,y0) ! CALL Curve_to_L3 (x1,y1, x2,y2, y3,y3) ! CALL End_L3_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) IMPLICIT NONE REAL, INTENT(IN) :: xa,ya, xb,yb, xc,yc REAL, INTENT(OUT) :: x0,y0, x1,y1, x2,y2, x3,y3 x0 = xa y0 = ya x1 = (4.*xb - xc)/3. y1 = (4.*yb - yc)/3. x2 = (4.*xb - xa)/3. y2 = (4.*yb - ya)/3. x3 = xc y3 = yc END SUBROUTINE ThreeNodeCurve_2_Bezier SUBROUTINE Top_Titles (top_line, & & bottom_line) ! Adds two lines of title text to the map. ! If only one line is wanted, set bottom_line to all-blank ! (which you can do with assignment to one blank: ! bottom_line = ' ' ! regardless of the declared length of bottom_line). ! If an error message is generated, check that ! plan_toptitles = .TRUE. in most recent CALL Begin_Page. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: top_line, bottom_line INTEGER :: top_line_bytes, bottom_line_bytes top_line_bytes = LEN_TRIM(top_line) bottom_line_bytes = LEN_TRIM(bottom_line) IF (.NOT.ai_toptitles_reserved) THEN WRITE (*,"(' ERROR: No space reserved (in Begin_Page) for top titles.')") CALL Traceback END IF IF (top_line_bytes > 0) THEN CALL L12_Text (level = 1, & & x_points = ai_window_xc_points, & & y_points = ai_top_limit_points - 0.5 * ai_toptitles_points, & & angle_radians = 0.0, & & font_points = NINT(0.5 * ai_toptitles_points), & & lr_fraction = 0.5, & & ud_fraction = -0.4, & & text = top_line) END IF IF (bottom_line_bytes > 0) THEN CALL L12_Text (level = 1, & & x_points = ai_window_xc_points, & & y_points = ai_top_limit_points - ai_toptitles_points, & & angle_radians = 0.0, & & font_points = NINT(0.5 * ai_toptitles_points), & & lr_fraction = 0.5, & & ud_fraction = -0.4, & & text = bottom_line) END IF END SUBROUTINE Top_Titles SUBROUTINE Vector_in_Plane (level, from_x,from_y, to_x,to_y) ! draws simple vector (from_x,from_y)----->(to_x,to_y). ! Level = 1: draws anywhere on paper; coordinates in points. ! Level = 2: draws only in map window; coordinates in points. ! Level = 3: draws only in map window; ccordinates in meters. IMPLICIT NONE INTEGER, INTENT(IN) :: level REAL, INTENT(IN) :: from_x, from_y, to_x, to_y REAL, PARAMETER :: headlength = 0.1666667, headhalfwidth = 0.0666667 REAL :: dx, dy, leftx, lefty, rightx, righty IF ((level < 1).OR.(level > 3)) THEN WRITE (*,"(' ERROR: Illegal level = ',I2,' for Vector_in_Plane.')") level CALL Traceback END IF CALL Begin_Group ! shaft of arrow IF (level == 3) THEN CALL New_L3_Path (from_x,from_y) CALL Line_to_L3 (to_x,to_y) CALL End_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! level 1 or 2 CALL New_L12_Path (level, from_x,from_y) CALL Line_to_L12 (to_x,to_y) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! arrowhead: dx = to_x - from_x dy = to_y - from_y leftx = to_x - headlength * dx - headhalfwidth * dy lefty = to_y - headlength * dy + headhalfwidth * dx rightx = to_x - headlength * dx + headhalfwidth * dy righty = to_y - headlength * dy - headhalfwidth * dx IF (level == 3) THEN CALL New_L3_Path (leftx,lefty) CALL Line_to_L3 (to_x,to_y) CALL Line_to_L3 (rightx,righty) CALL End_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! level 1 or 2 CALL New_L12_Path (level, leftx,lefty) CALL Line_to_L12 (to_x,to_y) CALL Line_to_L12 (rightx,righty) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF CALL End_Group END SUBROUTINE Vector_in_Plane SUBROUTINE Vector_on_Sphere (from_uvec, to_uvec, kind) ! Draws curved vector (from_uvec)----->(to_uvec), ! where a uvec is a position in the form of a Cartesian unit vector. ! Kind = 1: draws minor arc of great circle ("the short way"). ! Kind = 2: draws major arc of great circle ("the long way"). ! Kind = 3: draws great circle plus minor arc ("around + short"). ! Kind = 4: draws great circle plus major arc ("around + long"). ! (Note that kind = 3 and kind = 4 have arrowheads pointing ! in opposite senses along the same complete great circle.) ! In the cases of kind = 3 or 4, a cross-bar "tail" is added to ! show where the vector started. IMPLICIT NONE INTEGER, INTENT(IN) :: kind REAL, DIMENSION(3), INTENT(IN) :: from_uvec, to_uvec REAL, PARAMETER :: headlength = 0.1795, headhalfangle = 0.3805, & & limit = 3.14159, tailhalflength = 0.0666667 REAL :: azimuth, path_radians, turn_radians REAL, DIMENSION(3) :: left_uvec, omega_uvec, pole_uvec, right_uvec, t_vec IF ((kind < 1).OR.(kind > 4)) THEN WRITE (*,"(' ERROR: Illegal kind = ',I2,' for Vector_on_Sphere.')") kind CALL Traceback END IF IF (from_uvec(1) == to_uvec(1)) THEN IF (from_uvec(2) == to_uvec(2)) THEN IF (from_uvec(3) == to_uvec(3)) THEN IF (kind == 1) THEN RETURN ! zero-length arc; no action needed ELSE WRITE (*,"(' ERROR: Great circle from point to itself is nonunique.')") CALL Traceback END IF END IF END IF END IF CALL Begin_Group ! shaft of arrow CALL New_L45_Path (5, from_uvec) SELECT CASE (kind) CASE (1) CALL Great_to_L45 (to_uvec) path_radians = Arc (from_uvec, to_uvec) CASE (2) CALL Cross (to_uvec, from_uvec, t_vec) CALL Make_Uvec (t_vec, pole_uvec) CALL Small_To_L45 (pole_uvec, to_uvec) path_radians = 2.*Pi - Arc (from_uvec, to_uvec) CASE (3) CALL Cross (from_uvec, to_uvec, t_vec) CALL Make_Uvec (t_vec, pole_uvec) CALL Small_To_L45 (pole_uvec, from_uvec) CALL Small_To_L45 (pole_uvec, to_uvec) path_radians = 2.*Pi + Arc (from_uvec, to_uvec) CASE (4) CALL Cross (to_uvec, from_uvec, t_vec) CALL Make_Uvec (t_vec, pole_uvec) CALL Small_To_L45 (pole_uvec, from_uvec) CALL Small_To_L45 (pole_uvec, to_uvec) path_radians = 4.*Pi - Arc (from_uvec, to_uvec) END SELECT CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! arrowhead: size increases in proportion to path_radians up to limit: turn_radians = headlength * MIN(path_radians, limit) IF (MOD(kind,2) == 1) THEN ! using minor arcs azimuth = Relative_Compass (to_uvec, from_uvec) + headhalfangle ELSE ! using major arcs azimuth = Relative_Compass (to_uvec, from_uvec) + Pi + headhalfangle END IF CALL Turn_To (azimuth_radians = azimuth, & & base_uvec = to_uvec, & & far_radians = turn_radians, & ! inputs & omega_uvec = omega_uvec, & & result_uvec = left_uvec) azimuth = azimuth - 2. * headhalfangle CALL Turn_To (azimuth_radians = azimuth, & & base_uvec = to_uvec, & & far_radians = turn_radians, & ! inputs & omega_uvec = omega_uvec, & & result_uvec = right_uvec) CALL New_L45_Path (5, left_uvec) CALL Great_To_L45 (to_uvec) CALL Great_To_L45 (right_uvec) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! tail of arrow, if needed IF (kind >= 3) THEN t_vec = from_uvec + tailhalflength * MIN(path_radians, limit) * pole_uvec CALL Make_Uvec (t_vec, left_uvec) t_vec = from_uvec - tailhalflength * MIN(path_radians, limit) * pole_uvec CALL Make_Uvec (t_vec, right_uvec) CALL New_L45_Path (5, left_uvec) CALL Great_To_L45 (right_uvec) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF CALL End_Group END SUBROUTINE Vector_on_Sphere SUBROUTINE Velocity_Size_in_3Node_Sphere(l_, uvec1, uvec2, uvec3, & ! element input & v1t,v1p, v2t,v2p, v3t,v3p, & ! nodal velocities & r_, & ! position input & vsize, d_vsize_d_South, d_vsize_d_East) ! outputs ! GIVEN a 3-node spherical-triangle finite element defined by nodes ! at uvec1, uvec2, and uvec3 (counterclockwise!), with nodal velocities ! (v1t,v1p) = (v1theta,v1phi) = (v1South,v1East) at node 1, ! (v2t,v2p) = (v2theta,v2phi) = (v2South,v2East) at node 2, ! (v3t,v3p) = (v3theta,v3phi) = (v3South,v3East) at node 3, ! and a position (unit) vector r_ (which should be in the triangle), ! RETURNS the scalar magnitude (length) of the velocity vector ! 'vsize' and its South-ward and East-ward derivitives: ! 'd_vsize_d_South' and 'd_vsize_d_East'; ! these derivitives are per radian of great-circle arc distance. ! Note that d_vsize_d_South = d_vsize_d_theta, but ! d_vsize_d_East = d_vsize_d_phi / SIN(theta); that is, ! it has been corrected for the changing length of a radian ! of phi at different latitudes. Thus, d_vsize_d_South and ! d_vsize_d_East together form a horizontal gradient vector. ! Element identifying number 'l_' is used by Gjxy and by ! Del_Gjxy_del_thetaphi to decide whether the call concerns ! the same element as the last call, in which case initialization ! work can be skipped. Thus, l_ must change whenever ! uvec1, uvec2, or uvec3 changes. However, it need not ! change just because one or more velocity components change(s). IMPLICIT NONE INTEGER, INTENT(IN) :: l_ REAL, DIMENSION(3), INTENT(IN) :: uvec1, uvec2, uvec3, r_ REAL, INTENT(IN) :: v1t,v1p, v2t,v2p, v3t,v3p REAL, INTENT(OUT) :: vsize, d_vsize_d_South, d_vsize_d_East DOUBLE PRECISION, DIMENSION (3,2,2) :: G !The following 3 lines explain the subscripts of G: !INTEGER :: j ! 1:3 = local node numbering in element l_ !INTEGER :: x ! 1:2 = node j has unit velocity to South(1) or East(2) !INTEGER :: y ! 1:2 = South(1) or East(2) component of vector nodal function DOUBLE PRECISION, DIMENSION (3,2,2,2) :: dG !The following 4 lines explain the subscripts of dG: !INTEGER :: j ! 1:3 = local node numbering in element l_ !INTEGER :: x ! 1:2 = node j has unit velocity to South(1) or East(2)? !INTEGER :: y ! 1:2 = South(1) or East(2) component of vector nodal function? !INTEGER :: m ! 1:2 = theta (S-ward) or phi (E-ward) derivitive? REAL :: d_vrt_d_t, d_vrt_d_p, d_vrp_d_t, d_vrp_d_p, & & d_vsize_d_phi, d_vsize_d_theta, equat, vrt, vrp, vr2 CALL Gjxy (l_, uvec1, uvec2, uvec3, r_, G) ! computes G matrix vrt = v1t * G(1,1,1) + v1p * G(1,2,1) + & & v2t * G(2,1,1) + v2p * G(2,2,1) + & & v3t * G(3,1,1) + v3p * G(3,2,1) vrp = v1t * G(1,1,2) + v1p * G(1,2,2) + & & v2t * G(2,1,2) + v2p * G(2,2,2) + & & v3t * G(3,1,2) + v3p * G(3,2,2) !---- Begin kludge. While this routine should return the ! corner node velocity when the position r_ is a corner node, ! it doesn't do so EXACTLY, and this can be a problem for ! the recognition of contour-line element-edges in ! Contour_3Node_Velocity_on_Sphere. ! So, fix this with an explicit test: IF ((r_(1)==uvec1(1)).AND.(r_(2)==uvec1(2)).AND.(r_(3)==uvec1(3))) THEN vrt = v1t vrp = v1p ELSE IF ((r_(1)==uvec2(1)).AND.(r_(2)==uvec2(2)).AND.(r_(3)==uvec2(3))) THEN vrt = v2t vrp = v2p ELSE IF ((r_(1)==uvec3(1)).AND.(r_(2)==uvec3(2)).AND.(r_(3)==uvec3(3))) THEN vrt = v3t vrp = v3p END IF ! r_ lies exactly on uvec1, uvec2, or uvec3 !---- End kludge. vr2 = vrt*vrt + vrp*vrp IF (vr2 == 0.0) THEN ! exactly on an Euler pole; derivitives = 0/0 = UNDEFINED! vsize = 0.0 d_vsize_d_theta = 0.0 d_vsize_d_phi = 0.0 ELSE ! normal case; vsize > 0.0 vsize = SQRT(vr2) CALL Del_Gjxy_del_thetaphi (l_, uvec1, uvec2, uvec3, r_, dG) d_vrt_d_t = v1t * dG(1,1,1,1) + v1p * dG(1,2,1,1) + & & v2t * dG(2,1,1,1) + v2p * dG(2,2,1,1) + & & v3t * dG(3,1,1,1) + v3p * dG(3,2,1,1) d_vrt_d_p = v1t * dG(1,1,1,2) + v1p * dG(1,2,1,2) + & & v2t * dG(2,1,1,2) + v2p * dG(2,2,1,2) + & & v3t * dG(3,1,1,2) + v3p * dG(3,2,1,2) d_vrp_d_t = v1t * dG(1,1,2,1) + v1p * dG(1,2,2,1) + & & v2t * dG(2,1,2,1) + v2p * dG(2,2,2,1) + & & v3t * dG(3,1,2,1) + v3p * dG(3,2,2,1) d_vrp_d_p = v1t * dG(1,1,2,2) + v1p * dG(1,2,2,2) + & & v2t * dG(2,1,2,2) + v2p * dG(2,2,2,2) + & & v3t * dG(3,1,2,2) + v3p * dG(3,2,2,2) d_vsize_d_theta = (vrt*d_vrt_d_t + vrp*d_vrp_d_t) / vsize d_vsize_d_phi = (vrt*d_vrt_d_p + vrp*d_vrp_d_p) / vsize d_vsize_d_South = d_vsize_d_theta equat = SQRT(r_(1)**2 + r_(2)**2) IF (equat > 0.0) THEN d_vsize_d_East = d_vsize_d_phi / equat ELSE WRITE (*,"(' ERROR: r_ = N or S pole in Velocity_Size_in_3Node_Sphere.')") CALL Traceback END IF END IF END SUBROUTINE Velocity_Size_in_3Node_Sphere SUBROUTINE Velocity_Vector_on_Sphere (from_uvec, v_theta_mps, v_phi_mps, dt_sec, deflate) ! Plots horizontal velocity vector (v_theta, v_phi) = (v_South, v_East) ! at location from_uvec, projected forward in time by "dt_sec" along a great circle. ! Velocities should be in m/s, and time in seconds. !(Radius of sphere is taken from global mp_radius_meters.) ! IF (deflate), then size of vector is scaled down to anticipate ! the local amount of inflation introduced by the map projection, ! so that the vector is scaled to a standard vector in the margin. ! ELSE, no scaling is done, so vector inflates along with basemap; ! use this option to see where position would be after dt_sec. !(Note that "deflate" only works for the conformal map ! projections, which are: Mercator, Lambert Conformal Conic, ! and Stereographic.) IMPLICIT NONE REAL, DIMENSION(3), INTENT(IN) :: from_uvec REAL, INTENT(IN) :: dt_sec, v_phi_mps, v_theta_mps LOGICAL, INTENT(IN) :: deflate INTEGER :: kind REAL :: azimuth, path_radians, time REAL, DIMENSION(3) :: omega_uvec, to_uvec IF (deflate) THEN time = dt_sec * Conformal_Deflation(from_uvec) ELSE time = dt_sec END IF IF (time == 0.) RETURN IF ((v_theta_mps == 0.).AND.(v_phi_mps == 0.)) RETURN path_radians = SQRT(v_theta_mps**2 + v_phi_mps**2) * time / mp_radius_meters IF (ABS(path_radians) < Pi) THEN kind = 1 ! minor arc ELSE IF (ABS(path_radians) < 2.*Pi) THEN kind = 2 ! major arc ELSE IF (MOD(ABS(path_radians), 2.*Pi) < Pi) THEN kind = 3 ! great circle plus minor arc ELSE kind = 4 ! great circle plus major arc END IF azimuth = ATAN2 (v_phi_mps, -v_theta_mps) CALL Turn_To (azimuth_radians = azimuth, & & base_uvec = from_uvec, & & far_radians = path_radians, & ! inputs & omega_uvec = omega_uvec, & & result_uvec = to_uvec) CALL Vector_on_Sphere (from_uvec, to_uvec, kind) END SUBROUTINE Velocity_Vector_on_Sphere SUBROUTINE Which_Spherical_Triangle (b_, cold_start, & & num_ele, node, xyz_node, center, a_, neighbor, & & success, iele, s1, s2, s3) !Locates a point (b_, a uvec) in element iele with internal !coordinates (s1, s2, s3) in a SHELLS or RESTORE .feg. !and reports success. !If (cold_start), makes no use of input iele, s1, s2, s3 !If not, uses these values to initialize the search. ! !Note that Learn_Spherical_Triangles can be used to initialize !necessary arrays a_, center, and neighbor. ! !Beware of variable name changes (numel = num_ele, nodes = node, etc.). IMPLICIT NONE REAL, DIMENSION(3), INTENT(IN) :: b_ ! uvec of unknown point LOGICAL, INTENT(IN) :: cold_start ! mode switch INTEGER, INTENT(IN) :: num_ele ! count of elements INTEGER, DIMENSION(:,:),INTENT(IN) :: node ! element definitions REAL, DIMENSION(:,:),INTENT(IN) :: xyz_node ! uvecs of nodes REAL, DIMENSION(:,:),INTENT(IN) :: center ! center uvecs of elements REAL, DIMENSION(:), INTENT(IN) :: a_ ! (plane) areas of elements INTEGER, DIMENSION(:,:),INTENT(IN) :: neighbor ! neighbors of each element LOGICAL, INTENT(OUT) :: success ! OUTPUT INTEGER, INTENT(INOUT) :: iele ! OUTPUT REAL, INTENT(INOUT) :: s1, s2, s3 ! OUTPUT !- - - - - - - - - - - - - - - - - - - - - - - - - - - - INTEGER :: back1, back2, back3, i, iet, l_ REAL :: r2, r2min, s1t, s2t, s3t REAL, DIMENSION(3) :: s_temp, tv ! establish defaults (not found) in case of quick exit success = .FALSE. IF (cold_start) THEN iele = 0 ! default s1 = 0.0; s2 = 0.0; s3 = 0.0 ! default !find closest element center to initialize search r2min = 4.01 ! radians DO l_ = 1, num_ele r2 = (b_(1) - center(1,l_))**2 +(b_(2) - center(2,l_))**2 +(b_(3) - center(3,l_))**2 IF (r2 < r2min) THEN r2min = r2 iet = l_ END IF END DO ! If closest element center is more than 1 radian away, give up. tv = center(1:3, iet) IF (DOT_PRODUCT(b_, tv) < 0.540) RETURN ELSE ! warm (re)start; re-use last element# iet = iele END IF ! cold_start ! initialize search memory (with impossible numbers) back1 = -1 back2 = -2 back3 = -3 is_it_here: DO ! first, check for infinite loop between 2 elements! IF (iet == back2) THEN ! in loop; force location in one or the other! CALL Dumb_s123 (iet, b_, node, xyz_node, center, a_, & & s1t, s2t, s3t) s_temp(1) = s1t; s_temp(2) = s2t; s_temp(3) = s3t CALL Pull_in(s_temp) s1t = s_temp(1); s2t = s_temp(2); s3t = s_temp(3) EXIT is_it_here ! then, check for infinite loop between 3 elements! ELSE IF (iet == back3) THEN ! in loop; force location in one or the other! CALL Dumb_s123 (iet, b_, node, xyz_node, center, a_, & & s1t, s2t, s3t) s_temp(1) = s1t; s_temp(2) = s2t; s_temp(3) = s3t CALL Pull_in(s_temp) s1t = s_temp(1); s2t = s_temp(2); s3t = s_temp(3) EXIT is_it_here ELSE ! normal operation CALL Dumb_s123 (iet, b_, node, xyz_node, center, a_, & & s1t, s2t, s3t) IF ((s1t < s2t) .AND. (s1t < s3t)) THEN ! s1 is most negative; most critical IF (s1t >= 0.) THEN EXIT is_it_here ! success ELSE i = neighbor(1, iet) IF (i > 0) THEN back3 = back2 back2 = back1 back1 = iet iet = i CYCLE is_it_here ELSE RETURN ! fell off edge of grid ENDIF ENDIF ELSE IF ((s2t < s1t) .AND. (s2t < s3t)) THEN ! s2 is most negative; most critical IF (s2t >= 0.) THEN EXIT is_it_here ! success ELSE i = neighbor(2, iet) IF (i > 0) THEN back3 = back2 back2 = back1 back1 = iet iet = i CYCLE is_it_here ELSE RETURN ! fell off edge of grid ENDIF ENDIF ELSE ! s3 is most negative; most critical IF (s3t >= 0.) THEN EXIT is_it_here ! success ELSE i = neighbor(3, iet) IF (i > 0) THEN back3 = back2 back2 = back1 back1 = iet iet = i CYCLE is_it_here ELSE RETURN ! fell off edge of grid ENDIF ENDIF END IF END IF ! in/not in a loop END DO is_it_here ! successful completion iele = iet s1 = s1t s2 = s2t s3 = s3t success = .TRUE. END SUBROUTINE Which_Spherical_Triangle SUBROUTINE Wire_Mesh (kilometers) ! Adds a graphics group at level 3, containing ! a square grid of lines parallel to X and Y, ! with a spacing of "kilometers" (integer). ! The grid will often be larger than the window, ! but will be automatically clipped like other level 3 objects. ! Note that line width, color, dashing, etc. are ! not specified here and should be pre-defined. IMPLICIT NONE INTEGER, INTENT(IN) :: kilometers INTEGER :: i, i1, i2 REAL:: step_meters, x, xll, xlr, xmax, xmin, xul, xur, & & y, yll, ylr, ymax, ymin, yul, yur IF (kilometers < 1) THEN WRITE (*,"(' ERROR: Integer parameter kilometers sent to Wire_Mesh must be >= 1')") CALL Traceback END IF ! Find limits of x and y in window, remembering possible rotation. CALL Points_2_Meters(ai_window_x1_points,ai_window_y1_points, xll,yll) CALL Points_2_Meters(ai_window_x2_points,ai_window_y1_points, xlr,ylr) CALL Points_2_Meters(ai_window_x2_points,ai_window_y2_points, xur,yur) CALL Points_2_Meters(ai_window_x1_points,ai_window_y2_points, xul,yul) xmax = MAX(xll, xlr, xur, xul) xmin = MIN(xll, xlr, xur, xul) ymax = MAX(yll, ylr, yur, yul) ymin = MIN(yll, ylr, yur, yul) step_meters = 1000. * kilometers CALL Begin_Group ! lines parallel to X i1 = Int_Below(ymin/step_meters) i2 = Int_Below(ymax/step_meters) + 1 DO i = i1, i2 y = i * step_meters CALL New_L3_Path (xmin, y) CALL Line_To_L3 (xmax, y) CALL End_L3_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! lines parallel to X ! lines parallel to Y i1 = Int_Below(xmin/step_meters) i2 = Int_Below(xmax/step_meters) + 1 DO i = i1, i2 x = i * step_meters CALL New_L3_Path (x, ymin) CALL Line_To_L3 (x, ymax) CALL End_L3_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! lines parallel to Y CALL End_Group END SUBROUTINE Wire_Mesh ! =============================================== ! | INTERNAL UTILITY ROUTINES | ! | (in alphabetical order ) | ! =============================================== CHARACTER*8 FUNCTION ASCII8(x) ! Returns a right-justified 8-byte (or shorter) version of a ! floating-point number, in "human" format, with no more ! than 2 significant digits. IMPLICIT NONE REAL, INTENT(IN) :: x CHARACTER*8 :: temp8 CHARACTER*17 :: temp17 INTEGER :: j, k1, k8, zeros LOGICAL :: punt REAL :: x_log DOUBLE PRECISION :: y_DP IF (x == 0.0) THEN ASCII8=' 0' RETURN ELSE IF (x > 0.0) THEN punt = (x >= 99999999.5).OR.(x < 0.000010) ELSE ! x < 0.0 punt = (x <= -9999999.5).OR.(x > -0.00010) END IF IF (punt) THEN ! need exponential notation; use Fortran utility WRITE (temp8,'(1P,E8.1)') x !consider possible improvements from left to right: IF (temp8(3:4) == '.0') THEN temp17(5:8) = temp8(5:8) ! copy 'E-12' temp17(3:4) = temp8(1:2) ! copy '-5'; eliminate '.0' temp17(1:2) = ' ' ! pad on left temp8 = temp17(1:8) ENDIF IF (temp8(6:6) == '+') THEN temp17(7:8) = temp8(7:8) ! copy (positive) exponent digits temp17(2:6) = temp8(1:5) ! copy what is to left of '+' temp17(1:1) = ' ' ! pad on left temp8 = temp17(1:8) ENDIF IF (temp8(7:7) == '0') THEN temp17(8:8) = temp8(8:8) ! copy single-digit exponent temp17(2:7) = temp8(1:6) ! copy what is to left of '0' temp17(1:1) = ' ' ! pad on the left temp8 = temp17(1:8) ENDIF ASCII8 = temp8 ELSE ! can represent without exponential notation x_log = LOG10(ABS(x)) zeros = Int_Below(x_log) - 1 y_DP = (10.D0**zeros) * NINT(ABS(x) / (10.**zeros)) IF (x < 0.0) y_DP = -y_DP WRITE (temp17,"(F17.7)") y_DP !Avoid results like "0.740001" due to rounding error! IF (temp17(16:17) == '01') temp17(16:17) = '00' !Find first important byte from right; change 0 -> ' ' k8 = 9 ! (if no non-0 found to right of .) right_to_left: DO j = 17, 11, -1 IF (temp17(j:j) == '0') THEN temp17(j:j) = ' ' ELSE k8 = j EXIT right_to_left END IF END DO right_to_left !put leading (-)0 before . of fractions, if it fits IF (x > 0.0) THEN IF (temp17(9:10) == ' .') temp17(9:10) = '0.' ELSE ! x < 0.0 IF (k8 < 16) THEN IF (temp17(8:10) == ' -.') temp17(8:10) = '-0.' END IF END IF k1 = k8 - 7 ASCII8 = temp17(k1:k8) END IF ! punt, or not END FUNCTION ASCII8 CHARACTER*9 FUNCTION ASCII9(x) ! Returns a right-justified 9-byte (or shorter) version of a ! floating-point number, in "human" format, with no more ! than 3 significant digits. IMPLICIT NONE REAL, INTENT(IN) :: x CHARACTER*9 :: temp9 CHARACTER*19 :: temp19 INTEGER :: j, k1, k9, zeros LOGICAL :: punt REAL :: x_log DOUBLE PRECISION :: y IF (x == 0.0) THEN ASCII9=' 0' RETURN ELSE IF (x > 0.0) THEN punt = (x >= 999999999.5).OR.(x < 0.0000100) ELSE ! x < 0.0 punt = (x <= -99999999.5).OR.(x > -0.000100) END IF IF (punt) THEN ! need exponential notation; use Fortran utility WRITE (temp9,'(1P,E9.2)') x !consider possible improvements, from left to right: IF (temp9(3:5) == '.00') THEN ! right-shift over it temp19(6:9) = temp9(6:9) temp19(4:5) = temp9(1:2) temp19(1:3) = ' ' temp9 = temp19(1:9) ELSE IF (temp9(5:5) == '0') THEN ! right-shift over it temp19(6:9) = temp9(6:9) temp19(2:5) = temp9(1:4) temp19(1:1) = ' ' temp9 = temp19(1:9) END IF IF (temp9(7:7) == '+') THEN ! right-shift over it temp19(8:9) = temp9(8:9) temp19(2:7) = temp9(1:6) temp19(1:1) = ' ' temp9 = temp19(1:9) END IF IF (temp9(8:8) == '0') THEN ! right-shift over it temp19(9:9) = temp9(9:9) temp19(2:8) = temp9(1:7) temp19(1:1) = ' ' temp9 = temp19(1:9) END IF ASCII9 = temp9 ELSE ! can represent without exponential notation x_log = LOG10(ABS(x)) zeros = Int_Below(x_log) - 2 y = (10.D0**zeros) * NINT(ABS(x) / (10.D0**zeros)) IF (x < 0.0) y = -y WRITE (temp19,"(F19.8)") y ! byte 11 is the '.' !Avoid results like "0.7400001" due to rounding error! IF (temp19(18:19) == '01') temp19(18:19) = '00' !Find first important byte from right; change 0 -> ' ' k9 = 10 ! (if no non-0 found to right of .) right_to_left: DO j = 19, 12, -1 IF (temp19(j:j) == '0') THEN temp19(j:j) = ' ' ELSE k9 = j EXIT right_to_left END IF END DO right_to_left !put leading (-)0 before . of fractions, if it fits IF (x > 0.0) THEN IF (temp19(10:11) == ' .') temp19(10:11) = '0.' ELSE ! x < 0.0 IF (k9 <= 17) THEN IF (temp19(9:11) == ' -.') temp19(9:11) = '-0.' END IF END IF k1 = k9 - 8 ASCII9 = temp19(k1:k9) END IF ! punt, or not END FUNCTION ASCII9 CHARACTER*10 FUNCTION ASCII10(x) ! Returns a right-justified 10-byte (or shorter) version of a ! floating-point number, in "human" format, with no more ! than 4 significant digits. IMPLICIT NONE REAL, INTENT(IN) :: x CHARACTER*10 :: temp10 CHARACTER*20 :: temp20 INTEGER :: j, k1, k10, zeros LOGICAL :: punt REAL :: x_log DOUBLE PRECISION :: y IF (x == 0.0) THEN ASCII10=' 0' RETURN ELSE IF (x > 0.0) THEN punt = (x >= 999999999.5).OR.(x < 0.0000100) ELSE ! x < 0.0 punt = (x <= -99999999.5).OR.(x > -0.000100) END IF IF (punt) THEN ! need exponential notation; use Fortran utility WRITE (temp10,'(1P,E10.3)') x !consider possible improvements, from left to right: IF (temp10(3:6) == '.000') THEN ! right-shift 4 spaces over it temp20(7:10) = temp10(7:10) temp20(5:6) = temp10(1:2) temp20(1:4) = ' ' temp10 = temp20(1:10) ELSE IF (temp10(5:6) == '00') THEN ! right-shift 2 spaces over it temp20(7:10) = temp10(7:10) temp20(3:6) = temp10(1:4) temp20(1:2) = ' ' temp10 = temp20(1:10) ELSE IF (temp10(6:6) == '0') THEN ! right-shift 1 space over it temp20(7:10) = temp10(7:10) temp20(2:6) = temp10(1:5) temp20(1:1) = ' ' temp10 = temp20(1:10) END IF IF (temp10(8:8) == '+') THEN ! right-shift over + sign in exponent temp20(9:10) = temp10(9:10) temp20(2:8) = temp10(1:7) temp20(1:1) = ' ' temp10 = temp20(1:10) END IF IF (temp10(9:9) == '0') THEN ! right-shift over leading 0 in exponent temp20(10:10) = temp10(10:10) temp20(2:9) = temp10(1:8) temp20(1:1) = ' ' temp10 = temp20(1:10) END IF ASCII10 = temp10 ELSE ! can represent without exponential notation x_log = LOG10(ABS(x)) zeros = Int_Below(x_log) - 3 y = (10.D0**zeros) * NINT(ABS(x) / (10.D0**zeros)) IF (x < 0.0) y = -y WRITE (temp20,"(F20.9)") y ! byte 11 is the '.' !Avoid results like "0.7400001" due to rounding error! IF (temp20(19:20) == '01') temp20(19:20) = '00' !Find first important byte from right; change 0 -> ' ' k10 = 10 ! (if no non-0 found to right of .) right_to_left: DO j = 20, 12, -1 IF (temp20(j:j) == '0') THEN temp20(j:j) = ' ' ELSE k10 = j EXIT right_to_left END IF END DO right_to_left !put leading (-)0 before . of fractions, if it fits IF (x > 0.0) THEN IF (temp20(10:11) == ' .') temp20(10:11) = '0.' ELSE ! x < 0.0 IF (k10 <= 18) THEN IF (temp20(9:11) == ' -.') temp20(9:11) = '-0.' END IF END IF k1 = k10 - 9 ASCII10 = temp20(k1:k10) END IF ! punt, or not END FUNCTION ASCII10 SUBROUTINE DCross (a_vec, b_vec, c_vec) ! DOUBLE PRECISION version of Cross(); ! vector cross product: a x b = c IMPLICIT NONE DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: a_vec, b_vec DOUBLE PRECISION, DIMENSION(3), INTENT(OUT) :: c_vec c_vec(1) = a_vec(2)*b_vec(3) - a_vec(3)*b_vec(2) c_vec(2) = a_vec(3)*b_vec(1) - a_vec(1)*b_vec(3) c_vec(3) = a_vec(1)*b_vec(2) - a_vec(2)*b_vec(1) END SUBROUTINE DCross DOUBLE PRECISION FUNCTION DDot (a_vec, b_vec) ! DOUBLE PRECISION version of Dot; ! returns scalar (dot) product of two 3-component vectors, IMPLICIT NONE DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: a_vec, b_vec DDot = a_vec(1)*b_vec(1) + a_vec(2)*b_vec(2) + a_vec(3)*b_vec(3) END FUNCTION DDot SUBROUTINE Del_Gjxy_del_thetaphi (l_, uvec1, uvec2, uvec3, r_, dG) INTEGER, INTENT(IN) :: l_ ! element number or code REAL, DIMENSION(3), INTENT(IN) :: uvec1, uvec2, uvec3, & & r_ ! position vector DOUBLE PRECISION, DIMENSION (3,2,2,2), INTENT(OUT) :: dG ! Computes array of 2 derivitives of each of the 2 components of ! each of the 6 nodal functions for element l_, ! whose corners are uvec1, uvec2, and uvec3 (counterclockwise!), ! evaluated at position r_ (Cartesian unit vector). ! Results are in 1./radian (dimensionless), NOT 1./degree ! ! Also note that derivitives with respect to phi are algebraic, ! not spatial; that is, they have not been corrected for the ! changing length of a unit of phi with latitude, so these ! derivitives tend to become small near the poles, where ! a unit of phi does not cover very much distance. ! It is user's responsibility that element l_ contains r_. INTEGER, SAVE :: l_last = 0 ! remembers l_ from previous invocation INTEGER :: j ! 1:3 = local node numbering in element l_ INTEGER :: x ! 1:2 = node j has unit velocity to South(1) or East(2)? INTEGER :: y ! 1:2 = South(1) or East(2) component of vector nodal function? INTEGER :: m ! 1:2 = theta (S-ward) or phi (E-ward) derivitive? DOUBLE PRECISION, DIMENSION(3,2) :: del_r_ ! theta- and phi-derivitives of r_ (in 3-D) DOUBLE PRECISION, DIMENSION(3,2) :: local ! local Theta, Phi unit vectors at r_ (xyz, SE) DOUBLE PRECISION, DIMENSION(3,2,2) :: del_local ! theta-, phi- derivitives of local DOUBLE PRECISION, DIMENSION(3,3), SAVE :: corner ! positions vector of corner nodes (xyz, 123) DOUBLE PRECISION, DIMENSION(3,3,2), SAVE :: post ! unit coordinate vectors at corner nodes: ! (xyz, 123, SE) DOUBLE PRECISION, DIMENSION(3) :: tr_, tv, tvi, tvo, tv1, tv2, tv3, vfa, vfb ! temporary vector factors DOUBLE PRECISION :: cos_phi, cos_theta, factor, phi, sin_phi, sin_theta INTEGER :: i1, i2, i3 ! 1, 2, or 3 in cyclic rotation (depends on j) IF (l_ /= l_last) THEN ! new finite element l_last = l_ tvi(1:3) = uvec1(1:3) CALL DMake_Uvec(tvi, tvo) corner(1:3, 1) = tvo(1:3) tvi(1:3) = uvec2(1:3) CALL DMake_Uvec(tvi, tvo) corner(1:3, 2) = tvo(1:3) tvi(1:3) = uvec3(1:3) CALL DMake_Uvec(tvi, tvo) corner(1:3, 3) = tvo(1:3) DO j = 1, 3 tvi(1:3) = corner(1:3, j) CALL DLocal_Theta(tvi, tvo) post(1:3, j, 1) = tvo(1:3) CALL DLocal_Phi (tvi, tvo) post(1:3, j, 2) = tvo(1:3) END DO END IF ! begin calculations which depend on r_ tvi(1:3) = r_(1:3) ! upgrade to REAL8 CALL DMake_Uvec(tvi, tr_) CALL DLocal_Theta(tr_, tv) local(1:3,1) = tv(1:3) CALL DLocal_Phi(tr_, tv) local(1:3,2) = tv(1:3) ! Note: these functions will catch polar points; don't test again phi = DATAN2(tr_(2), tr_(1)) cos_phi = DCOS(phi) sin_phi = DSIN(phi) cos_theta = tr_(3) sin_theta = DSQRT(tr_(1)**2 + tr_(2)**2) del_r_(1:3,1) = local(1:3,1) ! d.r_/d.theta = Theta del_r_(1:3,2) = local(1:3,2) * sin_theta ! d.r_/d.phi = Phi * SIN(theta) del_local(1:3,1,1) = - tr_(1:3) ! d.Theta/d.theta = - r_ del_local(1:3,1,2) = local(1:3,2) * cos_theta ! d.Theta/d.phi = Phi * COS(theta) del_local(1:3,2,1) = (/ 0.0D0, 0.0D0, 0.0D0 /) ! d.Phi/d.theta = 0 del_local(1:3,2,2) = (/ -cos_phi, -sin_phi, 0.0D0 /) ! d.Phi/d.phi = (-COS(phi),-SIN(phi,0) DO j = 1, 3 ! 3 corner nodes of element i1 = j i2 = 1 + MOD(j, 3) i3 = 1 + MOD(i2,3) tv1(1:3) = corner(1:3, i1) tv2(1:3) = corner(1:3, i2) tv3(1:3) = corner(1:3, i3) CALL DCross(tv2, tv3, vfa) factor = 1.0D0 / DDot (tv1, vfa) vfb(1:3) = vfa(1:3) * factor DO x = 1, 2 ! unit velocity at node is S or E DO y = 1, 2 ! S- or E- component of nodal function tv1(1:3) = post(1:3, j, x) tvi(1:3) = local(1:3, y) DO m = 1, 2 ! theta- or phi-derivitive tv(1:3) = del_r_(1:3, m) tvo(1:3) = del_local(1:3, y, m) dG(j, x, y, m) = & & (DDot(tv,vfb)*DDot(tv1,tvi)) + & & (DDot(tr_,vfb)*DDot(tv1,tvo)) END DO END DO END DO END DO END SUBROUTINE Del_Gjxy_del_thetaphi SUBROUTINE Dumb_s123 (element, vector, node, xyz_nod, center, a_, & & s1, s2, s3) ! Finds s1, s2, s3 coordinates of position vector "in" element ! (whether the point is actually in the element or NOT). IMPLICIT NONE INTEGER, INTENT(IN) :: element ! element # REAL, DIMENSION(3), INTENT(IN) :: vector ! uvec to point INTEGER, DIMENSION(:,:), INTENT(IN) :: node ! element definitions REAL, DIMENSION(:,:), INTENT(IN) :: xyz_nod ! uvecs of nodes REAL, DIMENSION(:,:), INTENT(IN) :: center ! uvec of each element (uvec) REAL, DIMENSION(:), INTENT(IN) :: a_ ! element areas (plane; R == 1.0) REAL, INTENT(OUT) :: s1, s2, s3 ! results !- - - - - - - - - - - - - - - - - - - - - - - - INTEGER :: i1, i2, i3 REAL, DIMENSION(3) :: tv, tvi, tvo, tv1, tv2, v1 REAL :: d1, dc, t IF (element == 0) THEN WRITE (*,"(' ERROR: element = 0 in Dumb_s123')") CALL Traceback END IF i1 = node(1, element) i2 = node(2, element) i3 = node(3, element) !shorten(?) vector to just touch plane element -> v1 tv1 = center(1:3, element) dc = DOT_PRODUCT(vector, tv1) IF (dc <= 0.) THEN WRITE (*,"(' ERROR: Internal vector >= 90 deg. from element in Dumb_s123')") CALL Traceback END IF tv2 = xyz_nod(1:3, i1) d1 = DOT_PRODUCT(tv2, tv1) t = d1 / dc v1 = t * vector tvi = xyz_nod(1:3,i3) - xyz_nod(1:3,i2) tvo = v1(1:3) - xyz_nod(1:3,i3) CALL Cross(tvi, tvo, tv) s1 = 0.5 * DOT_PRODUCT(tv1, tv) / a_(element) tvi = xyz_nod(1:3,i1) - xyz_nod(1:3,i3) tvo = v1(1:3) - xyz_nod(1:3,i1) CALL Cross(tvi, tvo, tv) s2 = 0.5 * DOT_PRODUCT(tv1, tv) / a_(element) s3 = 1.00 - s1 - s2 END SUBROUTINE Dumb_s123 SUBROUTINE Gjxy (l_, uvec1, uvec2, uvec3, r_, G) INTEGER, INTENT(IN) :: l_ ! element number or code REAL, DIMENSION(3), INTENT(IN) :: uvec1, uvec2, uvec3, & ! corners & r_ ! position vector DOUBLE PRECISION, DIMENSION (3,2,2), INTENT(OUT) :: G ! Computes matrix of 6 vector nodal functions for element l_, ! whose corners are at uvec1, uvec2, and uvec3 (counterclockwise!), ! evaluated at position r_ (Cartesian unit vector). ! It is user's responsibility that element l_ contains r_. INTEGER, SAVE :: l_last = -999 ! remembers l_ from previous invocation INTEGER :: j ! 1:3 = local node numbering in element l_ INTEGER :: x ! 1:2 = node j has unit velocity to South(1) or East(2) INTEGER :: y ! 1:2 = South(1) or East(2) component of vector nodal function DOUBLE PRECISION, DIMENSION(3,2) :: local ! local unit vectors at r_ (xyz, SE) DOUBLE PRECISION, DIMENSION(3,3), SAVE :: corner ! positions vector of corner nodes (xyz, 123) DOUBLE PRECISION, DIMENSION(3,3,2), SAVE :: post ! unit coordinate vectors at corner nodes: ! (xyz, 123, SE) DOUBLE PRECISION, DIMENSION(3) :: tr_, tvi, tvo, tv1, tv2, tv3, vf ! temporary vector factors DOUBLE PRECISION :: f_sup_j ! as in Kong and Bird (1995) [ j == k ] INTEGER :: i1, i2, i3 ! 1, 2, or 3 in cyclic rotation (depends on j) IF (l_ /= l_last) THEN ! new finite element l_last = l_ tvi(1:3) = uvec1(1:3) CALL DMake_Uvec(tvi, tvo) corner(1:3, 1) = tvo(1:3) tvi(1:3) = uvec2(1:3) CALL DMake_Uvec(tvi, tvo) corner(1:3, 2) = tvo(1:3) tvi(1:3) = uvec3(1:3) CALL DMake_Uvec(tvi, tvo) corner(1:3, 3) = tvo(1:3) DO j = 1, 3 tvi(1:3) = corner(1:3, j) CALL DLocal_Theta(tvi, tvo) post(1:3, j, 1) = tvo(1:3) CALL DLocal_Phi (tvi, tvo) post(1:3, j, 2) = tvo(1:3) END DO END IF ! begin computations which depend on r_ tvi(1:3) = r_(1:3) CALL DMake_UVec(tvi, tr_) CALL DLocal_Theta(tr_, tvo) local(1:3,1) = tvo(1:3) CALL DLocal_Phi(tr_, tvo) local(1:3,2) = tvo(1:3) DO j = 1, 3 i1 = j i2 = 1 + MOD(j, 3) i3 = 1 + MOD(i2,3) tv1 = corner(1:3, i1) tv2 = corner(1:3, i2) tv3 = corner(1:3, i3) CALL DCross(tv2, tv3, vf) f_sup_j = DDot(tr_, vf) / DDot (tv1, vf) DO x = 1, 2 tv1(1:3) = post(1:3, j, x) DO y = 1, 2 tv2(1:3) = local(1:3, y) G(j, x, y) = f_sup_j * DDot(tv1, tv2) END DO END DO END DO END SUBROUTINE Gjxy SUBROUTINE In_Element (l_, uvec1, uvec2, uvec3, vector, code, s1, s2, s3) ! Finds s1, s2, s3 coordinates of position 'vector' "in"(?) ! the spherical triangle element defined by uvec1, uvec2, ! and uvec3 (in counterclockwise order!), ! whether the point is actually in the element or NOT. INTEGER, INTENT(IN) :: l_ ! element ID number REAL, DIMENSION(3), INTENT(IN) :: uvec1, uvec2, uvec3, vector ! all uvec's CHARACTER*1, INTENT(OUT) :: code ! O = out, I = in, B = border REAL, INTENT(OUT) :: s1, s2, s3 SAVE ! allows faster startup when repeating same element INTEGER :: l_last = -999 ! remembers l_ from previous invocation REAL, DIMENSION(3) :: c_vec, east_uvec, normal_uvec, north_uvec, & & p_vec, side2to3, side3to1, t_vec REAL :: d, min_radius, twice_area IF (l_ /= l_last) THEN !initialize for new element CALL Set_Sphere_2_Plane(uvec1, uvec2, uvec3, & ! inputs & normal_uvec, min_radius, & ! outputs, & north_uvec, east_uvec) side2to3 = uvec3 - uvec2 side3to1 = uvec1 - uvec3 twice_area = 2.0 * Plane_Area_Radian2s(uvec1, uvec2, uvec3) l_last = l_ END IF ! initialization required d = Dot(vector, normal_uvec) IF (d <= 0.0) THEN s1 = -444. s2 = -555. ELSE ! in right hemisphere, at least! !shorten/lengthen vector so it just reaches the plane triangle: t_vec = (min_radius / d) * vector !(in-plane) difference of point from uvec2: p_vec = t_vec - uvec2 CALL Cross(side2to3, p_vec, c_vec) IF (Dot(c_vec, normal_uvec) > 0.0) THEN s1 = Length(c_vec) / twice_area ELSE s1 = -Length(c_vec) / twice_area END IF !(in-plane) difference of point from uvec3: p_vec = t_vec - uvec3 CALL Cross(side3to1, p_vec, c_vec) IF (Dot(c_vec, normal_uvec) > 0.0) THEN s2 = Length(c_vec) / twice_area ELSE s2 = -Length(c_vec) / twice_area END IF END IF s3 = 1.00 - s1 - s2 code = 'I' ! if not changed below IF ((s1 < 0.0).OR.(s1 > 1.0)) THEN code = 'O' RETURN ELSE IF ((s1 == 0.0).OR.(s1 == 1.0)) THEN code = 'B' END IF IF ((s2 < 0.0).OR.(s2 > 1.0)) THEN code = 'O' RETURN ELSE IF ((s2 == 0.0).OR.(s2 == 1.0)) THEN code = 'B' END IF IF ((s3 < 0.0).OR.(s3 > 1.0)) THEN code = 'O' ELSE IF ((s3 == 0.0).OR.(s3 == 1.0)) THEN code = 'B' END IF END SUBROUTINE In_Element INTEGER FUNCTION Int_Above (x) ! Returns integer equal to, or greater than, x. ! (Note: INT() is different; always truncates toward zero.) IMPLICIT NONE REAL, INTENT(IN) :: x INTEGER :: i REAL :: y i = INT(x) IF (x <= 0.) THEN Int_Above = i ELSE ! x > 0. y = 1.*i IF (y >= x) THEN Int_Above = i ELSE ! most commonly Int_Above = i + 1 END IF END IF END FUNCTION Int_Above INTEGER FUNCTION Int_Below (x) ! Returns integer equal to, or less than, x. ! (Note: INT() is different; always truncates toward zero.) IMPLICIT NONE REAL, INTENT(IN) :: x INTEGER :: i REAL :: y i = INT(x) IF (x >= 0.) THEN Int_Below = i ELSE ! x < 0. y = 1.*i IF (y <= x) THEN Int_Below = i ELSE ! most commonly Int_Below = i - 1 END IF END IF END FUNCTION Int_Below DOUBLE PRECISION FUNCTION DLength(a_vec) ! DOUBLE PRECISION version of Length(); computes length of a 3-vector IMPLICIT NONE DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: a_vec DOUBLE PRECISION :: t t = a_vec(1)**2 + & & a_vec(2)**2 + & & a_vec(3)**2 IF (t == 0.0D0) THEN DLength = 0.0D0 ELSE DLength = DSQRT(t) END IF END FUNCTION DLength SUBROUTINE DLocal_Phi (b_, Phi) ! DOUBLE PRECISION version of Local_Phi(); ! returns local East-pointing unit vector in Cartesian coordinates ! for location b_; not intended to work at the poles! DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: b_ DOUBLE PRECISION, DIMENSION(3), INTENT(OUT) :: Phi DOUBLE PRECISION, DIMENSION(3) :: temp IF (b_(1) == 0.0D0) THEN IF (b_(2) == 0.0D0) THEN WRITE (*,"(' ERROR: DLocal_Phi was requested for N or S pole.')") CALL Traceback END IF END IF temp(1) = -b_(2) temp(2) = b_(1) temp(3) = 0.0D0 CALL DMake_Uvec(temp, Phi) END SUBROUTINE DLocal_Phi SUBROUTINE DLocal_Theta (b_, Theta) ! DOUBLE PRECISION version of Local_Theta(); ! returns local South-pointing unit vector in Cartesian coordinates ! for location b_; not intended to work at the poles! DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: b_ DOUBLE PRECISION, DIMENSION(3), INTENT(OUT) :: Theta DOUBLE PRECISION, DIMENSION(3) :: temp DOUBLE PRECISION :: equat, new_equat equat = DSQRT(b_(1)**2 + b_(2)**2) !equatorial component IF (equat == 0.0D0) THEN WRITE (*,"(' ERROR: DLocal_Theta was requested for N or S pole.')") CALL Traceback END IF new_equat = b_(3) ! swap components in a meridional plane temp(3) = -equat ! " temp(1) = new_equat * b_(1) / equat ! partition new equatorial component temp(2) = new_equat * b_(2) / equat ! " CALL DMake_Uvec (temp, Theta) END SUBROUTINE DLocal_Theta SUBROUTINE DMake_Uvec (vector, uvec) ! DOUBLE PRECISION version of Make_Uvec(); ! Shortens or lengthens a three-component vector to a unit vector; ! includes special kludge to prevent extremely small component ! values which result from rounding error and result in later ! numerical underflows. IMPLICIT NONE INTEGER :: i DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: vector DOUBLE PRECISION, DIMENSION(3), INTENT(OUT):: uvec DOUBLE PRECISION :: factor, size size = DLength(vector) IF (size > 0.0D0) THEN factor = 1.0D0 / size uvec = vector * factor DO i = 1, 3 IF (ABS(uvec(i)) < 1.D-100) uvec(i) = 0.0D0 END DO ELSE WRITE (*,"(' ERROR: Cannot DMake_Uvec of (0., 0., 0.).')") CALL Traceback END IF END SUBROUTINE DMake_Uvec REAL FUNCTION Plane_Area_Radian2s (uvec1, uvec2, uvec3) !returns area of plane triangle (below surface); !uvec1, uvec2, uvec3 must be in counterclockwise order! IMPLICIT NONE REAL, DIMENSION(3), INTENT(IN) :: uvec1, uvec2, uvec3 REAL, DIMENSION(3) :: a, b, c, t a = uvec2 - uvec1 b = uvec3 - uvec2 CALL Cross (a, b, c) t = uvec1 + uvec2 + uvec3 ! (no need to /3.) IF (Dot(t, c) > 0.) THEN Plane_Area_Radian2s = 0.5 * Length(c) ELSE WRITE (*,"(' ERROR: Spherical triangle has non-positive area.')") CALL Traceback END IF END FUNCTION Plane_Area_Radian2s SUBROUTINE Plane_2_Sphere(x,y, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & uvec) ! output ! Converts a location (x,y) within a plane triangle ! to a uvec in the spherical triangle ! which shares these 3 corners, by radial projection. ! Normal_uvec is the normal to the plane triangle. ! Where normal_uvec (projecting from center of planet) ! pierces the plane triangle is the origin of the (x,y) system. ! (Here the plane triangle is locally parallel to the overlying ! spherical surface.) ! Min_radius is the distance (dimensionless, <= 1.) from this ! point to the center of the planet. ! +x is to the East, and +y is to the North. They are ! represented by north_uvec and east_uvec, respectively. ! All of the preceding parameters are computed by Set_Sphere_2_Plane. IMPLICIT NONE REAL, INTENT(IN) :: x,y REAL, DIMENSION(3), INTENT(IN) :: normal_uvec, & & north_uvec, east_uvec REAL, INTENT(IN) :: min_radius REAL, DIMENSION(3), INTENT(OUT) :: uvec REAL, DIMENSION(3) :: p_vec, t_vec !find in-plane vector, in dimensionless radii units p_vec = (x / mp_radius_meters) * east_uvec + & & (y / mp_radius_meters) * north_uvec !add out_of_plane component common to whole plane triangle: t_vec = p_vec + min_radius * normal_uvec !scale up to uvec CALL Make_Uvec(t_vec, uvec) END SUBROUTINE Plane_2_Sphere SUBROUTINE Principal_Axes_22 (e11, e12, e22, & & e1, e2, u1x,u1y, u2x,u2y) ! Find principal values (e1,e2) of the symmetric 2x2 tensor ! e11 e12 ! e12 e22 ! and also the associated unit eigenvectors: ! #1 = (u1x, u1y); #2 = (u2x, u2y). ! The convention is that e1 <= e2. IMPLICIT NONE REAL, INTENT(IN) :: e11, e12, e22 REAL, INTENT(OUT) :: e1, e2, u1x, u1y, u2x, u2y REAL :: c, f1, f11, f12, f2, f22, r, scale, smallest, test, theta ! Smallest number that can be squared without underflowing: smallest = 1.1 * SQRT(TINY(f1)) ! First, check for trivial isotropic case: IF ((e11 == e22).AND.(e12 == 0.)) THEN ! In this case, directions are arbitrary: e1 = e11 u1x = 1. u1y = 0. e2 = e22 u2x = 0. u2y = 1. RETURN END IF ! Else, re-scale matrix to prevent under/overflows: scale = MAX(ABS(e11), ABS(e12), ABS(e22)) f11 = e11 / scale IF (ABS(f11) < smallest) f11 = 0. f12 = e12 / scale IF (ABS(f12) < smallest) f12 = 0. f22 = e22 / scale IF (ABS(f22) < smallest) f22 = 0. ! Find eigenvalues and eigenvectors of scaled matrix: r = SQRT(((f11 - f22)*0.5)**2 + f12**2) c = (f11 + f22)*0.5 f1 = c - r f2 = c + r test = 0.01 * MAX (ABS(f1), ABS(f2)) IF ((ABS(f12) > test).OR.(ABS(f11 - f1) > test)) THEN theta = Atan2F((f11 - f1), -f12) ELSE theta = Atan2F(f12, (f1 - f22)) END IF u1x = COS(theta) u1y = SIN(theta) u2x = u1y u2y = -u1x ! Undo the scaling e1 = scale * f1 e2 = scale * f2 END SUBROUTINE Principal_Axes_22 SUBROUTINE Prompt_for_Integer (prompt_text, default, answer) ! Writes a line to the default (*) unit, with: ! "prompt_text" ["default"]: ! and accepts an answer with an integer value. ! If [Enter] is pressed with nothing preceding it, ! then "answer" takes the value "default". ! This also occurs IF (mt_flashby), without waiting for user. ! Note that prompt_text should usually end with '?'. ! It can be more than 52 bytes long if necessary, but cannot ! contain line breaks, tabs, or other formatting. ! Trailing blanks in prompt_text are ignored. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: prompt_text INTEGER, INTENT(IN) :: default INTEGER, INTENT(OUT) :: answer CHARACTER*11 :: instring, suggested INTEGER :: blank_at, bytes, ios, trial, written LOGICAL :: finished IF (mt_flashby_count > mt_flashby_limit) THEN ! quash inf.-loop! WRITE (*, "(/' mt_flashby_count > mt_flashby_limit = ',I4,'; returning to manual.')") mt_flashby_limit mt_flashby = .FALSE. mt_flashby_count = 0 END IF WRITE (suggested,"(I11)") default suggested = ADJUSTL(suggested) bytes = LEN_TRIM(prompt_text) finished = .FALSE. DO WHILE (.NOT. finished) written = 0 DO WHILE ((bytes - written) > 52) blank_at = written + INDEX(prompt_text((written+1):(written+52)),' ',.TRUE.) ! searching L from end for ' ' IF (blank_at < (written + 2)) blank_at = written + 52 WRITE (*,"(' ',A)") prompt_text((written+1):blank_at) written = blank_at END DO WRITE (*,"(' ',A,' [',A']: '\)") prompt_text((written+1):bytes), TRIM(suggested) finished = .TRUE. ! unless changed below IF (mt_flashby) THEN WRITE (*, *) mt_flashby_count = mt_flashby_count + 1 ELSE READ (*,"(A)") instring END IF IF (instring == "'") mt_flashby = .TRUE. IF (mt_flashby.OR.(LEN_TRIM(instring) == 0)) THEN answer = default ELSE !The following lead to occoasional abends !under Digital Visual Fortran 5.0D !(memory violations caught by WinNT): !READ (instring, *, IOSTAT = ios) trial !The following fix leads to a compiler error: !BACKSPACE (*) !READ (*, *, IOSTAT = ios) trial !and the following fix lead to an immediate abend: !BACKSPACE (5) !READ (*, *, IOSTAT = ios) trial !So, I am creating and then reading a dummy file: OPEN (UNIT = 72, FILE = 'trash') WRITE (72, "(A)") instring CLOSE (72) OPEN (UNIT = 72, FILE = 'trash') READ (72, *, IOSTAT = ios) trial CLOSE (72, STATUS = 'DELETE') IF (ios /= 0) THEN ! bad string WRITE (*,"(' ERROR: Your response (',A,') was not recognized.')") TRIM(instring) WRITE (*,"(' Enter an integer of 9 digits or less.')") WRITE (*,"(' Please try again:')") finished = .FALSE. ELSE answer = trial END IF ! problem with string, or not? END IF ! some bytes were entered END DO ! until finished END SUBROUTINE Prompt_for_Integer SUBROUTINE Prompt_for_Logical (prompt_text, default, answer) ! Writes a line to the default (*) unit, with: ! "prompt_text" ["default"]: ! and accepts an answer with a logical value. ! If [Enter] is pressed with nothing preceding it, ! then "answer" takes the value "default". ! The same happens IF (mt_flashby), without waiting for the user. ! Note that prompt_text should usually end with '?'. ! It can be more than 70 bytes long if necessary, but cannot ! contain line breaks, tabs, or other formatting. ! Trailing blanks in prompt_text are ignored. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: prompt_text LOGICAL, INTENT(IN) :: default LOGICAL, INTENT(OUT) :: answer CHARACTER*1 :: inbyte CHARACTER*3 :: yesno INTEGER :: blank_at, bytes, ios, written LOGICAL :: finished IF (mt_flashby_count > mt_flashby_limit) THEN ! quash inf.-loop! WRITE (*, "(/' mt_flashby_count > mt_flashby_limit = ',I4,'; returning to manual.')") mt_flashby_limit mt_flashby = .FALSE. mt_flashby_count = 0 END IF bytes = LEN_TRIM(prompt_text) finished = .FALSE. DO WHILE (.NOT. finished) IF (default) THEN yesno = 'Yes' ELSE yesno = 'No' END IF written = 0 DO WHILE ((bytes - written) > 70) blank_at = written + INDEX(prompt_text((written+1):(written+70)),' ',.TRUE.) ! searching L from end for ' ' IF (blank_at < (written + 2)) blank_at = written + 70 WRITE (*,"(' ',A)") prompt_text((written+1):blank_at) written = blank_at END DO WRITE (*,"(' ',A,' [',A']: '\)") prompt_text((written+1):bytes), TRIM(yesno) finished = .TRUE. ! unless changed below IF (mt_flashby) THEN WRITE (*, *) mt_flashby_count = mt_flashby_count + 1 ELSE READ (*,"(A)") inbyte END IF IF (inbyte == "'") mt_flashby = .TRUE. IF (mt_flashby.OR.(LEN_TRIM(inbyte) == 0)) THEN answer = default ELSE SELECT CASE (inbyte) CASE ('Y') answer = .TRUE. CASE ('y') answer = .TRUE. CASE ('T') answer = .TRUE. CASE ('t') answer = .TRUE. CASE ('R') answer = .TRUE. CASE ('r') answer = .TRUE. CASE ('O') answer = .TRUE. CASE ('o') answer = .TRUE. CASE ('N') answer = .FALSE. CASE ('n') answer = .FALSE. CASE ('F') answer = .FALSE. CASE ('f') answer = .FALSE. CASE ('W') answer = .FALSE. CASE ('w') answer = .FALSE. CASE DEFAULT WRITE (*,"(' ERROR: Your response (',A,') was not recognized.')") inbyte WRITE (*,"(' (Only the first letter of your answer is used.)')") WRITE (*,"(' To agree, enter Y, y, T, t, O, o, R, or r.')") WRITE (*,"(' To disagree, enter N, n, F, f, W, or w.')") WRITE (*,"(' Please try again:')") finished = .FALSE. END SELECT END IF ! a byte was entered END DO ! until finished END SUBROUTINE Prompt_for_Logical SUBROUTINE Prompt_for_Real (prompt_text, default, answer) ! Writes a line to the default (*) unit, with: ! "prompt_text" ["default"]: ! and accepts an answer with a real value. ! If [Enter] is pressed with nothing preceding it, ! then "answer" takes the value "default". ! The same happens IF (mt_flashby), without waiting for the user. ! Note that prompt_text should usually end with '?'. ! It can be more than 52 bytes long if necessary, but cannot ! contain line breaks, tabs, or other formatting. ! Trailing blanks in prompt_text are ignored. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: prompt_text REAL, INTENT(IN) :: default REAL, INTENT(OUT) :: answer CHARACTER*11 :: instring, suggested INTEGER :: blank_at, bytes, ios, point, written LOGICAL :: finished REAL :: trial IF (mt_flashby_count > mt_flashby_limit) THEN ! quash inf.-loop! WRITE (*, "(/' mt_flashby_count > mt_flashby_limit = ',I4,'; returning to manual.')") mt_flashby_limit mt_flashby = .FALSE. mt_flashby_count = 0 END IF !------------------------------------------------------------------------------------ !This code worked (provided 4 significant digits), but left unecessary trailing zeros ("20.00"; "6.000E+07") !IF (((ABS(default) >= 0.1).AND.(ABS(default) < 1000.)).OR.(default == 0.0)) THEN ! ! Provide 4 significant digits by using Gxx.4 (the suffix shows significant digits, NOT digits after the decimal point!) ! WRITE (suggested,"(G11.4)") default !ELSE ! ! Use 1P,E because it avoids wasted and irritating leading 0 ("0.123E+4"). ! WRITE (suggested,"(1P,E11.3)") default !END IF !------------------------------------------------------------------------------------ !So I replaced it with the following: !(1) Use ASCII10 to get 4 significant digits (but no unecessary trailing zeroes): suggested = ASCII10(default) !(2) Be sure that the number contains some sign that it is floating-point, not integer: IF (INDEX(suggested, '.') == 0) THEN IF ((INDEX(suggested, 'E') == 0).AND.(INDEX(suggested, 'e') == 0).AND. & & (INDEX(suggested, 'D') == 0).AND.(INDEX(suggested, 'd') == 0)) THEN suggested = ADJUSTL(suggested) point = LEN_TRIM(suggested) + 1 suggested(point:point) = '.' END IF END IF !------------------------------------------------------------------------------------ suggested = ADJUSTL(suggested) bytes = LEN_TRIM(prompt_text) finished = .FALSE. DO WHILE (.NOT. finished) written = 0 DO WHILE ((bytes - written) > 52) blank_at = written + INDEX(prompt_text((written+1):(written+52)),' ',.TRUE.) ! searching L from end for ' ' IF (blank_at < (written + 2)) blank_at = written + 52 WRITE (*,"(' ',A)") prompt_text((written+1):blank_at) written = blank_at END DO WRITE (*,"(' ',A,' [',A']: '\)") prompt_text((written+1):bytes), TRIM(suggested) finished = .TRUE. ! unless changed below IF (mt_flashby) THEN WRITE (*, *) mt_flashby_count = mt_flashby_count + 1 ELSE READ (*,"(A)") instring END IF IF (instring == "'") mt_flashby = .TRUE. IF (mt_flashby.OR.(LEN_TRIM(instring) == 0)) THEN answer = default ELSE !The following lead to occoasional abends !under Digital Visual Fortran 5.0D !(memory violations caught by WinNT): !READ (instring, *, IOSTAT = ios) trial !The following fix leads to a compiler error: !BACKSPACE (*) !READ (*, *, IOSTAT = ios) trial !and the following fix lead to an immediate abend: !BACKSPACE (5) !READ (*, *, IOSTAT = ios) trial !So, I am creating and then reading a dummy file: OPEN (UNIT = 72, FILE = 'trash') WRITE (72, "(A)") instring CLOSE (72) OPEN (UNIT = 72, FILE = 'trash') READ (72, *, IOSTAT = ios) trial CLOSE (72, STATUS = 'DELETE') IF (ios /= 0) THEN ! bad string WRITE (*,"(' ERROR: Your response (',A,') was not recognized.')") TRIM(instring) WRITE (*,"(' Enter an real number using 11 characters (or less).')") WRITE (*,"(' Please try again:')") finished = .FALSE. ELSE answer = trial END IF ! problem with string, or not? END IF ! some bytes were entered END DO ! until finished END SUBROUTINE Prompt_for_Real SUBROUTINE Prompt_for_String (prompt_text, default, answer) ! Writes a line to the default (*) unit, with: ! "prompt_text" ["default"]: ! and accepts an answer with a character-string value. ! If [Enter] is pressed with nothing preceding it, ! then "answer" takes the value "default". ! The same happens IF (mt_flashby), without waiting for the user. ! Note that prompt_text should usually end with '?'. ! It can be more than 70 bytes long if necessary, but cannot ! contain line breaks, tabs, or other formatting. ! Trailing blanks in prompt_text are ignored. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: prompt_text CHARACTER*(*), INTENT(IN) :: default CHARACTER*(*), INTENT(OUT) :: answer CHARACTER*80 trial INTEGER :: blank_at, default_bytes, leftover, & & prompt_bytes, written IF (mt_flashby_count > mt_flashby_limit) THEN ! quash inf.-loop! WRITE (*, "(/' mt_flashby_count > mt_flashby_limit = ',I4,'; returning to manual.')") mt_flashby_limit mt_flashby = .FALSE. mt_flashby_count = 0 END IF prompt_bytes = LEN_TRIM(prompt_text) default_bytes = LEN_TRIM(default) written = 0 leftover = 79 - prompt_bytes - 4 ! unless changed below DO WHILE ((prompt_bytes - written) > 70) blank_at = written + INDEX(prompt_text((written+1):(written+70)),' ',.TRUE.) ! searching L from end for ' ' IF (blank_at < (written + 2)) blank_at = written + 70 WRITE (*,"(' ',A)") prompt_text((written+1):blank_at) leftover = 79 - (blank_at - (written+1) + 1) - 4 written = blank_at END DO IF (leftover >= default_bytes) THEN WRITE (*,"(' ',A,' [',A,']')") prompt_text(written+1:prompt_bytes), TRIM(default) ELSE WRITE (*,"(' ',A)") prompt_text(written+1:prompt_bytes) WRITE (*,"(' [',A,']')") TRIM(default) END IF WRITE (*,"(' ?: '\)") IF (mt_flashby) THEN mt_flashby_count = mt_flashby_count + 1 ELSE READ (*,"(A)") trial END IF IF (trial == "'") mt_flashby = .TRUE. IF (mt_flashby.OR.(LEN_TRIM(trial) == 0)) THEN answer = TRIM(default) ELSE answer = TRIM(trial) END IF END SUBROUTINE Prompt_for_String SUBROUTINE Pull_in(s) ! If necessary, adjusts internal coordinates s(1..3) so ! that none is negative. IMPLICIT NONE REAL, DIMENSION(3), INTENT(INOUT) :: s INTEGER, DIMENSION(1) :: array ! stupid, to satisfy MINLOC REAL factor, lowest, highest, medium INTEGER :: side, sidea, sideb lowest = MINVAL(s) IF (lowest < 0.) THEN highest = MAXVAL(s) medium = 1.00 - lowest - highest IF (medium > 0.) THEN ! correct to nearest edge array = MINLOC(s) side = array(1) s(side) = 0. sidea = 1 + MOD(side, 3) sideb = 1 + MOD(sidea, 3) factor = 1.00 / (1.00 - lowest) s(sidea) = factor * s(sidea) ! s(sideb) = factor * s(sideb) would be logical s(sideb) = 1.00 - s(sidea) ! is safer ELSE ! correct to nearest vertex array = MAXLOC(s) side = array(1) s(side) = 1.00 sidea = 1 + MOD(side, 3) sideb = 1 + MOD(sidea, 3) s(sidea) = 0. s(sideb) = 0. END IF END IF END SUBROUTINE Pull_in REAL FUNCTION Round (x) ! Rounds a positive real number to the form N*10**M IMPLICIT NONE REAL, INTENT(IN) :: x INTEGER :: m, n IF (x <= 0.0) THEN WRITE (*,"(' ERROR: Non-positive x in Round(x)')") CALL Traceback END IF m = Int_Below (ALOG10(x)) n = INT ((x / 10.**m) + 0.5) Round = n * 10.**m END FUNCTION Round SUBROUTINE Set_Sphere_2_Plane(uvec1, uvec2, uvec3, & ! inputs & normal_uvec, min_radius, & ! outputs, & north_uvec, east_uvec) ! Establish correspondance between a spherical triangle ! (with nodes uvec1, uvec2, uvec3, counterclockwise, and NOT ! located on the same great circle) and ! a 2-D Cartesian (x,y) system in the plane triangle ! which shares these 3 corners. ! Normal_uvec is the normal to the plane triangle. ! Where normal_uvec (projecting from center of planet) ! pierces the plane triangle is the origin of the (x,y) system. ! (Here the plane triangle is locally parallel to the overlying ! spherical surface.) ! Min_radius is the distance (dimensionless, <= 1.) from this ! point to the center of the planet. ! +x is to the East, and +y is to the North. They are ! represented by north_uvec and east_uvec, respectively. IMPLICIT NONE REAL, DIMENSION(3), INTENT(IN) :: uvec1, uvec2, uvec3 REAL, DIMENSION(3), INTENT(OUT) :: normal_uvec, north_uvec, east_uvec REAL, INTENT(OUT) :: min_radius REAL :: lon, lat REAL, DIMENSION(3) :: side1, side2, t_vec side1 = uvec3 - uvec2 ! vector subtraction side2 = uvec1 - uvec3 CALL Cross(side1, side2, t_vec) CALL Make_Uvec(t_vec, normal_uvec) min_radius = Dot(normal_uvec, uvec1) ! or uvec2, or uvec3 IF (min_radius < 0.0) THEN WRITE (*,"(' ERROR: 3 nodes sent to Set_Sphere_2_Plane not in counterclockwise order.')") CALL Uvec_2_LonLat(uvec1, lon, lat) WRITE (*,"(' 1: ',F10.4,'E, ',F9.4,'N')")lon, lat CALL Uvec_2_LonLat(uvec2, lon, lat) WRITE (*,"(' 2: ',F10.4,'E, ',F9.4,'N')")lon, lat CALL Uvec_2_LonLat(uvec3, lon, lat) WRITE (*,"(' 3: ',F10.4,'E, ',F9.4,'N')")lon, lat CALL Traceback END IF CALL NorthEast_Convention (normal_uvec, north_uvec, east_uvec) END SUBROUTINE Set_Sphere_2_Plane SUBROUTINE Sphere_2_Plane(uvec, normal_uvec, min_radius, north_uvec, east_uvec, & ! inputs & x,y) ! outputs ! Converts a location (uvec) within a spherical triangle ! to a 2-D Cartesian (x,y) system in the plane triangle ! which shares these 3 corners. ! Normal_uvec is the normal to the plane triangle. ! Where normal_uvec (projecting from center of planet) ! pierces the plane triangle is the origin of the (x,y) system. ! (Here the plane triangle is locally parallel to the overlying ! spherical surface.) ! Min_radius is the distance (dimensionless, <= 1.) from this ! point to the center of the planet. ! +x is to the East, and +y is to the North. They are ! represented by north_uvec and east_uvec, respectively. ! All of the preceding parameters are computed by Set_Sphere_2_Plane. IMPLICIT NONE REAL, DIMENSION(3), INTENT(IN) :: uvec, normal_uvec, & & north_uvec, east_uvec REAL, INTENT(IN) :: min_radius REAL, INTENT(OUT) :: x,y REAL, DIMENSION(3) :: p_vec, t_vec REAL :: d d = Dot(uvec, normal_uvec) IF (d < (0.99 * min_radius)) THEN WRITE (*,"(' ERROR: Uvec sent to Sphere_2_Plane is not in triangle.')") CALL Traceback END IF !shorten vector so it just reaches the plane triangle: t_vec = (min_radius / d) * uvec ! vector scaling !subtract off out-of-plane component p_vec = t_vec - min_radius * normal_uvec !find x and y components, rescaling to meter units x = mp_radius_meters * Dot(p_vec, east_uvec) y = mp_radius_meters * Dot(p_vec, north_uvec) END SUBROUTINE Sphere_2_Plane SUBROUTINE Upper_Case (string) !Modifies its sole argument so that a..z --> A..Z !Useful* as a filter applied to filenames, before testing ! for a match (*at least, on Windows systems!) IMPLICIT NONE CHARACTER*(*), INTENT(INOUT) :: string INTEGER :: i, j, length length = LEN_TRIM(string) DO i = 1, length j = IACHAR(string(i:i)) IF ((j >= 97).AND.(j <= 122)) THEN ! a..z string(i:i) = ACHAR(j - 32) ! A..Z = 65..90 END IF END DO END SUBROUTINE Upper_Case SUBROUTINE Value_On_3Node_Side (f1, f2, f3, f, & ! inputs & number, p1, p2) ! outputs !If function values are (in order) f1, f2, and f3 at the start, midpoint, and end !of a 3-node element side (or fault side), and if the function varies quadratically !along this side, then this subprogram reports any points at which the function value is f. !Number is the count of solutions (0, 1, or 2). If there is >= 1 solution, p1 is used !to record the fractional distance along the side. If there are 2 solutions, p2 is used !to hold the second solution. Only p values in [0.0, 1.0] are considered to be solutions. !If the value of f is reached at an extremum, this is reported as two solutions with !equal p values (p2 = p1). IMPLICIT NONE REAL, INTENT(IN) :: f1, f2, f3, f INTEGER, INTENT(OUT) :: number REAL, INTENT(OUT) :: p1, p2 REAL, PARAMETER :: dimensionless_curvature_noise = 1.E-4 REAL :: a, b, c, dimensional_curvature_noise, discriminant, f_scale, t !Express f(p) - f = 0 as a * p**2 + b * p + c = 0 a = 2.0 * f1 - 4.0 * f2 + 2.0 * f3 b = -3.0 * f1 + 4.0 * f2 - f3 c = f1 - f !Decide minimum curvature necessary for treating problem as quadratic: f_scale = MAX(ABS(f1), ABS(f2), ABS(f3)) dimensional_curvature_noise = f_scale * dimensionless_curvature_noise IF (ABS(a) > dimensional_curvature_noise) THEN ! normal case; quadratic problem discriminant = b**2 - 4.0 * a * c IF (discriminant < 0.0) THEN ! no solution number = 0 p1 = 0.0 ; p2 = 0.0 ! to define output variables and avoid confusion ELSE IF (discriminant == 0.0) THEN ! osculation; double solution at one point. p1 = -b / (2.0 * a) p2 = p1 IF ((p1 >= 0.0).AND.(p1 <= 1.0)) THEN number = 2 ELSE ! out of range number = 0 END IF ELSE ! discriminant > 0; two solutions p1 = (-b - SQRT(discriminant)) / (2.0 * a) p2 = (-b + SQRT(discriminant)) / (2.0 * a) IF ((p1 >= 0.0).AND.(p1 <= 1.0)) THEN ! p1 is valid IF ((p2 >= 0.0).AND.(p2 <= 1.0)) THEN number = 2 ELSE number = 1 END IF ELSE ! p1 is not valid IF ((p2 >= 0.0).AND.(p2 <= 1.0)) THEN number = 1 ! now, swap solutions, putting good one in p1 t = p1 ! save out-of-range solution p1 = p2 ! put in-range solution in p1 p2 = t ! put out-of-range solution in p2 ELSE number = 0 END IF END IF ENDIF ! discriminant negative, zero, positive ELSE ! a == 0.0 ; a linear problem: b * p + c = 0 b = f3 - f1 ! slightly redefined; guaruntees that linear function ends at f3 IF (b == 0.0) THEN number = 0 p1 = 0.0 ; p2 = 0.0 ! to define output variables and avoid confusion ELSE ! one solution, though not necessarily in-range p1 = -c / b p2 = 0.0 IF ((p1 >= 0.0).AND.(p1 <= 1.0)) THEN number = 1 ELSE number = 0 END IF END IF ! b == 0 or not END IF ! quadratic or linear problem END SUBROUTINE Value_On_3Node_Side END MODULE Map_Tools !=========================================================