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 an .ai graphics file with map, ! in a choice of 10 different map projections. ! ! by Peter Bird ! Department of Earth, Planetary, and Space Sciences ! University of California ! Los Angeles, CA 90095-1567 ! pbird@epss.ucla.edu ! !(c) Copyright 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2010, ! 2012, 2104, 2015, 2016, and 2017 ! by Peter Bird and the Regents of the University of California. ! USE DAdobe_Illustrator ! from Peter Bird's file DAdobe_Illustrator.f90 USE DMap_Projections ! from Peter Bird's file DMap_Projections.f90 USE DMap_Tools ! from Peter Bird's file DMap_Tools.f90 USE DIcosahedron ! from Peter Bird's file DIcosahedron.f90 USE DFLIB ! provided with Digital Visual Fortran, ! and also with Intel Parallel Studio XE 2013: ! 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. !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 = ' ', gp2_pathfile = ' ', & & 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 = ' ', & & point_data_file = ' ', point_data_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, beyond_loc, bitmap_color_mode, bitmap_height, & & bitmap_interpolation_mode, & & 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, end_loc, & & f_dig_count, f_highest, fault_count, fixed_node, & & GP2_count, group, & & heave_rate_method, high_GP2_index, high_trace, & & i, i_high, i1, i2, iele, internal_ios, ios, irow, & & j, jcol, jp, jp1, j1, j2, & & k, k_site, kilometers, & & l, l_, label_thinner, last_mosaic_choice, line_count, list_length, lp, & & m, m1, m2, ma, mb, minutes, mosaic_count, & & n, n1, n2, na, nb, nfl, n_intersection, n_items_done, n_refine, n_rounded, & & node_scalar_choice, node_scalar_limit, node_scalar_method, & & nonorbiting_node, np1, number_rejected, numel, numnod, & & old_k_site, old_mosaic_count, old_overlay_count, overlay_count, other_plate_ID, & & orogen_ID, & & path_length, plate_ID, point_count, point_pixel_width, & & read_status, ref_frame_plate_ID, rotationrate_method, & & s_nki_count, s1h_azim_int, s1h_sigma_int, segment_count, & & skip_lines, start_loc, step_count, & & strainrate_mode012, strainrate_mosaic_method, strainrate_mosaic_mode, strain_thinner, & ! method = bitmap/object; mode = log/linear & units & stress_interpolation_method, stress_thinner, subdivision, & & title_choice, title_count, & & trace_index, train_length, & & v_az, vector_thinner, velocity_method, velocity_mmpa_int, visible_labels, visible_point_count 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, advised_GPS_Postprocessor, any_cracked, any_FPS, any_titles, azimuth_is_integer, & & black_is_high, bottom, bull_on, 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_dip_degrees, got_index, got_parameters, got_point, grid_lowblue, & & hide_steps_in_orogens, & & 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, & & new_benchmark, node_scalar_lowblue, nseg, & & only_stressed, & & plot_GP2_ellipses, plot_dig_titles, plot_FPS, plot_this, point_data_values, polygons, problem, & & right, rotationrate_lowblue, & & shaded_relief, sigma_is_integer, skip_0_contour, stroke_this, success, suggest_logical, & & try_again, & & using_A_to_E, & & valid_azimuth, valid_FPS, velocity_reframe, velocity_lowblue, virgin, visible, & & xy_defined, & & zero_as_white LOGICAL, DIMENSION(:), ALLOCATABLE :: cracking, recorrelate_benchmark, selected, s1h_known LOGICAL(1), DIMENSION(:,:), ALLOCATABLE :: bitmap_success, touching !----------------------------------------------------------------------------------------------- ! STRUCTURAL CHANGE in February 2015: ! All REAL variables were changed to REAL*8 (i.e., DOUBLE PRECISION). ! At the same time, USEd MODULEs Adobe_Illustrator, Map_Projections, & Map_Tools ! were replaced with DOUBLE PRECISION versions named ! DAdobe_Illustrator, DMap_Projections, & DMap_Tools. ! In these upgraded modules, letter "D" was added to the name of each ! SUBROUTINE or FUNCTION. Now, all REAL function arguments (INPUT or OUTPUT) ! to these subprograms have been replaced by REAL*8 arguments. !---------------------------------------------------------------------------------------------- !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; OR, enter the "old" dips in f*.dig with "dip_degrees" code. !If you recompile, 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 version of NeoKineMap.exe to show that it only works with NeoKinema v1.x models! REAL*8, PARAMETER :: normal_dip_degrees = 55.0D0 ! consistent with Bird & Kagan [2004] Table 5 value used in Long_Term_Seismicity REAL*8, PARAMETER :: thrust_dip_degrees = 20.0D0 ! consistent with Bird & Kagan [2004] Table 5 value used in Long_Term_Seismicity REAL*8, PARAMETER :: subduction_dip_degrees = 14.0D0 ! consistent with Bird & Kagan [2004] Table 5 value used in Long_Term_Seismicity REAL*8, PARAMETER :: bottomlegend_gap_points = 14.0D0 REAL*8, PARAMETER :: m_per_km = 1000.0D0 REAL*8, PARAMETER :: rightlegend_gap_points = 14.0D0 REAL*8, PARAMETER :: sec_per_year = 365.25D0*24.D0*60.D0*60.D0 REAL*8, PARAMETER :: s_per_Ma = 1000000.D0*365.25D0*24.D0*60.D0*60.D0 REAL*8, PARAMETER :: subdip = 27.5D0 ! degrees; should match SHELLS value REAL*8 :: 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, & & 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, & & real_column, real_row, & & 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, strainrate_mosaic_interval, strainrate_mosaic_midvalue, & & 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, value_max, value_min, variance_mm2pera2, & & 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*8, 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*8, DIMENSION(3) :: eps_dot DOUBLE PRECISION, DIMENSION(3,2,2,2):: dG DOUBLE PRECISION, DIMENSION(3,2,2) :: G REAL*8, DIMENSION(3,7) :: Gauss_point REAL*8, DIMENSION(3, nPlates) :: omega REAL*8, DIMENSION(:), ALLOCATABLE :: a_ ! plane areas (R == 1.0) of spherical elements REAL*8, 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, & & benchmark_c12_mm2pera2 REAL*8, DIMENSION(:,:),ALLOCATABLE :: benchmark_uvec REAL*8, DIMENSION(:,:),ALLOCATABLE :: bitmap_value REAL*8, DIMENSION(:,:),ALLOCATABLE :: center ! uvecs of spherical elements REAL*8, DIMENSION(:), ALLOCATABLE :: e3_minus_e1_persec REAL*8, DIMENSION(:), ALLOCATABLE :: element_scalar REAL*8, DIMENSION(:), ALLOCATABLE :: f_dip_degrees REAL*8, DIMENSION(:), ALLOCATABLE :: f_rate_mmpa REAL*8, DIMENSION(:,:),ALLOCATABLE :: fdip REAL*8, DIMENSION(:), ALLOCATABLE :: graphic_largest_ei_persec REAL*8, DIMENSION(:,:),ALLOCATABLE :: grid1, grid2 REAL*8, DIMENSION(:), ALLOCATABLE :: heave_rate_mmpa REAL*8, DIMENSION(:), ALLOCATABLE :: omega_degperMa ! (numel) REAL*8, DIMENSION(:), ALLOCATABLE :: node_scalar REAL*8, DIMENSION(:,:),ALLOCATABLE :: node_uvec REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: orogen_uvecs REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: plate_uvecs REAL*8, DIMENSION(:,:),ALLOCATABLE :: plot_at_uvec REAL*8, DIMENSION(:), ALLOCATABLE :: s_azim REAL*8, DIMENSION(:), ALLOCATABLE :: s_sigma_ REAL*8, DIMENSION(:,:),ALLOCATABLE :: s_site REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: segments REAL*8, DIMENSION(:), ALLOCATABLE :: segment_dip_degrees REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: segment_uvecs REAL*8, DIMENSION(:,:),ALLOCATABLE :: slipnumbers ! 2 components used in steps.dat overlay REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: strainrate ! (3,7,numel) REAL*8, DIMENSION(:,:), ALLOCATABLE :: trace ! list of all uvecs encountered in f_dig REAL*8, DIMENSION(:), ALLOCATABLE :: trace_mma REAL*8, DIMENSION(:), ALLOCATABLE :: train REAL*8, DIMENSION(:), ALLOCATABLE :: up_azim_rads REAL*8, DIMENSION(:,:),ALLOCATABLE :: uvec_list REAL*8, DIMENSION(:), ALLOCATABLE :: vsize_mma DOUBLE PRECISION,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*8 :: heave_rate_mps ! heave-rate, in meters/second (SI); almost always positive REAL*8, DIMENSION(3) :: uvec1 ! unit vector with Cartesian location of start point REAL*8, 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.3333333333333333D0, 0.3333333333333333D0, 0.3333333333333333D0, & & 0.0597158733333333D0, 0.4701420633333333D0, 0.4701420633333333D0, & & 0.4701420633333333D0, 0.0597158733333333D0, 0.4701420633333333D0, & & 0.4701420633333333D0, 0.4701420633333333D0, 0.0597158733333333D0, & & 0.7974269866666667D0, 0.1012865066666667D0, 0.1012865066666667D0, & & 0.1012865066666667D0, 0.7974269866666667D0, 0.1012865066666667D0, & & 0.1012865066666667D0, 0.1012865066666667D0, 0.7974269866666667D0/ ! 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.002401D0, -0.00793D0, 0.013891D0, & ! 1 & 0.000949D0, -0.00864D0, 0.013725D0, & ! 2 & 0.000689D0, -0.00654D0, 0.013676D0, & ! 3 & 0.002042D0, -0.01315D0, 0.008856D0, & ! 4 & 0.008570D0, -0.00560D0, 0.017497D0, & ! 5 & 0.000148D0, -0.00307D0, 0.010915D0, & ! 6 & 0.015696D0, 0.002467D0, 0.023809D0, & ! 7 & 0.009349D0, 0.000284D0, 0.016253D0, & ! 8 & 0.000184D0, 0.005157D0, 0.001150D0, & ! 9 & -0.00087D0, -0.00226D0, 0.002507D0, & ! 10 & -0.01912D0, 0.030087D0, 0.010227D0, & ! 11 & 0.011506D0, -0.04452D0, 0.007197D0, & ! 12 & 0.001688D0, -0.00904D0, 0.012815D0, & ! 13 & 0.003716D0, -0.00379D0, 0.000949D0, & ! 14 & -0.00891D0, -0.02644D0, 0.020895D0, & ! 15 & -0.06117D0, 0.005216D0, -0.01375D0, & ! 16 & 0.070136D0, 0.160534D0, 0.094328D0, & ! 17 & 0.000529D0, -0.00723D0, 0.013123D0, & ! 18 & -0.08325D0, -0.00246D0, -0.01492D0, & ! 19 & 0.016256D0, 0.089364D0, 0.015035D0, & ! 20 & 0.008181D0, -0.00480D0, 0.016760D0, & ! 21 & 0.006512D0, 0.003176D0, 0.005073D0, & ! 22 & 0.108013D0, 0.299461D0, 0.230528D0, & ! 23 & 0.033318D0, -0.00181D0, 0.036441D0, & ! 24 & -0.01383D0, 0.008245D0, 0.015432D0, & ! 25 & -0.77784D0, 0.440872D0, -0.04743D0, & ! 26 & 0.001521D0, 0.007739D0, 0.013437D0, & ! 27 & 0.038223D0, -0.05829D0, 0.013679D0, & ! 28 & 0.001768D0, -0.00843D0, 0.009817D0, & ! 29 & -0.00433D0, 0.003769D0, -0.00040D0, & ! 30 & 0.000111D0, -0.00636D0, 0.010449D0, & ! 31 & 0.044913D0, -0.00954D0, 0.010601D0, & ! 32 & -0.05534D0, -0.01089D0, 0.006794D0, & ! 33 & -0.00002D0, -0.01341D0, 0.019579D0, & ! 34 & 0.001041D0, -0.00830D0, 0.012143D0, & ! 35 & -0.02622D0, 0.020184D0, 0.037208D0, & ! 36 & 0.000000D0, 0.000000D0, 0.000000D0, & ! 37 & -0.00004D0, -0.00929D0, 0.012815D0, & ! 38 & 0.012165D0, -0.01251D0, -0.00036D0, & ! 39 & -0.01918D0, -0.07060D0, 0.036797D0, & ! 40 & 0.000472D0, -0.00635D0, 0.009100D0, & ! 41 & 0.121443D0, -0.07883D0, 0.027122D0, & ! 42 & 0.001117D0, -0.00743D0, 0.008534D0, & ! 43 & -0.00083D0, -0.00670D0, 0.013323D0, & ! 44 & 0.001287D0, -0.00875D0, 0.014603D0, & ! 45 & -0.01719D0, 0.017186D0, 0.008623D0, & ! 46 & 0.003201D0, -0.01044D0, 0.015854D0, & ! 47 & 0.023380D0, -0.01936D0, -0.01046D0, & ! 48 & -0.00940D0, 0.023063D0, 0.008831D0, & ! 49 & 0.142118D0, 0.005616D0, 0.078214D0, & ! 50 & -0.01683D0, 0.018478D0, 0.010166D0, & ! 51 & -0.00083D0, -0.00616D0, 0.016274D0/ ! 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.0D0 / DTAN(normal_dip_radians) cot_thrust_dip = 1.0D0 / DTAN(thrust_dip_radians) cot_subduction_dip = 1.0D0 / DTAN(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: all REAL*8 version of 3 November 2017'& &/' (works with versions 1.x, 2.x, 3.x, 4.x, & 5.x of NeoKinema)'& &/' -----------------------------------------------------------------')") CALL DPrompt_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 (digitized 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 DPrompt_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+ (including CS+) for Windows, or for 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 DPrompt_for_Logical('Do you want detailed information about input and output files?',.FALSE.,more_info) IF (more_info) THEN CALL DPrompt_for_Logical('Do you want information about Digitize (*.dig) files?',.TRUE.,more_dig) IF (more_dig) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Digitize (*.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 DPrompt_for_Logical('Do you want more information about Digitize (*.dig) files?',.TRUE.,more_dig) IF (more_dig) THEN WRITE (*,"(//' ----------------------------------------------------------------------'& &/' More About Digitize (*.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 DPrompt_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 DPrompt_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'& &/' or OrbWin and have 3-node spherical triangles (but no fault elements).'& &//' ----------------------------------------------------------------------')") END IF ! more_feg CALL DPrompt_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 DPrompt_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 DPrompt_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 DPrompt_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 DPrompt_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 DPrompt_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 DPrompt_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+ (or CS+) for Windows, or for 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 DPrompt_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 DPress_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 DPrompter to get page and projection parameters. ! (4) Ask user what elements are desired in the plot. ! For each element, prompt for necessary files, contour ! intervals, etc. UNLIKE 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_interpolation_mode 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) strainrate_mosaic_method ! method = bitmap/objects problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) strainrate_mosaic_mode ! mode = log/linear, & units (/s or nanostrain/year) problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) strainrate_mosaic_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) strainrate_mosaic_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,"(A)",IOSTAT=ios) point_data_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) point_data_values problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) point_pixel_width 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)",IOSTAT=ios) old_eqc_file problem = problem.OR.(ios /= 0) READ (11,*,IOSTAT=ios) plot_FPS problem = problem.OR.(ios /= 0) READ (11,*,IOSTAT=ios) min_mag problem = problem.OR.(ios /= 0) READ (11,*,IOSTAT=ios) 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 DPress_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_interpolation_mode = 0 bitmap_color_mode = 1 shaded_relief = .FALSE. bitmap_shading_mode = 1 intensity = 0.5D0 grid_units = 'm' grid_interval = 0.D0 grid_midvalue = 0.D0 grid_lowblue = .TRUE. skip_0_contour = .FALSE. element_scalar_method = 2 element_scalar_feg_file = ' ' element_scalar_units = ' ' element_scalar_interval = 0.D0 element_scalar_midvalue = 0.D0 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.D0 node_scalar_midvalue = 0.D0 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.D0 reference_Nlat_deg = 0.D0 reference_vE_mmpa = 0.D0 reference_vN_mmpa = 0.D0 reference_ccw_degpMa = 0.D0 velocity_method = 2 velocity_interval = 0.D0 velocity_midvalue = 0.D0 velocity_lowblue = .TRUE. strainrate_mosaic_method = 2 ! method = polygons or bitmap strainrate_mosaic_mode = 1 ! mode = logarithmic or linear, & units (/s or nanostrains/year) strainrate_mosaic_interval = 1.0D0 strainrate_mosaic_midvalue = 0.0D0 log_strainrate_lowblue = .TRUE. rotationrate_method = 2 rotationrate_interval = 1.0D0 rotationrate_midvalue = 0.0D0 rotationrate_lowblue = .TRUE. point_data_file = ' ' point_data_values = .TRUE. point_pixel_width = 3 old_overlay_count = 1 overlay_choice = 0 ! whole array overlay_choice(1) = 1 lines_basemap_file = ' ' tick_points = 6.0D0 node_radius_points = 0.0D0 traces_file = ' ' f_nko_file = ' ' heave_segments_file = ' ' vel_file = ' ' gps_type = 1 gps_file = ' ' benchmark_points = 4.0D0 velocity_Ma = 10.0D0 vector_thinner = 1 heave_rate_method = 1 dv_scale_mma = 50.0D0 dv_scale_points = 25.0D0 R = 6371000.D0 strainrate_mode012 = 2 ref_e3_minus_e1_persec = 5.D-17 strainrate_diameter_points = 20.0D0 strain_thinner = 1 e1_size_points = 24.0D0 stress_thinner = 1 s1_size_points = 24.0D0 s1h_file = ' ' s1h_interp_points = 20.0D0 only_stressed = .FALSE. old_eqc_file = ' ' plot_FPS = .TRUE. min_mag = 4.4D0 m8_diam_points = 28.0D0 volcano_file = "Volcanoes.dat" volcano_points = 7.0D0 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!'& &/' ----------------------------------------------------------------------')") 10 CALL DPrompt_for_String('What is the path for your input files?',path_in,path_in) path_in = ADJUSTL(path_in) !warn about apparently-illegal path! --------------------------------------------------- path_length = LEN_TRIM(path_in) IF (path_length > 0) THEN c1 = path_in(path_length:path_length) IF (.NOT.((c1 == '\').OR.(c1 == '/'))) THEN WRITE (*, "(' ERROR: Each path must end in ''\'' (Windows) or ''/'' (Unix)!')") CALL DPrompt_for_Logical('Do you need to re-type this path?', .TRUE., try_again) IF (try_again) GO TO 10 END IF END IF !---------------------------------------------------------------------------------------- IF (LEN_TRIM(path_out) == 0) path_out = TRIM(path_in) 20 CALL DPrompt_for_String('What is the path for your output (.ai graphics) file?',path_out,path_out) path_out = ADJUSTL(path_out) !warn about apparently-illegal path! --------------------------------------------------- path_length = LEN_TRIM(path_out) IF (path_length > 0) THEN c1 = path_out(path_length:path_length) IF (.NOT.((c1 == '\').OR.(c1 == '/'))) THEN WRITE (*, "(' ERROR: Each path must end in ''\'' (Windows) or ''/'' (Unix)!')") CALL DPrompt_for_Logical('Do you need to re-type this path?', .TRUE., try_again) IF (try_again) GO TO 20 END IF END IF !---------------------------------------------------------------------------------------- WRITE (*,"(' IT WILL NOT BE NECESSARY TO TYPE THESE PATHS AGAIN!')") !-------------------------(end of defining paths)-------------------- CALL DPrompter (xy_mode = .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! got_parameters = .FALSE. !-------------------------- 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.D0 ! records filling of bottom legend, from left rightlegend_used_points = 0.D0 ! 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 :: digitized basemap (polygons type)')") IF (ai_using_color) THEN WRITE (*,"(' 2 :: colored/shaded bitmap from gridded dataset(s)')") ELSE WRITE (*,"(' 2 :: shaded-relief or 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 (e.g., {optional} mu_)')") 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 modeled faults')") 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 (*,"(' 13 :: point data as small rectangles, merged into one bitmap')") WRITE (*,"(' -------------------------------------------------------------------------------')") suggest_logical = old_mosaic_count > mosaic_count IF (mosaic_count == 0) CALL DPrompt_for_Logical('Do you want one (or more) of these mosaics?',suggest_logical,do_mosaic) IF (do_mosaic) THEN mosaic_count = mosaic_count + 1 choice = mosaic_choice(mosaic_count) CALL DPrompt_for_Integer('Which mosaic type should be added?',choice,choice) IF ((choice < 1).OR.(choice > 13)) THEN WRITE (*,"(/' ERROR: Please select an integer from the list!')") CALL DPress_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 DPrompt_for_String('Which file should be plotted?',polygons_basemap_file,polygons_basemap_file) polygons_basemap_pathfile = TRIM(temp_path_in)//TRIM(polygons_basemap_file) CALL Dig_Type (polygons_basemap_pathfile, 21, dig_is_lonlat, any_titles) CALL DPrompt_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 DPress_Enter STOP ' ' END IF IF (any_titles) THEN WRITE (*, "(/' Title lines were detected in this .dig file;')") CALL DPrompt_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 DPrompt_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 DSet_Fill_or_Pattern (.FALSE., 'gray______') CALL DNew_L12_Path (1, ai_window_x1_points, ai_window_y1_points) CALL DLine_To_L12 (ai_window_x2_points, ai_window_y1_points) CALL DLine_To_L12 (ai_window_x2_points, ai_window_y2_points) CALL DLine_To_L12 (ai_window_x1_points, ai_window_y2_points) CALL DLine_To_L12 (ai_window_x1_points, ai_window_y1_points) CALL DEnd_L12_Path (close = .TRUE., stroke = .FALSE., & & fill = .TRUE.) ! continental polygons are foreground line, background fill CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color (color_name = 'foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') polygons = .TRUE. IF (dig_is_lonlat) THEN CALL DPlot_Dig (7, polygons_basemap_pathfile, polygons, 21, in_ok) ELSE CALL DPlot_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 DSet_Fill_or_Pattern (.FALSE., 'foreground') IF (dig_is_lonlat) THEN CALL DPlot_Dig (7, polygons_basemap_pathfile, polygons, 21, in_ok, dig_title_method) ELSE CALL DPlot_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 (440, 250) ! end of basemap mosaic 1100 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. ! <--- 1100 is out-of-sequence, but helps to locate code for mosaic CASE(10) CALL DPrompt_for_Logical('Do you want shaded relief?',shaded_relief,shaded_relief) IF (shaded_relief) THEN WRITE (*,"(/' -------------------------------------------------------')") WRITE (*,"( ' Source of Shaded Relief:')") WRITE (*,"( ' 1 = same dataset as that used to assign colors')") WRITE (*,"( ' 2 = a different dataset (usually a topographic DEM)')") WRITE (*,"( ' -------------------------------------------------------')") 1020 CALL DPrompt_for_Integer('Bitmap shading mode (1 or 2)?',bitmap_shading_mode,bitmap_shading_mode) IF ((bitmap_shading_mode < 1).OR.(bitmap_shading_mode > 2)) THEN WRITE (*,"(' ERROR: Please select 1 or 2')") mt_flashby = .FALSE. GO TO 1020 END IF ELSE bitmap_shading_mode = 1 ! only one dataset grd2_success = .FALSE. 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 DPrompt_for_String('Which file should be displayed?',grd1_file,grd1_file) grd2_file = grd1_file ELSE ! bitmap_shading_mode = 2; two .grd files CALL DPrompt_for_String('Which file will determine the colors?',grd1_file,grd1_file) CALL DPrompt_for_String('Which file will control the 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 = (DABS(grd1_lat_min)<91.D0).AND.(DABS(grd1_lat_max)<91.D0) CALL DPrompt_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 DPress_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 (DABS(grd1_lon_max - grd1_lon_min - 360.0D0) < 0.01D0) THEN grd1_lon_range = 360.0D0 ELSE grd1_lon_range = DEasting(grd1_lon_max - grd1_lon_min) END IF READ (21, *, IOSTAT = ios) grd1_lat_min, grd1_d_lat, grd1_lat_max problem = problem .OR. (ios /= 0) grd1_ncols = 1 + NINT((grd1_lon_max - grd1_lon_min) / grd1_d_lon) grd1_nrows = 1 + NINT((grd1_lat_max - grd1_lat_min) / grd1_d_lat) ELSE ! (x,y) format READ (21, *, IOSTAT = ios) grd1_x_min, grd1_d_x, grd1_x_max problem = problem .OR. (ios /= 0) grd1_x_min = grd1_x_min * mt_meters_per_user grd1_d_x = grd1_d_x * mt_meters_per_user grd1_x_max = grd1_x_max * mt_meters_per_user READ (21, *, IOSTAT = ios) grd1_y_min, grd1_d_y, grd1_y_max problem = problem .OR. (ios /= 0) grd1_y_min = grd1_y_min * mt_meters_per_user grd1_d_y = grd1_d_y * mt_meters_per_user grd1_y_max = grd1_y_max * mt_meters_per_user grd1_ncols = 1 + NINT((grd1_x_max - grd1_x_min) / grd1_d_x) grd1_nrows = 1 + NINT((grd1_y_max - grd1_y_min) / grd1_d_y) END IF problem = problem .OR. (grd1_nrows < 2) .OR. (grd1_ncols < 2) ALLOCATE ( grid1(grd1_nrows, grd1_ncols) ) READ (21, *, IOSTAT = ios) ((grid1(i,j), j = 1, grd1_ncols), i = 1, grd1_nrows) problem = problem .OR. (ios /= 0) 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 DPress_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( Epicentroid rate density ) at or above magnitude "//threshold_magnitude_c6) n_rounded = 0 ! initialize counter DO i = 1, grd1_nrows DO j = 1, grd1_ncols IF (grid1(i, j) > 0.0D0) THEN grid1(i, j) = DLOG10(grid1(i, j)) ELSE IF (grid1(i, j) == 0.0D0) THEN !WRITE (*, *) !WRITE (*, "(' In row ',I6,' and column ',I6,' the value is ',ES12.4,'.')") i, j, grid1(i, j) !WRITE (*, "(' WARNING: Zero value(s) in seismicity-rate .grd file.')") !WRITE (*, "(' DLOG10 was set to ', ES10.2)") DLOG10(TINY(grid1(i, j))) grid1(i, j) = DLOG10(TINY(grid1(i, j))) n_rounded = n_rounded + 1 !CALL Pause() ELSE ! grid1(i, j) < 0.0D0 WRITE (*, *) WRITE (*, "(' In row ',I6,' and column ',I6,' the value is ',ES12.4,'.')") i, j, grid1(i, j) WRITE (*, "(' ERROR: Negative value(s) in seismicity-rate .grd file; illegal.' & & /' You should start over, and use mosaic type #2 for a linear plot.')") CALL Pause() STOP END IF END DO END DO IF (n_rounded > 0) THEN WRITE (*, *) WRITE (*, "(' CAUTION: ',I10,' zero (or very small) values were rounded up to TINY(grid1) = .',ES10.2)") n_rounded, TINY(grid1(1, 1)) CALL Pause() END IF 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 lat = MIN(MAX(lat, -90.0D0), 90.0D0) CALL DLonLat_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.0D0) CYCLE END IF CALL DProject (uvec = uvec, x = x_meters, y = y_meters) ! but no 'guide =' ELSE ! xy data grid x_meters = grd1_x_min + (jcol - 1) * grd1_d_x y_meters = grd1_y_max - (irow - 1) * grd1_d_y END IF ! lonlat, or simple xy CALL DMeters_2_Points (x_meters,y_meters, x_points,y_points) c1 = DIn_Window (x_points, y_points) visible = (c1 == 'I').OR.(c1 == 'B') ! Inside, or Border IF (visible) THEN k = k + 1 train(k) = grid1(irow,jcol) END IF ! visible END DO ! columns of gridded data END DO ! rows of gridded data CALL Histogram (train, k, .FALSE., maximum, minimum) DEALLOCATE ( train ) IF (ai_using_color) THEN IF (choice /= 10) THEN ! unknown units for values in grid1 CALL DPrompt_for_String('What are the units of these values?',TRIM(ADJUSTL(grid_units)),grid_units) bitmap_interpolation_mode = 1 ! linear interpolation will be used ELSE ! choice == 10 grid_units = "log(EC/m2/s)" ! limited to 12 bytes END IF 1022 WRITE (*,"(/' Should bitmap colors map be discontinuous or continuous?')") WRITE (*,"( ' mode 0: no interpolation; constant value in rectangle about grid point')") WRITE (*,"( ' mode 1: use linear interpolation between grid points')") WRITE (*,"( ' -------------------------------------------------------')") CALL DPrompt_for_Integer('Which interpolation mode?',bitmap_interpolation_mode,bitmap_interpolation_mode) IF ((bitmap_interpolation_mode < 0).OR.(bitmap_interpolation_mode > 1)) THEN WRITE (*,"(/' ERROR: Select mode index from list!' )") mt_flashby = .FALSE. GO TO 1022 END IF IF (bitmap_interpolation_mode == 0) THEN zero_as_white = .TRUE. CALL DPrompt_for_Logical('Shall rectangles with values of exactly 0 be left white?', zero_as_white, zero_as_white) ELSE zero_as_white = .FALSE. END IF 1023 WRITE (*,"(/' How shall the bitmap be colored?')") WRITE (*,"( ' mode 1: Munsell: smooth spectrum')") WRITE (*,"( ' mode 2: Kansas: 44-color scale of atlas-type colors')") WRITE (*,"( ' mode 3: UNAVCO: 20-color absolute scale (only for topography in m)')") WRITE (*,"( ' mode 4: AI: ',I2,'-color discrete scale, based on contour interval')") ai_spectrum_count WRITE (*,"( ' -------------------------------------------------------')") CALL DPrompt_for_Integer('Which coloring mode?',bitmap_color_mode,bitmap_color_mode) IF ((bitmap_color_mode < 1).OR.(bitmap_color_mode > 4)) THEN WRITE (*,"(/' ERROR: Select mode index from list!' )") mt_flashby = .FALSE. GO TO 1023 END IF IF (bitmap_color_mode <= 2) THEN ! need to pin down ends of spectrum CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) 1024 IF (grid_lowblue) THEN CALL DPrompt_for_Real('What (low?) value anchors the violet-blue end of the spectrum?',minimum,bitmap_color_lowvalue) CALL DPrompt_for_Real('What (high?) value anchors the red-pink end of the spectrum?',maximum,bitmap_color_highvalue) ELSE CALL DPrompt_for_Real('What (high?) value anchors the violet-blue end of the spectrum?',maximum,bitmap_color_lowvalue) CALL DPrompt_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 1024 END IF ! bad range ELSE IF (bitmap_color_mode == 3) THEN ! absolute UNAVCO color scale; no prompting; but must still define color range: bitmap_color_lowvalue = minimum bitmap_color_highvalue = maximum ELSE IF (bitmap_color_mode == 4) THEN IF (grid_interval == 0.0D0) THEN grid_interval = (maximum - minimum)/ai_spectrum_count grid_midvalue = (maximum + minimum)/2.D0 END IF 1025 CALL DPrompt_for_Real('What contour interval do you wish?',grid_interval,grid_interval) IF (grid_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") grid_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1025 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',grid_midvalue,grid_midvalue) CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) END IF ! bitmap_color_mode = 1,2 versus 4 ELSE ! .NOT. ai_using_color; provide grayscale bitmap! IF (bitmap_shading_mode == 1) THEN ! no color OR shaded relief; so, define the grayscale... WRITE (*, "(' Continuous-tone grayscale will be used.')") CALL DPrompt_for_Logical('Should dark-grey & black be used for high values?: ', .TRUE., black_is_high) IF (black_is_high) THEN bitmap_color_mode = 101 ELSE bitmap_color_mode = 102 END IF grid_units = "log(EC/m2/s)" ! limited to 12 bytes END IF 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 IF (grd2_lonlat) THEN 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 ELSE ! grd2 is in (x, y) units 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 END IF 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 DPrompt_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 DPress_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 (DABS(grd2_lon_max - grd2_lon_min - 360.0D0) < 0.01D0) THEN grd2_lon_range = 360.0D0 ELSE grd2_lon_range = DEasting(grd2_lon_max - grd2_lon_min) END IF READ (21, *, IOSTAT = ios) grd2_lat_min, grd2_d_lat, grd2_lat_max problem = problem .OR. (ios /= 0) grd2_ncols = 1 + NINT((grd2_lon_max - grd2_lon_min) / grd2_d_lon) grd2_nrows = 1 + NINT((grd2_lat_max - grd2_lat_min) / grd2_d_lat) ELSE ! (x,y) format READ (21, *, IOSTAT = ios) grd2_x_min, grd2_d_x, grd2_x_max problem = problem .OR. (ios /= 0) grd2_x_min = grd2_x_min * mt_meters_per_user grd2_d_x = grd2_d_x * mt_meters_per_user grd2_x_max = grd2_x_max * mt_meters_per_user READ (21, *, IOSTAT = ios) grd2_y_min, grd2_d_y, grd2_y_max problem = problem .OR. (ios /= 0) grd2_y_min = grd2_y_min * mt_meters_per_user grd2_d_y = grd2_d_y * mt_meters_per_user grd2_y_max = grd2_y_max * mt_meters_per_user grd2_ncols = 1 + NINT((grd2_x_max - grd2_x_min) / grd2_d_x) grd2_nrows = 1 + NINT((grd2_y_max - grd2_y_min) / grd2_d_y) END IF problem = problem .OR. (grd2_nrows < 2) .OR. (grd2_ncols < 2) train_length = grd2_nrows * grd2_ncols ALLOCATE ( grid2(grd2_nrows, grd2_ncols) ) READ (21, *, IOSTAT = ios) ((grid2(i,j), j = 1, grd2_ncols), i = 1, grd2_nrows) problem = problem .OR. (ios /= 0) CLOSE (21) IF (problem) THEN WRITE (*,"(' ERROR: ',A' defective in structure or truncated.')") TRIM(grd2_file) CALL DPress_Enter DEALLOCATE ( grid2 ) mt_flashby = .FALSE. GO TO 1021 END IF ! problem with grd2 END IF ! bitmap_shading_mode 1 or 2 CALL DPrompt_for_Real('Relative intensity of oblique lighting?', intensity, intensity) ! find RMS E-W slope IF (grd2_lonlat) THEN grd2_d_EW = grd2_d_lon ELSE grd2_d_EW = grd2_d_x END IF sum = 0.0D0 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 = DSQRT(sum / train_length) IF (RMS_slope == 0.0D0) RMS_slope = 1.0D0 ! prevent /0.0 END IF ! shaded_relief bitmap_width = ai_window_x2_points - ai_window_x1_points ! suggest one column/point bitmap_height = ai_window_y2_points - ai_window_y1_points ! suggest one row/point 1026 CALL DPrompt_for_Integer('How many columns of pixels in bitmap?',bitmap_width,bitmap_width) IF (bitmap_width < 2) THEN WRITE (*,"(' ERROR: Bitmap_width must be >= 2')") mt_flashby = .FALSE. GO TO 1026 END IF 1027 CALL DPrompt_for_Integer('How many rows of pixels in bitmap?',bitmap_height,bitmap_height) IF (bitmap_height < 2) THEN WRITE (*,"(' ERROR: Bitmap_height must be >= 2')") mt_flashby = .FALSE. GO TO 1027 END IF WRITE (*,"(/' Working on bitmap from gridded dataset(s)....')") ALLOCATE ( bitmap(bitmap_height,bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) !Get "value" (basis for color of pixel) from grid1: !Note: Even if .NOT.ai_using_color, we will need i1, i2, j1, j2, etc. IF (bitmap_shading_mode == 1) IF (ai_using_color.OR.(bitmap_shading_mode == 1)) THEN IF (grd1_lonlat) THEN ! must undo map projection CALL DReject (x_meters,y_meters, success, uvec) IF (success) THEN ! rejection worked CALL DUvec_2_LonLat (uvec, lon, lat) !define grd1_success as falling within grid1, using looser test if bitmap_interpolation_mode == 0: IF (bitmap_interpolation_mode == 0) THEN grd1_success = (lat >= (grd1_lat_min - 0.5D0 * grd1_d_lat)).AND. & & (lat <= (grd1_lat_max + 0.5D0 * grd1_d_lat)).AND. & & (DEasting(lon - (grd1_lon_min - 0.5D0 * grd1_d_lon)) <= (grd1_lon_range + grd1_d_lon)) !note: insensitive to longitude cycle ELSE IF (bitmap_interpolation_mode == 1) THEN grd1_success = (lat >= grd1_lat_min).AND. & & (lat <= grd1_lat_max).AND. & & (DEasting(lon - grd1_lon_min) <= grd1_lon_range) !note: insensitive to longitude cycle END IF IF (grd1_success) THEN IF (bitmap_interpolation_mode == 0) THEN ! use nearest grid value i = NINT(1 + (grd1_lat_max - lat) / grd1_d_lat) i = MAX (i, 1) i = MIN (i, grd1_nrows) j = NINT(0.5D0 + DEasting(lon - (grd1_lon_min - 0.5001D0 * grd1_d_lon)) / grd1_d_lon) j = MAX (j, 1) j = MIN (j, grd1_ncols) value = grid1(i,j) ELSE IF (bitmap_interpolation_mode == 1) THEN ! linear interpolation i1 = 1 + (grd1_lat_max - lat) / grd1_d_lat i1 = MAX(1,MIN(i1,grd1_nrows-1)) i2 = i1 + 1 fy2 = ((grd1_lat_max - lat) / grd1_d_lat) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + DEasting(lon - grd1_lon_min) / grd1_d_lon j1 = MAX(1,MIN(j1,grd1_ncols-1)) j2 = j1 + 1 fx2 = (DEasting(lon - grd1_lon_min) / grd1_d_lon) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 above = fx1 * grid1(i1,j1) + fx2 * grid1(i1,j2) below = fx1 * grid1(i2,j1) + fx2 * grid1(i2,j2) value = fy1 * above + fy2 * below END IF ELSE ! point fell outside grid1 grd1_success = .FALSE. value = 0.0D0 ! should not be used END IF ! point inside lon/lat grid1, or not ELSE ! rejection failed (i.e., back side of Earth in Orthographic projection) grd1_success = .FALSE. value = 0.0D0 ! should not be used 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.00D0 - fy2 j1 = 1 + (x_meters - grd1_x_min) / grd1_d_x j1 = MAX(1,MIN(j1,grd1_ncols-1)) j2 = j1 + 1 fx2 = ((x_meters - grd1_x_min) / grd1_d_x) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 above = fx1 * grid1(i1,j1) + fx2 * grid1(i1,j2) below = fx1 * grid1(i2,j1) + fx2 * grid1(i2,j2) value = fy1 * above + fy2 * below END IF ! point within x/y grid1 END IF ! need to undo map projection or not for grid1 ELSE ! neither ai_using_color, nor (bitmap_shading_mode == 1) grd1_success = .FALSE. value = 0.0D0 ! should not be used END IF ! finding i1, i2, j1, j2,,, value in grid1, or not !Finished getting "value" and i1, i2, j1, j2, ... (if possible) !Get "brightness" (basis for brightness of pixel) from grid2??? IF (shaded_relief) THEN IF (bitmap_shading_mode == 1) THEN grd2_success = grd1_success !and fx2, fy2, i1, i2, ... will be reused ELSE ! must find place in grid2! !must recompute fx1, fx2, fy1, fy2, i1, i2, j1, j2 for different grid IF (grd2_lonlat) THEN IF (success) THEN ! lon, lat still valid !define grd2_success as falling within grid2 grd2_success = (lat >= grd2_lat_min).AND. & & (lat <= grd2_lat_max).AND. & & (DEasting(lon - grd2_lon_min) <= grd2_lon_range) !note: insensitive to longitude cycle IF (grd2_success) THEN i1 = 1 + (grd2_lat_max - lat) / grd2_d_lat i1 = MAX(1,MIN(i1,grd2_nrows-1)) i2 = i1 + 1 fy2 = ((grd2_lat_max - lat) / grd2_d_lat) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + DEasting(lon - grd2_lon_min) / grd2_d_lon j1 = MAX(1,MIN(j1,grd2_ncols-1)) j2 = j1 + 1 fx2 = (DEasting(lon - grd2_lon_min) / grd2_d_lon) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 END IF ! point in grid2 ELSE ! Rejection failed; lon, lat undefined grd2_success = .FALSE. END IF ! successful Rejection or not ELSE ! .NOT.grd2_lonlat; grid2 is x,y grd2_success = (x_meters >= grd2_x_min).AND. & & (x_meters <= grd2_x_max).AND. & & (y_meters >= grd2_y_min).AND. & & (y_meters <= grd2_y_max) IF (grd2_success) THEN i1 = 1 + (grd2_y_max - y_meters) / grd2_d_y i1 = MAX(1,MIN(i1,grd2_nrows-1)) i2 = i1 + 1 fy2 = ((grd2_y_max - y_meters) / grd2_d_y) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + (x_meters - grd2_x_min) / grd2_d_x j1 = MAX(1,MIN(j1,grd2_ncols-1)) j2 = j1 + 1 fx2 = ((x_meters - grd2_x_min) / grd2_d_x) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 END IF ! point within x/y grid2 END IF ! grd2_lonlat, or not END IF ! shaded relief grid2 has different framework IF (grd2_success) THEN ! can compute brightness !Compute E-W slope in a way that gives a !result that is piecewise-linear in the E-W direction: fout = ABS(fx2 - 0.5D0) ! fraction for adjacent cell fin = 1.00D0 - fout ! fraction for the cell we're in inner = (grid2(i1,j2) - grid2(i1,j1)) / grd2_d_EW IF (fx2 > 0.5D0) THEN IF (j2 < grd2_ncols) THEN ! normal case outer = (grid2(i1,j2+1) - grid2(i1,j1+1)) / grd2_d_EW ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case outer = (grid2(i1,j2-1) - grid2(i1,j1-1)) / grd2_d_EW ELSE ! at left edge of grid outer = inner END IF END IF above = fin * inner + fout * outer !Repeat for row below the point: inner = (grid2(i2,j2) - grid2(i2,j1)) / grd2_d_EW IF (fx2 > 0.5D0) THEN IF (j2 < grd2_ncols) THEN ! normal case outer = (grid2(i2,j2+1) - grid2(i2,j1+1)) / grd2_d_EW ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case outer = (grid2(i2,j2-1) - grid2(i2,j1-1)) / grd2_d_EW ELSE ! at left edge of grid outer = inner END IF END IF below = fin * inner + fout * outer !Line below makes slope piecewise-linear in N-S direction: slope = fy1 * above + fy2 * below brightness = 1.0D0 + 0.5D0 * intensity * slope / RMS_slope brightness = MAX(0.0D0, MIN(2.0D0, brightness)) ELSE ! .NOT. dot2_success; so, point was not in grid2 brightness = 1.0D0 END IF ! point was in grid2 or not ELSE ! no shaded relief wanted brightness = 1.0D0 END IF ! shaded relief, or not !End of lookup (value and brightness); now use them! IF (ai_using_color.AND.grd1_success) THEN ! have "value" IF (zero_as_white.AND.(value == 0.0)) THEN c3 = CHAR(255)//CHAR(255)//CHAR(255) ELSE ! normal coloring case IF (bitmap_color_mode == 1) THEN ! Munsell: smooth spectrum t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Munsell(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 2) THEN ! Kansas: 44-color atlas-type scale t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = DRGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = DRGB_AI(value = value, contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, low_is_blue = grid_lowblue, & & brightness = brightness) END IF ! bitmap_color_mode selection END IF ! special 0 = white case, or normal case? bitmap(irow,jcol) = c3 ELSE IF (grd1_success) THEN ! .NOT.ai_using_color; but we have the "value" IF (black_is_high) THEN k = NINT(255.D0 - (255.D0 * (value - minimum) / (maximum - minimum))) ELSE ! white is high k = NINT(255.D0 * (value - minimum) / (maximum - minimum)) END IF k = MAX(0,MIN(255,k)) bitmap(irow,jcol) = CHAR(k)//CHAR(k)//CHAR(k) ELSE IF (grd2_success) THEN ! b/w; gray depends only on slope k = brightness * 127.5D0 k = MAX(0,MIN(255,k)) bitmap(irow,jcol) = CHAR(k)//CHAR(k)//CHAR(k) ELSE ! fill in with background IF (ai_black_background) THEN ! slide copy bitmap(irow,jcol) = CHAR(0)//CHAR(0)//CHAR(0) ELSE ! white background (paper print) bitmap(irow,jcol) = CHAR(255)//CHAR(255)//CHAR(255) END IF END IF ! color, grey-scale, or background END DO ! jcol, left to right WRITE (*,"('+Working on bitmap from gridded dataset(s)....',I6,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Working on bitmap from gridded dataset(s)....Writing to .ai ')") CALL DBitmap_on_L1 (bitmap, ai_window_x1_points, ai_window_x2_points, & & ai_window_y1_points, ai_window_y2_points) IF (choice == 10) THEN ! log(seismicity) plot: add floating box with integral value CALL DBegin_Group() CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color("foreground") CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = "background") CALL DNew_L12_Path(level = 1, x_points = ai_window_x1_points, y_points = ai_window_y1_points) CALL DLine_to_L12(x_points = ai_window_x1_points + 232., y_points = ai_window_y1_points) CALL DLine_to_L12(x_points = ai_window_x1_points + 232., y_points = ai_window_y1_points + 20.) CALL DLine_to_L12(x_points = ai_window_x1_points, y_points = ai_window_y1_points + 20.) CALL DLine_to_L12(x_points = ai_window_x1_points, y_points = ai_window_y1_points) CALL DEnd_L12_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) WRITE (c9, "(ES9.2)") EQs_per_century CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = "foreground") CALL DL12_Text (level = 1, & & x_points = ai_window_x1_points + 12.D0, y_points = ai_window_y1_points + 6.D0, & & angle_radians = 0.0D0, & & font_points = 12, lr_fraction = 0.D0, ud_fraction = 0.D0, & & text = "Integral: " // c9 // " epicentroids/century") CALL DEnd_Group() END IF ! floating box with integral of seismicity IF (ai_using_color.OR.(bitmap_shading_mode == 1)) THEN ! also plot a "color"-bar for continuous gray-scale maps (bitmap_color_mode = 101 or 102) CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! ai_using_color --> want spectrum in legend WRITE (*,"('+Working on bitmap from gridded dataset(s)....DONE. ')") CALL BEEPQQ (440, 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 DPrompt_for_String('Which file should be contoured?',grd1_file,grd1_file) grd1_pathfile = TRIM(temp_path_in)//TRIM(grd1_file) OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') 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 = (DABS(grd1_lat_min)<91.D0).AND.(DABS(grd1_lat_max)<91.D0) CALL DPrompt_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 DPress_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 DPress_Enter DEALLOCATE (grid1, train) mt_flashby = .FALSE. GO TO 1030 END IF !Alert the user about possible excessive .AI file size if a file like ETOPO5.grd is contoured! IF ((grd1_ncols * grd1_nrows) > 2332800) THEN ! N.B. This selected number is 1/4 the size of ETOPO5.grd; perhaps should be smaller? WRITE (*, *) WRITE (*, "(' WARNING:')") WRITE (*, "(' You requested a contour-map of a grid with ',I8,' rows and ',I8,' columns.')") grd1_nrows, grd1_ncols WRITE (*, "(' Execution time is likely to be very long.')") WRITE (*, "(' Also, the resulting .AI file might be too large to open.')") WRITE (*, "(' YOU ARE ADVISED TO START OVER, and select mosaic type 2 (BITMAP) instead.')") WRITE (*, "(' (However, you can ignore this warning and proceed, if you wish.)')") CALL DPrompt_for_Logical('Do you still wish to attempt this very large contour-map?', .FALSE., bull_on) IF (.NOT.bull_on) STOP END IF CALL Add_Title(grd1_file) WRITE (*,"(/' Here is the distribution of gridded values:' )") k = 0 DO i = 1, grd1_nrows DO j = 1, grd1_ncols k = k + 1 train(k) = grid1(i,j) END DO END DO CALL Histogram (train, train_length, .FALSE., maximum, minimum) CALL DPrompt_for_String('What are the units of these values?',TRIM(ADJUSTL(grid_units)),grid_units) IF (grid_interval == 0.0) THEN grid_interval = (maximum - minimum)/ai_spectrum_count grid_midvalue = (maximum + minimum)/2. END IF 1031 CALL DPrompt_for_Real('What contour interval do you wish?',grid_interval,grid_interval) IF (grid_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") grid_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1031 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',grid_midvalue,grid_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',grid_lowblue,grid_lowblue) END IF WRITE (*,"(/' If the data is elevation/bathymetry, and you plan to plot the coastline')") WRITE (*,"(' as a separate map element, the zero contour may be redundant (& less accurate)!')") CALL DPrompt_for_Logical('Should the 0 contour line be omitted?',skip_0_contour,skip_0_contour) WRITE (*,"(/' Working on gridded data....')") DO group = 1, 2 IF (group == 2) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) !note that contouring routine will set line colors CALL DBegin_Group IF (grd1_lonlat) THEN DO i = 1, grd1_nrows-1 DO j = 1, grd1_ncols-1 ! NW triangle: lon1 = grd1_lon_min + (j-1)*grd1_d_lon lat1 = grd1_lat_max - (i-1)*grd1_d_lat lat1 = MIN(MAX(lat1, -90.0D0), 90.0D0) CALL DLonLat_2_Uvec(lon1, lat1, uvec1) lon2 = lon1 lat2 = lat1 - grd1_d_lat lat2 = MIN(MAX(lat2, -90.0D0), 90.0D0) CALL DLonLat_2_Uvec(lon2, lat2, uvec2) lon3 = lon2 + grd1_d_lon lat3 = lat1 CALL DLonLat_2_Uvec(lon3, lat3, uvec3) !Skip triangles with two nodes at +90N, !since they have zero area: IF ((lat1 < 90.0D0).OR.(lat3 < 90.0D0)) THEN CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = grid1(i,j), & & f2 = grid1(i+1,j), & & f3 = grid1(i,j+1), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) 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 DLonLat_2_Uvec(lon1, lat1, uvec1) !Skip triangles with two nodes at -90N, !since they have zero area: IF ((lat1 > -90.0D0).OR.(lat3 > -90.0D0)) THEN CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = grid1(i+1,j+1), & & f2 = grid1(i,j+1), & & f3 = grid1(i+1,j), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) END 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 DContour_3Node_Scalar_in_Plane & &(x1 = t*(grd1_x_min+grd1_d_x*(j-1)), & & y1 = t*(grd1_y_max-grd1_d_y*(i-1)), & & x2 = t*(grd1_x_min+grd1_d_x*(j-1)), & & y2 = t*(grd1_y_max-grd1_d_y*(i)), & & x3 = t*(grd1_x_min+grd1_d_x*(j)), & & y3 = t*(grd1_y_max-grd1_d_y*(i-1)), & & f1 = grid1(i,j), & & f2 = grid1(i+1,j), & & f3 = grid1(i,j+1), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) ! lower right triangle CALL DContour_3Node_Scalar_in_Plane & &(x1 = t*(grd1_x_min+grd1_d_x*(j)), & & y1 = t*(grd1_y_max-grd1_d_y*(i)), & & x2 = t*(grd1_x_min+grd1_d_x*(j)), & & y2 = t*(grd1_y_max-grd1_d_y*(i-1)), & & x3 = t*(grd1_x_min+grd1_d_x*(j-1)), & & y3 = t*(grd1_y_max-grd1_d_y*(i)), & & f1 = grid1(i+1,j+1), & & f2 = grid1(i,j+1), & & f3 = grid1(i+1,j), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) END DO ! j=1, ncols-1 END DO ! i = 1, nrows-1 END IF ! lonlat, or (x,y) CALL DEnd_Group ! END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value =grid_midvalue, & & low_is_blue = grid_lowblue, & & units = ADJUSTL(grid_units)) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value =grid_midvalue, & & low_is_blue = grid_lowblue, & & units = ADJUSTL(grid_units)) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on gridded data....DONE.')") CALL BEEPQQ (440, 250) DEALLOCATE ( grid1 ) DEALLOCATE ( train ) ! end of contour map from gridded data CASE (4) ! discontinuous scalar (one value per element, if any) CALL DGroup_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 DPrompt_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 DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( 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 DPress_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 DPrompt_for_String('What are the units of these numbers?',element_scalar_units,element_scalar_units) IF (element_scalar_method == 1) THEN ! group of colored/shaded polygons IF (element_scalar_interval == 0.0D0) THEN element_scalar_interval = (maximum - minimum)/ai_spectrum_count element_scalar_midvalue = (maximum + minimum)/2.D0 END IF 1041 CALL DPrompt_for_Real('What contour interval do you wish?',element_scalar_interval,element_scalar_interval) IF (element_scalar_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") element_scalar_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1041 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',element_scalar_midvalue,element_scalar_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',element_scalar_lowblue,element_scalar_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',element_scalar_lowblue,element_scalar_lowblue) END IF WRITE (*,*) WRITE (*,"(' Non-zero values that lie exactly on a contour')") WRITE (*,"(' (color boundary) are always nudged toward zero')") WRITE (*,"(' in order to assign a color to them.')") WRITE (*,"(' -----------------------------------------------')") WRITE (*,"(' What shall be done with zero values?')") WRITE (*,"(' mode 1 :: round up to the 1st positive color')") WRITE (*,"(' mode 0 :: do not plot this triangle')") WRITE (*,"(' mode -1 :: round down to the 1st negative color')") WRITE (*,"(' ------------------------------------------------')") 1042 CALL DPrompt_for_Integer('Which mode do you want?',element_scalar_zeromode,element_scalar_zeromode) IF ((element_scalar_zeromode < -1).OR.(element_scalar_zeromode > 1)) THEN WRITE (*,"(' ERROR: Select mode in legal range.')") element_scalar_zeromode = 0 mt_flashby = .FALSE. GO TO 1042 END IF WRITE (*,"(/' Working on discontinuous scalar (one value per element)....')") CALL DBegin_Group ! of colored/shaded triangles (there won't be any contours) DO i = 1, numel t = element_scalar(i) IF (t == 0.0D0) THEN SELECT CASE (element_scalar_zeromode) CASE (1) ! round up t = 0.001D0 * element_scalar_interval plot_this = .TRUE. CASE (0) ! do not plot plot_this = .FALSE. CASE (-1) ! round down t = -0.001D0 * element_scalar_interval plot_this = .TRUE. END SELECT ELSE ! non-zero value plot_this = .TRUE. IF (DMOD(t, element_scalar_interval) == 0.0D0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0D0) THEN t = t - 0.001D0* element_scalar_interval ELSE ! t < 0.0 t = t + 0.001D0 * element_scalar_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) END IF ! zero or non-zero value 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 DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = element_scalar_interval, & & midspectrum_value = element_scalar_midvalue, & & low_is_blue = element_scalar_lowblue, group = 1) END IF ! plot_this END DO ! i = 1, numel CALL DEnd_Group ! of colored/shaded triangles CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = element_scalar_interval, & & midspectrum_value =element_scalar_midvalue, & & low_is_blue = element_scalar_lowblue, & & units = element_scalar_units) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = element_scalar_interval, & & midspectrum_value =element_scalar_midvalue, & & low_is_blue = element_scalar_lowblue, & & units = element_scalar_units) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on discontinuous scalar (one value per element)....DONE.')") ELSE ! element_scalar_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN bitmap_value(irow,jcol) = element_scalar(iele) bitmap_success(irow,jcol) = .TRUE. ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & element_scalar_units, minimum, maximum, & & bitmap_color_mode, element_scalar_interval, element_scalar_midvalue, element_scalar_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, element_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & element_scalar_interval, element_scalar_midvalue, element_scalar_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, element_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & element_scalar_interval, element_scalar_midvalue, element_scalar_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! element_scalar_method = 1 or 2 DEALLOCATE ( element_scalar, & & nodes ) ! in LIFO order DEALLOCATE ( node_uvec ) CALL BEEPQQ (440, 250) ! end of discontinuous scalar (one value per element) CASE (5) ! nodal data (if any) CALL DGroup_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 DPrompt_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 column of extra nodal variables (following [lon, lat]) should be plotted?')") WRITE (*,"(' 1 = mu_ (?)')") WRITE (*,"(' 2 = {user data or future NeoKinema extension}')") WRITE (*,"(' 3 = {user data or future NeoKinema extension}')") WRITE (*,"(' 4 = {user data or future NeoKinema extension}')") node_scalar_limit = 4 WRITE (*,"(' -------------------------------------------------')") CALL DPrompt_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 DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL DPress_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 DPrompt_for_String('What are the units of these numbers?',node_scalar_units,node_scalar_units) IF (node_scalar_method == 1) THEN ! group of colored/shaded polygons IF (node_scalar_interval == 0.0D0) THEN node_scalar_interval = (maximum - minimum)/ai_spectrum_count node_scalar_midvalue = (maximum + minimum)/2.D0 END IF 1052 CALL DPrompt_for_Real('What contour interval do you wish?',node_scalar_interval,node_scalar_interval) IF (node_scalar_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") node_scalar_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1052 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',node_scalar_midvalue,node_scalar_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',node_scalar_lowblue,node_scalar_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',node_scalar_lowblue,node_scalar_lowblue) END IF WRITE (*,"(/' Working on nodal data....')") DO group = 1, 2 CALL DBegin_Group IF (group == 2) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) !note that contouring routine will set line colors DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = node_scalar(nodes(1,i)), & & f2 = node_scalar(nodes(2,i)), & & f3 = node_scalar(nodes(3,i)), & & low_value = minimum, high_value = maximum, & & contour_interval = node_scalar_interval, & & midspectrum_value = node_scalar_midvalue, & & low_is_blue = node_scalar_lowblue, group = group) END DO ! i = 1, numel CALL DEnd_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = node_scalar_interval, & & midspectrum_value =node_scalar_midvalue, & & low_is_blue = node_scalar_lowblue, & & units = node_scalar_units) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = node_scalar_interval, & & midspectrum_value =node_scalar_midvalue, & & low_is_blue = node_scalar_lowblue, & & units = node_scalar_units) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on continuous scalar (one value per node)....DONE.')") ELSE ! node_scalar_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN 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.0D0) ! 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 DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & node_scalar_units, minimum, maximum, & & bitmap_color_mode, node_scalar_interval, node_scalar_midvalue, node_scalar_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, node_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & node_scalar_interval, node_scalar_midvalue, node_scalar_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, node_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & node_scalar_interval, node_scalar_midvalue, node_scalar_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! node_scalar_method = 1 or 2 DEALLOCATE ( nodes ) ! in LIFO order DEALLOCATE ( node_scalar ) DEALLOCATE ( node_uvec ) CALL BEEPQQ (440, 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 DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21,*) numel ALLOCATE ( nodes(3,numel) ) 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 DPrompt_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 DGroup_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 DPrompt_for_Integer('How many columns of pixels in bitmap?',bitmap_width,bitmap_width) IF (bitmap_width < 2) THEN WRITE (*,"(' ERROR: Bitmap_width must be >= 2')") GOTO 1061 END IF 1062 CALL DPrompt_for_Integer('How many rows of pixels in bitmap?',bitmap_height,bitmap_height) IF (bitmap_height < 2) THEN WRITE (*,"(' ERROR: Bitmap_height must be >= 2')") GOTO 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.0D0 * sec_per_year) CALL DLonLat_2_Uvec (lon1, lat1, uvec) cracks(i)%uvec1(1:3) = uvec(1:3) CALL DLonLat_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 DPrompt_for_Logical('Do you wish to CHANGE the velocity reference frame?',velocity_reframe,velocity_reframe) IF (velocity_reframe) THEN 1063 CALL DPrompt_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 DPrompt_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.D0 * sec_per_year * DSQRT(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.0D0) THEN velocity_interval = (maximum - minimum)/ai_spectrum_count velocity_midvalue = (maximum + minimum)/2.D0 END IF 1065 CALL DPrompt_for_Real('What contour interval do you wish?',velocity_interval,velocity_interval) IF (velocity_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") velocity_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1065 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',velocity_midvalue,velocity_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should slow areas be colored blue (versus red)?',velocity_lowblue,velocity_lowblue) ELSE CALL DPrompt_for_Logical('Should slow areas be shaded darkly (versus lightly)?',velocity_lowblue,velocity_lowblue) END IF WRITE (*,"(/' Working on magnitude of velocity....')") DO group = 1, 2 CALL DBegin_Group ! of colored/shaded spherical triangles IF (group == 2) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) !note that contouring routine will set line colors DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) IF ((.NOT.cracking(i)).OR.(cracked_element_method == 1)) THEN ! display this element v1S_mma = 1000.D0 * sec_per_year * vw(2*nodes(1,i)-1) v2S_mma = 1000.D0 * sec_per_year * vw(2*nodes(2,i)-1) v3S_mma = 1000.D0 * sec_per_year * vw(2*nodes(3,i)-1) v1E_mma = 1000.D0 * sec_per_year * vw(2*nodes(1,i)) v2E_mma = 1000.D0 * sec_per_year * vw(2*nodes(2,i)) v3E_mma = 1000.D0 * sec_per_year * vw(2*nodes(3,i)) CALL DContour_3Node_Sphere_Velocity( & & uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & v1t = v1S_mma, v1p = V1E_mma, & & v2t = v2S_mma, v2p = V2E_mma, & & v3t = v3S_mma, v3p = V3E_mma, & & low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value = velocity_midvalue, & & low_is_blue = velocity_lowblue, group = group) ELSE ! element is cracking, and cracked_element_method == 0; gray-out this element IF (group == 1) THEN CALL DSet_Fill_or_Pattern (.FALSE., "gray______") CALL DNew_L45_Path(5, uvec1) CALL DGreat_to_L45(uvec2) CALL DGreat_to_L45(uvec3) CALL DGreat_to_L45(uvec1) CALL DEnd_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 DEnd_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value = velocity_midvalue, & & low_is_blue = velocity_lowblue, & & units = 'mm/a') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value =velocity_midvalue, & & low_is_blue = velocity_lowblue, & & units = 'mm/a') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on magnitude of velocity....DONE.')") ELSE ! velocity_method == 2; create bitmap ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN 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 DVelocity_Size_in_3Node_Sphere & & (iele, uvec1, uvec2, uvec3, & ! element input & v1S,v1E, v2S,v2E, v3S,v3E, & ! nodal velocities & uvec, & ! position input & vsize, d_vsize_d_theta, d_vsize_d_phi) ! outputs t = vsize * 1000.D0 * 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 DCross(result_uvec, uvec, tvec) CALL DMake_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 DCross(turn_1_uvec, turn_2_uvec, tvec) CALL DMake_Uvec(tvec, pole_b_uvec) CALL DCircles_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 DLocal_Theta(cross_uvec, theta_uvec) CALL DLocal_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 DMake_Uvec(tvec, strike_uvec) !make strike_uvec point to the right, as seen from arc beginning at result_uvec: IF (DDot(pole_a_uvec, strike_uvec) > 0.0D0) 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 (DArc(turn_1_uvec, cross_uvec) > DArc(turn_2_uvec, cross_uvec)) THEN strike_azimuth = DRelative_Compass(from_uvec = cross_uvec, to_uvec = turn_1_uvec) ELSE strike_azimuth = DRelative_Compass(from_uvec = cross_uvec, to_uvec = turn_2_uvec) END IF dip_azimuth = strike_azimuth + Pi_over_2 orthogonal_uvec(1:3) = -DCOS(dip_azimuth) * theta_uvec(1:3) + & & DSIN(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 (DDot(orthogonal_uvec, tvec) < 0.0D0) 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 DTraceback END IF !convert tvec (velocity change) to horizontal components, and add: v_South_mps = v_South_mps + DDot(tvec, theta_uvec) v_East_mps = v_East_mps + DDot(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) = DSQRT(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 = DABS(vsize_estimates(1) - vsize_estimates(2)) d23 = DABS(vsize_estimates(2) - vsize_estimates(3)) d31 = DABS(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.0D0 ELSE IF ((d23 < d31).AND.(d23 < d12)) THEN ! d23 is the smallest difference vsize = (vsize_estimates(2) + vsize_estimates(3)) / 2.0D0 ELSE ! d31 is the smallest difference vsize = (vsize_estimates(3) + vsize_estimates(1)) / 2.0D0 END IF !================== end experimental algorithm (with assignment of vsize = ? m/s) ======= t = vsize * 1000.D0 * 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 DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & 'mm/a', minimum, maximum, & & bitmap_color_mode, velocity_interval, velocity_midvalue, velocity_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order IF (cracked_element_method == 0) THEN ! overlay some gray triangles: CALL DBegin_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 DSet_Fill_or_Pattern (.FALSE., "gray______") CALL DNew_L45_Path(5, uvec1) CALL DGreat_to_L45(uvec2) CALL DGreat_to_L45(uvec3) CALL DGreat_to_L45(uvec1) CALL DEnd_L45_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) END IF ! cracking(iele) END DO ! iele = 1, num_ele CALL DEnd_Group END IF ! some gray triangles (might be) needed CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! velocity_method = 1 or 2 CALL BEEPQQ (440, 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 CALL DGroup_or_Bitmap (latter_mosaic, strainrate_mosaic_method, bitmap_height, bitmap_width) ! method = polygons or bitmap 1070 WRITE (*, *) WRITE (*, "(' ------------------------------------------------------------------')") WRITE (*, "(' Choose color-scale mode, and units for strain-rates:')") WRITE (*, "(' 1 = logarithmic color scale; SI units of /s')") WRITE (*, "(' 2 = logarithmic color scale; popular units of nanostrains/year')") WRITE (*, "(' 3 = linear color scale; SI units of /s')") WRITE (*, "(' 4 = linear color scale; popular units of nanostrains/year')") WRITE (*, "(' ------------------------------------------------------------------')") CALL DPrompt_for_Integer('Strainrate mosaic mode:', strainrate_mosaic_mode, strainrate_mosaic_mode) IF ((strainrate_mosaic_mode < 1).OR.(strainrate_mosaic_mode > 4)) THEN WRITE (*, "(' ERROR: Illegal selection. Please choose an integer from 1 to 4...')") CALL Pause() GO TO 1070 END IF IF (choice == 7) THEN IF (strainrate_mosaic_mode == 1) THEN CALL Add_Title('Total Strain-Rate, including Faulting: log10 of greatest principal rate, in /s') ELSE IF (strainrate_mosaic_mode == 2) THEN CALL Add_Title('Total Strain-Rate, including Faulting: log10 of greatest principal rate, in nanostrains/year') ELSE IF (strainrate_mosaic_mode == 3) THEN CALL Add_Title('Total Strain-Rate, including Faulting: greatest (absolute value) principal rate, in /s') ELSE IF (strainrate_mosaic_mode == 4) THEN CALL Add_Title('Total Strain-Rate, including Faulting: greatest (absolute value) principal rate, in nanostrains/year') END IF ELSE IF (choice == 12) THEN IF (strainrate_mosaic_mode == 1) THEN CALL Add_Title('Short-Term Interseismic Strain-Rate: log10 of greatest principal rate, in /s') ELSE IF (strainrate_mosaic_mode == 2) THEN CALL Add_Title('Short-Term Interseismic Strain-Rate: log10 of greatest principal rate, in nanostrains/year') ELSE IF (strainrate_mosaic_mode == 3) THEN CALL Add_Title('Short-Term Interseismic Strain-Rate: greatest (absolute value) principal rate, in /s') ELSE IF (strainrate_mosaic_mode == 4) THEN CALL Add_Title('Short-Term Interseismic Strain-Rate: greatest (absolute value) principal rate, in nanostrains/year') END IF END IF IF (.NOT.got_parameters) CALL Get_Parameters 1071 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 DPrompt_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 DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 1071 END IF READ (21, *) nfl IF (nfl > 0) CALL No_Fault_Elements_Allowed() CLOSE (21) CALL Add_Title(feg_file) 1072 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 DPrompt_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 DPress_Enter mt_flashby = .FALSE. got_parameters = .FALSE. GO TO 1072 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 ( graphic_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 DMake_Uvec (uvec4, uvec) ! center of element equat = DSQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.0D0) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF theta_ = DATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) !convert to scalar measure, for histogram CALL DPrincipal_Axes_22 (eps_dot(1),eps_dot(2),eps_dot(3), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) err = -(e1h + e2h) largest_ei_persec = MAX(DABS(e1h), DABS(e2h), DABS(err)) IF (strainrate_mosaic_mode <= 2) THEN ! log scale IF (largest_ei_persec == 0.0D0) THEN graphic_largest_ei_persec(l_) = -60.0D0 ! arbitrary substitute for -infinity! ELSE IF (strainrate_mosaic_mode == 1) THEN ! /s units graphic_largest_ei_persec(l_) = DLOG10(largest_ei_persec) ELSE ! nanostrains/year graphic_largest_ei_persec(l_) = DLOG10(largest_ei_persec * 1.0D9 * sec_per_year) END IF END IF ELSE ! linear scale IF (strainrate_mosaic_mode == 3) THEN ! /s units graphic_largest_ei_persec(l_) = largest_ei_persec ELSE ! nanostrains/year graphic_largest_ei_persec(l_) = largest_ei_persec * 1.0D9 * sec_per_year END IF END IF !(not using loop on m = 1,...,7 since values almost identical) END DO ! l_ = 1, numel, computing strainrates and scalar measure IF (strainrate_mosaic_mode <= 2) THEN ! log scale IF (strainrate_mosaic_mode == 1) THEN ! /s units WRITE (*,"(/' Here is the distribution of common logs of largest (absolute value)' & & /' principal strain-rates (LOG10(MAX(ABS(Ei * 1 s)))) for each element:')") ELSE ! nanostrains/year WRITE (*,"(/' Here is the distribution of common logs of largest (absolute value) principal' & & /' strain-rates (LOG10(MAX(ABS(Ei * 1 year/nanostrain)))) for each element:')") END IF ELSE ! linear scale IF (strainrate_mosaic_mode == 3) THEN ! /s units WRITE (*,"(/' Here is the distribution of largest (absolute value)' & & /' principal strain-rates (MAX(ABS(Ei))), in /s, for each element:')") ELSE ! nanostrains/year WRITE (*,"(/' Here is the distribution of largest (absolute value) principal' & & /' strain-rates (MAX(ABS(Ei))), in nanostrains/year, for each element:')") END IF END IF CALL Histogram (graphic_largest_ei_persec, numel, .FALSE., maximum, minimum) IF (strainrate_mosaic_method == 1) THEN ! group of colored/shaded polygons IF (strainrate_mosaic_interval == 0.0D0) THEN strainrate_mosaic_interval = (maximum - minimum) / ai_spectrum_count strainrate_mosaic_midvalue = (maximum + minimum) / 2.D0 END IF 1073 CALL DPrompt_for_Real('What contour interval do you wish?', strainrate_mosaic_interval, strainrate_mosaic_interval) IF (strainrate_mosaic_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") strainrate_mosaic_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1073 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?', strainrate_mosaic_midvalue, strainrate_mosaic_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',log_strainrate_lowblue,log_strainrate_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',log_strainrate_lowblue,log_strainrate_lowblue) END IF IF (strainrate_mosaic_mode <= 2) THEN ! log scale WRITE (*,"(/' Working on log of largest (absolute value) principal strain-rate....')") ELSE WRITE (*,"(/' Working on largest (absolute value) principal strain-rate....')") END IF CALL DBegin_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 = graphic_largest_ei_persec(i) IF (DMOD(t, strainrate_mosaic_interval) == 0.0D0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0D0) THEN t = t - 0.001D0* strainrate_mosaic_interval ELSE ! t < 0.0 t = t + 0.001D0 * strainrate_mosaic_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, group = 1) END DO ! i = 1, numel CALL DEnd_Group ! of colored/shaded triangles WRITE (*,"('+Working on log of largest (absolute value) principal strain-rate....DONE.')") CALL Chooser(bottom, right) IF (bottom) THEN IF (strainrate_mosaic_mode <= 2) THEN ! log scale; dimensionless CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') ELSE IF (strainrate_mosaic_mode == 3) THEN ! linear scale, in /s CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = "/s") ELSE IF (strainrate_mosaic_mode == 4) THEN ! linear scale, in nanostrains/year CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = "nanostrains/year") END IF bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN IF (strainrate_mosaic_mode <= 2) THEN ! log scale; dimensionless CALL DBar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') ELSE IF (strainrate_mosaic_mode == 3) THEN ! linear scale, in /s CALL DBar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = "/s") ELSE IF (strainrate_mosaic_mode == 4) THEN ! linear scale, in nanostrains/year CALL DBar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = "nanostrains/year") END IF rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! ELSE ! strainrate_mosaic_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = graphic_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 DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & ' ', minimum, maximum, & & bitmap_color_mode, strainrate_mosaic_interval, strainrate_mosaic_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 IF (strainrate_mosaic_mode <= 2) THEN ! log scale; dimensionless CALL DSpectrum_in_BottomLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) ELSE IF (strainrate_mosaic_mode == 3) THEN ! linear scale, in /s CALL DSpectrum_in_BottomLegend (minimum, maximum, "/s", bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) ELSE IF (strainrate_mosaic_mode == 4) THEN ! linear scale, in nanostrains/year CALL DSpectrum_in_BottomLegend (minimum, maximum, "nanostrains/year", bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) END IF bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN IF (strainrate_mosaic_mode <= 2) THEN ! log scale; dimensionless CALL DSpectrum_in_RightLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) ELSE IF (strainrate_mosaic_mode == 3) THEN ! linear scale, in /s CALL DSpectrum_in_RightLegend (minimum, maximum, "/s", bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) ELSE IF (strainrate_mosaic_mode == 4) THEN ! linear scale, in nanostrains/year CALL DSpectrum_in_RightLegend (minimum, maximum, "nanostrains/year", bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) END IF rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! strainrate_mosaic_method = 1 or 2 CALL BEEPQQ (440, 250) DEALLOCATE ( graphic_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 DGroup_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 DPrompt_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 DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL DPress_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 DPrompt_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 DPress_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 DMake_Uvec (uvec4, uvec) ! center of element equat = DSQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.0D0) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF theta_ = DATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL Rotation_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, rotationrate) !convert to popular units, for histogram (clockwise degrees per Ma) omega_degperMa(l_) = -rotationrate * degrees_per_radian * s_per_Ma !(not using loop on m = 1,...,7 since values almost identical) 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.0D0) THEN rotationrate_interval = (maximum - minimum) / ai_spectrum_count rotationrate_midvalue = (maximum + minimum) / 2.0D0 END IF 1082 CALL DPrompt_for_Real('What contour interval do you wish?',rotationrate_interval,rotationrate_interval) IF (rotationrate_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") rotationrate_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1082 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',rotationrate_midvalue,rotationrate_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',rotationrate_lowblue,rotationrate_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',rotationrate_lowblue,rotationrate_lowblue) END IF WRITE (*,"(/' Working on rotation rate....')") CALL DBegin_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 (DMOD(t, rotationrate_interval) == 0.0D0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0D0) THEN t = t - 0.001D0* rotationrate_interval ELSE ! t < 0.0 t = t + 0.001D0 * rotationrate_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = rotationrate_interval, & & midspectrum_value = rotationrate_midvalue, & & low_is_blue = rotationrate_lowblue, group = 1) END DO ! i = 1, numel CALL DEnd_Group ! of colored/shaded triangles WRITE (*,"('+Working on rotation rate....DONE.')") CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = rotationrate_interval, & & midspectrum_value = rotationrate_midvalue, & & low_is_blue = rotationrate_lowblue, & & units = 'clockwise degree/Ma') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = rotationrate_interval, & & midspectrum_value = rotationrate_midvalue, & & low_is_blue = rotationrate_lowblue, & & units = 'clockwise degree/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 DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN 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 DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & 'clockwise degree/Ma', minimum, maximum, & & bitmap_color_mode, rotationrate_interval, rotationrate_midvalue, rotationrate_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, 'clockwise degree/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 DSpectrum_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 (440, 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 CALL DGroup_or_Bitmap (latter_mosaic, strainrate_mosaic_method, bitmap_height, bitmap_width) ! method = polygons or bitmap 1091 WRITE (*, *) WRITE (*, "(' ------------------------------------------------------------------')") WRITE (*, "(' Choose color-scale mode, and units for strain-rates:')") WRITE (*, "(' 1 = logarithmic color scale; SI units of /s')") WRITE (*, "(' 2 = logarithmic color scale; popular units of nanostrains/year')") WRITE (*, "(' 3 = linear color scale; SI units of /s')") WRITE (*, "(' 4 = linear color scale; popular units of nanostrains/year')") WRITE (*, "(' ------------------------------------------------------------------')") CALL DPrompt_for_Integer('Strainrate mosaic mode:', strainrate_mosaic_mode, strainrate_mosaic_mode) IF ((strainrate_mosaic_mode < 1).OR.(strainrate_mosaic_mode > 4)) THEN WRITE (*, "(' ERROR: Illegal selection. Please choose an integer from 1 to 4...')") CALL Pause() GO TO 1091 END IF IF ((TRIM(f_dat) /= 'none').AND.(TRIM(f_dig) /= 'none')) THEN ! there are faults in this model IF (strainrate_mosaic_mode == 1) THEN CALL Add_Title('Continuum Strain-Rate, excluding modeled faults: log10 of greatest principal rate, in /s') ELSE IF (strainrate_mosaic_mode == 2) THEN CALL Add_Title('Continuum Strain-Rate, excluding modeled faults: log10 of greatest principal rate, in nanostrains/year') ELSE IF (strainrate_mosaic_mode == 3) THEN CALL Add_Title('Continuum Strain-Rate, excluding modeled faults: greatest (absolute value) principal rate, in /s') ELSE IF (strainrate_mosaic_mode == 4) THEN CALL Add_Title('Continuum Strain-Rate, excluding modeled faults: greatest principal rate, in nanostrains/year') END IF ELSE IF (strainrate_mosaic_mode == 1) THEN CALL Add_Title('Continuum Strain-Rate: log10(greatest principal rate * 1 s)') ELSE IF (strainrate_mosaic_mode == 2) THEN CALL Add_Title('Continuum Strain-Rate: log10(greatest principal rate * 1 year/nanostrain)') ELSE IF (strainrate_mosaic_mode == 3) THEN CALL Add_Title('Continuum Strain-Rate: greatest (absolute value) principal rate, in /s') ELSE IF (strainrate_mosaic_mode == 4) THEN CALL Add_Title('Continuum Strain-Rate: greatest (absolute value) principal rate, in nanostrains/year') END IF END IF 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 DPrompt_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 DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL DPress_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 ( graphic_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 DPrincipal_Axes_22 (eps_dot(1),eps_dot(2),eps_dot(3), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) err = -(e1h + e2h) largest_ei_persec = MAX(DABS(e1h), DABS(e2h), DABS(err)) IF (strainrate_mosaic_mode <= 2) THEN ! log scale IF (largest_ei_persec == 0.0D0) THEN graphic_largest_ei_persec(l_) = -60.0D0 ! arbitrary substitute for -infinity! ELSE IF (strainrate_mosaic_mode == 1) THEN ! /s units graphic_largest_ei_persec(l_) = DLOG10(largest_ei_persec) ELSE ! nanostrains/year graphic_largest_ei_persec(l_) = DLOG10(largest_ei_persec * 1.0D9 * sec_per_year) END IF END IF ELSE ! linear scale IF (strainrate_mosaic_mode == 3) THEN ! /s units graphic_largest_ei_persec(l_) = largest_ei_persec ELSE ! nanostrains/year graphic_largest_ei_persec(l_) = largest_ei_persec * 1.0D9 * sec_per_year END IF 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 DMake_Uvec (uvec4, uvec) ! center of element equat = DSQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.0D0) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF theta_ = DATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) !convert to scalar measure, for histogram CALL DPrincipal_Axes_22 (eps_dot(1),eps_dot(2),eps_dot(3), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) err = -(e1h + e2h) largest_ei_persec = MAX(DABS(e1h), DABS(e2h), DABS(err)) IF (strainrate_mosaic_mode <= 2) THEN ! log scale IF (largest_ei_persec == 0.0D0) THEN graphic_largest_ei_persec(l_) = -60.0D0 ! arbitrary substitute for -infinity! ELSE IF (strainrate_mosaic_mode == 1) THEN ! /s units graphic_largest_ei_persec(l_) = DLOG10(largest_ei_persec) ELSE ! nanostrains/year graphic_largest_ei_persec(l_) = DLOG10(largest_ei_persec * 1.0D9 * sec_per_year) END IF END IF ELSE ! linear scale IF (strainrate_mosaic_mode == 3) THEN ! /s units graphic_largest_ei_persec(l_) = largest_ei_persec ELSE ! nanostrains/year graphic_largest_ei_persec(l_) = largest_ei_persec * 1.0D9 * sec_per_year END IF 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 IF (strainrate_mosaic_mode == 1) THEN WRITE (*,"(/' Here is the distribution of common logs of largest (absolute value)' & & /' principal strain-rates (LOG10(MAX(ABS(Ei * 1 s)))) for each element:')") ELSE IF (strainrate_mosaic_mode == 2) THEN WRITE (*,"(/' Here is the distribution of common logs of largest (absolute value)' & & /' principal strain-rates (LOG10(MAX(ABS(Ei * 1 year/nanostrain)))) for each element:')") ELSE IF (strainrate_mosaic_mode == 3) THEN WRITE (*,"(/' Here is the distribution of largest (absolute value) principal' & & /' strain-rates (MAX(ABS(Ei))), in /s, for each element:')") ELSE IF (strainrate_mosaic_mode == 4) THEN WRITE (*,"(/' Here is the distribution of largest (absolute value) principal' & & /' strain-rates (MAX(ABS(Ei))), in nanostrains/year, for each element:')") END IF CALL Histogram (graphic_largest_ei_persec, numel, .FALSE., maximum, minimum) IF (strainrate_mosaic_method == 1) THEN ! group of colored/shaded polygons IF (strainrate_mosaic_interval == 0.0D0) THEN strainrate_mosaic_interval = (maximum - minimum) / ai_spectrum_count strainrate_mosaic_midvalue = (maximum + minimum) / 2.D0 END IF 1092 CALL DPrompt_for_Real('What contour interval do you wish?',strainrate_mosaic_interval,strainrate_mosaic_interval) IF (strainrate_mosaic_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") strainrate_mosaic_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1092 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',strainrate_mosaic_midvalue,strainrate_mosaic_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',log_strainrate_lowblue,log_strainrate_lowblue) ELSE CALL DPrompt_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 DBegin_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 = graphic_largest_ei_persec(i) IF (DMOD(t, strainrate_mosaic_interval) == 0.0D0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0D0) THEN t = t - 0.001D0* strainrate_mosaic_interval ELSE ! t < 0.0 t = t + 0.001D0 * strainrate_mosaic_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, group = 1) END DO ! i = 1, numel CALL DEnd_Group ! of colored/shaded triangles IF (strainrate_mosaic_mode <= 2) THEN ! log scale WRITE (*,"('+Working on log of largest (absolute value) principal strain-rate....DONE.')") ELSE ! linear scale WRITE (*,"('+Working on largest (absolute value) principal strain-rate....DONE.')") END IF CALL Chooser(bottom, right) IF (bottom) THEN IF (strainrate_mosaic_mode <= 2) THEN ! log scale; dimensionless CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') ELSE IF (strainrate_mosaic_mode == 3) THEN ! linear scale, in /s CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = "/s") ELSE IF (strainrate_mosaic_mode == 4) THEN ! linear scale, in nanostrains/year CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = "nanostrains/year") END IF bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN IF (strainrate_mosaic_mode <= 2) THEN ! log scale; dimensionless CALL DBar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') ELSE IF (strainrate_mosaic_mode == 3) THEN ! linear scale, in /s CALL DBar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = "/s") ELSE IF (strainrate_mosaic_mode == 4) THEN ! linear scale, in nanostrains/year CALL DBar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = strainrate_mosaic_interval, & & midspectrum_value = strainrate_mosaic_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = "nanostrains/year") END IF rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! ELSE ! strainrate_mosaic_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = graphic_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 DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & ' ', minimum, maximum, & & bitmap_color_mode, strainrate_mosaic_interval, strainrate_mosaic_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 IF (strainrate_mosaic_mode <= 2) THEN ! log scale; dimensionless CALL DSpectrum_in_BottomLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) ELSE IF (strainrate_mosaic_mode == 3) THEN ! linear scale, in /s CALL DSpectrum_in_BottomLegend (minimum, maximum, "/s", bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) ELSE IF (strainrate_mosaic_mode == 4) THEN ! linear scale, in nanostrains/year CALL DSpectrum_in_BottomLegend (minimum, maximum, "nanostrains/year", bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) END IF bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN IF (strainrate_mosaic_mode <= 2) THEN ! log scale; dimensionless CALL DSpectrum_in_RightLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) ELSE IF (strainrate_mosaic_mode == 3) THEN ! linear scale, in /s CALL DSpectrum_in_RightLegend (minimum, maximum, "/s", bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) ELSE IF (strainrate_mosaic_mode == 4) THEN ! linear scale, in nanostrains/year CALL DSpectrum_in_RightLegend (minimum, maximum, "nanostrains/year", bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & strainrate_mosaic_interval, strainrate_mosaic_midvalue, log_strainrate_lowblue) END IF rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! strainrate_mosaic_method = 1 or 2 CALL BEEPQQ (440, 250) DEALLOCATE ( graphic_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] CASE (13) ! point data as colored rectangles, merged into one bitmap 1131 temp_path_in = path_in WRITE (*, "(/' Point-data files can be in either (lon, lat) format, or (lon, lat, value) format.')") CALL DPrompt_for_String('Which file contains the point data?',point_data_file,point_data_file) point_data_pathfile = TRIM(temp_path_in)//TRIM(point_data_file) OPEN (UNIT = 21, FILE = point_data_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) CALL Could_Not_Find_File(point_data_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) WRITE (*, "(/' Point-data files can be in either (lon, lat) format, or (lon, lat, value) format.')") CALL DPrompt_for_Logical('Does this file have a value after each (lon,lat) position?',point_data_values,point_data_values) CALL Add_Title(point_data_file) IF (point_data_values) THEN ! determine their range OPEN (UNIT = 21, FILE = point_data_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') point_count = 0 ! total points in file visible_point_count = 0 ! points visible in the map window pointing1: DO READ (21, *, IOSTAT = ios) lon, lat, value IF (ios /= 0) EXIT pointing1 point_count = point_count + 1 !decide whether this point is visible in the window CALL DLonLat_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.0D0) CYCLE pointing1 END IF CALL DProject (uvec = uvec, x = x_meters, y = y_meters) ! but no 'guide =' CALL DMeters_2_Points (x_meters,y_meters, x_points,y_points) c1 = DIn_Window (x_points, y_points) visible = (c1 == 'I').OR.(c1 == 'B') ! Inside, or Border IF (visible) THEN visible_point_count = visible_point_count + 1 IF (visible_point_count == 1) THEN value_max = value value_min = value ELSE value_max = MAX(value_max, value) value_min = MIN(value_min, value) END IF END IF ! visible END DO pointing1 CLOSE (21) IF (visible_point_count == 0) THEN value_min = 0.0D0 value_max = 0.0D0 END IF WRITE (*, "(' ',I10,' visible points have values from ',ES10.2,' to ',ES10.2)") & & visible_point_count, value_min, value_max minimum = value_min ! synonyms, for use in copied codes maximum = value_max IF (visible_point_count > 0) THEN train_length = visible_point_count ALLOCATE ( train(train_length) ) WRITE (*,"(/' Here is the distribution of VISIBLE values:' )") OPEN (UNIT = 21, FILE = point_data_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') k = 0 ! will count visible (in map window) points, up to visible_point_count pointing2: DO READ (21, *, IOSTAT = ios) lon, lat, value IF (ios /= 0) EXIT pointing2 !decide whether this point is visible in the window CALL DLonLat_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.0D0) CYCLE pointing2 END IF CALL DProject (uvec = uvec, x = x_meters, y = y_meters) ! but no 'guide =' CALL DMeters_2_Points (x_meters,y_meters, x_points,y_points) c1 = DIn_Window (x_points, y_points) visible = (c1 == 'I').OR.(c1 == 'B') ! Inside, or Border IF (visible) THEN k = k + 1 train(k) = value END IF ! visible END DO pointing2 CLOSE (21) CALL Histogram (train, visible_point_count, .FALSE., value_max, value_min) DEALLOCATE ( train ) END IF ! (visible_point_count > 0) END IF ! (point_data_values); determining range IF (ai_using_color.AND.(visible_point_count > 0)) THEN CALL DPrompt_for_String('What are the units of these values?',TRIM(ADJUSTL(grid_units)),grid_units) 1133 WRITE (*,"(/' How shall the points be colored?')") WRITE (*,"( ' mode 1: Munsell: smooth spectrum')") WRITE (*,"( ' mode 2: Kansas: 44-color scale of atlas-type colors')") WRITE (*,"( ' mode 3: UNAVCO: 20-color absolute scale (only for topography in m)')") WRITE (*,"( ' mode 4: AI: ',I2,'-color discrete scale, based on contour interval')") ai_spectrum_count WRITE (*,"( ' -------------------------------------------------------')") CALL DPrompt_for_Integer('Which coloring mode?',bitmap_color_mode,bitmap_color_mode) IF ((bitmap_color_mode < 1).OR.(bitmap_color_mode > 4)) THEN WRITE (*,"(/' ERROR: Select mode index from list!' )") mt_flashby = .FALSE. GO TO 1133 END IF IF (bitmap_color_mode <= 2) THEN ! need to pin down ends of spectrum CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) 1134 IF (grid_lowblue) THEN CALL DPrompt_for_Real('What (low?) value anchors the violet-blue end of the spectrum?',minimum,bitmap_color_lowvalue) CALL DPrompt_for_Real('What (high?) value anchors the red-pink end of the spectrum?',maximum,bitmap_color_highvalue) ELSE CALL DPrompt_for_Real('What (high?) value anchors the violet-blue end of the spectrum?',maximum,bitmap_color_lowvalue) CALL DPrompt_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 1134 END IF ! bad range ELSE IF (bitmap_color_mode == 4) THEN IF (grid_interval == 0.0D0) THEN grid_interval = (value_max - value_min)/ai_spectrum_count grid_midvalue = (value_max + value_min)/2.D0 END IF 1135 CALL DPrompt_for_Real('What contour interval do you wish?',grid_interval,grid_interval) IF (grid_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") grid_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1135 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',grid_midvalue,grid_midvalue) CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) END IF ! bitmap_color_mode = 1,2 versus 4 END IF ! ai_using_color, or not 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 1136 CALL DPrompt_for_Integer('How many columns of pixels in bitmap?',bitmap_width,bitmap_width) IF (bitmap_width < 2) THEN WRITE (*,"(' ERROR: Bitmap_width must be >= 2')") mt_flashby = .FALSE. GO TO 1136 END IF 1137 CALL DPrompt_for_Integer('How many rows of pixels in bitmap?',bitmap_height,bitmap_height) IF (bitmap_height < 2) THEN WRITE (*,"(' ERROR: Bitmap_height must be >= 2')") mt_flashby = .FALSE. GO TO 1137 END IF 1138 CALL DPrompt_for_Integer('How many pixels wide is each data point?',point_pixel_width,point_pixel_width) IF (point_pixel_width < 1) THEN WRITE (*,"(' ERROR: Point_pixel_width must be >= 1')") mt_flashby = .FALSE. GO TO 1138 END IF WRITE (*,"(/' Working on bitmap from point-value dataset(s)....')") ALLOCATE ( bitmap(bitmap_height,bitmap_width) ) !Initialize bitmap to background color !RGB_c3 = CHAR(red_integer)//CHAR(green_integer)//CHAR(blue_integer) c3 = CHAR(ai_background%rgb(1))//CHAR(ai_background%rgb(2))//CHAR(ai_background%rgb(3)) DO irow = 1, bitmap_height ! top to bottom DO jcol = 1, bitmap_width ! left to right bitmap(irow, jcol) = c3 END DO ! jcol, left to right END DO ! irow, top to bottom !Modify the blank bitmap by coloring in small rectangles: OPEN (UNIT = 21, FILE = point_data_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) CALL Could_Not_Find_File(point_data_pathfile) pointing3: DO IF (point_data_values) THEN READ (21, *, IOSTAT = ios) lon, lat, value ELSE READ (21, *, IOSTAT = ios) lon, lat END IF IF (ios /= 0) EXIT pointing3 !decide whether this point is visible in the window CALL DLonLat_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.0D0) CYCLE pointing3 END IF CALL DProject (uvec = uvec, x = x_meters, y = y_meters) ! but no 'guide =' CALL DMeters_2_Points (x_meters,y_meters, x_points,y_points) c1 = DIn_Window (x_points, y_points) visible = (c1 == 'I').OR.(c1 == 'B') ! Inside, or Border IF (visible) THEN !determine row & column position in bitmap (using reals): real_row = ((ai_window_y2_points - y_points) / & & (ai_window_y2_points - ai_window_y1_points)) * bitmap_height - 0.5D0 real_column = ((x_points - ai_window_x1_points) / & & (ai_window_x2_points - ai_window_x1_points)) * bitmap_width - 0.5D0 i1 = MAX(NINT(real_row - 0.5D0 * point_pixel_width), 1) i2 = MIN(NINT(real_row + 0.5D0 * point_pixel_width), bitmap_height) j1 = MAX(NINT(real_column - 0.5D0 * point_pixel_width), 1) j2 = MIN(NINT(real_column + 0.5D0 * point_pixel_width), bitmap_width) !determine appropriate color: IF (point_data_values.AND.ai_using_color) THEN ! choose color per value brightness = 1.0D0 IF (bitmap_color_mode == 1) THEN ! Munsell: smooth spectrum t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Munsell(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 2) THEN ! Kansas: 44-color atlas-type scale t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = DRGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = DRGB_AI(value = value, contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, low_is_blue = grid_lowblue, & & brightness = brightness) END IF ! bitmap_color_mode selection ELSE ! use foreground color c3 = CHAR(ai_foreground%rgb(1))//CHAR(ai_foreground%rgb(2))//CHAR(ai_foreground%rgb(3)) END IF !modify the bitmap with one more point: DO i = i1, i2 DO j = j1, j2 bitmap(i, j) = c3 END DO END DO END IF ! visible END DO pointing3 ! reading point-data file so as to modify bitmap CLOSE (21) WRITE (*,"('+Working on bitmap from gridded dataset(s)....Writing to .ai ')") CALL DBitmap_on_L1 (bitmap, ai_window_x1_points, ai_window_x2_points, & & ai_window_y1_points, ai_window_y2_points) IF (ai_using_color.AND.point_data_values.AND.(visible_point_count > 0)) THEN ! key is needed CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, .FALSE., & & grid_interval, grid_midvalue, grid_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, .FALSE., & & 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.AND.point_data_values.AND.(visible_point_count > 0)) THEN ! key is needed WRITE (*,"('+Working on bitmap from gridded dataset(s)....DONE. ')") CALL BEEPQQ (440, 250) DEALLOCATE ( bitmap ) ! end of point data as colored rectangles, merged into one bitmap END SELECT ! (choice) = mosaic type latter_mosaic = .TRUE. ! since one is already laid down WRITE (*,"(' ')") suggest_logical = mosaic_count < old_mosaic_count CALL DPrompt_for_Logical('Do you want additional mosaics?',suggest_logical,do_more_mosaics) IF (do_more_mosaics) GO TO 1000 ! 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 :: digitized 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 strain-rates, excluding modeled faults')") 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 DPrompt_for_Logical('Do you want one (or more) of these overlays?',suggest_logical,do_overlay) IF (do_overlay) THEN overlay_count = overlay_count + 1 choice = overlay_choice(overlay_count) 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 DPrompt_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 DPress_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 DPrompt_for_String('Which file should be plotted?',lines_basemap_file,lines_basemap_file) lines_basemap_pathfile = TRIM(temp_path_in)//TRIM(lines_basemap_file) CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color (color_name = 'foreground') CALL Dig_Type (lines_basemap_pathfile, 21, dig_is_lonlat, any_titles) CALL DPrompt_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 DPress_Enter STOP ' ' END IF IF (any_titles) THEN WRITE (*, "(/' Title lines were detected in this .dig file;')") CALL DPrompt_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 DPrompt_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 DPlot_Dig (7, lines_basemap_pathfile, polygons, 21, in_ok) ELSE CALL DPlot_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 DSet_Fill_or_Pattern (.FALSE., 'foreground') IF (dig_is_lonlat) THEN CALL DPlot_Dig (7, lines_basemap_pathfile, polygons, 21, in_ok, dig_title_method) ELSE CALL DPlot_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 (440, 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_v1/2/3/4/5; ! however, in Long_Term_Seismicity_v6+ this functionality is built-in (by copying the following code). 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 DPrompt_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 DPress_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 DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21,*) numel ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21,*) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21, *) nfl IF (nfl > 0) CALL No_Fault_Elements_Allowed() CLOSE(21) IF (choice == 2) THEN ! plot outline only WRITE (*,"(/' Working on outline of grid....')") CALL DBegin_Group() ! This might seem unecessary for a simply-connected perimeter; ! however, after L2-->L1 windowing it may no longer be one simply-connected piece; ! it may be chopped into bits where it leaves and re-enters the map window. ! 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 DSet_Line_Style (width_points = 4.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('gray______') j = 1 ! begin with first segment uvec1(1:3) = segments(1:3,1,j) CALL DNew_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 DUvec_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 DGreat_to_L45 (uvec2) CALL DUvec_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 DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) WRITE (55, "('*** end of line segment ***')") CLOSE(55) CALL DEnd_Group() 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 DPrompt_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.0D0)) THEN CALL DBegin_Group ! of nodes IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'dark_blue_') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF DO i = 1, numnod uvec1(1:3) = node_uvec(1:3,i) node_radius_radians = node_radius_points * 0.0003528D0 * & & mp_scale_denominator * & & DConformal_Deflation (uvec1) / R CALL DTurn_To (azimuth_radians = 0.0D0, & & base_uvec = uvec1, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DNew_L45_Path (5, uvec2) CALL DSmall_To_L45 (uvec1, uvec2) CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END DO ! i = 1, numnod CALL DEnd_Group ! of nodes END IF ! numnod > 0 and node_radius_points >= 1. IF (choice == 3) THEN ! plot node numbers CALL DBegin_Group ! of node numbers IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'dark_blue_') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF DO i = 1, numnod uvec1(1:3) = node_uvec(1:3,i) WRITE (c6,"(I6)") i c6 = ADJUSTL(c6) CALL DL5_Text (uvec = uvec1, angle_radians = 0.0D0, from_east = .FALSE., & & font_points = 8, lr_fraction = -0.2D0, ud_fraction = 0.4D0, & & text = TRIM(c6)) END DO ! i = 1, numnod CALL DEnd_Group ! of node numbers END IF ! node numbers are wanted IF ((choice == 3).AND.(numel > 0)) THEN ! plot elements CALL DBegin_Group ! of elements CALL DSet_Line_Style (width_points = 1.0D0, dashed = .TRUE., & & on_points = 6.D0, off_points = 3.D0) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('gray______') END IF DO i = 1, numel DO j = 1, 3 ! loop on 3 sides jp1 = MOD(j,3) + 1 virgin = .TRUE. ! until proven otherwise IF (i > 1) THEN edges_done: DO m = 1, i-1 DO n = 1, 3 np1 = MOD(n,3) + 1 IF (nodes(n,m) == nodes(jp1,i)) THEN IF (nodes(np1,m) == nodes(j,i)) THEN virgin = .FALSE. EXIT edges_done END IF ! both ends match! END IF ! one end matches END DO ! n = 1, 3 END DO edges_done ! m = 1, i-1 END IF ! there are lower-numbered elements IF (virgin) THEN ! only plot each line once, because of dashing! uvec1(1:3) = node_uvec(1:3,nodes(j,i)) CALL DNew_L45_Path (5, uvec1) uvec2(1:3) = node_uvec(1:3,nodes(jp1,i)) CALL DGreat_To_L45 (uvec2) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! virgin END DO ! j = 1, 3 END DO ! i = 1, numel CALL DEnd_Group ! of elements CALL DBegin_Group ! of element numbers IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'gray______') END IF DO i = 1, numel uvec2(1:3) = (node_uvec(1:3, nodes(1,i)) + & & node_uvec(1:3, nodes(2,i)) + & & node_uvec(1:3, nodes(3,i))) / 3.0 CALL DMake_Uvec(uvec2, uvec1) WRITE (c6,"(I6)") i c6 = ADJUSTL(c6) CALL DL5_Text (uvec = uvec1, angle_radians = 0.0D0, from_east = .FALSE., & & font_points = 8, lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = TRIM(c6)) END DO ! i = 1, numel CALL DEnd_Group ! of element 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 (440, 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 DPrompt_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 DPrompt_for_Real('How large are the dip ticks (in points)?',tick_points,tick_points) WRITE (*,"(/' Working on fault traces....')") CALL Fault_Traces (trace_choice = 0) ! N.B. This subprogram will read "dip_degrees" if present. WRITE (*,"('+Working on fault traces....DONE.')") CALL Add_Title(traces_file) CALL BEEPQQ (440, 250) CALL Chooser (bottom, right) IF (right) THEN CALL DBegin_Group CALL Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, tick_points) CALL DEnd_Group ELSE IF (bottom) THEN CALL DBegin_Group CALL Fault_Key_Bottom (bottomlegend_gap_points, bottomlegend_used_points, tick_points) CALL DEnd_Group END IF ! end of (4) fault traces overlay CASE (5) ! fault heave rates (according to input data); only displaying the larger of 2 components. 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 DPrompt_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) , f_dip_degrees(high_trace)) trace_mma = 0.0D0 ! whole array segment_sense = ' ' ! whole array f_dip_degrees = 0.0D0 ! whole array; if not changed, serves as a flag that dip_degrees was not provided. !re-read f_dig_pathfile to memorize any dip_degrees that might be in it. OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', PAD = 'YES') 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 got_dip_degrees = .FALSE. ! until... ELSE ! line was not a title; this leaves 3 possibilities: dip_degrees, (lon, lat), or *** end !try to read "dip_degrees"... BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, "(A)", IOSTAT = internal_ios) line start_loc = INDEX(line, "dip_degrees") IF (start_loc > 0) THEN ! found "dip_degrees" in line beyond_loc = start_loc + 11 ! first byte which is not part of "dip_degrees" end_loc = LEN_TRIM(line) line = line(beyond_loc:end_loc) READ (line, *, IOSTAT = internal_ios) dip_degrees IF (internal_ios == 0) f_dip_degrees(trace_index) = dip_degrees END IF END IF END DO CLOSE (21) CALL DPrompt_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 DPrompt_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 ! fault index = i !segment_sense(i) = c6(6:6) c1 = c6(6:6) IF ((c1 == 'T').OR.(c1 == 't')) THEN IF (f_dip_degrees(i) == 0.0) THEN test_mma = v_mma * cot_thrust_dip ELSE ! use dip_degrees read from f_dig_pathfile: test_mma = v_mma / DTAN(f_dip_degrees(i) * radians_per_degree) END IF 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 IF (f_dip_degrees(i) == 0.0D0) THEN test_mma = v_mma * cot_normal_dip ELSE ! use dip_degrees read from f_dig_pathfile: test_mma = v_mma / DTAN(f_dip_degrees(i) * radians_per_degree) END IF 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 ! only save the largest component (so far...) 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 DPrompt_for_Real('What representative rate should be plotted in the key?',dv_scale_mma,dv_scale_mma) CALL DPrompt_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 DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points - 12.D0 CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Change in') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'horizontal') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 36.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'velocity') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 48.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'across fault') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 60.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(mm/a):') number8 = ADJUSTL(DASCII8(dv_scale_mma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 72.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)) CALL DSet_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DNew_L12_Path (1, x1_points + 6.D0, y2_points - 75.D0 - 0.39D0 * dv_scale_points) CALL DLine_to_L12 (x2_points - 6.D0, y2_points - 75.D0 - 0.39D0 * dv_scale_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 87.D0 + dv_scale_points CALL Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, tick_points) CALL DEnd_Group ELSE IF (bottom) THEN !plot sample trace with width = dv_scale_points, !labelled with rate = dv_scale_mma CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 79.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Change in horizontal velocity') CALL DL12_Text (level = 1, & & x_points = x1_points + 79.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'across fault (mm/a):') number8 = ADJUSTL(DASCII8(dv_scale_mma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 79.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 12.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)) CALL DSet_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DNew_L12_Path (1, (x1_points + 79.D0) - 30.D0, 0.5D0*(y1_points + y2_points) - 15.D0 - 0.39D0 * dv_scale_points) CALL DLine_to_L12 ((x1_points + 79.D0) + 30.D0, 0.5D0*(y1_points + y2_points) - 15.D0 - 0.39D0 * dv_scale_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 158.D0 CALL Fault_Key_Bottom (bottomlegend_gap_points, bottomlegend_used_points, tick_points) CALL DEnd_Group END IF ! bottom or right legend CALL Add_Title(traces_file) CALL Add_Title(f_nki_file) IF (ALLOCATED(f_dip_degrees)) DEALLOCATE (f_dip_degrees) IF (ALLOCATED(segment_sense)) DEALLOCATE (segment_sense) IF (ALLOCATED(trace_mma)) DEALLOCATE (trace_mma) WRITE (*,"('+Working on heave rates of faults....DONE.')") CALL BEEPQQ (440, 250) ! end of (5) fault heave rates (according to data) overlay CASE (6) ! fault heave rates (according to NeoKinema) 2060 IF (.NOT.got_parameters) CALL Get_Parameters temp_path_in = path_in !Get fault traces (and any dips?) into memory from f_token.dig: 2061 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 DPrompt_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 ! f*.dig not found WRITE (*,"(' ERROR: File not found.')") CLOSE (21) WRITE (*,"(' Press any key to continue...'\)") READ (*,"(A)") line got_parameters = .FALSE. GOTO 2061 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 memory for any dip_degrees found (or 0 otherwise): ALLOCATE ( f_dip_degrees(f_highest) ) f_dip_degrees = 0.0D0 ! whole array; this is a flag showing that no dip was found in f*.dig !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.001D0) 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. trace_index = j2 ELSE IF (c50(1:3) == "***") THEN ! '*** end of line segment ***' got_point = .FALSE. got_index = .FALSE. ELSE ! might be a dip_degrees line; try to read it: start_loc = INDEX(c50, "dip_degrees") IF (start_loc > 0) THEN ! found "dip_degrees" in line beyond_loc = start_loc + 11 ! first byte which is not part of "dip_degrees" end_loc = LEN_TRIM(c50) c50 = c50(beyond_loc:end_loc) READ (c50, *, IOSTAT = internal_ios) dip_degrees IF (internal_ios == 0) f_dip_degrees(trace_index) = dip_degrees END IF ! found "dip_degrees" in c50 END IF ! different types of line within f*.dig ELSE; EXIT read_dig; END IF ! terminate file-reading if another line is not available IF (in_trace) THEN IF (got_point) THEN i = i + 1 CALL DLonLat_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 DLonLat_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 not found, or WAS found 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 (*,"(' ---------------------------------------------------')") 2062 CALL DPrompt_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 2062 END IF ! bad choice IF (heave_rate_method == 1) THEN ! elegant plot, showing each trace as continuous line of constant width (with mitering): 2063 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 DPrompt_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 2063 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 IF (f_dip_degrees(j) == 0.0D0) THEN ! use default dip: f_rate_mmpa(i) = v_mma * cot_thrust_dip ELSE ! use dip_degrees found in f*.dig: f_rate_mmpa(i) = v_mma / DTAN(f_dip_degrees(j) * radians_per_degree) END IF 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 IF (f_dip_degrees(j) == 0.0D0) THEN ! use default dip: f_rate_mmpa(i) = v_mma * cot_normal_dip ELSE ! use dip_degrees found in f*.dig: f_rate_mmpa(i) = v_mma / DTAN(f_dip_degrees(j) * radians_per_degree) END IF 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.0D0) 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.0D0) 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 DPrompt_for_Real('What representative rate should be plotted in the key?',dv_scale_mma,dv_scale_mma) CALL DPrompt_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 DBegin_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 IF (f_dip_degrees(f_trace(i)) == 0.0D0) THEN ! use default thrust dip, which is shallow: color_name = 'dark_blue_' ELSE ! use dip_degrees from f*.dig: IF (f_dip_degrees(f_trace(i)) <= 45.0D0) THEN color_name = 'dark_blue_' ELSE ! steep reverse fault: color_name = 'mid_blue__' END IF END IF ELSE IF ((c1 == 'P').OR.(c1 == 'p')) THEN IF (f_dip_degrees(f_trace(i)) == 0.0D0) THEN ! use default thrust dip, which is shallow: color_name = 'dark_blue_' ELSE ! use dip_degrees from f*.dig: IF (f_dip_degrees(f_trace(i)) <= 45.0D0) THEN color_name = 'dark_blue_' ELSE ! steep reverse fault: color_name = 'mid_blue__' END IF END IF ELSE IF ((c1 == 'S').OR.(c1 == 's')) THEN IF (f_dip_degrees(f_trace(i)) == 0.0D0) THEN ! use default subduction dip, which is shallow: color_name = 'dark_blue_' ELSE ! use dip_degrees from f*.dig: IF (f_dip_degrees(f_trace(i)) <= 45.0D0) THEN color_name = 'dark_blue_' ELSE ! steep reverse fault; probably will never occur! color_name = 'mid_blue__' END IF END IF ELSE IF ((c1 == 'D').OR.(c1 == 'd')) THEN IF (f_dip_degrees(f_trace(i)) == 0.0D0) THEN ! use default normal dip, which is steep: color_name = 'bronze____' ELSE ! use dip_degrees from f*.dig: IF (f_dip_degrees(f_trace(i)) <= 45.0D0) THEN ! low-angle detachment: color_name = 'red_______' ELSE ! steep normal fault: color_name = 'bronze____' END IF END IF ELSE IF ((c1 == 'R').OR.(c1 == 'r')) THEN color_name = 'green_____' ELSE IF ((c1 == 'N').OR.(c1 == 'n')) THEN IF (f_dip_degrees(f_trace(i)) == 0.0D0) THEN ! use default normal dip, which is steep: color_name = 'bronze____' ELSE ! use dip_degrees from f*.dig: IF (f_dip_degrees(f_trace(i)) <= 45.0D0) THEN ! low-angle detachment: color_name = 'red_______' ELSE ! steep normal fault: color_name = 'bronze____' END IF END IF ELSE ! any unexpected code color_name = 'foreground' END IF CALL DSet_Stroke_Color (color_name) ELSE CALL DSet_Stroke_Color (color_name = 'foreground') END IF ! ai_using_color or not width_points = f_rate_mmpa(i) * dv_scale_points / dv_scale_mma CALL DSet_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 DNew_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 DGreat_to_L45 (uvec) END DO CALL DEnd_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 DEnd_Group DEALLOCATE ( f_rate_mmpa ) ! in LIFO order 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 DPrompt_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 ( segment_dip_degrees(segment_count) ) ! many will be 0.0, if no dip_degrees in f*.dig segment_dip_degrees = 0.0 ! just for insurance & less confusion in debugging; probably not needed 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 READ (c6, "(1X,I4,1X)") trace_index segment_dip_degrees(i) = f_dip_degrees(trace_index) ! many will be 0.0, if no dip_degrees in f*.dig 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 DLonLat_2_Uvec(lon1, lat1, uvec) segment_uvecs(1:3, 1, i) = uvec(1:3) CALL DLonLat_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.0D0) 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) ! now, changed to positive END IF ! (heave_rate_mmpa(i) < 0.0D0) 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) dip_degrees = segment_dip_degrees(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_dip_degrees(i) = segment_dip_degrees(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_dip_degrees (i_high) = dip_degrees 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 DPrompt_for_Real('What representative rate should be plotted in the key?',dv_scale_mma,dv_scale_mma) CALL DPrompt_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 DBegin_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 IF (segment_dip_degrees(i) == 0.0D0) THEN ! use default dip, which is shallow: color_name = 'dark_blue_' ELSE ! use dip_degrees from f*.dig: IF (segment_dip_degrees(i) <= 45.0D0) THEN color_name = 'dark_blue_' ELSE ! steep reverse fault color_name = 'mid_blue__' END IF END IF ELSE IF ((c1 == 'P').OR.(c1 == 'p')) THEN IF (segment_dip_degrees(i) == 0.0D0) THEN ! use default dip, which is shallow: color_name = 'dark_blue_' ELSE ! use dip_degrees from f*.dig: IF (segment_dip_degrees(i) <= 45.0D0) THEN color_name = 'dark_blue_' ELSE ! steep reverse fault color_name = 'mid_blue__' END IF END IF ELSE IF ((c1 == 'S').OR.(c1 == 's')) THEN IF (segment_dip_degrees(i) == 0.0D0) THEN ! use default dip, which is shallow: color_name = 'dark_blue_' ELSE ! use dip_degrees from f*.dig: IF (segment_dip_degrees(i) <= 45.0D0) THEN color_name = 'dark_blue_' ELSE ! steep reverse fault color_name = 'mid_blue__' END IF END IF ELSE IF ((c1 == 'D').OR.(c1 == 'd')) THEN IF (segment_dip_degrees(i) == 0.0D0) THEN ! use default normal dip, which is steep: color_name = 'bronze____' ELSE ! use dip_degrees from f*.dig: IF (segment_dip_degrees(i) <= 45.0D0) THEN ! low-angle detachment: color_name = 'red_______' ELSE ! steep normal fault color_name = 'bronze____' END IF END IF ELSE IF ((c1 == 'R').OR.(c1 == 'r')) THEN color_name = 'green_____' ELSE IF ((c1 == 'N').OR.(c1 == 'n')) THEN IF (segment_dip_degrees(i) == 0.0D0) THEN ! use default normal dip, which is steep: color_name = 'bronze____' ELSE ! use dip_degrees from f*.dig: IF (segment_dip_degrees(i) <= 45.0D0) THEN ! low-angle detachment: color_name = 'red_______' ELSE ! steep normal fault color_name = 'bronze____' END IF END IF ELSE ! any unexpected code color_name = 'foreground' END IF CALL DSet_Stroke_Color (color_name) ELSE CALL DSet_Stroke_Color (color_name = 'foreground') END IF ! ai_using_color or not width_points = heave_rate_mmpa(i) * dv_scale_points / dv_scale_mma CALL DSet_Line_Style (width_points = width_points, dashed = .FALSE.) uvec(1:3) = segment_uvecs(1:3, 1, i) CALL DNew_L45_Path (5, uvec) uvec(1:3) = segment_uvecs(1:3, 2, i) CALL DGreat_to_L45 (uvec) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO CALL DEnd_Group DEALLOCATE ( segment_uvecs ) DEALLOCATE ( heave_rate_mmpa ) DEALLOCATE ( segment_dip_degrees ) DEALLOCATE ( segment_sense ) END IF ! (heave_rate_method == 1, or 2) ! clean up memorized fault traces and any dip_degrees: IF (ALLOCATED(trace_loc)) DEALLOCATE(trace_loc) IF (ALLOCATED(trace )) DEALLOCATE(trace) IF (ALLOCATED(f_dip_degrees)) DEALLOCATE(f_dip_degrees) !Explanation item: CALL DSet_Stroke_Color (color_name = 'foreground') ! just for insurance; if later code fails to set it CALL DSet_Line_Style (width_points = 1.0D0, 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 DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points - 12.D0 CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Change in') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'horizontal') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 36.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'velocity') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 48.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'across fault') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 60.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(mm/a):') number8 = ADJUSTL(DASCII8(dv_scale_mma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 72.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)) CALL DSet_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DNew_L12_Path (1, x1_points + 6.D0, y2_points - 75.D0 - 0.5D0 * dv_scale_points) CALL DLine_to_L12 (x2_points - 6.D0, y2_points - 75.D0 - 0.5D0 * dv_scale_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 87.D0 + dv_scale_points CALL Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, 0.0D0) CALL DEnd_Group ELSE IF (bottom) THEN !plot sample trace with width = dv_scale_points, !labelled with rate = dv_scale_mma CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 79., & & y_points = 0.5D0*(y1_points + y2_points) + 12.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Change in horizontal velocity') CALL DL12_Text (level = 1, & & x_points = x1_points + 79.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'across fault (mm/a):') number8 = ADJUSTL(DASCII8(dv_scale_mma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 79.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 12.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)) CALL DSet_Line_Style (width_points = dv_scale_points, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DNew_L12_Path (1, (x1_points + 79.D0) - 30.D0, 0.5D0*(y1_points + y2_points) - 15.D0 - 0.5D0 * dv_scale_points) CALL DLine_to_L12 ((x1_points + 79.D0) + 30.D0, 0.5D0*(y1_points + y2_points) - 15.D0 - 0.5D0 * dv_scale_points) CALL DEnd_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.0D0) CALL DEnd_Group END IF ! bottom or right legend WRITE (*,"('+Working on model heave rates of faults....DONE.')") CALL BEEPQQ (440, 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 DPrompt_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 DPress_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 DLonLat_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 DPrompt_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 DPress_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 DPrompt_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 DPrompt_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 DPrompt_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.D0 * sec_per_year * DSQRT(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 DPrompt_for_Real('For how many Ma should velocity be projected?',velocity_Ma,velocity_Ma) WRITE (*,"(/' There will be ',I7,' vectors if they are not thinned.')") numnod 2074 CALL DPrompt_for_Integer('What thinning factor ( >=1 ) do you want?',vector_thinner,vector_thinner) IF (vector_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") 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 DThin_on_Sphere (node_uvec, numnod, vector_thinner, selected) WRITE (*,"(/' Working on velocity vectors....')") CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DBegin_Group DO i = 1, numnod IF (selected(i)) THEN uvec1(1:3) = node_uvec(1:3,i) v_South_mps = vw(2*i-1) v_East_mps = vw(2*i) CALL DVelocity_Vector_on_Sphere (from_uvec = uvec1, & & v_theta_mps = v_South_mps, v_phi_mps = v_East_mps, & & dt_sec = velocity_Ma * 1.D6 * sec_per_year, deflate = .TRUE.) END IF ! selected END DO ! actually plotting velocity vectors CALL DEnd_Group DEALLOCATE ( vsize_mma, vw, selected, node_uvec) ! LIFO order CALL Chooser(bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Velocity') number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(x '//TRIM(number8)//' Ma):') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5D0*(x1_points+x2_points)-14.17D0, from_y = y2_points - 33.D0, & & to_x = 0.5D0*(x1_points+x2_points)+14.17D0, to_y = y2_points - 33.D0) v_mps = 0.01D0 * mp_scale_denominator / (velocity_Ma * 1.D6 * sec_per_year) v_mma = v_mps * 1000.D0 * sec_per_year number8 = ADJUSTL(DASCII8(v_mma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 36.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8)//' mm/a') CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 48.D0 ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Velocity') number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(x '//TRIM(number8)//' Ma):') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.D0)-14.17D0, from_y = 0.5D0*(y1_points+y2_points)-10.D0, & & to_x = (x1_points+29.D0)+14.17D0, to_y = 0.5D0*(y1_points+y2_points)-10.D0) v_mps = 0.01D0 * mp_scale_denominator / (velocity_Ma * 1.D6 * sec_per_year) v_mma = v_mps * 1000.D0 * sec_per_year number8 = ADJUSTL(DASCII8(v_mma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 24.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)//' mm/a') CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58.D0 END IF ! bottom or right legend WRITE (*,"('+Working on velocity vectors....DONE.')") CALL BEEPQQ (440, 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 long-term velocities at benchmarks as predicted by NeoKinema')") WRITE (*,"( ' (5) unfit portion of GPS velocities (data - model residuals)')") 2081 CALL DPrompt_for_Integer("Please select 1 or 2 or 3 or 4 or 5?",gps_type,gps_type) IF (.NOT.((gps_type == 1).OR.(gps_type == 2).OR.(gps_type == 3).OR.(gps_type == 4).OR.(gps_type == 5))) THEN WRITE (*,"(' ERROR: Please enter either 1, 2, 3, 4, or 5. 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 Long-Term 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) ELSE IF (gps_type == 5) THEN CALL Add_Title('Unfit Portions of Geodetic Velocities (data - model residuals)') advised_GPS_Postprocessor = .FALSE. ! initially, to allow one interactive warning !CALL File_List( file_type = "g*.nko", & ! & suggested_file = gps_file, & ! & using_path = temp_path_in) END IF IF (gps_type == 1) THEN CALL DPrompt_for_String('Which file (of type *.GPS) should be used?',gps_file,gps_file) ELSE ! gps_type > 1 CALL DPrompt_for_String('Which file (of type g*.NKO) should be used?',gps_file,gps_file) END IF 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 DPress_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 == 2, 3, 4, or 5; 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 compare the observed interseismic 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 long-term-prediction velocities: benchmark_E_velocity(i) = benchmark_E_velocity(i) + E_error_mmpa benchmark_N_velocity(i) = benchmark_N_velocity(i) + N_error_mmpa ELSE IF (gps_type == 5) THEN ! replace reframed, unlocked velocities with (data - model) residuals, ! which are assumed to be the same in either the interseismic or the ! long-term domain, and therefore just the negative of the model errors: benchmark_E_velocity(i) = -E_error_mmpa benchmark_N_velocity(i) = -N_error_mmpa END IF END IF CALL DLonLat_2_Uvec (lon, lat, uvec1) benchmark_uvec(1:3,i) = uvec1(1:3) benchmark_hypotenuse(i) = DSQRT(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) !option to read a .GP2 file and use those (block-diagonal) velocity uncertainty ellipses instead... IF (gps_type == 1) THEN ! plotting ellipses only for gps_type == 1 or 3 or 5; HOWEVER, benchmark numbering will NOT match .GP2 file ! when plotting in modes #3 or #5. ! This is because NeoKinema rejects any benchmarks outside ! the spatial domain of the active .FEG file, and thus the ! list in g_[token].NKO is shorter than the list in g*.GPS. ALLOCATE ( benchmark_c12_mm2pera2(benchmarks) ) benchmark_c12_mm2pera2 = 0.0D0 ! in case any relevant values are not found in the .GP2 file ALLOCATE ( recorrelate_benchmark(benchmarks) ) recorrelate_benchmark = .FALSE. ! but will become TRUE if c11, c12, or c22 is read for this benchmark WRITE (*, *) WRITE (*, "(' This .GPS file (already read) contains error-ellipse information.')") CALL DPrompt_for_Logical('Do you wish to replace these ellipses with those in a .GP2 file?', .FALSE., plot_GP2_ellipses) IF (plot_GP2_ellipses) THEN 2083 gp2_file = ' ' ! until File_List makes a better suggestion: !CALL File_List( file_type = "*.gp2", & ! & suggested_file = gp2_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file should be used?', gp2_file, gp2_file) gp2_pathfile = TRIM(temp_path_in)//TRIM(gp2_file) OPEN(UNIT = 22, FILE = gp2_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL DPress_Enter mt_flashby = .FALSE. GO TO 2083 END IF !check .GP2 file to be sure that it has the same # of benchmarks as the currently-active .GPS file! high_GP2_index = 0 scan_GP2: DO READ (22, *, IOSTAT = ios) i, j IF (ios /= 0) EXIT scan_GP2 high_GP2_index = MAX(high_GP2_index, i, j) END DO scan_GP2 CLOSE(22) ! close and then re-open: high_GP2_index = high_GP2_index / 2 ! converting to benchmark-count IF (high_GP2_index /= benchmarks) THEN WRITE (*, "(' ERROR: .GP2 file has different number of benchmarks than .GPS file does,')") WRITE (*, "(' so all associations between benchmarks and .GP2 rows/columns are undefined!')") WRITE (*, "(' ',I6,' benchmarks in .GPS file; but ',I6,' in .GP2 file.')") benchmarks, high_GP2_index WRITE (*, "(' Please select a different .GP2 file that matches the .GPS one-for-one!')") CALL Pause() GO TO 2083 END IF CALL Add_Title(TRIM(gp2_file)) ! (now that .GP2 has been checked for consistency with .GPS) OPEN(UNIT = 22, FILE = gp2_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') extracting: DO READ (22, *, IOSTAT = ios) i, j, variance_mm2pera2 IF (ios /= 0) EXIT extracting ! e.g., at EOF? IF (i == j) THEN ! diagonal value; always used k_site = (i + 1)/2 ! benchmark index, for storage in vector arrays IF (MOD(i, 2) == 1) THEN benchmark_E_sigma(k_site) = DSQRT(variance_mm2pera2) recorrelate_benchmark(k_site) = .TRUE. ELSE ! i is even; this is a NN variance benchmark_N_sigma(k_site) = DSQRT(variance_mm2pera2) recorrelate_benchmark(k_site) = .TRUE. END IF ELSE IF (((MOD(i, 2) == 1).AND.(j == (i+1))).OR. & & ((MOD(i, 2) == 0).AND.(j == (i-1)))) THEN ! SELECTED next-to-diagonal values are also used; ! NOTE that we can't be sure whether .GP2 file will contain the ! sub-diagonal or the super-diagonal entries, and we shouldn't ! assume any particular order for the entries, either. k_site = (i + 1)/2 ! benchmark index, for storage in vector arrays benchmark_c12_mm2pera2(k_site) = variance_mm2pera2 ! save for later use, after all diagonal changes are complete. recorrelate_benchmark(k_site) = .TRUE. END IF END DO extracting CLOSE (22) ! GP2_file !now, apply stored c12 values to recompute correlations: GP2_count = 0 DO i = 1, benchmarks IF (recorrelate_benchmark(i)) THEN GP2_count = GP2_count + 1 benchmark_correlation(i) = benchmark_c12_mm2pera2(i) / (benchmark_E_sigma(i) * benchmark_N_sigma(i)) ! which may be new, from .GP2 END IF END DO ! i = 1, benchmarks WRITE (*, "(' Uncertainty ellipses were replaced at ',I6,' benchmarks.')") GP2_count END IF ! plot_GP2_ellipses END IF ! error ellipses will be plotted (and perhaps user wants to change the basis to .GP2??) IF (gps_type == 2) THEN ! must open original data file and use interseismic velocities in it !CALL File_List( file_type = "*.gps", & ! & suggested_file = gps_file, & ! & using_path = temp_path_in) 2084 CALL DPrompt_for_String('Which is the original (input) geodetic data file?',gps_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 DPress_Enter mt_flashby = .FALSE. GO TO 2084 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 ((DMOD(lon - benchmark_Elon_deg(i) + 720.0D0, 360.0D0) == 0.0D0).AND.(lat == benchmark_Nlat_deg(i))) THEN ! got a match! !Note: At this point, benchmark_E/N_velocity(i) holds the model long-term target velocity benchmark_E_velocity(i) = benchmark_E_velocity(i) - vE_mmpa ! now, equal to unlocking- benchmark_N_velocity(i) = benchmark_N_velocity(i) - vN_mmpa ! rate correction vector benchmark_hypotenuse(i) = DSQRT(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 IF (gps_type /= 5) THEN ! gps_type /= {2.OR.5}, so ask if a frame change is wanted? CALL DPrompt_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 DPrompt_for_Real('Longitude of reference point (degrees, East is positive)?',reference_Elon_deg,reference_Elon_deg) CALL DPrompt_for_Real('Latitude of reference point (degrees, North is positive)?',reference_Nlat_deg,reference_Nlat_deg) CALL DPrompt_for_Real('Reference velocity to the East at this point (mm/a)?',reference_vE_mmpa,reference_vE_mmpa) CALL DPrompt_for_Real('Reference velocity to the North at this point (mm/a)?',reference_vN_mmpa,reference_vN_mmpa) CALL DPrompt_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.5 (frame-independent differential plot), or not IF (gps_type == 5) CALL Add_Title('(Note that these residuals are frame-independent.)') ALLOCATE ( train (benchmarks) ) k = 0 DO i = 1, benchmarks uvec(1:3) = benchmark_uvec(1:3, i) visible = DL5_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 DPrompt_for_Real('For how many Ma should velocity be projected?',velocity_Ma,velocity_Ma) CALL DPrompt_for_Real('How large (in points) should benchmark locations be plotted?',benchmark_points,benchmark_points) WRITE (*,"(/' Working on benchmark velocity vectors....')") !create group of error ellipses: ellipses = .FALSE. ! usually reversed by any finite ellipse, below CALL DSet_Join_to_Round CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') t = (velocity_Ma * 1.0D6) * 0.001D0 / mp_radius_meters ! arc-radians per (mm/a) IF ((gps_type == 1).OR.(gps_type == 3).OR.(gps_type == 5)) THEN ! do ellipses only for gps_type == 1 or 3 or 5 IF (velocity_Ma /= 0.0D0) THEN CALL DBegin_Group DO i = 1, benchmarks IF ((benchmark_N_sigma(i) > 0.0D0).AND.(benchmark_E_sigma(i) > 0.0D0)) THEN ellipses = .TRUE. uvec1(1:3) = benchmark_uvec(1:3,i) !locate head of vector, to be center of ellipse: az1 = DATan2F(benchmark_E_velocity(i),benchmark_N_velocity(i)) t1 = t * DConformal_Deflation (uvec1) ! arc-radians per (mm/a) CALL DTurn_To (azimuth_radians = az1, base_uvec = uvec1, far_radians = t1 * benchmark_hypotenuse(i), & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec) t1 = t * DConformal_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 DPrincipal_Axes_22 (covariance_11, covariance_12, covariance_22, & & e1, e2, u1x,u1y, u2x,u2y) e1 = 1.96D0 * DSQRT(e1) e2 = 1.96D0 * DSQRT(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 - DATan2F(u1y,u1x) ! smallest axis, in radians clockwise from North !find initial point at top of ellipse: CALL DTurn_To (azimuth_radians = start_azimuth, base_uvec = uvec, far_radians = t1 * e1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL DNew_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.5D0) * 30.0D0 * radians_per_degree ! mid-point; relative to e1 axis rel_az3 = -j * 30.0D0 * radians_per_degree ! 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 = DCOS(rel_az2) * t1 * e1 ! arc-radians dl2 = DSIN(rel_az2) * t1 * e2 arc2 = DSQRT(ds2**2 + dl2**2) aze2 = start_azimuth + DATan2F(dl2,ds2) CALL DTurn_To (azimuth_radians = aze2, base_uvec = uvec, far_radians = arc2, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) ds3 = DCOS(rel_az3) * t1 * e1 ! arc-radians dl3 = DSIN(rel_az3) * t1 * e2 arc3 = DSQRT(ds3**2 + dl3**2) aze3 = start_azimuth + DATan2F(dl3,ds3) CALL DTurn_To (azimuth_radians = aze3, base_uvec = uvec, far_radians = arc3, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DSmall_Through_L45 (uvec2, uvec3) ! through uvec2 to uvec3 END DO ! j = 1, 12 ! 30-degree sectors forming a circle CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF ! ellipise has positive dimensions END DO ! i = 1, benchmarks CALL DEnd_Group ! of error ellipses END IF ! velocity_Ma /= 0.0D0 END IF ! doing ellipses (if gps_type == 1 OR 3) !create group of benchmarks: IF (benchmark_points > 0.0D0) THEN CALL DSet_Join_to_Mitre CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') t = 0.6667D0 * mp_meters_per_point * benchmark_points / mp_radius_meters CALL DBegin_Group ! of benchmark triangles DO i = 1, benchmarks uvec(1:3) = benchmark_uvec(1:3,i) t1 = t * DConformal_Deflation (uvec) CALL DTurn_To (azimuth_radians = 0.0D0, base_uvec = uvec, far_radians = t1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL DNew_L45_Path (5, uvec1) CALL DTurn_To (azimuth_radians = 4.188D0, base_uvec = uvec, far_radians = t1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DGreat_To_L45 (uvec2) CALL DTurn_To (azimuth_radians = 2.094D0, base_uvec = uvec, far_radians = t1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DGreat_To_L45 (uvec3) CALL DGreat_To_L45 (uvec1) CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END DO ! i = 1, benchmarks CALL DEnd_Group ! of benchmark triangles END IF ! benchmark_points > 0.0 !create group of benchmark labels: CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DBegin_Group ! of benchmark labels DO i = 1, benchmarks uvec(1:3) = benchmark_uvec(1:3,i) c4 = benchmark_label(i)(1:4) CALL DL5_Text (uvec = uvec, angle_radians = 0.0D0, from_east = .TRUE., & & font_points = 6, lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = c4) END DO ! i = 1, benchmarks CALL DEnd_Group ! of benchmark triangles !create group of velocity vectors: IF (velocity_Ma /= 0.0D0) THEN CALL DSet_Join_to_Mitre CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DBegin_Group DO i = 1, benchmarks uvec1(1:3) = benchmark_uvec(1:3,i) v_South_mps = -0.001D0 * benchmark_N_velocity(i) / sec_per_year v_East_mps = +0.001D0 * 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 DSet_Stroke_Color ('foreground') ELSE IF (gps_type == 2) THEN ! adjustments to velocity (difference between g*.gps and g*.nko) CALL DSet_Stroke_Color ('gray______') ELSE IF (gps_type == 3) THEN ! modified g*.nko file CALL DSet_Stroke_Color ('dark_blue_') ELSE IF ((gps_type == 4).OR.(gps_type == 5)) THEN ! color will vary, green -> bronze -> red with error (in sigmas) IF (benchmark_error_sigmas(i) == 0.0D0) THEN ! No value available; plot as black. CALL DSet_Stroke_Color ('foreground') ! Note that this is usually because a .GP2 matrix was used in NeoKinema; ! therefore the NeoKineMap map of GPS misfit velocities is seriously ! inferior to the better set of maps that can be obtained from GPS_Postprocessor. IF (.NOT.advised_GPS_Postprocessor) THEN WRITE (*, *) WRITE (*, "(' CAUTION: This may be a case in which much better maps of GPS velocity misfit')") WRITE (*, "(' could be obtained by running the GPS_Postprocessor program.')") WRITE (*, *) CALL Pause() advised_GPS_Postprocessor = .TRUE. ! (This prevents more than one interactive warning per map plot.) END IF ELSE IF (benchmark_error_sigmas(i) <= 1.0D0) THEN CALL DSet_Stroke_Color ('green_____') ELSE IF (benchmark_error_sigmas(i) <= 2.0D0) THEN CALL DSet_Stroke_Color ('bronze____') ELSE ! big error, more than 2-sigmas: CALL DSet_Stroke_Color ('red_______') END IF END IF ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DVelocity_Vector_on_Sphere (from_uvec = uvec1, & & v_theta_mps = v_South_mps, v_phi_mps = v_East_mps, & & dt_sec = velocity_Ma * 1.D6 * sec_per_year, deflate = .TRUE.) END DO ! actually plotting benchmark velocity vectors CALL DEnd_Group END IF ! velocity_Ma /= 0.0D0 IF (ai_using_color) CALL DSet_Stroke_Color ('foreground') CALL Chooser(bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') IF (gps_type == 1) THEN CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'geodetic') ELSE IF (gps_type == 2) THEN CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'adjustment to') ELSE IF (gps_type == 3) THEN CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'adjusted') ELSE IF (gps_type == 4) THEN CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'NeoKinema') END IF CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'velocity') number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.0D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(x '//TRIM(number8)//' Ma):') x0p = 0.5D0 * (x1_points + x2_points) - 14.17D0 x1p = x0p + 2 * 14.17D0 ! 1-cm-long vector, expressed in points y0p = y2_points - 47.0D0 CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ellipses) THEN CALL DCircle_on_L12 (level = 1, x = x1p, y = y0p, radius = 6.0D0, stroke = .TRUE., fill = .FALSE.) END IF IF (benchmark_points > 0.0D0) THEN CALL DNew_L12_Path (1, x0p, y0p + 0.6667D0 * benchmark_points) CALL DLine_to_L12 (x0p - 0.577D0 * benchmark_points, y0p - 0.333D0 * benchmark_points) CALL DLine_to_L12 (x0p + 0.577D0 * benchmark_points, y0p - 0.333D0 * benchmark_points) CALL DLine_to_L12 (x0p, y0p + 0.6667D0 * benchmark_points) CALL DEnd_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) IF (ai_using_color) THEN IF (gps_type == 1) THEN ! original *.gps file CALL DSet_Stroke_Color ('foreground') ELSE IF (gps_type == 2) THEN ! adjustments to velocity CALL DSet_Stroke_Color ('gray______') ELSE IF (gps_type == 3) THEN ! modified g*.nko file CALL DSet_Stroke_Color ('dark_blue_') ELSE IF (gps_type == 4) THEN ! color will vary, green -> bronze -> red with error (in sigmas) CALL DSet_Stroke_Color ('red_______') END IF ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DVector_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 DSet_Stroke_Color ('foreground') v_mps = 0.01D0 * mp_scale_denominator / (velocity_Ma * 1.D6 * sec_per_year) v_mma = v_mps * 1000.D0 * sec_per_year number8 = ADJUSTL(DASCII8(v_mma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 48.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8)//' mm/a') IF (ellipses) THEN CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 60.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = "(95%-c.") CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 72.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = "ellipse)") END IF ! ellipses CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 60.0D0 IF (ellipses) rightlegend_used_points = rightlegend_used_points + 24.0D0 ! for "(95%-c./ellipse)" ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') IF (gps_type == 1) THEN CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'geodetic') ELSE IF (gps_type == 2) THEN CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'adjustment to') ELSE IF (gps_type == 3) THEN CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'adjusted') ELSE IF (gps_type == 4) THEN CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Neokinema') END IF CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'velocity') number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 12.0D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(x '//TRIM(number8)//' Ma):') x0p = (x1_points + 29.0D0) - 14.17D0 x1p = x0p + 2 * 14.17D0 ! 1-cm-long vector, expressed in points y0p = 0.5D0 * (y1_points + y2_points) - 22.0D0 CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') IF (ellipses) THEN CALL DCircle_on_L12 (level = 1, x = x1p, y = y0p, radius = 6.0D0, stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, & & x_points = x1p + 9.D0, & & y_points = y0p, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = '95%-c.') END IF IF (benchmark_points > 0.0D0) THEN CALL DNew_L12_Path (1, x0p, y0p + 0.6667D0 * benchmark_points) CALL DLine_to_L12 (x0p - 0.577D0 * benchmark_points, y0p - 0.333D0 * benchmark_points) CALL DLine_to_L12 (x0p + 0.577D0 * benchmark_points, y0p - 0.333D0 * benchmark_points) CALL DLine_to_L12 (x0p, y0p + 0.6667D0 * benchmark_points) CALL DEnd_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) IF (ai_using_color) THEN IF (gps_type == 1) THEN ! original *.gps file CALL DSet_Stroke_Color ('foreground') ELSE IF (gps_type == 2) THEN ! adjustments to velocity CALL DSet_Stroke_Color ('magenta___') ELSE IF (gps_type == 3) THEN ! modified g*.nko file CALL DSet_Stroke_Color ('dark_blue_') ELSE IF (gps_type == 4) THEN ! color will vary, green -> bronze -> red with error (in sigmas) CALL DSet_Stroke_Color ('red_______') END IF ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DVector_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 DSet_Stroke_Color ('foreground') v_mps = 0.01D0 * mp_scale_denominator / (velocity_Ma * 1.D6 * sec_per_year) v_mma = v_mps * 1000.D0 * sec_per_year number8 = ADJUSTL(DASCII8(v_mma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 36.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)//' mm/a') CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58.D0 IF (ellipses) bottomlegend_used_points = bottomlegend_used_points + 36.D0 ! for "95%-c." END IF ! bottom or right legend WRITE (*,"('+Working on benchmark velocity vectors....DONE.')") IF (gps_type == 1) THEN IF (ALLOCATED(recorrelate_benchmark)) DEALLOCATE ( recorrelate_benchmark ) ! in LIFO order IF (ALLOCATED(benchmark_c12_mm2pera2)) DEALLOCATE ( benchmark_c12_mm2pera2 ) ELSE IF (gps_type == 2) THEN DEALLOCATE ( benchmark_Nlat_deg ) ! in LIFO order 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 (440, 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 DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( 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 DPress_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 DMake_Uvec (uvec4, uvec) ! center of element IF (m == 1) uvec_list(1:3, l_) = uvec(1:3) equat = DSQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.0D0) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF theta_ = DATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL 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 DPrincipal_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.D0).AND.((e1h*e2h) <= 0.D0).AND.((e1h*err) <= 0.D0) e2h_partitioned = (e2h /= 0.D0).AND.((e2h*e1h) <= 0.D0).AND.((e2h*err) <= 0.D0) err_partitioned = (err /= 0.D0).AND.((err*e1h) <= 0.D0).AND.((err*e2h) <= 0.D0) ! Decide how big largest symbol is (in terms of partitioned e3-e1). big_diff = 0.0D0 IF (e1h*e2h < 0.0D0) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.D0*DABS(e2h)) ELSE big_diff = MAX(big_diff, 2.D0*DABS(e1h)) END IF END IF IF (e1h*err < 0.0D0) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.D0*DABS(err)) ELSE big_diff = MAX(big_diff, 2.D0*DABS(e1h)) END IF END IF IF (e2h*err < 0.0D0) THEN IF (e2h_partitioned) THEN big_diff = MAX(big_diff, 2.D0*DABS(err)) ELSE big_diff = MAX(big_diff, 2.D0*DABS(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 DPrompt_for_Integer('Which mode do you want?',strainrate_mode012,strainrate_mode012) IF (strainrate_mode012 == 0) THEN CALL DPrompt_for_Real('What diameter should the symbols be, in points?',strainrate_diameter_points,strainrate_diameter_points) ELSE WRITE (*,"(/' Here is the distribution of 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 DPrompt_for_Real('What is the reference strain-rate, in /s?',ref_e3_minus_e1_persec,ref_e3_minus_e1_persec) CALL DPrompt_for_Real('What diameter should the reference strain-rate have, in points?',strainrate_diameter_points,strainrate_diameter_points) END IF WRITE (*,"(/' There will be ',I7,' tensors if they are not thinned.')") numel 2092 CALL DPrompt_for_Integer('What thinning factor ( >=1 ) do you want?',strain_thinner,strain_thinner) IF (strain_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") 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 DThin_on_Sphere (uvec_list, numel, strain_thinner, selected) CALL DBegin_Group ! of strain-rates CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells DO i = 1, numel IF (selected(i)) THEN uvec(1:3) = uvec_list(1:3, i) CALL DStrain_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 DEnd_Group ! of strain-rate tensors CALL Chooser (bottom, right) IF (right) THEN ! sample strain-rate in rightlegend CALL DBegin_Group ! text part of strain-rate in legend; begin with a gap rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points ! y2 is top of next text line CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Total') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'strain-rate, as') rightlegend_used_points = rightlegend_used_points + 20.D0 y2_points = y2_points - 20.D0 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'conjugate') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'microfaults:') rightlegend_used_points = rightlegend_used_points + 25.D0 ! 5 points extra for minigap y2_points = y2_points - 25.D0 ! symbol part of paleostress in legend; CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL DStrain_in_Plane (1, 0.8D0*x1_points + 0.2D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & -0.5D0*ref_e3_minus_e1_persec, 0.D0, 0.D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL DStrain_in_Plane (1, 0.5D0*x1_points + 0.5D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & 0.5D0*ref_e3_minus_e1_persec, 0.D0, -0.5D0*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL DStrain_in_Plane (1, 0.2D0*x1_points + 0.8D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & 0.5D0*ref_e3_minus_e1_persec, 0.D0, 0.D0, & & 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 - 2.0D0 IF (strainrate_mode012 > 0) THEN ! label with E3-E1 = # CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'E3 - E1 =') number8 = DASCII8(ref_e3_minus_e1_persec) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Diameter') ELSE ! mode012 = 2 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Area is') END IF ! mode 1 or 2 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 30.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'proportional to') rightlegend_used_points = rightlegend_used_points + 40.D0 y2_points = y2_points - 40.D0 ELSE ! all symbols are of equal size CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Size is') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'independent of') rightlegend_used_points = rightlegend_used_points + 20.D0 y2_points = y2_points - 20.D0 END IF ! labelling with numerical strainrate, or not CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'strain-rate.)') rightlegend_used_points = rightlegend_used_points + 10.D0 y2_points = y2_points - 10.D0 CALL DEnd_Group ELSE IF (bottom) THEN ! sample strain-rate in bottomlegend CALL DBegin_Group ! text part of strain-rate in legend; begin with a gap CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Total') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'strain-rate, as') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'conjugate') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) -20.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'microfaults:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.D0 ! text1 only ! symbol part of paleostress in legend; CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL DStrain_in_Plane (1, x1_points + 14.D0, & & 0.5D0*(y1_points + y2_points), & & -0.5D0*ref_e3_minus_e1_persec, 0.D0, 0.D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL DStrain_in_Plane (1, x1_points + 36.D0, & & 0.5D0*(y1_points + y2_points), & & 0.5D0*ref_e3_minus_e1_persec, 0.D0, -0.5D0*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL DStrain_in_Plane (1, x1_points + 58.D0, & & 0.5D0*(y1_points + y2_points) , & & 0.5D0*ref_e3_minus_e1_persec, 0.D0, 0.D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) bottomlegend_used_points = bottomlegend_used_points + 72.D0 ! now, including middle symbols block x1_points = x1_points + 72.D0 !note that x1_points now indicates right side of middle symbol block IF (strainrate_mode012 > 0) THEN ! label with e3-e1 = # CALL DL12_Text (level = 1, & & x_points = x1_points - 36.D0, & & y_points = y1_points + 8.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'E3 - E1 =') number8 = DASCII8(ref_e3_minus_e1_persec) CALL DL12_Text (level = 1, & & x_points = x1_points - 36.D0, & & y_points = y1_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Diameter') ELSE ! mode012 = 2 CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Area is') END IF ! mode 1 or 2 CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'proportional to') ELSE ! all symbols are of equal size CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Size is') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'independent of') END IF ! labelling with numerical strainrate, or not CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'strain-rate.)') CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + 72.D0 ! right text block END IF ! sample strain-rate in bottom/right legend WRITE (*,"('+Working on strain-rates....DONE.')") CALL BEEPQQ (440, 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 DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( 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 DPress_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 DMake_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 DMake_Uvec (uvec4, uvec) ! center of element equat = DSQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.0D0) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF IF (m == 1) uvec_list(1:3, l_) = uvec(1:3) theta_ = DATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL 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 DPrincipal_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.0D0).AND.((e1h*e2h) <= 0.0D0).AND.((e1h*err) <= 0.0D0) e2h_partitioned = (e2h /= 0.0D0).AND.((e2h*e1h) <= 0.0D0).AND.((e2h*err) <= 0.0D0) err_partitioned = (err /= 0.0D0).AND.((err*e1h) <= 0.0D0).AND.((err*e2h) <= 0.0D0) ! Decide how big largest symbol is (in terms of partitioned e3-e1). big_diff = 0.0D0 IF (e1h*e2h < 0.0D0) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.D0*DABS(e2h)) ELSE big_diff = MAX(big_diff, 2.D0*DABS(e1h)) END IF END IF IF (e1h*err < 0.0D0) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.D0*DABS(err)) ELSE big_diff = MAX(big_diff, 2.D0*DABS(e1h)) END IF END IF IF (e2h*err < 0.0D0) THEN IF (e2h_partitioned) THEN big_diff = MAX(big_diff, 2.D0*DABS(err)) ELSE big_diff = MAX(big_diff, 2.D0*DABS(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 DPrompt_for_Integer('Which mode do you want?',strainrate_mode012,strainrate_mode012) IF (strainrate_mode012 == 0) THEN CALL DPrompt_for_Real('What diameter should the symbols be, in points?',strainrate_diameter_points,strainrate_diameter_points) ELSE WRITE (*,"(/' Here is the distribution of 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.0D0) ref_e3_minus_e1_persec = maximum CALL DPrompt_for_Real('What is the reference strain-rate, in /s?',ref_e3_minus_e1_persec,ref_e3_minus_e1_persec) CALL DPrompt_for_Real('What diameter should the reference strain-rate have, in points?',strainrate_diameter_points,strainrate_diameter_points) END IF WRITE (*,"(/' There will be ',I7,' tensors if they are not thinned.')") numel 2102 CALL DPrompt_for_Integer('What thinning factor ( >=1 ) do you want?',strain_thinner,strain_thinner) IF (strain_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") 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 modeled faults') ELSE ! == 1 CALL Add_Title('Continuum Strain-Rate Tensors, excluding modeled faults') END IF WRITE (*,"(/' Working on strain-rates....')") CALL DThin_on_Sphere (uvec_list, numel, strain_thinner, selected) CALL DBegin_Group ! of strain-rates CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells DO i = 1, numel IF (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 DMake_Uvec(uvec4, uvec) CALL DStrain_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 DEnd_Group ! of strain-rate tensors CALL Chooser (bottom, right) IF (right) THEN ! sample strain-rate in rightlegend CALL DBegin_Group ! text part of strain-rate in legend; begin with a gap rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points ! y2 is top of next text line CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Strain-rate of') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'continuum, as') rightlegend_used_points = rightlegend_used_points + 20.D0 y2_points = y2_points - 20.D0 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'conjugate') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'microfaults:') rightlegend_used_points = rightlegend_used_points + 25.D0 ! 5 points extra for minigap y2_points = y2_points - 25.D0 ! symbol part of paleostress in legend; CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL DStrain_in_Plane (1, 0.8D0*x1_points + 0.2D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & -0.5D0*ref_e3_minus_e1_persec, 0.D0, 0.D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL DStrain_in_Plane (1, 0.5D0*x1_points + 0.5D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & 0.5D0*ref_e3_minus_e1_persec, 0.D0, -0.5D0*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL DStrain_in_Plane (1, 0.2D0*x1_points + 0.8D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & 0.5D0*ref_e3_minus_e1_persec, 0.D0, 0.D0, & & 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 - 2.0D0 IF (strainrate_mode012 > 0) THEN ! label with e3-e1 = # CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'E3 - E1 =') number8 = DASCII8(ref_e3_minus_e1_persec) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Diameter') ELSE ! mode012 = 2 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Area is') END IF ! mode 1 or 2 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 30.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'proportional to') rightlegend_used_points = rightlegend_used_points + 40.D0 y2_points = y2_points - 40.D0 ELSE ! all symbols are of equal size CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Size is') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'independent of') rightlegend_used_points = rightlegend_used_points + 20.D0 y2_points = y2_points - 20.D0 END IF ! labelling with numerical strainrate, or not CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'strain-rate.)') rightlegend_used_points = rightlegend_used_points + 10.D0 y2_points = y2_points - 10.D0 CALL DEnd_Group ELSE IF (bottom) THEN ! sample strain-rate in bottomlegend CALL DBegin_Group ! text part of strain-rate in legend; begin with a gap CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Strain-rate of') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'continuum, as') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'conjugate') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) -20.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'microfaults:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.D0 ! text1 only ! symbol part of paleostress in legend; CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL DStrain_in_Plane (1, x1_points + 14.D0, & & 0.5D0*(y1_points + y2_points), & & -0.5D0*ref_e3_minus_e1_persec, 0.D0, 0.D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL DStrain_in_Plane (1, x1_points + 36.D0, & & 0.5D0*(y1_points + y2_points), & & 0.5D0*ref_e3_minus_e1_persec, 0.D0, -0.5D0*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL DStrain_in_Plane (1, x1_points + 58.D0, & & 0.5D0*(y1_points + y2_points) , & & 0.5D0*ref_e3_minus_e1_persec, 0.D0, 0.D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) bottomlegend_used_points = bottomlegend_used_points + 72.D0 ! now, including middle symbols block x1_points = x1_points + 72.D0 !note that x1_points now indicates right side of middle symbol block IF (strainrate_mode012 > 0) THEN ! label with e3-e1 = # CALL DL12_Text (level = 1, & & x_points = x1_points - 36.D0, & & y_points = y1_points + 8.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'E3 - E1 =') number8 = DASCII8(ref_e3_minus_e1_persec) CALL DL12_Text (level = 1, & & x_points = x1_points - 36.D0, & & y_points = y1_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Diameter') ELSE ! mode012 = 2 CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Area is') END IF ! mode 1 or 2 CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'proportional to') ELSE ! all symbols are of equal size CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Size is') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'independent of') END IF ! labelling with numerical strainrate, or not CALL DL12_Text (level = 1, & & x_points = x1_points + 36.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'strain-rate.)') CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + 72.D0 ! right text block END IF ! sample strain-rate in bottom/right legend WRITE (*,"('+Working on strain-rates....DONE.')") CALL BEEPQQ (440, 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 DPrompt_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 DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( 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 DPress_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 DPrompt_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 DPress_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 DPrompt_for_Real('How long should the symbols be, in points?',e1_size_points,e1_size_points) WRITE (*,"(/' There will be ',I7,' symbols if they are not thinned.')") numel 2112 CALL DPrompt_for_Integer('What thinning factor ( >=1 ) do you want?',strain_thinner,strain_thinner) IF (strain_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") 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 DMake_Uvec (uvec1, uvec) ! center of element uvec_list(1:3, l_) = uvec(1:3) END DO ! l_ = 1, numel CALL DThin_on_Sphere (uvec_list, numel, strain_thinner, selected) CALL DBegin_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 = DSQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.0D0) THEN PRINT "(' Error: center of element ',I5,' is N or S pole.')", l_ WRITE (21,"('Error: center of element ',I5,' is N or S pole.')") l_ STOP ' ' END IF theta_ = DATAN2(equat, uvec(3)) uvec1(1:3) = node_uvec(1:3, nodes(1, l_)) uvec2(1:3) = node_uvec(1:3, nodes(2, l_)) uvec3(1:3) = node_uvec(1:3, nodes(3, l_)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) ! compute 3 principal values, and partition one with unique sign CALL DPrincipal_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 = DATan2F(u1phi, -u1theta) eh_max = MAX(DABS(e1h),DABS(e2h)) offset_radians = DConformal_Deflation(uvec) * ((0.5D0*e1_size_points/2835.D0) & & * mp_scale_denominator) / mp_radius_meters IF (ai_using_color) THEN ! wide line of green (s-s), mid_blue (thrust), or bronze (normal) CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) IF (DABS(err) <= (0.2D0 * eh_max)) THEN CALL DSet_Stroke_Color('green_____') ! strike-slip ELSE IF (err > 0.D0) THEN CALL DSet_Stroke_Color('mid_blue__') ! thrust ELSE CALL DSet_Stroke_Color('bronze____') ! normal END IF ! different colors CALL DTurn_To (azimuth_radians = s1h_azim_radians, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL DTurn_To (azimuth_radians = s1h_azim_radians+Pi, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DNew_L45_Path(5,uvec1) CALL DGreat_to_L45(uvec2) CALL DEnd_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 DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) IF (DABS(err) <= (0.2D0 * eh_max)) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'gray______') ! strike-slip stroke_this = .FALSE. ELSE IF (err > 0.D0) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') ! thrust stroke_this = .FALSE. ELSE CALL DSet_Fill_or_Pattern(.FALSE.,'background') ! normal stroke_this = .TRUE. END IF ! different grays CALL DTurn_To (azimuth_radians = s1h_azim_radians+0.10D0, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL DNew_L45_Path(5,uvec1) CALL DTurn_To (azimuth_radians = s1h_azim_radians-0.10D0, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DGreat_to_L45(uvec2) CALL DTurn_To (azimuth_radians = s1h_azim_radians+Pi+0.10D0, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DGreat_to_L45(uvec2) CALL DTurn_To (azimuth_radians = s1h_azim_radians+Pi-0.10D0, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL DGreat_to_L45(uvec2) CALL DGreat_to_L45(uvec1) CALL DEnd_L45_Path(close = .TRUE., stroke = stroke_this, fill = .TRUE.) END IF END IF ! selected for plotting END DO ! l_ = 1, numel, computing strainrates CALL DEnd_Group ! s1h directions on map CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = "foreground") ! for text CALL DBegin_Group ! sample s1h directions in legend CALL Chooser (bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points xcp = (x1_points + x2_points)/2.D0 CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.D0, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Model e1h') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20.D0, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'direction and') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-30.D0, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'strain-rate regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('bronze____') CALL DSet_Line_Style (width_points = 3.00D0, dashed = .FALSE.) CALL DNew_L12_Path(1, xcp-4.D0, y2_points-40.D0) CALL DLine_to_L12(xcp-28.D0, y2_points-40.D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'background') CALL DNew_L12_Path(1,xcp-4.D0, y2_points-40.D0-1.5D0) CALL DLine_to_L12(xcp-4.D0, y2_points-40.D0+1.5D0) CALL DLine_to_L12(xcp-28.D0, y2_points-40.D0+1.5D0) CALL DLine_to_L12(xcp-28.D0, y2_points-40.D0-1.5D0) CALL DLine_to_L12(xcp-4.D0, y2_points-40.D0-1.5D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL DSet_Line_Style (width_points = 3.00D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-40.D0, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'normal') IF (ai_using_color) THEN CALL DSet_Stroke_Color('green_____') ELSE CALL DSet_Stroke_Color('gray______') END IF CALL DNew_L12_Path(1, xcp-4.D0, y2_points-50.D0) CALL DLine_to_L12(xcp-28.D0, y2_points-50.D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-50.D0, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'strike-slip') IF (ai_using_color) THEN CALL DSet_Stroke_Color('mid_blue__') ELSE CALL DSet_Stroke_Color('foreground') END IF CALL DNew_L12_Path(1, xcp-4.D0, y2_points-60.D0) CALL DLine_to_L12(xcp-28.D0, y2_points-60.D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-60.D0, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 64.D0 ELSE ! bottom CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points)/2.D0 CALL DL12_Text (level = 1, x_points = x1_points+72.D0, & & y_points = ycp+10.D0, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Model e1h') CALL DL12_Text (level = 1, x_points = x1_points+72.D0, & & y_points = ycp, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'direction and') CALL DL12_Text (level = 1, x_points = x1_points+72.D0, & & y_points = ycp-10.D0, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'strain regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('bronze____') CALL DSet_Line_Style (width_points = 3.00D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+76.D0, ycp+10.D0) CALL DLine_to_L12(x1_points+100.D0, ycp+10.D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'background') CALL DNew_L12_Path(1, x1_points+76.D0, ycp+10.D0-1.5D0) CALL DLine_to_L12(x1_points+100.D0, ycp+10.D0-1.5D0) CALL DLine_to_L12(x1_points+100.D0, ycp+10.D0+1.5D0) CALL DLine_to_L12(x1_points+76.D0, ycp+10.D0+1.5D0) CALL DLine_to_L12(x1_points+76.D0, ycp+10.D0-1.5D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL DSet_Line_Style (width_points = 3.00D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+104.D0, & & y_points = ycp+10.D0, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'normal') IF (ai_using_color) THEN CALL DSet_Stroke_Color('green_____') ELSE CALL DSet_Stroke_Color('gray______') END IF CALL DNew_L12_Path(1, x1_points+76.D0, ycp) CALL DLine_to_L12(x1_points+100.D0, ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+104.D0, & & y_points = ycp, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'strike-slip') IF (ai_using_color) THEN CALL DSet_Stroke_Color('mid_blue__') ELSE CALL DSet_Stroke_Color('foreground') END IF CALL DNew_L12_Path(1, x1_points+76.D0, ycp-10.D0) CALL DLine_to_L12(x1_points+100.D0, ycp-10.D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+104.D0, & & y_points = ycp-10.D0, & & angle_radians = 0.D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 140.D0 END IF ! right or bottom CALL DEnd_Group ! sample s1h directions in legend WRITE (*,"(/' Working on e1h directions....DONE.')") CALL BEEPQQ (440, 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 DPrompt_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 DCheck_for_Tabs(21) IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL DPress_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.0D0 ELSE IF ((s1h_sigma_c1 == 'B').OR.(s1h_sigma_c1 == 'b')) THEN ! per Zoback (1992): 12 < s.d. <= 25 s1h_sigma_degrees = 18.0D0 ELSE IF ((s1h_sigma_c1 == 'C').OR.(s1h_sigma_c1 == 'c')) THEN s1h_sigma_degrees = 30.0D0 ELSE IF ((s1h_sigma_c1 == 'D').OR.(s1h_sigma_c1 == 'e')) THEN s1h_sigma_degrees = 40.0D0 ELSE ! quality E; per Zoback (1992) : s.d. > 40 s1h_sigma_degrees = 50.0D0 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 DLonLat_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 DPrompt_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 DBegin_Group ! foreground-bounded background-colored wedges for 90% confidence limits CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radians = (0.6D0 * s1_size_points * 3.528D-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, s_nki_count valid_azimuth = ((s_azim(i) >= -3.142D0).AND.(s_azim(i) <= 6.284D0)) IF (valid_azimuth) THEN del_az_for_90pc = s_sigma_(i) * 1.645D0 uvec(1:3) = s_site(1:3, i) IF (del_az_for_90pc < Pi_over_2) THEN ! two sectors CALL DNew_L45_Path(5, uvec) CALL DTurn_To (s_azim(i)+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DGreat_to_L45(uvec1) CALL DTurn_To (s_azim(i)-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DSmall_to_L45(uvec, uvec2) CALL DGreat_to_L45(uvec) CALL DEnd_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL DNew_L45_Path(5, uvec) CALL DTurn_To (s_azim(i)+Pi+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DGreat_to_L45(uvec1) CALL DTurn_To (s_azim(i)+Pi-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DSmall_to_L45(uvec, uvec2) CALL DGreat_to_L45(uvec) CALL DEnd_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ELSE ! complete small circle CALL DTurn_To (0.0D0, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DNew_L45_Path(5, uvec1) CALL DSmall_to_L45(uvec, uvec1) CALL DEnd_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! sectors or circle END IF ! valid_azimuth END DO CALL DEnd_Group ! end of 90%-confidence limits CALL DBegin_Group ! stress indicator bar (solid if definately relevant) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radians = (0.5D0 * s1_size_points * 3.528D-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, s_nki_count valid_azimuth = ((s_azim(i) >= -3.142D0).AND.(s_azim(i) <= 6.284D0)) IF (valid_azimuth) THEN uvec(1:3) = s_site(1:3, i) CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.D0)), dashed = .FALSE.) CALL DTurn_To (s_azim(i), uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DNew_L45_Path(5, uvec1) CALL DTurn_To (s_azim(i)+Pi, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DGreat_to_L45(uvec2) CALL DEnd_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 DEnd_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 DBegin_Group ! text part of paleostress in legend CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Actual s1h') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'direction,') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '90%-confidence') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 30.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'sectors:') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 45.D0 ! text only ! symbol part of paleostress in legend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radius = 0.6D0 * s1_size_points xcp = (x1_points + x2_points)/2.D0 ycp = y2_points - radius * 0.5D0 CALL DNew_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.866D0 y0p = ycp - radius * 0.5D0 CALL DLine_to_L12 (x0p,y0p) x1p = x0p + radius * 0.5523D0 * 0.66667D0 * 0.5D0 y1p = y0p + radius * 0.5523D0 * 0.66667D0 * 0.866D0 x3p = x0p y3p = ycp + radius * 0.5D0 x2p = x1p y2p = y3p - radius * 0.5523D0 * 0.66667D0 * 0.866D0 CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x0p = xcp - (x0p - xcp) x1p = xcp - (x1p - xcp) x2p = x1p x3p = x0p CALL DNew_L12_Path(1,xcp,ycp) CALL DLine_to_L12 (x0p,y0p) CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.D0)), dashed = .FALSE.) radius = 0.5D0 * s1_size_points x0p = xcp - radius x1p = xcp + radius CALL DNew_L12_Path(1,x0p,ycp) CALL DLine_to_L12(x1p,ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + radius ! symbol only CALL DEnd_Group ELSE IF (bottom) THEN ! sample paleostress in bottomlegend CALL DBegin_Group ! text part of paleostress in legend CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 15.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Actual s1h') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 5.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'direction,') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 5.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = '90%-confidence') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 15.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'sectors:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.D0 ! text only ! symbol part of paleostress in legend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) radius = 0.6D0 * s1_size_points x1_points = x1_points + bottomlegend_used_points + radius xcp = x1_points ycp = (y1_points + y2_points)/2.D0 CALL DNew_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.5D0 y0p = ycp + radius * 0.866D0 CALL DLine_to_L12 (x0p,y0p) x1p = x0p - radius * 0.5523D0 * 0.66667D0 * 0.866D0 y1p = y0p + radius * 0.5523D0 * 0.66667D0 * 0.5D0 x3p = xcp - radius * 0.5D0 y3p = y0p x2p = x3p + radius * 0.5523D0 * 0.66667D0 * 0.866D0 y2p = y1p CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) y0p = ycp - (y0p - ycp) y1p = ycp - (y1p - ycp) y2p = y1p y3p = y0p CALL DNew_L12_Path(1,xcp,ycp) CALL DLine_to_L12 (x0p,y0p) CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.D0)), dashed = .FALSE.) radius = 0.5D0 * s1_size_points y0p = ycp - radius y1p = ycp + radius CALL DNew_L12_Path(1,xcp,y0p) CALL DLine_to_L12(xcp,y1p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + radius ! symbol only CALL DEnd_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 (440, 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 DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( center(3,numel) ) ALLOCATE ( selected(numel) ) ALLOCATE ( s1h_known(numel) ) ALLOCATE ( 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 DPrompt_for_Real('How long should the symbols be, in points?',s1h_interp_points,s1h_interp_points) WRITE (*,"(/' There will be ',I7,' interpolated stresses if they are not thinned.')") numel 2131 CALL DPrompt_for_Integer('What thinning factor ( >=1 ) do you want?',stress_thinner,stress_thinner) IF (stress_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") GO TO 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.0D0 CALL DMake_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 DUvec_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.D0) THEN ! per on-line WSM criteria ! quality_c1 = 'A' ! ELSE IF (s1h_sigma_degrees <= 20.D0) THEN ! quality_c1 = 'B' ! ELSE IF (s1h_sigma_degrees <= 25.D0) THEN ! quality_c1 = 'C' ! ELSE ! s1h_sigma_degrees < 27.6D0 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 DThin_on_Sphere (center, numel, stress_thinner, selected) CALL DPrompt_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 DBegin_Group ! foreground-bounded background-colored wedges for 90% confidence limits CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radians = (0.4D0 * s1h_interp_points * 3.528D-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, numel IF (((only_stressed).AND.(s1h_known(i))) .OR. & & ((.NOT.only_stressed).AND.(s_azim(i) /= 0.0D0))) THEN IF (selected(i)) THEN del_az_for_90pc = s_sigma_(i) * 1.645D0 uvec(1:3) = center(1:3,i) CALL DNew_L45_Path(5, uvec) CALL DTurn_To (s_azim(i)+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DGreat_to_L45(uvec1) CALL DTurn_To (s_azim(i)-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DSmall_to_L45(uvec, uvec2) CALL DGreat_to_L45(uvec) CALL DEnd_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL DNew_L45_Path(5, uvec) CALL DTurn_To (s_azim(i)+Pi+del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DGreat_to_L45(uvec1) CALL DTurn_To (s_azim(i)+Pi-del_az_for_90pc, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DSmall_to_L45(uvec, uvec2) CALL DGreat_to_L45(uvec) CALL DEnd_L45_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF ! selected(i) END IF ! s1h_known(i) END DO ! i = 1, numel CALL DEnd_Group ! end of 90%-confidence limits for interpolated stresses CALL DBegin_Group ! interpolated stress indicator bar IF (ai_using_color) THEN CALL DSet_Stroke_Color ('brick_____') ELSE CALL DSet_Stroke_Color ('gray______') END IF CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1h_interp_points / 8.0D0)), dashed = .FALSE.) radians = (0.5D0 * s1h_interp_points * 3.528D-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, numel IF (((only_stressed).AND.(s1h_known(i))) .OR. & & ((.NOT.only_stressed).AND.(s_azim(i) /= 0.0D0))) THEN IF (selected(i)) THEN uvec(1:3) = center(1:3,i) CALL DTurn_To (s_azim(i), uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DNew_L45_Path(5, uvec1) CALL DTurn_To (s_azim(i)+Pi, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DGreat_to_L45(uvec2) CALL DEnd_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! selected(i) END IF ! s1h_known(i) END DO ! i = 1, numel CALL DEnd_Group ! of interpolated stress-direction bars DEALLOCATE ( node_uvec, center, selected, nodes, s1h_known, s_azim, s_sigma_ ) CALL Chooser (bottom, right) IF (right) THEN ! sample interpolated stress in rightlegend CALL DBegin_Group ! text part of paleostress in legend CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Interpolated') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'stress direction,') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '90%-confidence') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 30.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'sectors:') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 45.D0 ! text only ! symbol part of paleostress in legend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radius = 0.4D0 * s1h_interp_points ! (was 0.6 for stress data, where sigma may be small) xcp = (x1_points + x2_points)/2.0D0 ycp = y2_points - radius * 0.5D0 CALL DNew_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.866D0 y0p = ycp - radius * 0.5D0 CALL DLine_to_L12 (x0p,y0p) x1p = x0p + radius * 0.5523D0 * 0.66667D0 * 0.5D0 y1p = y0p + radius * 0.5523D0 * 0.66667D0 * 0.866D0 x3p = x0p y3p = ycp + radius * 0.5D0 x2p = x1p y2p = y3p - radius * 0.5523D0 * 0.66667D0 * 0.866D0 CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x0p = xcp - (x0p - xcp) x1p = xcp - (x1p - xcp) x2p = x1p x3p = x0p CALL DNew_L12_Path(1,xcp,ycp) CALL DLine_to_L12 (x0p,y0p) CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself IF (ai_using_color) THEN CALL DSet_Stroke_Color ('brick_____') ELSE CALL DSet_Stroke_Color ('gray______') END IF CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1h_interp_points / 8.0D0)), dashed = .FALSE.) radius = 0.5D0 * s1h_interp_points x0p = xcp - radius x1p = xcp + radius CALL DNew_L12_Path(1,x0p,ycp) CALL DLine_to_L12(x1p,ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + radius ! symbol only CALL DEnd_Group ELSE IF (bottom) THEN ! sample interpolated stress in bottomlegend CALL DBegin_Group ! text part of paleostress in bottomlegend CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'Interpolated') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'stress direction,') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = '90%-confidence') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 20.D0, & & angle_radians = 0.D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.0D0, & & text = 'sectors:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.D0 ! text only ! symbol part of paleostress in bottomlegend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + 6.D0 CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radius = 0.4D0 * s1h_interp_points ! (was 0.6 for stress data, where sigma may be small) xcp = x1_points + radius * 0.5D0 ycp = (y1_points + y2_points)/2.0D0 CALL DNew_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.5D0 y0p = ycp + radius * 0.866D0 CALL DLine_to_L12 (x0p,y0p) x1p = x0p - radius * 0.5523D0 * 0.66667D0 * 0.866D0 y1p = y0p + radius * 0.5523D0 * 0.66667D0 * 0.5D0 x3p = xcp - radius * 0.5D0 y3p = y0p x2p = x3p + radius * 0.5523D0 * 0.66667D0 * 0.866D0 y2p = y1p CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) y0p = ycp - (y0p - ycp) y1p = ycp - (y1p - ycp) y2p = y1p y3p = y0p CALL DNew_L12_Path(1,xcp,ycp) CALL DLine_to_L12 (x0p,y0p) CALL DCurve_to_L12(x1p,y1p, x2p,y2p, x3p,y3p) CALL DLine_to_L12(xcp,ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself IF (ai_using_color) THEN CALL DSet_Stroke_Color ('brick_____') ELSE CALL DSet_Stroke_Color ('gray______') END IF CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1h_interp_points / 8.0D0)), dashed = .FALSE.) radius = 0.5D0 * s1h_interp_points y0p = ycp - radius y1p = ycp + radius CALL DNew_L12_Path(1,xcp,y0p) CALL DLine_to_L12(xcp,y1p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + 6.0D0 + radius ! symbol only CALL DEnd_Group END IF ! sample interpolated stress in bottom/right legend WRITE (*,"('+Working on stresses interpolated by NeoKinema....DONE.')") CALL BEEPQQ (440, 250) ! end of 13 :: stresses interpolated by NeoKinema CASE (14) ! earthquake epicenters/epicentroids and/or FPSs 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 DPrompt_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 DPress_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 IF (ios == 0) THEN valid_FPS = (e1_plunge /= 0).OR.(e1_azimuth /= 0).OR. & & (e2_plunge /= 0).OR.(e2_azimuth /= 0).OR. & & (e3_plunge /= 0).OR.(e3_azimuth /= 0) ELSE valid_FPS = .FALSE. END IF any_FPS = any_FPS .OR. valid_FPS END DO scanning_eqc CLOSE (22) IF (any_FPS) THEN CALL DPrompt_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 DPrompt_for_Real('What is the smallest magnitude to plot?',min_mag,min_mag) IF (min_mag > 8.0D0) THEN WRITE (*, "(' ERROR: Smallest magnitude cannot exceed 8.0')") min_mag = 8.0D0 GO TO 2143 END IF CALL DPrompt_for_Real('What diameter (in points) for magnitude 8.0?',m8_diam_points,m8_diam_points) d1 = MAX((m8_diam_points - 2.0D0), 0.0D0)/MAX((8.0D0 - min_mag), 1.0D0) d0 = 2.3D0 - 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.3D0) - d1 * 8.0D0) ! 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 DSet_Line_Style (0.6D0, .FALSE.) CALL DBegin_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 IF (ios == 0) THEN valid_FPS = (e1_plunge /= 0).OR.(e1_azimuth /= 0).OR. & & (e2_plunge /= 0).OR.(e2_azimuth /= 0).OR. & & (e3_plunge /= 0).OR.(e3_azimuth /= 0) ELSE valid_FPS = .FALSE. END IF radius_points = 0.5D0 *(d0 + d1 * eq_mag) IF ((eq_mag >= min_mag).AND.(radius_points >= 1.0D0)) THEN ! large enough to plot IF (valid_FPS.AND.plot_FPS.AND.(radius_points >= 3.0D0)) THEN ! plot as FPS ! (1) Plot a small cross to mark position if FPS circle must be pulled aside: CALL DLonLat_2_Uvec (eq_Elon, eq_Nlat, uvec) radians_per_point = (3.527777D-4)*(mp_scale_denominator*DConformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = 3.0D0 * radians_per_point ! each arm of cross CALL DTurn_To (azimuth_radians = 0.0D0, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DNew_L45_Path (5, result_uvec) CALL DTurn_To (azimuth_radians = Pi, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DGreat_to_L45 (result_uvec) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DTurn_To (azimuth_radians = Pi_over_2, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DNew_L45_Path (5, result_uvec) CALL DTurn_To (azimuth_radians = -Pi_over_2, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DGreat_to_L45 (result_uvec) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DBegin_Group ! for this one FPS symbol ! (2) Find Northward direction at epicenter, and express as ! an argument (counterclockwise from right, in radians): CALL DLonLat_2_Uvec (eq_Elon, eq_Nlat, uvec) radians_per_point = (3.527777D-4)*(mp_scale_denominator*DConformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = radius_points * radians_per_point CALL DTurn_To (azimuth_radians = 0.0D0, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DProject (uvec = uvec, x = epicenter_x_m, y = epicenter_y_m) CALL DProject (uvec = result_uvec, x = offset_x_m, y = offset_y_m) CALL DMeters_2_Points (epicenter_x_m,epicenter_y_m, epicenter_x_points,epicenter_y_points) CALL DMeters_2_Points (offset_x_m,offset_y_m, offset_x_points,offset_y_points) North_argument_radians = DATan2F((offset_y_points - epicenter_y_points), & &(offset_x_points - epicenter_x_points)) ! (3) Plot a white background circle (even for slide copy!): CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DLonLat_2_Uvec (eq_Elon, eq_Nlat, uvec) radians_per_point = (3.527777D-4)*(mp_scale_denominator*DConformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = radius_points * radians_per_point CALL DTurn_To (azimuth_radians = 0.0D0, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DNew_L45_Path (5, result_uvec) CALL DSmall_to_L45 (uvec, result_uvec) ! complete small circle CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ! (4) Save state of module Map_Projections: CALL DSave_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 DSet_Zoom (scale_denominator = 1.0D0, & & x_center_meters = ai_window_xc_points / 2834.65D0, & & y_center_meters = ai_window_yc_points / 2834.65D0, & & xy_wrt_page_radians = 0.0D0) CALL DSet_Stereographic (radius_meters = 0.5D0 * radius_points / 2834.65D0, & ! factor 0.5 counters stereographic blowup of outer circle & projpoint_uvec = (/ -0.01745241D0, 0.0D0, 0.9998477D0 /), & & x_projpoint_meters = epicenter_x_points / 2834.65D0, & & y_projpoint_meters = epicenter_y_points / 2834.65D0, & & y_azimuth_radians = North_argument_radians - Pi_over_2) ! (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 DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') e1_lon = -1.0D0 * e1_azimuth e2_lon = -1.0D0 * e2_azimuth e3_lon = -1.0D0 * e3_azimuth e1_lat = 1.0D0 * e1_plunge e2_lat = 1.0D0 * e2_plunge e3_lat = 1.0D0 * e3_plunge CALL DLonLat_2_Uvec (lon = e1_lon, lat = e1_lat, uvec = e1_f_uvec) ! front or visible end CALL DLonLat_2_Uvec (lon = e2_lon, lat = e2_lat, uvec = e2_f_uvec) ! front or visible end CALL DLonLat_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 DCross (e1_f_uvec, e2_f_uvec, tvec) ! replacing e3, now perp. to e2 IF (tvec(3) < 0.0D0) tvec = -tvec CALL DMake_Uvec (tvec, e3_f_uvec) CALL DCross (e2_f_uvec, e3_f_uvec, tvec) ! replacing e1, now perp. to both IF (tvec(3) < 0.0D0) tvec = -tvec CALL DMake_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 DMake_uvec (tvec, turn_1_uvec) ! pole of 1st small circle arc tvec = e3_f_uvec + e1_f_uvec CALL DMake_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 !Actually plot the two black sectors on the tiny world. !Note: 2015 version of NeoKineMap must use revert to using DOld_Complex_Process_L5_Paths() ! in order to get along-rind-edge completion of the outlines of these melon-wedges. ! This is achieved by adding new OPTIONAL argument retro = .TRUE. ! in the CALL to DEnd_L5_Path(). !First melon-wedge: CALL DNew_L45_Path (5, e2_f_uvec) CALL DSmall_To_L45 (pole_uvec = turn_1_uvec, to_uvec = e2_b_uvec) ! front to back {old-school, single-segment CALL} CALL DSmall_To_L45 (pole_uvec = turn_2_uvec, to_uvec = e2_f_uvec) ! back to front {old-school, single-segment CALL} CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE., retro = .TRUE.) ! <=== NOTE: retro = .TRUE. !Second melon-wedge: CALL DNew_L45_Path (5, e2_f_uvec) CALL DSmall_To_L45 (pole_uvec = turn_3_uvec, to_uvec = e2_b_uvec) ! front to back {old-school, single-segment CALL} CALL DSmall_To_L45 (pole_uvec = turn_4_uvec, to_uvec = e2_f_uvec) ! back to front {old-school, single-segment CALL} CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE., retro = .TRUE.) ! <=== NOTE: retro = .TRUE. ! (7) Reset (saved) state of module Map_Projections CALL DRestore_mp_State () ! (8) Plot the outer circle of lower focal hemisphere CALL DSet_Stroke_Color ('foreground') CALL DLonLat_2_Uvec (eq_Elon, eq_Nlat, uvec) radians_per_point = (3.527777D-4)*(mp_scale_denominator*DConformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = radius_points * radians_per_point CALL DTurn_To (azimuth_radians = 0.0D0, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DNew_L45_Path (5, result_uvec) CALL DSmall_to_L45 (uvec, result_uvec) ! complete small circle CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) CALL DEnd_Group ! for this one FPS symbol ELSE ! plot as solid dot ! EQs have black fill with white outline (to separate points) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DSet_Stroke_Color ('background') CALL DLonLat_2_Uvec (eq_Elon, eq_Nlat, uvec) radians_per_point = (3.527777D-4)*(mp_scale_denominator*DConformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = radius_points * radians_per_point CALL DTurn_To (azimuth_radians = 0.0D0, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DNew_L45_Path (5, result_uvec) CALL DSmall_to_L45 (uvec, result_uvec) ! complete small circle CALL DEnd_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 DEnd_Group CLOSE(22) !sample EQ magnitudes in the margin CALL Chooser (bottom, right) IF (bottom.OR.right) THEN m1 = DInt_Above(min_mag) m2 = 8 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') ! EQs have black fill with white outline (to separate points) CALL DSet_Stroke_Color ('background') CALL DSet_Line_Style (0.6D0, .FALSE.) CALL DBegin_Group IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x_used_points = 0.0D0 yp = (y1_points + y2_points) / 2.0D0 DO i = m1, m2 radius_points = 0.5D0 * (d0 + d1 * i) xp = x1_points + bottomlegend_used_points + x_used_points + radius_points + 6.0D0 CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) ypt = yp - radius_points - 12.0D0 WRITE (c1, "(I1)") i CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.5D0, 0.0D0, & & c1) x_used_points = x_used_points + 2.0D0 * radius_points + 6.0D0 END DO IF (any_FPS.AND.plot_FPS) THEN ! sample thrust and normal in bottom legend CALL DBegin_Group step_points = MAX((radius_points + 6.0D0), 24.0D0) xp = x1_points + bottomlegend_used_points + x_used_points + MAX(radius_points, 16.0D0) + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL Cats_Eye (xp, yp, radius_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) ypt = yp - radius_points - 12.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.6D0, 0.0D0, & & 'thrust') x_used_points = x_used_points + 2.0D0 * MAX(radius_points, 16.0D0) + 6.0D0 CALL DEnd_Group CALL DBegin_Group xp = x1_points + bottomlegend_used_points + x_used_points + MAX(radius_points, 16.0D0) + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL Cats_Eye (xp, yp, radius_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) ypt = yp - radius_points - 12.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.4D0, 0.0D0, & & 'normal') x_used_points = x_used_points + 2.0D0 * MAX(radius_points, 16.0D0) + 6.0D0 + step_points CALL DEnd_Group END IF ! sample FPS's needed in bottom legend bottomlegend_used_points = bottomlegend_used_points + x_used_points ELSE IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y_used_points = 0.0D0 radius_points = 0.5D0 * (d0 + d1 * m2) xp = x1_points + radius_points DO i = m1, m2 radius_points = 0.5D0 * (d0 + d1 * i) yp = y2_points - rightlegend_used_points - y_used_points - radius_points - 6.0D0 CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) xpt = xp + radius_points + 6.0D0 WRITE (c1, "(I1)") i CALL DL12_Text (1, xpt, yp, 0.0D0, & & 12, 0.0D0, 0.4D0, & & c1) y_used_points = y_used_points + 2.0D0 * radius_points + 6.0D0 END DO IF (any_FPS.AND.plot_FPS) THEN ! sample thrust and normal in right legend CALL DBegin_Group yp = y2_points - rightlegend_used_points - y_used_points - radius_points - 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL Cats_Eye (xp, yp, radius_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) xpt = xp + radius_points + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xpt, yp, 0.0D0, & & 12, 0.0D0, 0.4D0, & & 'thrust') y_used_points = y_used_points + 2.0D0 * radius_points + 6.0D0 CALL DEnd_Group CALL DBegin_Group yp = y2_points - rightlegend_used_points - y_used_points - radius_points - 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL Cats_Eye (xp, yp, radius_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) xpt = xp + radius_points + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xpt, yp, 0.0D0, & & 12, 0.0D0, 0.4D0, & & 'normal') y_used_points = y_used_points + 2.0D0 * radius_points + 6.0D0 CALL DEnd_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 DEnd_Group END IF ! either bottom or right legend reserved WRITE (*,"('+Working on earthquake epicenters....DONE.')") CALL BEEPQQ (440, 250) ! end of 14: earthquake epicenters from Seismicity .eqc file CASE (15) ! volcanoes 2150 temp_path_in = path_in !CALL File_List( file_type = "*.*", & ! & suggested_file = volcano_file, & ! & using_path = temp_path_in) 2151 WRITE (*,*) CALL DPrompt_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 DPress_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 DPrompt_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 DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='background') ELSE ! b/w figure CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='gray______') END IF CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (0.6D0, .FALSE.) WRITE (*,"(/' Working on volcanoes....')") CALL DBegin_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 DLonLat_2_Uvec (volcano_Elon, volcano_Nlat, uvec) radians_per_point = (3.527777D-4)*(mp_scale_denominator*DConformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) leg = 1.1547D0 * volcano_points * radians_per_point rad = 0.6666D0 * volcano_points * radians_per_point CALL DTurn_To (azimuth_radians = 0.0D0, base_uvec = uvec, & & far_radians = rad, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) uvec(1:3) = result_uvec(1:3) CALL DNew_L45_Path (5, uvec) CALL DTurn_To (azimuth_radians = 3.665D0, base_uvec = uvec, & & far_radians = leg, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DGreat_to_L45 (result_uvec) CALL DTurn_To (azimuth_radians = 2.618D0, base_uvec = uvec, & & far_radians = leg, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DGreat_to_L45 (result_uvec) CALL DGreat_to_L45 (uvec) CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) END DO volcano_reading CALL DEnd_Group CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CLOSE(22) CALL Chooser (bottom, right) IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) CALL DBegin_Group xp = x1_points + bottomlegend_used_points + bottomlegend_gap_points + 23.0D0 yp = (y1_points + y2_points)/2.0D0 + 12.0D0 + volcano_points IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='background') ELSE ! b/w figure CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='gray______') END IF CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (0.6D0, .FALSE.) CALL DNew_L12_Path(1, xp, yp) xpt = xp - 0.57735D0 * volcano_points ypt = yp - volcano_points CALL DLine_To_L12 (xpt, ypt) xpt = xp + 0.57735D0 * volcano_points CALL DLine_To_L12 (xpt, ypt) CALL DLine_To_L12 (xp, yp) CALL DEnd_L12_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) ypt = ypt - 12.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.5D0, 0.0D0, & & 'Recent') ypt = ypt - 12.0D0 CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.5D0, 0.0D0, & & 'volcano') CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 46.0D0 ELSE IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) CALL DBegin_Group xp = (x1_points + x2_points)/2.0D0 yp = y2_points - rightlegend_used_points + rightlegend_gap_points IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='background') ELSE ! b/w figure CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='gray______') END IF CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (0.6D0, .FALSE.) CALL DNew_L12_Path(1, xp, yp) xpt = xp - 0.57735D0 * volcano_points ypt = yp - volcano_points CALL DLine_To_L12 (xpt, ypt) xpt = xp + 0.57735D0 * volcano_points CALL DLine_To_L12 (xpt, ypt) CALL DLine_To_L12 (xp, yp) CALL DEnd_L12_Path (close = .TRUE., stroke = .TRUE., fill = .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') ypt = ypt - 12.0D0 CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.5D0, 0.0D0, & & 'Recent') ypt = ypt - 12.0D0 CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.5D0, 0.0D0, & & 'volcano') CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + volcano_points + 24.0D0 END IF ! bottom or right legend WRITE (*,"('+Working on volcanoes....DONE.')") CALL BEEPQQ (440, 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 DPrompt_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 DTraceback() 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 DLonLat_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 DTraceback() 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 DLonLat_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 = DInt_Above(nPlates / 6.0D0) 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 DPrompt_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 DPrompt_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 DPrompt_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 DMake_Global_Grid (subdivision, & ! only input(!) & numnod, node_uvec, & ! output: number of nodes, unit vectors of nodes, & numel, nodes) ! number of elements, element definitions CALL DWrite_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 DPrompt_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 DPress_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 DLonLat_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 DPrompt_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 DSet_Stroke_Color ("foreground") CALL DSet_Line_Style (width_points = 1.5D0, dashed =.FALSE.) CALL DSet_Join_to_Mitre() CALL DBegin_Group DO i = 1, numnod uvec(1:3) = node_uvec(1:3, i) visible = DL5_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 = DLength(Euler) IF (Euler_rate_radspMa > 1.D-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 DMake_Uvec(Euler, pole_uvec) az1 = DRelative_Compass (from_uvec = pole_uvec, to_uvec = uvec) ! in radians, clockwise from N az2 = az1 - arc2 ! azimuth to end point arc3 = DArc (pole_uvec, uvec) ! radians away from Euler pole CALL DTurn_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 DBegin_Group CALL DNew_L45_Path(5, uvec) ! start point CALL DSmall_To_L45 (pole_uvec = pole_uvec, to_uvec = result_uvec) CALL DEnd_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) !now add the arrowhead: arc2 = DArc(uvec, result_uvec) ! overall length of vector arc3 = 0.15D0 * arc2 ! chosen length for arms of the arrowhead az1 = DRelative_Compass (from_uvec = result_uvec, to_uvec = pole_uvec) ! direction from endpoint to pole az2 = az1 + (270 - 20) * radians_per_degree CALL DTurn_To (azimuth_radians = az2, base_uvec = result_uvec, far_radians = arc3, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL DNew_L45_Path(5, uvec1) ! begin at one eccentric point CALL DGreat_to_L45(result_uvec) ! go to head of vector az2 = az1 + (270 + 20) * radians_per_degree CALL DTurn_To (azimuth_radians = az2, base_uvec = result_uvec, far_radians = arc3, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL DGreat_to_L45(uvec1) CALL DEnd_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DEnd_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 DEnd_Group WRITE (*,"(/' Working on plate-model velocity numbers....')") CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = "foreground") CALL DBegin_Group DO i = 1, numnod uvec(1:3) = node_uvec(1:3, i) visible = DL5_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 DCross (Euler, uvec, tvec) tvec = R * tvec ! tvec will now be the velocity VECTOR in m/Ma velocity_mmpa = 0.001D0 * DLength(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 = DVector_Azimuth(site_uvec = uvec, vector = tvec) lr_fraction = 0.5D0 + 0.7D0 * DSIN(az1) ud_fraction = 0.4D0 + 0.6D0 * DCOS(az1) ELSE lr_fraction = 0.5D0 ud_fraction = 0.4D0 END IF CALL DL5_Text (uvec = uvec, angle_radians = 0.0D0, 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 DEnd_Group DEALLOCATE ( node_uvec ) ! in LIFO order DEALLOCATE ( orogen_uvecs ) DEALLOCATE ( plate_uvecs ) CALL Velocity_Explanation() ! common code; uses velocity_Ma CALL BEEPQQ (440, 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 DPrompt_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 DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 1.5D0, dashed =.FALSE.) CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') small_circle_radius_points = 4.0D0 large_circle_radius_points = 10.0D0 CALL DBegin_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 = DLength(Euler) IF (Euler_rate_radspMa > 1.D-6) THEN ! non-zero vector; it has a pole CALL DBegin_Group ! to make it easy to delete an unwanted pole (of 2 distant plates) CALL DMake_Uvec(Euler, uvec) !make a small dot radius_points = small_circle_radius_points radians_per_point = (3.527777D-4)*(mp_scale_denominator*DConformal_Deflation(uvec))/mp_radius_meters ! (page m / point)*(local scale)/(planet radius) radius = radius_points * radians_per_point CALL DTurn_To (azimuth_radians = 0.0D0, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DNew_L45_Path (5, result_uvec) CALL DSmall_to_L45 (uvec, result_uvec) ! complete small circle CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) !draw a circle around it for emphasis: radius_points = large_circle_radius_points CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') radius = radius_points * radians_per_point CALL DTurn_To (azimuth_radians = 0.0D0, base_uvec = uvec, & & far_radians = radius, & ! inputs & omega_uvec = omega_uvec, result_uvec = result_uvec) CALL DNew_L45_Path (5, result_uvec) CALL DSmall_to_L45 (uvec, result_uvec) ! complete small circle CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) CALL DL5_Text (uvec = result_uvec, angle_radians = 0.0D0, from_east = .TRUE., & & font_points = 14, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = c5) CALL DEnd_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 DEnd_Group DEALLOCATE ( touching ) CALL Chooser(bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = "Euler Pole:") number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.D0, & & angle_radians = 0.D0, & & font_points = 14, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = "CO-PA") CALL DCircle_on_L12 (level = 1, x = 0.5D0*(x1_points+x2_points), y = y2_points - 39.D0, & & radius = large_circle_radius_points, stroke = .TRUE., fill = .FALSE.) CALL DCircle_on_L12 (level = 1, x = 0.5D0*(x1_points+x2_points), y = y2_points - 39.D0, & & radius = small_circle_radius_points, stroke = .FALSE., fill = .TRUE.) CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 48.D0 ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = "Euler Pole:") number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = "CO-PA") CALL DCircle_on_L12 (level = 1, x = x1_points+29.D0, y = 0.5D0*(y1_points+y2_points)-13.D0, & & radius = large_circle_radius_points, stroke = .TRUE., fill = .FALSE.) CALL DCircle_on_L12 (level = 1, x = x1_points+29.D0, y = 0.5D0*(y1_points+y2_points)-13.D0, & & radius = small_circle_radius_points, stroke = .FALSE., fill = .TRUE.) CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58.D0 END IF ! bottom or right legend WRITE (*,"( '+Working on Euler poles of adjacent plates in plate model....DONE.')") CALL BEEPQQ (440, 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 DPrompt_for_Logical("Is it available?", .TRUE., maybe) IF (.NOT.maybe) GO TO 2180 WRITE (*, *) hide_steps_in_orogens = .FALSE. ! (suggestion to user) CALL DPrompt_for_Logical('Do you want to exclude/hide plate-boundary steps inside orogens?', hide_steps_in_orogens, hide_steps_in_orogens) WRITE (*, *) CALL DPrompt_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 (OR, 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 (hide_steps_in_orogens) THEN IF (star /= '*') step_count = step_count + 1 ELSE ! (don't hide any steps) step_count = step_count + 1 END IF 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 DBegin_Group ! of colored/shaded bands (two per step; the wider one plotted first) sup_slipnumber = 0.0D0 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 ((.NOT.hide_steps_in_orogens).OR.(star /= '*')) THEN step_count = step_count + 1 CALL DLonLat_2_Uvec(lon1, lat1, uvec1) CALL DLonLat_2_Uvec(lon2, lat2, uvec2) tvec(1:3) = (uvec1(1:3) + uvec2(1:3))/2. CALL DMake_Uvec(tvec, uvec4) ! uvec4 is midpoint (overwritten below) IF (DL5_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 (DSIN(f_azim_rads_c) > 0.0D0) THEN up_azim_rads(step_count) = f_azim_rads_c - Pi/2.D0 ! store for plotting #s later! ELSE up_azim_rads(step_count) = f_azim_rads_c + Pi/2.D0 !(ditto) END IF offset_radians = velocity_Ma * MAX(DABS(slipnumbers(1,step_count)),DABS(slipnumbers(2,step_count))) * 500.D0 / R CALL DTurn_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 (DABS(slipnumbers(1,step_count)) > DABS(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.0D0) THEN color_name = 'bronze____' ELSE ! thrust color_name = 'mid_blue__' END IF ! normal or thrust ELSE ! n == 1; strike-slip colors IF (dextral > 0.0D0) 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 DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = color_name) width_radians = velocity_Ma * DABS(slipnumbers(n, step_count)) * 1000.0D0 / mp_radius_meters !construct parallelogram using v_az information (so adjacent boxes will connect): IF (DABS(slipnumbers(2, step_count)) > DABS(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 DTurn_To (azimuth_radians = az_radians, & & base_uvec = uvec1, far_radians = width_radians/2.D0, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL DNew_L45_Path (5, uvec3) CALL DTurn_To (azimuth_radians = az_radians, & & base_uvec = uvec2, far_radians = width_radians/2.D0, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec4) CALL DGreat_to_L45(uvec4) CALL DTurn_To (azimuth_radians = (az_radians + Pi), & & base_uvec = uvec2, far_radians = width_radians/2.D0, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec4) CALL DGreat_to_L45(uvec4) CALL DTurn_To (azimuth_radians = (az_radians + Pi), & & base_uvec = uvec1, far_radians = width_radians/2.D0, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec4) CALL DGreat_to_L45(uvec4) CALL DGreat_to_L45(uvec3) ! returning to starting point (offset from uvec1) CALL DEnd_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 DEnd_Group ! of colored/shaded bands ALLOCATE ( selected(step_count) ) WRITE (*,"(/' There will be ',I7,' rate numbers plotted if they are not thinned.')") visible_labels label_thinner = 1 ! (suggestion to user) 2182 CALL DPrompt_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 DThin_on_Sphere (plot_at_uvec, step_count, label_thinner, selected) CALL DBegin_Group ! of rate numbers CALL DSet_Fill_or_Pattern(.FALSE., 'foreground') DO i = 1, step_count IF (selected(i)) THEN uvec1(1:3) = plot_at_uvec(1:3, i) IF (DABS(slipnumbers(1, i)) < 100.0D0) THEN string10 = ADJUSTL(DASCII8(slipnumbers(1, i))) ELSE ! use 3 significant digits; don't round to nearest 10 mm/a string10 = ADJUSTL(DASCII9(slipnumbers(1, i))) END IF IF (ABS(slipnumbers(2, i)) < 100.0D0) THEN line = TRIM(string10) // '[' // TRIM(ADJUSTL(DASCII8(slipnumbers(2, i)))) // ']' ELSE ! use 3 significant digits; don't round to nearest 10 mm/a line = TRIM(string10) // '[' // TRIM(ADJUSTL(DASCII9(slipnumbers(2, i)))) // ']' END IF CALL DL5_Text (uvec = uvec1, angle_radians = -up_azim_rads(i), from_east = .TRUE., & & font_points = 10, lr_fraction = 0.5D0, ud_fraction = -0.2D0, & & text = TRIM(line)) END IF ! selected(i) END DO ! i = 1, step_count CALL DEnd_Group ! of rate numbers DEALLOCATE ( selected ) DEALLOCATE ( up_azim_rads ) DEALLOCATE ( plot_at_uvec ) DEALLOCATE ( slipnumbers ) CALL Chooser (bottom, right) CALL DBegin_Group ! sample sliprates ! how fast is a 20-point band, in mm/a? sliprate1 = (((20.D0/2834.D0)/1000.D0)*mp_scale_denominator)/velocity_Ma ! ( bandwidth, in km, on Earth ) CALL DSet_Fill_or_Pattern(.FALSE., 'foreground') IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points xcp = (x1_points + x2_points)/2.D0 CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '[' // TRIM(ADJUSTL(DASCII8(sliprate1)))//"] mm/a") ! normal: [59] mma/a CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-45.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = "[-" // TRIM(ADJUSTL(DASCII8(sliprate1)))//"] mm/a") ! thrust: [-59] mm/a CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-80.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(DASCII8(sliprate1)))//' mm/a') ! dextral: 59 mm/a CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-115.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '-' // TRIM(ADJUSTL(DASCII8(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.D0, & & color_name = 'bronze____', text = 'normal') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-67.D0, & & color_name = 'mid_blue__', text = 'thrust') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-102.D0, & & color_name = 'green_____', text = 'dextral') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-137.D0, & & color_name = 'brown_____', text = 'sinistral') ELSE ! b/w CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-32.D0, & & color_name = 'gray______', text = 'normal') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-67.D0, & & color_name = 'gray______', text = 'thrust') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-102.D0, & & color_name = 'foreground', text = 'dextral') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-137.D0, & & color_name = 'foreground', text = 'sinistral') END IF ! color or b/w rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 137.D0 CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Horizontal') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'components of') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-30.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'slip rate') rightlegend_used_points = rightlegend_used_points + 30.D0 ELSE ! bottom CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points)/2.0D0 CALL DL12_Text (level = 1, x_points = x1_points+72.D0, & & y_points = ycp+10.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Horizontal') CALL DL12_Text (level = 1, x_points = x1_points+72.D0, & & y_points = ycp, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'components of') CALL DL12_Text (level = 1, x_points = x1_points+72.D0, & & y_points = ycp-10.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'slip rate:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.D0 CALL DReport_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 DL12_Text (level = 1, x_points = x1_points+36.D0, & & y_points = ycp+12.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '[' // TRIM(ADJUSTL(DASCII8(sliprate1)))//"] mm/a") ! normal: [59] mm/a CALL DL12_Text (level = 1, x_points = x1_points+108.D0, & & y_points = ycp+12.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = "[-" // TRIM(ADJUSTL(DASCII8(sliprate1)))//"] mm/a") ! thrust: [-59] mm/a CALL DL12_Text (level = 1, x_points = x1_points+180.D0, & & y_points = ycp+12.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(DASCII8(sliprate1)))//" mm/a") ! dextral: 59 mm/a CALL DL12_Text (level = 1, x_points = x1_points+252.D0, & & y_points = ycp+12.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '-' // TRIM(ADJUSTL(DASCII8(sliprate1)))//" mm/a") ! sinistral: -59 mm/a IF (ai_using_color) THEN CALL Slip_Sample(x_center_points = x1_points+36.D0, y_base_points = ycp-10.D0, & & color_name = 'bronze____', text = 'normal') CALL Slip_Sample(x_center_points = x1_points+108.D0, y_base_points = ycp-10.D0, & & color_name = 'mid_blue__', text = 'thrust') CALL Slip_Sample(x_center_points = x1_points+180.D0, y_base_points = ycp-10.D0, & & color_name = 'green_____', text = 'dextral') CALL Slip_Sample(x_center_points = x1_points+252.D0, y_base_points = ycp-10.D0, & & color_name = 'brown_____', text = 'sinistral') ELSE ! b/w CALL Slip_Sample(x_center_points = x1_points+36.D0, y_base_points = ycp-10.D0, & & color_name = 'gray______', text = 'normal') CALL Slip_Sample(x_center_points = x1_points+108.D0, y_base_points = ycp-10.D0, & & color_name = 'gray______', text = 'thrust') CALL Slip_Sample(x_center_points = x1_points+180.D0, y_base_points = ycp-10.D0, & & color_name = 'foreground', text = 'dextral') CALL Slip_Sample(x_center_points = x1_points+252.D0, y_base_points = ycp-10.D0, & & color_name = 'foreground', text = 'sinistral') END IF ! color or b/w bottomlegend_used_points = bottomlegend_used_points + 288.D0 END IF ! right or bottom CALL DEnd_Group ! sample sliprates IF (choice == 9) THEN WRITE (*,"('+Working on changes in horizontal velocity across faults....DONE.')") ELSE IF (choice == 10) THEN WRITE (*,"('+Working on slip-rates of fault elements....DONE.')") END IF ! choice == 9 or 10 CALL BEEPQQ (440, 250) ! end of (18) boundary slip raes from plate model END SELECT ! (choice) = overlay type just_began_surface_flow = .FALSE. just_began_total_strainrate = .FALSE. just_began_continuum_strainrate = .FALSE. WRITE (*,"(' ')") suggest_logical = overlay_count < old_overlay_count CALL DPrompt_for_Logical('Do you want additional overlays?',suggest_logical,do_more_overlays) IF (do_more_overlays) GO TO 2000 END IF ! do overlay !-------------------------------------------------------------------- !Graticule of parallels and meridians CALL DSet_Line_Style (width_points = 0.25D0, dashed = .FALSE.) CALL DSet_Stroke_Color (color_name = 'foreground') WRITE (*,"(' ')") IF (mp_projection_number == 0) THEN ! (x,y) axes desired 3010 CALL DPrompt_for_Integer('How many kilometers apart should fiducial lines& & of constant x and constant y be plotted?',kilometers,kilometers) IF (kilometers < 1) THEN WRITE (*, "(' ERROR: This value must be an integer >= 1')") CALL DPress_Enter mt_flashby = .FALSE. GO TO 3010 END IF CALL DWire_Mesh (kilometers) ELSE ! parallels and meridians desired 3020 CALL DPrompt_for_Integer('How many minutes apart should parallels& & and meridians be plotted?',minutes,minutes) IF (minutes < 1) THEN WRITE (*, "(' ERROR: This value must be an integer >= 1')") CALL DPress_Enter mt_flashby = .FALSE. GO TO 3020 END IF CALL DGraticule (minutes) END IF !numbered margin: IF (mp_projection_number == 0) THEN ! (x,y) axes desired CALL DKilometer_Frame (kilometers) ELSE ! parallels and meridians desired CALL DLonLat_Frame (minutes) END IF !Titles at top of map IF (ai_toptitles_reserved) THEN WRITE (*,"(' ')") mt_flashby = .FALSE. ! Do NOT flash by the prompts for titles, if there is space! CALL DPrompt_for_Logical('Do you want to add a title to this map?',.TRUE.,add_titles) IF (add_titles) THEN CALL Add_Title(top_line_memo) CALL Add_Title(bottom_line_memo) 900 WRITE (*,"(/' ----------------------------------------------------------------------')") WRITE (*,"(' SOME SUGGESTED TITLE OPTIONS')") WRITE (*,"(' (culled from files opened for this map)')") WRITE (*,"(/' 0 :: ANYTHING YOU CHOOSE TO TYPE!')") DO i = 1, title_count WRITE (*,"(' ',I2,' :: ',A)") i, TRIM(titles(i)) END DO ! i = 1, title_count WRITE (*,"(' ----------------------------------------------------------------------')") CALL DPrompt_for_Integer('Which option do you want for the upper line?',0,title_choice) IF ((title_choice < 0).OR.(title_choice > title_count)) THEN WRITE (*,"(' ERROR: Please choose a number from the list.')") mt_flashby = .FALSE. GO TO 900 END IF ! illegal choice IF (title_choice == 0) THEN CALL DPrompt_for_String('Enter top title (or one space for none)',' ',top_line) top_line_memo = top_line ELSE ! selection from list top_line = TRIM(titles(title_choice)) END IF CALL DPrompt_for_Integer('Which option do you want for the lower line?',0,title_choice) IF ((title_choice < 0).OR.(title_choice > title_count)) THEN WRITE (*,"(' ERROR: Please choose a number from the list.')") mt_flashby = .FALSE. GO TO 900 END IF ! illegal choice IF (title_choice == 0) THEN CALL DPrompt_for_String('Enter sub-title (or one space for none)',' ',bottom_line) bottom_line_memo = bottom_line ELSE ! selection from list bottom_line = TRIM(titles(title_choice)) END IF CALL DTop_Titles (top_line, & & bottom_line) END IF ! add_titles END IF ! ai_toptitles_reserved CALL DEnd_Page !-------------------------SAVE CHOICES FOR NEXT TIME!---------------- !GPBend OPEN (UNIT = 11, FILE = 'NeoKineMap.ini') WRITE (11,"(A)") TRIM(path_in) WRITE (11,"(A)") TRIM(path_out) WRITE (11,"(I12,' = mosaic_count')") mosaic_count WRITE (11,"(10I4,' = mosaic_choice')") mosaic_choice ! whole array WRITE (11,"(A)") TRIM(polygons_basemap_file) WRITE (11,"(L12,' = plot_dig_titles')") plot_dig_titles WRITE (11,"(I12,' = dig_title_method')") dig_title_method WRITE (11,"(A)") TRIM(grd1_file) WRITE (11,"(A)") TRIM(grd2_file) WRITE (11,"(I12,' = bitmap_interpolation_mode')") bitmap_interpolation_mode WRITE (11,"(I12,' = bitmap_color_mode')") bitmap_color_mode WRITE (11,"(L12,' = shaded_relief')") shaded_relief WRITE (11,"(I12,' = bitmap_shading_mode')") bitmap_shading_mode WRITE (11,"(F12.3,' = intensity')") intensity WRITE (11,"(A12,' = grid_units')") grid_units WRITE (11,"(1P,E12.4,' = grid_interval')") grid_interval WRITE (11,"(1P,E12.4,' = grid_midvalue')") grid_midvalue WRITE (11,"(L12,' = grid_lowblue')") grid_lowblue WRITE (11,"(L12,' = skip_0_contour')") skip_0_contour WRITE (11,"(I12,' = element_scalar_method')") element_scalar_method WRITE (11,"(A)") TRIM(element_scalar_feg_file) WRITE (11,"(A12,' = element_scalar_units')") element_scalar_units WRITE (11,"(1P,E12.4,' = element_scalar_interval')") element_scalar_interval WRITE (11,"(1P,E12.4,' = element_scalar_midvalue')") element_scalar_midvalue WRITE (11,"(L12,' = element_scalar_lowblue')") element_scalar_lowblue WRITE (11,"(I12,' = element_scalar_zeromode')") element_scalar_zeromode WRITE (11,"(A)") TRIM(feg_file) WRITE (11,"(I12,' = node_scalar_method')") node_scalar_method WRITE (11,"(I12,' = node_scalar_choice')") node_scalar_choice WRITE (11,"(A12,' = node_scalar_units')") node_scalar_units WRITE (11,"(1P,E12.4,' = node_scalar_interval')") node_scalar_interval WRITE (11,"(1P,E12.4,' = node_scalar_midvalue')") node_scalar_midvalue WRITE (11,"(L12,' = node_scalar_lowblue')") node_scalar_lowblue WRITE (11,"(A)") TRIM(parameter_file) WRITE (11,"(A)") TRIM(plates_dig_file) WRITE (11,"(L12,' = velocity_reframe')") velocity_reframe WRITE (11,"(I12,' = cracked_element_method')") cracked_element_method WRITE (11,"(I12,' = fixed_node')") fixed_node WRITE (11,"(I12,' = nonorbiting_node')") nonorbiting_node WRITE (11,"(1P,E12.4,' = reference_Elon_deg')") reference_Elon_deg WRITE (11,"(1P,E12.4,' = reference_Nlat_deg')") reference_Nlat_deg WRITE (11,"(1P,E12.4,' = reference_vE_mmpa')") reference_vE_mmpa WRITE (11,"(1P,E12.4,' = reference_vN_mmpa')") reference_vN_mmpa WRITE (11,"(1P,E12.4,' = reference_ccw_degpMa')") reference_ccw_degpMa WRITE (11,"(I12,' = velocity_method')") velocity_method WRITE (11,"(1P,E12.4,' = velocity_interval')") velocity_interval WRITE (11,"(1P,E12.4,' = velocity_midvalue')") velocity_midvalue WRITE (11,"(L12,' = velocity_lowblue')") velocity_lowblue WRITE (11,"(I12,' = strainrate_mosaic_method')") strainrate_mosaic_method ! method = polygons or bitmap WRITE (11,"(I12,' = strainrate_mosaic_mode')") strainrate_mosaic_mode ! mode = logarithmic or linear, & units (/s or nanostrains/year) WRITE (11,"(1P,E12.4,' = strainrate_mosaic_interval')") strainrate_mosaic_interval WRITE (11,"(1P,E12.4,' = strainrate_mosaic_midvalue')") strainrate_mosaic_midvalue WRITE (11,"(L12,' = log_strainrate_lowblue')") log_strainrate_lowblue WRITE (11,"(I12,' = rotationrate_method')") rotationrate_method WRITE (11,"(1P,E12.4,' = rotationrate_interval')") rotationrate_interval WRITE (11,"(1P,E12.4,' = rotationrate_midvalue')") rotationrate_midvalue WRITE (11,"(L12,' = rotationrate_lowblue')") rotationrate_lowblue WRITE (11,"(A)") TRIM(point_data_file) WRITE (11,"(L12,' = point_data_values')") point_data_values WRITE (11,"(I12,' = point_pixel_width')") point_pixel_width WRITE (11,"(I12,' = overlay_count')") overlay_count WRITE (11,"(10I4,' = overlay_choice')") overlay_choice ! whole array WRITE (11,"(A)") TRIM(lines_basemap_file) WRITE (11,"(F12.1,' = tick_points')") tick_points WRITE (11,"(F12.1,' = node_radius_points')") node_radius_points WRITE (11,"(A)") TRIM(traces_file) WRITE (11,"(A)") TRIM(f_nko_file) WRITE (11,"(A)") TRIM(heave_segments_file) WRITE (11,"(A)") TRIM(vel_file) WRITE (11,"(I12,' = gps_type')") gps_type WRITE (11,"(A)") TRIM(gps_file) WRITE (11,"(F12.1,' = benchmark_points')") benchmark_points WRITE (11,"(F12.3,' = velocity_Ma')") velocity_Ma WRITE (11,"(I12, ' = vector_thinner')") vector_thinner WRITE (11,"(I12, ' = heave_rate_method')") heave_rate_method WRITE (11,"(F12.3,' = dv_scale_mma')") dv_scale_mma WRITE (11,"(F12.3,' = dv_scale_points')") dv_scale_points WRITE (11,"(1P,E12.4,' = R, radius of planet, in m')") R WRITE (11,"(I12,' = strainrate_mode012')") strainrate_mode012 WRITE (11,"(1P,E12.2,' = ref_e3_minus_e1_persec')") ref_e3_minus_e1_persec WRITE (11,"(F12.1,' = strainrate_diameter_points')") strainrate_diameter_points WRITE (11,"(I12,' = strain_thinner')") strain_thinner WRITE (11,"(F12.1,' = e1_size_points')") e1_size_points WRITE (11,"(I12, ' = stress_thinner')") stress_thinner WRITE (11,"(F12.1,' = s1_size_points')") s1_size_points WRITE (11,"(A)") TRIM(s1h_file) WRITE (11,"(F12.1,' = s1h_interp_points')") s1h_interp_points WRITE (11,"(L12,' = only_stressed')") only_stressed WRITE (11,"(A)") TRIM(old_eqc_file) WRITE (11,"(11X,L1,' = plot_FPS')") plot_FPS WRITE (11,"(F12.2,' = min_mag')") min_mag WRITE (11,"(F12.2,' = m8_diam_points')") m8_diam_points WRITE (11,"(A)") TRIM(volcano_file) WRITE (11,"(F12.2,' = volcano_points')") volcano_points WRITE (11,"(A)") TRIM(boundaries_dig_file) WRITE (11,"(A)") TRIM(plates_dig_file) WRITE (11,"(A)") TRIM(orogens_dig_file) WRITE (11,"(A)") TRIM(steps_dat_file) WRITE (11,"(I12, ' = ref_frame_plate_ID')") ref_frame_plate_ID WRITE (11,"(I12, ' = subdivision')") subdivision !GPBwrite WRITE (11,"(I12,' = minutes')") minutes WRITE (11,"(I12,' = kilometers')") kilometers WRITE (11,"(A)") TRIM(top_line_memo) WRITE (11,"(A)") TRIM(bottom_line_memo) CLOSE (11) CONTAINS ! member subprograms SUBROUTINE Add_Title(line) ! Adds "line" to global array "titles" and bumps global "title_count" ! if "line" is non-blank and also is novel. CHARACTER*(*), INTENT(IN) :: line CHARACTER*132 :: copy LOGICAL :: blank, novel INTEGER :: i blank = LEN_TRIM(line) <= 0 IF (.NOT.blank) THEN copy = ADJUSTL(TRIM(line)) novel = .TRUE. IF (title_count > 0) THEN DO i = 1, title_count IF (TRIM(copy) == TRIM(titles(i))) novel = .FALSE. END DO ! i = 1, title_count END IF ! have stored titles already IF (novel) THEN title_count = MIN(20, title_count + 1) titles(title_count) = TRIM(copy) END IF ! novel END IF ! not blank END SUBROUTINE Add_Title SUBROUTINE Bad_Parameters() !prints admonition screen, calls Pause(), and STOP's. IMPLICIT NONE WRITE (*, *) WRITE (*, "(' ==========================================================================')") WRITE (*, "(' ERROR DURING READING OF PARAMETER FILE')") WRITE (*, "(' ')") WRITE (*, "(' Please review the proper format, which is listed in the introductory')") WRITE (*, "(' comment lines of NeoKinema.f90.')") WRITE (*, "(' ')") WRITE (*, "(' This program is smart enough to read either NeoKinema v1.x, OR')") WRITE (*, "(' NeoKinema v2.x~v3.x, OR NeoKinema v4.x flavors of the')") WRITE (*, "(' input parameter file (and decide which is intended),')") WRITE (*, "(' but it cannot correct for other unexpected errors.')") WRITE (*, "(' ')") WRITE (*, "(' After you have read this message, NeoKinema will stop.')") WRITE (*, "(' Please correct the input parameter file and re-start it.')") WRITE (*, "(' ==========================================================================')") Call Pause() STOP END SUBROUTINE Bad_Parameters SUBROUTINE Cats_Eye (xp, yp, radius_points) !Creates a horizontal lens in the margin; used to avoid !repeating same code 4x in fault-plane-solution explanation IMPLICIT NONE REAL*8, INTENT(IN) :: xp, yp, radius_points REAL*8 :: xp0,xp1,xp2,xp3,yp0,yp1,yp2,yp3 xp0 = xp - radius_points xp1 = xp - 0.4D0 * radius_points ! adjust? xp2 = xp + 0.4D0 * radius_points ! adjust? xp3 = xp + radius_points yp0 = yp yp1 = yp + 0.6D0 * radius_points ! adjust? yp2 = yp1 yp3 = yp CALL DNew_L12_Path (1, xp0, yp0) CALL DCurve_to_L12 (xp1,yp1,xp2,yp2,xp3,yp3) xps = xp1 xp1 = xp2 xp2 = xps xp3 = xp0 yp1 = yp - (yp2 - yp) yp2 = yp1 CALL DCurve_to_L12 (xp1,yp1,xp2,yp2,xp3,yp3) CALL DEnd_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END SUBROUTINE Cats_Eye SUBROUTINE Chooser(bottom, right) ! Decides whether there is more margin space at "bottom" or "right". ! Will return both = F if NOT (ai_bottomlegend_reserved OR ai_rightlegend_reserved). ! Refers to NeoKineMap global variables: bottomlegend_used_points, rightlegend_used_points. LOGICAL, INTENT(out) :: bottom, right REAL*8 :: bottomlegend_free_points, rightlegend_free_points, & & x1_points, x2_points, y1_points, y2_points bottom = ai_bottomlegend_reserved right = ai_rightlegend_reserved IF (bottom.AND.right) THEN ! must choose one CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) bottomlegend_free_points = x2_points - x1_points - bottomlegend_used_points CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) rightlegend_free_points = y2_points - y1_points - rightlegend_used_points IF (rightlegend_free_points >= bottomlegend_free_points) THEN right = .TRUE. bottom = .FALSE. ELSE right = .FALSE. bottom = .TRUE. END IF END IF ! choice is needed END SUBROUTINE Chooser SUBROUTINE Could_Not_Find_File(pathfilename) !prevents multiple duplications of this very simple code: IMPLICIT NONE CHARACTER*(*), INTENT(IN), OPTIONAL :: pathfilename IF (PRESENT(pathfilename)) THEN WRITE (*, "(' ERROR: Could not find a necessary input file:'/' ',A)") TRIM(pathfilename) ELSE WRITE (*, "(' ERROR: Could not find a necessary input file')") END IF CALL Pause() STOP END SUBROUTINE Could_Not_Find_File SUBROUTINE Dig_Type (dig_pathfile, free_unit, dig_is_lonlat, any_titles) ! Decide whether dig_pathfile is (lon,lat) or (x,y) based ! on the extreme range displayed in the y (or latitude) ! component. ! Also reports "any_titles" = T/F. ! Note that there can be trouble when a title like "TX" is ! interpreted by (*) format-free READ as x, and then y is ! taken from the start of the next line (a longitude!). ! So, we have to test the first two bytes to rule out titles. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: dig_pathfile ! points to .dig file INTEGER, INTENT(IN) :: free_unit ! Fortran device number LOGICAL, INTENT(OUT) :: dig_is_lonlat, any_titles ! Yes or No CHARACTER*2 :: c2 CHARACTER*26 :: line INTEGER :: ios LOGICAL :: first REAL*8 :: high_y, low_y, x, y OPEN (UNIT = free_unit, FILE = dig_pathfile, STATUS = 'OLD', & & PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(dig_pathfile) IF (ios /= 0) THEN WRITE (*,"(' ERROR in Dig_Type: Following file cannot be opened:' & & /' ',A)") TRIM(dig_pathfile) CALL DTraceback END IF any_titles = .FALSE. ! unless changed below... WRITE (*,"(/' Scanning through .dig file...')") first = .TRUE. scanning: DO READ (free_unit, "(A)", IOSTAT = ios) c2 IF (ios == -1) EXIT scanning ! EOF IF ((c2 == ' +').OR.(c2 == ' -')) THEN BACKSPACE (free_unit) READ (free_unit, *, IOSTAT = ios) x, y IF (ios == 0) THEN IF (first) THEN first = .FALSE. high_y = y low_y = y END IF high_y = MAX(high_y, y) low_y = MIN(low_y, y) END IF ! read was successful ELSE ! not a number line; either *** or a title BACKSPACE (free_unit) READ (free_unit, "(A)") line any_titles = any_titles .OR. (line(1:3) /= '***') END IF ! line has two numbers, or not END DO scanning CLOSE (UNIT = free_unit, IOSTAT = ios) WRITE (*,"('+Scanning through .dig file...DONE')") dig_is_lonlat = (low_y > -91.0D0).AND.(high_y < 91.0D0) END SUBROUTINE Dig_Type SUBROUTINE E_rate(R, l_, nodes, G, dG, theta_, vw, eps_dot) ! Evaluate strain-rate at one point in one spherical continuum element (# l_); ! the specific point is implied by the values of arrays G and dG supplied, ! but note that the value of theta_ must also be consistent. REAL*8, INTENT(IN) :: R ! radius of planet, in m INTEGER, INTENT(IN) :: l_ ! element number INTEGER, DIMENSION(:,:), INTENT(IN) :: nodes DOUBLE PRECISION, DIMENSION(3,2,2), INTENT(IN) :: G ! nodal functions @ selected point DOUBLE PRECISION, DIMENSION(3,2,2,2), INTENT(IN):: dG ! derivitives of nodal functions @ selected point REAL*8, INTENT(IN) :: theta_ ! colatitude, radians DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: vw REAL*8, DIMENSION(3), INTENT(OUT) :: eps_dot DOUBLE PRECISION, DIMENSION(3) :: sums INTEGER :: iv, iw, j DOUBLE PRECISION :: cott, csct, prefix cott = 1.0D0 / DTAN(1.0D0 * theta_) csct = 1.0D0 / DSIN(1.0D0 * theta_) prefix = 1.0D0 / R sums(1:3) = 0.0D0 DO j = 1, 3 iv = 2 * nodes(j, l_) - 1 iw = iv + 1 ! epsilon_dot_sub_theta_theta sums(1) = sums(1) + & & vw(iv) * prefix * dG(j,1,1,1) + & & vw(iw) * prefix * dG(j,2,1,1) ! epsilon_dot_sub_theta_phi sums(2) = sums(2) + & & vw(iv) * prefix * 0.5D0 * (csct * dG(j,1,1,2) + dG(j,1,2,1) - cott * G(j,1,2)) + & & vw(iw) * prefix * 0.5D0 * (csct * dG(j,2,1,2) + dG(j,2,2,1) - cott * G(j,2,2)) ! epsilon_dot_sub_phi_phi sums(3) = sums(3) + & & vw(iv) * prefix * (csct * dG(j,1,2,2) + cott * G(j,1,1)) + & & vw(iw) * prefix * (csct * dG(j,2,2,2) + cott * G(j,2,1)) END DO ! 3 local nodes eps_dot(1:3) = sums(1:3) END SUBROUTINE E_rate SUBROUTINE Fault_Key_Bottom (bottomlegend_gap_points, bottomlegend_used_points, tick_points) ! Plots 6 sample fault traces in bottom legend, ! in color (if ai_using_color) or b/w, with tick size tick_points; ! then adds to bottomlegend_used_points to record size of block. ! Note that these 6 samples are not grouped; you may wish to do ! this externally. IMPLICIT NONE REAL*8, INTENT(INOUT) :: bottomlegend_used_points REAL*8, INTENT(IN) :: bottomlegend_gap_points, tick_points INTEGER :: fp = 12 ! font points REAL*8 :: x1_points, x2_points, xc, xl, xr, & & y1, y1_points, y2, y2_points, y3 IF (.NOT.ai_bottomlegend_reserved) THEN WRITE (*,"(' Error: Fault_Key_Bottom requires ai_bottomlegend_reserved = T')") CALL DTraceback END IF CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) !center of first block: xc = x1_points + bottomlegend_used_points + bottomlegend_gap_points + 31.0D0 !left and right limits of fault traces xl = xc - 22.0D0 xr = xc + 22.0D0 !baselines of 3 lines of text/fault trace: y3 = y1_points + MAX(2.0D0, tick_points) y2 = y3 + MAX(1.0D0*fp, 0.4D0*fp + tick_points) y1 = y2 + fp CALL DSet_Stroke_Color ('foreground') ! will remain, if .NOT. ai_using_color ! low-angle thrust (S or P or T with no dip_degrees; or, with dip_degrees<=45): dark_blue_, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xc, y_points = y1, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Low-angle') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'thrust:') CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('dark_blue_') CALL DSet_Fill_or_Pattern (.FALSE., 'dark_blue_') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi/2.D0, & & style_byte = 'P', size_points = tick_points, offset_points = 1.0D0) ! high-angle reverse fault (T or P with dip_degrees>45): mid_blue__, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') xc = xc + 62.0D0 xl = xc - 22.0D0 xr = xc + 22.0D0 CALL DL12_Text (level = 1, x_points = xc, y_points = y1, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'High-angle') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'reverse:') CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('mid_blue__') CALL DSet_Fill_or_Pattern (.FALSE., 'mid_blue__') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi/2.D0, & & style_byte = 'T', size_points = tick_points, offset_points = 1.0D0) ! dextral (R): green_____, xc = xc + 62.0D0 xl = xc - 22.0D0 xr = xc + 22.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Dextral:') CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi/2.D0, & & style_byte = 'R', size_points = tick_points, offset_points = 1.0D0) ! sinistral (L): brown_____, xc = xc + 62.0D0 xl = xc - 22.0D0 xr = xc + 22.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Sinistral:') CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('brown_____') CALL DSet_Fill_or_Pattern (.FALSE., 'brown_____') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi/2.D0, & & style_byte = 'L', size_points = tick_points, offset_points = 1.0D0) ! high-angle normal (N or D with no dip_degrees; or, with dip_degrees>45): bronze____, xc = xc + 62.0D0 xl = xc - 22.0D0 xr = xc + 22.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xc, y_points = y1, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'High-angle') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'normal:') CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('bronze____') CALL DSet_Fill_or_Pattern (.FALSE., 'bronze____') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi/2.D0, & & style_byte = 'N', size_points = tick_points, offset_points = 1.0D0) ! low-angle detachment (N or D with dip_degrees<=45): red_______, xc = xc + 62.0D0 xl = xc - 22.0D0 xr = xc + 22.0D0 CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, x_points = xc, y_points = y1, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Low-angle') CALL DL12_Text (level = 1, x_points = xc, y_points = y2, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'detachment:') CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') END IF CALL DNew_L12_Path (1, xl, y3) CALL DLine_to_L12 (xr, y3) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = y3, dip_angle_radians = Pi/2.D0, & & style_byte = 'D', size_points = tick_points, offset_points = 1.0D0) ! wrap-up: adjust bottomlegend_used_points bottomlegend_used_points = bottomlegend_used_points + 365.0D0 END SUBROUTINE Fault_Key_Bottom SUBROUTINE Fault_Key_Right (rightlegend_gap_points, rightlegend_used_points, tick_points) ! Plots 6 sample fault traces in right legend, ! in color (if ai_using_color) or b/w, with tick size tick_points; ! then adds to rightlegend_used_points to record size of block. ! Note that these 6 samples are not grouped; you may wish to do ! this externally. IMPLICIT NONE REAL*8, INTENT(INOUT) :: rightlegend_used_points REAL*8, INTENT(IN) :: rightlegend_gap_points, tick_points INTEGER :: fp = 12 ! font points REAL*8 :: x1_points, x2_points, xc, xl, xr, y1_points, y2_points, yc IF (.NOT.ai_rightlegend_reserved) THEN WRITE (*,"(' Error: Fault_Key_Right requires ai_rightlegend_reserved = T')") CALL DTraceback END IF CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) yc = y2_points - rightlegend_used_points - rightlegend_gap_points xc = (x1_points + x2_points) / 2.0D0 xl = 0.8D0*x1_points + 0.2D0*x2_points xr = 0.2D0*x1_points + 0.8D0*x2_points CALL DSet_Stroke_Color ('foreground') ! will remain, if .NOT. ai_using_color ! low-angle thrust (S or P or T with no dip_degrees; or, with dip_degrees<=45): dark_blue_, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - 0.4D0*fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Low-angle') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'thrust:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('dark_blue_') CALL DSet_Fill_or_Pattern (.FALSE., 'dark_blue_') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi/2.D0, & & style_byte = 'P', size_points = tick_points, offset_points = 1.0D0) ! high-angle reverse (T or P and dip_degrees>45): mid_blue__, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'High-angle') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'reverse:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('mid_blue__') CALL DSet_Fill_or_Pattern (.FALSE., 'mid_blue__') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi/2.D0, & & style_byte = 'T', size_points = tick_points, offset_points = 1.0D0) ! dextral (R): green_____, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Dextral:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') CALL DSet_Fill_or_Pattern (.FALSE., 'green_____') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi/2.D0, & & style_byte = 'R', size_points = tick_points, offset_points = 1.0D0) yc = yc - tick_points ! sinistral (L): brown_____, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Sinistral:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('brown_____') CALL DSet_Fill_or_Pattern (.FALSE., 'brown_____') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi/2.D0, & & style_byte = 'L', size_points = tick_points, offset_points = 1.0D0) yc = yc - tick_points ! high-angle normal (N or D with no dip_degrees; or, with dip_degrees>45): bronze____, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'High-angle') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'normal:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('bronze____') CALL DSet_Fill_or_Pattern (.FALSE., 'bronze____') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi/2.D0, & & style_byte = 'N', size_points = tick_points, offset_points = 1.0D0) ! low-angle detachment (D or N with dip_degrees<=45): red_______, CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Low-angle') yc = yc - fp CALL DL12_Text (level = 1, x_points = xc, y_points = yc, & & angle_radians = 0.D0, font_points = fp, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'detachment:') yc = yc - MAX(1.0D0*fp, 0.4D0*fp + tick_points) CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') END IF CALL DNew_L12_Path (1, xl, yc) CALL DLine_to_L12 (xr, yc) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DDipTick_in_Plane (level = 1, x = xc, y = yc, dip_angle_radians = Pi/2.D0, & & style_byte = 'D', size_points = tick_points, offset_points = 1.0D0) ! wrap-up: adjust rightlegend_used_points rightlegend_used_points = y2_points - yc + 0.5D0 END SUBROUTINE Fault_Key_Right SUBROUTINE Fault_Traces (trace_choice, & ! NOTE: following parameters only needed for trace_choice >0: & width_array, dw_scale_amount, dw_scale_points, sense) ! optional parameters ! Draws fault traces on an open page, in 3 groups: ! (1) dip ticks (allowing for deletion; changes of color ! and/or pen width are not practical due to the mixture ! of stroked-but-unfilled with filled-but-unstroked kinds; ! (2) traces (allowing for width change if trace_choice = 1, ! or shadowing in either case); ! (3) text labels. ! Different variants are plotted according to "trace_choice" = ! 0 :: plot all traces with equal width, annotate with id number. ! In this case, slip sense is from byte(s) in f.dig. ! 1 :: plot traces with width proportional to "width_array"; ! scaled using parameters "dw_scale_amount" and "dw_scale_points"; ! annotate with value (rounded to two significant digits). ! In this case, slip sense is from array "sense". ! The following variables must be pre-declared, and values ! defined, in the calling program: ! CHARACTER*(*) :: traces_pathfile ! [path\]name of F.DIG file. ! REAL*8 :: tick_points ! desired size of dip ticks, in points ! LOGICAL :: ai_using_color ! from Adobe_Illustrator module data. ! REAL*8 :: mp_radius_meters, mp_scale_denominator ! from Map_Projections module data. IMPLICIT NONE INTEGER, INTENT(IN) :: trace_choice REAL*8, DIMENSION(:), INTENT(IN), OPTIONAL :: width_array REAL*8, INTENT(IN), OPTIONAL :: dw_scale_points, dw_scale_amount CHARACTER*1, DIMENSION(:), INTENT(IN), OPTIONAL :: sense CHARACTER*1 :: another_byte, dip_byte, f_byte, one_byte, second_dip_byte, tick_byte CHARACTER*10 :: color_name, label CHARACTER*132 :: line INTEGER :: beyond_loc, count, end_loc, fault_number, & & i, i1, i2, internal_ios, ios, longest, nsteps, start_loc, which_byte LOGICAL :: got_dip_degrees, plotting REAL*8 :: angle, dip_azimuth_radians, dip_degrees, goal_radians, & & lat, lon, lr_fraction, nudge_radians, offset_points, & & r1, r2, step_radians, & & trace_points, trace_radians, ud_fraction, width, & & x1_meters, x2_meters, x1_points, x2_points, & & y1_meters, y2_meters, y1_points, y2_points REAL*8, DIMENSION(3) :: tvec, uvec1, uvec2, uvec3 REAL*8, DIMENSION(:,:), ALLOCATABLE :: one_trace !Read through and determine length of longest trace OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) CALL Could_Not_Find_File(traces_pathfile) longest = 0 count = 0 DO READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, *, IOSTAT = internal_ios) lon, lat IF (internal_ios == 0) THEN ! read lon, lat OK count = count + 1 longest = MAX(longest,count) ELSE ! encountered ***END or title line or additional header count = 0 END IF END DO CLOSE (21) ALLOCATE ( one_trace(2,longest) ) ! First group will have dip ticks only. OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) CALL Could_Not_Find_File(traces_pathfile) CALL DBegin_Group ! group of all dip ticks count = 0 DO ! reading lines of traces file READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, "(A1,I4,A1,A1)", IOSTAT = internal_ios) f_byte, i, one_byte, another_byte IF ((internal_ios == 0).AND.((f_byte == 'F').OR.(f_byte == 'f'))) THEN fault_number = i IF (trace_choice == 0) THEN dip_byte = one_byte second_dip_byte = another_byte ELSE ! trace_choice /= 0; probably 1? dip_byte = sense(i) ! primary sense may have reversed! second_dip_byte = ' ' ! don't try to display secondary sense END IF SELECT CASE (trace_choice) CASE (0) plotting = .TRUE. CASE (1) width = width_array(fault_number) * dw_scale_points / dw_scale_amount plotting = (width >= 0.1) ! to avoid orphan dip-ticks after trace dissapears in slide/print! END SELECT got_dip_degrees = .FALSE. ! until... ELSE ! line was not a title; this leaves 3 possibilities: dip_degrees, (lon, lat), or *** end !try to read "dip_degrees"... BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, "(A)", IOSTAT = internal_ios) line start_loc = INDEX(line, "dip_degrees") IF (start_loc > 0) THEN ! found "dip_degrees" in line beyond_loc = start_loc + 11 ! first byte which is not part of "dip_degrees" end_loc = LEN_TRIM(line) line = line(beyond_loc:end_loc) READ (line, *, IOSTAT = internal_ios) dip_degrees IF (internal_ios == 0) got_dip_degrees = .TRUE. ELSE ! "dip_degrees" not there, so either (lon, lat), or *** end !continue, on assumption that next line is probably a (lon, lat) pair... BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, *, IOSTAT = internal_ios) lon, lat IF (internal_ios == 0) THEN ! read lon, lat OK count = count + 1 one_trace(1,count) = lon one_trace(2,count) = lat ELSE ! encountered "*** end of line segment ***"; ! finished reading a trace IF (plotting.AND.(count > 1)) THEN ! got a trace to plot!!! SELECT CASE (trace_choice) CASE (0) ! constant width offset_points = 0.8D0 ! 40% of 2.0 points CASE (1) ! width prop. to trace_mma(fault_number) offset_points = 0.5D0 * width_array(fault_number) * dw_scale_points / dw_scale_amount END SELECT DO which_byte = 1, 2 IF (which_byte == 2) THEN IF (dip_byte /= ' ') dip_byte = second_dip_byte !Note that we don't plot the "second dip byte" if the first was blank, !because then the "second dip byte" might actually be first character of fault name! END IF IF (ai_using_color) THEN IF ((dip_byte == 'L').OR.(dip_byte == 'l')) THEN color_name = 'brown_____' tick_byte = dip_byte ELSE IF ((dip_byte == 'R').OR.(dip_byte == 'r')) THEN color_name = 'green_____' tick_byte = dip_byte ELSE IF ((dip_byte == 'T').OR.(dip_byte == 't')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN color_name = 'dark_blue_' tick_byte = 'P' ELSE color_name = 'mid_blue__' tick_byte = 'T' END IF ELSE ! assume gentle dip as the default: color_name = 'dark_blue_' tick_byte = 'P' END IF ELSE IF ((dip_byte == 'P').OR.(dip_byte == 'p')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN color_name = 'dark_blue_' tick_byte = 'P' ELSE color_name = 'mid_blue__' tick_byte = 'T' END IF ELSE ! assume gentle dip as the default: color_name = 'dark_blue_' tick_byte = 'P' END IF ELSE IF ((dip_byte == 'S').OR.(dip_byte == 's')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN color_name = 'dark_blue_' tick_byte = 'P' ELSE color_name = 'mid_blue__' tick_byte = 'T' END IF ELSE ! assume gentle dip as the default: color_name = 'dark_blue_' tick_byte = 'P' END IF ELSE IF ((dip_byte == 'D').OR.(dip_byte == 'd')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN color_name = 'red_______' tick_byte = 'D' ELSE color_name = 'bronze____' tick_byte = 'N' END IF ELSE ! assume steep dip as the default: color_name = 'bronze____' tick_byte = 'N' END IF ELSE IF ((dip_byte == 'N').OR.(dip_byte == 'n')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN color_name = 'red_______' tick_byte = 'D' ELSE color_name = 'bronze____' tick_byte = 'N' END IF ELSE ! assume steep dip as the default: color_name = 'bronze____' tick_byte = 'N' END IF ELSE IF (dip_byte == ' ') THEN ! provide for case of blank second dip byte color_name = 'background' tick_byte = ' ' ELSE ! any other unexpected code color_name = 'foreground' tick_byte = ' ' END IF CALL DSet_Stroke_Color (color_name) ELSE ! .NOT.ai_using_color IF (dip_byte == ' ') THEN color_name = 'background' tick_byte = ' ' ELSE ! any non-blank byte color_name = 'foreground' IF ((dip_byte == 'L').OR.(dip_byte == 'l')) THEN tick_byte = dip_byte ELSE IF ((dip_byte == 'R').OR.(dip_byte == 'r')) THEN tick_byte = dip_byte ELSE IF ((dip_byte == 'T').OR.(dip_byte == 't')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN tick_byte = 'P' ELSE tick_byte = 'T' END IF ELSE ! assume gentle dip as the default: tick_byte = 'P' END IF ELSE IF ((dip_byte == 'P').OR.(dip_byte == 'p')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN tick_byte = 'P' ELSE tick_byte = 'T' END IF ELSE ! assume gentle dip as the default: tick_byte = 'P' END IF ELSE IF ((dip_byte == 'S').OR.(dip_byte == 's')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN tick_byte = 'P' ELSE tick_byte = 'T' END IF ELSE ! assume gentle dip as the default: tick_byte = 'P' END IF ELSE IF ((dip_byte == 'D').OR.(dip_byte == 'd')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN tick_byte = 'D' ELSE tick_byte = 'N' END IF ELSE ! assume steep dip as the default: tick_byte = 'N' END IF ELSE IF ((dip_byte == 'N').OR.(dip_byte == 'n')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN tick_byte = 'D' ELSE tick_byte = 'N' END IF ELSE ! assume steep dip as the default: tick_byte = 'N' END IF ELSE IF (dip_byte == ' ') THEN ! provide for case of blank second dip byte tick_byte = ' ' ELSE ! any other unexpected code tick_byte = ' ' END IF END IF CALL DSet_Stroke_Color (color_name) END IF ! ai_using_color or not trace_radians = 0.0D0 CALL DLonLat_2_Uvec(one_trace(1,1),one_trace(2,1),uvec1) DO i = 2, count CALL DLonLat_2_Uvec(one_trace(1,i),one_trace(2,i),uvec2) tvec = uvec2 - uvec1 trace_radians = trace_radians + DLength(tvec) uvec1 = uvec2 ! preparing to loop END DO trace_points = trace_radians * (mp_radius_meters/mp_scale_denominator) * 39.37D0 * 72.D0 IF ((trace_points >= (2.D0 * tick_points)).AND.(tick_points > 0.0D0)) THEN ! long enough trace to plot a dip tick on CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = color_name) nsteps = MAX(2,NINT(trace_points/(4.D0*tick_points))) step_radians = 1.001D0 * trace_radians / nsteps CALL DLonLat_2_Uvec(one_trace(1,1),one_trace(2,1),uvec1) trace_radians = 0.D0 goal_radians = step_radians DO i = 2, count CALL DLonLat_2_Uvec(one_trace(1,i),one_trace(2,i),uvec2) tvec = uvec2 - uvec1 nudge_radians = DLength(tvec) trace_radians = trace_radians + nudge_radians IF (trace_radians > goal_radians) THEN IF (which_byte == 1) THEN ! primary dip tick !place primary dip tick mid-segment to reduce chance of misalignment tvec = 0.5D0*(uvec1 + uvec2) ELSE ! secondary dip tick !place secondary dip tick near end of segment to reduce chance of collision with primary: tvec = 0.15D0 * uvec1 + 0.85D0 * uvec2 END IF CALL DMake_Uvec(tvec, uvec3) IF ((uvec1(1) /= uvec2(1)).OR.(uvec1(2) /= uvec2(2)).OR.(uvec1(3) /= uvec2(3))) THEN dip_azimuth_radians = DRelative_Compass(uvec1,uvec2) - Pi_over_2 CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = dip_azimuth_radians, & & style_byte = tick_byte, & & size_points = tick_points, & & offset_points = offset_points) END IF goal_radians = goal_radians + step_radians END IF ! plotted a tick uvec1 = uvec2 ! preparing to loop END DO END IF ! long enough trace to plot on END DO ! which_byte = 1, 2 END IF ! got a trace to plot!!! count = 0 END IF ! hit end of segment at *** end END IF ! line did not contain "dip_degrees", so either (lon, lat) or *** end END IF ! line was not a title, so either dip_degrees, (lon, lat), or *** end END DO ! reading line of traces file (for 1st time, out of 3!) CALL DEnd_Group ! of all dip ticks CLOSE(21) ! Second group will have fault traces only. OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) CALL Could_Not_Find_File(traces_pathfile) CALL DBegin_Group ! group of all fault traces count = 0 DO ! reading lines of traces file READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, "(A1,I4,A1)", IOSTAT = internal_ios) f_byte, i, one_byte IF ((internal_ios == 0).AND.((f_byte == 'F').OR.(f_byte == 'f'))) THEN fault_number = i IF (trace_choice == 0) THEN dip_byte = one_byte ELSE dip_byte = sense(i) END IF SELECT CASE (trace_choice) CASE (0) plotting = .TRUE. CASE (1) plotting = (width_array(fault_number) > 0.0D0) END SELECT got_dip_degrees = .FALSE. ! until... ELSE ! line was not a title; this leaves 3 possibilities: dip_degrees, (lon, lat), or *** end !try to read "dip_degrees"... BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, "(A)", IOSTAT = internal_ios) line start_loc = INDEX(line, "dip_degrees") IF (start_loc > 0) THEN ! found "dip_degrees" in line beyond_loc = start_loc + 11 ! first byte which is not part of "dip_degrees" end_loc = LEN_TRIM(line) line = line(beyond_loc:end_loc) READ (line, *, IOSTAT = internal_ios) dip_degrees IF (internal_ios == 0) got_dip_degrees = .TRUE. ELSE ! "dip_degrees" not there, so either (lon, lat), or *** end !continue, on assumption that next line is probably a (lon, lat) pair... BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, *, IOSTAT = internal_ios) lon, lat IF (internal_ios == 0) THEN ! read lon, lat OK count = count + 1 one_trace(1,count) = lon one_trace(2,count) = lat ELSE ! encountered *** end of segment ***; ! finished reading a trace IF (plotting.AND.(count > 1)) THEN ! got a trace to plot!!! SELECT CASE (trace_choice) CASE (0) ! constant width width = 2.0D0 ! points CASE (1) ! width prop. to trace_mma(fault_number) width = width_array(fault_number) * dw_scale_points / dw_scale_amount END SELECT IF (ai_using_color) THEN IF ((dip_byte == 'L').OR.(dip_byte == 'l')) THEN color_name = 'brown_____' ELSE IF ((dip_byte == 'R').OR.(dip_byte == 'r')) THEN color_name = 'green_____' ELSE IF ((dip_byte == 'T').OR.(dip_byte == 't')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN color_name = 'dark_blue_' ELSE color_name = 'mid_blue__' END IF ELSE ! assume gentle dip as the default: color_name = 'dark_blue_' END IF ELSE IF ((dip_byte == 'P').OR.(dip_byte == 'p')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN color_name = 'dark_blue_' ELSE color_name = 'mid_blue__' END IF ELSE ! assume gentle dip as the default: color_name = 'dark_blue_' END IF ELSE IF ((dip_byte == 'S').OR.(dip_byte == 's')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN color_name = 'dark_blue_' ELSE color_name = 'mid_blue__' END IF ELSE ! assume gentle dip as the default: color_name = 'dark_blue_' END IF ELSE IF ((dip_byte == 'D').OR.(dip_byte == 'd')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN color_name = 'red_______' ELSE color_name = 'bronze____' END IF ELSE ! assume steep dip as the default: color_name = 'bronze____' END IF ELSE IF ((dip_byte == 'N').OR.(dip_byte == 'n')) THEN IF (got_dip_degrees) THEN IF (dip_degrees <= 45.0D0) THEN color_name = 'red_______' ELSE color_name = 'bronze____' END IF ELSE ! assume steep dip as the default: color_name = 'bronze____' END IF ELSE ! any unexpected code color_name = 'foreground' END IF CALL DSet_Stroke_Color (color_name) ELSE CALL DSet_Stroke_Color (color_name = 'foreground') END IF ! ai_using_color or not CALL DSet_Line_Style (width_points = width, dashed = .FALSE.) CALL DNew_L67_Path (7,one_trace(1,1),one_trace(2,1)) DO i = 2, count CALL DGreat_to_L67(one_trace(1,i),one_trace(2,i)) END DO CALL DEnd_L67_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! got a trace to plot!!! count = 0 END IF ! hit end of segment at *** end END IF ! line did not contain "dip_degrees", so either (lon, lat) or *** end END IF ! line was not a title, so either dip_degrees, (lon, lat), or *** end END DO ! reading line of traces file (for 2nd time) CALL DEnd_Group ! of fault traces CLOSE(21) ! Third group will have text labels. OPEN(UNIT = 21, FILE = traces_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) CALL Could_Not_Find_File(traces_pathfile) CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') CALL DBegin_Group ! group of text labels count = 0 DO ! reading lines of traces file READ (21, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, "(A1,I4,A1)", IOSTAT = internal_ios) f_byte, i, one_byte IF ((internal_ios == 0).AND.((f_byte == 'F').OR.(f_byte == 'f'))) THEN fault_number = i IF (trace_choice == 0) THEN dip_byte = one_byte ELSE dip_byte = sense(i) END IF SELECT CASE (trace_choice) CASE (0) plotting = .TRUE. CASE (1) width = width_array(fault_number) * dw_scale_points / dw_scale_amount plotting = (width >= 0.1D0) !to avoid orphan text after the trace dissapears in slide/print! END SELECT got_dip_degrees = .FALSE. ! until... ELSE ! line was not a title; this leaves 3 possibilities: dip_degrees, (lon, lat), or *** end !try to read "dip_degrees"... BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, "(A)", IOSTAT = internal_ios) line start_loc = INDEX(line, "dip_degrees") IF (start_loc > 0) THEN ! found "dip_degrees" in line beyond_loc = start_loc + 11 ! first byte which is not part of "dip_degrees" end_loc = LEN_TRIM(line) line = line(beyond_loc:end_loc) READ (line, *, IOSTAT = internal_ios) dip_degrees IF (internal_ios == 0) got_dip_degrees = .TRUE. ELSE ! "dip_degrees" not there, so either (lon, lat), or *** end !continue, on assumption that next line is probably a (lon, lat) pair... BACKSPACE (21) ! instead of READ(line,*,...) which is BUGGY! READ (21, *, IOSTAT = internal_ios) lon, lat IF (internal_ios == 0) THEN ! read lon, lat OK count = count + 1 one_trace(1,count) = lon one_trace(2,count) = lat ELSE ! encountered ***END OF SEGMENT***; ! finished reading a trace IF (plotting.AND.(count > 1)) THEN ! got a trace to plot!!! CALL DLonLat_2_Uvec (one_trace(1,1),one_trace(2,1),uvec1) CALL DLonLat_2_Uvec (one_trace(1,count),one_trace(2,count),uvec2) tvec = uvec2 - uvec1 IF (DLength(tvec) > 0.0D0) THEN SELECT CASE (trace_choice) CASE (0) ! label with id number WRITE (label,"(I10)") fault_number label = ADJUSTL(label) r1 = one_trace(1,1) r2 = one_trace(2,1) angle = Pi_over_2 - DRelative_Compass (uvec1, uvec2) lr_fraction = 0.0D0 ud_fraction = 1.0D0 CALL DL67_Text (level = 7, & & r1 = r1, r2 = r2, & & angle_radians = angle, from_east = .TRUE., & & font_points = 8, & & lr_fraction = lr_fraction, ud_fraction = ud_fraction, & & text = TRIM(label)) CASE (1) ! label with mm/a label = ADJUSTL(DASCII8(width_array(fault_number))) offset_points = 0.5D0 * width_array(fault_number) * dw_scale_points / dw_scale_amount !because of the need for this offset, use level 2 text. i1 = DInt_Below(count/2.0D0) i2 = i1 + 1 CALL DLonLat_2_Uvec (one_trace(1,i1),one_trace(2,i1),uvec1) CALL DLonLat_2_Uvec (one_trace(1,i2),one_trace(2,i2),uvec2) CALL DProject (uvec = uvec1, x = x1_meters, y = y1_meters) CALL DProject (uvec = uvec2, x = x2_meters, y = y2_meters) CALL DMeters_2_Points (x1_meters,y1_meters, x1_points,y1_points) CALL DMeters_2_Points (x2_meters,y2_meters, x2_points,y2_points) ! angle is of text baseline, counterclockwise from right, radians angle = DAtan2f((y1_points - y2_points),(x1_points - x2_points)) r1 = 0.5D0 * (x1_points + x2_points) - offset_points * DSIN(angle) r2 = 0.5D0 * (y1_points + y2_points) + offset_points * DCOS(angle) lr_fraction = 0.5D0 ud_fraction = -0.2D0 CALL DL12_Text (level = 2, & & x_points = r1, y_points = r2, & & angle_radians = angle, & & font_points = 8, & & lr_fraction = lr_fraction, ud_fraction = ud_fraction, & & text = TRIM(label)) END SELECT END IF ! trace has different 1st, last points END IF ! got a trace to plot!!! count = 0 END IF ! hit end of segment at *** end END IF ! line did not contain "dip_degrees", so either (lon, lat) or *** end END IF ! line was not a title, so either dip_degrees, (lon, lat), or *** end END DO ! reading line of traces file (for 3rd time) CALL DEnd_Group ! of text labels CLOSE(21) DEALLOCATE ( one_trace ) END SUBROUTINE Fault_Traces ! SUBROUTINE File_List( file_type, & ! & suggested_file, & ! & using_path ) ! ! Reports a list (on default device) of filenames of the type requested. ! ! ! ! Usage of CHARACTER*(*), INTENT(INOUT) :: suggested_file ! ! depends on how many files (of specified type) are ! ! found in the current using_path directory: ! ! * If none are found, suggested_file is unchanged (it may ! ! be a correct file name in some other directory). ! ! * If one file is found, suggested_file is changed to its name. ! ! * If multiple files are found: ! ! -if suggested_file is one of them, it is unchanged. ! ! -if suggested_file is not one, it is changed to ' '. ! ! ! ! Uses GETFILEINFOQQ of module DFLIB.F90 ! ! (DIGITAL Visual Fortran 5.0). ! IMPLICIT NONE ! CHARACTER*(*), INTENT(IN) :: file_type ! CHARACTER*(*), INTENT(INOUT) :: suggested_file, using_path ! CHARACTER*1 :: first_letter ! CHARACTER*70 :: line = ' ', old_name ! CHARACTER*132 :: string0, string1, string2 ! CHARACTER*255 :: files ! INTEGER :: count, full_to, old_result, result ! LOGICAL :: duplicate, matched !! TYPE file$info ! this type as defined in DFLIB.F90 !! INTEGER(4) creation !! INTEGER(4) lastwrite !! INTEGER(4) lastaccess !! INTEGER(4) length !! INTEGER(4) permit !! CHARACTER(255) name !! END TYPE file$info ! TYPE (FILE$INFO) info ! this type as defined in DFLIB.F90 ! INTEGER(4) :: handle ! must be preserved, even if rest of NKM goes to INTEGER(8). ! !10 count = 0 ! matched = .FALSE. ! until we find a file == suggested_file ! IF (file_type == "*.*") THEN ! WRITE (*,"(/' Here are all the files in the input directory:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.*' ! ! ELSE IF (file_type == "*.eqc") THEN ! WRITE (*,"(/' The following appear to be EarthQuake catalog (.eqc) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.EQC' ! ! ELSE IF (file_type == "*.dig") THEN ! WRITE (*,"(/' The following appear to be basemap (.dig) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.DIG' ! ! ELSE IF (file_type == "*.feg") THEN ! WRITE (*,"(/' The following appear to be FE grid (.feg) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.FEG' ! ELSE IF (file_type == "*.gps") THEN ! WRITE (*,"(/' The following appear to be geodetic-velocity (.gps) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.GPS' ! ELSE IF (file_type == "*.gp2") THEN ! WRITE (*,"(/' The following appear to be geodetic-covariance (.gp2) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.GP2' ! ELSE IF (file_type == "*.grd") THEN ! WRITE (*,"(/' The following appear to be gridded data (.grd) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.GRD' ! ELSE IF (file_type == "e*.nko") THEN ! WRITE (*,"(/' The following appear to be continuum strain-rate output (e*.nko) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.NKO' ! ELSE IF (file_type == "f*.dig") THEN ! WRITE (*,"(/' The following appear to be fault-trace (f*.dig) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.DIG' ! ! ELSE IF (file_type == "f*.nki") THEN ! WRITE (*,"(/' The following appear to be Fault offset-rate input (f*.nki) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.NKI' ! ELSE IF (file_type == "f*.nko") THEN ! WRITE (*,"(/' The following appear to be Fault offset-rate output (f*.nko) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.NKO' ! ELSE IF (file_type == "p*.nki") THEN ! WRITE (*,"(/' The following appear to be Parameter input (p*.nki) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.NKI' ! ELSE IF (file_type == "s*.nki") THEN ! WRITE (*,"(/' The following appear to be Stress-direction input (s*.nki) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.NKI' ! ELSE IF (file_type == "h*.nko") THEN ! WRITE (*,"(/' The following appear to be model Heave-rate output (h*.nko) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.NKO' ! ELSE IF (file_type == "s*.nko") THEN ! WRITE (*,"(/' The following appear to be interpolated Stress-direction output (s*.nko) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.NKO' ! ELSE IF (file_type == "g*.nko") THEN ! WRITE (*,"(/' The following appear to be reframed geodetic-velocity output (g*.nko) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.NKO' ! ELSE IF (file_type == "v*.out") THEN ! WRITE (*,"(/' The following appear to be velocity output (v*.out) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.OUT' ! (must also filter below to exclude force "f*.out" and text "t*.out" files) ! ELSE ! WRITE (*, "(' ERROR: Unknown file_type (',A,') requested from FileList.')") TRIM(file_type) ! CALL DTraceback ! END IF ! full_to = 0 ! keeps track of use of line ! handle = FILE$FIRST ! flag constant, defined in DFLIB as -1 ! old_result = -999 ! old_name = 'undefined' ! all_files: DO ! result = GETFILEINFOQQ (TRIM(files), info, handle) ! !check for duplicate return of last file (a bug in GETFILEINFOQQ): ! IF (result >= 1) THEN ! duplicate = (result == old_result) .AND. (info.name(1:result) == TRIM(old_name)) ! old_name = info.name(1:result) ! ELSE ! duplicate = .FALSE. ! old_name = ' ' ! END IF ! old_result = result ! !- - - - - - - - - - - - - - - - - - - ! IF (handle == FILE$ERROR) RETURN ! defined in DFLIB as -3 ! IF ((result == 0).OR.duplicate) THEN ! no (new) matching files found ! IF (full_to > 0) THEN ! WRITE (*,"(' ',A)") TRIM(line) ! GO TO 100 ! ELSE IF (count == 0) THEN ! WRITE (*,"(' No such files in directory ',A,';')") TRIM(using_path) ! CALL DPrompt_for_String('Select new directory (for this file only)?',using_path,using_path) ! GO TO 10 ! ELSE ! count > 0, but line empty ! GO TO 100 ! END IF ! END IF ! first_letter = info.name(1:1) ! !If looking for f*.dig, reject .dig files that don't start with 'f' ! IF ((file_type == "f*.dig").AND.(.NOT.((first_letter == 'F').OR.(first_letter == 'f')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for f*.nki, reject "input" files that don't start with 'f' ! IF ((file_type == "f*.nki").AND.(.NOT.((first_letter == 'F').OR.(first_letter == 'f')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for p*.nki, reject "parameter" files that don't start with 'p' ! IF ((file_type == "p*.nki").AND.(.NOT.((first_letter == 'P').OR.(first_letter == 'p')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for s*.nki, reject "input" files that don't start with 's' ! IF ((file_type == "s*.nki").AND.(.NOT.((first_letter == 'S').OR.(first_letter == 's')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for e*.nko, reject "output" files that don't start with 'e' ! IF ((file_type == "e*.nko").AND.(.NOT.((first_letter == 'E').OR.(first_letter == 'e')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for f*.nko, reject "output" files that don't start with 'f' ! IF ((file_type == "f*.nko").AND.(.NOT.((first_letter == 'F').OR.(first_letter == 'f')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for h*.nko, reject "output" files that don't start with 'h' ! IF ((file_type == "h*.nko").AND.(.NOT.((first_letter == 'H').OR.(first_letter == 'h')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for s*.nko, reject "output" files that don't start with 's' ! IF ((file_type == "s*.nko").AND.(.NOT.((first_letter == 'S').OR.(first_letter == 's')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for g*.nko, reject "output" files that don't start with 'g' ! IF ((file_type == "g*.nko").AND.(.NOT.((first_letter == 'G').OR.(first_letter == 'g')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for v*.out, reject "velocity" files that don't start with 'v' ! IF ((file_type == "v*.out").AND.(.NOT.((first_letter == 'V').OR.(first_letter == 'v')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If we've gotten this far, we have a qualified file! ! count = count + 1 ! string0 = TRIM(suggested_file) ! CALL DUpper_Case(string0) ! string1 = info.name(1:result) ! string2 = string1 ! CALL DUpper_Case(string2) ! matched = matched .OR. (string0 == string2) ! IF ((full_to + 2 + result) > 70) THEN ! line would overflow ! WRITE (*,"(' ',A)") TRIM(line) ! full_to = 0 ! line = ' ' ! line = info.name(1:result) ! full_to = result ! ELSE ! line can accept this name ! IF (full_to == 0) THEN ! no leading spaces ! line = info.name(1:result) ! full_to = result ! ELSE ! use 2 leading spaces ! line = TRIM(line) // ' ' // info.name(1:result) ! full_to = full_to + 2 + result ! END IF ! END IF ! IF (handle == FILE$LAST) THEN ! IF (full_to > 0) WRITE (*,"(' ',A)") TRIM(line) ! GO TO 100 ! END IF ! END DO all_files ! 100 IF (count == 1) THEN ! collector point, replacing "RETURN" ! ! so that we can adjust suggested_file(?) ! suggested_file = TRIM(string1) ! ELSE IF (count > 1) THEN ! IF (.NOT.matched) THEN ! suggested_file = ' ' ! END IF ! END IF ! END SUBROUTINE File_List SUBROUTINE Get_filename (unit, filename, error) ! Obtains a filename from the beginning of the next line; ! name may be padded with blanks on both sides, and ! may be followed by comments. Note that ! "unit" should have been opened with PAD = "YES". IMPLICIT NONE INTEGER, INTENT (IN) :: unit ! Fortran device number to READ CHARACTER*132, INTENT(OUT) :: filename ! main result of this SUBR LOGICAL, INTENT(OUT) :: error ! IF (ios /= 0) error = .TRUE. CHARACTER(132) :: buffer INTEGER :: i, ios LOGICAL :: past error = .FALSE. ! unless changed below READ (unit,"(A)", IOSTAT = ios) buffer IF (ios /= 0) THEN error = .TRUE. RETURN END IF buffer = ADJUSTL(buffer) ! left-justify past = .FALSE. ! will be T when past end of filename blank_right: DO i=2,132 IF ((buffer(i:i) == ' ') .OR. & (buffer(i:i) == ',') .OR. & (buffer(i:i) == '=') .OR. & (buffer(i:i) == ':')) past = .TRUE. if (past) buffer(i:i) = ' ' END DO blank_right IF (((buffer(1:1) == 'N') .OR. (buffer(1:1) == 'n')) .AND. & ((buffer(2:2) == 'O') .OR. (buffer(2:2) == 'o')) .AND. & ((buffer(3:3) == 'N') .OR. (buffer(3:3) == 'n')) .AND. & ((buffer(4:4) == 'E') .OR. (buffer(4:4) == 'e')) .AND. & (buffer(5:5) == ' ')) buffer = 'none' filename = buffer(1:80) END SUBROUTINE Get_filename SUBROUTINE Get_Parameters ! Reads input parameter file p*.nki ! and memorizes its contents. ! Values reside in global variables. ! This is just a SUBR to avoid repetition of code. ! ! Revised 2014.10.04 to read EITHER NeoKinema v1.x, or NeoKinema v2.x - ! NeoKinema v3.x, OR NeoKinema v.4.x parameter file. ! input parameter files. IMPLICIT NONE CHARACTER*132 :: temp_path_in = ' ' INTEGER :: gps_index_1, gps_index_2, ios, line LOGICAL :: bad_parameter, any_bad_parameters REAL*8 :: t, t1, t2 !NOTE that this routine also uses (and fills) global variables like mu_, xi_, ! sigma_offnormal_degrees, .... temp_path_in = path_in !N.B. parameter_file is a global character variable. !CALL File_List( file_type = "p*.nki", & ! & suggested_file = parameter_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which parameter file should be used?',parameter_file,parameter_file) parameter_pathfile = TRIM(temp_path_in)//TRIM(parameter_file) !------- Try reading file by assuming that it is in NeoKinema v1.x format: OPEN (UNIT = 1, FILE = parameter_pathfile, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(parameter_pathfile) any_bad_parameters = .FALSE. ! until an error occurs (below) CALL Get_Filename(1, token, bad_parameter) any_bad_parameters = any_bad_parameters .OR. bad_parameter ! delaying reaction line = 1 ! number of refinements READ (1, *, IOSTAT = ios) n_refine ; line = line + 1 IF (n_refine < 0) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! strain-rate uncertainty for rigid blocks READ (1, *, IOSTAT = ios) mu_ ; line = line + 1 IF (mu_ <= 0.D0) bad_parameter = .TRUE. IF (mu_ < DSQRT(1.1D0 * TINY(mu_))) bad_parameter = .TRUE. IF (mu_ > 1.D-10) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! small strain-rate increment (xi_) for imposing stress-directions READ (1, *, IOSTAT = ios) xi_ ; line = line + 1 IF (xi_ <= 0.D0) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! sigma, in degrees, of angle between [heave vectors of dip-slip faults] & [trace-normal direction] READ (1, *, IOSTAT = ios) sigma_offnormal_degrees ; line = line + 1 IF (sigma_offnormal_degrees < 0.D0) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! radius of planet READ (1, *, IOSTAT = ios) t ; line = line + 1 IF (t <= 0.D0) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter R = t * m_per_km ! minimum and maximum locking depths of intraplate faults, in km READ (1, *, IOSTAT = ios) t1, t2 ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) locking_depth_m_min = t1 * 1000.0D0 locking_depth_m_max = t2 * 1000.0D0 ! minimum and maximum locking depths of subduction zones, in km READ (1, *, IOSTAT = ios) t1, t2 ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) locking_depth_m_subduction_min = t1 * 1000.0D0 locking_depth_m_subduction_max = t2 * 1000.0D0 ! do new active faults count as sigma_1h data? READ (1, *, IOSTAT = ios) faults_give_sigma_1h ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! names of additional input files (or, "none ") CALL Get_filename (1, f_dat, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter IF (f_dat(1:5) == 'none ') THEN READ (1,*) ; line = line + 1 ! read and ignore f_dig = 'skipped' ELSE CALL Get_filename (1, f_dig, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter END IF CALL Get_filename (1, s_dat, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter CALL Get_filename (1, gps_file, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter CALL Get_filename (1, gp2_file, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter ! is velocity reference frame for geodetic data allowed to float? READ (1, *, IOSTAT =ios) floating_frame ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! conservative_geodetic_adjustment? (using geologic slip rates) READ (1, *, IOSTAT = ios) conservative_geodetic_adjustment ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! weight factor for all geodetic data: READ (1, *, IOSTAT = ios) geodesy_weight ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) CALL Get_filename (1, x_feg, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter CALL Get_filename (1, x_bcs, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter READ (1,"(A)", IOSTAT = ios) reference_plate_c2; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) CLOSE (UNIT = 1) ! close parameter_file IF (.NOT.any_bad_parameters) THEN got_parameters = .TRUE. f_dat_pathfile = TRIM(path_in) // TRIM(f_dat) f_dig_pathfile = TRIM(path_in) // TRIM(f_dig) s_dat_pathfile = TRIM(path_in) // TRIM(s_dat) gps_pathfile = TRIM(path_in) // TRIM(gps_file) x_feg_pathfile = TRIM(path_in) // TRIM(x_feg) x_bcs_pathfile = TRIM(path_in) // TRIM(x_bcs) RETURN END IF !=========== Note: We only reach here if there was an error during reading ! of parameters under assumption of NeoKinema v1.x format. !------- Try reading file by assuming that it is in NeoKinema v2.x~v3.x format, !------- in which case it has new lines added for parameters L0 and A0. OPEN (UNIT = 1, FILE = parameter_pathfile, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(parameter_pathfile) any_bad_parameters = .FALSE. ! until an error occurs (below) CALL Get_Filename(1, token, bad_parameter) any_bad_parameters = any_bad_parameters .OR. bad_parameter ! delaying reaction line = 1 ! L0 READ (1, *, IOSTAT = ios) L0 ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! A0 READ (1, *, IOSTAT = ios) A0 ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! number of refinements READ (1, *, IOSTAT = ios) n_refine ; line = line + 1 IF (n_refine < 0) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! strain-rate uncertainty for rigid blocks READ (1, *, IOSTAT = ios) mu_ ; line = line + 1 IF (mu_ <= 0.D0) bad_parameter = .TRUE. IF (mu_ < DSQRT(1.1D0 * TINY(mu_))) bad_parameter = .TRUE. IF (mu_ > 1.D-10) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! small strain-rate increment (xi_) for imposing stress-directions READ (1, *, IOSTAT = ios) xi_ ; line = line + 1 IF (xi_ <= 0.) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! sigma, in degrees, of angle between [heave vectors of dip-slip faults] & [trace-normal direction] READ (1, *, IOSTAT = ios) sigma_offnormal_degrees ; line = line + 1 IF (sigma_offnormal_degrees < 0.D0) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! radius of planet READ (1, *, IOSTAT = ios) t ; line = line + 1 IF (t <= 0.D0) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter R = t * m_per_km ! minimum and maximum locking depths of intraplate faults, in km READ (1, *, IOSTAT = ios) t1, t2 ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) locking_depth_m_min = t1 * 1000.0D0 locking_depth_m_max = t2 * 1000.0D0 ! minimum and maximum locking depths of subduction zones, in km READ (1, *, IOSTAT = ios) t1, t2 ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) locking_depth_m_subduction_min = t1 * 1000.0D0 locking_depth_m_subduction_max = t2 * 1000.0D0 ! do new active faults count as sigma_1h data? READ (1, *, IOSTAT = ios) faults_give_sigma_1h ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! names of additional input files (or, "none ") CALL Get_filename (1, f_dat, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter IF (f_dat(1:5) == 'none ') THEN READ (1,*) ; line = line + 1 ! read and ignore f_dig = 'skipped' ELSE CALL Get_filename (1, f_dig, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter END IF CALL Get_filename (1, s_dat, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter CALL Get_filename (1, gps_file, bad_parameter) ; line = line + 1 !Protect against reading "INTEGER :: stress_interpolation_method" of a NKv4 parameter file; !do this by searching for required filename extension ".gps". gps_index_1 = INDEX(gps_file, ".gps") gps_index_2 = INDEX(gps_file, ".GPS") bad_parameter = ((gps_index_1 == 0).AND.(gps_index_2 == 0)) any_bad_parameters = any_bad_parameters .OR. bad_parameter CALL Get_filename (1, gp2_file, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter ! is velocity reference frame for geodetic data allowed to float? READ (1, *, IOSTAT =ios) floating_frame ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! conservative_geodetic_adjustment? (using geologic slip rates) READ (1, *, IOSTAT = ios) conservative_geodetic_adjustment ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! weight factor for all geodetic data: geodesy_weight = 1.0D0 ! by definition in NeoKinema v2.x CALL Get_filename (1, x_feg, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter CALL Get_filename (1, x_bcs, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter READ (1,"(A)", IOSTAT = ios) reference_plate_c2; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) CLOSE (UNIT = 1) ! close parameter_file IF (.NOT.any_bad_parameters) THEN got_parameters = .TRUE. f_dat_pathfile = TRIM(path_in) // TRIM(f_dat) f_dig_pathfile = TRIM(path_in) // TRIM(f_dig) s_dat_pathfile = TRIM(path_in) // TRIM(s_dat) gps_pathfile = TRIM(path_in) // TRIM(gps_file) x_feg_pathfile = TRIM(path_in) // TRIM(x_feg) x_bcs_pathfile = TRIM(path_in) // TRIM(x_bcs) RETURN END IF !=========== Note: We only reach here if there was an error during reading ! of parameters under assumption of NeoKinema v1.x format, AND ! under assumption of NeoKinema v2.x~3.x format. !------- Try reading file by assuming that it is in NeoKinema v4.x format, !------- in which case it has ANOTHER new line added for parameter "stress_interpolation_method" !------- coming after "s_dat" and before "gps_file". OPEN (UNIT = 1, FILE = parameter_pathfile, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) IF (ios /= 0) CALL Could_Not_Find_File(parameter_pathfile) any_bad_parameters = .FALSE. ! until an error occurs (below) CALL Get_Filename(1, token, bad_parameter) any_bad_parameters = any_bad_parameters .OR. bad_parameter ! delaying reaction line = 1 ! L0 READ (1, *, IOSTAT = ios) L0 ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! A0 READ (1, *, IOSTAT = ios) A0 ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! number of refinements READ (1, *, IOSTAT = ios) n_refine ; line = line + 1 IF (n_refine < 0) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! strain-rate uncertainty for rigid blocks READ (1, *, IOSTAT = ios) mu_ ; line = line + 1 IF (mu_ <= 0.D0) bad_parameter = .TRUE. IF (mu_ < DSQRT(1.1D0 * TINY(mu_))) bad_parameter = .TRUE. IF (mu_ > 1.D-10) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! small strain-rate increment (xi_) for imposing stress-directions READ (1, *, IOSTAT = ios) xi_ ; line = line + 1 IF (xi_ <= 0.D0) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! sigma, in degrees, of angle between [heave vectors of dip-slip faults] & [trace-normal direction] READ (1, *, IOSTAT = ios) sigma_offnormal_degrees ; line = line + 1 IF (sigma_offnormal_degrees < 0.D0) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter ! radius of planet READ (1, *, IOSTAT = ios) t ; line = line + 1 IF (t <= 0.D0) bad_parameter = .TRUE. any_bad_parameters = any_bad_parameters .OR. (ios /= 0) .OR. bad_parameter R = t * m_per_km ! minimum and maximum locking depths of intraplate faults, in km READ (1, *, IOSTAT = ios) t1, t2 ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) locking_depth_m_min = t1 * 1000.0D0 locking_depth_m_max = t2 * 1000.0D0 ! minimum and maximum locking depths of subduction zones, in km READ (1, *, IOSTAT = ios) t1, t2 ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) locking_depth_m_subduction_min = t1 * 1000.0D0 locking_depth_m_subduction_max = t2 * 1000.0D0 ! do new active faults count as sigma_1h data? READ (1, *, IOSTAT = ios) faults_give_sigma_1h ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! names of additional input files (or, "none ") CALL Get_filename (1, f_dat, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter IF (f_dat(1:5) == 'none ') THEN READ (1,*) ; line = line + 1 ! read and ignore f_dig = 'skipped' ELSE CALL Get_filename (1, f_dig, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter END IF CALL Get_filename (1, s_dat, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter ! stress interpolation method (INTEGER index): line = line + 1 READ (1, *, IOSTAT = ios) stress_interpolation_method bad_parameter = (ios /= 0) any_bad_parameters = any_bad_parameters .OR. bad_parameter CALL Get_filename (1, gps_file, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter CALL Get_filename (1, gp2_file, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter ! is velocity reference frame for geodetic data allowed to float? READ (1, *, IOSTAT =ios) floating_frame ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! conservative_geodetic_adjustment? (using geologic slip rates) READ (1, *, IOSTAT = ios) conservative_geodetic_adjustment ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) ! weight factor for all geodetic data: geodesy_weight = 1.0D0 ! by definition in NeoKinema v2.x and beyond CALL Get_filename (1, x_feg, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter CALL Get_filename (1, x_bcs, bad_parameter) ; line = line + 1 any_bad_parameters = any_bad_parameters .OR. bad_parameter READ (1,"(A)", IOSTAT = ios) reference_plate_c2; line = line + 1 any_bad_parameters = any_bad_parameters .OR. (ios /= 0) CLOSE (UNIT = 1) ! close parameter_file IF (.NOT.any_bad_parameters) THEN got_parameters = .TRUE. f_dat_pathfile = TRIM(path_in) // TRIM(f_dat) f_dig_pathfile = TRIM(path_in) // TRIM(f_dig) s_dat_pathfile = TRIM(path_in) // TRIM(s_dat) gps_pathfile = TRIM(path_in) // TRIM(gps_file) x_feg_pathfile = TRIM(path_in) // TRIM(x_feg) x_bcs_pathfile = TRIM(path_in) // TRIM(x_bcs) RETURN END IF !=========== Note: We only reach here if there was an error during reading ! of parameters under assumptions of NeoKinema v1.x format, ! NeoKinema v2.x~3,x, and NeoKinema v4.x format! CALL Bad_Parameters() END SUBROUTINE Get_Parameters SUBROUTINE Histogram (real_list, list_length, skip_zeros, maximum, minimum) ! Puts a printer-plot on the default device, no more than ! (n15 + 2) rows tall by n70 bytes wide, showing the range and ! distribution of values within real_list. IMPLICIT NONE REAL*8, DIMENSION(:), INTENT(IN) :: real_list INTEGER, INTENT(IN) :: list_length LOGICAL, INTENT(IN) :: skip_zeros REAL*8, INTENT(OUT) :: maximum, minimum INTEGER, PARAMETER :: n15 = 15, n70 = 70 REAL*8, PARAMETER :: Huge = 9.99D59 CHARACTER*10 :: number10 CHARACTER*(n70) :: line INTEGER :: highest, i, j, length INTEGER, DIMENSION(:), ALLOCATABLE :: counters REAL*8 :: dx, factor IF (list_length < 1) RETURN IF (skip_zeros) THEN maximum = -Huge minimum = +Huge DO i = 1, list_length IF (real_list(i) /= 0.0D0) THEN maximum = MAX(maximum, real_list(i)) minimum = MIN(minimum, real_list(i)) END IF END DO ELSE maximum = real_list(1) minimum = maximum DO i = 2, list_length maximum = MAX(maximum, real_list(i)) minimum = MIN(minimum, real_list(i)) END DO END IF dx = (maximum - minimum) / (n70 - 1) IF (dx == 0.0D0) dx = 1.00D0 ! avoid divide-by-zero ALLOCATE ( counters(n70) ) counters = 0 ! whole array DO i = 1, list_length IF (skip_zeros) THEN IF (real_list(i) /= 0.0D0) THEN j = 1 + DInt_Below((real_list(i) - minimum) / dx) counters(j) = counters(j) + 1 END IF ELSE j = 1 + DInt_Below((real_list(i) - minimum) / dx) counters(j) = counters(j) + 1 END IF END DO highest = 0 DO j = 1, n70 highest = MAX(highest,counters(j)) END DO factor = (1.D0 * n15) / (1.D0 * highest) DO i = n15, 1, -1 ! rows, from top to bottom line = ' ' DO j = 1, n70 ! columns !In bottom row only, put "." to show non-zero contents: IF (i == 1) THEN ! bottom row IF (counters(j) > 0) line(j:j) = '.' END IF IF (NINT(factor * counters(j)) >= i) line(j:j) = '*' END DO ! columns WRITE (*,"(' ',A)") TRIM(line) END DO ! rows line = REPEAT('-',n70) WRITE (*,"(' ', A)") line number10 = DASCII10(minimum) line = TRIM(ADJUSTL(number10)) number10 = DASCII10(maximum) number10 = ADJUSTL(number10) length = LEN_TRIM(number10) line((n70 - length + 1):n70) = TRIM(number10) WRITE (*,"(' ', A)") line DEALLOCATE ( counters ) END SUBROUTINE Histogram SUBROUTINE No_Fault_Elements_Allowed() ! Called if nfl > 0 in the .feg file: ! Prints explanatory messages and stops execution. IMPLICIT NONE 101 FORMAT (& &/' This .feg (finite element grid) file contains fault elements!'& &/' Fault elements are not allowed in NeoKinema grids, because:'& &/' I. NeoKinema does not require fault elements.'& &/' 1. NeoKinema has logic to add the compliance of any number of'& &/' faults to the continuum (triangle) elements that contain them.'& &/' 2. NeoKinema has logic to infer the heave-rate and slip-rate of'& &/' such implied fault(s) from the computed strain-rate of the'& &/' triangular continuum element(s).'& &/' 3. Graphics program NeoKineMap has logic to plot the heave-rates'& &/' of these faults, and also velocity fields with fault '& &/' disontinuities, without the use of fault elements.') 102 FORMAT (& &/' II. Fault elements cause bad grid topology.'& &/' 1. Fault elements are not read or stored by NeoKineMap.'& &/' 2. With fault elements deleted, the grids on the two sides of'& &/' each fault are not connected in any way.'& &/' 3. The solution process may fail due to a singular stiffness'& &/' matrix during solution of the linear system.'& &/' 4. Even if the solution does not fail, its physical interpretation'& &/' will be problematical.') 103 FORMAT (& &/' III. Fault elements should be eliminated from the .feg file.'& &/' 1. Re-load this .feg file into OrbWeaver, select command Faults,'& &/' and use the right mouse button to heal the fault cuts.'& &/' 2. Use command Adjust to move all nodes off of fault traces.'& &/' 3. Save the edited grid and re-number it with OrbNumber.'& &/' 4. Alternatively, use command Tile in OrbWeaver to create a'& &/' new .feg grid with no fault elements.') WRITE (*, 101) CALL Pause() WRITE (*, 102) CALL Pause() WRITE (*, 103) CALL Pause() STOP END SUBROUTINE No_Fault_Elements_Allowed SUBROUTINE Pause() IMPLICIT NONE WRITE (*,"(' Press [Enter]...'\)") READ (*,*) END SUBROUTINE Pause SUBROUTINE Plot_Fault_Ticks (colored) ! uses global variables and arrays LOGICAL, INTENT(IN) :: colored IF (colored) THEN CALL DSet_Stroke_Color ('red_______') CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF CALL DBegin_Group ! of dip ticks CALL DSet_Line_Style (width_points = 0.6D0, dashed = .FALSE.) DO i = 1, nfl dip_degrees = (fdip(1,i) + fdip(2,i))/2.D0 uvec1(1:3) = node_uvec(1:3,nodef(1,i)) uvec2(1:3) = node_uvec(1:3,nodef(2,i)) uvec3(1:3) = (uvec1(1:3) + uvec2(1:3))/2.D0 tick_azimuth = DCompass (from_uvec = uvec3, to_uvec = uvec2) IF (dip_degrees > 0.D0) THEN tick_azimuth = tick_azimuth + Pi/2.D0 ELSE ! negative dip means dipping from N3-N4 side. tick_azimuth = tick_azimuth - Pi/2.D0 END IF IF (DABS(dip_degrees) >= 73.D0) THEN ! ~Vertical fault; no dip ticks (sense undefined). ELSE IF (DABS(dip_degrees) > 45.D0) THEN ! ~65 deg. dip; use normal fault symbol CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = tick_azimuth, & & style_byte = 'N', & & size_points = tick_points, & & offset_points = 0.8D0) ELSE IF (DABS(dip_degrees) > 35.D0) THEN ! ~45 deg. dip; use ambiguous/detachment fault symbol CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = tick_azimuth, & & style_byte = 'D', & & size_points = tick_points, & & offset_points = 0.8D0) ELSE IF (DABS(dip_degrees) > subdip) THEN ! (high-angle) thrust; i.e., not a subduction zone in SHELLS CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = tick_azimuth, & & style_byte = 'T', & & size_points = tick_points, & & offset_points = 0.8D0) ELSE ! (low-angle) thrust; a subduction zone in SHELLS CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = tick_azimuth, & & style_byte = 'P', & & size_points = tick_points, & & offset_points = 0.8D0) END IF ! different dip symbols END DO ! i = 1, nfl CALL DEnd_Group ! of dip ticks END SUBROUTINE Plot_Fault_Ticks SUBROUTINE Plot_Fault_Traces (colored) ! uses global variables and arrays LOGICAL, INTENT(IN) :: colored IF (colored) THEN CALL DSet_Stroke_Color ('red_______') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DBegin_Group ! of fault traces CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) DO i = 1, nfl uvec1(1:3) = node_uvec(1:3,nodef(1,i)) CALL DNew_L45_Path (5, uvec1) uvec2(1:3) = node_uvec(1:3,nodef(2,i)) CALL DGreat_To_L45 (uvec2) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! i = 1, nfl CALL DEnd_Group ! of fault traces END SUBROUTINE Plot_Fault_Traces SUBROUTINE Prevent (bad_thing, line, filename) INTEGER, INTENT(IN) :: line CHARACTER(*), INTENT(IN) :: bad_thing, filename PRINT "(' Error: ',A,' is illegal in line ',I6/' of ',A)", & TRIM(bad_thing), line, TRIM(filename) STOP ' ' END SUBROUTINE Prevent SUBROUTINE 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 IMPLICIT NONE REAL*8, INTENT(IN) :: reference_Elon_deg, reference_Nlat_deg, reference_vE_mmpa, reference_vN_mmpa, reference_ccw_degpMa INTEGER, INTENT(IN) :: benchmarks REAL*8, DIMENSION(:,:), INTENT(IN) :: benchmark_uvec REAL*8, DIMENSION(:), INTENT(IN OUT) :: benchmark_E_velocity, benchmark_N_velocity, benchmark_hypotenuse INTEGER :: i REAL*8 :: v_East_mps, v_South_mps, vE_referenced_mmpa, vN_referenced_mmpa REAL*8, DIMENSION(3) :: euler, euler1, euler2, phi_uvec, reference_uvec, theta_uvec, tvec, velocity CALL DLonLat_2_Uvec(reference_Elon_deg, reference_Nlat_deg, reference_uvec) !Find the euler pole for the non-rotational velocity at the reference point (which is to be removed): CALL DLocal_Theta(reference_uvec, theta_uvec) CALL DLocal_Phi (reference_uvec, phi_uvec) velocity(1:3) = -reference_vN_mmpa * theta_uvec(1:3) & & +reference_vE_mmpa * phi_uvec(1:3) ! initially in mm/a velocity = velocity / (1000.D0 * sec_per_year) ! now in m/s CALL DCross(reference_uvec, velocity, euler1) ! reference_uvec and velocity were already perpendicular euler1 = euler1 / R ! now in units of radians/s. ! euler1 now describes the reference velocity vector at the reference point, using a pole 90 deg. away. ! It is in units of radians per second. !Find the euler pole for the rotation about reference point (which is to be removed): euler2 = (reference_ccw_degpMa * radians_per_degree / (1.0D6 * sec_per_year)) * reference_uvec !This is also in units of radians per second. euler = euler1 + euler2 ! this is the total rotation (in radians/s) which is to be REMOVED. DO i = 1, benchmarks uvec(1:3) = benchmark_uvec(1:3, i) CALL DCross (euler, uvec, tvec) ! tvec is in radians/s tvec = tvec * R ! now it is in m/s CALL DLocal_Theta(uvec, theta_uvec) ! at the benchmark, now CALL DLocal_Phi (uvec, phi_uvec) v_East_mps = phi_uvec(1)*tvec(1) + phi_uvec(2)*tvec(2) + phi_uvec(3)*tvec(3) v_South_mps = theta_uvec(1)*tvec(1) + theta_uvec(2)*tvec(2) + theta_uvec(3)*tvec(3) vE_referenced_mmpa = +v_East_mps * 1000.D0 * sec_per_year vN_referenced_mmpa = -v_South_mps * 1000.D0 * sec_per_year benchmark_E_velocity(i) = benchmark_E_velocity(i) - vE_referenced_mmpa benchmark_N_velocity(i) = benchmark_N_velocity(i) - vN_referenced_mmpa benchmark_hypotenuse(i) = DSQRT(benchmark_E_velocity(i)**2 + benchmark_N_velocity(i)**2) END DO ! i = 1, benchmarks END SUBROUTINE Reframe_Velocity_at_Benchmarks SUBROUTINE 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 ! Adjusts velocities (packed in "vw") of all "numnod" nodes (with positions "node_uvec") ! so that "fixed_node" is not moving, and "nonorbiting_node" is not rotating around it. ! Reports an alternative description of the reference frame change in variables: !"reference_Elon_deg, reference_Nlat_deg, reference_vE_mmpa, reference_vN_mmpa, reference_ccw_degpMa" ! so that this information can be used to reframe geodetic velocities, if desired. IMPLICIT NONE INTEGER, INTENT(IN) :: fixed_node, nonorbiting_node, numnod REAL*8, DIMENSION(:, :), INTENT(IN) :: node_uvec ! (1:3, 1:numnod) DOUBLE PRECISION, DIMENSION(:), INTENT(IN OUT) :: vw ! (1:2*numnod) REAL*8, INTENT(OUT) :: reference_Elon_deg, reference_Nlat_deg, & & reference_vE_mmpa, reference_vN_mmpa, reference_ccw_degpMa INTEGER :: i REAL*8 :: spin, v_East_at2, v_East_mps, v_South_at2, v_South_mps REAL*8, DIMENSION(3) :: about_uvec, euler1, euler2, euler3, & & phi_uvec, reference_uvec, theta_uvec, tvec, & & uvec, uvec1, uvec2, velocity1, velocity2 uvec1(1:3) = node_uvec(1:3, fixed_node) CALL DUvec_2_LonLat(uvec1, reference_Elon_deg, reference_Nlat_deg) reference_vE_mmpa = +1000.D0 * sec_per_year * vw(2 * fixed_node) reference_vN_mmpa = -1000.D0 * sec_per_year * vw(2 * fixed_node - 1) CALL DLocal_Theta(uvec1, theta_uvec) CALL DLocal_Phi (uvec1, phi_uvec) velocity1(1:3) = vw(2 * fixed_node -1) * theta_uvec(1:3) + & & vw(2 * fixed_node) * phi_uvec(1:3) ! this is in 3-D Cartesian m/s CALL DCross(uvec1, velocity1, euler1) ! uvec1 and velocity1 are already perpendicular euler1 = euler1 / R ! converting from m/s to radians/s ! euler1 now describes the velocity of fixed_node, using a pole 90 deg. away uvec2(1:3) = node_uvec(1:3, nonorbiting_node) CALL DLocal_Theta(uvec2, theta_uvec) CALL DLocal_Phi (uvec2, phi_uvec) v_South_at2 = vw(2 * nonorbiting_node - 1) ! in m/s v_East_at2 = vw(2 * nonorbiting_node) velocity2(1:3) = v_South_at2 * theta_uvec(1:3) + & & v_East_at2 * phi_uvec(1:3) ! in Cartesian 3-D m/s !correct velocity2 for rotation euler1: CALL DCross (euler1, uvec2, tvec) ! tvec is in radians/s tvec = tvec * R ! now, it is in m/s v_South_mps = theta_uvec(1)*tvec(1) + theta_uvec(2)*tvec(2) + theta_uvec(3)*tvec(3) v_East_mps = phi_uvec(1)*tvec(1) + phi_uvec(2)*tvec(2) + phi_uvec(3)*tvec(3) v_South_at2 = v_South_at2 - v_South_mps v_East_at2 = v_East_at2 - v_East_mps ! in m/s velocity2(1:3) = v_South_at2 * theta_uvec(1:3) + & & v_East_at2 * phi_uvec(1:3) ! in m/s CALL DCross (uvec1, uvec2, tvec) CALL DMake_Uvec(tvec, about_uvec) ! direction of counterclockwise circling component at uvec2 spin = (velocity2(1)*about_uvec(1) + & & velocity2(2)*about_uvec(2) + & & velocity2(3)*about_uvec(3)) / (R * DSIN(DArc(uvec1, uvec2))) ! in radians/s reference_ccw_degpMa = spin * degrees_per_radian * 1.0D6 * sec_per_year euler2(1:3) = uvec1(1:3) * spin ! this component rotates nonorbiting_node about fixed_node, in radians/s euler3 = euler1 + euler2 ! this is the total rotation-rate that we need to subtract, in radians/s DO i = 1, numnod ! remove this rotation from all nodes uvec(1:3) = node_uvec(1:3, i) CALL DCross (euler3, uvec, tvec) ! tvec initially in radians/s tvec = tvec * R ! now, it is in m/s CALL DLocal_Theta(uvec, theta_uvec) CALL DLocal_Phi (uvec, phi_uvec) v_South_mps = theta_uvec(1)*tvec(1) + theta_uvec(2)*tvec(2) + theta_uvec(3)*tvec(3) v_East_mps = phi_uvec(1)*tvec(1) + phi_uvec(2)*tvec(2) + phi_uvec(3)*tvec(3) vw(2*i-1) = vw(2*i-1) - v_South_mps vw(2*i) = vw(2*i) - v_East_mps END DO ! i = 1, numnod END SUBROUTINE Reframe_Velocity_at_Nodes SUBROUTINE Rotation_rate (R, l_, nodes, G, dG, theta_, vw, rotationrate) ! Evaluate rotation-rate in spherical continuum element !(of rigid cylinder, about the local vertical axis, ! in units of radians per second, with counterclockwise positive). ! Note that exact position in element is implied by values in arrays G and dG; ! input parameter theta_ must agree! REAL*8, INTENT(IN) :: R ! radius of planet, in m INTEGER, INTENT(IN) :: l_ ! element number INTEGER, DIMENSION(:,:), INTENT(IN) :: nodes DOUBLE PRECISION, DIMENSION(3,2,2) :: G ! nodal functions @ selected point DOUBLE PRECISION, DIMENSION(3,2,2,2):: dG ! derivitives of nodal functions REAL*8, INTENT(IN) :: theta_ ! colatitude, radians DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: vw REAL*8, INTENT(OUT) :: rotationrate INTEGER :: iv, iw, j REAL*8 :: cott, csct, prefix rotationrate = 0.0D0 cott = 1.0D0 / DTAN(theta_) csct = 1.0D0 / DSIN(theta_) prefix = 0.5D0 / R DO j = 1, 3 ! v is Southward velocity; w is Eastward velocity iv = 2 * nodes(j, l_) - 1 iw = iv + 1 ! w / tan(theta_) = w * cot(theta_) [ use G(j,x,2) ]: rotationrate = rotationrate + & & prefix * (vw(iv) * G(j,1,2) + vw(iw) * G(j,2,2)) * cott ! d w / d theta_ [ use dG(j,x,2,1) ]: rotationrate = rotationrate + & & prefix * (vw(iv) * dG(j,1,2,1) + vw(iw) * dG(j,2,2,1)) ! -csc(theta_) * d v / d phi_ [ use dG(j,x,1,2) ]: rotationrate = rotationrate - & & prefix * csct * (vw(iv) * dG(j,1,1,2) + vw(iw) * dG(j,2,1,2)) END DO ! 3 local nodes END SUBROUTINE Rotation_rate SUBROUTINE Slip_Sample(x_center_points, y_base_points, & & color_name, text) !plots a 62-point x 2 point horizontal fault at level 1 !centered on (x_center_points, y_base_points) !and decorates it with a 20pt-wide band of "color_name" with "text" superposed REAL*8, INTENT(IN) :: x_center_points, y_base_points CHARACTER*(*), INTENT(IN) :: color_name, text CALL DSet_Fill_or_Pattern(.FALSE.,color_name) CALL DNew_L12_Path(1, x_center_points - 31.D0, y_base_points) CALL DLine_to_L12(x_center_points + 31.D0, y_base_points) CALL DLine_to_L12(x_center_points + 31.D0, y_base_points+20.D0) CALL DLine_to_L12(x_center_points - 31.D0, y_base_points+20.D0) CALL DLine_to_L12(x_center_points - 31.D0, y_base_points) CALL DEnd_L12_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x_center_points - 31.D0, y_base_points) CALL DLine_to_L12(x_center_points + 31.D0, y_base_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x_center_points, & & y_points = y_base_points+10.D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = TRIM(ADJUSTL(text))) END SUBROUTINE Slip_Sample SUBROUTINE Velocity_Explanation() !This block of code is only a SUBR to prevent it appearing at 3 different !places in FiniteMap (deep velocity, surface velocity, and plate velocity). !The only global that it uses from FiniteMap is velocity_Ma. !All other globals are from Adobe_Illustrator or Map_Projections or Map_Tools. IMPLICIT NONE CHARACTER*8 :: number8 REAL*8 :: v_mma, v_mps, x1_points, x2_points, y1_points, y2_points CALL Chooser(bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Velocity') number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(x '//TRIM(number8)//' Ma):') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5D0*(x1_points+x2_points)-14.17D0, from_y = y2_points - 33.D0, & & to_x = 0.5D0*(x1_points+x2_points)+14.17D0, to_y = y2_points - 33.D0) v_mps = 0.01D0 * mp_scale_denominator / (velocity_Ma * 1.D6 * sec_per_year) v_mma = v_mps * 1000.D0 * sec_per_year number8 = ADJUSTL(DASCII8(v_mma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 36.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8)//' mm/a') CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 48.D0 ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Velocity') number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(x '//TRIM(number8)//' Ma):') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.D0)-14.17D0, from_y = 0.5D0*(y1_points+y2_points)-10.D0, & & to_x = (x1_points+29.D0)+14.17D0, to_y = 0.5D0*(y1_points+y2_points)-10.D0) v_mps = 0.01D0 * mp_scale_denominator / (velocity_Ma * 1.D6 * sec_per_year) v_mma = v_mps * 1000.D0 * sec_per_year number8 = ADJUSTL(DASCII8(v_mma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.D0, & & y_points = 0.5D0*(y1_points + y2_points) - 24.D0, & & angle_radians = 0.D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)//' mm/a') CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58.D0 END IF ! bottom or right legend END SUBROUTINE Velocity_Explanation SUBROUTINE Which_Plate (uvec, nPlates, nInEachPlate, plate_uvecs, & ! inputs & plate_ID) ! output !Determines which (if any) counterclockwise outline the point "uvec" is in. !If not inside any outline, the result will be plate_ID = 0 IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: uvec INTEGER, INTENT(IN) :: nPlates INTEGER, DIMENSION(:), INTENT(IN) :: nInEachPlate ! (nPlates) REAL*8, DIMENSION(:,:,:), INTENT(IN) :: plate_uvecs ! (3, mostInOnePlate, nPlates) INTEGER, INTENT(OUT) :: plate_ID !-------------------- INTEGER :: j, k LOGICAL :: inside REAL*8 :: angle_sum, t1, t2 REAL*8, DIMENSION(3) :: uvec1, uvec2 plate_ID = 0 ! to be replaced below check_plates: DO j = 1, nPlates angle_sum = 0.0D0 ! initialize sum of angles subtended by orogen steps, as seen from test point: DO k = 2, nInEachPlate(j) uvec1(1:3) = plate_uvecs(1:3, k-1, j) uvec2(1:3) = plate_uvecs(1:3, k , j) t1 = DRelative_Compass(from_uvec = uvec, to_uvec = uvec1) t2 = DRelative_Compass(from_uvec = uvec, to_uvec = uvec2) IF ((t2 - t1) > Pi) t2 = t2 - Two_Pi IF ((t2 - t1) < -Pi) t2 = t2 + Two_Pi angle_sum = angle_sum + t2 - t1 END DO ! k = 2, nInEachPlate(j) inside = ((angle_sum < -6.0D0).AND.(angle_sum > -6.6D0)) ! inside a counterclockwise circuit !Note: Generalizing formula to allow for being inside a clockwise circuit will unfortunately ! cast virtual images of each orogen on the far side of the Earth! IF (inside) THEN plate_ID = j EXIT check_plates END IF END DO check_plates ! j = 1, nPlates END SUBROUTINE Which_Plate END PROGRAM NeoKineMap