PROGRAM RetroMap4 ! ! (RetroMap, version 4, for use with version 4 of Restore) ! ! Graphical part of the RESTORE group of ! palinspastic and paleotectonic programs. ! Reads basemap (.dig) files in (lon,lat) format ! and/or gridded-data (.grd) files for display, ! finite-element-grid (.feg) files ! defining finite strains over time, nodal ! velocity (.vel) files, and various kinds of ! fault/paleomagnetic/stress data (.rst) files, ! with embedded histories of slip/movement/rotation, ! and creates .ai graphics files containing maps, ! in a choice of 10 different map projections. ! ! by Peter Bird ! Department of Earth, Planetary, and Space Sciences ! University of California ! Los Angeles, CA 90095-1567 ! pbird@epss.ucla.edu ! ! August 1997 - August 1999; REAL*8 update July 2015; ! overlay of initiation/termination ages added 2016.08; ! better selection of elements for net strain and rotation ! maps added 2017.11; Geologic Map of North America 2018.10; ! minor corrections and improvements through November 2020. ! !(c) Copyright 1997, 1998, 1999, 2015, 2016, 2017, 2018, 2020 by ! Peter Bird and the Regents of the University of California. ! USE DAdobe_Illustrator ! provided in separate file DAdobe_Illustrator.f90 USE DMap_Projections ! provided in separate file DMap_Projections.f90 USE DMap_Tools ! provided in separate file DMap_Tools.f90 !NOTE that CONTAINed SUBROUTINE FE_Strain, below, also uses one routine from ! either IMSL (International Mathematics Subroutine Library), OR one from ! mkl95_LAPACK (Math Kernel Library, 1995 edition; LAPACK portion). ! The USE statement is inside that routine. USE DFLIB, ArcQQ => Arc ! Using GETFILEINFOQQ, part of DFLIB of ! DIGITAL Visual Fortran which provides names of files ! matching spec.s like "F*.dig". Helps user select correct file. ! If no substitute is available on your system when you compile, ! just comment-out SUBROUTINE File_List (and any CALLs to it). ! ALSO using BEEPQQ to sound PC speaker when tasks are done; ! again, this can simply be omitted if there is no substitute. ! However, not using ellipse-drawing routine ARC; I have my own ! Arc function in module Map_Projections. So, it is renamed ArcQQ. !TYPES IMPLICIT NONE CHARACTER(1), PARAMETER :: tab = CHAR(9) ! special "HT" tab character in ASCII sequence CHARACTER(1), DIMENSION(:), ALLOCATABLE :: SHR_c1 CHARACTER*1 :: c1, dip_byte, first_byte, offset_c1 CHARACTER*3 :: c3 CHARACTER*3, DIMENSION(:,:), ALLOCATABLE :: bitmap CHARACTER*4 :: trace_number_c4 CHARACTER*5 :: c5 CHARACTER*6 :: c6, c6t1, c6t2 CHARACTER*7 :: c7 CHARACTER*8 :: c8, number8, unit_symbol CHARACTER*10 :: age_in_Ma_text, color_name, string10 CHARACTER*12 :: element_scalar_units, grid_units, node_scalar_units CHARACTER*20 :: keyword, old_keyword ! although probably only using first 7 bytes: OUTCROP, CONTACT, DIKE, FAULT, ... CHARACTER*40 :: c40 CHARACTER*47 :: c47 CHARACTER*50 :: c50 CHARACTER*78 :: c78 CHARACTER*80 :: age_line = ' ', bottom_line_memo = ' ', c_rst_file = ' ', c_rst_pathfile = ' ', & & element_scalar_feg_file = ' ', element_scalar_feg_pathfile = ' ', & & element_scalar_format = ' ', & & f_rst_file = ' ', f_rst_pathfile = ' ', & & feg_file = ' ', feg_pathfile = ' ', & & GMNA_file = ' ', GMNA_pathfile = ' ', grd1_file = ' ', grd1_pathfile = ' ', grd2_file = ' ', grd2_pathfile = ' ', & & keyword_line = ' ', & & line = ' ', & & lines_basemap_file = ' ', lines_basemap_pathfile = ' ', & & new_feg_file = ' ', new_feg_pathfile = ' ', & & node_scalar_feg_file = ' ', node_scalar_feg_pathfile = ' ', & & old_feg_file = ' ', old_feg_pathfile = ' ', & & path_in = ' ', path_out = ' ', p_rst_file = ' ', p_rst_pathfile = ' ', & & polygons_basemap_file = ' ', polygons_basemap_pathfile = ' ', & & s_rst_file = ' ', s_rst_pathfile = ' ', SHR_file = ' ', SHR_pathfile = ' ', & & strain_feg_file = ' ', strain_feg_pathfile = ' ', & & stress_feg_file = ' ', stress_feg_pathfile = ' ', & & tabbed_file = ' ', tabbed_pathfile = ' ', temp_path_in = ' ', top_line_memo = ' ', traces_file = ' ', traces_pathfile = ' ', & & unit_line = ' ', & & vel_file = ' ', vel_pathfile = ' ' CHARACTER*132 :: bottom_line = ' ', line132 = ' ', long_line = ' ', top_line = ' ' CHARACTER*132, DIMENSION(20) :: titles CHARACTER*134 :: c134 = ' ', & & c_rst_format = ' ', c_rst_titles = ' ', & & f_rst_format = ' ', f_rst_titles = ' ', & & p_rst_format = ' ', p_rst_titles = ' ', & & s_rst_format = ' ', s_rst_titles = ' ' INTEGER :: begin_or_end_int, bitmap_color_mode, bitmap_height, bitmap_width, bitmap_shading_mode, & & c_rst_count, choice, distance_method, & & element_scalar_method, element_scalar_zeromode, & & gap_index, GMNA_pass, group, grd1_ncols, grd1_nrows, grd2_ncols, grd2_nrows, & & high_trace, & & i, i1, i2, icycle, iele, ios, irow, & & j, j1, j2, jcol, jp, jp1, & & k, l, l_, last_byte, ln_area_method, lp, & & m, ma, Ma_index, mb, method, minutes, model_is_unfinished, mosaic_count, & & n, na, nb, ncols, new_numel, nfl, node_scalar_choice, node_scalar_method, & & np1, nrows, nseg, number_of_dts, number_of_tabs, numel, numnod, & & offered_step_j, old_mosaic_count, old_numel, old_overlay_count, overlay_count, & & p_rst_count, part_index, part_1_index, path_length, plotting_step_i, points_in_trace, & & query_index, & & read_status, rotation_method, rotationrate_method, rotationrate_selection_method, & & s_rst_count, sample_length, segments_in_SHR, sense_int, star_index, strain_thinner, & & strainrate_mode012, stress_thinner, & & title_choice, title_count, trace_index, train_length, & & vector_thinner, velocity_method INTEGER, DIMENSION(10) :: mosaic_choice, overlay_choice INTEGER, DIMENSION(132) :: tab_bytes ! within in line132; no more than 132 entries possible INTEGER, DIMENSION(:,:), ALLOCATABLE :: neighbor INTEGER, DIMENSION(:,:), ALLOCATABLE :: nodef INTEGER, DIMENSION(:,:), ALLOCATABLE :: nodes, new_nodes, old_nodes LOGICAL :: add_titles, also_plot_faulted_elements, any_model_unfinished, bottom, cold_start, & & distance_km_lowblue, do_more_mosaics, do_more_overlays, & & do_mosaic, do_overlay, & & element_scalar_lowblue, & & e1h_partitioned, e2h_partitioned, err_partitioned, & & got_any_stars, got_stars, grd1_lonlat, grd2_lonlat, & & grid_lowblue, grd1_success, grd2_success, & & in_ok, latter_mosaic, ln_area_lowblue, lt, & & mated, more_ai, more_dig, more_feg, more_grd, more_info, more_map, more_rst, more_vel, & & neotec, node_scalar_lowblue, & & only_stressed, & & p_rst_includes_model, paleotec, plot_this, polygons, problem, & & restored, right, rotation_degrees_lowblue, rotationrate_lowblue, & & shaded_relief, site_moved_North, skip_0_contour, solid, starting_new_area, success, suggest_logical, & & trace_number, try_again, & & use_this_datum, use_this_model_rate, & & velocity_lowblue, virgin, visible LOGICAL(1), DIMENSION(:), ALLOCATABLE :: before_and_after_unfaulted LOGICAL(1), DIMENSION(:,:), ALLOCATABLE :: bitmap_success LOGICAL, DIMENSION(:), ALLOCATABLE :: faulting ! are any fault segments (cracks) active in this element? ! (1:numel = element index) LOGICAL, DIMENSION(:), ALLOCATABLE :: selected LOGICAL, DIMENSION(:), ALLOCATABLE :: strained REAL*8, PARAMETER :: bottomlegend_gap_points = 14.0D0 REAL*8, PARAMETER :: cot_thrust_dip = 2.14451D0 ! 1./TAN(25.) REAL*8, PARAMETER :: cot_normal_dip = 0.46631D0 ! 1./TAN(65.) REAL*8, PARAMETER :: rightlegend_gap_points = 14.0D0 REAL*8, PARAMETER :: sec_per_year = 365.25D0 * 24.0D0 * 60.0D0 * 60.0D0 REAL*8, PARAMETER :: s_per_Ma = 1000000.0D0 * 365.25D0 * 24.0D0 * 60.0D0 * 60.0D0 REAL*8 :: above, add_radians, age_in_Ma_real, ahead_radians, allowance_Ma, & & anomaly, azim1h, azimuth_radians, & & below, big_diff, bitmap_color_highvalue, bitmap_color_lowvalue, & & bottomlegend_used_points, brightness, & & C_R8, cross_radians, & & d_vsize_d_phi, d_vsize_d_theta, & & deg1h, del_az_for_90pc, delta_t_Ma, dip_degrees, & & du_scale_km, du_scale_points, dv_scale_mma, dv_scale_points, & & distance_km_interval, distance_km_midvalue, & & e_end_lat, e_end_lon, Elon, element_scalar_interval, element_scalar_midvalue, & & equat, eps1h, eps2h, err, e1h, e2h, & & fin, fout, fx1, fx2, fy1, fy2, & & GMNA_epoch_Ma, & & grd1_d_EW, grd1_d_lat, grd1_d_lon, grd1_d_x, grd1_d_y, grd1_x_max, grd1_x_min, grd1_y_max, grd1_y_min, & & grd2_d_EW, grd2_d_lat, grd2_d_lon, grd2_d_x, grd2_d_y, grd2_x_max, grd2_x_min, grd2_y_max, grd2_y_min, & & grd1_lat_max, grd1_lat_min, grd1_lon_max, grd1_lon_min, grd1_lon_range, & & grd2_lat_max, grd2_lat_min, grd2_lon_max, grd2_lon_min, grd2_lon_range, & & greatest_age_Ma, green_part, grid_interval, grid_midvalue, & & highest_age_Ma, hr_in_mmpa, & & inner, intensity, & & K_R8, km_model, km_now, km_sigma, km_was, & & lat, lever_points, ln_area_interval, ln_area_midvalue, & & log_stretch_rr, log_stretch_pp, log_stretch_tp, & & log_stretch_tt, log_stretch_1h, log_stretch_2h, lon, & & M_R8, maximum, minimum, model, model_limit_Ma, multiplier, & & Nlat, no_sigma_radius_points, no_sigma_width_points, node_radius_points, node_radius_radians, & & node_scalar_interval, node_scalar_midvalue, & & offset_goal_km, offset_sigma_km, onesigma_radius_points, onesigma_width_points, & & overlap, overlap_star, overlap_Ma, overlap_threshold_Ma, outer, & & paleolatitude_factor, p_rst_radius_points, p_rst_width_points, plat, plon, & & R, radians, radius, rate, ref_e3_minus_e1_persec, ref_lns3_minus_lns1, & & relevance, rightlegend_used_points, RMS_slope, rotate_radians, & & rotation_degrees_interval, rotation_degrees_midvalue, & & rotationrate, rotationrate_interval, rotationrate_midvalue, r1t, r2t, & & s1, s2, s3, section_width_points, section_width_radians, segment_width_points, sigma, & & slope, strain_diameter_points, strainrate_diameter_points, sum, & & s1_size_points, s1h_interp_points, s1h_azim_degrees, s1h_sigma_degrees, & & sum_of_dts, & & t, t_Ma, t_max_Ma, t_min_Ma, tt1_Ma, tt2_Ma, t1_Ma, t2_Ma, & & t1, t2, t3, t4, theta_, tick_azimuth, tick_points, & & twosigma_radius_points, twosigma_width_points, & & u1theta, u1phi, u2theta, u2phi, & & v_East_mps, v_mma, v_mma_datum, v_mma_model, & & v_mps, v_South_mps, value, velocity_epoch_Ma, velocity_my, & & v1E, v1E_mma, v2E, v2E_mma, v3E, v3E_mma, & & v1S, v1S_mma, v2S, v2S_mma, v3S, v3S_mma, & & velocity_interval, velocity_midvalue, vsize, & & w_end_lat, w_end_lon, wedge_radius_radians, & & x_max, x_meters, x_min, x_points, xap, xbp, xcp, xep, & & x0p, x1_points, x1p, x2_points, x2p, x3p, x4p, & & y_max, y_meters, y_min, y_points, Y_R8, yap, ybp, ycp, yep, & & y0p, y1_points, y1p, y2_points, y2p, y3p, y4p REAL*8, DIMENSION(3) :: e_uvec, omega_uvec, pole_uvec, tvec, & & uvec, uvec1, uvec2, uvec3, uvec4, uvec_saved, & & w_uvec REAL*8, DIMENSION(3) :: eps_dot REAL*8, DIMENSION(3,2,2,2):: dG REAL*8, DIMENSION(3,2,2) :: G REAL*8, DIMENSION(3,7) :: Gauss_point REAL*8, DIMENSION(:), ALLOCATABLE :: a_ REAL*8, DIMENSION(:,:),ALLOCATABLE :: bitmap_value REAL*8, DIMENSION(:,:),ALLOCATABLE :: center REAL*8, DIMENSION(:), ALLOCATABLE :: clockwise_anomaly_degrees CHARACTER*1, DIMENSION(:,:), ALLOCATABLE :: component_sense REAL*8, DIMENSION(:), ALLOCATABLE :: e3_minus_e1_persec REAL*8, DIMENSION(:), ALLOCATABLE :: element_scalar REAL*8, DIMENSION(:), ALLOCATABLE :: extension_km REAL*8, DIMENSION(:,:),ALLOCATABLE :: f_center_uvec REAL*8, DIMENSION(:,:),ALLOCATABLE :: fdip REAL*8, DIMENSION(:,:),ALLOCATABLE :: grid1, grid2 REAL*8, DIMENSION(:,:),ALLOCATABLE :: log_stretch REAL*8, DIMENSION(:), ALLOCATABLE :: node_scalar REAL*8, DIMENSION(:,:),ALLOCATABLE :: new_node_uvec REAL*8, DIMENSION(:,:),ALLOCATABLE :: node_uvec ! 3-component unit vector pointing from center of planet ! to a node position on the surface. Like all uvec's, uses ! coordinate axes x = (0E, 0N), y = (90E, 0N), z = (90N). !(1:3 = x,y,z; 1:numel = element index ) REAL*8, DIMENSION(:,:),ALLOCATABLE :: old_node_uvec REAL*8, DIMENSION(:), ALLOCATABLE :: omega_degperMa ! (numel) REAL*8, DIMENSION(:), ALLOCATABLE :: paleolatitude_anomaly_degrees CHARACTER*1, DIMENSION(:), ALLOCATABLE :: plot_sense REAL*8, DIMENSION(:), ALLOCATABLE :: s_azim_now ! (integrated) azimuth of most compressive horizontal principal stress, ! in radians clockwise from North (in the reference frame ! used to define velocity boundary conditions) !(1:s_rst_count = paleostress site index) CHARACTER(5), DIMENSION(:), ALLOCATABLE :: s_code ! master-map location memo for each paleostress datum ! (1:s_rst_count = paleostress index) REAL*8, DIMENSION(:), ALLOCATABLE :: s_sigma_ ! standard deviation of azimuth of most compressive ! horizontal principal stress, in radians !(1:s_rst_count = paleostress site index) REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: s_site_now ! current location of paleostress site (integrated); ! Cartesian unit vector from Earth center: ! (1:3 = x,y,z; 1:2 = site,neighbor@azimuth_cw_from_N; ! 1:s_rst_count = paleostress site index) LOGICAL(1), DIMENSION(:), ALLOCATABLE :: s_stage ! .TRUE. indicates that paleostress is valid anytime ! from s_t_max to s_t_min (not just SOME time) !(1:s_rst_count = paleostress site index) REAL*8, DIMENSION(:), ALLOCATABLE :: s_t_max ! maximum age of paleostress, in s ! (1:s_rst_count = paleostress site index) REAL*8, DIMENSION(:), ALLOCATABLE :: s_t_min ! minimum age of paleostress, in s ! (1:s_rst_count = paleostress site index) REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: segments CHARACTER*1, DIMENSION(:), ALLOCATABLE :: sense REAL*8, DIMENSION(:), ALLOCATABLE :: SHR_rate_mmpa REAL*8, DIMENSION(:), ALLOCATABLE :: SHR_ELon1 REAL*8, DIMENSION(:), ALLOCATABLE :: SHR_ELon2 REAL*8, DIMENSION(:), ALLOCATABLE :: SHR_NLat1 REAL*8, DIMENSION(:), ALLOCATABLE :: SHR_NLat2 REAL*8, DIMENSION(:,:), ALLOCATABLE :: strain_table REAL*8, DIMENSION(:,:), ALLOCATABLE :: strainrate ! strain-rate of finite element, in /s. ! It may or may not include fault-related strain-rate, ! depending on value of "choice": 8, 9, or 10. ! (1:3 = theta-theta or N-S, theta-phi or SE, phi-phi or E-W; ! 1:numel = element index) LOGICAL, DIMENSION(:), ALLOCATABLE :: s1h_known ! was Restore able to interpolate a sigma1h direction for this ! element, with 90%-confidence range of <= +-45 degrees? ! (1:numel = element index) REAL*8, DIMENSION(:), ALLOCATABLE :: s1h_azim_radians ! sigm1h azimuth (clockwise from North) in radians, as interpolated ! by Restore (if possible; see s1h_known). ! (1:numel = element index) REAL*8, DIMENSION(:), ALLOCATABLE :: s1h_sigma_radians ! standard deviation of sigm1h, in radians interpolated ! by Restore (if possible; see s1h_known). ! (1:numel = element index) REAL*8, DIMENSION(:), ALLOCATABLE :: trace_parallel_mma, trace_parallel_km, & & trace_perpendicular_mma, trace_perpendicular_km, & & trace_oblique_mma, trace_oblique_km ! properties of fault traces, indexed by number (e.g., 1034 in F1034N) REAL*8, DIMENSION(:), ALLOCATABLE :: train ! train = temporary 1-D array for sending values to Histogram REAL*8, DIMENSION(:), ALLOCATABLE :: vsize_mma REAL*8, DIMENSION(:), ALLOCATABLE :: vw !========================================================== DATA Gauss_point / & & 0.3333333333333333D0, 0.3333333333333333D0, 0.3333333333333333D0, & & 0.0597158733333333D0, 0.4701420633333333D0, 0.4701420633333333D0, & & 0.4701420633333333D0, 0.0597158733333333D0, 0.4701420633333333D0, & & 0.4701420633333333D0, 0.4701420633333333D0, 0.0597158733333333D0, & & 0.7974269866666667D0, 0.1012865066666667D0, 0.1012865066666667D0, & & 0.1012865066666667D0, 0.7974269866666667D0, 0.1012865066666667D0, & & 0.1012865066666667D0, 0.1012865066666667D0, 0.7974269866666667D0/ !========================================================== !GPBgo WRITE (*,"(//' ----------------------------------------------------------------------'& &//' RetroMap4'& &/' (RetroMap version 4, for use with version 4 of Restore)'& &//' This is the graphics part of the Restore package of paleotectonic'& &/' and palinspastic programs.'& &//' INPUT files may include:'& &/' * AI7frame.ai (model .ai file; always required);'& &/' * .dig files (digitised basemaps);'& &/' * .grd files (gridded datasets);'& &/' * .feg files (finite element grids);'& &/' * .vel files (velocities of nodes);'& &/' * .rst files (fault-slip, paleomagnetic, and stress data files);'& &//' OUTPUT FILES ARE MAPS OF PRESENT OR PAST STRUCTURE AND TECTONICS,'& &/' in a choice of 10 different map projections!'& &/' They have .ai extensions and are intended to be read by Adobe'& &/' Illustrator 7+ (including CSn) for Windows; or by Adobe'& &/' Illustrator 4 for Windows 3.1. In AI they can be edited and'& &/' annotated before they are printed on a wide variety of devices.'& &//' By Peter Bird, UCLA, August 1999; REAL*8 update 27 July 2015,'& &/' with fault initiation/termination symbols added August 2016.'& &/' ----------------------------------------------------------------------')") CALL DPrompt_for_Logical('Do you want more information about input and output files?',.FALSE.,more_info) IF (more_info) THEN CALL DPrompt_for_Logical('Do you want more information about .ai files?',.TRUE.,more_ai) IF (more_ai) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About .ai Files'& &//' The .ai files created by this program can be read by:'& &/' * Adobe Illustrator 7+ (including CSn) for Windows or MacOS, or'& &/' * Adobe Illustrator 4 for Windows 3.1'& &/' (except that AI4 cannot read files with embedded bitmaps).'& &//' In Adobe Illustrator you can view, edit, annotate, and print the maps.'& &//' A model .ai file is needed to provide the boiler-plate PostScript'& &/' header that all .ai files carry. Therefore, file AI7Frame.ai'& &/' must be in a location accessible by this program. You will have'& &/' a chance to specify the path if it is not in your current directory.'& &//' All .ai files are transmitted (e.g., by FTP over the Internet) as'& &/' ASCII, not as binary. This is because different computer systems'& &/' have different ways of marking the end of a line.'& &/' ----------------------------------------------------------------------')") END IF ! more_ai CALL DPrompt_for_Logical('Do you want more information about .dig files?',.TRUE.,more_dig) IF (more_dig) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About .dig Files'& &/' The box below contains the first 12 lines of a typical .dig file.'& &/' ----------------------------- Notice:'& &/' |F0469N | <- a title line'& &/' | -1.05875E+02,+3.87835E+01 | <- 1st (lon,lat) pair in segment'& &/' | -1.05849E+02,+3.87731E+01 |'& &/' | -1.05826E+02,+3.87534E+01 |'& &/' | -1.05801E+02,+3.87355E+01 | <-(segment can have any number of'& &/' | -1.05777E+02,+3.87195E+01 | points)'& &/' | -1.05769E+02,+3.87104E+01 |<- last (lon,lat) pair in segment'& &/' |*** END OF SEGMENT *** |<- standard end record (required)'& &/' |F0453N |<- title of next segment (optional)'& &/' | -1.05023E+02,+3.76613E+01 |'& &/' | -1.05040E+02,+3.76794E+01 |'& &/' | -1.05050E+02,+3.76995E+01 | et cetera, et cetera......'& &/' -----------------------------'& &/' ----------------------------------------------------------------------')") END IF ! more_dig IF (more_dig) CALL DPrompt_for_Logical('Do you want more information about .dig files?',.TRUE.,more_dig) IF (more_dig) THEN WRITE (*,"(//' ----------------------------------------------------------------------'& &/' More About .dig Files'& &/' File-naming convention: Those .dig files containing fault traces'& &/' MUST have a filename beginning with F (or f). Other .dig files'& &/' with any other kind of basemap feature are NOT ALLOWED to have'& &/' names beginning with F (or f).'& &//' Titles of segments: Optional for .dig files used as basemaps; but,'& &/' .dig files containing fault traces have a special convention:'& &/' title line F0408N indicates Fault #0408 (which index ties to'& &/' the Faults.rst file(s)), which is a Normal fault, for example.'& &/' Where titles are optional, multiple title lines are permitted.'& &/' ----------------------------------------------------------------------')") END IF ! more_dig IF (more_dig) CALL DPrompt_for_Logical('Do you want more information about .dig files?',.TRUE.,more_dig) IF (more_dig) THEN WRITE (*,"(//' ----------------------------------------------------------------------'& &/' More About .dig Files'& &/' Number formats: Column 1 blank. Column 2 holds sign. Columns 3-13'& &/' hold the first real number, preferably in scientific notation.'& &/' Column 14 is a comma. Column 15 is a sign. Columns 16-26 hold'& &/' the second real number. To write such data from a Fortran program,'& &/' use FORMAT(1X,SP,1P,E12.5,'','',E12.5).'& &/' (lon,lat) data has longitude before latitude in each pair. Units are'& &/' degrees (e.g., 24 degrees 17 minutes 5 seconds -> 24.2847 degrees).'& &/' East longitude is +, West is -. North latitude is +, South is -.'& &/' (x,y) data can be in units of meters, kilometers, centimeters, miles,'& &/' or feet. However, it MUST give the actual sizes of features on'& &/' the planet, NOT their reduced sizes on some map! Any origin and'& &/' any orientation of the (x,y) system is permissible, as long as'& &/' the +y axis is 90 degrees counterclockwise from the +x axis.'& &/' NOTE that (x,y) data must be converted to (lon,lat) by Projector'& &/' before it can be read and used by this program, RetroMap4.'& &/' ----------------------------------------------------------------------')") END IF ! more_dig CALL DPrompt_for_Logical('Do you want information about .grd files?',.TRUE.,more_grd) IF (more_grd) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Gridded Data (.grd) Files'& &//' These files contain scalar data values on a regular rectangular grid,'& &/' in (lon,lat) space.'& &//' Such data may be added to maps, although it is not used in computing'& &/' or in scoring finite-element models.'& &//' The first line has 3 numbers: lon_min, d_lon, lon_max;'& &/' the 2nd also has 3 numbers: lat_min, d_lat, lat_max.'& &/' Following lines give the gridded data in text order, i.e., beginning'& &/' with the NW corner, going W->E along the North row, then W->E '& &/' along the 2nd row, etc. The number and position of line breaks'& &/' is not important in this part of the file.'& &//' ----------------------------------------------------------------------')") END IF ! more_grd CALL DPrompt_for_Logical('Do you want more information about .feg files?',.TRUE.,more_feg) IF (more_feg) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Finite Element Grid (.feg) Files'& &//' Finite element grids are composed of 3-node spherical triangles'& &/' (Kong & Bird, 1995) and are created and edited by program OrbWin'& &/' (or OrbWeave). An .feg file contains nodal locations and nodal data'& &/' (mu_, the uncertainty in nominally zero strain-rates, in 1/s).'& &/' They also contain topological connections of the nodes to form'& &/' elements.'& &//' Program Resstore deforms these over time, thus creating many similar'& &/' .feg files, distinguished by small differences in their names:'& &/' Example: in file WUS10150.feg,'& &/' WUS (characters 1-3) identifies the Restoration project.'& &/' 1 (character 4) identifies a group with the same topology'& &/' 01 (characters 5-6) identifies iteration #1'& &/' 50 (characters 7-8) identifies the restoration time: 50 Ma.'& &/' When hand-editing is needed due to excess strain, WUS10150.feg'& &/' is edited to produce WUS2.feg. This will then be run and'& &/' deformed to WUS20155.feg, etc. It is meaningless to compute'& &/' strain by comparing two grids of different topology!'& &//' ----------------------------------------------------------------------')") END IF ! more_feg CALL DPrompt_for_Logical('Do you want more information about .vel files?',.TRUE.,more_vel) IF (more_vel) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Velocity (.vel) Files'& &//' These files contain velocities of nodes. The first 3 lines'& &/' contain comments with the geologic age, iteration number, date'& &/' of computation, and the .feg grid files that velocities refer to.'& &//' Later lines contain the velocity components v_theta (South) and'& &/' v_phi (East), in meters/second.'& &//' Velocity is always expressed as the movement from old --> young,'& &/' just as it is today, in neotectonic modeling.'& &//' All the rules described above for naming .feg files also apply to'& &/' these .vel files.'& &//' ----------------------------------------------------------------------')") END IF ! more_vel CALL DPrompt_for_Logical('Do you want more information about .rst files?',.TRUE.,more_rst) IF (more_rst) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About ReSTore Data Files (.rst)'& &//' These files contain very detailed and dense information about fault'& &/' offsets, paleomagnetic latitude changes and vertical-axis'& &/' rotations, paleostress indicators, and strain in balanced cross-'& &/' sections.'& &//' For a complete definition of the entries, see extensive comments'& &/' at the beginning of Restore3.f90.'& &//' As Restore runs, it adds computed rate histories in additional'& &/' lines intervening between the original data.'& &//' All the rules described above for naming .feg files also apply to'& &/' these .vel files. There is one additional rule: initial letter'& &/' C = balanced Cross-sections, F = Fault offsets, P = Paleomagnetism,'& &/' and S = paleoStress.'& &//' ----------------------------------------------------------------------')") END IF ! more_rst CALL DPrompt_for_Logical('Do you want more information about map projections?',.TRUE.,more_map) IF (more_map) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Map Projections'& &//' John Parr Snyder (1983) Map projections used by the U.S. Geological'& &/' Survey, U.S. Geological Survey Bulletin, volume 1532.'& &//' G. B. Newton (1985) Computer programs for common map projections,'& &/' U.S. Geological Survey Publication, B-1642, 33 pages.'& &/' '& &/' (Note that I use the simpler spherical-Earth formulas.)'& &//' ----------------------------------------------------------------------')") WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line END IF ! more_map END IF ! more_info !-------------------------(end of Introduction)---------------------- ! ! Basic structure of RetroMap4 is similar to Prompter of Map_Tools: ! (1) Look for memory file RetroMap4.ini in current directory. ! Read in choices made in last use of program. ! If file not found, initialize with defaults. ! (2) Define paths (directories) for input and output. ! (3) Call DPrompter to get page and projection parameters. ! (4) Ask user what elements are desired in the plot. ! For each element, prompt for necessary files, contour ! intervals, etc. UNLIKE DPrompter, RetroMap4 executes ! these requests immediately, so that error messages ! will be more understandable. ! (5) After closing the plot, save RetroMap4.ini with record ! of all the selections made. ! !-------------------------------------------------------------------- !GPBmemory OPEN (UNIT = 11, FILE = 'RetroMap4.ini', STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios == 0) THEN ! RetroMap4.ini was found problem = .FALSE. ! may change below READ (11,"(A)",IOSTAT=ios) path_in problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) path_out problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) old_mosaic_count problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) mosaic_choice ! whole array problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) polygons_basemap_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) grd1_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) grd2_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) bitmap_color_mode problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) shaded_relief problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) bitmap_shading_mode problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) intensity problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) grid_units problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) grid_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) grid_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) grid_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) skip_0_contour problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) element_scalar_method problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) element_scalar_feg_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) element_scalar_units problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) element_scalar_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) element_scalar_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) element_scalar_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) element_scalar_zeromode problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) node_scalar_feg_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) node_scalar_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) node_scalar_choice problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) node_scalar_units problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) node_scalar_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) node_scalar_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) node_scalar_lowblue problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) feg_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) velocity_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) velocity_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) velocity_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) velocity_lowblue problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) old_feg_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) new_feg_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) distance_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) distance_km_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) distance_km_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) distance_km_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotation_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotation_degrees_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotation_degrees_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotation_degrees_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) ln_area_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) ln_area_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) ln_area_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) ln_area_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) old_overlay_count problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) overlay_choice ! whole array problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) lines_basemap_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) traces_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) tick_points problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) node_radius_points problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) vel_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) velocity_my problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) vector_thinner problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) f_rst_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) t_Ma problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) dv_scale_mma problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) dv_scale_points problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) du_scale_km problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) du_scale_points problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) p_rst_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) paleolatitude_factor problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) s_rst_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) t1_Ma problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) t2_Ma problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) s1_size_points problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) stress_feg_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) s1h_interp_points problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) stress_thinner problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) only_stressed problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) strain_feg_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) R problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) strainrate_mode012 problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) ref_e3_minus_e1_persec problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) strainrate_diameter_points problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) strain_thinner problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) ref_lns3_minus_lns1 problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) strain_diameter_points problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) c_rst_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) model_limit_Ma problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) minutes problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) top_line_memo problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) bottom_line_memo problem = problem.OR.(ios /= 0) CLOSE(11) IF (problem) THEN WRITE (*,"(/' ERROR: Bad data, bad format, or missing lines in RetroMap4.ini.')") WRITE (*,"( ' The easiest way to recover from this is to:')") WRITE (*,"( ' (1) Print out RetroMap4.ini')") WRITE (*,"( ' (2) Delete RetroMap4.ini')") WRITE (*,"( ' (3) Restart RetroMap4, and enter your choices manually.')") WRITE (*,"( ' Press [Enter] when ready...'\)") READ (*,"(A)") c1 STOP ' ' END IF ELSE ! no .ini file; use defaults CLOSE (11, IOSTAT = ios) ! just to be sure path_in = ' ' path_out = ' ' old_mosaic_count = 0 mosaic_choice = 1 ! whole array polygons_basemap_file = ' ' grd1_file = ' ' grd2_file = ' ' bitmap_color_mode = 1 shaded_relief = .TRUE. bitmap_shading_mode = 1 intensity = 0.5D0 grid_units = 'm' grid_interval = 0.0D0 grid_midvalue = 0.0D0 grid_lowblue = .TRUE. skip_0_contour = .FALSE. element_scalar_method = 1 element_scalar_feg_file = ' ' element_scalar_units = ' ' element_scalar_interval = 0.0D0 element_scalar_midvalue = 0.0D0 element_scalar_lowblue = .TRUE. element_scalar_zeromode = 0 node_scalar_feg_file = ' ' node_scalar_method = 1 node_scalar_choice = 1 node_scalar_units = ' ' node_scalar_interval = 0.0D0 node_scalar_midvalue = 0.0D0 node_scalar_lowblue = .TRUE. feg_file = ' ' velocity_method = 1 velocity_interval = 0.0D0 velocity_midvalue = 0.0D0 velocity_lowblue = .TRUE. old_feg_file = ' ' new_feg_file = ' ' distance_method = 1 distance_km_interval = 20.0D0 distance_km_midvalue = 100.0D0 distance_km_lowblue = .TRUE. rotation_method = 1 rotationrate_method = 1 rotation_degrees_interval = 5.0D0 rotation_degrees_midvalue = 50.0D0 rotation_degrees_lowblue = .TRUE. ln_area_method = 1 ln_area_interval = 0.2D0 ln_area_midvalue = 0.0D0 ln_area_lowblue = .TRUE. old_overlay_count = 1 overlay_choice = 0 ! whole array overlay_choice(1) = 1 lines_basemap_file = ' ' traces_file = ' ' tick_points = 5.0D0 node_radius_points = 3.0D0 vel_file = ' ' velocity_my = 10.0D0 vector_thinner = 1 f_rst_file = ' ' dv_scale_mma = 35.0D0 dv_scale_points = 24.0D0 du_scale_km = 300.0D0 du_scale_points = 30.0D0 p_rst_file = ' ' paleolatitude_factor = 1.0D0 s_rst_file = ' ' t1_Ma = 0.0D0 t2_Ma = 0.0D0 s1_size_points = 24.0D0 stress_feg_file = ' ' s1h_interp_points = 18.0D0 stress_thinner = 1 only_stressed = .FALSE. strain_feg_file = ' ' R = 6371000.D0 strainrate_mode012 = 2 ref_e3_minus_e1_persec = 5.0D-17 strainrate_diameter_points = 20.0D0 strain_thinner = 1 ref_lns3_minus_lns1 = 0.0D0 strain_diameter_points = 20.0D0 c_rst_file = ' ' minutes = 120 top_line_memo = ' ' bottom_line_memo = ' ' END IF ! .ini file, or defaults? !-------------------------(Define Paths)----------------------------- WRITE (*,"(//' ----------------------------------------------------------------------'& &/' Setting PATHS to Input and Output Files'& &//' RetroMap4 stores its memory in RetroMap4.ini and Map_Tools.ini,'& &/' which are placed in the current directory when RetroMap4 is run.'& &/' Normally, this should be the directory holding RetroMap4.exe.'& &/' This is also the best place to keep AI7Frame.ai.'& &//' However, it is usually good practice to keep the many input files'& &/' and output (graphics) files separate in their own directories.'& &//' When entering the paths below, you may include computer and drive'& &/' identifiers according to the conventions of your system.'& &/' Under Windows, paths should end in ''\''.'& &/' Under Unix, paths should end in ''/''.'& &//' PLEASE TYPE PATH NAMES CAREFULLY; there is no way to validate or'& &/' correct them using standard Fortran 90; errors will crash'& &/' RetroMap4 (at least)!'& &/' ----------------------------------------------------------------------')") 10 CALL DPrompt_for_String('What is the path for your input files?',path_in,path_in) path_in = ADJUSTL(path_in) !warn about apparently-illegal path! --------------------------------------------------- path_length = LEN_TRIM(path_in) IF (path_length > 0) THEN c1 = path_in(path_length:path_length) IF (.NOT.((c1 == '\').OR.(c1 == '/'))) THEN WRITE (*, "(' ERROR: Each path must end in ''\'' (Windows) or ''/'' (Unix)!')") CALL DPrompt_for_Logical('Do you need to re-type this path?', .TRUE., try_again) IF (try_again) GO TO 10 END IF END IF !---------------------------------------------------------------------------------------- 20 CALL DPrompt_for_String('What is the path for your output (.ai graphics) file?',path_out,path_out) path_out = ADJUSTL(path_out) !warn about apparently-illegal path! --------------------------------------------------- path_length = LEN_TRIM(path_out) IF (path_length > 0) THEN c1 = path_out(path_length:path_length) IF (.NOT.((c1 == '\').OR.(c1 == '/'))) THEN WRITE (*, "(' ERROR: Each path must end in ''\'' (Windows) or ''/'' (Unix)!')") CALL DPrompt_for_Logical('Do you need to re-type this path?', .TRUE., try_again) IF (try_again) GO TO 20 END IF END IF !---------------------------------------------------------------------------------------- WRITE (*,"(' IT WILL NOT BE NECESSARY TO TYPE THESE PATHS AGAIN!')") !-------------------------(end of defining paths)-------------------- CALL DPrompter (xy_mode = .FALSE., lonlat_mode = .TRUE., path_out = path_out) !NOTE: Prompter opens AI7Frame.ai, begins new graphics file. ! At this stage, we are ready to write on the page! !-------------------------- MOSAICS ------------------------------ !----- (layers of shaded/colored polygons; mostly opaque) -------- mosaic_count = 0 ! counts number of mosaics in this map latter_mosaic = .FALSE. ! until one has been plotted, below title_count = 0 ! collects possible titles from input files bottomlegend_used_points = 0.0D0 ! records filling of bottom legend, from left rightlegend_used_points = 0.0D0 ! records filling of right legend, from top !GPBmosaics 1000 WRITE(*,"(//' ----------------------------------------------------------------------'& &/' MOSAIC (colored-area) LAYERS AVAILABLE:')") WRITE (*,"(' 1 :: digitised basemap (closed-polygons type)')") WRITE (*,"(' 2 :: colored/shaded bitmap from gridded data')") WRITE (*,"(' 3 :: contour map from gridded data')") WRITE (*,"(' 4 :: discontinuous scalar from .feg (one value per element)')") WRITE (*,"(' 5 :: continuous scalar from .feg (one value per node)')") WRITE (*,"(' 6 :: magnitude of continuous velocity field')") WRITE (*,"(' 7 :: amount of displacement')") WRITE (*,"(' 8 :: vertical-axis rotation (in degrees)')") WRITE (*,"(' 9 :: natural dilatation = ln[area/(former area)]')") WRITE (*,"(' 10 :: Geologic Map of North America')") WRITE (*,"(' 11 :: vertical-axis rotation-rate (in degrees/m.y.)')") WRITE (*,"(' ----------------------------------------------------------------------')") suggest_logical = old_mosaic_count > mosaic_count IF (mosaic_count == 0) CALL DPrompt_for_Logical('Do you want one (or more) of these mosaics?',suggest_logical,do_mosaic) IF (do_mosaic) THEN mosaic_count = mosaic_count + 1 choice = mosaic_choice(mosaic_count) CALL DPrompt_for_Integer('Which mosaic type should be added?',choice,choice) IF ((choice < 1).OR.(choice > 11)) THEN WRITE (*,"(/' ERROR: Please select an integer from the list!')") WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 1000 ELSE mosaic_choice(mosaic_count) = choice ! for memory END IF ! illegal or legal choice SELECT CASE (choice) CASE (1) ! basemap (polygons type) 1010 temp_path_in = path_in !CALL File_List(basemap = .TRUE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = polygons_basemap_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file should be plotted?',polygons_basemap_file,polygons_basemap_file) polygons_basemap_pathfile = TRIM(temp_path_in)//TRIM(polygons_basemap_file) ! gray rectangle for seas goes behind all continental polygons CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') CALL DNew_L12_Path (1, ai_window_x1_points, ai_window_y1_points) CALL DLine_To_L12 (ai_window_x2_points, ai_window_y1_points) CALL DLine_To_L12 (ai_window_x2_points, ai_window_y2_points) CALL DLine_To_L12 (ai_window_x1_points, ai_window_y2_points) CALL DLine_To_L12 (ai_window_x1_points, ai_window_y1_points) CALL DEnd_L12_Path (close = .TRUE., stroke = .FALSE., & & fill = .TRUE.) ! continental polygons are foreground line, background fill CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color (color_name = 'foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') WRITE (*,"(/' Working on basemap....')") polygons = .TRUE. CALL DPlot_Dig (7, polygons_basemap_pathfile, polygons, 21, in_ok) IF (.not.in_ok) GOTO 1010 WRITE (*,"('+Working on basemap....DONE.')") ! possible plot titles: filename, and first 3 lines CALL Add_Title(polygons_basemap_file) OPEN (UNIT = 21, FILE = polygons_basemap_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') DO i = 1, 3 READ (21,"(A)") line READ (line, *, IOSTAT = ios) lon, lat IF (ios /= 0) THEN ! got possible title CALL Add_Title(line) END IF END DO CLOSE (21) CALL BEEPQQ (frequency = 440, duration = 250) ! end of basemap mosaic CASE (2) ! colored/shaded bitmap from gridded dataset(s) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Do you want shaded relief?',shaded_relief,shaded_relief) IF (shaded_relief) THEN WRITE (*,"(/' -------------------------------------------------------')") WRITE (*,"( ' Source of Shaded Relief:')") WRITE (*,"( ' 1 = same dataset as that used to assign colors')") WRITE (*,"( ' 2 = a different dataset (usually a topographic DEM)')") WRITE (*,"( ' -------------------------------------------------------')") 1020 CALL DPrompt_for_Integer('Bitmap shading mode (1 or 2)?',bitmap_shading_mode,bitmap_shading_mode) IF ((bitmap_shading_mode < 1).OR.(bitmap_shading_mode > 2)) THEN WRITE (*,"(' ERROR: Please select 1 or 2')") GOTO 1020 END IF ELSE bitmap_shading_mode = 1 ! only one dataset END IF ELSE ! gray-scale image shaded_relief = .TRUE. bitmap_shading_mode = 1 ! only one dataset END IF 1021 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .TRUE. , & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = grd1_file, & ! & using_path = temp_path_in) IF (bitmap_shading_mode == 1) THEN CALL DPrompt_for_String('Which file should be displayed?',grd1_file,grd1_file) grd2_file = grd1_file ELSE ! bitmap_shading_mode = 2; two .grd files CALL DPrompt_for_String('Which file will determine the colors?',grd1_file,grd1_file) CALL DPrompt_for_String('Which file will be overlain with shaded relief?',grd2_file,grd2_file) END IF grd1_pathfile = TRIM(temp_path_in)//TRIM(grd1_file) grd2_pathfile = TRIM(temp_path_in)//TRIM(grd2_file) OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (bitmap_shading_mode == 1) THEN WRITE(*,"(/' Here are the first 5 lines of the file:' & &/' ----------------------------------------')") ELSE ! bitmap_shading_mode = 2; two .grd files WRITE(*,"(/' Here are the first 5 lines of the file to be colored:' & &/' -----------------------------------------------------')") END IF DO i = 1, 5 READ (21,"(A)", IOSTAT = ios) line WRITE (*,"(' ',A)") TRIM(line(1:79)) END DO WRITE(*,"(' -----------------------------------------------------')") CLOSE (21) CALL DPrompt_for_Logical('Is this grid defined in (lon,lat) coordinates?',.TRUE.,grd1_lonlat) OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios) problem = (ios /= 0) IF (grd1_lonlat) THEN READ (21, *, IOSTAT = ios) grd1_lon_min, grd1_d_lon, grd1_lon_max problem = problem .OR. (ios /= 0) IF (ABS(grd1_lon_max - grd1_lon_min - 360.0D0) < 0.01D0) THEN grd1_lon_range = 360.0D0 ELSE grd1_lon_range = DEasting(grd1_lon_max - grd1_lon_min) END IF READ (21, *, IOSTAT = ios) grd1_lat_min, grd1_d_lat, grd1_lat_max problem = problem .OR. (ios /= 0) grd1_ncols = 1 + NINT((grd1_lon_max - grd1_lon_min) / grd1_d_lon) grd1_nrows = 1 + NINT((grd1_lat_max - grd1_lat_min) / grd1_d_lat) ELSE ! (x,y) format READ (21, *, IOSTAT = ios) grd1_x_min, grd1_d_x, grd1_x_max problem = problem .OR. (ios /= 0) grd1_x_min = grd1_x_min * mt_meters_per_user grd1_d_x = grd1_d_x * mt_meters_per_user grd1_x_max = grd1_x_max * mt_meters_per_user READ (21, *, IOSTAT = ios) grd1_y_min, grd1_d_y, grd1_y_max problem = problem .OR. (ios /= 0) grd1_y_min = grd1_y_min * mt_meters_per_user grd1_d_y = grd1_d_y * mt_meters_per_user grd1_y_max = grd1_y_max * mt_meters_per_user grd1_ncols = 1 + NINT((grd1_x_max - grd1_x_min) / grd1_d_x) grd1_nrows = 1 + NINT((grd1_y_max - grd1_y_min) / grd1_d_y) END IF problem = problem .OR. (grd1_nrows < 2) .OR. (grd1_ncols < 2) ALLOCATE ( grid1(grd1_nrows, grd1_ncols) ) READ (21, *, IOSTAT = ios) ((grid1(i,j), j = 1, grd1_ncols), i = 1, grd1_nrows) problem = problem .OR. (ios /= 0) CLOSE (21) IF (problem) THEN WRITE (*,"(' ERROR: ',A' defective in structure or truncated.')") TRIM(grd1_file) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line DEALLOCATE ( grid1 ) GOTO 1021 END IF CALL Add_Title(grd1_file) train_length = grd1_nrows * grd1_ncols ALLOCATE ( train(train_length) ) WRITE (*,"(/' Here is the distribution of VISIBLE values:' )") k = 0 ! will count visible (in map window) grid points DO irow = 1, grd1_nrows ! top to bottom DO jcol = 1, grd1_ncols ! left to right !decide whether this point is visible in the window IF (grd1_lonlat) THEN lon = grd1_lon_min + (jcol - 1) * grd1_d_lon lat = grd1_lat_max - (irow - 1) * grd1_d_lat CALL DLonLat_2_Uvec (lon, lat, uvec) CALL DProject (uvec = uvec, x = x_meters, y = y_meters) ! but no 'guide =' ELSE ! xy data grid x_meters = grd1_x_min + (jcol - 1) * grd1_d_x y_meters = grd1_y_max - (irow - 1) * grd1_d_y END IF ! lonlat, or simple xy CALL DMeters_2_Points (x_meters,y_meters, x_points,y_points) c1 = DIn_Window (x_points, y_points) visible = (c1 == 'I').OR.(c1 == 'B') ! Inside, or Border IF (visible) THEN k = k + 1 train(k) = grid1(irow,jcol) END IF ! visible END DO ! columns of gridded data END DO ! rows of gridded data CALL Histogram (train, k, .FALSE., maximum, minimum) DEALLOCATE ( train ) IF (ai_using_color) THEN CALL DPrompt_for_String('What are the units of these values?',TRIM(ADJUSTL(grid_units)),grid_units) 1022 WRITE (*,"(/' How shall the bitmap be colored?')") WRITE (*,"( ' mode 1: Munsell: smooth spectrum')") 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 DPrompt_for_Integer('Which coloring mode?',bitmap_color_mode,bitmap_color_mode) IF ((bitmap_color_mode < 1).OR.(bitmap_color_mode > 4)) THEN WRITE (*,"(/' ERROR: Select mode index from list!' )") GOTO 1022 END IF bitmap_color_lowvalue = minimum bitmap_color_highvalue = maximum IF (bitmap_color_mode <= 2) THEN ! need to pin down ends of spectrum 1023 CALL DPrompt_for_Real('What (low) value anchors the blue end of the spectrum?',bitmap_color_lowvalue,bitmap_color_lowvalue) CALL DPrompt_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 exceed blue value!' )") GOTO 1023 END IF ! bad range ELSE IF (bitmap_color_mode == 4) THEN IF (grid_interval == 0.0D0) THEN grid_interval = (maximum - minimum) / ai_spectrum_count grid_midvalue = (maximum + minimum) / 2.0D0 END IF 1024 CALL DPrompt_for_Real('What contour interval do you wish?',grid_interval,grid_interval) IF (grid_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") grid_interval = (maximum - minimum) / ai_spectrum_count GOTO 1024 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',grid_midvalue,grid_midvalue) CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) END IF ! bitmap_color_mode = 1,2 versus 4 END IF ! ai_using_color, or not IF (shaded_relief) THEN ! get topography data into grid2: IF (bitmap_shading_mode == 1) THEN ! grid2 == grid1 grd2_lonlat = grd1_lonlat grd2_lon_min = grd1_lon_min grd2_d_lon = grd1_d_lon grd2_lon_max = grd1_lon_max grd2_lon_range = grd1_lon_range grd2_lat_min = grd1_lat_min grd2_d_lat = grd1_d_lat grd2_lat_max = grd1_lat_max grd2_x_min = grd1_x_min grd2_d_x = grd1_d_x grd2_x_max = grd1_x_max grd2_y_min = grd1_y_min grd2_d_y = grd1_d_y grd2_y_max = grd1_y_max grd2_nrows = grd1_nrows grd2_ncols = grd1_ncols ALLOCATE ( grid2( grd2_nrows, grd2_ncols) ) grid2 = grid1 ! whole array copy ELSE ! bitmap_shading_mode == 2; read grid2 WRITE(*,"(/' Here are the first 5 lines of the file with the shaded relief:' & &/' --------------------------------------------------------------')") OPEN (UNIT = 21, FILE = grd2_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') DO i = 1, 5 READ (21,"(A)", IOSTAT = ios) line WRITE (*,"(' ',A)") TRIM(line(1:79)) END DO WRITE(*,"(' --------------------------------------------------------------')") CLOSE (21) CALL DPrompt_for_Logical('Is this grid defined in (lon,lat) coordinates?',.TRUE.,grd2_lonlat) OPEN (UNIT = 21, FILE = grd2_pathfile, STATUS = 'OLD', IOSTAT = ios) problem = (ios /= 0) IF (grd2_lonlat) THEN READ (21, *, 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.0D0) < 0.01D0) THEN grd2_lon_range = 360.0D0 ELSE grd2_lon_range = DEasting(grd2_lon_max - grd2_lon_min) END IF READ (21, *, 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 (21, *, 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 (21, *, 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 (21, *, IOSTAT = ios) ((grid2(i,j), j = 1, grd2_ncols), i = 1, grd2_nrows) problem = problem .OR. (ios /= 0) CLOSE (21) IF (problem) THEN WRITE (*,"(' ERROR: ',A' defective in structure or truncated.')") TRIM(grd2_file) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line DEALLOCATE ( grid2 ) GOTO 1021 END IF ! problem with grd2 END IF ! bitmap_shading_mode 1 or 2 CALL DPrompt_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.0D0) RMS_slope = 1.0D0 ! prevent /0.0 END IF ! shaded_relief 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 1025 CALL DPrompt_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 1025 END IF 1026 CALL DPrompt_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 1026 END IF WRITE (*,"(/' Working on bitmap from gridded dataset(s)....')") ALLOCATE ( bitmap(bitmap_height,bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) !Get "value" (basis for color of pixel) from grid1: !Note: Even if .NOT.ai_using_color, we will need i1, i2, j1, j2, etc. IF (bitmap_shading_mode == 1) IF (ai_using_color.OR.(bitmap_shading_mode == 1)) THEN IF (grd1_lonlat) THEN ! must undo map projection CALL DReject (x_meters,y_meters, success, uvec) IF (success) THEN ! rejection worked CALL DUvec_2_LonLat (uvec, lon, lat) !define grd1_success as falling within grid1 grd1_success = (lat >= grd1_lat_min).AND. & & (lat <= grd1_lat_max).AND. & & (DEasting(lon - grd1_lon_min) <= grd1_lon_range) !note: insensitive to longitude cycle IF (grd1_success) THEN i1 = 1 + (grd1_lat_max - lat) / grd1_d_lat i1 = MAX(1,MIN(i1,grd1_nrows-1)) i2 = i1 + 1 fy2 = ((grd1_lat_max - lat) / grd1_d_lat) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + DEasting(lon - grd1_lon_min) / grd1_d_lon j1 = MAX(1,MIN(j1,grd1_ncols-1)) j2 = j1 + 1 fx2 = (DEasting(lon - grd1_lon_min) / grd1_d_lon) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 above = fx1 * grid1(i1,j1) + fx2 * grid1(i1,j2) below = fx1 * grid1(i2,j1) + fx2 * grid1(i2,j2) value = fy1 * above + fy2 * below END IF ! point inside lon/lat grid1 END IF ! rejection worked ELSE ! gridded data is on a x,y grid1 already grd1_success = (x_meters >= grd1_x_min).AND. & & (x_meters <= grd1_x_max).AND. & & (y_meters >= grd1_y_min).AND. & & (y_meters <= grd1_y_max) IF (grd1_success) THEN i1 = 1 + (grd1_y_max - y_meters) / grd1_d_y i1 = MAX(1,MIN(i1,grd1_nrows-1)) i2 = i1 + 1 fy2 = ((grd1_y_max - y_meters) / grd1_d_y) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + (x_meters - grd1_x_min) / grd1_d_x j1 = MAX(1,MIN(j1,grd1_ncols-1)) j2 = j1 + 1 fx2 = ((x_meters - grd1_x_min) / grd1_d_x) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 above = fx1 * grid1(i1,j1) + fx2 * grid1(i1,j2) below = fx1 * grid1(i2,j1) + fx2 * grid1(i2,j2) value = fy1 * above + fy2 * below END IF ! point within x/y grid1 END IF ! need to undo map projection or not for grid1 ELSE ! neither ai_using_color, nor (bitmap_shading_mode == 1) grd1_success = .FALSE. value = 0.0D0 ! should not be used END IF ! finding i1, i2, j1, j2,,, value in grid1, or not !Finished getting "value" and i1, i2, j1, j2, ... (if possible) !Get "brightness" (basis for brightness of pixel) from grid2??? IF (shaded_relief) THEN IF (bitmap_shading_mode == 1) THEN grd2_success = grd1_success !and fx2, fy2, i1, i2, ... will be reused ELSE ! must find place in grid2! !must recompute fx1, fx2, fy1, fy2, i1, i2, j1, j2 for different grid IF (grd2_lonlat) THEN IF (success) THEN ! lon, lat still valid !define grd2_success as falling within grid2 grd2_success = (lat >= grd2_lat_min).AND. & & (lat <= grd2_lat_max).AND. & & (DEasting(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.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + DEasting(lon - grd2_lon_min) / grd2_d_lon j1 = MAX(1,MIN(j1,grd2_ncols-1)) j2 = j1 + 1 fx2 = (DEasting(lon - grd2_lon_min) / grd2_d_lon) - j1 + 1.0D0 fx1 = 1.00D0 - 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.0D0 fy1 = 1.00D0 - 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.0D0 fx1 = 1.00D0 - fx2 END IF ! point within x/y grid2 END IF ! grd2_lonlat, or not END IF ! shaded relief grid2 has different framework 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.5D0) ! fraction for adjacent cell fin = 1.00D0 - fout ! fraction for the cell we're in inner = (grid2(i1,j2) - grid2(i1,j1)) / grd2_d_EW IF (fx2 > 0.5D0) 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.5D0) 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.0D0 + 0.5D0 * intensity * slope / RMS_slope brightness = MAX(0.0D0, MIN(2.0D0, brightness)) ELSE ! .NOT. dot2_success; so, point was not in grid2 brightness = 1.0D0 END IF ! point was in grid2 or not ELSE ! no shaded relief wanted brightness = 1.0D0 END IF ! shaded relief, or not !End of lookup (value and brightness); now use them! IF (ai_using_color.AND.grd1_success) THEN ! have "value" IF (bitmap_color_mode == 1) THEN ! Munsell: smooth spectrum t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Munsell(warmth = t, brightness = brightness) 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 = DRGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = DRGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = DRGB_AI(value = value, contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, low_is_blue = grid_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.5D0 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 from gridded dataset(s)....',I6,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Working on bitmap from gridded dataset(s)....Writing to .ai ')") CALL DBitmap_on_L1 (bitmap, ai_window_x1_points, ai_window_x2_points, & & ai_window_y1_points, ai_window_y2_points) IF (ai_using_color) THEN CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! ai_using_color --> want spectrum in legend WRITE (*,"('+Working on bitmap from gridded dataset(s)....DONE. ')") CALL BEEPQQ (frequency = 440, duration = 250) ! deallocate by LIFO method: DEALLOCATE ( bitmap ) IF (ALLOCATED(grid2)) DEALLOCATE ( grid2 ) DEALLOCATE ( grid1 ) ! end of colored/shaded bitmap from gridded dataset(s) CASE (3) ! contour map from gridded data 1030 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .TRUE. , & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = grd1_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file should be contoured?',grd1_file,grd1_file) grd1_pathfile = TRIM(temp_path_in)//TRIM(grd1_file) OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') WRITE(*,"(' Here are the first 5 lines of the file:' & &/' ----------------------------------------')") DO i = 1, 5 READ (21,"(A)", IOSTAT = ios) line WRITE (*,"(' ',A)") TRIM(line(1:79)) END DO WRITE(*,"(' ----------------------------------------')") CALL DPrompt_for_Logical('Is this grid defined in (lon,lat) coordinates?',.TRUE.,grd1_lonlat) CLOSE (21) OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) IF (grd1_lonlat) THEN READ (21, *, IOSTAT = ios) grd1_lon_min, grd1_d_lon, grd1_lon_max problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) grd1_lat_min, grd1_d_lat, grd1_lat_max problem = problem .OR. (ios /= 0) grd1_ncols = 1 + NINT((grd1_lon_max - grd1_lon_min) / grd1_d_lon) grd1_nrows = 1 + NINT((grd1_lat_max - grd1_lat_min) / grd1_d_lat) ELSE ! (x,y) format READ (21, *, IOSTAT = ios) grd1_x_min, grd1_d_x, grd1_x_max problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) grd1_y_min, grd1_d_y, grd1_y_max problem = problem .OR. (ios /= 0) grd1_ncols = 1 + NINT((grd1_x_max - grd1_x_min) / grd1_d_x) grd1_nrows = 1 + NINT((grd1_y_max - grd1_y_min) / grd1_d_y) END IF problem = problem .OR. (grd1_nrows < 2) .OR. (grd1_ncols < 2) ALLOCATE ( grid1(grd1_nrows, grd1_ncols) ) train_length = grd1_nrows * grd1_ncols ALLOCATE ( train(train_length) ) READ (21, *, IOSTAT = ios) ((grid1(i,j), j = 1, grd1_ncols), i = 1, grd1_nrows) problem = problem .OR. (ios /= 0) CLOSE (21) IF (problem) THEN WRITE (*,"(' ERROR: File defective in structure or truncated.')") WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line DEALLOCATE (grid1, train) GOTO 1030 END IF CALL Add_Title(grd1_file) WRITE (*,"(/' Here is the distribution of gridded values:' )") k = 0 DO i = 1, grd1_nrows DO j = 1, grd1_ncols k = k + 1 train(k) = grid1(i,j) END DO END DO CALL Histogram (train, train_length, .FALSE., maximum, minimum) CALL DPrompt_for_String('What are the units of these values?',TRIM(ADJUSTL(grid_units)),grid_units) IF (grid_interval == 0.0D0) THEN grid_interval = (maximum - minimum) / ai_spectrum_count grid_midvalue = (maximum + minimum) / 2.0D0 END IF 1031 CALL DPrompt_for_Real('What contour interval do you wish?',grid_interval,grid_interval) IF (grid_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") grid_interval = (maximum - minimum) / ai_spectrum_count GOTO 1031 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',grid_midvalue,grid_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',grid_lowblue,grid_lowblue) END IF WRITE (*,"(/' If the data is elevation/bathymetry, and you plan to plot the coastline')") WRITE (*,"(' as a separate map element, the zero contour may be redundant (& less accurate)!')") CALL DPrompt_for_Logical('Should the 0 contour line be omitted?',skip_0_contour,skip_0_contour) WRITE (*,"(/' Working on gridded data....')") DO group = 1, 2 IF (group == 2) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) !note that contouring routine will set line colors CALL DBegin_Group IF (grd1_lonlat) THEN DO i = 1, grd1_nrows-1 DO j = 1, grd1_ncols-1 ! NW triangle: lon = grd1_lon_min + (j-1)*grd1_d_lon lat = grd1_lat_max - (i-1)*grd1_d_lat lat = MAX(MIN(lat, 90.0D0), -90.0D0) CALL DLonLat_2_Uvec(lon, lat, uvec1) lat = lat - grd1_d_lat lat = MAX(MIN(lat, 90.0D0), -90.0D0) CALL DLonLat_2_Uvec(lon, lat, uvec2) lon = lon + grd1_d_lon lat = lat + grd1_d_lat lat = MAX(MIN(lat, 90.0D0), -90.0D0) CALL DLonLat_2_Uvec(lon, lat, uvec3) CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = grid1(i,j), & & f2 = grid1(i+1,j), & & f3 = grid1(i,j+1), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) ! SE triangle uvec(1:3) = uvec2(1:3) uvec2(1:3) = uvec3(1:3) uvec3(1:3) = uvec(1:3) lat = lat - grd1_d_lat lat = MAX(MIN(lat, 90.0D0), -90.0D0) CALL DLonLat_2_Uvec(lon, lat, uvec1) CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = grid1(i+1,j+1), & & f2 = grid1(i,j+1), & & f3 = grid1(i+1,j), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) END DO ! j=1, grd1_ncols-1 END DO ! i = 1, grd1_nrows-1 ELSE ! data are in (x,y) format t = mt_meters_per_user ! (abbreviation) DO i = 1, grd1_nrows-1 DO j = 1, grd1_ncols-1 !upper left triangle CALL DContour_3Node_Scalar_in_Plane & &(x1 = t*(grd1_x_min+grd1_d_x*(j-1)), & & y1 = t*(grd1_y_max-grd1_d_y*(i-1)), & & x2 = t*(grd1_x_min+grd1_d_x*(j-1)), & & y2 = t*(grd1_y_max-grd1_d_y*(i)), & & x3 = t*(grd1_x_min+grd1_d_x*(j)), & & y3 = t*(grd1_y_max-grd1_d_y*(i-1)), & & f1 = grid1(i,j), & & f2 = grid1(i+1,j), & & f3 = grid1(i,j+1), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) ! lower right triangle CALL DContour_3Node_Scalar_in_Plane & &(x1 = t*(grd1_x_min+grd1_d_x*(j)), & & y1 = t*(grd1_y_max-grd1_d_y*(i)), & & x2 = t*(grd1_x_min+grd1_d_x*(j)), & & y2 = t*(grd1_y_max-grd1_d_y*(i-1)), & & x3 = t*(grd1_x_min+grd1_d_x*(j-1)), & & y3 = t*(grd1_y_max-grd1_d_y*(i)), & & f1 = grid1(i+1,j+1), & & f2 = grid1(i,j+1), & & f3 = grid1(i+1,j), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) END DO ! j=1, ncols-1 END DO ! i = 1, nrows-1 END IF ! lonlat, or (x,y) CALL DEnd_Group ! END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value =grid_midvalue, & & low_is_blue = grid_lowblue, & & units = ADJUSTL(grid_units)) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value =grid_midvalue, & & low_is_blue = grid_lowblue, & & units = ADJUSTL(grid_units)) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on gridded data....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( grid1 ) DEALLOCATE ( train ) ! end of contour map from gridded data CASE (4) ! discontinuous scalar (one value per element) CALL DGroup_or_Bitmap (latter_mosaic, element_scalar_method, bitmap_height, bitmap_width) 1040 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .TRUE., & ! & velocity = .FALSE., & ! & suggested_file = element_scalar_feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file defines the elements?',element_scalar_feg_file,element_scalar_feg_file) element_scalar_feg_pathfile = TRIM(temp_path_in)//TRIM(element_scalar_feg_file) OPEN (UNIT = 21, FILE = element_scalar_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) ALLOCATE ( node_uvec(3,numnod) ) DO i = 1, numnod READ (21, *, IOSTAT = ios) j, lon, lat problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) IF (numel <= 0) THEN WRITE (*,"(' ERROR: No elements are found in this file.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 1040 END IF ! numel <= 0 sample_length = MIN(10, numel) WRITE (*,"(' Here are the first ',I2,' element lines, with rulers:')") sample_length WRITE (*,"(' ----+----1----+----2----+----3----+----4----+----5----+----6----+----7')") DO i = 1, sample_length READ (21, "(A)", IOSTAT = ios) c78 WRITE (*, "(' ',A)") TRIM(c78) END DO ! i = 1, sample_length WRITE (*,"(' ----+----1----+----2----+----3----+----4----+----5----+----6----+----7')") CLOSE (21) WRITE (*,"(' Please enter a Fortran FORMAT, enclosed in parentheses (),')") WRITE (*,"(' which will permit reading the 4 integers, and then the desired field,')") WRITE (*,"(' such as, for example, (I5,3I6,8X,F7.1)')") READ (*, "(A)") element_scalar_format ALLOCATE ( nodes(3,numel) ) ALLOCATE ( element_scalar(numel) ) OPEN (UNIT = 21, FILE = element_scalar_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) DO i = 1, numnod READ (21, *, IOSTAT = ios) j, lon, lat problem = problem .OR. (ios /= 0) .OR. (j /= i) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) DO i = 1, numel READ (21, element_scalar_format, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i), & & element_scalar(i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Defective FORMAT or data file.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 1040 END IF CLOSE (21) CALL Add_Title(element_scalar_feg_file) WRITE (*,"(/' Here is the distribution of non-zero element values:' )") CALL Histogram (element_scalar, numel, .TRUE., maximum, minimum) CALL DPrompt_for_String('What are the units of these numbers?',element_scalar_units,element_scalar_units) IF (element_scalar_method == 1) THEN ! group of colored/shaded polygons IF (element_scalar_interval == 0.0D0) THEN element_scalar_interval = (maximum - minimum) / ai_spectrum_count element_scalar_midvalue = (maximum + minimum) / 2.0D0 END IF 1041 CALL DPrompt_for_Real('What contour interval do you wish?',element_scalar_interval,element_scalar_interval) IF (element_scalar_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") element_scalar_interval = (maximum - minimum) / ai_spectrum_count GOTO 1041 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',element_scalar_midvalue,element_scalar_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',element_scalar_lowblue,element_scalar_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',element_scalar_lowblue,element_scalar_lowblue) END IF WRITE (*,*) WRITE (*,"(' Non-zero values that lie exactly on a contour')") WRITE (*,"(' (color boundary) are always nudged toward zero')") WRITE (*,"(' in order to assign a color to them.')") WRITE (*,"(' -----------------------------------------------')") WRITE (*,"(' What shall be done with zero values?')") WRITE (*,"(' mode 1 :: round up to the 1st positive color')") WRITE (*,"(' mode 0 :: do not plot this triangle')") WRITE (*,"(' mode -1 :: round down to the 1st negative color')") WRITE (*,"(' ------------------------------------------------')") 1042 CALL DPrompt_for_Integer('Which mode do you want?',element_scalar_zeromode,element_scalar_zeromode) IF ((element_scalar_zeromode < -1).OR.(element_scalar_zeromode > 1)) THEN WRITE (*,"(' ERROR: Select mode in legal range.')") GOTO 1042 element_scalar_zeromode = 0 END IF WRITE (*,"(/' Working on discontinuous scalar (one value per element)....')") CALL DBegin_Group ! of colored/shaded triangles DO i = 1, numel t = element_scalar(i) IF (t == 0.0D0) THEN SELECT CASE (element_scalar_zeromode) CASE (1) ! round up t = 0.001D0 * element_scalar_interval plot_this = .TRUE. CASE (0) ! do not plot plot_this = .FALSE. CASE (-1) ! round down t = -0.001D0 * element_scalar_interval plot_this = .TRUE. END SELECT ELSE ! non-zero value plot_this = .TRUE. IF (MOD(t, element_scalar_interval) == 0.0D0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0D0) THEN t = t - 0.001D0 * element_scalar_interval ELSE ! t < 0.0 t = t + 0.001D0 * element_scalar_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) END IF ! zero or non-zero value uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) IF (plot_this) CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = element_scalar_interval, & & midspectrum_value = element_scalar_midvalue, & & low_is_blue = element_scalar_lowblue, group = 1) END DO ! i = 1, numel CALL DEnd_Group ! of colored/shaded triangles CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = element_scalar_interval, & & midspectrum_value =element_scalar_midvalue, & & low_is_blue = element_scalar_lowblue, & & units = element_scalar_units) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = element_scalar_interval, & & midspectrum_value =element_scalar_midvalue, & & low_is_blue = element_scalar_lowblue, & & units = element_scalar_units) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on discontinuous scalar (one value per element)....DONE.')") ELSE ! element_scalar_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN bitmap_value(irow,jcol) = element_scalar(iele) bitmap_success(irow,jcol) = .TRUE. ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & element_scalar_units, minimum, maximum, & & bitmap_color_mode, element_scalar_interval, element_scalar_midvalue, element_scalar_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, element_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & element_scalar_interval, element_scalar_midvalue, element_scalar_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, element_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & element_scalar_interval, element_scalar_midvalue, element_scalar_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! element_scalar_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( element_scalar, & & node_uvec, & & nodes) ! end of discontinuous scalar (one value per element) CASE (5) ! continuous scalar (one value per node) CALL DGroup_or_Bitmap (latter_mosaic, node_scalar_method, bitmap_height, bitmap_width) 1050 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .TRUE., & ! & velocity = .FALSE., & ! & suggested_file = node_scalar_feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file defines the nodes and elements?',node_scalar_feg_file,node_scalar_feg_file) node_scalar_feg_pathfile = TRIM(temp_path_in)//TRIM(node_scalar_feg_file) OPEN (UNIT = 21, FILE = node_scalar_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) WRITE (*,"(/' Here are the records for the first 5 nodes:')") DO i = 1, 5 READ (21,"(A)") line WRITE (*,"(' ',A)") TRIM(line) END DO ! i = 1, 5 nodal lines CLOSE(21) IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 1050 END IF CALL DPrompt_for_Integer('How many positions AFTER the latitude is the scalar field that you want to plot?',node_scalar_choice,node_scalar_choice) IF ((node_scalar_choice < 1).OR.(node_scalar_choice > 5)) GOTO 1050 !open .feg again to record nodal values (and element definitions) OPEN (UNIT = 21, FILE = node_scalar_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( node_scalar(numnod) ) DO i = 1, numnod IF (node_scalar_choice == 1) THEN READ (21, *, IOSTAT = ios) j, lon, lat, node_scalar(i) ELSE IF (node_scalar_choice == 2) THEN READ (21, *, IOSTAT = ios) j, lon, lat, t1, node_scalar(i) ELSE IF (node_scalar_choice == 3) THEN READ (21, *, IOSTAT = ios) j, lon, lat, t1, t2, node_scalar(i) ELSE IF (node_scalar_choice == 4) THEN READ (21, *, IOSTAT = ios) j, lon, lat, t1, t2, t3, node_scalar(i) ELSE IF (node_scalar_choice == 5) THEN READ (21, *, IOSTAT = ios) j, lon, lat, t1, t2, t3, t4, node_scalar(i) END IF ! node_scalar_choice = 1, 2, 3, 4, 5 problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 1050 END IF CLOSE (21) CALL Add_Title(node_scalar_feg_file) WRITE (*,"(/' Here is the distribution of nodal values:' )") CALL Histogram (node_scalar, numnod, .FALSE., maximum, minimum) CALL DPrompt_for_String('What are the units of these numbers?',node_scalar_units,node_scalar_units) IF (node_scalar_method == 1) THEN ! group of colored/shaded polygons IF (node_scalar_interval == 0.0D0) THEN node_scalar_interval = (maximum - minimum) / ai_spectrum_count node_scalar_midvalue = (maximum + minimum) / 2.0D0 END IF 1051 CALL DPrompt_for_Real('What contour interval do you wish?',node_scalar_interval,node_scalar_interval) IF (node_scalar_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") node_scalar_interval = (maximum - minimum) / ai_spectrum_count GOTO 1051 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',node_scalar_midvalue,node_scalar_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',node_scalar_lowblue,node_scalar_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',node_scalar_lowblue,node_scalar_lowblue) END IF WRITE (*,"(/' Working on continuous scalar (one value per node)....')") DO group = 1, 2 CALL DBegin_Group IF (group == 2) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) !note that contouring routine will set line colors DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = node_scalar(nodes(1,i)), & & f2 = node_scalar(nodes(2,i)), & & f3 = node_scalar(nodes(3,i)), & & low_value = minimum, high_value = maximum, & & contour_interval = node_scalar_interval, & & midspectrum_value = node_scalar_midvalue, & & low_is_blue = node_scalar_lowblue, group = group) END DO ! i = 1, numel CALL DEnd_Group END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = node_scalar_interval, & & midspectrum_value =node_scalar_midvalue, & & low_is_blue = node_scalar_lowblue, & & units = node_scalar_units) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = node_scalar_interval, & & midspectrum_value =node_scalar_midvalue, & & low_is_blue = node_scalar_lowblue, & & units = node_scalar_units) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on continuous scalar (one value per node)....DONE.')") ELSE ! node_scalar_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN bitmap_value(irow,jcol) = node_scalar(nodes(1,iele)) * s1 + & & node_scalar(nodes(2,iele)) * s2 + & & node_scalar(nodes(3,iele)) * s3 bitmap_success(irow,jcol) = .TRUE. ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & node_scalar_units, minimum, maximum, & & bitmap_color_mode, node_scalar_interval, node_scalar_midvalue, node_scalar_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, node_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & node_scalar_interval, node_scalar_midvalue, node_scalar_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, node_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & node_scalar_interval, node_scalar_midvalue, node_scalar_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! node_scalar_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( node_scalar, & & node_uvec, & & nodes) ! end of continuous scalar (one value per node) CASE (6) ! magnitude of continuous velocity field CALL DGroup_or_Bitmap (latter_mosaic, velocity_method, bitmap_height, bitmap_width) 1060 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .TRUE., & ! & velocity = .FALSE., & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which grid was used to compute velocities?', feg_file, feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 1060 END IF READ (21,*) ! title READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( vw(2*numnod) ) ALLOCATE ( vsize_mma(numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21,*) numel ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21,*) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel CLOSE(21) 1061 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .TRUE., & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be plotted?', vel_file, vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 1061 END IF DO i = 1, 3 READ (22,"(A)") line CALL Add_Title(line) END DO ! first 3 lines of velocity file READ (22,*) (vw(i), i = 1, (2*numnod)) !this read method should work with either SHELLS or RESTORE format DO i = 1, numnod v_South_mps = vw(2*i-1) v_East_mps = vw(2*i) vsize_mma(i) = 1000.0D0 * sec_per_year * DSQRT(v_South_mps**2 + v_East_mps**2) END DO ! i = 1, numnod CLOSE(22) CALL DPrompt_for_Real("Enter age in Ma for velocity map: ", velocity_epoch_Ma, velocity_epoch_Ma) WRITE (*,"(/' Here is the distribution of velocities (in mm/a):')") CALL Histogram (vsize_mma, numnod, .FALSE., maximum, minimum) IF (velocity_method == 1) THEN ! group of colored/shaded polygons IF (velocity_interval == 0.0D0) THEN velocity_interval = (maximum - minimum) / ai_spectrum_count velocity_midvalue = (maximum + minimum) / 2.0D0 END IF 1062 CALL DPrompt_for_Real('What contour interval do you wish?',velocity_interval,velocity_interval) IF (velocity_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") velocity_interval = (maximum - minimum) / ai_spectrum_count GOTO 1062 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',velocity_midvalue,velocity_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should slow areas be colored blue (versus red)?',velocity_lowblue,velocity_lowblue) ELSE CALL DPrompt_for_Logical('Should slow areas be shaded darkly (versus lightly)?',velocity_lowblue,velocity_lowblue) END IF WRITE (*,"(/' Working on magnitude of continuous velocity field....')") DO group = 1, 2 CALL DBegin_Group IF (group == 2) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) !note that contouring routine will set line colors DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) v1S_mma = 1000.0D0 * sec_per_year * vw(2*nodes(1,i)-1) v2S_mma = 1000.0D0 * sec_per_year * vw(2*nodes(2,i)-1) v3S_mma = 1000.0D0 * sec_per_year * vw(2*nodes(3,i)-1) v1E_mma = 1000.0D0 * sec_per_year * vw(2*nodes(1,i)) v2E_mma = 1000.0D0 * sec_per_year * vw(2*nodes(2,i)) v3E_mma = 1000.0D0 * sec_per_year * vw(2*nodes(3,i)) CALL DContour_3Node_Sphere_Velocity( & & uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & v1t = v1S_mma, v1p = V1E_mma, & & v2t = v2S_mma, v2p = V2E_mma, & & v3t = v3S_mma, v3p = V3E_mma, & & low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value = velocity_midvalue, & & low_is_blue = velocity_lowblue, group = group) END DO ! i = 1, numel CALL DEnd_Group END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value = velocity_midvalue, & & low_is_blue = velocity_lowblue, & & units = 'mm/a') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value =velocity_midvalue, & & low_is_blue = velocity_lowblue, & & units = 'mm/a') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on magnitude of continuous velocity field....DONE.')") ELSE ! velocity_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN uvec1(1:3) = node_uvec(1:3,nodes(1,iele)) uvec2(1:3) = node_uvec(1:3,nodes(2,iele)) uvec3(1:3) = node_uvec(1:3,nodes(3,iele)) v1S = vw(2*nodes(1,iele)-1) v2S = vw(2*nodes(2,iele)-1) v3S = vw(2*nodes(3,iele)-1) v1E = vw(2*nodes(1,iele)) v2E = vw(2*nodes(2,iele)) v3E = vw(2*nodes(3,iele)) CALL DVelocity_Size_in_3Node_Sphere & & (iele, uvec1, uvec2, uvec3, & ! element input & v1S,v1E, v2S,v2E, v3S,v3E, & ! nodal velocities & uvec, & ! position input & vsize, d_vsize_d_theta, d_vsize_d_phi) ! outputs bitmap_value(irow,jcol) = vsize * 1000.0D0 * sec_per_year bitmap_success(irow,jcol) = .TRUE. ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & 'mm/a', minimum, maximum, & & bitmap_color_mode, velocity_interval, velocity_midvalue, velocity_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! velocity_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) WRITE (c5, "(F5.1)") velocity_epoch_Ma c40 = Epoch(velocity_epoch_Ma) line = "Velocity at " // c5 // " Ma (" // TRIM(c40) // ')' CALL Add_Title(TRIM(line)) !GPBhere DEALLOCATE ( node_uvec ) DEALLOCATE ( vw ) DEALLOCATE ( vsize_mma ) DEALLOCATE ( nodes ) ! end of magnitude of continuous velocity field CASE (7) ! displacement amount (mosaic, in color) CALL DGroup_or_Bitmap (latter_mosaic, distance_method, bitmap_height, bitmap_width) 1070 CALL Get_Paired_Feg_Names (old_feg_file, old_feg_pathfile, & & new_feg_file, new_feg_pathfile) !This routine has tested files by opening and comparing numnod's. 1071 CALL DPrompt_for_Real('What is the geologic age of the older file, in Ma?', t2_Ma, t2_Ma) CALL DPrompt_for_Real('What is the geologic age of the younger file, in Ma?', t1_Ma, t1_Ma) IF (t2_Ma <= t1_Ma) THEN WRITE (*,"(' ERROR: Maximum age must exceed minimum age.')") GO TO 1071 END IF IF (t1_Ma <= 0.0D0) THEN WRITE (c6t2, "(F6.2)") t2_Ma line = 'Displacement since ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ')' ELSE WRITE (c6t1, "(F6.2)") t1_Ma WRITE (c6t2, "(F6.2)") t2_Ma line = 'Displacement from ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ') to ' // & & TRIM(ADJUSTL(c6t1)) // ' Ma (' // TRIM(Epoch(t1_Ma)) // ')' END IF CALL Add_Title(line) OPEN(UNIT = 21, FILE = old_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21,*) READ (21,*) numnod ALLOCATE ( old_node_uvec(3,numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) old_node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod CLOSE (21) OPEN(UNIT = 22, FILE = new_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (22,*) READ (22,*) numnod ALLOCATE ( new_node_uvec(3,numnod) ) DO i = 1, numnod READ (22,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) new_node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod !Note that NEW (present-day) elements are used as basis for !plotting, since present-day nodal coordinates are used as !the basis for plotting. Any combination of new nodes and !old elements risks negative element areas. READ (22,*) numel ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (22,*) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO CLOSE (22) WRITE (*,"(/' Working on displacement amount....')") ALLOCATE ( node_scalar(numnod) ) DO i = 1, numnod uvec1(1:3) = old_node_uvec(1:3,i) uvec2(1:3) = new_node_uvec(1:3,i) node_scalar(i) = mp_radius_meters * DArc(uvec1, uvec2) / 1000.0D0 END DO WRITE (*,"(/' Here is the distribution of displacement amounts, in km:' )") CALL Histogram (node_scalar, numnod, .FALSE., maximum, minimum) IF (distance_method == 1) THEN ! group of colored/shaded polygons IF (distance_km_interval == 0.0D0) THEN distance_km_interval = (maximum - minimum) / ai_spectrum_count distance_km_midvalue = (maximum + minimum) / 2.0D0 END IF 1072 CALL DPrompt_for_Real('What contour interval do you wish?',distance_km_interval,distance_km_interval) IF (distance_km_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") distance_km_interval = (maximum - minimum) / ai_spectrum_count GOTO 1072 END IF CALL DPrompt_for_Real('What distance should fall at mid-spectrum?',distance_km_midvalue,distance_km_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should small distances be colored blue (versus red)?',distance_km_lowblue,distance_km_lowblue) ELSE CALL DPrompt_for_Logical('Should small distances be shaded darkly (versus lightly)?',distance_km_lowblue,distance_km_lowblue) END IF WRITE (*,"(/' Working on displacement amount....')") DO group = 1, 2 IF (group == 2) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) !note that contouring routine will set line colors CALL DBegin_Group DO i = 1, numel uvec1(1:3) = new_node_uvec(1:3,nodes(1,i)) uvec2(1:3) = new_node_uvec(1:3,nodes(2,i)) uvec3(1:3) = new_node_uvec(1:3,nodes(3,i)) CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = node_scalar(nodes(1,i)), & & f2 = node_scalar(nodes(2,i)), & & f3 = node_scalar(nodes(3,i)), & & low_value = minimum, high_value = maximum, & & contour_interval = distance_km_interval, & & midspectrum_value = distance_km_midvalue, & & low_is_blue = distance_km_lowblue, group = group) END DO ! i = 1, numel CALL DEnd_Group END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = distance_km_interval, & & midspectrum_value = distance_km_midvalue, & & low_is_blue = distance_km_lowblue, & & units = 'km') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = distance_km_interval, & & midspectrum_value = distance_km_midvalue, & & low_is_blue = distance_km_lowblue, & & units = 'km') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on displacement amount....DONE.')") ELSE ! distance_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, new_node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, new_node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN bitmap_value(irow,jcol) = node_scalar(nodes(1,iele)) * s1 + & & node_scalar(nodes(2,iele)) * s2 + & & node_scalar(nodes(3,iele)) * s3 bitmap_success(irow,jcol) = .TRUE. ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & 'km', minimum, maximum, & & bitmap_color_mode, distance_km_interval, distance_km_midvalue, distance_km_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, 'km', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & distance_km_interval, distance_km_midvalue, distance_km_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, 'km', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & distance_km_interval, distance_km_midvalue, distance_km_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! distance_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( node_scalar, & & nodes, & & new_node_uvec, & & old_node_uvec ) ! in LIFO order !end of displacement amount CASE (8:9) ! 8 = vertical-axis rotation; 9 = ln[area/(former area)] 1080 IF (choice == 8) THEN CALL Add_Title ('Clockwise Vertical-Axis Rotation') CALL DGroup_or_Bitmap (latter_mosaic, rotation_method, bitmap_height, bitmap_width) method = rotation_method ELSE IF (choice == 9) THEN CALL Add_Title ('Natural Dilatation = ln[area/(former area)]') ! or, for use as title2, under a later overlay(?) of Natural Strain Tensors: CALL Add_Title ('with Natural Dilatation in color') CALL DGroup_or_Bitmap (latter_mosaic, ln_area_method, bitmap_height, bitmap_width) method = ln_area_method END IF ! choice = 8 or 9 1090 CALL Get_Paired_Feg_Names (old_feg_file, old_feg_pathfile, & & new_feg_file, new_feg_pathfile) ! all: INTENT(OUT) !This routine has tested files by opening and comparing numnod's. 1091 CALL DPrompt_for_Real('What is the geologic age of the older file, in Ma?',t2_Ma,t2_Ma) CALL DPrompt_for_Real('What is the geologic age of the younger file, in Ma?',t1_Ma,t1_Ma) IF (t2_Ma <= t1_Ma) THEN WRITE (*,"(' ERROR: Maximum age must exceed minimum age.')") GO TO 1091 END IF IF (t1_Ma <= 0.0D0) THEN WRITE (c6t2, "(F6.2)") t2_Ma IF (choice == 8) THEN line = 'Clockwise Rotation since ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ')' ELSE IF (choice == 9) THEN line = 'Natural Dilatation since ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ')' END IF ELSE WRITE (c6t1, "(F6.2)") t1_Ma WRITE (c6t2, "(F6.2)") t2_Ma IF (choice == 8) THEN line = 'Clockwise Rotation from ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ') to ' // & & TRIM(ADJUSTL(c6t1)) // ' Ma (' // TRIM(Epoch(t1_Ma)) // ')' ELSE IF (choice == 9) THEN line = 'Natural Dilatation from ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ') to ' // & & TRIM(ADJUSTL(c6t1)) // ' Ma (' // TRIM(Epoch(t1_Ma)) // ')' END IF END IF CALL Add_Title(line) WRITE (*, *) CALL DPrompt_for_Logical('Should this map include faulted elements?', .FALSE., also_plot_faulted_elements) OPEN(UNIT = 21, FILE = old_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21,*) READ (21,*) numnod ALLOCATE ( old_node_uvec(3, numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) old_node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21,*) old_numel ALLOCATE ( old_nodes(3, old_numel) ) DO i = 1, old_numel READ (21,*) j, old_nodes(1,i), old_nodes(2,i), old_nodes(3,i) END DO CLOSE (21) OPEN(UNIT = 22, FILE = new_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (22,*) READ (22,*) numnod ALLOCATE ( new_node_uvec(3,numnod) ) DO i = 1, numnod READ (22,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) new_node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (22,*) new_numel ALLOCATE ( new_nodes(3, new_numel) ) ALLOCATE ( before_and_after_unfaulted(new_numel) ) DO i = 1, new_numel READ (22, *, IOSTAT = ios) j, new_nodes(1,i), new_nodes(2,i), new_nodes(3,i), before_and_after_unfaulted(i) IF (ios /= 0) THEN ! probably because before_and_after_unfaulted(i) LOGICAL was not found; assume .TRUE. so plot can proceed: BACKSPACE (22) READ (22, *) j, new_nodes(1,i), new_nodes(2,i), new_nodes(3,i) before_and_after_unfaulted(i) = .TRUE. ! which may cause highly-strained elements to be plotted; less confusing than rejecting all elements! END IF END DO CLOSE (22) ALLOCATE ( strained(new_numel) ) ALLOCATE ( strain_table(15, new_numel) ) CALL FE_Strain (numnod, old_node_uvec, new_node_uvec, & & old_numel, old_nodes, & & new_numel, new_nodes, & & strained, strain_table) ! outputs refer to new_ grid IF (.NOT.also_plot_faulted_elements) THEN DO i = 1, new_numel IF (.NOT.before_and_after_unfaulted(i)) strained(i) = .FALSE. END DO END IF ALLOCATE ( element_scalar(new_numel) ) train_length = 0 DO i = 1, new_numel IF (strained(i)) THEN train_length = train_length + 1 IF (choice == 8) THEN ! clockwise rotation element_scalar(i) = -strain_table(6,i) ! turned is already in degrees; converting to clockwise positive ELSE IF (choice == 9) THEN ! log(greatest horizontal principal stretch, including faulting) eps1h = strain_table(10,i) eps2h = strain_table(11,i) IF (eps1h > -1.0D0) THEN element_scalar(i) = LOG((1.0D0 + eps1h) * (1.0D0 + eps2h)) ELSE strained(i) = .FALSE. element_scalar(i) = 0.0D0 END IF ! eps1h is reasonable or not END IF ! rotation (8) or log(strain) (9) ELSE element_scalar(i) = 0.0D0 ! means "undefined" END IF END DO IF (train_length == 0) THEN WRITE (*,"(' ERROR: Not one single element matches between these grids.')") CALL Pause() STOP END IF IF (choice == 8) THEN WRITE (*,"(/' Here are the vertical-axis rotations, in degrees (clockwise = +)' )") ELSE IF (choice == 9) THEN WRITE (*,"(/' Here are the natural dilatations = ln[area/(former area)]' )") END IF CALL Histogram (element_scalar, new_numel, .TRUE., maximum, minimum) IF (method == 1) THEN ! group of colored/shaded polygons IF (choice == 8) THEN IF (rotation_degrees_interval == 0.0D0) THEN rotation_degrees_interval = (maximum - minimum) / ai_spectrum_count rotation_degrees_midvalue = (maximum + minimum) / 2.0D0 END IF 1092 CALL DPrompt_for_Real('What contour interval do you wish?',rotation_degrees_interval,rotation_degrees_interval) IF (rotation_degrees_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") rotation_degrees_interval = (maximum - minimum) / ai_spectrum_count GOTO 1092 END IF CALL DPrompt_for_Real('What rotation should fall at mid-spectrum?',rotation_degrees_midvalue,rotation_degrees_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should counterclockwise rotations be colored blue (versus red)?',rotation_degrees_lowblue,rotation_degrees_lowblue) ELSE CALL DPrompt_for_Logical('Should counterclockwise rotations be shaded darkly (versus lightly)?',rotation_degrees_lowblue,rotation_degrees_lowblue) END IF WRITE (*,"(/' Working on vertical-axis rotation....')") ELSE IF (choice == 9) THEN IF (ln_area_interval == 0.0D0) THEN ln_area_interval = 2.0D0 * MAX(ABS(maximum),ABS(minimum)) / ai_spectrum_count END IF 1093 CALL DPrompt_for_Real('What contour interval do you wish?',ln_area_interval,ln_area_interval) IF (ln_area_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") ln_area_interval = (maximum - minimum)/ai_spectrum_count GOTO 1093 END IF CALL DPrompt_for_Real('What ln[area/(former area)] should fall at mid-spectrum?',ln_area_midvalue,ln_area_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should compressed regions be colored blue (versus red)?',ln_area_lowblue,ln_area_lowblue) ELSE CALL DPrompt_for_Logical('Should compressed regions be shaded darkly (versus lightly)?',ln_area_lowblue,ln_area_lowblue) END IF WRITE (*,"(/' Working on ln[area/(former area)]....')") END IF ! choice = 8 or 9 CALL DBegin_Group ! of colored/shaded triangles (there won't be any contours) DO i = 1, new_numel IF (strained(i)) THEN ! strain is defined; OK to plot uvec1(1:3) = new_node_uvec(1:3, new_nodes(1,i)) uvec2(1:3) = new_node_uvec(1:3, new_nodes(2,i)) uvec3(1:3) = new_node_uvec(1:3, new_nodes(3,i)) IF (choice == 8) THEN CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = element_scalar(i), & & f2 = element_scalar(i), & & f3 = element_scalar(i), & & low_value = minimum, high_value = maximum, & & contour_interval = rotation_degrees_interval, & & midspectrum_value = rotation_degrees_midvalue, & & low_is_blue = rotation_degrees_lowblue, group = 1) ELSE IF (choice == 9) THEN CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = element_scalar(i), & & f2 = element_scalar(i), & & f3 = element_scalar(i), & & low_value = minimum, high_value = maximum, & & contour_interval = ln_area_interval, & & midspectrum_value = ln_area_midvalue, & & low_is_blue = ln_area_lowblue, group = 1) END IF ! choice = 8 or 9 END IF ! strained(i); strain is defined END DO ! i = 1, numel CALL DEnd_Group ! of colored/shaded triangles CALL Chooser(bottom, right) IF (bottom) THEN IF (choice == 8) THEN CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = rotation_degrees_interval, & & midspectrum_value = rotation_degrees_midvalue, & & low_is_blue = rotation_degrees_lowblue, & & units = 'degrees') ELSE IF (choice == 9) THEN CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = ln_area_interval, & & midspectrum_value = ln_area_midvalue, & & low_is_blue = ln_area_lowblue, & & units = ' ') END IF ! choice = 8 or 9 bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN IF (choice == 8) THEN CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = rotation_degrees_interval, & & midspectrum_value = rotation_degrees_midvalue, & & low_is_blue = rotation_degrees_lowblue, & & units = 'degrees') ELSE IF (choice == 9) THEN CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = ln_area_interval, & & midspectrum_value = ln_area_midvalue, & & low_is_blue = ln_area_lowblue, & & units = ' ') END IF ! choice = 8 or 9 rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! IF (choice == 8) THEN WRITE (*,"('+Working on vertical-axis rotation....DONE.')") ELSE IF (choice == 9) THEN WRITE (*,"('+Working on ln[area/(former area)]....DONE.')") END IF ELSE ! method == 2 ALLOCATE ( a_(new_numel) ) ALLOCATE ( center(3, new_numel) ) ALLOCATE ( neighbor(3, new_numel) ) CALL DLearn_Spherical_Triangles (new_numel, new_nodes, new_node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & new_numel, new_nodes, new_node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN IF (strained(iele)) THEN bitmap_value(irow,jcol) = element_scalar(iele) bitmap_success(irow,jcol) = .TRUE. ELSE bitmap_success(irow,jcol) = .FALSE. END IF ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") IF (choice == 8) THEN ! rotation CALL DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & 'degrees', minimum, maximum, & & bitmap_color_mode, rotation_degrees_interval, rotation_degrees_midvalue, rotation_degrees_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) ELSE ! choice == 9 ; natural dilatation CALL DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & ' ', minimum, maximum, & & bitmap_color_mode, ln_area_interval, ln_area_midvalue, ln_area_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) END IF ! choice is 8 or 9 DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN IF (choice == 8) THEN ! rotation CALL DSpectrum_in_BottomLegend (minimum, maximum, 'degrees', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & rotation_degrees_interval, rotation_degrees_midvalue, rotation_degrees_lowblue) ELSE ! choice == 9 ; natural dilatation CALL DSpectrum_in_BottomLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & ln_area_interval, ln_area_midvalue, ln_area_lowblue) END IF bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN IF (choice == 8) THEN ! rotation CALL DSpectrum_in_RightLegend (minimum, maximum, 'degrees', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & rotation_degrees_interval, rotation_degrees_midvalue, rotation_degrees_lowblue) ELSE ! choice == 9 ; natural dilatation CALL DSpectrum_in_RightLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & ln_area_interval, ln_area_midvalue, ln_area_lowblue) END IF rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( element_scalar, & & strain_table, & & strained, & & before_and_after_unfaulted, & & new_nodes, & & new_node_uvec, & & old_nodes, & & old_node_uvec ) ! in LIFO order !end of rotation (8) or natural dilatation (9) mosaic CASE (10) ! Geologic Map of North America (outcrop areas, unit symbols, contact lines, dikes, & faults) 1100 temp_path_in = path_in GMNA_epoch_Ma = 0.0D0 ! Plot present-day map (with all units, including Q) unless user chooses an older epoch below. CALL DPrompt_for_String('Which file should be plotted?', 'GMNA.dig', GMNA_file) Ma_index = INDEX(GMNA_file, "Ma") IF (Ma_index > 0) THEN ! GMNA_file name includes "Ma"; so extract age in Ma: c5 = GMNA_file((Ma_index-5):(Ma_index-1)) READ(c5, *) GMNA_epoch_Ma END IF ! GMNA_file name includes "Ma" CALL DPrompt_for_Real("Enter age in Ma for paleogeologic map: ", GMNA_epoch_Ma, GMNA_epoch_Ma) GMNA_pathfile = TRIM(temp_path_in)//TRIM(GMNA_file) WRITE (*,"(/' Working on Geologic Map of North America....')") DO GMNA_pass = 1, 2 ! First pass ONLY plots outcrop areas (as colored areas, using some compound paths); ! second pass adds unit-symbol (group), contact lines (group), dikes (group), & faults (group). OPEN (UNIT = 21, FILE = GMNA_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (GMNA_pass == 1) THEN ! plot colored areas defined in Geologic_units.shp & .dbf of GMNA: tiling: DO ! read OUTCROP blocks from GMNA.dig (or GMNA_NI_006.0Ma.dig, ...) READ (21, "(A)") keyword_line gap_index = INDEX(keyword_line, ' ') keyword = keyword_line(1:(gap_index-1)) IF (keyword(1:7) == "OUTCROP") THEN READ (21, "(A)") unit_line ! N.B. Both of these are expected after any "OUTCROP" line, per logic in GMNA_SHP_2_DIG. READ (21, "(A)") age_line line = age_line(5:80) READ (line, *) t_max_Ma, t_min_Ma greatest_age_Ma = t_max_Ma IF (greatest_age_Ma > GMNA_epoch_Ma) THEN ! plot this area: part_index = INDEX(keyword_line, ' part ') ! If >0, then one part of a multi-part compound area. part_1_index = INDEX(keyword_line, ' part 1') ! If >0, then this is the FIRST part of a multi-part compound area. starting_new_area = ((part_index == 0).OR.(part_1_index > 0)) ! Either a simple non-compound area, or first part of a compound area. IF (starting_new_area) THEN IF (ai_compound_paths_open > 0) CALL DEnd_Compound_Path() ! Close any "old" compound path that may currently be open. !Decide on appropriate fill color: gap_index = INDEX(unit_line, ' ') unit_symbol = unit_line(1:(gap_index-1)) CALL Unit_Symbol_2_CMYK(unit_symbol, C_R8, M_R8, Y_R8, K_R8) CALL DSet_Custom_Fill(C_R8, M_R8, Y_R8, K_R8) IF (part_1_index > 0) CALL DBegin_Compound_Path() END IF ! starting_new_area (Otherwise, just continuing with parts 2, 3, ... of a compound path that is already open.) READ (21, *) Elon, Nlat CALL DNew_L67_Path (7, Elon, Nlat) going_around: DO READ (21, "(A)") line IF (line(1:3) == "***") EXIT going_around READ (line, *) Elon, Nlat CALL DGreat_to_L67(Elon, Nlat) END DO going_around CALL DEnd_L67_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE., retro = .FALSE.) ELSE ! DON'T plot this area (e.g., Q alluvium); just waste the associated points: trashing: DO READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT tiling IF (line(1:3) == "***") EXIT trashing END DO trashing END IF ! Feature is old enough to plot, or not ELSE ! some other keyword, e.g., CONTACT, DIKE, FAULT EXIT tiling ! These other features will be handled later when GMNA_pass == 2. END IF ! keyword = OUTCROP, or not END DO tiling IF (ai_compound_paths_open > 0) CALL DEnd_Compound_Path ELSE IF (GMNA_pass == 2) THEN ! plot groups of: unit-symbols, contact-lines, dikes, & faults old_keyword = "none " retiling: DO ! read OUTCROP/CONTACT/DIKE/FAULT blocks from GMNA.dig (or GMNA_NI_006.0Ma.dig, ...) READ (21, "(A)", IOSTAT = ios) keyword_line IF (ios /= 0) EXIT retiling ! at EOF, for example... gap_index = INDEX(keyword_line, ' ') keyword = keyword_line(1:(gap_index-1)) !manage pens (color & width) and graphical "groups" in Adobe Illustrator: IF (keyword /= old_keyword) THEN IF (ai_groups_open > 0) CALL DEnd_Group() IF (keyword == "OUTCROP") THEN CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = "foreground") ! Reset fill to default (after custom-fills above), for text. ELSE IF (keyword == "CONTACT") THEN CALL DSet_Line_Style(width_points = 0.28346D0, dashed = .FALSE.) ! 0.28346 points = 0.10 mm CALL DSet_Stroke_Color('foreground') ELSE IF (keyword == "DIKE") THEN CALL DSet_Line_Style(width_points = 1.27D0, dashed = .FALSE.) ! 1.27 points == 0.45 mm CALL DSet_Stroke_Color('red_______') ELSE IF (keyword == "FAULT") THEN CALL DSet_Line_Style(width_points = 1.70D0, dashed = .FALSE.) ! 1.70 points == 0.6 mm CALL DSet_Stroke_Color('foreground') END IF CALL DBegin_Group() old_keyword = keyword ! remember, for next pass thorugh this loop "retiling" END IF IF (keyword == "OUTCROP") THEN READ (21, "(A)") unit_line ! N.B. Both of these are expected after any "OUTCROP" line, per logic in GMNA_SHP_2_DIG. READ (21, "(A)") age_line line = age_line(5:80) READ (line, *) t_max_Ma, t_min_Ma greatest_age_Ma = t_max_Ma IF (greatest_age_Ma > GMNA_epoch_Ma) THEN ! plot this unit-symbol: part_index = INDEX(keyword_line, ' part ') ! If >0, then one part of a multi-part compound area. part_1_index = INDEX(keyword_line, ' part 1') ! If >0, then this is the FIRST part of a multi-part compound area. starting_new_area = ((part_index == 0).OR.(part_1_index > 0)) ! Either a simple non-compound area, or first part of a compound area. IF (starting_new_area) THEN !Decide on appropriate text for unit-symbol: gap_index = INDEX(unit_line, ' ') unit_symbol = unit_line(1:(gap_index-1)) !Fix some peculiar features of unit-symbols in GMNA.dig which are NOT used in the actual map (per Explanation, top-center text) query_index = INDEX(unit_symbol, '?') IF (query_index > 0) THEN c8 = unit_symbol c8(query_index:query_index) = ' ' unit_symbol = ADJUSTL(c8) END IF ! unit_symbol starts with '?' star_index = INDEX(unit_symbol, '*') IF (star_index > 0) THEN unit_symbol(star_index:star_index) = ' ' END IF ! unit_symbol ends with '*' !Read all points in outline, and average their uvecs: tvec = 0.0D0 ! initialize before sum... going_around_again: DO READ (21, "(A)") line IF (line(1:3) == "***") EXIT going_around_again READ (line, *) Elon, Nlat CALL DLonLat_2_Uvec(Elon, Nlat, uvec1) tvec(1:3) = tvec(1:3) + uvec1(1:3) END DO going_around_again CALL DMake_Uvec(tvec, uvec) ! This should be the center-point for the unit-symbol text. CALL DL5_Text (uvec = uvec, angle_radians = 0.0D0, from_east = .FALSE., & & font_points = 8, lr_fraction = 0.5D0, ud_fraction = 0.3D0, & & text = TRIM(unit_symbol)) ELSE ! NOT starting_new_area, and no text unit-symbol is wanted; but we still need to "burn through" the associated points until "***" wasting: DO READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT retiling IF (line(1:3) == "***") EXIT wasting END DO wasting END IF ! starting_new_area (Otherwise, just continuing with parts 2, 3, ... of a compound path; no unit-symbol text required.) ELSE ! This unit-symbol is too young to plot; just waste the associated locations: dreaming: DO READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT retiling IF (line(1:3) == "***") EXIT dreaming END DO dreaming END IF ! Unit-symbol is old enough to plot, or NOT. ELSE IF (keyword == "CONTACT") THEN greatest_age_Ma = 4600.0D0 ! age of Earth (because no information in .dbf file) READ (21, *) Elon, Nlat CALL DNew_L67_Path(level = 7, r1 = Elon, r2 = Nlat) contacting: DO READ (21, "(A)") line IF (line(1:3) == "***") EXIT contacting READ (line, *) Elon, Nlat CALL DGreat_to_L67(Elon, Nlat) END DO contacting CALL DEnd_L67_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE., retro = .FALSE.) ELSE IF (keyword == "DIKE") THEN READ (21, "(A)") unit_line ! N.B. Both of these are expected after any "DIKE" line, per logic in GMNA_SHP_2_DIG. READ (21, "(A)") age_line line = age_line(5:80) READ (line, *) t_max_Ma, t_min_Ma greatest_age_Ma = t_max_Ma IF (greatest_age_Ma > GMNA_epoch_Ma) THEN ! plot this dike: READ (21, *) Elon, Nlat CALL DNew_L67_Path(level = 7, r1 = Elon, r2 = Nlat) diking: DO READ (21, "(A)") line IF (line(1:3) == "***") EXIT diking READ (line, *) Elon, Nlat CALL DGreat_to_L67(Elon, Nlat) END DO diking CALL DEnd_L67_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE., retro = .FALSE.) ELSE ! This dike is too young to plot; just discard the associated points: discarding: DO READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT retiling IF (line(1:3) == "***") EXIT discarding END DO discarding END IF ! This dike is too young to plot, or NOT. ELSE IF (keyword == "FAULT") THEN greatest_age_Ma = 4600.0D0 ! age of Earth (because no information in .dbf file) READ (21, *) Elon, Nlat CALL DNew_L67_Path(level = 7, r1 = Elon, r2 = Nlat) fault_lining: DO READ (21, "(A)") line IF (line(1:3) == "***") EXIT fault_lining READ (line, *) Elon, Nlat CALL DGreat_to_L67(Elon, Nlat) END DO fault_lining CALL DEnd_L67_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE., retro = .FALSE.) ELSE ! some other keyword, or not really a "keyword" at all... EXIT retiling ! These other features will be handled later when GMNA_pass == 2. END IF ! keyword = OUTCROP/CONTACT/DIKE/FAULT, or other END DO retiling IF (ai_groups_open > 0) CALL DEnd_Group() END IF ! GMNA_pass = 1, or 2 CLOSE (21) END DO ! GMNA_pass = 1, 2 (First = outcrop areas; second = groups of: unit-symbols, contact-lines, dikes, & faults. WRITE (*,"('+Working on Geologic Map of North America....DONE.')") IF (GMNA_epoch_Ma <= 0.0D0) THEN CALL Add_Title("Geologic Map of North America [2005; digital 2009]") ELSE WRITE (c5, "(F5.1)") GMNA_epoch_Ma c40 = Epoch(GMNA_epoch_Ma) line = "Paleogeologic map at " // c5 // " Ma (" // TRIM(c40) // ')' CALL Add_Title(TRIM(line)) CALL Add_Title("based on Geologic Map of North America [2005; digital 2009]") END IF CALL BEEPQQ (frequency = 440, duration = 250) ! end of Geologic Map of North America (N.B. grouped with mosaics, since it begins with outcrop AREAS; however, includes overlays, too.) CASE (11) ! vertical-axis rotation-rate (in degrees/m.y.) CALL Add_Title('Vertical-axis Rotation-rate (in degrees/m.y.; CW = +)') rotationrate_method = 2 ! (bitmap method; not yet integrated with RetroMap.ini memory) CALL DGroup_or_Bitmap (latter_mosaic, rotationrate_method, bitmap_height, bitmap_width) 1110 WRITE (*, *) WRITE (*, "(' Do you want to hide the (HUGE?) rates of elements with active faults?')") WRITE (*, "(' ---------------------------------------------------------------------')") WRITE (*, "(' 1: NO. Allow the biggest fault-related rates to define color-scale.')") WRITE (*, "(' 2: YES. Hide the rotation-rates of any elements with active faults.')") WRITE (*, "(' ---------------------------------------------------------------------')") rotationrate_selection_method = 2 ! (default; not yet integrated into RetroMap.ini memory) CALL DPrompt_for_Integer('Enter integer from list above:', rotationrate_selection_method, rotationrate_selection_method) IF ((rotationrate_selection_method < 1).OR.(rotationrate_selection_method > 2)) THEN WRITE (*, "(' ERROR: Please try again to select an INTEGER from list above.')") CALL Pause() GO TO 1110 END IF IF (rotationrate_selection_method == 2) THEN CALL Add_Title('excluding rates of elements that contain active faults') END IF 1111 temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file defines the elements?', feg_file, feg_file) feg_pathfile = TRIM(temp_path_in) // TRIM(feg_file) OPEN (UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) ALLOCATE ( node_uvec(3,numnod) ) DO i = 1, numnod READ (21, *, IOSTAT = ios) j, lon, lat problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( faulting(numel) ) IF (rotationrate_selection_method == 1) THEN ! no need to check whether elements are faulting? faulting = .FALSE. ! whole vector DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel ELSE IF (rotationrate_selection_method == 2) THEN ! get "faulting?" indicator from end of each line in the .feg file: DO i = 1, numel READ (21, "(A)") long_line READ (long_line, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) last_byte = LEN_TRIM(long_line) c1 = Long_line(last_byte:last_byte) READ (c1, "(L1)") faulting(i) END DO END IF IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1111 END IF READ (21, *) nfl CLOSE (21) CALL Add_Title(feg_file) 1112 temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be used?', vel_file, vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1112 END IF DO i = 1, 3 READ (22,"(A)") line CALL Add_Title(line) END DO ! first 3 lines of velocity file ALLOCATE ( vw(2*numnod) ) READ (22,*) (vw(i), i = 1, (2*numnod)) CLOSE (22) ALLOCATE ( omega_degPerMa(numel) ) DO l_ = 1, numel ! compute rotation rates at element centers IF ((rotationrate_selection_method == 1).OR.(.NOT.faulting(l_))) THEN uvec1(1:3) = node_uvec(1:3, nodes(1, l_)) uvec2(1:3) = node_uvec(1:3, nodes(2, l_)) uvec3(1:3) = node_uvec(1:3, nodes(3, l_)) m = 1 ! (not using loop, since values for m =1,...,7 almost identical ! evaluate nodal function and derivitives uvec4(1:3) = Gauss_point(1, m) * node_uvec(1:3, nodes(1, l_)) + & & Gauss_point(2, m) * node_uvec(1:3, nodes(2, l_)) + & & Gauss_point(3, m) * node_uvec(1:3, nodes(3, l_)) CALL DMake_Uvec (uvec4, uvec) ! center of element equat = DSQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.0D0) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF theta_ = DATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL Rotation_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, rotationrate) !convert to popular units, for histogram (clockwise degrees per Ma) omega_degPerMa(l_) = -rotationrate * degrees_per_radian * s_per_Ma !(not using loop on m = 1,...,7 since values almost identical) ELSE ! faulting element, which should be hidden (and not included in definition of color-bar) omega_degPerMa(l_) = 0.0D0 END IF END DO ! l_ = 1, numel, computing rotation rates in popular units WRITE (*,"(/' Here is the distribution of clockwise rotation rates' & /' (about local vertical axes, in degrees/m.y.):')") IF (rotationrate_selection_method == 1) THEN ! do not hide any rates, or exclude any zeros: CALL Histogram (omega_degperMa, numel, .FALSE., maximum, minimum) ELSE IF (rotationrate_selection_method == 2) THEN ! faulting elements have rates set to zero, and zeros should be ignored: CALL Histogram (omega_degperMa, numel, .TRUE., maximum, minimum) END IF IF (rotationrate_method == 1) THEN ! group of colored/shaded polygons IF (rotationrate_interval == 0.0D0) THEN rotationrate_interval = (maximum - minimum) / ai_spectrum_count rotationrate_midvalue = (maximum + minimum) / 2.0D0 END IF 1113 CALL DPrompt_for_Real('What contour interval do you wish?', rotationrate_interval, rotationrate_interval) IF (rotationrate_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") rotationrate_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1113 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?', rotationrate_midvalue, rotationrate_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',rotationrate_lowblue,rotationrate_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',rotationrate_lowblue,rotationrate_lowblue) END IF WRITE (*,"(/' Working on rotation rates....')") CALL DBegin_Group ! of colored/shaded triangles (There won't be any contours inside them.) DO i = 1, numel IF ((rotationrate_selection_method == 1).OR.(.NOT.faulting(i))) THEN uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) t = omega_degperMa(i) IF (DMOD(t, rotationrate_interval) == 0.0D0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0D0) THEN t = t - 0.001D0* rotationrate_interval ELSE ! t < 0.0 t = t + 0.001D0 * rotationrate_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = rotationrate_interval, & & midspectrum_value = rotationrate_midvalue, & & low_is_blue = rotationrate_lowblue, group = 1) END IF ! plot this element? END DO ! i = 1, numel CALL DEnd_Group ! of colored/shaded triangles WRITE (*,"('+Working on rotation rates....DONE.')") CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = rotationrate_interval, & & midspectrum_value = rotationrate_midvalue, & & low_is_blue = rotationrate_lowblue, & & units = 'clockwise degree/m.y.') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = rotationrate_interval, & & midspectrum_value = rotationrate_midvalue, & & low_is_blue = rotationrate_lowblue, & & units = 'clockwise degree/m.y.') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! ELSE ! rotationrate_method == 2 (BITMAP) ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN IF ((rotationrate_selection_method == 1).OR.(.NOT.faulting(iele))) THEN t = omega_degperMa(iele) bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) ELSE ! nothing should be plotted for this element (which is faulting, and therefore excluded): t = 0.0D0 bitmap_success(irow,jcol) = .FALSE. ! (leave white-space) bitmap_value(irow,jcol) = t END IF ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & 'clockwise degree/Ma', minimum, maximum, & & bitmap_color_mode, rotationrate_interval, rotationrate_midvalue, rotationrate_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, 'clockwise degree/m.y.', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & rotationrate_interval, rotationrate_midvalue, rotationrate_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, 'clockwise degree/m.y.', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & rotationrate_interval, rotationrate_midvalue, rotationrate_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! rotationrate_method = 1 or 2 CALL BEEPQQ (440, 250) DEALLOCATE ( omega_degperMa, & & vw, & ! in LIFO order & faulting, & & nodes, & & node_uvec) ! end of 11: vertical-axis rotation-rate (in degrees/m.y.) END SELECT ! (choice) = mosaic type latter_mosaic = .TRUE. ! since one is already laid down WRITE (*,"(' ')") suggest_logical = (mosaic_count < old_mosaic_count) CALL DPrompt_for_Logical('Do you want additional mosaics?', suggest_logical, do_more_mosaics) IF (do_more_mosaics) GO TO 1000 END IF ! do mosaic !-------------------------- OVERLAYS ------------------------------ !----- (symbols composed mostly of lines; mostly transparent) ----- overlay_count = 0 ! counts number of overlays in this map !GPBoverlays 2000 WRITE(*,"(//' ----------------------------------------------------------------------'& &/' LINE- & SYMBOL-OVERLAY LAYERS AVAILABLE:')") WRITE (*,"(' 1 :: digitised basemap')") WRITE (*,"(' 2 :: fault traces')") WRITE (*,"(' 3 :: finite-element grid')") WRITE (*,"(' 4 :: outline of finite-element grid')") WRITE (*,"(' 5 :: velocity vectors')") WRITE (*,"(' 6 :: displacement vectors')") WRITE (*,"(' 7 :: fault heave rates (elegant mean-per-fault view)')") WRITE (*,"(' 8 :: net fault heave over geologic time')") WRITE (*,"(' 9 :: paleomagnetic paleolatitude anomalies')") WRITE (*,"(' 10 :: paleomagnetic vertical-axis rotations')") WRITE (*,"(' 11 :: paleostress direction data')") WRITE (*,"(' 12 :: paleostress directions interpolated by Restore')") WRITE (*,"(' 13 :: total strain-rate tensors, including faulting')") WRITE (*,"(' 14 :: strain-rate tensors of non-faulting elements only')") WRITE (*,"(' 15 :: continuum strain-rate tensors of all elements')") WRITE (*,"(' 16 :: log-of-net-principal-stretch tensors')") WRITE (*,"(' 17 :: balanced cross-sections with restored lengths')") WRITE (*,"(' 18 :: fault initiation/termination age dots, annotated with Ma')") WRITE (*,"(' 19 :: fault heave rates (detailed per-segment view)')") WRITE (*,"(' ----------------------------------------------------------------------')") suggest_logical = old_overlay_count > overlay_count IF (overlay_count == 0) CALL DPrompt_for_Logical('Do you want one (or more) of these overlays?',suggest_logical,do_overlay) IF (do_overlay) THEN overlay_count = overlay_count + 1 choice = overlay_choice(overlay_count) CALL DPrompt_for_Integer('Which overlay type should be added?',choice,choice) IF ((choice < 1).OR.(choice > 19)) THEN WRITE (*,"(/' ERROR: Please select an integer from the list!')") WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2000 ELSE overlay_choice(overlay_count) = choice ! for memory END IF ! illegal or legal choice SELECT CASE (choice) CASE (1) ! basemap (lines type) 2010 temp_path_in = path_in !CALL File_List(basemap = .TRUE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = lines_basemap_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file should be plotted?',lines_basemap_file,lines_basemap_file) lines_basemap_pathfile = TRIM(temp_path_in)//TRIM(lines_basemap_file) CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color (color_name = 'foreground') WRITE (*,"(/' Working on basemap....')") polygons = .FALSE. CALL DPlot_Dig (7, lines_basemap_pathfile, polygons, 21, in_ok) IF (.not.in_ok) GOTO 2010 WRITE (*,"('+Working on basemap....DONE.')") ! possible plot titles: filename, and first 3 lines CALL Add_Title(lines_basemap_file) OPEN (UNIT = 21, FILE = lines_basemap_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') DO i = 1, 3 READ (21,"(A)") line READ (line, *, IOSTAT = ios) lon, lat IF (ios /= 0) THEN ! got possible title CALL Add_Title(line) END IF END DO CLOSE (21) CALL BEEPQQ (frequency = 440, duration = 250) ! end of basemap overlay CASE (2) ! fault traces 2020 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .TRUE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = traces_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file should be plotted?',traces_file,traces_file) traces_pathfile = TRIM(temp_path_in)//TRIM(traces_file) OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2020 END IF CLOSE (21) CALL DPrompt_for_Real('How large are the dip ticks (in points)?',tick_points,tick_points) WRITE (*,"(/' Working on fault traces....')") CALL Fault_Traces (trace_choice = 0) WRITE (*,"('+Working on fault traces....DONE.')") CALL Add_Title(traces_file) CALL BEEPQQ (frequency = 440, duration = 250) CALL Chooser (bottom, right) IF (right) THEN CALL DBegin_Group CALL Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, tick_points) CALL DEnd_Group ELSE IF (bottom) THEN CALL DBegin_Group CALL Fault_Key_Bottom (bottomlegend_gap_points, bottomlegend_used_points, tick_points) CALL DEnd_Group END IF ! end of fault traces overlay CASE (3:4) ! finite-element grid (3) or its outline only (4) 2030 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .TRUE., & ! & velocity = .FALSE., & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file should be plotted?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2030 END IF READ (21,"(A)") line CALL Add_Title(line) READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod), segments(3,2,numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21,*) numel ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21,*) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21,*) nfl ALLOCATE ( nodef(4,nfl), fdip(2,nfl) ) DO i = 1, nfl READ (21,*) j, nodef(1,i), nodef(2,i), nodef(3,i), nodef(4,i), & & fdip(1,i), fdip(2,i) END DO ! i = 1, nfl CLOSE(21) IF (choice == 3) THEN ! plot whole grid CALL DPrompt_for_Real('Desired radius of node circles (in points)?',node_radius_points,node_radius_points) IF (nfl > 0) CALL DPrompt_for_Real('How large are the dip ticks (in points)?',tick_points,tick_points) WRITE (*,"(/' Working on finite-element grid....')") IF ((numnod > 0) .AND. (node_radius_points >= 1.0D0)) THEN CALL DBegin_Group ! of nodes IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'dark_blue_') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF DO i = 1, numnod uvec1(1:3) = node_uvec(1:3,i) node_radius_radians = node_radius_points * 0.0003528D0 * & & mp_scale_denominator * & & DConformal_Deflation (uvec1) / R CALL DTurn_To (azimuth_radians = 0.0D0, & & base_uvec = uvec1, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DNew_L45_Path (5, uvec2) CALL DSmall_To_L45 (uvec1, uvec2) CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END DO ! i = 1, numnod CALL DEnd_Group ! of nodes END IF ! numnod > 0 and node_radius_points >= 1. IF (numel > 0) THEN CALL DBegin_Group ! of elements CALL DSet_Line_Style (width_points = 1.0D0, dashed = .TRUE., & & on_points = 6.0D0, off_points = 3.0D0) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('gray______') END IF DO i = 1, numel DO j = 1, 3 ! loop on 3 sides jp1 = MOD(j,3) + 1 virgin = .TRUE. ! until proven otherwise IF (i > 1) THEN edges_done: DO m = 1, i-1 DO n = 1, 3 np1 = MOD(n,3) + 1 IF (nodes(n,m) == nodes(jp1,i)) THEN IF (nodes(np1,m) == nodes(j,i)) THEN virgin = .FALSE. EXIT edges_done END IF ! both ends match! END IF ! one end matches END DO ! n = 1, 3 END DO edges_done ! m = 1, i-1 END IF ! there are lower-numbered elements IF (virgin) THEN ! only plot each line once, because of dashing! uvec1(1:3) = node_uvec(1:3,nodes(j,i)) CALL DNew_L45_Path (5, uvec1) uvec2(1:3) = node_uvec(1:3,nodes(jp1,i)) CALL DGreat_To_L45 (uvec2) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! virgin END DO ! j = 1, 3 END DO ! i = 1, numel CALL DEnd_Group ! of elements !Plot element numbers, at centroids. (May be needed, e.g., for "Franciscan" mu_ assignments.) !If element numbers are NOT needed they can be deleted, as a graphical group. CALL DBegin_Group ! of element #s IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') END IF DO i = 1, numEl uvec2(1:3) = (node_uvec(1:3, nodes(1,i)) + & & node_uvec(1:3, nodes(2,i)) + & & node_uvec(1:3, nodes(3,i))) / 3.0D0 CALL DMake_Uvec(uvec2, uvec1) WRITE (c6,"(I6)") i c6 = ADJUSTL(c6) CALL DL5_Text (uvec = uvec1, angle_radians = 0.0D0, from_east = .FALSE., & & font_points = 8, lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = TRIM(c6)) END DO ! i = 1, numel CALL DEnd_Group ! of element #s END IF ! numel > 0 IF (nfl > 0) THEN ! NOTE that this case should NOT occur in Restore-type FEGs. This block of code COULD be deleted. IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF CALL DBegin_Group ! of dip ticks CALL DSet_Line_Style (width_points = 0.6D0, dashed = .FALSE.) DO i = 1, nfl dip_degrees = (fdip(1,i) + fdip(2,i)) / 2.0D0 uvec1(1:3) = node_uvec(1:3,nodef(1,i)) uvec2(1:3) = node_uvec(1:3,nodef(2,i)) uvec3(1:3) = (uvec1(1:3) + uvec2(1:3)) / 2.0D0 tick_azimuth = DCompass (from_uvec = uvec3, to_uvec = uvec2) IF (dip_degrees > 0.0D0) THEN tick_azimuth = tick_azimuth + Pi / 2.0D0 ELSE ! negative dip means dipping from N3-N4 side. tick_azimuth = tick_azimuth - Pi / 2.0D0 END IF IF (ABS(dip_degrees) > 75.0D0) THEN ! ~Vertical fault; no dip ticks (sense unknown). ELSE IF (ABS(dip_degrees) > 55.0D0) THEN ! ~65 deg. dip; use normal fault symbol CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = tick_azimuth, & & style_byte = 'N', & & size_points = tick_points, & & offset_points = 0.8D0) ELSE IF (ABS(dip_degrees) > 35.0D0) THEN ! ~45 deg. dip; use ambiguous/detachment fault symbol CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = tick_azimuth, & & style_byte = 'D', & & size_points = tick_points, & & offset_points = 0.8D0) ELSE IF (ABS(dip_degrees) >= 31.0D0) THEN ! (high-angle) thrust; i.e., not a subduction zone in SHELLS CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = tick_azimuth, & & style_byte = 'T', & & size_points = tick_points, & & offset_points = 0.8D0) ELSE ! (low-angle) thrust; a subduction zone in SHELLS CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = tick_azimuth, & & style_byte = 'P', & & size_points = tick_points, & & offset_points = 0.8D0) END IF ! different dip symbols END DO ! i = 1, nfl CALL DEnd_Group ! of dip ticks CALL DBegin_Group ! of fault traces CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) DO i = 1, nfl uvec1(1:3) = node_uvec(1:3,nodef(1,i)) CALL DNew_L45_Path (5, uvec1) uvec2(1:3) = node_uvec(1:3,nodef(2,i)) CALL DGreat_To_L45 (uvec2) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! i = 1, nfl CALL DEnd_Group ! of fault traces END IF ! nfl > 0 WRITE (*,"('+Working on finite-element grid....DONE.')") ELSE ! choice == 4; plot outline only WRITE (*,"(/' Working on outline of grid....')") ! build library of external edge segments (unsorted) nseg = 0 DO i = 1, numel DO j = 1, 3 jp = 1 + MOD(j,3) na = nodes(j,i) nb = nodes(jp,i) mated = .FALSE. might_mate: DO k = 1, numel DO l = 1, 3 lp = 1 + MOD(l,3) ma = nodes(l,k) mb = nodes(lp,k) IF ((na == mb).AND.(nb == ma)) THEN mated = .TRUE. EXIT might_mate END IF ! mate was found END DO ! l = 1, 3 END DO might_mate ! k = 1, numel IF (.NOT.mated) THEN nseg = MIN(nseg + 1, numnod) ! no problem expected segments(1:3,1,nseg) = node_uvec(1:3,na) segments(1:3,2,nseg) = node_uvec(1:3,nb) !note that segments always proceed counterclockwise around grid END IF ! NOT mated END DO ! j = 1, 3 END DO ! i = 1, numel !link segments to create outline CALL DSet_Line_Style (width_points = 4.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('gray______') CALL DBegin_Group j = 1 ! begin with first segment uvec1(1:3) = segments(1:3,1,j) CALL DNew_L45_Path (5, uvec1) DO i = 1, nseg uvec2(1:3) = segments(1:3,2,j) CALL DGreat_to_L45 (uvec2) find_next: DO k = 2, nseg IF (uvec2(1) == segments(1,1,k)) THEN IF (uvec2(2) == segments(2,1,k)) THEN IF (uvec2(3) == segments(3,1,k)) THEN j = k EXIT find_next END IF END IF END IF END DO find_next !prepare to loop uvec1 = uvec2 END DO ! i = 1, nseg CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) CALL DEnd_Group WRITE (*,"('+Working on outline of grid....DONE.')") END IF ! choice == 3 versus 4 DEALLOCATE ( node_uvec, segments ) DEALLOCATE ( nodes ) DEALLOCATE ( nodef, fdip ) CALL BEEPQQ (frequency = 440, duration = 250) ! end of finite element grid (3) or its outline (4) CASE (5) ! velocity vectors 2050 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .TRUE., & ! & velocity = .FALSE., & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which grid was used to compute velocities?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2050 END IF READ (21,*) ! title READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( vw(2*numnod) ) ALLOCATE ( vsize_mma(numnod) ) ALLOCATE (selected(numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod CLOSE(21) 2051 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .TRUE., & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be plotted?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2051 END IF DO i = 1, 3 READ (22,"(A)") line CALL Add_Title(line) END DO ! first 3 lines of velocity file READ (22,*) (vw(i), i = 1, (2*numnod)) !this read method should work with either SHELLS or RESTORE format DO i = 1, numnod v_South_mps = vw(2*i-1) v_East_mps = vw(2*i) vsize_mma(i) = 1000.0D0 * sec_per_year * DSQRT(v_South_mps**2 + v_East_mps**2) END DO ! i = 1, numnod CLOSE(22) WRITE (*,"(/' Here is the distribution of velocities (in mm/a):')") CALL Histogram (vsize_mma, numnod, .FALSE., maximum, minimum) CALL DPrompt_for_Real('For how many m.y. should velocity be projected?', velocity_my, velocity_my) WRITE (*,"(/' There will be ',I7,' vectors if they are not thinned.')") numnod 2052 CALL DPrompt_for_Integer('What thinning factor ( >=1 ) do you want?',vector_thinner,vector_thinner) IF (vector_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") GO TO 2052 END IF IF (vector_thinner > 1) THEN WRITE(string10,"(I10)") vector_thinner CALL Add_Title('(1/'//TRIM(ADJUSTL(string10))//') of Velocity Vectors') ELSE ! == 1 CALL Add_Title('Velocity Vectors') END IF CALL DThin_on_Sphere (node_uvec, numnod, vector_thinner, selected) WRITE (*,"(/' Working on velocity vectors....')") CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DBegin_Group DO i = 1, numnod IF (selected(i)) THEN uvec1(1:3) = node_uvec(1:3,i) v_South_mps = vw(2*i-1) v_East_mps = vw(2*i) CALL DVelocity_Vector_on_Sphere (from_uvec = uvec1, & & v_theta_mps = v_South_mps, v_phi_mps = v_East_mps, & & dt_sec = velocity_my * 1.0D6 * sec_per_year, deflate = .TRUE.) END IF ! selected(i) END DO ! actually plotting velocity vectors CALL DEnd_Group DEALLOCATE ( node_uvec, vw, vsize_mma, selected ) CALL Chooser(bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Velocity') number8 = ADJUSTL(DASCII8(velocity_my)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(x '//TRIM(number8)//' Ma):') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5D0*(x1_points+x2_points)-14.17D0, from_y = y2_points - 33.0D0, & & to_x = 0.5D0*(x1_points+x2_points)+14.17D0, to_y = y2_points - 33.0D0) v_mps = 0.01D0 * mp_scale_denominator / (velocity_my * 1.0D6 * sec_per_year) v_mma = v_mps * 1000.0D0 * sec_per_year number8 = ADJUSTL(DASCII8(v_mma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 36.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8)//' mm/a') CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 48.0D0 ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Velocity') number8 = ADJUSTL(DASCII8(velocity_my)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(x '//TRIM(number8)//' Ma):') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.0D0)-14.17D0, from_y = 0.5D0*(y1_points+y2_points)-10.0D0, & & to_x = (x1_points+29.0D0)+14.17D0, to_y = 0.5D0*(y1_points+y2_points)-10.0D0) v_mps = 0.01D0 * mp_scale_denominator / (velocity_my * 1.0D6 * sec_per_year) v_mma = v_mps * 1000.0D0 * sec_per_year number8 = ADJUSTL(DASCII8(v_mma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)//' mm/a') CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 58.0D0 END IF ! bottom or right legend WRITE (*,"('+Working on velocity vectors....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of velocity vector overlay CASE (6) ! displacement vectors CALL Get_Paired_Feg_Names (old_feg_file, old_feg_pathfile, & & new_feg_file, new_feg_pathfile) !This routine has tested files by opening and comparing numnod's. 2060 CALL DPrompt_for_Real('What is the geologic age of the older file, in Ma?',t2_Ma,t2_Ma) CALL DPrompt_for_Real('What is the geologic age of the younger file, in Ma?',t1_Ma,t1_Ma) IF (t2_Ma <= t1_Ma) THEN WRITE (*,"(' ERROR: Maximum age must exceed minimum age.')") GO TO 2060 END IF IF (t1_Ma <= 0.0D0) THEN WRITE (c6t2, "(F6.2)") t2_Ma line = 'Displacement since ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ')' ELSE WRITE (c6t1, "(F6.2)") t1_Ma WRITE (c6t2, "(F6.2)") t2_Ma line = 'Displacement from ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ') to ' // & & TRIM(ADJUSTL(c6t1)) // ' Ma (' // TRIM(Epoch(t1_Ma)) // ')' END IF CALL Add_Title(line) OPEN(UNIT = 21, FILE = old_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21,*) READ (21,*) numnod ALLOCATE ( old_node_uvec(3,numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) old_node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod CLOSE (21) OPEN(UNIT = 22, FILE = new_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (22,*) READ (22,*) numnod ALLOCATE ( new_node_uvec(3,numnod) ) DO i = 1, numnod READ (22,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) new_node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod CLOSE (22) WRITE (*,"(/' There will be ',I7,' vectors if they are not thinned.')") numnod 2061 CALL DPrompt_for_Integer('What thinning factor ( >=1 ) do you want?',vector_thinner,vector_thinner) IF (vector_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") GO TO 2061 END IF ALLOCATE ( selected(numnod) ) CALL DThin_on_Sphere (old_node_uvec, numnod, vector_thinner, selected) WRITE (*,"(/' Working on displacement vectors....')") CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DBegin_Group DO i = 1, numnod IF (selected(i)) THEN uvec1(1:3) = old_node_uvec(1:3,i) uvec2(1:3) = new_node_uvec(1:3,i) IF (DArc(uvec1,uvec2) > 0.0D0) THEN CALL DVector_on_Sphere (from_uvec = uvec1, & & to_uvec = uvec2, kind = 1) END IF ! non-null vector END IF ! selected(i) END DO ! actually plotting displacement vectors CALL DEnd_Group DEALLOCATE ( old_node_uvec, new_node_uvec, selected ) CALL Chooser(bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Net') number8 = ADJUSTL(DASCII8(velocity_my)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Displacement') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5D0*(x1_points+x2_points)-14.17D0, from_y = y2_points - 33.0D0, & & to_x = 0.5D0*(x1_points+x2_points)+14.17D0, to_y = y2_points - 33.0D0) CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 40.0D0 ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Net') number8 = ADJUSTL(DASCII8(velocity_my)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Displacement') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.0D0)-14.17D0, from_y = 0.5D0*(y1_points+y2_points)-10.0D0, & & to_x = (x1_points+29.0D0)+14.17D0, to_y = 0.5D0*(y1_points+y2_points)-10.0D0) CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 58.0D0 END IF ! bottom or right legend WRITE (*,"('+Working on displacement vectors....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) CASE (7) ! changes in horizontal velocity across faults 2070 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .TRUE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = traces_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which fault traces should be plotted?', traces_file, traces_file) traces_pathfile = TRIM(temp_path_in)//TRIM(traces_file) OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2070 END IF !find the highest-numbered trace, to dimension arrays high_trace = 0 DO READ (21,"(A)", IOSTAT = ios) line IF (ios == -1) EXIT ! EOF first_byte = line(1:1) IF ((first_byte == 'F').OR.(first_byte == 'f')) THEN READ (line,"(1X,I4)") trace_index high_trace = MAX(high_trace, trace_index) END IF END DO CLOSE (21) CALL DPrompt_for_Real('How large are the dip ticks (in points)?', tick_points, tick_points) WRITE (*,"(' ')") 2071 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .TRUE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = f_rst_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which slip-rates should be used?', f_rst_file, f_rst_file) f_rst_pathfile = TRIM(temp_path_in)//TRIM(f_rst_file) OPEN(UNIT = 22, FILE = f_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2071 END IF ! On 1st READing of f.rst, all we want to do is infer the time-step, in m.y.: READ (22,"(A)") f_rst_format READ (22,"(A)") f_rst_titles number_of_dts = 0 sum_of_dts = 0.0D0 now_starring: DO READ (22, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT now_starring IF (line(1:1) == '*') THEN line(1:1) = ' ' ! clear it READ (line, *) t1_Ma, t2_Ma number_of_dts = number_of_dts + 1 sum_of_dts = sum_of_dts + (t2_Ma - t1_Ma) END IF END DO now_starring CLOSE (22) delta_t_Ma = sum_of_dts / number_of_dts WRITE (*, "(' Inferred time-step size is ', F6.2, ' Ma.')") delta_t_Ma IF (delta_t_Ma == 0.0D0) THEN CALL Pause() t_Ma = 0.0D0 plotting_step_i = 1 ELSE CALL DPrompt_for_Real('What is the geologic time (age) for this plot, in Ma?', t_Ma, t_Ma) IF ((t_Ma > 0.0D0).AND.(MOD(t_Ma, delta_t_Ma) == 0.0D0)) THEN !Requested time is exactly on a time-step boundary, when (technically) heave-rates are discontinuous and undefined. !Modify request slightly in the young direction, because that is what the user typically means, ! and, also, results from the younger side of the time-step boundary are more likely to be available! t_Ma = t_Ma - 0.001D0 ! (Note that this change will vanish when ages are rounded for map-title purposes.) END IF plotting_step_i = MAX(1, NINT((t_Ma / delta_t_Ma) + 0.5D0)) END IF t1_Ma = (plotting_step_i - 1) * delta_t_Ma t2_Ma = plotting_step_i * delta_t_Ma WRITE (*, "(' Plotting mean heave-rates in timestep #', I5, ' (from ', F7.3, ' Ma to ', F7.3, ' Ma).')") plotting_step_i, t1_Ma, t2_Ma CALL Pause() OPEN (UNIT = 22, FILE = f_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') ! On 2nd READing of f.rst, extract mean (over one time-step) offset-rate per datum (in mm/a): ALLOCATE ( trace_parallel_mma(high_trace), & & trace_perpendicular_mma(high_trace), & & trace_oblique_mma(high_trace), & & component_sense(2, high_trace), & & plot_sense(high_trace) ) trace_parallel_mma = 0.0D0 ! whole array; from here on we will accumulate sum of one, two, (or more) ! offset-rates in the requested timestep. (There may be multiple cracks for ! one component of one trace.) trace_perpendicular_mma = 0.0D0 ! whole array trace_oblique_mma = 0.0D0 ! whole array component_sense = ' ' ! for all traces, and for both sub-codes (parallel sense, perpendicular sense) plot_sense = ' ' ! for all traces READ (22,"(A)") f_rst_format READ (22,"(A)") f_rst_titles read_f_rst: DO ! reading to end of file !N.B. Within one cycle of this loop, we are only concerned with a SINGLE component of any oblique-slip fault. READ (22, f_rst_format, IOSTAT = ios) c6, c50, offset_goal_km, offset_sigma_km, t2, t1 IF (ios == -1) EXIT read_f_rst ! EOF READ (c6, "(1X,I4,1X)") i c1 = c6(6:6) ! sense byte IF (delta_t_Ma == 0.0D0) THEN use_this_datum = (t1 == 0.0D0) ELSE ! positive time step use_this_datum = (t2 >= t_Ma).AND.(t1 <= t_Ma) ! checking whether the time-window for this datum even TOUCHES the fiducial time of plot? END IF IF (use_this_datum) THEN ! plotting_step_i overlaps the time window of this offset datum ! CAUTION: Only record sense byte for ACTIVE faults. (Otherwise, sense reversals over geologic time cause CHAOS!) IF ((c1 == 'L').OR.(c1 == 'l').OR.(c1 == 'R').OR.(c1 == 'r')) THEN ! set parallel-sense: component_sense(1, i) = c1 ELSE ! set perpendicular sense: component_sense(2, i) = c1 END IF !N.B. Goal offset rate will be: v_mma = offset_goal_km / (t2 - t1) ! in units of mm/a = km / Ma !Check for any '*' lines with ACTUAL model offset rate: stars_in_f_rst: DO READ (22, "(A)", IOSTAT = ios) line IF (ios == -1) EXIT stars_in_f_rst ! EOF IF ((line(1:1) == 'F').OR.(line(1:1) == 'f')) THEN BACKSPACE(22) EXIT stars_in_f_rst ELSE ! got a * in first byte of "line" line(1:1) = ' ' READ (line, *) t1, t2, t3, t4 ! t1 is the lesser age and t2 is the greater age, in Ma IF (delta_t_Ma == 0.0D0) THEN use_this_model_rate = (t1 == 0.0D0) ELSE ! positive time step offered_step_j = NINT(t2 / delta_t_Ma) use_this_model_rate = (offered_step_j == plotting_step_i) END IF IF (use_this_model_rate) THEN ! this rate applies ! t3 is the computed model offset rate; t4 was the goal offset rate v_mma = t3 END IF END IF END DO stars_in_f_rst ELSE ! not in the time window v_mma = 0.0D0 !Skip over any '*' lines to next 'F' line: skipping_f_rst: DO READ (22, "(A)", IOSTAT = ios) c6 IF (ios == -1) THEN ! EOF (probably); deal with current v_mma and then exit the reading loop: !We ADD to the SUM of per-crack rates, in case there are multiple cracks (data) for this fault in this timestep. !For example, the timestep from 1.0~1.2 Ma might include one rate before 1.1 Ma, and a different rate after 1.1 Ma, !and this is true even if we are only considering the strike-slip (or the dip-slip) component of offsets. IF ((c1 == 'T').OR.(c1 == 't')) THEN trace_perpendicular_mma(i) = trace_perpendicular_mma(i) + v_mma * cot_thrust_dip ELSE IF ((c1 == 'P').OR.(c1 == 'p')) THEN trace_perpendicular_mma(i) = trace_perpendicular_mma(i) + v_mma ELSE IF ((c1 == 'N').OR.(c1 == 'n')) THEN trace_perpendicular_mma(i) = trace_perpendicular_mma(i) + v_mma * cot_normal_dip ELSE IF ((c1 == 'D').OR.(c1 == 'd')) THEN trace_perpendicular_mma(i) = trace_perpendicular_mma(i) + v_mma ELSE IF ((c1 == 'R').OR.(c1 == 'r')) THEN trace_parallel_mma(i) = trace_parallel_mma(i) + v_mma ELSE IF ((c1 == 'L').OR.(c1 == 'l')) THEN trace_parallel_mma(i) = trace_parallel_mma(i) + v_mma END IF EXIT read_f_rst END IF IF ((c6(1:1) == 'F').OR.(c6(1:1) == 'f')) THEN BACKSPACE(22) EXIT skipping_f_rst END IF END DO skipping_f_rst END IF !We ADD to the SUM of per-crack rates, in case there are multiple cracks (data) for this fault in this timestep. !For example, the timestep from 1.0~1.2 Ma might include one rate before 1.1 Ma, and a different rate after 1.1 Ma, !and this is true even if we are only considering the strike-slip (or the dip-slip) component of offsets. IF ((c1 == 'T').OR.(c1 == 't')) THEN trace_perpendicular_mma(i) = trace_perpendicular_mma(i) + v_mma * cot_thrust_dip ELSE IF ((c1 == 'P').OR.(c1 == 'p')) THEN trace_perpendicular_mma(i) = trace_perpendicular_mma(i) + v_mma ELSE IF ((c1 == 'N').OR.(c1 == 'n')) THEN trace_perpendicular_mma(i) = trace_perpendicular_mma(i) + v_mma * cot_normal_dip ELSE IF ((c1 == 'D').OR.(c1 == 'd')) THEN trace_perpendicular_mma(i) = trace_perpendicular_mma(i) + v_mma ELSE IF ((c1 == 'R').OR.(c1 == 'r')) THEN trace_parallel_mma(i) = trace_parallel_mma(i) + v_mma ELSE IF ((c1 == 'L').OR.(c1 == 'l')) THEN trace_parallel_mma(i) = trace_parallel_mma(i) + v_mma END IF END DO read_f_rst CLOSE (22) !If any rate is negative, flip it, and also flip the sense... DO i = 1, high_trace IF (trace_parallel_mma(i) < 0.0D0) THEN IF ((component_sense(1, i) == 'R').OR.(component_sense(1, i) == 'r')) THEN component_sense(1, i) = 'L' ELSE IF ((component_sense(1, i) == 'L').OR.(component_sense(1, i) == 'l')) THEN component_sense(1, i) = 'R' END IF trace_parallel_mma(i) = -trace_parallel_mma(i) END IF ! trace_parallel_mma(i) was negative IF (trace_perpendicular_mma(i) < 0.0D0) THEN IF ((component_sense(2, i) == 'T').OR.(component_sense(2, i) == 't')) THEN component_sense(2, i) = 'N' ELSE IF ((component_sense(2, i) == 'N').OR.(component_sense(2, i) == 'n')) THEN component_sense(2, i) = 'T' ELSE IF ((component_sense(2, i) == 'P').OR.(component_sense(2, i) == 'p')) THEN component_sense(2, i) = 'D' ELSE IF ((component_sense(2, i) == 'D').OR.(component_sense(2, i) == 'd')) THEN component_sense(2, i) = 'P' END IF trace_perpendicular_mma(i) = -trace_perpendicular_mma(i) END IF ! trace_perpendicular_mma(i) was negative !Combine both components into one oblique heave-rate for the fault: trace_oblique_mma(i) = SQRT(trace_parallel_mma(i)**2 + trace_perpendicular_mma(i)**2) IF (ABS(trace_parallel_mma(i)) > ABS(trace_perpendicular_mma(i))) THEN plot_sense(i) = component_sense(1, i) ! plot the trace-parallel component ELSE ! trace-perpendicular heave-rate had greater magnitude: plot_sense(i) = component_sense(2, i) END IF END DO ! i = 1, high_trace WRITE (*,"(/' Here is the distribution of non-zero velocity changes' & & /' across faults at this time (in mm/a):')") CALL Histogram (trace_oblique_mma, high_trace, .TRUE., maximum, minimum) IF (dv_scale_mma == 0.0D0) dv_scale_mma = maximum CALL DPrompt_for_Real('What (fairly high) heave rate should be shown in Explanation?', dv_scale_mma, dv_scale_mma) CALL DPrompt_for_Real('How many points wide should this be plotted?', dv_scale_points, dv_scale_points) WRITE (*,"(/' Working on changes in horizontal velocity across faults....')") CALL Fault_Traces (trace_choice = 1, width_array = trace_oblique_mma, & & dw_scale_amount = dv_scale_mma, dw_scale_points = dv_scale_points, & & sense = plot_sense) DEALLOCATE ( trace_parallel_mma, trace_perpendicular_mma, trace_oblique_mma, component_sense, plot_sense ) CALL Chooser(bottom, right) IF (right) THEN !plot sample trace with width = dv_scale_points, !labelled with rate = dv_scale_mma CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points - 12.0D0 CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Change in') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'horizontal') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 36.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'velocity') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 48.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'across fault') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 60.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(mm/a):') number8 = ADJUSTL(DASCII8(dv_scale_mma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 72.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)) CALL DSet_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DNew_L12_Path (1, x1_points + 6.0D0, y2_points - 75.0D0 - 0.39D0 * dv_scale_points) CALL DLine_to_L12 (x2_points - 6.0D0, y2_points - 75.0D0 - 0.39D0 * dv_scale_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 87.0D0 + dv_scale_points CALL Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, tick_points) CALL DEnd_Group ELSE IF (bottom) THEN !plot sample trace with width = dv_scale_points, !labelled with rate = dv_scale_mma CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 79.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Change in horizontal velocity') CALL DL12_Text (level = 1, & & x_points = x1_points + 79.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'across fault (mm/a):') number8 = ADJUSTL(DASCII8(dv_scale_mma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 79.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)) CALL DSet_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DNew_L12_Path (1, (x1_points + 79.0D0) - 30.0D0, 0.5D0*(y1_points + y2_points) - 15.0D0 - 0.39D0 * dv_scale_points) CALL DLine_to_L12 ((x1_points + 79.0D0) + 30.0D0, 0.5D0*(y1_points + y2_points) - 15.0D0 - 0.39D0 * dv_scale_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 158.0D0 CALL Fault_Key_Bottom (bottomlegend_gap_points, bottomlegend_used_points, tick_points) CALL DEnd_Group END IF ! bottom or right legend CALL Add_Title('Fault heave rates') IF (t_Ma > 0.0D0) THEN WRITE (c7, "(F7.2)") t_Ma IF (c7(5:7) == ".00") THEN c7(5:7) = " " ELSE IF (c7(7:7) == '0') THEN c7(7:7) = ' ' END IF CALL Add_Title(TRIM(ADJUSTL(c7))//' Ma ('//TRIM(Epoch(t_Ma))//')') ELSE CALL Add_Title('Neotectonic/Holocene') END IF CALL Add_Title(traces_file) CALL Add_Title(f_rst_file) WRITE (*,"('+Working on changes in horizontal velocity across faults....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of change-in-horizontal-velocity-across-faults overlay CASE (8) ! net heave of faults over geologic time 2080 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .TRUE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = traces_file, & ! & using_path = temp_path_in) WRITE (*, *) WRITE (*, "(' You can choose to plot fault-ribbons in either present or paleo-positions.')") WRITE (*, "(' For present positions, choose the f.dig file that was INPUT to Restore.')") WRITE (*, "(' For paleo-positions, choose any f.dig file that was OUTPUT from Restore.')") CALL DPrompt_for_String('Which fault-trace locations (f.dig) should be plotted?', traces_file, traces_file) traces_pathfile = TRIM(temp_path_in)//TRIM(traces_file) OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2080 END IF !find the highest-numbered trace, to dimension arrays high_trace = 0 DO READ (21,"(A)", IOSTAT = ios) line IF (ios == -1) EXIT ! EOF first_byte = line(1:1) IF ((first_byte == 'F').OR.(first_byte == 'f')) THEN READ (line,"(1X,I4)") trace_index high_trace = MAX(high_trace, trace_index) END IF END DO CLOSE (21) ALLOCATE ( trace_parallel_km(high_trace), & & trace_perpendicular_km(high_trace), & & trace_oblique_km(high_trace), & & component_sense(2, high_trace), & & plot_sense(high_trace) ) trace_parallel_km = 0.0D0 ! whole array; totals will be integrated trace_perpendicular_km = 0.0D0 ! whole array; totals will be integrated trace_oblique_km = 0.0D0 ! whole array; final value to be from Pythagorean theorom component_sense = ' ' ! whole array plot_sense = ' ' ! whole array CALL DPrompt_for_Real('How large are the dip ticks (in points)?',tick_points,tick_points) WRITE (*,"(' ')") 2081 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .TRUE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = f_rst_file, & ! & using_path = temp_path_in) WRITE (*, *) WRITE (*, "(' Next, please choose the file containing fault-offset information:')") WRITE (*, "(' If you choose the f.rst file INPUT to Restore, you get a map of heave GOALS.')") WRITE (*, "(' If you choose any f.rst file OUTPUT by Restore, you get a map of MODEL heaves.')") CALL DPrompt_for_String('Which (f.rst) file of offset-rates should be integrated?', f_rst_file, f_rst_file) f_rst_pathfile = TRIM(temp_path_in)//TRIM(f_rst_file) OPEN(UNIT = 22, FILE = f_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2081 END IF CLOSE (22) 2082 CALL DPrompt_for_Real('What is the maximum geologic time (age) limit for integration, in Ma?', t2_Ma, t2_Ma) CALL DPrompt_for_Real('What is the minimum geologic time (age) limit for integration, in Ma?', t1_Ma, t1_Ma) IF (t2_Ma < t1_Ma) THEN WRITE (*,"(' ERROR: Minimum age cannot exceed maximum age.')") GO TO 2082 END IF IF (t1_Ma <= 0.0D0) THEN WRITE (c6t2, "(F6.2)") t2_Ma line = 'Heave (horizontal offset) on faults since ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ')' ELSE WRITE (c6t1, "(F6.2)") t1_Ma WRITE (c6t2, "(F6.2)") t2_Ma line = 'Heave on faults from ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ') to ' // & & TRIM(ADJUSTL(c6t1)) // ' Ma (' // TRIM(Epoch(t1_Ma)) // ')' END IF CALL Add_Title(line) OPEN(UNIT = 22, FILE = f_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') ! read f.rst and integrate horizontal component of slip-rate (mm/a --> km): READ (22,"(A)") f_rst_format READ (22,"(A)") f_rst_titles read_f_rst2: DO ! reading to end of file READ (22, f_rst_format, IOSTAT = ios) c6, c50, t1, t2, t3, t4 IF (ios == -1) EXIT read_f_rst2 ! EOF ! t1 is offset in km, t2 is uncertainty (sigma) in km, t3 is max age, t4 is min age (both in Ma) overlap = MIN((t2_Ma - t1_Ma), (t3 - t4), (t2_Ma - t4), (t3 - t1_Ma)) IF (overlap > 0.0D0) THEN READ (c6, "(1X, I4, 1X)") i !Guard against subscript-out-of-range (due to mismatch between fault-traces file and fault-offset file?): IF (i > high_trace) THEN WRITE (*, *) WRITE (*, "(' ERROR: Fault-traces.dig file has highest Fnnnn index of: ', I6)") high_trace WRITE (*, "(' but fault-offset file contains trace with index of: ', I6)") i WRITE (*, "(' Please use a fault-traces.dig file that contains ALL necessary traces!')") CALL Pause() STOP END IF c1 = c6(6:6) ! offset sense (L, R, N, D, P, T, ...) IF ((c1 == 'L').OR.(c1 == 'l').OR.(c1 == 'R').OR.(c1 == 'r')) THEN ! parallel sense: component_sense(1, i) = c1 ELSE ! perpendicular sense: component_sense(2, i) = c1 END IF v_mma_datum = t1 / (t3 - t4) ! mm/a = km/Ma !Check for any '*' lines with better rate estimate; !if found, replace v_mma with mean rate in window v_mma_model = 0.0D0 got_stars = .FALSE. stars_in_f_rst2: DO READ (22, "(A)", IOSTAT = ios) line IF (ios == -1) EXIT stars_in_f_rst2 ! EOF IF ((line(1:1) == 'F').OR.(line(1:1) == 'f')) THEN BACKSPACE(22) EXIT stars_in_f_rst2 ELSE ! got a * in line got_stars = .TRUE. READ (line,"(1X,2F8.3,2F10.4)") t1, t2, t3, t4 ! t1 is the lesser age and t2 is the greater age of a particular timestep, in Ma overlap_star = MIN((t2_Ma - t1_Ma), (t2 - t1), (t2_Ma - t1), (t2 - t1_Ma)) IF (overlap_star > 0.0D0) THEN ! this rate applies ! t3 is the computed rate; t4 was the goal rate v_mma_model = v_mma_model + t3 * overlap_star / overlap END IF END IF END DO stars_in_f_rst2 IF (got_stars) THEN v_mma = v_mma_model ELSE v_mma = v_mma_datum END IF !Check whether a multiplier is needed, to convert from throw to heave? IF ((c1 == 'T').OR.(c1 == 't')) THEN multiplier = cot_thrust_dip ELSE IF ((c1 == 'N').OR.(c1 == 'n')) THEN multiplier = cot_normal_dip ELSE ! R, L, D, P multiplier = 1.0 END IF !Note: ADD instead of EQUATING because other time !windows may follow for the same fault trace and offset sense! IF ((c1 == 'L').OR.(c1 == 'l').OR.(c1 == 'R').OR.(c1 == 'r')) THEN ! parallel sense: trace_parallel_km(i) = trace_parallel_km(i) + multiplier * overlap * v_mma ! Ma * mm/a = km ELSE ! perpendicular sense: trace_perpendicular_km(i) = trace_perpendicular_km(i) + multiplier * overlap * v_mma ! Ma * mm/a = km END IF ELSE !No overlap with integration window; !skip over any '*' lines to next 'F' line: skipping_f_rst2: DO READ (22, "(A)", IOSTAT = ios) c6 IF (ios == -1) EXIT skipping_f_rst2 ! EOF IF ((c6(1:1) == 'F').OR.(c6(1:1) == 'f')) THEN BACKSPACE(22) EXIT skipping_f_rst2 END IF END DO skipping_f_rst2 END IF ! overlap > 0, or not END DO read_f_rst2 CLOSE (22) !Check for negative offsets; if any, reverse the slip style: DO i = 1, high_trace IF (trace_parallel_km(i) < 0.0D0) THEN IF ((component_sense(1, i) == 'R').OR.(component_sense(1, i) == 'r')) THEN component_sense(1, i) = 'L' ELSE IF ((component_sense(1, i) == 'L').OR.(component_sense(1, i) == 'l')) THEN component_sense(1, i) = 'R' END IF trace_parallel_km(i) = -trace_parallel_km(i) END IF ! trace_parallel_km(i) was negative IF (trace_perpendicular_km(i) < 0.0D0) THEN IF ((component_sense(2, i) == 'T').OR.(component_sense(2, i) == 't')) THEN component_sense(2, i) = 'N' ELSE IF ((component_sense(2, i) == 'N').OR.(component_sense(2, i) == 'n')) THEN component_sense(2, i) = 'T' ELSE IF ((component_sense(2, i) == 'P').OR.(component_sense(2, i) == 'p')) THEN component_sense(2, i) = 'D' ELSE IF ((component_sense(2, i) == 'D').OR.(component_sense(2, i) == 'd')) THEN component_sense(2, i) = 'P' ELSE IF ((component_sense(2, i) == 'R').OR.(component_sense(2, i) == 'r')) THEN component_sense(2, i) = 'L' ELSE IF ((component_sense(2, i) == 'L').OR.(component_sense(2, i) == 'l')) THEN component_sense(2, i) = 'R' END IF trace_perpendicular_km(i) = -trace_perpendicular_km(i) END IF ! trace_perpendicular_km(i) was negative trace_oblique_km(i) = SQRT(trace_parallel_km(i)**2 + trace_perpendicular_km(i)**2) IF (ABS(trace_parallel_km(i)) > ABS(trace_perpendicular_km(i))) THEN ! plot in strike-slip color: plot_sense(i) = component_sense(1, i) ELSE ! plot with dip-slip color: plot_sense(i) = component_sense(2, i) END IF END DO ! i = 1, high_trace WRITE (*,"(/' Here is the distribution of non-zero heaves' & & /' on faults in this time window (in km):')") CALL Histogram (trace_oblique_km, high_trace, .TRUE., maximum, minimum) IF (du_scale_km == 0.0D0) du_scale_km = maximum CALL DPrompt_for_Real('What amount of heave (in km) should be shown in the Explanation?', du_scale_km, du_scale_km) CALL DPrompt_for_Real('How many points wide should this be plotted?', du_scale_points, du_scale_points) WRITE (*,"(/' Working on heaves of faults....')") CALL Fault_Traces (trace_choice = 1, width_array = trace_oblique_km, & & dw_scale_amount = du_scale_km, dw_scale_points = du_scale_points, & & sense = plot_sense) DEALLOCATE ( trace_parallel_km, trace_perpendicular_km, trace_oblique_km, component_sense, plot_sense ) CALL Chooser(bottom, right) IF (right) THEN !plot sample trace with width = du_scale_points, !labelled with heave = du_scale_km CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points - 12.0D0 CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Heave') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(horizontal') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 36.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'offset)') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 48.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'across fault') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 60.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(in km):') number8 = ADJUSTL(DASCII8(du_scale_km)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 72.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)) CALL DSet_Line_Style (width_points = du_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DNew_L12_Path (1, x1_points + 6.0D0, y2_points - 75.0D0 - 0.39D0 * du_scale_points) CALL DLine_to_L12 (x2_points - 6.0D0, y2_points - 75.0D0 - 0.39D0 * du_scale_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 87.0D0 + dv_scale_points CALL Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, tick_points) CALL DEnd_Group ELSE IF (bottom) THEN !plot sample trace with width = du_scale_points, !labelled with heave = du_scale_km CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 79.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Heave (horizontal offset)') CALL DL12_Text (level = 1, & & x_points = x1_points + 79.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'across fault (in km):') number8 = ADJUSTL(DASCII8(du_scale_km)) CALL DL12_Text (level = 1, & & x_points = x1_points + 79.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)) CALL DSet_Line_Style (width_points = du_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DNew_L12_Path (1, (x1_points + 79.0D0) - 30.0D0, 0.5D0*(y1_points + y2_points) - 15.0D0 - 0.39D0 * du_scale_points) CALL DLine_to_L12 ((x1_points + 79.0D0) + 30.0D0, 0.5D0*(y1_points + y2_points) - 15.0D0 - 0.39D0 * du_scale_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 158.0D0 CALL Fault_Key_Bottom (bottomlegend_gap_points, bottomlegend_used_points, tick_points) CALL DEnd_Group END IF ! bottom or right legend CALL Add_Title(traces_file) CALL Add_Title(f_rst_file) CALL Add_Title(TRIM(ADJUSTL(DASCII8(t_Ma)))//' Ma ('//TRIM(Epoch(t_Ma))//')') ! end of 8: heave of faults CASE (9) ! paleomagnetic paleolatitude anomalies CALL Add_Title('Paleolatitude Anomalies') 2090 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .TRUE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = p_rst_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which paleomagnetic dataset should be plotted?',p_rst_file,p_rst_file) p_rst_pathfile = TRIM(temp_path_in)//TRIM(p_rst_file) OPEN(UNIT = 21, FILE = p_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2090 END IF CALL Add_Title(p_rst_file) READ (21,"(A)") p_rst_format READ (21,"(A)") p_rst_titles p_rst_count = 0 size_p_rst: DO ! reading paleomagnetic data, to determine number of sites READ (21, p_rst_format, IOSTAT = ios) c50, lon, lat, anomaly, sigma, & & t1, t2, t3, t4, plon, plat IF (ios == -1) EXIT size_p_rst ! EOF p_rst_count = p_rst_count + 1 !Try to read a "+" line to see if this file has model output: READ (21, "(A)", IOSTAT = ios) c1 ! restored position will not be used IF (ios == -1) c1 = ' ' ! EOF marker, to be used below got_stars = (c1 == '+') IF (got_stars) THEN p_rst_stars1: DO READ (21, "(A1,2F8.3,F10.4)", IOSTAT = ios) c1, t1_Ma, t2_Ma, rate IF (ios == -1) EXIT p_rst_stars1 ! EOF IF (c1 == '*') THEN ! model rate ELSE IF (c1 == '&') THEN ! rotation data; ignore ELSE ! c1 /= '*' or '&'; have overshot BACKSPACE(21) EXIT p_rst_stars1 END IF ! c1 is or is not '*' END DO p_rst_stars1 ELSE ! got_stars = F; no model output in this file IF (c1 /= ' ') BACKSPACE (21) ! so next datum can be read in next time through loop END IF ! got_stars, or not END DO size_p_rst CLOSE (21) ALLOCATE ( paleolatitude_anomaly_degrees(p_rst_count) ) OPEN(UNIT = 21, FILE = p_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21,"(A)") p_rst_format READ (21,"(A)") p_rst_titles p_rst_count = 0 ! sic; using as index one more time scan_p_rst: DO ! reading paleomagnetic data, to display anomaly sizes READ (21, p_rst_format, IOSTAT = ios) c50, lon, lat, anomaly, sigma, & & t1, t2, t3, t4, plon, plat IF (ios == -1) EXIT scan_p_rst ! EOF p_rst_count = p_rst_count + 1 paleolatitude_anomaly_degrees(p_rst_count) = anomaly !Try to read a "+" line to see if this file has model output: READ (21, "(A)", IOSTAT = ios) c1 ! restored position will not be used IF (ios == -1) c1 = ' ' ! EOF marker, to be used below got_stars = (c1 == '+') IF (got_stars) THEN p_rst_stars2: DO READ (21, "(A1,2F8.3,F10.4)", IOSTAT = ios) c1, t1_Ma, t2_Ma, rate IF (ios == -1) EXIT p_rst_stars2 ! EOF IF (c1 == '*') THEN ! model rate ELSE IF (c1 == '&') THEN ! rotation data; ignore ELSE ! c1 /= '*' or '&'; have overshot BACKSPACE(21) EXIT p_rst_stars2 END IF ! c1 is or is not '*' END DO p_rst_stars2 ELSE ! got_stars = F; no model output in this file IF (c1 /= ' ') BACKSPACE (21) ! so next datum can be read in next time through loop END IF ! got_stars, or not END DO scan_p_rst CLOSE (21) WRITE (*,"(/' Here is the distribution of paleolatitude anomalies in degrees:')") CALL Histogram (paleolatitude_anomaly_degrees, p_rst_count, .FALSE., maximum, minimum) DEALLOCATE (paleolatitude_anomaly_degrees) 2091 CALL DPrompt_for_Real('Enter a scaling factor for paleolatitude anomaly bars ( =1 for true size, ' // & & '<1 to reduce, or >1 to expand)', paleolatitude_factor, paleolatitude_factor) IF (paleolatitude_factor <= 0.0D0) THEN WRITE (*,"(' ERROR: Factor must be positive.')") paleolatitude_factor = 1.0D0 GO TO 2091 END IF WRITE (*,"(/' Working on paleolatitude anomalies....')") CALL DBegin_Group OPEN(UNIT = 21, FILE = p_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21,"(A)") p_rst_format READ (21,"(A)") p_rst_titles got_any_stars = .FALSE. ! may be set T below; controls contents of legend read_p_rst: DO ! reading paleomagnetic data, to end of file READ (21, p_rst_format, IOSTAT = ios) c50, lon, lat, anomaly, sigma, & & t1, t2, t3, t4, plon, plat IF (ios == -1) EXIT read_p_rst ! EOF !not using t1: counterclockwise rotation or t2: its sigma t_Ma = (t3 + t4) / 2.0 site_moved_North = (anomaly <= 0.0D0) CALL DLonLat_2_Uvec(plon, plat, uvec1) ! paleopole CALL DLonLat_2_Uvec( lon, lat, uvec2) ! site azimuth_radians = Pi + DCompass(uvec2, uvec1) ! at site; away from paleopole (S) !Try to read a "+" line to see if this file has model output: READ (21, "(A)", IOSTAT = ios) c1 ! restored position will not be used IF (ios == -1) c1 = ' ' ! EOF marker, to be used below got_stars = (c1 == '+') got_any_stars = got_any_stars .OR. got_stars IF (got_stars) THEN model = 0.0 p_rst_stars3: DO READ (21, "(A1,2F8.3,F10.4)", IOSTAT = ios) c1, t1_Ma, t2_Ma, rate IF (ios == -1) EXIT p_rst_stars3 ! EOF IF (c1 == '*') THEN model = model + rate * (t2_Ma - t1_Ma) ELSE IF (c1 == '&') THEN ! rotation data; ignore ELSE ! c1 /= '*' or '&'; have overshot BACKSPACE(21) EXIT p_rst_stars3 END IF ! c1 is or is not '*' END DO p_rst_stars3 ELSE ! got_stars = F; no model output in this file IF (c1 /= ' ') BACKSPACE (21) ! so next datum can be read in next time through loop END IF ! got_stars, or not !HERE is where we plot the paleolatitude anomaly symbol: twosigma_width_points = 12.0D0 ! ADJUST HERE to change width of colored bars, diameter of site circle onesigma_width_points = 8.0D0 ! ADJUST HERE to change width of colored bars, diameter of site circle no_sigma_width_points = 4.0D0 ! ADJUST HERE to change width of colored bars, diameter of site circle IF (ABS(anomaly)/sigma >= 2.0D0) THEN ! important anomaly; wide line p_rst_width_points = twosigma_width_points ELSE IF (ABS(anomaly)/sigma >= 1.0D0) THEN ! medium line width p_rst_width_points = onesigma_width_points ELSE ! insignificant anomaly, smaller than one sigma p_rst_width_points = no_sigma_width_points END IF node_radius_radians = 0.5D0 * p_rst_width_points * 3.528D-4 * mp_scale_denominator / mp_radius_meters CALL DBegin_Group ! for this one symbol !First, the red/blue bar with foreground outline, for the datum CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN IF (site_moved_North) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'dark_blue_') END IF ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF IF (site_moved_North) THEN ! normal case; site was once further S add_radians = 0.0D0 ELSE ! site was once further N, and has moved South add_radians = Pi END IF CALL DNew_L45_Path(5, uvec2) CALL DTurn_To (azimuth_radians = azimuth_radians + add_radians + Pi_over_2, & & base_uvec = uvec2, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DGreat_to_L45(uvec3) ! short leg to left of site CALL DTurn_To (azimuth_radians = azimuth_radians + add_radians, & & base_uvec = uvec3, & & far_radians = ABS(anomaly) * radians_per_degree * paleolatitude_factor, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DGreat_to_L45(uvec3) ! long leg to S(?) IF (anomaly > 0.0D0) uvec_saved = uvec3 ! memorize, for plotting number of degrees cross_radians = DCompass(uvec3, uvec1) + Pi_over_2 + add_radians CALL DTurn_To (azimuth_radians = cross_radians, & & base_uvec = uvec3, & & far_radians = 2.0D0 * node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DGreat_to_L45(uvec3) ! short leg back to right in the S(?) IF (anomaly <= 0.0D0) uvec_saved = uvec3 CALL DTurn_To (azimuth_radians = azimuth_radians + add_radians - Pi_over_2, & & base_uvec = uvec2, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec4) CALL DGreat_to_L45(uvec4) ! long return leg to right of site CALL DGreat_to_L45(uvec2) CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) !Add integer with number of degrees to right of end of red/blue bar: WRITE (c3, "(I3)") NINT(ABS(anomaly)) c3 = ADJUSTL(c3) rotate_radians = -DCompass(uvec_saved, uvec1) ! -azimuth from number site to pole CALL DL5_Text (uvec = uvec_saved, angle_radians = rotate_radians, from_east = .TRUE., & & font_points = 16, lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = ' ' // TRIM(c3)) !Second, the green/white bar with foreground line, for the a prediction .LE. datum !(If anomaly is zero, then postpone model prediction and make it yellow.) IF (got_stars.AND.(anomaly /= 0.0D0)) THEN IF ((model/anomaly) > 1.0D0) THEN ! model OVERSHOOTS datum; plot only part of bar now green_part = anomaly ELSE ! normal case; model is less than, or opposite sign from, datum green_part = model END IF CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'background') END IF IF (green_part <= 0.0D0) THEN ! normal case; site was once further S add_radians = 0.0D0 ELSE ! site was once further N add_radians = Pi END IF CALL DNew_L45_Path(5, uvec2) CALL DTurn_To (azimuth_radians = azimuth_radians + add_radians + Pi_over_2, & & base_uvec = uvec2, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DGreat_to_L45(uvec3) ! short leg to left of site CALL DTurn_To (azimuth_radians = azimuth_radians + add_radians, & & base_uvec = uvec3, & & far_radians = ABS(green_part) * radians_per_degree * paleolatitude_factor, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DGreat_to_L45(uvec3) ! long leg to S(?) cross_radians = DCompass(uvec3, uvec1) + Pi_over_2 + add_radians CALL DTurn_To (azimuth_radians = cross_radians, & & base_uvec = uvec3, & & far_radians = 2.0 * node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DGreat_to_L45(uvec3) ! short leg back to right in the S(?) CALL DTurn_To (azimuth_radians = azimuth_radians + add_radians - Pi_over_2, & & base_uvec = uvec2, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DGreat_to_L45(uvec3) ! long return leg to right of site CALL DGreat_to_L45(uvec2) CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! plotting green bar IF (got_stars.AND.((anomaly == 0.0D0).OR.(model/anomaly > 1.0D0))) THEN !Third, the yellow/grey bar with foreground line, for the a prediction exceeding CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'yellow____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') END IF IF (model <= 0.0D0) THEN ! normal case; site was once further S add_radians = 0.0D0 ELSE ! site was once further N add_radians = Pi END IF CALL DTurn_To (azimuth_radians = azimuth_radians + add_radians + Pi_over_2, & & base_uvec = uvec2, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DTurn_To (azimuth_radians = azimuth_radians + add_radians, & & base_uvec = uvec3, & & far_radians = ABS(anomaly) * radians_per_degree * paleolatitude_factor, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DNew_L45_path(5, uvec3) ! after long "anomaly" leg to S(?) uvec4 = uvec3 ! save to close path with ahead_radians = DCompass(uvec3, uvec1) + Pi + add_radians CALL DTurn_To (azimuth_radians = ahead_radians, & & base_uvec = uvec3, & & far_radians = ABS(model - anomaly) * radians_per_degree * paleolatitude_factor, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DGreat_To_L45(uvec3) ! medium "overshoot" leg to S(?) cross_radians = DCompass(uvec3, uvec1) + Pi_over_2 + add_radians CALL DTurn_To (azimuth_radians = cross_radians, & & base_uvec = uvec3, & & far_radians = 2.0 * node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DGreat_to_L45(uvec3) ! short leg back to right in the S(?) CALL DTurn_To (azimuth_radians = azimuth_radians + add_radians - Pi_over_2, & & base_uvec = uvec2, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DTurn_To (azimuth_radians = azimuth_radians + add_radians, & & base_uvec = uvec3, & & far_radians = ABS(anomaly) * radians_per_degree * paleolatitude_factor, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DGreat_to_L45(uvec3) ! long return leg to right of site CALL DGreat_to_L45(uvec4) CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! plotting yellow bar !Lastly, add circle to show site, and age (integer) in Ma CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DTurn_To (azimuth_radians = -Pi_over_2, & & base_uvec = uvec2, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DNew_L45_Path(5, uvec3) CALL DSmall_To_L45(pole_uvec = uvec2, to_uvec = uvec3) CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) j = NINT(t_Ma) WRITE (c3,"(I3)") j c3 = ADJUSTL(c3) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL5_Text (uvec = uvec3, angle_radians = 0.0D0, from_east = .TRUE., & & font_points = 16, lr_fraction = 1.1D0, ud_fraction = 0.4D0, & & text = TRIM(c3)) CALL DEnd_Group ! for one symbol END DO read_p_rst CALL DEnd_Group ! of all symbols CLOSE (21) ! p.dat CALL Chooser (bottom, right) IF (bottom) THEN CALL DBegin_Group ! for bottom paleolatitude legend CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points) / 2.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') x1p = x1_points + 40.0D0 CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 14.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Paleomagnetic') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 29.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'site, with') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 43.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'age in Ma:') x1p = x1_points + 104.0D0 CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 14.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 29.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 43.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DCircle_on_L12 (level = 1, x = x1_points + 111.0D0, y = y2_points - 10.0D0, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 109.0D0, y = y2_points - 24.0D0, radius = onesigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 107.0D0, y = y2_points - 39.0D0, radius = no_sigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x1_points + 175.0D0, y_points = y2_points - 14.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Size (in degrees)') CALL DL12_Text (level = 1, x_points = x1_points + 175.0D0, y_points = y2_points - 29.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'and significance') CALL DL12_Text (level = 1, x_points = x1_points + 175.0D0, y_points = y2_points - 43.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'of latitude anomaly:') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF x1p = x1_points + 240.0D0 x2p = x1_points + 300.0D0 y2p = y2_points - 8.5D0 + twosigma_width_points / 2.0D0 y1p = y2p - twosigma_width_points CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_To_L12(x2p, y1p) CALL DLine_To_L12(x2p, y2p) CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x2p = x1_points + 285.0D0 y2p = ycp y1p = y2p - onesigma_width_points CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_To_L12(x2p, y1p) CALL DLine_To_L12(x2p, y2p) CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x2p = x1_points + 270.0D0 y2p = y1_points + 3.0D0 + no_sigma_width_points / 2.0D0 y1p = y2p - no_sigma_width_points CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_To_L12(x2p, y1p) CALL DLine_To_L12(x2p, y2p) CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DCircle_on_L12 (level = 1, x = x1p, y = y2_points - 8.5D0, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1p, y = ycp - onesigma_width_points / 2.0D0, radius = onesigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1p, y = y1_points + 3.0D0, radius = no_sigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern(.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern(.FALSE., 'foreground') END IF x2p = x1_points + 300.0D0 y2p = y2_points - 8.5D0 + twosigma_width_points / 2.0D0 CALL DL12_Text (level = 1, x_points = x2p, y_points = y2p, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = -0.3D0, ud_fraction = 0.4D0, & & text = '7') x2p = x1_points + 285.0D0 y2p = ycp CALL DL12_Text (level = 1, x_points = x2p, y_points = y2p, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = -0.3D0, ud_fraction = 0.4D0, & & text = '5') x2p = x1_points + 270.0D0 y2p = y1_points + 3.0D0 + no_sigma_width_points / 2.0D0 CALL DL12_Text (level = 1, x_points = x2p, y_points = y2p, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = -0.3D0, ud_fraction = 0.4D0, & & text = '3') CALL DSet_Fill_or_Pattern(.FALSE., 'foreground') x2p = x1_points + 304.0D0 y2p = y2_points - 8.5D0 + twosigma_width_points / 2.0D0 CALL DL12_Text (level = 1, x_points = x2p, y_points = y2p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.0D0, ud_fraction = 0.8D0, & & text = 'anomaly > 2 sigma') y2p = ycp CALL DL12_Text (level = 1, x_points = x2p, y_points = y2p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.0D0, ud_fraction = 0.5D0, & & text = 'anomaly < 2 sigma') y2p = y1_points + 3.0D0 + no_sigma_width_points / 2.0D0 CALL DL12_Text (level = 1, x_points = x2p, y_points = y2p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.0D0, ud_fraction = 0.2D0, & & text = 'anomaly < 1 sigma') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 410.0D0 IF (got_any_stars) THEN ! add model predictions to legend x1p = x1_points + 465.0D0 CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 13.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Paleolatitude') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 26.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'anomaly') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 39.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'predicted by') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 52.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'the model:') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF x1p = x1_points + 530.0D0 x2p = x1_points + 590.0D0 y2p = y2_points - 2.0D0 y1p = y2p - twosigma_width_points CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_To_L12(x2p, y1p) CALL DLine_To_L12(x2p, y2p) CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) y2p = ycp + twosigma_width_points / 2.0D0 y1p = y2p - twosigma_width_points CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_To_L12(x2p, y1p) CALL DLine_To_L12(x2p, y2p) CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'yellow____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') END IF x2p = x1_points + 620.0D0 y2p = y1_points + 2.0D0 + twosigma_width_points y1p = y1_points + 2.0D0 CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_To_L12(x2p, y1p) CALL DLine_To_L12(x2p, y2p) CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'background') END IF x2p = x1_points + 504.0D0 y2p = y2_points - 2.0D0 y1p = y2p - twosigma_width_points CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_To_L12(x2p, y1p) CALL DLine_To_L12(x2p, y2p) CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x2p = x1_points + 561.0D0 y2p = ycp + twosigma_width_points / 2.0D0 y1p = y2p - twosigma_width_points CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_To_L12(x2p, y1p) CALL DLine_To_L12(x2p, y2p) CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x2p = x1_points + 590.0D0 y2p = y1_points + 2.0D0 + twosigma_width_points y1p = y1_points + 2.0D0 CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_To_L12(x2p, y1p) CALL DLine_To_L12(x2p, y2p) CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') y1p = y2_points - 2.0D0 - twosigma_width_points / 2.0D0 CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) y1p = ycp CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) y1p = y1_points + 2.0D0 + twosigma_width_points / 2.0D0 CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') x1p = x1_points + 627.0D0 y1p = y2_points - 2.0D0 - twosigma_width_points / 2.0D0 CALL DL12_Text (level = 1, x_points = x1p, y_points = y1p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'opposite to datum') y1p = ycp CALL DL12_Text (level = 1, x_points = x1p, y_points = y1p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'less than datum') y1p = y1_points + 2.0D0 + twosigma_width_points / 2.0D0 CALL DL12_Text (level = 1, x_points = x1p, y_points = y1p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'more than datum') bottomlegend_used_points = bottomlegend_used_points + 317.0D0 ! (for model predictions only) END IF CALL DEnd_Group ! of bottom legend ELSE IF (right) THEN CALL DBegin_Group ! for right paleolatitude legend CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points xcp = (x1_points + x2_points) / 2.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 14.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Paleomagnetic') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 29.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'site, with') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 43.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'age in Ma:') CALL DL12_Text (level = 1, x_points = x1_points + 14.0D0, y_points = y2_points - 60.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DCircle_on_L12 (level = 1, x = x1_points + 20.5D0, y = y2_points - 55.0D0, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x1_points + 42.0D0, y_points = y2_points - 60.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DCircle_on_L12 (level = 1, x = x1_points + 46.5D0, y = y2_points - 55.0D0, radius = onesigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x1_points + 68.0D0, y_points = y2_points - 60.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DCircle_on_L12 (level = 1, x = x1_points + 69.5D0, y = y2_points - 55.0D0, radius = no_sigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 83.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Size (in') IF (ai_using_color) CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 97.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'degrees)') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 112.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '& significance') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 126.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'of latitude') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 141.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'anomaly:') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF x1p = x1_points + 5.0D0 - no_sigma_width_points / 2.0D0 x2p = x1p + no_sigma_width_points CALL DNew_L12_Path(1, x1p, y2_points - 151.0D0) CALL DLine_To_L12(x1p, y2_points - 181.0D0) CALL DLine_To_L12(x2p, y2_points - 181.0D0) CALL DLine_To_L12(x2p, y2_points - 151.0D0) CALL DLine_To_L12(x1p, y2_points - 151.0D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x1p = x1_points + 29.5D0 - onesigma_width_points / 2.0D0 x2p = x1p + onesigma_width_points CALL DNew_L12_Path(1, x1p, y2_points - 151.0D0) CALL DLine_To_L12(x1p, y2_points - 196.0D0) CALL DLine_To_L12(x2p, y2_points - 196.0D0) CALL DLine_To_L12(x2p, y2_points - 151.0D0) CALL DLine_To_L12(x1p, y2_points - 151.0D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x1p = x1_points + 57.0D0 - twosigma_width_points / 2.0D0 x2p = x1p + twosigma_width_points CALL DNew_L12_Path(1, x1p, y2_points - 151.0D0) CALL DLine_To_L12(x1p, y2_points - 210.0D0) CALL DLine_To_L12(x2p, y2_points - 210.0D0) CALL DLine_To_L12(x2p, y2_points - 151.0D0) CALL DLine_To_L12(x1p, y2_points - 151.0D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DCircle_on_L12 (level = 1, x = x1_points + 5.0D0, y = y2_points - 151.0D0, radius = no_sigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 29.5D0, y = y2_points - 151.0D0, radius = onesigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 57.0D0, y = y2_points - 151.0D0, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern(.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern(.FALSE., 'foreground') END IF x2p = x1_points + 5.0D0 + no_sigma_width_points / 2.0D0 CALL DL12_Text (level = 1, x_points = x2p, y_points = y2_points - 181.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = -0.3D0, ud_fraction = 0.4D0, & & text = '3') x2p = x1_points + 29.5D0 + onesigma_width_points / 2.0D0 CALL DL12_Text (level = 1, x_points = x2p, y_points = y2_points - 196.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = -0.3D0, ud_fraction = 0.4D0, & & text = '5') x2p = x1_points + 57.0D0 + twosigma_width_points / 2.0D0 CALL DL12_Text (level = 1, x_points = x2p, y_points = y2_points - 210.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = -0.3D0, ud_fraction = 0.4D0, & & text = '7') CALL DSet_Fill_or_Pattern(.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x1_points + 11.0D0, y_points = y2_points - 214.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'anomaly < 1 sigma') CALL DL12_Text (level = 1, x_points = x1_points + 35.0D0, y_points = y2_points - 214.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'anomaly < 2 sigma') CALL DL12_Text (level = 1, x_points = x1_points + 61.0D0, y_points = y2_points - 214.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'anomaly > 2 sigma') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 314.0D0 IF (got_any_stars) THEN ! add model predictions to legend CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 333.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Paleolatitude') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 347.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'anomaly') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 362.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'predicted by') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 376.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'the model:') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF x1p = x1_points + 11.0D0 - twosigma_width_points / 2.0D0 x2p = x1p + twosigma_width_points CALL DNew_L12_Path(1, x1p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 473.0D0) CALL DLine_To_L12(x2p, y2_points - 473.0D0) CALL DLine_To_L12(x2p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 413.0D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x1p = xcp - twosigma_width_points / 2.0D0 x2p = x1p + twosigma_width_points CALL DNew_L12_Path(1, x1p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 473.0D0) CALL DLine_To_L12(x2p, y2_points - 473.0D0) CALL DLine_To_L12(x2p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 413.0D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'yellow____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') END IF x1p = x2_points - 11.0D0 - twosigma_width_points / 2.0D0 x2p = x1p + twosigma_width_points CALL DNew_L12_Path(1, x1p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 504.0D0) CALL DLine_To_L12(x2p, y2_points - 504.0D0) CALL DLine_To_L12(x2p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 413.0D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'background') END IF x1p = x1_points + 11.0D0 - twosigma_width_points / 2.0D0 x2p = x1p + twosigma_width_points CALL DNew_L12_Path(1, x1p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 387.0D0) CALL DLine_To_L12(x2p, y2_points - 387.0D0) CALL DLine_To_L12(x2p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 413.0D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x1p = xcp - twosigma_width_points / 2.0D0 x2p = x1p + twosigma_width_points CALL DNew_L12_Path(1, x1p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 444.0D0) CALL DLine_To_L12(x2p, y2_points - 444.0D0) CALL DLine_To_L12(x2p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 413.0D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x1p = x2_points - 11.0D0 - twosigma_width_points / 2.0D0 x2p = x1p + twosigma_width_points CALL DNew_L12_Path(1, x1p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 473.0D0) CALL DLine_To_L12(x2p, y2_points - 473.0D0) CALL DLine_To_L12(x2p, y2_points - 413.0D0) CALL DLine_To_L12(x1p, y2_points - 413.0D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DCircle_on_L12 (level = 1, x = x1_points + 11.0D0, y = y2_points - 413.0D0, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = xcp, y = y2_points - 413.0D0, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x2_points - 11.0D0, y = y2_points - 413.0D0, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x1_points + 11.0D0, y_points = y2_points - 507.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'opposite to datum') CALL DL12_Text (level = 1, x_points = x1_points + 35.0D0, y_points = y2_points - 507.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'less than datum') CALL DL12_Text (level = 1, x_points = x1_points + 61.0D0, y_points = y2_points - 507.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'more than datum') rightlegend_used_points = rightlegend_used_points + 288.0D0 ! (for model predictions only) END IF CALL DEnd_Group ! of right legend END IF ! bottom or right legend for paleolatitude anomalies WRITE (*,"('+Working on paleolatitude anomalies....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 9: paleolatitude anomalies CASE (10) ! paleomagnetic vertical-axis rotations 2100 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .TRUE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = p_rst_file, & ! & using_path = temp_path_in) WRITE (*, *) WRITE (*, "(' -------------------------------------------------------------------------------')") WRITE (*, "(' The next prompt will ask you which paleomagnetic data file (p*.rst) to plot?')") WRITE (*, "(' If you choose the INPUT dataset for Restore, then only RED TARGET sectors')") WRITE (*, "(' representing measured rotations will appear on the map.')") WRITE (*, "(' If you choose an OUTPUT dataset from Restore, then GREEN MODEL sectors')") WRITE (*, "(' representing computed rotations will ALSO be plotted.')") WRITE (*, "(' Regardless of this choice, all paleomagnetic sites will be plotted in ')") WRITE (*, "(' their PRESENT locations, so plotting these over present coastlines,')") WRITE (*, "(' state lines, fault traces, and/or outcrops would be appropriate.')") WRITE (*, "(' -------------------------------------------------------------------------------')") WRITE (*, *) CALL Pause() WRITE (*, *) CALL DPrompt_for_String('Which paleomagnetic dataset should be plotted?', p_rst_file, p_rst_file) p_rst_pathfile = TRIM(temp_path_in)//TRIM(p_rst_file) OPEN(UNIT = 21, FILE = p_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2100 END IF READ (21,"(A)") p_rst_format READ (21,"(A)") p_rst_titles p_rst_count = 0 p_rst_includes_model = .FALSE. ! but, this can be easily changed below, by discovering any '+' line(s)... size_p_rst2: DO ! reading paleomagnetic data, to determine number of sites, and check for Restore model output(?) READ (21, p_rst_format, IOSTAT = ios) c50, lon, lat, t1, t2, anomaly, sigma, t3, t4, plon, plat IF (ios == -1) EXIT size_p_rst2 ! EOF? p_rst_count = p_rst_count + 1 !Try to read a "+" line to see if this file also has Restore model output line? READ (21, "(A)", IOSTAT = ios) c1 ! Checking for '+', a restored position (which will not be used). IF (ios == -1) EXIT size_p_rst2 ! EOF instead? IF (c1 == '+') p_rst_includes_model = .TRUE. ! Note that we are not reading, recording, or using the restored position. IF (p_rst_includes_model) THEN ! READ past any '*' and '&' lines with model rates and target rates. p_rst_stars4: DO READ (21, "(A1)", IOSTAT = ios) c1 IF (ios == -1) EXIT size_p_rst2 ! EOF (not expected here) IF (c1 == '*') THEN ! latitude rate and goal ELSE IF (c1 == '&') THEN ! rotation rate and goal ELSE ! c1 /= '*' or '&'; have overshot, and accidentally began to read the next record! Back up... BACKSPACE(21) EXIT p_rst_stars4 END IF ! c1 is or is not '*' OR '&' END DO p_rst_stars4 ELSE ! p_rst_includes_model = F; no model output in this file, so we just accidentally read start of next datum! BACKSPACE (21) ! so next datum can be read in next time through loop END IF ! p_rst_includes_model, or not END DO size_p_rst2 CLOSE (21) IF (p_rst_includes_model) THEN CALL Add_Title('Vertical-axis rotations: Data (red) vs. Model (green)') !model_is_unfinished? will be decided below, on case-by-case basis ELSE CALL Add_Title('Vertical-axis rotations: Paleomagnetic data') model_is_unfinished = .FALSE. ! (because NO model--just in case this value is accessed) END IF CALL Add_Title(p_rst_file) ALLOCATE ( clockwise_anomaly_degrees(p_rst_count) ) OPEN(UNIT = 21, FILE = p_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21,"(A)") p_rst_format READ (21,"(A)") p_rst_titles p_rst_count = 0 ! sic; using as index one more time scan_p_rst2: DO ! reading and recording rotations (only) from paleomagnetic data, in order to display a histogram of vertical-axis rotations READ (21, p_rst_format, IOSTAT = ios) c50, lon, lat, t1, t2, anomaly, sigma, t3, t4, plon, plat IF (ios == -1) EXIT scan_p_rst2 ! EOF p_rst_count = p_rst_count + 1 clockwise_anomaly_degrees(p_rst_count) = -anomaly IF (p_rst_includes_model) THEN READ (21, "(A)", IOSTAT = ios) c1 ! Expecting c1 = '+' in this line. p_rst_stars5: DO ! READ past any '*' and '&' lines with model rates and target rates. READ (21, "(A1)", IOSTAT = ios) c1 IF (ios == -1) EXIT scan_p_rst2 ! EOF (not expected) IF (c1 == '*') THEN ! latitude rate and goal ELSE IF (c1 == '&') THEN ! rotation rate and goal ELSE ! c1 /= '*' or '&'; have overshot BACKSPACE(21) EXIT p_rst_stars5 END IF ! c1 is or is not '*' OR '&' END DO p_rst_stars5 END IF ! p_rst_includes_model, or not END DO scan_p_rst2 CLOSE (21) WRITE (*,"(/' Here is the distribution of data (clockwise rotations in degrees):')") CALL Histogram (clockwise_anomaly_degrees, p_rst_count, .FALSE., maximum, minimum) DEALLOCATE (clockwise_anomaly_degrees) WRITE (*,"(/' Working on vertical-axis rotations....')") CALL DBegin_Group ! of vertical-axis rotation symbols OPEN(UNIT = 21, FILE = p_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21,"(A)") p_rst_format READ (21,"(A)") p_rst_titles any_model_unfinished = .FALSE. ! but that can easily be changed, by any single case below... read_p_rst2: DO ! reading paleomagnetic data, to end of file READ (21, p_rst_format, IOSTAT = ios) c50, lon, lat, t1, t2, anomaly, sigma, t3, t4, plon, plat IF (ios == -1) EXIT read_p_rst2 ! EOF !Anomaly is in degrees counterclockwise from North. !Not using t1: latitude anomaly or t2: its sigma. !Also not using paleopole; rotations are relative to North. t_Ma = (t3 + t4) / 2.0D0 CALL DLonLat_2_Uvec( lon, lat, uvec1) ! PRESENT position of paleomag site IF (p_rst_includes_model) THEN READ (21, "(A)", IOSTAT = ios) c1 ! Expecting c1 = '+' here; this restored position will not be used. IF (ios == -1) EXIT read_p_rst2 ! EOF (not expected) model = 0.0D0 highest_age_Ma = 0.0D0 ! N.B. Both will be increased below... p_rst_stars6: DO READ (21, "(A1, 2F8.3, F12.6)", IOSTAT = ios) c1, t1_Ma, t2_Ma, rate IF (ios == -1) EXIT p_rst_stars6 ! EOF IF (c1 == '*') THEN ! latitude rate and goal; ignore ELSE IF (c1 == '&') THEN ! rotation rate and goal highest_age_Ma = MAX(highest_age_Ma, t2_Ma) ! Note that we are only considering '&' lines in this search! See below... model = model + rate * (t2_Ma - t1_Ma) !Like anomaly, model is in degrees counterclockwise from North. ELSE ! c1 /= '*' or '&'; have overshot BACKSPACE(21) EXIT p_rst_stars6 END IF ! c1 is, or is not, '*' OR '&' END DO p_rst_stars6 model_is_unfinished = (highest_age_Ma < t_Ma) ! N.B. This can happen for either of two reasons: ! (1) Model has not yet run long enough (far enough back into the past) ! to reach the mean age of magnetization for this paleomag site, ! so it is understandable why the green wedge is smaller than the red; OR ! (2) Rotations at this site were not used in modeling because some ! strike-slip fault intruded into the same finite-element; in such cases, ! the '&' lines that would normally be found in the p*.rst output file ! are missing for this paleomagnetic site, and no green wedge is plotted there. any_model_unfinished = any_model_unfinished.OR.model_is_unfinished ! <= to control appearance of extra block in marginal Explanation. END IF ! p_rst_includes_model !HERE is where we plot the vertical-axis rotation symbol: twosigma_radius_points = 30.0D0 ! ADJUST HERE to change radius of colored wedges onesigma_radius_points = 20.0D0 ! ADJUST HERE to change radius of colored wedges no_sigma_radius_points = 10.0D0 ! ADJUST HERE to change radius of colored wedges twosigma_width_points = 12.0D0 ! Adjust here to change diameter of (background) site circle. onesigma_width_points = 8.0D0 ! Adjust here to change diameter of (background) site circle. no_sigma_width_points = 4.0D0 ! Adjust here to change diameter of (background) site circle. IF (ABS(anomaly)/sigma >= 2.0D0) THEN ! important anomaly; plot large wedge p_rst_radius_points = twosigma_radius_points p_rst_width_points = twosigma_width_points ELSE IF (ABS(anomaly)/sigma >= 1.0D0) THEN ! medium wedge size p_rst_radius_points = onesigma_radius_points p_rst_width_points = onesigma_width_points ELSE ! insignificant anomaly, smaller than one sigma p_rst_radius_points = no_sigma_radius_points p_rst_width_points = no_sigma_width_points END IF wedge_radius_radians = p_rst_radius_points * 3.528D-4 * mp_scale_denominator / mp_radius_meters node_radius_radians = 0.5D0 * p_rst_width_points * 3.528D-4 * mp_scale_denominator / mp_radius_meters CALL DBegin_Group ! for this one vertical-axis rotation symbol !Reference N axis (25% longer than radius): CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DNew_L45_Path(5, uvec1) ! site CALL DTurn_To (azimuth_radians = 0.0D0, & ! along present declineation & base_uvec = uvec1, & ! from site & far_radians = 1.25D0 * wedge_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DGreat_to_L45(uvec2) ! radius along present declination CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) !First, the red/black wedge with foreground line, for the datum (UNLESS anomaly == 0; then skip plotting to avoid complete circle!) IF (anomaly /= 0.0D0) THEN CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF CALL DNew_L45_Path(5, uvec1) ! site CALL DTurn_To (azimuth_radians = -anomaly * radians_per_degree, & ! along present declineation & base_uvec = uvec1, & ! from site & far_radians = wedge_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DGreat_to_L45(uvec2) ! radius along present declination CALL DTurn_To (azimuth_radians = 0.0D0, & ! present due North & base_uvec = uvec1, & ! from site & far_radians = wedge_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) IF (anomaly <= 0.0D0) THEN ! clockwise declination; counterclockwise swing pole_uvec = uvec1 ELSE ! counterclockwise declination; clockwise swing pole_uvec = -uvec1 END IF CALL DSmall_to_L45(pole_uvec = pole_uvec, to_uvec = uvec3) ! swing around site CALL DGreat_to_L45(uvec1) ! return to site CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! anomaly /= 0.0D0; typical case !Second, the green/white wedge with foreground line, for the a prediction .LE. datum !(If anomaly is zero, then postpone model prediction and make it yellow.) IF (p_rst_includes_model.AND.(anomaly /= 0.0D0).AND.(model /= 0.0D0)) THEN IF ((model/anomaly) > 1.0D0) THEN ! model OVERSHOOTS datum; plot only part of bar now green_part = anomaly ELSE ! normal case; model is less than, or opposite sign from, datum green_part = model END IF !Green_part is in degrees counterclockwise from North. CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'background') END IF CALL DNew_L45_Path(5, uvec1) ! site CALL DTurn_To (azimuth_radians = -green_part * radians_per_degree, & ! along model declineation & base_uvec = uvec1, & ! from site & far_radians = wedge_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DGreat_to_L45(uvec2) ! radius along model declination CALL DTurn_To (azimuth_radians = 0.0D0, & ! present due North & base_uvec = uvec1, & ! from site & far_radians = wedge_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) IF (green_part <= 0.0D0) THEN ! clockwise declination; counterclockwise swing pole_uvec = uvec1 ELSE ! counterclockwise declination; clockwise swing pole_uvec = -uvec1 END IF CALL DSmall_to_L45(pole_uvec = pole_uvec, to_uvec = uvec3) ! swing around site CALL DGreat_to_L45(uvec1) ! return to site CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! plotting green wedge IF (p_rst_includes_model.AND.(model /= 0.0D0).AND.((anomaly == 0.0D0).OR.(model/anomaly > 1.0D0))) THEN !Third, the yellow/grey wedge with foreground line, for the a prediction exceeding CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'yellow____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') END IF CALL DNew_L45_Path(5, uvec1) ! site CALL DTurn_To (azimuth_radians = -model * radians_per_degree, & ! along model declineation & base_uvec = uvec1, & ! from site & far_radians = wedge_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DGreat_to_L45(uvec2) ! radius along model declination CALL DTurn_To (azimuth_radians = -anomaly * radians_per_degree, & ! present due North & base_uvec = uvec1, & ! from site & far_radians = wedge_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) IF ((model - anomaly) <= 0.0D0) THEN ! model has extra clockwise declination; counterclockwise swing pole_uvec = uvec1 ELSE ! counterclockwise declination; clockwise swing pole_uvec = -uvec1 END IF CALL DSmall_to_L45(pole_uvec = pole_uvec, to_uvec = uvec3) ! swing around site CALL DGreat_to_L45(uvec1) ! return to site CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! plotting yellow wedge !Lastly, add circle to show site, and age (integer) in Ma CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (model_is_unfinished) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'background') END IF CALL DTurn_To (azimuth_radians = Pi, & ! base of circle & base_uvec = uvec1, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DNew_L45_Path(5, uvec2) CALL DSmall_To_L45(pole_uvec = uvec1, to_uvec = uvec2) CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) j = NINT(t_Ma) WRITE (c3,"(I3)") j c3 = ADJUSTL(c3) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL5_Text (uvec = uvec2, angle_radians = 0.0D0, from_east = .TRUE., & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(c3)) CALL DEnd_Group ! for one vertical-axis rotation symbol END DO read_p_rst2 CALL DEnd_Group ! of all vertical-axis rotation symbols CLOSE (21) ! p.dat CALL Chooser (bottom, right) IF (bottom) THEN CALL DBegin_Group ! for bottom vertical-axis rotation legend CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points) / 2.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') x1p = x1_points + 40.0D0 CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 14.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Paleomagnetic') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 29.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'site, with') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 43.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'age in Ma:') y1p = y2_points - 43.5D0 CALL DL12_Text (level = 1, x_points = x1_points + 83.0D0, y_points = y1p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '61') CALL DL12_Text (level = 1, x_points = x1_points + 109.5D0, y_points = y1p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '61') CALL DL12_Text (level = 1, x_points = x1_points + 135.0D0, y_points = y1p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '61') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DCircle_on_L12 (level = 1, x = x1_points + 83.0D0, y = y2_points - 27.5D0, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 109.5D0, y = y2_points - 29.0D0, radius = onesigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 135.0D0, y = y2_points - 31.0D0, radius = no_sigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') x1p = x1_points + 185.0D0 CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 12.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Size and') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 25.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'significance') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 38.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'of vertical-') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 51.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'axis rotation:') !reference N lines for each of three samples: CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') x1p = x1_points + 284.0D0 ! for small sample y1p = y2_points - 16.5D0 CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x1p, y1p + 1.25D0 * no_sigma_radius_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) x1p = x1_points + 259.0D0 ! for medium sample y1p = y2_points - 28.0D0 CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x1p, y1p + 1.25D0 * onesigma_radius_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) x1p = x1_points + 231.0D0 ! for large sample y1p = y2_points - 41.0D0 CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x1p, y1p + 1.25D0 * twosigma_radius_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF x1p = x1_points + 284.0D0 ! for small sample y1p = y2_points - 16.5D0 CALL DNew_L12_Path(1, x1p, y1p) x2p = x1p + no_sigma_radius_points * DSIN(10.0D0 * radians_per_degree) y2p = y1p + no_sigma_radius_points * DCOS(10.0D0 * radians_per_degree) CALL DLine_To_L12(x2p, y2p) y2p = y1p + no_sigma_radius_points CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x1p = x1_points + 259.0D0 ! for medium sample y1p = y2_points - 28.0D0 CALL DNew_L12_Path(1, x1p, y1p) x2p = x1p + onesigma_radius_points * DSIN(15.0D0 * radians_per_degree) y2p = y1p + onesigma_radius_points * DCOS(15.0D0 * radians_per_degree) CALL DLine_To_L12(x2p, y2p) y2p = y1p + onesigma_radius_points CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x1p = x1_points + 231.0D0 ! for large sample y1p = y2_points - 41.0D0 CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 0.0D0, 25.0D0) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') x1p = x1_points + 284.0D0 ! for small sample y1p = y2_points - 16.5D0 CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = no_sigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) x1p = x1_points + 259.0D0 ! for medium sample y1p = y2_points - 28.0D0 CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = onesigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) x1p = x1_points + 231.0D0 ! for large sample y1p = y2_points - 41.0D0 CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern(.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x1_points + 294.0D0, y_points = y2_points - 18.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.0D0, ud_fraction = 0.0D0, & & text = 'anomaly < 1 sigma') CALL DL12_Text (level = 1, x_points = x1_points + 270.0D0, y_points = y2_points - 31.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.0D0, ud_fraction = 0.0D0, & & text = 'anomaly < 2 sigma') CALL DL12_Text (level = 1, x_points = x1_points + 244.0D0, y_points = y2_points - 44.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.0D0, ud_fraction = 0.0D0, & & text = 'anomaly > 2 sigma') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 398.0D0 IF (p_rst_includes_model) THEN ! add model predictions to legend x1p = x1_points + 435.0D0 CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 13.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Vertical-axis') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 26.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'rotation') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 39.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'predicted by') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 52.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'the model:') !reference N lines for each of three samples: CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') x1p = x1_points + 478.0D0 ! for less sample y1p = y2_points - 40.5D0 CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x1p, y1p + 1.25D0 * twosigma_radius_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) x1p = x1_points + 607.5D0 ! for more sample CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x1p, y1p + 1.25D0 * twosigma_radius_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 0.0D0, 25.0D0) x1p = x1_points + 478.0D0 ! for smaller sample CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 0.0D0, 25.0D0) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'background') END IF x1p = x1_points + 478.0D0 ! for smaller sample CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 0.0D0, 15.0D0) x1p = x1_points + 607.5D0 ! for larger sample CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 0.0D0, 25.0D0) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'yellow____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') END IF x1p = x1_points + 607.5D0 ! for larger sample CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 25.0D0, 35.0D0) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') x1p = x1_points + 478.0D0 ! for smaller sample CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) x1p = x1_points + 607.5D0 ! for larger sample CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x1_points + 492.0D0, y_points = y2_points - 21.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.0D0, ud_fraction = 0.0D0, & & text = 'less than datum') CALL DL12_Text (level = 1, x_points = x1_points + 599.5D0, y_points = y2_points - 35.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'more than datum') bottomlegend_used_points = bottomlegend_used_points + 227.0D0 ! (for model predictions only) IF (any_model_unfinished) THEN ! Add extra block to Explanation: x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points) / 2.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') x1p = x1_points + 40.0D0 CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 14.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Gray circle') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 29.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'warns of') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2_points - 43.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'incomplete model:') y1p = y2_points - 43.5D0 CALL DL12_Text (level = 1, x_points = x1_points + 103.0D0, y_points = y1p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '61') CALL DL12_Text (level = 1, x_points = x1_points + 129.5D0, y_points = y1p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '61') CALL DL12_Text (level = 1, x_points = x1_points + 155.0D0, y_points = y1p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '61') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') CALL DCircle_on_L12 (level = 1, x = x1_points + 103.0D0, y = y2_points - 27.5D0, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 129.5D0, y = y2_points - 29.0D0, radius = onesigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 155.0D0, y = y2_points - 31.0D0, radius = no_sigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') bottomlegend_used_points = bottomlegend_used_points + 200.0D0 ! (for gray-circle warning only) END IF ! any_model_unfinished END IF ! p_rst_includes_model CALL DEnd_Group ! of bottom vertical-axis rotation legend ELSE IF (right) THEN CALL DBegin_Group ! for right vertical-axis rotation legend CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points xcp = (x1_points + x2_points) / 2.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 14.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Paleomagnetic') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 29.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'site, with') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 43.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'age in Ma:') CALL DL12_Text (level = 1, x_points = x1_points + 17.0D0, y_points = y2_points - 71.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DL12_Text (level = 1, x_points = x1_points + 45.0D0, y_points = y2_points - 71.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DL12_Text (level = 1, x_points = x1_points + 71.0D0, y_points = y2_points - 71.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DCircle_on_L12 (level = 1, x = x1_points + 10.5D0, y = y2_points - 55.0D0, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 37.5D0, y = y2_points - 57.0D0, radius = onesigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 62.5D0, y = y2_points - 59.0D0, radius = no_sigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 90.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Size and') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 105.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'significance') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 119.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'of vertical-') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 134.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'axis rotation:') !reference N lines for each of three samples: CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') x1p = x1_points + 8.0D0 ! for small sample y1p = y2_points - 166.0D0 CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x1p, y1p + 1.25D0 * no_sigma_radius_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) x1p = x1_points + 30.0D0 ! for medium sample y1p = y2_points - 170.0D0 CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x1p, y1p + 1.25D0 * onesigma_radius_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) x1p = x1_points + 56.0D0 ! for large sample y1p = y2_points - 175.0D0 CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x1p, y1p + 1.25D0 * twosigma_radius_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF x1p = x1_points + 8.0D0 ! for small sample y1p = y2_points - 166.0D0 CALL DNew_L12_Path(1, x1p, y1p) x2p = x1p + no_sigma_radius_points * DSIN(10.0D0 * radians_per_degree) y2p = y1p + no_sigma_radius_points * DCOS(10.0D0 * radians_per_degree) CALL DLine_To_L12(x2p, y2p) y2p = y1p + no_sigma_radius_points CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x1p = x1_points + 30.0D0 ! for medium sample y1p = y2_points - 170.0D0 CALL DNew_L12_Path(1, x1p, y1p) x2p = x1p + onesigma_radius_points * DSIN(15.0D0 * radians_per_degree) y2p = y1p + onesigma_radius_points * DCOS(15.0D0 * radians_per_degree) CALL DLine_To_L12(x2p, y2p) y2p = y1p + onesigma_radius_points CALL DLine_To_L12(x1p, y2p) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x1p = x1_points + 56.0D0 ! for large sample y1p = y2_points - 175.0D0 CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 0.0D0, 25.0D0) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') x1p = x1_points + 8.0D0 ! for small sample y1p = y2_points - 166.0D0 CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = no_sigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) x1p = x1_points + 30.0D0 ! for medium sample y1p = y2_points - 170.0D0 CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = onesigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) x1p = x1_points + 56.0D0 ! for large sample y1p = y2_points - 175.0D0 CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern(.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x1_points + 11.0D0, y_points = y2_points - 188.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'anomaly < 1 sigma') CALL DL12_Text (level = 1, x_points = x1_points + 35.0D0, y_points = y2_points - 188.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'anomaly < 2 sigma') CALL DL12_Text (level = 1, x_points = x1_points + 61.0D0, y_points = y2_points - 188.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'anomaly > 2 sigma') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 290.0D0 IF (p_rst_includes_model) THEN ! add model predictions to legend CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 309.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Vertical-axis') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 323.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'rotation') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 338.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'predicted by') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 352.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'the model:') !reference N lines for each of three samples: CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') x1p = x1_points + 13.0D0 ! for opposite sample y1p = y2_points - 395.0D0 CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x1p, y1p + 1.25D0 * twosigma_radius_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) x1p = xcp - 2.0D0 ! for less sample CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x1p, y1p + 1.25D0 * twosigma_radius_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) x1p = x2_points - 18.0D0 ! for more sample CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x1p, y1p + 1.25D0 * twosigma_radius_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF x1p = x1_points + 13.0D0 ! for opposite sample y1p = y2_points - 395.0D0 CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 0.0D0, 25.0D0) x1p = xcp - 2.0D0 ! for smaller sample CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 0.0D0, 25.0D0) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'background') END IF x1p = x1_points + 13.0D0 ! for opposite sample CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, -20.0D0, 0.0D0) x1p = xcp - 2.0D0 ! for smaller sample CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 0.0D0, 15.0D0) x1p = x2_points - 18.0D0 ! for larger sample CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 0.0D0, 25.0D0) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'yellow____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') END IF x1p = x2_points - 18.0D0 ! for larger sample y1p = y2_points - 395.0D0 CALL Wedge_on_L1(x1p, y1p, twosigma_radius_points, 25.0D0, 35.0D0) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') x1p = x1_points + 13.0D0 ! for opposite sample CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) x1p = xcp - 2.0D0 ! for smaller sample CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) x1p = x2_points - 18.0D0 ! for larger sample CALL DCircle_on_L12 (level = 1, x = x1p, y = y1p, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x1_points + 11.0D0, y_points = y2_points - 409.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'opposite to datum') CALL DL12_Text (level = 1, x_points = x1_points + 33.0D0, y_points = y2_points - 409.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'less than datum') CALL DL12_Text (level = 1, x_points = x1_points + 55.0D0, y_points = y2_points - 409.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'more than datum') rightlegend_used_points = rightlegend_used_points + 214.0D0 ! (for model predictions only) IF (any_model_unfinished) THEN ! Explain the grayed-out site circles: y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points xcp = (x1_points + x2_points) / 2.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 14.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Gray circle') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 29.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'warns of') CALL DL12_Text (level = 1, x_points = xcp, y_points = y2_points - 43.5D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'incomplete model:') CALL DL12_Text (level = 1, x_points = x1_points + 17.0D0, y_points = y2_points - 71.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DL12_Text (level = 1, x_points = x1_points + 45.0D0, y_points = y2_points - 71.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DL12_Text (level = 1, x_points = x1_points + 71.0D0, y_points = y2_points - 71.0D0, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '61') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') CALL DCircle_on_L12 (level = 1, x = x1_points + 10.5D0, y = y2_points - 55.0D0, radius = twosigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 37.5D0, y = y2_points - 57.0D0, radius = onesigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DCircle_on_L12 (level = 1, x = x1_points + 62.5D0, y = y2_points - 59.0D0, radius = no_sigma_width_points / 2.0D0, stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 80.0D0 END IF ! any_model_unfinished END IF ! p_rst_includes_model CALL DEnd_Group ! of right legend END IF ! bottom or right legend for paleolatitude anomalies WRITE (*,"('+Working on vertical-axis rotations....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 10: paleomagnetic vertical-axis rotations CASE (11) ! paleostress direction data 2110 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .TRUE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = s_rst_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which stress dataset should be plotted?',s_rst_file,s_rst_file) s_rst_pathfile = TRIM(temp_path_in)//TRIM(s_rst_file) OPEN(UNIT = 21, FILE = s_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2110 END IF CALL Add_Title("Paleostress directions") 2111 CALL DPrompt_for_Real('What is the maximum geologic time (age) for data selection, in Ma?',t2_Ma,t2_Ma) CALL DPrompt_for_Real('What is the minimum geologic time (age) for data selection, in Ma?',t1_Ma,t1_Ma) IF (t2_Ma < t1_Ma) THEN WRITE (*,"(' ERROR: Minimum age cannot exceed maximum age.')") WRITE (*,"(' Use minimum age = maximum age if you want neotec mode,')") WRITE (*,"(' in which only stage-type stress indicators are displayed.')") GO TO 2111 END IF neotec = (t1_Ma == t2_Ma) paleotec = .NOT. neotec t_Ma = (t1_Ma + t2_Ma) / 2.0D0 suggest_logical = (t1_Ma > 0.0D0) CALL DPrompt_for_Logical('Use restored locations (if any) in data file?',suggest_logical,restored) CALL DPrompt_for_Real('How long should the symbols be, in points?',s1_size_points,s1_size_points) WRITE (*,"(/' Working on paleostress directions....')") CALL Read_S_rst (free_unit = 21, recording = .FALSE.) ALLOCATE ( s_code (s_rst_count) ) ALLOCATE ( s_site_now (3, 2, s_rst_count) ) ALLOCATE ( s_azim_now (s_rst_count) ) ALLOCATE ( s_sigma_ (s_rst_count) ) ALLOCATE ( s_t_max (s_rst_count) ) ALLOCATE ( s_t_min (s_rst_count) ) ALLOCATE ( s_stage (s_rst_count) ) CALL Read_S_rst (free_unit = 21, recording = .TRUE.) CALL DBegin_Group ! foreground-bounded background-colored wedges for 90% confidence limits CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radians = (0.6D0 * s1_size_points * 3.528D-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, s_rst_count tt1_Ma = s_t_min(i) / s_per_Ma tt2_Ma = s_t_max(i) / s_per_Ma IF (paleotec) THEN overlap_Ma = MAX(0.0D0, MIN((t2_Ma - t1_Ma), (tt2_Ma - tt1_Ma), (t2_Ma - tt1_Ma), (tt2_Ma - t1_Ma))) IF (s_stage(i)) THEN overlap_threshold_Ma = MIN(0.1D0, 0.5D0 * (t2_Ma - t1_Ma)) IF (overlap_Ma > overlap_threshold_Ma) THEN relevance = 1.0D0 ELSE relevance = 0.0D0 END IF ELSE ! window-type datum relevance = overlap_Ma / (tt2_Ma - tt1_Ma) END IF ! stage or window ELSE ! neotec IF (s_stage(i)) THEN allowance_Ma = 0.1D0 IF ((t1_Ma > (tt1_Ma - allowance_Ma)).AND. & & (t1_Ma < (tt2_Ma + allowance_Ma))) THEN relevance = 1.0D0 ELSE relevance = 0.0D0 END IF ELSE ! window-type datum relevance = 0.0D0 END IF ! stage or window END IF ! paleotec, or neotec IF (relevance > 0.05D0) THEN ! datum is relevant to this time window del_az_for_90pc = s_sigma_(i) * 1.645D0 uvec(1:3) = s_site_now(1:3, 1, i) IF (del_az_for_90pc < Pi_over_2) THEN ! two sectors CALL DNew_L45_Path(5, uvec) CALL DTurn_To (s_azim_now(i)+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DGreat_to_L45(uvec1) CALL DTurn_To (s_azim_now(i)-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DSmall_to_L45(uvec, uvec2) CALL DGreat_to_L45(uvec) CALL DEnd_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL DNew_L45_Path(5, uvec) CALL DTurn_To (s_azim_now(i)+Pi+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DGreat_to_L45(uvec1) CALL DTurn_To (s_azim_now(i)+Pi-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DSmall_to_L45(uvec, uvec2) CALL DGreat_to_L45(uvec) CALL DEnd_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ELSE ! complete small circle CALL DTurn_To (0.0D0, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DNew_L45_Path(5, uvec1) CALL DSmall_to_L45(uvec, uvec1) CALL DEnd_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! sectors or circle END IF ! datum is relevant to this time window END DO CALL DEnd_Group ! end of 90%-confidence limits CALL DBegin_Group ! stress indicator bar (solid if definately relevant) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radians = (0.5D0 * s1_size_points * 3.528D-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, s_rst_count tt1_Ma = s_t_min(i) / s_per_Ma tt2_Ma = s_t_max(i) / s_per_Ma IF (paleotec) THEN overlap_Ma = MAX(0.0D0, MIN((t2_Ma - t1_Ma), (tt2_Ma - tt1_Ma), (t2_Ma - tt1_Ma), (tt2_Ma - t1_Ma))) IF (s_stage(i)) THEN overlap_threshold_Ma = MIN(0.1D0, 0.5D0 * (t2_Ma - t1_Ma)) IF (overlap_Ma > overlap_threshold_Ma) THEN relevance = 1.0D0 ELSE relevance = 0.0D0 END IF ELSE ! window-type datum relevance = overlap_Ma / (tt2_Ma - tt1_Ma) END IF ! stage or window ELSE ! neotec IF (s_stage(i)) THEN allowance_Ma = 0.1D0 IF ((t1_Ma > (tt1_Ma - allowance_Ma)).AND. & & (t1_Ma < (tt2_Ma + allowance_Ma))) THEN relevance = 1.0D0 ELSE relevance = 0.0D0 END IF ELSE ! window-type datum relevance = 0.0D0 END IF ! stage or window END IF ! paleotec, or neotec IF (relevance > 0.05D0) THEN ! datum is relevant to this time window uvec(1:3) = s_site_now(1:3, 1, i) solid = (relevance > 0.99D0) IF (solid) THEN ! solid bar, width 1/8 of length CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.0D0)), dashed = .FALSE.) CALL DTurn_To (s_azim_now(i), uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DNew_L45_Path(5, uvec1) CALL DTurn_To (s_azim_now(i)+Pi, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DGreat_to_L45(uvec2) CALL DEnd_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! foreground-outlined, background-filled bar CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 24.0D0)), dashed = .FALSE.) CALL DTurn_To (s_azim_now(i)+0.12435D0, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DNew_L45_Path(5, uvec1) CALL DTurn_To (s_azim_now(i)-0.12435D0, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DGreat_to_L45(uvec2) CALL DTurn_To (s_azim_now(i)-Pi+0.12435D0, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DGreat_to_L45(uvec2) CALL DTurn_To (s_azim_now(i)-Pi-0.12435D0, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DGreat_to_L45(uvec2) CALL DGreat_to_L45(uvec1) CALL DEnd_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! sectors or circle END IF ! datum is relevant to this time window END DO CALL DEnd_Group ! of stress-direction bars CALL DBegin_Group ! of text labels CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') DO i = 1, s_rst_count tt1_Ma = s_t_min(i) / s_per_Ma tt2_Ma = s_t_max(i) / s_per_Ma IF (paleotec) THEN overlap_Ma = MAX(0.0D0, MIN((t2_Ma - t1_Ma), (tt2_Ma - tt1_Ma), (t2_Ma - tt1_Ma), (tt2_Ma - t1_Ma))) IF (s_stage(i)) THEN overlap_threshold_Ma = MIN(0.1D0, 0.5D0 * (t2_Ma - t1_Ma)) IF (overlap_Ma > overlap_threshold_Ma) THEN relevance = 1.0D0 ELSE relevance = 0.0D0 END IF ELSE ! window-type datum relevance = overlap_Ma / (tt2_Ma - tt1_Ma) END IF ! stage or window ELSE ! neotec IF (s_stage(i)) THEN allowance_Ma = 0.1D0 IF ((t1_Ma > (tt1_Ma - allowance_Ma)).AND. & & (t1_Ma < (tt2_Ma + allowance_Ma))) THEN relevance = 1.0D0 ELSE relevance = 0.0D0 END IF ELSE ! window-type datum relevance = 0.0D0 END IF ! stage or window END IF ! paleotec, or neotec IF (relevance > 0.05D0) THEN ! datum is relevant to this time window uvec(1:3) = s_site_now(1:3, 1, i) radians = Pi_over_2 - s_azim_now(i) CALL DL5_Text (uvec = uvec, angle_radians = radians, from_east = .TRUE., & & font_points = 6, lr_fraction = 0.5D0, ud_fraction = -0.3D0, & & text = s_code(i)) END IF ! datum is relevant to this time window END DO CALL DEnd_Group ! of text labels CALL Chooser (bottom, right) IF (right) THEN ! sample paleostress in rightlegend CALL DBegin_Group ! text part of paleostress in legend CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Paleostress') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'datum, with') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '90%-confidence') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 30.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'sectors; solid if') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 40.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '100%-relevant:') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 55.0D0 ! text only ! symbol part of paleostress in legend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radius = 0.6D0 * s1_size_points xcp = (x1_points + x2_points) / 2.0D0 ycp = y2_points - radius * 0.5D0 CALL DNew_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.866D0 y0p = ycp - radius * 0.5D0 CALL DLine_to_L12 (x0p,y0p) x1p = x0p + radius * 0.5523D0 * 0.66667D0 * 0.5D0 y1p = y0p + radius * 0.5523D0 * 0.66667D0 * 0.866D0 x3p = x0p y3p = ycp + radius * 0.5D0 x2p = x1p y2p = y3p - radius * 0.5523D0 * 0.66667D0 * 0.866D0 CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x0p = xcp - (x0p - xcp) x1p = xcp - (x1p - xcp) x2p = x1p x3p = x0p CALL DNew_L12_Path(1,xcp,ycp) CALL DLine_to_L12 (x0p,y0p) CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.0D0)), dashed = .FALSE.) radius = 0.5D0 * s1_size_points x0p = xcp - radius x1p = xcp + radius CALL DNew_L12_Path(1,x0p,ycp) CALL DLine_to_L12(x1p,ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + radius ! symbol only CALL DEnd_Group ELSE IF (bottom) THEN ! sample paleostress in bottomlegend CALL DBegin_Group ! text part of paleostress in legend CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Paleostress') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'datum, with') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = '90%-confidence') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'sectors; solid if') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = '100%-relevant:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.0D0 ! text only ! symbol part of paleostress in legend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points radius = 0.6D0 * s1_size_points xcp = x1_points + 12.0D0 ycp = (y1_points + y2_points) / 2.0D0 CALL DNew_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.5D0 y0p = ycp + radius * 0.866D0 CALL DLine_to_L12 (x0p,y0p) x1p = x0p - radius * 0.5523D0 * 0.66667D0 * 0.866D0 y1p = y0p + radius * 0.5523D0 * 0.66667D0 * 0.5D0 x3p = xcp - radius * 0.5D0 y3p = y0p x2p = x3p + radius * 0.5523D0 * 0.66667D0 * 0.866D0 y2p = y1p CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) y0p = ycp - (y0p - ycp) y1p = ycp - (y1p - ycp) y2p = y1p y3p = y0p CALL DNew_L12_Path(1,xcp,ycp) CALL DLine_to_L12 (x0p,y0p) CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.0D0)), dashed = .FALSE.) radius = 0.5D0 * s1_size_points y0p = ycp - radius y1p = ycp + radius CALL DNew_L12_Path(1,xcp,y0p) CALL DLine_to_L12(xcp,y1p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + 12.0D0 + radius ! symbol only CALL DEnd_Group END IF ! sample paleostress in right or bottom legend !close up after plotting stress data DEALLOCATE ( s_code ) DEALLOCATE ( s_site_now ) DEALLOCATE ( s_azim_now ) DEALLOCATE ( s_sigma_ ) DEALLOCATE ( s_t_max ) DEALLOCATE ( s_t_min ) DEALLOCATE ( s_stage ) CALL Add_Title(s_rst_file) CALL Add_Title(TRIM(ADJUSTL(DASCII8(t2_Ma)))//' Ma ('//TRIM(Epoch(t2_Ma))//') to '//& & TRIM(ADJUSTL(DASCII8(t1_Ma)))//' Ma ('//TRIM(Epoch(t1_Ma))//')') WRITE (*,"('+Working on paleostress directions....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of paleostress directions overlay CASE (12) ! stress directions interpolated by Restore 2120 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .TRUE., & ! & velocity = .FALSE., & ! & suggested_file = stress_feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file contains the stresses?',stress_feg_file,stress_feg_file) stress_feg_pathfile = TRIM(temp_path_in)//TRIM(stress_feg_file) OPEN (UNIT = 21, FILE = stress_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) ALLOCATE ( node_uvec(3,numnod) ) DO i = 1, numnod READ (21, *, IOSTAT = ios) j, lon, lat problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( center(3,numel) ) ALLOCATE ( selected(numel) ) ALLOCATE ( s1h_known(numel) ) ALLOCATE ( s1h_azim_radians(numel) ) ALLOCATE ( s1h_sigma_radians(numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i), & & t1, t2, t3, & ! these are mu_element(1), mu_switch, mu_element(2) & s1h_known(i), s1h_azim_degrees, s1h_sigma_degrees problem = problem .OR. (ios /= 0) s1h_azim_radians(i) = s1h_azim_degrees * radians_per_degree s1h_sigma_radians(i) = s1h_sigma_degrees * radians_per_degree END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Interpolated stresses absent or defective in this file.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2120 END IF CLOSE (21) CALL DPrompt_for_Real('How long should the symbols be, in points?',s1h_interp_points,s1h_interp_points) WRITE (*,"(/' There will be ',I7,' interpolated stresses if they are not thinned.')") numel 2121 CALL DPrompt_for_Integer('What thinning factor ( >=1 ) do you want?',stress_thinner,stress_thinner) IF (stress_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") GO TO 2121 END IF IF (stress_thinner > 1) THEN WRITE(string10,"(I10)") stress_thinner CALL Add_Title('(1/'//TRIM(ADJUSTL(string10))//') of Interpolated Stress Directions') ELSE ! == 1 CALL Add_Title('Interpolated Stress Directions') END IF CALL Add_Title(stress_feg_file) DO i = 1, numel uvec1(1:3) = (node_uvec(1:3, nodes(1,i)) + & & node_uvec(1:3, nodes(2,i)) + & & node_uvec(1:3, nodes(3,i))) / 3. CALL DMake_Uvec (uvec1, uvec) ! center of element center(1:3,i) = uvec(1:3) END DO CALL DThin_on_Sphere (center, numel, stress_thinner, selected) CALL DPrompt_for_Logical('Program RESTORE attempts to interpolate stress to all elements, & & but only uses interpolated stresses whose 90%-confidence bounds are& & +-45 deg. or less. (One neighboring stress datum is not enough for this.)& & Shall this plot be limited to only those results?',only_stressed,only_stressed) WRITE (*,"(/' Working on stresses interpolated by Restore....')") CALL DBegin_Group ! foreground-bounded background-colored wedges for 90% confidence limits CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radians = (0.4D0 * s1h_interp_points * 3.528D-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, numel IF (((only_stressed).AND.(s1h_known(i))) .OR. & & ((.NOT.only_stressed).AND.(s1h_azim_radians(i) /= 0.0D0))) THEN IF (selected(i)) THEN del_az_for_90pc = s1h_sigma_radians(i) * 1.645D0 uvec(1:3) = center(1:3,i) CALL DNew_L45_Path(5, uvec) CALL DTurn_To (s1h_azim_radians(i)+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DGreat_to_L45(uvec1) CALL DTurn_To (s1h_azim_radians(i)-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DSmall_to_L45(uvec, uvec2) CALL DGreat_to_L45(uvec) CALL DEnd_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL DNew_L45_Path(5, uvec) CALL DTurn_To (s1h_azim_radians(i)+Pi+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DGreat_to_L45(uvec1) CALL DTurn_To (s1h_azim_radians(i)+Pi-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DSmall_to_L45(uvec, uvec2) CALL DGreat_to_L45(uvec) CALL DEnd_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! selected(i) END IF ! s1h_known(i) END DO ! i = 1, numel CALL DEnd_Group ! end of 90%-confidence limits for interpolated stresses CALL DBegin_Group ! interpolated stress indicator bar IF (ai_using_color) THEN CALL DSet_Stroke_Color ('mid_blue__') ELSE CALL DSet_Stroke_Color ('gray______') END IF CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1h_interp_points / 8.0D0)), dashed = .FALSE.) radians = (0.5D0 * s1h_interp_points * 3.528D-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, numel IF (((only_stressed).AND.(s1h_known(i))) .OR. & & ((.NOT.only_stressed).AND.(s1h_azim_radians(i) /= 0.0D0))) THEN IF (selected(i)) THEN uvec(1:3) = center(1:3,i) CALL DTurn_To (s1h_azim_radians(i), uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DNew_L45_Path(5, uvec1) CALL DTurn_To (s1h_azim_radians(i)+Pi, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DGreat_to_L45(uvec2) CALL DEnd_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! selected(i) END IF ! s1h_known(i) END DO ! i = 1, numel CALL DEnd_Group ! of interpolated stress-direction bars DEALLOCATE ( node_uvec, center, selected, nodes, s1h_known, s1h_azim_radians, s1h_sigma_radians ) CALL Chooser (bottom, right) IF (right) THEN ! sample interpolated stress in rightlegend CALL DBegin_Group ! text part of paleostress in legend CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Interpolated') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'stress direction,') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '90%-confidence') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 30.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'sectors:') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 45.0D0 ! text only ! symbol part of paleostress in legend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radius = 0.4D0 * s1h_interp_points ! (was 0.6 for stress data, where sigma may be small) xcp = (x1_points + x2_points) / 2.0D0 ycp = y2_points - radius * 0.5D0 CALL DNew_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.866 y0p = ycp - radius * 0.5 CALL DLine_to_L12 (x0p,y0p) x1p = x0p + radius * 0.5523D0 * 0.66667D0 * 0.5D0 y1p = y0p + radius * 0.5523D0 * 0.66667D0 * 0.866D0 x3p = x0p y3p = ycp + radius * 0.5D0 x2p = x1p y2p = y3p - radius * 0.5523D0 * 0.66667D0 * 0.866D0 CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x0p = xcp - (x0p - xcp) x1p = xcp - (x1p - xcp) x2p = x1p x3p = x0p CALL DNew_L12_Path(1,xcp,ycp) CALL DLine_to_L12 (x0p,y0p) CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself IF (ai_using_color) THEN CALL DSet_Stroke_Color ('mid_blue__') ELSE CALL DSet_Stroke_Color ('gray______') END IF CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1h_interp_points / 8.0D0)), dashed = .FALSE.) radius = 0.5D0 * s1h_interp_points x0p = xcp - radius x1p = xcp + radius CALL DNew_L12_Path(1,x0p,ycp) CALL DLine_to_L12(x1p,ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + radius ! symbol only CALL DEnd_Group ELSE IF (bottom) THEN ! sample interpolated stress in bottomlegend CALL DBegin_Group ! text part of paleostress in bottomlegend CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'Interpolated') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'stress direction,') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '90%-confidence') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'sectors:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.0D0 ! text only ! symbol part of paleostress in bottomlegend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + 6.0D0 CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radius = 0.4D0 * s1h_interp_points ! (was 0.6 for stress data, where sigma may be small) xcp = x1_points + radius * 0.5D0 ycp = (y1_points + y2_points) / 2.0D0 CALL DNew_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.5D0 y0p = ycp + radius * 0.866D0 CALL DLine_to_L12 (x0p,y0p) x1p = x0p - radius * 0.5523D0 * 0.66667D0 * 0.866D0 y1p = y0p + radius * 0.5523D0 * 0.66667D0 * 0.5D0 x3p = xcp - radius * 0.5D0 y3p = y0p x2p = x3p + radius * 0.5523D0 * 0.66667D0 * 0.866D0 y2p = y1p CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) y0p = ycp - (y0p - ycp) y1p = ycp - (y1p - ycp) y2p = y1p y3p = y0p CALL DNew_L12_Path(1,xcp,ycp) CALL DLine_to_L12 (x0p,y0p) CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself IF (ai_using_color) THEN CALL DSet_Stroke_Color ('mid_blue__') ELSE CALL DSet_Stroke_Color ('gray______') END IF CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1h_interp_points / 8.0D0)), dashed = .FALSE.) radius = 0.5D0 * s1h_interp_points y0p = ycp - radius y1p = ycp + radius CALL DNew_L12_Path(1,xcp,y0p) CALL DLine_to_L12(xcp,y1p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + 6.0D0 + radius ! symbol only CALL DEnd_Group END IF ! sample interpolated stress in bottom/right legend WRITE (*,"('+Working on stresses interpolated by Restore....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 7 :: stresses interpolated by Restore CASE (13:15) ! strain-rates: ! 13 = total strain-rate of all elements (including faulting); ! 14 = strain-rate of non-faulting elements only ! 15 = continuum (non-faulting) part of strain-rate in faulting elements, ! and continuum (= total) strain-rate in non-faulting elements. ! Note that CASE(13) uses a xmmnn.vel file for data; ! but CASE(14:15) use values computed by Restore and ! recorded in the element list of a xxxxmmnn.feg file. IF (choice == 13) THEN CALL Add_Title("Total strain-rates, including faulting") ELSE IF (choice == 14) THEN CALL Add_Title("Strain-rates of non-faulting elements only") ELSE IF (choice == 15) THEN CALL Add_Title("Continuum (non-faulting) strain-rates in all elements") END IF ! choice == 13, 14, 15 2130 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .TRUE., & ! & velocity = .FALSE., & ! & suggested_file = strain_feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file defines the elements?',strain_feg_file,strain_feg_file) strain_feg_pathfile = TRIM(temp_path_in)//TRIM(strain_feg_file) OPEN (UNIT = 21, FILE = strain_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( vw(2*numnod) ) DO i = 1, numnod READ (21, *, IOSTAT = ios) j, lon, lat problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( center(3,numel) ) ALLOCATE ( selected(numel) ) ALLOCATE ( faulting(numel) ) ALLOCATE ( strainrate(3, numel) ) ALLOCATE ( e3_minus_e1_persec(numel) ) DO i = 1, numel IF (choice == 13) THEN ! only read element node numbers READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) ELSE ! choice == 14:15; read further to get continuum strainrates, faulting? READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i), & & t1, t2, t3, & ! mu_element(1), mu_switch, mu_element(2) & lt, r1t, r2t, strainrate(1:3, i), faulting(i) END IF problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2130 END IF CLOSE (21) CALL Add_Title(strain_feg_file) IF (choice == 13) THEN ! must also read .vel file 2131 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .TRUE., & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity (.vel) file should be used?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2131 END IF DO i = 1, 3 READ (22,"(A)") line CALL Add_Title(line) END DO ! first 3 lines of velocity file READ (22,*) (vw(i), i = 1, (2*numnod)) !This read method should work for either SHELLS or RESTORE formats. CLOSE (22) CALL DPrompt_for_Real('What is the radius of the planet, in m?', R, R) DO l_ = 1, numel ! compute strainrates at element centers ! evaluate nodal function and derivitives at center of element uvec1(1:3) = (node_uvec(1:3, nodes(1,l_)) + & & node_uvec(1:3, nodes(2,l_)) + & & node_uvec(1:3, nodes(3,l_))) / 3. CALL DMake_Uvec (uvec1, uvec) ! center of element equat = DSQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.0D0) THEN PRINT "(' Error: center of element ',I5,' is N or S pole.')", l_ WRITE (21,"('Error: center of element ',I5,' is N or S pole.')") l_ STOP ' ' END IF theta_ = DATAN2(equat, uvec(3)) uvec1(1:3) = node_uvec(1:3, nodes(1, l_)) uvec2(1:3) = node_uvec(1:3, nodes(2, l_)) uvec3(1:3) = node_uvec(1:3, nodes(3, l_)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(R, l_, G, dG, theta_, vw, eps_dot) strainrate(1:3, l_) = eps_dot(1:3) END DO ! l_ = 1, numel, computing total strainrates END IF ! .vel file is needed to compute total strainrates !convert to scalar measure, for histogram DO i = 1, numel IF ((choice == 14) .AND. (faulting(i))) THEN e3_minus_e1_persec(i) = 0.0D0 ELSE ! compute 3 principal values, and partition one with unique sign CALL DPrincipal_Axes_22 (strainrate(1,i),strainrate(2,i),strainrate(3,i), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) err = -(e1h + e2h) ! Decide which principal strain(-rate) is partitioned: e1h_partitioned = (e1h /= 0.0D0).AND.((e1h*e2h) <= 0.0D0).AND.((e1h*err) <= 0.0D0) e2h_partitioned = (e2h /= 0.0D0).AND.((e2h*e1h) <= 0.0D0).AND.((e2h*err) <= 0.0D0) err_partitioned = (err /= 0.0D0).AND.((err*e1h) <= 0.0D0).AND.((err*e2h) <= 0.0D0) ! Decide how big largest symbol is (in terms of partitioned e3-e1). big_diff = 0.0D0 IF (e1h*e2h < 0.0D0) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.0D0*ABS(e2h)) ELSE big_diff = MAX(big_diff, 2.0D0*ABS(e1h)) END IF END IF IF (e1h*err < 0.0D0) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.0D0*ABS(err)) ELSE big_diff = MAX(big_diff, 2.0D0*ABS(e1h)) END IF END IF IF (e2h*err < 0.0D0) THEN IF (e2h_partitioned) THEN big_diff = MAX(big_diff, 2.0D0*ABS(err)) ELSE big_diff = MAX(big_diff, 2.0D0*ABS(e2h)) END IF END IF e3_minus_e1_persec(i) = big_diff END IF END DO WRITE (*, "(/ & & ' Available modes for plotting strain-rate are:'/ & & ' 0 : All symbols are the same size (for legibility).'/ & & ' 1 : Symbol diameter is linearly proportional to strain-rate.'/ & & ' 2 : Symbol area (diameter**2) is proportional to strain-rate.')") CALL DPrompt_for_Integer('Which mode do you want?',strainrate_mode012,strainrate_mode012) IF (strainrate_mode012 == 0) THEN CALL DPrompt_for_Real('What diameter should the symbols be, in points?',strainrate_diameter_points,strainrate_diameter_points) ELSE WRITE (*,"(/' Here is the distribution of non-zero differential strain-rates' & & /' (e3 - e1) across the elements (in /s):')") CALL Histogram (e3_minus_e1_persec, numel, .TRUE., maximum, minimum) IF (ref_e3_minus_e1_persec <= 0.0D0) ref_e3_minus_e1_persec = maximum CALL DPrompt_for_Real('What is the reference strain-rate, in /s?',ref_e3_minus_e1_persec,ref_e3_minus_e1_persec) CALL DPrompt_for_Real('What diameter should the reference strain-rate have, in points?',strainrate_diameter_points,strainrate_diameter_points) END IF WRITE (*,"(/' There will be ',I7,' strain-rates if they are not thinned.')") numel 2132 CALL DPrompt_for_Integer('What thinning factor ( >=1 ) do you want?',strain_thinner,strain_thinner) IF (strain_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") GO TO 2132 END IF IF (strain_thinner > 1) THEN WRITE(string10,"(I10)") strain_thinner CALL Add_Title('Showing (1/'//TRIM(ADJUSTL(string10))//') of per-element strain-rates') ELSE ! == 1 CALL Add_Title('Strain-rates shown in all elements') END IF CALL Add_Title(stress_feg_file) DO i = 1, numel uvec1(1:3) = (node_uvec(1:3, nodes(1,i)) + & & node_uvec(1:3, nodes(2,i)) + & & node_uvec(1:3, nodes(3,i))) / 3. CALL DMake_Uvec (uvec1, uvec) ! center of element center(1:3,i) = uvec(1:3) END DO CALL DThin_on_Sphere (center, numel, strain_thinner, selected) WRITE (*,"(/' Working on strain-rates....')") CALL DBegin_Group ! of strain-rates CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells DO i = 1, numel IF ((choice /= 14).OR.(.NOT.faulting(i))) THEN ! tensor should be plotted IF (selected(i)) THEN uvec(1:3) = center(1:3,i) CALL DStrain_on_Sphere (uvec, & & strainrate(1,i), strainrate(2,i), strainrate(3,i), & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) END IF ! selected(i) END IF ! tensor should be plotted END DO ! i = 1, numel CALL DEnd_Group ! of strain-rate tensors DEALLOCATE ( center, & & e3_minus_e1_persec, & & faulting, & & node_uvec, & & nodes, & & selected, & & strainrate, & & vw ) CALL Chooser (bottom, right) IF (right) THEN ! sample strain-rate in rightlegend CALL DBegin_Group ! text part of strain-rate in legend; begin with a gap rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points ! y2 is top of next text line CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') IF (choice == 13) THEN ! "Strain-rate, as" CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Strain-rate, as') rightlegend_used_points = rightlegend_used_points + 10.0D0 y2_points = y2_points - 10.0D0 ELSE ! "Strain-rate of" / "continuum, as" CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Strain-rate of') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'continuum, as') rightlegend_used_points = rightlegend_used_points + 20.0D0 y2_points = y2_points - 20.0D0 END IF ! choice = 13 or 14:15. (Now, y2 still points to top of next line.) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'conjugate') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'microfaults:') rightlegend_used_points = rightlegend_used_points + 25.0D0 ! 5 points extra for minigap y2_points = y2_points - 25.0D0 ! symbol part of paleostress in legend; CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL DStrain_in_Plane (1, 0.8D0*x1_points + 0.2D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & -0.5D0*ref_e3_minus_e1_persec, 0.0D0, 0.0D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL DStrain_in_Plane (1, 0.5D0*x1_points + 0.5D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & 0.5D0*ref_e3_minus_e1_persec, 0.0D0, -0.5D0*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL DStrain_in_Plane (1, 0.2D0*x1_points + 0.8D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & 0.5D0*ref_e3_minus_e1_persec, 0.0D0, 0.0D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) rightlegend_used_points = rightlegend_used_points + strainrate_diameter_points y2_points = y2_points - strainrate_diameter_points IF (strainrate_mode012 > 0) THEN ! label with e3-e1 = # CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'E3 - E1 =') number8 = DASCII8(ref_e3_minus_e1_persec) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Diameter') ELSE ! mode012 = 2 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Area is') END IF ! mode 1 or 2 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 30.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'proportional to') rightlegend_used_points = rightlegend_used_points + 40.0D0 y2_points = y2_points - 40.0D0 ELSE ! all symbols are of equal size CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Size is') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'independent of') rightlegend_used_points = rightlegend_used_points + 20.0D0 y2_points = y2_points - 20.0D0 END IF ! labelling with numerical strainrate, or not CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'strain-rate.)') rightlegend_used_points = rightlegend_used_points + 10.0D0 y2_points = y2_points - 10.0D0 CALL DEnd_Group ELSE IF (bottom) THEN ! sample strain-rate in bottomlegend CALL DBegin_Group ! text part of strain-rate in legend; begin with a gap CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') IF (choice == 13) THEN ! "Strain-rate, as" CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Strain-rate, as') rightlegend_used_points = rightlegend_used_points + 10.0D0 y2_points = y2_points - 10.0D0 ELSE ! "Strain-rate of" / "continuum, as" CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Strain-rate of') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'continuum, as') END IF ! choice = 13 or 14:15 CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'conjugate') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) -20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'microfaults:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.0D0 ! text1 only ! symbol part of paleostress in legend; CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL DStrain_in_Plane (1, x1_points + 14.0D0, & & 0.5D0*(y1_points + y2_points), & & -0.5D0*ref_e3_minus_e1_persec, 0.0D0, 0.0D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL DStrain_in_Plane (1, x1_points + 36.0D0, & & 0.5D0*(y1_points + y2_points), & & 0.5D0*ref_e3_minus_e1_persec, 0.0D0, -0.5D0*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL DStrain_in_Plane (1, x1_points + 58.0D0, & & 0.5D0*(y1_points + y2_points) , & & 0.5D0*ref_e3_minus_e1_persec, 0.0D0, 0.0D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) bottomlegend_used_points = bottomlegend_used_points + 72.0D0 ! now, including middle symbols block x1_points = x1_points + 72.0D0 !note that x1_points now indicates right side of middle symbol block IF (strainrate_mode012 > 0) THEN ! label with e3-e1 = # CALL DL12_Text (level = 1, & & x_points = x1_points - 36.0D0, & & y_points = y1_points + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'E3 - E1 =') number8 = DASCII8(ref_e3_minus_e1_persec) CALL DL12_Text (level = 1, & & x_points = x1_points - 36.0D0, & & y_points = y1_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Diameter') ELSE ! mode012 = 2 CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Area is') END IF ! mode 1 or 2 CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'proportional to') ELSE ! all symbols are of equal size CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Size is') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'independent of') END IF ! labelling with numerical strainrate, or not CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'strain-rate.)') CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + 72.0D0 ! right text block END IF ! sample strain-rate in bottom/right legend WRITE (*,"('+Working on strain-rates....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 13:15 :: strain-rates CASE (16) ! log-of-net-principal-stretch tensor, including faulting 2160 CALL Add_Title('Natural Strain (ln(stretch)) Tensors') CALL Get_Paired_Feg_Names (old_feg_file, old_feg_pathfile, & & new_feg_file, new_feg_pathfile) !This routine has tested files by opening and comparing numnod's. 2161 CALL DPrompt_for_Real('What is the geologic age of the older file, in Ma?',t2_Ma,t2_Ma) CALL DPrompt_for_Real('What is the geologic age of the younger file, in Ma?',t1_Ma,t1_Ma) IF (t2_Ma <= t1_Ma) THEN WRITE (*,"(' ERROR: Maximum age must exceed minimum age.')") GO TO 2161 END IF IF (t1_Ma <= 0.0D0) THEN WRITE (c6t2, "(F6.2)") t2_Ma line = 'Natural Strain since ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ')' ELSE WRITE (c6t1, "(F6.2)") t1_Ma WRITE (c6t2, "(F6.2)") t2_Ma line = 'Natural Strain from ' // & & TRIM(ADJUSTL(c6t2)) // ' Ma (' // TRIM(Epoch(t2_Ma)) // ') to ' // & & TRIM(ADJUSTL(c6t1)) // ' Ma (' // TRIM(Epoch(t1_Ma)) // ')' END IF CALL Add_Title(line) WRITE (*, *) CALL DPrompt_for_Logical('Should this map include faulted elements?', .FALSE., also_plot_faulted_elements) OPEN(UNIT = 21, FILE = old_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21,*) READ (21,*) numnod ALLOCATE ( old_node_uvec(3,numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) old_node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21,*) old_numel ALLOCATE ( old_nodes(3, old_numel) ) DO i = 1, old_numel READ (21,*) j, old_nodes(1,i), old_nodes(2,i), old_nodes(3,i) END DO CLOSE (21) OPEN(UNIT = 22, FILE = new_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (22,*) READ (22,*) numnod ALLOCATE ( new_node_uvec(3,numnod) ) DO i = 1, numnod READ (22,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) new_node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (22,*) new_numel ALLOCATE ( new_nodes(3, new_numel) ) ALLOCATE ( before_and_after_unfaulted(new_numel) ) DO i = 1, new_numel READ (22, *, IOSTAT = ios) j, new_nodes(1,i), new_nodes(2,i), new_nodes(3,i), before_and_after_unfaulted(i) IF (ios /= 0) THEN ! This is probably because before_and_after_unfaulted(i) was not present (in older input files). BACKSPACE (22) READ (22, *, IOSTAT = ios) j, new_nodes(1,i), new_nodes(2,i), new_nodes(3,i), before_and_after_unfaulted(i) before_and_after_unfaulted(i) = .TRUE. ! This may be wrong, but too-many-symbols-plotted is less confusing than no-symbols-plotted! END IF END DO CLOSE (22) ALLOCATE ( strained(new_numel) ) ALLOCATE ( strain_table(15, new_numel) ) CALL FE_Strain (numnod, old_node_uvec, new_node_uvec, & & old_numel, old_nodes, & & new_numel, new_nodes, & & strained, strain_table) ! outputs refer to new_ grid IF (.NOT.also_plot_faulted_elements) THEN DO i = 1, new_numel IF (.NOT.before_and_after_unfaulted(i)) strained(i) = .FALSE. END DO END IF ALLOCATE ( log_stretch(3, new_numel) ) ALLOCATE ( train(new_numel) ) ! (1) Convert principal strains to log_stretch's, ! and (2) find theta, phi, thetaphi components ( log_strain(1:3,1:numel) ) ! and (3) convert to scalar measure, for histogram ( train(1:numel) ) train_length = 0 ! length of list of scalars destined for Histogram DO i = 1, new_numel IF (strained(i)) THEN eps1h = strain_table(10,i) ! -0.99 < eps1h -1.0D0) THEN ! reasonable value log_stretch_1h = DLOG(1.0D0 + eps1h) log_stretch_2h = DLOG(1.0D0 + eps2h) log_stretch_rr = -(log_stretch_1h + log_stretch_2h) azim1h = deg1h * radians_per_degree ! in radians, clockwise from present N log_stretch_tt = (log_stretch_1h + log_stretch_2h) / 2.0D0 - & &((log_stretch_2h - log_stretch_1h) / 2.0D0) * DCOS(2.0D0 * azim1h) log_stretch_pp = (log_stretch_1h + log_stretch_2h) / 2.0D0 + & &((log_stretch_2h - log_stretch_1h) / 2.0D0) * DCOS(2.0D0 * azim1h) log_stretch_tp =((log_stretch_2h - log_stretch_1h) / 2.0D0) * DSIN(2.0D0 * azim1h) log_stretch(1,i) = log_stretch_tt log_stretch(2,i) = log_stretch_tp log_stretch(3,i) = log_stretch_pp ! Decide which principal log_stretch is partitioned: e1h_partitioned = (log_stretch_1h /= 0.0D0).AND. & & ((log_stretch_1h * log_stretch_2h) <= 0.0D0).AND. & & ((log_stretch_1h * log_stretch_rr) <= 0.0D0) e2h_partitioned = (log_stretch_2h /= 0.0D0).AND. & & ((log_stretch_2h * log_stretch_1h) <= 0.0D0).AND. & & ((log_stretch_2h * log_stretch_rr) <= 0.0D0) err_partitioned = (log_stretch_rr /= 0.0D0).AND. & & ((log_stretch_rr * log_stretch_1h) <= 0.0D0).AND. & & ((log_stretch_rr * log_stretch_2h) <= 0.0D0) ! Decide how big largest symbol is (in terms of partitioned e3-e1). big_diff = 0.0D0 IF ((log_stretch_1h * log_stretch_2h) < 0.0D0) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.0D0*ABS(log_stretch_2h)) ELSE big_diff = MAX(big_diff, 2.0D0*ABS(log_stretch_1h)) END IF END IF IF ((log_stretch_1h * log_stretch_rr) < 0.0D0) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.0D0*ABS(log_stretch_rr)) ELSE big_diff = MAX(big_diff, 2.0D0*ABS(log_stretch_1h)) END IF END IF IF ((log_stretch_2h * log_stretch_rr) < 0.0D0) THEN IF (e2h_partitioned) THEN big_diff = MAX(big_diff, 2.0D0*ABS(log_stretch_rr)) ELSE big_diff = MAX(big_diff, 2.0D0*ABS(log_stretch_2h)) END IF END IF train_length = train_length + 1 train(train_length) = big_diff ELSE strained(i) = .FALSE. log_stretch(1:3,i) = 0.0D0 END IF ! eps1h is reasonable or not ELSE ! .NOT. strained(i) log_stretch(1:3,i) = 0.0D0 END IF ! strained(i) END DO ! i = 1, numel IF (train_length == 0) THEN WRITE (*,"(' ERROR: Not one single element matches between these grids.')") STOP END IF WRITE (*,"(/' Here is the distribution of non-zero differential log-stretches' & & /' (ln(s3) - ln(s1)) across the elements:')") CALL Histogram (train, train_length, .TRUE., maximum, minimum) IF (ref_lns3_minus_lns1 <= 0.0D0) ref_lns3_minus_lns1 = maximum CALL DPrompt_for_Real('What is the reference (ln(s3) - ln(s1))?',ref_lns3_minus_lns1,ref_lns3_minus_lns1) CALL DPrompt_for_Real('What diameter should this reference (ln(s3) - ln(s1)) have, in points?',strain_diameter_points,strain_diameter_points) WRITE (*,"(/' There will be ',I7,' ln(stretch) tensors if they are not thinned.')") new_numel 2162 CALL DPrompt_for_Integer('What thinning factor ( >=1 ) do you want?',strain_thinner,strain_thinner) IF (strain_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") GO TO 2162 END IF WRITE (*,"(/' Working on natural strain tensors....')") ALLOCATE ( center(3, new_numel) ) ALLOCATE ( selected(new_numel) ) DO i = 1, new_numel uvec1(1:3) = (new_node_uvec(1:3, new_nodes(1,i)) + & & new_node_uvec(1:3, new_nodes(2,i)) + & & new_node_uvec(1:3, new_nodes(3,i))) / 3. CALL DMake_Uvec (uvec1, uvec) ! center of element center(1:3,i) = uvec(1:3) END DO CALL DThin_on_Sphere (center, new_numel, strain_thinner, selected) CALL DBegin_Group ! of strain (ln(stretch)) tensors CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells DO i = 1, new_numel IF (strained(i).AND.selected(i)) THEN uvec(1:3) = center(1:3,i) CALL DStrain_on_Sphere (uvec, & & log_stretch(1,i), log_stretch(2,i), log_stretch(3,i), & & ref_lns3_minus_lns1, strain_diameter_points, & & 1) ! plot in mode 1: diameter proportional to ln(stretch) END IF ! strained(i).AND.selected(i) END DO ! i = 1, new_numel CALL DEnd_Group ! of strain-rate tensors !Deallocate in reverse order of allocation: LIFO) DEALLOCATE ( selected, center, train, & & log_stretch, strain_table, strained, & & before_and_after_unfaulted, & & new_nodes, new_node_uvec, & & old_nodes, old_node_uvec ) CALL Chooser (bottom, right) IF (right) THEN ! sample strain in rightlegend CALL DBegin_Group ! text part of strain-rate in legend; begin with a gap rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points ! y2 is top of next text line CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Natural Strain') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(ln(stretch))') rightlegend_used_points = rightlegend_used_points + 20.0D0 y2_points = y2_points - 20.0D0 !Now, y2 still points to top of next line. CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'as conjugate') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'microfaults:') rightlegend_used_points = rightlegend_used_points + 25.0D0 ! 5 points extra for minigap y2_points = y2_points - 25.0D0 ! symbol part of paleostress in legend; CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL DStrain_in_Plane (1, 0.8D0*x1_points + 0.2D0*x2_points, & & y2_points - 0.5D0*strain_diameter_points , & & -0.5D0*ref_lns3_minus_lns1, 0.0D0, 0.0D0, & & ref_lns3_minus_lns1, strain_diameter_points, & & 1) ! X for strike-slip in center CALL DStrain_in_Plane (1, 0.5D0*x1_points + 0.5D0*x2_points, & & y2_points - 0.5D0*strain_diameter_points , & & 0.5D0*ref_lns3_minus_lns1, 0.0D0, -0.5D0*ref_lns3_minus_lns1, & & ref_lns3_minus_lns1, strain_diameter_points, & & 1) ! vertical graben symbol on right: CALL DStrain_in_Plane (1, 0.2D0*x1_points + 0.8D0*x2_points, & & y2_points - 0.5D0*strain_diameter_points , & & 0.5D0*ref_lns3_minus_lns1, 0.0D0, 0.0D0, & & ref_lns3_minus_lns1, strain_diameter_points, & & 1) rightlegend_used_points = rightlegend_used_points + strain_diameter_points y2_points = y2_points - strain_diameter_points CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'ln(s3) - ln(s1) =') number8 = DASCII8(ref_lns3_minus_lns1) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(ADJUSTL(number8))) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Diameter') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 30.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'proportional to') rightlegend_used_points = rightlegend_used_points + 40.0D0 y2_points = y2_points - 40.0D0 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'ln(stretch).)') rightlegend_used_points = rightlegend_used_points + 10.0D0 y2_points = y2_points - 10.0D0 CALL DEnd_Group ELSE IF (bottom) THEN ! sample strain in bottomlegend CALL DBegin_Group ! text part of strain in legend; begin with a gap CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Natural Strain') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(ln(stretch))') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'as conjugate') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) -20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'microfaults:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.0D0 ! text1 only ! symbol part of strain in legend; CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL DStrain_in_Plane (1, x1_points + 14.0D0, & & 0.5D0*(y1_points + y2_points), & & -0.5D0*ref_lns3_minus_lns1, 0.0D0, 0.0D0, & & ref_lns3_minus_lns1, strain_diameter_points, & & 1) ! X for strike-slip in center CALL DStrain_in_Plane (1, x1_points + 36.0D0, & & 0.5D0*(y1_points + y2_points), & & 0.5D0*ref_lns3_minus_lns1, 0.0D0, -0.5D0*ref_lns3_minus_lns1, & & ref_lns3_minus_lns1, strain_diameter_points, & & 1) ! vertical graben symbol on right: CALL DStrain_in_Plane (1, x1_points + 58.0D0, & & 0.5D0*(y1_points + y2_points) , & & 0.5D0*ref_lns3_minus_lns1, 0.0D0, 0.0D0, & & ref_lns3_minus_lns1, strain_diameter_points, & & 1) bottomlegend_used_points = bottomlegend_used_points + 72.0D0 ! now, including middle symbols block x1_points = x1_points + 72.0D0 !note that x1_points now indicates right side of middle symbol block CALL DL12_Text (level = 1, & & x_points = x1_points - 36.0D0, & & y_points = y1_points + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'ln(s3) - ln(s1) =') number8 = DASCII8(ref_lns3_minus_lns1) CALL DL12_Text (level = 1, & & x_points = x1_points - 36.0D0, & & y_points = y1_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(number8))) CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Diameter') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'proportional to') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'ln(stretch).)') CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + 72.0D0 ! right text block END IF ! sample strain in bottom/right legend WRITE (*,"('+Working on natural strain tensors....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 16 :: log-of-net-principal-stretch tensors CASE (17) ! balanced cross-sections, with restored lengths CALL Add_Title('Restored Lengths of Balanced Cross-Sections') 2170 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .TRUE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = c_rst_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which cross-section dataset should be plotted?',c_rst_file,c_rst_file) c_rst_pathfile = TRIM(temp_path_in)//TRIM(c_rst_file) OPEN(UNIT = 21, FILE = c_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2170 END IF CALL Add_Title(c_rst_file) READ (21,"(A)") c_rst_format READ (21,"(A)") c_rst_titles c_rst_count = 0 size_c_rst: DO ! reading cross-section data, to determine number of sections READ (21, c_rst_format, IOSTAT = ios) c47, & & w_end_lon, w_end_lat, e_end_lon, e_end_lat, & & c5, km_now, km_was, km_sigma, t2, t1 IF (ios == -1) EXIT size_c_rst ! EOF c_rst_count = c_rst_count + 1 !Try to read two "+" lines to see if this file has model output: c1 = 'A' READ (21, "(A)", IOSTAT = ios) c1 ! restored position will not be used IF (ios == -1) c1 = ' ' ! EOF marker, to be used below IF (c1 == '+') THEN ! try again, for second + line READ (21, "(A)", IOSTAT = ios) c1 ! restored position will not be used IF (ios == -1) c1 = ' ' ! EOF marker, to be used below END IF got_stars = (c1 == '+') IF (got_stars) THEN c_rst_stars1: DO READ (21, "(A1,2F8.3,F10.4)", IOSTAT = ios) c1, t3, t4, rate IF (ios == -1) EXIT c_rst_stars1 ! EOF IF (c1 == '*') THEN ! lengthening rate and goal ELSE ! c1 /= '*'; have overshot BACKSPACE(21) EXIT c_rst_stars1 END IF ! c1 is or is not '*' END DO c_rst_stars1 ELSE ! got_stars = F; no model output in this file IF (c1 /= ' ') BACKSPACE (21) ! so next datum can be read in next time through loop END IF ! got_stars, or not END DO size_c_rst CLOSE (21) ALLOCATE ( extension_km(c_rst_count) ) OPEN(UNIT = 21, FILE = c_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21,"(A)") c_rst_format READ (21,"(A)") c_rst_titles c_rst_count = 0 ! sic; using as index one more time got_any_stars = .FALSE. ! may be set T below; controls contents of legend, & prompting for model_limit_Ma scan_c_rst: DO ! reading cross-section data, to display extensions in km READ (21, c_rst_format, IOSTAT = ios) c47, & & w_end_lon, w_end_lat, e_end_lon, e_end_lat, & & c5, km_now, km_was, km_sigma, t2, t1 IF (ios == -1) EXIT scan_c_rst ! EOF c_rst_count = c_rst_count + 1 extension_km(c_rst_count) = km_now - km_was !Try to read two "+" lines to see if this file has model output: c1 = 'A' READ (21, "(A)", IOSTAT = ios) c1 ! restored position will not be used IF (ios == -1) c1 = ' ' ! EOF marker, to be used below IF (c1 == '+') THEN ! try again, for second '+' line READ (21, "(A)", IOSTAT = ios) c1 ! restored position will not be used IF (ios == -1) c1 = ' ' ! EOF marker, to be used below END IF got_stars = (c1 == '+') IF (got_stars) THEN got_any_stars = .TRUE. c_rst_stars2: DO READ (21, "(A1,2F8.3,F10.4)", IOSTAT = ios) c1, t3, t4, rate IF (ios == -1) EXIT c_rst_stars2 ! EOF IF (c1 == '*') THEN ! lengthening rate and goal ELSE ! c1 /= '*'; have overshot BACKSPACE(21) EXIT c_rst_stars2 END IF ! c1 is or is not '*' END DO c_rst_stars2 ELSE ! got_stars = F; no model output in this file IF (c1 /= ' ') BACKSPACE (21) ! so next datum can be read in next time through loop END IF ! got_stars, or not END DO scan_c_rst CLOSE (21) WRITE (*,"(/' Here is the distribution of cross-section extensions, in km:')") CALL Histogram (extension_km, c_rst_count, .FALSE., maximum, minimum) DEALLOCATE (extension_km) IF (got_any_stars) THEN CALL DPrompt_for_Real('What is the maximum age (in Ma) that this model reached?', model_limit_Ma, model_limit_Ma) END IF ! got_any_stars WRITE (*,"(/' Working on restored lengths of balanced cross-sections....')") CALL DBegin_Group ! of all balanced cross-section symbols OPEN(UNIT = 21, FILE = c_rst_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21,"(A)") c_rst_format READ (21,"(A)") c_rst_titles read_c_rst: DO ! reading cross-section data, to end of file READ (21, c_rst_format, IOSTAT = ios) c47, & & w_end_lon, w_end_lat, e_end_lon, e_end_lat, & & c5, km_now, km_was, km_sigma, t2, t1 IF (ios == -1) EXIT read_c_rst ! EOF t_Ma = t2 ! only maximum age will be plotted CALL DLonLat_2_Uvec( w_end_lon, w_end_lat, w_uvec) ! west end CALL DLonLat_2_Uvec( e_end_lon, e_end_lat, e_uvec) ! east end !Try to read two "+" lines to see if this file has model output: c1 = 'A' READ (21, "(A)", IOSTAT = ios) c1 ! restored position will not be used IF (ios == -1) c1 = ' ' ! EOF marker, to be used below IF (c1 == '+') THEN ! try again, for second '+' line READ (21, "(A)", IOSTAT = ios) c1 ! restored position will not be used IF (ios == -1) c1 = ' ' ! EOF marker, to be used below END IF got_stars = (c1 == '+') IF (got_stars) THEN model = 0.0 c_rst_stars3: DO READ (21, "(A1,2F8.3,F10.4)", IOSTAT = ios) c1, t3, t4, rate IF (ios == -1) EXIT c_rst_stars3 ! EOF IF (c1 == '*') THEN ! extension rate and goal model = model + rate * (t4 - t3) !model is the net extension, in km (Ma * mm/a = km) ELSE ! c1 /= '*'; have overshot BACKSPACE(21) EXIT c_rst_stars3 END IF ! c1 is or is not '*' END DO c_rst_stars3 ELSE ! got_stars = F; no model output in this file IF (c1 /= ' ') BACKSPACE (21) ! so next datum can be read in next time through loop END IF ! got_stars, or not km_model = km_now - model ! since "model" is integrated extension in model !HERE is where we plot the balanced cross-section symbol: CALL DBegin_Group ! for one cross-section symbol section_width_points = 12.0D0 ! ADJUST here the fatness of section lines section_width_radians = section_width_points * 3.528D-4 * mp_scale_denominator / mp_radius_meters !Plot mid_blue (gray) bar with tapered end to show restored length !(note: Line of section is plotted LATER, so it will be on top.) CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'mid_blue__') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') END IF CALL By_Ribbon(e_uvec, w_uvec, 0.0D0, 0.0D0, section_width_radians, uvec) CALL DNew_L45_Path(5, uvec) CALL By_Ribbon(e_uvec, w_uvec, MAX(0.0D0,(km_was - 2.0D0 * km_sigma)/km_now), 0.0D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, MAX(0.0D0,(km_was - km_sigma)/km_now), 0.08D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, km_was/km_now, 0.25D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, (km_was + km_sigma)/km_now, 0.42D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, (km_was + 2.0D0 * km_sigma)/km_now, 0.5D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, (km_was + km_sigma)/km_now, 0.58D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, km_was/km_now, 0.75D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, MAX(0.0D0,(km_was - km_sigma)/km_now), 0.92D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, MAX(0.0D0,(km_was - 2.0D0 * km_sigma)/km_now), 1.0D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, 0.0D0, 1.0D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, 0.0D0, 0.0D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) !label end of mid_blue (gray) bar with age in Ma WRITE (c3, "(I3)") NINT(t_Ma) c3 = ADJUSTL(c3) CALL By_Ribbon(e_uvec, w_uvec, (km_was + 2.0D0 * km_sigma)/km_now, 0.5D0, section_width_radians, uvec) CALL By_Ribbon(e_uvec, w_uvec, 0.0D0, 0.5D0, section_width_radians, uvec1) rotate_radians = Pi_over_2 - DRelative_Compass(uvec, uvec1) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL5_Text (uvec = uvec, angle_radians = rotate_radians, from_east = .TRUE., & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = 0.3D0, & & text = TRIM(c3)) !plot present section location with |__________C0001___________| CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL By_Ribbon(e_uvec, w_uvec, 0.0D0, -1.0D0, section_width_radians, uvec) CALL DNew_L45_Path(5, uvec) CALL By_Ribbon(e_uvec, w_uvec, 0.0D0, 0.0D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, 1.0D0, 0.0D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, 1.0D0, -1.0D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL By_Ribbon(e_uvec, w_uvec, 0.5D0, 0.0D0, section_width_radians, uvec) rotate_radians = Pi_over_2 - DRelative_Compass(uvec, e_uvec) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL5_Text (uvec = uvec, angle_radians = rotate_radians, from_east = .TRUE., & & font_points = 12, lr_fraction = 0.5D0, ud_fraction =-0.4D0, & & text = c5) IF (got_stars) THEN !Plot green (background) bar to show restored length per model CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'background') END IF CALL By_Ribbon(e_uvec, w_uvec, 0.0D0, 1.0D0, section_width_radians, uvec) CALL DNew_L45_Path(5, uvec) CALL By_Ribbon(e_uvec, w_uvec, km_model/km_now, 1.0D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, km_model/km_now, 2.0D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, 0.0D0, 2.0D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL By_Ribbon(e_uvec, w_uvec, 0.0D0, 1.0D0, section_width_radians, uvec) CALL DGreat_to_L45(uvec) CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) !label end of green (background) model bar with lesser of section age or model limit, in Ma WRITE (c3, "(I3)") NINT(MIN(t_Ma, model_limit_Ma)) c3 = ADJUSTL(c3) CALL By_Ribbon(e_uvec, w_uvec, km_model/km_now, 1.5D0, section_width_radians, uvec) CALL By_Ribbon(e_uvec, w_uvec, 0.0D0, 1.5D0, section_width_radians, uvec1) rotate_radians = Pi_over_2 - DRelative_Compass(uvec, uvec1) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL5_Text (uvec = uvec, angle_radians = rotate_radians, from_east = .TRUE., & & font_points = 12, lr_fraction = 1.2D0, ud_fraction = 0.3D0, & & text = TRIM(c3)) END IF ! got_stars; model prediction available for this section CALL DEnd_Group ! for one cross-section symbol END DO read_c_rst CALL DEnd_Group ! of all balanced cross-section symbols CALL Chooser (bottom, right) IF (bottom) THEN ! bottom legend for balanced cross-sections CALL DBegin_Group ! for bottom vertical-axis rotation legend CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points) / 2.0D0 y4p = y2_points - 7.0D0 y3p = y4p - section_width_points y2p = y3p - section_width_points y1p = y2p - section_width_points x1p = x1_points + 185.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x1p, y_points = y3p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = -0.2D0, & & text = 'Cross-section location and index:') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = -0.2D0, & & text = 'Geologic restoration, to age in Ma:') IF (got_any_stars) THEN CALL DL12_Text (level = 1, x_points = x1p, y_points = y1p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = -0.2D0, & & text = 'Model restoration, to age in Ma:') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) x1p = x1_points + 215.0D0 ! limits of green bar x2p = x1_points + 290.0D0 CALL DL12_Text (level = 1, x_points = x1p, y_points = y1p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.2D0, ud_fraction = -0.2D0, & & text = '85') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'background') END IF CALL DNew_L12_Path (1, x1p, y1p) CALL DLine_to_L12 (x2p, y1p) CALL DLine_to_L12 (x2p, y2p) CALL DLine_to_L12 (x1p, y2p) CALL DLine_to_L12 (x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! got_any_stars; one or more model predictions are plotted !sample blue bar with tapered end on left x1p = x1_points + 205.0D0 x2p = x1_points + 290.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x1p, y_points = y2p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = -0.2D0, & & text = '99') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'mid_blue__') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') END IF CALL DNew_L12_Path(1, x1p, (0.50D0 * y2p + 0.50D0 * y3p)) CALL DLine_to_L12 ((x1p + 3.0D0), (0.58D0 * y2p + 0.42D0 * y3p)) CALL DLine_to_L12 ((x1p + 6.0D0), (0.75D0 * y2p + 0.25D0 * y3p)) CALL DLine_to_L12 ((x1p + 9.0D0), (0.92D0 * y2p + 0.08D0 * y3p)) CALL DLine_to_L12 ((x1p + 12.0D0), y2p) CALL DLine_to_L12 (x2p, y2p) CALL DLine_to_L12 (x2p, y3p) CALL DLine_to_L12 ((x1p + 12.0D0), y3p) CALL DLine_to_L12 ((x1p + 9.0D0), (0.92D0 * y3p + 0.08D0 * y2p)) CALL DLine_to_L12 ((x1p + 6.0D0), (0.75D0 * y3p + 0.25D0 * y2p)) CALL DLine_to_L12 ((x1p + 3.0D0), (0.58D0 * y3p + 0.42D0 * y2p)) CALL DLine_to_L12 (x1p, (0.50D0 * y2p + 0.50D0 * y3p)) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) !sample section line and index CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') x1p = x1_points + 236.0D0 CALL DNew_L12_Path(1, x1p, y4p) CALL DLine_to_L12(x1p, y3p) CALL DLine_to_L12(x2p, y3p) CALL DLine_to_L12(x2p, y4p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = (x1p + x2p)/2.0D0, y_points = y3p, angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = -0.4D0, & & text = 'C0017') CALL DEnd_Group ! of bottom vertical-axis rotation legend bottomlegend_used_points = bottomlegend_used_points + 291.0D0 + bottomlegend_gap_points ELSE IF (right) THEN ! right legend for balanced cross-sections CALL DBegin_Group ! for right vertical-axis rotation legend CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points xcp = (x1_points + x2_points) / 2.0D0 x1p = xcp - 1.5D0 * section_width_points x2p = xcp - 0.5D0 * section_width_points x3p = xcp + 0.5D0 * section_width_points x4p = xcp + 1.5D0 * section_width_points y1p = y2_points - 108.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x2p, y_points = y1p, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = -0.2D0, & & text = 'Cross-section location and index:') CALL DL12_Text (level = 1, x_points = x3p, y_points = y1p, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = -0.2D0, & & text = 'Geologic restoration, to age in Ma:') IF (got_any_stars) THEN CALL DL12_Text (level = 1, x_points = x4p, y_points = y1p, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = -0.2D0, & & text = 'Model restoration, to age in Ma:') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) y1p = y2_points - 77.0D0 ! limits of green bar y2p = y2_points - 3.0D0 CALL DL12_Text (level = 1, x_points = x4p, y_points = y1p, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.2D0, ud_fraction = -0.2D0, & & text = '85') IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'background') END IF CALL DNew_L12_Path (1, x4p, y1p) CALL DLine_to_L12 (x4p, y2p) CALL DLine_to_L12 (x3p, y2p) CALL DLine_to_L12 (x3p, y1p) CALL DLine_to_L12 (x4p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! got_any_stars; one or more model predictions are plotted !sample blue bar with tapered end on left y2p = y2_points - 3.0D0 y1p = y2_points - 87.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x3p, y_points = y1p, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 1.0D0, ud_fraction = -0.2D0, & & text = '99') CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'mid_blue__') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') END IF CALL DNew_L12_Path(1, (0.50D0 * x3p + 0.50D0 * x2p), y1p) CALL DLine_to_L12 ((0.58D0 * x3p + 0.42D0 * x2p), (y1p + 3.0D0)) CALL DLine_to_L12 ((0.75D0 * x3p + 0.25D0 * x2p), (y1p + 6.0D0)) CALL DLine_to_L12 ((0.92D0 * x3p + 0.08D0 * x2p), (y1p + 9.0D0)) CALL DLine_to_L12 (x3p, (y1p + 12.0D0)) CALL DLine_to_L12 (x3p, y2p) CALL DLine_to_L12 (x2p, y2p) CALL DLine_to_L12 (x2p, (y1p + 12.0D0)) CALL DLine_to_L12 ((0.92D0 * x2p + 0.08D0 * x3p), (y1p + 9.0D0)) CALL DLine_to_L12 ((0.75D0 * x2p + 0.25D0 * x3p), (y1p + 6.0D0)) CALL DLine_to_L12 ((0.58D0 * x2p + 0.42D0 * x3p), (y1p + 3.0D0)) CALL DLine_to_L12 ((0.50D0 * x2p + 0.50D0 * x3p), y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) !sample section line and index CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') y1p = y2_points - 56.0D0 CALL DNew_L12_Path(1, x1p, y1p) CALL DLine_to_L12(x2p, y1p) CALL DLine_to_L12(x2p, y2p) CALL DLine_to_L12(x1p, y2p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = x2p, y_points = (y1p + y2p) / 2.0D0, angle_radians = Pi_over_2, & & font_points = 12, lr_fraction = 0.5D0, ud_fraction = -0.4D0, & & text = 'C0017') CALL DEnd_Group ! of right legend for balanced cross-sections rightlegend_used_points = rightlegend_used_points + 291.0D0 + rightlegend_gap_points END IF ! bottom or right legend for balanced cross-sections WRITE (*,"('+Working on restored length of balanced cross-sections....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 17: balanced cross-sections, with restored lengths CASE (18) ! fault initiation/termination ages (colored dots, with number annotation in Ma; ! note that D, L, N, P, R, T are plotted as separate maps, and initiation and ! termination are plotted as separate maps, so it will take 12 runs of RetroMap4 ! to plot all the available age constraints in the (tab-delimited, header-stripped) F_PRIME.txt file. CALL Add_Title('Fault initiation or termination ages in Ma, separated by offset type') 2180 temp_path_in = path_in !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .TRUE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .FALSE., & ! & velocity = .FALSE., & ! & suggested_file = traces_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which f____.DIG file should be plotted?', traces_file, traces_file) traces_pathfile = TRIM(temp_path_in) // TRIM(traces_file) OPEN (UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2180 END IF CLOSE (21) !Allocate storage for one central-point uvec for each possible trace: ALLOCATE ( f_center_uvec(3, 0:9999) ) f_center_uvec = 0.0D0 ! whole list of uvecs !Re-read traces file, and memorize center-points (of those traces actually present): OPEN (UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') get_trace_center: DO READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT get_trace_center !check that this line begins with 'F' or 'f' ... IF (.NOT.((line(1:1) == 'F').OR.(line(1:1) == 'f'))) CYCLE get_trace_center trace_number_c4 = line(2:5) !strip away any leading zeros: IF (trace_number_c4(1:1) == '0') THEN trace_number_c4(1:1) = ' ' IF (trace_number_c4(2:2) == '0') THEN trace_number_c4(2:2) = ' ' IF (trace_number_c4(3:3) == '0') THEN trace_number_c4(3:3) = ' ' END IF END IF END IF READ (trace_number_c4, "(I4)") trace_number points_in_trace = 0 ! just initializing... tvec = 0.0D0 ! all 3 entries !Now read all (Elon, Nlat) points in this trace and average them: eating_points: DO READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT eating_points IF (line(1:1) == '*') THEN ! "*** end of line segment ***" IF (points_in_trace > 0) THEN CALL DMake_Uvec(tvec, uvec) f_center_uvec(1:3, trace_number) = uvec(1:3) ELSE ! trace ended with no points in it (rare) END IF CYCLE get_trace_center ELSE ! probably an ordinary line with 2 numbers--but, COULD be a dip_degrees, etc. ... READ (line, *, IOSTAT = ios) Elon, Nlat IF (ios == 0) THEN ! got a pair of coordinates: CALL DLonLat_2_Uvec(Elon, Nlat, uvec) !add to accumulator vector... tvec(1:3) = tvec(1:3) + uvec(1:3) points_in_trace = points_in_trace + 1 END IF END IF END DO eating_points END DO get_trace_center CLOSE (21) ! Done with the f___.DIG file. 2181 WRITE (*, *) WRITE (*, "(' Now, provide a tab-delimited .TXT version of your F_PRIME.XLSX file,')") WRITE (*, "(' (with all header lines removed)')") WRITE (*, "(' from which editor''s choices of initiation and termination ages may be read.')") tabbed_file = "F_PRIME_PB20160725_WUS-only_extract.txt" CALL DPrompt_for_String('Name of this tab-delimited .TXT file? ', tabbed_file, tabbed_file) tabbed_pathfile = TRIM(temp_path_in) // TRIM(tabbed_file) OPEN (UNIT = 21, FILE = tabbed_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2181 END IF 2182 WRITE (*, *) WRITE (*, "(' Sense of offsets to be plotted on this map:')") WRITE (*, "(' 1: D (Detachment)')") WRITE (*, "(' 2: L (Left-lateral)')") WRITE (*, "(' 3: N (Normal)')") WRITE (*, "(' 4: P (thrust Plate or naPPe')") WRITE (*, "(' 5: R (Right-lateral)')") WRITE (*, "(' 6: T (Thrust)')") WRITE (*, "(' ---------------------------------------------')") sense_int = 0 CALL DPrompt_for_Integer('Choose one integer index from this table:', sense_int, sense_int) IF ((sense_int < 1).OR.(sense_int > 6)) THEN WRITE (*, "(' ERROR: Integer selection was out-of-range. Try again...')") CALL Pause() GO TO 2182 END IF 2183 WRITE (*, *) WRITE (*, "(' Which age limit is to be plotted on this map:')") WRITE (*, "(' 1: Initiation (greater age)')") WRITE (*, "(' 2: Termination (lesser age; may be 0)')") WRITE (*, "(' ---------------------------------------------')") begin_or_end_int = 0 CALL DPrompt_for_Integer('Choose one integer index from this table:', begin_or_end_int, begin_or_end_int) IF ((begin_or_end_int < 1).OR.(begin_or_end_int > 2)) THEN WRITE (*, "(' ERROR: Integer selection was out-of-range. Try again...')") CALL Pause() GO TO 2183 END IF IF (begin_or_end_int == 1) THEN c78 = "Initiation ages (in Ma) of fault offsets of sense" ELSE c78 = "Termination ages (in Ma) of fault offsets of sense" END IF IF (sense_int == 1) THEN c78 = TRIM(c78) // ' D' ELSE IF (sense_int == 2) THEN c78 = TRIM(c78) // ' L' ELSE IF (sense_int == 3) THEN c78 = TRIM(c78) // ' N' ELSE IF (sense_int == 4) THEN c78 = TRIM(c78) // ' P' ELSE IF (sense_int == 5) THEN c78 = TRIM(c78) // ' R' ELSE IF (sense_int == 6) THEN c78 = TRIM(c78) // ' T' END IF CALL Add_Title(c78) CALL Add_Title(tabbed_file) CALL DBegin_Group scanning_tabbed_lines: DO READ (21, "(A)", IOSTAT = ios) line132 IF (ios /= 0) EXIT scanning_tabbed_lines !Reject any line that doesn't start with 'F' or 'f' ... IF (.NOT.((line132(1:1) == 'F').OR.(line132(1:1) == 'f'))) CYCLE scanning_tabbed_lines !analyze line for tab-locations: tab_bytes = 0 ! whole vector in INTs number_of_tabs = 0 last_byte = LEN_TRIM(line132) ! no more than 132 DO i = 1, last_byte IF (line132(i:i) == tab) THEN number_of_tabs = number_of_tabs + 1 tab_bytes(number_of_tabs) = i END IF END DO !Reject any line that doesn't have at least 6 tabs, and its first tab in byte 7 ... IF ((number_of_tabs < 6).OR.(tab_bytes(1) /= 7)) CYCLE scanning_tabbed_lines !NOW that we are confident we have an editor's summary-line, extract offset sense: offset_c1 = line132(6:6) IF (sense_int == 1) THEN plot_this = (offset_c1 == 'D').OR.(offset_c1 == 'd') ELSE IF (sense_int == 2) THEN plot_this = (offset_c1 == 'L').OR.(offset_c1 == 'l') ELSE IF (sense_int == 3) THEN plot_this = (offset_c1 == 'N').OR.(offset_c1 == 'n') ELSE IF (sense_int == 4) THEN plot_this = (offset_c1 == 'P').OR.(offset_c1 == 'p') ELSE IF (sense_int == 5) THEN plot_this = (offset_c1 == 'R').OR.(offset_c1 == 'r') ELSE IF (sense_int == 6) THEN plot_this = (offset_c1 == 'T').OR.(offset_c1 == 't') END IF IF (plot_this) THEN IF (begin_or_end_int == 1) THEN ! initiation j1 = tab_bytes(4) + 1 j2 = tab_bytes(5) - 1 ELSE ! termination j1 = tab_bytes(5) + 1 j2 = tab_bytes(6) - 1 END IF age_in_Ma_text = line132(j1:j2) READ (age_in_Ma_text, * , IOSTAT = ios) age_in_Ma_real IF (ios /= 0) CYCLE scanning_tabbed_lines !Try to get f_center_uvec for this trace: trace_number_c4 = line132(2:5) !strip away any leading zeros: IF (trace_number_c4(1:1) == '0') THEN trace_number_c4(1:1) = ' ' IF (trace_number_c4(2:2) == '0') THEN trace_number_c4(2:2) = ' ' IF (trace_number_c4(3:3) == '0') THEN trace_number_c4(3:3) = ' ' END IF END IF END IF READ (trace_number_c4, * , IOSTAT = ios) trace_index ! INT IF (ios /= 0) CYCLE scanning_tabbed_lines uvec(1:3) = f_center_uvec(1:3, trace_index) IF ((uvec(1) /= 0.0D0).OR.(uvec(2) /= 0.0D0).OR.(uvec(3) /= 0.0D0)) THEN ! not a zero (invalid) uvec !CALL DBegin_Group ! local group allows colored dot and its text label to be dragged CALL DL5_Text (uvec = uvec, angle_radians = 0.0D0, from_east = .FALSE., & & font_points = 16, lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = TRIM(age_in_Ma_text)) !CALL DEnd_Group ELSE WRITE (*, "(' WARNING: No digitized trace was found for F', A4)") trace_number_c4 END IF END IF ! plot_this END DO scanning_tabbed_lines CALL DEnd_Group CLOSE (21) CALL BEEPQQ (frequency = 440, duration = 250) CASE (19) ! fault heave rates (detailed per-segment view) 2190 temp_path_in = path_in CALL DPrompt_for_String('Which .SHR (Segment Heave Rate) file from Restore4+ should be plotted?', SHR_file, SHR_file) SHR_pathfile = TRIM(temp_path_in)//TRIM(SHR_file) OPEN(UNIT = 21, FILE = SHR_pathfile, STATUS = 'OLD', IOSTAT = ios) IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21, IOSTAT = ios) ! (CLOSE may not succeed, if never OPENed.) CALL Pause() GO TO 2190 END IF !count the segments (and duplicate segments, for oblique-slip faults), to dimension arrays segments_in_SHR = 0 seg_ticking: DO READ (21, *, IOSTAT = ios) hr_in_mmpa IF (ios == -1) EXIT seg_ticking ! EOF IF (hr_in_mmpa < 0.05D0) EXIT seg_ticking ! because current convention is that only 0.1 mm/a and higher should appear here segments_in_SHR = segments_in_SHR + 1 END DO seg_ticking CLOSE (21) !allocate storage for all data in the .SHR file (so mini-lines can be sorted by rate/width): ALLOCATE ( SHR_rate_mmpa(segments_in_SHR) ) ALLOCATE ( SHR_c1(segments_in_SHR) ) ALLOCATE ( SHR_ELon1(segments_in_SHR) ) ALLOCATE ( SHR_NLat1(segments_in_SHR) ) ALLOCATE ( SHR_ELon2(segments_in_SHR) ) ALLOCATE ( SHR_NLat2(segments_in_SHR) ) !OPEN SHR file again, READ again, and memorize all contents: OPEN(UNIT = 21, FILE = SHR_pathfile, STATUS = 'OLD', IOSTAT = ios) DO i = 1, segments_in_SHR READ (21, "(F7.1, 1X, A1, F10.4, F9.4, F10.4, F9.4)") SHR_rate_mmpa(i), SHR_c1(i), SHR_ELon1(i), SHR_NLat1(i), SHR_ELon2(i), SHR_NLat2(i) END DO CLOSE (21) WRITE (*,"(' ')") CALL DPrompt_for_Real('What is the geologic time (age) for this plot, in Ma?', t_Ma, t_Ma) WRITE (*,"(' ')") WRITE (*,"(/' Here is the distribution of fault heave-rate components at this time (in mm/a):')") CALL Histogram (SHR_rate_mmpa, segments_in_SHR, .TRUE., maximum, minimum) IF (dv_scale_mma == 0.0D0) dv_scale_mma = maximum CALL DPrompt_for_Real('What (fairly high) heave rate should be shown in Explanation?', dv_scale_mma, dv_scale_mma) CALL DPrompt_for_Real('How many points wide should this be plotted?', dv_scale_points, dv_scale_points) WRITE (*,"(/' Working on fault heave rates (detailed view)....')") !Sort segments by rate/width, widest/fastest first, so that the narrower/slower component can be plotted on top, and be visible! DO i = 1, (segments_in_SHR - 1) DO j = (i + 1), segments_in_SHR IF (SHR_rate_mmpa(j) > SHR_rate_mmpa(i)) THEN ! SWAP THEM! !First, save all data #i in temporaries: t = SHR_rate_mmpa(i) c1 = SHR_c1(i) t1 = SHR_ELon1(i) t2 = SHR_NLat1(i) t3 = SHR_ELon2(i) t4 = SHR_NLat2(i) !Then, overwrite #i entries with faster/wider #j entries: SHR_rate_mmpa(i) = SHR_rate_mmpa(j) SHR_c1(i) = SHR_c1(j) SHR_ELon1(i) = SHR_ELon1(j) SHR_NLat1(i) = SHR_NLat1(j) SHR_ELon2(i) = SHR_ELon2(j) SHR_NLat2(i) = SHR_NLat2(j) !Finally, place the former #i entries in slot #j: SHR_rate_mmpa(j) = t SHR_c1(j) = c1 SHR_ELon1(j) = t1 SHR_NLat1(j) = t2 SHR_ELon2(j) = t3 SHR_NLat2(j) = t4 END IF ! swap is needed for this pair (#i and #j). END DO ! j = (i + 1), segments_in_SHR END DO ! i = 1, (segments_in_SHR - 1) CALL DBegin_Group DO i = 1, segments_in_SHR dip_byte = SHR_c1(i) IF (ai_using_color) THEN IF ((dip_byte == 'L').OR.(dip_byte == 'l')) THEN color_name = 'brown_____' ELSE IF ((dip_byte == 'T').OR.(dip_byte == 't')) THEN color_name = 'mid_blue__' ELSE IF ((dip_byte == 'P').OR.(dip_byte == 'p')) THEN color_name = 'dark_blue_' ELSE IF ((dip_byte == 'D').OR.(dip_byte == 'd')) THEN color_name = 'red_______' ELSE IF ((dip_byte == 'R').OR.(dip_byte == 'r')) THEN color_name = 'green_____' ELSE IF ((dip_byte == 'N').OR.(dip_byte == 'n')) THEN color_name = 'bronze____' ELSE ! any unexpected code color_name = 'foreground' END IF ELSE color_name = 'foreground' END IF ! ai_using_color or not CALL DSet_Stroke_Color (color_name) segment_width_points = dv_scale_points * SHR_rate_mmpa(i) / dv_scale_mma CALL DSet_Line_Style (width_points = segment_width_points, dashed = .FALSE.) CALL DNew_L67_Path (level = 7, r1 = SHR_ELon1(i), r2 = SHR_NLat1(i)) CALL DGreat_to_L67 (r1 = SHR_ELon2(i), r2 = SHR_NLat2(i)) CALL DEnd_L67_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE., retro = .FALSE.) END DO ! i = 1, segments_in_SHR CALL DEnd_Group DEALLOCATE ( SHR_NLat2, SHR_ELon2, SHR_NLat1, SHR_ELon1, SHR_c1, SHR_rate_mmpa ) CALL Chooser(bottom, right) IF (right) THEN !plot sample trace with width = dv_scale_points, !labelled with rate = dv_scale_mma CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points - 12.0D0 CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Fault heave') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'rates') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 36.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(per segment)') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 48.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(mm/a):') number8 = ADJUSTL(DASCII8(dv_scale_mma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 72.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)) CALL DSet_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DNew_L12_Path (1, x1_points + 6.0D0, y2_points - 75.0D0 - 0.39D0 * dv_scale_points) CALL DLine_to_L12 (x2_points - 6.0D0, y2_points - 75.0D0 - 0.39D0 * dv_scale_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 87.0D0 + dv_scale_points CALL Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, tick_points) CALL DEnd_Group ELSE IF (bottom) THEN !plot sample trace with width = dv_scale_points, !labelled with rate = dv_scale_mma CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 79.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Fault heave rates') CALL DL12_Text (level = 1, & & x_points = x1_points + 79.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(per segment, in mm/a):') number8 = ADJUSTL(DASCII8(dv_scale_mma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 79.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)) CALL DSet_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DNew_L12_Path (1, (x1_points + 79.0D0) - 30.0D0, 0.5D0*(y1_points + y2_points) - 15.0D0 - 0.39D0 * dv_scale_points) CALL DLine_to_L12 ((x1_points + 79.0D0) + 30.0D0, 0.5D0*(y1_points + y2_points) - 15.0D0 - 0.39D0 * dv_scale_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 158.0D0 CALL Fault_Key_Bottom (bottomlegend_gap_points, bottomlegend_used_points, tick_points) CALL DEnd_Group END IF ! bottom or right legend CALL Add_Title('Fault heave rates') IF (t_Ma > 0.0D0) THEN WRITE (c7, "(F7.2)") t_Ma IF (c7(5:7) == ".00") THEN c7(5:7) = " " ELSE IF (c7(7:7) == '0') THEN c7(7:7) = ' ' END IF CALL Add_Title(TRIM(ADJUSTL(c7))//' Ma ('//TRIM(Epoch(t_Ma))//')') ELSE CALL Add_Title('Neotectonic/Holocene') END IF CALL Add_Title(traces_file) CALL Add_Title(f_rst_file) WRITE (*,"('+Working on fault heave rates (detailed view)....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of fault heave rates (detailed per-segment view) overlay END SELECT ! (choice) = overlay type WRITE (*,"(' ')") suggest_logical = overlay_count < old_overlay_count CALL DPrompt_for_Logical('Do you want additional overlays?',suggest_logical,do_more_overlays) IF (do_more_overlays) GOTO 2000 END IF ! do overlay !-------------------------------------------------------------------- !Graticule of parallels and meridians CALL DSet_Line_Style (width_points = 1.0D0, dashed = .TRUE., on_points = 2.0D0, off_points = 9.0D0) CALL DSet_Stroke_Color (color_name = 'foreground') WRITE (*,"(' ')") CALL DPrompt_for_Integer('How many minutes apart are parallels and meridians?',minutes,minutes) CALL DGraticule (minutes) CALL DLonLat_Frame (minutes) !Titles at top of map IF (ai_toptitles_reserved) THEN WRITE (*,"(' ')") CALL DPrompt_for_Logical('Do you want to add a title to this map?',.TRUE.,add_titles) IF (add_titles) THEN CALL Add_Title(top_line_memo) CALL Add_Title(bottom_line_memo) 900 WRITE (*,"(/' ----------------------------------------------------------------------')") WRITE (*,"(' SOME SUGGESTED TITLE OPTIONS')") WRITE (*,"(' (culled from files opened for this map)')") WRITE (*,"(/' 0 :: ANYTHING YOU CHOOSE TO TYPE!')") DO i = 1, title_count WRITE (*,"(' ',I2,' :: ',A)") i, TRIM(titles(i)) END DO ! i = 1, title_count WRITE (*,"(' ----------------------------------------------------------------------')") CALL DPrompt_for_Integer('Which option do you want for the upper line?',0,title_choice) IF ((title_choice < 0).OR.(title_choice > title_count)) THEN WRITE (*,"(' ERROR: Please choose a number from the list.')") GOTO 900 END IF ! illegal choice IF (title_choice == 0) THEN CALL DPrompt_for_String('Enter top title (or one space for none)',' ',top_line) top_line_memo = top_line ELSE ! selection from list top_line = TRIM(titles(title_choice)) END IF CALL DPrompt_for_Integer('Which option do you want for the lower line?',0,title_choice) IF ((title_choice < 0).OR.(title_choice > title_count)) THEN WRITE (*,"(' ERROR: Please choose a number from the list.')") GOTO 900 END IF ! illegal choice IF (title_choice == 0) THEN CALL DPrompt_for_String('Enter sub-title (or one space for none)',' ',bottom_line) bottom_line_memo = bottom_line ELSE ! selection from list bottom_line = TRIM(titles(title_choice)) END IF CALL DTop_Titles (top_line, & & bottom_line) END IF ! add_titles END IF ! ai_toptitles_reserved CALL DEnd_Page !-------------------------SAVE CHOICES FOR NEXT TIME!---------------- OPEN (UNIT = 11, FILE = 'RetroMap4.ini') WRITE (11,"(A)") TRIM(path_in) WRITE (11,"(A)") TRIM(path_out) WRITE (11,"(I12,' = mosaic_count')") mosaic_count WRITE (11,"(10I4,' = mosaic_choice')") mosaic_choice ! whole array WRITE (11,"(A)") TRIM(polygons_basemap_file) WRITE (11,"(A)") TRIM(grd1_file) WRITE (11,"(A)") TRIM(grd2_file) WRITE (11,"(I12,' = bitmap_color_mode')") bitmap_color_mode WRITE (11,"(L12,' = shaded_relief')") shaded_relief WRITE (11,"(I12,' = bitmap_shading_mode')") bitmap_shading_mode WRITE (11,"(F12.3,' = intensity')") intensity WRITE (11,"(A12,' = grid_units')") TRIM(grid_units) WRITE (11,"(1P,E12.4,' = grid_interval')") grid_interval WRITE (11,"(1P,E12.4,' = grid_midvalue')") grid_midvalue WRITE (11,"(L12,' = grid_lowblue')") grid_lowblue WRITE (11,"(L12,' = skip_0_contour')") skip_0_contour WRITE (11,"(I12,' = element_scalar_method')") element_scalar_method WRITE (11,"(A)") TRIM(element_scalar_feg_file) WRITE (11,"(A12,' = element_scalar_units')") element_scalar_units WRITE (11,"(1P,E12.4,' = element_scalar_interval')") element_scalar_interval WRITE (11,"(1P,E12.4,' = element_scalar_midvalue')") element_scalar_midvalue WRITE (11,"(L12,' = element_scalar_lowblue')") element_scalar_lowblue WRITE (11,"(I12,' = element_scalar_zeromode')") element_scalar_zeromode WRITE (11,"(A)") TRIM(node_scalar_feg_file) WRITE (11,"(I12,' = node_scalar_method')") node_scalar_method WRITE (11,"(I12,' = node_scalar_choice')") node_scalar_choice WRITE (11,"(A12,' = node_scalar_units')") node_scalar_units WRITE (11,"(1P,E12.4,' = node_scalar_interval')") node_scalar_interval WRITE (11,"(1P,E12.4,' = node_scalar_midvalue')") node_scalar_midvalue WRITE (11,"(L12,' = node_scalar_lowblue')") node_scalar_lowblue WRITE (11,"(A)") TRIM(feg_file) WRITE (11,"(I12,' = velocity_method')") velocity_method WRITE (11,"(1P,E12.4,' = velocity_interval')") velocity_interval WRITE (11,"(1P,E12.4,' = velocity_midvalue')") velocity_midvalue WRITE (11,"(L12,' = velocity_lowblue')") velocity_lowblue WRITE (11,"(A)") TRIM(old_feg_file) WRITE (11,"(A)") TRIM(new_feg_file) WRITE (11,"(I12,' = distance_method')") distance_method WRITE (11,"(1P,E12.4,' = distance_km_interval')") distance_km_interval WRITE (11,"(1P,E12.4,' = distance_km_midvalue')") distance_km_midvalue WRITE (11,"(L12,' = distance_km_lowblue')") distance_km_lowblue WRITE (11,"(I12,' = rotation_method')") rotation_method WRITE (11,"(1P,E12.4,' = rotation_degrees_interval')") rotation_degrees_interval WRITE (11,"(1P,E12.4,' = rotation_degrees_midvalue')") rotation_degrees_midvalue WRITE (11,"(L12,' = rotation_degrees_lowblue')") rotation_degrees_lowblue WRITE (11,"(I12,' = ln_area_method')") ln_area_method WRITE (11,"(1P,E12.4,' = ln_area_interval')") ln_area_interval WRITE (11,"(1P,E12.4,' = ln_area_midvalue')") ln_area_midvalue WRITE (11,"(L12,' = ln_area_lowblue')") ln_area_lowblue !GPBend WRITE (11,"(I12,' = overlay_count')") overlay_count WRITE (11,"(10I4,' = overlay_choice')") overlay_choice ! whole array WRITE (11,"(A)") TRIM(lines_basemap_file) WRITE (11,"(A)") TRIM(traces_file) WRITE (11,"(F12.1,' = tick_points')") tick_points WRITE (11,"(F12.1,' = node_radius_points')") node_radius_points WRITE (11,"(A)") TRIM(vel_file) WRITE (11,"(F12.3,' = velocity_my')") velocity_my WRITE (11,"(I12,' = vector_thinner')") vector_thinner WRITE (11,"(A)") TRIM(f_rst_file) WRITE (11,"(F12.3,' = t_Ma')") t_Ma WRITE (11,"(F12.3,' = dv_scale_mma')") dv_scale_mma WRITE (11,"(F12.3,' = dv_scale_points')") dv_scale_points WRITE (11,"(F12.3,' = du_scale_km')") du_scale_km WRITE (11,"(F12.3,' = du_scale_points')") du_scale_points WRITE (11,"(A)") TRIM(p_rst_file) WRITE (11,"(F12.3,' = paleolatitude_factor')") paleolatitude_factor WRITE (11,"(A)") TRIM(s_rst_file) WRITE (11,"(F12.3,' = t1_Ma')") t1_Ma WRITE (11,"(F12.3,' = t2_Ma')") t2_Ma WRITE (11,"(F12.1,' = s1_size_points')") s1_size_points WRITE (11,"(A)") TRIM(stress_feg_file) WRITE (11,"(F12.1,' = s1h_interp_points')") s1h_interp_points WRITE (11,"(I12,' = stress_thinner')") stress_thinner WRITE (11,"(L12,' = only_stressed')") only_stressed WRITE (11,"(A)") TRIM(strain_feg_file) WRITE (11,"(1P,E12.4,' = R, radius of planet, in m')") R WRITE (11,"(I12,' = strainrate_mode012')") strainrate_mode012 WRITE (11,"(1P,E12.2,' = ref_e3_minus_e1_persec')") ref_e3_minus_e1_persec WRITE (11,"(F12.1,' = strainrate_diameter_points')") strainrate_diameter_points WRITE (11,"(I12,' = strain_thinner')") strain_thinner WRITE (11,"(1P,E12.2,' = ref_lns3_minus_lns1')") ref_lns3_minus_lns1 WRITE (11,"(F12.1,' = strain_diameter_points')") strain_diameter_points WRITE (11,"(A)") TRIM(c_rst_file) WRITE (11,"(1P,E12.2,' = model_limit_Ma')") model_limit_Ma WRITE (11,"(I12,' = minutes')") minutes WRITE (11,"(A)") TRIM(top_line_memo) WRITE (11,"(A)") TRIM(bottom_line_memo) CLOSE (11) CONTAINS ! member subprograms SUBROUTINE Add_Title(line) ! Adds "line" to global array "titles" and bumps global "title_count" ! if "line" is non-blank and also is novel. CHARACTER*(*), INTENT(IN) :: line CHARACTER*132 :: copy LOGICAL :: blank, novel INTEGER :: i blank = LEN_TRIM(line) <= 0 IF (.NOT.blank) THEN copy = ADJUSTL(TRIM(line)) novel = .TRUE. IF (title_count > 0) THEN DO i = 1, title_count IF (TRIM(copy) == TRIM(titles(i))) novel = .FALSE. END DO ! i = 1, title_count END IF ! have stored titles already IF (novel) THEN title_count = MIN(20, title_count + 1) titles(title_count) = TRIM(copy) END IF ! novel END IF ! not blank END SUBROUTINE Add_Title SUBROUTINE By_Ribbon(uvec1, uvec2, s, left, width_radians, uvec) !returns a single point on sphere (uvec) based on two !different points defining a directed line (uvec1 --> uvec2), !and internal (dimensionless) coordinate s, and !an orthogonal left-right offset of "left" !(in steps of width_radians) IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: uvec1, uvec2 REAL*8, INTENT(IN) :: s, left, width_radians REAL*8, DIMENSION(3), INTENT(OUT) :: uvec REAL*8 :: forward_azimuth, left_azimuth, right_azimuth REAL*8, DIMENSION(3) :: inline_uvec, omega_uvec CALL DGreatCircle_Point (from_uvec = uvec1, to_uvec = uvec2, s = s, & ! inputs & point_uvec = inline_uvec, azimuth_radians = forward_azimuth) ! outputs IF (left >= 0.0D0) THEN left_azimuth = forward_azimuth - Pi_over_2 CALL DTurn_To (azimuth_radians = left_azimuth, & & base_uvec = inline_uvec, & & far_radians = left * width_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec) ELSE right_azimuth = forward_azimuth + Pi_over_2 CALL DTurn_To (azimuth_radians = right_azimuth, & & base_uvec = inline_uvec, & & far_radians = -left * width_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec) END IF END SUBROUTINE By_Ribbon SUBROUTINE Chooser(bottom, right) ! Decides whether there is more margin space at "bottom" or "right". ! Will return both = F if NOT (ai_bottomlegend_reserved OR ai_rightlegend_reserved). ! Refers to RetroMap4 global variables: bottomlegend_used_points, rightlegend_used_points. LOGICAL, INTENT(out) :: bottom, right REAL*8 :: bottomlegend_free_points, rightlegend_free_points, & & x1_points, x2_points, y1_points, y2_points bottom = ai_bottomlegend_reserved right = ai_rightlegend_reserved IF (bottom.AND.right) THEN ! must choose one CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) bottomlegend_free_points = x2_points - x1_points - bottomlegend_used_points CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) rightlegend_free_points = y2_points - y1_points - rightlegend_used_points IF (rightlegend_free_points >= bottomlegend_free_points) THEN right = .TRUE. bottom = .FALSE. ELSE right = .FALSE. bottom = .TRUE. END IF END IF ! choice is needed END SUBROUTINE Chooser SUBROUTINE E_rate(R, l_, G, dG, theta_, vw, eps_dot) ! evaluate strain-rate REAL*8, INTENT(IN) :: R ! radius of planet, in m INTEGER, INTENT(IN) :: l_ ! element number REAL*8, DIMENSION(3,2,2) :: G ! nodal functions @ selected point REAL*8, DIMENSION(3,2,2,2):: dG ! derivitives of nodal functions REAL*8, INTENT(IN) :: theta_ ! colatitude, radians REAL*8, DIMENSION(:), INTENT(IN) :: vw REAL*8, DIMENSION(3), INTENT(OUT) :: eps_dot INTEGER :: iv, iw, j REAL*8 :: cott, csct, prefix eps_dot = 0.0D0 ! (1..3) cott = 1.0D0 / DTAN(theta_) csct = 1.0D0 / DSIN(theta_) prefix = 1.0D0 / R DO j = 1, 3 iv = 2 * nodes(j, l_) - 1 ! global index array iw = iv + 1 ! epsilon_dot_sub_theta_theta eps_dot(1) = eps_dot(1) + & & vw(iv) * prefix * dG(j,1,1,1) + & & vw(iw) * prefix * dG(j,2,1,1) ! epsilon_dot_sub_theta_phi eps_dot(2) = eps_dot(2) + & & vw(iv) * prefix * 0.5D0 * (csct * dG(j,1,1,2) + dG(j,1,2,1) - cott * G(j,1,2)) + & & vw(iw) * prefix * 0.5D0 * (csct * dG(j,2,1,2) + dG(j,2,2,1) - cott * G(j,2,2)) ! epsilon_dot_sub_phi_phi eps_dot(3) = eps_dot(3) + & & vw(iv) * prefix * (csct * dG(j,1,2,2) + cott * G(j,1,1)) + & & vw(iw) * prefix * (csct * dG(j,2,2,2) + cott * G(j,2,1)) END DO ! 3 local nodes END SUBROUTINE E_rate CHARACTER*40 FUNCTION Epoch (t_Ma) ! Selects the name of the epoch containing t_Ma before present ! per ISC 2010 geologic time scale (thru beginning of Late/Upper Cretaceous). IMPLICIT NONE REAL*8, INTENT(IN) :: t_Ma ! age, in millions of years INTEGER, PARAMETER :: ntime = 21 CHARACTER*40, DIMENSION(ntime) :: epoch_name INTEGER :: i REAL*8, DIMENSION(ntime) :: ttop DATA epoch_name/'Holocene ',& & 'Pleistocene ',& & 'Late Pliocene ',& & 'Early Pliocene ',& & 'Late Miocene ',& & 'Middle Miocene ',& & 'Early Miocene ',& & 'Late Oligocene ',& & 'Early Oligocene ',& & 'Late Eocene ',& & 'Middle Eocene ',& & 'Early Eocene ',& & 'Late Paleocene ',& & 'Middle Paleocene ',& & 'Early Paleocene ',& & 'Late Cretaceous: Maastrichtian ',& & 'Late Cretaceous: Campanian ',& & 'Late Cretaceous: Santonian ',& & 'Late Cretaceous: Coniacian ',& & 'Late Cretaceous: Turonian ',& & 'Late Cretaceous: Cenomanian '/ DATA ttop/ 0.0117D0, 2.588D0, 3.6D0, 5.332D0, 11.608D0, 15.97D0, & & 23.03D0, 28.4D0, 33.9D0, 37.2D0, 48.6D0, 55.8D0, & & 58.7D0, 61.1D0, 65.5D0, & & 70.6D0, 83.5D0, 85.8D0, 88.6D0, 93.6D0, 99.6D0 / IF (ABS(t_Ma) < 0.001D0) THEN Epoch = 'Present' ELSE IF (t_Ma < 0.0D0) THEN Epoch = 'Future' ELSE IF (t_Ma > ttop(ntime)) THEN Epoch = '?' ELSE DO i = 1, ntime IF (t_Ma <= ttop(i)) THEN Epoch = epoch_name(i) RETURN END IF END DO END IF END FUNCTION Epoch SUBROUTINE Fault_Key_Bottom (bottomlegend_gap_points, bottomlegend_used_points, tick_points) ! Plots 6 sample fault traces in bottom legend, ! in color (if ai_using_color) or b/w, with tick size tick_points; ! then adds to bottomlegend_used_points to record size of block. ! Note that these 6 samples are not grouped; you may wish to do ! this externally. IMPLICIT NONE REAL*8, INTENT(INOUT) :: bottomlegend_used_points REAL*8, INTENT(IN) :: bottomlegend_gap_points, tick_points INTEGER :: fp = 12 ! font points REAL*8 :: x1_points, x2_points, xc, xl, xr, & & y1, y1_points, y2, y2_points, y3 IF (.NOT.ai_bottomlegend_reserved) THEN WRITE (*,"(' Error: Fault_Key_Bottom requires ai_bottomlegend_reserved = T')") CALL DTraceback END IF CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) !center of first block: xc = x1_points + bottomlegend_used_points + bottomlegend_gap_points + 36.0D0 !left and right limits of fault traces xl = xc - 22.0D0 xr = xc + 22.0D0 !baselines of 3 lines of text/fault trace: y3 = y1_points + MAX(2.0D0, tick_points) y2 = y3 + MAX(1.0D0*fp, 0.4D0*fp + tick_points) y1 = y2 + fp CALL DSet_Stroke_Color ('foreground') ! will remain, if .NOT. ai_using_color ! thrust plate (P): dark_blue_, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xc, y_points = y1, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Low-angle') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'thrust plate:') CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('dark_blue_') CALL DSet_Fill_or_Pattern (.FALSE., 'dark_blue_') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'P', size_points = tick_points, offset_points = 0.5D0) ! high-angle thrust (T): mid_blue__, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') xc = xc + 72.0D0 xl = xc - 22.0D0 xr = xc + 22.0D0 CALL DL12_Text (level = 1, x_points = xc, y_points = y1, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'High-angle') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'thrust:') CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('mid_blue__') CALL DSet_Fill_or_Pattern (.FALSE., 'mid_blue__') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'T', size_points = tick_points, offset_points = 0.5D0) ! dextral (R): green_____, xc = xc + 72.0D0 xl = xc - 22.0D0 xr = xc + 22.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Dextral:') CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'R', size_points = tick_points, offset_points = 0.5D0) ! sinistral (L): brown_____, xc = xc + 72.0D0 xl = xc - 22.0D0 xr = xc + 22.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Sinistral:') CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('brown_____') CALL DSet_Fill_or_Pattern (.FALSE., 'brown_____') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'L', size_points = tick_points, offset_points = 0.5D0) ! high-angle Normal (N): bronze____, xc = xc + 72.0D0 xl = xc - 22.0D0 xr = xc + 22.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xc, y_points = y1, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'High-angle') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'normal:') CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('bronze____') CALL DSet_Fill_or_Pattern (.FALSE., 'bronze____') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'N', size_points = tick_points, offset_points = 0.5D0) ! low-angle Detachment (D): red_______, xc = xc + 72.0D0 xl = xc - 22.0D0 xr = xc + 22.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xc, y_points = y1, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Low-angle') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'normal:') CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'D', size_points = tick_points, offset_points = 0.5D0) ! wrap-up: adjust bottomlegend_used_points bottomlegend_used_points = bottomlegend_used_points + 420.0D0 END SUBROUTINE Fault_Key_Bottom SUBROUTINE Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, tick_points) ! Plots 6 sample fault traces in right legend, ! in color (if ai_using_color) or b/w, with tick size tick_points; ! then adds to rightlegend_used_points to record size of block. ! Note that these 6 samples are not grouped; you may wish to do ! this externally. IMPLICIT NONE REAL*8, INTENT(INOUT) :: rightlegend_used_points REAL*8, INTENT(IN) :: rightlegend_gap_points, tick_points INTEGER :: fp = 12 ! font points REAL*8 :: x1_points, x2_points, xc, xl, xr, y1_points, y2_points, yc IF (.NOT.ai_rightlegend_reserved) THEN WRITE (*,"(' Error: Fault_Key_Right requires ai_rightlegend_reserved = T')") CALL DTraceback END IF CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) yc = y2_points - rightlegend_used_points - rightlegend_gap_points xc = (x1_points + x2_points) / 2.0D0 xl = 0.8D0*x1_points + 0.2D0*x2_points xr = 0.2D0*x1_points + 0.8D0*x2_points CALL DSet_Stroke_Color ('foreground') ! will remain, if .NOT. ai_using_color ! thrust plate (P): dark_blue_, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - 0.4D0*fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Low-angle') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'thrust plate:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('dark_blue_') CALL DSet_Fill_or_Pattern (.FALSE., 'dark_blue_') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'P', size_points = tick_points, offset_points = 0.5D0) ! high-angle thrust (T): mid_blue__, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'High-angle') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'thrust:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('mid_blue__') CALL DSet_Fill_or_Pattern (.FALSE., 'mid_blue__') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'T', size_points = tick_points, offset_points = 0.5D0) ! dextral (R): green_____, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Dextral:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'R', size_points = tick_points, offset_points = 0.5D0) yc = yc - tick_points ! sinistral (L): brown_____, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Sinistral:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('brown_____') CALL DSet_Fill_or_Pattern (.FALSE., 'brown_____') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'L', size_points = tick_points, offset_points = 0.5D0) yc = yc - tick_points ! high-angle Normal (N): bronze____, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'High-angle') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'normal:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('bronze____') CALL DSet_Fill_or_Pattern (.FALSE., 'bronze____') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'N', size_points = tick_points, offset_points = 0.5D0) ! low-angle Detachment (D): red_______, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Low-angle') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.0D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'normal:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi / 2.0D0, & & style_byte = 'D', size_points = tick_points, offset_points = 0.5D0) ! wrap-up: adjust rightlegend_used_points rightlegend_used_points = y2_points - yc + 0.5D0 END SUBROUTINE Fault_Key_Right SUBROUTINE Fault_Traces (trace_choice, & ! NOTE: following parameters only needed for trace_choice >0: & width_array, dw_scale_amount, dw_scale_points, sense) ! optional parameters ! Draws fault traces on an open page, in 3 groups: ! (1) dip ticks (allowing for deletion; be warned that changes of color ! and/or pen width are not practical due to the mixture ! of stroked-but-unfilled with filled-but-unstroked kinds; ! (2) traces (allowing for width change if trace_choice = 1, ! or, you can try shadowing in either case); ! (3) text labels. ! Different variants are plotted according to "trace_choice" = ! 0 :: plot all traces with equal width, annotate with trace ID number. ! In this case, slip sense is from byte in f.dig. ! 1 :: plot traces with width proportional to "width_array"; ! scaled using parameters "dw_scale_amount" and "dw_scale_points"; ! annotate with value (rounded to two significant digits IFF <100). ! In this case, slip sense is from array "sense". ! The following variables must be pre-declared, and values ! defined, in the calling program: ! CHARACTER*(*) :: traces_pathfile ! [path\]name of F.DIG file. ! REAL*8 :: tick_points ! desired size of dip ticks, in points ! LOGICAL :: ai_using_color ! from Adobe_Illustrator module data. ! REAL*8 :: mp_radius_meters, mp_scale_denominator ! from Map_Projections module data. IMPLICIT NONE INTEGER, INTENT(IN) :: trace_choice REAL*8, DIMENSION(:), INTENT(IN), OPTIONAL :: width_array REAL*8, INTENT(IN), OPTIONAL :: dw_scale_points, dw_scale_amount CHARACTER*1, DIMENSION(:), INTENT(IN), OPTIONAL :: sense CHARACTER*1 :: dip_byte, f_byte, one_byte CHARACTER*10 :: color_name, label CHARACTER*80 :: line INTEGER :: count, fault_number, & & i, i1, i2, internal_ios, ios, longest, nsteps LOGICAL :: plotting REAL*8 :: angle, dip_azimuth_radians, goal_radians, & & lat, lon, lr_fraction, nudge_radians, offset_points, & & r1, r2, step_radians, & & trace_points, trace_radians, ud_fraction, width, & & x1_meters, x2_meters, x1_points, x2_points, & & y1_meters, y2_meters, y1_points, y2_points REAL*8, DIMENSION(3) :: tvec, uvec1, uvec2, uvec3 REAL*8, DIMENSION(:,:), ALLOCATABLE :: one_trace !Read through and determine length of longest trace OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') longest = 0 count = 0 DO READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, *, IOSTAT = internal_ios) lon, lat IF (internal_ios == 0) THEN ! read lon, lat OK count = count + 1 longest = MAX(longest,count) ELSE ! encountered ***END or title lines count = 0 END IF END DO CLOSE (21) ALLOCATE ( one_trace(2,longest) ) ! First group will have dip ticks only. OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') CALL DBegin_Group ! group of all dip ticks count = 0 DO ! reading lines of traces file READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, "(A1,I4,A1)", IOSTAT = internal_ios) f_byte, i, one_byte IF ((internal_ios == 0).AND.((f_byte == 'F').OR.(f_byte == 'f'))) THEN fault_number = i IF (trace_choice == 0) THEN dip_byte = one_byte ELSE dip_byte = sense(i) ! may have reversed! END IF SELECT CASE (trace_choice) CASE (0) plotting = .TRUE. CASE (1) width = width_array(fault_number) * dw_scale_points / dw_scale_amount plotting = (width >= 0.1D0) ! to avoid orphan dip-ticks after trace dissapears in slide/print! END SELECT ELSE ! line was not a title BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, *, IOSTAT = internal_ios) lon, lat IF (internal_ios == 0) THEN ! read lon, lat OK count = count + 1 one_trace(1,count) = lon one_trace(2,count) = lat ELSE ! encountered ***END OF SEGMENT***; ! finished reading a trace IF (plotting.AND.(count > 1)) THEN ! got a trace to plot!!! SELECT CASE (trace_choice) CASE (0) ! constant width offset_points = 0.8D0 ! 40% of 2.0 points CASE (1) ! width prop. to trace_mma(fault_number) offset_points = 0.5D0 * width_array(fault_number) * dw_scale_points / dw_scale_amount END SELECT IF (ai_using_color) THEN IF ((dip_byte == 'L').OR.(dip_byte == 'l')) THEN color_name = 'brown_____' ELSE IF ((dip_byte == 'T').OR.(dip_byte == 't')) THEN color_name = 'mid_blue__' ELSE IF ((dip_byte == 'P').OR.(dip_byte == 'p')) THEN color_name = 'dark_blue_' ELSE IF ((dip_byte == 'D').OR.(dip_byte == 'd')) THEN color_name = 'red_______' ELSE IF ((dip_byte == 'R').OR.(dip_byte == 'r')) THEN color_name = 'green_____' ELSE IF ((dip_byte == 'N').OR.(dip_byte == 'n')) THEN color_name = 'bronze____' ELSE ! any unexpected code color_name = 'foreground' END IF CALL DSet_Stroke_Color (color_name) ELSE color_name = 'foreground' CALL DSet_Stroke_Color (color_name) END IF ! ai_using_color or not trace_radians = 0.0D0 CALL DLonLat_2_Uvec(one_trace(1,1),one_trace(2,1),uvec1) DO i = 2, count CALL DLonLat_2_Uvec(one_trace(1,i),one_trace(2,i),uvec2) tvec = uvec2 - uvec1 trace_radians = trace_radians + DLength(tvec) uvec1 = uvec2 ! preparing to loop END DO trace_points = trace_radians * (mp_radius_meters/mp_scale_denominator) * 39.37D0 * 72.0D0 IF ((trace_points >= (2.0D0 * tick_points)).AND.(tick_points > 0.0D0)) THEN ! long enough trace to plot a dip tick on CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = color_name) nsteps = MAX(2, NINT(trace_points/(4.D0*tick_points))) step_radians = 1.001D0 * trace_radians / nsteps CALL DLonLat_2_Uvec(one_trace(1,1),one_trace(2,1),uvec1) trace_radians = 0.0D0 goal_radians = step_radians DO i = 2, count CALL DLonLat_2_Uvec(one_trace(1,i),one_trace(2,i),uvec2) tvec = uvec2 - uvec1 nudge_radians = DLength(tvec) trace_radians = trace_radians + nudge_radians IF (trace_radians > goal_radians) THEN tvec = 0.5D0*(uvec1 + uvec2) !place mid-segment to reduce chance of misalignment CALL DMake_Uvec(tvec, uvec3) dip_azimuth_radians = DRelative_Compass(uvec1,uvec2) - Pi_over_2 CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = dip_azimuth_radians, & & style_byte = dip_byte, & & size_points = tick_points, & & offset_points = offset_points) goal_radians = goal_radians + step_radians END IF ! plotted a tick uvec1 = uvec2 ! preparing to loop END DO END IF ! long enough trace to plot on END IF ! got a trace to plot!!! count = 0 END IF ! hit end of segment END IF ! line was not a title END DO ! reading line of traces file CALL DEnd_Group ! of all dip ticks CLOSE(21) ! Second group will have fault traces only. OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') CALL DBegin_Group ! group of all fault traces count = 0 DO ! reading lines of traces file READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, "(A1,I4,A1)", IOSTAT = internal_ios) f_byte, i, one_byte IF ((internal_ios == 0).AND.((f_byte == 'F').OR.(f_byte == 'f'))) THEN fault_number = i IF (trace_choice == 0) THEN dip_byte = one_byte ELSE dip_byte = sense(i) END IF SELECT CASE (trace_choice) CASE (0) plotting = .TRUE. CASE (1) plotting = (width_array(fault_number) > 0.0D0) END SELECT ELSE ! line was not a title BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, *, IOSTAT = internal_ios) lon, lat IF (internal_ios == 0) THEN ! read lon, lat OK count = count + 1 one_trace(1,count) = lon one_trace(2,count) = lat ELSE ! encountered ***END OF SEGMENT***; ! finished reading a trace IF (plotting.AND.(count > 1)) THEN ! got a trace to plot!!! SELECT CASE (trace_choice) CASE (0) ! constant width width = 1.5D0 ! points CASE (1) ! width prop. to trace_mma(fault_number) width = width_array(fault_number) * dw_scale_points / dw_scale_amount END SELECT IF (ai_using_color) THEN IF ((dip_byte == 'L').OR.(dip_byte == 'l')) THEN color_name = 'brown_____' ELSE IF ((dip_byte == 'T').OR.(dip_byte == 't')) THEN color_name = 'mid_blue__' ELSE IF ((dip_byte == 'P').OR.(dip_byte == 'p')) THEN color_name = 'dark_blue_' ELSE IF ((dip_byte == 'D').OR.(dip_byte == 'd')) THEN color_name = 'red_______' ELSE IF ((dip_byte == 'R').OR.(dip_byte == 'r')) THEN color_name = 'green_____' ELSE IF ((dip_byte == 'N').OR.(dip_byte == 'n')) THEN color_name = 'bronze____' ELSE ! any unexpected code color_name = 'foreground' END IF CALL DSet_Stroke_Color (color_name) ELSE CALL DSet_Stroke_Color (color_name = 'foreground') END IF ! ai_using_color or not CALL DSet_Line_Style (width_points = width, dashed = .FALSE.) CALL DNew_L67_Path (7,one_trace(1,1),one_trace(2,1)) DO i = 2, count CALL DGreat_to_L67(one_trace(1,i),one_trace(2,i)) END DO CALL DEnd_L67_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! got a trace to plot!!! count = 0 END IF ! hit end of segment END IF ! line was not a title END DO ! reading line of traces file CALL DEnd_Group ! of fault traces CLOSE(21) ! Third group will have text labels. OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') CALL DBegin_Group ! group of text labels count = 0 DO ! reading lines of traces file READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, "(A1,I4,A1)", IOSTAT = internal_ios) f_byte, i, one_byte IF ((internal_ios == 0).AND.((f_byte == 'F').OR.(f_byte == 'f'))) THEN fault_number = i IF (trace_choice == 0) THEN dip_byte = one_byte ELSE dip_byte = sense(i) END IF SELECT CASE (trace_choice) CASE (0) plotting = .TRUE. CASE (1) width = width_array(fault_number) * dw_scale_points / dw_scale_amount plotting = (width >= 0.1D0) !to avoid orphan text after the trace dissapears in slide/print! END SELECT ELSE ! line was not a title BACKSPACE (21) READ (21, *, IOSTAT = internal_ios) lon, lat IF (internal_ios == 0) THEN ! read lon, lat OK count = count + 1 one_trace(1,count) = lon one_trace(2,count) = lat ELSE ! encountered ***END OF SEGMENT***; ! finished reading a trace IF (plotting.AND.(count > 1)) THEN ! got a trace to plot!!! CALL DLonLat_2_Uvec (one_trace(1,1),one_trace(2,1),uvec1) CALL DLonLat_2_Uvec (one_trace(1,count),one_trace(2,count),uvec2) tvec = uvec2 - uvec1 IF (DLength(tvec) > 0.0D0) THEN SELECT CASE (trace_choice) CASE (0) ! label with id number WRITE (label,"(I10)") fault_number label = ADJUSTL(label) r1 = one_trace(1,1) r2 = one_trace(2,1) angle = Pi_over_2 - DRelative_Compass (uvec1, uvec2) lr_fraction = 0.0D0 ud_fraction = 1.0D0 CALL DL67_Text (level = 7, & & r1 = r1, r2 = r2, & & angle_radians = angle, from_east = .TRUE., & & font_points = 6, & & lr_fraction = lr_fraction, ud_fraction = ud_fraction, & & text = TRIM(label)) CASE (1) ! label with mm/a (e.g., heave-rate) or with offset in km (e.g., goal or actual model heave): IF (width_array(fault_number) < 100.0D0) THEN ! round to only 2 significant digits; e.g., 99, 12, 1.9, 0.23 label = ADJUSTL(DASCII8(width_array(fault_number))) ELSE ! round to integer, allowing 3 or more significant digits; e.g., 237, 1234 !N.B. CHARACTER(10) :: label WRITE (label, "(I10)"), NINT(width_array(fault_number)) label = ADJUSTL(label) END IF offset_points = 0.5D0 * width_array(fault_number) * dw_scale_points / dw_scale_amount !because of the need for this offset, use level 2 text. i1 = DInt_Below(count/2.0D0) i2 = i1 + 1 CALL DLonLat_2_Uvec (one_trace(1,i1),one_trace(2,i1),uvec1) CALL DLonLat_2_Uvec (one_trace(1,i2),one_trace(2,i2),uvec2) CALL DProject (uvec = uvec1, x = x1_meters, y = y1_meters) CALL DProject (uvec = uvec2, x = x2_meters, y = y2_meters) CALL DMeters_2_Points (x1_meters,y1_meters, x1_points,y1_points) CALL DMeters_2_Points (x2_meters,y2_meters, x2_points,y2_points) ! angle is of text baseline, counterclockwise from right, radians angle = DATan2F((y1_points - y2_points),(x1_points - x2_points)) r1 = 0.5D0 * (x1_points + x2_points) - offset_points * DSIN(angle) r2 = 0.5D0 * (y1_points + y2_points) + offset_points * DCOS(angle) lr_fraction = 0.5D0 ud_fraction = -0.2D0 CALL DL12_Text (level = 2, & & x_points = r1, y_points = r2, & & angle_radians = angle, & & font_points = 8, & & lr_fraction = lr_fraction, ud_fraction = ud_fraction, & & text = TRIM(label)) END SELECT END IF ! trace has different 1st, last points END IF ! got a trace to plot!!! count = 0 END IF ! hit end of segment END IF ! line was not a title END DO ! reading line of traces file CALL DEnd_Group ! of text labels CLOSE(21) DEALLOCATE ( one_trace ) END SUBROUTINE Fault_Traces SUBROUTINE FE_Strain (numnod, old_node_uvec, new_node_uvec, & ! numel is same for both grids! & old_numel, old_nodes, & & new_numel, new_nodes, & & strained, strain_table) ! these outputs refer to new_ grid ! Computes strains and rotations of 3-node spherical-shell ! finite elements which have moved on a planet, ! using node positions from two finite element grid (.feg) ! files with (preferably) the same topology (or AT LEAST the same ! number of nodes, and SOME elements not redefined!) ! Derived from PROGRAM FEStrain.f90, which has more documentation. ! ------------------------------------------------------------------------------- USE MKL95_PRECISION USE MKL95_LAPACK, ONLY: geev ! Math Kernel Library, LAPACK portion: ! using only dgeev: complex eigenvectors and eigenvalues of any REAL*8 matrix. ! -------------------- *** {OR} *** --------------------------------------------- ! USE MSIMSL, ONLY: DEVCRG ! Microsoft version of International Mathematics Subroutine Library; ! using only DEVCRG: complex eigenvectors and eigenvalues of any REAL*8 matrix ! -------------------- *** {OR} *** --------------------------------------------- ! USE Numerical_Libraries, ONLY: DEVCRG ! Digital Visual Fortran version of International Mathematics Subroutine Library; ! using only DEVCRG: complex eigenvectors and eigenvalues of any REAL*8 matrix ! ------------------------------------------------------------------------------- IMPLICIT NONE INTEGER, INTENT(IN) :: numnod, old_numel, new_numel INTEGER, DIMENSION(:,:), INTENT(IN) :: old_nodes, new_nodes REAL*8, DIMENSION(:,:), INTENT(IN) :: old_node_uvec, new_node_uvec LOGICAL, DIMENSION(:), INTENT(OUT) :: strained ! could results be computed? REAL*8, DIMENSION(:,:), INTENT(OUT) :: strain_table REAL*8, DIMENSION(3) :: a ! temporary vector REAL*8 :: a0_, a1_ ! element areas REAL*8 :: angle ! see comment below REAL*8, DIMENSION(3) :: aperp ! perp. to sc_pole REAL*8 :: arc_radians ! temp., in rads REAL*8, DIMENSION(0:1,3) :: az_rad ! azimuths from center0 in rads REAL*8 :: azim ! temp., in rads cw from N REAL*8 :: azim1h ! see Glossary below REAL*8 :: azim2h ! see Glossary below REAL*8, DIMENSION(3) :: b ! temporary vector REAL*8, DIMENSION(3) :: bvec ! = scm * aperp REAL*8, DIMENSION(3) :: c ! temporary vector REAL*8, DIMENSION(3) :: center0, center1 ! element centers REAL*8 :: cott ! 1./TAN(theta) REAL*8 :: csct ! 1./SIN(theta) REAL*8 :: deg1h, deg2h ! e1h, e2h azimuths in deg. REAL*8, DIMENSION(3,2,2,2) :: dG ! derivitives of nodal functions REAL*8, PARAMETER :: deg_per_rad = 57.2957795130D0 REAL*8 :: dilat ! dilatation = a0_/a1_ - 1. REAL*8 :: diver ! divergence of displacement DOUBLE COMPLEX, DIMENSION(3) :: eigenvalues REAL*8, DIMENSION(3,3) :: eigenvectors INTEGER :: element ! see Glossary below REAL*8 :: epp REAL*8 :: eps1h ! see Glossary below REAL*8 :: eps2h ! see Glossary below REAL*8 :: epsrr ! see Glossary below REAL*8 :: equat REAL*8 :: etp REAL*8 :: ett REAL*8, DIMENSION(3) :: far ! from center to nodes REAL*8, DIMENSION(3,2,2) :: G ! nodal functions REAL*8 :: gc_lat ! see Glossary below REAL*8 :: gc_lon ! see Glossary below REAL*8, DIMENSION(3) :: gc_pole ! great circle pole REAL*8 :: gca ! great circle arc, rads REAL*8, DIMENSION(3,3) :: gcm ! rotation matrix for great circle REAL*8 :: half_R2 ! R**2/2. INTEGER :: i, j ! temporary INTEGER :: info ! return flag from CALL dgeev REAL*8 :: lat ! E. latitude in deg. REAL*8 :: lat_now ! see Glossary below REAL*8 :: lon ! E. longitude in deg. REAL*8 :: lon_now ! see Glossary below REAL*8, DIMENSION(3,3) :: lrm ! rotation matrix for vertical-axis REAL*8 :: moved ! see Glossary below INTEGER :: new_n1, new_n2, new_n3 ! defines element in new grid INTEGER :: old_i ! element in old grid, corresponding to i in new INTEGER :: old_n1, old_n2, old_n3 ! defines element in old grid REAL*8 :: R ! radius of planet, in m CHARACTER(80) :: results ! output filename REAL*8 :: rot ! addit. vert.-ax rot. mixed w strain REAL*8 :: sc_lat ! see Glossary below REAL*8 :: sc_lon ! see Glossary below REAL*8, DIMENSION(3) :: sc_pole ! pole of small circle REAL*8, DIMENSION(3,3) :: scm ! rotation matrix for small-circle REAL*8 :: shear ! radius of Mohr's circle REAL*8 :: spin ! final rotation, in rads ccw REAL*8 :: swing ! turn about small circle pole, rads REAL*8 :: swung ! see Glossary below REAL*8, DIMENSION(3) :: t ! temporary vector REAL*8 :: theta REAL*8 :: turn1, turn2, turn3 ! approx. rotation after gc move REAL*8 :: turned ! see Glossary below REAL*8, DIMENSION(3) :: uvec REAL*8, DIMENSION(3) :: v, w ! components of nodal displacement DOUBLE COMPLEX, DIMENSION(3,3) :: vl, vr ! left (not used) & right eigenvectors of matrix scm, as computed by dgeev. INTEGER :: which REAL*8, DIMENSION(100) :: work ! workspace vector needed during CALL dgeev REAL*8, DIMENSION(3) :: wr, wi ! output of dgeev; real & imaginary parts of eigenvalues of scm REAL*8, DIMENSION(3,3) :: xyzt ! 3 nodes, rotated !----------------------------------------------- strain_table = 0.0D0 ! whole array; in case .NOT.strained(i) all_elements: DO i = 1, new_numel ! results reported for new_ grid new_n1 = new_nodes(1, i) new_n2 = new_nodes(2, i) new_n3 = new_nodes(3, i) strained(i) = .FALSE. ! (until a matching element is found) find_mate: DO j = 1, old_numel old_n1 = old_nodes(1, j) old_n2 = old_nodes(2, j) old_n3 = old_nodes(3, j) IF ((old_n1 == new_n1).AND.(old_n2 == new_n2).AND.(old_n3 == new_n3)) THEN old_i = j strained(i) = .TRUE. ! (unless disproven below, by folding) EXIT find_mate END IF ! match found END DO find_mate ! j = 1, old_numel; looking for a match IF (.NOT.strained(i)) CYCLE all_elements ! compute element area, assuming unit sphere ! first, old grid: a = old_node_uvec(1:3, old_n2) - old_node_uvec(1:3, old_n1) b = old_node_uvec(1:3, old_n3) - old_node_uvec(1:3, old_n2) CALL DCross (a, b, c) t = old_node_uvec(1:3, old_n1) + old_node_uvec(1:3, old_n2) + old_node_uvec(1:3, old_n3) IF (DOT_PRODUCT(t, c) > 0.0D0) THEN a1_ = DMagnitude(c) * 0.5D0 ELSE strained(i) = .FALSE. CYCLE all_elements END IF ! then, new (present-day?) grid: a = new_node_uvec(1:3, new_n2) - new_node_uvec(1:3, new_n1) b = new_node_uvec(1:3, new_n3) - new_node_uvec(1:3, new_n2) CALL DCross (a, b, c) t = new_node_uvec(1:3, new_n1) + new_node_uvec(1:3, new_n2) + new_node_uvec(1:3, new_n3) IF (DOT_PRODUCT(t, c) > 0.0D0) THEN a0_ = DMagnitude(c) * 0.5D0 ELSE strained(i) = .FALSE. CYCLE all_elements END IF ! element center locations: CALL DMake_Uvec ((new_node_uvec(1:3, new_n1) + new_node_uvec(1:3, new_n2) + new_node_uvec(1:3, new_n3)) / 3.0D0, center0) CALL DMake_Uvec ((old_node_uvec(1:3, old_n1) + old_node_uvec(1:3, old_n2) + old_node_uvec(1:3, old_n3)) / 3.0D0, center1) ! great circle movement: CALL DCross (center1, center0, uvec) IF (DMagnitude(uvec) > 0.0D0) THEN CALL DMake_Uvec (uvec, gc_pole) gca = DArc (center1, center0) ELSE gca = 0.0D0 END IF ! nonzero movement gcm = Rot_matrix(gc_pole, gca) ! bring ancient element to present center xyzt(1:3, 1) = MATMUL ( gcm, old_node_uvec(1:3, old_n1) ) xyzt(1:3, 2) = MATMUL ( gcm, old_node_uvec(1:3, old_n2) ) xyzt(1:3, 3) = MATMUL ( gcm, old_node_uvec(1:3, old_n3) ) ! approximate rotation after great-circle translation: az_rad(0, 1) = DCompass(center0, new_node_uvec(1:3, new_n1)) az_rad(0, 2) = DCompass(center0, new_node_uvec(1:3, new_n2)) az_rad(0, 3) = DCompass(center0, new_node_uvec(1:3, new_n3)) az_rad(1, 1) = DCompass(center0, xyzt(1:3, 1)) az_rad(1, 2) = DCompass(center0, xyzt(1:3, 2)) az_rad(1, 3) = DCompass(center0, xyzt(1:3, 3)) turn1 = -( az_rad(0,1) - az_rad(1,1) ) turn2 = -( az_rad(0,2) - az_rad(1,2) ) turn2 = Same_cycle(turn2, turn1) turn3 = -( az_rad(0,3) - az_rad(1,3) ) turn3 = Same_cycle(turn3, turn1) far(1) = (DArc(center0, new_node_uvec(1:3,new_n1)) + & & DArc(center0, xyzt(1:3,1)) ) / 2.0D0 far(2) = (DArc(center0, new_node_uvec(1:3,new_n2)) + & & DArc(center0, xyzt(1:3,2)) ) / 2.0D0 far(3) = (DArc(center0, new_node_uvec(1:3,new_n3)) + & & DArc(center0, xyzt(1:3,3)) ) / 2.0D0 spin = ( far(1)*turn1 + far(2)*turn2 + far(3)*turn3 )/ & & ( far(1) + far(2) + far(3) ) lrm = Rot_matrix(center0, spin) ! turn ancient element about center0 to approximately match present one xyzt(1:3, 1) = MATMUL ( lrm, xyzt(1:3, 1) ) xyzt(1:3, 2) = MATMUL ( lrm, xyzt(1:3, 2) ) xyzt(1:3, 3) = MATMUL ( lrm, xyzt(1:3, 3) ) ! find small remaining displacement (mostly from strain) DO j = 1, 3 arc_radians = DArc ( xyzt(1:3, j), new_node_uvec(1:3, new_nodes(j, i)) ) IF (arc_radians > 0.0D0) THEN azim = DCompass ( xyzt(1:3,j), new_node_uvec(1:3, new_nodes(j, i)) ) ELSE azim = 0.0D0 END IF v(j) = -arc_radians * DCOS(azim) w(j) = +arc_radians * DSIN(azim) END DO ! compute strains and additional rotation from nodal functions and derivitives CALL Gjxy (i, xyzt(1:3,1), xyzt(1:3,2), xyzt(1:3,3), center0, G) CALL Del_Gjxy_del_thetaphi (i, xyzt(1:3,1), xyzt(1:3,2), xyzt(1:3,3), center0, dG) equat = DSQRT(center0(1)**2 + center0(2)**2) theta = DATAN2(equat, center0(3)) csct = 1.0D0 / DSIN(theta) cott = 1.0D0 / DTAN(theta) ett = 0.0D0 epp = 0.0D0 etp = 0.0D0 rot = 0.0D0 DO j = 1, 3 ! sum over 3 nodes in element ett = ett + v(j) * dG(j,1,1,1) + w(j) * dG(j,2,1,1) epp = epp + csct * (v(j) * dG(j,1,2,2) + w(j) * dG(j,2,2,2)) + & & cott * (v(j) * G(j,1,1) + w(j) * G(j,2,1)) etp = etp + 0.5D0 * ( csct * (v(j) * dG(j,1,1,2) + w(j) * dG(j,2,1,2)) + & & (v(j) * dG(j,1,2,1) + w(j) * dG(j,2,2,1)) - & & cott * (v(j) * G(j,1,2) + w(j) * G(j,2,2)) ) rot = rot + 0.5D0 * ( cott * (v(j) * G(j,1,2) + w(j) * G(j,2,2)) + & & (v(j) * dG(j,1,2,1) + w(j) * dG(j,2,2,1)) - & & csct * (v(j) * dG(j,1,1,2) + w(j) * dG(j,2,1,2)) ) END DO ! adjust rotation for any more that was found spin = spin + rot lrm = Rot_matrix (center0, spin) ! find small-circle rotation equivalent scm = MATMUL( lrm, gcm ) !--------------------------------------------------------------------------------------------------------------------- CALL dgeev ('N', 'V', 3, scm, 3, wr, wi, vl, 3, eigenvectors, 3, work, 100, info) ! from MKL (Math Kernel Library) section LAPACK (Linear Analysis Package), on topic "Nonsymmetric Eigenvproblems". ! Computes the eigenvalues and left and right eigenvectors of a general matrix. ! Usage: ! CALL dgeev (jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr, ldvr, work, lwork, info) ! Arguments: ! jobvl = 'N' (input) to show that left-eigenvectors should not be computed. ! jobvr = 'V' (input) to show that right-eigenvectors should be computed. ! n = 3 (input) = the order of the input matrix a. ! a = (input) 2-subscript REAL*8 array, with leading dimension lda, that contains the n-by-n matrix to be analyzed. ! lda = 3 (input) = leading DIMENSION of input array a ! wr, wi = (output) = REAL*8 vectors with the real and imaginary parts of the eigenvalues, respectively. ! vl = (output) REAL*8, DIMENSION(3, 3) matrix of left-eigenvectors of array a. ! ldv = 3 (input) = leading DIMENSION of array vl ! vr = (output) REAL*8, DIMENSION(3, 3) matrix of right-eigenvectors of array a. ! ldr = 3 (input) = leading DIMENSION of array vr ! work = (input) REAL*8 workspace vector of length lwork. ! lwork = 6 (input) = the dimension of the array work; at least 2*n = 6. ! info = (output) 0 for successful completion IF (info /= 0) THEN WRITE (*, "(' ERROR: info = ',I9,' after CALL dgeev in FE_Strain.')") info CALL DTraceback END IF !CAUTION: Already inside a DO loop with subscript 'i'! DO j = 1, 3 eigenvalues(j) = CMPLX(wr(j), wi(j), KIND = 8) END DO !--------------------- *** {OR} *** -------------------------------------------------------------------------------- !CALL DEVCRG (3, scm, 3, eigenvalues, eigenvectors, 3) ! from IMSL (International Mathematics Subroutine Library). ! Compute all of the eigenvalues and eigenvectors of a real matrix. ! Usage: ! CALL DEVCRG (N, A, LDA, EVAL, EVEC, LDEVEC) ! Arguments ! N = Order of the matrix. (Input) ! A = Floating-point (REAL*8) array containing the matrix. (Input) ! LDA = Leading dimension of A exactly as specified in the dimension statement of the calling program. (Input) ! EVAL = Complex*8 array of size N containing the eigenvalues of A in decreasing order of magnitude. (Output) ! EVEC = Complex*8 array containing the matrix of eigenvectors. (Output) ! The J-th eigenvector, corresponding to EVAL(J), is stored in the J-th column. Each vector is normalized to have ! Euclidean length of unity. ! LDEVEC = Leading dimension of EVEC exactly as specified in the dimension statement of the calling program. (Input) !--------------------------------------------------------------------------------------------------------------------- which = 0 DO j = 1, 3 IF ((CDABS(eigenvalues(j)) > 0.9999D0) .AND. (CDABS(eigenvalues(j)) < 1.0001D0)) THEN IF (ABS(DIMAG(eigenvalues(j))) < 0.0001D0) THEN which = j END IF END IF END DO IF (which == 0) THEN WRITE (*,"(' Error: No eigenvalue == 1.0000 for scm in element ',I6)") i CALL DTraceback END IF sc_pole(1) = eigenvectors(1, which) sc_pole(2) = eigenvectors(2, which) sc_pole(3) = eigenvectors(3, which) CALL DMake_Uvec (sc_pole, sc_pole) ! just for safety equat = DSQRT(sc_pole(1)**2 + sc_pole(2)**2) IF (equat > 0.0D0) THEN CALL DCross (sc_pole, (/ 0.0D0, 0.0D0, 1.0D0 /), uvec) CALL DMake_Uvec (uvec, aperp) ELSE aperp = (/ 1.0D0, 0.0D0, 0.0D0 /) END IF bvec = MATMUL ( scm, aperp ) CALL DCross (aperp, bvec, uvec) swing = DATAN2(DOT_PRODUCT(uvec, sc_pole), DOT_PRODUCT(aperp, bvec )) ! find principal strains diver = ett + epp shear = DSQRT(etp**2 + 0.25D0 * (ett - epp)**2) eps1h = 0.5D0 * diver - shear eps2h = 0.5D0 * diver + shear epsrr = -diver angle = 0.5D0 * DATAN2(-etp, (epp - ett) / 2.0D0) ! Note that internal variable angle is direction of eps1h ! measured counterclockwise from +x (+theta, or South). ! correct for additional rotation mixed with strain: angle = angle + rot ! define azimuths of principal axes azim1h = Pi - angle IF (azim1h < 0.) azim1h = azim1h + Pi IF (azim1h < 0.) azim1h = azim1h + Pi IF (azim1h >= Pi) azim1h = azim1h - Pi IF (azim1h >= Pi) azim1h = azim1h - Pi azim2h = azim1h + Pi_over_2 IF (azim2h < 0.0D0) azim2h = azim2h + Pi IF (azim2h < 0.0D0) azim2h = azim2h + Pi IF (azim2h >= Pi) azim2h = azim2h - Pi IF (azim2h >= Pi) azim2h = azim2h - Pi ! dilatation dilat = (a0_ / a1_) - 1.0D0 ! format for output element = i CALL DUvec_2_LonLat(center0, lon_now, lat_now) moved = deg_per_rad * gca CALL DUvec_2_LonLat(gc_pole, gc_lon, gc_lat) turned = deg_per_rad * Same_cycle(spin, 0.0D0) swung = deg_per_rad * swing CALL DUvec_2_LonLat(sc_pole, sc_lon, sc_lat) IF (swung < 0.0D0) THEN sc_lon = sc_lon + 180.0D0 IF (sc_lon > 180.0D0) sc_lon = sc_lon - 360.0D0 sc_lat = -sc_lat swung = -swung END IF deg1h = azim1h * deg_per_rad deg2h = azim2h * deg_per_rad strain_table( 1, i) = lon_now strain_table( 2, i) = lat_now strain_table( 3, i) = moved strain_table( 4, i) = gc_lon strain_table( 5, i) = gc_lat strain_table( 6, i) = turned strain_table( 7, i) = swung strain_table( 8, i) = sc_lon strain_table( 9, i) = sc_lat strain_table(10, i) = eps1h strain_table(11, i) = eps2h strain_table(12, i) = dilat strain_table(13, i) = epsrr strain_table(14, i) = deg1h strain_table(15, i) = deg2h END DO all_elements ! i = 1, new_elements END SUBROUTINE FE_Strain ! SUBROUTINE File_List(basemap, & ! & gridded_data, & ! & traces, & ! & offsets, & ! & sections, & ! & paleomag, & ! & stress, & ! & fegrid, & ! & velocity, & ! & suggested_file, & ! & using_path) ! ! Reports a list (on default device) of filenames of the ! ! (ONE!) type requested. ! ! Uses GETFILEINFOQQ of module DFLIB.F90 ! ! ! ! Usage of CHARACTER*(*), INTENT(INOUT) :: suggested_file ! ! depends on how many files (of specified type) are ! ! found in the current using_path 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 ' '. ! ! ! ! (DIGITAL Visual Fortran 5.0). ! IMPLICIT NONE ! LOGICAL, INTENT(IN) :: basemap, gridded_data, traces, offsets, sections, & ! & paleomag, stress, fegrid, velocity ! CHARACTER*(*), INTENT(INOUT) :: suggested_file, using_path ! CHARACTER*1 :: first_letter ! CHARACTER*70 :: line = ' ', old_name ! CHARACTER*80 :: string0, string1, string2 ! 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 ! !10 count = 0 ! matched = .FALSE. ! until we find a file == suggested_file ! IF (basemap) THEN ! WRITE (*,"(/' The following appear to be basemap files:')") ! files = TRIM(using_path) // & ! defined in RetroMap4 above ! & '*.DIG' ! (must filter later to exclude F*.DIG) ! ELSE IF (gridded_data) THEN ! WRITE (*,"(/' The following appear to be gridded data (.grd) files:')") ! files = TRIM(using_path) // & ! defined in RetroMap4 above ! & '*.GRD' ! ELSE IF (traces) THEN ! WRITE (*,"(/' The following appear to be fault-trace files:')") ! files = TRIM(using_path) // & ! defined in RetroMap4 above ! & 'F*.DIG' ! ELSE IF (offsets) THEN ! WRITE (*,"(/' The following appear to be fault-offset files:')") ! files = TRIM(using_path) // & ! defined in RetroMap4 above ! & 'F*.RST' ! ELSE IF (sections) THEN ! WRITE (*,"(/' The following appear to be balanced cross-section files:')") ! files = TRIM(using_path) // & ! defined in RetroMap4 above ! & 'C*.RST' ! ELSE IF (paleomag) THEN ! WRITE (*,"(/' The following appear to be paleomagnetic files:')") ! files = TRIM(using_path) // & ! defined in RetroMap4 above ! & 'P*.RST' ! ELSE IF (stress) THEN ! WRITE (*,"(/' The following appear to be paleostress files:')") ! files = TRIM(using_path) // & ! defined in RetroMap4 above ! & 'S*.RST' ! ELSE IF (fegrid) THEN ! WRITE (*,"(/' The following appear to be FE grid files:')") ! files = TRIM(using_path) // & ! defined in RetroMap4 above ! & '*.FEG' ! ELSE IF (velocity) THEN ! WRITE (*,"(/' The following appear to be velocity files:')") ! files = TRIM(using_path) // & ! defined in RetroMap4 above ! & '*.VEL' ! ELSE ! RETURN ! no files of any kind are wanted! ! END IF ! full_to = 0 ! keeps trace 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) ! GO TO 100 ! ELSE IF (count == 0) THEN ! WRITE (*,"(' No such files in directory ',A,';')") TRIM(using_path) ! CALL DPrompt_for_String('Select new directory (for this file only)',using_path,using_path) ! GO TO 10 ! ELSE ! count > 0, but line empty ! GO TO 100 ! END IF ! END IF ! first_letter = info.name(1:1) ! IF (basemap.AND.((first_letter == 'F').OR.(first_letter == 'f'))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If we've gotten this far, we have a qualified file! ! count = count + 1 ! string0 = TRIM(suggested_file) ! CALL DUpper_Case(string0) ! string1 = info.name(1:result) ! string2 = string1 ! CALL DUpper_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) ! GO TO 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 File_List SUBROUTINE Get_Paired_Feg_Names (old_feg_file, old_feg_pathfile, & & new_feg_file, new_feg_pathfile) !Prompts user to identify 2 .feg files that are topologically !identical, although of different ages (and, one is strained !with respect to the other). IMPLICIT NONE CHARACTER*(*), INTENT(OUT) :: old_feg_file, old_feg_pathfile, & & new_feg_file, new_feg_pathfile CHARACTER*80 :: temp_path_in ! used in CALL File_List INTEGER :: ios, new_numnod, old_numnod WRITE (*,"(/' To make this plot, you should supply the names of two .feg files')") WRITE (*,"( ' which are TOPOLOGICALLY IDENTICAL; that is, one is a strained')") WRITE (*,"( ' version of the other. There should be one-to-one correspondance')") WRITE (*,"( ' of nodes and elements between the two grids.')") WRITE (*,"( ' There MUST be equal numbers of nodes in these two grids.')") temp_path_in = path_in ! global variable old_feg_file = 'before.feg' ! default name; produced by Restore3+ new_feg_file = 'after.feg' ! default name; produced by Restore3+ !CALL File_List(basemap = .FALSE., & ! & gridded_data = .FALSE., & ! & traces = .FALSE., & ! & offsets = .FALSE., & ! & sections = .FALSE., & ! & paleomag = .FALSE., & ! & stress = .FALSE., & ! & fegrid = .TRUE., & ! & velocity = .FALSE., & ! & suggested_file = old_feg_file, & ! & using_path = temp_path_in) 10 CALL DPrompt_for_String('Which .feg file is the OLDER one in this pair?',old_feg_file,old_feg_file) old_feg_pathfile = TRIM(temp_path_in)//TRIM(old_feg_file) OPEN (UNIT = 71, FILE = old_feg_pathfile, STATUS = 'OLD', IOSTAT = ios) IF (ios == 0) THEN READ (71,*) READ (71,*) old_numnod CLOSE (71) ELSE WRITE (*,"(' ERROR: Not a valid file (in the chosen source directory). Try again.')") GO TO 10 END IF 20 CALL DPrompt_for_String('Which .feg file is the YOUNGER one in this pair?',new_feg_file,new_feg_file) new_feg_pathfile = TRIM(temp_path_in)//TRIM(new_feg_file) OPEN (UNIT = 71, FILE = new_feg_pathfile, STATUS = 'OLD', IOSTAT = ios) IF (ios == 0) THEN READ (71,*) READ (71,*) new_numnod CLOSE (71) ELSE WRITE (*,"(' ERROR: Not a valid file (in the chosen source directory). Try again.')") GO TO 20 END IF IF (old_numnod /= new_numnod) THEN WRITE (*,"(' ERROR: Files have different numbers of nodes.')") GO TO 10 END IF END SUBROUTINE Get_Paired_Feg_Names SUBROUTINE Histogram (real_list, list_length, skip_zeros, maximum, minimum) ! Puts a printer-plot on the default device, no more than ! (n15 + 2) rows tall by n70 bytes wide, showing the range and ! distribution of values within real_list. IMPLICIT NONE REAL*8, DIMENSION(:), INTENT(IN) :: real_list INTEGER, INTENT(IN) :: list_length LOGICAL, INTENT(IN) :: skip_zeros REAL*8, INTENT(OUT) :: maximum, minimum INTEGER, PARAMETER :: n15 = 15, n70 = 70 REAL*8, PARAMETER :: Huge = 9.99D37 CHARACTER*8 :: number8 CHARACTER*(n70) :: line INTEGER :: highest, i, j, length, zero_index INTEGER, DIMENSION(:), ALLOCATABLE :: counters REAL*8 :: dx, factor IF (list_length < 1) RETURN IF (skip_zeros) THEN IF (real_list(1) /= 0.0D0) THEN maximum = real_list(1) minimum = real_list(1) ELSE ! leading zero maximum = -Huge minimum = +Huge END IF DO i = 2, list_length IF (real_list(i) /= 0.0D0) THEN maximum = MAX(maximum, real_list(i)) minimum = MIN(minimum, real_list(i)) END IF END DO ELSE maximum = real_list(1) minimum = real_list(1) DO i = 2, list_length maximum = MAX(maximum, real_list(i)) minimum = MIN(minimum, real_list(i)) END DO END IF dx = (maximum - minimum) / (n70 - 1) IF (dx == 0.0D0) dx = 1.00D0 ! avoid divide-by-zero ALLOCATE ( counters(n70) ) counters = 0 ! whole array DO i = 1, list_length IF (skip_zeros) THEN IF (real_list(i) /= 0.0D0) THEN j = 1 + DInt_Below((real_list(i) - minimum) / dx) counters(j) = counters(j) + 1 END IF ELSE j = 1 + DInt_Below((real_list(i) - minimum) / dx) counters(j) = counters(j) + 1 END IF END DO highest = 0 DO j = 1, n70 highest = MAX(highest,counters(j)) END DO IF (highest > 0) THEN factor = (1.0D0 * n15) / (1.0D0 * highest) ELSE WRITE (*, "(' ERROR: All values sent to histogram routine are zeros.')") CALL Pause() CALL DTraceback() STOP END IF DO i = n15, 1, -1 ! rows, from top to bottom line = ' ' DO j = 1, n70 ! columns !In bottom row only, put "." to show non-zero contents: IF (i == 1) THEN ! bottom row IF (counters(j) > 0) line(j:j) = '.' END IF IF (NINT(factor * counters(j)) >= i) line(j:j) = '*' END DO ! columns WRITE (*,"(' ',A)") TRIM(line) END DO ! rows line = REPEAT('-',n70) WRITE (*,"(' ',A)") line number8 = DASCII8(minimum) line = TRIM(ADJUSTL(number8)) number8 = DASCII8(maximum) number8 = ADJUSTL(number8) length = LEN_TRIM(number8) line((n70 - length + 1):n70) = TRIM(number8) !Add 0 if it occurs in line, not too close to either end IF (maximum > minimum) THEN zero_index = 1 + NINT(-minimum * (n70-1) / (maximum - minimum)) IF ((zero_index > 9).AND.(zero_index < (n70 - 8))) line(zero_index:zero_index) = '0' END IF WRITE (*,"(' ',A)") line DEALLOCATE ( counters ) END SUBROUTINE Histogram SUBROUTINE Pause() IMPLICIT NONE WRITE (*,"(' Press [Enter]...'\)") READ (*,*) END SUBROUTINE Pause SUBROUTINE Read_S_rst (free_unit, recording) ! Reads s.rst files, possibly with + and $ lines. ! Set up as a SUBR to avoid multiple copies. ! Most long-term variables are global, except: ! free_unit = Fortran device # to use for OPEN, READ, CLOSE ! recording = whether to fill arrays (or just count data)? IMPLICIT NONE INTEGER, INTENT(IN) :: free_unit LOGICAL, INTENT(IN) :: recording CHARACTER*5 :: c5 CHARACTER*6 :: c6 CHARACTER*30 :: c30, c30a INTEGER :: i, line REAL*8 :: r1, r2, t1, t2, x1, x2 REAL*8, DIMENSION(3) :: tv, tvi, tvo !- - - - - - - - - - - - - - - - - IF (.NOT.recording) THEN OPEN (UNIT = free_unit, FILE = TRIM(s_rst_pathfile), STATUS = "OLD", PAD = "YES") READ (free_unit, "(A)") s_rst_format READ (free_unit, "(A)") s_rst_titles ! Skim file and count number of data lines s_rst_count = 0 get_stress_lines: DO READ (free_unit, "(A)", IOSTAT = read_status) c134 IF (read_status == 0) THEN ! read was successful IF ((c134(1:1) /= '+') .AND. & (c134(1:1) /= '*') .AND. & (c134(1:1) /= '&') .AND. & (c134(1:1) /= '$')) THEN s_rst_count = s_rst_count + 1 END IF ELSE ! reached end of file EXIT get_stress_lines END IF END DO get_stress_lines CLOSE (UNIT = free_unit) ! (will be re-read) ELSE ! recording OPEN (UNIT = free_unit, FILE = s_rst_pathfile, STATUS = "OLD", ACTION = "READ", & & PAD = "YES") ; line = 0 READ (free_unit,*) ; line = line + 1 READ (free_unit,*) ; line = line + 1 reading_s_rst: DO i = 1, s_rst_count READ (free_unit, s_rst_format) c30, c30a, c5, x1, x2, r1, r2, t2, t1, c6; line = line + 1 ! s_ref (c30) and s_loc (c30a) are not stored. s_code(i) = c5 CALL DLonLat_2_Uvec(x1, x2, tv) s_site_now(1:3, 1, i) = tv ! possibly overwritten below s_azim_now(i) = r1 * radians_per_degree ! possibly overwritten below CALL Step_aside(tv, s_azim_now(i), tvo) s_site_now(1:3, 2, i) = tvo IF (r2 <= 0.0D0) THEN WRITE (*,"(' ERROR: Nonpositive sigma_ in s_rst_file')") CALL DTraceback END IF s_sigma_(i) = r2 * radians_per_degree IF (t2 <= t1) THEN PRINT "(' Error in line ',I6,' of'/' ',A/' ',F10.2,' is <= ',F10.2)", & & line, TRIM(s_rst_pathfile), t2, t1 STOP ' ' ENDIF s_t_max(i) = t2 * s_per_Ma s_t_min(i) = t1 * s_per_Ma s_stage(i) = (c6(1:1) == 'S') .OR. (c6(1:1) == 's') !read the + line (if present), but use only if "restored" READ (free_unit,"(A)", IOSTAT = read_status) c134 IF (read_status /= 0) EXIT reading_s_rst if (c134(1:1) == '+') THEN c134 = c134(2:134) // ' ' READ (c134,*) x1, x2 IF (restored) THEN CALL DLonLat_2_Uvec(x1, x2, tv) s_site_now(1:3, 1, i) = tv END IF ELSE BACKSPACE(free_unit) END IF !read the $ line (if present), but use only if "restored". READ (free_unit,"(A)", IOSTAT = read_status) c134 IF (read_status /= 0) EXIT reading_s_rst if (c134(1:1) == '$') THEN c134 = c134(2:134) // ' ' READ (c134,*) t1 IF (restored) THEN s_azim_now(i) = t1 * radians_per_degree tvi = s_site_now(1:3, 1, i) CALL Step_aside(tvi, s_azim_now(i), tvo) s_site_now(1:3, 2, i) = tvo END IF ELSE BACKSPACE(free_unit) END IF END DO reading_s_rst CLOSE (UNIT = free_unit) ! close s_rst END IF ! recording or not END SUBROUTINE Read_S_rst FUNCTION Rot_matrix (pole, turn) REAL*8, DIMENSION(3,3) :: Rot_matrix REAL*8, DIMENSION(3), INTENT(IN) :: pole ! Cartesian unit vector REAL*8, INTENT(IN) :: turn ! radians, ccw about pole REAL*8 :: cosa, onem, sina, x, y, z x = pole(1) y = pole(2) z = pole(3) cosa = DCOS(turn) sina = DSIN(turn) onem = 1.0D0 - cosa Rot_matrix(1,1) = cosa + x * x * onem Rot_matrix(1,2) = -z * sina + x * y * onem Rot_matrix(1,3) = y * sina + x * z * onem Rot_matrix(2,1) = z * sina + y * x * onem Rot_matrix(2,2) = cosa + y * y * onem Rot_matrix(2,3) = -x * sina + y * z * onem Rot_matrix(3,1) = -y * sina + z * x * onem Rot_matrix(3,2) = x * sina + z * y * onem Rot_matrix(3,3) = cosa + z * z * onem END FUNCTION Rot_matrix SUBROUTINE Rotation_rate (R, l_, nodes, G, dG, theta_, vw, rotationrate) ! Evaluate rotation-rate in spherical continuum element !(of rigid cylinder, about the local vertical axis, ! in units of radians per second, with counterclockwise positive). ! Note that exact position in element is implied by values in arrays G and dG; ! input parameter theta_ must agree! REAL*8, INTENT(IN) :: R ! radius of planet, in m INTEGER, INTENT(IN) :: l_ ! element number INTEGER, DIMENSION(:,:), INTENT(IN) :: nodes DOUBLE PRECISION, DIMENSION(3,2,2) :: G ! nodal functions @ selected point DOUBLE PRECISION, DIMENSION(3,2,2,2):: dG ! derivitives of nodal functions REAL*8, INTENT(IN) :: theta_ ! colatitude, radians DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: vw REAL*8, INTENT(OUT) :: rotationrate INTEGER :: iv, iw, j REAL*8 :: cott, csct, prefix rotationrate = 0.0D0 cott = 1.0D0 / DTAN(theta_) csct = 1.0D0 / DSIN(theta_) prefix = 0.5D0 / R DO j = 1, 3 ! v is Southward velocity; w is Eastward velocity iv = 2 * nodes(j, l_) - 1 iw = iv + 1 ! w / tan(theta_) = w * cot(theta_) [ use G(j,x,2) ]: rotationrate = rotationrate + & & prefix * (vw(iv) * G(j,1,2) + vw(iw) * G(j,2,2)) * cott ! d w / d theta_ [ use dG(j,x,2,1) ]: rotationrate = rotationrate + & & prefix * (vw(iv) * dG(j,1,2,1) + vw(iw) * dG(j,2,2,1)) ! -csc(theta_) * d v / d phi_ [ use dG(j,x,1,2) ]: rotationrate = rotationrate - & & prefix * csct * (vw(iv) * dG(j,1,1,2) + vw(iw) * dG(j,2,1,2)) END DO ! 3 local nodes END SUBROUTINE Rotation_rate REAL*8 FUNCTION Same_cycle(rads, reference) REAL*8, INTENT(IN) :: rads, reference ! returns result "rads" +- 2n * Pi such that ABS( Same_cycle - reference) <= Pi REAL*8 :: dx, dy dx = DCOS(rads - reference) dy = DSIN(rads - reference) Same_cycle = reference + DATAN2 (dy, dx) END FUNCTION Same_cycle SUBROUTINE Step_aside (b_, gamma_, new_vec) REAL*8, DIMENSION(3), INTENT(IN) :: b_ REAL*8, INTENT(IN) :: gamma_ REAL*8, DIMENSION(3), INTENT(OUT) :: new_vec ! gives position (Cartesian unit vector) close to b_, ! but displaced toward gamma_ (in radians, clockwise from N) REAL*8, DIMENSION(3) :: offset, Phi, Theta, v1 REAL*8 :: radians = 0.002D0 ! offset ~13 km on Earth CALL DLocal_Phi (b_, Phi) CALL DLocal_Theta(b_, Theta) offset = Phi * DSIN(gamma_) - Theta * DCOS(gamma_) v1 = b_ + (offset * radians) CALL DMake_Uvec(v1, new_vec) END SUBROUTINE Step_aside SUBROUTINE Unit_Symbol_2_CMYK(unit, C, M, Y, K) !Determines colors used as custom-fills in OUTCROP areas from Geologic Map of North America IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: unit ! length at least 8; longer unit-symbols permitted, but only 7~8 bytes are used here. REAL*8, INTENT(OUT) :: C, M, Y, K CHARACTER*1 :: c1 c1 = unit(1:1) IF (c1 == '?') THEN IF (unit(1:7) == "?K* ") THEN; C = 0.101961; M = 0.054902; Y = 0.141176; K = 0 ELSE IF (unit(1:7) == "?KT* ") THEN; C = 0.039216; M = 0.047059; Y = 0.278431; K = 0 ELSE IF (unit(1:7) == "?T* ") THEN; C = 0.000000; M = 0.058824; Y = 0.329412; K = 0 ELSE IF (unit(1:7) == "?TR* ") THEN; C = 0.164706; M = 0.078431; Y = 0.090196; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == '1') THEN IF (unit(1:7) == "1eT ") THEN; C = 0.074510; M = 0.133333; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "1lK ") THEN; C = 0.603922; M = 0.270588; Y = 0.494118; K = 0 ELSE IF (unit(1:7) == "1uK ") THEN; C = 0.278431; M = 0.129412; Y = 0.372549; K = 0 ELSE IF (unit(1:7) == "1uP ") THEN; C = 0.435294; M = 0.274510; Y = 0.196078; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == '2') THEN IF (unit(1:7) == "2eT ") THEN; C = 0.094118; M = 0.211765; Y = 0.411765; K = 0 ELSE IF (unit(1:7) == "2lK ") THEN; C = 0.482353; M = 0.176471; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "2lP ") THEN; C = 0.172549; M = 0.200000; Y = 0.227451; K = 0 ELSE IF (unit(1:7) == "2uK ") THEN; C = 0.356863; M = 0.125490; Y = 0.384314; K = 0 ELSE IF (unit(1:7) == "2uKvb ") THEN; C = 0.105882; M = 0.133333; Y = 0.505882; K = 0 ELSE IF (unit(1:7) == "2uKvi ") THEN; C = 0.074510; M = 0.129412; Y = 0.498039; K = 0 ELSE IF (unit(1:7) == "2uP ") THEN; C = 0.278431; M = 0.250980; Y = 0.384314; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == '3') THEN IF (unit(1:7) == "3eT ") THEN; C = 0.078431; M = 0.160784; Y = 0.388235; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'A') THEN IF (unit(1:7) == "Ag ") THEN; C = 0.015686; M = 0.298039; Y = 0.164706; K = 0 ELSE IF (unit(1:7) == "An ") THEN; C = 0.007843; M = 0.098039; Y = 0.062745; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'C') THEN IF (unit(1:7) == "CA ") THEN; C = 1.000000; M = 0.321569; Y = 0.062745; K = 0 ELSE IF (unit(1:7) == "CAD ") THEN; C = 0.788235; M = 0.258824; Y = 0.070588; K = 0 ELSE IF (unit(1:7) == "CADsv ") THEN; C = 0.862745; M = 0.545098; Y = 0.070588; K = 0 ELSE IF (unit(1:7) == "CADv ") THEN; C = 0.807843; M = 0.423529; Y = 0.074510; K = 0 ELSE IF (unit(1:7) == "CAJ ") THEN; C = 0.345098; M = 0.184314; Y = 0.400000; K = 0 ELSE IF (unit(1:7) == "CAk ") THEN; C = 0.345098; M = 0.878431; Y = 0.545098; K = 0 ELSE IF (unit(1:7) == "CAM ") THEN; C = 0.282353; M = 0.282353; Y = 0.250980; K = 0 ELSE IF (unit(1:7) == "CAO ") THEN; C = 0.572549; M = 0.239216; Y = 0.078431; K = 0 ELSE IF (unit(1:7) == "CAOm ") THEN; C = 0.047059; M = 0.447059; Y = 0.266667; K = 0 ELSE IF (unit(1:7) == "CAOsv ") THEN; C = 0.592157; M = 0.309804; Y = 0.074510; K = 0 ELSE IF (unit(1:7) == "CAOv ") THEN; C = 0.623529; M = 0.258824; Y = 0.098039; K = 0 ELSE IF (unit(1:7) == "CAS ") THEN; C = 0.360784; M = 0.172549; Y = 0.086275; K = 0 ELSE IF (unit(1:7) == "CAv ") THEN; C = 0.945098; M = 0.458824; Y = 0.019608; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'D') THEN IF (unit(1:7) == "D ") THEN; C = 0.450980; M = 0.160784; Y = 0.109804; K = 0 ELSE IF (unit(1:7) == "Dg ") THEN; C = 0.109804; M = 0.400000; Y = 0.231373; K = 0 ELSE IF (unit(1:7) == "Dgn ") THEN; C = 0.074510; M = 0.317647; Y = 0.184314; K = 0 ELSE IF (unit(1:7) == "Di ") THEN; C = 0.160784; M = 0.513725; Y = 0.301961; K = 0 ELSE IF (unit(1:7) == "DJvm ") THEN; C = 0.090196; M = 0.317647; Y = 0.945098; K = 0 ELSE IF (unit(1:7) == "DK ") THEN; C = 0.227451; M = 0.184314; Y = 0.309804; K = 0 ELSE IF (unit(1:7) == "DKvm ") THEN; C = 0.309804; M = 0.176471; Y = 0.231373; K = 0 ELSE IF (unit(1:7) == "DM ") THEN; C = 0.309804; M = 0.341176; Y = 0.015686; K = 0 ELSE IF (unit(1:7) == "DM* ") THEN; C = 0.309804; M = 0.341176; Y = 0.015686; K = 0 ELSE IF (unit(1:7) == "DMi ") THEN; C = 0.160784; M = 0.580392; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "DMn ") THEN; C = 0.160784; M = 0.580392; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "DMq ") THEN; C = 0.160784; M = 0.580392; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "DMsv ") THEN; C = 0.258824; M = 0.215686; Y = 0.074510; K = 0 ELSE IF (unit(1:7) == "DMv ") THEN; C = 0.486275; M = 0.909804; Y = 0.207843; K = 0 ELSE IF (unit(1:7) == "DMvk ") THEN; C = 0.486275; M = 0.909804; Y = 0.207843; K = 0 ELSE IF (unit(1:7) == "DMy ") THEN; C = 0.321569; M = 0.972549; Y = 0.105882; K = 0 ELSE IF (unit(1:7) == "DP ") THEN; C = 0.250980; M = 0.137255; Y = 0.074510; K = 0 ELSE IF (unit(1:7) == "DPA ") THEN; C = 0.749020; M = 0.235294; Y = 0.164706; K = 0 ELSE IF (unit(1:7) == "DPsv ") THEN; C = 0.521569; M = 0.180392; Y = 0.094118; K = 0 ELSE IF (unit(1:7) == "DPv ") THEN; C = 0.313725; M = 0.137255; Y = 0.070588; K = 0 ELSE IF (unit(1:7) == "DPvm ") THEN; C = 0.211765; M = 0.219608; Y = 0.078431; K = 0 ELSE IF (unit(1:7) == "Dq ") THEN; C = 0.129412; M = 0.447059; Y = 0.254902; K = 0 ELSE IF (unit(1:7) == "Dsv ") THEN; C = 0.443137; M = 0.247059; Y = 0.066667; K = 0 ELSE IF (unit(1:7) == "DTR ") THEN; C = 0.227451; M = 0.184314; Y = 0.309804; K = 0 ELSE IF (unit(1:7) == "DTRm ") THEN; C = 0.082353; M = 0.592157; Y = 0.717647; K = 0 ELSE IF (unit(1:7) == "DTRsv ") THEN; C = 0.184314; M = 0.176471; Y = 0.333333; K = 0 ELSE IF (unit(1:7) == "DTRsvm ") THEN; C = 0.223529; M = 0.188235; Y = 0.294118; K = 0 ELSE IF (unit(1:7) == "DTRu ") THEN; C = 0.607843; M = 0.823529; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "DTRvm ") THEN; C = 0.145098; M = 0.239216; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "Dv ") THEN; C = 0.466667; M = 0.282353; Y = 0.082353; K = 0 ELSE IF (unit(1:7) == "Dvm ") THEN; C = 0.352941; M = 0.270588; Y = 0.078431; K = 0 ELSE IF (unit(1:7) == "Dy ") THEN; C = 0.160784; M = 0.529412; Y = 0.094118; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'e') THEN IF (unit(1:7) == "eKg ") THEN; C = 0.023529; M = 0.341176; Y = 0.184314; K = 0 ELSE IF (unit(1:7) == "eKi ") THEN; C = 0.043137; M = 0.521569; Y = 0.376471; K = 0 ELSE IF (unit(1:7) == "eKm ") THEN; C = 0.031373; M = 0.717647; Y = 0.321569; K = 0 ELSE IF (unit(1:7) == "eoT ") THEN; C = 0.050980; M = 0.235294; Y = 0.549020; K = 0 ELSE IF (unit(1:7) == "eoTk ") THEN; C = 0.050980; M = 0.341176; Y = 0.203922; K = 0 ELSE IF (unit(1:7) == "eoTsv ") THEN; C = 0.082353; M = 0.341176; Y = 0.658824; K = 0 ELSE IF (unit(1:7) == "eoTvb ") THEN; C = 0.000000; M = 0.443137; Y = 0.000000; K = 0 ELSE IF (unit(1:7) == "eoTvf ") THEN; C = 0.000000; M = 0.443137; Y = 0.000000; K = 0 ELSE IF (unit(1:7) == "eoTvi ") THEN; C = 0.000000; M = 0.443137; Y = 0.000000; K = 0 ELSE IF (unit(1:7) == "eoTvm ") THEN; C = 0.000000; M = 0.443137; Y = 0.000000; K = 0 ELSE IF (unit(1:7) == "eoTvmk ") THEN; C = 0.000000; M = 0.443137; Y = 0.000000; K = 0 ELSE IF (unit(1:7) == "eT ") THEN; C = 0.054902; M = 0.129412; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "eT* ") THEN; C = 0.050980; M = 0.172549; Y = 0.384314; K = 0 ELSE IF (unit(1:7) == "eTg ") THEN; C = 0.007843; M = 0.576471; Y = 0.392157; K = 0 ELSE IF (unit(1:7) == "eTi ") THEN; C = 0.070588; M = 0.541176; Y = 0.392157; K = 0 ELSE IF (unit(1:7) == "eTk ") THEN; C = 0.047059; M = 0.545098; Y = 0.384314; K = 0 ELSE IF (unit(1:7) == "eTq ") THEN; C = 0.015686; M = 0.541176; Y = 0.266667; K = 0 ELSE IF (unit(1:7) == "eTsv ") THEN; C = 0.058824; M = 0.349020; Y = 0.490196; K = 0 ELSE IF (unit(1:7) == "eTv ") THEN; C = 0.050980; M = 0.247059; Y = 0.466667; K = 0 ELSE IF (unit(1:7) == "eTvf ") THEN; C = 0.023529; M = 0.223529; Y = 0.407843; K = 0 ELSE IF (unit(1:7) == "eTvi ") THEN; C = 0.066667; M = 0.290196; Y = 0.517647; K = 0 ELSE IF (unit(1:7) == "eTvim ") THEN; C = 0.074510; M = 0.490196; Y = 0.564706; K = 0 ELSE IF (unit(1:7) == "eTvk ") THEN; C = 0.027451; M = 0.066667; Y = 0.521569; K = 0 ELSE IF (unit(1:7) == "eTvm ") THEN; C = 0.023529; M = 0.223529; Y = 0.407843; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'g') THEN IF (unit(1:7) == "gn ") THEN; C = 0.058824; M = 0.058824; Y = 0.058824; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'I') THEN IF (unit(1:7) == "Ice ") THEN; C = 0.000000; M = 0.000000; Y = 0.000000; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'J') THEN IF (unit(1:7) == "J ") THEN; C = 0.407843; M = 0.180392; Y = 0.337255; K = 0 ELSE IF (unit(1:7) == "J* ") THEN; C = 0.239216; M = 0.105882; Y = 0.200000; K = 0 ELSE IF (unit(1:7) == "Jg ") THEN; C = 0.031373; M = 0.356863; Y = 0.415686; K = 0 ELSE IF (unit(1:7) == "Ji ") THEN; C = 0.054902; M = 0.286275; Y = 0.352941; K = 0 ELSE IF (unit(1:7) == "Jim ") THEN; C = 0.039216; M = 0.345098; Y = 0.411765; K = 0 ELSE IF (unit(1:7) == "JK ") THEN; C = 0.152941; M = 0.137255; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "JK* ") THEN; C = 0.094118; M = 0.066667; Y = 0.333333; K = 0 ELSE IF (unit(1:7) == "JKg ") THEN; C = 0.062745; M = 0.470588; Y = 0.317647; K = 0 ELSE IF (unit(1:7) == "JKgn ") THEN; C = 0.047059; M = 0.196078; Y = 0.176471; K = 0 ELSE IF (unit(1:7) == "JKi ") THEN; C = 0.047059; M = 0.450980; Y = 0.333333; K = 0 ELSE IF (unit(1:7) == "JKm ") THEN; C = 0.105882; M = 0.894118; Y = 0.494118; K = 0 ELSE IF (unit(1:7) == "JKq ") THEN; C = 0.082353; M = 0.482353; Y = 0.423529; K = 0 ELSE IF (unit(1:7) == "JKsv ") THEN; C = 0.094118; M = 0.125490; Y = 0.305882; K = 0 ELSE IF (unit(1:7) == "JKsv* ") THEN; C = 0.047059; M = 0.121569; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "JKv ") THEN; C = 0.305882; M = 0.294118; Y = 0.603922; K = 0 ELSE IF (unit(1:7) == "JKvi ") THEN; C = 0.090196; M = 0.098039; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "JKvim ") THEN; C = 0.258824; M = 0.458824; Y = 0.682353; K = 0 ELSE IF (unit(1:7) == "JKx ") THEN; C = 0.066667; M = 0.066667; Y = 0.200000; K = 0 ELSE IF (unit(1:7) == "Jm ") THEN; C = 0.015686; M = 0.196078; Y = 0.200000; K = 0 ELSE IF (unit(1:7) == "Jmu ") THEN; C = 0.168627; M = 0.984314; Y = 0.435294; K = 0 ELSE IF (unit(1:7) == "Jsv ") THEN; C = 0.462745; M = 0.180392; Y = 0.145098; K = 0 ELSE IF (unit(1:7) == "Ju ") THEN; C = 0.607843; M = 0.823529; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "Jv ") THEN; C = 0.941176; M = 0.250980; Y = 0.372549; K = 0 ELSE IF (unit(1:7) == "Jvi ") THEN; C = 0.956863; M = 0.396078; Y = 0.333333; K = 0 ELSE IF (unit(1:7) == "Jvm ") THEN; C = 0.945098; M = 0.439216; Y = 0.329412; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'K') THEN IF (unit(1:7) == "K ") THEN; C = 0.294118; M = 0.176471; Y = 0.803922; K = 0 ELSE IF (unit(1:7) == "K* ") THEN; C = 0.109804; M = 0.054902; Y = 0.145098; K = 0 ELSE IF (unit(1:7) == "Kg ") THEN; C = 0.027451; M = 0.376471; Y = 0.266667; K = 0 ELSE IF (unit(1:7) == "Kg* ") THEN; C = 0.039216; M = 0.313725; Y = 0.227451; K = 0 ELSE IF (unit(1:7) == "Ki ") THEN; C = 0.003922; M = 0.313725; Y = 0.219608; K = 0 ELSE IF (unit(1:7) == "Km ") THEN; C = 0.062745; M = 0.101961; Y = 0.105882; K = 0 ELSE IF (unit(1:7) == "Ksv ") THEN; C = 0.176471; M = 0.345098; Y = 0.749020; K = 0 ELSE IF (unit(1:7) == "KT ") THEN; C = 0.086275; M = 0.078431; Y = 0.505882; K = 0 ELSE IF (unit(1:7) == "KT* ") THEN; C = 0.047059; M = 0.043137; Y = 0.270588; K = 0 ELSE IF (unit(1:7) == "KTf ") THEN; C = 0.027451; M = 0.407843; Y = 0.439216; K = 0 ELSE IF (unit(1:7) == "KTg ") THEN; C = 0.039216; M = 0.619608; Y = 0.576471; K = 0 ELSE IF (unit(1:7) == "KTgn ") THEN; C = 0.200000; M = 0.196078; Y = 0.278431; K = 0 ELSE IF (unit(1:7) == "KTi ") THEN; C = 0.050980; M = 0.658824; Y = 0.690196; K = 0 ELSE IF (unit(1:7) == "KTm ") THEN; C = 0.019608; M = 0.850980; Y = 0.419608; K = 0 ELSE IF (unit(1:7) == "KTsv ") THEN; C = 0.039216; M = 0.098039; Y = 0.294118; K = 0 ELSE IF (unit(1:7) == "KTt ") THEN; C = 0.090196; M = 0.674510; Y = 0.529412; K = 0 ELSE IF (unit(1:7) == "KTv ") THEN; C = 0.090196; M = 0.172549; Y = 0.482353; K = 0 ELSE IF (unit(1:7) == "KTvf ") THEN; C = 0.003922; M = 0.211765; Y = 0.847059; K = 0 ELSE IF (unit(1:7) == "KTvi ") THEN; C = 0.003922; M = 0.211765; Y = 0.847059; K = 0 ELSE IF (unit(1:7) == "KTvi* ") THEN; C = 0.043137; M = 0.105882; Y = 0.290196; K = 0 ELSE IF (unit(1:7) == "Kvf ") THEN; C = 0.215686; M = 0.188235; Y = 0.788235; K = 0 ELSE IF (unit(1:7) == "Kvi ") THEN; C = 0.266667; M = 0.243137; Y = 0.760784; K = 0 ELSE IF (unit(1:7) == "Kvm ") THEN; C = 0.188235; M = 0.329412; Y = 0.764706; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'l') THEN IF (unit(1:7) == "lJ ") THEN; C = 0.529412; M = 0.203922; Y = 0.415686; K = 0 ELSE IF (unit(1:7) == "lJi ") THEN; C = 0.129412; M = 0.556863; Y = 0.435294; K = 0 ELSE IF (unit(1:7) == "lJm ") THEN; C = 0.168627; M = 0.603922; Y = 0.403922; K = 0 ELSE IF (unit(1:7) == "lJq ") THEN; C = 0.137255; M = 0.509804; Y = 0.384314; K = 0 ELSE IF (unit(1:7) == "lJsv ") THEN; C = 0.533333; M = 0.337255; Y = 0.192157; K = 0 ELSE IF (unit(1:7) == "lJv ") THEN; C = 0.572549; M = 0.266667; Y = 0.317647; K = 0 ELSE IF (unit(1:7) == "lJvb ") THEN; C = 0.537255; M = 0.407843; Y = 0.196078; K = 0 ELSE IF (unit(1:7) == "lJvi ") THEN; C = 0.588235; M = 0.262745; Y = 0.196078; K = 0 ELSE IF (unit(1:7) == "lK ") THEN; C = 0.415686; M = 0.176471; Y = 0.478431; K = 0 ELSE IF (unit(1:7) == "lK* ") THEN; C = 0.109804; M = 0.054902; Y = 0.145098; K = 0 ELSE IF (unit(1:7) == "lKfi ") THEN; C = 0.090196; M = 0.290196; Y = 0.243137; K = 0 ELSE IF (unit(1:7) == "lKg ") THEN; C = 0.047059; M = 0.423529; Y = 0.317647; K = 0 ELSE IF (unit(1:7) == "lKgn ") THEN; C = 0.007843; M = 0.149020; Y = 0.113725; K = 0 ELSE IF (unit(1:7) == "lKi ") THEN; C = 0.047059; M = 0.572549; Y = 0.454902; K = 0 ELSE IF (unit(1:7) == "lKq ") THEN; C = 0.050980; M = 0.466667; Y = 0.349020; K = 0 ELSE IF (unit(1:7) == "lKsv ") THEN; C = 0.407843; M = 0.215686; Y = 0.450980; K = 0 ELSE IF (unit(1:7) == "lKv ") THEN; C = 0.349020; M = 0.223529; Y = 0.450980; K = 0 ELSE IF (unit(1:7) == "lKvi ") THEN; C = 0.403922; M = 0.250980; Y = 0.450980; K = 0 ELSE IF (unit(1:7) == "lKy ") THEN; C = 0.027451; M = 0.411765; Y = 0.309804; K = 0 ELSE IF (unit(1:7) == "lmD ") THEN; C = 0.631373; M = 0.200000; Y = 0.125490; K = 0 ELSE IF (unit(1:7) == "lmJ ") THEN; C = 0.486275; M = 0.211765; Y = 0.384314; K = 0 ELSE IF (unit(1:7) == "lmJv ") THEN; C = 0.396078; M = 0.262745; Y = 0.349020; K = 0 ELSE IF (unit(1:7) == "lmJvb ") THEN; C = 0.329412; M = 0.211765; Y = 0.282353; K = 0 ELSE IF (unit(1:7) == "lmJvi ") THEN; C = 0.478431; M = 0.278431; Y = 0.329412; K = 0 ELSE IF (unit(1:7) == "lP ") THEN; C = 0.372549; M = 0.180392; Y = 0.129412; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF ((c1 == 'm').OR.(c1 == 'M')) THEN IF (unit(1:7) == "M ") THEN; C = 0.337255; M = 0.286275; Y = 0.250980; K = 0 ELSE IF (unit(1:7) == "mCA ") THEN; C = 0.988235; M = 0.478431; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "mD ") THEN; C = 0.450980; M = 0.160784; Y = 0.109804; K = 0 ELSE IF (unit(1:7) == "mDcb ") THEN; C = 0.450980; M = 0.160784; Y = 0.109804; K = 0 ELSE IF (unit(1:7) == "mDe ") THEN; C = 0.450980; M = 0.160784; Y = 0.109804; K = 0 ELSE IF (unit(1:7) == "MJ ") THEN; C = 0.392157; M = 0.250980; Y = 0.431373; K = 0 ELSE IF (unit(1:7) == "mJi ") THEN; C = 0.094118; M = 0.513725; Y = 0.270588; K = 0 ELSE IF (unit(1:7) == "mJm ") THEN; C = 0.058824; M = 0.576471; Y = 0.470588; K = 0 ELSE IF (unit(1:7) == "mJq ") THEN; C = 0.078431; M = 0.521569; Y = 0.443137; K = 0 ELSE IF (unit(1:7) == "MJsvm ") THEN; C = 0.411765; M = 0.258824; Y = 0.435294; K = 0 ELSE IF (unit(1:7) == "MJvm ") THEN; C = 0.305882; M = 0.278431; Y = 0.403922; K = 0 ELSE IF (unit(1:7) == "mJy ") THEN; C = 0.074510; M = 0.525490; Y = 0.207843; K = 0 ELSE IF (unit(1:7) == "mKgn ") THEN; C = 0.133333; M = 0.356863; Y = 0.294118; K = 0 ELSE IF (unit(1:7) == "mKi ") THEN; C = 0.058824; M = 0.431373; Y = 0.207843; K = 0 ELSE IF (unit(1:7) == "mKi* ") THEN; C = 0.039216; M = 0.278431; Y = 0.200000; K = 0 ELSE IF (unit(1:7) == "mKm ") THEN; C = 0.121569; M = 0.427451; Y = 0.270588; K = 0 ELSE IF (unit(1:7) == "mKq ") THEN; C = 0.047059; M = 0.419608; Y = 0.223529; K = 0 ELSE IF (unit(1:7) == "MKsv ") THEN; C = 0.341176; M = 0.258824; Y = 0.415686; K = 0 ELSE IF (unit(1:7) == "mKv ") THEN; C = 0.690196; M = 0.274510; Y = 0.705882; K = 0 ELSE IF (unit(1:7) == "mKy ") THEN; C = 0.117647; M = 0.411765; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "mlJi ") THEN; C = 0.109804; M = 0.533333; Y = 0.443137; K = 0 ELSE IF (unit(1:7) == "mlJm ") THEN; C = 0.113725; M = 0.745098; Y = 0.686275; K = 0 ELSE IF (unit(1:7) == "mlJq ") THEN; C = 0.152941; M = 0.580392; Y = 0.517647; K = 0 ELSE IF (unit(1:7) == "mlJt ") THEN; C = 0.066667; M = 0.615686; Y = 0.521569; K = 0 ELSE IF (unit(1:7) == "MP ") THEN; C = 0.639216; M = 0.227451; Y = 0.094118; K = 0 ELSE IF (unit(1:7) == "MPA ") THEN; C = 0.431373; M = 0.317647; Y = 0.145098; K = 0 ELSE IF (unit(1:7) == "MPAsv ") THEN; C = 0.360784; M = 0.329412; Y = 0.086275; K = 0 ELSE IF (unit(1:7) == "MPm ") THEN; C = 0.149020; M = 0.243137; Y = 0.149020; K = 0 ELSE IF (unit(1:7) == "MPsvm ") THEN; C = 0.392157; M = 0.298039; Y = 0.125490; K = 0 ELSE IF (unit(1:7) == "MPu ") THEN; C = 0.607843; M = 0.823529; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "MPvm ") THEN; C = 0.470588; M = 0.317647; Y = 0.188235; K = 0 ELSE IF (unit(1:7) == "mT ") THEN; C = 0.000000; M = 0.164706; Y = 0.462745; K = 0 ELSE IF (unit(1:7) == "mT* ") THEN; C = 0.011765; M = 0.101961; Y = 0.313725; K = 0 ELSE IF (unit(1:7) == "mTg ") THEN; C = 0.156863; M = 0.392157; Y = 0.219608; K = 0 ELSE IF (unit(1:7) == "mTi ") THEN; C = 0.172549; M = 0.419608; Y = 0.247059; K = 0 ELSE IF (unit(1:7) == "mTq ") THEN; C = 0.172549; M = 0.419608; Y = 0.239216; K = 0 ELSE IF (unit(1:7) == "MTR ") THEN; C = 0.474510; M = 0.258824; Y = 0.282353; K = 0 ELSE IF (unit(1:7) == "MTRu ") THEN; C = 0.607843; M = 0.823529; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "MTRvm ") THEN; C = 0.317647; M = 0.262745; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "mTsv ") THEN; C = 0.062745; M = 0.192157; Y = 0.278431; K = 0 ELSE IF (unit(1:7) == "mTvb ") THEN; C = 0.000000; M = 0.152941; Y = 0.309804; K = 0 ELSE IF (unit(1:7) == "mTvf ") THEN; C = 0.015686; M = 0.223529; Y = 0.415686; K = 0 ELSE IF (unit(1:7) == "mTvf* ") THEN; C = 0.015686; M = 0.223529; Y = 0.415686; K = 0 ELSE IF (unit(1:7) == "mTvi ") THEN; C = 0.019608; M = 0.192157; Y = 0.329412; K = 0 ELSE IF (unit(1:7) == "mTvi* ") THEN; C = 0.000000; M = 0.149020; Y = 0.352941; K = 0 ELSE IF (unit(1:7) == "mTvim ") THEN; C = 0.047059; M = 0.176471; Y = 0.439216; K = 0 ELSE IF (unit(1:7) == "mTvm ") THEN; C = 0.047059; M = 0.176471; Y = 0.439216; K = 0 ELSE IF (unit(1:7) == "mTvm* ") THEN; C = 0.047059; M = 0.176471; Y = 0.439216; K = 0 ELSE IF (unit(1:7) == "mTvmk* ") THEN; C = 0.000000; M = 0.109804; Y = 0.243137; K = 0 ELSE IF (unit(1:7) == "Mv ") THEN; C = 0.317647; M = 0.290196; Y = 0.215686; K = 0 ELSE IF (unit(1:7) == "MZ ") THEN; C = 0.227451; M = 0.149020; Y = 0.294118; K = 0 ELSE IF (unit(1:7) == "MZ* ") THEN; C = 0.109804; M = 0.054902; Y = 0.145098; K = 0 ELSE IF (unit(1:7) == "MZg ") THEN; C = 0.039216; M = 0.780392; Y = 0.556863; K = 0 ELSE IF (unit(1:7) == "MZn ") THEN; C = 0.137255; M = 0.090196; Y = 0.192157; K = 0 ELSE IF (unit(1:7) == "MZsv ") THEN; C = 0.392157; M = 0.254902; Y = 0.403922; K = 0 ELSE IF (unit(1:7) == "MZT* ") THEN; C = 0.043137; M = 0.039216; Y = 0.266667; K = 0 ELSE IF (unit(1:7) == "MZx* ") THEN; C = 0.215686; M = 0.160784; Y = 0.262745; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'n') THEN IF (unit(1:7) == "n ") THEN; C = 0.082353; M = 0.082353; Y = 0.082353; K = 0 ELSE IF (unit(1:7) == "nT ") THEN; C = 0.000000; M = 0.117647; Y = 0.533333; K = 0 ELSE IF (unit(1:7) == "nT* ") THEN; C = 0.000000; M = 0.058824; Y = 0.431373; K = 0 ELSE IF (unit(1:7) == "nTf ") THEN; C = 0.000000; M = 0.101961; Y = 0.996078; K = 0 ELSE IF (unit(1:7) == "nTg ") THEN; C = 0.396078; M = 0.882353; Y = 0.513725; K = 0 ELSE IF (unit(1:7) == "nTi ") THEN; C = 0.254902; M = 0.486275; Y = 0.282353; K = 0 ELSE IF (unit(1:7) == "nTQ ") THEN; C = 0.000000; M = 0.035294; Y = 0.517647; K = 0 ELSE IF (unit(1:7) == "nTQ* ") THEN; C = 0.090196; M = 0.105882; Y = 0.149020; K = 0 ELSE IF (unit(1:7) == "nTQvm ") THEN; C = 0.000000; M = 0.070588; Y = 0.309804; K = 0 ELSE IF (unit(1:7) == "nTsv ") THEN; C = 0.082353; M = 0.243137; Y = 1.000000; K = 0 ELSE IF (unit(1:7) == "nTv ") THEN; C = 0.000000; M = 0.121569; Y = 1.000000; K = 0 ELSE IF (unit(1:7) == "nTv* ") THEN; C = 0.019608; M = 0.094118; Y = 0.454902; K = 0 ELSE IF (unit(1:7) == "nTvf ") THEN; C = 0.000000; M = 0.223529; Y = 1.000000; K = 0 ELSE IF (unit(1:7) == "nTvfi ") THEN; C = 0.000000; M = 0.223529; Y = 1.000000; K = 0 ELSE IF (unit(1:7) == "nTvi ") THEN; C = 0.003922; M = 0.137255; Y = 1.000000; K = 0 ELSE IF (unit(1:7) == "nTvim ") THEN; C = 0.149020; M = 0.227451; Y = 0.498039; K = 0 ELSE IF (unit(1:7) == "nTvk ") THEN; C = 0.000000; M = 0.050980; Y = 0.992157; K = 0 ELSE IF (unit(1:7) == "nTvm ") THEN; C = 0.003922; M = 0.039216; Y = 0.396078; K = 0 ELSE IF (unit(1:7) == "nTy ") THEN; C = 0.341176; M = 0.862745; Y = 0.443137; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF ((c1 == 'o').OR.(c1 == 'O')) THEN IF (unit(1:7) == "O ") THEN; C = 0.219608; M = 0.082353; Y = 0.007843; K = 0 ELSE IF (unit(1:7) == "OD ") THEN; C = 0.470588; M = 0.160784; Y = 0.031373; K = 0 ELSE IF (unit(1:7) == "ODsv ") THEN; C = 0.466667; M = 0.243137; Y = 0.133333; K = 0 ELSE IF (unit(1:7) == "ODv ") THEN; C = 0.392157; M = 0.176471; Y = 0.058824; K = 0 ELSE IF (unit(1:7) == "OJsv ") THEN; C = 0.556863; M = 0.372549; Y = 0.513725; K = 0 ELSE IF (unit(1:7) == "OJsv* ") THEN; C = 0.356863; M = 0.243137; Y = 0.321569; K = 0 ELSE IF (unit(1:7) == "omT ") THEN; C = 0.000000; M = 0.129412; Y = 0.650980; K = 0 ELSE IF (unit(1:7) == "omT* ") THEN; C = 0.000000; M = 0.066667; Y = 0.349020; K = 0 ELSE IF (unit(1:7) == "omTf ") THEN; C = 0.027451; M = 0.364706; Y = 0.670588; K = 0 ELSE IF (unit(1:7) == "omTi ") THEN; C = 0.007843; M = 0.498039; Y = 0.305882; K = 0 ELSE IF (unit(1:7) == "omTk ") THEN; C = 0.070588; M = 0.454902; Y = 0.298039; K = 0 ELSE IF (unit(1:7) == "omTm ") THEN; C = 0.003922; M = 0.647059; Y = 0.411765; K = 0 ELSE IF (unit(1:7) == "omTq ") THEN; C = 0.054902; M = 0.447059; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "omTsv ") THEN; C = 0.000000; M = 0.360784; Y = 0.635294; K = 0 ELSE IF (unit(1:7) == "omTv ") THEN; C = 0.003922; M = 0.305882; Y = 0.611765; K = 0 ELSE IF (unit(1:7) == "omTvf ") THEN; C = 0.011765; M = 0.392157; Y = 0.670588; K = 0 ELSE IF (unit(1:7) == "omTvfi ") THEN; C = 0.027451; M = 0.435294; Y = 0.635294; K = 0 ELSE IF (unit(1:7) == "omTvi ") THEN; C = 0.027451; M = 0.341176; Y = 0.650980; K = 0 ELSE IF (unit(1:7) == "omTvim ") THEN; C = 0.054902; M = 0.423529; Y = 0.670588; K = 0 ELSE IF (unit(1:7) == "omTvm ") THEN; C = 0.062745; M = 0.411765; Y = 0.670588; K = 0 ELSE IF (unit(1:7) == "Oq ") THEN; C = 0.047059; M = 0.552941; Y = 0.333333; K = 0 ELSE IF (unit(1:7) == "OS ") THEN; C = 0.349020; M = 0.176471; Y = 0.172549; K = 0 ELSE IF (unit(1:7) == "OSi ") THEN; C = 0.062745; M = 0.580392; Y = 0.227451; K = 0 ELSE IF (unit(1:7) == "OSsv ") THEN; C = 0.298039; M = 0.258824; Y = 0.164706; K = 0 ELSE IF (unit(1:7) == "OSu ") THEN; C = 0.623529; M = 0.835294; Y = 0.396078; K = 0 ELSE IF (unit(1:7) == "OSv ") THEN; C = 0.329412; M = 0.156863; Y = 0.145098; K = 0 ELSE IF (unit(1:7) == "oT ") THEN; C = 0.050980; M = 0.101961; Y = 0.227451; K = 0 ELSE IF (unit(1:7) == "oTm ") THEN; C = 0.000000; M = 0.419608; Y = 0.431373; K = 0 ELSE IF (unit(1:7) == "oTq ") THEN; C = 0.039216; M = 0.662745; Y = 0.627451; K = 0 ELSE IF (unit(1:7) == "OTR ") THEN; C = 0.227451; M = 0.184314; Y = 0.309804; K = 0 ELSE IF (unit(1:7) == "OTRsv ") THEN; C = 0.211765; M = 0.243137; Y = 0.305882; K = 0 ELSE IF (unit(1:7) == "OTRv ") THEN; C = 0.435294; M = 0.203922; Y = 0.172549; K = 0 ELSE IF (unit(1:7) == "oTsv ") THEN; C = 0.031373; M = 0.121569; Y = 0.286275; K = 0 ELSE IF (unit(1:7) == "oTvf ") THEN; C = 0.031373; M = 0.113725; Y = 0.282353; K = 0 ELSE IF (unit(1:7) == "oTvi ") THEN; C = 0.050980; M = 0.168627; Y = 0.364706; K = 0 ELSE IF (unit(1:7) == "oTvm ") THEN; C = 0.047059; M = 0.168627; Y = 0.352941; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF ((c1 == 'p').OR.(c1 == 'P')) THEN IF (unit(1:7) == "P ") THEN; C = 0.345098; M = 0.258824; Y = 0.176471; K = 0 ELSE IF (unit(1:7) == "PA ") THEN; C = 0.168627; M = 0.121569; Y = 0.215686; K = 0 ELSE IF (unit(1:7) == "PAP ") THEN; C = 0.235294; M = 0.231373; Y = 0.262745; K = 0 ELSE IF (unit(1:7) == "PAPi ") THEN; C = 0.207843; M = 0.364706; Y = 0.258824; K = 0 ELSE IF (unit(1:7) == "PAPm ") THEN; C = 0.388235; M = 0.396078; Y = 0.196078; K = 0 ELSE IF (unit(1:7) == "PAPsv ") THEN; C = 0.105882; M = 0.078431; Y = 0.203922; K = 0 ELSE IF (unit(1:7) == "PAPv ") THEN; C = 0.121569; M = 0.078431; Y = 0.196078; K = 0 ELSE IF (unit(1:7) == "PAPy ") THEN; C = 0.211765; M = 0.372549; Y = 0.254902; K = 0 ELSE IF (unit(1:7) == "paT ") THEN; C = 0.047059; M = 0.172549; Y = 0.325490; K = 0 ELSE IF (unit(1:7) == "paT* ") THEN; C = 0.050980; M = 0.117647; Y = 0.235294; K = 0 ELSE IF (unit(1:7) == "PATR ") THEN; C = 0.482353; M = 0.298039; Y = 0.317647; K = 0 ELSE IF (unit(1:7) == "PATRsv ") THEN; C = 0.145098; M = 0.160784; Y = 0.196078; K = 0 ELSE IF (unit(1:7) == "paTsv ") THEN; C = 0.000000; M = 0.274510; Y = 0.443137; K = 0 ELSE IF (unit(1:7) == "paTvf ") THEN; C = 0.121569; M = 0.231373; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "PAvm ") THEN; C = 0.117647; M = 0.117647; Y = 0.164706; K = 0 ELSE IF (unit(1:7) == "pCAx ") THEN; C = 0.160784; M = 0.160784; Y = 0.160784; K = 0 ELSE IF (unit(1:7) == "Pg ") THEN; C = 0.031373; M = 0.909804; Y = 0.337255; K = 0 ELSE IF (unit(1:7) == "pgT ") THEN; C = 0.050980; M = 0.235294; Y = 0.549020; K = 0 ELSE IF (unit(1:7) == "pgT* ") THEN; C = 0.058824; M = 0.133333; Y = 0.298039; K = 0 ELSE IF (unit(1:7) == "pgTf ") THEN; C = 0.000000; M = 0.800000; Y = 0.400000; K = 0 ELSE IF (unit(1:7) == "pgTg ") THEN; C = 0.000000; M = 0.976471; Y = 0.462745; K = 0 ELSE IF (unit(1:7) == "pgTgn ") THEN; C = 0.000000; M = 0.466667; Y = 0.207843; K = 0 ELSE IF (unit(1:7) == "pgTi ") THEN; C = 0.000000; M = 0.941176; Y = 0.470588; K = 0 ELSE IF (unit(1:7) == "pgTm ") THEN; C = 0.039216; M = 0.647059; Y = 0.313725; K = 0 ELSE IF (unit(1:7) == "pgTmy ") THEN; C = 0.066667; M = 0.960784; Y = 0.431373; K = 0 ELSE IF (unit(1:7) == "pgTq ") THEN; C = 0.000000; M = 0.807843; Y = 0.384314; K = 0 ELSE IF (unit(1:7) == "pgTsv ") THEN; C = 0.094118; M = 0.278431; Y = 0.639216; K = 0 ELSE IF (unit(1:7) == "pgTsv* ") THEN; C = 0.050980; M = 0.192157; Y = 0.396078; K = 0 ELSE IF (unit(1:7) == "pgTsvm*") THEN; C = 0.062745; M = 0.203922; Y = 0.400000; K = 0 ELSE IF (unit(1:7) == "pgTv ") THEN; C = 0.086275; M = 0.317647; Y = 0.788235; K = 0 ELSE IF (unit(1:7) == "pgTvb ") THEN; C = 0.039216; M = 0.325490; Y = 0.647059; K = 0 ELSE IF (unit(1:7) == "pgTvf ") THEN; C = 0.105882; M = 0.254902; Y = 0.572549; K = 0 ELSE IF (unit(1:7) == "pgTvi ") THEN; C = 0.105882; M = 0.286275; Y = 0.670588; K = 0 ELSE IF (unit(1:7) == "pgTvk ") THEN; C = 0.070588; M = 0.258824; Y = 0.690196; K = 0 ELSE IF (unit(1:7) == "pgTvm ") THEN; C = 0.082353; M = 0.341176; Y = 0.725490; K = 0 ELSE IF (unit(1:7) == "pgTy ") THEN; C = 0.062745; M = 0.996078; Y = 0.250980; K = 0 ELSE IF (unit(1:7) == "Pi ") THEN; C = 0.117647; M = 0.717647; Y = 0.325490; K = 0 ELSE IF (unit(1:7) == "PJ ") THEN; C = 0.674510; M = 0.407843; Y = 0.466667; K = 0 ELSE IF (unit(1:7) == "PJsv ") THEN; C = 0.149020; M = 0.211765; Y = 0.250980; K = 0 ELSE IF (unit(1:7) == "PK ") THEN; C = 0.615686; M = 0.384314; Y = 0.815686; K = 0 ELSE IF (unit(1:7) == "PKv ") THEN; C = 0.141176; M = 0.172549; Y = 0.192157; K = 0 ELSE IF (unit(1:7) == "plT ") THEN; C = 0.000000; M = 0.109804; Y = 0.364706; K = 0 ELSE IF (unit(1:7) == "plT* ") THEN; C = 0.000000; M = 0.062745; Y = 0.294118; K = 0 ELSE IF (unit(1:7) == "plTQ ") THEN; C = 0.000000; M = 0.035294; Y = 0.517647; K = 0 ELSE IF (unit(1:7) == "plTQ* ") THEN; C = 0.090196; M = 0.105882; Y = 0.149020; K = 0 ELSE IF (unit(1:7) == "plTQvf ") THEN; C = 0.000000; M = 0.113725; Y = 0.498039; K = 0 ELSE IF (unit(1:7) == "plTQvf*") THEN; C = 0.003922; M = 0.090196; Y = 0.388235; K = 0 ELSE IF (unit(1:7) == "plTQvi ") THEN; C = 0.023529; M = 0.090196; Y = 0.556863; K = 0 ELSE IF (unit(1:7) == "plTQvim") THEN; C = 0.007843; M = 0.156863; Y = 0.509804; K = 0 ELSE IF (unit(1:8) == "plTQvm* ") THEN; C = 0.039216; M = 0.145098; Y = 0.580392; K = 0 ELSE IF (unit(1:8) == "plTQvm**") THEN; C = 0.039216; M = 0.145098; Y = 0.580392; K = 0 ELSE IF (unit(1:7) == "plTsv ") THEN; C = 0.000000; M = 0.129412; Y = 0.517647; K = 0 ELSE IF (unit(1:7) == "plTvf ") THEN; C = 0.011765; M = 0.105882; Y = 0.537255; K = 0 ELSE IF (unit(1:7) == "plTvi ") THEN; C = 0.000000; M = 0.176471; Y = 0.541176; K = 0 ELSE IF (unit(1:7) == "plTvm ") THEN; C = 0.039216; M = 0.180392; Y = 0.552941; K = 0 ELSE IF (unit(1:7) == "Pm ") THEN; C = 0.137255; M = 0.396078; Y = 0.196078; K = 0 ELSE IF (unit(1:7) == "Pq ") THEN; C = 0.113725; M = 0.913725; Y = 0.392157; K = 0 ELSE IF (unit(1:7) == "PRgn ") THEN; C = 0.047059; M = 0.223529; Y = 0.294118; K = 0 ELSE IF (unit(1:7) == "Psv ") THEN; C = 0.286275; M = 0.305882; Y = 0.180392; K = 0 ELSE IF (unit(1:7) == "Pt ") THEN; C = 0.184314; M = 0.956863; Y = 0.403922; K = 0 ELSE IF (unit(1:7) == "PTR ") THEN; C = 0.674510; M = 0.400000; Y = 0.462745; K = 0 ELSE IF (unit(1:7) == "PTRsv ") THEN; C = 0.000000; M = 0.196078; Y = 0.188235; K = 0 ELSE IF (unit(1:7) == "PTRvim ") THEN; C = 0.117647; M = 0.188235; Y = 0.215686; K = 0 ELSE IF (unit(1:7) == "PTRvm ") THEN; C = 0.156863; M = 0.215686; Y = 0.223529; K = 0 ELSE IF (unit(1:7) == "Pu ") THEN; C = 0.607843; M = 0.823529; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "Pv ") THEN; C = 0.349020; M = 0.266667; Y = 0.184314; K = 0 ELSE IF (unit(1:7) == "Pvm ") THEN; C = 0.329412; M = 0.341176; Y = 0.200000; K = 0 ELSE IF (unit(1:7) == "PZ ") THEN; C = 0.670588; M = 0.180392; Y = 0.137255; K = 0 ELSE IF (unit(1:7) == "PZ* ") THEN; C = 0.113725; M = 0.043137; Y = 0.003922; K = 0 ELSE IF (unit(1:7) == "PZg ") THEN; C = 0.113725; M = 0.894118; Y = 0.309804; K = 0 ELSE IF (unit(1:7) == "PZMZ ") THEN; C = 0.298039; M = 0.294118; Y = 0.278431; K = 0 ELSE IF (unit(1:7) == "PZMZ* ") THEN; C = 0.152941; M = 0.149020; Y = 0.141176; K = 0 ELSE IF (unit(1:7) == "PZMZsv ") THEN; C = 0.309804; M = 0.333333; Y = 0.258824; K = 0 ELSE IF (unit(1:7) == "PZMZu ") THEN; C = 0.607843; M = 0.823529; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "PZn ") THEN; C = 0.231373; M = 0.909804; Y = 0.447059; K = 0 ELSE IF (unit(1:7) == "PZsv ") THEN; C = 0.654902; M = 0.352941; Y = 0.211765; K = 0 ELSE IF (unit(1:7) == "PZTRm ") THEN; C = 0.313725; M = 0.439216; Y = 0.329412; K = 0 ELSE IF (unit(1:7) == "PZvf ") THEN; C = 0.752941; M = 0.372549; Y = 0.160784; K = 0 ELSE IF (unit(1:7) == "PZvm ") THEN; C = 0.721569; M = 0.443137; Y = 0.137255; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'Q') THEN IF (unit(1:7) == "Q ") THEN; C = 0.000000; M = 0.019608; Y = 0.270588; K = 0 ELSE IF (unit(1:7) == "Q* ") THEN; C = 0.094118; M = 0.094118; Y = 0.094118; K = 0 ELSE IF (unit(1:7) == "Qv ") THEN; C = 0.043137; M = 0.070588; Y = 0.200000; K = 0 ELSE IF (unit(1:7) == "Qv* ") THEN; C = 0.043137; M = 0.054902; Y = 0.141176; K = 0 ELSE IF (unit(1:7) == "Qvf ") THEN; C = 0.000000; M = 0.023529; Y = 0.231373; K = 0 ELSE IF (unit(1:7) == "Qvfi ") THEN; C = 0.000000; M = 0.054902; Y = 0.200000; K = 0 ELSE IF (unit(1:7) == "Qvi ") THEN; C = 0.007843; M = 0.054902; Y = 0.274510; K = 0 ELSE IF (unit(1:7) == "Qvim ") THEN; C = 0.000000; M = 0.039216; Y = 0.156863; K = 0 ELSE IF (unit(1:7) == "Qvm ") THEN; C = 0.000000; M = 0.000000; Y = 0.262745; K = 0 ELSE IF (unit(1:7) == "Qvm* ") THEN; C = 0.000000; M = 0.007843; Y = 0.133333; K = 0 ELSE IF (unit(1:7) == "Qvmk ") THEN; C = 0.074510; M = 0.000000; Y = 0.298039; K = 0 ELSE IF (unit(1:7) == "Qvmk* ") THEN; C = 0.054902; M = 0.000000; Y = 0.192157; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'S') THEN IF (unit(1:7) == "S ") THEN; C = 0.705882; M = 0.262745; Y = 0.231373; K = 0 ELSE IF (unit(1:7) == "SD ") THEN; C = 0.521569; M = 0.152941; Y = 0.011765; K = 0 ELSE IF (unit(1:7) == "SD* ") THEN; C = 0.219608; M = 0.082353; Y = 0.007843; K = 0 ELSE IF (unit(1:7) == "Sv ") THEN; C = 0.713725; M = 0.372549; Y = 0.203922; K = 0 ELSE IF (unit(1:7) == "Sy ") THEN; C = 0.066667; M = 0.427451; Y = 0.274510; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'T') THEN IF (unit(1:7) == "T ") THEN; C = 0.000000; M = 0.129412; Y = 0.650980; K = 0 ELSE IF (unit(1:7) == "T* ") THEN; C = 0.000000; M = 0.050980; Y = 0.317647; K = 0 ELSE IF (unit(1:7) == "Tg ") THEN; C = 0.039216; M = 0.407843; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "Ti ") THEN; C = 0.066667; M = 0.756863; Y = 0.717647; K = 0 ELSE IF (unit(1:7) == "TQ ") THEN; C = 0.000000; M = 0.035294; Y = 0.517647; K = 0 ELSE IF (unit(1:7) == "TQ* ") THEN; C = 0.082353; M = 0.105882; Y = 0.200000; K = 0 ELSE IF (unit(1:7) == "TQv ") THEN; C = 0.011765; M = 0.058824; Y = 0.537255; K = 0 ELSE IF (unit(1:7) == "TQv* ") THEN; C = 0.007843; M = 0.027451; Y = 0.278431; K = 0 ELSE IF (unit(1:7) == "TQvb ") THEN; C = 0.000000; M = 0.074510; Y = 0.490196; K = 0 ELSE IF (unit(1:7) == "TQvbk ") THEN; C = 0.125490; M = 0.015686; Y = 0.498039; K = 0 ELSE IF (unit(1:7) == "TQvf ") THEN; C = 0.000000; M = 0.105882; Y = 0.592157; K = 0 ELSE IF (unit(1:7) == "TQvi ") THEN; C = 0.000000; M = 0.121569; Y = 0.533333; K = 0 ELSE IF (unit(1:7) == "TQvim ") THEN; C = 0.003922; M = 0.137255; Y = 0.486275; K = 0 ELSE IF (unit(1:7) == "TQvk ") THEN; C = 0.011765; M = 0.062745; Y = 0.564706; K = 0 ELSE IF (unit(1:7) == "TQvm ") THEN; C = 0.000000; M = 0.125490; Y = 0.462745; K = 0 ELSE IF (unit(1:7) == "TQvm* ") THEN; C = 0.027451; M = 0.094118; Y = 0.294118; K = 0 ELSE IF (unit(1:7) == "TR ") THEN; C = 0.239216; M = 0.105882; Y = 0.200000; K = 0 ELSE IF (unit(1:7) == "TR* ") THEN; C = 0.180392; M = 0.074510; Y = 0.094118; K = 0 ELSE IF (unit(1:7) == "TRg ") THEN; C = 0.000000; M = 0.325490; Y = 0.498039; K = 0 ELSE IF (unit(1:7) == "TRi ") THEN; C = 0.023529; M = 0.364706; Y = 0.768627; K = 0 ELSE IF (unit(1:7) == "TRJ ") THEN; C = 0.329412; M = 0.121569; Y = 0.223529; K = 0 ELSE IF (unit(1:7) == "TRJg ") THEN; C = 0.007843; M = 0.415686; Y = 0.749020; K = 0 ELSE IF (unit(1:7) == "TRJi ") THEN; C = 0.011765; M = 0.411765; Y = 0.745098; K = 0 ELSE IF (unit(1:7) == "TRJm ") THEN; C = 0.000000; M = 0.560784; Y = 0.607843; K = 0 ELSE IF (unit(1:7) == "TRJq ") THEN; C = 0.003922; M = 0.364706; Y = 0.768627; K = 0 ELSE IF (unit(1:7) == "TRJsv ") THEN; C = 0.211765; M = 0.113725; Y = 0.231373; K = 0 ELSE IF (unit(1:7) == "TRJv ") THEN; C = 0.266667; M = 0.066667; Y = 0.141176; K = 0 ELSE IF (unit(1:7) == "TRJvi ") THEN; C = 0.219608; M = 0.105882; Y = 0.192157; K = 0 ELSE IF (unit(1:7) == "TRJvk ") THEN; C = 0.270588; M = 0.086275; Y = 0.109804; K = 0 ELSE IF (unit(1:7) == "TRJy ") THEN; C = 0.152941; M = 0.364706; Y = 0.627451; K = 0 ELSE IF (unit(1:7) == "TRK ") THEN; C = 0.952941; M = 0.286275; Y = 0.400000; K = 0 ELSE IF (unit(1:7) == "TRm ") THEN; C = 0.007843; M = 0.490196; Y = 0.470588; K = 0 ELSE IF (unit(1:7) == "TRsv ") THEN; C = 0.235294; M = 0.141176; Y = 0.192157; K = 0 ELSE IF (unit(1:7) == "TRu ") THEN; C = 0.607843; M = 0.823529; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "TRv ") THEN; C = 0.250980; M = 0.145098; Y = 0.211765; K = 0 ELSE IF (unit(1:7) == "TRvb ") THEN; C = 0.250980; M = 0.082353; Y = 0.188235; K = 0 ELSE IF (unit(1:7) == "TRvi ") THEN; C = 0.243137; M = 0.090196; Y = 0.160784; K = 0 ELSE IF (unit(1:7) == "TRvk ") THEN; C = 0.270588; M = 0.113725; Y = 0.145098; K = 0 ELSE IF (unit(1:7) == "TRvm ") THEN; C = 0.247059; M = 0.105882; Y = 0.125490; K = 0 ELSE IF (unit(1:7) == "Tv ") THEN; C = 0.011765; M = 0.196078; Y = 0.945098; K = 0 ELSE IF (unit(1:7) == "Tvf ") THEN; C = 0.003922; M = 0.176471; Y = 1.000000; K = 0 ELSE IF (unit(1:7) == "Tvi ") THEN; C = 0.019608; M = 0.196078; Y = 1.000000; K = 0 ELSE IF (unit(1:7) == "Tvm ") THEN; C = 0.054902; M = 0.227451; Y = 0.937255; K = 0 ELSE IF (unit(1:7) == "Tvm* ") THEN; C = 0.039216; M = 0.137255; Y = 0.478431; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'u') THEN IF (unit(1:7) == "u ") THEN; C = 0.607843; M = 0.823529; Y = 0.427451; K = 0 ELSE IF (unit(1:7) == "uD ") THEN; C = 0.486275; M = 0.156863; Y = 0.149020; K = 0 ELSE IF (unit(1:7) == "uDcb ") THEN; C = 0.486275; M = 0.156863; Y = 0.149020; K = 0 ELSE IF (unit(1:7) == "uJ ") THEN; C = 0.458824; M = 0.188235; Y = 0.258824; K = 0 ELSE IF (unit(1:7) == "uK ") THEN; C = 0.270588; M = 0.113725; Y = 0.458824; K = 0 ELSE IF (unit(1:7) == "uK* ") THEN; C = 0.172549; M = 0.082353; Y = 0.184314; K = 0 ELSE IF (unit(1:7) == "uKsv ") THEN; C = 0.113725; M = 0.094118; Y = 0.447059; K = 0 ELSE IF (unit(1:7) == "uKv ") THEN; C = 0.156863; M = 0.117647; Y = 0.517647; K = 0 ELSE IF (unit(1:7) == "uKvf ") THEN; C = 0.207843; M = 0.125490; Y = 0.490196; K = 0 ELSE IF (unit(1:7) == "uKvi ") THEN; C = 0.141176; M = 0.215686; Y = 0.474510; K = 0 ELSE IF (unit(1:7) == "uKvm ") THEN; C = 0.211765; M = 0.133333; Y = 0.450980; K = 0 ELSE IF (unit(1:7) == "uP ") THEN; C = 0.364706; M = 0.149020; Y = 0.066667; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'V') THEN IF (unit(1:7) == "VWn ") THEN; C = 0.043137; M = 0.082353; Y = 0.090196; K = 0 ELSE IF (unit(1:7) == "VWsv ") THEN; C = 0.129412; M = 0.160784; Y = 0.219608; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'W') THEN IF (unit(1:7) == "W ") THEN; C = 0.125490; M = 0.145098; Y = 0.219608; K = 0 ELSE IF (unit(1:7) == "Wg ") THEN; C = 0.019608; M = 0.270588; Y = 0.137255; K = 0 ELSE IF (unit(1:7) == "Wgn ") THEN; C = 0.011765; M = 0.086275; Y = 0.058824; K = 0 ELSE IF (unit(1:7) == "Wi ") THEN; C = 0.094118; M = 0.400000; Y = 0.243137; K = 0 ELSE IF (unit(1:7) == "Wm ") THEN; C = 0.454902; M = 0.584314; Y = 0.368627; K = 0 ELSE IF (unit(1:7) == "Wn ") THEN; C = 0.000000; M = 0.200000; Y = 0.117647; K = 0 ELSE IF (unit(1:7) == "Wq ") THEN; C = 0.000000; M = 0.270588; Y = 0.149020; K = 0 ELSE IF (unit(1:7) == "Wsv ") THEN; C = 0.082353; M = 0.172549; Y = 0.223529; K = 0 ELSE IF (unit(1:7) == "Wvf ") THEN; C = 0.125490; M = 0.180392; Y = 0.231373; K = 0 ELSE IF (unit(1:7) == "Wvm ") THEN; C = 0.086275; M = 0.164706; Y = 0.211765; K = 0 ELSE IF (unit(1:7) == "WXg ") THEN; C = 0.078431; M = 0.231373; Y = 0.247059; K = 0 ELSE IF (unit(1:7) == "WXsv ") THEN; C = 0.133333; M = 0.188235; Y = 0.215686; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'X') THEN IF (unit(1:7) == "X ") THEN; C = 0.125490; M = 0.227451; Y = 0.121569; K = 0 ELSE IF (unit(1:7) == "XCAn ") THEN; C = 0.078431; M = 0.078431; Y = 0.078431; K = 0 ELSE IF (unit(1:7) == "Xg ") THEN; C = 0.050980; M = 0.874510; Y = 0.525490; K = 0 ELSE IF (unit(1:7) == "Xm ") THEN; C = 0.054902; M = 0.462745; Y = 0.309804; K = 0 ELSE IF (unit(1:7) == "Xq ") THEN; C = 0.031373; M = 0.815686; Y = 0.505882; K = 0 ELSE IF (unit(1:7) == "Xqz ") THEN; C = 0.023529; M = 0.082353; Y = 0.058824; K = 0 ELSE IF (unit(1:7) == "Xsv ") THEN; C = 0.113725; M = 0.219608; Y = 0.094118; K = 0 ELSE IF (unit(1:7) == "Xsvn ") THEN; C = 0.117647; M = 0.192157; Y = 0.129412; K = 0 ELSE IF (unit(1:7) == "XYg ") THEN; C = 0.027451; M = 0.364706; Y = 0.901961; K = 0 ELSE IF (unit(1:7) == "X? ") THEN; C = 0.345098; M = 0.415686; Y = 0.219608; K = 0 ELSE IF (unit(1:7) == "X?g ") THEN; C = 0.039216; M = 0.972549; Y = 0.360784; K = 0 ELSE IF (unit(1:7) == "X?gn ") THEN; C = 0.050980; M = 0.501961; Y = 0.349020; K = 0 ELSE IF (unit(1:7) == "X?n ") THEN; C = 0.086275; M = 0.203922; Y = 0.149020; K = 0 ELSE IF (unit(1:7) == "X?vf ") THEN; C = 0.235294; M = 0.309804; Y = 0.192157; K = 0 ELSE IF (unit(1:7) == "X? ") THEN; C = 0.196078; M = 0.321569; Y = 0.176471; K = 0 ELSE IF (unit(1:7) == "X?Y? ") THEN; C = 0.023529; M = 0.286275; Y = 0.643137; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'Y') THEN IF (unit(1:7) == "Y ") THEN; C = 0.011765; M = 0.160784; Y = 0.658824; K = 0 ELSE IF (unit(1:7) == "Ya ") THEN; C = 0.031373; M = 0.031373; Y = 0.650980; K = 0 ELSE IF (unit(1:7) == "Ygn ") THEN; C = 0.003922; M = 0.098039; Y = 0.552941; K = 0 ELSE IF (unit(1:7) == "Ym ") THEN; C = 0.011765; M = 0.133333; Y = 0.270588; K = 0 ELSE IF (unit(1:7) == "Yn ") THEN; C = 0.003922; M = 0.070588; Y = 0.537255; K = 0 ELSE IF (unit(1:7) == "Yq ") THEN; C = 0.000000; M = 0.247059; Y = 0.549020; K = 0 ELSE IF (unit(1:7) == "Yy ") THEN; C = 0.098039; M = 0.317647; Y = 0.682353; K = 0 ELSE IF (unit(1:7) == "YZ ") THEN; C = 0.156863; M = 0.317647; Y = 0.474510; K = 0 ELSE IF (unit(1:7) == "Y?q ") THEN; C = 0.031373; M = 0.239216; Y = 0.482353; K = 0 ELSE IF (unit(1:7) == "Y?Z ") THEN; C = 0.145098; M = 0.313725; Y = 0.513725; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE IF (c1 == 'Z') THEN IF (unit(1:7) == "Z ") THEN; C = 0.223529; M = 0.349020; Y = 0.498039; K = 0 ELSE IF (unit(1:7) == "ZCA ") THEN; C = 0.176471; M = 0.254902; Y = 0.290196; K = 0 ELSE IF (unit(1:7) == "ZD ") THEN; C = 0.321569; M = 0.305882; Y = 0.396078; K = 0 ELSE IF (unit(1:7) == "ZDn ") THEN; C = 0.172549; M = 0.513725; Y = 0.152941; K = 0 ELSE IF (unit(1:7) == "ZDsv ") THEN; C = 0.329412; M = 0.407843; Y = 0.454902; K = 0 ELSE IF (unit(1:7) == "ZDvm ") THEN; C = 0.270588; M = 0.313725; Y = 0.345098; K = 0 ELSE IF (unit(1:7) == "Zm ") THEN; C = 0.349020; M = 0.529412; Y = 0.278431; K = 0 ELSE IF (unit(1:7) == "ZPZ ") THEN; C = 0.294118; M = 0.290196; Y = 0.274510; K = 0 ELSE IF (unit(1:7) == "ZPZn ") THEN; C = 0.074510; M = 0.074510; Y = 0.074510; K = 0 ELSE IF (unit(1:7) == "ZPZsv ") THEN; C = 0.219608; M = 0.329412; Y = 0.337255; K = 0 ELSE IF (unit(1:7) == "Zq ") THEN; C = 0.309804; M = 0.541176; Y = 0.313725; K = 0 ELSE IF (unit(1:7) == "ZTR ") THEN; C = 0.294118; M = 0.290196; Y = 0.274510; K = 0 ELSE IF (unit(1:7) == "ZTRvm ") THEN; C = 0.498039; M = 0.396078; Y = 0.345098; K = 0 ELSE IF (unit(1:7) == "Zv ") THEN; C = 0.384314; M = 0.466667; Y = 0.576471; K = 0 ELSE; C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0; END IF ELSE ! unexpected initial letter C = 0.0D0; M = 0.0D0; Y = 0.0D0; K = 0.2D0 END IF END SUBROUTINE Unit_Symbol_2_CMYK SUBROUTINE Wedge_on_L1(x1p, y1p, radius_points, azimuth0, azimuth1) ! Creates a pie-wedge path on L1, with vertex at (x1p, y1p) points, ! with radius of radius_points, from azimuth0 to azimuth1 !(both in degrees, measured clockwise from top). ! Used to reduce length of legend code for vertical-axis rotations ! Note that it may NOT work well if ABS(azimuth1 - azimuth0) > 90.0 IMPLICIT NONE REAL*8, INTENT(IN) :: x1p, y1p, radius_points, azimuth0, azimuth1 REAL*8 :: lever_points, xap, xbp, xep, x2p, yap, ybp, yep, y2p CALL DNew_L12_Path(1, x1p, y1p) x2p = x1p + radius_points * DSIN(azimuth1 * radians_per_degree) y2p = y1p + radius_points * DCOS(azimuth1 * radians_per_degree) CALL DLine_To_L12(x2p, y2p) xep = x1p + radius_points * DSIN(azimuth0 * radians_per_degree) ! goal of curveto yep = y1p + radius_points * DCOS(azimuth0 * radians_per_degree) lever_points = 0.35D0 * radius_points * (azimuth1 - azimuth0) * radians_per_degree xap = x2p - lever_points * DCOS(azimuth1 * radians_per_degree) ! lever for start of curve yap = y2p + lever_points * DSIN(azimuth1 * radians_per_degree) xbp = xep + lever_points * DCOS(azimuth0 * radians_per_degree) ! lever for end point ybp = yep - lever_points * DSIN(azimuth0 * radians_per_degree) CALL DCurve_To_L12(xap,yap, xbp,ybp, xep,yep) CALL DLine_To_L12(x1p, y1p) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END SUBROUTINE Wedge_on_L1 END PROGRAM RetroMap4