PROGRAM NeoKineMap ! ! Graphical part of the NeoKinema ! kinematic (or inverse) finite element model of ! ongoing velocity and strain-rate in the lithosphere. ! Reads .dig files in either (x,y) or (lon,lat) ! format, gridded-data .grd files in either (x,y) ! or (lon,lat) format, finite-element-grid (.feg) files, ! input parameter (i*.nki) files, nodal ! velocity (v*.out) files, and various kinds ! of input (*.nki) and output (*.nko) data files ! specific to NeoKinema, ! and then creates .ai graphics file with map, ! in a choice of 10 different map projections. ! ! by Peter Bird ! Department of Earth and Space Sciences ! University of California ! Los Angeles, CA 90095-1567 ! pbird@ess.ucla.edu ! (310) 825-1126 ! !(c) Copyright 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2010 by ! Peter Bird and the Regents of the University of California. ! USE Adobe_Illustrator ! provided as Adobe_Illustrator.f90 USE Map_Projections ! provided as Map_Projections.f90 USE Map_Tools ! provided as Map_Tools.f90 USE Icosahedron ! provided as Icosahedron.f90 USE DFLIB, ARCQQ => ARC ! provided with Digital Visual Fortran: ! Using GETFILEINFOQQ, which provides names of files ! matching spec.s like "v*.out". Helps user select correct file. ! If no substitute is available on your system when you compile, ! just omit SUBROUTINE File_List (and any CALLs to it). ! Also, using BEEPQQ to sound PC speaker when each task is done; ! again, this can simply be omitted if there is no substitute. ! However, not using ARC, because I have my own Arc; so I am ! renaming their ARC to ARCQQ to avoid conflicts. !GPBtypes !TYPES IMPLICIT NONE INTEGER, PARAMETER :: nPlates = 52, mostInOnePlate = 1500 ! referring to PB2002_plates.dig INTEGER, PARAMETER :: nOrogens = 13, mostInOneOrogen = 600 ! referring to PB2002_orogens.dig CHARACTER*1 :: cE, cN, c1, c1a, eq_tenths, first_byte, quality_c1, s1h_sigma_c1, star CHARACTER*2 :: c2, eq_day, eq_hour, eq_minute, eq_month, eq_second, reference_plate_c2, regime_c2 CHARACTER*3 :: c3, class CHARACTER*4 :: c4 CHARACTER*5 :: c5 CHARACTER*6 :: c6, threshold_magnitude_c6 CHARACTER*8 :: number8 CHARACTER*9 :: c9 CHARACTER*10 :: color_name, string10 CHARACTER*12 :: grid_units, element_scalar_units, & & node_scalar_units CHARACTER*27 :: c27 CHARACTER*50 :: c50 CHARACTER*132 :: boundaries_dig_file, boundaries_dig_pathfile, & & c80a, c80b, continuum_strainrate_file, continuum_strainrate_pathfile, & & grd1_file, grd1_pathfile, grd2_file, grd2_pathfile, & & feg_file, feg_pathfile, & & element_scalar_feg_file, element_scalar_feg_pathfile, & & f_dat, f_dat_pathfile, f_dig, f_dig_pathfile, & & f_nki_file, f_nki_format, f_nki_pathfile, f_nki_titles, & & f_nko_file, f_nko_pathfile, & & gps_file, gps_pathfile, gp2_file, & & heave_segments_file, heave_segments_pathfile, & & input_gps_file, input_gps_pathfile, & & line, & & lines_basemap_file, lines_basemap_pathfile, & & old_eqc_file, old_eqc_pathfile, & & orogens_dig_file, orogens_dig_pathfile, & & parameter_file, parameter_pathfile, & & path_in, path_out, plates_dig_file, plates_dig_pathfile, & & polygons_basemap_file, polygons_basemap_pathfile, & & s1h_file, s1h_pathfile, s1h_format, s_dat, s_dat_pathfile, & & s_nko_file, s_nko_pathfile, steps_dat_file, steps_dat_pathfile, & & temp_path_in, token, traces_file, traces_pathfile, & & vel_file, vel_pathfile, volcano_file, volcano_pathfile, & & x_feg, x_feg_pathfile, x_bcs, x_bcs_pathfile CHARACTER*132 :: bottom_line, bottom_line_memo, f_nko_format, gps_format, top_line, top_line_memo CHARACTER*200 :: appended_data CHARACTER*132, DIMENSION(20) :: titles CHARACTER(LEN=2), DIMENSION(nPlates) :: names CHARACTER(LEN=1), DIMENSION(:), ALLOCATABLE :: f_c1 CHARACTER(LEN=1), DIMENSION(:), ALLOCATABLE :: segment_sense CHARACTER(LEN=3), DIMENSION(:,:), ALLOCATABLE :: bitmap ! array of RGB pixels CHARACTER(LEN=35),DIMENSION(:), ALLOCATABLE :: benchmark_label INTEGER :: age, azim, azimuth_int, & & benchmarks, bitmap_color_mode, bitmap_height, & & bitmap_shading_mode, bitmap_width, & & choice, cracked_element_method, crack_count, & & d_n, dig_title_method, & & element_scalar_method, eq_depth_int, eq_year, & & e1_azimuth, e1_plunge, e2_azimuth, e2_plunge, e3_azimuth, e3_plunge, & & gps_type, & & grd1_ncols, grd1_nrows, & & grd2_ncols, grd2_nrows, & & element_scalar_zeromode, elev, & & f_dig_count, f_highest, fault_count, fixed_node, & & group, & & heave_rate_method, high_trace, & & i, i_high, i1, i2, iele, ios, irow, & & j, jcol, jp, jp1, j1, j2, & & k, kilometers, & & l, l_, label_thinner, last_mosaic_choice, line_count, list_length, & & log_strainrate_method, lp, & & m, m1, m2, ma, mb, minutes, mosaic_count, & & n, n1, n2, na, nb, nfl, n_intersection, n_items_done, n_refine, & & node_scalar_choice, node_scalar_limit, node_scalar_method, & & nonorbiting_node, np1, number_rejected, numel, numnod, & & old_mosaic_count, old_overlay_count, overlay_count, other_plate_ID, & & orogen_ID, & & plate_ID, & & read_status, ref_frame_plate_ID, rotationrate_method, & & s_nki_count, s1h_azim_int, s1h_sigma_int, segment_count, & & skip_lines, step_count, strainrate_mode012, strain_thinner, stress_thinner, & & subdivision, & & title_choice, title_count, & & trace_index, train_length, & & v_az, vector_thinner, velocity_method, velocity_mmpa_int, visible_labels INTEGER, DIMENSION(10) :: mosaic_choice, overlay_choice INTEGER, DIMENSION(nPlates) :: nInEachPlate INTEGER, DIMENSION(nOrogens) :: nInEachOrogen INTEGER, DIMENSION(:), ALLOCATABLE :: f_trace ! holds the fault-trace indeces from the F1234D strings in f_dig INTEGER, DIMENSION(:,:), ALLOCATABLE :: neighbor ! of spherical triangles INTEGER, DIMENSION(:,:), ALLOCATABLE :: nodef ! (6, nfl) or (4, nfl) INTEGER, DIMENSION(:,:), ALLOCATABLE :: nodes ! (6, numel) or (3, numel) INTEGER, DIMENSION(:,:), ALLOCATABLE :: trace_loc ! (2, f_highest) = pointers to beginning & ! end of each fault trace in array "trace" of uvecs LOGICAL :: add_titles, any_cracked, any_FPS, any_titles, azimuth_is_integer, & & bottom, cold_start, & & conservative_geodetic_adjustment, create_global_grid, creeping, & & do_more_mosaics, dig_is_lonlat, do_more_overlays, & & grd1_lonlat, grd1_success, & & grd2_lonlat, grd2_success, & & do_mosaic, do_overlay, & & element_scalar_lowblue, ellipses, & & e1h_partitioned, e2h_partitioned, err_partitioned, & & faults_give_sigma_1h, floating_frame, & & got_index, got_parameters, got_point, grid_lowblue, & & in_ok, in_trace, & & just_began_continuum_strainrate, just_began_total_strainrate, just_began_surface_flow, & & latter_mosaic, log_strainrate_lowblue, lonlat, & & mated, maybe, more_ai, more_eqc, more_dat, more_dig, & & more_feg, more_gps, more_grd, more_info, more_map, more_s_nki, more_s_nko, more_vel, & & node_scalar_lowblue, nseg, & & only_stressed, & & plot_dig_titles, plot_FPS, plot_this, polygons, problem, & & right, rotationrate_lowblue, & & shaded_relief, sigma_is_integer, skip_0_contour, stroke_this, success, suggest_logical, & & using_A_to_E, & & valid_azimuth, valid_FPS, velocity_reframe, velocity_lowblue, virgin, visible, & & xy_defined LOGICAL, DIMENSION(:), ALLOCATABLE :: cracking, selected, s1h_known LOGICAL(1), DIMENSION(:,:), ALLOCATABLE :: bitmap_success, touching !CAUTION about fault dips: !NeoKinema v1.x assumed different dip angles. !Therefore, to exactly reproduce graphics from old NeoKinema v1.x runs, !you will need to change these values and recompile. !If you do so, please also change SUBROUTINE Get_Parameters() !so that it will no longer accept input parameter files in NeoKinema v2.x format. !Finally, label the resulting NeoKineMap.exe to show that it only works with NeoKinema v1.x models! REAL, PARAMETER :: normal_dip_degrees = 55.0 ! consistent with Bird & Kagan [2004] Table 5 value used in Long_Term_Seismicity REAL, PARAMETER :: thrust_dip_degrees = 20.0 ! consistent with Bird & Kagan [2004] Table 5 value used in Long_Term_Seismicity REAL, PARAMETER :: subduction_dip_degrees = 14.0 ! consistent with Bird & Kagan [2004] Table 5 value used in Long_Term_Seismicity REAL, PARAMETER :: bottomlegend_gap_points = 14.0 REAL, PARAMETER :: deg_per_rad = 180.0 / 3.141592654 REAL, PARAMETER :: m_per_km = 1000.0 REAL, PARAMETER :: rad_per_deg = 3.141592654 / 180. REAL, PARAMETER :: rightlegend_gap_points = 14.0 REAL, PARAMETER :: s_per_Ma = 1000000.*365.25*24.*60.*60. REAL, PARAMETER :: sec_per_year = 31557600.0 REAL, PARAMETER :: subdip = 27.5 ! degrees; should match SHELLS value REAL :: A0, above, arc2, arc3, az_radians, aze2, aze3, az1, az2, az3, & & below, benchmark_points, big_diff, bitmap_color_highvalue, bitmap_color_lowvalue, & & bottomlegend_used_points, brightness, & & cot_normal_dip, cot_subduction_dip, cot_thrust_dip, & & covariance_11, covariance_12, covariance_22, & & d0, d1, d12, d23, d31, d_vsize_d_theta, d_vsize_d_phi, del_az_for_90pc, & & dextral, dip_azimuth, dip_degrees, & & divergence, dl2, dl3, ds2, ds3, dv_scale_mma, dv_scale_points, & & E_error_mmpa, eh_max, element_scalar_interval, element_scalar_midvalue, & & epicenter_x_m, epicenter_x_points, epicenter_y_m, epicenter_y_points, & & eq_Elon, eq_mag, eq_Nlat, EQs_per_s, EQs_per_century, & & equat, err, Euler_rate_radspMa, e1_size_points, & & e1, e1_lat, e1_lon, e1h, e2, e2_lat, e2_lon, e2h, e3_lat, e3_lon, & & f_azim_rads_c, fin, fout, fx1, fx2, fy1, fy2, & & geodesy_weight, & & 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, & & grid_interval, grid_midvalue, & & h_high, & & inner, intensity, & & L0, large_circle_radius_points, largest_ei_persec, lat, lat1, lat2, lat3, latitude, leg, & & locking_depth_m_max, locking_depth_m_min, locking_depth_m_subduction_max, locking_depth_m_subduction_min, & & log_strainrate_interval, log_strainrate_midvalue, & & lon, lon1, lon2, lon3, long, longitude, lr_fraction, & & maximum, minimum, min_mag, m8_diam_points, model_heave_rate_mmpa, mu_, & & N_error_mmpa, node_radius_points, node_radius_radians, & & node_scalar_interval, node_scalar_midvalue, normal_dip_radians, North_argument_radians, & & offset_radians, offset_x_m, offset_x_points, offset_y_m, offset_y_points, & & outer, & & R, rad, radians, radians_per_point, radius, radius_points, & & reference_Elon_deg, reference_Nlat_deg, & & reference_vE_mmpa, reference_vN_mmpa, reference_ccw_degpMa, & & ref_e3_minus_e1_persec, rel_az2, rel_az3, & & rightlegend_used_points, RMS_slope, & & rotationrate, rotationrate_interval, rotationrate_midvalue, & & s1, s2, s3, s1_size_points, s1h_interp_points, sigma_offnormal_degrees, & & sliprate1, slope, small_circle_radius_points, spread, start_azimuth, & & strainrate_diameter_points, sum, strict_maximum, strict_minimum, s1h_azim_degrees, & & s1h_sigma_degrees, s1h_azim_radians, step_points, strike_azimuth, & & subduction_dip_radians, sup_slipnumber, & & t, t1, t2, t3, & & test_mma, theta_, tick_azimuth, tick_points, thrust_dip_radians, & & u1theta, u1phi, u1x, u1y, u2theta, u2phi, u2x, u2y, ud_fraction, & & v_East_mps, v_error_mmpa, v_mma, v_mps, v_South_mps, & & vE_mmpa, v1E, v1E_mma, v2E, v2E_mma, v3E, v3E_mma, & & vN_mmpa, v1S, v1S_mma, v2S, v2S_mma, v3S, v3S_mma, value, & & veloc, velocity_Ma, velocity_interval, velocity_midvalue, velocity_mmpa, & & volcano_Elon, volcano_Nlat, volcano_points, vsize, & & width_points, width_radians, & & x_meters, x_used_points, & & xcp, xi_, xp, xps, xpt, x0p, x_points, x1p, x1_points, x2_points, x2p, x3p, & & y_meters, y_points, y_used_points, ycp, yp, ypt, y0p, y1_points, y1p, y2_points, y2p, y3p REAL, DIMENSION(3) :: cross_uvec, & & e1_b_uvec, e1_f_uvec, e2_b_uvec, e2_f_uvec, e3_b_uvec, e3_f_uvec, Euler, & & omega_uvec, orthogonal_uvec, & & phi_uvec, pole_uvec, pole_a_uvec, pole_b_uvec, & & result_uvec, & & strike_uvec, & & theta_uvec, tvec, turn_1_uvec, turn_2_uvec, turn_3_uvec, turn_4_uvec, & & uvec, uvec1, uvec2, uvec3, uvec4, & & vsize_estimates REAL, DIMENSION(3) :: eps_dot REAL, DIMENSION(3,2,2,2):: dG REAL, DIMENSION(3,2,2) :: G REAL, DIMENSION(3,7) :: Gauss_point REAL, DIMENSION(3, nPlates) :: omega REAL, DIMENSION(:), ALLOCATABLE :: a_ ! plane areas (R == 1.0) of spherical elements REAL, DIMENSION(:), ALLOCATABLE :: benchmark_N_velocity, & & benchmark_N_sigma, & & benchmark_E_velocity, & & benchmark_E_sigma, & & benchmark_correlation, & & benchmark_hypotenuse, & & benchmark_error_sigmas, & & benchmark_Elon_deg, & & benchmark_Nlat_deg REAL, DIMENSION(:,:),ALLOCATABLE :: benchmark_uvec REAL, DIMENSION(:,:),ALLOCATABLE :: bitmap_value REAL, DIMENSION(:,:),ALLOCATABLE :: center ! uvecs of spherical elements REAL, DIMENSION(:), ALLOCATABLE :: e3_minus_e1_persec REAL, DIMENSION(:), ALLOCATABLE :: element_scalar REAL, DIMENSION(:), ALLOCATABLE :: f_rate_mmpa REAL, DIMENSION(:,:),ALLOCATABLE :: fdip REAL, DIMENSION(:,:),ALLOCATABLE :: grid1, grid2 REAL, DIMENSION(:), ALLOCATABLE :: heave_rate_mmpa REAL, DIMENSION(:), ALLOCATABLE :: log_largest_ei_persec REAL, DIMENSION(:), ALLOCATABLE :: omega_degperMa ! (numel) REAL, DIMENSION(:), ALLOCATABLE :: node_scalar REAL, DIMENSION(:,:),ALLOCATABLE :: node_uvec REAL, DIMENSION(:,:,:),ALLOCATABLE :: orogen_uvecs REAL, DIMENSION(:,:,:),ALLOCATABLE :: plate_uvecs REAL, DIMENSION(:,:),ALLOCATABLE :: plot_at_uvec REAL, DIMENSION(:), ALLOCATABLE :: s_azim REAL, DIMENSION(:), ALLOCATABLE :: s_sigma_ REAL, DIMENSION(:,:),ALLOCATABLE :: s_site REAL, DIMENSION(:,:,:),ALLOCATABLE :: segments REAL, DIMENSION(:,:,:),ALLOCATABLE :: segment_uvecs REAL, DIMENSION(:,:),ALLOCATABLE :: slipnumbers ! 2 components used in steps.dat overlay REAL, DIMENSION(:,:,:),ALLOCATABLE :: strainrate ! (3,7,numel) REAL, DIMENSION(:,:), ALLOCATABLE :: trace ! list of all uvecs encountered in f_dig REAL, DIMENSION(:), ALLOCATABLE :: trace_mma REAL, DIMENSION(:), ALLOCATABLE :: train REAL, DIMENSION(:), ALLOCATABLE :: up_azim_rads REAL, DIMENSION(:,:),ALLOCATABLE :: uvec_list REAL, DIMENSION(:), ALLOCATABLE :: vsize_mma REAL, DIMENSION(:), ALLOCATABLE :: vw TYPE :: cracklike ! Warning: Not the same as TYPE crack in NeoKinema! CHARACTER*1 :: sense ! fault-type: R, L, N, D, T, P REAL :: heave_rate_mps ! heave-rate, in meters/second (SI); almost always positive REAL, DIMENSION(3) :: uvec1 ! unit vector with Cartesian location of start point REAL, DIMENSION(3) :: uvec2 ! unit vector with Cartesian location of end point INTEGER :: iele ! element number END TYPE cracklike TYPE(cracklike), DIMENSION(:), ALLOCATABLE :: cracks ! info needed reconstruct velocity field with discontinuities !================== DATA statements ======================= DATA Gauss_point / & & 0.3333333333333333E0, 0.3333333333333333E0, 0.3333333333333333E0, & & 0.0597158733333333E0, 0.4701420633333333E0, 0.4701420633333333E0, & & 0.4701420633333333E0, 0.0597158733333333E0, 0.4701420633333333E0, & & 0.4701420633333333E0, 0.4701420633333333E0, 0.0597158733333333E0, & & 0.7974269866666667E0, 0.1012865066666667E0, 0.1012865066666667E0, & & 0.1012865066666667E0, 0.7974269866666667E0, 0.1012865066666667E0, & & 0.1012865066666667E0, 0.1012865066666667E0, 0.7974269866666667E0/ ! plate names (in alphabetical order): DATA names / 'AF','AM','AN', & ! 1, 2, 3 & 'AP','AR','AS', & ! 4, 5, 6 & 'AT','AU','BH', & ! 7, 8, 9 & 'BR','BS','BU', & ! 10, 11, 12 & 'CA','CL','CO', & ! 13, 14, 15 & 'CR','EA','EU', & ! 16, 17, 18 & 'FT','GP','IN', & ! 19, 20, 21 & 'JF','JZ','KE', & ! 22, 23, 24 & 'MA','MN','MO', & ! 25, 26, 27 & 'MS','NA','NB', & ! 28, 29, 30 & 'ND','NH','NI', & ! 31, 32, 33 & 'NZ','OK','ON', & ! 34, 35, 36 & 'PA','PM','PS', & ! 37, 38, 39 & 'RI','SA','SB', & ! 40, 41, 42 & 'SC','SL','SO', & ! 43, 44, 45 & 'SS','SU','SW', & ! 46, 47, 48 & 'TI','TO','WL', & ! 49, 50, 51 & 'YA' / ! 52 ! Following rotation vectors in Cartesian (x,y,z) components, ! with units of radians per million years (per DeMets et al., 1990, ! Table 1, * 0,9562 [DeMets et al., 1994] and other rotations estimated for PB2002): DATA ((omega(i, j),i = 1, 3), j = 1, nPlates) / & ! following lines come from PB2002_omega.xls: & 0.002401, -0.00793, 0.013891, & ! 1 & 0.000949, -0.00864, 0.013725, & ! 2 & 0.000689, -0.00654, 0.013676, & ! 3 & 0.002042, -0.01315, 0.008856, & ! 4 & 0.008570, -0.00560, 0.017497, & ! 5 & 0.000148, -0.00307, 0.010915, & ! 6 & 0.015696, 0.002467, 0.023809, & ! 7 & 0.009349, 0.000284, 0.016253, & ! 8 & 0.000184, 0.005157, 0.001150, & ! 9 & -0.00087, -0.00226, 0.002507, & ! 10 & -0.01912, 0.030087, 0.010227, & ! 11 & 0.011506, -0.04452, 0.007197, & ! 12 & 0.001688, -0.00904, 0.012815, & ! 13 & 0.003716, -0.00379, 0.000949, & ! 14 & -0.00891, -0.02644, 0.020895, & ! 15 & -0.06117, 0.005216, -0.01375, & ! 16 & 0.070136, 0.160534, 0.094328, & ! 17 & 0.000529, -0.00723, 0.013123, & ! 18 & -0.08325, -0.00246, -0.01492, & ! 19 & 0.016256, 0.089364, 0.015035, & ! 20 & 0.008181, -0.00480, 0.016760, & ! 21 & 0.006512, 0.003176, 0.005073, & ! 22 & 0.108013, 0.299461, 0.230528, & ! 23 & 0.033318, -0.00181, 0.036441, & ! 24 & -0.01383, 0.008245, 0.015432, & ! 25 & -0.77784, 0.440872, -0.04743, & ! 26 & 0.001521, 0.007739, 0.013437, & ! 27 & 0.038223, -0.05829, 0.013679, & ! 28 & 0.001768, -0.00843, 0.009817, & ! 29 & -0.00433, 0.003769, -0.00040, & ! 30 & 0.000111, -0.00636, 0.010449, & ! 31 & 0.044913, -0.00954, 0.010601, & ! 32 & -0.05534, -0.01089, 0.006794, & ! 33 & -0.00002, -0.01341, 0.019579, & ! 34 & 0.001041, -0.00830, 0.012143, & ! 35 & -0.02622, 0.020184, 0.037208, & ! 36 & 0.000000, 0.000000, 0.000000, & ! 37 & -0.00004, -0.00929, 0.012815, & ! 38 & 0.012165, -0.01251, -0.00036, & ! 39 & -0.01918, -0.07060, 0.036797, & ! 40 & 0.000472, -0.00635, 0.009100, & ! 41 & 0.121443, -0.07883, 0.027122, & ! 42 & 0.001117, -0.00743, 0.008534, & ! 43 & -0.00083, -0.00670, 0.013323, & ! 44 & 0.001287, -0.00875, 0.014603, & ! 45 & -0.01719, 0.017186, 0.008623, & ! 46 & 0.003201, -0.01044, 0.015854, & ! 47 & 0.023380, -0.01936, -0.01046, & ! 48 & -0.00940, 0.023063, 0.008831, & ! 49 & 0.142118, 0.005616, 0.078214, & ! 50 & -0.01683, 0.018478, 0.010166, & ! 51 & -0.00083, -0.00616, 0.016274/ ! 52 !========================================================== normal_dip_radians = normal_dip_degrees * radians_per_degree thrust_dip_radians = thrust_dip_degrees * radians_per_degree subduction_dip_radians = subduction_dip_degrees * radians_per_degree cot_normal_dip = 1.0 / TAN(normal_dip_radians) cot_thrust_dip = 1.0 / TAN(thrust_dip_radians) cot_subduction_dip = 1.0 / TAN(subduction_dip_radians) !GPBgo WRITE (*,"(//' -----------------------------------------------------------------'& &//' NeoKineMap'& &//' This is the graphics post-processor for program NeoKinema'& &/' (Neotectonic Kinematics finite-element program) which plots'& &/' present velocities and strain-rates of the lithosphere,'& &/' fault heave-rates, principal stress and strain-rate axes,'& &/' geodetic velocities of benchmarks, earthquakes, et cetera.'& &//' by Peter Bird, UCLA, 10 March 2010'& &/' (works with versions 1.1-1.4 & 2.0-2.4 of NeoKinema)'& &/' -----------------------------------------------------------------')") CALL Prompt_for_Logical('Do you want to read what kind of input is supported?',.FALSE.,more_info) IF (more_info) THEN WRITE (*,"(//' -----------------------------------------------------------------------'& &/' INPUT files may include:'& &/' -> AI7frame.ai (model .ai file; always required);'& &/' -> *.dig files (digitised basemaps);'& &/' -> *.grd files (gridded data files);'& &/' -> *.feg files (finite element grid);'& &/' -> p*.nki files (parameter set input to NeoKinema);'& &/' -> f*.nki files (fault offset-rate data input to NeoKinema);'& &/' -> f*.dig files (fault traces input to NeoKinema);'& &/' -> s*.nki files (stress data input to NeoKinema);'& &/' -> s*.nko files (interpolated stresses, from NeoKinema);'& &/' -> v*.out files (velocities of nodes, from NeoKinema);'& &/' -> *.gps files (geodetic velocity files-input to NeoKinema);'& &/' -> g*.nko files (geodetic velocities reframed by NeoKinema);'& &/' -> *.eqc files (earthquake catalog files);'& &/' -> *.dat files (volcanoes or other important sites).'& &/' ------------------------------------------------------------------------')") END IF CALL Prompt_for_Logical('Do you want to read about the output which is produced?',.FALSE.,more_info) IF (more_info) THEN WRITE (*,"(///' -----------------------------------------------------------------------'& &/' OUTPUT FILES ARE MAPS OF NEOTECTONICS,'& &/' in a choice of 10 different map projections.'& &/' They have .ai extensions and are intended to be read by Adobe'& &/' Illustrator 7+ for Windows XP, 2000, Me, NT, 98, 95, or MacOS; 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.'& &/' -----------------------------------------------------------------------')") END IF CALL Prompt_for_Logical('Do you want detailed information about input and output files?',.FALSE.,more_info) IF (more_info) THEN CALL Prompt_for_Logical('Do you want information about Digitiser (*.dig) files?',.TRUE.,more_dig) IF (more_dig) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Digitiser (*.dig) Files'& &/' A .dig file is created to contain digitized straight lines and/or'& &/' crooked ""segments"", such as coast lines, state lines, or fault traces.'& &/' 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 line 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 Prompt_for_Logical('Do you want more information about Digitised (*.dig) files?',.TRUE.,more_dig) IF (more_dig) THEN WRITE (*,"(//' ----------------------------------------------------------------------'& &/' More About Digitiser (*.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,ES12.5,'','',ES12.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.'& &/' ----------------------------------------------------------------------')") END IF ! more_dig CALL Prompt_for_Logical('Do you want information about Gridded Data (*.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,'& &/' either in (x,y) or (lon,lat) space.'& &//' The first line has 3 numbers: x_min, d_x, x_max (lon_min, d_lon, lon_max);'& &/' the 2nd also has 3 numbers: y_min, d_y, y_max (lat_min, d_lat, lat_max).'& &/' Following lines give the gridded data in text order, i.e., beginning'& &/' with the top left corner, going L->R along the top row, then L->R '& &/' 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 Prompt_for_Logical('Do you want information about Finite Element Grid (*.feg) files?',.TRUE.,more_feg) IF (more_feg) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Finite Element Grid (*.feg) Files'& &//' Finite element grids used here must be of the spherical-Earth type.'& &/' Spherical-Earth grids used with NeoKinema are produced by OrbWeaver'& &/' and have 3-node spherical triangles (but no fault elements).'& &//' ----------------------------------------------------------------------')") END IF ! more_feg CALL Prompt_for_Logical('Do you want information about Stress input (s*.nki) files?',.TRUE.,more_s_nki) IF (more_s_nki) THEN WRITE (*, "(' -------------------------------------------------------------------------------'& &/' About Stress-direction input (s*.nki) Files'& &//' There should be exactly 2 header lines before the data begin.' & &/' The first header should be a FORMAT for reading the file.' & &/' The second header might be column labels, if you like.' & &/' There must be (at least) 6 columns in the file, in this order:'& &//' text_string_1 text_string_2 longitude latitude azimuth uncertainty/quality'& &//' Longitude and latitude must be real numbers (F, E, or D format);'& &/' use decimal degrees, with North and East treated as positive.'& &/' Azimuth is in degrees clockwise from North, either in integer (I)'& &/' or real (F/E/D) format.'& &/' Uncertainty/quality can be in integer (I), real (F/E/D), or character (A)'& &/' format. If it is in A format, use letter grades of A, B, C, D, E.'& &/' -------------------------------------------------------------------------------')") END IF CALL Prompt_for_Logical('Do you want information about Stress OUTPUT (s*.nko) files?',.TRUE.,more_s_nko) IF (more_s_nko) THEN WRITE (*, "(' -------------------------------------------------------------------------------'& &/' About Stress-direction Output (s*.nko) Files'& &//' These are created by NeoKinema, to record the stress directions' & &/' interpolated at each element center, for plotting by NeoKineMap.' & &/' There are 4 columns in the file, in this order:'& &//' element_number successful_interpolation? azimuth standard_deviation'& &//' Element numbers refer to the .feg file used in the run of NeoKinema.'& &/' Successful_interpolation is a logical value (T/F).'& &/' Azimuth is in degrees clockwise from North.'& &/' Standard deviation (sigma) is also in degrees.'& &/' -------------------------------------------------------------------------------')") END IF CALL Prompt_for_Logical('Do you want information about Velocity output (v*.out) files?',.TRUE.,more_vel) IF (more_vel) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Velocity output(v*.out) Files'& &//' These files contain velocities of nodes. The first 3 lines'& &/' are titles describing the computational experiment.'& &//' Later lines contain the velocity components:'& &/' v_theta (South) and v_phi (East), in meters/second.'& &//' ----------------------------------------------------------------------')") END IF ! more_vel CALL Prompt_for_Logical('Do you want information about .gps and g*.nko files?',.TRUE.,more_gps) IF (more_gps) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Geodetic-Velocity (.gps and g*.nko) Files:'& &/' First header line gives file name and source of data.'& &/' Second header line is a FORMAT enclosed in () for reading.'& &/' Third header line labels the columns of data to follow:'& &/' E_lon_deg N_lat_deg v_E_mmpa v_N_mmpa v_E_sigma v_N_sigma correl...'& &/' Then follows one line per geodetic benchmark, containing:'& &/' E_lon_deg = longitude, in degrees, with East positive'& &/' N_lat_deg = latitude, in degrees, with North positive'& &/' v_E_mmpa = velocity to East, in millimeters per year'& &/' v_N_mmpa = velocity to North, in millimeters per year'& &/' v_E_sigma = standard deviation of v_E_mmpa, also in mm/a'& &/' v_N_sigma = standard deviation of v_N_mmpa, also in mm/a'& &/' correlation = correlation between v_E_mmpa and v_N_mmpa'& &/' reference_frame = left-justified, limited to 15 bytes [not used]'& &/' identifier(s) = [optional] station name and/or source reference'& &/' [ A g*.nko output file differs from a .gps input file only in its'& &/' reference frame, which is reset by NeoKinema.]'& &/' ----------------------------------------------------------------------')") END IF ! more_gps CALL Prompt_for_Logical('Do you want information about EarthQuake Catalog (*.eqc) files?',.TRUE.,more_eqc) IF (more_eqc) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About EarthQuake Catalog (*.eqc) Files'& &//' These files contain epicenters with date, time, location,'& &/' depth, and magnitude for each.'& &//' Optionally, principal strain axes may be appended, permitting'& &/' the plotting of fault-plane-solutions'& &/' (technically, only the double-couple part of the moment tensor).'& &/' These files are produced by program Seismicity.'& &//' ----------------------------------------------------------------------')") END IF ! more_eqc CALL Prompt_for_Logical('Do you want information about Datum (*.dat) files?',.TRUE.,more_dat) IF (more_dat) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Volcano (or other site) Datum (*.dat) Files'& &//' These files contain locations (and possibly other data)'& &/' expressed with one line per site.'& &/' Each line must include:'& &/' Latitude, N/S, Longitude, E/W'& &/' which can be read with:'& &/' FORMAT(61X,F6.3,1X,A1,1X,F7.3,1X,A1)'& &/' NeoKineMap will plot a solid triangle to mark the location(s).'& &//' ----------------------------------------------------------------------')") END IF ! more_dat CALL Prompt_for_Logical('Do you want information about Adobe Illustrator (*.ai) files?',.TRUE.,more_ai) IF (more_ai) THEN WRITE (*,& &"(//' ------------------------------------------------------------------------'& &/' About Adobe Illustrator (*.ai) Files'& &//' The .ai files created by this program can be read by:'& &/' * Adobe Illustrator 7+ for Windows XP, 2000, NT, 98, 95, or MacOS; or'& &/' * Adobe Illustrator 4 for Windows 3.1'& &/' (except that AI4 cannot handle colored/shaded 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'& &/' (or AI4Frame.ai, if you have to use Adobe Illustrator 4)'& &/' 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 Prompt_for_Logical('Do you want 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.'& &//' ----------------------------------------------------------------------')") CALL Press_Enter END IF ! more_map END IF ! more_info !-------------------------(end of Introduction)---------------------- ! ! Basic structure of NeoKineMap is similar to Prompter of Map_Tools: ! (1) Look for memory file NeoKineMap.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 Prompter 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 Prompter, NeoKineMap executes ! these requests immediately, so that error messages ! will be more understandable. ! (5) After closing the plot, save MapTools.ini and NeoKineMap.ini ! to record all the selections made. (MapTools.ini has page ! formatting and map projection; NeoKineMap.ini records the ! actual content of the map. ! !-------------------------------------------------------------------- !GPBmemory OPEN (UNIT = 11, FILE = 'NeoKineMap.ini', STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios == 0) THEN ! NeoKineMap.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, *,IOSTAT=ios) plot_dig_titles problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) dig_title_method 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) 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) parameter_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) plates_dig_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) velocity_reframe problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) cracked_element_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) fixed_node problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) nonorbiting_node problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) reference_Elon_deg problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) reference_Nlat_deg problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) reference_vE_mmpa problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) reference_vN_mmpa problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) reference_ccw_degpMa 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, *,IOSTAT=ios) log_strainrate_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) log_strainrate_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) log_strainrate_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) log_strainrate_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotationrate_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotationrate_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotationrate_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotationrate_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, *,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) traces_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) f_nko_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) heave_segments_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) vel_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) gps_type problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) gps_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) benchmark_points problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) velocity_Ma problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) vector_thinner problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) heave_rate_method 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) 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) e1_size_points problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) stress_thinner problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) s1_size_points problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) s1h_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) s1h_interp_points problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) only_stressed problem = problem.OR.(ios /= 0) READ (11,"(A)") old_eqc_file problem = problem.OR.(ios /= 0) READ (11,*) plot_FPS problem = problem.OR.(ios /= 0) READ (11,*) min_mag problem = problem.OR.(ios /= 0) READ (11,*) m8_diam_points problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) volcano_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) volcano_points problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) boundaries_dig_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) plates_dig_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) orogens_dig_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) steps_dat_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) ref_frame_plate_ID problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) subdivision problem = problem.OR.(ios /= 0) !GPBread READ (11, *,IOSTAT=ios) minutes problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) kilometers 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 NeoKineMap.ini.')") WRITE (*,"( ' The easiest way to recover from this is to:')") WRITE (*,"( ' (1) Print out NeoKineMap.ini')") WRITE (*,"( ' (2) Delete NeoKineMap.ini')") WRITE (*,"( ' (3) Restart NeoKineMap, and enter your choices manually.')") CALL Press_Enter 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 = ' ' plot_dig_titles = .FALSE. dig_title_method = 1 grd1_file = ' ' grd2_file = ' ' bitmap_color_mode = 1 shaded_relief = .FALSE. bitmap_shading_mode = 1 intensity = 1.0 grid_units = 'm' grid_interval = 0. grid_midvalue = 0. grid_lowblue = .TRUE. skip_0_contour = .FALSE. element_scalar_method = 2 element_scalar_feg_file = ' ' element_scalar_units = ' ' element_scalar_interval = 0. element_scalar_midvalue = 0. element_scalar_lowblue = .TRUE. element_scalar_zeromode = 0 feg_file = ' ' node_scalar_method = 2 node_scalar_choice = 1 node_scalar_units = ' ' node_scalar_interval = 0. node_scalar_midvalue = 0. node_scalar_lowblue = .TRUE. parameter_file = ' ' plates_dig_file = 'PB1999_plates.dig' velocity_reframe = .FALSE. cracked_element_method = 2 fixed_node = 1 nonorbiting_node = 2 reference_Elon_deg = 0. reference_Nlat_deg = 0. reference_vE_mmpa = 0. reference_vN_mmpa = 0. reference_ccw_degpMa = 0. velocity_method = 2 velocity_interval = 0. velocity_midvalue = 0. velocity_lowblue = .TRUE. log_strainrate_method = 2 log_strainrate_interval = 1.0 log_strainrate_midvalue = 0.0 log_strainrate_lowblue = .TRUE. rotationrate_method = 2 rotationrate_interval = 1.0 rotationrate_midvalue = 0.0 rotationrate_lowblue = .TRUE. old_overlay_count = 1 overlay_choice = 0 ! whole array overlay_choice(1) = 1 lines_basemap_file = ' ' tick_points = 6.0 node_radius_points = 0.0 traces_file = ' ' f_nko_file = ' ' heave_segments_file = ' ' vel_file = ' ' gps_type = 1 gps_file = ' ' benchmark_points = 7.0 velocity_Ma = 10.0 vector_thinner = 1 heave_rate_method = 1 dv_scale_mma = 50.0 dv_scale_points = 25.0 R = 6371000. strainrate_mode012 = 2 ref_e3_minus_e1_persec = 5.E-17 strainrate_diameter_points = 20.0 strain_thinner = 1 e1_size_points = 24.0 stress_thinner = 1 s1_size_points = 24.0 s1h_file = ' ' s1h_interp_points = 20.0 only_stressed = .FALSE. old_eqc_file = ' ' plot_FPS = .TRUE. min_mag = 4.4 m8_diam_points = 28.0 volcano_file = "Volcanoes.dat" volcano_points = 7.0 boundaries_dig_file = "PB2002_boundaries.dig" plates_dig_file = "PB2002_plates.dig" orogens_dig_file = "PB2002_orogens.dig" steps_dat_file = "PB2002_steps.dat" ref_frame_plate_ID = 28 subdivision = 4 label_thinner = 1 minutes = 120 kilometers = 100 top_line_memo = ' ' bottom_line_memo = ' ' END IF ! .ini file, or defaults? !-------------------------(Define Paths)----------------------------- WRITE (*,"(//' ----------------------------------------------------------------------'& &/' Setting PATHS to Input and Output Files'& &//' NeoKineMap stores its memory in NeoKineMap.ini and Map_Tools.ini,'& &/' which are placed in the current directory when NeoKineMap is run.'& &/' Normally, this should be the directory holding NeoKineMap.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; e.g.,'& &/' In Windows, paths should end in ''\''.'& &/' In Unix, paths should end in ''/''.'& &//' PLEASE TYPE PATH NAMES CAREFULLY; there is no way to validate or'& &/' correct them using standard Fortran 90; any errors may crash'& &/' NeoKineMap!'& &/' ----------------------------------------------------------------------')") CALL Prompt_for_String('What is the path for your input files?',path_in,path_in) path_in = ADJUSTL(path_in) CALL Prompt_for_String('What is the path for your output (.ai graphics) file?',path_out,path_out) path_out = ADJUSTL(path_out) WRITE (*,"(' IT WILL NOT BE NECESSARY TO TYPE THESE PATHS AGAIN!')") !-------------------------(end of defining paths)-------------------- CALL Prompter (xy_mode = .TRUE., lonlat_mode = .TRUE., path_out = path_out, & & xy_defined = xy_defined) ! output; reports whether user set (x,y) system !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 title_count = 0 ! collects possible titles from input files bottomlegend_used_points = 0. ! records filling of bottom legend, from left rightlegend_used_points = 0. ! records filling of right legend, from top latter_mosaic = .FALSE. ! for first pass; will be set .TRUE. below 1000 just_began_surface_flow = .FALSE. just_began_total_strainrate = .FALSE. just_began_continuum_strainrate = .FALSE. WRITE (*,"(//' -------------------------------------------------------------------------------')") IF (ai_using_color) THEN WRITE (*,"(' MOSAIC (colored-area) LAYERS AVAILABLE:')") ELSE WRITE (*,"(' MOSAIC (patterned-area) LAYERS AVAILABLE:')") END IF !GPBmosaics WRITE (*,"(' 1 :: digitised basemap (polygons type)')") IF (ai_using_color) THEN WRITE (*,"(' 2 :: colored/shaded bitmap from gridded dataset(s)')") ELSE WRITE (*,"(' 2 :: shaded-relief grey-scale bitmap from gridded dataset')") END IF WRITE (*,"(' 3 :: contour map from gridded dataset')") WRITE (*,"(' 4 :: discontinuous scalar (one value per element, if any)')") WRITE (*,"(' 5 :: nodal data (if any)')") WRITE (*,"(' 6 :: magnitude of long-term-average velocity')") WRITE (*,"(' 7 :: total long-term-average strain-rate, including any faulting')") WRITE (*,"(' 8 :: total long-term rotation rate, including faulting, about vertical axis')") WRITE (*,"(' 9 :: continuum long-term-average strain-rate, excluding faulting')") WRITE (*,"(' 10 :: logarithm of seismicity rate, from a Long_Term_Seismicity .grd file')") WRITE (*,"(' 11 :: magnitude of short-term interseismic velocity')") WRITE (*,"(' 12 :: short-term interseismic strain-rate (largely, but not all, elastic)')") WRITE (*,"(' -------------------------------------------------------------------------------')") suggest_logical = old_mosaic_count > mosaic_count IF (mosaic_count == 0) CALL Prompt_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 Prompt_for_Integer('Which mosaic type should be added?',choice,choice) IF ((choice < 1).OR.(choice > 12)) THEN WRITE (*,"(/' ERROR: Please select an integer from the list!')") CALL Press_Enter mt_flashby = .FALSE. GO TO 1000 ! mosaics menu 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( file_type = "*.dig", & & suggested_file = polygons_basemap_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file should be plotted?',polygons_basemap_file,polygons_basemap_file) polygons_basemap_pathfile = TRIM(temp_path_in)//TRIM(polygons_basemap_file) CALL Dig_Type (polygons_basemap_pathfile, 21, dig_is_lonlat, any_titles) CALL Prompt_for_Logical('Are these polygons written in (lon,lat) coordinates?',dig_is_lonlat,dig_is_lonlat) IF ((.NOT.xy_defined).AND.(.NOT.dig_is_lonlat)) THEN WRITE (*,"(' ERROR: Start NeoKineMap over again and define the (x,y) coordinates.')") CALL Press_Enter STOP ' ' END IF IF (any_titles) THEN WRITE (*, "(/' Title lines were detected in this .dig file;')") CALL Prompt_for_Logical('do you want to include these titles in the plot?',plot_dig_titles,plot_dig_titles) IF (plot_dig_titles) THEN WRITE (*,"(' -------------------------------------------------')") WRITE (*,"(' Choose Alignment Method for Titles:')") WRITE (*,"(' 1: upright, at geometric center of polyline')") WRITE (*,"(' 2: parallel to first segment of polyline')") WRITE (*,"(' -------------------------------------------------')") 1011 CALL Prompt_for_Integer('Which alignment method?',dig_title_method,dig_title_method) IF ((dig_title_method < 1).OR.(dig_title_method > 2)) THEN WRITE (*,"(' ERROR: Illegal choice of method.')") mt_flashby = .FALSE. GO TO 1011 END IF ! bad choice END IF ! plot_dig_titles END IF ! any_titles WRITE (*,"(/' Working on basemap....')") ! gray rectangle for seas goes behind all continental polygons CALL Set_Fill_or_Pattern (.FALSE., 'gray______') CALL New_L12_Path (1, ai_window_x1_points, ai_window_y1_points) CALL Line_To_L12 (ai_window_x2_points, ai_window_y1_points) CALL Line_To_L12 (ai_window_x2_points, ai_window_y2_points) CALL Line_To_L12 (ai_window_x1_points, ai_window_y2_points) CALL Line_To_L12 (ai_window_x1_points, ai_window_y1_points) CALL End_L12_Path (close = .TRUE., stroke = .FALSE., & & fill = .TRUE.) ! continental polygons are foreground line, background fill CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) CALL Set_Stroke_Color (color_name = 'foreground') CALL Set_Fill_or_Pattern (.FALSE., 'background') polygons = .TRUE. IF (dig_is_lonlat) THEN CALL Plot_Dig (7, polygons_basemap_pathfile, polygons, 21, in_ok) ELSE CALL Plot_Dig (3, polygons_basemap_pathfile, polygons, 21, in_ok) END IF IF (.NOT.in_ok) THEN mt_flashby = .FALSE. GO TO 1010 END IF IF (any_titles .AND. plot_dig_titles) THEN CALL Set_Fill_or_Pattern (.FALSE., 'foreground') IF (dig_is_lonlat) THEN CALL Plot_Dig (7, polygons_basemap_pathfile, polygons, 21, in_ok, dig_title_method) ELSE CALL Plot_Dig (3, polygons_basemap_pathfile, polygons, 21, in_ok, dig_title_method) END IF END IF ! any_titles .AND. plot_dig_titles 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') IF (ios /= 0) CALL Could_Not_Find_File(polygons_basemap_pathfile) 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, 10) ! colored/shaded bitmap from gridded dataset(s); ! CASE(10) is a .grd file from Long_Term_Seismicity, which is displayed ! after taking the base-10 logarithms of all the values. IF (ai_using_color) THEN CALL Prompt_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 Prompt_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')") mt_flashby = .FALSE. GO TO 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( file_type = "*.grd", & & suggested_file = grd1_file, & & using_path = temp_path_in) IF (bitmap_shading_mode == 1) THEN CALL Prompt_for_String('Which file should be displayed?',grd1_file,grd1_file) grd2_file = grd1_file ELSE ! bitmap_shading_mode = 2; two .grd files CALL Prompt_for_String('Which file will determine the colors?',grd1_file,grd1_file) CALL Prompt_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 (ios /= 0) CALL Could_Not_Find_File(grd1_pathfile) 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) OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) CALL Could_Not_Find_File(grd1_pathfile) READ (21, *, IOSTAT = ios) grd1_lon_min, grd1_d_lon, grd1_lon_max READ (21, *, IOSTAT = ios) grd1_lat_min, grd1_d_lat, grd1_lat_max CLOSE (21) grd1_lonlat = (ABS(grd1_lat_min)<91.).AND.(ABS(grd1_lat_max)<91.) CALL Prompt_for_Logical('Is this grid defined in (lon,lat) coordinates?',grd1_lonlat,grd1_lonlat) IF ((.NOT.xy_defined).AND.(.NOT.grd1_lonlat)) THEN WRITE (*,"(' ERROR: Start NeoKineMap over again and define the (x,y) coordinates.')") CALL Press_Enter STOP ' ' END IF 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.0) < 0.01) THEN grd1_lon_range = 360.0 ELSE grd1_lon_range = Easting(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) IF (choice == 10) THEN ! read 2 additional lines with integrals of seismicity READ (21, *, IOSTAT = ios) problem = problem .OR. (ios /= 0) READ (21, "(ES11.4,17X,ES11.4)", IOSTAT = ios) EQs_per_s, EQs_per_century problem = problem .OR. (ios /= 0) END IF CLOSE (21) IF (problem) THEN WRITE (*,"(' ERROR: ',A' defective in structure or truncated.')") TRIM(grd1_file) CALL Press_Enter DEALLOCATE ( grid1 ) mt_flashby = .FALSE. GO TO 1021 END IF CALL Add_Title(grd1_file) IF (choice == 10) THEN !re-open file to get threshold magnitude from first line OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios) READ (21, "(106X,A6)", IOSTAT = ios) threshold_magnitude_c6 CLOSE (21) IF (ios /= 0) THEN WRITE (*, "(' ERROR: Threshold_magnitude could not be read from bytes 107-112' & & /' of the first line of this .grd file.')") CALL Pause() threshold_magnitude_c6 = "??????" END IF CALL Add_Title("Log10( Seismicity Rate ) above magnitude "//threshold_magnitude_c6) DO i = 1, grd1_nrows DO j = 1, grd1_ncols IF (grid1(i, j) > 0.0) THEN grid1(i, j) = ALOG10(grid1(i, j)) ELSE WRITE (*, "(' ERROR: Non-positive value(s) in seismicity-rate .grd file.' & & /' Start over, and use mosaic type #2 for a linear plot.')") CALL Pause() STOP END IF END DO END DO END IF ! choice == 10; .grd file from Long_Term_Seismicity 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 LonLat_2_Uvec (lon, lat, uvec) IF (mp_projection_number == 9) THEN ! Orthographic projection ! guard against looking at backside of Earth t = uvec(1) * mp_projpoint_uvec(1) + & & uvec(2) * mp_projpoint_uvec(2) + & & uvec(3) * mp_projpoint_uvec(3) IF (t <= 0.0) CYCLE END IF CALL Project (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 Meters_2_Points (x_meters,y_meters, x_points,y_points) c1 = In_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 IF (choice /= 10) THEN ! unknown units for values in grid1 CALL Prompt_for_String('What are the units of these values?',TRIM(ADJUSTL(grid_units)),grid_units) ELSE ! choice == 10 grid_units = "log(EQ/m2/s)" ! limited to 12 bytes END IF 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 Prompt_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!' )") mt_flashby = .FALSE. GO TO 1022 END IF IF (bitmap_color_mode <= 2) THEN ! need to pin down ends of spectrum CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) 1023 IF (grid_lowblue) THEN CALL Prompt_for_Real('What (low?) value anchors the violet-blue end of the spectrum?',minimum,bitmap_color_lowvalue) CALL Prompt_for_Real('What (high?) value anchors the red-pink end of the spectrum?',maximum,bitmap_color_highvalue) ELSE CALL Prompt_for_Real('What (high?) value anchors the violet-blue end of the spectrum?',maximum,bitmap_color_lowvalue) CALL Prompt_for_Real('What (low?) value anchors the red-pink end of the spectrum?',minimum,bitmap_color_highvalue) END IF ! grid_lowblue, or not IF (bitmap_color_highvalue == bitmap_color_lowvalue) THEN WRITE (*,"(/' ERROR: Red value must differ from blue value!' )") mt_flashby = .FALSE. GO TO 1023 END IF ! bad range ELSE IF (bitmap_color_mode == 4) THEN IF (grid_interval == 0.0) THEN grid_interval = (maximum - minimum)/ai_spectrum_count grid_midvalue = (maximum + minimum)/2. END IF 1024 CALL Prompt_for_Real('What contour interval do you wish?',grid_interval,grid_interval) IF (grid_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") grid_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1024 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',grid_midvalue,grid_midvalue) CALL Prompt_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') IF (ios /= 0) CALL Could_Not_Find_File(grd2_pathfile) DO i = 1, 5 READ (21,"(A)", IOSTAT = ios) line WRITE (*,"(' ',A)") TRIM(line(1:79)) END DO WRITE(*,"(' --------------------------------------------------------------')") CLOSE (21) CALL Prompt_for_Logical('Is this grid defined in (lon,lat) coordinates?',.TRUE.,grd2_lonlat) IF ((.NOT.xy_defined).AND.(.NOT.grd2_lonlat)) THEN WRITE (*,"(' ERROR: Start NeoKineMap over again and define the (x,y) coordinates.')") CALL Press_Enter STOP ' ' END IF 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.0) < 0.01) THEN grd2_lon_range = 360.0 ELSE grd2_lon_range = Easting(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) CALL Press_Enter DEALLOCATE ( grid2 ) mt_flashby = .FALSE. GO TO 1021 END IF ! problem with grd2 END IF ! bitmap_shading_mode 1 or 2 CALL Prompt_for_Real('Relative intensity of oblique lighting?',intensity,intensity) ! find RMS E-W slope IF (grd2_lonlat) THEN grd2_d_EW = grd2_d_lon ELSE grd2_d_EW = grd2_d_x END IF sum = 0.0 DO irow = 1, grd2_nrows DO jcol = 2, grd2_ncols sum = sum + ((grid2(irow,jcol) - grid2(irow,jcol-1)) / grd2_d_EW)**2 END DO ! jcol END DO ! irow RMS_slope = SQRT(sum / train_length) IF (RMS_slope == 0.0) RMS_slope = 1.0 ! prevent /0.0 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 Prompt_for_Integer('How many columns of pixels in bitmap?',bitmap_width,bitmap_width) IF (bitmap_width < 2) THEN WRITE (*,"(' ERROR: Bitmap_width must be >= 2')") mt_flashby = .FALSE. GO TO 1025 END IF 1026 CALL Prompt_for_Integer('How many rows of pixels in bitmap?',bitmap_height,bitmap_height) IF (bitmap_height < 2) THEN WRITE (*,"(' ERROR: Bitmap_height must be >= 2')") mt_flashby = .FALSE. GO TO 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.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) !Get "value" (basis for color of pixel) 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 Reject (x_meters,y_meters, success, uvec) IF (success) THEN ! rejection worked CALL Uvec_2_LonLat (uvec, lon, lat) !define grd1_success as falling within grid1 grd1_success = (lat >= grd1_lat_min).AND. & & (lat <= grd1_lat_max).AND. & & (Easting(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.0 fy1 = 1.00 - fy2 j1 = 1 + Easting(lon - grd1_lon_min) / grd1_d_lon j1 = MAX(1,MIN(j1,grd1_ncols-1)) j2 = j1 + 1 fx2 = (Easting(lon - grd1_lon_min) / grd1_d_lon) - j1 + 1.0 fx1 = 1.00 - 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 ELSE ! rejection failed (i.e., back side of Earth in Orthographic projection) grd1_success = .FALSE. END IF ! rejection worked or failed 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.0 fy1 = 1.00 - 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.0 fx1 = 1.00 - 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.0 ! 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. & & (Easting(lon - grd2_lon_min) <= grd2_lon_range) !note: insensitive to longitude cycle IF (grd2_success) THEN i1 = 1 + (grd2_lat_max - lat) / grd2_d_lat i1 = MAX(1,MIN(i1,grd2_nrows-1)) i2 = i1 + 1 fy2 = ((grd2_lat_max - lat) / grd2_d_lat) - i1 + 1.0 fy1 = 1.00 - fy2 j1 = 1 + Easting(lon - grd2_lon_min) / grd2_d_lon j1 = MAX(1,MIN(j1,grd2_ncols-1)) j2 = j1 + 1 fx2 = (Easting(lon - grd2_lon_min) / grd2_d_lon) - j1 + 1.0 fx1 = 1.00 - fx2 END IF ! point in grid2 ELSE ! Rejection failed; lon, lat undefined grd2_success = .FALSE. END IF ! successful Rejection or not ELSE ! .NOT.grd2_lonlat; grid2 is x,y grd2_success = (x_meters >= grd2_x_min).AND. & & (x_meters <= grd2_x_max).AND. & & (y_meters >= grd2_y_min).AND. & & (y_meters <= grd2_y_max) IF (grd2_success) THEN i1 = 1 + (grd2_y_max - y_meters) / grd2_d_y i1 = MAX(1,MIN(i1,grd2_nrows-1)) i2 = i1 + 1 fy2 = ((grd2_y_max - y_meters) / grd2_d_y) - i1 + 1.0 fy1 = 1.00 - fy2 j1 = 1 + (x_meters - grd2_x_min) / grd2_d_x j1 = MAX(1,MIN(j1,grd2_ncols-1)) j2 = j1 + 1 fx2 = ((x_meters - grd2_x_min) / grd2_d_x) - j1 + 1.0 fx1 = 1.00 - fx2 END IF ! point within x/y grid2 END IF ! grd2_lonlat, or not 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.5) ! fraction for adjacent cell fin = 1.00 - fout ! fraction for the cell we're in inner = (grid2(i1,j2) - grid2(i1,j1)) / grd2_d_EW IF (fx2 > 0.5) THEN IF (j2 < grd2_ncols) THEN ! normal case outer = (grid2(i1,j2+1) - grid2(i1,j1+1)) / grd2_d_EW ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case outer = (grid2(i1,j2-1) - grid2(i1,j1-1)) / grd2_d_EW ELSE ! at left edge of grid outer = inner END IF END IF above = fin * inner + fout * outer !Repeat for row below the point: inner = (grid2(i2,j2) - grid2(i2,j1)) / grd2_d_EW IF (fx2 > 0.5) THEN IF (j2 < grd2_ncols) THEN ! normal case outer = (grid2(i2,j2+1) - grid2(i2,j1+1)) / grd2_d_EW ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case outer = (grid2(i2,j2-1) - grid2(i2,j1-1)) / grd2_d_EW ELSE ! at left edge of grid outer = inner END IF END IF below = fin * inner + fout * outer !Line below makes slope piecewise-linear in N-S direction: slope = fy1 * above + fy2 * below brightness = 1.0 + 0.5 * intensity * slope / RMS_slope brightness = MAX(0.0, MIN(2.0, brightness)) ELSE ! .NOT. dot2_success; so, point was not in grid2 brightness = 1.0 END IF ! point was in grid2 or not ELSE ! no shaded relief wanted brightness = 1.0 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 = RGB_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 = RGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = RGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = RGB_AI(value = value, contour_interval = 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.5 k = MAX(0,MIN(255,k)) bitmap(irow,jcol) = CHAR(k)//CHAR(k)//CHAR(k) ELSE ! fill in with background IF (ai_black_background) THEN ! slide copy bitmap(irow,jcol) = CHAR(0)//CHAR(0)//CHAR(0) ELSE ! white background (paper print) bitmap(irow,jcol) = CHAR(255)//CHAR(255)//CHAR(255) END IF END IF ! color, grey-scale, or background END DO ! jcol, left to right WRITE (*,"('+Working on bitmap 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 Bitmap_on_L1 (bitmap, ai_window_x1_points, ai_window_x2_points, & & ai_window_y1_points, ai_window_y2_points) IF (choice == 10) THEN ! log(seismicity) plot: add floating box with integral value CALL Begin_Group() CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color("foreground") CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = "background") CALL New_L12_Path(level = 1, x_points = ai_window_x1_points, y_points = ai_window_y1_points) CALL Line_to_L12(x_points = ai_window_x1_points + 232., y_points = ai_window_y1_points) CALL Line_to_L12(x_points = ai_window_x1_points + 232., y_points = ai_window_y1_points + 20.) CALL Line_to_L12(x_points = ai_window_x1_points, y_points = ai_window_y1_points + 20.) CALL Line_to_L12(x_points = ai_window_x1_points, y_points = ai_window_y1_points) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) WRITE (c9, "(ES9.2)") EQs_per_century CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = "foreground") CALL L12_Text (level = 1, & & x_points = ai_window_x1_points + 12., y_points = ai_window_y1_points + 6., & & angle_radians = 0.0, & & font_points = 12, lr_fraction = 0., ud_fraction = 0., & & text = "Integral: " // c9 // " earthquakes/century") CALL End_Group() END IF ! floating box with integral of seismicity IF (ai_using_color) THEN CALL Chooser(bottom, right) IF (bottom) THEN CALL Spectrum_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 Spectrum_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( file_type = "*.grd", & & suggested_file = grd1_file, & & using_path = temp_path_in) CALL Prompt_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') IF (ios /= 0) CALL Could_Not_Find_File(grd1_pathfile) 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(*,"(' ----------------------------------------')") CLOSE (21) OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) CALL Could_Not_Find_File(grd1_pathfile) READ (21, *, IOSTAT = ios) grd1_lon_min, grd1_d_lon, grd1_lon_max READ (21, *, IOSTAT = ios) grd1_lat_min, grd1_d_lat, grd1_lat_max CLOSE (21) grd1_lonlat = (ABS(grd1_lat_min)<91.).AND.(ABS(grd1_lat_max)<91.) CALL Prompt_for_Logical('Is this grid defined in (lon,lat) coordinates?',grd1_lonlat,grd1_lonlat) IF ((.NOT.xy_defined).AND.(.NOT.grd1_lonlat)) THEN WRITE (*,"(' ERROR: Start NeoKineMap over again and define the (x,y) coordinates.')") CALL Press_Enter STOP ' ' END IF 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.')") CALL Press_Enter DEALLOCATE (grid1, train) mt_flashby = .FALSE. GO TO 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 Prompt_for_String('What are the units of these values?',TRIM(ADJUSTL(grid_units)),grid_units) IF (grid_interval == 0.0) THEN grid_interval = (maximum - minimum)/ai_spectrum_count grid_midvalue = (maximum + minimum)/2. END IF 1031 CALL Prompt_for_Real('What contour interval do you wish?',grid_interval,grid_interval) IF (grid_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") grid_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1031 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',grid_midvalue,grid_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) ELSE CALL Prompt_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 Prompt_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 Set_Line_Style (width_points = 0.75, dashed = .FALSE.) !note that contouring routine will set line colors CALL Begin_Group IF (grd1_lonlat) THEN DO i = 1, grd1_nrows-1 DO j = 1, grd1_ncols-1 ! NW triangle: lon1 = grd1_lon_min + (j-1)*grd1_d_lon lat1 = grd1_lat_max - (i-1)*grd1_d_lat CALL LonLat_2_Uvec(lon1, lat1, uvec1) lon2 = lon1 lat2 = lat1 - grd1_d_lat CALL LonLat_2_Uvec(lon2, lat2, uvec2) lon3 = lon2 + grd1_d_lon lat3 = lat1 CALL LonLat_2_Uvec(lon3, lat3, uvec3) !Skip triangles with two nodes at +90N, !since they have zero area: IF ((lat1 < 90.0).OR.(lat3 < 90.0)) THEN CALL Contour_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) END IF ! area is positive ! SE triangle; defined in terms of NW-triangle values: lon1 = lon3 lat1 = lat2 t = lat2 lat2 = lat3 lat3 = t t = lon2 lon2 = lon3 lon3 = t uvec(1:3) = uvec2(1:3) uvec2(1:3) = uvec3(1:3) uvec3(1:3) = uvec(1:3) CALL LonLat_2_Uvec(lon1, lat1, uvec1) !Skip triangles with two nodes at -90N, !since they have zero area: IF ((lat1 > -90.0).OR.(lat3 > -90.0)) THEN CALL Contour_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 IF ! area is positive 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 Contour_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 Contour_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 End_Group ! END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_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 Bar_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, if any) CALL Group_or_Bitmap (latter_mosaic, element_scalar_method, bitmap_height, bitmap_width) 1040 temp_path_in = path_in IF (got_parameters) THEN element_scalar_feg_file = x_feg ELSE !do not force use of parameter file; it may not have been created yet. CALL File_List( file_type = "*.feg", & & suggested_file = element_scalar_feg_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file defines the elements?',element_scalar_feg_file,element_scalar_feg_file) END IF 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') !Warning: PAD = "YES" will not be sufficient to zero out the element_scalar(i) if it is !missing, because the READ is unformatted (*). All values must be present in the element- !definition section of the input .feg file, even if 0.0. 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 LonLat_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 ( element_scalar(numel) ) DO i = 1, numel READ (21, *, 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: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 1040 END IF READ (21, *) nfl IF (nfl > 0) CALL No_Fault_Elements_Allowed() 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 Prompt_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.0) THEN element_scalar_interval = (maximum - minimum)/ai_spectrum_count element_scalar_midvalue = (maximum + minimum)/2. END IF 1041 CALL Prompt_for_Real('What contour interval do you wish?',element_scalar_interval,element_scalar_interval) IF (element_scalar_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") element_scalar_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1041 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',element_scalar_midvalue,element_scalar_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',element_scalar_lowblue,element_scalar_lowblue) ELSE CALL Prompt_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 Prompt_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.')") element_scalar_zeromode = 0 mt_flashby = .FALSE. GO TO 1042 END IF WRITE (*,"(/' Working on discontinuous scalar (one value per element)....')") CALL Begin_Group ! of colored/shaded triangles (there won't be any contours) DO i = 1, numel t = element_scalar(i) IF (t == 0.0) THEN SELECT CASE (element_scalar_zeromode) CASE (1) ! round up t = 0.001 * element_scalar_interval plot_this = .TRUE. CASE (0) ! do not plot plot_this = .FALSE. CASE (-1) ! round down t = -0.001 * element_scalar_interval plot_this = .TRUE. END SELECT ELSE ! non-zero value plot_this = .TRUE. IF (MOD(t, element_scalar_interval) == 0.0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0) THEN t = t - 0.001* element_scalar_interval ELSE ! t < 0.0 t = t + 0.001 * 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 IF (plot_this) 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)) CALL Contour_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 IF ! plot_this END DO ! i = 1, numel CALL End_Group ! of colored/shaded triangles CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_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 Bar_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 Learn_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.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_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 Bumpy_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 Spectrum_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 Spectrum_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 DEALLOCATE ( element_scalar, & & nodes ) ! in LIFO order DEALLOCATE ( node_uvec ) CALL BEEPQQ (frequency = 440, duration = 250) ! end of discontinuous scalar (one value per element) CASE (5) ! nodal data (if any) CALL Group_or_Bitmap (latter_mosaic, node_scalar_method, bitmap_height, bitmap_width) 1050 temp_path_in = path_in IF (got_parameters) THEN feg_file = x_feg ELSE !do not force use of parameter file; it may not have been created yet. CALL File_List( file_type = "*.feg", & & suggested_file = feg_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file contains the node locations and data?',feg_file,feg_file) END IF feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) 1051 WRITE (*,"(' -----------------------------------------')") WRITE (*,"(' Which nodal variable should be plotted?')") WRITE (*,"(' 1 = ???')") WRITE (*,"(' 2 = ???')") WRITE (*,"(' 3 = ???')") WRITE (*,"(' 4 = ???')") node_scalar_limit = 4 WRITE (*,"(' -----------------------------------------')") CALL Prompt_for_Integer('Which do you want?',node_scalar_choice,node_scalar_choice) IF ((node_scalar_choice < 1).OR.(node_scalar_choice > node_scalar_limit)) THEN mt_flashby = .FALSE. GO TO 1051 END IF IF (node_scalar_choice == 1) THEN CALL Add_Title('???') ELSE IF (node_scalar_choice == 2) THEN CALL Add_Title('???') ELSE IF (node_scalar_choice == 3) THEN CALL Add_Title('???') ELSE IF (node_scalar_choice == 4) THEN CALL Add_Title('???') END IF !open .feg to record nodal values (and element definitions) OPEN (UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, "(A)", IOSTAT = ios) line CALL Add_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) END IF ! node_scalar_choice = 1, 2, 3, 4 problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL LonLat_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) CALL Press_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 1050 END IF CLOSE (21) CALL Add_Title(feg_file) WRITE (*,"(/' Here is the distribution of nodal values:' )") CALL Histogram (node_scalar, numnod, .FALSE., maximum, minimum) CALL Prompt_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.0) THEN node_scalar_interval = (maximum - minimum)/ai_spectrum_count node_scalar_midvalue = (maximum + minimum)/2. END IF 1052 CALL Prompt_for_Real('What contour interval do you wish?',node_scalar_interval,node_scalar_interval) IF (node_scalar_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") node_scalar_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1052 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',node_scalar_midvalue,node_scalar_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',node_scalar_lowblue,node_scalar_lowblue) ELSE CALL Prompt_for_Logical('Should low values be shaded darkly (versus lightly)?',node_scalar_lowblue,node_scalar_lowblue) END IF WRITE (*,"(/' Working on nodal data....')") DO group = 1, 2 CALL Begin_Group IF (group == 2) CALL Set_Line_Style (width_points = 0.75, 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 Contour_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 End_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_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 Bar_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 Learn_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.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = node_scalar(nodes(1,iele)) * s1 + & & node_scalar(nodes(2,iele)) * s2 + & & node_scalar(nodes(3,iele)) * s3 IF (node_scalar_choice >= 3) t = MAX(t, 0.0) ! all-positive, please! bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) 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 Bumpy_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 Spectrum_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 Spectrum_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 DEALLOCATE ( nodes ) ! in LIFO order DEALLOCATE ( node_scalar ) DEALLOCATE ( node_uvec ) CALL BEEPQQ (frequency = 440, duration = 250) ! end of 5 nodal data (elevation, Q, crust, mantle lithosphere) CASE (6, 11) ! magnitude of long-term-average velocity 1060 IF (.NOT.got_parameters) CALL Get_Parameters !read .feg file for num_nod, node locations, num_ele, element definitions feg_file = x_feg temp_path_in = path_in ! must be set to allow express processing of overlay velocity vectors feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(feg_pathfile) READ (21,*) ! title READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( vw(2*numnod) ) ! N.B. If (choice == 11) then this really represents vw_interseismic. ALLOCATE ( vsize_mma(numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL LonLat_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) ) ALLOCATE ( cracking(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 IF (nfl > 0) CALL No_Fault_Elements_Allowed() CLOSE(21) IF (((TRIM(f_dat) /= 'none').AND.(TRIM(f_dig) /= 'none')).AND.(choice == 6)) THEN ! there are faults in this model, and long-term velocity is wanted !read e*.nko to see which elements have active fault segments: continuum_strainrate_file = 'e' // TRIM(token) // ".nko" continuum_strainrate_pathfile = TRIM(temp_path_in) // TRIM(continuum_strainrate_file) OPEN (UNIT = 22, FILE = continuum_strainrate_pathfile, STATUS = "OLD", ACTION = "READ", IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(continuum_strainrate_pathfile) any_cracked = .FALSE. ! but usually changed in loop below DO i = 1, numel READ (22, *) j, cracking(j) any_cracked = any_cracked .OR. cracking(j) END DO CLOSE(22) ELSE ! there are no fault velocity discontinuities in this plot any_cracked = .FALSE. DO i = 1, numel cracking(i) = .FALSE. END DO END IF !determine cracked_element_method, if relevant: IF (any_cracked) THEN WRITE (*, "(/' -------------------------------------------------------------------')") WRITE (*, "( ' How shall velocity in faulting elements be displayed?')") WRITE (*, "(/' 0 = Obscure this element with gray shading')") WRITE (*, "( ' 1 = Continuous linear interpolation, smoothing discontinuities')") WRITE (*, "( ' 2 = Reconstruct velocity from known discontinuities')") WRITE (*, "(/' NOTE: Method (2) requires the mosaic to be a bitmap.')") WRITE (*, "( ' -------------------------------------------------------------------')") CALL Prompt_for_Integer('Which method should be used?',cracked_element_method, cracked_element_method) END IF ! Note: No need to change cracked_element_method if none are cracked; leave it set for another case. !choose format for mosaic: IF ((.NOT.any_cracked).OR.(cracked_element_method < 2)) THEN ! either format may be used: CALL Group_or_Bitmap (latter_mosaic, velocity_method, bitmap_height, bitmap_width) ELSE ! cracked_element method >= 2 AND any_cracked; must use bitmap method: velocity_method = 2 ! bitmap !now ask questions normally asked inside Group_or_Bitmap: 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 1061 CALL Prompt_for_Integer('How many columns of pixels in bitmap?',bitmap_width,bitmap_width) IF (bitmap_width < 2) THEN WRITE (*,"(' ERROR: Bitmap_width must be >= 2')") GOTO 1061 END IF 1062 CALL Prompt_for_Integer('How many rows of pixels in bitmap?',bitmap_height,bitmap_height) IF (bitmap_height < 2) THEN WRITE (*,"(' ERROR: Bitmap_height must be >= 2')") GOTO 1062 END IF END IF !scan, and then memorize h*.nko, if needed: IF (any_cracked.AND.(cracked_element_method >= 2)) THEN heave_segments_file = 'h' // TRIM(token) // ".nko" CALL Add_Title(heave_segments_file) heave_segments_pathfile = TRIM(temp_path_in)//TRIM(heave_segments_file) OPEN(UNIT = 23, FILE = heave_segments_pathfile, STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(heave_segments_pathfile) !read through once to find the number of cracks (with positive length) crack_count = 0 line_count = 0 DO READ (23,"(A6,13X,F12.3,10X,F8.3,1X,F7.3,3X,F8.3,1X,F7.3,11X,I7)", IOSTAT = ios) & & c6, model_heave_rate_mmpa, lon1, lat1, lon2, lat2, iele IF (ios == -1) EXIT ! EOF first_byte = c6(1:1) IF ((first_byte == 'F').OR.(first_byte == 'f')) THEN line_count = line_count + 1 IF ((lon1 /= lon2).OR.(lat1 /= lat2)) THEN ! ignore segments whose length rounded to zero when h_token.nko was written crack_count = crack_count + 1 END IF END IF END DO CLOSE (23) ALLOCATE ( cracks(crack_count) ) !second time through, contents are memorized: OPEN(UNIT = 23, FILE = heave_segments_pathfile, STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(heave_segments_pathfile) i = 0 ! will be index of (finite-length) segments DO j = 1, line_count READ (23,"(A6,13X,F12.3,10X,F8.3,1X,F7.3,3X,F8.3,1X,F7.3,11X,I7)") & & c6, model_heave_rate_mmpa, lon1, lat1, lon2, lat2, iele IF ((lon1 /= lon2).OR.(lat1 /= lat2)) THEN ! ignore segments whose length rounded to zero when h_token.nko was written i = i + 1 cracks(i)%sense = c6(6:6) cracks(i)%heave_rate_mps = model_heave_rate_mmpa / (1000.0 * sec_per_year) CALL LonLat_2_Uvec (lon1, lat1, uvec) cracks(i)%uvec1(1:3) = uvec(1:3) CALL LonLat_2_Uvec (lon2, lat2, uvec) cracks(i)%uvec2(1:3) = uvec(1:3) cracks(i)%iele = iele END IF END DO ! j = 1, line_count (i = 1, crack_count) CLOSE (23) END IF ! h*.nko must be memorized !read velocity file: IF (choice == 6) THEN vel_file = 'v' // TRIM(token) // ".out" ELSE IF (choice == 11) THEN vel_file = 'v_interseismic' // TRIM(token) // ".out" END IF vel_pathfile = TRIM(path_in)//TRIM(vel_file) OPEN(UNIT = 24, FILE = vel_pathfile, STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(vel_pathfile) DO i = 1, 3 READ (24,"(A)") line CALL Add_Title(line) END DO ! first 3 lines of velocity file READ (24,*) (vw(i), i = 1, (2*numnod)) !this read method should work with either NeoKinema or SHELLS format CLOSE(24) !allow option to change the velocity reference frame: CALL Prompt_for_Logical('Do you wish to CHANGE the velocity reference frame?',velocity_reframe,velocity_reframe) IF (velocity_reframe) THEN 1063 CALL Prompt_for_Integer('Which node should be fixed?',fixed_node,fixed_node) IF ((fixed_node < 1).OR.(fixed_node > numnod)) THEN WRITE (*,"(' ERROR: Illegal node number!')") mt_flashby = .FALSE. GO TO 1063 END IF ! illegal fixed_node 1064 CALL Prompt_for_Integer('Which OTHER node should be prevented from rotating about the first?',nonorbiting_node,nonorbiting_node) IF ((nonorbiting_node < 1).OR.(nonorbiting_node > numnod).OR.(nonorbiting_node == fixed_node)) THEN WRITE (*,"(' ERROR: Illegal node number!')") mt_flashby = .FALSE. GO TO 1064 END IF ! illegal nonorbiting_node WRITE (number8, "(I8)") fixed_node IF (choice == 6) THEN line = 'Long-term-average Velocity, with node ' // TRIM(ADJUSTL(number8)) // ' fixed' ELSE IF (choice == 11) THEN line = 'Short-term Interseismic Velocity, with node ' // TRIM(ADJUSTL(number8)) // ' fixed' END IF CALL Add_Title(line) CALL Reframe_Velocity_at_Nodes (fixed_node, nonorbiting_node, node_uvec, numnod, & ! input & vw, & ! modify & reference_Elon_deg, reference_Nlat_deg, & & reference_vE_mmpa, reference_vN_mmpa, reference_ccw_degpMa) !output ELSE ! velocity_reframe = .FALSE. IF (choice == 6) THEN CALL Add_Title('Long-Term-Average Velocity Magnitude') ELSE IF (choice == 11) THEN CALL Add_Title('Short-Term Interseismic Velocity Magnitude') END IF END IF ! velocity_reframe, or not !prepare to display histogram of velocities list_length = 0 DO i = 1, numnod list_length = list_length + 1 v_South_mps = vw(2*i-1) v_East_mps = vw(2*i) vsize_mma(list_length) = 1000. * sec_per_year * SQRT(v_South_mps**2 + v_East_mps**2) END DO ! i = 1, numnod WRITE (*,"(/' Here is the distribution of velocities (in mm/a):')") CALL Histogram (vsize_mma, list_length, .FALSE., maximum, minimum) IF (velocity_method == 1) THEN ! group of colored/shaded polygons IF (velocity_interval == 0.0) THEN velocity_interval = (maximum - minimum)/ai_spectrum_count velocity_midvalue = (maximum + minimum)/2. END IF 1065 CALL Prompt_for_Real('What contour interval do you wish?',velocity_interval,velocity_interval) IF (velocity_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") velocity_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1065 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',velocity_midvalue,velocity_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should slow areas be colored blue (versus red)?',velocity_lowblue,velocity_lowblue) ELSE CALL Prompt_for_Logical('Should slow areas be shaded darkly (versus lightly)?',velocity_lowblue,velocity_lowblue) END IF WRITE (*,"(/' Working on magnitude of velocity....')") DO group = 1, 2 CALL Begin_Group ! of colored/shaded spherical triangles IF (group == 2) CALL Set_Line_Style (width_points = 0.75, 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)) IF ((.NOT.cracking(i)).OR.(cracked_element_method == 1)) THEN ! display this element v1S_mma = 1000. * sec_per_year * vw(2*nodes(1,i)-1) v2S_mma = 1000. * sec_per_year * vw(2*nodes(2,i)-1) v3S_mma = 1000. * sec_per_year * vw(2*nodes(3,i)-1) v1E_mma = 1000. * sec_per_year * vw(2*nodes(1,i)) v2E_mma = 1000. * sec_per_year * vw(2*nodes(2,i)) v3E_mma = 1000. * sec_per_year * vw(2*nodes(3,i)) CALL Contour_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) ELSE ! element is cracking, and cracked_element_method == 0; gray-out this element IF (group == 1) THEN CALL Set_Fill_or_Pattern (.FALSE., "gray______") CALL New_L45_Path(5, uvec1) CALL Great_to_L45(uvec2) CALL Great_to_L45(uvec3) CALL Great_to_L45(uvec1) CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF END IF ! this element should be displayed, or grayed-out END DO ! i = 1, numel CALL End_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_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 Bar_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 velocity....DONE.')") ELSE ! velocity_method == 2; create bitmap ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL Learn_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.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_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)) IF ((.NOT.cracking(iele)).OR.(cracked_element_method == 1)) THEN ! display this element normally 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 Velocity_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 t = vsize * 1000. * sec_per_year bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) ELSE IF (cracked_element_method == 0) THEN ! cracking(iele) = T if we get here ! (leave blank; we will gray-out this element AFTER bitmap is placed, by adding gray triangles) bitmap_success(irow,jcol) = .FALSE. ELSE ! cracking, and cracked_element_method >= 2; attempt reconstruction of velocity with discontinuities strict_minimum = minimum ! distinguishing extreme values of vsize inside elements (noisy) strict_maximum = maximum ! versus at nodes (stable) !================== begin experimental algorithm ======================================== !integrate 3 times, from 3 different corner nodes; at end, use voting method DO j = 1, 3 result_uvec(1:3) = node_uvec(1:3,nodes(j,iele)) v_South_mps = vw(2*nodes(j,iele)-1) v_East_mps = vw(2*nodes(j,iele)) !correct for any faults crossed on arc from result_uvec to uvec, which has pole = pole_a_uvec CALL Cross(result_uvec, uvec, tvec) CALL Make_Uvec(tvec, pole_a_uvec) DO i = 1, crack_count IF (cracks(i)%iele == iele) THEN ! crack is in this element turn_1_uvec(1:3) = cracks(i)%uvec1(1:3) turn_2_uvec(1:3) = cracks(i)%uvec2(1:3) CALL Cross(turn_1_uvec, turn_2_uvec, tvec) CALL Make_Uvec(tvec, pole_b_uvec) CALL Circles_Intersect (pole_a_uvec = pole_a_uvec, dot_a = 0.0D0, first_a_uvec = result_uvec, last_a_uvec = uvec, & & pole_b_uvec = pole_b_uvec, dot_b = 0.0D0, first_b_uvec = turn_1_uvec, last_b_uvec = turn_2_uvec, & ! input & overlap = maybe, number = n_intersection, point1_uvec = cross_uvec, point2_uvec = uvec4) ! output IF (n_intersection == 1) THEN ! connecting arc crosses this fault at cross_uvec CALL Local_Theta(cross_uvec, theta_uvec) CALL Local_Phi (cross_uvec, phi_uvec) c1 = cracks(i)%sense IF ((c1 == 'R').OR.(c1 == 'L')) THEN ! strike-slip tvec(1:3) = turn_2_uvec(1:3) - turn_1_uvec(1:3) CALL Make_Uvec(tvec, strike_uvec) !make strike_uvec point to the right, as seen from arc beginning at result_uvec: IF (Dot(pole_a_uvec, strike_uvec) > 0.0) strike_uvec(1:3) = -strike_uvec(1:3) IF (c1 == 'R') THEN tvec(1:3) = cracks(i)%heave_rate_mps * strike_uvec(1:3) ! velocity correction ELSE tvec(1:3) = -cracks(i)%heave_rate_mps * strike_uvec(1:3) END IF ELSE IF ((c1 == 'N').OR.(c1 == 'D').OR.(c1 == 'T').OR.(c1 == 'P').OR.(c1 == 'S')) THEN ! dip-slip !get azimuth of fault at cross_uvec: IF (Arc(turn_1_uvec, cross_uvec) > Arc(turn_2_uvec, cross_uvec)) THEN strike_azimuth = Relative_Compass(from_uvec = cross_uvec, to_uvec = turn_1_uvec) ELSE strike_azimuth = Relative_Compass(from_uvec = cross_uvec, to_uvec = turn_2_uvec) END IF dip_azimuth = strike_azimuth + Pi_over_2 orthogonal_uvec(1:3) = -COS(dip_azimuth) * theta_uvec(1:3) + & & SIN(dip_azimuth) * phi_uvec(1:3) !make orthogonal_uvec point in same sense as from result_uvec to uvec: tvec(1:3) = uvec(1:3) - result_uvec(1:3) ! desired direction IF (Dot(orthogonal_uvec, tvec) < 0.0) orthogonal_uvec(1:3) = -orthogonal_uvec(1:3) IF ((c1 == 'D').OR.(c1 == 'N')) THEN tvec(1:3) = cracks(i)%heave_rate_mps * orthogonal_uvec(1:3) ! velocity correction ELSE tvec(1:3) = -cracks(i)%heave_rate_mps * orthogonal_uvec(1:3) END IF ELSE ! should not happen WRITE (*,"(' ERROR: Bad cracks(',I6,')%sense')") i CALL Traceback END IF !convert tvec (velocity change) to horizontal components, and add: v_South_mps = v_South_mps + Dot(tvec, theta_uvec) v_East_mps = v_East_mps + Dot(tvec, phi_uvec) END IF ! connecting arc crosses this fault END IF ! crack is in this element END DO ! i = 1, crack_count vsize_estimates(j) = SQRT(v_South_mps**2 + v_East_mps**2) END DO ! j = 1, 3 (different starting nodes in this element) !voting section (probably better than averaging the 3): d12 = ABS(vsize_estimates(1) - vsize_estimates(2)) d23 = ABS(vsize_estimates(2) - vsize_estimates(3)) d31 = ABS(vsize_estimates(3) - vsize_estimates(1)) IF ((d12 < d23).AND.(d12 < d31)) THEN ! d12 is the smallest difference vsize = (vsize_estimates(1) + vsize_estimates(2)) / 2.0 ELSE IF ((d23 < d31).AND.(d23 < d12)) THEN ! d23 is the smallest difference vsize = (vsize_estimates(2) + vsize_estimates(3)) / 2.0 ELSE ! d31 is the smallest difference vsize = (vsize_estimates(3) + vsize_estimates(1)) / 2.0 END IF !================== end experimental algorithm (with assignment of vsize = ? m/s) ======= t = vsize * 1000. * sec_per_year bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t strict_minimum = MIN(strict_minimum, t) strict_maximum = MAX(strict_maximum, t) END IF ! this element should be displayed, or not 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 Bumpy_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 IF (cracked_element_method == 0) THEN ! overlay some gray triangles: CALL Begin_Group DO iele = 1, numel IF (cracking(iele)) 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)) CALL Set_Fill_or_Pattern (.FALSE., "gray______") CALL New_L45_Path(5, uvec1) CALL Great_to_L45(uvec2) CALL Great_to_L45(uvec3) CALL Great_to_L45(uvec1) CALL End_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! cracking(iele) END DO ! iele = 1, num_ele CALL End_Group END IF ! some gray triangles (might be) needed CALL Chooser(bottom, right) IF (bottom) THEN CALL Spectrum_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 Spectrum_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) IF (ALLOCATED( cracks )) DEALLOCATE ( cracks ) DEALLOCATE ( cracking ) DEALLOCATE ( nodes ) DEALLOCATE ( vsize_mma ) DEALLOCATE ( vw ) DEALLOCATE ( node_uvec ) ! in LIFO order just_began_surface_flow = .TRUE. ! may speed overlay of vectors last_mosaic_choice = choice ! remembering (long-term or short-term?) to guid suggestion of appropriate overlay ! end of CASE (6, 11): magnitude of long-term-average velocity field, or short-term interseismic field CASE (7, 12) ! log of largest (absolute value) principal strain-rate ! Derived by taking derivatives of v_[token].out or of v_interseismic_[token].out. ! CASE(7) = long-term-average; CASE(12) = short-term interseismic IF (choice == 7) THEN CALL Add_Title('Total Strain-Rate, including Faulting: log10 of greatest principal rate') ELSE IF (choice == 12) THEN CALL Add_Title('Short-Term Interseismic Strain-Rate: log10 of greatest principal rate') END IF CALL Group_or_Bitmap (latter_mosaic, log_strainrate_method, bitmap_height, bitmap_width) IF (.NOT.got_parameters) CALL Get_Parameters 1070 temp_path_in = path_in IF (got_parameters) THEN feg_file = x_feg ELSE CALL File_List( file_type = "*.feg", & & suggested_file = feg_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which .feg file defines the elements?',feg_file,feg_file) END IF 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 LonLat_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) CALL Press_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 1070 END IF READ (21, *) nfl IF (nfl > 0) CALL No_Fault_Elements_Allowed() CLOSE (21) CALL Add_Title(feg_file) 1071 temp_path_in = path_in IF (got_parameters) THEN IF (choice == 7) THEN vel_file = 'v' // TRIM(token) // ".out" ELSE IF (choice == 12) THEN vel_file = 'v_interseismic' // TRIM(token) // ".out" END IF ELSE CALL File_List( file_type = "v*.out", & & suggested_file = vel_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which velocity file should be used?',vel_file,vel_file) END IF 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 Press_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 1071 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) ) ! N.B. IF (choice == 12) then this actually represents vw_interseismic. READ (22,*) (vw(i), i = 1, (2*numnod)) CLOSE (22) ALLOCATE ( log_largest_ei_persec(numel) ) DO l_ = 1, numel ! compute strainrates at element centers 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 Make_Uvec (uvec4, uvec) ! center of element equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) 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_ = ATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) !convert to scalar measure, for histogram CALL Principal_Axes_22 (eps_dot(1),eps_dot(2),eps_dot(3), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) err = -(e1h + e2h) largest_ei_persec = MAX(ABS(e1h), ABS(e2h), ABS(err)) IF (largest_ei_persec == 0.0) THEN log_largest_ei_persec(l_) = -20.0 ! arbitrary substitute for -infinity! ELSE log_largest_ei_persec(l_) = LOG10(largest_ei_persec) END IF !(not using loop on m = 1,...,7 since values almost identical) END DO ! l_ = 1, numel, computing strainrates and scalar measure WRITE (*,"(/' Here is the distribution of common logs of largest (absolute value)' & & /' principal strain-rates (LOG10(MAX(ABS(Ei * 1 s)))) for each element:')") CALL Histogram (log_largest_ei_persec, numel, .FALSE., maximum, minimum) IF (log_strainrate_method == 1) THEN ! group of colored/shaded polygons IF (log_strainrate_interval == 0.0) THEN log_strainrate_interval = (maximum - minimum)/ai_spectrum_count log_strainrate_midvalue = (maximum + minimum)/2. END IF 1072 CALL Prompt_for_Real('What contour interval do you wish?',log_strainrate_interval,log_strainrate_interval) IF (log_strainrate_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") log_strainrate_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1072 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',log_strainrate_midvalue,log_strainrate_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',log_strainrate_lowblue,log_strainrate_lowblue) ELSE CALL Prompt_for_Logical('Should low values be shaded darkly (versus lightly)?',log_strainrate_lowblue,log_strainrate_lowblue) END IF WRITE (*,"(/' Working on log of largest (absolute value) principal strain-rate....')") CALL Begin_Group ! of colored/shaded triangles (there won't be any contours) 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)) t = log_largest_ei_persec(i) IF (MOD(t, log_strainrate_interval) == 0.0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0) THEN t = t - 0.001* log_strainrate_interval ELSE ! t < 0.0 t = t + 0.001 * log_strainrate_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) CALL Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, group = 1) END DO ! i = 1, numel CALL End_Group ! of colored/shaded triangles WRITE (*,"('+Working on log of largest (absolute value) principal strain-rate....DONE.')") CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Bar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! ELSE ! log_strainrate_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL Learn_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.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = log_largest_ei_persec(iele) bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) 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 Bumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & ' ', minimum, maximum, & & bitmap_color_mode, log_strainrate_interval, log_strainrate_midvalue, log_strainrate_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 Spectrum_in_BottomLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Spectrum_in_RightLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! log_strainrate_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( log_largest_ei_persec, & & vw, & ! in LIFO order & nodes, & & node_uvec) just_began_total_strainrate = .TRUE. ! may speed overlay of tensor symbols last_mosaic_choice = choice ! remember this, to guide suggestion of appropriate tensor overlay ! end of CASE (7, 12): log of [largest (absolute value) principal total-strain-rate * 1 s] CASE (8) ! total rotation rate, including faulting, about local vertical axis IF (.NOT.got_parameters) CALL Get_Parameters IF ((TRIM(f_dat) /= 'none').AND.(TRIM(f_dig) /= 'none')) THEN ! there are faults in this model CALL Add_Title('Total Rotation Rate, including Faulting (about vertical axis)') ELSE CALL Add_Title('Total Rotation Rate (about vertical axis)') END IF CALL Group_or_Bitmap (latter_mosaic, rotationrate_method, bitmap_height, bitmap_width) 1080 temp_path_in = path_in IF (got_parameters) THEN feg_file = x_feg ELSE CALL File_List( file_type = "*.feg", & & suggested_file = feg_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which .feg file defines the elements?',feg_file,feg_file) END IF 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 LonLat_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) CALL Press_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 1080 END IF READ (21, *) nfl IF (nfl > 0) CALL No_Fault_Elements_Allowed() CLOSE (21) CALL Add_Title(feg_file) 1081 temp_path_in = path_in IF (got_parameters) THEN vel_file = 'v' // TRIM(token) // ".out" ELSE CALL File_List( file_type = "v*.out", & & suggested_file = vel_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which velocity file should be used?',vel_file,vel_file) END IF 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 Press_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 1081 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 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 Make_Uvec (uvec4, uvec) ! center of element equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) 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_ = ATAN2(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) END DO ! l_ = 1, numel, computing rotation rates in popular units WRITE (*,"(/' Here is the distribution of clockwise rotation rates' & /' (about the vertical axis, in degrees per million years):')") CALL Histogram (omega_degperMa, numel, .FALSE., maximum, minimum) IF (rotationrate_method == 1) THEN ! group of colored/shaded polygons IF (rotationrate_interval == 0.0) THEN rotationrate_interval = (maximum - minimum) / ai_spectrum_count rotationrate_midvalue = (maximum + minimum) / 2.0 END IF 1082 CALL Prompt_for_Real('What contour interval do you wish?',rotationrate_interval,rotationrate_interval) IF (rotationrate_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") rotationrate_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1082 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',rotationrate_midvalue,rotationrate_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',rotationrate_lowblue,rotationrate_lowblue) ELSE CALL Prompt_for_Logical('Should low values be shaded darkly (versus lightly)?',rotationrate_lowblue,rotationrate_lowblue) END IF WRITE (*,"(/' Working on rotation rate....')") CALL Begin_Group ! of colored/shaded triangles (there won't be any contours) 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)) t = omega_degperMa(i) IF (MOD(t, rotationrate_interval) == 0.0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0) THEN t = t - 0.001* rotationrate_interval ELSE ! t < 0.0 t = t + 0.001 * rotationrate_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) CALL Contour_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 DO ! i = 1, numel CALL End_Group ! of colored/shaded triangles WRITE (*,"('+Working on rotation rate....DONE.')") CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = rotationrate_interval, & & midspectrum_value = rotationrate_midvalue, & & low_is_blue = rotationrate_lowblue, & & units = 'clockwise degree/Ma') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Bar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = rotationrate_interval, & & midspectrum_value = rotationrate_midvalue, & & low_is_blue = rotationrate_lowblue, & & units = 'clockwise degree/Ma') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! ELSE ! rotationrate_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL Learn_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.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = omega_degperMa(iele) bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) 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 Bumpy_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 Spectrum_in_BottomLegend (minimum, maximum, 'clockwise degree/Ma', 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 Spectrum_in_RightLegend (minimum, maximum, 'clockwise degree/Ma', 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 (frequency = 440, duration = 250) DEALLOCATE ( omega_degperMa, & & vw, & ! in LIFO order & nodes, & & node_uvec) ! end of 8: rotation rate (of vertical cylinder, about vertical axis) CASE (9) ! log of largest (absolute value) principal strain-rate 1090 IF (.NOT.got_parameters) CALL Get_Parameters IF ((TRIM(f_dat) /= 'none').AND.(TRIM(f_dig) /= 'none')) THEN ! there are faults in this model CALL Add_Title('Continuum Strain-Rate, excluding faulting: log10 of greatest principal rate') ELSE CALL Add_Title('Continuum Strain-Rate: log10(greatest principal rate * 1 s)') END IF CALL Group_or_Bitmap (latter_mosaic, log_strainrate_method, bitmap_height, bitmap_width) temp_path_in = path_in IF (got_parameters) THEN feg_file = x_feg ELSE CALL File_List( file_type = "*.feg", & & suggested_file = feg_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which .feg file defines the elements?',feg_file,feg_file) END IF 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 LonLat_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) CALL Press_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 1090 END IF READ (21, *) nfl IF (nfl > 0) CALL No_Fault_Elements_Allowed() CLOSE (21) CALL Add_Title(feg_file) ALLOCATE ( log_largest_ei_persec(numel) ) temp_path_in = path_in IF ((TRIM(f_dat) /= 'none').AND.(TRIM(f_dig) /= 'none')) THEN ! there are faults in this model continuum_strainrate_file = 'e' // TRIM(token) // ".nko" continuum_strainrate_pathfile = TRIM(temp_path_in)//TRIM(continuum_strainrate_file) OPEN(UNIT = 22, FILE = continuum_strainrate_pathfile, STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(continuum_strainrate_pathfile) DO l_ = 1, numel ! read continuum strainrates at element centers READ (22, *) i, maybe, eps_dot(1), eps_dot(2), eps_dot(3) !convert to scalar measure, for histogram CALL Principal_Axes_22 (eps_dot(1),eps_dot(2),eps_dot(3), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) err = -(e1h + e2h) largest_ei_persec = MAX(ABS(e1h), ABS(e2h), ABS(err)) IF (largest_ei_persec == 0.0) THEN log_largest_ei_persec(l_) = -20.0 ! arbitrary substitute for -infinity! ELSE log_largest_ei_persec(l_) = LOG10(largest_ei_persec) END IF END DO ! l_ = 1, numel, reading continuum strainrates and computing scalar measure CLOSE(22) ELSE ! there are no faults; use same method as in case (12): vel_file = 'v' // TRIM(token) // ".out" vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(vel_pathfile) 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) DO l_ = 1, numel ! compute strainrates at element centers 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 Make_Uvec (uvec4, uvec) ! center of element equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) 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_ = ATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) !convert to scalar measure, for histogram CALL Principal_Axes_22 (eps_dot(1),eps_dot(2),eps_dot(3), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) err = -(e1h + e2h) largest_ei_persec = MAX(ABS(e1h), ABS(e2h), ABS(err)) IF (largest_ei_persec == 0.0) THEN log_largest_ei_persec(l_) = -20.0 ! arbitrary substitute for -infinity! ELSE log_largest_ei_persec(l_) = LOG10(largest_ei_persec) END IF !(not using loop on m = 1,...,7 since values almost identical) END DO ! l_ = 1, numel, computing strainrates and scalar measure DEALLOCATE ( vw ) END IF WRITE (*,"(/' Here is the distribution of common logs of largest (absolute value)' & & /' principal strain-rates (LOG10(MAX(ABS(Ei * 1 s)))) for each element:')") CALL Histogram (log_largest_ei_persec, numel, .FALSE., maximum, minimum) IF (log_strainrate_method == 1) THEN ! group of colored/shaded polygons IF (log_strainrate_interval == 0.0) THEN log_strainrate_interval = (maximum - minimum)/ai_spectrum_count log_strainrate_midvalue = (maximum + minimum)/2. END IF 1092 CALL Prompt_for_Real('What contour interval do you wish?',log_strainrate_interval,log_strainrate_interval) IF (log_strainrate_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") log_strainrate_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1092 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',log_strainrate_midvalue,log_strainrate_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',log_strainrate_lowblue,log_strainrate_lowblue) ELSE CALL Prompt_for_Logical('Should low values be shaded darkly (versus lightly)?',log_strainrate_lowblue,log_strainrate_lowblue) END IF WRITE (*,"(/' Working on log of largest (absolute value) principal strain-rate....')") CALL Begin_Group ! of colored/shaded triangles (there won't be any contours) 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)) t = log_largest_ei_persec(i) IF (MOD(t, log_strainrate_interval) == 0.0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0) THEN t = t - 0.001* log_strainrate_interval ELSE ! t < 0.0 t = t + 0.001 * log_strainrate_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) CALL Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, group = 1) END DO ! i = 1, numel CALL End_Group ! of colored/shaded triangles WRITE (*,"('+Working on log of largest (absolute value) principal strain-rate....DONE.')") CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Bar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! ELSE ! log_strainrate_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL Learn_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.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = log_largest_ei_persec(iele) bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) 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 Bumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & ' ', minimum, maximum, & & bitmap_color_mode, log_strainrate_interval, log_strainrate_midvalue, log_strainrate_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 Spectrum_in_BottomLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Spectrum_in_RightLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! log_strainrate_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( log_largest_ei_persec, & & nodes, & ! in LIFO order & node_uvec) just_began_continuum_strainrate = .TRUE. ! may speed overlay of tensor symbols ! end of 9: log of [largest (absolute value) principal continuum-strain-rate * 1 s] END SELECT ! (choice) = mosaic type latter_mosaic = .TRUE. ! since one is already laid down WRITE (*,"(' ')") suggest_logical = mosaic_count < old_mosaic_count CALL Prompt_for_Logical('Do you want additional mosaics?',suggest_logical,do_more_mosaics) IF (do_more_mosaics) GO TO 1000 ! mosaics menu END IF ! do mosaic !-------------------------- OVERLAYS ------------------------------ !----- (symbols composed mostly of lines; mostly transparent) ----- overlay_count = 0 ! counts number of overlays in this map 2000 WRITE (*,"(//' ----------------------------------------------------------------------')") WRITE (*,"( /' LINE AND SYMBOL OVERLAY LAYERS AVAILABLE:')") !GPBoverlays WRITE (*,"( ' 1 :: digitised basemap (lines type)')") WRITE (*,"( ' 2 :: outline of finite-element grid')") WRITE (*,"( ' 3 :: finite-element grid')") WRITE (*,"( ' 4 :: fault traces')") WRITE (*,"( ' 5 :: fault heave rates (according to data)')") WRITE (*,"( ' 6 :: fault heave rates (according to NeoKinema)')") WRITE (*,"( ' 7 :: long-term-average velocity vectors')") WRITE (*,"( ' 8 :: geodetic benchmarks with velocities')") WRITE (*,"( ' 9 :: total long-term-average strain-rates, including faulting')") WRITE (*,"( ' 10 :: continuum long-term-average strain-rates, excluding faulting')") WRITE (*,"( ' 11 :: most-compressive horizontal principal strain-rate axes')") WRITE (*,"( ' 12 :: stress direction data')") WRITE (*,"( ' 13 :: stress directions interpolated by NeoKinema')") WRITE (*,"( ' 14 :: earthquake epicenters from EarthQuake Catalog .eqc file')") WRITE (*,"( ' 15 :: volcanoes (Recent, subaerial) from file volcanoes.dat')") WRITE (*,"( ' 16 :: velocity vectors from plate model')") WRITE (*,"( ' 17 :: Euler poles from plate model')") WRITE (*,"( ' 18 :: boundary slip-rates from plate model')") WRITE (*,"( ' 19 :: short-term interseismic velocity vectors')") WRITE (*,"( ' 20 :: short-term interseismic strain-rates (largely elastic)')") WRITE (*,"( ' ----------------------------------------------------------------------')") suggest_logical = old_overlay_count > overlay_count IF (overlay_count == 0) CALL Prompt_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) IF (just_began_surface_flow) THEN ! suggestion to save time IF (last_mosaic_choice == 6) THEN ! mosaic was long-term-average velocity field choice = 7 ELSE IF (last_mosaic_choice == 11) THEN ! mosaic was short-term interseismic velocity field choice = 19 ELSE choice = 0 ! (should not happen) END IF END IF ! just_began_surface_flow IF (just_began_total_strainrate) THEN ! suggestion to save time IF (last_mosaic_choice == 7) THEN choice = 9 ! long-term-average ELSE IF (last_mosaic_choice == 12) THEN choice = 20 ! short-term interseismic ELSE choice = 0 ! (should not happen) END IF END IF IF (just_began_continuum_strainrate) choice = 10 ! suggestion to save time CALL Prompt_for_Integer('Which overlay type should be added?',choice,choice) IF ((choice < 1).OR.(choice > 20)) THEN WRITE (*,"(/' ERROR: Please select an integer from the list!')") CALL Press_Enter mt_flashby = .FALSE. GO TO 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( file_type = "*.dig", & & suggested_file = lines_basemap_file, & & using_path = temp_path_in) CALL Prompt_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 Set_Line_Style (width_points = 2.0, dashed = .FALSE.) CALL Set_Stroke_Color (color_name = 'foreground') CALL Dig_Type (lines_basemap_pathfile, 21, dig_is_lonlat, any_titles) CALL Prompt_for_Logical('Is this basemap written in (lon,lat) coordinates?',dig_is_lonlat,dig_is_lonlat) IF ((.NOT.xy_defined).AND.(.NOT.dig_is_lonlat)) THEN WRITE (*,"(' ERROR: Start NeoKineMap over again and define the (x,y) coordinates.')") CALL Press_Enter STOP ' ' END IF IF (any_titles) THEN WRITE (*, "(/' Title lines were detected in this .dig file;')") CALL Prompt_for_Logical('do you want to include these titles in the plot?',plot_dig_titles,plot_dig_titles) IF (plot_dig_titles) THEN WRITE (*,"(' -------------------------------------------------')") WRITE (*,"(' Choose Alignment Method for Titles:')") WRITE (*,"(' 1: upright, at geometric center of polyline')") WRITE (*,"(' 2: parallel to first segment of polyline')") WRITE (*,"(' -------------------------------------------------')") 2011 CALL Prompt_for_Integer('Which alignment method?',dig_title_method,dig_title_method) IF ((dig_title_method < 1).OR.(dig_title_method > 2)) THEN WRITE (*,"(' ERROR: Illegal choice of method.')") mt_flashby = .FALSE. GO TO 2011 END IF ! bad choice END IF ! plot_dig_titles END IF ! any_titles WRITE (*,"(/' Working on basemap....')") polygons = .FALSE. IF (dig_is_lonlat) THEN CALL Plot_Dig (7, lines_basemap_pathfile, polygons, 21, in_ok) ELSE CALL Plot_Dig (3, lines_basemap_pathfile, polygons, 21, in_ok) END IF IF (.NOT.in_ok) THEN mt_flashby = .FALSE. GO TO 2010 END IF IF (any_titles .AND. plot_dig_titles) THEN CALL Set_Fill_or_Pattern (.FALSE., 'foreground') IF (dig_is_lonlat) THEN CALL Plot_Dig (7, lines_basemap_pathfile, polygons, 21, in_ok, dig_title_method) ELSE CALL Plot_Dig (3, lines_basemap_pathfile, polygons, 21, in_ok, dig_title_method) END IF END IF ! any_titles .AND. plot_dig_titles 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') IF (ios /= 0) CALL Could_Not_Find_File(lines_basemap_pathfile) DO i = 1, 3 READ (21, *, IOSTAT = ios) lon, lat IF (ios /= 0) THEN ! got possible title BACKSPACE (21) READ (21,"(A)") line CALL Add_Title(line) END IF END DO CLOSE (21) CALL BEEPQQ (frequency = 440, duration = 250) ! end of basemap overlay CASE (2:3) ! finite-element grid: outline (2), all(3) !Note: Code added to produce output file "outline.dig" which is needed by Long_Term_Seismicity CALL Add_Title('Finite Element Grid') 2020 temp_path_in = path_in 2030 IF (got_parameters) THEN feg_file = x_feg ELSE !don't force use of parameter file; it may not exist yet. CALL File_List( file_type = "*.feg", & & suggested_file = feg_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file should be plotted?',feg_file,feg_file) END IF 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) CALL Press_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 2020 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 LonLat_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 IF (nfl > 0) CALL No_Fault_Elements_Allowed() CLOSE(21) IF (choice == 2) THEN ! plot outline only WRITE (*,"(/' Working on outline of grid....')") ! Build library of external edge segments (unsorted) nseg = 0 DO i = 1, numel ! first, look for external edges of spherical triangles DO j = 1, 3 jp = 1 + MOD(j,3) na = nodes(j,i) nb = nodes(jp,i) mated = .FALSE. might_mate_1: DO k = 1, numel ! mating to another spherical triangle? 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_1 END IF ! mate was found END DO ! l = 1, 3 sides of trial spherical triangle END DO might_mate_1 ! 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; looking for external edges of spherical triangles !link segments to create outline CALL Set_Line_Style (width_points = 4.0, dashed = .FALSE.) CALL Set_Stroke_Color ('gray______') j = 1 ! begin with first segment uvec1(1:3) = segments(1:3,1,j) CALL New_L45_Path (5, uvec1) OPEN (UNIT = 55, FILE = TRIM(path_out)//"outline_of_"//TRIM(feg_file)//".dig") WRITE (55, "('outline of ',A)") TRIM(feg_file) CALL Uvec_2_LonLat(uvec1, longitude, latitude) WRITE (55, "(1X,SP,ES12.5,',',ES12.5)") longitude, latitude DO i = 1, nseg uvec2(1:3) = segments(1:3,2,j) CALL Great_to_L45 (uvec2) CALL Uvec_2_LonLat(uvec2, longitude, latitude) WRITE (55, "(1X,SP,ES12.5,',',ES12.5)") longitude, latitude 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 End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) WRITE (55, "('*** end of line segment ***')") CLOSE(55) WRITE (*,"('+Working on outline of grid....DONE.')") ELSE ! 3; plot (at least some) elements and nodes, with numbers (in separate groups) IF (choice == 3) CALL Prompt_for_Real('Desired radius of node circles, in points (or 0 for none)?',node_radius_points,node_radius_points) WRITE (*,"(/' Working on finite-element grid....')") IF ((choice == 3).AND.(numnod > 0).AND.(node_radius_points >= 1.0)) THEN CALL Begin_Group ! of nodes IF (ai_using_color) THEN CALL Set_Fill_or_Pattern (.FALSE., 'dark_blue_') ELSE CALL Set_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.0003528 * & & mp_scale_denominator * & & Conformal_Deflation (uvec1) / R CALL Turn_To (azimuth_radians = 0.0, & & base_uvec = uvec1, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL New_L45_Path (5, uvec2) CALL Small_To_L45 (uvec1, uvec2) CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END DO ! i = 1, numnod CALL End_Group ! of nodes END IF ! numnod > 0 and node_radius_points >= 1. IF (choice == 3) THEN ! plot node numbers CALL Begin_Group ! of node numbers IF (ai_using_color) THEN CALL Set_Fill_or_Pattern (.FALSE., 'dark_blue_') ELSE CALL Set_Fill_or_Pattern (.FALSE., 'foreground') END IF DO i = 1, numnod uvec1(1:3) = node_uvec(1:3,i) WRITE (c6,"(I6)") i c6 = ADJUSTL(c6) CALL L5_Text (uvec = uvec1, angle_radians = 0.0, from_east = .FALSE., & & font_points = 8, lr_fraction = -0.2, ud_fraction = 0.4, & & text = TRIM(c6)) END DO ! i = 1, numnod CALL End_Group ! of node numbers END IF ! node numbers are wanted IF ((choice == 3).AND.(numel > 0)) THEN ! plot elements CALL Begin_Group ! of elements CALL Set_Line_Style (width_points = 1.0, dashed = .TRUE., & & on_points = 6., off_points = 3.) IF (ai_using_color) THEN CALL Set_Stroke_Color ('green_____') ELSE CALL Set_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 New_L45_Path (5, uvec1) uvec2(1:3) = node_uvec(1:3,nodes(jp1,i)) CALL Great_To_L45 (uvec2) CALL End_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! virgin END DO ! j = 1, 3 END DO ! i = 1, numel CALL End_Group ! of elements CALL Begin_Group ! of element numbers IF (ai_using_color) THEN CALL Set_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL Set_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.0 CALL Make_Uvec(uvec2, uvec1) WRITE (c6,"(I6)") i c6 = ADJUSTL(c6) CALL L5_Text (uvec = uvec1, angle_radians = 0.0, from_east = .FALSE., & & font_points = 8, lr_fraction = 0.5, ud_fraction = 0.4, & & text = TRIM(c6)) END DO ! i = 1, numel CALL End_Group ! of element numbers END IF ! elements should be plotted WRITE (*,"('+Working on finite-element grid....DONE.')") END IF ! choice = 2 (outline) or 3 (nodes and elements) DEALLOCATE ( node_uvec, segments ) DEALLOCATE ( nodes ) CALL BEEPQQ (frequency = 440, duration = 250) ! end of (2) outline or (3) full finite element grid (which has no fault elements) CASE (4) ! fault traces CALL Add_Title("Fault Traces") 2040 temp_path_in = path_in IF (got_parameters) THEN traces_file = f_dig ELSE !don't require use of parameter file; it may not have been created yet. CALL File_List(file_type = "f*.dig", & & suggested_file = traces_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file should be plotted?',traces_file,traces_file) END IF 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 got_parameters = .FALSE. GOTO 2040 END IF CLOSE (21) CALL Prompt_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 Begin_Group CALL Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, tick_points) CALL End_Group ELSE IF (bottom) THEN CALL Begin_Group CALL Fault_Key_Bottom (bottomlegend_gap_points, bottomlegend_used_points, tick_points) CALL End_Group END IF ! end of (4) fault traces overlay CASE (5) ! fault heave rates (according to data) CALL Add_Title("Fault Heave Rates (from data)") 2050 temp_path_in = path_in IF (got_parameters) THEN traces_file = f_dig ELSE !don't force use of parameter file; it may not have been created yet. CALL File_List(file_type = "f*.dig", & & suggested_file = traces_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which fault traces should be plotted?',traces_file,traces_file) END IF 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 got_parameters = .FALSE. GOTO 2050 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_mma(high_trace), segment_sense(high_trace) ) trace_mma = 0. ! whole array segment_sense = ' ' ! whole array CALL Prompt_for_Real('How large are the dip ticks (in points)?',tick_points,tick_points) WRITE (*,"(' ')") 2051 temp_path_in = path_in IF (got_parameters) THEN f_nki_file = 'f' // TRIM(token) // ".nki" ELSE !don't force use of parameter file'; it may not have been created yet. CALL File_List(file_type = "f*.nki", & & suggested_file = f_nki_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which offset-rates file should be used?',f_nki_file,f_nki_file) END IF f_nki_pathfile = TRIM(temp_path_in)//TRIM(f_nki_file) OPEN(UNIT = 22, FILE = f_nki_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 got_parameters = .FALSE. GOTO 2051 END IF READ (22,"(A)") f_nki_format READ (22,"(A)") f_nki_titles read_f_nki: DO ! reading to end of file READ (22, f_nki_format, IOSTAT = ios) c6, c50, v_mma IF (ios == -1) EXIT read_f_nki ! EOF READ (c6, "(1X,I4,1X)") i !segment_sense(i) = c6(6:6) c1 = c6(6:6) IF ((c1 == 'T').OR.(c1 == 't')) THEN test_mma = v_mma * cot_thrust_dip ELSE IF ((c1 == 'P').OR.(c1 == 'p')) THEN test_mma = v_mma ELSE IF ((c1 == 'S').OR.(c1 == 's')) THEN test_mma = v_mma ELSE IF ((c1 == 'N').OR.(c1 == 'n')) THEN test_mma = v_mma * cot_normal_dip ELSE IF ((c1 == 'D').OR.(c1 == 'd')) THEN test_mma = v_mma ELSE IF ((c1 == 'R').OR.(c1 == 'r')) THEN test_mma = v_mma ELSE IF ((c1 == 'L').OR.(c1 == 'l')) THEN test_mma = v_mma END IF IF (test_mma > trace_mma(i)) THEN trace_mma(i) = test_mma segment_sense(i) = c1 END IF END DO read_f_nki CLOSE (22) WRITE (*,"(/' Here is the distribution of non-zero heave rates'& &/' (changes in horizontal velocity across faults) in mm/a):')") CALL Histogram (trace_mma, high_trace, .TRUE., maximum, minimum) WRITE (*,"(/' In answering the following, NOTE that line-widths computed as over 100')") WRITE (*,"( ' points ( = 1.39 inches = 35.3 mm) wide are shown as 100-point lines')") WRITE (*,"( ' to avoid obscuring other information in the map.')") CALL Prompt_for_Real('What representative rate should be plotted in the key?',dv_scale_mma,dv_scale_mma) CALL Prompt_for_Real('How many points wide should this rate be plotted?',dv_scale_points,dv_scale_points) WRITE (*,"(/' Working on heave rates of faults....')") CALL Fault_Traces (trace_choice = 1, width_array = trace_mma, & & dw_scale_amount = dv_scale_mma, dw_scale_points = dv_scale_points, & & sense = segment_sense) DEALLOCATE ( trace_mma, segment_sense ) CALL Chooser(bottom, right) IF (right) THEN !plot sample trace with width = dv_scale_points, !labelled with rate = dv_scale_mma CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points - 12. CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 12., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Change in') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 24., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'horizontal') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 36., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'velocity') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 48., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'across fault') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 60., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = '(mm/a):') number8 = ADJUSTL(ASCII8(dv_scale_mma)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 72., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(number8)) CALL Set_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL Set_Stroke_Color ('green_____') ELSE CALL Set_Stroke_Color ('foreground') END IF CALL New_L12_Path (1, x1_points + 6., y2_points - 75. - 0.39 * dv_scale_points) CALL Line_to_L12 (x2_points - 6., y2_points - 75. - 0.39 * dv_scale_points) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 87. + dv_scale_points CALL Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, tick_points) CALL End_Group ELSE IF (bottom) THEN !plot sample trace with width = dv_scale_points, !labelled with rate = dv_scale_mma CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 79., & & y_points = 0.5*(y1_points + y2_points) + 12., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Change in horizontal velocity') CALL L12_Text (level = 1, & & x_points = x1_points + 79., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'across fault (mm/a):') number8 = ADJUSTL(ASCII8(dv_scale_mma)) CALL L12_Text (level = 1, & & x_points = x1_points + 79., & & y_points = 0.5*(y1_points + y2_points) - 12., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(number8)) CALL Set_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL Set_Stroke_Color ('green_____') ELSE CALL Set_Stroke_Color ('foreground') END IF CALL New_L12_Path (1, (x1_points + 79.) - 30., 0.5*(y1_points + y2_points) - 15. - 0.39 * dv_scale_points) CALL Line_to_L12 ((x1_points + 79.) + 30., 0.5*(y1_points + y2_points) - 15. - 0.39 * dv_scale_points) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 158. CALL Fault_Key_Bottom (bottomlegend_gap_points, bottomlegend_used_points, tick_points) CALL End_Group END IF ! bottom or right legend CALL Add_Title(traces_file) CALL Add_Title(f_nki_file) WRITE (*,"('+Working on heave rates of faults....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of (5) fault heave rates (according to data) overlay CASE (6) ! fault heave rates (according to NeoKinema) IF (.NOT.got_parameters) CALL Get_Parameters 2060 temp_path_in = path_in WRITE (*,"(' ---------------------------------------------------')") WRITE (*,"(' Choose Presentation Method for Model Heave-Rates:')") WRITE (*,"(' 1: elegant plot, using trace-average rates')") WRITE (*,"(' 2: detailed plot, of individual segment rates')") WRITE (*,"(' ---------------------------------------------------')") 2061 CALL Prompt_for_Integer('Which presentation method?',heave_rate_method,heave_rate_method) IF ((heave_rate_method < 1).OR.(heave_rate_method > 2)) THEN WRITE (*,"(' ERROR: Illegal choice of method.')") mt_flashby = .FALSE. GO TO 2061 END IF ! bad choice IF (heave_rate_method == 1) THEN ! elegant plot, showing each trace as continuous line of constant width (with mitering): 2062 IF (got_parameters) THEN CALL Add_Title("Fault Heave Rates (from model " // TRIM(token) // ')') f_nko_file = 'f' // TRIM(token) // ".nko" ELSE CALL Add_Title("Fault Heave Rates from Model") CALL File_List(file_type = "f*.nko", & & suggested_file = f_nko_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which f*.nko file should be plotted?',f_nko_file,f_nko_file) END IF CALL Add_Title("shown using trace-averaged rates from " // TRIM(f_nko_file)) f_nko_pathfile = TRIM(temp_path_in)//TRIM(f_nko_file) OPEN(UNIT = 22, FILE = f_nko_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 got_parameters = .FALSE. GOTO 2062 END IF !Read through once to find the number of fault offset-rate (component) lines: READ (22, "(A)") f_nko_format READ (22, *) ! f_nko header line fault_count = 0 DO READ (22, f_nko_format, IOSTAT = ios) c6 IF (ios == -1) EXIT ! EOF first_byte = c6(1:1) IF ((first_byte == 'F').OR.(first_byte == 'f')) THEN fault_count = fault_count + 1 END IF END DO CLOSE (22) ALLOCATE ( f_trace(fault_count) ) ! integer from F1234D string (e.g., 1234) ALLOCATE ( f_c1(fault_count) ) ALLOCATE ( f_rate_mmpa(fault_count) ) !Second reading is to remember heave rates (some converted from throw rates); may be negative at this point OPEN(UNIT = 22, FILE = f_nko_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (22, "(A)") f_nko_format READ (22, *) ! f_nko header line read_f_nko: DO i = 1, fault_count ! reading to end of file READ (22, f_nko_format, IOSTAT = ios) c6, c50, t1, t2, creeping, v_mma ! c50, t1, and t2 are not used IF (ios == -1) EXIT read_f_nko ! EOF c4 = c6(2:5) ! integer part READ (c4,"(I4)") j f_trace(i) = j f_c1(i) = c6(6:6) c1 = f_c1(i) IF ((c1 == 'T').OR.(c1 == 't')) THEN f_rate_mmpa(i) = v_mma * cot_thrust_dip ELSE IF ((c1 == 'P').OR.(c1 == 'p')) THEN f_rate_mmpa(i) = v_mma ELSE IF ((c1 == 'S').OR.(c1 == 's')) THEN f_rate_mmpa(i) = v_mma ELSE IF ((c1 == 'N').OR.(c1 == 'n')) THEN f_rate_mmpa(i) = v_mma * cot_normal_dip ELSE IF ((c1 == 'D').OR.(c1 == 'd')) THEN f_rate_mmpa(i) = v_mma ELSE IF ((c1 == 'R').OR.(c1 == 'r')) THEN f_rate_mmpa(i) = v_mma ELSE IF ((c1 == 'L').OR.(c1 == 'l')) THEN f_rate_mmpa(i) = v_mma END IF END DO read_f_nko CLOSE (22) !Replace any negative heave-rates with positive by changing sense of fault (offset-rate component): DO i = 1, fault_count IF (f_rate_mmpa(i) < 0.0) THEN !"reverse" indicator byte (semantically): c1 = f_c1(i) IF ((c1 == 'S').OR.(c1 == 's')) THEN f_c1(i) = 'D' ELSE IF ((c1 == 'P').OR.(c1 == 'p')) THEN f_c1(i) = 'D' ELSE IF ((c1 == 'T').OR.(c1 == 't')) THEN f_c1(i) = 'N' ELSE IF ((c1 == 'D').OR.(c1 == 'd')) THEN f_c1(i) = 'P' ELSE IF ((c1 == 'N').OR.(c1 == 'n')) THEN f_c1(i) = 'T' ELSE IF ((c1 == 'R').OR.(c1 == 'r')) THEN f_c1(i) = 'L' ELSE IF ((c1 == 'L').OR.(c1 == 'l')) THEN f_c1(i) = 'R' END IF f_rate_mmpa(i) = -f_rate_mmpa(i) END IF ! (f_rate_mmpa(i) < 0.0) END DO ! i = 1, fault_count; checking the sense !Sort the arrays by f_rate_mmpa(:), highest to lowest DO i = 1, fault_count-1 ! replace values one-by-one with the highest remaining !find the highest value in the range i:fault_count i_high = i h_high = f_rate_mmpa(i) DO j = i+1, fault_count IF (f_rate_mmpa(j) > h_high) THEN i_high = j h_high = f_rate_mmpa(j) END IF END DO ! j = i+1, fault_count; inner loop of the sort (searching for highest value) IF (i_high /= i) THEN ! swap i and i_high contents !first, save values that are to be replaced, in position i: j = f_trace(i) c1 = f_c1(i) t = f_rate_mmpa(i) !next, put contents of position i_high into position i: f_trace(i) = f_trace(i_high) f_c1(i) = f_c1(i_high) f_rate_mmpa(i) = f_rate_mmpa(i_high) !finally, replace i_high values with saved values: f_trace(i_high) = j f_c1(i_high) = c1 f_rate_mmpa(i_high) = t END IF ! swap required END DO ! i = 1, fault_count-1; outer loop of the sort (value being replaced) !Select scale: WRITE (*,"(/' Here is the distribution of non-zero model heave rates'& &/' (changes in horizontal velocity across faults) in mm/a:')") CALL Histogram (f_rate_mmpa, fault_count, .TRUE., maximum, minimum) WRITE (*,"(/' In answering the following, NOTE that line-widths computed as over 100')") WRITE (*,"( ' points ( = 1.39 inches = 35.3 mm) wide are shown as 100-point lines')") WRITE (*,"( ' to avoid obscuring other information in the map.')") CALL Prompt_for_Real('What representative rate should be plotted in the key?',dv_scale_mma,dv_scale_mma) CALL Prompt_for_Real('How many points wide should this rate be plotted?',dv_scale_points,dv_scale_points) !Get fault traces into memory from f_token.dig: 2063 temp_path_in = path_in IF (got_parameters) THEN traces_file = f_dig ELSE !don't require use of parameter file; it may not have been created yet. CALL File_List(file_type = "f*.dig", & & suggested_file = traces_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file of digitized fault traces should be plotted?',traces_file,traces_file) END IF 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 got_parameters = .FALSE. GOTO 2063 ELSE ! Scan for total length and highest trace number: f_dig_count = 0 ! total number of digitized points in the file f_highest = 0 ! highest trace index, e.g. 2096 from F2096N loop_thru: DO READ (21, "(A)", IOSTAT = read_status) c50 IF (read_status == 0) THEN ! read was successful IF ((c50(1:2) == ' +') .OR. (c50(1:2) == ' -')) THEN f_dig_count = f_dig_count + 1 ELSE IF ((c50(1:1) == 'F') .OR. (c50(1:1) == 'f')) THEN READ (c50,"(1X,I4)", IOSTAT = read_status) i IF (read_status == 0) THEN f_highest = MAX (f_highest, i) END IF END IF ELSE; EXIT loop_thru; END IF END DO loop_thru CLOSE (21) ! (will be re-read) ! allocate arrays to hold list of uvecs, and pointers to them: ALLOCATE ( trace (3, f_dig_count) ) ALLOCATE ( trace_loc (2, f_highest) ) trace_loc = 0 ! whole array; if any trace has no points (or only 1) this will be a warning ! re-read f_dig file and memorize contents: OPEN (UNIT = 21, FILE = traces_pathfile, STATUS = "OLD", ACTION = "READ", PAD = "YES") in_trace = .FALSE. i = 0 read_dig: DO READ (21, "(A)", IOSTAT = read_status) c50 IF (read_status == 0) THEN ! read was successful IF ((c50(1:2) == ' +') .OR. (c50(1:2) == ' -')) THEN got_point = .TRUE. got_index = .FALSE. READ (c50,*) t1, t2 ! E longitude, N latitude IF (ABS(t2) > 90.001) THEN PRINT "(' Bad latitude ',F10.2,' in ',A)", t2, TRIM(f_dig) STOP END IF ELSE IF ((c50(1:1) == 'F') .OR. (c50(1:1) == 'f')) THEN got_point = .FALSE. READ (c50,"(1X,I4)") j2 ! new trace number (NOTE: Any slip-sense bytes are ignored.) got_index = .TRUE. ELSE ! most likely, '*** end of line segment ***' got_point = .FALSE. got_index = .FALSE. END IF ELSE; EXIT read_dig; END IF IF (in_trace) THEN IF (got_point) THEN i = i + 1 CALL LonLat_2_Uvec(t1, t2, uvec) trace(1:3, i) = uvec(1:3) trace_loc(2, j1) = i ELSE ! *** end ... in_trace = .FALSE. END IF ELSE ! (not in_trace) IF (got_index) THEN j1 = j2 ! new index becomes current index ELSE IF (got_point) THEN i = i + 1 CALL LonLat_2_Uvec(t1, t2, uvec) trace(1:3, i) = uvec(1:3) trace_loc(1, j1) = i in_trace = .TRUE. ELSE ! *** end ... END IF END IF ! (in_trace) END DO read_dig CLOSE (21) ! close f_dig for the last time END IF ! f_dig has problems, or not WRITE (*,"(/' Working on model heave rates of faults....')") !begin plotting the group of ribbons, with widest ones plotted first (so they end up on the bottom): CALL Begin_Group DO i = 1, fault_count ! (actually, refers to non-header lines in f_token.nko) c1 = f_c1(i) IF (ai_using_color) THEN IF ((c1 == 'L').OR.(c1 == 'l')) THEN color_name = 'brown_____' ELSE IF ((c1 == 'T').OR.(c1 == 't')) THEN color_name = 'mid_blue__' ELSE IF ((c1 == 'P').OR.(c1 == 'p')) THEN color_name = 'dark_blue_' ELSE IF ((c1 == 'S').OR.(c1 == 's')) THEN color_name = 'dark_blue_' ELSE IF ((c1 == 'D').OR.(c1 == 'd')) THEN color_name = 'red_______' ELSE IF ((c1 == 'R').OR.(c1 == 'r')) THEN color_name = 'green_____' ELSE IF ((c1 == 'N').OR.(c1 == 'n')) THEN color_name = 'bronze____' ELSE ! any unexpected code color_name = 'foreground' END IF CALL Set_Stroke_Color (color_name) ELSE CALL Set_Stroke_Color (color_name = 'foreground') END IF ! ai_using_color or not width_points = f_rate_mmpa(i) * dv_scale_points / dv_scale_mma CALL Set_Line_Style (width_points = width_points, dashed = .FALSE.) IF (trace_loc(2, f_trace(i)) > trace_loc(1, f_trace(i))) THEN ! non-degenerate trace uvec(1:3) = trace(1:3, trace_loc(1, f_trace(i))) CALL New_L45_Path (5, uvec) DO j = 1+trace_loc(1, f_trace(i)), trace_loc(2, f_trace(i)) uvec(1:3) = trace(1:3, j) CALL Great_to_L45 (uvec) END DO CALL End_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! non-degenerate trace END DO ! i = 1, fault_count (actually, refers to non-header lines in f_token.nko) CALL End_Group DEALLOCATE ( trace_loc ) ! in LIFO order DEALLOCATE ( trace ) DEALLOCATE ( f_rate_mmpa ) DEALLOCATE ( f_c1 ) DEALLOCATE ( f_trace ) ELSE IF (heave_rate_method == 2) THEN ! detailed plot, with each segment plotted separately (no mitering) 2064 IF (got_parameters) THEN CALL Add_Title("Fault Heave Rates (from model " // TRIM(token) // ')') heave_segments_file = 'h' // TRIM(token) // ".nko" ELSE CALL Add_Title("Fault Heave Rates from Model") CALL File_List(file_type = "h*.dig", & & suggested_file = heave_segments_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which h*.nko file should be plotted?',heave_segments_file,heave_segments_file) END IF CALL Add_Title("shown using individual segment rates from " // TRIM(heave_segments_file)) heave_segments_pathfile = TRIM(temp_path_in)//TRIM(heave_segments_file) OPEN(UNIT = 21, FILE = heave_segments_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 got_parameters = .FALSE. GOTO 2064 END IF !Read through once to find the number of segments: segment_count = 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 segment_count = segment_count + 1 END IF END DO CLOSE (21) !Read a second time to memorize: the heave-rates, in mm/a (converted to a non-negative number); ! the fault type (S, P, T, N, D, R, L). !Note: All segments must be memorized so that they can be sorted, to plot thinner-on-wider. ALLOCATE ( segment_sense(segment_count) ) ! swapped in sense (if necessary), so heave rate is positive ALLOCATE ( heave_rate_mmpa(segment_count) ) ALLOCATE ( segment_uvecs(3, 2, segment_count) ) OPEN(UNIT = 21, FILE = heave_segments_pathfile, STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(heave_segments_pathfile) DO i = 1, segment_count READ (21, "(A6,13X,F12.3,10X,F8.3,1X,F7.3,3X,F8.3,1X,F7.3)", IOSTAT = ios) c6, t, lon1, lat1, lon2, lat2 segment_sense(i) = c6(6:6) ! may be reversed in a later loop heave_rate_mmpa(i) = t ! at this point, may be negative, if so reported (original data only, not shadow pseudo-data) CALL LonLat_2_Uvec(lon1, lat1, uvec) segment_uvecs(1:3, 1, i) = uvec(1:3) CALL LonLat_2_Uvec(lon2, lat2, uvec) segment_uvecs(1:3, 2, i) = uvec(1:3) END DO CLOSE (21) !Replace any negative heave-rates with positive by changing sense of fault: DO i = 1, segment_count IF (heave_rate_mmpa(i) < 0.0) THEN !reverse segment_sense(i) IF ((segment_sense(i) == 'S').OR.(segment_sense(i) == 's')) THEN segment_sense(i) = 'D' ELSE IF ((segment_sense(i) == 'P').OR.(segment_sense(i) == 'p')) THEN segment_sense(i) = 'D' ELSE IF ((segment_sense(i) == 'T').OR.(segment_sense(i) == 't')) THEN segment_sense(i) = 'N' ELSE IF ((segment_sense(i) == 'D').OR.(segment_sense(i) == 'd')) THEN segment_sense(i) = 'P' ELSE IF ((segment_sense(i) == 'N').OR.(segment_sense(i) == 'n')) THEN segment_sense(i) = 'T' ELSE IF ((segment_sense(i) == 'R').OR.(segment_sense(i) == 'r')) THEN segment_sense(i) = 'L' ELSE IF ((segment_sense(i) == 'L').OR.(segment_sense(i) == 'l')) THEN segment_sense(i) = 'R' END IF heave_rate_mmpa(i) = -heave_rate_mmpa(i) END IF ! (heave_rate_mmpa(i) < 0.0) END DO ! i = 1, segment_count; checking the sense !Sort the arrays by heave_rate_mmpa(:), highest to lowest DO i = 1, segment_count-1 ! replace values one-by-one with the highest remaining !find the highest value in the range i:segment_count i_high = i h_high = heave_rate_mmpa(i) DO j = i+1, segment_count IF (heave_rate_mmpa(j) > h_high) THEN i_high = j h_high = heave_rate_mmpa(j) END IF END DO ! j = i+1, segment_count; inner loop of the sort (searching for highest value) IF (i_high /= i) THEN ! swap i and i_high contents !first, save values that are to be replaced, in position i: t = heave_rate_mmpa(i) c1 = segment_sense(i) uvec1(1:3) = segment_uvecs(1:3, 1, i) uvec2(1:3) = segment_uvecs(1:3, 2, i) !next, put contents of position i_high into position i: heave_rate_mmpa(i) = heave_rate_mmpa(i_high) segment_sense(i) = segment_sense(i_high) segment_uvecs(1:3, 1, i) = segment_uvecs(1:3, 1, i_high) segment_uvecs(1:3, 2, i) = segment_uvecs(1:3, 2, i_high) !finally, replace i_high values with saved values: heave_rate_mmpa(i_high) = t segment_sense(i_high) = c1 segment_uvecs(1:3, 1, i_high) = uvec1(1:3) segment_uvecs(1:3, 2, i_high) = uvec2(1:3) END IF ! swap required END DO ! i = 1, segment_count-1; outer loop of the sort (value being replaced) !Select scale: WRITE (*,"(/' Here is the distribution of non-zero model heave rates'& &/' (changes in horizontal velocity across faults) in mm/a:')") CALL Histogram (heave_rate_mmpa, segment_count, .TRUE., maximum, minimum) WRITE (*,"(/' In answering the following, NOTE that line-widths computed as over 100')") WRITE (*,"( ' points ( = 1.39 inches = 35.3 mm) wide are shown as 100-point lines')") WRITE (*,"( ' to avoid obscuring other information in the map.')") CALL Prompt_for_Real('What representative rate should be plotted in the key?',dv_scale_mma,dv_scale_mma) CALL Prompt_for_Real('How many points wide should this rate be plotted?',dv_scale_points,dv_scale_points) WRITE (*,"(/' Working on model heave rates of faults....')") !begin plotting the group of ribbons, with widest ones plotted first (so they end up on the bottom): CALL Begin_Group DO i = 1, segment_count c1 = segment_sense(i) IF (ai_using_color) THEN IF ((c1 == 'L').OR.(c1 == 'l')) THEN color_name = 'brown_____' ELSE IF ((c1 == 'T').OR.(c1 == 't')) THEN color_name = 'mid_blue__' ELSE IF ((c1 == 'P').OR.(c1 == 'p')) THEN color_name = 'dark_blue_' ELSE IF ((c1 == 'S').OR.(c1 == 's')) THEN color_name = 'dark_blue_' ELSE IF ((c1 == 'D').OR.(c1 == 'd')) THEN color_name = 'red_______' ELSE IF ((c1 == 'R').OR.(c1 == 'r')) THEN color_name = 'green_____' ELSE IF ((c1 == 'N').OR.(c1 == 'n')) THEN color_name = 'bronze____' ELSE ! any unexpected code color_name = 'foreground' END IF CALL Set_Stroke_Color (color_name) ELSE CALL Set_Stroke_Color (color_name = 'foreground') END IF ! ai_using_color or not width_points = heave_rate_mmpa(i) * dv_scale_points / dv_scale_mma CALL Set_Line_Style (width_points = width_points, dashed = .FALSE.) uvec(1:3) = segment_uvecs(1:3, 1, i) CALL New_L45_Path (5, uvec) uvec(1:3) = segment_uvecs(1:3, 2, i) CALL Great_to_L45 (uvec) CALL End_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO CALL End_Group DEALLOCATE ( segment_uvecs ) DEALLOCATE ( heave_rate_mmpa ) DEALLOCATE ( segment_sense ) END IF ! (heave_rate_method == 1, or 2) !Explanation item: CALL Set_Stroke_Color (color_name = 'foreground') ! just for insurance; if later code fails to set it CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) ! ditto CALL Chooser(bottom, right) IF (right) THEN !plot sample trace with width = dv_scale_points, !labelled with rate = dv_scale_mma CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points - 12. CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 12., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Change in') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 24., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'horizontal') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 36., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'velocity') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 48., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'across fault') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 60., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = '(mm/a):') number8 = ADJUSTL(ASCII8(dv_scale_mma)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 72., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(number8)) CALL Set_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL Set_Stroke_Color ('green_____') ELSE CALL Set_Stroke_Color ('foreground') END IF CALL New_L12_Path (1, x1_points + 6., y2_points - 75. - 0.5 * dv_scale_points) CALL Line_to_L12 (x2_points - 6., y2_points - 75. - 0.5 * dv_scale_points) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 87. + dv_scale_points CALL Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, 0.0) CALL End_Group ELSE IF (bottom) THEN !plot sample trace with width = dv_scale_points, !labelled with rate = dv_scale_mma CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 79., & & y_points = 0.5*(y1_points + y2_points) + 12., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Change in horizontal velocity') CALL L12_Text (level = 1, & & x_points = x1_points + 79., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'across fault (mm/a):') number8 = ADJUSTL(ASCII8(dv_scale_mma)) CALL L12_Text (level = 1, & & x_points = x1_points + 79., & & y_points = 0.5*(y1_points + y2_points) - 12., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(number8)) CALL Set_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL Set_Stroke_Color ('green_____') ELSE CALL Set_Stroke_Color ('foreground') END IF CALL New_L12_Path (1, (x1_points + 79.) - 30., 0.5*(y1_points + y2_points) - 15. - 0.5 * dv_scale_points) CALL Line_to_L12 ((x1_points + 79.) + 30., 0.5*(y1_points + y2_points) - 15. - 0.5 * dv_scale_points) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 153.0 CALL Fault_Key_Bottom (bottomlegend_gap_points, bottomlegend_used_points, 0.0) CALL End_Group END IF ! bottom or right legend WRITE (*,"('+Working on model heave rates of faults....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of (6) fault heave rates (according to NeoKinema) overlay CASE (7, 19) ! velocity vectors, long-term-average or short-term interseismic 2070 IF (.NOT.just_began_surface_flow) THEN IF (.NOT.got_parameters) CALL Get_Parameters temp_path_in = path_in IF (got_parameters) THEN feg_file = x_feg ELSE CALL File_List( file_type = "*.feg", & & suggested_file = feg_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which grid was used to compute velocities?',feg_file,feg_file) END IF END IF ! need to get 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) CALL Press_Enter just_began_surface_flow = .FALSE. ! must get file name mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 2070 END IF READ (21,*) ! title READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( selected(numnod) ) ALLOCATE ( vw(2*numnod) ) ! N.B. This might actually represent vw_interseismic. ALLOCATE ( vsize_mma(numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod CLOSE(21) 2071 IF (.NOT.just_began_surface_flow) THEN temp_path_in = path_in IF (got_parameters) THEN IF (choice == 7) THEN ! long-term-average velocity vel_file = 'v' // TRIM(token) // ".out" ELSE IF (choice == 19) THEN ! short-term interseismic velocity vel_file = 'v_interseismic' // TRIM(token) // ".out" END IF ELSE CALL File_List( file_type = "v*.out", & & suggested_file = vel_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which velocity file should be plotted?',vel_file,vel_file) END IF END IF ! need to get 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 Press_Enter just_began_surface_flow = .FALSE. ! must get file name mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 2071 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)) CLOSE(22) IF (.NOT.just_began_surface_flow) THEN CALL Prompt_for_Logical('Do you wish to CHANGE the velocity reference frame?',velocity_reframe,velocity_reframe) END IF IF (velocity_reframe) THEN IF (.NOT.just_began_surface_flow) THEN 2072 CALL Prompt_for_Integer('Which node should be fixed?',fixed_node,fixed_node) IF ((fixed_node < 1).OR.(fixed_node > numnod)) THEN WRITE (*,"(' ERROR: Illegal node number!')") mt_flashby = .FALSE. GO TO 2072 END IF ! illegal fixed_node 2073 CALL Prompt_for_Integer('Which OTHER node should be prevented from rotating about the first?',nonorbiting_node,nonorbiting_node) IF ((nonorbiting_node < 1).OR.(nonorbiting_node > numnod).OR.(nonorbiting_node == fixed_node)) THEN WRITE (*,"(' ERROR: Illegal node number!')") mt_flashby = .FALSE. GO TO 2073 END IF ! illegal nonorbiting_node END IF WRITE (number8, "(I8)") fixed_node IF (choice == 7) THEN line = 'Long-term-average Velocity, with node ' // TRIM(ADJUSTL(number8)) // ' fixed' ELSE IF (choice == 19) THEN line = 'Short-term Interseismic Velocity, with node ' // TRIM(ADJUSTL(number8)) // ' fixed' END IF CALL Add_Title(line) CALL Reframe_Velocity_at_Nodes (fixed_node, nonorbiting_node, node_uvec, numnod, & ! input & vw, & ! modify & reference_Elon_deg, reference_Nlat_deg, & & reference_vE_mmpa, reference_vN_mmpa, reference_ccw_degpMa) !output ELSE ! velocity_reframe = .FALSE. IF (choice == 7) THEN CALL Add_Title('Long-term-average Velocity') ELSE IF (choice == 19) THEN CALL Add_Title('Short-term Interseismic Velocity') END IF END IF ! velocity_reframe, or not !when scaling velocity vectors, consider ALL vectors, even those !along outside of boundary fault elements, with no associated area: DO i = 1, numnod v_South_mps = vw(2*i-1) v_East_mps = vw(2*i) vsize_mma(i) = 1000. * sec_per_year * SQRT(v_South_mps**2 + v_East_mps**2) END DO ! i = 1, numnod WRITE (*,"(/' Here is the distribution of velocities (in mm/a):')") CALL Histogram (vsize_mma, numnod, .FALSE., maximum, minimum) CALL Prompt_for_Real('For how many Ma should velocity be projected?',velocity_Ma,velocity_Ma) WRITE (*,"(/' There will be ',I7,' vectors plotted if they are not thinned.')") numnod 2074 CALL Prompt_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!')") mt_flashby = .FALSE. GO TO 2074 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 Thin_on_Sphere (node_uvec, numnod, vector_thinner, selected) WRITE (*,"(/' Working on velocity vectors....')") CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Begin_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 Velocity_Vector_on_Sphere (from_uvec = uvec1, & & v_theta_mps = v_South_mps, v_phi_mps = v_East_mps, & & dt_sec = velocity_Ma * 1.E6 * sec_per_year, deflate = .TRUE.) END IF ! selected END DO ! actually plotting velocity vectors CALL End_Group DEALLOCATE ( vsize_mma, vw, selected, node_uvec) ! LIFO order CALL Chooser(bottom, right) IF (right) THEN CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'Velocity') number8 = ADJUSTL(ASCII8(velocity_Ma)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 12., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(x '//TRIM(number8)//' Ma):') CALL Vector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5*(x1_points+x2_points)-14.17, from_y = y2_points - 33., & & to_x = 0.5*(x1_points+x2_points)+14.17, to_y = y2_points - 33.) v_mps = 0.01 * mp_scale_denominator / (velocity_Ma * 1.E6 * sec_per_year) v_mma = v_mps * 1000. * sec_per_year number8 = ADJUSTL(ASCII8(v_mma)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 36., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(number8)//' mm/a') CALL End_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 48. ELSE IF (bottom) THEN CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) + 12., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Velocity') number8 = ADJUSTL(ASCII8(velocity_Ma)) CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = '(x '//TRIM(number8)//' Ma):') CALL Vector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.)-14.17, from_y = 0.5*(y1_points+y2_points)-10., & & to_x = (x1_points+29.)+14.17, to_y = 0.5*(y1_points+y2_points)-10.) v_mps = 0.01 * mp_scale_denominator / (velocity_Ma * 1.E6 * sec_per_year) v_mma = v_mps * 1000. * sec_per_year number8 = ADJUSTL(ASCII8(v_mma)) CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) - 24., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(number8)//' mm/a') CALL End_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58. END IF ! bottom or right legend WRITE (*,"('+Working on velocity vectors....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of velocity vector overlay CASE (8) ! geodetic velocities of benchmarks 2080 temp_path_in = path_in WRITE (*,"(/' Which kind of geodetic velocities do you wish to plot?')") WRITE (*,"( ' (1) observed geodetic velocities, used as input to NeoKinema')") WRITE (*,"( ' (2) velocity adjustments (coseismic slip, frame change?) by NeoKinema')") WRITE (*,"( ' (3) adjusted geodetic velocities which NeoKinema uses as targets')") WRITE (*,"( ' (4) model velocities at benchmarks as predicted by NeoKinema')") 2081 CALL Prompt_for_Integer("Please select 1 or 2 or 3 or 4?",gps_type,gps_type) IF (.NOT.((gps_type == 1).OR.(gps_type == 2).OR.(gps_type == 3).OR.(gps_type == 4))) THEN WRITE (*,"(' ERROR: Please enter either 1, 2, 3, or 4. Try again.')") GO TO 2081 END IF 2082 IF (gps_type == 1) THEN CALL Add_Title('Relative Velocities of Geodetic Benchmarks') CALL File_List( file_type = "*.gps", & & suggested_file = gps_file, & & using_path = temp_path_in) CALL Add_Title(gps_file) ELSE IF (gps_type == 2) THEN CALL Add_Title('Estimated Coseismic Rates, + Frame Change?') CALL File_List( file_type = "g*.nko", & & suggested_file = gps_file, & & using_path = temp_path_in) CALL Add_Title(gps_file) ELSE IF (gps_type == 3) THEN CALL Add_Title('Geodetic Velocities + Estimated Coseismic Rates') CALL File_List( file_type = "g*.nko", & & suggested_file = gps_file, & & using_path = temp_path_in) CALL Add_Title(gps_file) ELSE IF (gps_type == 4) THEN CALL Add_Title('Model Velocities at Geodetic Benchmarks') CALL File_List( file_type = "g*.nko", & ! still needed, to determine benchmark locations & suggested_file = gps_file, & & using_path = temp_path_in) END IF CALL Prompt_for_String('Which file should be used?',gps_file,gps_file) gps_pathfile = TRIM(temp_path_in)//TRIM(gps_file) OPEN(UNIT = 21, FILE = gps_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. GO TO 2082 END IF READ (21, "(A)") line ! file name and comments on source WRITE (*, "(' ',A)") TRIM(line) CALL Add_Title(line) READ (21, "(A)") gps_format READ (21, *) ! throw away column headers benchmarks = 0 ! begin count counting: DO READ (21, gps_format, IOSTAT = ios) lon, lat IF (.NOT.((ios == 0).OR.(ios == -1))) THEN WRITE (*, "(' ERROR: After successful reading of ',I6,' benchmark locations (lon, lat)' & &/' an error condition of IOSTAT = ',I6,' occurred.')") benchmarks, ios CALL Pause() STOP END IF IF (ios == -1) EXIT counting ! EOF benchmarks = benchmarks + 1 END DO counting CLOSE (21) ALLOCATE ( benchmark_label (benchmarks) ) ALLOCATE ( benchmark_uvec (3,benchmarks) ) ALLOCATE ( benchmark_N_velocity (benchmarks) ) ALLOCATE ( benchmark_N_sigma (benchmarks) ) ALLOCATE ( benchmark_E_velocity (benchmarks) ) ALLOCATE ( benchmark_E_sigma (benchmarks) ) ALLOCATE ( benchmark_correlation (benchmarks) ) ALLOCATE ( benchmark_hypotenuse (benchmarks) ) ALLOCATE ( benchmark_error_sigmas (benchmarks) ) IF (gps_type == 2) THEN ALLOCATE ( benchmark_Elon_deg (benchmarks) ) ALLOCATE ( benchmark_Nlat_deg (benchmarks) ) END IF OPEN(UNIT = 21, FILE = gps_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21, *) ! file name and comments on source READ (21, *) ! gps_format READ (21, *) ! throw away column headers DO i = 1, benchmarks IF (gps_type == 1) THEN ! reading *.gps file, which does not have right-hand set of columns: READ (21,gps_format,IOSTAT=ios) & & lon, lat, & & benchmark_E_velocity(i), benchmark_N_velocity(i), & & benchmark_E_sigma(i), benchmark_N_sigma(i), & & benchmark_correlation(i), c9, benchmark_label(i) !Note: No action if ios /= 0; this permits plotting benchmark symbols for !non-velocity files which may lack velocity and error-ellipse information on !each line, following the lon and lat. ELSE ! gps_type == 3 or 4; reading g*.nko file with more columns: READ (21,gps_format,IOSTAT=ios) & & lon, lat, & & benchmark_E_velocity(i), benchmark_N_velocity(i), & & benchmark_E_sigma(i), benchmark_N_sigma(i), & & benchmark_correlation(i), & & c9, benchmark_label(i), & & E_error_mmpa, N_error_mmpa, v_error_mmpa, benchmark_error_sigmas(i) IF (gps_type == 2) THEN benchmark_Elon_deg(i) = lon benchmark_Nlat_deg(i) = lat ! save position to correlate records in original data file !Note: velocities are not complete; we still need to open the original data file ! and subtract the velocities that we find there! END IF !Note: If gps_type == 3, then no changes are needed IF (gps_type == 4) THEN ! replace reframed, unlocked velocities with model prediction velocities: benchmark_E_velocity(i) = benchmark_E_velocity(i) + E_error_mmpa benchmark_N_velocity(i) = benchmark_N_velocity(i) + N_error_mmpa END IF END IF CALL LonLat_2_Uvec (lon, lat, uvec1) benchmark_uvec(1:3,i) = uvec1(1:3) benchmark_hypotenuse(i) = SQRT(benchmark_N_velocity(i)**2 + & & benchmark_E_velocity(i)**2) ! but if gps_type == 2 this will be re-computed below END DO ! i = 1, benchmarks CLOSE(21) IF (gps_type == 2) THEN ! must open original data file and subtract velocities in it 2083 c50 = ' ' CALL File_List( file_type = "*.gps", & & suggested_file = c50, & & using_path = temp_path_in) CALL Prompt_for_String('Which is the original (input) geodetic data file?',' ',input_gps_file) input_gps_pathfile = TRIM(temp_path_in)//TRIM(input_gps_file) OPEN(UNIT = 21, FILE = input_gps_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21, *) ! throw file's title line READ (21, "(A)") gps_format READ (21, *) ! throw away column headers IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. GO TO 2083 END IF i = 1 ! initializing loop with unknown number of passes matching_up: DO READ (21,gps_format,IOSTAT=ios) & & lon, lat, & & vE_mmpa, vN_mmpa IF (ios /= 0) THEN WRITE (*, "(' Error code ',I6,' during attempt to read original benchmark velocity for benchmark #',I6)") ios, i CALL Pause() STOP END IF IF ((MOD(lon - benchmark_Elon_deg(i) + 720.0, 360.0) == 0.0).AND.(lat == benchmark_Nlat_deg(i))) THEN ! got a match! benchmark_E_velocity(i) = benchmark_E_velocity(i) - vE_mmpa benchmark_N_velocity(i) = benchmark_N_velocity(i) - vN_mmpa benchmark_hypotenuse(i) = SQRT(benchmark_N_velocity(i)**2 + & & benchmark_E_velocity(i)**2) ! replacing previous value i = i + 1 ! start looking for next match END IF IF (i > benchmarks) EXIT matching_up END DO matching_up CLOSE (21) CALL Add_Title('(Note that these corrections are frame-independent.)') ELSE ! gps_type /= 2, so ask if a frame change is wanted? CALL Prompt_for_Logical('Do you wish to CHANGE the velocity reference frame?',velocity_reframe,velocity_reframe) IF (velocity_reframe) THEN WRITE (*, "(' NOTE: The reference velocity and rotation that you specify')") WRITE (*, "(' will be SUBTRACTED from geodetic velocities before plotting.')") CALL Prompt_for_Real('Longitude of reference point (degrees, East is positive)?',reference_Elon_deg,reference_Elon_deg) CALL Prompt_for_Real('Latitude of reference point (degrees, North is positive)?',reference_Nlat_deg,reference_Nlat_deg) CALL Prompt_for_Real('Reference velocity to the East at this point (mm/a)?',reference_vE_mmpa,reference_vE_mmpa) CALL Prompt_for_Real('Reference velocity to the North at this point (mm/a)?',reference_vN_mmpa,reference_vN_mmpa) CALL Prompt_for_Real('Reference counterclockwise rotation at this point (degrees/Ma)?',reference_ccw_degpMa,reference_ccw_degpMa) CALL Reframe_Velocity_at_Benchmarks (reference_Elon_deg, reference_Nlat_deg, reference_vE_mmpa, reference_vN_mmpa, reference_ccw_degpMa, & ! input & benchmarks, benchmark_uvec, & ! input & benchmark_E_velocity, benchmark_N_velocity, benchmark_hypotenuse) ! modify !Note that benchmark_N_velocity, benchmark_E_velocity, benchmark_hypotenuse are all in mm/a. !Also note that changing velocity reference frame has no effect on error ellipses (except for their placement in the plot). CALL Add_Title('shown in a local velocity reference frame') END IF ! velocity_reframe END IF ! gps_type == 2, or not ALLOCATE ( train (benchmarks) ) k = 0 DO i = 1, benchmarks uvec(1:3) = benchmark_uvec(1:3, i) visible = L5_In_Window(uvec) IF (visible) THEN k = k + 1 train(k) = benchmark_hypotenuse(i) END IF END DO WRITE (*,"(/' Here is the distribution of visible velocities (in mm/a):')") CALL Histogram (train, k, .FALSE., maximum, minimum) DEALLOCATE ( train ) CALL Prompt_for_Real('For how many Ma should velocity be projected?',velocity_Ma,velocity_Ma) CALL Prompt_for_Real('How large (in points) should benchmark locations be plotted?',benchmark_points,benchmark_points) WRITE (*,"(/' Working on benchmark velocity vectors....')") CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) !create group of error ellipses: ellipses = .FALSE. ! usually reversed by any finite ellipse, below CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') t = (velocity_Ma * 1.0E6) * 0.001 / mp_radius_meters ! arc-radians per (mm/a) IF ((gps_type == 1).OR.(gps_type == 3)) THEN ! do ellipses only for gps_type == 1 or 3 IF (velocity_Ma /= 0.0) THEN CALL Begin_Group DO i = 1, benchmarks IF ((benchmark_N_sigma(i) > 0.0).AND.(benchmark_E_sigma(i) > 0.0)) THEN ellipses = .TRUE. uvec1(1:3) = benchmark_uvec(1:3,i) !locate head of vector, to be center of ellipse: az1 = ATAN2F(benchmark_E_velocity(i),benchmark_N_velocity(i)) t1 = t * Conformal_Deflation (uvec1) ! arc-radians per (mm/a) CALL Turn_To (azimuth_radians = az1, base_uvec = uvec1, far_radians = t1 * benchmark_hypotenuse(i), & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec) t1 = t * Conformal_Deflation (uvec) ! arc-radians per (mm/a) !find rotation principal axes of ellipse: covariance_11 = benchmark_E_sigma(i)**2 covariance_22 = benchmark_N_sigma(i)**2 covariance_12 = benchmark_N_sigma(i) * benchmark_E_sigma(i) * benchmark_correlation(i) CALL Principal_Axes_22 (covariance_11, covariance_12, covariance_22, & & e1, e2, u1x,u1y, u2x,u2y) e1 = 1.96 * SQRT(e1) e2 = 1.96 * SQRT(e2) ! back into units of mm/a, but now amplified by *1.96, to convert from 1-sigma to 95%-confidence start_azimuth = Pi_over_2 - ATAN2F(u1y,u1x) ! smallest axis, in radians clockwise from North !find initial point at top of ellipse: CALL Turn_To (azimuth_radians = start_azimuth, base_uvec = uvec, far_radians = t1 * e1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL New_L45_Path (5, uvec1) ! beginning (e1 axis) of ellipse DO j = 1, 12 ! 12 30-degree sectors, counterclockwise from e1 axis: rel_az2 = -(j - 0.5) * 30.0 * rad_per_deg ! mid-point; relative to e1 axis rel_az3 = -j * 30.0 * rad_per_deg ! end-point; relative to e1 axis az2 = start_azimuth + rel_az2 ! mid-point, in radians clockwise from N az3 = start_azimuth + rel_az3 ! end-point, in radians clockwise from N ds2 = COS(rel_az2) * t1 * e1 ! arc-radians dl2 = SIN(rel_az2) * t1 * e2 arc2 = SQRT(ds2**2 + dl2**2) aze2 = start_azimuth + ATAN2F(dl2,ds2) CALL Turn_To (azimuth_radians = aze2, base_uvec = uvec, far_radians = arc2, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) ds3 = COS(rel_az3) * t1 * e1 ! arc-radians dl3 = SIN(rel_az3) * t1 * e2 arc3 = SQRT(ds3**2 + dl3**2) aze3 = start_azimuth + ATAN2F(dl3,ds3) CALL Turn_To (azimuth_radians = aze3, base_uvec = uvec, far_radians = arc3, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL Small_Through_L45 (uvec2, uvec3) ! through uvec2 to uvec3 END DO ! j = 1, 12 ! 30-degree sectors forming a circle CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF ! ellipise has positive dimensions END DO ! i = 1, benchmarks CALL End_Group ! of error ellipses END IF ! velocity_Ma /= 0.0 END IF ! doing ellipses (if gps_type == 1 OR 3) !create group of benchmarks: IF (benchmark_points > 0.0) THEN CALL Set_Stroke_Color ('foreground') t = 0.6667 * mp_meters_per_point * benchmark_points / mp_radius_meters CALL Begin_Group ! of benchmark triangles DO i = 1, benchmarks uvec(1:3) = benchmark_uvec(1:3,i) t1 = t * Conformal_Deflation (uvec) CALL Turn_To (azimuth_radians = 0.0, base_uvec = uvec, far_radians = t1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL New_L45_Path (5, uvec1) CALL Turn_To (azimuth_radians = 4.188, base_uvec = uvec, far_radians = t1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL Great_To_L45 (uvec2) CALL Turn_To (azimuth_radians = 2.094, base_uvec = uvec, far_radians = t1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL Great_To_L45 (uvec3) CALL Great_To_L45 (uvec1) CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END DO ! i = 1, benchmarks CALL End_Group ! of benchmark triangles END IF ! benchmark_points > 0.0 !create group of benchmark labels: CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL Begin_Group ! of benchmark labels DO i = 1, benchmarks uvec(1:3) = benchmark_uvec(1:3,i) c4 = benchmark_label(i)(1:4) CALL L5_Text (uvec = uvec, angle_radians = 0.0, from_east = .TRUE., & & font_points = 6, lr_fraction = 0.5, ud_fraction = 1.0, & & text = c4) END DO ! i = 1, benchmarks CALL End_Group ! of benchmark triangles !create group of velocity vectors: IF (velocity_Ma /= 0.0) THEN CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) CALL Begin_Group DO i = 1, benchmarks uvec1(1:3) = benchmark_uvec(1:3,i) v_South_mps = -0.001 * benchmark_N_velocity(i) / sec_per_year v_East_mps = +0.001 * benchmark_E_velocity(i) / sec_per_year IF (ai_using_color) THEN !Choose colors that allow all 3 vectors to be distinguished at one benchmark (in extreme close-up view): IF (gps_type == 1) THEN ! original *.gps file CALL Set_Stroke_Color ('foreground') ELSE IF (gps_type == 2) THEN ! adjustments to velocity (difference between g*.gps and g*.nko) CALL Set_Stroke_Color ('magenta___') ELSE IF (gps_type == 3) THEN ! modified g*.nko file CALL Set_Stroke_Color ('dark_blue_') ELSE IF (gps_type == 4) THEN ! color will vary, green -> bronze -> red with error (in sigmas) IF (benchmark_error_sigmas(i) <= 2.0) THEN CALL Set_Stroke_Color ('green_____') ELSE IF (benchmark_error_sigmas(i) <= 4.0) THEN CALL Set_Stroke_Color ('bronze____') ELSE CALL Set_Stroke_Color ('red_______') END IF END IF ELSE CALL Set_Stroke_Color ('foreground') END IF CALL Velocity_Vector_on_Sphere (from_uvec = uvec1, & & v_theta_mps = v_South_mps, v_phi_mps = v_East_mps, & & dt_sec = velocity_Ma * 1.E6 * sec_per_year, deflate = .TRUE.) END DO ! actually plotting benchmark velocity vectors CALL End_Group END IF ! velocity_Ma /= 0.0 IF (ai_using_color) CALL Set_Stroke_Color ('foreground') CALL Chooser(bottom, right) IF (right) THEN CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') IF (gps_type == 1) THEN CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'geodetic') ELSE IF (gps_type == 2) THEN CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'adjustment to') ELSE IF (gps_type == 3) THEN CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'adjusted') ELSE IF (gps_type == 4) THEN CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'NeoKinema') END IF CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 12.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'velocity') number8 = ADJUSTL(ASCII8(velocity_Ma)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 24.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(x '//TRIM(number8)//' Ma):') x0p = 0.5 * (x1_points + x2_points) - 14.17 x1p = x0p + 2 * 14.17 ! 1-cm-long vector, expressed in points y0p = y2_points - 47.0 CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') IF (ellipses) THEN CALL Circle_on_L12 (level = 1, x = x1p, y = y0p, radius = 6.0, stroke = .TRUE., fill = .FALSE.) END IF IF (benchmark_points > 0.0) THEN CALL New_L12_Path (1, x0p, y0p + 0.6667 * benchmark_points) CALL Line_to_L12 (x0p - 0.577 * benchmark_points, y0p - 0.333 * benchmark_points) CALL Line_to_L12 (x0p + 0.577 * benchmark_points, y0p - 0.333 * benchmark_points) CALL Line_to_L12 (x0p, y0p + 0.6667 * benchmark_points) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) IF (ai_using_color) THEN IF (gps_type == 1) THEN ! original *.gps file CALL Set_Stroke_Color ('foreground') ELSE IF (gps_type == 2) THEN ! adjustments to velocity CALL Set_Stroke_Color ('magenta___') ELSE IF (gps_type == 3) THEN ! modified g*.nko file CALL Set_Stroke_Color ('dark_blue_') ELSE IF (gps_type == 4) THEN ! color will vary, green -> bronze -> red with error (in sigmas) CALL Set_Stroke_Color ('red_______') END IF ELSE CALL Set_Stroke_Color ('foreground') END IF CALL Vector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = x0p, from_y = y0p, & & to_x = x1p, to_y = y0p) IF (ai_using_color) CALL Set_Stroke_Color ('foreground') v_mps = 0.01 * mp_scale_denominator / (velocity_Ma * 1.E6 * sec_per_year) v_mma = v_mps * 1000. * sec_per_year number8 = ADJUSTL(ASCII8(v_mma)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 48., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(number8)//' mm/a') IF (ellipses) THEN CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 60., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = "(95%-c.") CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 72., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = "ellipse)") END IF ! ellipses CALL End_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 60.0 IF (ellipses) rightlegend_used_points = rightlegend_used_points + 24.0 ! for "(95%-c./ellipse)" ELSE IF (bottom) THEN CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') IF (gps_type == 1) THEN CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) + 12.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'geodetic') ELSE IF (gps_type == 2) THEN CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) + 12.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'adjustment to') ELSE IF (gps_type == 3) THEN CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) + 12.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'adjusted') ELSE IF (gps_type == 4) THEN CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) + 12.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Neokinema') END IF CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'velocity') number8 = ADJUSTL(ASCII8(velocity_Ma)) CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) - 12.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = '(x '//TRIM(number8)//' Ma):') x0p = (x1_points + 29.0) - 14.17 x1p = x0p + 2 * 14.17 ! 1-cm-long vector, expressed in points y0p = 0.5 * (y1_points + y2_points) - 22.0 CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') IF (ellipses) THEN CALL Circle_on_L12 (level = 1, x = x1p, y = y0p, radius = 6.0, stroke = .TRUE., fill = .FALSE.) CALL L12_Text (level = 1, & & x_points = x1p + 9., & & y_points = y0p, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = '95%-c.') END IF IF (benchmark_points > 0.0) THEN CALL New_L12_Path (1, x0p, y0p + 0.6667 * benchmark_points) CALL Line_to_L12 (x0p - 0.577 * benchmark_points, y0p - 0.333 * benchmark_points) CALL Line_to_L12 (x0p + 0.577 * benchmark_points, y0p - 0.333 * benchmark_points) CALL Line_to_L12 (x0p, y0p + 0.6667 * benchmark_points) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) IF (ai_using_color) THEN IF (gps_type == 1) THEN ! original *.gps file CALL Set_Stroke_Color ('foreground') ELSE IF (gps_type == 2) THEN ! adjustments to velocity CALL Set_Stroke_Color ('magenta___') ELSE IF (gps_type == 3) THEN ! modified g*.nko file CALL Set_Stroke_Color ('dark_blue_') ELSE IF (gps_type == 4) THEN ! color will vary, green -> bronze -> red with error (in sigmas) CALL Set_Stroke_Color ('red_______') END IF ELSE CALL Set_Stroke_Color ('foreground') END IF CALL Vector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = x0p, from_y = y0p, & & to_x = x1p, to_y = y0p) IF (ai_using_color) CALL Set_Stroke_Color ('foreground') v_mps = 0.01 * mp_scale_denominator / (velocity_Ma * 1.E6 * sec_per_year) v_mma = v_mps * 1000. * sec_per_year number8 = ADJUSTL(ASCII8(v_mma)) CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) - 36., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(number8)//' mm/a') CALL End_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58. IF (ellipses) bottomlegend_used_points = bottomlegend_used_points + 36. ! for "95%-c." END IF ! bottom or right legend WRITE (*,"('+Working on benchmark velocity vectors....DONE.')") IF (gps_type == 2) THEN DEALLOCATE ( benchmark_Nlat_deg ) DEALLOCATE ( benchmark_Elon_deg ) END IF DEALLOCATE ( benchmark_error_sigmas ) ! in LIFO order DEALLOCATE ( benchmark_hypotenuse ) DEALLOCATE ( benchmark_correlation ) DEALLOCATE ( benchmark_E_sigma ) DEALLOCATE ( benchmark_E_velocity ) DEALLOCATE ( benchmark_N_sigma ) DEALLOCATE ( benchmark_N_velocity ) DEALLOCATE ( benchmark_uvec ) DEALLOCATE ( benchmark_label ) CALL BEEPQQ (frequency = 440, duration = 250) ! end of 8: geodetic velocities of benchmarks CASE (9, 20) ! total strain-rates, either long-term-average, or short-term interseismic: IF (.NOT.got_parameters) CALL Get_Parameters 2090 IF (.NOT.just_began_total_strainrate) THEN temp_path_in = path_in feg_file = x_feg feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) END IF ! .NOT.just_began_total_strainrate 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) ) ALLOCATE ( vw(2*numnod) ) ! N.B. This may actually represent vw_interseismic. DO i = 1, numnod READ (21, *, IOSTAT = ios) j, lon, lat problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL LonLat_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 ( e3_minus_e1_persec(numel) ) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( selected(numel) ) ALLOCATE ( strainrate(3, 7, numel) ) ALLOCATE ( uvec_list(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) CALL Press_Enter just_began_total_strainrate = .FALSE. mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 2090 END IF READ (21, *) nfl IF (nfl > 0) CALL No_Fault_Elements_Allowed() CLOSE (21) CALL Add_Title(feg_file) IF (.NOT.just_began_total_strainrate) THEN temp_path_in = path_in IF (choice == 9) THEN vel_file = 'v' // TRIM(token) // ".out" ELSE IF (choice == 20) THEN vel_file = 'v_interseismic' // TRIM(token) // ".out" END IF vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) END IF ! .NOT.just_began_total_strainrate OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(vel_pathfile) 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)) CLOSE (22) DO l_ = 1, numel ! compute strainrates at integration points 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_)) DO m = 1, 7 ! 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 Make_Uvec (uvec4, uvec) ! center of element IF (m == 1) uvec_list(1:3, l_) = uvec(1:3) equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) 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_ = ATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) strainrate(1:3, m, l_) = eps_dot(1:3) END DO ! m = 1, 7 END DO ! l_ = 1, numel, computing strainrates !convert to scalar measure, for histogram DO i = 1, numel ! compute 3 principal values, and partition one with unique sign CALL Principal_Axes_22 (strainrate(1,1,i),strainrate(2,1,i),strainrate(3,1,i), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) err = -(e1h + e2h) ! Decide which principal strain(-rate) is partitioned: e1h_partitioned = (e1h /= 0.).AND.((e1h*e2h) <= 0.).AND.((e1h*err) <= 0.) e2h_partitioned = (e2h /= 0.).AND.((e2h*e1h) <= 0.).AND.((e2h*err) <= 0.) err_partitioned = (err /= 0.).AND.((err*e1h) <= 0.).AND.((err*e2h) <= 0.) ! Decide how big largest symbol is (in terms of partitioned e3-e1). big_diff = 0. IF (e1h*e2h < 0.) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(e2h)) ELSE big_diff = MAX(big_diff, 2.*ABS(e1h)) END IF END IF IF (e1h*err < 0.) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(err)) ELSE big_diff = MAX(big_diff, 2.*ABS(e1h)) END IF END IF IF (e2h*err < 0.) THEN IF (e2h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(err)) ELSE big_diff = MAX(big_diff, 2.*ABS(e2h)) END IF END IF e3_minus_e1_persec(i) = big_diff 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 Prompt_for_Integer('Which mode do you want?',strainrate_mode012,strainrate_mode012) IF (strainrate_mode012 == 0) THEN CALL Prompt_for_Real('What diameter should the symbols be, in points?',strainrate_diameter_points,strainrate_diameter_points) ELSE WRITE (*,"(/' Here is the distribution of differential strain-rates' & & /' (e3 - e1) across the elements (in /s):')") CALL Histogram (e3_minus_e1_persec, numel, .FALSE., maximum, minimum) IF (ref_e3_minus_e1_persec <= 0.0) ref_e3_minus_e1_persec = maximum CALL Prompt_for_Real('What is the reference strain-rate, in /s?',ref_e3_minus_e1_persec,ref_e3_minus_e1_persec) CALL Prompt_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,' tensors plotted if they are not thinned.')") numel 2092 CALL Prompt_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!')") mt_flashby = .FALSE. GO TO 2092 END IF IF (strain_thinner > 1) THEN WRITE(string10,"(I10)") strain_thinner IF (((TRIM(f_dat) /= 'none').AND.(TRIM(f_dig) /= 'none')).AND.(choice == 9)) THEN ! there are faults in this model, and they slip CALL Add_Title('(1/'//TRIM(ADJUSTL(string10))//') of Total Strain-Rate Tensors, including Faulting') ELSE ! no faults, so no distinction between long-term and short-term: CALL Add_Title('(1/'//TRIM(ADJUSTL(string10))//') of Strain-Rate Tensors') END IF ELSE ! == 1 IF (((TRIM(f_dat) /= 'none').AND.(TRIM(f_dig) /= 'none')).AND.(choice == 9)) THEN ! there are faults in this model, and they slip CALL Add_Title('Total Long-Term Strain-Rate Tensors, including Faulting') ELSE ! no faults, so no distinction between long-term and short-term: CALL Add_Title('Strain-Rate Tensors') END IF END IF WRITE (*,"(/' Working on strain-rates....')") CALL Thin_on_Sphere (uvec_list, numel, strain_thinner, selected) CALL Begin_Group ! of strain-rates CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells DO i = 1, numel IF (selected(i)) THEN uvec(1:3) = uvec_list(1:3, i) CALL Strain_on_Sphere (uvec, & & strainrate(1,1,i), strainrate(2,1,i), strainrate(3,1,i), & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) END IF ! selected END DO ! i = 1, numel CALL End_Group ! of strain-rate tensors CALL Chooser (bottom, right) IF (right) THEN ! sample strain-rate in rightlegend CALL Begin_Group ! text part of strain-rate in legend; begin with a gap rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points CALL Report_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 Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'Total') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'strain-rate, as') rightlegend_used_points = rightlegend_used_points + 20. y2_points = y2_points - 20. CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'conjugate') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'microfaults:') rightlegend_used_points = rightlegend_used_points + 25. ! 5 points extra for minigap y2_points = y2_points - 25. ! symbol part of paleostress in legend; CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL Strain_in_Plane (1, 0.8*x1_points + 0.2*x2_points, & & y2_points - 0.5*strainrate_diameter_points , & & -0.5*ref_e3_minus_e1_persec, 0., 0., & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL Strain_in_Plane (1, 0.5*x1_points + 0.5*x2_points, & & y2_points - 0.5*strainrate_diameter_points , & & 0.5*ref_e3_minus_e1_persec, 0., -0.5*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL Strain_in_Plane (1, 0.2*x1_points + 0.8*x2_points, & & y2_points - 0.5*strainrate_diameter_points , & & 0.5*ref_e3_minus_e1_persec, 0., 0., & & 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 L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'E3 - E1 =') number8 = ASCII8(ref_e3_minus_e1_persec) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(Diameter') ELSE ! mode012 = 2 CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(Area is') END IF ! mode 1 or 2 CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 30., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'proportional to') rightlegend_used_points = rightlegend_used_points + 40. y2_points = y2_points - 40. ELSE ! all symbols are of equal size CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(Size is') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'independent of') rightlegend_used_points = rightlegend_used_points + 20. y2_points = y2_points - 20. END IF ! labelling with numerical strainrate, or not CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'strain-rate.)') rightlegend_used_points = rightlegend_used_points + 10. y2_points = y2_points - 10. CALL End_Group ELSE IF (bottom) THEN ! sample strain-rate in bottomlegend CALL Begin_Group ! text part of strain-rate in legend; begin with a gap CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Total') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'strain-rate, as') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'conjugate') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) -20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'microfaults:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72. ! text1 only ! symbol part of paleostress in legend; CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL Strain_in_Plane (1, x1_points + 14., & & 0.5*(y1_points + y2_points), & & -0.5*ref_e3_minus_e1_persec, 0., 0., & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL Strain_in_Plane (1, x1_points + 36., & & 0.5*(y1_points + y2_points), & & 0.5*ref_e3_minus_e1_persec, 0., -0.5*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL Strain_in_Plane (1, x1_points + 58., & & 0.5*(y1_points + y2_points) , & & 0.5*ref_e3_minus_e1_persec, 0., 0., & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) bottomlegend_used_points = bottomlegend_used_points + 72. ! now, including middle symbols block x1_points = x1_points + 72. !note that x1_points now indicates right side of middle symbol block IF (strainrate_mode012 > 0) THEN ! label with e3-e1 = # CALL L12_Text (level = 1, & & x_points = x1_points - 36., & & y_points = y1_points + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'E3 - E1 =') number8 = ASCII8(ref_e3_minus_e1_persec) CALL L12_Text (level = 1, & & x_points = x1_points - 36., & & y_points = y1_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = '(Diameter') ELSE ! mode012 = 2 CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = '(Area is') END IF ! mode 1 or 2 CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = 'proportional to') ELSE ! all symbols are of equal size CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = '(Size is') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = 'independent of') END IF ! labelling with numerical strainrate, or not CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = 'strain-rate.)') CALL End_Group bottomlegend_used_points = bottomlegend_used_points + 72. ! right text block END IF ! sample strain-rate in bottom/right legend WRITE (*,"('+Working on strain-rates....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( e3_minus_e1_persec, & & node_uvec, & & nodes, & & selected, strainrate, & & uvec_list, vw ) ! end of 9: total strain-rate tensor overlay CASE (10) ! continuum strain-rate tensor overlay: 2100 IF (.NOT.got_parameters) CALL Get_Parameters IF (.NOT.just_began_continuum_strainrate) THEN temp_path_in = path_in feg_file = x_feg feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) END IF ! .NOT.just_began_continuum_strainrate 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 LonLat_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 ( e3_minus_e1_persec(numel) ) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( selected(numel) ) ALLOCATE ( strainrate(3, 7, numel) ) ALLOCATE ( uvec_list(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) CALL Press_Enter just_began_continuum_strainrate = .FALSE. mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 2100 END IF READ (21, *) nfl IF (nfl > 0) CALL No_Fault_Elements_Allowed() CLOSE (21) CALL Add_Title(feg_file) IF ((TRIM(f_dat) /= 'none').AND.(TRIM(f_dig) /= 'none')) THEN ! there are faults in this model IF (.NOT.just_began_continuum_strainrate) THEN temp_path_in = path_in continuum_strainrate_file = 'e' // TRIM(token) // ".nko" continuum_strainrate_pathfile = TRIM(temp_path_in)//TRIM(continuum_strainrate_file) END IF ! .NOT.just_began_continuum_strainrate CALL Add_Title(continuum_strainrate_file) OPEN(UNIT = 22, FILE = continuum_strainrate_pathfile, STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(continuum_strainrate_pathfile) DO l_ = 1, numel ! read and save strainrates at integration points READ (22, *) j, maybe, eps_dot(1), eps_dot(2), eps_dot(3) DO m = 1, 7 strainrate(1:3, m, l_) = eps_dot(1:3) END DO ! m = 1, 7 !determine center point of element (for uvec_list, in case thinning is wanted): 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_)) uvec4(1:3) = uvec1(1:3) + uvec2(1:3) + uvec3(1:3) CALL Make_Uvec(uvec4, uvec) uvec_list(1:3, l_) = uvec(1:3) END DO ! l_ = 1, numel, reading strainrates and computing center points of elements CLOSE(22) ELSE ! no faults; use same method as in case (11) IF (.NOT.just_began_continuum_strainrate) THEN temp_path_in = path_in vel_file = 'v' // TRIM(token) // ".out" vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) END IF ALLOCATE ( vw(2*numnod) ) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(vel_pathfile) 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)) CLOSE (22) DO l_ = 1, numel ! compute strainrates at integration points 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_)) DO m = 1, 7 ! 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 Make_Uvec (uvec4, uvec) ! center of element equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) 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 IF (m == 1) uvec_list(1:3, l_) = uvec(1:3) theta_ = ATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) strainrate(1:3, m, l_) = eps_dot(1:3) END DO ! m = 1, 7 END DO ! l_ = 1, numel, computing strainrates DEALLOCATE ( vw ) END IF ! faults in this model (and e*.nko) or not !convert to scalar measure, for histogram DO i = 1, numel ! compute 3 principal values, and partition one with unique sign CALL Principal_Axes_22 (strainrate(1,1,i),strainrate(2,1,i),strainrate(3,1,i), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) err = -(e1h + e2h) ! Decide which principal strain(-rate) is partitioned: e1h_partitioned = (e1h /= 0.).AND.((e1h*e2h) <= 0.).AND.((e1h*err) <= 0.) e2h_partitioned = (e2h /= 0.).AND.((e2h*e1h) <= 0.).AND.((e2h*err) <= 0.) err_partitioned = (err /= 0.).AND.((err*e1h) <= 0.).AND.((err*e2h) <= 0.) ! Decide how big largest symbol is (in terms of partitioned e3-e1). big_diff = 0. IF (e1h*e2h < 0.) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(e2h)) ELSE big_diff = MAX(big_diff, 2.*ABS(e1h)) END IF END IF IF (e1h*err < 0.) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(err)) ELSE big_diff = MAX(big_diff, 2.*ABS(e1h)) END IF END IF IF (e2h*err < 0.) THEN IF (e2h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(err)) ELSE big_diff = MAX(big_diff, 2.*ABS(e2h)) END IF END IF e3_minus_e1_persec(i) = big_diff 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 Prompt_for_Integer('Which mode do you want?',strainrate_mode012,strainrate_mode012) IF (strainrate_mode012 == 0) THEN CALL Prompt_for_Real('What diameter should the symbols be, in points?',strainrate_diameter_points,strainrate_diameter_points) ELSE WRITE (*,"(/' Here is the distribution of differential strain-rates' & & /' (e3 - e1) across the elements (in /s):')") CALL Histogram (e3_minus_e1_persec, numel, .FALSE., maximum, minimum) IF (ref_e3_minus_e1_persec <= 0.0) ref_e3_minus_e1_persec = maximum CALL Prompt_for_Real('What is the reference strain-rate, in /s?',ref_e3_minus_e1_persec,ref_e3_minus_e1_persec) CALL Prompt_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,' tensors plotted if they are not thinned.')") numel 2102 CALL Prompt_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!')") mt_flashby = .FALSE. GO TO 2102 END IF IF (strain_thinner > 1) THEN WRITE(string10,"(I10)") strain_thinner CALL Add_Title('(1/'//TRIM(ADJUSTL(string10))//') of Continuum Strain-Rate Tensors, excluding faulting') ELSE ! == 1 CALL Add_Title('Continuum Strain-Rate Tensors, excluding faulting') END IF WRITE (*,"(/' Working on strain-rates....')") CALL Thin_on_Sphere (uvec_list, numel, strain_thinner, selected) CALL Begin_Group ! of strain-rates CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells DO i = 1, numel IF (selected(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)) uvec4(1:3) = uvec1(1:3) + uvec2(1:3) + uvec3(1:3) CALL Make_Uvec(uvec4, uvec) CALL Strain_on_Sphere (uvec, & & strainrate(1,1,i), strainrate(2,1,i), strainrate(3,1,i), & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) END IF ! selected END DO ! i = 1, numel CALL End_Group ! of strain-rate tensors CALL Chooser (bottom, right) IF (right) THEN ! sample strain-rate in rightlegend CALL Begin_Group ! text part of strain-rate in legend; begin with a gap rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points CALL Report_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 Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'Strain-rate of') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'continuum, as') rightlegend_used_points = rightlegend_used_points + 20. y2_points = y2_points - 20. CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'conjugate') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'microfaults:') rightlegend_used_points = rightlegend_used_points + 25. ! 5 points extra for minigap y2_points = y2_points - 25. ! symbol part of paleostress in legend; CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL Strain_in_Plane (1, 0.8*x1_points + 0.2*x2_points, & & y2_points - 0.5*strainrate_diameter_points , & & -0.5*ref_e3_minus_e1_persec, 0., 0., & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL Strain_in_Plane (1, 0.5*x1_points + 0.5*x2_points, & & y2_points - 0.5*strainrate_diameter_points , & & 0.5*ref_e3_minus_e1_persec, 0., -0.5*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL Strain_in_Plane (1, 0.2*x1_points + 0.8*x2_points, & & y2_points - 0.5*strainrate_diameter_points , & & 0.5*ref_e3_minus_e1_persec, 0., 0., & & 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 L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'E3 - E1 =') number8 = ASCII8(ref_e3_minus_e1_persec) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(Diameter') ELSE ! mode012 = 2 CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(Area is') END IF ! mode 1 or 2 CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 30., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'proportional to') rightlegend_used_points = rightlegend_used_points + 40. y2_points = y2_points - 40. ELSE ! all symbols are of equal size CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(Size is') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'independent of') rightlegend_used_points = rightlegend_used_points + 20. y2_points = y2_points - 20. END IF ! labelling with numerical strainrate, or not CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'strain-rate.)') rightlegend_used_points = rightlegend_used_points + 10. y2_points = y2_points - 10. CALL End_Group ELSE IF (bottom) THEN ! sample strain-rate in bottomlegend CALL Begin_Group ! text part of strain-rate in legend; begin with a gap CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Strain-rate of') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'continuum, as') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'conjugate') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) -20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'microfaults:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72. ! text1 only ! symbol part of paleostress in legend; CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL Strain_in_Plane (1, x1_points + 14., & & 0.5*(y1_points + y2_points), & & -0.5*ref_e3_minus_e1_persec, 0., 0., & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL Strain_in_Plane (1, x1_points + 36., & & 0.5*(y1_points + y2_points), & & 0.5*ref_e3_minus_e1_persec, 0., -0.5*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL Strain_in_Plane (1, x1_points + 58., & & 0.5*(y1_points + y2_points) , & & 0.5*ref_e3_minus_e1_persec, 0., 0., & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) bottomlegend_used_points = bottomlegend_used_points + 72. ! now, including middle symbols block x1_points = x1_points + 72. !note that x1_points now indicates right side of middle symbol block IF (strainrate_mode012 > 0) THEN ! label with e3-e1 = # CALL L12_Text (level = 1, & & x_points = x1_points - 36., & & y_points = y1_points + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'E3 - E1 =') number8 = ASCII8(ref_e3_minus_e1_persec) CALL L12_Text (level = 1, & & x_points = x1_points - 36., & & y_points = y1_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = '(Diameter') ELSE ! mode012 = 2 CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = '(Area is') END IF ! mode 1 or 2 CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = 'proportional to') ELSE ! all symbols are of equal size CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = '(Size is') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = 'independent of') END IF ! labelling with numerical strainrate, or not CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = 'strain-rate.)') CALL End_Group bottomlegend_used_points = bottomlegend_used_points + 72. ! right text block END IF ! sample strain-rate in bottom/right legend WRITE (*,"('+Working on strain-rates....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( e3_minus_e1_persec, & & node_uvec, & & nodes, & & selected, strainrate, & & uvec_list ) IF (ALLOCATED( vw )) DEALLOCATE ( vw ) ! end of 10: continuum strain-rate tensor overlay CASE (11) ! most-compressive horizontal principal strain-rate axes IF (.NOT.got_parameters) CALL Get_Parameters 2110 temp_path_in = path_in IF (got_parameters) THEN feg_file = x_feg ELSE CALL File_List( file_type = "*.feg", & & suggested_file = feg_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which .feg file defines the elements?',feg_file,feg_file) END IF 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) ) ALLOCATE ( vw(2*numnod) ) DO i = 1, numnod READ (21, *, IOSTAT = ios) j, lon, lat problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL LonLat_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 ( selected(numel) ) ALLOCATE ( uvec_list(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) CALL Press_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 2110 END IF READ (21, *) nfl IF (nfl > 0) CALL No_Fault_Elements_Allowed() CLOSE (21) CALL Add_Title(feg_file) 2111 temp_path_in = path_in IF (got_parameters) THEN vel_file = 'v' // TRIM(token) // ".out" ELSE CALL File_List( file_type = "v*.out", & & suggested_file = vel_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which velocity file should be used?',vel_file,vel_file) END IF 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 Press_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 2111 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)) CLOSE (22) CALL Prompt_for_Real('How long should the symbols be, in points?',e1_size_points,e1_size_points) WRITE (*,"(/' There will be ',I7,' symbols plotted if they are not thinned.')") numel 2112 CALL Prompt_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!')") mt_flashby = .FALSE. GO TO 2112 END IF IF (strain_thinner > 1) THEN WRITE(string10,"(I10)") strain_thinner CALL Add_Title('(1/'//TRIM(ADJUSTL(string10))//') of Most-Compressive Horizontal Principal Strain-Rate Axes') ELSE ! == 1 CALL Add_Title('Most-Compressive Horizontal Principal Strain-Rate Axes') END IF WRITE (*,"(/' Working on e1h directions....')") DO l_ = 1, numel ! precompute element center positions, for thinning 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 Make_Uvec (uvec1, uvec) ! center of element uvec_list(1:3, l_) = uvec(1:3) END DO ! l_ = 1, numel CALL Thin_on_Sphere (uvec_list, numel, strain_thinner, selected) CALL Begin_Group DO l_ = 1, numel ! compute strainrates at element centers ! evaluate nodal function and derivitives at center of element IF (selected(l_)) THEN uvec(1:3) = uvec_list(1:3, l_) equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) 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_ = ATAN2(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(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) ! compute 3 principal values, and partition one with unique sign CALL Principal_Axes_22 (eps_dot(1),eps_dot(2),eps_dot(3), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) divergence = e1h + e2h err = -divergence s1h_azim_radians = ATAN2F(u1phi, -u1theta) eh_max = MAX(ABS(e1h),ABS(e2h)) offset_radians = Conformal_Deflation(uvec) * ((0.5*e1_size_points/2835.) & & * mp_scale_denominator) / mp_radius_meters IF (ai_using_color) THEN ! wide line of green (s-s), mid_blue (thrust), or bronze (normal) CALL Set_Line_Style (width_points = 3.0, dashed = .FALSE.) IF (ABS(err) <= (0.2 * eh_max)) THEN CALL Set_Stroke_Color('green_____') ! strike-slip ELSE IF (err > 0.) THEN CALL Set_Stroke_Color('mid_blue__') ! thrust ELSE CALL Set_Stroke_Color('bronze____') ! normal END IF ! different colors CALL Turn_To (azimuth_radians = s1h_azim_radians, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL Turn_To (azimuth_radians = s1h_azim_radians+Pi, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL New_L45_Path(5,uvec1) CALL Great_to_L45(uvec2) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! b/w symbol ! black-stroked white box for normal, unstroked grey box for s-s, black for thrusting CALL Set_Stroke_Color('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) IF (ABS(err) <= (0.2 * eh_max)) THEN CALL Set_Fill_or_Pattern(.FALSE.,'gray______') ! strike-slip stroke_this = .FALSE. ELSE IF (err > 0.) THEN CALL Set_Fill_or_Pattern(.FALSE.,'foreground') ! thrust stroke_this = .FALSE. ELSE CALL Set_Fill_or_Pattern(.FALSE.,'background') ! normal stroke_this = .TRUE. END IF ! different grays CALL Turn_To (azimuth_radians = s1h_azim_radians+0.10, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL New_L45_Path(5,uvec1) CALL Turn_To (azimuth_radians = s1h_azim_radians-0.10, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL Great_to_L45(uvec2) CALL Turn_To (azimuth_radians = s1h_azim_radians+Pi+0.10, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL Great_to_L45(uvec2) CALL Turn_To (azimuth_radians = s1h_azim_radians+Pi-0.10, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL Great_to_L45(uvec2) CALL Great_to_L45(uvec1) CALL End_L45_Path(close = .TRUE., stroke = stroke_this, fill = .TRUE.) END IF END IF ! selected for plotting END DO ! l_ = 1, numel, computing strainrates CALL End_Group ! s1h directions on map CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = "foreground") ! for text CALL Begin_Group ! sample s1h directions in legend CALL Chooser (bottom, right) IF (right) THEN CALL Report_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. CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Model e1h') CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'direction and') CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-30., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'strain-rate regime:') IF (ai_using_color) THEN CALL Set_Stroke_Color('bronze____') CALL Set_Line_Style (width_points = 3.00, dashed = .FALSE.) CALL New_L12_Path(1,xcp-4.,y2_points-40.) CALL Line_to_L12(xcp-28.,y2_points-40.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL Set_Stroke_Color('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Fill_or_Pattern(.FALSE.,'background') CALL New_L12_Path(1,xcp-4.,y2_points-40.-1.5) CALL Line_to_L12(xcp-4.,y2_points-40.+1.5) CALL Line_to_L12(xcp-28.,y2_points-40.+1.5) CALL Line_to_L12(xcp-28.,y2_points-40.-1.5) CALL Line_to_L12(xcp-4.,y2_points-40.-1.5) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL Set_Line_Style (width_points = 3.00, dashed = .FALSE.) CALL Set_Fill_or_Pattern(.FALSE.,'foreground') CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-40., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'normal') IF (ai_using_color) THEN CALL Set_Stroke_Color('green_____') ELSE CALL Set_Stroke_Color('gray______') END IF CALL New_L12_Path(1,xcp-4.,y2_points-50.) CALL Line_to_L12(xcp-28.,y2_points-50.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-50., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'strike-slip') IF (ai_using_color) THEN CALL Set_Stroke_Color('mid_blue__') ELSE CALL Set_Stroke_Color('foreground') END IF CALL New_L12_Path(1,xcp-4.,y2_points-60.) CALL Line_to_L12(xcp-28.,y2_points-60.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-60., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'thrust') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 64. ELSE ! bottom CALL Report_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. CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp+10., & & angle_radians = 0., font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'Model e1h') CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp, & & angle_radians = 0., font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'direction and') CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp-10., & & angle_radians = 0., font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'strain regime:') IF (ai_using_color) THEN CALL Set_Stroke_Color('bronze____') CALL Set_Line_Style (width_points = 3.00, dashed = .FALSE.) CALL New_L12_Path(1,x1_points+76.,ycp+10.) CALL Line_to_L12(x1_points+100.,ycp+10.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL Set_Stroke_Color('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Fill_or_Pattern(.FALSE.,'background') CALL New_L12_Path(1,x1_points+76.,ycp+10.-1.5) CALL Line_to_L12(x1_points+100.,ycp+10.-1.5) CALL Line_to_L12(x1_points+100.,ycp+10.+1.5) CALL Line_to_L12(x1_points+76.,ycp+10.+1.5) CALL Line_to_L12(x1_points+76.,ycp+10.-1.5) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL Set_Line_Style (width_points = 3.00, dashed = .FALSE.) CALL Set_Fill_or_Pattern(.FALSE.,'foreground') CALL L12_Text (level = 1, x_points = x1_points+104., & & y_points = ycp+10., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'normal') IF (ai_using_color) THEN CALL Set_Stroke_Color('green_____') ELSE CALL Set_Stroke_Color('gray______') END IF CALL New_L12_Path(1,x1_points+76.,ycp) CALL Line_to_L12(x1_points+100.,ycp) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL L12_Text (level = 1, x_points = x1_points+104., & & y_points = ycp, & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'strike-slip') IF (ai_using_color) THEN CALL Set_Stroke_Color('mid_blue__') ELSE CALL Set_Stroke_Color('foreground') END IF CALL New_L12_Path(1,x1_points+76.,ycp-10.) CALL Line_to_L12(x1_points+100.,ycp-10.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL L12_Text (level = 1, x_points = x1_points+104., & & y_points = ycp-10., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'thrust') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 140. END IF ! right or bottom CALL End_Group ! sample s1h directions in legend WRITE (*,"(/' Working on e1h directions....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( node_uvec, & & nodes, selected, & & uvec_list, vw ) ! end of 11: sigma1h from FEM CASE (12) ! stress direction data 2120 temp_path_in = path_in IF (got_parameters) THEN s1h_file = s_dat ELSE ! don't force use of parameter input file; it may not exist yet! CALL File_List( file_type = "s*.nki" , & & suggested_file = s1h_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which is the stress-direction dataset that should be plotted?',s1h_file,s1h_file) END IF s1h_pathfile = TRIM(temp_path_in)//TRIM(s1h_file) CALL Add_Title('Stress Direction Data') CALL Add_Title(s1h_file) ! open 1st time for a view (headers, formats) OPEN(UNIT = 21, FILE = s1h_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') CALL Check_for_Tabs(21) IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 2120 END IF WRITE(*,"(' Here are the first 5 lines of the file, and a ruler:' & &/' -------------------------------------------------------------------------------')") DO i = 1, 5 READ (21,"(A)", IOSTAT = ios) line WRITE (*,"(' ',A)") TRIM(line(1:79)) END DO WRITE(*,"(' ----+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----')") CLOSE (21) skip_lines = 2 lonlat = .TRUE. WRITE (*, "(' CAUTIONS: There should be exactly 2 header lines.' & &/' The first header should be a FORMAT for reading the file.' & &/' There must be (at least) 6 columns in the file, in this order:'& &//' text_string_1 text_string_2 longitude latitude azimuth uncertainty/quality'& &//' Longitude and latitude must be real numbers (F, E, or D format).'& &/' Azimuth is clockwise from North, either in integer (I) or real (F/E/D) format.'& &/' Uncertainty/quality can be in integer (I), real (F/E/D), or character (A)'& &/' format. If it is in A format, use letter grades of A, B, C, D, E.'/)") ! open 2nd time to get FORMAT OPEN(UNIT = 21, FILE = s1h_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) CALL Could_Not_Find_File(s1h_pathfile) READ (21, "(A)") s1h_format ! isolate the FORMAT item for the azimuth and determine if it is an integer or a real; ! also determine whether the error is integer, real, or character. n_items_done = 0 DO i = 1, LEN_TRIM(s1h_format) c1 = s1h_format(i:i) ! ignore any of: ( [number] X . [comma] [space] ) IF ((c1 == 'A').OR.(c1 == 'H').OR.(c1 == 'I').OR.(c1 == 'F').OR.(c1 == 'E').OR.(c1 == 'D').OR. & & (c1 == 'a').OR.(c1 == 'h').OR.(c1 == 'i').OR.(c1 == 'f').OR.(c1 == 'e').OR.(c1 == 'd')) THEN n_items_done = n_items_done + 1 IF (n_items_done == 5) THEN ! this is the azimuth item azimuth_is_integer = ((c1 == 'I').OR.(c1 == 'i')) ELSE IF (n_items_done == 6) THEN ! this is the error item using_A_to_E = ((c1 == 'A').OR.(c1 == 'a').OR.(c1 == 'H').OR.(c1 == 'h')) sigma_is_integer = ((c1 == 'I').OR.(c1 == 'i')) END IF END IF END DO READ (21, *) ! skip column headers ! count data lines, without storing them (yet) s_nki_count = 0 2121 READ (21, s1h_format, IOSTAT = ios) c80a, c80b, t1, t2 ! deliberately skipping the problematic azimuth (I?, F?) sigma/letter IF (ios == 0) THEN s_nki_count = s_nki_count + 1 GO TO 2121 ELSE CLOSE (21) WRITE (*,"(' ',I10,' stress data were counted.')") s_nki_count END IF ! good read, or not IF (s_nki_count == 0) THEN mt_flashby = .FALSE. GO TO 2120 END IF ALLOCATE ( s_site(3, s_nki_count) ) ALLOCATE ( s_azim(s_nki_count) ) ALLOCATE ( s_sigma_(s_nki_count) ) ! open 3rd time to read and record the data lines OPEN(UNIT = 21, FILE = s1h_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, "(A)") s1h_format READ (21, *) ! skip column headers recording: DO i = 1, s_nki_count IF (using_A_to_E) THEN IF (azimuth_is_integer) THEN READ (21, s1h_format, IOSTAT = ios) c80a, c80b, lon, lat, s1h_azim_int, s1h_sigma_c1 s1h_azim_degrees = s1h_azim_int ELSE ! azimuth is a real number READ (21, s1h_format, IOSTAT = ios) c80a, c80b, lon, lat, s1h_azim_degrees, s1h_sigma_c1 END IF IF ((s1h_sigma_c1 == 'A').OR.(s1h_sigma_c1 == 'a')) THEN ! per Zoback (1992): s.d. <= 12 s1h_sigma_degrees = 8.0 ELSE IF ((s1h_sigma_c1 == 'B').OR.(s1h_sigma_c1 == 'b')) THEN ! per Zoback (1992): 12 < s.d. <= 25 s1h_sigma_degrees = 18.0 ELSE IF ((s1h_sigma_c1 == 'C').OR.(s1h_sigma_c1 == 'c')) THEN ! (interpolated by GPB) s1h_sigma_degrees = 30.0 ELSE IF ((s1h_sigma_c1 == 'D').OR.(s1h_sigma_c1 == 'e')) THEN ! (interpolated by GPB) s1h_sigma_degrees = 40.0 ELSE ! quality E; per Zoback (1992) : s.d. > 40 s1h_sigma_degrees = 50.0 END IF ELSE IF (sigma_is_integer) THEN IF (azimuth_is_integer) THEN READ (21, s1h_format, IOSTAT = ios) c80a, c80b, lon, lat, s1h_azim_int, s1h_sigma_int s1h_azim_degrees = s1h_azim_int ELSE ! azimuth is a real number READ (21, s1h_format, IOSTAT = ios) c80a, c80b, lon, lat, s1h_azim_degrees, s1h_sigma_int END IF s1h_sigma_degrees = s1h_sigma_int ELSE ! sigma is a real number IF (azimuth_is_integer) THEN READ (21, s1h_format, IOSTAT = ios) c80a, c80b, lon, lat, s1h_azim_int, s1h_sigma_degrees s1h_azim_degrees = s1h_azim_int ELSE ! azimuth is a real number READ (21, s1h_format, IOSTAT = ios) c80a, c80b, lon, lat, s1h_azim_degrees, s1h_sigma_degrees END IF END IF ! sigma is A-E, integer, or real problem = problem .OR. (ios /= 0) IF (problem) THEN s_nki_count = i-1 EXIT recording END IF CALL LonLat_2_Uvec(lon, lat, uvec) s_site(1:3,i) = uvec(1:3) s_azim(i) = s1h_azim_degrees * radians_per_degree s_sigma_(i) = s1h_sigma_degrees * radians_per_degree END DO recording ! reading data CLOSE (21) CALL Prompt_for_Real('How long should the symbols be, in points?',s1_size_points,s1_size_points) WRITE (*,"(/' Working on stress direction data....')") number_rejected = 0 CALL Begin_Group ! foreground-bounded background-colored wedges for 90% confidence limits CALL Set_Line_Style (width_points = 0.5, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'background') radians = (0.6 * s1_size_points * 3.528E-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, s_nki_count valid_azimuth = ((s_azim(i) >= -3.142).AND.(s_azim(i) <= 6.284)) IF (valid_azimuth) THEN del_az_for_90pc = s_sigma_(i) * 1.645 uvec(1:3) = s_site(1:3, i) IF (del_az_for_90pc < Pi_over_2) THEN ! two sectors CALL New_L45_Path(5, uvec) CALL Turn_To (s_azim(i)+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL Great_to_L45(uvec1) CALL Turn_To (s_azim(i)-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL Small_to_L45(uvec, uvec2) CALL Great_to_L45(uvec) CALL End_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL New_L45_Path(5, uvec) CALL Turn_To (s_azim(i)+Pi+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL Great_to_L45(uvec1) CALL Turn_To (s_azim(i)+Pi-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL Small_to_L45(uvec, uvec2) CALL Great_to_L45(uvec) CALL End_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ELSE ! complete small circle CALL Turn_To (0.0, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL New_L45_Path(5, uvec1) CALL Small_to_L45(uvec, uvec1) CALL End_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! sectors or circle END IF ! valid_azimuth END DO CALL End_Group ! end of 90%-confidence limits CALL Begin_Group ! stress indicator bar (solid if definately relevant) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'background') radians = (0.5 * s1_size_points * 3.528E-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, s_nki_count valid_azimuth = ((s_azim(i) >= -3.142).AND.(s_azim(i) <= 6.284)) IF (valid_azimuth) THEN uvec(1:3) = s_site(1:3, i) CALL Set_Line_Style (width_points = MAX(0.5, (s1_size_points / 8.)), dashed = .FALSE.) CALL Turn_To (s_azim(i), uvec, radians, & ! inputs & omega_uvec, uvec1) CALL New_L45_Path(5, uvec1) CALL Turn_To (s_azim(i)+Pi, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL Great_to_L45(uvec2) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! .NOT.valid_azimuth number_rejected = number_rejected + 1 END IF ! valid_azimuth, or not END DO CALL End_Group ! of stress-direction bars IF (number_rejected > 0) THEN WRITE (*, "(/' WARNING: ',I6,' azimuths were outside legal range -180~+360 and were not plotted.')") number_rejected CALL Pause() END IF CALL Chooser (bottom, right) IF (right) THEN ! sample paleostress in rightlegend CALL Begin_Group ! text part of paleostress in legend CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'Actual s1h') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'direction,') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '90%-confidence') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 30., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'sectors:') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 45. ! text only ! symbol part of paleostress in legend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points CALL Set_Line_Style (width_points = 0.5, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'background') radius = 0.6 * s1_size_points xcp = (x1_points + x2_points)/2. ycp = y2_points - radius * 0.5 CALL New_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.866 y0p = ycp - radius * 0.5 CALL Line_to_L12 (x0p,y0p) x1p = x0p + radius * 0.5523 * 0.66667 * 0.5 y1p = y0p + radius * 0.5523 * 0.66667 * 0.866 x3p = x0p y3p = ycp + radius * 0.5 x2p = x1p y2p = y3p - radius * 0.5523 * 0.66667 * 0.866 CALL Curve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL Line_to_L12(xcp,ycp) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x0p = xcp - (x0p - xcp) x1p = xcp - (x1p - xcp) x2p = x1p x3p = x0p CALL New_L12_Path(1,xcp,ycp) CALL Line_to_L12 (x0p,y0p) CALL Curve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL Line_to_L12(xcp,ycp) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (width_points = MAX(0.5, (s1_size_points / 8.)), dashed = .FALSE.) radius = 0.5 * s1_size_points x0p = xcp - radius x1p = xcp + radius CALL New_L12_Path(1,x0p,ycp) CALL Line_to_L12(x1p,ycp) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + radius ! symbol only CALL End_Group ELSE IF (bottom) THEN ! sample paleostress in bottomlegend CALL Begin_Group ! text part of paleostress in legend CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 72., & & y_points = 0.5*(y1_points + y2_points) + 15., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'Actual s1h') CALL L12_Text (level = 1, & & x_points = x1_points + 72., & & y_points = 0.5*(y1_points + y2_points) + 5., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'direction,') CALL L12_Text (level = 1, & & x_points = x1_points + 72., & & y_points = 0.5*(y1_points + y2_points) - 5., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = '90%-confidence') CALL L12_Text (level = 1, & & x_points = x1_points + 72., & & y_points = 0.5*(y1_points + y2_points) - 15., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'sectors:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72. ! text only ! symbol part of paleostress in legend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL Set_Line_Style (width_points = 0.5, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'background') CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) radius = 0.6 * s1_size_points x1_points = x1_points + bottomlegend_used_points + radius xcp = x1_points ycp = (y1_points + y2_points)/2. CALL New_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.5 y0p = ycp + radius * 0.866 CALL Line_to_L12 (x0p,y0p) x1p = x0p - radius * 0.5523 * 0.66667 * 0.866 y1p = y0p + radius * 0.5523 * 0.66667 * 0.5 x3p = xcp - radius * 0.5 y3p = y0p x2p = x3p + radius * 0.5523 * 0.66667 * 0.866 y2p = y1p CALL Curve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL Line_to_L12(xcp,ycp) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) y0p = ycp - (y0p - ycp) y1p = ycp - (y1p - ycp) y2p = y1p y3p = y0p CALL New_L12_Path(1,xcp,ycp) CALL Line_to_L12 (x0p,y0p) CALL Curve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL Line_to_L12(xcp,ycp) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (width_points = MAX(0.5, (s1_size_points / 8.)), dashed = .FALSE.) radius = 0.5 * s1_size_points y0p = ycp - radius y1p = ycp + radius CALL New_L12_Path(1,xcp,y0p) CALL Line_to_L12(xcp,y1p) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + radius ! symbol only CALL End_Group END IF ! sample paleostress in right or bottom legend !close up after plotting stress data DEALLOCATE ( s_site ) DEALLOCATE ( s_azim ) DEALLOCATE ( s_sigma_ ) WRITE (*,"('+Working on stress direction data....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 12: stress direction data overlay CASE (13) ! stress directions interpolated by NeoKinema 2130 IF (.NOT.got_parameters) CALL Get_Parameters ! which will include: token, x_feg OPEN (UNIT = 21, FILE = x_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 LonLat_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 ( s_azim(numel) ) ALLOCATE ( s_sigma_(numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Finite element grid absent or defective in file ',A)") TRIM(x_feg) CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2130 END IF CLOSE (21) s_nko_file = 's' // TRIM(token) // ".nko" s_nko_pathfile = TRIM(path_in) // TRIM(s_nko_file) problem = .FALSE. OPEN (UNIT = 21, FILE = s_nko_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = problem .OR. (ios /= 0) DO i = 1, numel READ (21, *, IOSTAT = ios) j, s1h_known(i), s1h_azim_degrees, s1h_sigma_degrees s_azim(i) = s1h_azim_degrees * radians_per_degree s_sigma_(i) = s1h_sigma_degrees * radians_per_degree problem = problem .OR. (ios /= 0) END DO IF (problem) THEN WRITE (*,"(' ERROR: Interpolated stresses absent or defective in file ',A)") TRIM(s_nko_file) CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line GOTO 2130 END IF CLOSE (21) CALL Prompt_for_Real('How long should the symbols be, in points?',s1h_interp_points,s1h_interp_points) WRITE (*,"(/' There will be ',I7,' interpolated stresses plotted if they are not thinned.')") numel 2131 CALL Prompt_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 2131 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(s_nko_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 Make_Uvec (uvec1, uvec) ! center of element center(1:3,i) = uvec(1:3) END DO !GPBkludge------------------------------------------------------ ! OPEN (UNIT = 91, FILE = "robust_interpolated_stress_for_OrbScore2.dat") ! DO i = 1, numel ! IF (s1h_known(i)) THEN ! uvec(1:3) = center(1:3, i) ! CALL Uvec_2_LonLat(uvec, lon, lat) ! s1h_azim_degrees = s_azim(i) / radians_per_degree ! azimuth_int = NINT(s1h_azim_degrees) ! s1h_sigma_degrees = s_sigma_(i) / radians_per_degree ! IF (s1h_sigma_degrees < 15.) THEN ! per on-line WSM criteria ! quality_c1 = 'A' ! ELSE IF (s1h_sigma_degrees <= 20.) THEN ! quality_c1 = 'B' ! ELSE IF (s1h_sigma_degrees <= 25.) THEN ! quality_c1 = 'C' ! ELSE ! s1h_sigma_degrees < 27.6 degrees, IF (s1h_known). ! quality_c1 = 'D' ! END IF ! regime_c2 = " U" ! Unknown, because of interpolation ! WRITE (91, "('NeoKi',2F9.3,7X,I3,17X,A1,5X,A2)") lat, lon, azimuth_int, quality_c1, regime_c2 ! END IF ! END DO ! CLOSE (91) !GPBkludge------------------------------------------------------ CALL Thin_on_Sphere (center, numel, stress_thinner, selected) CALL Prompt_for_Logical('Program NeoKinema 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 NeoKinema....')") CALL Begin_Group ! foreground-bounded background-colored wedges for 90% confidence limits CALL Set_Line_Style (width_points = 0.5, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'background') radians = (0.4 * s1h_interp_points * 3.528E-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, numel IF (((only_stressed).AND.(s1h_known(i))) .OR. & & ((.NOT.only_stressed).AND.(s_azim(i) /= 0.0))) THEN IF (selected(i)) THEN del_az_for_90pc = s_sigma_(i) * 1.645 uvec(1:3) = center(1:3,i) CALL New_L45_Path(5, uvec) CALL Turn_To (s_azim(i)+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL Great_to_L45(uvec1) CALL Turn_To (s_azim(i)-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL Small_to_L45(uvec, uvec2) CALL Great_to_L45(uvec) CALL End_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL New_L45_Path(5, uvec) CALL Turn_To (s_azim(i)+Pi+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL Great_to_L45(uvec1) CALL Turn_To (s_azim(i)+Pi-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL Small_to_L45(uvec, uvec2) CALL Great_to_L45(uvec) CALL End_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! selected(i) END IF ! s1h_known(i) END DO ! i = 1, numel CALL End_Group ! end of 90%-confidence limits for interpolated stresses CALL Begin_Group ! interpolated stress indicator bar IF (ai_using_color) THEN CALL Set_Stroke_Color ('brick_____') ELSE CALL Set_Stroke_Color ('gray______') END IF CALL Set_Line_Style (width_points = MAX(0.5, (s1h_interp_points / 8.)), dashed = .FALSE.) radians = (0.5 * s1h_interp_points * 3.528E-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, numel IF (((only_stressed).AND.(s1h_known(i))) .OR. & & ((.NOT.only_stressed).AND.(s_azim(i) /= 0.0))) THEN IF (selected(i)) THEN uvec(1:3) = center(1:3,i) CALL Turn_To (s_azim(i), uvec, radians, & ! inputs & omega_uvec, uvec1) CALL New_L45_Path(5, uvec1) CALL Turn_To (s_azim(i)+Pi, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL Great_to_L45(uvec2) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! selected(i) END IF ! s1h_known(i) END DO ! i = 1, numel CALL End_Group ! of interpolated stress-direction bars DEALLOCATE ( node_uvec, center, selected, nodes, s1h_known, s_azim, s_sigma_ ) CALL Chooser (bottom, right) IF (right) THEN ! sample interpolated stress in rightlegend CALL Begin_Group ! text part of paleostress in legend CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'Interpolated') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'stress direction,') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '90%-confidence') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 30., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'sectors:') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 45. ! text only ! symbol part of paleostress in legend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points CALL Set_Line_Style (width_points = 0.5, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'background') radius = 0.4 * s1h_interp_points ! (was 0.6 for stress data, where sigma may be small) xcp = (x1_points + x2_points)/2. ycp = y2_points - radius * 0.5 CALL New_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.866 y0p = ycp - radius * 0.5 CALL Line_to_L12 (x0p,y0p) x1p = x0p + radius * 0.5523 * 0.66667 * 0.5 y1p = y0p + radius * 0.5523 * 0.66667 * 0.866 x3p = x0p y3p = ycp + radius * 0.5 x2p = x1p y2p = y3p - radius * 0.5523 * 0.66667 * 0.866 CALL Curve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL Line_to_L12(xcp,ycp) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x0p = xcp - (x0p - xcp) x1p = xcp - (x1p - xcp) x2p = x1p x3p = x0p CALL New_L12_Path(1,xcp,ycp) CALL Line_to_L12 (x0p,y0p) CALL Curve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL Line_to_L12(xcp,ycp) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself IF (ai_using_color) THEN CALL Set_Stroke_Color ('brick_____') ELSE CALL Set_Stroke_Color ('gray______') END IF CALL Set_Line_Style (width_points = MAX(0.5, (s1h_interp_points / 8.)), dashed = .FALSE.) radius = 0.5 * s1h_interp_points x0p = xcp - radius x1p = xcp + radius CALL New_L12_Path(1,x0p,ycp) CALL Line_to_L12(x1p,ycp) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + radius ! symbol only CALL End_Group ELSE IF (bottom) THEN ! sample interpolated stress in bottomlegend CALL Begin_Group ! text part of paleostress in bottomlegend CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 72., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.0, & & text = 'Interpolated') CALL L12_Text (level = 1, & & x_points = x1_points + 72., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.0, & & text = 'stress direction,') CALL L12_Text (level = 1, & & x_points = x1_points + 72., & & y_points = 0.5*(y1_points + y2_points) - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.0, & & text = '90%-confidence') CALL L12_Text (level = 1, & & x_points = x1_points + 72., & & y_points = 0.5*(y1_points + y2_points) - 20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.0, & & text = 'sectors:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72. ! text only ! symbol part of paleostress in bottomlegend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + 6. CALL Set_Line_Style (width_points = 0.5, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'background') radius = 0.4 * s1h_interp_points ! (was 0.6 for stress data, where sigma may be small) xcp = x1_points + radius * 0.5 ycp = (y1_points + y2_points)/2. CALL New_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.5 y0p = ycp + radius * 0.866 CALL Line_to_L12 (x0p,y0p) x1p = x0p - radius * 0.5523 * 0.66667 * 0.866 y1p = y0p + radius * 0.5523 * 0.66667 * 0.5 x3p = xcp - radius * 0.5 y3p = y0p x2p = x3p + radius * 0.5523 * 0.66667 * 0.866 y2p = y1p CALL Curve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL Line_to_L12(xcp,ycp) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) y0p = ycp - (y0p - ycp) y1p = ycp - (y1p - ycp) y2p = y1p y3p = y0p CALL New_L12_Path(1,xcp,ycp) CALL Line_to_L12 (x0p,y0p) CALL Curve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL Line_to_L12(xcp,ycp) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself IF (ai_using_color) THEN CALL Set_Stroke_Color ('brick_____') ELSE CALL Set_Stroke_Color ('gray______') END IF CALL Set_Line_Style (width_points = MAX(0.5, (s1h_interp_points / 8.)), dashed = .FALSE.) radius = 0.5 * s1h_interp_points y0p = ycp - radius y1p = ycp + radius CALL New_L12_Path(1,xcp,y0p) CALL Line_to_L12(xcp,y1p) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + 6. + radius ! symbol only CALL End_Group END IF ! sample interpolated stress in bottom/right legend WRITE (*,"('+Working on stresses interpolated by NeoKinema....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 13 :: stresses interpolated by NeoKinema CASE (14) ! earthquake epicenters and/or FPS from EarthQuake Catalog .eqc file 2140 WRITE (*,"(/' This plot requires a catalog (.eqc) file produced by Seismicity.')") 2141 temp_path_in = path_in CALL File_List( file_type = "*.eqc", & & suggested_file = old_eqc_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which .eqc file should be plotted?',old_eqc_file,old_eqc_file) old_eqc_pathfile = TRIM(temp_path_in) // old_eqc_file OPEN (UNIT = 22, FILE = old_eqc_pathfile, STATUS = 'OLD', IOSTAT = ios, & & PAD = 'YES') ! padding required because FPS may or may not be present IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22, IOSTAT = ios) CALL Press_Enter mt_flashby = .FALSE. GO TO 2141 END IF CALL Add_Title (old_eqc_file) !scan for any fault plane solutions any_FPS = .FALSE. scanning_eqc: DO READ (22, 2142, IOSTAT = ios) & & eq_year, eq_month, eq_day, & & eq_hour, eq_minute, eq_second, eq_tenths, & & eq_Elon, eq_Nlat, & & eq_depth_int, eq_mag, & & appended_data 2142 FORMAT (9X, & & I5,'.',A2,'.',A2, 1X, & ! read with I5 in case of -3000 (B.C.) & A2,':',A2,':',A2,'.',A1, 1X, & & F8.3, 1X, F7.3, 1X, & & I3, F6.2, & ! some .eqc records end at this point; & A ) ! try to read appended_data if any IF (ios /= 0) EXIT scanning_eqc READ (appended_data, *, IOSTAT = ios) e1_plunge, e1_azimuth, e2_plunge, e2_azimuth, e3_plunge, e3_azimuth valid_FPS = (ios == 0).AND. & & (e1_plunge /= 0).OR.(e1_azimuth /= 0).OR. & & (e2_plunge /= 0).OR.(e2_azimuth /= 0).OR. & & (e3_plunge /= 0).OR.(e3_azimuth /= 0) any_FPS = any_FPS .OR. valid_FPS END DO scanning_eqc CLOSE (22) IF (any_FPS) THEN CALL Prompt_for_Logical('Do you want to plot fault-plane-solutions as stereographic projections of the lower focal hemisphere?',plot_FPS,plot_FPS) IF (plot_FPS) THEN WRITE (*, *) WRITE (*,"(' Caution: Only symbols with diameter of at least 6 points can')") WRITE (*,"(' portray fault-plane-solutions; smaller symbols will')") WRITE (*,"(' plot as solid-color dots.')") WRITE (*,"(' Suggested parameters for plotting *all* CMT moment tensors are:')") WRITE (*,"(' What is the smallest magnitude to plot? [ignore]: 4.4 (or less)')") WRITE (*,"(' What diameter (in points) for magnitude 8.0? [ignore]: 28. (or larger)')") WRITE (*,"(' so that magnitude 5.0 events will plot as at least 6 points in diameter.')") WRITE (*, *) END IF END IF WRITE (*,"(' Diameter of symbol will be a linear function of magnitude.')") 2143 CALL Prompt_for_Real('What is the smallest magnitude to plot?',min_mag,min_mag) IF (min_mag > 8.0) THEN WRITE (*, "(' ERROR: Smallest magnitude cannot exceed 8.0')") min_mag = 8.0 GO TO 2143 END IF CALL Prompt_for_Real('What diameter (in points) for magnitude 8.0?',m8_diam_points,m8_diam_points) d1 = MAX((m8_diam_points - 2.), 0.)/MAX((8. - min_mag), 1.0) d0 = 2.3 - d1 * min_mag ! formula for constant term is based on fitting size of min_mag event !Note: extra 0.3 point of radius is to compensate for the ! overlap of the 0.6-point white outline into the interior. d0 = MAX(d0, (m8_diam_points + 0.3) - d1 * 8.0) ! based on fitting m8_diam_points; equivalent if min_mag <= 7 WRITE (*,"(/' Working on earthquake epicenters....')") OPEN (UNIT = 22, FILE = old_eqc_pathfile, STATUS = 'OLD', IOSTAT = ios, & & PAD = 'YES') ! padding required because FPS may or may not be present IF (ios /= 0) CALL Could_Not_Find_File(old_eqc_pathfile) CALL Set_Line_Style (0.6, .FALSE.) CALL Begin_Group rereading_eqc: DO READ (22, 2142, IOSTAT = ios) & & eq_year, eq_month, eq_day, & & eq_hour, eq_minute, eq_second, eq_tenths, & & eq_Elon, eq_Nlat, & & eq_depth_int, eq_mag, & & appended_data IF (ios /= 0) EXIT rereading_eqc READ (appended_data, *, IOSTAT = ios) e1_plunge, e1_azimuth, e2_plunge, e2_azimuth, e3_plunge, e3_azimuth valid_FPS = (ios == 0).AND. & & (e1_plunge /= 0).OR.(e1_azimuth /= 0).OR. & & (e2_plunge /= 0).OR.(e2_azimuth /= 0).OR. & & (e3_plunge /= 0).OR.(e3_azimuth /= 0) radius_points = 0.5 *(d0 + d1 * eq_mag) IF ((eq_mag >= min_mag).AND.(radius_points >= 1.0)) THEN ! large enough to plot IF (valid_FPS.AND.plot_FPS.AND.(radius_points >= 3.0)) THEN ! plot as FPS ! (1) Plot a small cross to mark position if FPS circle must be pulled aside: CALL LonLat_2_Uvec (eq_Elon, eq_Nlat, uvec) radians_per_point = (3.527777E-4)*(mp_scale_denominator*Conformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = 3.0 * radians_per_point ! each arm of cross CALL Turn_To (azimuth_radians = 0., base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL New_L45_Path (5, result_uvec) CALL Turn_To (azimuth_radians = Pi, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL Great_to_L45 (result_uvec) CALL End_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL Turn_To (azimuth_radians = Pi_over_2, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL New_L45_Path (5, result_uvec) CALL Turn_To (azimuth_radians = -Pi_over_2, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL Great_to_L45 (result_uvec) CALL End_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL Begin_Group ! for this one FPS symbol ! (2) Find Northward direction at epicenter, and express as ! an argument (counterclockwise from right, in radians): CALL LonLat_2_Uvec (eq_Elon, eq_Nlat, uvec) radians_per_point = (3.527777E-4)*(mp_scale_denominator*Conformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = radius_points * radians_per_point CALL Turn_To (azimuth_radians = 0., base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL Project (uvec = uvec, x = epicenter_x_m, y = epicenter_y_m) CALL Project (uvec = result_uvec, x = offset_x_m, y = offset_y_m) CALL Meters_2_Points (epicenter_x_m,epicenter_y_m, epicenter_x_points,epicenter_y_points) CALL Meters_2_Points (offset_x_m,offset_y_m, offset_x_points,offset_y_points) North_argument_radians = ATAN2F((offset_y_points - epicenter_y_points), & &(offset_x_points - epicenter_x_points)) ! (3) Plot a white background circle (even for slide copy!): CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL LonLat_2_Uvec (eq_Elon, eq_Nlat, uvec) radians_per_point = (3.527777E-4)*(mp_scale_denominator*Conformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = radius_points * radians_per_point CALL Turn_To (azimuth_radians = 0., base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL New_L45_Path (5, result_uvec) CALL Small_to_L45 (uvec, result_uvec) ! complete small circle CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ! (4) Save state of module Map_Projections: CALL Save_mp_State () ! (5) Reset Map_Projections to show a tiny world at right location and size: ! NOTE: Since projection-plane (x,y) system is arbitrary, I will set it as ! equal to the page-points system (except that it is in meters instead of points): ! centered at lower left corner of page; +x to right; +y up; dimensions ! are those of the physical page space. CALL Set_Zoom (scale_denominator = 1.0, & & x_center_meters = ai_window_xc_points / 2834.65, & & y_center_meters = ai_window_yc_points / 2834.65, & & xy_wrt_page_radians = 0.0) CALL Set_Stereographic (radius_meters = 0.5 * radius_points / 2834.65, & ! factor 0.5 counters stereographic blowup of outer circle & projpoint_uvec = (/ -0.01745241, 0.0, 0.9998477 /), & & x_projpoint_meters = epicenter_x_points / 2834.65, & & y_projpoint_meters = epicenter_y_points / 2834.65, & & y_azimuth_radians = North_argument_radians - Pi_over_2) !CALL Set_Orthographic ( radius_meters = radius_points / 2834.65, & ! & projpoint_uvec = (/ -0.01745241, 0.0, 0.9998477 /), & ! 89N, 180E ! & x_projpoint_meters = epicenter_x_points / 2834.65, & ! & y_projpoint_meters = epicenter_y_points / 2834.65, & ! & y_azimuth_radians = North_argument_radians - Pi_over_2) ! positive value twists FPS counterclockwise wrt page ! (6) Plot two black sectors on (front) side of little world. ! NOTE: Little world is seen from ~North pole ! (actually, from 89N, 180 E to prevent degeneracy), with ! its Greenwich meridian pointing to N on the big Earth, ! so that if 1.0*plunge is used as a North latitude, and ! -1.0*azimuth is used as a longitude, points plot correctly on ! the lower focal hemisphere. Points with negative ! plunge will not be seen, as they will be on the back side. CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') e1_lon = -1.0 * e1_azimuth e2_lon = -1.0 * e2_azimuth e3_lon = -1.0 * e3_azimuth e1_lat = 1.0 * e1_plunge e2_lat = 1.0 * e2_plunge e3_lat = 1.0 * e3_plunge CALL LonLat_2_Uvec (lon = e1_lon, lat = e1_lat, uvec = e1_f_uvec) ! front or visible end CALL LonLat_2_Uvec (lon = e2_lon, lat = e2_lat, uvec = e2_f_uvec) ! front or visible end CALL LonLat_2_Uvec (lon = e3_lon, lat = e3_lat, uvec = e3_f_uvec) ! front or visible end !To prevent topological problems during drafting, adjust these three axes !to be exactly perpendicular to each other! Preserve e2_f_uvec exactly, !since this is the one that comes directly from data. CALL Cross (e1_f_uvec, e2_f_uvec, tvec) ! replacing e3, now perp. to e2 IF (tvec(3) < 0.0) tvec = -tvec CALL Make_Uvec (tvec, e3_f_uvec) CALL Cross (e2_f_uvec, e3_f_uvec, tvec) ! replacing e1, now perp. to both IF (tvec(3) < 0.0) tvec = -tvec CALL Make_Uvec (tvec, e1_f_uvec) e1_b_uvec = -e1_f_uvec ! back end of e1 axis; invisible e2_b_uvec = -e2_f_uvec ! back end of e2 axis; invisible e3_b_uvec = -e3_f_uvec ! back end of e3 axis; invisible tvec = e3_f_uvec + e1_b_uvec CALL Make_uvec (tvec, turn_1_uvec) ! pole of 1st small circle arc tvec = e3_f_uvec + e1_f_uvec CALL Make_uvec (tvec, turn_2_uvec) ! pole of 2nd small circle arc turn_3_uvec = -turn_1_uvec ! pole of 3rd small circle turn_4_uvec = -turn_2_uvec ! pole of 4th small circle CALL New_L45_Path (5, e2_f_uvec) CALL Small_To_L45 (pole_uvec = turn_1_uvec, to_uvec = e2_b_uvec) ! front to back CALL Small_To_L45 (pole_uvec = turn_2_uvec, to_uvec = e2_f_uvec) ! back to front CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) CALL New_L45_Path (5, e2_f_uvec) CALL Small_To_L45 (pole_uvec = turn_3_uvec, to_uvec = e2_b_uvec) ! front to back CALL Small_To_L45 (pole_uvec = turn_4_uvec, to_uvec = e2_f_uvec) ! back to front CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ! (7) Reset (saved) state of module Map_Projections CALL Restore_mp_State () ! (8) Plot the outer circle of lower focal hemisphere CALL Set_Stroke_Color ('foreground') CALL LonLat_2_Uvec (eq_Elon, eq_Nlat, uvec) radians_per_point = (3.527777E-4)*(mp_scale_denominator*Conformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = radius_points * radians_per_point CALL Turn_To (azimuth_radians = 0., base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL New_L45_Path (5, result_uvec) CALL Small_to_L45 (uvec, result_uvec) ! complete small circle CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) CALL End_Group ! for this one FPS symbol ELSE ! plot as solid dot ! EQs have black fill with white outline (to separate points) CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL Set_Stroke_Color ('background') CALL LonLat_2_Uvec (eq_Elon, eq_Nlat, uvec) radians_per_point = (3.527777E-4)*(mp_scale_denominator*Conformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = radius_points * radians_per_point CALL Turn_To (azimuth_radians = 0., base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL New_L45_Path (5, result_uvec) CALL Small_to_L45 (uvec, result_uvec) ! complete small circle CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! FPS symbol or solid-dot symbol END IF ! large enough to plot END DO rereading_eqc CALL End_Group CLOSE(22) !sample EQ magnitudes in the margin CALL Chooser (bottom, right) IF (bottom.OR.right) THEN m1 = Int_Above(min_mag) m2 = 8 CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') ! EQs have black fill with white outline (to separate points) CALL Set_Stroke_Color ('background') CALL Set_Line_Style (0.6, .FALSE.) CALL Begin_Group IF (bottom) THEN CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x_used_points = 0.0 yp = (y1_points + y2_points) / 2.0 DO i = m1, m2 radius_points = 0.5 * (d0 + d1 * i) xp = x1_points + bottomlegend_used_points + x_used_points + radius_points + 6.0 CALL Circle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) ypt = yp - radius_points - 12.0 WRITE (c1, "(I1)") i CALL L12_Text (1, xp, ypt, 0., & & 12, 0.5, 0.0, & & c1) x_used_points = x_used_points + 2.0 * radius_points + 6.0 END DO IF (any_FPS.AND.plot_FPS) THEN ! sample thrust and normal in bottom legend CALL Begin_Group step_points = MAX((radius_points + 6.0), 24.0) xp = x1_points + bottomlegend_used_points + x_used_points + MAX(radius_points, 16.0) + 6.0 CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL Circle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL Cats_Eye (xp, yp, radius_points) CALL Set_Stroke_Color ('foreground') CALL Circle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) ypt = yp - radius_points - 12.0 CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL L12_Text (1, xp, ypt, 0., & & 12, 0.6, 0.0, & & 'thrust') x_used_points = x_used_points + 2.0 * MAX(radius_points, 16.0) + 6.0 CALL End_Group CALL Begin_Group xp = x1_points + bottomlegend_used_points + x_used_points + MAX(radius_points, 16.0) + 6.0 CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL Circle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL Cats_Eye (xp, yp, radius_points) CALL Set_Stroke_Color ('foreground') CALL Circle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) ypt = yp - radius_points - 12.0 CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL L12_Text (1, xp, ypt, 0., & & 12, 0.4, 0.0, & & 'normal') x_used_points = x_used_points + 2.0 * MAX(radius_points, 16.0) + 6.0 + step_points CALL End_Group END IF ! sample FPS's needed in bottom legend bottomlegend_used_points = bottomlegend_used_points + x_used_points ELSE IF (right) THEN CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y_used_points = 0.0 radius_points = 0.5 * (d0 + d1 * m2) xp = x1_points + radius_points DO i = m1, m2 radius_points = 0.5 * (d0 + d1 * i) yp = y2_points - rightlegend_used_points - y_used_points - radius_points - 6.0 CALL Circle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) xpt = xp + radius_points + 6.0 WRITE (c1, "(I1)") i CALL L12_Text (1, xpt, yp, 0., & & 12, 0.0, 0.4, & & c1) y_used_points = y_used_points + 2.0 * radius_points + 6.0 END DO IF (any_FPS.AND.plot_FPS) THEN ! sample thrust and normal in right legend CALL Begin_Group yp = y2_points - rightlegend_used_points - y_used_points - radius_points - 6.0 CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL Circle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL Cats_Eye (xp, yp, radius_points) CALL Set_Stroke_Color ('foreground') CALL Circle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) xpt = xp + radius_points + 6.0 CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL L12_Text (1, xpt, yp, 0., & & 12, 0.0, 0.4, & & 'thrust') y_used_points = y_used_points + 2.0 * radius_points + 6.0 CALL End_Group CALL Begin_Group yp = y2_points - rightlegend_used_points - y_used_points - radius_points - 6.0 CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL Circle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL Cats_Eye (xp, yp, radius_points) CALL Set_Stroke_Color ('foreground') CALL Circle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) xpt = xp + radius_points + 6.0 CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL L12_Text (1, xpt, yp, 0., & & 12, 0.0, 0.4, & & 'normal') y_used_points = y_used_points + 2.0 * radius_points + 6.0 CALL End_Group END IF ! sample FPS's needed in right legend rightlegend_used_points = rightlegend_used_points + y_used_points END IF ! bottom, or right, legend in use CALL End_Group END IF ! either bottom or right legend reserved WRITE (*,"('+Working on earthquake epicenters....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 14: earthquake epicenters from Seismicity .eqc file CASE (15) ! volcanoes 2150 temp_path_in = path_in 2151 CALL File_List( file_type = "*.*", & & suggested_file = volcano_file, & & using_path = temp_path_in) WRITE (*,*) CALL Prompt_for_String ('Which file has the volcano locations?',volcano_file,volcano_file) IF (LEN_TRIM(temp_path_in) > 0) THEN volcano_pathfile = TRIM(temp_path_in) // TRIM(volcano_file) ELSE volcano_pathfile = TRIM(volcano_file) END IF OPEN (UNIT = 22, FILE = volcano_pathfile, STATUS = 'OLD', IOSTAT = ios) IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22, IOSTAT = ios) CALL Press_Enter mt_flashby = .FALSE. GO TO 2151 END IF CALL Add_Title ('Volcanoes') IF (TRIM(volcano_file) == 'Volcanoes.dat') CALL Add_Title & & ("Smithsonian Institution, Global Volcanism Project") WRITE (*,*) CALL Prompt_for_Real('How many points high shall symbols be?',volcano_points,volcano_points) ! Vents have white fill (snow) with black outlines (to separate them), ! unless map is b/w, in which case they are gray. IF (ai_using_color) THEN CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='background') ELSE ! b/w figure CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='gray______') END IF CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (0.6, .FALSE.) WRITE (*,"(/' Working on volcanoes....')") CALL Begin_Group volcano_reading: DO READ (22, "(A)", IOSTAT = ios) line IF (ios == -1) EXIT volcano_reading READ (line, "(61X,F6.3,1X,A1,1X,F7.3,1X,A1)", IOSTAT = ios) & & volcano_Nlat, cN, volcano_Elon, cE IF (ios /= 0) THEN WRITE (*,"(/' ERROR: Bad line of data in file ',A,':')") TRIM(volcano_file) WRITE (*,"(' ',A)") TRIM(line) STOP END IF IF (cN == 'S') volcano_Nlat = -volcano_Nlat IF (cE == 'W') volcano_Elon = -volcano_Elon CALL LonLat_2_Uvec (volcano_Elon, volcano_Nlat, uvec) radians_per_point = (3.527777E-4)*(mp_scale_denominator*Conformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) leg = 1.1547 * volcano_points * radians_per_point rad = 0.6666 * volcano_points * radians_per_point CALL Turn_To (azimuth_radians = 0.0, base_uvec = uvec, & & far_radians = rad, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) uvec(1:3) = result_uvec(1:3) CALL New_L45_Path (5, uvec) CALL Turn_To (azimuth_radians = 3.665, base_uvec = uvec, & & far_radians = leg, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL Great_to_L45 (result_uvec) CALL Turn_To (azimuth_radians = 2.618, base_uvec = uvec, & & far_radians = leg, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL Great_to_L45 (result_uvec) CALL Great_to_L45 (uvec) CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) END DO volcano_reading CALL End_Group CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CLOSE(22) CALL Chooser (bottom, right) IF (bottom) THEN CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) CALL Begin_Group xp = x1_points + bottomlegend_used_points + bottomlegend_gap_points + 23.0 yp = (y1_points + y2_points)/2.0 + 12.0 + volcano_points IF (ai_using_color) THEN CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='background') ELSE ! b/w figure CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='gray______') END IF CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (0.6, .FALSE.) CALL New_L12_Path(1, xp, yp) xpt = xp - 0.57735 * volcano_points ypt = yp - volcano_points CALL Line_To_L12 (xpt, ypt) xpt = xp + 0.57735 * volcano_points CALL Line_To_L12 (xpt, ypt) CALL Line_To_L12 (xp, yp) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) ypt = ypt - 12.0 CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL L12_Text (1, xp, ypt, 0., & & 12, 0.5, 0.0, & & 'Recent') ypt = ypt - 12.0 CALL L12_Text (1, xp, ypt, 0., & & 12, 0.5, 0.0, & & 'volcano') CALL End_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 46.0 ELSE IF (right) THEN CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) CALL Begin_Group xp = (x1_points + x2_points)/2.0 yp = y2_points - rightlegend_used_points + rightlegend_gap_points IF (ai_using_color) THEN CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='background') ELSE ! b/w figure CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='gray______') END IF CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (0.6, .FALSE.) CALL New_L12_Path(1, xp, yp) xpt = xp - 0.57735 * volcano_points ypt = yp - volcano_points CALL Line_To_L12 (xpt, ypt) xpt = xp + 0.57735 * volcano_points CALL Line_To_L12 (xpt, ypt) CALL Line_To_L12 (xp, yp) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL Set_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') ypt = ypt - 12.0 CALL L12_Text (1, xp, ypt, 0., & & 12, 0.5, 0.0, & & 'Recent') ypt = ypt - 12.0 CALL L12_Text (1, xp, ypt, 0., & & 12, 0.5, 0.0, & & 'volcano') CALL End_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + volcano_points + 24.0 END IF ! bottom or right legend WRITE (*,"('+Working on volcanoes....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 15: volcanoes CASE (16) ! velocity vectors from plate model, with mm/a number annotations CALL Add_Title("Velocities from Plate Model") 2160 WRITE (*, "(/' This overlay requires two data files to be in the input folder:'& &/' ',A & &/' ',A & &/' Please check that these are available, or move them in right now!')") & & TRIM(plates_dig_file), TRIM(orogens_dig_file) CALL Prompt_for_Logical("Are they available?", .TRUE., maybe) IF (.NOT.maybe) GO TO 2160 !get plate outlines (for deciding which plate a point is in) 2161 temp_path_in = path_in plates_dig_pathfile = TRIM(temp_path_in) // TRIM(plates_dig_file) OPEN (UNIT = 21, FILE = plates_dig_pathfile, STATUS = "OLD", ACTION = "READ", IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(plates_dig_pathfile) ALLOCATE ( plate_uvecs(3, mostInOnePlate, nPlates) ) DO k = 1, nPlates ! Note: k not used as a storage subscript READ (21,"(A)", IOSTAT = ios) c2 IF (ios /= 0) THEN WRITE (*,"(' ERROR: could not read (all?) of ',A)") TRIM(plates_dig_file) CALL Traceback() STOP END IF plate_ID = 0 ! this should be replaced, in loop below DO j = 1, nPlates IF (c2 == names(j)) THEN plate_ID = j EXIT END IF END DO IF (plate_ID == 0) THEN WRITE (*, "(' ERROR: Bad plate name in ',A,': ',A)") TRIM(plates_dig_file), c2 CALL Pause() STOP END IF plate_points: DO i = 1, mostInOnePlate + 1 READ (21, *, IOSTAT = ios) lon, lat IF (ios /= 0) THEN ! hit "*** end of line segment ***" nInEachPlate(j) = i - 1 EXIT plate_points END IF CALL LonLat_2_Uvec(lon, lat, uvec) plate_uvecs(1:3, i, plate_ID) = uvec(1:3) END DO plate_points END DO ! k = 1, nPlates CLOSE(21) ! plates_dig_file !get orogen outlines (so points within them can be skipped) 2162 temp_path_in = path_in orogens_dig_pathfile = TRIM(temp_path_in) // orogens_dig_file OPEN (UNIT = 22, FILE = orogens_dig_pathfile, STATUS = "OLD", ACTION = "READ", IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(orogens_dig_pathfile) ALLOCATE ( orogen_uvecs(3, mostInOneOrogen, nOrogens) ) DO j = 1, nOrogens READ (22,"(A)", IOSTAT = ios) c27 IF (ios /= 0) THEN WRITE (*,"(' ERROR: could not read (all?) of ',A)") TRIM(orogens_dig_file) CALL Traceback() STOP END IF orogen_points: DO i = 1, mostInOneOrogen + 1 READ (22, *, IOSTAT = ios) lon, lat IF (ios /= 0) THEN ! hit "*** end of line segment ***" nInEachOrogen(j) = i - 1 EXIT orogen_points END IF CALL LonLat_2_Uvec(lon, lat, uvec) orogen_uvecs(1:3, i, j) = uvec(1:3) END DO orogen_points END DO ! j = 1, nOrogens CLOSE(22) ! orogens_dig_file !query user on reference frame: WRITE (*, "(/' ----------------------------------------------------------------')") WRITE (*, "( ' Select a Stationary Plate to Define the Velocity Reference Frame:'/)") list_length = Int_Above(nPlates / 6.0) DO j = 1, list_length ! number of lines in 6-column table IF ((j + 5 * list_length) <= nPlates) THEN ! use 6-column line WRITE (*, "(6(2X,I3,' = ',A2))") (j + list_length * (i - 1), names(j + list_length * (i - 1)), i = 1, 6) ELSE ! use 5-column line WRITE (*, "(5(2X,I3,' = ',A2))") (j + list_length * (i - 1), names(j + list_length * (i - 1)), i = 1, 5) END IF END DO WRITE (*, "( ' ----------------------------------------------------------------')") 2163 CALL Prompt_for_Integer("Which integer describes your choice?", ref_frame_plate_ID, ref_frame_plate_ID) IF ((ref_frame_plate_ID < 1).OR.(ref_frame_plate_ID > nPlates)) THEN WRITE (*, "(' ERROR: Please select an integer from the table!')") CALL Pause() GO TO 2163 END IF !query user on source of .feg: WRITE (*, "(/' FiniteMap plots plate-model velocity vectors at locations')") WRITE (*, "( ' which are specified as node locations in some finite element')") WRITE (*, "( ' grid (*.feg). You can specify a real grid that you are working')") WRITE (*, "( ' with, or a dummy grid composed only of nodes (which can be')") WRITE (*, "( ' quickly created in OrbWeaver).')") WRITE (*, "( ' Alternatively, FiniteMap can create global grid for you now')") WRITE (*, "( ' (but this is slow if you request closely-spaced nodes!')") CALL Prompt_for_Logical("Do you want FiniteMap to create global grid?",.FALSE.,create_global_grid) IF (create_global_grid) THEN !query user on spacing of points: WRITE (*, "(/' ---------------------------------------------------------------')") WRITE (*, "( ' Select Density of Velocity Vectors:')") WRITE (*, "( ' 0 -> points 72 degrees apart ( 12 points on globe)')") WRITE (*, "( ' 1 -> points 36 degrees apart ( 42 points on globe)')") WRITE (*, "( ' 2 -> points 18 degrees apart ( 162 points on globe)')") WRITE (*, "( ' 3 -> points 9 degrees apart ( 642 points on globe)')") WRITE (*, "( ' 4 -> points 4.5 degrees apart ( 2,562 points on globe)')") WRITE (*, "( ' 5 -> points 2.25 degrees apart ( 10,242 points on globe)')") WRITE (*, "( ' 6 -> points 1.13 degrees apart ( 40,962 points on globe)')") WRITE (*, "( ' 7 -> points 0.56 degrees apart (163,842 points on globe)')") WRITE (*, "( ' 8 -> points 0.28 degrees apart (655,362 points on globe)')") WRITE (*, "( ' ---------------------------------------------------------------')") 2164 CALL Prompt_for_Integer("Which integer describes your choice?", subdivision, subdivision) IF ((subdivision < 0).OR.(subdivision > 8)) THEN WRITE (*, "(' ERROR: Please select an integer from the table!')") CALL Pause() GO TO 2164 END IF numnod = 2 + 10 * (4**subdivision) ! ALLOCATE ( node_uvec(3, numnod) ) numel = 20 * (4**subdivision) ALLOCATE ( nodes(3, numel) ) CALL Make_Global_Grid (subdivision, & ! only input(!) & numnod, node_uvec, & ! output: number of nodes, unit vectors of nodes, & numel, nodes) ! number of elements, element definitions CALL Write_Global_Grid (path_out, & & subdivision, & & numnod, node_uvec, & & numel, nodes) ! all are INTENT(IN) DEALLOCATE ( nodes ) ! note: node_uvec will be allocated later (same for either branch) ELSE ! read an existing .feg 2165 temp_path_in = path_in CALL File_List( file_type = "*.feg", & & suggested_file = feg_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file contains the (velocity-location) nodes?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 23, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (23) CALL Press_Enter mt_flashby = .FALSE. GO TO 2165 END IF READ (23,"(A)") line CALL Add_Title(line) READ (23,*) numnod ALLOCATE ( node_uvec(3,numnod) ) DO i = 1, numnod READ (23,*) j, lon, lat CALL LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod CLOSE (23) END IF ! create, or read existing, .feg !query user on length of vectors (expressed in Ma): CALL Prompt_for_Real('For how many Ma should velocity be projected?',velocity_Ma,velocity_Ma) !go to work! WRITE (*,"(/' Working on plate-model velocity vectors....')") CALL Set_Stroke_Color ("foreground") CALL Set_Line_Style (width_points = 1.5, dashed =.FALSE.) CALL Set_Join_to_Mitre() CALL Begin_Group() DO i = 1, numnod uvec(1:3) = node_uvec(1:3, i) visible = L5_In_Window(uvec) IF (visible) THEN !test whether point "uvec" is in any orogen of distributed deformation: CALL Which_Plate (uvec, nOrogens, nInEachOrogen, orogen_uvecs, & ! inputs & orogen_ID) ! output IF (orogen_ID == 0) THEN ! not in any orogen; proceed, by deciding which plate it is in CALL Which_Plate (uvec, nPlates, nInEachPlate, plate_uvecs, & ! inputs & plate_ID) ! output IF (plate_ID > 0) THEN ! we know which plate it is in! !characterize Euler rotation-rate vector every possible way: Euler(1:3) = omega(1:3, plate_ID) - omega(1:3, ref_frame_plate_ID) Euler_rate_radspMa = Length(Euler) IF (Euler_rate_radspMa > 1.E-6) THEN ! point is moving (in this reference frame) !find end-point of finite rotation continuing for velocity_Ma: arc2 = Euler_rate_radspMa * velocity_Ma ! result is counterclockwise rotation angle in radians CALL Make_Uvec(Euler, pole_uvec) az1 = Relative_Compass (from_uvec = pole_uvec, to_uvec = uvec) ! in radians, clockwise from N az2 = az1 - arc2 ! azimuth to end point arc3 = Arc (pole_uvec, uvec) ! radians away from Euler pole CALL Turn_To (azimuth_radians = az2, base_uvec = pole_uvec, far_radians = arc3, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) !create the (curved) vector symbol: CALL Begin_Group() CALL New_L45_Path(5, uvec) ! start point CALL Small_To_L45 (pole_uvec = pole_uvec, to_uvec = result_uvec) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) !now add the arrowhead: arc2 = Arc(uvec, result_uvec) ! overall length of vector arc3 = 0.15 * arc2 ! chosen length for arms of the arrowhead az1 = Relative_Compass (from_uvec = result_uvec, to_uvec = pole_uvec) ! direction from endpoint to pole az2 = az1 + (270 - 20) * radians_per_degree CALL Turn_To (azimuth_radians = az2, base_uvec = result_uvec, far_radians = arc3, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL New_L45_Path(5, uvec1) ! begin at one eccentric point CALL Great_to_L45(result_uvec) ! go to head of vector az2 = az1 + (270 + 20) * radians_per_degree CALL Turn_To (azimuth_radians = az2, base_uvec = result_uvec, far_radians = arc3, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL Great_to_L45(uvec1) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL End_Group() END IF ! point is moving END IF ! plate was identified END IF ! not in any orogen END IF ! visible in window IF (MOD(i, 10) == 0) THEN WRITE (*,"('+Working on plate-model velocity vectors....',I6,' out of ',I6)") i, numnod END IF END DO ! i = 1, numnod WRITE (*,"('+Working on plate-model velocity vectors....DONE. ')") CALL End_Group() WRITE (*,"(/' Working on plate-model velocity numbers....')") CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = "foreground") CALL Begin_Group() DO i = 1, numnod uvec(1:3) = node_uvec(1:3, i) visible = L5_In_Window(uvec) IF (visible) THEN !test whether point "uvec" is in any orogen of distributed deformation: CALL Which_Plate (uvec, nOrogens, nInEachOrogen, orogen_uvecs, & ! inputs & orogen_ID) ! output IF (orogen_ID == 0) THEN ! not in any orogen; proceed, by deciding which plate it is in CALL Which_Plate (uvec, nPlates, nInEachPlate, plate_uvecs, & ! inputs & plate_ID) ! output IF (plate_ID > 0) THEN ! we know which plate it is in! Euler(1:3) = omega(1:3, plate_ID) - omega(1:3, ref_frame_plate_ID) CALL Cross (Euler, uvec, tvec) tvec = R * tvec ! tvec will now be the velocity VECTOR in m/Ma velocity_mmpa = 0.001 * Length(tvec) velocity_mmpa_int = NINT(velocity_mmpa) velocity_mmpa_int = MIN(999, velocity_mmpa_int) velocity_mmpa_int = MAX( 0, velocity_mmpa_int) WRITE(c3, "(I3)") velocity_mmpa_int c3 = ADJUSTL(c3) !offset text relative to fiducial point using lr_fraction and ud_fraction: IF (velocity_mmpa_int /= 0) THEN az1 = Vector_Azimuth(site_uvec = uvec, vector = tvec) lr_fraction = 0.5 + 0.7 * SIN(az1) ud_fraction = 0.4 + 0.6 * COS(az1) ELSE lr_fraction = 0.5 ud_fraction = 0.4 END IF CALL L5_Text (uvec = uvec, angle_radians = 0.0, from_east = .TRUE., & & font_points = 10, lr_fraction = lr_fraction, ud_fraction = ud_fraction, & & text = TRIM(c3)) END IF ! plate was identified END IF ! not in any orogen END IF ! visible in window IF (MOD(i, 10) == 0) THEN WRITE (*,"('+Working on plate-model velocity numbers....',I6,' out of ',I6)") i, numnod END IF END DO ! i = 1, numnod WRITE (*,"('+Working on plate-model velocity numbers....DONE. ')") CALL End_Group() DEALLOCATE ( node_uvec ) ! in LIFO order DEALLOCATE ( orogen_uvecs ) DEALLOCATE ( plate_uvecs ) CALL Velocity_Explanation() ! common code; uses velocity_Ma CALL BEEPQQ (frequency = 440, duration = 250) ! end of 16: velocity vectors from plate model CASE (17) ! Euler poles from plate model CALL Add_Title("Euler Poles of Plate Model") 2170 WRITE (*, "(/' This overlay requires a plate-boundaries .dig file to be in the input folder:'& &/' ',A & &/' Please check that this is available, or move it in right now!')") & & TRIM(boundaries_dig_file) CALL Prompt_for_Logical("Is it available?", .TRUE., maybe) IF (.NOT.maybe) GO TO 2170 WRITE (*,"(/' Working on Euler poles of adjacent plates in plate model....')") !find out which pairs of plates are in contact: ALLOCATE ( touching(nPlates, nPlates) ) touching = .FALSE. !initialize whole array; entries in boundaries_dig_file will change some values 2191 temp_path_in = path_in boundaries_dig_pathfile = TRIM(temp_path_in) // TRIM(boundaries_dig_file) OPEN (UNIT = 21, FILE = boundaries_dig_pathfile, STATUS = "OLD", ACTION = "READ", IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(boundaries_dig_pathfile) introduce_pairs: DO READ (21,"(A)", IOSTAT = ios) c5 IF (ios /= 0) EXIT introduce_pairs c2 = c5(1:2) ! get first plate name plate_ID = 0 ! this should be replaced, in loop below plate1: DO i = 1, nPlates IF (c2 == names(i)) THEN plate_ID = i EXIT plate1 END IF END DO plate1 IF (plate_ID == 0) THEN WRITE (*, "(' ERROR: Bad plate name in ',A,': ',A,' in boundary ',A)") TRIM(boundaries_dig_file), c2, c5 CALL Pause() STOP END IF c2 = c5(4:5) ! get second plate name other_plate_ID = 0 ! this should be replaced, in loop below plate2: DO i = 1, nPlates IF (c2 == names(i)) THEN other_plate_ID = i EXIT plate2 END IF END DO plate2 IF (other_plate_ID == 0) THEN WRITE (*, "(' ERROR: Bad plate name in ',A,': ',A,' in boundary ',A)") TRIM(boundaries_dig_file), c2, c5 CALL Pause() STOP END IF more_plate_points: DO i = 1, mostInOnePlate + 1 READ (21, *, IOSTAT = ios) lon, lat IF (ios /= 0) THEN ! hit "*** end of line segment ***" EXIT more_plate_points END IF END DO more_plate_points touching(plate_ID, other_plate_ID) = .TRUE. touching(other_plate_ID, plate_ID) = .TRUE. END DO introduce_pairs CLOSE(21) ! plates_dig_file CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (width_points = 1.5, dashed =.FALSE.) CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') small_circle_radius_points = 4.0 large_circle_radius_points = 10.0 CALL Begin_Group() DO i = 1, nPlates ! moving plate DO j = 1, nPlates ! reference plate IF (touching(i, j)) THEN ! two plates are distinct but in contact c5 = names(i) // '-' // names(j) Euler(1:3) = omega(1:3, i) - omega(1:3, j) Euler_rate_radspMa = Length(Euler) IF (Euler_rate_radspMa > 1.E-6) THEN ! non-zero vector; it has a pole CALL Begin_Group() ! to make it easy to delete an unwanted pole (of 2 distant plates) CALL Make_Uvec(Euler, uvec) !make a small dot radius_points = small_circle_radius_points radians_per_point = (3.527777E-4)*(mp_scale_denominator*Conformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = radius_points * radians_per_point CALL Turn_To (azimuth_radians = 0., base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL New_L45_Path (5, result_uvec) CALL Small_to_L45 (uvec, result_uvec) ! complete small circle CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) !draw a circle around it for emphasis: radius_points = large_circle_radius_points CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') radius = radius_points * radians_per_point CALL Turn_To (azimuth_radians = 0., base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL New_L45_Path (5, result_uvec) CALL Small_to_L45 (uvec, result_uvec) ! complete small circle CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) CALL L5_Text (uvec = result_uvec, angle_radians = 0.0, from_east = .TRUE., & & font_points = 14, lr_fraction = 0.5, ud_fraction = 0.0, & & text = c5) CALL End_Group() END IF ! non-zero Euler vector END IF ! two plates are distinct but in contact END DO ! j = 1, nPlates; reference plate END DO ! i = 1, nPlates; moving plate CALL End_Group() DEALLOCATE ( touching ) CALL Chooser(bottom, right) IF (right) THEN CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL Begin_Group() CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = "Euler Pole:") number8 = ADJUSTL(ASCII8(velocity_Ma)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 12., & & angle_radians = 0., & & font_points = 14, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = "CO-PA") CALL Circle_on_L12 (level = 1, x = 0.5*(x1_points+x2_points), y = y2_points - 39., & & radius = large_circle_radius_points, stroke = .TRUE., fill = .FALSE.) CALL Circle_on_L12 (level = 1, x = 0.5*(x1_points+x2_points), y = y2_points - 39., & & radius = small_circle_radius_points, stroke = .FALSE., fill = .TRUE.) CALL End_Group() rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 48. ELSE IF (bottom) THEN CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Begin_Group() CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) + 12., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = "Euler Pole:") number8 = ADJUSTL(ASCII8(velocity_Ma)) CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = "CO-PA") CALL Circle_on_L12 (level = 1, x = x1_points+29., y = 0.5*(y1_points+y2_points)-13., & & radius = large_circle_radius_points, stroke = .TRUE., fill = .FALSE.) CALL Circle_on_L12 (level = 1, x = x1_points+29., y = 0.5*(y1_points+y2_points)-13., & & radius = small_circle_radius_points, stroke = .FALSE., fill = .TRUE.) CALL End_Group() bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58. END IF ! bottom or right legend WRITE (*,"( '+Working on Euler poles of adjacent plates in plate model....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 17: Euler poles from plate model CASE (18) ! boundary slip rates from plate model CALL Add_Title("Boundary Slip-Rates from Plate Model") 2180 WRITE (*, "(/' This overlay requires a .dat file with plate-boundary steps to be in the'& &/' input folder: ',A & &/' Please check that this is available, or move it in right now!')") & & TRIM(steps_dat_file) CALL Prompt_for_Logical("Is it available?", .TRUE., maybe) IF (.NOT.maybe) GO TO 2180 WRITE (*, *) CALL Prompt_for_Real('The widths of the shaded bands along plate boundaries are & &equal to their heave-rates multiplied by a time factor. For how many Ma should & &these boundary rates be projected?', velocity_Ma, velocity_Ma) steps_dat_pathfile = TRIM(path_in) // TRIM(steps_dat_file) WRITE (*,"(/' Working on boundary slip-rates from plate model....')") OPEN(UNIT = 21, FILE = steps_dat_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') !see Table 2 of PB2002_manuscript.doc for explanation of this FORMAT: 2181 FORMAT ( I4,1X,A1,A5,1X,F8.3,1X,F7.3,1X,F8.3,1X,F7.3,1X,F5.1,1X,I3,1X,F5.1,1X,I3,1X,F6.1, 1X,F6.1,1X,I6,1X,I3,1X,A1, A3, A1) !READ(21,2181)i, c1,c5, lon1, lat1, lon2, lat2, long, azim, veloc, v_az, spread, dextral, elev, age, c1a,class,star IF (ios /= 0) CALL Could_Not_Find_File(steps_dat_pathfile) !read through once to count steps which are NOT annotated with * for orogen step_count = 0 DO READ (21, 2181, IOSTAT = ios) i, c1,c5, lon1, lat1, lon2, lat2, long, azim, veloc, v_az, spread, dextral, elev, age, c1a,class,star IF (ios /= 0) EXIT IF (star /= '*') step_count = step_count + 1 END DO CLOSE(21) ALLOCATE ( slipnumbers(2, step_count) ) ALLOCATE ( plot_at_uvec(3, step_count) ) ALLOCATE ( up_azim_rads(step_count) ) OPEN(UNIT = 21, FILE = steps_dat_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') CALL Begin_Group ! of colored/shaded bands (two per step; the wider one plotted first) sup_slipnumber = 0.0 step_count = 0 visible_labels = 0 reading_steps: DO READ (21, 2181, IOSTAT = ios) i, c1,c5, lon1, lat1, lon2, lat2, long, azim, veloc, v_az, spread, dextral, elev, age, c1a,class,star IF (ios /= 0) EXIT reading_steps IF (star /= '*') THEN step_count = step_count + 1 CALL LonLat_2_Uvec(lon1, lat1, uvec1) CALL LonLat_2_Uvec(lon2, lat2, uvec2) tvec(1:3) = (uvec1(1:3) + uvec2(1:3))/2. CALL Make_Uvec(tvec, uvec4) ! uvec4 is midpoint (overwritten below) IF (L5_In_Window(uvec4)) visible_labels = visible_labels + 1 slipnumbers(1, step_count) = dextral ! store for plotting #s later! slipnumbers(2, step_count) = spread ! store for plotting #s later! sup_slipnumber = MAX(sup_slipnumber, slipnumbers(1, step_count)) sup_slipnumber = MAX(sup_slipnumber, slipnumbers(2, step_count)) f_azim_rads_c = azim * radians_per_degree IF (SIN(f_azim_rads_c) > 0.0) THEN up_azim_rads(step_count) = f_azim_rads_c - Pi/2. ! store for plotting #s later! ELSE up_azim_rads(step_count) = f_azim_rads_c + Pi/2. !(ditto) END IF offset_radians = velocity_Ma * MAX(ABS(slipnumbers(1,step_count)),ABS(slipnumbers(2,step_count))) * 500. / R CALL Turn_To (azimuth_radians = up_azim_rads(step_count), & & base_uvec = uvec4, far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) plot_at_uvec(1:3, step_count) = uvec3(1:3) ! store for plotting #s later !plot both components, but plot the larger(ABS) first so that the smaller is visible! IF (ABS(slipnumbers(1,step_count)) > ABS(slipnumbers(2,step_count))) THEN n1 = 1; n2 = 2; d_n = 1 ! do strike-slip first ELSE ! component 2 is bigger than component 1; plot #2 first n1 = 2; n2 = 1; d_n = -1 ! do dip-slip first END IF DO n = n1, n2, d_n IF (ai_using_color) THEN IF (n == 2) THEN ! spreading/convergence component IF (spread > 0.0) THEN color_name = 'bronze____' ELSE ! thrust color_name = 'mid_blue__' END IF ! normal or thrust ELSE ! n == 1; strike-slip colors IF (dextral > 0.0) THEN color_name = 'green_____' ELSE ! sinistral color_name = 'brown_____' END IF ! dextral or sinistral END IF ! dip-slip or strike-slip colors ELSE ! b/w plot IF (n == 2) THEN ! spreading/convergence component color_name = 'gray______' ELSE ! n == 1; strike-slip color color_name = 'foreground' END IF ! dip-slip or strike-slip colors END IF ! ai_using_color, or b/w CALL Set_Fill_or_Pattern (use_pattern = .FALSE., color_name = color_name) width_radians = velocity_Ma * ABS(slipnumbers(n, step_count)) * 1000.0 / mp_radius_meters !construct parallelogram using v_az information (so adjacent boxes will connect): IF (ABS(slipnumbers(2, step_count)) > ABS(slipnumbers(1, step_count))) THEN ! dip-slip is the main mode az_radians = v_az * radians_per_degree ELSE ! strike-slip is the main mode az_radians = (v_az + 90) * radians_per_degree END IF CALL Turn_To (azimuth_radians = az_radians, & & base_uvec = uvec1, far_radians = width_radians/2., & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL New_L45_Path (5, uvec3) CALL Turn_To (azimuth_radians = az_radians, & & base_uvec = uvec2, far_radians = width_radians/2., & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec4) CALL Great_to_L45(uvec4) CALL Turn_To (azimuth_radians = (az_radians + Pi), & & base_uvec = uvec2, far_radians = width_radians/2., & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec4) CALL Great_to_L45(uvec4) CALL Turn_To (azimuth_radians = (az_radians + Pi), & & base_uvec = uvec1, far_radians = width_radians/2., & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec4) CALL Great_to_L45(uvec4) CALL Great_to_L45(uvec3) ! returning to starting point (offset from uvec1) CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END DO ! n = 1, 2 OR 2, 1 END IF ! star /= '*' (not in a orogen) END DO reading_steps CALL End_Group ! of colored/shaded bands ALLOCATE ( selected(step_count) ) WRITE (*,"(/' There will be ',I7,' rate numbers plotted if they are not thinned.')") visible_labels 2182 CALL Prompt_for_Integer('What thinning factor ( >=1 ) do you want?',label_thinner,label_thinner) IF (label_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") mt_flashby = .FALSE. GO TO 2182 END IF CALL Thin_on_Sphere (plot_at_uvec, step_count, label_thinner, selected) CALL Begin_Group ! of rate numbers CALL Set_Fill_or_Pattern(.FALSE., 'foreground') DO i = 1, step_count IF (selected(i)) THEN uvec1(1:3) = plot_at_uvec(1:3, i) IF (ABS(slipnumbers(1, i)) < 100.0) THEN string10 = ADJUSTL(ASCII8(slipnumbers(1, i))) ELSE ! use 3 significant digits; don't round to nearest 10 mm/a string10 = ADJUSTL(ASCII9(slipnumbers(1, i))) END IF IF (ABS(slipnumbers(2, i)) < 100.0) THEN line = TRIM(string10) // '[' // TRIM(ADJUSTL(ASCII8(slipnumbers(2, i)))) // ']' ELSE ! use 3 significant digits; don't round to nearest 10 mm/a line = TRIM(string10) // '[' // TRIM(ADJUSTL(ASCII9(slipnumbers(2, i)))) // ']' END IF CALL L5_Text (uvec = uvec1, angle_radians = -up_azim_rads(i), from_east = .TRUE., & & font_points = 10, lr_fraction = 0.5, ud_fraction = -0.2, & & text = TRIM(line)) END IF ! selected(i) END DO ! i = 1, step_count CALL End_Group ! of rate numbers DEALLOCATE ( selected ) DEALLOCATE ( up_azim_rads ) DEALLOCATE ( plot_at_uvec ) DEALLOCATE ( slipnumbers ) CALL Chooser (bottom, right) CALL Begin_Group ! sample sliprates ! how fast is a 20-point band, in mm/a? sliprate1 = (((20./2834.)/1000.)*mp_scale_denominator)/velocity_Ma ! ( bandwidth, in km, on Earth ) CALL Set_Fill_or_Pattern(.FALSE., 'foreground') IF (right) THEN CALL Report_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. CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = '[' // TRIM(ADJUSTL(ASCII8(sliprate1)))//"] mm/a") ! normal: [59] mma/a CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-45., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = "[-" // TRIM(ADJUSTL(ASCII8(sliprate1)))//"] mm/a") ! thrust: [-59] mm/a CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-80., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(ADJUSTL(ASCII8(sliprate1)))//' mm/a') ! dextral: 59 mm/a CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-115., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = '-' // TRIM(ADJUSTL(ASCII8(sliprate1)))//' mm/a') ! sinistral: -59 mm/a IF (ai_using_color) THEN CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-32., & & color_name = 'bronze____', text = 'normal') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-67., & & color_name = 'mid_blue__', text = 'thrust') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-102., & & color_name = 'green_____', text = 'dextral') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-137., & & color_name = 'brown_____', text = 'sinistral') ELSE ! b/w CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-32., & & color_name = 'gray______', text = 'normal') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-67., & & color_name = 'gray______', text = 'thrust') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-102., & & color_name = 'foreground', text = 'dextral') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-137., & & color_name = 'foreground', text = 'sinistral') END IF ! color or b/w rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 137. CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points CALL Set_Fill_or_Pattern(.FALSE.,'foreground') CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Horizontal') CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'components of') CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-30., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'slip rate') rightlegend_used_points = rightlegend_used_points + 30. ELSE ! bottom CALL Report_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. CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp+10., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'Horizontal') CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp, angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'components of') CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp-10., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'slip rate:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72. CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points !each sample: 5 pt gap + 62 pt wide + 5 pt gap = 72 pt CALL L12_Text (level = 1, x_points = x1_points+36., & & y_points = ycp+12., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = '[' // TRIM(ADJUSTL(ASCII8(sliprate1)))//"] mm/a") ! normal: [59] mm/a CALL L12_Text (level = 1, x_points = x1_points+108., & & y_points = ycp+12., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = "[-" // TRIM(ADJUSTL(ASCII