BLOCK DATA BD1 ! Define "weight" (Gaussian integration weights) of the ! seven integration points in each element, defined by internal ! coordinates points(3, 7), where points(1-3, m) holds the s1-s3 of ! integration point number m. ! Because all of these arrays are functions of internal ! coordinates, they are not affected by scaling or shape of ! particular elements. IMPLICIT NONE DOUBLE PRECISION points, weight COMMON / S1S2S3 / points COMMON / WgtVec / weight DIMENSION points(3, 7), weight(7) ! "points" contains the internal coordinates (s1, s2, s3) of the 7 ! Gaussian integration points (for area integrals) of the ! triangular elements. "points" is also the set of nodal functions ! for unprojected scalar quantities within an element: DATA points / & & 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 / ! "weight" is the Gaussian weight (for area integrals) of the 7 ! integration points in each triangular element: DATA weight / 0.2250000000000000D0, & & 0.1323941500000000D0, 0.1323941500000000D0, 0.1323941500000000D0, & & 0.1259391833333333D0, 0.1259391833333333D0, 0.1259391833333333D0 / END BLOCK DATA BD1 PROGRAM FiniteMap ! ! Graphical part of the SHELLS/PLATES/FAULTS ! group of dynamic finite element models of ! deformation and motion of the lithosphere. ! Also useful for plotting the global plate model PB2002. ! 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 ! defining strain-rates and stress, nodal ! velocity (.v_____.out) files, boundary reaction-force ! (f____.out) files, plate-driving torque (q____.out) ! files, and various kinds of scoring data files, ! and creates an .ai graphics file containing a map, ! in a choice of 10 different map projections. ! ! N.B. If you need graphical support for paleo-kinematic ! F-E calculations with my program Restore, see my ! program RetroMap. If you need graphical support ! for neotectonic kinematic F-E calculations with ! my program NeoKinema, see my program NeoKineMap. ! ! by Peter Bird ! Professor Emeritus ! 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, 2005, 2006, 2014, 2015, 2016, 2019 by ! Peter Bird and the Regents of the University of California. ! !The following 4 modules are written and provided by Peter Bird: USE DAdobe_Illustrator ! provided as DAdobe_Illustrator.f90 USE DMap_Projections ! provided as DMap_Projections.f90 USE DMap_Tools ! provided as DMap_Tools.f90 USE DIcosahedron ! provided as DIcosahedron.f90 USE DFLIB, ARCQQ => ARC ! 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 comment-out SUBROUTINE File_List (and any CALLs to it). ! Also, using BEEPQQ to sound PC speaker when each task is done; ! again, this can simply be omitted if there is no substitute. ! However, not using ARC, because I have my own Arc; so I am ! renaming their ARC to ARCQQ to avoid conflicts. !TYPES IMPLICIT NONE !Note: INTEGER, PARAMETER objects are used in DIMENSIONs, so they must come first: 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, star CHARACTER*2 :: c2, eq_day, eq_hour, eq_minute, eq_month, eq_second CHARACTER*3 :: c3, class CHARACTER*4 :: c4 CHARACTER*5 :: c5 CHARACTER*6 :: c6, FEP CHARACTER*8 :: c8, number8, quadrant_bearing_c8, quadrant_bearing_c8_saved CHARACTER*10 :: color_name, string10 CHARACTER*12 :: element_scalar_units, fault_LRi_units, force_units, grid_units, & & node_scalar_units, stress_integral_units, & & splitting_format1, splitting_format2, splitting_format3, splitting_format4, & & spreading_format1, spreading_format2, spreading_format3, spreading_format4, & & stress_format1, stress_format2, stress_format3, stress_format4, stress_format5 CHARACTER*27 :: c27 CHARACTER*80 :: longer_line, shorter_line ! used by Extract_LRi CHARACTER*132 :: input_record CHARACTER*300 :: boundaries_dig_file = ' ', boundaries_dig_pathfile = ' ', & & gps_file = ' ', gps_pathfile = ' ', & & grd1_file = ' ', grd1_pathfile = ' ', grd2_file = ' ', grd2_pathfile = ' ', & & element_scalar_feg_file = ' ', element_scalar_feg_pathfile = ' ', & & feg_file = ' ', feg_pathfile = ' ', & & force_file = ' ', force_pathfile = ' ', friction_file = ' ', friction_pathfile = ' ', & & line = ' ', & & lines_basemap_file = ' ', lines_basemap_pathfile = ' ', & & old_eqc_file = ' ', old_eqc_pathfile = ' ', & & OrbScore_feg_file = ' ', OrbScore_feg_pathfile = ' ', & & parameter_file = ' ', parameter_pathfile = ' ', & & path_in = ' ', path_out = ' ', plates_dig_file = ' ', plates_dig_pathfile = ' ', & & polygons_basemap_file = ' ', polygons_basemap_pathfile = ' ', & & s1h_file = ' ', s1h_pathfile = ' ', slipRate_file = ' ', slipRate_pathfile = ' ', & & splitting_file = ' ', splitting_pathfile = ' ', & & spreading_rate_file = ' ', spreading_rate_pathfile = ' ', & & steps_dat_file = ' ', steps_dat_pathfile = ' ', & & temp_path_in = ' ', title3 = ' ', torque_file = ' ', torque_pathfile = ' ', & & vel_file = ' ', vel_pathfile = ' ', volcano_file = ' ', volcano_pathfile = ' ', & & orogens_dig_file = ' ', orogens_dig_pathfile = ' ' CHARACTER*132 :: bottom_line = ' ', bottom_line_memo = ' ', gps_format = ' ', & & long_line = ' ', top_line = ' ', top_line_memo = ' ' CHARACTER*200 :: appended_data = ' ' CHARACTER*132, DIMENSION(20) :: titles CHARACTER(LEN=2), DIMENSION(nPlates) :: names CHARACTER(LEN=2), DIMENSION(:), ALLOCATABLE :: s_regime_c2 CHARACTER(LEN=3), DIMENSION(:,:), ALLOCATABLE :: bitmap ! array of RGB pixels INTEGER :: age, azim, & & benchmarks, bitmap_color_mode, bitmap_color_mode_temp, bitmap_height, & & bitmap_shading_mode, bitmap_width, choice, & & color_int, & & 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, & & grid_access_mode, grd1_ncols, grd1_nrows, & & grd2_ncols, grd2_nrows, & & element_scalar_selector, element_scalar_zeromode, elev, & & fixed_node, & & group, & & highestLRi, & & i, i1, i2, iconve, iele, ios, ipAfri, iplate, ipvref, irow, & & j, j1, j2, jcol, jp, jp1, jp2, jSHELLS_fE, & & k, kilometers, kp1, kp2, & & l, l_, label_thinner, list_length, & & log_strainrate_method, log_viscosity_integral_method, lp, LRi, LRn, & & m, m1, m2, ma, maxitr, mb, method, minutes, mosaic_count, & & n, n1, n2, n3, na, nb, nfaken, nfl, n_in_sum, & & node_scalar_choice, node_scalar_limit, node_scalar_method, & & nonorbiting_node, np1, nrealn, number_rejected, numel, numnod, n1000, & & old_mosaic_count, old_overlay_count, overlay_count, other_plate_ID, & & path_length, plate_count, plate_count_times_3, plate_ID, pressure_MPa_method, & & read_status, ref_frame_plate_ID, reversed_color_int, rotationrate_method, & & s_header_lines, s_rst_count, shear_integral_method, shear_integral_zeromode, & & splitting_header_lines, splitting_count, & & spreading_header_lines, spreading_rate_count, & & step_count, strainrate_mode012, strain_thinner, & & stress_thinner, subdivision, & & Tbase_C_method, TMoho_C_method, title_choice, title_count, & & traction_method, train_length, & & v_az, vector_thinner, velocity_method, velocity_mmpa_int, visible_labels, & & orogen_ID INTEGER, DIMENSION(nPlates) :: nInEachPlate INTEGER, DIMENSION(nOrogens) :: nInEachOrogen INTEGER, DIMENSION(10) :: mosaic_choice, overlay_choice INTEGER, DIMENSION(:), ALLOCATABLE :: ndplat ! plate-boundary path lengths in plat, plon INTEGER, DIMENSION(:), ALLOCATABLE :: whichP ! integer 1~52 identifies plate associated with each node 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 :: continuum_LRi ! (numEl) INTEGER, DIMENSION(:), ALLOCATABLE :: fault_LRi ! (nFl) LOGICAL :: add_titles, any_FPS, any_titles, azimuth_is_integer, azimuth_is_real, & & bottom, bull_on, & & cold_start, continental, create_global_grid, & & debug, do_more_mosaics, dig_is_lonlat, do_more_overlays, & & grd1_lonlat, grd1_success, & & grd2_lonlat, grd2_success, & & do_mosaic, do_overlay, & & east_q, element_scalar_lowblue, ellipses, everyp, & & e1h_partitioned, e2h_partitioned, err_partitioned, & & fault_LRi_lowblue, first_pass, & & got_FEP, grid_lowblue, & & in_ok, inside, & & just_began_deep_flow, just_began_traction,& & just_began_surface_flow, just_began_strainrate, just_began_tau_integral, & & latter_mosaic, log_strainrate_lowblue, log_viscosity_integral_lowblue, lonlat, lt, & & mated, maybe, more_ai, more_eqc, more_dat, more_dig, & & more_feg, more_force, more_gps, more_grd, more_info, more_map, more_torque, more_vel, & & node_scalar_lowblue, north_q, nseg, & & OrbData5, & & plot_dig_titles, plot_FPS, plot_this, polygons, pressure_MPa_lowblue, problem, & & regimes_known, restored, right, rotationrate_lowblue, & & same_path_in_out, shaded_relief, shaded_relief_temp, shear_integral_lowblue, sigma_is_integer, & & skip_0_contour, solid, south_q, & & spreading_rate_is_integer, stroke_this, success, suggest_logical, & & Tbase_C_lowblue, TMoho_C_lowblue, traction_lowblue, try_again, & & using_A_to_E, using_quadrants, & & valid_azimuth, valid_FPS, velocity_reframe, velocity_lowblue, velocity_lowblue_temp, virgin, visible, & & west_q, & & xy_defined LOGICAL, DIMENSION(nPlates) :: slab_Q ! does this plate have (extensive) driving slabs attached? LOGICAL, DIMENSION(:), ALLOCATABLE :: checkN, node_has_area, selected, traction_pole_read LOGICAL(1), DIMENSION(:,:), ALLOCATABLE :: bitmap_success, touching ! DIMENSIONs that will be ALLOCATEd based on variable LRn, using range (0:LRn): LOGICAL, DIMENSION(:), ALLOCATABLE :: LR_is_defined, LR_is_used REAL*8, PARAMETER :: bottomlegend_gap_points = 14.D0 REAL*8, PARAMETER :: rightlegend_gap_points = 14.D0 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 = 19.0D0 ! degrees; should match SHELLS value REAL*8 :: above, angle_sum, angle_weight, arc2, arc3, argument, aze2, aze3, az1, az2, az3, az_radians, & & below, benchmark_points, big_diff, bitmap_color_highvalue, bitmap_color_highvalue_temp, & & bitmap_color_lowvalue, bitmap_color_lowvalue_temp, & & bottomlegend_used_points, brightness, & & constr, contour_interval, cooling_curvature_Cpm2, covariance_11, covariance_12, covariance_22, crust_meters, & & d_fFric, d_cFric, d_Biot, d_Byerly, d_eCreep, & ! N.B. See below for d_aCreep, ... , d_d_Creep & d0, d1, d_vsize_d_theta, d_vsize_d_phi, del_az_for_90pc, delta12, delta13, delta23, & & delta_max, delta_v_mps, delta_quadratic, deltaV_IP1_mps, density_anomaly_kgpm3, dextral, dextral1, dextral2, dip_degrees, & & dipslip1, dipslip2, divergence, dl2, dl3, ds2, ds3, dtdzc, dtdzm, dv_scale_mma, dv_scale_points, & & East_part, ecreep, eh_max, element_scalar_interval, element_scalar_midvalue, & & elevation, epicenter_x_m, epicenter_x_points, epicenter_y_m, epicenter_y_points, & & eq_Elon, eq_mag, eq_Nlat, equat, err, etamax, Euler_rate_radspMa, & & e1, e1_lat, e1_lon, e1h, e11, e12, e2, e2_lat, e2_lon, e2h, e22, e3, e3_lat, e3_lon, & & f, f_azim_rads_1, f_azim_rads_2, f_azim_rads_c, f1, f2, f3, & & f_East, fault_LRi_interval, fault_LRi_midvalue, fin, fmumax, fout, force_scale_N, force_scale_points, & & friction1, friction_width_km, friction_width_m, f_South, fx1, fx2, fy1, fy2, & & geoth1, geoth2, geoth3, geoth4, geoth5, geoth6, geoth7, geoth8, gmean, gradie, & & grd1_d_EW, grd1_d_lat, grd1_d_lon, grd1_d_x, grd1_d_y, grd1_x_max, grd1_x_min, grd1_y_max, grd1_y_min, & & grd2_d_EW, grd2_d_lat, grd2_d_lon, grd2_d_x, grd2_d_y, grd2_x_max, grd2_x_min, grd2_y_max, grd2_y_min, & & grd1_lat_max, grd1_lat_min, grd1_lon_max, grd1_lon_min, grd1_lon_range, & & grd2_lat_max, grd2_lat_min, grd2_lon_max, grd2_lon_min, grd2_lon_range, & & grid_interval, grid_midvalue, & & heatflow, & & inner, intensity, & & large_circle_radius_points, largest_ei_persec, last_sRate, & & last_fFric, lat, lat1, lat2, lat3, & & leg, log_strainrate_interval, log_strainrate_midvalue, & & log_viscosity_integral_interval, log_viscosity_integral_midvalue, & & lon, lon1, lon2, lon3, long, lr_fraction, & & mantle_meters, maximum, minimum, min_mag, m8_diam_points, & & node_radius_points, node_radius_radians, & & node_scalar_interval, node_scalar_midvalue, North_argument_radians, & & offset_radians, offset_x_m, offset_x_points, offset_y_m, offset_y_points, & & okdelv, oktoqt, onekm, open1, open2, outer, & & phi, pl0, pressure_MPa_interval, pressure_MPa_midvalue, pseudotime, & & pt1, pt1de1, pt1de2, pt2, pt2de1, pt2de2, pw0, & & R, rad, radians, radians_per_point, radius, radius_points, & & ref_e3_minus_e1_persec, refstr, rel_az2, rel_az3, & & rhoast, rhoh2o, rho_use, rightlegend_used_points, RMS_slope, & & rotationrate, rotationrate_interval, rotationrate_midvalue, r1t, r2t, & & s, s1, s2, s3, shear_integral_interval, shear_integral_midvalue, & & sighbi, sliprate1, sliprate2, slope, small_circle_radius_points, South_part, & & spread, start_azimuth, strainrate_diameter_points, sum, & & s1_size_points, s1h_azim_radians, s1h_azim_degrees, s1h_sigma_degrees, sigzzb, & & splitting_dt_sec, splitting_phi_degrees, splitting_scale_s, splitting_scale_points, & & spreading_azim_degrees, spreading_rate_mmpa, step_points, sup_slipnumber, & & t, t_Ma, t_mean, t1, t2, t3, t4, t5, t6, & & tadiab, target_sRate, tasthk, tau_integral_scale_NPm, tau_integral_scale_points, & & tauzz, Tbase_C_interval, Tbase_C_midvalue, & & terr0r, test, theta, theta_, tick_azimuth, tick_points, TMoho_C_interval, TMoho_C_midvalue, & & traction_at_node_MPa_E, traction_at_node_MPa_S, traction_interval, traction_IP1_MPa, traction_IP1_MPa_E, traction_IP1_MPa_S, & & traction_midvalue, traction_scale_MPa, traction_scale_points, trhmax, tsurf, & & u1theta, u1phi, u1x, u1y, u2theta, u2phi, u2x, u2y, ud_fraction, & & v_East_mps, v_mma, v_mps, v_South_mps, & & v1E, v1E_mma, v2E, v2E_mma, v3E, v3E_mma, v4E_mma, & & v1S, v1S_mma, v2S, v2S_mma, v3S, v3S_mma, v4S_mma, value, & & veloc, velocity_Ma, velocity_mmpa, velocity_interval, velocity_interval_temp, & & velocity_midvalue, velocity_midvalue_temp, vertical1, vertical2, & & viscosity_integral, vismax, volcano_Elon, volcano_Nlat, volcano_points, vsize, vtimes, & & width_points, width_radians, & & x_azim_rads_1, x_azim_rads_2, x_meters, x_used_points, x_user, & & xcp, xp, xps, xpt, xp1, xp2, xp3, xt, x0p, x_points, x1p, x1_points, x2_points, x2p, x3p, & & y_meters, y_points, y_used_points, y_user, ycp, yp, ypt, y0p, y1_points, y1p, y2_points, y2p, y3p, & & z, zbasth, zoftop, zstop, ztran REAL*8, DIMENSION(2) :: alphat, & & conduc, & & d_aCreep, d_bCreep, d_cCreep, d_dCreep, deltaV_IP1, & & radio, rhobar, & & taumax, temlim, & & vm_IP1, vs_IP1 REAL*8, DIMENSION(3) :: e1_b_uvec, e1_f_uvec, e2_b_uvec, e2_f_uvec, e3_b_uvec, e3_f_uvec, Euler, & & omega_uvec, pole_uvec, result_uvec, phi_uvec, & & theta_uvec, tvec, turn_1_uvec, turn_2_uvec, turn_3_uvec, turn_4_uvec, & & uvec, uvec1, uvec2, uvec3, uvec4, uvec5, uvec6 REAL*8, DIMENSION(3) :: eps_dot REAL*8, DIMENSION(6) :: f_6nodes REAL*8, DIMENSION(3,2,2,2):: dG REAL*8, DIMENSION(3,2,2) :: G REAL*8, DIMENSION(3,7) :: Gauss_point REAL*8, DIMENSION(3, nPlates) :: omega REAL*8, DIMENSION(2, 6) :: xy_6nodes REAL*8, DIMENSION(:), ALLOCATABLE :: a_ ! plane areas (R == 1.0) of spherical elements REAL*8, DIMENSION(:), ALLOCATABLE :: area ! (numEl) REAL*8, DIMENSION(:), ALLOCATABLE :: azimuth ! of tau1h axis, in radians clockwise from North REAL*8, DIMENSION(:,:),ALLOCATABLE :: balance_point_uvec REAL*8, DIMENSION(:), ALLOCATABLE :: benchmark_N_velocity, & & benchmark_N_sigma, & & benchmark_E_velocity, & & benchmark_E_sigma, & & benchmark_correlation, & & benchmark_hypotenuse 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 :: detJ ! (1:7, 1:numEl) REAL*8, DIMENSION(:), ALLOCATABLE :: dQdTdA ! (1:numNod) REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE :: dXS, dYS ! (2, 2, 3, 7, mxEl) REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: dXSP, dYSP REAL*8, DIMENSION(:), ALLOCATABLE :: e3_minus_e1_persec REAL*8, DIMENSION(:), ALLOCATABLE :: element_scalar REAL*8, DIMENSION(:,:),ALLOCATABLE :: eqcm ! (6,numnod) REAL*8, DIMENSION(:), ALLOCATABLE :: f_size ! (numnod) REAL*8, DIMENSION(:,:),ALLOCATABLE :: fazim REAL*8, DIMENSION(:,:),ALLOCATABLE :: fdip REAL*8, DIMENSION(:), ALLOCATABLE :: fg ! (2*numnod; like vw) REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE :: fPSfer REAL*8, DIMENSION(:), ALLOCATABLE :: friction ! (from Tuned_SHELLS) REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: geothC, geothM ! (4, 7, numEl) REAL*8, DIMENSION(:,:),ALLOCATABLE :: glue ! (7, numEl); from OneBar REAL*8, DIMENSION(:,:),ALLOCATABLE :: grid1, grid2 REAL*8, DIMENSION(:), ALLOCATABLE :: largest_axis REAL*8, DIMENSION(:), ALLOCATABLE :: log_largest_ei_persec REAL*8, DIMENSION(:), ALLOCATABLE :: log_viscosity_integral ! (numel) ! DIMENSIONs that will be ALLOCATEd based on variable LRn: REAL*8, DIMENSION(:), ALLOCATABLE :: LR_set_fFric, LR_set_cFric, LR_set_Biot, LR_set_Byerly, LR_set_eCreep ! (0:LRn) REAL*8, DIMENSION(:,:), ALLOCATABLE :: LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_dCreep ! These have initial subscript (1:2) for crust:mantle. REAL*8, DIMENSION(:,:),ALLOCATABLE :: nodal_vector_numerator REAL*8, DIMENSION(:), ALLOCATABLE :: nodal_vector_denominator REAL*8, DIMENSION(:), ALLOCATABLE :: node_scalar REAL*8, DIMENSION(:,:),ALLOCATABLE :: node_uvec REAL*8, DIMENSION(:), ALLOCATABLE :: omega_degperMa ! (numel) REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: outVecM, outVecS ! (1:2, 1:7, 1:numEl); vector velocities at integration poitns REAL*8, DIMENSION(:,:),ALLOCATABLE :: plat, plon REAL*8, DIMENSION(:,:),ALLOCATABLE :: plate_center_uvec REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: plate_uvecs REAL*8, DIMENSION(:,:),ALLOCATABLE :: plot_at_uvec REAL*8, DIMENSION(:,:),ALLOCATABLE :: point_force_magnitude REAL*8, DIMENSION(:,:),ALLOCATABLE :: point_force_azimuth 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 :: shear_integral ! (numel; at m=1) REAL*8, DIMENSION(:,:),ALLOCATABLE :: sita REAL*8, DIMENSION(:), ALLOCATABLE :: slipnumber REAL*8, DIMENSION(:,:),ALLOCATABLE :: slipnumbers ! 2 components used in steps.dat overlay REAL*8, DIMENSION(:), ALLOCATABLE :: slipRate ! (input dataset for Tuned_SHELLS) REAL*8, DIMENSION(:), ALLOCATABLE :: splitting_phi REAL*8, DIMENSION(:), ALLOCATABLE :: splitting_dt REAL*8, DIMENSION(:,:),ALLOCATABLE :: splitting_site REAL*8, DIMENSION(:), ALLOCATABLE :: spreading_azim REAL*8, DIMENSION(:), ALLOCATABLE :: spreading_rate REAL*8, DIMENSION(:,:),ALLOCATABLE :: spreading_site REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: strainrate ! (3, 7, numEl) REAL*8, DIMENSION(:,:),ALLOCATABLE :: tau_integral ! (3, numEl) = t1h, t2h, trr REAL*8, DIMENSION(:,:),ALLOCATABLE :: tLInt ! (7, numEl) REAL*8, DIMENSION(:), ALLOCATABLE :: tLNode ! (numNod) REAL*8, DIMENSION(:), ALLOCATABLE :: traction_MPa ! (numNod) REAL*8, DIMENSION(:,:),ALLOCATABLE :: traction_pole_vector ! (3,nPlates) REAL*8, DIMENSION(:), ALLOCATABLE :: train REAL*8, DIMENSION(:), ALLOCATABLE :: up_azim_rads REAL*8, DIMENSION(:,:),ALLOCATABLE :: uvec_list REAL*8, DIMENSION(:), ALLOCATABLE :: vsize_mma REAL*8, DIMENSION(:,:),ALLOCATABLE :: vm, vs REAL*8, DIMENSION(:), ALLOCATABLE :: vw REAL*8, DIMENSION(:), ALLOCATABLE :: xnode, ynode REAL*8, DIMENSION(:,:),ALLOCATABLE :: xy_node_meters REAL*8, DIMENSION(:), ALLOCATABLE :: zMNode ! (1:numNod) REAL*8, DIMENSION(:,:),ALLOCATABLE :: zMoho ! (1:7, 1:numEl) REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: orogen_uvecs !================== 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 DATA ipAfri / 1 / ! Which plate is Africa? (Needed if ICONVE = 0 in Shells) ! ! 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 !========================================================== slab_Q = .FALSE. ! except for particular plates with large attached slabs: slab_Q( 8) = .TRUE. ! AU = Australia slab_Q(14) = .TRUE. ! CL = Caroline slab_Q(15) = .TRUE. ! CO = Cocos slab_Q(21) = .TRUE. ! IN = India slab_Q(22) = .TRUE. ! JF = Juan de Fuca slab_Q(34) = .TRUE. ! NZ = Nazca slab_Q(37) = .TRUE. ! PA = Pacific slab_Q(39) = .TRUE. ! PS = Philippine Sea slab_Q(40) = .TRUE. ! RI = Rivera slab_Q(46) = .TRUE. ! SS = Solomon Sea WRITE (*,"( ' FiniteMap'& &/' This is the graphics part of the SHELLS/PLATES/FAULTS'& &/' package of dynamic finite-element model (FEM) programs'& &/' for simulating and/or plotting deformation of the lithosphere.'& &/' INPUT files may include:'& &/' -> AI7frame.ai (model .ai file; always required);'& &/' -> *.dig files (digitised basemaps);'& &/' -> *.grd files (gridded data files);'& &/' -> *.feg files (finite element grids);'& &/' -> *.in files (parameters input to the FEM);'& &/' -> f*.out files (nodal reaction forces, from the FEM);'& &/' -> v*.out files (velocities of nodes, from the FEM);'& &/' -> q*.out files (torques on plates, from the FEM);'& &/' -> *.eqc files (earthquake catalog files);'& &/' -> *.gps files (velocities of geodetic benchmarks);'& &/' -> *.dat files (tables of volcanoes, plate boundaries, &c).'& &/' OUTPUT FILES ARE MAPS OF PRESENT STRUCTURE AND TECTONICS,'& &/' in a choice of 10 different map projections.'& &/' They have .ai extensions and are intended to be read by Adobe'& &/' Illustrator 7+ for Windows or MacOS (or by'& &/' Adobe Illustrator 4 for Windows 3.1). In AI they can be edited and'& &/' annotated before they are printed on a wide variety of devices.'& &/' By Peter Bird, UCLA, (Shells5-compatible) version of 25 Feb. 2019.'& &/' -----------------------------------------------------------------------')") CALL DPrompt_for_Logical('Do you want more information about input and output files?',.FALSE.,more_info) IF (more_info) THEN CALL DPrompt_for_Logical('Do you want information about .ai files?',.TRUE.,more_ai) IF (more_ai) THEN WRITE (*,& &"(//' ------------------------------------------------------------------------'& &/' About .ai Files'& &//' The .ai files created by this program can be read by:'& &/' * Adobe Illustrator CSn for Windows 7, 8, 10; or'& &/' * Adobe Illustrator 7+ for Windows XP, 2000, NT, 98, 95, or MacOS; or'& &/' * Adobe Illustrator 4 for Windows 3.1'& &/' (except that AI4 cannot handle colored/shaded bitmaps).'& &//' In Adobe Illustrator you can view, edit, annotate, and print the maps.'& &//' A model .ai file is needed to provide the boiler-plate PostScript'& &/' header that all .ai files carry. Therefore, file AI7Frame.ai'& &/' (or AI4Frame.ai, if you have to use Adobe Illustrator 4)'& &/' must be in a location accessible by this program. You will have'& &/' a chance to specify the path if it is not in your current directory.'& &//' All .ai files are transmitted (e.g., by FTP over the Internet) as'& &/' ASCII, not as binary. This is because different computer systems'& &/' have different ways of marking the end of a line.'& &/' ------------------------------------------------------------------------')") END IF ! more_ai CALL DPrompt_for_Logical('Do you want information about .dig files?',.TRUE.,more_dig) IF (more_dig) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About .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 .dig files?',.TRUE.,more_dig) IF (more_dig) THEN WRITE (*,"(//' ----------------------------------------------------------------------'& &/' More About .dig Files'& &/' Number formats: Column 1 blank. Column 2 holds sign. Columns 3-13'& &/' hold the first real number, preferably in scientific notation.'& &/' Column 14 is a comma. Column 15 is a sign. Columns 16-26 hold'& &/' the second real number. To write such data from a FORTRAN program,'& &/' use FORMAT(1X,SP,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 .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 .feg files?',.TRUE.,more_feg) IF (more_feg) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Finite Element Grid (.feg) Files'& &//' Finite element grids may be either spherical-Earth or flat-Earth.'& &/' Spherical-Earth grids used with SHELLS are produced by OrbWin'& &/' and have 3-node spherical triangles and 4-node great-circle faults.'& &/' Flat-Earth grids used with PLATES or FAULTS are produced by DrawGrid'& &/' and have 6-node isoparametric triangles and 6-node curved faults.'& &/' Any .feg file contains nodal locations and (possibly) nodal data'& &/' (elevation, heat-flow, crustal thickness, lithosphere thickness).'& &/' They also contain topological connections of the nodes to form'& &/' elements. If there are fault elements, their dips are specified.'& &//' ----------------------------------------------------------------------')") END IF ! more_feg CALL DPrompt_for_Logical('Do you want information about velocity (v*.out) files?',.TRUE.,more_vel) IF (more_vel) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Velocity (v*.out) Files'& &//' These files contain velocities of nodes. The first 2 or 3 lines'& &/' are titles describing the computational experiment.'& &//' Later lines contain the velocity components:'& &/' Spherical-Earth models have components v_theta (South) and'& &/' v_phi (East), in meters/second.'& &/' Flat-Earth models have components x (roughly East??) and'& &/' y (roughly North??), in meters/second.'& &//' ----------------------------------------------------------------------')") END IF ! more_vel CALL DPrompt_for_Logical('Do you want information about nodal-Force (f*.out) files?',.TRUE.,more_force) IF (more_force) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Nodal-Force (f*.out) Files'& &//' These files contain a horizontal vector of consistent nodal force'& &/' for each node in an .feg file. These are the forces needed to'& &/' satisfy the velocity boundary conditions. (Small forces may'& &/' appear at other nodes due to lack of numerical precision in the'& &/' solution of the stress-equilibrium equations.)'& &/' Spherical-Earth models have components f_theta (South) and'& &/' f_phi (East), in Newtons.'& &/' Flat-Earth models have components x (roughly East??) and'& &/' y (roughly North??), in Newtons.'& &/' For more information, set log_force_balance = .TRUE. in SHELLS,'& &/' recompile, re-run, & read the report from subprogram -BALANC-.'& &//' ----------------------------------------------------------------------')") END IF ! more_force CALL DPrompt_for_Logical('Do you want information about torque (q*.out) files?',.TRUE.,more_torque) IF (more_torque) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Plate-Driving Torque (q*.out) Files'& &//' This file is produced by each run of SHELLS (but not PLATES or'& &/' FAULTS). It is a human-readable table reporting the torque'& &/' balance on each plate in the current global plate model of'& &/' Earth. Obviously, the table is useless if the SHELLS model'& &/' describes another planet, or does not conform to the plate '& &/' model currently coded into SHELLS. (To update this, consider'& &/' variables NPLATE, NAMES, & OMEGA within SHELLS & FiniteMap.)'& &/' The table contains entries for every plate contained (even partly)'& &/' in the SHELLS model, but is only useful for plates entirely'& &/' within the SHELLS model.'& &//' A q*.out file is needed to plot the balance of driving forces on'& &/' plates, and/or to plot basal shear tractions if ICONVE = 6.'& &//' ----------------------------------------------------------------------')") END IF ! more_torque CALL DPrompt_for_Logical('Do you want information about .eqc files?',.TRUE.,more_eqc) IF (more_eqc) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About EarthQauke 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 .gps files?',.TRUE.,more_gps) IF (more_gps) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Geodetic-Velocity (.gps) 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'& &//' ----------------------------------------------------------------------')") END IF ! more_gps CALL DPrompt_for_Logical('Do you want information about .dat files?',.TRUE.,more_dat) IF (more_dat) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Tables of Data (.dat files):'& &//' These files contain locations (any additional data is ignored)'& &/' expressed with one line per site.'& &/' For plotting active subaerial volcanoes, 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)'& &/' FiniteMap will plot a solid triangle to mark the location(s).'& &//' ----------------------------------------------------------------------')") END IF ! more_dat 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.'& &//' J. P. Snyder & P. M. Voxland (1989) An Album of Map Projections,'& &/' U.S. Geological Survey Professional Paper, 1453, 249 pages.'& &//' (Note that FiniteMap uses approximate spherical-planet formulas'& &/' instead of exact elliptical-planet formulas.)'& &//' ----------------------------------------------------------------------')") CALL Pause() END IF ! more_map END IF ! more_info !-------------------------(end of Introduction)---------------------- ! ! Basic structure of FiniteMap is similar to Prompter of Map_Tools: ! (1) Look for memory file FiniteMap.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, FiniteMap executes ! these requests immediately, so that error messages ! will be more understandable. ! (5) After closing the plot, save MapTools.ini and FiniteMap.ini ! to record all the selections made. MapTools.ini has page ! formatting and map projection; FiniteMap.ini records the ! actual content of the map. (Caution: If multiple mosaics ! or multiple overlays of the SAME TYPE are used in one map, ! then FiniteMap.ini will only remember the filename for the ! dataset most recently plotted.) ! !-------------------------------------------------------------------- OPEN (UNIT = 11, FILE = 'FiniteMap.ini', STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios == 0) THEN ! FiniteMap.ini was found problem = .FALSE. ! may change below READ (11,"(A)",IOSTAT=ios) path_in problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) same_path_in_out problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) path_out problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) FEP problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) old_mosaic_count problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) mosaic_choice ! whole array problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) polygons_basemap_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) plot_dig_titles problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) dig_title_method problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) grd1_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) grd2_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) bitmap_color_mode problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) shaded_relief problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) grid_access_mode 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, *,IOSTAT=ios) TMoho_C_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) TMoho_C_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) TMoho_C_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) TMoho_C_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) Tbase_C_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) Tbase_C_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) Tbase_C_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) Tbase_C_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) pressure_MPa_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) pressure_MPa_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) pressure_MPa_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) pressure_MPa_lowblue 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, *,IOSTAT=ios) velocity_reframe 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) 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) traction_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) traction_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) traction_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) traction_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) shear_integral_method problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) stress_integral_units problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) shear_integral_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) shear_integral_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) shear_integral_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) shear_integral_zeromode problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) log_viscosity_integral_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) log_viscosity_integral_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) log_viscosity_integral_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) log_viscosity_integral_lowblue problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) OrbScore_feg_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) log_strainrate_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) log_strainrate_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) log_strainrate_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) log_strainrate_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotationrate_method problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotationrate_interval problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotationrate_midvalue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) rotationrate_lowblue problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) old_overlay_count problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) overlay_choice ! whole array problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) lines_basemap_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) tick_points problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) node_radius_points problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) vel_file 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) traction_scale_MPa problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) traction_scale_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) 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) tau_integral_scale_Npm problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) tau_integral_scale_points problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) s1_size_points problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) stress_thinner problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) s1h_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) s_header_lines problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) regimes_known problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) stress_format1 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) stress_format2 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) stress_format3 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) stress_format4 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) stress_format5 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) force_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) force_units problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) force_scale_N problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) force_scale_points problem = problem.OR.(ios /= 0) READ (11,"(A)") old_eqc_file problem = problem.OR.(ios /= 0) READ (11,*) plot_FPS problem = problem.OR.(ios /= 0) READ (11,*) min_mag problem = problem.OR.(ios /= 0) READ (11,*) m8_diam_points problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) volcano_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) volcano_points problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) ref_frame_plate_ID problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) subdivision problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) label_thinner problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) steps_dat_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) torque_file problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) spreading_rate_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) spreading_header_lines problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) spreading_format1 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) spreading_format2 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) spreading_format3 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) spreading_format4 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) splitting_file problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) splitting_header_lines problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) splitting_format1 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) splitting_format2 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) splitting_format3 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) splitting_format4 problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) splitting_scale_s problem = problem.OR.(ios /= 0) READ (11, *,IOSTAT=ios) splitting_scale_points problem = problem.OR.(ios /= 0) 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 FiniteMap.ini.')") WRITE (*,"( ' The easiest way to recover from this is to:')") WRITE (*,"( ' (1) Print out FiniteMap.ini')") WRITE (*,"( ' (2) Delete FiniteMap.ini')") WRITE (*,"( ' (3) Restart FiniteMap, 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 = ' ' same_path_in_out = .TRUE. path_out = ' ' old_mosaic_count = 0 mosaic_choice = 1 ! whole array polygons_basemap_file = ' ' plot_dig_titles = .FALSE. dig_title_method = 1 grd1_file = ' ' grd2_file = ' ' bitmap_color_mode = 1 shaded_relief = .TRUE. grid_access_mode = 1 bitmap_shading_mode = 1 intensity = 1.0D0 grid_units = 'm' grid_interval = 0.0D0 grid_midvalue = 0.0D0 grid_lowblue = .TRUE. skip_0_contour = .FALSE. element_scalar_method = 2 element_scalar_feg_file = ' ' element_scalar_units = ' ' element_scalar_interval = 0.0D0 element_scalar_midvalue = 0.0D0 element_scalar_lowblue = .TRUE. element_scalar_zeromode = 0 feg_file = ' ' node_scalar_method = 2 node_scalar_choice = 1 node_scalar_units = ' ' node_scalar_interval = 0.0D0 node_scalar_midvalue = 0.0D0 node_scalar_lowblue = .TRUE. parameter_file = ' ' TMoho_C_method = 2 TMoho_C_interval = 0.0D0 TMoho_C_midvalue = 0.0D0 TMoho_C_lowblue = .TRUE. Tbase_C_method = 2 Tbase_C_interval = 0.0D0 Tbase_C_midvalue = 0.0D0 Tbase_C_lowblue = .TRUE. pressure_MPa_method = 2 pressure_MPa_interval = 0.0D0 pressure_MPa_midvalue = 0.0D0 pressure_MPa_lowblue = .TRUE. boundaries_dig_file = 'PB2002_boundaries.dig' plates_dig_file = 'PB2002_plates.dig' orogens_dig_file = 'PB2002_orogens.dig' velocity_reframe = .FALSE. fixed_node = 1 nonorbiting_node = 2 velocity_method = 2 velocity_interval = 0.0D0 velocity_midvalue = 0.0D0 velocity_lowblue = .TRUE. traction_method = 2 traction_interval = 0.0D0 traction_midvalue = 0.0D0 traction_lowblue = .TRUE. shear_integral_method = 2 stress_integral_units = 'N/m' shear_integral_interval = 0.0D0 shear_integral_midvalue = 0.0D0 shear_integral_lowblue = .TRUE. shear_integral_zeromode = 0 log_viscosity_integral_method = 2 log_viscosity_integral_interval = 1.0D0 log_viscosity_integral_midvalue = 0.0D0 log_viscosity_integral_lowblue = .FALSE. OrbScore_feg_file = ' ' log_strainrate_method = 2 log_strainrate_interval = 1.0D0 log_strainrate_midvalue = 0.0D0 log_strainrate_lowblue = .TRUE. rotationrate_method = 2 rotationrate_interval = 1.0D0 rotationrate_midvalue = 0.0D0 rotationrate_lowblue = .TRUE. 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 vel_file = ' ' gps_file = ' ' benchmark_points = 12.0D0 traction_scale_MPa = 0.0D0 traction_scale_points = 36.0D0 velocity_Ma = 10.0D0 vector_thinner = 1 dv_scale_mma = 35.0D0 dv_scale_points = 24.0D0 R = 6371000.D0 strainrate_mode012 = 2 ref_e3_minus_e1_persec = 5.D-17 strainrate_diameter_points = 20.0D0 strain_thinner = 1 tau_integral_scale_Npm = 0.0D0 tau_integral_scale_points = 48.0D0 ! diameter s1_size_points = 24.0D0 stress_thinner = 1 s1h_file = ' ' s_header_lines = 1 regimes_known = .TRUE. stress_format1 = '10X,F10.3' stress_format2 = '20X,F10.3' stress_format3 = '30X,F10.3' stress_format4 = '40X,F10.3' stress_format5 = '50X,A2' force_file = ' ' force_units = 'N' force_scale_N = 0.0D0 force_scale_points = 48.0D0 old_eqc_file = ' ' plot_FPS = .TRUE. min_mag = 4.4D0 m8_diam_points = 28.0D0 volcano_file = 'Volcanoes.dat' volcano_points = 7.0D0 ref_frame_plate_ID = 28 subdivision = 4 label_thinner = 1 steps_dat_file = "PB2002_steps.dat" torque_file = ' ' spreading_rate_file = ' ' spreading_header_lines = 3 spreading_format1 = "12X,F8.2" spreading_format2 = "5X,F7.2" spreading_format3 = "20X,F6.1" spreading_format4 = "32X,A4" splitting_file = ' ' splitting_header_lines = 2 splitting_format1 = "16X,F10.4" splitting_format2 = "8X,F8.4" splitting_format3 = "26X,I8" splitting_format4 = "34X,F8.2" splitting_scale_s = 2.0D0 splitting_scale_points = 16 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'& &//' FiniteMap stores its memory in FiniteMap.ini and Map_Tools.ini,'& &/' which are placed in the current directory when FiniteMap is run.'& &/' Normally, this should be the directory holding FiniteMap.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'& &/' FiniteMap!'& &/' ----------------------------------------------------------------------')") 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 !---------------------------------------------------------------------------------------- CALL DPrompt_for_Logical('Should the path for the output (.ai graphic) file be the same?',same_path_in_out,same_path_in_out) IF (same_path_in_out) THEN path_out = path_in WRITE (*,"(' IT WILL NOT BE NECESSARY TO TYPE THIS PATH AGAIN!')") ELSE 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 IF !-------------------------(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! !-------------------------- 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.0D0 ! records filling of bottom legend, from left rightlegend_used_points = 0.0D0 ! records filling of right legend, from top got_FEP = .FALSE. ! we don't yet know which FEP is in use. latter_mosaic = .FALSE. ! for first pass; will be set .TRUE. below 1000 just_began_deep_flow = .FALSE. ! These will be set TRUE just_began_traction = .FALSE. ! if the corresponding mosaic is just_began_surface_flow = .FALSE. ! chosen as the MOST RECENT mosaic, just_began_strainrate = .FALSE. ! to permit fast addition of related overlays. just_began_tau_integral = .FALSE. WRITE (*,"(//' ----------------------------------------------------------------------')") IF (ai_using_color) THEN WRITE (*,"(' MOSAIC (colored-area) LAYERS AVAILABLE:')") ELSE WRITE (*,"(' MOSAIC (patterned-area) LAYERS AVAILABLE:')") END IF WRITE (*,"(' 1 :: digitised basemap (polygons type)')") IF (ai_using_color) THEN WRITE (*,"(' 2 :: colored/shaded bitmap from gridded dataset(s)')") ELSE WRITE (*,"(' 2 :: shaded-relief grey-scale bitmap from gridded dataset')") END IF WRITE (*,"(' 3 :: contour map from gridded dataset')") WRITE (*,"(' 4 :: element scalar, or LR#')") WRITE (*,"(' 5 :: nodal data (elevation, Q, crust, lithosphere)')") WRITE (*,"(' 6 :: temperature of Moho')") WRITE (*,"(' 7 :: temperature at bottom of model domain')") WRITE (*,"(' 8 :: pressure anomaly at bottom of model domain')") WRITE (*,"(' 9 :: magnitude of deep velocity, below the model')") WRITE (*,"(' 10 :: magnitude of shear traction on base of model')") WRITE (*,"(' 11 :: magnitude of surface velocity')") WRITE (*,"(' 12 :: log of largest (absolute value) principal strain-rate')") WRITE (*,"(' 13 :: rotation rate about local vertical axis')") WRITE (*,"(' 14 :: vertical integral of greatest shear stress')") WRITE (*,"(' 15 :: log10[vertical integral of viscosity]')") WRITE (*,"(' 16 :: smoothed-seismic-strainrate map produced by OrbScore')") 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 > 16)) 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 FiniteMap 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') DO i = 1, 3 READ (21,"(A)") line READ (line, *, IOSTAT = ios) lon, lat IF (ios /= 0) THEN ! got possible title CALL Add_Title(line) END IF END DO CLOSE (21) CALL BEEPQQ (frequency = 440, duration = 250) ! end of basemap mosaic CASE (2) ! colored/shaded bitmap from gridded dataset(s) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Do you want shaded relief?',shaded_relief,shaded_relief) IF (shaded_relief) THEN WRITE (*,"(/' -------------------------------------------------------')") WRITE (*,"( ' Source of Shaded Relief:')") WRITE (*,"( ' 1 = same dataset as that used to assign colors')") WRITE (*,"( ' 2 = a different dataset (usually a topographic DEM)')") WRITE (*,"( ' -------------------------------------------------------')") 1020 CALL DPrompt_for_Integer('Bitmap shading mode (1 or 2)?',bitmap_shading_mode,bitmap_shading_mode) IF ((bitmap_shading_mode < 1).OR.(bitmap_shading_mode > 2)) THEN WRITE (*,"(' ERROR: Please select 1 or 2')") mt_flashby = .FALSE. GO TO 1020 END IF ELSE bitmap_shading_mode = 1 ! only one dataset END IF ELSE ! gray-scale image shaded_relief = .TRUE. bitmap_shading_mode = 1 ! only one dataset END IF IF (bitmap_shading_mode == 2) THEN grid_access_mode = 1 ! linear interpolation ELSE ! allow choice WRITE (*,"(/' -------------------------------------------------------')") WRITE (*,"( ' Access Method for .grd Dataset:')") WRITE (*,"( ' 0 = use closest value (good for discontinuous data)')") WRITE (*,"( ' 1 = linear interpolation (good for topography)')") WRITE (*,"( ' -------------------------------------------------------')") 1021 CALL DPrompt_for_Integer('Grid access mode (0 or 1)?',grid_access_mode,grid_access_mode) IF ((grid_access_mode < 0).OR.(grid_access_mode > 1)) THEN WRITE (*,"(' ERROR: Please select 0 or 1')") mt_flashby = .FALSE. GO TO 1021 END IF END IF 1022 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 be overlain with shaded relief?',grd2_file,grd2_file) END IF grd1_pathfile = TRIM(temp_path_in)//TRIM(grd1_file) grd2_pathfile = TRIM(temp_path_in)//TRIM(grd2_file) OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (bitmap_shading_mode == 1) THEN WRITE(*,"(/' Here are the first 5 lines of the file:' & &/' ----------------------------------------')") ELSE ! bitmap_shading_mode = 2; two .grd files WRITE(*,"(/' Here are the first 5 lines of the file to be colored:' & &/' -----------------------------------------------------')") END IF DO i = 1, 5 READ (21,"(A)", IOSTAT = ios) line WRITE (*,"(' ',A)") TRIM(line(1:79)) END DO WRITE(*,"(' -----------------------------------------------------')") CLOSE (21) OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21, *, IOSTAT = ios) grd1_lon_min, grd1_d_lon, grd1_lon_max READ (21, *, IOSTAT = ios) grd1_lat_min, grd1_d_lat, grd1_lat_max CLOSE (21) grd1_lonlat = (ABS(grd1_lat_min)<91.D0).AND.(ABS(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 FiniteMap 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 (ABS(grd1_lon_max - grd1_lon_min - 360.0D0) < 0.01D0) THEN grd1_lon_range = 360.0D0 ELSE grd1_lon_range = DEasting(grd1_lon_max - grd1_lon_min) END IF READ (21, *, IOSTAT = ios) grd1_lat_min, grd1_d_lat, grd1_lat_max problem = problem .OR. (ios /= 0) grd1_ncols = 1 + NINT((grd1_lon_max - grd1_lon_min) / grd1_d_lon) grd1_nrows = 1 + NINT((grd1_lat_max - grd1_lat_min) / grd1_d_lat) grd1_x_min = 0.0D0 ! (this paragraph just to avoid use of undefined variables) grd1_d_x = 0.0D0 grd1_x_max = 0.0D0 grd1_y_min = 0.0D0 grd1_d_y = 0.0D0 grd1_y_max = 0.0D0 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) grd1_lon_min = 0.0D0 ! (this paragraph just to avoid use of undefined variables) grd1_d_lon = 0.0D0 grd1_lon_max = 0.0D0 grd1_lat_min = 0.0D0 grd1_d_lat = 0.0D0 grd1_lat_max = 0.0D0 END IF problem = problem .OR. (grd1_nrows < 2) .OR. (grd1_ncols < 2) ALLOCATE ( grid1(grd1_nrows, grd1_ncols) ) READ (21, *, IOSTAT = ios) ((grid1(i,j), j = 1, grd1_ncols), i = 1, grd1_nrows) problem = problem .OR. (ios /= 0) CLOSE (21) IF (problem) THEN WRITE (*,"(' ERROR: ',A' defective in structure or truncated.')") TRIM(grd1_file) CALL DPress_Enter DEALLOCATE ( grid1 ) mt_flashby = .FALSE. GO TO 1022 END IF CALL Add_Title(grd1_file) train_length = grd1_nrows * grd1_ncols ALLOCATE ( train(train_length) ) WRITE (*,"(/' Here is the distribution of VISIBLE values:' )") k = 0 ! will count visible (in map window) grid points DO irow = 1, grd1_nrows ! top to bottom DO jcol = 1, grd1_ncols ! left to right !decide whether this point is visible in the window IF (grd1_lonlat) THEN lon = grd1_lon_min + (jcol - 1) * grd1_d_lon lat = grd1_lat_max - (irow - 1) * grd1_d_lat 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.0) 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 CALL DPrompt_for_String('What are the units of these values?',TRIM(ADJUSTL(grid_units)),grid_units) 1023 WRITE (*,"(/' How shall the bitmap be colored?')") WRITE (*,"( ' mode 0: Munsell: smooth spectrum (but values of 0 not colored)')") WRITE (*,"( ' mode 1: Munsell: smooth spectrum (with values of 0 colored normally)')") WRITE (*,"( ' mode 2: Kansas: 44-color scale of atlas-type colors')") WRITE (*,"( ' mode 3: UNAVCO: 20-color absolute scale (only for topography in m)')") WRITE (*,"( ' mode 4: AI: ',I2,'-color discrete scale, based on contour interval')") ai_spectrum_count WRITE (*,"( ' ------------------------------------------------------------------------')") CALL DPrompt_for_Integer('Which coloring mode?',bitmap_color_mode,bitmap_color_mode) IF ((bitmap_color_mode < 0).OR.(bitmap_color_mode > 4)) THEN WRITE (*,"(/' ERROR: Select mode index from list!' )") 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 = 0/1,2 versus 4 END IF ! ai_using_color, or not IF (shaded_relief) THEN ! get topography data into grid2: IF (bitmap_shading_mode == 1) THEN ! grid2 == grid1 grd2_lonlat = grd1_lonlat grd2_lon_min = grd1_lon_min grd2_d_lon = grd1_d_lon grd2_lon_max = grd1_lon_max grd2_lon_range = grd1_lon_range grd2_lat_min = grd1_lat_min grd2_d_lat = grd1_d_lat grd2_lat_max = grd1_lat_max grd2_x_min = grd1_x_min grd2_d_x = grd1_d_x grd2_x_max = grd1_x_max grd2_y_min = grd1_y_min grd2_d_y = grd1_d_y grd2_y_max = grd1_y_max grd2_nrows = grd1_nrows grd2_ncols = grd1_ncols ALLOCATE ( grid2( grd2_nrows, grd2_ncols) ) grid2 = grid1 ! whole array copy ELSE ! bitmap_shading_mode == 2; read grid2 WRITE(*,"(/' Here are the first 5 lines of the file with the shaded relief:' & &/' --------------------------------------------------------------')") OPEN (UNIT = 21, FILE = grd2_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') DO i = 1, 5 READ (21,"(A)", IOSTAT = ios) line WRITE (*,"(' ',A)") TRIM(line(1:79)) END DO WRITE(*,"(' --------------------------------------------------------------')") CLOSE (21) CALL DPrompt_for_Logical('Is this grid defined in (lon,lat) coordinates?',.TRUE.,grd2_lonlat) IF ((.NOT.xy_defined).AND.(.NOT.grd2_lonlat)) THEN WRITE (*,"(' ERROR: Start FiniteMap 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 (ABS(grd2_lon_max - grd2_lon_min - 360.0D0) < 0.01D0) THEN grd2_lon_range = 360.0D0 ELSE grd2_lon_range = DEasting(grd2_lon_max - grd2_lon_min) END IF READ (21, *, IOSTAT = ios) grd2_lat_min, grd2_d_lat, grd2_lat_max problem = problem .OR. (ios /= 0) grd2_ncols = 1 + NINT((grd2_lon_max - grd2_lon_min) / grd2_d_lon) grd2_nrows = 1 + NINT((grd2_lat_max - grd2_lat_min) / grd2_d_lat) ELSE ! (x,y) format READ (21, *, IOSTAT = ios) grd2_x_min, grd2_d_x, grd2_x_max problem = problem .OR. (ios /= 0) grd2_x_min = grd2_x_min * mt_meters_per_user grd2_d_x = grd2_d_x * mt_meters_per_user grd2_x_max = grd2_x_max * mt_meters_per_user READ (21, *, IOSTAT = ios) grd2_y_min, grd2_d_y, grd2_y_max problem = problem .OR. (ios /= 0) grd2_y_min = grd2_y_min * mt_meters_per_user grd2_d_y = grd2_d_y * mt_meters_per_user grd2_y_max = grd2_y_max * mt_meters_per_user grd2_ncols = 1 + NINT((grd2_x_max - grd2_x_min) / grd2_d_x) grd2_nrows = 1 + NINT((grd2_y_max - grd2_y_min) / grd2_d_y) END IF problem = problem .OR. (grd2_nrows < 2) .OR. (grd2_ncols < 2) train_length = grd2_nrows * grd2_ncols ALLOCATE ( grid2(grd2_nrows, grd2_ncols) ) READ (21, *, IOSTAT = ios) ((grid2(i,j), j = 1, grd2_ncols), i = 1, grd2_nrows) problem = problem .OR. (ios /= 0) CLOSE (21) IF (problem) THEN WRITE (*,"(' ERROR: ',A' defective in structure or truncated.')") TRIM(grd2_file) CALL DPress_Enter DEALLOCATE ( grid2 ) mt_flashby = .FALSE. GO TO 1022 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 grd1_success = (lat >= grd1_lat_min).AND. & & (lat <= grd1_lat_max).AND. & & (DEasting(lon - grd1_lon_min) <= grd1_lon_range) !note: insensitive to longitude cycle IF (grd1_success) THEN i1 = 1 + (grd1_lat_max - lat) / grd1_d_lat i1 = MAX(1,MIN(i1,grd1_nrows-1)) i2 = i1 + 1 fy2 = ((grd1_lat_max - lat) / grd1_d_lat) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + DEasting(lon - grd1_lon_min) / grd1_d_lon j1 = MAX(1,MIN(j1,grd1_ncols-1)) j2 = j1 + 1 fx2 = (DEasting(lon - grd1_lon_min) / grd1_d_lon) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 IF (grid_access_mode == 0) THEN ! use closest grid value IF (fx1 >= 0.5D0) THEN ! use left column j1 IF (fy1 >= 0.5D0) THEN ! use row i1 (above) value = grid1(i1, j1) ELSE ! use row i2 (below) value = grid1(i2, j1) END IF ELSE ! use right column j2 IF (fy1 >= 0.5D0) THEN ! use row i1 (above) value = grid1(i1, j2) ELSE ! use row i2 (below) value = grid1(i2, j2) END IF END IF ELSE IF (grid_access_mode == 1) THEN ! linear interpolation 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 END IF ! point inside lon/lat grid1 ELSE ! rejection failed (i.e., back side of Earth in Orthographic projection) grd1_success = .FALSE. END IF ! rejection worked or failed ELSE ! gridded data is on a x,y grid1 already grd1_success = (x_meters >= grd1_x_min).AND. & & (x_meters <= grd1_x_max).AND. & & (y_meters >= grd1_y_min).AND. & & (y_meters <= grd1_y_max) IF (grd1_success) THEN i1 = 1 + (grd1_y_max - y_meters) / grd1_d_y i1 = MAX(1,MIN(i1,grd1_nrows-1)) i2 = i1 + 1 fy2 = ((grd1_y_max - y_meters) / grd1_d_y) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + (x_meters - grd1_x_min) / grd1_d_x j1 = MAX(1,MIN(j1,grd1_ncols-1)) j2 = j1 + 1 fx2 = ((x_meters - grd1_x_min) / grd1_d_x) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 IF (grid_access_mode == 0) THEN ! use closest grid value IF (fx1 >= 0.5D0) THEN ! use left column j1 IF (fy1 >= 0.5D0) THEN ! use row i1 (above) value = grid1(i1, j1) ELSE ! use row i2 (below) value = grid1(i2, j1) END IF ELSE ! use right column j2 IF (fy1 >= 0.5D0) THEN ! use row i1 (above) value = grid1(i1, j2) ELSE ! use row i2 (below) value = grid1(i2, j2) END IF END IF ELSE IF (grid_access_mode == 1) THEN ! linear interpolation 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 END IF ! point within x/y grid1 END IF ! need to undo map projection or not for grid1 ELSE ! neither ai_using_color, nor (bitmap_shading_mode == 1) grd1_success = .FALSE. value = 0.0D0 ! should not be used END IF ! finding i1, i2, j1, j2,,, value in grid1, or not !Finished getting "value" and i1, i2, j1, j2, ... (if possible) !Get "brightness" (basis for brightness of pixel) from grid2??? IF (shaded_relief) THEN IF (bitmap_shading_mode == 1) THEN grd2_success = grd1_success !and fx2, fy2, i1, i2, ... will be reused ELSE ! must find place in grid2! !must recompute fx1, fx2, fy1, fy2, i1, i2, j1, j2 for different grid IF (grd2_lonlat) THEN IF (success) THEN ! lon, lat still valid !define grd2_success as falling within grid2 grd2_success = (lat >= grd2_lat_min).AND. & & (lat <= grd2_lat_max).AND. & & (DEasting(lon - grd2_lon_min) <= grd2_lon_range) !note: insensitive to longitude cycle IF (grd2_success) THEN i1 = 1 + (grd2_lat_max - lat) / grd2_d_lat i1 = MAX(1,MIN(i1,grd2_nrows-1)) i2 = i1 + 1 fy2 = ((grd2_lat_max - lat) / grd2_d_lat) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + DEasting(lon - grd2_lon_min) / grd2_d_lon j1 = MAX(1,MIN(j1,grd2_ncols-1)) j2 = j1 + 1 fx2 = (DEasting(lon - grd2_lon_min) / grd2_d_lon) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 END IF ! point in grid2 ELSE ! Rejection failed; lon, lat undefined grd2_success = .FALSE. END IF ! successful Rejection or not ELSE ! .NOT.grd2_lonlat; grid2 is x,y grd2_success = (x_meters >= grd2_x_min).AND. & & (x_meters <= grd2_x_max).AND. & & (y_meters >= grd2_y_min).AND. & & (y_meters <= grd2_y_max) IF (grd2_success) THEN i1 = 1 + (grd2_y_max - y_meters) / grd2_d_y i1 = MAX(1,MIN(i1,grd2_nrows-1)) i2 = i1 + 1 fy2 = ((grd2_y_max - y_meters) / grd2_d_y) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + (x_meters - grd2_x_min) / grd2_d_x j1 = MAX(1,MIN(j1,grd2_ncols-1)) j2 = j1 + 1 fx2 = ((x_meters - grd2_x_min) / grd2_d_x) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 END IF ! point within x/y grid2 END IF ! grd2_lonlat, or not END IF ! shaded relief grid2 has different framework IF (grd2_success) THEN ! can compute brightness !Compute E-W slope in a way that gives a !result that is piecewise-linear in the E-W direction: fout = ABS(fx2 - 0.5D0) ! fraction for adjacent cell fin = 1.00D0 - fout ! fraction for the cell we're in inner = (grid2(i1,j2) - grid2(i1,j1)) / grd2_d_EW IF (fx2 > 0.5D0) THEN IF (j2 < grd2_ncols) THEN ! normal case outer = (grid2(i1,j2+1) - grid2(i1,j1+1)) / grd2_d_EW ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case outer = (grid2(i1,j2-1) - grid2(i1,j1-1)) / grd2_d_EW ELSE ! at left edge of grid outer = inner END IF END IF above = fin * inner + fout * outer !Repeat for row below the point: inner = (grid2(i2,j2) - grid2(i2,j1)) / grd2_d_EW IF (fx2 > 0.5D0) THEN IF (j2 < grd2_ncols) THEN ! normal case outer = (grid2(i2,j2+1) - grid2(i2,j1+1)) / grd2_d_EW ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case outer = (grid2(i2,j2-1) - grid2(i2,j1-1)) / grd2_d_EW ELSE ! at left edge of grid outer = inner END IF END IF below = fin * inner + fout * outer !Line below makes slope piecewise-linear in N-S direction: slope = fy1 * above + fy2 * below brightness = 1.0D0 + 0.5D0 * intensity * slope / RMS_slope brightness = MAX(0.0D0, MIN(2.0D0, brightness)) ELSE ! .NOT. dot2_success; so, point was not in grid2 brightness = 1.0D0 END IF ! point was in grid2 or not ELSE ! no shaded relief wanted brightness = 1.0D0 END IF ! shaded relief, or not !End of lookup (value and brightness); now use them! IF (ai_using_color.AND.grd1_success) THEN ! have "value" IF (bitmap_color_mode <= 1) THEN ! Munsell: smooth spectrum IF ((bitmap_color_mode == 0).AND.(value == 0.0D0)) THEN c3 = CHAR(ai_background%rgb(1))//CHAR(ai_background%rgb(2))//CHAR(ai_background%rgb(3)) ELSE ! normal coloring t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Munsell(warmth = t, brightness = brightness) END IF ELSE IF (bitmap_color_mode == 2) THEN ! Kansas: 44-color atlas-type scale t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = DRGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = DRGB_AI(value = value, contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, low_is_blue = grid_lowblue, & & brightness = brightness) END IF ! bitmap_color_mode selection bitmap(irow,jcol) = c3 ELSE IF (grd2_success) THEN ! b/w; gray depends only on slope k = brightness * 127.5D0 k = MAX(0,MIN(255,k)) bitmap(irow,jcol) = CHAR(k)//CHAR(k)//CHAR(k) ELSE ! fill in with background IF (ai_black_background) THEN ! slide copy bitmap(irow,jcol) = CHAR(0)//CHAR(0)//CHAR(0) ELSE ! white background (paper print) bitmap(irow,jcol) = CHAR(255)//CHAR(255)//CHAR(255) END IF END IF ! color, grey-scale, or background END DO ! jcol, left to right WRITE (*,"('+Working on bitmap from gridded dataset(s)....',I6,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Working on bitmap from gridded dataset(s)....Writing to .ai ')") CALL DBitmap_on_L1 (bitmap, ai_window_x1_points, ai_window_x2_points, & & ai_window_y1_points, ai_window_y2_points) IF (ai_using_color) THEN CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! ai_using_color --> want spectrum in legend WRITE (*,"('+Working on bitmap from gridded dataset(s)....DONE. ')") CALL BEEPQQ (frequency = 440, duration = 250) ! deallocate by LIFO method: DEALLOCATE ( bitmap ) IF (ALLOCATED(grid2)) DEALLOCATE ( grid2 ) DEALLOCATE ( grid1 ) ! end of colored/shaded bitmap from gridded dataset(s) CASE (3) ! contour map from gridded data 1030 temp_path_in = path_in !CALL File_List( 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') 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') READ (21, *, IOSTAT = ios) grd1_lon_min, grd1_d_lon, grd1_lon_max READ (21, *, IOSTAT = ios) grd1_lat_min, grd1_d_lat, grd1_lat_max CLOSE (21) grd1_lonlat = (ABS(grd1_lat_min)<91.D0).AND.(ABS(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 FiniteMap 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.0D0) THEN grid_interval = (maximum - minimum)/ai_spectrum_count grid_midvalue = (maximum + minimum)/2.D0 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 = MAX(MIN(lat1, 90.0D0), -90.0D0) CALL DLonLat_2_Uvec(lon1, lat1, uvec1) lon2 = lon1 lat2 = lat1 - grd1_d_lat lat2 = MAX(MIN(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 (frequency = 440, duration = 250) DEALLOCATE ( grid1 ) DEALLOCATE ( train ) ! end of contour map from gridded data CASE (4) ! element scalar, or LR# (one value per element) IF (.NOT.got_FEP) CALL Get_FEP IF (FEP == "SHELLS") THEN WRITE (*,*) WRITE (*,"(' Color of each triangular element will be constant,')") WRITE (*,"(' so there will be color discontinuities at many')") WRITE (*,"(' element boundaries.')") WRITE (*,"(' -----------------------------------------------')") WRITE (*,"(' Which value shall be plotted, with color, in each element?')") WRITE (*,"(' mode 1 :: the real number following each element definition')") WRITE (*,"(' mode 2 :: integer #LRi of the Lithospheric Rheology')") WRITE (*,"(' ------------------------------------------------')") mt_flashby = .FALSE. 1040 element_scalar_selector = 0 CALL DPrompt_for_Integer('Which mode do you want?', element_scalar_selector, element_scalar_selector) IF ((element_scalar_selector < 1).OR.(element_scalar_selector > 2)) THEN WRITE (*,"(' ERROR: Select mode in legal range.')") GO TO 1040 END IF ELSE ! older F-E programs don't support LR# element_scalar_selector = 1 END IF IF (element_scalar_selector == 1) THEN CALL Add_Title("Color represents per-element scalar data") ELSE IF (element_scalar_selector == 2) THEN CALL Add_Title("Colors represent Lithospheric Rheology index #s.") END IF CALL DGroup_or_Bitmap (latter_mosaic, element_scalar_method, bitmap_height, bitmap_width) 1041 temp_path_in = path_in !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) 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 regarding plots with element_scalar_selector == 1 (floating-point scalar): !This use of PAD = "YES" will not be sufficient to zero out any element_scalar(i) that is !missing, because the READ is unformatted (*), and it will just go on to grad another line !of the input file (leading to a crash). All values must be present in the triangular-element- !definition section of the input .FEG file, even if they are just 0.0's (meaning "unknown"). problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) SELECT CASE (FEP) CASE ("FAULTS", "PLATES") READ (21, *, IOSTAT = ios) numnod, nrealn, nfaken, n1000 problem = problem .OR. (ios /= 0) ALLOCATE ( xy_node_meters(2,numnod) ) DO i = 1, numnod READ (21, *, IOSTAT = ios) j, x_user, y_user problem = problem .OR. (ios /= 0) x_meters = x_user * mt_meters_per_user y_meters = y_user * mt_meters_per_user xy_node_meters(1, i) = x_meters xy_node_meters(2, i) = y_meters END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(6,numel) ) ALLOCATE ( element_scalar(numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i), & & nodes(4,i), nodes(5,i), nodes(6,i), & & element_scalar(i) problem = problem .OR. (ios /= 0) DO j = 1, 6 IF (nodes(j, i) > nrealn) THEN nodes(j, i) = nodes(j, i) - n1000 + nrealn END IF END DO END DO ! i = 1, numel !Must also read fault elements, to get information on curvature of element sides! READ (21, *, IOSTAT = ios) nfl problem = problem .OR. (ios /= 0) ALLOCATE ( nodef(6,nfl) ) ALLOCATE ( fazim(2,nfl) ) DO i = 1, nfl READ (21, *, IOSTAT = ios) k, (nodef(j, i), j = 1, 6), t1, t2, t3, t4, t5 problem = problem .OR. (ios /= 0) DO j = 1, 6 IF (nodef(j, i) > nrealn) THEN nodef(j, i) = nodef(j, i) - n1000 + nrealn END IF END DO fazim(1, i) = t4 * radians_per_degree fazim(2, i) = t5 * radians_per_degree END DO ! i = 1, nfl CASE ("SHELLS") ! which includes the possibility of plotting LRi integer #s as colors. 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) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) IF (element_scalar_selector == 1) THEN ! older mode; plot a (floating-point?) scalar following list of nodes READ (shorter_line, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i), element_scalar(i) problem = problem .OR. (ios /= 0) ELSE IF (element_scalar_selector == 2) THEN ! new mode; plot the LR# READ (shorter_line, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) element_scalar(i) = LRi * 1.0D0 END IF END DO ! i = 1, numEl END SELECT IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1041 END IF CLOSE (21) IF ((FEP == "FAULTS").OR.(FEP == "PLATES")) CALL Replace_Zeros() !N.B. This is to deal with the old "shorthand" option to ! specify fault-element midpoint node locations as (0.0, 0.0) ! when you want the fault to be straight (so that midpoints ! can be computed from end-points, within FAULTS, PLATES, FiniteMap, ... CALL Add_Title(element_scalar_feg_file) IF (element_scalar_selector == 1) THEN ! old-fashioned method 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) ELSE IF (element_scalar_selector == 2) THEN ! plotting LRi #s; many will be 0's. WRITE (*,"(/' Here is the distribution of Lithospheric Rheology index #s:' )") CALL Histogram (element_scalar, numel, .FALSE., maximum, minimum) element_scalar_units = ' ' ! pure numbers (originally INTEGERs; converted to REAL*8's for convenience). END IF IF (element_scalar_method == 1) THEN ! group of colored/shaded polygons IF (element_scalar_interval == 0.0D0) THEN element_scalar_interval = (maximum - minimum)/ai_spectrum_count element_scalar_midvalue = (maximum + minimum)/2.0D0 END IF 1042 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 1042 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 (*,"(' ------------------------------------------------')") 1043 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 1043 END IF WRITE (*,"(/' Working on element scalar or LR#....')") 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 (MOD(t, element_scalar_interval) == 0.0D0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0D0) THEN t = t - 0.001D0* element_scalar_interval ELSE ! t < 0.0 t = t + 0.001D0 * element_scalar_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) END IF ! zero or non-zero value IF (plot_this) THEN SELECT CASE (FEP) CASE ("FAULTS", "PLATES") DO j = 1, 6 xy_6nodes(1:2, j) = xy_node_meters(1:2, nodes(j, i)) f_6nodes(j) = t END DO ! j = 1, 6 CALL DContour_6Node_Scalar_in_Plane & &(xy_6nodes = xy_6nodes, & & f_6nodes = f_6nodes, & & low_value = minimum, high_value = maximum, & & contour_interval = element_scalar_interval, & & midspectrum_value = element_scalar_midvalue, & & low_is_blue = element_scalar_lowblue, & & all_positive = .FALSE., & & group = 1) CASE ("SHELLS") 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 SELECT 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 (bitmap) SELECT CASE (FEP) CASE ("FAULTS", "PLATES") ALLOCATE ( center(2, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_6Node_Plane_Grid (numel, nodes, xy_node_meters, .TRUE., & ! inputs & center, neighbor) ! outputs CASE ("SHELLS") ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) END SELECT 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) SELECT CASE (FEP) CASE ("FAULTS", "PLATES") CALL DLookUp (cold_start, x_meters,y_meters, & & center, neighbor, nodes, numel, xy_node_meters, & ! inputs & iele, s1, s2, s3, & ! to be modified & success) ! output flag CASE ("SHELLS") 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) END SELECT 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 SELECT CASE (FEP) CASE ("FAULTS", "PLATES") DEALLOCATE ( neighbor, & & center ) ! in LIFO order CASE ("SHELLS") DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order END SELECT 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 SELECT CASE (FEP) CASE ("FAULTS", "PLATES") DEALLOCATE ( fazim ) DEALLOCATE ( nodef ) DEALLOCATE ( element_scalar, & & nodes ) ! in LIFO order DEALLOCATE ( xy_node_meters ) CASE ("SHELLS") DEALLOCATE ( continuum_LRi, & & element_scalar, & & nodes ) ! in LIFO order DEALLOCATE ( node_uvec ) END SELECT CALL BEEPQQ (frequency = 440, duration = 250) ! end of discontinuous scalar (one value per element) CASE (5) ! nodal data (elevation, Q, crust, mantle lithosphere, density anomaly, mid-lithosphere Delta T) CALL DGroup_or_Bitmap (latter_mosaic, node_scalar_method, bitmap_height, bitmap_width) IF (.NOT.got_FEP) CALL Get_FEP 1050 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 node locations and data?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) 1051 WRITE (*,"(' -----------------------------------------')") WRITE (*,"(' Which nodal variable should be plotted?')") WRITE (*,"(' 1 = elevation')") WRITE (*,"(' 2 = heat flow')") WRITE (*,"(' 3 = crustal thickness')") IF (FEP /= "FAULTS") THEN WRITE (*,"(' 4 = mantle lithosphere thickness')") WRITE (*,"(' 5 = total lithosphere thickness')") IF (FEP /= "PLATES") THEN ! "SHELLS" -- possibly new SHELLS, with OrbData5 .feg file !conduct trial read-through to see if .feg file is in new OrbData5 format (6 variables at each node)? OrbData5 = .FALSE. ! unless non-zero values discovered in columns 5, 6 below... OPEN (UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') READ (21, *) ! skip title READ (21, *) numnod DO i = 1, numnod READ (21, "(A)", IOSTAT = ios) input_record READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters, & & density_anomaly_kgpm3, cooling_curvature_Cpm2 IF (ios /= 0) THEN density_anomaly_kgpm3 = 0.0D0 cooling_curvature_Cpm2 = 0.0D0 READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters END IF OrbData5 = OrbData5 .OR. (density_anomaly_kgpm3 /= 0.0D0) .OR. (cooling_curvature_Cpm2 /= 0.0D0) END DO ! i = 1, numnod CLOSE (21) IF (OrbData5) THEN WRITE (*,"(' 6 = chemical density anomaly (whole lithosphere)')") WRITE (*,"(' 7 = mid-lithosphere temperature anomaly (above steady-state)')") node_scalar_limit = 7 ELSE ! old OrbData type of .feg file, with only 4 nodal variables node_scalar_limit = 5 END IF ELSE ! "PLATES" node_scalar_limit = 5 END IF ELSE ! "FAULTS" node_scalar_limit = 3 END IF 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('Elevation') ELSE IF (node_scalar_choice == 2) THEN CALL Add_Title('Heat Flow') ELSE IF (node_scalar_choice == 3) THEN CALL Add_Title('Crustal Thickness') ELSE IF (node_scalar_choice == 4) THEN CALL Add_Title('Thickness of Mantle Lithosphere') ELSE IF (node_scalar_choice == 5) THEN CALL Add_Title('Total Lithosphere Thickness') ELSE IF (node_scalar_choice == 6) THEN CALL Add_Title('Chemical Density Anomaly (of whole lithosphere)') ELSE IF (node_scalar_choice == 7) THEN CALL Add_Title('Mid-lithosphere temperature anomaly (above steady-state)') 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) SELECT CASE (FEP) CASE ("FAULTS", "PLATES") READ (21, *, IOSTAT = ios) numnod, nrealn, nfaken, n1000 problem = problem .OR. (ios /= 0) ALLOCATE ( xy_node_meters(2,numnod) ) ALLOCATE ( node_scalar(numnod) ) DO i = 1, numnod IF (node_scalar_choice == 1) THEN READ (21, *, IOSTAT = ios) j, x_user, y_user, node_scalar(i) ELSE IF (node_scalar_choice == 2) THEN READ (21, *, IOSTAT = ios) j, x_user, y_user, t1, node_scalar(i) ELSE IF (node_scalar_choice == 3) THEN READ (21, *, IOSTAT = ios) j, x_user, y_user, t1, t2, node_scalar(i) ELSE IF (node_scalar_choice == 4) THEN READ (21, *, IOSTAT = ios) j, x_user, y_user, t1, t2, t3, node_scalar(i) ELSE IF (node_scalar_choice == 5) THEN READ (21, *, IOSTAT = ios) j, x_user, y_user, t1, t2, t3, t4 node_scalar(i) = t3 + t4 END IF ! node_scalar_choice = 1, 2, 3, 4, 5 problem = problem .OR. (ios /= 0) x_meters = x_user * mt_meters_per_user y_meters = y_user * mt_meters_per_user xy_node_meters(1, i) = x_meters xy_node_meters(2, i) = y_meters END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(6,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) k, (nodes(j, i), j = 1, 6) problem = problem .OR. (ios /= 0) DO j = 1, 6 IF (nodes(j, i) > nrealn) THEN nodes(j, i) = nodes(j, i) - n1000 + nrealn END IF END DO END DO ! i = 1, numel !Must also read fault elements, to get information on curvature of element sides! READ (21, *, IOSTAT = ios) nfl problem = problem .OR. (ios /= 0) ALLOCATE ( nodef(6,nfl) ) ALLOCATE ( fazim(2,nfl) ) DO i = 1, nfl READ (21, *, IOSTAT = ios) k, (nodef(j, i), j = 1, 6), t1, t2, t3, t4, t5 problem = problem .OR. (ios /= 0) DO j = 1, 6 IF (nodef(j, i) > nrealn) THEN nodef(j, i) = nodef(j, i) - n1000 + nrealn END IF END DO fazim(1, i) = t4 * radians_per_degree fazim(2, i) = t5 * radians_per_degree END DO ! i = 1, nfl CASE ("SHELLS") 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 ! elevation READ (21, *, IOSTAT = ios) j, lon, lat, node_scalar(i) ELSE IF (node_scalar_choice == 2) THEN ! heat flow READ (21, *, IOSTAT = ios) j, lon, lat, t1, node_scalar(i) ELSE IF (node_scalar_choice == 3) THEN ! crust READ (21, *, IOSTAT = ios) j, lon, lat, t1, t2, node_scalar(i) ELSE IF (node_scalar_choice == 4) THEN ! mantle lithosphere READ (21, *, IOSTAT = ios) j, lon, lat, t1, t2, t3, node_scalar(i) ELSE IF (node_scalar_choice == 5) THEN ! total lithosphere thickness READ (21, *, IOSTAT = ios) j, lon, lat, t1, t2, t3, t4 node_scalar(i) = t3 + t4 ELSE IF (node_scalar_choice == 6) THEN ! chemical density anomaly READ (21, *, IOSTAT = ios) j, lon, lat, t1, t2, t3, t4, node_scalar(i) ELSE IF (node_scalar_choice == 7) THEN ! cooling curvature of geotherm READ (21, *, IOSTAT = ios) j, lon, lat, t1, t2, t3, t4, t5, t6 node_scalar(i) = 0.5 * t6 * ((t3 + t4) / 2.)**2 END IF ! node_scalar_choice = 1, 2, 3, 4, 5, 6, 7 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 ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel END SELECT IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1050 END IF CLOSE (21) IF ((FEP == "FAULTS").OR.(FEP == "PLATES")) CALL Replace_Zeros() 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.0D0 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 SELECT CASE (FEP) CASE ("FAULTS", "PLATES") DO j = 1, 6 xy_6nodes(1:2, j) = xy_node_meters(1:2, nodes(j, i)) f_6nodes(j) = node_scalar(nodes(j, i)) END DO ! j = 1, 6 CALL DContour_6Node_Scalar_in_Plane & & (xy_6nodes = xy_6nodes, & & f_6nodes = f_6nodes, & & low_value = minimum, high_value = maximum, & & contour_interval = node_scalar_interval, & & midspectrum_value = node_scalar_midvalue, & & low_is_blue = node_scalar_lowblue, & & all_positive = (node_scalar_choice >= 3), & & group = group) CASE ("SHELLS") 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 SELECT 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 SELECT CASE (FEP) CASE ("FAULTS", "PLATES") ALLOCATE ( center(2, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_6Node_Plane_Grid (numel, nodes, xy_node_meters, .TRUE., & ! inputs & center, neighbor) ! outputs CASE ("SHELLS") ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) END SELECT 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) SELECT CASE (FEP) CASE ("FAULTS", "PLATES") CALL DLookUp (cold_start, x_meters,y_meters, & & center, neighbor, nodes, numel, xy_node_meters, & ! inputs & iele, s1, s2, s3, & ! to be modified & success) ! output flag CASE ("SHELLS") 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) END SELECT IF (success) THEN SELECT CASE (FEP) CASE ("FAULTS", "PLATES") t = node_scalar(nodes(1,iele)) * (-s1 + 2.0D0 * s1**2) + & & node_scalar(nodes(2,iele)) * (-s2 + 2.0D0 * s2**2) + & & node_scalar(nodes(3,iele)) * (-s3 + 2.0D0 * s3**2) + & & node_scalar(nodes(4,iele)) * (4.0D0 * s1 * s2) + & & node_scalar(nodes(5,iele)) * (4.0D0 * s2 * s3) + & & node_scalar(nodes(6,iele)) * (4.0D0 * s3 * s1) CASE ("SHELLS") t = node_scalar(nodes(1,iele)) * s1 + & & node_scalar(nodes(2,iele)) * s2 + & & node_scalar(nodes(3,iele)) * s3 END SELECT 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 SELECT CASE (FEP) CASE ("FAULTS", "PLATES") DEALLOCATE ( neighbor, & & center ) ! in LIFO order CASE ("SHELLS") DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order END SELECT 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 SELECT CASE (FEP) CASE ("FAULTS", "PLATES") DEALLOCATE ( fazim ) ! in LIFO order DEALLOCATE ( nodef ) DEALLOCATE ( nodes ) DEALLOCATE ( node_scalar ) DEALLOCATE ( xy_node_meters ) CASE ("SHELLS") DEALLOCATE ( continuum_LRi ) ! in LIFO order DEALLOCATE ( nodes ) DEALLOCATE ( node_scalar ) DEALLOCATE ( node_uvec ) END SELECT CALL BEEPQQ (frequency = 440, duration = 250) ! end of 5 nodal data (elevation, Q, crust, mantle lithosphere) CASE (6:7) ! Moho T or T at base of model domain IF (choice == 6) THEN CALL Add_Title('Moho Temperature') CALL DGroup_or_Bitmap (latter_mosaic, TMoho_C_method, bitmap_height, bitmap_width) method = TMoho_C_method ELSE IF (choice == 7) THEN CALL Add_Title('Temperature at Base of Model Domain') CALL DGroup_or_Bitmap (latter_mosaic, Tbase_C_method, bitmap_height, bitmap_width) method = Tbase_C_method END IF IF (.NOT.got_FEP) CALL Get_FEP ! get .in 1060 temp_path_in = path_in !CALL File_List( file_type = "i*.in", & ! & suggested_file = parameter_file, & ! & using_path = temp_path_in) 1070 CALL DPrompt_for_String('Which file contains the input parameters?',parameter_file,parameter_file) parameter_pathfile = TRIM(temp_path_in)//TRIM(parameter_file) CALL Input_to_SHELLS ( 11, parameter_pathfile, names , nPlates, & ! inputs & alphat, conduc, & ! outputs... & d_fFric, d_cFric, d_Biot, d_Byerly, d_aCreep, d_bCreep, d_cCreep, d_dCreep, d_eCreep, & & everyp, & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, radius, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) CALL Add_Title(parameter_file) CALL Add_Title(title3) !get .feg 1061 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 node locations and data?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN (UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, "(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) ) OrbData5 = .FALSE. ! unless non-zero values discovered in columns 5, 6 below... DO i = 1, numnod READ (21, "(A)") input_record READ (input_record, *, IOSTAT = ios) j, lon, lat, t1, t2, t3, t4, t5, t6 ! assuming OrbData5 format IF (ios /= 0) THEN ! probably old OrbData format; zero out the missing fields t5 = 0.0D0 t6 = 0.0D0 READ (input_record, *, IOSTAT = ios) j, lon, lat, t1, t2, t3, t4 problem = problem .OR. (ios /= 0) .OR. (j /= i) ELSE OrbData5 = OrbData5 .OR. (t5 /= 0.0D0) .OR. (t6 /= 0.0D0) END IF CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) IF (choice == 6) THEN ! TMoho_C node_scalar(i) = tsurf & & + (t2 / conduc(1)) * t3 & & - (0.5D0 * radio(1) / conduc(1)) * t3**2 & & - (0.5D0 * t6) * t3**2 & & - 273.0D0 ELSE IF (choice == 7) THEN ! Tbase node_scalar(i) = tsurf & & + (t2 / conduc(1)) * t3 & & - (0.5D0 * radio(1) / conduc(1)) * t3**2 & & + ((t2 - (t3 * radio(1))) / conduc(2)) * t4 & & - (0.5D0 * radio(2) / conduc(2)) * t4**2 & & - (0.5D0 * t6) * (t3 + t4)**2 & & - 273.0D0 END IF END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *, 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. GO TO 1061 END IF CLOSE (21) CALL Add_Title(feg_file) WRITE (*,"(/' Here is the distribution of temperatures in degrees Centigrade:' )") CALL Histogram (node_scalar, numnod, .FALSE., maximum, minimum) IF (method == 1) THEN ! group of colored/shaded polygons IF ((choice == 6).AND.(TMoho_C_interval == 0.0D0)) THEN TMoho_C_interval = (maximum - minimum)/ai_spectrum_count TMoho_C_midvalue = (maximum + minimum)/2.0D0 ELSE IF ((choice == 7).AND.(Tbase_C_interval == 0.0D0)) THEN Tbase_C_interval = (maximum - minimum)/ai_spectrum_count Tbase_C_midvalue = (maximum + minimum)/2.0D0 END IF IF (choice == 6) THEN ! TMoho_C 1062 CALL DPrompt_for_Real('What contour interval do you wish?',Tmoho_C_interval,TMoho_C_interval) IF (TMoho_C_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") TMoho_C_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1062 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',TMoho_C_midvalue,TMoho_C_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',Tmoho_C_lowblue,TMoho_C_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',TMoho_C_lowblue,TMoho_C_lowblue) END IF ELSE IF (choice == 7) THEN ! Tbase_C 1063 CALL DPrompt_for_Real('What contour interval do you wish?',Tbase_C_interval,Tbase_C_interval) IF (Tbase_C_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") Tbase_C_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1063 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',Tbase_C_midvalue,Tbase_C_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',Tbase_C_lowblue,Tbase_C_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',Tbase_C_lowblue,Tbase_C_lowblue) END IF END IF WRITE (*,"(/' Working on temperatures....')") 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)) IF (choice == 6) THEN ! TMoho_C 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 = TMoho_C_interval, & & midspectrum_value = TMoho_C_midvalue, & & low_is_blue = TMoho_C_lowblue, group = group) ELSE IF (choice == 7) THEN ! Tbase_C 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 = Tbase_C_interval, & & midspectrum_value = Tbase_C_midvalue, & & low_is_blue = Tbase_C_lowblue, group = group) END IF END DO ! i = 1, numel CALL DEnd_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN IF (choice == 6) THEN ! TMoho_C CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = TMoho_C_interval, & & midspectrum_value =TMoho_C_midvalue, & & low_is_blue = TMoho_C_lowblue, & & units = 'C') ELSE IF (choice == 7) THEN ! Tbase_C CALL DBar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = Tbase_C_interval, & & midspectrum_value =Tbase_C_midvalue, & & low_is_blue = Tbase_C_lowblue, & & units = 'C') END IF bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN IF (choice == 6) THEN ! TMoho_C CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = TMoho_C_interval, & & midspectrum_value =TMoho_C_midvalue, & & low_is_blue = TMoho_C_lowblue, & & units = 'C') ELSE IF (choice == 7) THEN ! Tbase_C CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = Tbase_C_interval, & & midspectrum_value =Tbase_C_midvalue, & & low_is_blue = Tbase_C_lowblue, & & units = 'C') END IF rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on temperatures....DONE.')") ELSE ! 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 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 ')") IF (choice == 6) THEN ! TMoho_C CALL DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & 'C', minimum, maximum, & & bitmap_color_mode, TMoho_C_interval, TMoho_C_midvalue, TMoho_C_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) ELSE IF (choice == 7) THEN ! Tbase_C CALL DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & 'C', minimum, maximum, & & bitmap_color_mode, Tbase_C_interval, Tbase_C_midvalue, Tbase_C_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) END IF DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN IF (choice == 6) THEN ! TMoho_C CALL DSpectrum_in_BottomLegend (minimum, maximum, 'C', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & Tmoho_C_interval, TMoho_C_midvalue, TMoho_C_lowblue) ELSE IF (choice == 7) THEN ! Tbase_C CALL DSpectrum_in_BottomLegend (minimum, maximum, 'C', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & Tbase_C_interval, Tbase_C_midvalue, Tbase_C_lowblue) END IF bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN IF (choice == 6) THEN ! TMoho_C CALL DSpectrum_in_RightLegend (minimum, maximum, 'C', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & TMoho_C_interval, TMoho_C_midvalue, TMoho_C_lowblue) ELSE IF (choice == 7) THEN ! Tbase_C CALL DSpectrum_in_RightLegend (minimum, maximum, 'C', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & Tbase_C_interval, Tbase_C_midvalue, Tbase_C_lowblue) END IF rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( continuum_LRi, & ! in LIFO order & nodes, & & node_scalar, & & node_uvec) ! end 6:7 (Moho T or T at base of model domain) CASE (8) ! pressure anomaly at base of model domain CALL Add_Title('Pressure Anomaly at Base of Model') CALL DGroup_or_Bitmap (latter_mosaic, pressure_MPa_method, bitmap_height, bitmap_width) IF (.NOT.got_FEP) CALL Get_FEP ! get .in 1080 temp_path_in = path_in !CALL File_List( file_type = "i*.in", & ! & suggested_file = parameter_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the input parameters?',parameter_file,parameter_file) parameter_pathfile = TRIM(temp_path_in)//TRIM(parameter_file) CALL Input_to_SHELLS ( 11, parameter_pathfile, names , nPlates, & ! inputs & alphat, conduc, & ! outputs... & d_fFric, d_cFric, d_Biot, d_Byerly, d_aCreep, d_bCreep, d_cCreep, d_dCreep, d_eCreep, & & everyp, & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, radius, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) CALL Add_Title(parameter_file) CALL Add_Title(title3) !get .feg 1081 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 node locations and data?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN (UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, "(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 READ (21, "(A)") input_record READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters, & & density_anomaly_kgpm3, cooling_curvature_Cpm2 IF (ios /= 0) THEN density_anomaly_kgpm3 = 0.0D0 cooling_curvature_Cpm2 = 0.0D0 READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters problem = problem .OR. (ios /= 0) .OR. (j /= i) ELSE problem = problem .OR. (j /= i) END IF CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) geoth1 = tsurf geoth2 = heatflow / conduc(1) geoth3 = -0.5D0 * (radio(1) / conduc(1)) - 0.5D0 * cooling_curvature_Cpm2 geoth4 = 0.0D0 geoth5 = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 geoth6 = ((heatflow - crust_meters * radio(1)) / conduc(2)) - cooling_curvature_Cpm2 * crust_meters geoth7 = -0.5D0 * (radio(2) / conduc(2)) - 0.5D0 * cooling_curvature_Cpm2 geoth8 = 0.0D0 zstop = crust_meters + mantle_meters CALL SQUEEZ (alphat, density_anomaly_kgpm3, elevation, & & geoth1,geoth2,geoth3,geoth4, & & geoth5,geoth6,geoth7,geoth8, & & gmean, & & 6,onekm,rhoast,rhobar,rhoh2o, & & temlim,crust_meters,zstop, & ! inputs & tauzz,sigzzb) ! outputs node_scalar(i) = -sigzzb / 1.0D6 ! in MPa of pressure END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *, 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. GO TO 1081 END IF CLOSE (21) CALL Add_Title(feg_file) WRITE (*,"(/' Here is the distribution of pressure anomalies in MPa:' )") CALL Histogram (node_scalar, numnod, .FALSE., maximum, minimum) IF (pressure_MPa_method == 1) THEN ! group of colored/shaded polygons IF (pressure_MPa_interval == 0.0D0) THEN pressure_MPa_interval = (maximum - minimum) / ai_spectrum_count END IF 1082 CALL DPrompt_for_Real('What contour interval do you wish?',pressure_MPa_interval,pressure_MPa_interval) IF (pressure_MPa_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") pressure_MPa_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?',pressure_MPa_midvalue,pressure_MPa_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',pressure_MPa_lowblue,pressure_MPa_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',pressure_MPa_lowblue,pressure_MPa_lowblue) END IF WRITE (*,"(/' Working on pressure anomalies....')") 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 = pressure_MPa_interval, & & midspectrum_value = pressure_MPa_midvalue, & & low_is_blue = pressure_MPa_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 = pressure_MPa_interval, & & midspectrum_value =pressure_MPa_midvalue, & & low_is_blue = pressure_MPa_lowblue, & & units = 'MPa') 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 = pressure_MPa_interval, & & midspectrum_value =pressure_MPa_midvalue, & & low_is_blue = pressure_MPa_lowblue, & & units = 'MPa') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on pressure anomalies....DONE.')") ELSE ! 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 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, & & 'MPa', minimum, maximum, & & bitmap_color_mode, pressure_MPa_interval, pressure_MPa_midvalue, pressure_MPa_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, 'MPa', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & pressure_MPa_interval, pressure_MPa_midvalue, pressure_MPa_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, 'MPa', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & pressure_MPa_interval, pressure_MPa_midvalue, pressure_MPa_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( continuum_LRi, & ! in LIFO order & nodes, & & node_scalar, & & node_uvec) ! end 8 (pressure anomaly at base of model domain) CASE (9) ! magnitude of deep velocity CALL Add_Title ('Velocity Field Imposed Below the Model') CALL DGroup_or_Bitmap (latter_mosaic, velocity_method, bitmap_height, bitmap_width) IF (.NOT.got_FEP) CALL Get_FEP 1090 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 finite-element grid should deep flow be projected onto?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1090 END IF READ (21,*) ! title READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( xnode(numnod) ) !theta, in radians ALLOCATE ( ynode(numnod) ) !phi, in radians ALLOCATE ( checkN(numnod) ) ALLOCATE ( node_has_area(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) CALL DLonLat_2_ThetaPhi (lon, lat, theta, phi) xnode(i) = theta ynode(i) = phi END DO ! i = 1, numnod READ (21,*) numEl ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line,*) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21,*) nfl ALLOCATE ( nodef(4, nFl) ) ALLOCATE ( fault_LRi(nFl) ) DO i = 1, nFl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output fault_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodef(1,i), nodef(2,i), nodef(3,i), nodef(4,i) END DO ! i = 1, nFl CLOSE(21) !Get input parameters: 1091 temp_path_in = path_in !CALL File_List( file_type = "i*.in", & ! & suggested_file = parameter_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the input parameters?',parameter_file,parameter_file) parameter_pathfile = TRIM(temp_path_in)//TRIM(parameter_file) CALL Input_to_SHELLS ( 11, parameter_pathfile, names , nPlates, & ! inputs & alphat, conduc, & ! outputs... & d_fFric, d_cFric, d_Biot, d_Byerly, d_aCreep, d_bCreep, d_cCreep, d_dCreep, d_eCreep, & & everyp, & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, radius, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) IF (iconve == 0) THEN line = 'Static Lower Mantle (w.r.t. AF), seen from ' // names(ipvref) // ' reference frame' CALL Add_Title(line) ELSE IF (iconve == 1) THEN IF (vtimes == 1.0D0) THEN line = "Hager & O'Connell (1979), seen from " // names(ipvref) // ' reference frame' ELSE WRITE (c5,"(F5.2)") vtimes line = "Hager & O'Connell (1979) x" // c5 // ', seen from ' // names(ipvref) // ' reference frame' END IF CALL Add_Title(line) ELSE IF (iconve == 2) THEN IF (vtimes == 1.0D0) THEN line = 'Baumgardner (1988) Fig. 7, seen from ' // names(ipvref) // ' reference frame' ELSE WRITE (c5,"(F5.2)") vtimes line = 'Baumgardner (1988) Fig. 7 x' // c5 // ', seen from ' // names(ipvref) // ' reference frame' END IF CALL Add_Title(line) ELSE IF ((iconve == 3).OR.(iconve == 4)) THEN IF (vtimes == 1.0D0) THEN line = 'PB2002 (Bird, 2003), seen from ' // names(ipvref) // ' reference frame' ELSE WRITE (c5,"(F5.2)") vtimes line = 'PB2002 x' // c5 // ', seen from ' // names(ipvref) // ' reference frame' END IF CALL Add_Title(line) ELSE IF (iconve == 5) THEN WRITE (*, "(/' Sorry; this mosaic is not programmed yet!')") CALL Pause() GO TO 1999 ELSE IF (iconve == 6) THEN WRITE (*, "(/' Sorry; impossible. When ICONVE == 6, lower mantle flow is not defined.')") CALL Pause() GO TO 1999 END IF CALL Add_Title(parameter_file) CALL Add_Title(title3) !Now, call CONVEC(iconve), which may require arrays (or do its own I/O!): IF ((iconve >= 3).AND.(iconve <= 4)) THEN temp_path_in = path_in !CALL File_List( file_type = "*.dig", & ! & suggested_file = plates_dig_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the plate outlines?',plates_dig_file,plates_dig_file) ALLOCATE ( ndplat(nPlates) ) ! Integer; plate-boundary path lengths ALLOCATE ( plat(nPlates, mostInOnePlate) ) ! latitudes of plate-boundary paths ALLOCATE ( plon(nPlates, mostInOnePlate) ) ! longitudes of plate-boundary paths CALL GETNUV (temp_path_in,plates_dig_file,21,6,names,mostInOnePlate,nPlates, & ! inputs & ndplat,plat,plon) ! outputs END IF ALLOCATE ( vm(2,numnod) ) CALL CONVEC (iconve, ipAfri, ipvref, 21, 6, & & names, ndplat, & & nfl, nodef, nodes, & & mostInOnePlate, nPlates, numel, numnod, & & omega, path_in, plat, plon, mp_radius_meters, vtimes, & & xnode, ynode, & ! inputs & vm ) ! output array ALLOCATE ( vsize_mma(numnod) ) !When finding range of velocities, do not consider any nodes which do not !have associated continuum-element area. (Disregard boundary nodes on the !outside of marginal faults, which are parts of adjacent plates.) node_has_area = .FALSE. ! initialize whole array DO i = 1, numel node_has_area(nodes(1, i)) = .TRUE. node_has_area(nodes(2, i)) = .TRUE. node_has_area(nodes(3, i)) = .TRUE. END DO ! i = 1, numel list_length = 0 DO i = 1, numnod IF (node_has_area(i)) THEN list_length = list_length + 1 v_South_mps = vm(1, i) v_East_mps = vm(2, i) vsize_mma(list_length) = 1000.D0 * sec_per_year * DSQRT(v_South_mps**2 + v_East_mps**2) END IF END DO ! i = 1, numnod WRITE (*,"(/' Here is the distribution of deep 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.0D0 END IF 1093 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 1093 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 deep 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)) v1S_mma = 1000.0D0 * sec_per_year * vm(1, nodes(1,i)) v2S_mma = 1000.0D0 * sec_per_year * vm(1, nodes(2,i)) v3S_mma = 1000.0D0 * sec_per_year * vm(1, nodes(3,i)) v1E_mma = 1000.0D0 * sec_per_year * vm(2, nodes(1,i)) v2E_mma = 1000.0D0 * sec_per_year * vm(2, nodes(2,i)) v3E_mma = 1000.0D0 * sec_per_year * vm(2, nodes(3,i)) CALL DContour_3Node_Sphere_Velocity( & & uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & v1t = v1S_mma, v1p = V1E_mma, & & v2t = v2S_mma, v2p = V2E_mma, & & v3t = v3S_mma, v3p = V3E_mma, & & low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value = velocity_midvalue, & & low_is_blue = velocity_lowblue, group = group) END DO ! i = 1, numel CALL DEnd_Group ! 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 deep velocity....DONE.')") ELSE ! velocity_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN uvec1(1:3) = node_uvec(1:3,nodes(1,iele)) uvec2(1:3) = node_uvec(1:3,nodes(2,iele)) uvec3(1:3) = node_uvec(1:3,nodes(3,iele)) v1S = vm(1, nodes(1,iele)) v2S = vm(1, nodes(2,iele)) v3S = vm(1, nodes(3,iele)) v1E = vm(2, nodes(1,iele)) v2E = vm(2, nodes(2,iele)) v3E = vm(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.0D0 * sec_per_year 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, & & 'mm/a', minimum, maximum, & & bitmap_color_mode, velocity_interval, velocity_midvalue, velocity_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! velocity_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( vsize_mma ) !NOTE: Deliberately NOT deallocating vm, in case overlay of vectors is ! wanted; this array can be VERY time-consuming to create, and it ! is not all that large! IF (ALLOCATED(ndplat)) DEALLOCATE ( plon, plat, ndplat ) ! LIFO order DEALLOCATE ( fault_LRi, & ! in LIFO order & nodeF, & & continuum_LRi, & & nodes, & & node_has_area, & & checkN, & & ynode, & & xnode, & & node_uvec ) just_began_deep_flow = .TRUE. ! may speed overlay of vectors ! end of 9: magnitude of deep velocity field CASE (10) ! magnitude of shear traction on base of model CALL Add_Title ('Shear Traction on Base of Model') CALL DGroup_or_Bitmap (latter_mosaic, traction_method, bitmap_height, bitmap_width) IF (.NOT.got_FEP) CALL Get_FEP 1100 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 finite-element grid should traction be computed on?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1100 END IF READ (21,*) ! title READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( xnode(numnod) ) !theta, in radians ALLOCATE ( ynode(numnod) ) !phi, in radians ALLOCATE ( checkN(numnod) ) ALLOCATE ( eqcm(6, numnod) ) ALLOCATE ( whichp(numnod) ) OrbData5 = .FALSE. ! unless non-zero values discovered in columns 5, 6 below... DO i = 1, numnod READ (21, "(A)", IOSTAT = ios) input_record READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters, & & density_anomaly_kgpm3, cooling_curvature_Cpm2 IF (ios /= 0) THEN density_anomaly_kgpm3 = 0.0D0 cooling_curvature_Cpm2 = 0.0D0 READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters END IF CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) CALL DLonLat_2_ThetaPhi (lon, lat, theta, phi) xnode(i) = theta ynode(i) = phi eqcm(1,i) = elevation eqcm(2,i) = heatflow eqcm(3,i) = crust_meters eqcm(4,i) = mantle_meters eqcm(5,i) = density_anomaly_kgpm3 eqcm(6,i) = cooling_curvature_Cpm2 OrbData5 = OrbData5 .OR. (density_anomaly_kgpm3 /= 0.0D0) .OR. (cooling_curvature_Cpm2 /= 0.0D0) END DO ! i = 1, numnod READ (21,*) numEl ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21,*) nFl ALLOCATE ( nodeF(4, nFl) ) ALLOCATE ( fault_LRi(nFl) ) DO i = 1, nFl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output fault_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodeF(1,i), nodeF(2,i), nodeF(3,i), nodeF(4,i) END DO ! i = 1, nfl CLOSE(21) !Now that LRn is known: [N.B. It will often be 0] ALLOCATE ( LR_is_defined(0:LRn) ) ALLOCATE ( LR_is_used(0:LRn) ) LR_is_defined = .FALSE. ! whole array, until information is read, below... LR_is_used = .FALSE. ! whole array, until information is read, below... ALLOCATE ( LR_set_fFric(0:LRn) ) ALLOCATE ( LR_set_cFric(0:LRn) ) ALLOCATE ( LR_set_Biot(0:LRn) ) ALLOCATE ( LR_set_Byerly(0:LRn) ) ALLOCATE ( LR_set_aCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_bCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_cCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_dCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_eCreep(0:LRn) ) !Just for ease in debugging, initialize all (currently) undefined array values as zero: LR_set_fFric = 0.0D0 LR_set_cFric = 0.0D0 LR_set_Biot = 0.0D0 LR_set_Byerly = 0.0D0 LR_set_aCreep = 0.0D0 LR_set_bCreep = 0.0D0 LR_set_cCreep = 0.0D0 LR_set_dCreep = 0.0D0 LR_set_eCreep = 0.0D0 !Get input parameters. !N.B. If iconve == 6, rheologic parameters not needed. ! However, we must still read the parameters to discover that iconve == 6 ! 1101 temp_path_in = path_in !CALL File_List( file_type = "i*.in", & ! & suggested_file = parameter_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the input parameters?',parameter_file,parameter_file) parameter_pathfile = TRIM(temp_path_in)//TRIM(parameter_file) CALL Input_to_SHELLS ( 11, parameter_pathfile, names , nPlates, & ! inputs & alphat, conduc, & ! outputs... & d_fFric, d_cFric, d_Biot, d_Byerly, d_aCreep, d_bCreep, d_cCreep, d_dCreep, d_eCreep, & & everyp, & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, radius, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) !Remember the default ("d_") Lithospheric Rheology as LR0, or LR_set_XXXX(0): LR_set_fFric(0) = d_fFric LR_set_cFric(0) = d_cFric LR_set_Biot(0) = d_Biot LR_set_Byerly(0) = d_Byerly LR_set_aCreep(1:2, 0) = d_aCreep(1:2) LR_set_bCreep(1:2, 0) = d_bCreep(1:2) LR_set_cCreep(1:2, 0) = d_cCreep(1:2) LR_set_dCreep(1:2, 0) = d_dCreep(1:2) LR_set_eCreep(0) = d_eCreep LR_is_defined(0) = .TRUE. IF (LRn > 0) THEN CALL Read_Additional_LRs (temp_path_in, 13, LRn, continuum_LRi, fault_LRi, numEl, nFl, & ! input & LR_set_fFric, LR_set_cFric, LR_set_Biot, LR_set_Byerly, & ! modify & LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_dCreep, LR_set_eCreep, & & LR_is_defined, LR_is_used) !N.B. This SUBR will prompt the user to supply the name of the necessary input file. END IF ! LRn > 0 IF (iconve == 0) THEN line = 'due to static lower mantle (w.r.t. AF)' CALL Add_Title(line) ELSE IF (iconve == 1) THEN IF (vtimes == 1.0D0) THEN line = "due to Hager & O'Connell (1979) lower mantle flow" ELSE WRITE (c5,"(F5.2)") vtimes line = "due to Hager & O'Connell (1979) lower mantle flow x" // c5 END IF CALL Add_Title(line) ELSE IF (iconve == 2) THEN IF (vtimes == 1.0D0) THEN line = 'due to Baumgardner (1988) Fig. 7 flow' ELSE WRITE (c5,"(F5.2)") vtimes line = 'due to Baumgardner (1988) Fig. 7 flow x' // c5 END IF CALL Add_Title(line) ELSE IF (iconve == 3) THEN IF (vtimes == 1.0D0) THEN line = 'due to PB2002 (Bird, 2003) flow' ELSE WRITE (c5,"(F5.2)") vtimes line = 'due to PB2002 flow x' // c5 END IF CALL Add_Title(line) ELSE IF (iconve == 4) THEN IF (vtimes == 1.0D0) THEN line = 'due to PB2002 (Bird, 2003) flow dragging continents only' ELSE WRITE (c5,"(F5.2)") vtimes line = 'due to PB2002 flow x' // c5 // ' dragging continents only' END IF CALL Add_Title(line) ELSE IF (iconve == 5) THEN ! drag on base of subduction forearc only WRITE (*,"(/' Sorry. The display for ICONVE == 5 is not programmed yet.')") CALL Pause() GO TO 1999 ELSE IF (iconve == 6) THEN ! shear traction on slabless plates from PREVIOUS traction report: 1102 WRITE (*,"( & &/' ICONVE==6 implies basal shear tractions on slabless plates were computed' & &/' from a torque report file created in a PREVIOUS run of SHELLS.' & &/' It is necessary to access that PREVIOUS torque report to prepare this plot!'\)") temp_path_in = path_in !CALL File_List( file_type = "q*.out", & ! & suggested_file = torque_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file reported the plate-driving torques?',torque_file,torque_file) torque_pathfile = TRIM(temp_path_in)//TRIM(torque_file) OPEN(UNIT = 21, FILE = torque_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL Pause() GO TO 1102 END IF DO i = 1, 5 READ (21, "(A)") line IF (i <= 3) CALL Add_Title(line) END DO ! first 5 lines (titles1~3 & 2 blanks) of torque file READ (21, "(46X,A)") line(1:38) ! " (FFRIC 0.150, TAUMAX 2.5E+12\2.5E+12)" line = "Inferred basal-strength tractions" // TRIM(line) CALL Add_Title(line) CLOSE (21) ! for now; will re-open below END IF CALL Add_Title(parameter_file) CALL Add_Title(title3) !Now, call CONVEC(iconve), which may require arrays (or do its own I/O!), !to get the deep velocity field at nodes: vm(2,numnod): IF ((iconve == 3).OR.(iconve == 4).OR.(iconve == 6)) THEN ! plate outlines are needed: temp_path_in = path_in !CALL File_List( file_type = "*.dig", & ! & suggested_file = plates_dig_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the plate outlines?',plates_dig_file,plates_dig_file) ALLOCATE ( ndplat(nPlates) ) ! Integer; plate-boundary path lengths ALLOCATE ( plat(nPlates, mostInOnePlate) ) ! latitudes of plate-boundary paths ALLOCATE ( plon(nPlates, mostInOnePlate) ) ! longitudes of plate-boundary paths CALL GETNUV (temp_path_in,plates_dig_file,21,6,names,mostInOnePlate,nPlates, & ! inputs & ndplat,plat,plon) ! outputs !N.B. Subprogram -GETNUV- will handle any file-not-found problems. IF (iconve == 6) THEN ! assign each node of the .feg to a plate ID# in INTEGER, DIMENSION(numnod) :: whichp WRITE (*,"(/' Assigning every node to a plate (slow)...')") CALL ASSIGN (6, & ! INPUTs & mostInOnePlate, ndplat, nfl, nodef, nodes, & & nPlates, numel, numnod, & & plat, plon, & & xnode, ynode, & & whichp, & ! OUTPUT & checkN) ! WORK WRITE (*,"('+Assigning every node to a plate....DONE ')") CALL BEEPQQ (frequency = 440, duration = 250) END IF END IF ALLOCATE ( traction_MPa(numnod) ) IF (iconve <= 5) THEN ! all cases prior to new (q-report-based) iConve = 6 !compute vm (mantle velocity), then read in vs (surface velocity); compute traction_MPa using existing input parameters ALLOCATE ( vm(2,numnod) ) CALL CONVEC (iconve, ipAfri, ipvref, 21, 6, & & names, ndplat, & & nfl, nodef, nodes, & & mostInOnePlate, nPlates, numel, numnod, & & omega, path_in, plat, plon, mp_radius_meters, vtimes, & & xnode, ynode, & ! inputs & vm ) ! output array = lower mantle velocity vm(2,numnod) !Get surface velocity solution (v____.out): 1103 temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity solution file should be used?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1103 END IF DO i = 1, 3 READ (22,"(A)") line CALL Add_Title(line) END DO ! first 3 lines of velocity file ALLOCATE ( vs(2, numnod) ) READ (22,*) ((vs(i,j), i = 1,2), j = 1,numnod) CLOSE(22) !Compute geotherm & glue at 7 IPs of each continuum element: CALL Limits_in_SHELLS (eqcm,nodes,numel,node_uvec, & & okdelv,mp_radius_meters,refstr, & & trhmax, & ! inputs & constr,etamax,fmumax,vismax) ! outputs (especially: etaMax) ALLOCATE ( nodal_vector_numerator(2, numNod) ) nodal_vector_numerator = 0.0D0 ! initializing before sum ALLOCATE ( nodal_vector_denominator(numNod) ) nodal_vector_denominator = 0.0D0 ALLOCATE ( glue(7, numEl) ) !Calculate "glue" (shear stress, at each IP of each continuum element, required to create one unit of relative !horizontal velocity across the lithosphere+asthenosphere mantle layer, down to depth zBAsth). ALLOCATE ( geothC(4, 7, numEl) ) ALLOCATE ( geothM(4, 7, numEl) ) ALLOCATE ( zMoho(7, numEl) ) ALLOCATE ( zMNode(numNod) ) DO i = 1, numNod zMNode(i) = eqcm(3, i) END DO CALL Interp (zMNode, nodes, numEl, numNod, & ! input & zMoho) ! output DEALLOCATE ( zMNode ) ! but, zMoho(7, numEl) remains, for now ... ALLOCATE ( tLNode(numNod) ) DO i = 1, numNod tLNode(i) = eqcm(4, i) END DO ALLOCATE ( dQdTdA(numNod) ) ALLOCATE ( tLInt(7, numEl) ) CALL Interp (tLNode, nodes, numEl, numNod, & ! input & tLInt) ! output DEALLOCATE ( tLNode ) DO i = 1, numNod dQdTdA(i) = eqcm(2, i) END DO CALL Compute_geotherms (conduc, dQdTdA, gradie, & & nodes, numEl, numNod, & & radio, tAdiab, tLInt, tSurf, zMoho, & ! input & geothC, geothM) ! output DEALLOCATE ( tLInt ) DEALLOCATE ( dQdTdA ) CALL OneBar (continuum_LRi, & ! input & geothC, geothM, gradie, & ! input & LRn, LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_eCreep, & ! input & numEl, oneKm, tAdiab, & ! input & zBAsth, zMoho, & ! input & glue) ! output: glue(1:7, 1:numEl) DEALLOCATE ( zMoho ) DEALLOCATE ( geothM ) DEALLOCATE ( geothC ) ! but, glue() remains (for now)... !Compute derivitives of nodal functions at integration points: ALLOCATE ( fPSfer(2, 2, 3, 7, numEl) ) ALLOCATE ( area(numEl) ) ALLOCATE ( detJ(7, numEl) ) ALLOCATE ( dXS(2, 2, 3, 7, numEl) ) ALLOCATE ( dYS(2, 2, 3, 7, numEl) ) ALLOCATE ( dXSP(3, 7, numEl) ) ALLOCATE ( dYSP(3, 7, numEl) ) ALLOCATE ( sita(7, numEl) ) CALL Deriv ( 6, numEl, numNod, nodes, numEl, & ! input & radius, xNode, yNode, & & area, detJ, & ! output & dXS, dYS, dXSP, dYSP, fPSfer, sita) ! (In this context, what we will need is fPSfer. Other arrays to be discarded...) DEALLOCATE ( sita ) ! in LIFO order DEALLOCATE ( dYSP ) DEALLOCATE ( dXSP ) DEALLOCATE ( dYS ) DEALLOCATE ( dXS ) DEALLOCATE ( detJ ) DEALLOCATE ( area ) ! but, fPSfer(,,,,) remains (for now)... !compute surface-velocity and lower-mantle-velocity at integration points of continuum elements: ALLOCATE ( outVecS(2, 7, numEl) ) ALLOCATE ( outVecM(2, 7, numEl) ) !using nodal-vector arrays vs and vm computed above.... CALL Flow (fPSfer, numEl, numNod, nodes, numEl, vs, & ! input & outVecS) ! output CALL Flow (fPSfer, numEl, numNod, nodes, numEl, vm, & ! input & outVecM) ! output DEALLOCATE ( fPSfer ) DO i = 1, numEl vs_IP1(1:2) = outVecS(1:2, 1, i) vm_IP1(1:2) = outVecM(1:2, 1, i) deltaV_IP1(1:2) = vm_IP1(1:2) - vs_IP1(1:2) ! components (theta == S, phi == E). deltaV_IP1_mps = SQRT(deltaV_IP1(1)**2 + deltaV_IP1(2)**2) !compute basal shear traction at integration point #1, subject to 2 upper-limits: traction_IP1_MPa = 1.0D-6 * glue(1, i) * deltaV_IP1_mps**LR_set_eCreep(continuum_LRi(i)) traction_IP1_MPa = MIN(traction_IP1_MPa, (etaMax * deltaV_IP1_mps * 1.0D-6)) traction_IP1_MPa = MIN(traction_IP1_MPa, (trHMax * 1.0D-6)) !divide traction into (theta, phi) = (S, E) components: IF (deltaV_IP1_mps > 0.0D0) THEN traction_IP1_MPa_S = traction_IP1_MPa * deltaV_IP1(1) / deltaV_IP1_mps traction_IP1_MPa_E = traction_IP1_MPa * deltaV_IP1(2) / deltaV_IP1_mps ELSE traction_IP1_MPa_S = 0.0D0 traction_IP1_MPA_E = 0.0D0 END IF !Now, apply this traction vector to the (not-yet-ratioed) numerator & denominator sums for 3 corner nodes: DO j = 1, 3 !define 3 corners of this element (from current-node point-of-view): jp1 = j+1; IF (jp1 > 3) jp1 = jp1 - 3 jp2 = jp1+1; IF (jp2 > 3) jp2 = jp2 - 3 k = nodes(j, i) kp1 = nodes(jp1, i) kp2 = nodes(jp2, i) CALL DThetaPhi_2_Uvec(xnode(k), ynode(k), uvec1) CALL DThetaPhi_2_Uvec(xnode(kp1), ynode(kp1), uvec2) CALL DThetaPhi_2_Uvec(xnode(kp2), ynode(kp2), uvec3) !define angle, at current node, between great-circle arcs going to the other 2 nodes: angle_weight = ABS(DRelative_Compass(uvec1, uvec2) - DRelative_Compass(uvec1, uvec3)) IF (angle_weight > Pi) angle_weight = Two_Pi - angle_weight !increment vector (and scalar) sums at each node nodal_vector_numerator(1, k) = nodal_vector_numerator(1, k) + (traction_IP1_MPa_S * angle_weight) nodal_vector_numerator(2, k) = nodal_vector_numerator(2, k) + (traction_IP1_MPa_E * angle_weight) nodal_vector_denominator(k) = nodal_vector_denominator(k) + angle_weight END DO ! j = 1, 3 (corners) END DO ! i = 1, numEl (all continuum elements)\ DEALLOCATE ( outVecM ) ! in LIFO order DEALLOCATE ( outVecS ) DEALLOCATE ( glue ) DO i = 1, numnod IF (nodal_vector_denominator(i) > 0.0D0) THEN traction_at_node_MPa_S = nodal_vector_numerator(1, i) / nodal_vector_denominator(i) traction_at_node_MPa_E = nodal_vector_numerator(2, i) / nodal_vector_denominator(i) traction_MPa(i) = SQRT(traction_at_node_MPa_S**2 + traction_at_node_MPa_E**2) ELSE traction_MPa(i) = 0.0D0 END IF IF (iconve == 4) THEN ! no basal shear traction under oceans! elevation = eqcm(1, i) heatflow = eqcm(2, i) continental = (elevation > -2500.0D0).AND.(heatflow < 0.150D0) IF (.NOT.continental) traction_MPa(i) = 0.0D0 END IF END DO ! i = 1, numnod DEALLOCATE ( nodal_vector_denominator ) DEALLOCATE ( nodal_vector_numerator ) ELSE IF (iconve == 6) THEN !no need to allocate and compute vm, or allocate and read vs; !get traction_MPa directly from traction pole vectors in torque report (and existing whichp): ALLOCATE ( traction_pole_vector(3,nPlates) ) traction_pole_vector = 0.0D0 ! whole array; advisable because some plates may not appear in report. ALLOCATE ( traction_pole_read(nPlates) ) ! logical traction_pole_read = .FALSE. ! whole list (1..nPlates) OPEN(UNIT = 21, FILE = torque_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') ! re-opening; I assume file is there. DO i = 1, 6 READ (21, "(A)") line END DO ! waste first 6 lines (titles1~3 & 2 blanks & header) of torque file. !N.B. Header was already read, up above, to extract header line. traction_poling: DO READ (21, *, IOSTAT = ios) ! blank line IF (ios == -1) EXIT traction_poling ! EOF READ (21, "(8X,I6)", IOSTAT = ios) iplate IF (ios == -1) EXIT traction_poling ! EOF DO j = 1, 23 ! waste 23 more lines of each plate report READ (21, *, IOSTAT = ios) IF (ios == -1) EXIT traction_poling ! EOF END DO READ (21, "(56X,ES10.3,2F10.2)") t, lon, lat ! t is magnitude, in Pa, at location 90 deg. from (lon, lat). CALL DLonLat_2_Uvec(lon, lat, uvec) traction_pole_vector(1:3, iplate) = t * uvec(1:3) traction_pole_read(iplate) = .TRUE. DO j = 1, 14 ! waste 14 lines to get past the "=======" at the bottom of each torque report: READ (21, *, IOSTAT = ios) IF (ios == -1) EXIT traction_poling ! EOF END DO END DO traction_poling CLOSE (21) ! second CLOSE; but, will usually be re-opened once more in overlay section DO i = 1, numnod iplate = whichp(i) ! previously computed above by -ASSIGN- IF (slab_Q(iplate)) THEN traction_MPa(i) = 0.0D0 ELSE ! no (extensive) driving slab attached: IF (traction_pole_read(iplate)) THEN uvec(1) = DSIN(xnode(i)) * DCOS(ynode(i)) ! xnode is theta in radians; ynode is phi. uvec(2) = DSIN(xnode(i)) * DSIN(ynode(i)) uvec(3) = DCOS(xnode(i)) tvec(1) = traction_pole_vector(2, iplate) * uvec(3) - traction_pole_vector(3, iplate) * uvec(2) tvec(2) = traction_pole_vector(3, iplate) * uvec(1) - traction_pole_vector(1, iplate) * uvec(3) tvec(3) = traction_pole_vector(1, iplate) * uvec(2) - traction_pole_vector(2, iplate) * uvec(1) t = DSQRT(tvec(1)**2 + tvec(2)**2 + tvec(3)**2) t = MIN(t, trhmax) traction_MPa(i) = t / 1.D6 ! from Pa to MPa ELSE traction_MPa(i) = 0.0D0 END IF END IF ! slab_Q(iplate), or not END DO DEALLOCATE ( traction_pole_read ) DEALLOCATE ( traction_pole_vector ) END IF ! iconve <=5 (rheologic method), OR iconve == 6 (traction pole vector method) WRITE (*,"(/' Here is the distribution of tractions (in MPa):')") CALL Histogram (traction_MPa, numnod, .FALSE., maximum, minimum) IF (traction_method == 1) THEN ! group of colored/shaded polygons IF (traction_interval == 0.0D0) THEN traction_interval = (maximum - minimum) / ai_spectrum_count traction_midvalue = (maximum + minimum) / 2.0D0 END IF 1104 CALL DPrompt_for_Real('What contour interval do you wish?',traction_interval,traction_interval) IF (traction_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") traction_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1104 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',traction_midvalue,traction_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low-traction areas be colored blue (versus red)?',traction_lowblue,traction_lowblue) ELSE CALL DPrompt_for_Logical('Should low-traction areas be shaded darkly (versus lightly)?',traction_lowblue,traction_lowblue) END IF WRITE (*,"(/' Working on magnitude of traction on base of plate....')") 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 IF (MAX(traction_MPa(nodes(1,i)), & & traction_MPa(nodes(2,i)), & & traction_MPa(nodes(3,i))) > 0.0) 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 = traction_MPa(nodes(1,i)), & & f2 = traction_MPa(nodes(2,i)), & & f3 = traction_MPa(nodes(3,i)), & & low_value = minimum, high_value = maximum, & & contour_interval = traction_interval, & & midspectrum_value = traction_midvalue, & & low_is_blue = traction_lowblue, group = group) END IF ! traction /= 0.0 for whole element 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 = traction_interval, & & midspectrum_value = traction_midvalue, & & low_is_blue = traction_lowblue, & & units = 'MPa') 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 = traction_interval, & & midspectrum_value =traction_midvalue, & & low_is_blue = traction_lowblue, & & units = 'MPa') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on magnitude of traction on base of plate....DONE.')") ELSE ! traction_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN uvec1(1:3) = node_uvec(1:3,nodes(1,iele)) uvec2(1:3) = node_uvec(1:3,nodes(2,iele)) uvec3(1:3) = node_uvec(1:3,nodes(3,iele)) t = s1 * traction_MPa(nodes(1,iele)) + & & s2 * traction_MPa(nodes(2,iele)) + & & s3 * traction_MPa(nodes(3,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, & & 'MPa', minimum, maximum, & & bitmap_color_mode, traction_interval, traction_midvalue, traction_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, 'MPa', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & traction_interval, traction_midvalue, traction_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, 'MPa', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & traction_interval, traction_midvalue, traction_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! traction_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) IF (ALLOCATED(vs)) DEALLOCATE ( vs ) ! IF iconve == 6, these two were never allocated. IF (ALLOCATED(vm)) DEALLOCATE ( vm ) DEALLOCATE ( traction_MPa ) ! in LIFO order IF (ALLOCATED(ndplat)) DEALLOCATE ( plon, plat, ndplat ) ! LIFO order DEALLOCATE ( LR_set_eCreep, LR_set_dCreep, LR_set_cCreep, LR_set_bCreep, LR_set_aCreep, & ! in LIFO order & LR_set_Byerly, LR_set_Biot, LR_set_cFric, LR_set_fFric, & & LR_is_used, LR_is_defined) DEALLOCATE ( fault_LRi, & ! in LIFO order & nodeF, & & continuum_LRi, & & nodes, & & eqcm, & ! N.B. Deliberately LEAVING whichP allocated, in case overlay #6 is wanted! & checkN, & & ynode, & & xnode, & & node_uvec ) just_began_traction = .TRUE. ! may speed overlay of vectors ! end of 10: magnitude of shear traction on base of model CASE (11) ! magnitude of surface velocity CALL DGroup_or_Bitmap (latter_mosaic, velocity_method, bitmap_height, bitmap_width) IF (.NOT.got_FEP) CALL Get_FEP 1110 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 grid was used to compute velocities?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1110 END IF READ (21,*) ! title READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( node_has_area(numnod) ) ALLOCATE ( vw(2*numnod) ) ALLOCATE ( vsize_mma(numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21,*) numEl ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel CLOSE(21) 1111 temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be plotted?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1111 END IF DO i = 1, 3 READ (22,"(A)") line CALL Add_Title(line) END DO ! first 3 lines of velocity file READ (22,*) (vw(i), i = 1, (2*numnod)) !this read method should work with either SHELLS or RESTORE format CLOSE(22) CALL DPrompt_for_Logical('Do you wish to CHANGE the velocity reference frame?',velocity_reframe,velocity_reframe) IF (velocity_reframe) THEN 1112 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 1112 END IF ! illegal fixed_node 1113 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 1113 END IF ! illegal nonorbiting_node WRITE (number8, "(I8)") fixed_node line = 'Surface Velocity, with node ' // TRIM(ADJUSTL(number8)) // ' fixed' CALL Add_Title(line) CALL Reframe_Velocity() ELSE ! velocity_reframe = .FALSE. CALL Add_Title('Surface Velocity Magnitude') END IF ! velocity_reframe, or not !When finding range of velocities, do not consider any nodes which do not !have associated continuum-element area. (Disregard boundary nodes on the !outside of marginal faults, which are parts of adjacent plates.) node_has_area = .FALSE. ! initialize whole array DO i = 1, numel node_has_area(nodes(1, i)) = .TRUE. node_has_area(nodes(2, i)) = .TRUE. node_has_area(nodes(3, i)) = .TRUE. END DO ! i = 1, numel list_length = 0 DO i = 1, numnod IF (node_has_area(i)) THEN list_length = list_length + 1 v_South_mps = vw(2*i-1) v_East_mps = vw(2*i) vsize_mma(list_length) = 1000.0D0 * sec_per_year * DSQRT(v_South_mps**2 + v_East_mps**2) END IF 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.0D0 END IF 1114 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 1114 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)) v1S_mma = 1000.0D0 * sec_per_year * vw(2*nodes(1,i)-1) v2S_mma = 1000.0D0 * sec_per_year * vw(2*nodes(2,i)-1) v3S_mma = 1000.0D0 * sec_per_year * vw(2*nodes(3,i)-1) v1E_mma = 1000.0D0 * sec_per_year * vw(2*nodes(1,i)) v2E_mma = 1000.0D0 * sec_per_year * vw(2*nodes(2,i)) v3E_mma = 1000.0D0 * sec_per_year * vw(2*nodes(3,i)) CALL DContour_3Node_Sphere_Velocity( & & uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & v1t = v1S_mma, v1p = V1E_mma, & & v2t = v2S_mma, v2p = V2E_mma, & & v3t = v3S_mma, v3p = V3E_mma, & & low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value = velocity_midvalue, & & low_is_blue = velocity_lowblue, group = group) END DO ! i = 1, numel CALL DEnd_Group ! 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 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL DLearn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) CALL DReject (x_meters,y_meters, success, uvec) CALL DWhich_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN uvec1(1:3) = node_uvec(1:3,nodes(1,iele)) uvec2(1:3) = node_uvec(1:3,nodes(2,iele)) uvec3(1:3) = node_uvec(1:3,nodes(3,iele)) v1S = vw(2*nodes(1,iele)-1) v2S = vw(2*nodes(2,iele)-1) v3S = vw(2*nodes(3,iele)-1) v1E = vw(2*nodes(1,iele)) v2E = vw(2*nodes(2,iele)) v3E = vw(2*nodes(3,iele)) CALL DVelocity_Size_in_3Node_Sphere & & (iele, uvec1, uvec2, uvec3, & ! element input & v1S,v1E, v2S,v2E, v3S,v3E, & ! nodal velocities & uvec, & ! position input & vsize, d_vsize_d_theta, d_vsize_d_phi) ! outputs t = vsize * 1000.0D0 * sec_per_year 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, & & 'mm/a', minimum, maximum, & & bitmap_color_mode, velocity_interval, velocity_midvalue, velocity_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! velocity_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( continuum_LRi ) ! in LIFO order DEALLOCATE ( nodes ) DEALLOCATE ( vsize_mma ) DEALLOCATE ( vw ) DEALLOCATE ( node_has_area ) DEALLOCATE ( node_uvec ) just_began_surface_flow = .TRUE. ! may speed overlay of vectors ! end of 11: magnitude of surface velocity field CASE (12) ! log of largest (absolute value) principal strain-rate CALL DGroup_or_Bitmap (latter_mosaic, log_strainrate_method, bitmap_height, bitmap_width) IF (.NOT.got_FEP) CALL Get_FEP CALL Add_Title('Common Log of [Largest (Absolute Value) Principal Strain-Rate * 1 s]') 1120 temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file defines the elements?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN (UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) ALLOCATE ( node_uvec(3,numnod) ) DO i = 1, numnod READ (21, *, IOSTAT = ios) j, lon, lat problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numEl problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *, 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. GO TO 1120 END IF CLOSE (21) CALL Add_Title(feg_file) 1121 temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be used?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1121 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 ( log_largest_ei_persec(numel) ) DO l_ = 1, numel ! compute strainrates at element centers uvec1(1:3) = node_uvec(1:3, nodes(1, l_)) uvec2(1:3) = node_uvec(1:3, nodes(2, l_)) uvec3(1:3) = node_uvec(1:3, nodes(3, l_)) m = 1 ! (not using loop, since values for m =1,...,7 almost identical ! evaluate nodal function and derivitives uvec4(1:3) = Gauss_point(1,m) * node_uvec(1:3, nodes(1,l_)) + & & Gauss_point(2,m) * node_uvec(1:3, nodes(2,l_)) + & & Gauss_point(3,m) * node_uvec(1:3, nodes(3,l_)) CALL 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(ABS(e1h), ABS(e2h), ABS(err)) IF (largest_ei_persec == 0.0D0) THEN log_largest_ei_persec(l_) = -20.0D0 ! arbitrary substitute for -infinity! ELSE log_largest_ei_persec(l_) = DLOG10(largest_ei_persec) END IF !(not using loop on m = 1,...,7 since values almost identical) END DO ! l_ = 1, numel, computing strainrates and scalar measure WRITE (*,"(/' Here is the distribution of common logs of largest (absolute value)' & & /' principal strain-rates (LOG10(MAX(ABS(Ei * 1 s)))) for each element:')") CALL Histogram (log_largest_ei_persec, numel, .FALSE., maximum, minimum) IF (log_strainrate_method == 1) THEN ! group of colored/shaded polygons IF (log_strainrate_interval == 0.0D0) THEN log_strainrate_interval = (maximum - minimum) / ai_spectrum_count log_strainrate_midvalue = (maximum + minimum) / 2.0D0 END IF 1122 CALL DPrompt_for_Real('What contour interval do you wish?',log_strainrate_interval,log_strainrate_interval) IF (log_strainrate_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") log_strainrate_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1122 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',log_strainrate_midvalue,log_strainrate_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 = log_largest_ei_persec(i) IF (MOD(t, log_strainrate_interval) == 0.0D0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0) THEN t = t - 0.001D0 * log_strainrate_interval ELSE ! t < 0.0 t = t + 0.001D0 * log_strainrate_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 = log_strainrate_interval, & & midspectrum_value = log_strainrate_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 CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! ELSE ! log_strainrate_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL 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 = log_largest_ei_persec(iele) bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL DBumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & ' ', minimum, maximum, & & bitmap_color_mode, log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! log_strainrate_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( log_largest_ei_persec, & & vw, & ! in LIFO order & continuum_LRi, & & nodes, & & node_uvec) just_began_strainrate = .TRUE. ! may speed overlay of tensor symbols ! end of 12: log of [largest (absolute value) principal strain-rate * 1 s] CASE (13) ! rotation rate about local vertical axis CALL DGroup_or_Bitmap (latter_mosaic, rotationrate_method, bitmap_height, bitmap_width) IF (.NOT.got_FEP) CALL Get_FEP CALL Add_Title('Rotation Rate (of rigid cylinders, about vertical axis)') 1130 temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file defines the elements?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN (UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) ALLOCATE ( node_uvec(3,numnod) ) DO i = 1, numnod READ (21, *, IOSTAT = ios) j, lon, lat problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numEl problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *, 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. GO TO 1130 END IF CLOSE (21) CALL Add_Title(feg_file) 1131 temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be used?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1131 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' & /' (for rigid vertical-circular-cylindrical inclusions,' & /' 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 1132 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 1132 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 (MOD(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 (frequency = 440, duration = 250) DEALLOCATE ( omega_degperMa, & & vw, & ! in LIFO order & continuum_LRi, & & nodes, & & node_uvec) ! end of 13: rotation rate (of vertical cylinder, about vertical axis) CASE (14) ! vertical integral of greatest shear stress CALL Add_Title('Vertical Integral of Greatest Shear Stress') CALL DGroup_or_Bitmap (latter_mosaic, shear_integral_method, bitmap_height, bitmap_width) IF (.NOT.got_FEP) CALL Get_FEP 1140 temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file defines the elements?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN (UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( vw(2*numnod) ) ALLOCATE ( eqcm(6,numnod) ) OrbData5 = .FALSE. ! unless non-zero values discovered in columns 5, 6 below... DO i = 1, numnod READ (21, "(A)", IOSTAT = ios) input_record READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters, & & density_anomaly_kgpm3, cooling_curvature_Cpm2 IF (ios /= 0) THEN density_anomaly_kgpm3 = 0.0D0 cooling_curvature_Cpm2 = 0.0D0 READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters END IF problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) eqcm(1,i) = elevation eqcm(2,i) = heatflow eqcm(3,i) = crust_meters eqcm(4,i) = mantle_meters eqcm(5,i) = density_anomaly_kgpm3 eqcm(6,i) = cooling_curvature_Cpm2 OrbData5 = OrbData5 .OR. (density_anomaly_kgpm3 /= 0.0D0) .OR. (cooling_curvature_Cpm2 /= 0.0D0) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numEl problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) ALLOCATE ( strainrate(3, 7, numel) ) ! 3 components; 7 integration points LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *, 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. GO TO 1140 END IF CLOSE (21) CALL Add_Title(feg_file) 1141 temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be used?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1141 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) 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) ! integration point 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 !Now that LRn is known: [N.B. It will often be 0] ALLOCATE ( LR_is_defined(0:LRn) ) ALLOCATE ( LR_is_used(0:LRn) ) LR_is_defined = .FALSE. ! whole array, until information is read, below... LR_is_used = .FALSE. ! whole array, until information is read, below... ALLOCATE ( LR_set_fFric(0:LRn) ) ALLOCATE ( LR_set_cFric(0:LRn) ) ALLOCATE ( LR_set_Biot(0:LRn) ) ALLOCATE ( LR_set_Byerly(0:LRn) ) ALLOCATE ( LR_set_aCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_bCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_cCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_dCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_eCreep(0:LRn) ) !Just for ease in debugging, initialize all (currently) undefined array values as zero: LR_set_fFric = 0.0D0 LR_set_cFric = 0.0D0 LR_set_Biot = 0.0D0 LR_set_Byerly = 0.0D0 LR_set_aCreep = 0.0D0 LR_set_bCreep = 0.0D0 LR_set_cCreep = 0.0D0 LR_set_dCreep = 0.0D0 LR_set_eCreep = 0.0D0 !Get input parameters. !N.B. If iconve == 6, rheologic parameters not needed. ! However, we must still read the parameters to discover that iconve == 6 ! 1142 temp_path_in = path_in !CALL File_List( file_type = "i*.in", & ! & suggested_file = parameter_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the input parameters?',parameter_file,parameter_file) parameter_pathfile = TRIM(temp_path_in)//TRIM(parameter_file) CALL Input_to_SHELLS ( 11, parameter_pathfile, names , nPlates, & ! inputs & alphat, conduc, & ! outputs... & d_fFric, d_cFric, d_Biot, d_Byerly, d_aCreep, d_bCreep, d_cCreep, d_dCreep, d_eCreep, & & everyp, & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, radius, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) !Remember the default ("d_") Lithospheric Rheology as LR0, or LR_set_XXXX(0): LR_set_fFric(0) = d_fFric LR_set_cFric(0) = d_cFric LR_set_Biot(0) = d_Biot LR_set_Byerly(0) = d_Byerly LR_set_aCreep(1:2, 0) = d_aCreep(1:2) LR_set_bCreep(1:2, 0) = d_bCreep(1:2) LR_set_cCreep(1:2, 0) = d_cCreep(1:2) LR_set_dCreep(1:2, 0) = d_dCreep(1:2) LR_set_eCreep(0) = d_eCreep LR_is_defined(0) = .TRUE. IF (LRn > 0) THEN CALL Read_Additional_LRs (temp_path_in, 13, LRn, continuum_LRi, fault_LRi, numEl, nFl, & ! input & LR_set_fFric, LR_set_cFric, LR_set_Biot, LR_set_Byerly, & ! modify & LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_dCreep, LR_set_eCreep, & & LR_is_defined, LR_is_used) !N.B. This SUBR will prompt the user to supply the name of the necessary input file. END IF ! LRn > 0 CALL Add_Title(parameter_file) CALL Limits_in_SHELLS (eqcm,nodes,numel,node_uvec, & & okdelv,mp_radius_meters,refstr, & & trhmax, & ! inputs & constr,etamax,fmumax,vismax) ! outputs !find vertical integral of greatest shear stress for each m=1 point: ALLOCATE ( shear_integral(numel) ) DO i = 1, numel n1 = nodes(1,i) n2 = nodes(2,i) n3 = nodes(3,i) m = 1 ! only do the center integration point of each element sighbi = 0.0D0 ! simply punting on this; too much trouble to recompute! e11 = strainrate(1,m,i) e12 = strainrate(2,m,i) ! (see subprogram E_rate) e22 = strainrate(3,m,i) CALL DPrincipal_Axes_22 (e11, e12, e22, & & e1, e2, u1x,u1y, u2x,u2y) IF ((e1 == 0.0D0).AND.(e2 == 0.0D0)) THEN shear_integral(i) = 0.0D0 ELSE t1 = 0.0D0 ! prepare to sum layer contributions to vertical integrals of t2 = 0.0D0 ! principal horizontal stresses (relative to vertical) heatflow = Gauss_point(1,m) * eqcm(2,n1) + Gauss_point(2,m) * eqcm(2,n2) + Gauss_point(3,m) * eqcm(2,n3) crust_meters = Gauss_point(1,m) * eqcm(3,n1) + Gauss_point(2,m) * eqcm(3,n2) + Gauss_point(3,m) * eqcm(3,n3) mantle_meters = Gauss_point(1,m) * eqcm(4,n1) + Gauss_point(2,m) * eqcm(4,n2) + Gauss_point(3,m) * eqcm(4,n3) density_anomaly_kgpm3 = Gauss_point(1,m) * eqcm(5,n1) + Gauss_point(2,m) * eqcm(5,n2) + Gauss_point(3,m) * eqcm(5,n3) !N.B. Following logic does not work, due to strong nonlinearities in geotherm equations interacting with lateral gradients: !cooling_curvature_Cpm2 = Gauss_point(1,m) * eqcm(6,n1) + Gauss_point(2,m) * eqcm(6,n2) + Gauss_point(3,m) * eqcm(6,n3) !Instead, it is necessary to adjust the geotherm to match the asthenosphere temperature (for either OrbData or OrbData5 models): tasthk = tadiab + gradie * 100.D3 !Non-controversial geotherm coefficients: geoth1 = tsurf geoth2 = heatflow / conduc(1) geoth3 = -0.5D0 * radio(1) / conduc(1) geoth4 = 0.0D0 geoth7 = -0.5D0 * radio(2) / conduc(2) geoth8 = 0.0D0 !On first pass, build geotherm WITHOUT any cooling_curvature (as in old Shells): geoth5 = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 + geoth4 * crust_meters**3 dtdzc = geoth2 + 2. * geoth3 * crust_meters + 3. * geoth4 * crust_meters**2 dtdzm = dtdzc * conduc(1) / conduc(2) geoth6 = dtdzm !Now, correct geotherm to hit tashtk: IF (mantle_meters > 0.0D0) THEN test = geoth5 + geoth6 * mantle_meters + geoth7 * mantle_meters**2 + geoth8 * mantle_meters**3 ELSE test = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 + geoth4 * crust_meters**3 END IF terr0r = test - tasthk delta_quadratic = -terr0r / (crust_meters + mantle_meters)**2 cooling_curvature_Cpm2 = -2.0D0 * delta_quadratic ! (not actually used here) geoth3 = geoth3 + delta_quadratic geoth7 = geoth7 + delta_quadratic geoth5 = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 + geoth4 * crust_meters**3 dtdzc = geoth2 + 2.0D0 * geoth3 * crust_meters + 3.0D0 * geoth4 * crust_meters**2 dtdzm = dtdzc * conduc(1) / conduc(2) geoth6 = dtdzm IF (crust_meters > 0.0D0) THEN pl0 = 0.0D0 ! same approximation as in VISCOS; pw0 = 0.0D0 ! ocean not important since it affects both equally zoftop = 0.0D0 rho_use = rhobar(1) + density_anomaly_kgpm3 geoth3 = -0.5D0 * (radio(1) / conduc(1)) -0.5D0 * cooling_curvature_Cpm2 !CALL DIAMND (acreep(1),alphat(1),bcreep(1), & ! beginning of inputs ! & biot,ccreep(1),dcreep(1),ecreep, & ! & e1,e2, & !principal horizontal strain rates ! & cfric,gmean,geoth1,geoth2,geoth3,geoth4, & ! & pl0,pw0,rho_use,rhoh2o,sighbi, & ! & crust_meters,temlim(1),vismax,zoftop, & ! end of inputs ! & pt1de1,pt2de2,pt2de1,pt2de2, & !beginning of outputs ! & pt1,pt2,ztran) !NOTE: ALL arguments in the following CALL must be scalars (not arrays)! CALL Diamnd (LR_set_aCreep(1, continuum_LRi(i)), alphaT(1), LR_set_bCreep(1, continuum_LRi(i)), & ! input & LR_set_Biot(continuum_LRi(i)), LR_set_cCreep(1, continuum_LRi(i)), LR_set_dCreep(1, continuum_LRi(i)), & & LR_set_eCreep(continuum_LRi(i)), & & e1, e2, & !principal horizontal strain rates (just computed above) & LR_set_cFric(continuum_LRi(i)), & & gmean, & ! <= note substitution for "g" in SUBR & geoth1, & & geoth2, & & geoth3, & & geoth4, & & pl0, pw0, & & rho_use, & ! <= note substitution for "rhoBar" in SUBR & rhoH2O, sigHBi, & & crust_meters, & ! <= note substition for "thick" in SUBR & temLim(1), & & visMax, zOfTop, & & pT1dE1, pT1dE2, & ! output & pT2dE1, pT2dE2, & & pT1, pT2, zTran) t1 = t1 + pt1 t2 = t2 + pt2 END IF ! crust_meters > 0 IF (mantle_meters > 0.0D0) THEN zoftop = crust_meters pw0 = rhoh2o * gmean * crust_meters t_mean = geoth1 + & & 0.5D0 * geoth2 * crust_meters + & & 0.333D0 * geoth3 * crust_meters**2 + & & 0.25D0 * geoth4 * crust_meters**3 rho_use = rhobar(1) * (1.0D0 - alphat(1) * t_mean) + density_anomaly_kgpm3 pl0 = rho_use * gmean * crust_meters rho_use = rhobar(2) + density_anomaly_kgpm3 !CALL DIAMND (acreep(2),alphat(2),bcreep(2), & ! beginning of inputs ! & biot,ccreep(2),dcreep(2),ecreep, & ! & e1,e2, & !principal horizontal strain rates ! & cfric,gmean,geoth5,geoth6,geoth7,geoth8, & ! & pl0,pw0,rho_use,rhoh2o,sighbi, & ! & mantle_meters,temlim(2),vismax,zoftop, & ! end of inputs ! & pt1de1,pt1de2,pt2de1,pt2de2, & !beginning of outputs ! & pt1,pt2,ztran) !NOTE: ALL arguments in the following CALL must be scalars (not arrays)! CALL Diamnd (LR_set_aCreep(2, continuum_LRi(i)), alphaT(2), LR_set_bCreep(2, continuum_LRi(i)), & ! input & LR_set_Biot(continuum_LRi(i)), LR_set_cCreep(2, continuum_LRi(i)), LR_set_dCreep(2, continuum_LRi(i)), & & LR_set_eCreep(continuum_LRi(i)), & & e1, e2, & !principal horizontal strain rates (just computed above) & LR_set_cFric(continuum_LRi(i)), & & gmean, & ! <= note substitution for "g" in SUBR & geoth5, & & geoth6, & & geoth7, & & geoth8, & & pl0, pw0, & & rho_use, & ! <= note substitution for "rhoBar" in SUBR & rhoH2O, sigHBi, & & mantle_meters, & ! <= note substition for "thick" in SUBR & temLim(2), & & visMax, zOfTop, & & pT1dE1, pT1dE2, & ! output & pT2dE1, pT2dE2, & & pT1, pT2, zTran) t1 = t1 + pt1 t2 = t2 + pt2 END IF ! mantle_meters > 0 shear_integral(i) = 0.5D0 * MAX(ABS(t1),ABS(t2),ABS(t2-t1)) END IF ! e1 OR e2 /= 0.0 END DO ! i = 1, numel ALLOCATE ( train (numel) ) k = 0 DO i = 1, numel uvec1(1:3) = node_uvec(1:3, nodes(1, i)) ! get 3 corner uvecs uvec2(1:3) = node_uvec(1:3, nodes(2, i)) uvec3(1:3) = node_uvec(1:3, nodes(3, i)) uvec4(1:3) = 0.333333 * uvec1(1:3) + & ! center-point tvec (almost uvec) & 0.333333 * uvec2(1:3) + & & 0.333333 * uvec3(1:3) CALL DMake_Uvec (uvec4, uvec) ! integration point visible = DL5_In_Window(uvec) IF (visible) THEN k = k + 1 train(k) = shear_integral(i) END IF END DO WRITE (*,"(/' Here is the distribution of visible integrated shear stresses:' )") CALL Histogram (train, k, .FALSE., maximum, minimum) DEALLOCATE ( train ) CALL DPrompt_for_String('What are the units of these numbers?',stress_integral_units,stress_integral_units) IF (shear_integral_method == 1) THEN ! group of colored/shaded polygons IF (shear_integral_interval == 0.0D0) THEN shear_integral_interval = (maximum - minimum) / ai_spectrum_count shear_integral_midvalue = (maximum + minimum) / 2.0D0 END IF 1143 CALL DPrompt_for_Real('What contour interval do you wish?',shear_integral_interval,shear_integral_interval) IF (shear_integral_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") shear_integral_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1143 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',shear_integral_midvalue,shear_integral_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',shear_integral_lowblue,shear_integral_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',shear_integral_lowblue,shear_integral_lowblue) END IF IF (minimum == 0.0D0) THEN 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 element')") WRITE (*,"(' mode -1 :: round down to the 1st negative color')") WRITE (*,"(' ------------------------------------------------')") 1144 CALL DPrompt_for_Integer('Which mode do you want?',shear_integral_zeromode,shear_integral_zeromode) IF ((shear_integral_zeromode < -1).OR.(shear_integral_zeromode > 1)) THEN WRITE (*,"(' ERROR: Select mode in legal range.')") mt_flashby = .FALSE. GO TO 1144 shear_integral_zeromode = 0 END IF ! illegal value entered END IF ! any zero values WRITE (*,"(/' Working on vertical integral of greatest shear stress....')") 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 = shear_integral(i) IF (t == 0.0D0) THEN SELECT CASE (shear_integral_zeromode) CASE (1) ! round up t = 0.001D0 * shear_integral_interval plot_this = .TRUE. CASE (0) ! do not plot plot_this = .FALSE. CASE (-1) ! round down t = -0.001D0 * shear_integral_interval plot_this = .TRUE. END SELECT ELSE ! non-zero value plot_this = .TRUE. IF (MOD(t, shear_integral_interval) == 0.0D0) THEN ! Color is undefined for t = n * shear_integral_interval, ! so nudge the value toward zero: IF (t > 0.0D0) THEN t = t - 0.001D0 * shear_integral_interval ELSE ! t < 0.0 t = t + 0.001D0 * shear_integral_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) 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 = shear_integral_interval, & & midspectrum_value = shear_integral_midvalue, & & low_is_blue = shear_integral_lowblue, group = 1) END DO ! i = 1, numel CALL DEnd_Group ! of colored/shaded triangles CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = shear_integral_interval, & & midspectrum_value =shear_integral_midvalue, & & low_is_blue = shear_integral_lowblue, & & units = stress_integral_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 = shear_integral_interval, & & midspectrum_value =shear_integral_midvalue, & & low_is_blue = shear_integral_lowblue, & & units = stress_integral_units) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on vertical integral of greatest shear stress....DONE.')") ELSE ! shear_integral_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 = shear_integral(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, & & stress_integral_units, minimum, maximum, & & bitmap_color_mode, shear_integral_interval, shear_integral_midvalue, shear_integral_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, stress_integral_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & shear_integral_interval, shear_integral_midvalue, shear_integral_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, stress_integral_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & shear_integral_interval, shear_integral_midvalue, shear_integral_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! shear_integral_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( LR_set_eCreep, LR_set_dCreep, LR_set_cCreep, LR_set_bCreep, LR_set_aCreep, & ! in LIFO order & LR_set_Byerly, LR_set_Biot, LR_set_cFric, LR_set_fFric, & & LR_is_used, LR_is_defined) DEALLOCATE ( shear_integral ) ! in LIFO order DEALLOCATE ( strainrate ) DEALLOCATE ( continuum_LRi ) DEALLOCATE ( nodes ) DEALLOCATE ( eqcm ) DEALLOCATE ( vw ) DEALLOCATE ( node_uvec ) just_began_tau_integral = .TRUE. ! may speed overlay of vectors ! end of 14: vertical integral of greatest shear stress CASE (15) ! log10[vertical integral of viscosity] CALL Add_Title('log10[Vertical Integral of Viscosity]') CALL DGroup_or_Bitmap (latter_mosaic, log_viscosity_integral_method, bitmap_height, bitmap_width) IF (.NOT.got_FEP) CALL Get_FEP 1150 temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file defines the elements?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN (UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( vw(2*numnod) ) ALLOCATE ( eqcm(6,numnod) ) OrbData5 = .FALSE. ! unless non-zero values discovered in columns 5, 6 below... DO i = 1, numnod READ (21, "(A)", IOSTAT = ios) input_record READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters, & & density_anomaly_kgpm3, cooling_curvature_Cpm2 IF (ios /= 0) THEN density_anomaly_kgpm3 = 0.0D0 cooling_curvature_Cpm2 = 0.0D0 READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters END IF problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) eqcm(1,i) = elevation eqcm(2,i) = heatflow eqcm(3,i) = crust_meters eqcm(4,i) = mantle_meters eqcm(5,i) = density_anomaly_kgpm3 eqcm(6,i) = cooling_curvature_Cpm2 OrbData5 = OrbData5 .OR. (density_anomaly_kgpm3 /= 0.0D0) .OR. (cooling_curvature_Cpm2 /= 0.0D0) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numEl problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) ALLOCATE ( strainrate(3, 7, numel) ) ! 3 components; 7 integration points LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *, 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. GO TO 1150 END IF CLOSE (21) CALL Add_Title(feg_file) 1151 temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be used?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL DPress_Enter mt_flashby = .FALSE. GO TO 1151 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) 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) ! integration point equat = SQRT(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 !Get input parameters: !Now that LRn is known: [N.B. It will often be 0] ALLOCATE ( LR_is_defined(0:LRn) ) ALLOCATE ( LR_is_used(0:LRn) ) LR_is_defined = .FALSE. ! whole array, until information is read, below... LR_is_used = .FALSE. ! whole array, until information is read, below... ALLOCATE ( LR_set_fFric(0:LRn) ) ALLOCATE ( LR_set_cFric(0:LRn) ) ALLOCATE ( LR_set_Biot(0:LRn) ) ALLOCATE ( LR_set_Byerly(0:LRn) ) ALLOCATE ( LR_set_aCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_bCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_cCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_dCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_eCreep(0:LRn) ) !Just for ease in debugging, initialize all (currently) undefined array values as zero: LR_set_fFric = 0.0D0 LR_set_cFric = 0.0D0 LR_set_Biot = 0.0D0 LR_set_Byerly = 0.0D0 LR_set_aCreep = 0.0D0 LR_set_bCreep = 0.0D0 LR_set_cCreep = 0.0D0 LR_set_dCreep = 0.0D0 LR_set_eCreep = 0.0D0 !Get input parameters. !N.B. If iconve == 6, rheologic parameters not needed. ! However, we must still read the parameters to discover that iconve == 6 ! 1152 temp_path_in = path_in !CALL File_List( file_type = "i*.in", & ! & suggested_file = parameter_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the input parameters?',parameter_file,parameter_file) parameter_pathfile = TRIM(temp_path_in)//TRIM(parameter_file) CALL Input_to_SHELLS ( 11, parameter_pathfile, names , nPlates, & ! inputs & alphat, conduc, & ! outputs... & d_fFric, d_cFric, d_Biot, d_Byerly, d_aCreep, d_bCreep, d_cCreep, d_dCreep, d_eCreep, & & everyp, & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, radius, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) !Remember the default ("d_") Lithospheric Rheology as LR0, or LR_set_XXXX(0): LR_set_fFric(0) = d_fFric LR_set_cFric(0) = d_cFric LR_set_Biot(0) = d_Biot LR_set_Byerly(0) = d_Byerly LR_set_aCreep(1:2, 0) = d_aCreep(1:2) LR_set_bCreep(1:2, 0) = d_bCreep(1:2) LR_set_cCreep(1:2, 0) = d_cCreep(1:2) LR_set_dCreep(1:2, 0) = d_dCreep(1:2) LR_set_eCreep(0) = d_eCreep LR_is_defined(0) = .TRUE. IF (LRn > 0) THEN CALL Read_Additional_LRs (temp_path_in, 13, LRn, continuum_LRi, fault_LRi, numEl, nFl, & ! input & LR_set_fFric, LR_set_cFric, LR_set_Biot, LR_set_Byerly, & ! modify & LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_dCreep, LR_set_eCreep, & & LR_is_defined, LR_is_used) !N.B. This SUBR will prompt the user to supply the name of the necessary input file. END IF ! LRn > 0 CALL Add_Title(parameter_file) CALL Limits_in_SHELLS (eqcm,nodes,numel,node_uvec, & & okdelv,mp_radius_meters,refstr, & & trhmax, & ! inputs & constr,etamax,fmumax,vismax) ! outputs !find vertical integral of viscosity for each m=1 point: ALLOCATE ( log_viscosity_integral(numel) ) DO i = 1, numel n1 = nodes(1,i) n2 = nodes(2,i) n3 = nodes(3,i) m = 1 ! only do the center integration point of each element sighbi = 0.0D0 ! simply punting on this; too much trouble to recompute! e11 = strainrate(1,m,i) e12 = strainrate(2,m,i) ! (see subprogram E_rate) e22 = strainrate(3,m,i) CALL DPrincipal_Axes_22 (e11, e12, e22, & & e1, e2, u1x,u1y, u2x,u2y) IF ((e1 == 0.0D0).AND.(e2 == 0.0D0)) THEN log_viscosity_integral(i) = 0.0D0 ! meaning: undefined ELSE t1 = 0.0D0 ! prepare to sum layer contributions to vertical integrals of t2 = 0.0D0 ! principal horizontal stresses (relative to vertical) heatflow = Gauss_point(1,m) * eqcm(2,n1) + Gauss_point(2,m) * eqcm(2,n2) + Gauss_point(3,m) * eqcm(2,n3) crust_meters = Gauss_point(1,m) * eqcm(3,n1) + Gauss_point(2,m) * eqcm(3,n2) + Gauss_point(3,m) * eqcm(3,n3) mantle_meters = Gauss_point(1,m) * eqcm(4,n1) + Gauss_point(2,m) * eqcm(4,n2) + Gauss_point(3,m) * eqcm(4,n3) density_anomaly_kgpm3 = Gauss_point(1,m) * eqcm(5,n1) + Gauss_point(2,m) * eqcm(5,n2) + Gauss_point(3,m) * eqcm(5,n3) !N.B. Following logic does not work, due to strong nonlinearities in geotherm equations interacting with lateral gradients: !cooling_curvature_Cpm2 = Gauss_point(1,m) * eqcm(6,n1) + Gauss_point(2,m) * eqcm(6,n2) + Gauss_point(3,m) * eqcm(6,n3) !Instead, it is necessary to adjust the geotherm to match the asthenosphere temperature (for either OrbData or OrbData5 models): tasthk = tadiab + gradie * 100.D3 !Non-controversial geotherm coefficients: geoth1 = tsurf geoth2 = heatflow / conduc(1) geoth3 = -0.5D0 * radio(1) / conduc(1) geoth4 = 0.0D0 geoth7 = -0.5D0 * radio(2) / conduc(2) geoth8 = 0.0D0 !On first pass, build geotherm WITHOUT any cooling_curvature (as in old Shells): geoth5 = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 + geoth4 * crust_meters**3 dtdzc = geoth2 + 2.0D0 * geoth3 * crust_meters + 3.0D0 * geoth4 * crust_meters**2 dtdzm = dtdzc * conduc(1) / conduc(2) geoth6 = dtdzm !Now, correct geotherm to hit tashtk: IF (mantle_meters > 0.0D0) THEN test = geoth5 + geoth6 * mantle_meters + geoth7 * mantle_meters**2 + geoth8 * mantle_meters**3 ELSE test = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 + geoth4 * crust_meters**3 END IF terr0r = test - tasthk delta_quadratic = -terr0r / (crust_meters + mantle_meters)**2 cooling_curvature_Cpm2 = -2.0D0 * delta_quadratic ! (not actually used here) geoth3 = geoth3 + delta_quadratic geoth7 = geoth7 + delta_quadratic geoth5 = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 + geoth4 * crust_meters**3 dtdzc = geoth2 + 2.0D0 * geoth3 * crust_meters + 3.0D0 * geoth4 * crust_meters**2 dtdzm = dtdzc * conduc(1) / conduc(2) geoth6 = dtdzm IF (crust_meters > 0.0D0) THEN pl0 = 0.0D0 ! same approximation as in VISCOS; pw0 = 0.0D0 ! ocean not important since it affects both equally zoftop = 0.0D0 rho_use = rhobar(1) + density_anomaly_kgpm3 !CALL DIAMND (acreep(1),alphat(1),bcreep(1), & ! beginning of inputs ! & biot,ccreep(1),dcreep(1),ecreep, & ! & e1,e2, & !principal horizontal strain rates ! & cfric,gmean,geoth1,geoth2,geoth3,geoth4, & ! & pl0,pw0,rho_use,rhoh2o,sighbi, & ! & crust_meters,temlim(1),vismax,zoftop, & ! end of inputs ! & pt1de1,pt2de2,pt2de1,pt2de2, & !beginning of outputs ! & pt1,pt2,ztran) !NOTE: ALL arguments in the following CALL must be scalars (not arrays)! CALL Diamnd (LR_set_aCreep(1, continuum_LRi(i)), alphaT(1), LR_set_bCreep(1, continuum_LRi(i)), & ! input & LR_set_Biot(continuum_LRi(i)), LR_set_cCreep(1, continuum_LRi(i)), LR_set_dCreep(1, continuum_LRi(i)), & & LR_set_eCreep(continuum_LRi(i)), & & e1, e2, & !principal horizontal strain rates (just computed above) & LR_set_cFric(continuum_LRi(i)), & & gmean, & ! <= note substitution for "g" in SUBR & geoth1, & & geoth2, & & geoth3, & & geoth4, & & pl0, pw0, & & rho_use, & ! <= note substitution for "rhoBar" in SUBR & rhoH2O, sigHBi, & & crust_meters, & ! <= note substition for "thick" in SUBR & temLim(1), & & visMax, zOfTop, & & pT1dE1, pT1dE2, & ! output & pT2dE1, pT2dE2, & & pT1, pT2, zTran) t1 = t1 + pt1 t2 = t2 + pt2 END IF ! crust_meters > 0 IF (mantle_meters > 0.0D0) THEN zoftop = crust_meters pw0 = rhoh2o * gmean * crust_meters t_mean = geoth1 + & & 0.5D0 * geoth2 * crust_meters + & & 0.333D0 * geoth3 * crust_meters**2 + & & 0.25D0 * geoth4 * crust_meters**3 rho_use = rhobar(1) * (1.0D0 - alphat(1) * t_mean) + density_anomaly_kgpm3 pl0 = rho_use * gmean * crust_meters rho_use = rhobar(2) + density_anomaly_kgpm3 !CALL DIAMND (acreep(2),alphat(2),bcreep(2), & ! beginning of inputs ! & biot,ccreep(2),dcreep(2),ecreep, & ! & e1,e2, & !principal horizontal strain rates ! & cfric,gmean,geoth5,geoth6,geoth7,geoth8, & ! & pl0,pw0,rho_use,rhoh2o,sighbi, & ! & mantle_meters,temlim(2),vismax,zoftop, & ! end of inputs ! & pt1de1,pt1de2,pt2de1,pt2de2, & !beginning of outputs ! & pt1,pt2,ztran) !NOTE: ALL arguments in the following CALL must be scalars (not arrays)! CALL Diamnd (LR_set_aCreep(2, continuum_LRi(i)), alphaT(2), LR_set_bCreep(2, continuum_LRi(i)), & ! input & LR_set_Biot(continuum_LRi(i)), LR_set_cCreep(2, continuum_LRi(i)), LR_set_dCreep(2, continuum_LRi(i)), & & LR_set_eCreep(continuum_LRi(i)), & & e1, e2, & !principal horizontal strain rates (just computed above) & LR_set_cFric(continuum_LRi(i)), & & gmean, & ! <= note substitution for "g" in SUBR & geoth5, & & geoth6, & & geoth7, & & geoth8, & & pl0, pw0, & & rho_use, & ! <= note substitution for "rhoBar" in SUBR & rhoH2O, sigHBi, & & mantle_meters, & ! <= note substition for "thick" in SUBR & temLim(2), & & visMax, zOfTop, & & pT1dE1, pT1dE2, & ! output & pT2dE1, pT2dE2, & & pT1, pT2, zTran) t1 = t1 + pt1 t2 = t2 + pt2 END IF ! mantle_meters > 0 e3 = -(e1 + e2) ! vertical strain rate delta12 = ABS(e1 - e2) delta13 = ABS(e1 - e3) delta23 = ABS(e2 - e3) delta_max = MAX(delta12, delta13, delta23) IF (delta_max == delta12) THEN viscosity_integral = 0.5D0 * ABS(t2 - t1) / ABS(delta12) ELSE IF (delta_max == delta13) THEN viscosity_integral = 0.5D0 * ABS(t1) / ABS(delta13) ELSE ! delta_max == delta23 viscosity_integral = 0.5D0 * ABS(t2) / ABS(delta23) END IF log_viscosity_integral(i) = DLOG10(viscosity_integral) END IF ! e1 OR e2 /= 0.0 END DO ! i = 1, numel WRITE (*,"(/' Here is the distribution of log10[vertical integral of viscosity]:' )") CALL Histogram (log_viscosity_integral, numel, .TRUE., maximum, minimum) IF (log_viscosity_integral_method == 1) THEN ! group of colored/shaded polygons IF (log_viscosity_integral_interval == 0.0D0) THEN log_viscosity_integral_interval = 1.0D0 END IF IF (log_viscosity_integral_midvalue == 0.0D0) THEN log_viscosity_integral_midvalue = (maximum + minimum) / 2.0D0 END IF 1153 CALL DPrompt_for_Real('What contour interval do you wish?',log_viscosity_integral_interval,log_viscosity_integral_interval) IF (log_viscosity_integral_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") log_viscosity_integral_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1153 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',log_viscosity_integral_midvalue,log_viscosity_integral_midvalue) IF (ai_using_color) THEN CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?',log_viscosity_integral_lowblue,log_viscosity_integral_lowblue) ELSE CALL DPrompt_for_Logical('Should low values be shaded darkly (versus lightly)?',log_viscosity_integral_lowblue,log_viscosity_integral_lowblue) END IF WRITE (*,"(/' Working on log10[vertical integral of viscosity]....')") 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 = log_viscosity_integral(i) IF (MOD(t, log_viscosity_integral_interval) == 0.0D0) THEN ! Color is undefined for t = n * log_viscosity_integral_interval, ! so nudge the value toward zero: IF (t > 0.0D0) THEN t = t - 0.001D0 * log_viscosity_integral_interval ELSE ! t < 0.0 t = t + 0.001D0 * log_viscosity_integral_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) IF (t /= 0.0) 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 = log_viscosity_integral_interval, & & midspectrum_value = log_viscosity_integral_midvalue, & & low_is_blue = log_viscosity_integral_lowblue, group = 1) END DO ! i = 1, numel CALL DEnd_Group ! of colored/shaded triangles CALL Chooser(bottom, right) IF (bottom) THEN CALL DBar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = log_viscosity_integral_interval, & & midspectrum_value =log_viscosity_integral_midvalue, & & low_is_blue = log_viscosity_integral_lowblue, & & 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 = log_viscosity_integral_interval, & & midspectrum_value =log_viscosity_integral_midvalue, & & low_is_blue = log_viscosity_integral_lowblue, & & units = ' ') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on log10[vertical integral of viscosity]....DONE.')") ELSE ! log_viscosity_integral_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 = log_viscosity_integral(iele) !--------------------------------------------- !Special kludge for log_viscosity_integral (only): !Do not count a zero value as a success. !Zero values come from elements with strain-rates !of exactly zero (due to boundary conditions in corners) !and their viscosity integrals are undefined. IF (t > 0.0D0) THEN 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 !--------------------------------------------- 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, log_viscosity_integral_interval, log_viscosity_integral_midvalue, log_viscosity_integral_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, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_viscosity_integral_interval, log_viscosity_integral_midvalue, log_viscosity_integral_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_viscosity_integral_interval, log_viscosity_integral_midvalue, log_viscosity_integral_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! log_viscosity_integral_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( log_viscosity_integral ) ! in LIFO order DEALLOCATE ( strainrate ) DEALLOCATE ( LR_set_eCreep, LR_set_dCreep, LR_set_cCreep, LR_set_bCreep, LR_set_aCreep, & ! in LIFO order & LR_set_Byerly, LR_set_Biot, LR_set_cFric, LR_set_fFric, & & LR_is_used, LR_is_defined) DEALLOCATE ( continuum_LRi ) DEALLOCATE ( nodes ) DEALLOCATE ( eqcm ) DEALLOCATE ( vw ) DEALLOCATE ( node_uvec ) just_began_tau_integral = .TRUE. ! may speed overlay of vectors ! end of 14: log10[vertical integral of viscosity] CASE (16) ! smoothed-seismic-strainrate map produced by OrbScore CALL DGroup_or_Bitmap (latter_mosaic, log_strainrate_method, bitmap_height, bitmap_width) IF (.NOT.got_FEP) CALL Get_FEP 1160 temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = OrbScore_feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file PRODUCED BY OrbScore should be plotted?',OrbScore_feg_file,OrbScore_feg_file) OrbScore_feg_pathfile = TRIM(temp_path_in)//TRIM(OrbScore_feg_file) CALL Add_Title('Log10[Strain-rate, in /s]') !open .feg to record nodal strainrates (and element definitions) OPEN (UNIT = 21, FILE = OrbScore_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 READ (21, *, IOSTAT = ios) j, lon, lat, t problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) IF (t > 0.0D0) THEN node_scalar(i) = DLOG10(t) ELSE node_scalar(i) = 0.0D0 END IF END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numEl problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *, 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. GO TO 1160 END IF CLOSE (21) CALL Add_Title(OrbScore_feg_file) WRITE (*,"(/' Here is the distribution of Log10[Strain-rate, in /s]:' )") CALL Histogram (node_scalar, numnod, .TRUE., maximum, minimum) IF (log_strainrate_method == 1) THEN ! group of colored/shaded polygons IF (log_strainrate_interval == 0.0D0) THEN log_strainrate_interval = 1.0D0 END IF IF (log_strainrate_midvalue == 0.0D0) THEN log_strainrate_midvalue = (maximum + minimum) / 2.0D0 END IF 1162 CALL DPrompt_for_Real('What contour interval do you wish?',log_strainrate_interval,log_strainrate_interval) IF (log_strainrate_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") log_strainrate_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1162 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?',log_strainrate_midvalue,log_strainrate_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 log10[strain-rate, in /s]....')") 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)) f1 = node_scalar(nodes(1,i)) f2 = node_scalar(nodes(2,i)) f3 = node_scalar(nodes(3,i)) IF ((f1 /= 0.0D0).AND.(f2 /= 0.0D0).AND.(f3 /= 0.0D0)) THEN CALL DContour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = f1, f2 = f2, f3 = f3, & & low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, group = group) END IF ! all 3 corner values are valid 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 = log_strainrate_interval, & & midspectrum_value =log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DBar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value =log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on log10[strain-rate, in /s]....DONE.')") ELSE ! log_strainrate_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 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, log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! log_strainrate_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( node_scalar, & ! in LIFO order & node_uvec, & & continuum_LRi, & & nodes) ! end of 16: smoothed-seismic-strainrate map produced by OrbScore END SELECT ! (choice) = mosaic type 1999 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:')") WRITE (*,"( ' 1 :: digitised basemap (lines type)')") WRITE (*,"( ' 2 :: outline of finite-element grid')") WRITE (*,"( ' 3 :: fault elements (only)')") WRITE (*,"( ' 4 :: finite-element grid (including fault elements)')") WRITE (*,"( ' 5 :: deep velocity vectors, below the model')") WRITE (*,"( ' 6 :: shear traction vectors on the base of the model')") WRITE (*,"( ' 7 :: surface velocity vectors')") WRITE (*,"( ' 8 :: geodetic benchmarks with velocities')") WRITE (*,"( ' 9 :: fault elements with change in horizontal velocity')") WRITE (*,"( ' 10 :: fault elements with slip rate')") WRITE (*,"( ' 11 :: strain-rates of continuum elements (between any faults)')") WRITE (*,"( ' 12 :: vertical integral of stress anomaly tensors')") WRITE (*,"( ' 13 :: most-compressive principal stress direction in F-E model')") WRITE (*,"( ' 14 :: stress direction data')") WRITE (*,"( ' 15 :: external forces on nodes (large on forced boundaries)')") WRITE (*,"( ' 16 :: earthquake epicenters, from EarthQuake Catalog .eqc file')") WRITE (*,"( ' 17 :: volcanoes (Recent, subaerial) from file volcanoes.dat')") WRITE (*,"( ' 18 :: velocity vectors from plate model')") WRITE (*,"( ' 19 :: Euler poles from plate model')") WRITE (*,"( ' 20 :: boundary heave rates from plate model')") IF (ai_using_color) THEN WRITE (*,"( ' 21 :: boundary lines of plate model, in 7 colors')") ELSE WRITE (*,"( ' 21 :: boundary lines of plate model')") END IF WRITE (*,"( ' 22 :: balance of plate-driving/resisting forces on each plate')") WRITE (*,"( ' 23 :: seafloor-spreading rates')") WRITE (*,"( ' 24 :: SKS-splitting fast azimuths (phi) & delay times')") WRITE (*,"( ' 25 :: slip-rate input dataset for Tuned_SHELLS')") WRITE (*,"( ' 26 :: effective fault friction from Tuned_SHELLS')") WRITE (*,"( ' 27 :: Lithospheric Rheology #s (LR#s) of faults')") 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_deep_flow) choice = 5 ! suggestion to save time IF (just_began_traction) choice = 6 ! suggestion to save time IF (just_began_surface_flow) choice = 7 ! suggestion to save time IF (just_began_strainrate) choice = 11 ! suggestion to save time IF (just_began_tau_integral) choice = 12 ! suggestion to save time CALL DPrompt_for_Integer('Which overlay type should be added?',choice,choice) IF ((choice < 1).OR.(choice > 27)) 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 FiniteMap 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') DO i = 1, 3 READ (21, *, IOSTAT = ios) lon, lat IF (ios /= 0) THEN ! got possible title BACKSPACE (21) READ (21,"(A)") line CALL Add_Title(line) END IF END DO CLOSE (21) CALL BEEPQQ (frequency = 440, duration = 250) ! end of basemap overlay CASE (2:4, 27) ! "choice"s related to finite-element grid: outline (2), faults (3), all(4), LR#s of faults(27) 2020 IF (.NOT.got_FEP) CALL Get_FEP 2030 temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) 2040 CALL DPrompt_for_String('Which file should be plotted?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 2030 END IF IF (choice == 27) THEN CALL Add_Title('Lithospheric Rheology (LR) index #s of faults') ELSE ! choice == 2:4 CALL Add_Title('Finite Element Grid') 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) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before READs DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21,*) nFl ALLOCATE ( nodeF(4, nFl) ) ALLOCATE ( fDip(2, nFl) ) ALLOCATE ( fault_LRi(nFl) ) DO i = 1, nFl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output fault_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodeF(1,i), nodeF(2,i), nodeF(3,i), nodeF(4,i), fDip(1,i), fDip(2,i) END DO ! i = 1, nFl CLOSE(21) IF (choice == 2) THEN ! plot outline only WRITE (*,"(/' Working on outline of grid....')") ! Build library of external edge segments (unsorted) nseg = 0 DO i = 1, numel ! first, look for external edges of spherical triangles DO j = 1, 3 jp = 1 + MOD(j,3) na = nodes(j,i) nb = nodes(jp,i) mated = .FALSE. might_mate_1: DO k = 1, numel ! mating to another spherical triangle? DO l = 1, 3 lp = 1 + MOD(l,3) ma = nodes(l,k) mb = nodes(lp,k) IF ((na == mb).AND.(nb == ma)) THEN mated = .TRUE. EXIT might_mate_1 END IF ! mate was found END DO ! l = 1, 3 sides of trial spherical triangle END DO might_mate_1 ! k = 1, numel might_mate_2: DO k = 1, nfl ! mating to a fault element DO l = 1, 3, 2 ! 2 sides lp = l + 1 ma = nodef(l,k) mb = nodef(lp,k) IF ((na == mb).AND.(nb == ma)) THEN mated = .TRUE. EXIT might_mate_2 END IF ! mate was found END DO ! l = 1, 3, 2 ! two sides of trial fault END DO might_mate_2 ! k = 1, nfl 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 DO i = 1, nfl ! first, look for external edges of 4-node faults DO j = 1, 3, 2 ! two sides of fault jp = j + 1 na = nodef(j,i) nb = nodef(jp,i) mated = .FALSE. might_mate_3: DO k = 1, numel ! mating to a 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_3 END IF ! mate was found END DO ! l = 1, 3 sides of trial spherical triangle END DO might_mate_3 ! 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, 2 (two sides of fault) END DO ! i = 1, nfl; looking for external edges of 4-node faults IF (nseg > 0) THEN ! found some segments !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) DO i = 1, nseg uvec2(1:3) = segments(1:3,2,j) CALL DGreat_to_L45 (uvec2) find_next: DO k = 2, nseg IF (uvec2(1) == segments(1,1,k)) THEN IF (uvec2(2) == segments(2,1,k)) THEN IF (uvec2(3) == segments(3,1,k)) THEN j = k EXIT find_next END IF END IF END IF END DO find_next !prepare to loop uvec1 = uvec2 END DO ! i = 1, nseg CALL DEnd_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) WRITE (*,"('+Working on outline of grid....DONE.')") ELSE ! no boundary segments found WRITE (*, *) WRITE (*, "(' NOTICE: No perimeter was found. Perhaps this is a global grid?')") CALL Pause() END IF ELSE IF (choice <= 4) THEN ! 3 or 4; plot (at least some) elements and nodes, with numbers (in separate groups) IF (choice == 4) CALL DPrompt_for_Real('Desired radius of node circles, in points (or 0 for none)?',node_radius_points,node_radius_points) IF (nFl > 0) CALL DPrompt_for_Real('How large are the dip ticks (in points)?',tick_points,tick_points) WRITE (*,"(/' Working on finite-element grid....')") IF ((choice == 4).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 == 4) 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 ! Decide sense of offset number !(in such a way as to separate multiple nodes on faults) uvec1(1:3) = node_uvec(1:3,i) n_in_sum = 0 ! prepare to sum the centers of connected elements uvec3(1:3) = 0.0D0 DO j = 1, numel IF ((nodes(1,j) == i).OR.(nodes(2,j) == i).OR.(nodes(3,j) == i)) THEN uvec2(1:3) = (node_uvec(1:3, nodes(1,j)) + & & node_uvec(1:3, nodes(2,j)) + & & node_uvec(1:3, nodes(3,j))) / 3.0D0 !uvec2 is the centroid of the element n_in_sum = n_in_sum + 1 uvec3(1:3) = uvec3(1:3) + uvec2(1:3) END IF ! node i is in this element END DO ! j = 1, numel WRITE (c6,"(I6)") i c6 = ADJUSTL(c6) IF ((n_in_sum == 0).OR.(n_in_sum >= 5)) THEN ! isolated node or honeycomb node; plot number to right 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)) ELSE ! offset direction is available CALL DMake_Uvec(uvec3, uvec2) argument = Pi_over_2 - DRelative_Compass(uvec1, uvec2) IF (DCOS(argument) > 0.0D0) THEN ! number is right-side-up CALL DL5_Text (uvec = uvec1, angle_radians = argument, from_east = .TRUE., & & font_points = 8, lr_fraction = -0.2D0, ud_fraction = 0.4D0, & & text = TRIM(c6)) ELSE ! number must be flipped or it will be inverted argument = argument + Pi CALL DL5_Text (uvec = uvec1, angle_radians = argument, from_east = .TRUE., & & font_points = 8, lr_fraction = 1.2D0, ud_fraction = 0.4D0, & & text = TRIM(c6)) END IF ! number is right-side-up or not END IF ! offset direction available or not END DO ! i = 1, numnod CALL DEnd_Group ! of node numbers END IF ! node numbers are wanted IF ((choice == 4).AND.(numEl > 0)) THEN ! plot triangular continuum elements, and then linear fault elements CALL DBegin_Group ! of triangular continuum elements CALL DSet_Line_Style (width_points = 1.0D0, dashed = .TRUE., & & on_points = 6.0D0, off_points = 3.0D0) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('gray______') END IF DO i = 1, numel DO j = 1, 3 ! loop on 3 sides jp1 = MOD(j,3) + 1 virgin = .TRUE. ! until proven otherwise IF (i > 1) THEN edges_done: DO m = 1, i-1 DO n = 1, 3 np1 = MOD(n,3) + 1 IF (nodes(n,m) == nodes(jp1,i)) THEN IF (nodes(np1,m) == nodes(j,i)) THEN virgin = .FALSE. EXIT edges_done END IF ! both ends match! END IF ! one end matches END DO ! n = 1, 3 END DO edges_done ! m = 1, i-1 END IF ! there are lower-numbered elements IF (virgin) THEN ! only plot each line once, because of dashing! uvec1(1:3) = node_uvec(1:3,nodes(j,i)) CALL DNew_L45_Path (5, uvec1) uvec2(1:3) = node_uvec(1:3,nodes(jp1,i)) CALL DGreat_To_L45 (uvec2) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! virgin END DO ! j = 1, 3 END DO ! i = 1, numel CALL DEnd_Group ! of elements 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.0D0 CALL DMake_Uvec(uvec2, uvec1) WRITE (c6,"(I6)") i c6 = ADJUSTL(c6) CALL DL5_Text (uvec = uvec1, angle_radians = 0.0D0, from_east = .FALSE., & & font_points = 8, lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = TRIM(c6)) END DO ! i = 1, numel CALL DEnd_Group ! of element numbers END IF ! elements should be plotted IF (nFl > 0) THEN ! plot faults CALL Plot_Fault_Ticks (colored = ai_using_color) CALL Plot_Fault_Traces (colored = ai_using_color) !Each chooses color, etc. and defines a group; !all information is from global variables. CALL DBegin_Group ! of fault element numbers IF (ai_using_color) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') END IF DO i = 1, nfl ! all fault element numbers WRITE (c6,"(I6)") i c6 = ADJUSTL(c6) uvec2(1:3) = (node_uvec(1:3, nodef(1,i)) + node_uvec(1:3, nodef(2,i))) / 2.0D0 CALL DMake_Uvec(uvec2, uvec1) uvec2(1:3) = node_uvec(1:3, nodef(2,i)) argument = Pi_over_2 - DRelative_Compass(uvec1, uvec2) CALL DL5_Text (uvec = uvec1, angle_radians = argument, from_east = .TRUE., & & font_points = 8, lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(c6)) END DO ! i = 1, nfl; fault element numbers CALL DEnd_Group ! of fault element numbers END IF ! nfl > 0; plot faults WRITE (*,"('+Working on finite-element grid....DONE.')") ELSE IF (choice == 27) THEN ! plot LR #s with colored fault traces IF (nFl > 0) THEN ! plot faults using trace colors based on LR #s highestLRi = 0 ! just initializing, before survey... DO i = 1, numEl highestLRi = MAX(highestLRi, continuum_LRi(i)) END DO DO i = 1, nFl highestLRi = MAX(highestLRi, fault_LRi(i)) END DO minimum = 0 ! REAL*8 = INTEGER maximum = highestLRi ! REAL*8 = INTEGER bitmap_color_lowvalue = -maximum / 6.0D0 ! to get blue on L end of color bar (not purple) bitmap_color_highvalue = maximum fault_LRi_interval = (maximum - minimum)/(ai_spectrum_count - 2) fault_LRi_midvalue = (maximum + minimum)/2.0D0 fault_LRi_lowblue = .TRUE. shaded_relief = .FALSE. fault_LRi_units = ' ' CALL Plot_Fault_Ticks (colored = ai_using_color, using_LRi_color = .TRUE., highestLRi = highestLRi) CALL Plot_Fault_Traces (colored = ai_using_color, using_LRi_color = .TRUE., highestLRi = highestLRi) !Each chooses color, etc. and defines a group; !all information is from global variables. CALL DBegin_Group ! of fault LR numbers (as text) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') DO i = 1, nFl ! all fault LR numbers WRITE (c8, "(I8)") fault_LRi(i) c6 = ADJUSTL(c6) uvec2(1:3) = (node_uvec(1:3, nodef(1,i)) + node_uvec(1:3, nodef(2,i))) / 2.0D0 CALL DMake_Uvec(uvec2, uvec1) uvec2(1:3) = node_uvec(1:3, nodef(2,i)) argument = Pi_over_2 - DRelative_Compass(uvec1, uvec2) CALL DL5_Text (uvec = uvec1, angle_radians = argument, from_east = .TRUE., & & font_points = 8, lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(c8)) END DO ! i = 1, nFl; fault LR numbers CALL DEnd_Group ! of fault LR numbers END IF ! nFl > 0; plot fault LR numbers CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, fault_LRi_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & fault_LRi_interval, fault_LRi_midvalue, fault_LRi_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, fault_LRi_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & fault_LRi_interval, fault_LRi_midvalue, fault_LRi_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! choice = 2 (outline), or 3:4 (elements), or 27 (LR #s of faults) DEALLOCATE ( node_uvec, segments ) ! in LIFO order DEALLOCATE ( continuum_LRi ) DEALLOCATE ( nodes ) DEALLOCATE ( fault_LRi ) DEALLOCATE ( fDip ) DEALLOCATE ( nodeF ) CALL BEEPQQ (frequency = 440, duration = 250) ! end of finite element grid: outline(2), faults(3), all(4), or LR #s of faults(27) CASE (5) ! deep velocity vectors CALL Add_Title ('Velocity Field Imposed Below the Model') IF (.NOT.got_FEP) CALL Get_FEP 2050 IF (.NOT.just_began_deep_flow) THEN 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 finite-element grid should deep flow be projected onto?',feg_file,feg_file) 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_deep_flow = .FALSE. mt_flashby = .FALSE. GO TO 2050 END IF READ (21,*) ! title READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( xnode(numnod) ) !theta, in radians ALLOCATE ( ynode(numnod) ) !phi, in radians ALLOCATE (checkN(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) CALL DLonLat_2_ThetaPhi (lon, lat, theta, phi) xnode(i) = theta ynode(i) = phi END DO ! i = 1, numnod READ (21,*) numEl ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21,*) nFl ALLOCATE ( nodeF(4, nFl) ) ALLOCATE ( fault_LRi(nFl) ) DO i = 1, nFl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output fault_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodeF(1,i), nodeF(2,i), nodeF(3,i), nodeF(4,i) END DO ! i = 1, nFl CLOSE(21) !Get input parameters: 2051 IF (.NOT.just_began_deep_flow) THEN temp_path_in = path_in !CALL File_List( file_type = "i*.in", & ! & suggested_file = parameter_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the input parameters?',parameter_file,parameter_file) parameter_pathfile = TRIM(temp_path_in)//TRIM(parameter_file) CALL Input_to_SHELLS ( 11, parameter_pathfile, names , nPlates, & ! inputs & alphat, conduc, & ! outputs... & d_fFric, d_cFric, d_Biot, d_Byerly, d_aCreep, d_bCreep, d_cCreep, d_dCreep, d_eCreep, & & everyp, & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, radius, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) IF (iconve == 0) THEN line = 'Static Lower Mantle (w.r.t. AF), seen from ' // names(ipvref) // ' reference frame' CALL Add_Title(line) ELSE IF (iconve == 1) THEN IF (vtimes == 1.0D0) THEN line = "Hager & O'Connell (1979), seen from " // names(ipvref) // ' reference frame' ELSE WRITE (c5,"(F5.2)") vtimes line = "Hager & O'Connell (1979) x" // c5 // ', seen from ' // names(ipvref) // ' reference frame' END IF CALL Add_Title(line) ELSE IF (iconve == 2) THEN IF (vtimes == 1.0D0) THEN line = 'Baumgardner (1988) Fig. 7, seen from ' // names(ipvref) // ' reference frame' ELSE WRITE (c5,"(F5.2)") vtimes line = 'Baumgardner (1988) Fig. 7 x' // c5 // ', seen from ' // names(ipvref) // ' reference frame' END IF CALL Add_Title(line) ELSE IF ((iconve == 3).OR.(iconve == 4)) THEN IF (vtimes == 1.0D0) THEN line = 'PB2002 (Bird, 2003), seen from ' // names(ipvref) // ' reference frame' ELSE WRITE (c5,"(F5.2)") vtimes line = 'PB2002 x' // c5 // ', seen from ' // names(ipvref) // ' reference frame' END IF CALL Add_Title(line) ELSE IF (iconve == 5) THEN WRITE (*, "(/' Sorry; this overlay is not programmed yet!')") CALL Pause() GO TO 2999 ELSE IF (iconve == 6) THEN WRITE (*, "(/' Sorry; impossible. When ICONVE == 6, lower mantle flow is not defined.')") CALL Pause() GO TO 2999 END IF CALL Add_Title(parameter_file) CALL Add_Title(title3) END IF ! .NOT. just_began_deep_flow IF (.NOT.ALLOCATED (vm) ) THEN !Call CONVEC(iconve), which may require arrays (or do its own I/O!): IF ((iconve >= 3).AND.(iconve <= 4)) THEN temp_path_in = path_in !CALL File_List( file_type = "*.dig", & ! & suggested_file = plates_dig_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the plate outlines?',plates_dig_file,plates_dig_file) ALLOCATE ( ndplat(nPlates) ) ! Integer; plate-boundary path lengths ALLOCATE ( plat(nPlates, mostInOnePlate) ) ! latitudes of plate-boundary paths ALLOCATE ( plon(nPlates, mostInOnePlate) ) ! longitudes of plate-boundary paths CALL GETNUV (temp_path_in,plates_dig_file,21,6,names,mostInOnePlate,nPlates, & ! inputs & ndplat,plat,plon) ! outputs END IF ALLOCATE ( vm(2,numnod) ) CALL CONVEC (iconve, ipAfri, ipvref, 21, 6, & & names, ndplat, & & nfl, nodef, nodes, & & mostInOnePlate, nPlates, numel, numnod, & & omega, path_in, plat, plon, mp_radius_meters, vtimes, & & xnode, ynode, & ! inputs & vm ) ! output array END IF ! need to allocate and fill array vm ALLOCATE ( vsize_mma(numnod) ) DO i = 1, numnod v_South_mps = vm(1,i) v_East_mps = vm(2,i) vsize_mma(i) = 1000.0D0 * sec_per_year * DSQRT(v_South_mps**2 + v_East_mps**2) END DO ! i = 1, numnod WRITE (*,"(/' Here is the distribution of deep 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 2052 CALL DPrompt_for_Integer('What thinning factor ( >=1 ) do you want?',vector_thinner,vector_thinner) IF (vector_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") mt_flashby = .FALSE. GO TO 2052 END IF IF (vector_thinner > 1) THEN WRITE(string10,"(I10)") vector_thinner CALL Add_Title('(1/'//TRIM(ADJUSTL(string10))//') of Deep Velocity Vectors, Below the Model') ELSE ! == 1 CALL Add_Title('Deep Velocity Vectors, Below the Model') END IF ALLOCATE ( selected(numnod) ) CALL DThin_on_Sphere (node_uvec, numnod, vector_thinner, selected) WRITE (*,"(/' Working on deep 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 = vm(1, i) v_East_mps = vm(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.0D6 * sec_per_year, deflate = .TRUE.) END IF ! selected END DO ! actually plotting deep velocity vectors CALL DEnd_Group DEALLOCATE ( selected ) CALL Velocity_Explanation() ! common code; uses velocity_Ma WRITE (*,"('+Working on deep velocity vectors....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( vsize_mma, & & vm )! in LIFO order IF (ALLOCATED(ndplat)) DEALLOCATE ( plon, plat, ndplat ) ! LIFO order DEALLOCATE ( fault_LRi, & ! in LIFO order & nodeF, & & continuum_LRi, & & nodes, & & checkN, & & ynode, & & xnode, & & node_uvec ) ! end of 5: deep velocity vectors CASE (6) ! shear traction vectors on base of model CALL Add_Title ('Shear Traction on Base of Model') IF (.NOT.got_FEP) CALL Get_FEP 2060 IF (.NOT.just_began_traction) THEN 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 finite-element grid should traction be computed on?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) END IF ! .NOT.just_began_traction 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_traction = .FALSE. mt_flashby = .FALSE. GO TO 2060 END IF READ (21,*) ! title READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( xnode(numnod) ) !theta, in radians ALLOCATE ( ynode(numnod) ) !phi, in radians ALLOCATE ( checkN(numnod) ) ALLOCATE ( eqcm(6, numnod) ) IF (.NOT.ALLOCATED(whichp)) ALLOCATE ( whichp(numnod) ) ! N.B. Since this is slow to compute, I leave it allocated at the end of the mosaic code! OrbData5 = .FALSE. ! unless non-zero values discovered in columns 5, 6 below... DO i = 1, numnod READ (21, "(A)", IOSTAT = ios) input_record READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters, & & density_anomaly_kgpm3, cooling_curvature_Cpm2 IF (ios /= 0) THEN density_anomaly_kgpm3 = 0.0D0 cooling_curvature_Cpm2 = 0.0D0 READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters END IF CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) CALL DLonLat_2_ThetaPhi (lon, lat, theta, phi) xnode(i) = theta ynode(i) = phi eqcm(1,i) = elevation eqcm(2,i) = heatflow eqcm(3,i) = crust_meters eqcm(4,i) = mantle_meters eqcm(5,i) = density_anomaly_kgpm3 eqcm(6,i) = cooling_curvature_Cpm2 OrbData5 = OrbData5 .OR. (density_anomaly_kgpm3 /= 0.0D0) .OR. (cooling_curvature_Cpm2 /= 0.0D0) END DO ! i = 1, numnod READ (21,*) numEl ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21,*) nFl ALLOCATE ( nodeF(4, nFl) ) ALLOCATE ( fault_LRi(nFl) ) DO i = 1, nFl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output fault_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodeF(1,i), nodeF(2,i), nodeF(3,i), nodeF(4,i) END DO ! i = 1, nFl CLOSE(21) !Now that LRn is known: [N.B. It will often be 0] ALLOCATE ( LR_is_defined(0:LRn) ) ALLOCATE ( LR_is_used(0:LRn) ) LR_is_defined = .FALSE. ! whole array, until information is read, below... LR_is_used = .FALSE. ! whole array, until information is read, below... ALLOCATE ( LR_set_fFric(0:LRn) ) ALLOCATE ( LR_set_cFric(0:LRn) ) ALLOCATE ( LR_set_Biot(0:LRn) ) ALLOCATE ( LR_set_Byerly(0:LRn) ) ALLOCATE ( LR_set_aCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_bCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_cCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_dCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_eCreep(0:LRn) ) !Just for ease in debugging, initialize all (currently) undefined array values as zero: LR_set_fFric = 0.0D0 LR_set_cFric = 0.0D0 LR_set_Biot = 0.0D0 LR_set_Byerly = 0.0D0 LR_set_aCreep = 0.0D0 LR_set_bCreep = 0.0D0 LR_set_cCreep = 0.0D0 LR_set_dCreep = 0.0D0 LR_set_eCreep = 0.0D0 !Get input parameters: 2061 IF (.NOT.just_began_traction) THEN temp_path_in = path_in !CALL File_List( file_type = "i*.in", & ! & suggested_file = parameter_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the input parameters?',parameter_file,parameter_file) parameter_pathfile = TRIM(temp_path_in)//TRIM(parameter_file) END IF ! .NOT.just_began_traction CALL Input_to_SHELLS ( 11, parameter_pathfile, names , nPlates, & ! inputs & alphat, conduc, & ! outputs... & d_fFric, d_cFric, d_Biot, d_Byerly, d_aCreep, d_bCreep, d_cCreep, d_dCreep, d_eCreep, & & everyp, & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, radius, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) !Remember the default ("d_") Lithospheric Rheology as LR0, or LR_set_XXXX(0): LR_set_fFric(0) = d_fFric LR_set_cFric(0) = d_cFric LR_set_Biot(0) = d_Biot LR_set_Byerly(0) = d_Byerly LR_set_aCreep(1:2, 0) = d_aCreep(1:2) LR_set_bCreep(1:2, 0) = d_bCreep(1:2) LR_set_cCreep(1:2, 0) = d_cCreep(1:2) LR_set_dCreep(1:2, 0) = d_dCreep(1:2) LR_set_eCreep(0) = d_eCreep LR_is_defined(0) = .TRUE. IF (LRn > 0) THEN CALL Read_Additional_LRs (temp_path_in, 13, LRn, continuum_LRi, fault_LRi, numEl, nFl, & ! input & LR_set_fFric, LR_set_cFric, LR_set_Biot, LR_set_Byerly, & ! modify & LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_dCreep, LR_set_eCreep, & & LR_is_defined, LR_is_used) !N.B. This SUBR will prompt the user to supply the name of the necessary input file. END IF ! LRn > 0 IF (iconve == 0) THEN line = 'due to static lower mantle (w.r.t. AF)' CALL Add_Title(line) ELSE IF (iconve == 1) THEN IF (vtimes == 1.0D0) THEN line = "due to Hager & O'Connell (1979) lower mantle flow" ELSE WRITE (c5,"(F5.2)") vtimes line = "due to Hager & O'Connell (1979) lower mantle flow x" // c5 END IF CALL Add_Title(line) ELSE IF (iconve == 2) THEN IF (vtimes == 1.0D0) THEN line = 'due to Baumgardner (1988) Fig. 7 flow' ELSE WRITE (c5,"(F5.2)") vtimes line = 'due to Baumgardner (1988) Fig. 7 flow x' // c5 END IF CALL Add_Title(line) ELSE IF (iconve == 3) THEN IF (vtimes == 1.0D0) THEN line = 'due to PB2002 (Bird, 2003) flow' ELSE WRITE (c5,"(F5.2)") vtimes line = 'due to PB2002 flow x' // c5 END IF CALL Add_Title(line) ELSE IF (iconve == 4) THEN IF (vtimes == 1.0D0) THEN line = 'due to PB2002 (Bird, 2003) flow dragging continents only' ELSE WRITE (c5,"(F5.2)") vtimes line = 'due to PB2002 flow x' // c5 // ' dragging continents only' END IF CALL Add_Title(line) ELSE IF (iconve == 5) THEN ! drag on base of subduction forearc only WRITE (*,"(/' Sorry. The display for ICONVE == 5 is not programmed yet.')") CALL Pause() GO TO 2999 ELSE IF (iconve == 6) THEN ! shear traction on slabless plates from PREVIOUS traction report: IF (.NOT.just_began_traction) THEN 2062 WRITE (*,"( & &/' ICONVE==6 implies basal shear tractions on slabless plates were computed' & &/' from a torque report file created in a PREVIOUS run of SHELLS.' & &/' It is necessary to access that PREVIOUS torque report to prepare this plot!'\)") temp_path_in = path_in !CALL File_List( file_type = "q*.out", & ! & suggested_file = torque_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file reported the plate-driving torques?',torque_file,torque_file) torque_pathfile = TRIM(temp_path_in)//TRIM(torque_file) OPEN(UNIT = 21, FILE = torque_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL Pause() GO TO 2062 END IF DO i = 1, 5 READ (21, "(A)") line IF (i <= 3) CALL Add_Title(line) END DO ! first 5 lines (titles1~3 & 2 blanks) of torque file READ (21, "(46X,A)") line(1:38) ! " (FFRIC 0.150, TAUMAX 2.5E+12\2.5E+12)" line = "Inferred basal-strength tractions" // TRIM(line) CALL Add_Title(line) CLOSE (21) ! for now; will re-open below END IF ! (.NOT.just_began_traction) END IF ! different values of iconve CALL Add_Title(parameter_file) CALL Add_Title(title3) !Now, call CONVEC(iconve), which may require arrays (or do its own I/O!), !to get the deep velocity field at nodes: vm(2,numnod): IF ((iconve == 3).OR.(iconve == 4).OR.(iconve == 6)) THEN ! plate outlines are needed: IF (.NOT.just_began_traction) THEN temp_path_in = path_in !CALL File_List( file_type = "*.dig", & ! & suggested_file = plates_dig_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the plate outlines?',plates_dig_file,plates_dig_file) END IF ALLOCATE ( ndplat(nPlates) ) ! Integer; plate-boundary path lengths ALLOCATE ( plat(nPlates, mostInOnePlate) ) ! latitudes of plate-boundary paths ALLOCATE ( plon(nPlates, mostInOnePlate) ) ! longitudes of plate-boundary paths CALL GETNUV (temp_path_in,plates_dig_file,21,6,names,mostInOnePlate,nPlates, & ! inputs & ndplat,plat,plon) ! outputs IF (iconve == 6) THEN IF (.NOT.just_began_traction) THEN ! assign each node of the .feg to a plate ID# in INTEGER, DIMENSION(numnod) :: whichp WRITE (*,"(/' Assigning every node to a plate (slow)...')") CALL ASSIGN (6, & ! INPUTs & mostInOnePlate, ndplat, nfl, nodef, nodes, & & nPlates, numel, numnod, & & plat, plon, & & xnode, ynode, & & whichp, & ! OUTPUT & checkN) ! WORK WRITE (*,"('+Assigning every node to a plate....DONE ')") CALL BEEPQQ (frequency = 440, duration = 250) END IF END IF END IF ALLOCATE ( traction_MPa(numnod) ) ALLOCATE ( vm(2,numnod) ) ! sic; needed whether iconve <= 5 or iconve == 6 IF (iconve <= 5) THEN ! all cases prior to new (q-report-based) iConve = 6 !compute vm (mantle velocity), then read in vs (surface velocity); compute traction_MPa using existing input parameters; !when shear traction vector is computed, store it in vm. Also store scalar form in traction_MPa vector, for histogram. CALL CONVEC (iconve, ipAfri, ipvref, 21, 6, & & names, ndplat, & & nfl, nodef, nodes, & & mostInOnePlate, nPlates, numel, numnod, & & omega, path_in, plat, plon, mp_radius_meters, vtimes, & & xnode, ynode, & ! inputs & vm ) ! output array = lower mantle velocity vm(2,numnod) !Get surface velocity solution (v____.out): 2063 IF (.NOT.just_began_traction) THEN temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity solution file should be used?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) END IF ! .NOT.just_began_traction 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_traction = .FALSE. mt_flashby = .FALSE. GO TO 2063 END IF DO i = 1, 3 READ (22,"(A)") line CALL Add_Title(line) END DO ! first 3 lines of velocity file ALLOCATE ( vs(2, numnod) ) READ (22,*) ((vs(i,j), i = 1,2), j = 1,numnod) CLOSE(22) !Compute geotherm, glue, and traction at each node: CALL Limits_in_SHELLS (eqcm,nodes,numel,node_uvec, & & okdelv,mp_radius_meters,refstr, & & trhmax, & ! inputs & constr,etamax,fmumax,vismax) ! outputs ALLOCATE ( nodal_vector_numerator(2, numNod) ) nodal_vector_numerator = 0.0D0 ! initializing before sum ALLOCATE ( nodal_vector_denominator(numNod) ) nodal_vector_denominator = 0.0D0 ALLOCATE ( glue(7, numEl) ) !Calculate "glue" (shear stress, at each IP of each continuum element, required to create one unit of relative !horizontal velocity across the lithosphere+asthenosphere mantle layer, down to depth zBAsth). ALLOCATE ( geothC(4, 7, numEl) ) ALLOCATE ( geothM(4, 7, numEl) ) ALLOCATE ( zMoho(7, numEl) ) ALLOCATE ( zMNode(numNod) ) DO i = 1, numNod zMNode(i) = eqcm(3, i) END DO CALL Interp (zMNode, nodes, numEl, numNod, & ! input & zMoho) ! output DEALLOCATE ( zMNode ) ! but, zMoho(7, numEl) remains, for now ... ALLOCATE ( tLNode(numNod) ) DO i = 1, numNod tLNode(i) = eqcm(4, i) END DO ALLOCATE ( tLInt(7, numEl) ) CALL Interp (tLNode, nodes, numEl, numNod, & ! input & tLInt) ! output ALLOCATE ( dQdTdA(numNod) ) DO i = 1, numNod dQdTdA(i) = eqcm(2, i) END DO CALL Compute_geotherms (conduc, dQdTdA, gradie, & & nodes, numEl, numNod, & & radio, tAdiab, tLInt, tSurf, zMoho, & ! input & geothC, geothM) ! output DEALLOCATE ( dQdTdA ) DEALLOCATE ( tLInt ) DEALLOCATE ( tLNode ) CALL OneBar (continuum_LRi, & ! input & geothC, geothM, gradie, & ! input & LRn, LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_eCreep, & ! input & numEl, oneKm, tAdiab, & ! input & zBAsth, zMoho, & ! input & glue) ! output: glue(1:7, 1:numEl) DEALLOCATE ( zMoho ) DEALLOCATE ( geothM ) DEALLOCATE ( geothC ) ! but, glue() remains (for now)... !Compute derivitives of nodal functions at integration points: ALLOCATE ( fPSfer(2, 2, 3, 7, numEl) ) ALLOCATE ( area(numEl) ) ALLOCATE ( detJ(7, numEl) ) ALLOCATE ( dXS(2, 2, 3, 7, numEl) ) ALLOCATE ( dYS(2, 2, 3, 7, numEl) ) ALLOCATE ( dXSP(3, 7, numEl) ) ALLOCATE ( dYSP(3, 7, numEl) ) ALLOCATE ( sita(7, numEl) ) CALL Deriv ( 6, numEl, numNod, nodes, numEl, & ! input & radius, xNode, yNode, & & area, detJ, & ! output & dXS, dYS, dXSP, dYSP, fPSfer, sita) ! (In this context, what we will need is fPSfer. Other arrays to be discarded...) DEALLOCATE ( sita ) ! in LIFO order DEALLOCATE ( dYSP ) DEALLOCATE ( dXSP ) DEALLOCATE ( dYS ) DEALLOCATE ( dXS ) DEALLOCATE ( detJ ) DEALLOCATE ( area ) ! but, fPSfer(,,,,) remains (for now)... !compute surface-velocity and lower-mantle-velocity at integration points of continuum elements: ALLOCATE ( outVecS(2, 7, numEl) ) ALLOCATE ( outVecM(2, 7, numEl) ) !using nodal-vector arrays vs and vm computed above.... CALL Flow (fPSfer, numEl, numNod, nodes, numEl, vs, & ! input & outVecS) ! output CALL Flow (fPSfer, numEl, numNod, nodes, numEl, vm, & ! input & outVecM) ! output DEALLOCATE ( fPSfer ) DO i = 1, numEl vs_IP1(1:2) = outVecS(1:2, 1, i) vm_IP1(1:2) = outVecM(1:2, 1, i) deltaV_IP1(1:2) = vm_IP1(1:2) - vs_IP1(1:2) ! components (theta == S, phi == E). deltaV_IP1_mps = SQRT(deltaV_IP1(1)**2 + deltaV_IP1(2)**2) !compute basal shear traction at integration point #1, subject to 2 upper-limits: traction_IP1_MPa = 1.0D-6 * glue(1, i) * deltaV_IP1_mps**LR_set_eCreep(continuum_LRi(i)) traction_IP1_MPa = MIN(traction_IP1_MPa, (etaMax * deltaV_IP1_mps * 1.0D-6)) traction_IP1_MPa = MIN(traction_IP1_MPa, (trHMax * 1.0D-6)) !divide traction into (theta, phi) = (S, E) components: IF (deltaV_IP1_mps > 0.0D0) THEN traction_IP1_MPa_S = traction_IP1_MPa * deltaV_IP1(1) / deltaV_IP1_mps traction_IP1_MPa_E = traction_IP1_MPa * deltaV_IP1(2) / deltaV_IP1_mps ELSE traction_IP1_MPa_S = 0.0D0 traction_IP1_MPA_E = 0.0D0 END IF !Now, apply this traction vector to the (not-yet-ratioed) numerator & denominator sums for 3 corner nodes: DO j = 1, 3 !define 3 corners of this element (from current-node point-of-view): jp1 = j+1; IF (jp1 > 3) jp1 = jp1 - 3 jp2 = jp1+1; IF (jp2 > 3) jp2 = jp2 - 3 k = nodes(j, i) kp1 = nodes(jp1, i) kp2 = nodes(jp2, i) CALL DThetaPhi_2_Uvec(xnode(k), ynode(k), uvec1) CALL DThetaPhi_2_Uvec(xnode(kp1), ynode(kp1), uvec2) CALL DThetaPhi_2_Uvec(xnode(kp2), ynode(kp2), uvec3) !define angle, at current node, between great-circle arcs going to the other 2 nodes: angle_weight = ABS(DRelative_Compass(uvec1, uvec2) - DRelative_Compass(uvec1, uvec3)) IF (angle_weight > Pi) angle_weight = Two_Pi - angle_weight !increment vector (and scalar) sums at each node nodal_vector_numerator(1, k) = nodal_vector_numerator(1, k) + (traction_IP1_MPa_S * angle_weight) nodal_vector_numerator(2, k) = nodal_vector_numerator(2, k) + (traction_IP1_MPa_E * angle_weight) nodal_vector_denominator(k) = nodal_vector_denominator(k) + angle_weight END DO ! j = 1, 3 (corners) END DO ! i = 1, numEl (all continuum elements)\ DEALLOCATE ( outVecM ) ! in LIFO order DEALLOCATE ( outVecS ) DEALLOCATE ( glue ) DO i = 1, numnod IF (nodal_vector_denominator(i) > 0.0D0) THEN traction_at_node_MPa_S = nodal_vector_numerator(1, i) / nodal_vector_denominator(i) traction_at_node_MPa_E = nodal_vector_numerator(2, i) / nodal_vector_denominator(i) traction_MPa(i) = SQRT(traction_at_node_MPa_S**2 + traction_at_node_MPa_E**2) ELSE traction_at_node_MPa_S = 0.0D0 traction_at_node_MPa_E = 0.0D0 traction_MPa(i) = 0.0D0 END IF IF (iconve == 4) THEN ! no basal shear traction under oceans! elevation = eqcm(1, i) heatflow = eqcm(2, i) continental = (elevation > -2500.0D0).AND.(heatflow < 0.150D0) IF (.NOT.continental) THEN ! no traction under oceans! traction_MPa(i) = 0.0D0 traction_at_node_MPa_S = 0.0D0 traction_at_node_MPa_E = 0.0D0 END IF END IF !redefine vm(2,numnod) as the traction vector (in MPa): vm(1, i) = traction_at_node_MPa_S vm(2, i) = traction_at_node_MPa_E END DO ! i = 1, numnod DEALLOCATE ( nodal_vector_denominator ) DEALLOCATE ( nodal_vector_numerator ) ELSE IF (iconve == 6) THEN !no need to allocate and read vs; !get traction_MPa directly from traction pole vectors in torque report (and existing whichp), and store for histogram. !Also, compute 2-D (theta, phi) vector form of shear traction, and store it in wm [old kludge]. ALLOCATE ( traction_pole_vector(3,nPlates) ) traction_pole_vector = 0.0D0 ! whole array; advisable because some plates may not appear in report. ALLOCATE ( traction_pole_read(nPlates) ) ! logical traction_pole_read = .FALSE. ! whole list (1..nPlates) OPEN(UNIT = 21, FILE = torque_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') ! re-opening; I assume file is there. DO i = 1, 6 READ (21, "(A)") line END DO ! waste first 6 lines (titles1~3 & 2 blanks & header) of torque file. !N.B. Header was already read, up above, to extract header line. traction_poling_2: DO READ (21, *, IOSTAT = ios) ! blank line IF (ios == -1) EXIT traction_poling_2 ! EOF READ (21, "(8X,I6)", IOSTAT = ios) iplate IF (ios == -1) EXIT traction_poling_2 ! EOF DO j = 1, 23 ! waste 23 more lines of each plate report READ (21, *, IOSTAT = ios) IF (ios == -1) EXIT traction_poling_2 ! EOF END DO READ (21, "(56X,ES10.3,2F10.2)") t, lon, lat ! t is magnitude, in Pa, at location 90 deg. from (lon, lat). CALL DLonLat_2_Uvec(lon, lat, uvec) traction_pole_vector(1:3, iplate) = t * uvec(1:3) traction_pole_read(iplate) = .TRUE. DO j = 1, 14 ! waste 14 lines to get past the "=======" at the bottom of each torque report: READ (21, *, IOSTAT = ios) IF (ios == -1) EXIT traction_poling_2 ! EOF END DO END DO traction_poling_2 CLOSE (21) ! third & final CLOSE (or second, if mosaic layer was not plotted) DO i = 1, numnod iplate = whichp(i) ! previously computed above by -ASSIGN- IF (slab_Q(iplate)) THEN !no need for inferred basal-strength traction: traction_MPa(i) = 0.0D0 vm(1, i) = 0.0D0 vm(2, i) = 0.0D0 ELSE ! no (extensive slab attached to this plate): IF (traction_pole_read(iplate)) THEN uvec(1) = DSIN(xnode(i)) * DCOS(ynode(i)) ! xnode is theta in radians; ynode is phi. uvec(2) = DSIN(xnode(i)) * DSIN(ynode(i)) uvec(3) = DCOS(xnode(i)) tvec(1) = traction_pole_vector(2, iplate) * uvec(3) - traction_pole_vector(3, iplate) * uvec(2) tvec(2) = traction_pole_vector(3, iplate) * uvec(1) - traction_pole_vector(1, iplate) * uvec(3) tvec(3) = traction_pole_vector(1, iplate) * uvec(2) - traction_pole_vector(2, iplate) * uvec(1) !save in scalar form, for histogram: t = DSQRT(tvec(1)**2 + tvec(2)**2 + tvec(3)**2) IF (t > trhmax) THEN tvec(1) = tvec(1) * trhmax / t tvec(2) = tvec(2) * trhmax / t tvec(3) = tvec(3) * trhmax / t t = trhmax END IF traction_MPa(i) = t / 1.0D6 ! from Pa to MPa !saved in 2-D (theta, phi) vector form for plotting, in array vm [kludge]. CALL DLocal_Theta(uvec, theta_uvec) vm(1,i) = (tvec(1) * theta_uvec(1) + tvec(2) * theta_uvec(2) + tvec(3) * theta_uvec(3)) / 1.0D6 CALL DLocal_Phi(uvec, phi_uvec) vm(2,i) = (tvec(1) * phi_uvec(1) + tvec(2) * phi_uvec(2) + tvec(3) * phi_uvec(3)) / 1.0D6 ELSE traction_MPa(i) = 0.0D0 vm(1,i) = 0.0D0 vm(2,i) = 0.0D0 END IF END IF ! slab_Q(iplate), or not END DO DEALLOCATE ( traction_pole_read ) DEALLOCATE ( traction_pole_vector ) END IF ! iconve <=5 (rheologic method), OR iconve == 6 (traction pole vector method) WRITE (*,"(/' Here is the distribution of tractions (in MPa):')") CALL Histogram (traction_MPa, numnod, .FALSE., maximum, minimum) 2064 IF (traction_scale_MPa <= 0.0D0) traction_scale_MPa = (maximum + minimum) / 2.0D0 CALL DPrompt_for_Real('What typical traction (in MPa) should be shown in the margin?',traction_scale_MPa,traction_scale_MPa) IF (traction_scale_MPa <= 0.0D0) THEN WRITE(*,"(' Error: Please enter a positive number!')") mt_flashby = .FALSE. GO TO 2064 END IF 2065 CALL DPrompt_for_Real('How long (in points) should this vector be plotted?',traction_scale_points,traction_scale_points) IF (traction_scale_points <= 0.0D0) THEN WRITE(*,"(' Error: Please enter a positive number!')") mt_flashby = .FALSE. GO TO 2065 END IF WRITE (*,"(/' There will be ',I7,' vectors if they are not thinned.')") numnod 2066 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 2066 END IF ALLOCATE ( selected(numnod) ) CALL DThin_on_Sphere (node_uvec, numnod, vector_thinner, selected) WRITE (*,"(/' Working on basal traction vectors....')") CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DBegin_Group !note: product of pseudotime*traction_MPa(i) ! must be a distance in map-plane meters; ! so pseudotime is in meters/MPa: pseudotime = mp_meters_per_point * traction_scale_points / traction_scale_MPa DO i = 1, numnod IF (selected(i)) THEN uvec1(1:3) = node_uvec(1:3,i) CALL DVelocity_Vector_on_Sphere (from_uvec = uvec1, & & v_theta_mps = vm(1,i), v_phi_mps = vm(2,i), & & dt_sec = pseudotime, deflate = .TRUE.) END IF ! selected END DO ! actually plotting velocity vectors CALL DEnd_Group CALL Chooser(bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Shear traction') number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'on model base') CALL DVector_in_Plane (level = 1, & & from_x = 0.5D0*(x1_points+x2_points-traction_scale_points), from_y = y2_points - 33.0D0, & & to_x = 0.5D0*(x1_points+x2_points+traction_scale_points), to_y = y2_points - 33.0D0) number8 = ADJUSTL(DASCII8(traction_scale_Mpa)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 36.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8)//' MPa') CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 48.0D0 ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Shear traction') number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'on model base') CALL DVector_in_Plane (level = 1, & & from_x = x1_points+29.0D0-0.5D0*traction_scale_points, from_y = 0.5D0*(y1_points+y2_points)-10.0D0, & & to_x = x1_points+29.0D0+0.5D0*traction_scale_points, to_y = 0.5D0*(y1_points+y2_points)-10.0D0) number8 = ADJUSTL(DASCII8(traction_scale_MPa)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)//' MPa') CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 58.0D0 END IF ! bottom or right legend WRITE (*,"('+Working on basal traction vectors....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( selected, & ! vs, if allocated, was already deallocated & vm, & & traction_MPa )! in LIFO order IF (ALLOCATED(ndplat)) DEALLOCATE ( plon, plat, ndplat ) ! LIFO order DEALLOCATE ( fault_LRi, & ! in LIFO order & nodeF, & & continuum_LRi, & & nodes, & & whichP, & ! N.B. Mosaic code left this in place, but Overlay code should scratch it. & eqcm, & & checkN, & & ynode, & & xnode, & & node_uvec ) ! end of 6: shear traction vectors on base of model CASE (7) ! velocity vectors IF (.NOT.got_FEP) CALL Get_FEP 2070 IF (.NOT.just_began_surface_flow) THEN 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 grid was used to compute velocities?',feg_file,feg_file) 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. GO TO 2070 END IF READ (21,*) ! title READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( selected(numnod) ) ALLOCATE ( vw(2*numnod) ) ALLOCATE ( vsize_mma(numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod CLOSE(21) 2071 IF (.NOT.just_began_surface_flow) THEN temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be plotted?',vel_file,vel_file) 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. 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 line = 'Surface Velocity, with node ' // TRIM(ADJUSTL(number8)) // ' fixed' CALL Add_Title(line) CALL Reframe_Velocity() ELSE ! velocity_reframe = .FALSE. CALL Add_Title('Surface Velocity') 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.0D0 * 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.0D6 * 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 Velocity_Explanation() ! common code; uses velocity_Ma WRITE (*,"('+Working on velocity vectors....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of velocity vector overlay CASE (8) ! geodetic velocities of benchmarks CALL Add_Title('Relative Velocities of Geodetic Benchmarks') 2080 temp_path_in = path_in !CALL File_List( file_type = "*.gps", & ! & suggested_file = gps_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .gps file should be used?',gps_file,gps_file) CALL Add_Title(gps_file) gps_pathfile = TRIM(temp_path_in)//TRIM(gps_file) OPEN(UNIT = 21, FILE = gps_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 2080 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, *, IOSTAT = ios) lon, lat IF (ios /= 0) EXIT counting benchmarks = benchmarks + 1 END DO counting CLOSE (21) 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) ) 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 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) !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. 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) END DO ! i = 1, numnod CLOSE(21) 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....')") CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) !create group of error ellipses: ellipses = .FALSE. ! usually reversed by any finite ellipse, below CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') t = (velocity_Ma * 1.0D6) * 0.001D0 / mp_radius_meters ! arc-radians per (mm/a) 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.0 !create group of benchmarks: IF (benchmark_points > 0.0D0) THEN 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 velocity vectors: IF (velocity_Ma /= 0.0D0) THEN CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') ELSE CALL DSet_Stroke_Color ('foreground') END IF 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 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.0D6 * sec_per_year, deflate = .TRUE.) END DO ! actually plotting benchmark velocity vectors CALL DEnd_Group END IF ! velocity_Ma /= 0.0 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') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Geodetic') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '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.0D0, & & 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.0D0 * 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) CALL DSet_Stroke_Color ('red_______') 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.0D6 * sec_per_year) v_mma = v_mps * 1000.0D0 * sec_per_year number8 = ADJUSTL(DASCII8(v_mma)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 48.0D0, & & angle_radians = 0.0D0, & & 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.0D0, & & angle_radians = 0.0D0, & & 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.0D0, & & angle_radians = 0.0D0, & & 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') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'GPS velocity') number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(x '//TRIM(number8)//' Ma):') x0p = (x1_points + 29.0D0) - 14.17D0 x1p = x0p + 2.0D0 * 14.17D0 ! 1-cm-long vector, expressed in points y0p = 0.5D0 * (y1_points + y2_points) - 10.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.0D0, & & y_points = y0p, & & angle_radians = 0.0D0, & & 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) CALL DSet_Stroke_Color ('red_______') 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.0D6 * sec_per_year) v_mma = v_mps * 1000.0D0 * sec_per_year number8 = ADJUSTL(DASCII8(v_mma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)//' mm/a') CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 58.0D0 IF (ellipses) rightlegend_used_points = rightlegend_used_points + 36.0D0 ! for "95%-c." END IF ! bottom or right legend WRITE (*,"('+Working on benchmark velocity vectors....DONE.')") DEALLOCATE ( benchmark_hypotenuse ) ! in LIFO order DEALLOCATE ( benchmark_correlation ) DEALLOCATE ( benchmark_E_sigma ) DEALLOCATE ( benchmark_E_velocity ) DEALLOCATE ( benchmark_N_sigma ) DEALLOCATE ( benchmark_N_velocity ) DEALLOCATE ( benchmark_uvec ) ! in LIFO order CALL BEEPQQ (frequency = 440, duration = 250) ! end of 8: geodetic velocities of benchmarks CASE (9:10) ! fault element activity: (9) horizontal; (10) slip rate IF (.NOT.got_FEP) CALL Get_FEP 2090 temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file should be used?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 2090 END IF READ (21,"(A)") line CALL Add_Title(line) READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod) ) ALLOCATE ( vw(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 DO i = 1, numel READ (21,*) END DO ! i = 1, numel READ (21,*) nFl ALLOCATE ( nodeF(4, nFl) ) ALLOCATE ( fault_LRi(nFl) ) ALLOCATE ( fDip(2, nFl) ) ALLOCATE ( fAzim(2, nFl) ) ALLOCATE ( slipNumber(nFl) ) ALLOCATE ( up_azim_rads(nFl) ) ALLOCATE ( plot_at_uvec(3, nFl) ) LRn = 0 ! just initializing, before READs DO i = 1, nFl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output fault_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodeF(1,i), nodeF(2,i), nodeF(3,i), nodeF(4,i), fDip(1,i), fDip(2,i) END DO ! i = 1, nFl CLOSE (21) CALL Fault_Azimuths(FEP, nfl, nodef, node_uvec, fdip, fazim) 2091 temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be used?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL DPress_Enter mt_flashby = .FALSE. GO TO 2091 END IF IF (choice == 9) THEN CALL Add_Title('Change in Horizontal Velocity Across Faults') ELSE IF (choice == 10) THEN CALL Add_Title('Slip Rates of Faults') 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('The widths of the shaded bands along faults are equal & &to their slip-rates multiplied by a time factor. For how many Ma should & &fault slip-rates be projected?',velocity_Ma,velocity_Ma) CALL DPrompt_for_Real('How large are the dip ticks (in points)?',tick_points,tick_points) IF (choice == 9) THEN WRITE (*,"(/' Working on changes in horizontal velocity across faults....')") ELSE IF (choice == 10) THEN WRITE (*,"(/' Working on slip-rates of fault elements....')") END IF ! choice == 9 or 10 CALL Plot_Fault_Ticks (colored = .FALSE.) ! would conflict with bands ! Chooses color, etc. and defines a group; ! all information is from global. sup_slipnumber = 0.0D0 CALL DBegin_Group ! of colored/shaded bands DO i = 1, nfl IF (FEP == "SHELLS") THEN 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. CALL DMake_Uvec(uvec3, uvec4) ! uvec4 is midpoint v1E_mma = 1000.0D0 * sec_per_year * vw(2*nodef(1,i)) v2E_mma = 1000.0D0 * sec_per_year * vw(2*nodef(2,i)) v3E_mma = 1000.0D0 * sec_per_year * vw(2*nodef(3,i)) v4E_mma = 1000.0D0 * sec_per_year * vw(2*nodef(4,i)) v1S_mma = 1000.0D0 * sec_per_year * vw(2*nodef(1,i)-1) v2S_mma = 1000.0D0 * sec_per_year * vw(2*nodef(2,i)-1) v3S_mma = 1000.0D0 * sec_per_year * vw(2*nodef(3,i)-1) v4S_mma = 1000.0D0 * sec_per_year * vw(2*nodef(4,i)-1) f_azim_rads_1 = fazim(1,i) f_azim_rads_2 = fazim(2,i) f_azim_rads_c = DCompass(uvec4, uvec2) open1 = (v1E_mma - v4E_mma) * DCOS(f_azim_rads_1) + & & (v1S_mma - v4S_mma) * DSIN(f_azim_rads_1) open2 = (v2E_mma - v3E_mma) * DCOS(f_azim_rads_2) + & & (v2S_mma - v3S_mma) * DSIN(f_azim_rads_2) dextral1 = (v1S_mma - v4S_mma) * DCOS(f_azim_rads_1) + & & (v4E_mma - v1E_mma) * DSIN(f_azim_rads_1) dextral2 = (v2S_mma - v3S_mma) * DCOS(f_azim_rads_2) + & & (v3E_mma - v2E_mma) * DSIN(f_azim_rads_2) IF (ABS(fdip(1,i)) <= 75.0D0) THEN vertical1 = open1 * DTAN(ABS(fdip(1,i))*radians_per_degree) ELSE ! vertical fault vertical1 = 0.0D0 END IF IF (ABS(fdip(2,i)) <= 75.0D0) THEN vertical2 = open2 * DTAN(ABS(fdip(2,i))*radians_per_degree) ELSE ! vertical fault vertical2 = 0.0D0 END IF IF ((ABS(fdip(1,i)) > 75.0D0).AND.(ABS(fdip(2,i)) > 75.0D0)) THEN !for vertical fault only, consider reversing direction! test = 0.7071D0 * DCOS(f_azim_rads_c) + (-0.7071D0) * DSIN(f_azim_rads_c) ! note that test is > 0. when fault trends NW; this puts number label upside-down IF (test > 0.0D0) THEN ! reverse the element (not in arrays, just in temporary variables!) uvec3(1:3) = uvec1(1:3) uvec1(1:3) = uvec2(1:3) uvec2(1:3) = uvec3(1:3) ! note that uvec4: midpoint is unchanged t1 = v1S_mma t2 = v1E_mma v1S_mma = v3S_mma v1E_mma = v3E_mma v3S_mma = t1 v3E_mma = t2 t1 = v2S_mma t2 = v2E_mma v2S_mma = v4S_mma v2E_mma = v4E_mma v4S_mma = t1 v4E_mma = t2 t1 = f_azim_rads_1 t2 = f_azim_rads_2 f_azim_rads_1 = t2 + Pi f_azim_rads_2 = t1 + Pi f_azim_rads_c = f_azim_rads_c + Pi t1 = open1 open1 = open2 open2 = t1 t1 = dextral1 dextral1 = dextral2 dextral2 = t1 ! no need to swap vertical1, 2 == 0.0 END IF ! reversing fault element END IF ! element is a vertical fault dipslip1 = DSQRT(open1**2 + vertical1**2) dipslip2 = DSQRT(open2**2 + vertical2**2) IF (choice == 9) THEN ! horizontal only sliprate1 = DSQRT(dextral1**2 + open1**2) sliprate2 = DSQRT(dextral2**2 + open2**2) ELSE IF (choice == 10) THEN ! 3-D sliprate sliprate1 = DSQRT(dextral1**2 + dipslip1**2) sliprate2 = DSQRT(dextral2**2 + dipslip2**2) END IF ! choice == 9 or 10 slipnumber(i) = (sliprate1 + sliprate2) / 2.0D0 ! store for plotting # later! sup_slipnumber = MAX(sup_slipnumber, slipnumber(i)) IF (fdip(1,i) >= 0.0D0) THEN x_azim_rads_1 = f_azim_rads_1 - Pi/2.0D0 up_azim_rads(i) = f_azim_rads_c - Pi/2.0D0 ! store for plotting # later! x_azim_rads_2 = f_azim_rads_2 - Pi/2.0D0 ELSE ! negative fdip means dipping from N3-N4 side. x_azim_rads_1 = f_azim_rads_1 + Pi/2.0D0 up_azim_rads(i) = f_azim_rads_c + Pi/2.0D0 x_azim_rads_2 = f_azim_rads_2 + Pi/2.0D0 END IF offset_radians = velocity_Ma * slipnumber(i) * 1000.0D0 / R CALL DTurn_To (azimuth_radians = up_azim_rads(i), & & base_uvec = uvec4, far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) plot_at_uvec(1:3,i) = uvec3(1:3) ! store for plotting # later offset_radians = velocity_Ma * sliprate1 * 1000.0D0 / R CALL DTurn_To (azimuth_radians = x_azim_rads_1, & & base_uvec = uvec1, far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec4) ! as in nodef(4,i), displaced offset_radians = velocity_Ma * sliprate2 * 1000.0D0 / R CALL DTurn_To (azimuth_radians = x_azim_rads_2, & & base_uvec = uvec2, far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) ! as in nodef(3,i), displaced IF (ai_using_color) THEN IF (ABS(dipslip1 + dipslip2) > ABS(dextral1 + dextral2)) THEN IF ((open1 + open2) > 0.0D0) THEN color_name = 'bronze____' ELSE ! thrust color_name = 'mid_blue__' END IF ! normal or thrust ELSE ! strike-slip colors IF ((dextral1 + dextral2) > 0.0D0) THEN color_name = 'green_____' ELSE ! sinistral color_name = 'brown_____' END IF ! dextral or sinistral END IF !dipslip or strike-slip colors CALL DSet_Fill_or_Pattern (.FALSE., color_name) CALL DNew_L45_Path (5, uvec1) CALL DGreat_to_L45(uvec2) CALL DGreat_to_L45(uvec3) CALL DGreat_to_L45(uvec4) CALL DGreat_to_L45(uvec1) CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ELSE ! b/w plot CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DNew_L45_Path (5, uvec4) CALL DGreat_to_L45(uvec3) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = 0, 6 ! 7 lines per fault element s = j/6.0D0 CALL DGreatCircle_Point (from_uvec = uvec4, & & to_uvec = uvec3, s = s, & ! inputs & point_uvec = uvec5, azimuth_radians = t) ! outputs CALL DGreatCircle_Point (from_uvec = uvec1, & & to_uvec = uvec2, s = s, & ! inputs & point_uvec = uvec6, azimuth_radians = t) ! outputs CALL DNew_L45_Path (5, uvec5) CALL DGreat_to_L45(uvec6) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! j = 0, 6 END IF ! ai_using_color or not END IF ! FEP selection END DO ! i = 1, nfl CALL DEnd_Group ! of colored/shaded bands CALL Plot_Fault_Traces (colored = .FALSE.) ! would conflict with bands ALLOCATE ( selected(nfl) ) WRITE (*,"(/' There will be ',I7,' rate numbers if they are not thinned.')") nfl 2092 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 2092 END IF CALL DThin_on_Sphere (plot_at_uvec, nfl, label_thinner, selected) IF (label_thinner > 1) THEN ! also block any very tiny numbers: DO i = 1, nfl IF (selected(i)) THEN IF (slipnumber(i) < 0.01 * sup_slipnumber) selected(i) = .FALSE. END IF END DO END IF ! label_thinner > 1 CALL DBegin_Group ! of rate numbers CALL DSet_Fill_or_Pattern(.FALSE., 'foreground') DO i = 1, nfl IF (selected(i)) THEN IF (FEP == "SHELLS") THEN uvec1(1:3) = plot_at_uvec(1:3,i) 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 = ADJUSTL(DASCII8(slipnumber(i)))) END IF ! FEP selection END IF ! selected(i) END DO ! i = 1, nfl CALL DEnd_Group ! of rate numbers DEALLOCATE ( selected ) DEALLOCATE ( vw ) DEALLOCATE ( node_uvec ) DEALLOCATE ( plot_at_uvec ) DEALLOCATE ( up_azim_rads ) DEALLOCATE ( slipNumber ) DEALLOCATE ( fAzim ) DEALLOCATE ( fDip ) DEALLOCATE ( fault_LRi ) DEALLOCATE ( nodeF ) CALL Chooser (bottom, right) CALL DBegin_Group ! sample sliprates ! how fast is a 20-point band, in mm/a? sliprate1 = (((20.0D0/2834.0D0)/1000.0D0)*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.0D0 CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(DASCII8(sliprate1)))//' mm/a') IF (ai_using_color) THEN !each takes 20 points plus space below for a dip tick = 30 apart CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-32.0D0, & & color_name = 'bronze____', text = 'normal') CALL DDipTick_in_Plane (level = 1, x = xcp, y = y2_points-32.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'N', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-62.0D0, & & color_name = 'mid_blue__', text = 'thrust') CALL DDipTick_in_Plane (level = 1, x = xcp, y = y2_points-62.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'T', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-92.0D0, & & color_name = 'green_____', text = 'dextral') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-122.0D0, & & color_name = 'brown_____', text = 'sinistral') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 122.0D0 ELSE ! b/w CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DNew_L12_Path(1, xcp-31.0D0, y2_points-12.0D0) CALL DLine_to_L12(xcp+31., y2_points-12.) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = -30,30,6 CALL DNew_L12_Path(1, xcp+j, y2_points-12.0D0) CALL DLine_to_L12(xcp+j, y2_points-32.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! vertical stripes CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, xcp-31.0D0, y2_points-32.0D0) CALL DLine_to_L12(xcp+31.0D0, y2_points-32.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 32.0D0 END IF ! color or b/w CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points IF (choice == 9) THEN ! delta Vh CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, 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.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'part of') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-30.0D0, 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.0D0 ELSE IF (choice == 10) THEN ! 3-D sliprate CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Slip rate') rightlegend_used_points = rightlegend_used_points + 10.0D0 END IF ! choice == 9 or 10 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 IF (choice == 9) THEN ! delta Vh CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp+10.0D0, 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.0D0, & & y_points = ycp, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'part of') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp-10.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'slip rate:') ELSE IF (choice == 10) THEN ! 3-D sliprate CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Slip rate:') END IF ! choice == 9 or 10 bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.0D0 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.0D0, & & y_points = ycp+12.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(DASCII8(sliprate1)))//' mm/a') IF (ai_using_color) THEN CALL Slip_Sample(x_center_points = x1_points+36.0D0, y_base_points = ycp-10.0D0, & & color_name = 'bronze____', text = 'normal') CALL DDipTick_in_Plane (level = 1, x = x1_points+36.0D0, y = ycp-10.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'N', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = x1_points+108.0D0, y_base_points = ycp-10.0D0, & & color_name = 'mid_blue__', text = 'thrust') CALL DDipTick_in_Plane (level = 1, x = x1_points+108.0D0, y = ycp-10.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'T', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = x1_points+180.0D0, y_base_points = ycp-10.0D0, & & color_name = 'green_____', text = 'dextral') CALL Slip_Sample(x_center_points = x1_points+252.0D0, y_base_points = ycp-10.0D0, & & color_name = 'brown_____', text = 'sinistral') bottomlegend_used_points = bottomlegend_used_points + 288.0D0 ELSE ! b/w CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+5.0D0, ycp+10.0D0) CALL DLine_to_L12(x1_points+67.0D0, ycp+10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = -30,30,6 CALL DNew_L12_Path(1, x1_points+36.0D0+j, ycp+10.0D0) CALL DLine_to_L12(x1_points+36.0D0+j, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! vertical stripes CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+5.0D0, ycp-10.0D0) CALL DLine_to_L12(x1_points+67.0D0, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + 72.0D0 END IF ! color or b/w 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 (frequency = 440, duration = 250) ! end of fault activity (9: horizontal; 10: slip rate) CASE (11) ! strain-rates (not including fault slip): IF (.NOT.got_FEP) CALL Get_FEP 2110 IF (.NOT.just_began_strainrate) THEN temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file defines the elements?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) END IF ! .NOT.just_began_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) ) 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 ( continuum_LRi(numEl) ) ALLOCATE ( selected(numEl) ) ALLOCATE ( strainrate(3, 7, numEl) ) ALLOCATE ( uvec_list(3, numEl) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *, 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_strainrate = .FALSE. mt_flashby = .FALSE. GO TO 2110 END IF CLOSE (21) CALL Add_Title(feg_file) 2111 IF (.NOT.just_began_strainrate) THEN temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be used?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) END IF ! .NOT.just_began_strainrate 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_strainrate = .FALSE. mt_flashby = .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) 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.0D0).AND.((e1h*e2h) <= 0.0D0).AND.((e1h*err) <= 0.0D0) e2h_partitioned = (e2h /= 0.0D0).AND.((e2h*e1h) <= 0.0D0).AND.((e2h*err) <= 0.0D0) err_partitioned = (err /= 0.0D0).AND.((err*e1h) <= 0.0D0).AND.((err*e2h) <= 0.0D0) ! Decide how big largest symbol is (in terms of partitioned e3-e1). big_diff = 0.0D0 IF (e1h*e2h < 0.0D0) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.0D0*ABS(e2h)) ELSE big_diff = MAX(big_diff, 2.0D0*ABS(e1h)) END IF END IF IF (e1h*err < 0.0D0) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.0D0*ABS(err)) ELSE big_diff = MAX(big_diff, 2.0D0*ABS(e1h)) END IF END IF IF (e2h*err < 0.0D0) THEN IF (e2h_partitioned) THEN big_diff = MAX(big_diff, 2.0D0*ABS(err)) ELSE big_diff = MAX(big_diff, 2.0D0*ABS(e2h)) END IF END IF e3_minus_e1_persec(i) = big_diff END 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 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 Strain Rates (not including fault slip)') ELSE ! == 1 CALL Add_Title('Strain Rates (not including fault slip)') 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.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Strain-rate of') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'continuum, as') rightlegend_used_points = rightlegend_used_points + 20.0D0 y2_points = y2_points - 20.0D0 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'conjugate') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'microfaults:') rightlegend_used_points = rightlegend_used_points + 25.0D0 ! 5 points extra for minigap y2_points = y2_points - 25.0D0 ! symbol part of paleostress in legend; CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL DStrain_in_Plane (1, 0.8D0*x1_points + 0.2D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & -0.5D0*ref_e3_minus_e1_persec, 0.0D0, 0.0D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL DStrain_in_Plane (1, 0.5D0*x1_points + 0.5D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & 0.5D0*ref_e3_minus_e1_persec, 0.0D0, -0.5D0*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL DStrain_in_Plane (1, 0.2D0*x1_points + 0.8D0*x2_points, & & y2_points - 0.5D0*strainrate_diameter_points , & & 0.5D0*ref_e3_minus_e1_persec, 0.0D0, 0.0D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) rightlegend_used_points = rightlegend_used_points + strainrate_diameter_points y2_points = y2_points - strainrate_diameter_points IF (strainrate_mode012 > 0) THEN ! label with e3-e1 = # CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'E3 - E1 =') number8 = DASCII8(ref_e3_minus_e1_persec) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Diameter') ELSE ! mode012 = 2 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Area is') END IF ! mode 1 or 2 CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 30.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'proportional to') rightlegend_used_points = rightlegend_used_points + 40.0D0 y2_points = y2_points - 40.0D0 ELSE ! all symbols are of equal size CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(Size is') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'independent of') rightlegend_used_points = rightlegend_used_points + 20.0D0 y2_points = y2_points - 20.0D0 END IF ! labelling with numerical strainrate, or not CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'strain-rate.)') rightlegend_used_points = rightlegend_used_points + 10.0D0 y2_points = y2_points - 10.0D0 CALL DEnd_Group ELSE IF (bottom) THEN ! sample strain-rate in bottomlegend CALL DBegin_Group ! text part of strain-rate in legend; begin with a gap CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Strain-rate of') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'continuum, as') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'conjugate') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) -20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'microfaults:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.0D0 ! text1 only ! symbol part of paleostress in legend; CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL DStrain_in_Plane (1, x1_points + 14.0D0, & & 0.5D0*(y1_points + y2_points), & & -0.5D0*ref_e3_minus_e1_persec, 0.0D0, 0.0D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL DStrain_in_Plane (1, x1_points + 36.0D0, & & 0.5D0*(y1_points + y2_points), & & 0.5D0*ref_e3_minus_e1_persec, 0.0D0, -0.5D0*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL DStrain_in_Plane (1, x1_points + 58.0D0, & & 0.5D0*(y1_points + y2_points) , & & 0.5D0*ref_e3_minus_e1_persec, 0.0D0, 0.0D0, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) bottomlegend_used_points = bottomlegend_used_points + 72.0D0 ! now, including middle symbols block x1_points = x1_points + 72.0D0 !note that x1_points now indicates right side of middle symbol block IF (strainrate_mode012 > 0) THEN ! label with e3-e1 = # CALL DL12_Text (level = 1, & & x_points = x1_points - 36.0D0, & & y_points = y1_points + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'E3 - E1 =') number8 = DASCII8(ref_e3_minus_e1_persec) CALL DL12_Text (level = 1, & & x_points = x1_points - 36.0D0, & & y_points = y1_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Diameter') ELSE ! mode012 = 2 CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Area is') END IF ! mode 1 or 2 CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'proportional to') ELSE ! all symbols are of equal size CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = '(Size is') CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'independent of') END IF ! labelling with numerical strainrate, or not CALL DL12_Text (level = 1, & & x_points = x1_points + 36.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.5D0, & & text = 'strain-rate.)') CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + 72.0D0 ! right text block END IF ! sample strain-rate in bottom/right legend WRITE (*,"('+Working on strain-rates....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( e3_minus_e1_persec, & & node_uvec, & & continuum_LRi, & & nodes, & & selected, strainrate, & & uvec_list, vw ) ! end of 11: strain-rates CASE (12) ! vertical integral of stress anomaly tensors IF (just_began_tau_integral) THEN CALL Add_Title('Vertical Integrals of Shear Stress and Stress Anomaly') ELSE CALL Add_Title('Vertical Integral of Stress Anomaly Tensors') END IF IF (.NOT.got_FEP) CALL Get_FEP 2120 IF (.NOT.just_began_tau_integral) THEN temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file defines the elements?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) END IF ! .NOT. just_began_tau_integral 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) ) ALLOCATE ( eqcm(6,numnod) ) OrbData5 = .FALSE. ! unless non-zero values discovered in columns 5, 6 below... DO i = 1, numnod READ (21, "(A)", IOSTAT = ios) input_record READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters, & & density_anomaly_kgpm3, cooling_curvature_Cpm2 IF (ios /= 0) THEN density_anomaly_kgpm3 = 0.0D0 cooling_curvature_Cpm2 = 0.0D0 READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters END IF problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL DLonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) eqcm(1,i) = elevation eqcm(2,i) = heatflow eqcm(3,i) = crust_meters eqcm(4,i) = mantle_meters eqcm(5,i) = density_anomaly_kgpm3 eqcm(6,i) = cooling_curvature_Cpm2 OrbData5 = OrbData5 .OR. (density_anomaly_kgpm3 /= 0.0D0) .OR. (cooling_curvature_Cpm2 /= 0.0D0) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numEl problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3, numEl) ) ALLOCATE ( continuum_LRi(numEl) ) ALLOCATE ( strainrate(3, 7, numEl) ) ! 3 components; 7 integration points LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *, 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. GO TO 2120 END IF CLOSE (21) !Now that LRn is known: [N.B. It will often be 0] ALLOCATE ( LR_is_defined(0:LRn) ) ALLOCATE ( LR_is_used(0:LRn) ) LR_is_defined = .FALSE. ! whole array, until information is read, below... LR_is_used = .FALSE. ! whole array, until information is read, below... ALLOCATE ( LR_set_fFric(0:LRn) ) ALLOCATE ( LR_set_cFric(0:LRn) ) ALLOCATE ( LR_set_Biot(0:LRn) ) ALLOCATE ( LR_set_Byerly(0:LRn) ) ALLOCATE ( LR_set_aCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_bCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_cCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_dCreep(1:2, 0:LRn) ) ALLOCATE ( LR_set_eCreep(0:LRn) ) !Just for ease in debugging, initialize all (currently) undefined array values as zero: LR_set_fFric = 0.0D0 LR_set_cFric = 0.0D0 LR_set_Biot = 0.0D0 LR_set_Byerly = 0.0D0 LR_set_aCreep = 0.0D0 LR_set_bCreep = 0.0D0 LR_set_cCreep = 0.0D0 LR_set_dCreep = 0.0D0 LR_set_eCreep = 0.0D0 CALL Add_Title(feg_file) 2121 IF (.NOT.just_began_tau_integral) THEN temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be used?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) END IF ! .NOT.just_began_tau_integral OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL DPress_Enter mt_flashby = .FALSE. GO TO 2121 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) 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) ! integration point 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 !Get input parameters: 2122 IF (.NOT.just_began_tau_integral) THEN temp_path_in = path_in !CALL File_List( file_type = "i*.in", & ! & suggested_file = parameter_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file contains the input parameters?',parameter_file,parameter_file) parameter_pathfile = TRIM(temp_path_in)//TRIM(parameter_file) END IF ! .NOT.just_began_tau_integral CALL Input_to_SHELLS ( 11, parameter_pathfile, names , nPlates, & ! inputs & alphat, conduc, & ! outputs... & d_fFric, d_cFric, d_Biot, d_Byerly, d_aCreep, d_bCreep, d_cCreep, d_dCreep, d_eCreep, & & everyp, & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, radius, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) !Remember the default ("d_") Lithospheric Rheology as LR0, or LR_set_XXXX(0): LR_set_fFric(0) = d_fFric LR_set_cFric(0) = d_cFric LR_set_Biot(0) = d_Biot LR_set_Byerly(0) = d_Byerly LR_set_aCreep(1:2, 0) = d_aCreep(1:2) LR_set_bCreep(1:2, 0) = d_bCreep(1:2) LR_set_cCreep(1:2, 0) = d_cCreep(1:2) LR_set_dCreep(1:2, 0) = d_dCreep(1:2) LR_set_eCreep(0) = d_eCreep LR_is_defined(0) = .TRUE. IF (LRn > 0) THEN CALL Read_Additional_LRs (temp_path_in, 13, LRn, continuum_LRi, fault_LRi, numEl, nFl, & ! input & LR_set_fFric, LR_set_cFric, LR_set_Biot, LR_set_Byerly, & ! modify & LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_dCreep, LR_set_eCreep, & & LR_is_defined, LR_is_used) !N.B. This SUBR will prompt the user to supply the name of the necessary input file. END IF ! LRn > 0 CALL Add_Title(parameter_file) CALL Limits_in_SHELLS (eqcm,nodes,numel,node_uvec, & & okdelv,mp_radius_meters,refstr, & & trhmax, & ! inputs & constr,etamax,fmumax,vismax) ! outputs !find vertical integrals of principal stress anomalies for each m=1 point: ALLOCATE ( tau_integral(3,numel) ) ! t1, t2, trr at m=1 center of each element ALLOCATE ( azimuth(numel) ) ! of tau1h, in radians clockwise from North ALLOCATE ( largest_axis(numel) ) ALLOCATE ( uvec_list(3,numel) ) DO i = 1, numel n1 = nodes(1,i) n2 = nodes(2,i) n3 = nodes(3,i) m = 1 ! only do the center integration point of each element uvec1(1:3) = Gauss_point(1,m) * node_uvec(1:3,n1) + & & Gauss_point(2,m) * node_uvec(1:3,n2) + & & Gauss_point(3,m) * node_uvec(1:3,n3) CALL DMake_Uvec (uvec1, uvec) ! center of element uvec_list(1:3, i) = uvec(1:3) elevation = Gauss_point(1,m) * eqcm(1,n1) + Gauss_point(2,m) * eqcm(1,n2) + Gauss_point(3,m) * eqcm(1,n3) heatflow = Gauss_point(1,m) * eqcm(2,n1) + Gauss_point(2,m) * eqcm(2,n2) + Gauss_point(3,m) * eqcm(2,n3) crust_meters = Gauss_point(1,m) * eqcm(3,n1) + Gauss_point(2,m) * eqcm(3,n2) + Gauss_point(3,m) * eqcm(3,n3) mantle_meters = Gauss_point(1,m) * eqcm(4,n1) + Gauss_point(2,m) * eqcm(4,n2) + Gauss_point(3,m) * eqcm(4,n3) density_anomaly_kgpm3 = Gauss_point(1,m) * eqcm(5,n1) + Gauss_point(2,m) * eqcm(5,n2) + Gauss_point(3,m) * eqcm(5,n3) !N.B. Following logic does not work, due to strong nonlinearities in geotherm equations interacting with lateral gradients: !cooling_curvature_Cpm2 = Gauss_point(1,m) * eqcm(6,n1) + Gauss_point(2,m) * eqcm(6,n2) + Gauss_point(3,m) * eqcm(6,n3) !Instead, it is necessary to adjust the geotherm to match the asthenosphere temperature (for either OrbData or OrbData5 models): tasthk = tadiab + gradie * 100.0D3 !Non-controversial geotherm coefficients: geoth1 = tsurf geoth2 = heatflow / conduc(1) geoth3 = -0.5D0 * radio(1) / conduc(1) geoth4 = 0.0D0 geoth7 = -0.5D0 * radio(2) / conduc(2) geoth8 = 0.0D0 !On first pass, build geotherm WITHOUT any cooling_curvature (as in old Shells): geoth5 = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 + geoth4 * crust_meters**3 dtdzc = geoth2 + 2.0D0 * geoth3 * crust_meters + 3. * geoth4 * crust_meters**2 dtdzm = dtdzc * conduc(1) / conduc(2) geoth6 = dtdzm !Now, correct geotherm to hit tashtk: IF (mantle_meters > 0.0D0) THEN test = geoth5 + geoth6 * mantle_meters + geoth7 * mantle_meters**2 + geoth8 * mantle_meters**3 ELSE test = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 + geoth4 * crust_meters**3 END IF terr0r = test - tasthk delta_quadratic = -terr0r / (crust_meters + mantle_meters)**2 cooling_curvature_Cpm2 = -2.0D0 * delta_quadratic ! (not actually used here) geoth3 = geoth3 + delta_quadratic geoth7 = geoth7 + delta_quadratic geoth5 = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 + geoth4 * crust_meters**3 dtdzc = geoth2 + 2.0D0 * geoth3 * crust_meters + 3.0D0 * geoth4 * crust_meters**2 dtdzm = dtdzc * conduc(1) / conduc(2) geoth6 = dtdzm zstop = crust_meters + mantle_meters CALL SQUEEZ (alphat, density_anomaly_kgpm3, elevation, & & geoth1,geoth2,geoth3,geoth4, & & geoth5,geoth6,geoth7,geoth8, & & gmean, & & 6,onekm,rhoast,rhobar,rhoh2o, & & temlim,crust_meters,zstop, & ! inputs & tauzz,sigzzb) ! outputs tau_integral(3,i) = tauzz !use DIAMND to compute excess horizontal principal stresses sighbi = 0.0D0 ! simply punting on this; too much trouble to recompute! e11 = strainrate(1,m,i) e12 = strainrate(2,m,i) ! (see subprogram E_rate) e22 = strainrate(3,m,i) CALL DPrincipal_Axes_22 (e11, e12, e22, & & e1, e2, u1x,u1y, u2x,u2y) azimuth(i) = Pi - DATan2F(u1y, u1x) ! save for plotting, below IF ((e1 == 0.0D0).AND.(e2 == 0.0D0)) THEN tau_integral(1,i) = tau_integral(3,i) tau_integral(2,i) = tau_integral(3,i) ELSE t1 = tau_integral(3,i) ! prepare to sum layer contributions t2 = tau_integral(3,i) IF (crust_meters > 0.0D0) THEN pl0 = 0.0D0 ! same approximation as in VISCOS; pw0 = 0.0D0 ! ocean not important since it affects both equally zoftop = 0.0D0 rho_use = rhobar(1) + density_anomaly_kgpm3 !CALL DIAMND (acreep(1),alphat(1),bcreep(1), & ! beginning of inputs ! & biot,ccreep(1),dcreep(1),ecreep, & ! & e1,e2, & !principal horizontal strain rates ! & cfric,gmean,geoth1,geoth2,geoth3,geoth4, & ! & pl0,pw0,rho_use,rhoh2o,sighbi, & ! & crust_meters,temlim(1),vismax,zoftop, & ! end of inputs ! & pt1de1,pt2de2,pt2de1,pt2de2, & !beginning of outputs ! & pt1,pt2,ztran) !NOTE: ALL arguments in the following CALL must be scalars (not arrays)! CALL Diamnd (LR_set_aCreep(1, continuum_LRi(i)), alphaT(1), LR_set_bCreep(1, continuum_LRi(i)), & ! input & LR_set_Biot(continuum_LRi(i)), LR_set_cCreep(1, continuum_LRi(i)), LR_set_dCreep(1, continuum_LRi(i)), & & LR_set_eCreep(continuum_LRi(i)), & & e1, e2, & !principal horizontal strain rates (just computed above) & LR_set_cFric(continuum_LRi(i)), & & gmean, & ! <= note substitution for "g" in SUBR & geoth1, & & geoth2, & & geoth3, & & geoth4, & & pl0, pw0, & & rho_use, & ! <= note substitution for "rhoBar" in SUBR & rhoH2O, sigHBi, & & crust_meters, & ! <= note substition for "thick" in SUBR & temLim(1), & & visMax, zOfTop, & & pT1dE1, pT1dE2, & ! output & pT2dE1, pT2dE2, & & pT1, pT2, zTran) t1 = t1 + pt1 t2 = t2 + pt2 END IF ! crust_meters > 0 IF (mantle_meters > 0.0D0) THEN zoftop = crust_meters pw0 = rhoh2o * gmean * crust_meters t_mean = geoth1 + & & 0.5D0 * geoth2 * crust_meters + & & 0.333D0 * geoth3 * crust_meters**2 + & & 0.25D0 * geoth4 * crust_meters**3 rho_use = rhobar(1) * (1.0D0 - alphat(1) * t_mean) + density_anomaly_kgpm3 pl0 = rho_use * gmean * crust_meters rho_use = rhobar(2) + density_anomaly_kgpm3 !CALL DIAMND (acreep(2),alphat(2),bcreep(2), & ! beginning of inputs ! & biot,ccreep(2),dcreep(2),ecreep, & ! & e1,e2, & !principal horizontal strain rates ! & cfric,gmean,geoth5,geoth6,geoth7,geoth8, & ! & pl0,pw0,rho_use,rhoh2o,sighbi, & ! & mantle_meters,temlim(2),vismax,zoftop, & ! end of inputs ! & pt1de1,pt1de2,pt2de1,pt2de2, & !beginning of outputs ! & pt1,pt2,ztran) !NOTE: ALL arguments in the following CALL must be scalars (not arrays)! CALL Diamnd (LR_set_aCreep(2, continuum_LRi(i)), alphaT(2), LR_set_bCreep(2, continuum_LRi(i)), & ! input & LR_set_Biot(continuum_LRi(i)), LR_set_cCreep(2, continuum_LRi(i)), LR_set_dCreep(2, continuum_LRi(i)), & & LR_set_eCreep(continuum_LRi(i)), & & e1, e2, & !principal horizontal strain rates (just computed above) & LR_set_cFric(continuum_LRi(i)), & & gmean, & ! <= note substitution for "g" in SUBR & geoth5, & & geoth6, & & geoth7, & & geoth8, & & pl0, pw0, & & rho_use, & ! <= note substitution for "rhoBar" in SUBR & rhoH2O, sigHBi, & & mantle_meters, & ! <= note substition for "thick" in SUBR & temLim(2), & & visMax, zOfTop, & & pT1dE1, pT1dE2, & ! output & pT2dE1, pT2dE2, & & pT1, pT2, zTran) t1 = t1 + pt1 t2 = t2 + pt2 END IF ! mantle_meters > 0 tau_integral(1,i) = t1 tau_integral(2,i) = t2 END IF ! e1 AND e2 == 0.0, or not largest_axis(i) = MAX(ABS(tau_integral(1,i)),ABS(tau_integral(2,i)),ABS(tau_integral(3,i))) END DO ! i = 1, numel WRITE (*,"(/' Here is the distribution of largest principal stress anomalies:')") CALL Histogram (largest_axis, numel, .FALSE., maximum, minimum) CALL DPrompt_for_String('What are the units of these vertically-integrated stress anomalies?',stress_integral_units,stress_integral_units) 2123 IF (tau_integral_scale_Npm <= 0.0D0) tau_integral_scale_Npm = (maximum + minimum) / 2.0D0 CALL DPrompt_for_Real('What typical stress-anomaly-integral value should be shown in the margin?',tau_integral_scale_Npm,tau_integral_scale_Npm) IF (tau_integral_scale_Npm <= 0.0D0) THEN WRITE(*,"(' Error: Please enter a positive number!')") mt_flashby = .FALSE. GO TO 2123 END IF 2124 CALL DPrompt_for_Real('With what diameter (in points) should this value be plotted?',tau_integral_scale_points,tau_integral_scale_points) IF (tau_integral_scale_points <= 0.0D0) THEN WRITE(*,"(' Error: Please enter a positive number!')") mt_flashby = .FALSE. GO TO 2124 END IF WRITE (*,"(/' There will be ',I7,' tensors if they are not thinned.')") numel 2125 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!')") mt_flashby = .FALSE. GO TO 2125 END IF IF (stress_thinner > 1) THEN WRITE(string10,"(I10)") stress_thinner CALL Add_Title('(1/'//TRIM(ADJUSTL(string10))//') of Vertically-Integrated Stress Anomaly Tensors') ELSE ! == 1 CALL Add_Title('Vertically-Integrated Stress Anomaly Tensors') END IF ALLOCATE ( selected(numel) ) CALL DThin_on_Sphere (uvec_list, numel, stress_thinner, selected) WRITE (*,"(/' Working on vertical integral of stress anomaly tensors....')") CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DBegin_Group DO i = 1, numel IF (selected(i)) THEN uvec(1:3) = uvec_list(1:3,i) CALL DStress_on_Sphere (uvec, azimuth(i), tau_integral(1,i), tau_integral(2,i), tau_integral(3,i), & & tau_integral_scale_Npm, tau_integral_scale_points) END IF ! selected END DO ! actually plotting integrated-stress-anomaly tensors at element centers CALL DEnd_Group DEALLOCATE ( selected ) CALL Chooser(bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Vertical Integral') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'of Stress Anomaly') CALL DStress_in_Plane (level = 1, & & x = 0.5D0*(x1_points + x2_points), & & y = y2_points - 24.0D0 - 0.5D0 * tau_integral_scale_points, & & s11 = -tau_integral_scale_Npm, & & s12 = 0.0D0, & & s22 = -tau_integral_scale_Npm, & & s33 = -tau_integral_scale_Npm, & & ref_pressure_SI = tau_integral_scale_Npm, & & ref_diameter_points = tau_integral_scale_points) number8 = ADJUSTL(DASCII8(tau_integral_scale_Npm)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.0D0 - tau_integral_scale_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8) // ' ' // TRIM(stress_integral_units)) CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 36.0D0 + tau_integral_scale_points 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 + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Vertical Integral of') CALL DL12_Text (level = 1, & & x_points = x1_points + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Stress Anomaly:') number8 = ADJUSTL(DASCII8(tau_integral_scale_Npm)) CALL DL12_Text (level = 1, & & x_points = x1_points + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = TRIM(number8) // ' ' // TRIM(stress_integral_units)) CALL DStress_in_Plane (level = 1, & & x = x1_points + 100.0D0 + 0.5D0 * tau_integral_scale_points, & & y = 0.5D0 * (y1_points + y2_points), & & s11 = -tau_integral_scale_Npm, & & s12 = 0.0D0, & & s22 = -tau_integral_scale_Npm, & & s33 = -tau_integral_scale_Npm, & & ref_pressure_SI = tau_integral_scale_Npm, & & ref_diameter_points = tau_integral_scale_points) CALL DStress_in_Plane (level = 1, & & x = x1_points + 106.0D0 + 1.5D0 * tau_integral_scale_points, & & y = 0.5D0 * (y1_points + y2_points), & & s11 = +tau_integral_scale_Npm, & & s12 = 0.0D0, & & s22 = +tau_integral_scale_Npm, & & s33 = +tau_integral_scale_Npm, & & ref_pressure_SI = tau_integral_scale_Npm, & & ref_diameter_points = tau_integral_scale_points) CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 106.0D0 + 2.0D0 * tau_integral_scale_points END IF ! bottom or right legend WRITE (*,"('+Working on vertical integral of stress anomaly tensors....DONE.')") DEALLOCATE ( uvec_list ) DEALLOCATE ( largest_axis ) DEALLOCATE ( azimuth ) DEALLOCATE ( tau_integral ) DEALLOCATE ( strainrate ) DEALLOCATE ( continuum_LRi ) DEALLOCATE ( nodes ) DEALLOCATE ( eqcm ) DEALLOCATE ( vw ) DEALLOCATE ( node_uvec ) ! end of 12: vertical integral of stress anomaly tensors CASE (13) ! most-compressive horizontal principal stress direction IF (.NOT.got_FEP) CALL Get_FEP 2130 temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file defines the elements?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN (UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) ALLOCATE ( node_uvec(3,numnod) ) 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 ( continuum_LRi(numEl) ) ALLOCATE ( selected(numel) ) ALLOCATE ( uvec_list(3,numel) ) LRn = 0 ! just initializing, before search DO i = 1, numEl READ (21, "(A)", IOSTAT = ios) longer_line problem = problem .OR. (ios /= 0) CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output continuum_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *, 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. GO TO 2130 END IF CLOSE (21) CALL Add_Title(feg_file) 2131 temp_path_in = path_in !CALL File_List( file_type = "v*.out", & ! & suggested_file = vel_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which velocity file should be used?',vel_file,vel_file) vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL DPress_Enter mt_flashby = .FALSE. GO TO 2131 END IF DO i = 1, 3 READ (22,"(A)") line CALL Add_Title(line) END DO ! first 3 lines of velocity file READ (22,*) (vw(i), i = 1, (2*numnod)) CLOSE (22) CALL DPrompt_for_Real('How long should the symbols be, in points?',s1_size_points,s1_size_points) WRITE (*,"(/' There will be ',I7,' symbols if they are not thinned.')") numel 2132 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!')") mt_flashby = .FALSE. GO TO 2132 END IF IF (stress_thinner > 1) THEN WRITE(string10,"(I10)") stress_thinner CALL Add_Title('(1/'//TRIM(ADJUSTL(string10))//') of Most-Compressive Horizontal Principal Stress Directions') ELSE ! == 1 CALL Add_Title('Most-Compressive Horizontal Principal Stress Directions') END IF WRITE (*,"(/' Working on s1h 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, stress_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(ABS(e1h),ABS(e2h)) offset_radians = DConformal_Deflation(uvec) * ((0.5*s1_size_points/2835.) & & * mp_scale_denominator) / mp_radius_meters IF (ai_using_color) THEN ! wide line of green (s-s), mid_blue (thrust), or bronze (normal) CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) IF ((err >= (e1h + 0.01D0 * (e2h - e1h))).AND. & & (err <= (e2h - 0.01D0 * (e2h - e1h)))) THEN ! e_rr is e2 CALL DSet_Stroke_Color('green_____') ! strike-slip ELSE IF (err > 0.0D0) THEN ! e_rr is e3 CALL DSet_Stroke_Color('mid_blue__') ! thrust ELSE ! e_rr is e1 CALL DSet_Stroke_Color('red_______') ! 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 ((err >= (e1h + 0.01D0 * (e2h - e1h))).AND. & ! e_rr is e2 & (err <= (e2h - 0.01D0 * (e2h - e1h)))) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'gray______') ! strike-slip stroke_this = .FALSE. ELSE IF (err > 0.0D0) THEN ! e_rr is e3 CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') ! thrust stroke_this = .FALSE. ELSE ! e_rr is e1 CALL DSet_Fill_or_Pattern(.FALSE.,'background') ! normal stroke_this = .TRUE. END IF ! different grays CALL DTurn_To (azimuth_radians = s1h_azim_radians+0.10, & & 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.10, & & 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.10, & & 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.10, & & 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 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.0D0 CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Model s1h') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20.0D0, & & angle_radians = 0.0D0, 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.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'stress regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('red_______') CALL DSet_Line_Style (width_points = 3.00D0, dashed = .FALSE.) CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-40.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0) 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.0D0, y2_points-40.0D0-1.5D0) CALL DLine_to_L12(xcp-4.0D0, y2_points-40.0D0+1.5D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0+1.5D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0-1.5D0) CALL DLine_to_L12(xcp-4.0D0, y2_points-40.0D0-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.0D0, & & angle_radians = 0.0D0, 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.0D0, y2_points-50.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-50.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-50.0D0, & & angle_radians = 0.0D0, 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.0D0, y2_points-60.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-60.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-60.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 64.0D0 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 DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Model s1h') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'direction and') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'stress regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('red_______') CALL DSet_Line_Style (width_points = 3.00D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+76.0D0, ycp+10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0) 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.0D0, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0-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+80.0D0+s1_size_points, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, 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.0D0, ycp) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp, & & angle_radians = 0.0D0, 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.0D0, ycp-10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 116.0D0 + s1_size_points END IF ! right or bottom CALL DEnd_Group ! sample s1h directions in legend WRITE (*,"(/' Working on s1h directions....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( node_uvec, & & continuum_LRi, & & nodes, & & selected, & & uvec_list, vw ) ! end of 13: sigma1h from FEM CASE (14) ! stress direction data 2140 temp_path_in = path_in !CALL File_List( file_type = "*.*" , & ! & 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) s1h_pathfile = TRIM(temp_path_in)//TRIM(s1h_file) 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') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 2140 END IF CALL DCheck_for_TABs(21) 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) CALL DPrompt_for_Integer('How many title/header lines are there?',0,s_header_lines) CALL DPrompt_for_Logical('Is there a column with stress regime (NF, SS, TF, ...)?',.TRUE.,regimes_known) CALL DPrompt_for_Logical('Are these data in (lon,lat) coordinates?',.TRUE.,lonlat) IF (lonlat) THEN CALL DPrompt_for_String('What FORMAT will extract the longitude?',stress_format1,stress_format1) CALL DPrompt_for_String('What FORMAT will extract the latitude ?',stress_format2,stress_format2) ELSE ! x,y CALL DPrompt_for_String('What FORMAT will extract the X coordinate?',stress_format1,stress_format1) CALL DPrompt_for_String('What FORMAT will extract the Y coordinate?',stress_format2,stress_format2) END IF ! lon,lat or x,y CALL DPrompt_for_String('What FORMAT will extract the s1h azimuth?',stress_format3,stress_format3) azimuth_is_integer = (SCAN(stress_format3, 'I') > 0).OR.(SCAN(stress_format3, 'i') > 0) CALL DPrompt_for_String('What FORMAT will extract the uncertainty? (Note: ' // & & 'Use an A format if the uncertainty is expressed as A-E;' // & & ' use an F format if the uncertainty is a sigma in degrees.)',& & stress_format4,stress_format4) using_A_to_E = (SCAN(stress_format4, 'A') > 0).OR.(SCAN(stress_format4, 'a') > 0) sigma_is_integer = (SCAN(stress_format4, 'I') > 0).OR.(SCAN(stress_format4, 'i') > 0) IF (regimes_known) THEN CALL DPrompt_for_String('What FORMAT will extract the stress regime?',stress_format5,stress_format5) END IF ! regimes_known ! open 2nd time to count data lines OPEN(UNIT = 21, FILE = s1h_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') s_rst_count = 0 CALL Add_Title('Stress Direction Data') DO i =1, s_header_lines READ (21, "(A)") line CALL Add_Title(line) END DO 2141 READ (21, '('//stress_format1//')', IOSTAT = ios) t IF (ios == 0) THEN s_rst_count = s_rst_count + 1 GO TO 2141 ELSE CLOSE (21) WRITE (*,"(' ',I10,' stress data were counted.')") s_rst_count END IF ! good read, or not IF (s_rst_count == 0) THEN mt_flashby = .FALSE. GO TO 2140 END IF ALLOCATE ( s_site(3, s_rst_count) ) ALLOCATE ( s_azim(s_rst_count) ) ALLOCATE ( s_sigma_(s_rst_count) ) IF (regimes_known) THEN ALLOCATE ( s_regime_c2(s_rst_count) ) END IF ! regimes_known ! open 3rd time to read data lines OPEN(UNIT = 21, FILE = s1h_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) DO i =1, s_header_lines READ (21, "(A)") line END DO recording: DO i = 1, s_rst_count READ (21, '('//stress_format1//')', IOSTAT = ios) lon problem = problem .OR. (ios /= 0) BACKSPACE (21) READ (21, '('//stress_format2//')', IOSTAT = ios) lat problem = problem .OR. (ios /= 0) BACKSPACE (21) IF (azimuth_is_integer) THEN READ (21, '('//stress_format3//')', IOSTAT = ios) n s1h_azim_degrees = n ELSE READ (21, '('//stress_format3//')', IOSTAT = ios) s1h_azim_degrees END IF problem = problem .OR. (ios /= 0) s_azim(i) = s1h_azim_degrees * radians_per_degree BACKSPACE (21) IF (using_A_to_E) THEN READ (21, '('//stress_format4//')', IOSTAT = ios) c1 IF ((c1 == 'A').OR.(c1 == 'a')) THEN ! per Zoback (1992): s.d. <= 12 s_sigma_(i) = 8.0D0 * radians_per_degree ELSE IF ((c1 == 'B').OR.(c1 == 'b')) THEN ! per Zoback (1992): 12 < s.d. <= 25 s_sigma_(i) = 18.0D0 * radians_per_degree ELSE IF ((c1 == 'C').OR.(c1 == 'c')) THEN ! (interpolated by GPB) s_sigma_(i) = 30.0D0 * radians_per_degree ELSE IF ((c1 == 'D').OR.(c1 == 'd')) THEN ! (interpolated by GPB) s_sigma_(i) = 40.0D0 * radians_per_degree ELSE ! per Zoback (1992) : s.d. > 40 s_sigma_(i) = 50.0D0 * radians_per_degree END IF ELSE IF (sigma_is_integer) THEN READ (21, '('//stress_format4//')', IOSTAT = ios) n s1h_sigma_degrees = n ELSE READ (21, '('//stress_format4//')', IOSTAT = ios) s1h_sigma_degrees END IF s_sigma_(i) = s1h_sigma_degrees * radians_per_degree END IF problem = problem .OR. (ios /= 0) IF (problem) THEN WRITE (*, "(' ERROR in reading datum #',I6,'. Reading of data stops here.')") i CALL Pause() s_rst_count = i-1 EXIT recording ELSE CALL DLonLat_2_Uvec(lon, lat, uvec) s_site(1:3,i) = uvec(1:3) END IF IF (regimes_known) THEN BACKSPACE (21) READ (21, '('//stress_format5//')', IOSTAT = ios) s_regime_c2(i) END IF ! regimes_known 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_rst_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_Fill_or_Pattern (.FALSE., 'background') radians = (0.5D0 * s1_size_points * 3.528D-4 * mp_scale_denominator) / mp_radius_meters DO i = 1, s_rst_count 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) IF (regimes_known) THEN IF (s_regime_c2(i) == "NF") THEN ! normal faulting IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') ELSE ! b/w plot CALL DSet_Stroke_Color ('background') END IF ! color or b/w ELSE IF (s_regime_c2(i) == "NS") THEN ! normal with strike-slip component IF (ai_using_color) THEN CALL DSet_Stroke_Color ('yellow____') ELSE ! b/w plot CALL DSet_Stroke_Color ('background') END IF ! color or b/w ELSE IF (s_regime_c2(i) == "SS") THEN ! strike-slip IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE ! b/w plot CALL DSet_Stroke_Color ('gray______') END IF ! color or b/w ELSE IF (s_regime_c2(i) == "TS") THEN ! thrust with strike-slip component IF (ai_using_color) THEN CALL DSet_Stroke_Color ('blue_green') ELSE ! b/w plot CALL DSet_Stroke_Color ('foreground') END IF ! color or b/w ELSE IF (s_regime_c2(i) == "TF") THEN ! thrust faulting IF (ai_using_color) THEN CALL DSet_Stroke_Color ('dark_blue_') ELSE ! b/w plot CALL DSet_Stroke_Color ('foreground') END IF ! color or b/w ELSE ! unknown regime IF (ai_using_color) THEN CALL DSet_Stroke_Color ('foreground') ELSE ! b/w plot CALL DSet_Stroke_Color ('gray______') END IF ! color or b/w END IF ! different regimes ELSE ! regimes_known = .FALSE. CALL DSet_Stroke_Color ('foreground') END IF ! regimes_known, or not IF (ai_next_line_color == "background") THEN ! if last Set_Stroke_Color ('background'), then pre-plot a slightly longer, ! fatter line in 'foreground' to make the main slash visible. CALL DSet_Stroke_Color ('foreground') ! just temporarily; to be reversed below CALL DSet_Line_Style (width_points = MAX(1.0D0, (s1_size_points / 4.0D0)), dashed = .FALSE.) CALL DTurn_To (s_azim(i), uvec, 1.2D0 * radians, & ! inputs & omega_uvec, uvec1) CALL DNew_L45_Path(5, uvec1) CALL DTurn_To (s_azim(i)+Pi, uvec, 1.2D0 * radians, & ! inputs & omega_uvec, uvec2) CALL DGreat_to_L45(uvec2) CALL DEnd_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Stroke_Color ('background') ! returning it to its initial value END IF ! pre-plotting needed (see IF above) CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.0D0)), 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.0D0, & & 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.0D0, & & angle_radians = 0.0D0, & & 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.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '90%-confidence') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 30.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'sectors, and') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 40.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'stress regime:') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 55.0D0 ! text only ! symbol part of stress-direction datum in legend; ! 90%-confidence bowtie has two 60-degree (+-30 deg.) sectors. CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (.FALSE., 'background') radius = 0.6D0 * s1_size_points xcp = (x1_points + x2_points) / 2.0D0 ycp = y2_points - radius * 0.5D0 CALL DNew_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.866D0 y0p = ycp - radius * 0.5D0 CALL DLine_to_L12 (x0p, y0p) x1p = x0p + radius * 0.5523D0 * 0.66667D0 * 0.5D0 y1p = y0p + radius * 0.5523D0 * 0.66667D0 * 0.866D0 x3p = x0p y3p = ycp + radius * 0.5D0 x2p = x1p y2p = y3p - radius * 0.5523D0 * 0.66667D0 * 0.866D0 CALL DCurve_to_L12(x1p, y1p, x2p, y2p, x3p, y3p) CALL DLine_to_L12(xcp, ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) x0p = xcp - (x0p - xcp) x1p = xcp - (x1p - xcp) x2p = x1p x3p = x0p CALL DNew_L12_Path(1, xcp, ycp) CALL DLine_to_L12 (x0p, y0p) CALL DCurve_to_L12(x1p, y1p, x2p, y2p, x3p, y3p) CALL DLine_to_L12(xcp, ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.0D0)), dashed = .FALSE.) radius = 0.5D0 * s1_size_points x0p = xcp - radius x1p = xcp + radius CALL DNew_L12_Path(1, x0p, ycp) CALL DLine_to_L12(x1p, ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + radius ! symbol only x0p = xcp - 2.0D0 * radius x1p = xcp ycp = ycp - radius ! was center of bowtie; now center of first colored line ! NF y0p = ycp IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') ! NF ELSE ! b/w plot !must pre-plot a wider stroke in 'foreground' to make the main stroke show: CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = MAX(1.0D0, (s1_size_points / 4.0D0)), dashed = .FALSE.) CALL DNew_L12_Path(1, x0p-1.0D0, y0p) CALL DLine_to_L12 (x1p+1.0D0, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Stroke_Color ('background') CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.0D0)), dashed = .FALSE.) END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! NS y0p = ycp - 8.0D0 IF (ai_using_color) THEN CALL DSet_Stroke_Color ('yellow____') ! NS ELSE ! b/w plot !must pre-plot a wider stroke in 'foreground' to make the main stroke show: CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = MAX(1.0D0, (s1_size_points / 4.0D0)), dashed = .FALSE.) CALL DNew_L12_Path(1, x0p-1.0D0, y0p) CALL DLine_to_L12 (x1p+1.0D0, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Stroke_Color ('background') CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.0D0)), dashed = .FALSE.) END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! SS y0p = ycp - 16.0D0 IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ! SS ELSE ! b/w plot CALL DSet_Stroke_Color ('gray______') END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! TS y0p = ycp - 24.0D0 IF (ai_using_color) THEN CALL DSet_Stroke_Color ('blue_green') ! TS ELSE ! b/w plot CALL DSet_Stroke_Color ('foreground') END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! TF y0p = ycp - 32.0D0 IF (ai_using_color) THEN CALL DSet_Stroke_Color ('dark_blue_') ! TF ELSE ! b/w plot CALL DSet_Stroke_Color ('foreground') END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! U y0p = ycp - 40.0D0 IF (ai_using_color) THEN CALL DSet_Stroke_Color ('foreground') ! U ELSE ! b/w plot CALL DSet_Stroke_Color ('gray______') END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! text labels: NF, NS, SS, TS, TF, U: x0p = x1p + 10.0D0 ! gap of 10 points between sample colored lines and their labels CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = ycp, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'NF') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = ycp - 8.0D0, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'NS') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = ycp - 16.0D0, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'SS') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = ycp - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'TS') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = ycp - 32.0D0, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'TF') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = ycp - 40.0D0, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'U') rightlegend_used_points = rightlegend_used_points + radius + 43.0D0 ! colored lines and their labels only CALL DEnd_Group ELSE IF (bottom) THEN ! sample paleostress in bottomlegend CALL DBegin_Group ! text part of paleostress in legend CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Actual s1h') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'direction,') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 0.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = '90%-confidence') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 10.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'sectors, and') CALL DL12_Text (level = 1, & & x_points = x1_points + 72.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 20.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'stress regime:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.0D0 ! left text block only ! symbol part of stress-direction datum 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.0D0 CALL DNew_L12_Path(1, xcp, ycp) x0p = xcp + radius * 0.5D0 y0p = ycp + radius * 0.866D0 CALL DLine_to_L12 (x0p,y0p) x1p = x0p - radius * 0.5523D0 * 0.66667D0 * 0.866D0 y1p = y0p + radius * 0.5523D0 * 0.66667D0 * 0.5D0 x3p = xcp - radius * 0.5D0 y3p = y0p x2p = x3p + radius * 0.5523D0 * 0.66667D0 * 0.866D0 y2p = y1p CALL DCurve_to_L12(x1p, y1p, x2p, y2p, x3p, y3p) CALL DLine_to_L12(xcp, ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) y0p = ycp - (y0p - ycp) y1p = ycp - (y1p - ycp) y2p = y1p y3p = y0p CALL DNew_L12_Path(1, xcp, ycp) CALL DLine_to_L12 (x0p, y0p) CALL DCurve_to_L12(x1p, y1p, x2p, y2p, x3p, y3p) CALL DLine_to_L12(xcp, ycp) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) ! end bowtie; begin symbol itself CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.0D0)), dashed = .FALSE.) radius = 0.5D0 * s1_size_points y0p = ycp - radius y1p = ycp + radius CALL DNew_L12_Path(1, xcp, y0p) CALL DLine_to_L12(xcp, y1p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + radius ! symbol only ! add colored line samples with labels: TF, TS, SS, NS, NF, U (from World Stress Map): x0p = xcp + 10.0D0 x1p = x0p + 2.0D0 * radius ! NF y0p = 0.5D0*(y1_points + y2_points) + 20.0D0 IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') ! NF ELSE ! b/w plot !must pre-plot a wider stroke in 'foreground' to make the main stroke show: CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = MAX(1.0D0, (s1_size_points / 4.0D0)), dashed = .FALSE.) CALL DNew_L12_Path(1, x0p-1.0D0, y0p) CALL DLine_to_L12 (x1p+1.0D0, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Stroke_Color ('background') CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.0D0)), dashed = .FALSE.) END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! NS y0p = 0.5D0*(y1_points + y2_points) + 12.0D0 IF (ai_using_color) THEN CALL DSet_Stroke_Color ('yellow____') ! NS ELSE ! b/w plot !must pre-plot a wider stroke in 'foreground' to make the main stroke show: CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = MAX(1.0D0, (s1_size_points / 4.0D0)), dashed = .FALSE.) CALL DNew_L12_Path(1, x0p-1.0D0, y0p) CALL DLine_to_L12 (x1p+1.0D0, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Stroke_Color ('background') CALL DSet_Line_Style (width_points = MAX(0.5D0, (s1_size_points / 8.0D0)), dashed = .FALSE.) END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! SS y0p = 0.5D0*(y1_points + y2_points) + 4.0D0 IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ! SS ELSE ! b/w plot CALL DSet_Stroke_Color ('gray______') END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! TS y0p = 0.5D0*(y1_points + y2_points) - 4.0D0 IF (ai_using_color) THEN CALL DSet_Stroke_Color ('blue_green') ! TS ELSE ! b/w plot CALL DSet_Stroke_Color ('foreground') END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! TF y0p = 0.5D0*(y1_points + y2_points) - 12.0D0 IF (ai_using_color) THEN CALL DSet_Stroke_Color ('dark_blue_') ! TF ELSE ! b/w plot CALL DSet_Stroke_Color ('foreground') END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! U y0p = 0.5D0*(y1_points + y2_points) - 20.0D0 IF (ai_using_color) THEN CALL DSet_Stroke_Color ('foreground') ! U ELSE ! b/w plot CALL DSet_Stroke_Color ('gray______') END IF ! color or b/w plot CALL DNew_L12_Path(1, x0p, y0p) CALL DLine_to_L12 (x1p, y0p) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ! text labels: NF, NS, SS, TS, TF, U: x0p = x1p + 10.0D0 ! gap of 10 points between sample colored lines and their labels CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = 0.5D0*(y1_points + y2_points) + 20.0D0, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'NF') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'NS') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = 0.5D0*(y1_points + y2_points) + 4.0D0, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'SS') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = 0.5D0*(y1_points + y2_points) - 4.0D0, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'TS') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = 0.5D0*(y1_points + y2_points) - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'TF') CALL DL12_Text (level = 1, & & x_points = x0p, & & y_points = 0.5D0*(y1_points + y2_points) - 20.0D0, & & angle_radians = 0.0D0, & & font_points = 9, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'U') bottomlegend_used_points = bottomlegend_used_points + 10.0D0 + 2.0D0 * radius + 30.0D0 ! colored lines and their labels only CALL DEnd_Group END IF ! sample stress-direction data in right or bottom legend !close up after plotting stress data IF (regimes_known) THEN DEALLOCATE ( s_regime_c2 ) END IF ! regimes_known DEALLOCATE ( s_site ) DEALLOCATE ( s_azim ) DEALLOCATE ( s_sigma_ ) WRITE (*,"('+Working on stress-direction data....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 14: stress direction data overlay CASE (15) ! external forces on nodes IF (.NOT.got_FEP) CALL Get_FEP CALL Add_Title('External Forces on Nodes') 2150 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 grid was used to compute the force balance?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL DPress_Enter READ (*, "(A)") line GO TO 2150 END IF READ (21,*) ! title READ (21,*) numnod ALLOCATE ( node_uvec(3,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) 2151 temp_path_in = path_in !CALL File_List( file_type = "f*.out", & ! & suggested_file = force_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which force file should be plotted?',force_file,force_file) force_pathfile = TRIM(temp_path_in)//TRIM(force_file) OPEN(UNIT = 22, FILE = force_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 2151 END IF DO i = 1, 3 READ (22, "(A)") line CALL Add_Title(line) END DO ! first 3 lines (titles) of force file ALLOCATE ( fg(2*numnod) ) ALLOCATE ( f_size(numnod) ) READ (22,*) (fg(i), i = 1, (2*numnod)) DO i = 1, numnod f_South = fg(2*i-1) f_East = fg(2*i) f_size(i) = DSQRT(f_South**2 + f_East**2) END DO ! i = 1, numnod CLOSE(22) WRITE (*,"(/' Here is the distribution of force magnitudes:')") CALL Histogram (f_size, numnod, .FALSE., maximum, minimum) CALL DPrompt_for_String('What are the units of these forces?',force_units,force_units) IF (force_scale_N == 0.0D0) force_scale_N = 0.5D0 * maximum 2152 CALL DPrompt_for_Real('How large a sample force should be shown in the margin?',force_scale_N,force_scale_N) IF (force_scale_N <= 0.0D0) THEN WRITE (*,"(' Error: Please enter a positive real number.')") force_scale_N = 3.0D+18 mt_flashby = .FALSE. GO TO 2152 END IF ! non-positive force_scale_N CALL DPrompt_for_Real('How long (in points) should this vector be plotted?',force_scale_points,force_scale_points) WRITE (*,"(/' Working on external forces on nodes....')") !note: product of pseudotime * f_size(i) ! must be a distance in map-plane meters; ! so pseudotime is in meters/N: pseudotime = mp_meters_per_point * force_scale_points / force_scale_N CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DBegin_Group DO i = 1, numnod uvec1(1:3) = node_uvec(1:3,i) f_South = fg(2*i-1) f_East = fg(2*i) !NOTE: Skip any force vectors whose size is less than 1.0D-7 * maximum; ! otherwise, these will cause trouble in DProcess_L4_Paths, where their ! incredibly small lengths will cause some of them to be plotted as great circles! ! (Note: This became a problem starting with SHELLS_v4.0 and Tuned_SHELLS, ! whose remarkable new precision caused the range in nodal force vectors ! to span 16 orders of magnitude within one solution!) ! It is possible that even 1.0D-7 is too small; if there is trouble with force ! vectors in the future, this arbitrary cut-off could be raised further (e.g., 1.0D-5?). IF (f_size(i) > (1.0D-7 * maximum)) THEN CALL DVelocity_Vector_on_Sphere (from_uvec = uvec1, & & v_theta_mps = f_South, v_phi_mps = f_East, & & dt_sec = pseudotime, deflate = .TRUE.) END IF END DO ! actually plotting force vectors CALL DEnd_Group 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') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'External Force') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'on Nodes:') IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5D0*(x1_points+x2_points)-0.5D0*force_scale_points, from_y = y2_points - 33.0D0, & & to_x = 0.5D0*(x1_points+x2_points)+0.5D0*force_scale_points, to_y = y2_points - 33.0D0) IF (ai_using_color) CALL DSet_Stroke_Color ('foreground') number8 = ADJUSTL(DASCII8(force_scale_N)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 36.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8) // ' ' // TRIM(force_units)) CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 48.0D0 ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'External Force') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'on Nodes:') IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.0D0)-0.5D0*force_scale_points, from_y = 0.5D0*(y1_points+y2_points)-10.0D0, & & to_x = (x1_points+29.0D0)+0.5D0*force_scale_points, to_y = 0.5D0*(y1_points+y2_points)-10.0D0) IF (ai_using_color) CALL DSet_Stroke_Color ('foreground') number8 = ADJUSTL(DASCII8(force_scale_N)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8) // ' ' // TRIM(force_units)) CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58.0D0 END IF ! right or bottom legend WRITE (*,"('+Working on external forces on nodes....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( f_size, fg, node_uvec) ! LIFO order ! end of 15: net external force on nodes CASE (16) ! earthquake epicenters and/or FPS from EarthQuake Catalog .cat file 2160 WRITE (*,"(/' This plot requires an EarthQuake Catalog (.eqc) file.')") 2161 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 2161 END IF CALL Add_Title (old_eqc_file) !scan for any fault plane solutions any_FPS = .FALSE. scanning_eqc: DO READ (22, 2162, 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 2162 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.')") 2163 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 2163 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', & & PAD = 'YES') ! padding required because FPS may or may not be present CALL DSet_Line_Style (0.6D0, .FALSE.) CALL DBegin_Group rereading_eqc: DO READ (22, 2162, 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 (within current outer group) ! (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 DMap_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 FiniteMap 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 DMap_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 (but we are still inside one larger group) 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 (frequency = 440, duration = 250) ! end of 16: earthquake epicenters from Seismicity .eqc file CASE (17) ! volcanoes 2170 temp_path_in = path_in !CALL File_List( file_type = "*.*", & ! & suggested_file = volcano_file, & ! & using_path = temp_path_in) 2171 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 2171 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 ! end of 17: volcanoes CASE (18) ! velocity vectors from plate model, with velocity-in-mm/a (integer) annotations CALL Add_Title("Velocities from Plate Model") 2180 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 2180 !get plate outlines (for deciding which plate a point is in) 2181 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) 2182 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 (*, "( ' ----------------------------------------------------------------')") 2183 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 2183 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')") 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 (*, "( ' ---------------------------------------------------------------')") 2184 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 2184 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 IF (.NOT.got_FEP) CALL Get_FEP 2185 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 2185 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: 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.0D0 - 20.0D0) * 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.0D0 + 20.0D0) * 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: 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 (frequency = 440, duration = 250) ! end of 18: velocity vectors from plate model CASE (19) ! Euler poles from plate model CALL Add_Title("Euler Poles of Plate Model") 2190 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 2190 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.0D0, & & 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.0D0, & & angle_radians = 0.0D0, & & 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.0D0, & & 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.0D0, & & radius = small_circle_radius_points, stroke = .FALSE., fill = .TRUE.) CALL DEnd_Group() rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 48.0D0 ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group() CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = "Euler Pole:") number8 = ADJUSTL(DASCII8(velocity_Ma)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = "CO-PA") CALL DCircle_on_L12 (level = 1, x = x1_points+29.0D0, y = 0.5D0*(y1_points+y2_points)-13.0D0, & & radius = large_circle_radius_points, stroke = .TRUE., fill = .FALSE.) CALL DCircle_on_L12 (level = 1, x = x1_points+29.0D0, y = 0.5D0*(y1_points+y2_points)-13.0D0, & & radius = small_circle_radius_points, stroke = .FALSE., fill = .TRUE.) CALL DEnd_Group() bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58.0D0 END IF ! bottom or right legend WRITE (*,"( '+Working on Euler poles of adjacent plates in plate model....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of 19: Euler poles from plate model CASE (20) ! boundary heave rates from plate model CALL Add_Title("Boundary Heave-Rates from Plate Model") 2200 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 2200 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 heave-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: 2201 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,2201)i, c1,c5, lon1, lat1, lon2, lat2, long, azim, veloc, v_az, spread, dextral, elev, age, c1a,class,star IF (ios /= 0) CALL Could_Not_Find_File(steps_dat_pathfile) !read through once to count steps which are NOT annotated with * for orogen-of-distributed step_count = 0 DO READ (21, 2201, IOSTAT = ios) i, c1,c5, lon1, lat1, lon2, lat2, long, azim, veloc, v_az, spread, dextral, elev, age, c1a,class,star IF (ios /= 0) EXIT IF (star /= '*') step_count = step_count + 1 END DO CLOSE(21) ALLOCATE ( slipnumbers(2, step_count) ) ALLOCATE ( plot_at_uvec(3, step_count) ) ALLOCATE ( up_azim_rads(step_count) ) OPEN(UNIT = 21, FILE = steps_dat_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') CALL 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, 2201, IOSTAT = ios) i, c1,c5, lon1, lat1, lon2, lat2, long, azim, veloc, v_az, spread, dextral, elev, age, c1a,class,star IF (ios /= 0) EXIT reading_steps IF (star /= '*') THEN step_count = step_count + 1 CALL 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.0D0 ! store for plotting #s later! ELSE up_azim_rads(step_count) = f_azim_rads_c + Pi / 2.0D0 !(ditto) END IF offset_radians = velocity_Ma * MAX(ABS(slipnumbers(1,step_count)),ABS(slipnumbers(2,step_count))) * 500.0D0 / 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 (ABS(slipnumbers(1,step_count)) > ABS(slipnumbers(2,step_count))) THEN n1 = 1; n2 = 2; d_n = 1 ! do strike-slip first ELSE ! component 2 is bigger than component 1; plot #2 first n1 = 2; n2 = 1; d_n = -1 ! do dip-slip first END IF DO n = n1, n2, d_n IF (ai_using_color) THEN IF (n == 2) THEN ! spreading/convergence component IF (spread > 0.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 * ABS(slipnumbers(n, step_count)) * 1000.0D0 / mp_radius_meters !construct parallelogram using v_az information (so adjacent boxes will connect): IF (ABS(slipnumbers(2, step_count)) > ABS(slipnumbers(1, step_count))) THEN ! dip-slip is the main mode az_radians = v_az * radians_per_degree ELSE ! strike-slip is the main mode az_radians = (v_az + 90) * radians_per_degree END IF CALL DTurn_To (azimuth_radians = az_radians, & & base_uvec = uvec1, far_radians = width_radians / 2.0D0, & ! 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.0D0, & ! 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.0D0, & ! 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.0D0, & ! 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 if they are not thinned.')") visible_labels 2202 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 2202 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 (ABS(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 heave rates ! how fast is a 20-point band, in mm/a? sliprate1 = (((20.0D0/2834.0D0)/1000.0D0)*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.0D0 CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, 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.0D0, 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.0D0, 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.0D0, 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.0D0, & & color_name = 'bronze____', text = 'normal') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-67.0D0, & & color_name = 'mid_blue__', text = 'thrust') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-102.0D0, & & color_name = 'green_____', text = 'dextral') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-137.0D0, & & color_name = 'brown_____', text = 'sinistral') ELSE ! b/w CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-32.0D0, & & color_name = 'gray______', text = 'normal') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-67.0D0, & & color_name = 'gray______', text = 'thrust') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-102.0D0, & & color_name = 'foreground', text = 'dextral') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-137.0D0, & & color_name = 'foreground', text = 'sinistral') END IF ! color or b/w rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 137.0D0 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.0D0, 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.0D0, 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.0D0, 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.0D0 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.0D0, & & y_points = ycp+10.0D0, 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.0D0, & & 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.0D0, & & y_points = ycp-10.0D0, 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.0D0 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.0D0, & & y_points = ycp+12.0D0, 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.0D0, & & y_points = ycp+12.0D0, 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.0D0, & & y_points = ycp+12.0D0, 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.0D0, & & y_points = ycp+12.0D0, 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.0D0, y_base_points = ycp-10.0D0, & & color_name = 'bronze____', text = 'normal') CALL Slip_Sample(x_center_points = x1_points+108.0D0, y_base_points = ycp-10.0D0, & & color_name = 'mid_blue__', text = 'thrust') CALL Slip_Sample(x_center_points = x1_points+180.0D0, y_base_points = ycp-10.0D0, & & color_name = 'green_____', text = 'dextral') CALL Slip_Sample(x_center_points = x1_points+252.0D0, y_base_points = ycp-10.0D0, & & color_name = 'brown_____', text = 'sinistral') ELSE ! b/w CALL Slip_Sample(x_center_points = x1_points+36.0D0, y_base_points = ycp-10.0D0, & & color_name = 'gray______', text = 'normal') CALL Slip_Sample(x_center_points = x1_points+108.0D0, y_base_points = ycp-10.0D0, & & color_name = 'gray______', text = 'thrust') CALL Slip_Sample(x_center_points = x1_points+180.0D0, y_base_points = ycp-10.0D0, & & color_name = 'foreground', text = 'dextral') CALL Slip_Sample(x_center_points = x1_points+252.0D0, y_base_points = ycp-10.0D0, & & color_name = 'foreground', text = 'sinistral') END IF ! color or b/w bottomlegend_used_points = bottomlegend_used_points + 288.0D0 END IF ! right or bottom CALL DEnd_Group ! sample sliprates CALL BEEPQQ (frequency = 440, duration = 250) ! end of (20) boundary slip raes from plate model CASE (21) ! boundary lines from plate model, in color(?) CALL Add_Title("Boundary Lines from Plate Model") 2210 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 2210 steps_dat_pathfile = TRIM(path_in) // TRIM(steps_dat_file) WRITE (*,"(/' Working on boundary lines 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: 2211 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,2211)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) CALL DBegin_Group ! of colored(?) boundary lines CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) IF (.NOT.ai_using_color) CALL DSet_Stroke_Color('foreground') first_pass = .TRUE. DO READ (21, 2201, 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 (c1a == ':') THEN ! (note: should not happen on first line of file) !this step is same line type and color as previous step; join them CALL DGreat_To_L67 (lon2, lat2) ! intentionally leaving it open for possible continuation ELSE ! this step begins a new color IF (.NOT.first_pass) CALL DEnd_L67_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) IF (ai_using_color) THEN ! else, left as 'foreground' SELECT CASE (class) CASE ('CCB') CALL DSet_Stroke_Color('gray______') CASE ('CTF') CALL DSet_Stroke_Color('brown_____') CASE ('CRB') CALL DSet_Stroke_Color('yellow____') CASE ('OSR') CALL DSet_Stroke_Color('red_______') CASE ('OTF') CALL DSet_Stroke_Color('green_____') CASE ('OCB') CALL DSet_Stroke_Color('magenta___') CASE ('SUB') CALL DSet_Stroke_Color('mid_blue__') END SELECT END IF CALL DNew_L67_Path (7, lon1, lat1) CALL DGreat_To_L67 (lon2, lat2) ! intentionally leaving it open for possible continuation END IF first_pass = .FALSE. END DO IF (.NOT.first_pass) CALL DEnd_L67_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CLOSE(21) CALL DEnd_Group ! of colored(?) boundary lines CALL Chooser (bottom, right) CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') CALL DBegin_Group ! sample sliprates CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) 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.0D0 xt = 0.8D0 * x1_points + 0.2D0 * xcp IF (ai_using_color) THEN ! give 7 sample lines rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points !CCB CALL DSet_Stroke_Color('gray______') CALL DNew_L12_Path(1, xt, y2_points-10.0D0) CALL DLine_To_L12 (xcp, y2_points-10.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "CCB") rightlegend_used_points = rightlegend_used_points + 10.0D0 !CTF CALL DSet_Stroke_Color('brown_____') CALL DNew_L12_Path(1, xt, y2_points-20.0D0) CALL DLine_To_L12 (xcp, y2_points-20.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "CTF") rightlegend_used_points = rightlegend_used_points + 10.0D0 !CRB CALL DSet_Stroke_Color('yellow____') CALL DNew_L12_Path(1, xt, y2_points-30.0D0) CALL DLine_To_L12 (xcp, y2_points-30.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-30.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "CRB") rightlegend_used_points = rightlegend_used_points + 10.0D0 !OSR CALL DSet_Stroke_Color('red_______') CALL DNew_L12_Path(1, xt, y2_points-40.0D0) CALL DLine_To_L12 (xcp, y2_points-40.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-40.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "OSR") rightlegend_used_points = rightlegend_used_points + 10.0D0 !OTF CALL DSet_Stroke_Color('green_____') CALL DNew_L12_Path(1, xt, y2_points-50.0D0) CALL DLine_To_L12 (xcp, y2_points-50.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-50.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "OTF") rightlegend_used_points = rightlegend_used_points + 10.0D0 !OCB CALL DSet_Stroke_Color('magenta___') CALL DNew_L12_Path(1, xt, y2_points-60.0D0) CALL DLine_To_L12 (xcp, y2_points-60.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-60.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "OCB") rightlegend_used_points = rightlegend_used_points + 10.0D0 !SUB CALL DSet_Stroke_Color('mid_blue__') CALL DNew_L12_Path(1, xt, y2_points-70.0D0) CALL DLine_To_L12 (xcp, y2_points-70.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-70.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "SUB") rightlegend_used_points = rightlegend_used_points + 10.0D0 ELSE ! .NOT.using_color; give 1 sample line CALL DSet_Stroke_Color('foreground') CALL DNew_L12_Path(1, xt, y2_points-10.0D0) CALL DLine_To_L12 (xcp, y2_points-10.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "plate") CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = -0.1D0, ud_fraction = 0.4D0, & & text = "boundary") rightlegend_used_points = rightlegend_used_points + 20.0D0 + rightlegend_gap_points END IF 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 bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points IF (ai_using_color) THEN ! give 7 sample lines xp1 = x1_points + 36.0D0 xp2 = x1_points + 72.0D0 xp3 = x1_points + 108.0D0 !CCB CALL DSet_Stroke_Color('gray______') CALL DNew_L12_Path(1, x1_points, ycp-6.0D0) CALL DLine_To_L12 (xp1, ycp-6.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xp1, & & y_points = ycp-6.0D0, angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "CCB") !CTF CALL DSet_Stroke_Color('brown_____') CALL DNew_L12_Path(1, x1_points, ycp+6.0D0) CALL DLine_To_L12 (xp1, ycp+6.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xp1, & & y_points = ycp+6.0D0, angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "CTF") !CRB CALL DSet_Stroke_Color('yellow____') CALL DNew_L12_Path(1, x1_points, ycp+18.0D0) CALL DLine_To_L12 (xp1, ycp+18.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xp1, & & y_points = ycp+18.0D0, angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "CRB") !OSR CALL DSet_Stroke_Color('red_______') CALL DNew_L12_Path(1, xp2, ycp+18.0D0) CALL DLine_To_L12 (xp3, ycp+18.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xp3, & & y_points = ycp+18.0D0, angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "OSR") !OTF CALL DSet_Stroke_Color('green_____') CALL DNew_L12_Path(1, xp2, ycp+6.0D0) CALL DLine_To_L12 (xp3, ycp+6.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xp3, & & y_points = ycp+6.0D0, angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "OTF") !OCB CALL DSet_Stroke_Color('magenta___') CALL DNew_L12_Path(1, xp2, ycp-6.0D0) CALL DLine_To_L12 (xp3, ycp-6.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xp3, & & y_points = ycp-6.0D0, angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "OCB") !SUB CALL DSet_Stroke_Color('mid_blue__') CALL DNew_L12_Path(1, xp1, ycp-18.0D0) CALL DLine_To_L12 (xp2, ycp-18.0D0) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xp2, & & y_points = ycp-18.0D0, angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "SUB") bottomlegend_used_points = bottomlegend_used_points + 144.0D0 ELSE ! .NOT.using_color; give 1 sample line CALL DSet_Stroke_Color('foreground') CALL DNew_L12_Path(1, x1_points, ycp) CALL DLine_To_L12 (x1_points + 36.0D0, ycp) CALL DEnd_L12_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+36.0, & & y_points = ycp, angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = -0.1D0, ud_fraction = 0.3D0, & & text = "plate") CALL DL12_Text (level = 1, x_points = x1_points+36.0D0, & & y_points = ycp-12.0D0, angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = -0.1D0, ud_fraction = 0.4D0, & & text = "boundary") bottomlegend_used_points = bottomlegend_used_points + 72.0D0 END IF END IF ! right or bottom CALL DEnd_Group ! sample sliprates CALL BEEPQQ (frequency = 440, duration = 250) ! end of (21) boundary lines from plate model, in color(?) CASE (22) ! balance of plate-driving/resisting forces on each plate 2220 IF (.NOT.got_FEP) CALL Get_FEP IF (FEP /= "SHELLS") THEN WRITE (*,"(/' Sorry. This overlay only available for SHELLS models.')") CALL Pause() GO TO 2999 END IF 2221 temp_path_in = path_in !CALL File_List( file_type = "q*.out", & ! & suggested_file = torque_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which file reported the plate-driving torques?',torque_file,torque_file) CALL Add_Title(torque_file) torque_pathfile = TRIM(temp_path_in)//TRIM(torque_file) OPEN(UNIT = 21, FILE = torque_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL Pause() GO TO 2221 END IF DO i = 1, 3 READ (21, "(A)") line CALL Add_Title(line) END DO ! first 3 lines (titles) of torque file READ (21,*) ! blank line READ (21,*) ! blank line line = ' ' READ (21, "(46X,A)") line(1:38) ! " (FFRIC 0.150, TAUMAX 2.5E+12\2.5E+12)" CALL Add_Title("Balance of Plate-Driving/Resisting Forces" // TRIM(line)) ALLOCATE ( balance_point_uvec(3, nPlates) ) ALLOCATE ( point_force_magnitude(3,nPlates) ) ALLOCATE ( f_size(3*nPlates) ) ALLOCATE ( point_force_azimuth (3,nPlates) ) ALLOCATE ( plate_center_uvec(3, nPlates) ) plate_count = 0 ! just initializing before loop plate_counting: DO DO j = 1, 27 ! waste 27 lines; when file ends, these READ's should fail. READ (21, *, IOSTAT = ios) IF (ios == -1) EXIT plate_counting ! EOF END DO plate_count = plate_count + 1 READ (21, "(79X,F7.2,2X,F6.2)") lon, lat CALL DLonLat_2_Uvec(lon, lat, uvec) balance_point_uvec(1:3, plate_count) = uvec(1:3) DO j = 1, 5 ! waste 5 lines. READ (21, *, IOSTAT = ios) IF (ios == -1) EXIT plate_counting ! EOF END DO READ (21, "(56X,E10.3,F10.1)") point_force_magnitude(1, plate_count), point_force_azimuth(1, plate_count) ! LP = lithostatic-pressure READ (21, "(56X,E10.3,F10.1)") point_force_magnitude(2, plate_count), point_force_azimuth(2, plate_count) ! SS = side-strength READ (21, "(56X,E10.3,F10.1)") point_force_magnitude(3, plate_count), point_force_azimuth(3, plate_count) ! BS = basal-strength f_size(3 * plate_count - 2) = point_force_magnitude(1, plate_count) f_size(3 * plate_count - 1) = point_force_magnitude(2, plate_count) f_size(3 * plate_count ) = point_force_magnitude(3, plate_count) DO j = 1, 2 ! waste 2 lines. READ (21, *, IOSTAT = ios) IF (ios == -1) EXIT plate_counting ! EOF END DO READ (21, "(40X,F7.2,2X,F6.2)") lon, lat CALL DLonLat_2_Uvec(lon, lat, uvec) plate_center_uvec(1:3, plate_count) = uvec(1:3) READ (21, *, IOSTAT = ios) IF (ios == -1) EXIT plate_counting ! EOF END DO plate_counting CLOSE(21) plate_count_times_3 = plate_count * 3 WRITE (*,"(/' Here is the distribution of force magnitudes:')") CALL Histogram (f_size, plate_count_times_3, .FALSE., maximum, minimum) CALL DPrompt_for_String('What are the units of these forces?',force_units,force_units) IF (force_scale_N == 0.0D0) force_scale_N = 0.5D0 * maximum 2222 CALL DPrompt_for_Real('How large a sample force should be shown in the margin?',force_scale_N,force_scale_N) IF (force_scale_N <= 0.0D0) THEN WRITE (*,"(' Error: Please enter a positive real number.')") force_scale_N = 3.0D+19 mt_flashby = .FALSE. GO TO 2222 END IF ! non-positive force_scale_N CALL DPrompt_for_Real('How long (in points) should this vector be plotted?',force_scale_points,force_scale_points) WRITE (*,"(/' Working on plate-driving/resisting forces....')") !note: product of pseudotime * point_force_magnitude(1~3, iPlate) ! must be a distance in map-plane meters; ! so pseudotime is in meters/N: pseudotime = mp_meters_per_point * force_scale_points / force_scale_N CALL DBegin_Group ! whole set of <52 force triplets DO i = 1, plate_count CALL DBegin_Group ! force triplet for one plate !tie line from balance point to plate center CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) uvec(1:3) = balance_point_uvec(1:3, i) CALL DNew_L45_Path (level = 5, uvec = uvec) uvec(1:3) = plate_center_uvec(1:3, i) CALL DGreat_To_L45 (to_uvec = uvec) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) !SS = side-strength force CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF uvec(1:3) = balance_point_uvec(1:3,i) f_South = point_force_magnitude(2, i) * DCOS((point_force_azimuth(2, i) - 180.0D0) / 57.296D0) f_East = point_force_magnitude(2, i) * DSIN((180.0D0 - point_force_azimuth(2, i)) / 57.296D0) CALL DVelocity_Vector_on_Sphere (from_uvec = uvec, & & v_theta_mps = f_South, v_phi_mps = f_East, & & dt_sec = pseudotime, deflate = .TRUE.) !BS = basal-strength force CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') ELSE CALL DSet_Stroke_Color ('foreground') END IF uvec(1:3) = balance_point_uvec(1:3,i) f_South = point_force_magnitude(3, i) * DCOS((point_force_azimuth(3, i) - 180.0D0) / 57.296D0) f_East = point_force_magnitude(3, i) * DSIN((180.0D0 - point_force_azimuth(3, i)) / 57.296D0) CALL DVelocity_Vector_on_Sphere (from_uvec = uvec, & & v_theta_mps = f_South, v_phi_mps = f_East, & & dt_sec = pseudotime, deflate = .TRUE.) !LP = lithostatic-pressure force (plotted last, so it is on top and VISIBLE!) CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color ('dark_blue_') ELSE CALL DSet_Stroke_Color ('foreground') END IF uvec(1:3) = balance_point_uvec(1:3,i) f_South = point_force_magnitude(1, i) * DCOS((point_force_azimuth(1, i) - 180.0D0) / 57.296D0) f_East = point_force_magnitude(1, i) * DSIN((180.0D0 - point_force_azimuth(1, i)) / 57.296D0) CALL DVelocity_Vector_on_Sphere (from_uvec = uvec, & & v_theta_mps = f_South, v_phi_mps = f_East, & & dt_sec = pseudotime, deflate = .TRUE.) CALL DEnd_Group ! force triplet for one plate END DO ! i = 1, plate_count CALL DEnd_Group ! whole set of <52 force triplets CALL Chooser(bottom, right) IF (right) THEN CALL DBegin_Group !LP = lithostatic-pressure force (blue): CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Lithostatic') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '-Pressure:') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Force:') IF (ai_using_color) THEN CALL DSet_Stroke_Color ('dark_blue_') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5D0*(x1_points+x2_points)-0.5D0*force_scale_points, from_y = y2_points - 45.0D0, & & to_x = 0.5D0*(x1_points+x2_points)+0.5D0*force_scale_points, to_y = y2_points - 45.0D0) IF (ai_using_color) CALL DSet_Stroke_Color ('foreground') number8 = ADJUSTL(DASCII8(force_scale_N)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 48.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8) // ' ' // TRIM(force_units)) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 60.0D0 !SS = side-strength force (green): CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Side-') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Strength') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Force:') IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5D0*(x1_points+x2_points)-0.5D0*force_scale_points, from_y = y2_points - 45.0D0, & & to_x = 0.5D0*(x1_points+x2_points)+0.5D0*force_scale_points, to_y = y2_points - 45.0D0) IF (ai_using_color) CALL DSet_Stroke_Color ('foreground') number8 = ADJUSTL(DASCII8(force_scale_N)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 48.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8) // ' ' // TRIM(force_units)) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 60.0D0 !BS = basal-strength force (red): CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Basal-') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Strength') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Force:') IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5D0*(x1_points+x2_points)-0.5D0*force_scale_points, from_y = y2_points - 45.0D0, & & to_x = 0.5D0*(x1_points+x2_points)+0.5D0*force_scale_points, to_y = y2_points - 45.0D0) IF (ai_using_color) CALL DSet_Stroke_Color ('foreground') number8 = ADJUSTL(DASCII8(force_scale_N)) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 48.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8) // ' ' // TRIM(force_units)) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 60.0D0 CALL DEnd_Group ELSE IF (bottom) THEN CALL DBegin_Group !LP = lithostatic-pressure force (blue): 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 + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Lithostatic-') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Pressure Force') IF (ai_using_color) THEN CALL DSet_Stroke_Color ('dark_blue_') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.0D0)-0.5D0*force_scale_points, from_y = 0.5D0*(y1_points+y2_points)-10.0D0, & & to_x = (x1_points+29.0D0)+0.5D0*force_scale_points, to_y = 0.5D0*(y1_points+y2_points)-10.0D0) IF (ai_using_color) CALL DSet_Stroke_Color ('foreground') number8 = ADJUSTL(DASCII8(force_scale_N)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8) // ' ' // TRIM(force_units)) bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 64.0D0 !SS = side-strength force (green): 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 + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Side-Strength') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Force') IF (ai_using_color) THEN CALL DSet_Stroke_Color ('green_____') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.0D0)-0.5D0*force_scale_points, from_y = 0.5D0*(y1_points+y2_points)-10.0D0, & & to_x = (x1_points+29.0D0)+0.5D0*force_scale_points, to_y = 0.5D0*(y1_points+y2_points)-10.0D0) IF (ai_using_color) CALL DSet_Stroke_Color ('foreground') number8 = ADJUSTL(DASCII8(force_scale_N)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8) // ' ' // TRIM(force_units)) bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 64.0D0 !BS = basal-strength force (red): 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 + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Basal-Strength') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Force') IF (ai_using_color) THEN CALL DSet_Stroke_Color ('red_______') ELSE CALL DSet_Stroke_Color ('foreground') END IF CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.0D0)-0.5D0*force_scale_points, from_y = 0.5D0*(y1_points+y2_points)-10.0D0, & & to_x = (x1_points+29.0D0)+0.5D0*force_scale_points, to_y = 0.5D0*(y1_points+y2_points)-10.0D0) IF (ai_using_color) CALL DSet_Stroke_Color ('foreground') number8 = ADJUSTL(DASCII8(force_scale_N)) CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8) // ' ' // TRIM(force_units)) bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 64.0D0 CALL DEnd_Group END IF ! right or bottom legend WRITE (*,"('+Working on plate-driving/resisting forces....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( plate_center_uvec ) ! LIFO order DEALLOCATE ( point_force_azimuth ) ! LIFO order DEALLOCATE ( f_size ) ! LIFO order DEALLOCATE ( point_force_magnitude ) ! LIFO order DEALLOCATE ( balance_point_uvec ) ! LIFO order ! end of 22: balance of plate-driving/resisting forces on each plate CASE (23) ! seafloor-spreading rates 2230 temp_path_in = path_in !CALL File_List( file_type = "*.*" , & ! & suggested_file = spreading_rate_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which is the seafloor-spreading dataset that should be plotted?',spreading_rate_file,spreading_rate_file) spreading_rate_pathfile = TRIM(temp_path_in)//TRIM(spreading_rate_file) CALL Add_Title(spreading_rate_file) ! open 1st time for a view (headers, formats) OPEN(UNIT = 21, FILE = spreading_rate_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 2230 END IF CALL DCheck_for_TABs(21) 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) CALL DPrompt_for_Integer('How many title/header lines are there?',0,spreading_header_lines) CALL DPrompt_for_Logical('Are these data in (lon,lat) coordinates?',.TRUE.,lonlat) IF (lonlat) THEN CALL DPrompt_for_String('What FORMAT will extract the longitude?',spreading_format1,spreading_format1) CALL DPrompt_for_String('What FORMAT will extract the latitude ?',spreading_format2,spreading_format2) ELSE ! x,y CALL DPrompt_for_String('What FORMAT will extract the X coordinate?',spreading_format1,spreading_format1) CALL DPrompt_for_String('What FORMAT will extract the Y coordinate?',spreading_format2,spreading_format2) END IF ! lon,lat or x,y CALL DPrompt_for_String('What FORMAT will extract the spreading-rate in mm/a?',spreading_format3,spreading_format3) spreading_rate_is_integer = (SCAN(spreading_format3, 'I') > 0).OR.(SCAN(spreading_format3, 'i') > 0) CALL DPrompt_for_String('What FORMAT will extract the azimuth? (Note: ' // & & 'Use an A format if the azimuth is expressed as N78E;' // & & ' use an I or F format if the azimuth is in degrees, 0~360.)',& & spreading_format4,spreading_format4) using_quadrants = (SCAN(spreading_format4, 'A') > 0).OR.(SCAN(spreading_format4, 'a') > 0) azimuth_is_integer = ((.NOT.using_quadrants).AND.(SCAN(spreading_format4, 'I') > 0).OR.(SCAN(spreading_format4, 'i') > 0)) azimuth_is_real = ((.NOT.using_quadrants).AND.(SCAN(spreading_format4, 'F') > 0).OR.(SCAN(spreading_format4, 'f') > 0)) ! open 2nd time to count data lines OPEN(UNIT = 21, FILE = spreading_rate_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') spreading_rate_count = 0 CALL Add_Title('Seafloor Spreading Rates') DO i =1, spreading_header_lines READ (21, "(A)") line CALL Add_Title(line) END DO 2231 READ (21, '('//spreading_format1//')', IOSTAT = ios) t ! trying to read the longitude IF (ios == 0) THEN spreading_rate_count = spreading_rate_count + 1 GO TO 2231 ELSE CLOSE (21) WRITE (*,"(' ',I10,' spreading-rate data were counted.')") spreading_rate_count END IF ! good read, or not IF (spreading_rate_count == 0) THEN mt_flashby = .FALSE. GO TO 2230 END IF ALLOCATE ( spreading_site(3, spreading_rate_count) ) ALLOCATE ( spreading_rate (spreading_rate_count) ) ALLOCATE ( spreading_azim (spreading_rate_count) ) ! open 3rd time to read data lines OPEN(UNIT = 21, FILE = spreading_rate_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) DO i =1, spreading_header_lines READ (21, "(A)") line END DO record_spreading: DO i = 1, spreading_rate_count READ (21, '('//spreading_format1//')', IOSTAT = ios) lon problem = problem .OR. (ios /= 0) BACKSPACE (21) READ (21, '('//spreading_format2//')', IOSTAT = ios) lat problem = problem .OR. (ios /= 0) BACKSPACE (21) IF (spreading_rate_is_integer) THEN READ (21, '('//spreading_format3//', IOSTAT = ios)', IOSTAT = ios) n problem = problem .OR. (ios /= 0) spreading_rate_mmpa = n ELSE READ (21, '('//spreading_format3//')', IOSTAT = ios) spreading_rate_mmpa problem = problem .OR. (ios /= 0) END IF BACKSPACE (21) IF (azimuth_is_integer) THEN READ (21, '('//spreading_format4//')', IOSTAT = ios) n problem = problem .OR. (ios /= 0) spreading_azim_degrees = n ELSE IF (azimuth_is_real) THEN READ (21, '('//spreading_format4//')', IOSTAT = ios) spreading_azim_degrees problem = problem .OR. (ios /= 0) ELSE IF (using_quadrants) THEN READ (21, '('//spreading_format4//')', IOSTAT = ios) quadrant_bearing_c8 problem = problem .OR. (ios /= 0) north_q = .FALSE. east_q = .FALSE. south_q = .FALSE. west_q = .FALSE. quadrant_bearing_c8_saved = quadrant_bearing_c8 !look for North: k = SCAN(quadrant_bearing_c8, "Nn") IF (k > 0) THEN north_q = .TRUE. quadrant_bearing_c8(k:k) = ' ' END IF !look for East: k = SCAN(quadrant_bearing_c8, "Ee") IF (k > 0) THEN east_q = .TRUE. quadrant_bearing_c8(k:k) = ' ' END IF !look for South: k = SCAN(quadrant_bearing_c8, "Ss") IF (k > 0) THEN south_q = .TRUE. quadrant_bearing_c8(k:k) = ' ' END IF !look for West: k = SCAN(quadrant_bearing_c8, "Ww") IF (k > 0) THEN west_q = .TRUE. quadrant_bearing_c8(k:k) = ' ' END IF READ (quadrant_bearing_c8, *, IOSTAT = ios) spreading_azim_degrees problem = problem .OR. (ios /= 0) IF (north_q) THEN IF (east_q) THEN !no correction necessary ELSE IF (west_q) THEN spreading_azim_degrees = 360.0D0 - spreading_azim_degrees ELSE ! shouldn't happen WRITE (*, "(' ERROR: Cannot interpret quadrant-based azimuth: ',A)") quadrant_bearing_c8_saved CALL Pause() STOP END IF ELSE IF (south_q) THEN IF (east_q) THEN spreading_azim_degrees = 180.0D0 - spreading_azim_degrees ELSE IF (west_q) THEN spreading_azim_degrees = 180.0D0 + spreading_azim_degrees ELSE ! shouldn't happen WRITE (*, "(' ERROR: Cannot interpret quadrant-based azimuth: ',A)") quadrant_bearing_c8_saved CALL Pause() STOP END IF ELSE ! shouldn't happen WRITE (*, "(' ERROR: Cannot interpret quadrant-based azimuth: ',A)") quadrant_bearing_c8_saved CALL Pause() STOP END IF END IF ! using quadrants IF (problem) THEN WRITE (*, "(' ERROR in reading datum #',I6,'. Reading of data stops here.')") i CALL Pause() spreading_rate_count = i-1 EXIT record_spreading END IF CALL DLonLat_2_Uvec(lon, lat, uvec) spreading_site(1:3,i) = uvec(1:3) spreading_rate(i) = spreading_rate_mmpa spreading_azim(i) = spreading_azim_degrees * radians_per_degree END DO record_spreading ! reading data CLOSE (21) WRITE (*,"(/' Here is the distribution of seafloor-spreading rates (in mm/a):')") CALL Histogram (spreading_rate, spreading_rate_count, .FALSE., maximum, minimum) contour_interval = NINT(maximum / ai_spectrum_count) ! ~ 13 mm/a CALL DPrompt_for_Real('For how many Ma should spreading be projected?',velocity_Ma,velocity_Ma) WRITE (*,"(/' Working on seafloor-spreading rate data....')") CALL DBegin_Group ! spreading-rate bars CALL DSet_Fill_or_Pattern (.FALSE., 'background') DO i = 1, spreading_rate_count uvec(1:3) = spreading_site(1:3, i) spreading_rate_mmpa = spreading_rate(i) color_int = DInt_Above(spreading_rate_mmpa / contour_interval) reversed_color_int = ai_spectrum_count + 1 - color_int color_name = ai_spectrum(reversed_color_int)%color_name CALL DSet_Stroke_Color (color_name) CALL DSet_Line_Style (width_points = 4.0D0, dashed = .FALSE.) radians = spreading_rate(i) * velocity_Ma * 500.0D0 / & ! meters & mp_radius_meters CALL DTurn_To (spreading_azim(i), uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DNew_L45_Path(5, uvec1) CALL DTurn_To (spreading_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 DO CALL DEnd_Group ! of seafloor-spreading rates DEALLOCATE (spreading_azim) DEALLOCATE (spreading_rate) DEALLOCATE (spreading_site) bitmap_color_mode_temp = 4 bitmap_color_lowvalue_temp = 0.0D0 bitmap_color_highvalue_temp = ai_spectrum_count * contour_interval shaded_relief_temp = .FALSE. velocity_interval_temp = contour_interval velocity_midvalue_temp = bitmap_color_highvalue_temp / 2.0D0 velocity_lowblue_temp = .TRUE. CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, 'mm/a', bitmap_color_mode_temp, & & bitmap_color_lowvalue_temp, bitmap_color_highvalue_temp, shaded_relief_temp, & & velocity_interval_temp, velocity_midvalue_temp, velocity_lowblue_temp) 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_temp, & & bitmap_color_lowvalue_temp, bitmap_color_highvalue_temp, shaded_relief_temp, & & velocity_interval_temp, velocity_midvalue_temp, velocity_lowblue_temp) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! !end CASE(23): overlay of seafloor-spreading rates CASE (24) ! overlay of SKS-splitting fast azimuths (phi) & delay times 2240 temp_path_in = path_in !CALL File_List( file_type = "*.*" , & ! & suggested_file = splitting_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which is the SKS-splitting dataset that should be plotted?',splitting_file,splitting_file) splitting_pathfile = TRIM(temp_path_in)//TRIM(splitting_file) CALL Add_Title(splitting_file) ! open 1st time for a view (headers, formats) OPEN(UNIT = 21, FILE = splitting_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 2240 END IF CALL DCheck_for_TABs(21) 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) CALL DPrompt_for_Integer('How many title/header lines are there?',splitting_header_lines,splitting_header_lines) CALL DPrompt_for_Logical('Are these data in (lon,lat) coordinates?',.TRUE.,lonlat) IF (lonlat) THEN CALL DPrompt_for_String('What FORMAT will extract the longitude?',splitting_format1,splitting_format1) CALL DPrompt_for_String('What FORMAT will extract the latitude ?',splitting_format2,splitting_format2) ELSE ! x,y CALL DPrompt_for_String('What FORMAT will extract the X coordinate?',splitting_format1,splitting_format1) CALL DPrompt_for_String('What FORMAT will extract the Y coordinate?',splitting_format2,splitting_format2) END IF ! lon,lat or x,y CALL DPrompt_for_String('What FORMAT will extract the fast-polarization azimuth (phi)? (Note: ' // & & 'Use an A format if the azimuth is expressed as N78E;' // & & ' use an I or F format if the azimuth is in degrees, 0~360.)',& & splitting_format3,splitting_format3) using_quadrants = (SCAN(splitting_format3, 'A') > 0).OR.(SCAN(splitting_format3, 'a') > 0) azimuth_is_integer = ((.NOT.using_quadrants).AND.(SCAN(splitting_format3, 'I') > 0).OR.(SCAN(splitting_format3, 'i') > 0)) azimuth_is_real = ((.NOT.using_quadrants).AND.(SCAN(splitting_format3, 'F') > 0).OR.(SCAN(splitting_format3, 'f') > 0)) CALL DPrompt_for_String('What FORMAT will extract the relative delay time (dt)?',splitting_format4,splitting_format4) ! open 2nd time to count data lines OPEN(UNIT = 21, FILE = splitting_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') splitting_count = 0 CALL Add_Title('SKS-splitting: fast polarizations (phi) & delay times') DO i =1, splitting_header_lines READ (21, "(A)") line CALL Add_Title(line) END DO 2241 READ (21, '('//splitting_format1//')', IOSTAT = ios) t ! trying to read the longitude IF (ios == 0) THEN splitting_count = splitting_count + 1 GO TO 2241 ELSE CLOSE (21) WRITE (*,"(' ',I10,' SKS-splitting data were counted.')") splitting_count END IF ! good read, or not IF (splitting_count == 0) THEN mt_flashby = .FALSE. GO TO 2240 END IF ALLOCATE ( splitting_site(3, splitting_count) ) ALLOCATE ( splitting_phi (splitting_count) ) ALLOCATE ( splitting_dt (splitting_count) ) ! open 3rd time to read data lines OPEN(UNIT = 21, FILE = splitting_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) DO i =1, splitting_header_lines READ (21, "(A)") line END DO record_splitting: DO i = 1, splitting_count READ (21, '('//splitting_format1//')', IOSTAT = ios) lon problem = problem .OR. (ios /= 0) BACKSPACE (21) READ (21, '('//splitting_format2//')', IOSTAT = ios) lat problem = problem .OR. (ios /= 0) BACKSPACE (21) IF (azimuth_is_integer) THEN READ (21, '('//splitting_format3//')', IOSTAT = ios) n problem = problem .OR. (ios /= 0) splitting_phi_degrees = n ELSE IF (azimuth_is_real) THEN READ (21, '('//splitting_format3//')', IOSTAT = ios) splitting_phi_degrees problem = problem .OR. (ios /= 0) ELSE IF (using_quadrants) THEN READ (21, '('//splitting_format3//')', IOSTAT = ios) quadrant_bearing_c8 problem = problem .OR. (ios /= 0) north_q = .FALSE. east_q = .FALSE. south_q = .FALSE. west_q = .FALSE. quadrant_bearing_c8_saved = quadrant_bearing_c8 !look for North: k = SCAN(quadrant_bearing_c8, "Nn") IF (k > 0) THEN north_q = .TRUE. quadrant_bearing_c8(k:k) = ' ' END IF !look for East: k = SCAN(quadrant_bearing_c8, "Ee") IF (k > 0) THEN east_q = .TRUE. quadrant_bearing_c8(k:k) = ' ' END IF !look for South: k = SCAN(quadrant_bearing_c8, "Ss") IF (k > 0) THEN south_q = .TRUE. quadrant_bearing_c8(k:k) = ' ' END IF !look for West: k = SCAN(quadrant_bearing_c8, "Ww") IF (k > 0) THEN west_q = .TRUE. quadrant_bearing_c8(k:k) = ' ' END IF READ (quadrant_bearing_c8, *, IOSTAT = ios) splitting_phi_degrees problem = problem .OR. (ios /= 0) IF (north_q) THEN IF (east_q) THEN !no correction necessary ELSE IF (west_q) THEN splitting_phi_degrees = 360.0D0 - splitting_phi_degrees ELSE ! shouldn't happen WRITE (*, "(' ERROR: Cannot interpret quadrant-based azimuth: ',A)") quadrant_bearing_c8_saved CALL Pause() STOP END IF ELSE IF (south_q) THEN IF (east_q) THEN splitting_phi_degrees = 180.0D0 - splitting_phi_degrees ELSE IF (west_q) THEN splitting_phi_degrees = 180.0D0 + splitting_phi_degrees ELSE ! shouldn't happen WRITE (*, "(' ERROR: Cannot interpret quadrant-based azimuth: ',A)") quadrant_bearing_c8_saved CALL Pause() STOP END IF ELSE ! shouldn't happen WRITE (*, "(' ERROR: Cannot interpret quadrant-based azimuth: ',A)") quadrant_bearing_c8_saved CALL Pause() STOP END IF END IF ! using quadrants IF (problem) THEN WRITE (*, "(' ERROR in reading datum #',I6,'. Reading of data stops here.')") i CALL Pause() splitting_count = i-1 EXIT record_splitting END IF BACKSPACE (21) READ (21, '('//splitting_format4//')', IOSTAT = ios) splitting_dt_sec problem = problem .OR. (ios /= 0) CALL DLonLat_2_Uvec(lon, lat, uvec) splitting_site(1:3,i) = uvec(1:3) splitting_phi(i) = splitting_phi_degrees * radians_per_degree splitting_dt(i) = splitting_dt_sec END DO record_splitting ! reading data CLOSE (21) WRITE (*,"(/' Here is the distribution of SKS-splitting delay times (in s):')") CALL Histogram (splitting_dt, splitting_count, .FALSE., maximum, minimum) contour_interval = 0.10D0 * NINT(10 * maximum / ai_spectrum_count) ! ~ 0.2 s 2242 IF (splitting_scale_s <= 0.0D0) splitting_scale_s = (maximum + minimum) / 2.0D0 CALL DPrompt_for_Real('What typical delay time (in s) should be shown in the margin?',splitting_scale_s,splitting_scale_s) IF (splitting_scale_s <= 0.0D0) THEN WRITE(*,"(' Error: Please enter a positive number!')") mt_flashby = .FALSE. GO TO 2242 END IF 2243 CALL DPrompt_for_Real('How long (in points) should this delay-time be plotted?',splitting_scale_points,splitting_scale_points) IF (splitting_scale_points <= 0.0D0) THEN WRITE(*,"(' Error: Please enter a positive number!')") mt_flashby = .FALSE. GO TO 2243 END IF WRITE (*,"(/' Working on SKS-splitting data....')") CALL DBegin_Group ! spreading-rate bars 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, splitting_count uvec(1:3) = splitting_site(1:3, i) splitting_dt_sec = splitting_dt(i) color_int = DInt_Above(splitting_dt_sec / contour_interval) reversed_color_int = ai_spectrum_count + 1 - color_int reversed_color_int = MAX(MIN(reversed_color_int, ai_spectrum_count), 1) color_name = ai_spectrum(reversed_color_int)%color_name CALL DSet_Stroke_Color (color_name) CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) radians = (splitting_dt(i) / splitting_scale_s) * (0.5D0 * splitting_scale_points) * mp_meters_per_point / mp_radius_meters CALL DTurn_To (splitting_phi(i), uvec, radians, & ! inputs & omega_uvec, uvec1) CALL DNew_L45_Path(5, uvec1) CALL DTurn_To (splitting_phi(i)+Pi, uvec, radians, & ! inputs & omega_uvec, uvec2) CALL DGreat_to_L45(uvec2) CALL DEnd_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO CALL DEnd_Group ! of SKS-splitting data DEALLOCATE (splitting_dt) DEALLOCATE (splitting_phi) DEALLOCATE (splitting_site) bitmap_color_mode_temp = 4 bitmap_color_lowvalue_temp = 0.0D0 bitmap_color_highvalue_temp = ai_spectrum_count * contour_interval shaded_relief_temp = .FALSE. velocity_interval_temp = contour_interval velocity_midvalue_temp = bitmap_color_highvalue_temp / 2.0D0 velocity_lowblue_temp = .TRUE. CALL Chooser(bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, 's', bitmap_color_mode_temp, & & bitmap_color_lowvalue_temp, bitmap_color_highvalue_temp, shaded_relief_temp, & & velocity_interval_temp, velocity_midvalue_temp, velocity_lowblue_temp) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, 's', bitmap_color_mode_temp, & & bitmap_color_lowvalue_temp, bitmap_color_highvalue_temp, shaded_relief_temp, & & velocity_interval_temp, velocity_midvalue_temp, velocity_lowblue_temp) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! !end CASE(24): overlay of SKS-splitting fast azimuths (phi) & delay times CASE (25) ! fault slip-rate input dataset for Tuned_SHELLS. (Reads Tuned_SHELLS_fault_input_data.txt, ! which was "Saved As...Text (Tab-Delimited) from EXCEL file Tuned_SHELLS_fault_input_data.xlsx.) IF (.NOT.got_FEP) CALL Get_FEP 2250 temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file should be used?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 2250 END IF READ (21,"(A)") line CALL Add_Title(line) READ (21,*) numnod ALLOCATE ( node_uvec(3,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 DO i = 1, numel READ (21,*) END DO ! i = 1, numel READ (21,*) nFl ALLOCATE ( nodeF(4, nFl) ) ALLOCATE ( fDip(2, nFl) ) ALLOCATE ( fault_LRi(nFl) ) ALLOCATE ( fAzim(2, nFl) ) ALLOCATE ( slipRate(nFl) ) ALLOCATE ( up_azim_rads(nFl) ) ALLOCATE ( plot_at_uvec(3, nFl) ) DO i = 1, nFl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output READ (shorter_line, *) j, nodeF(1,i), nodeF(2,i), nodeF(3,i), nodeF(4,i), fDip(1,i), fDip(2,i) END DO ! i = 1, nFl CLOSE (21) CALL Fault_Azimuths(FEP, nfl, nodef, node_uvec, fdip, fazim) 2251 temp_path_in = path_in slipRate_file = "Tuned_SHELLS_fault_input_data.txt" ! invariant default; not saved in FiniteMap.ini (yet). CALL DPrompt_for_String('Which slip-rate input dataset should be used?', slipRate_file, slipRate_file) slipRate_pathfile = TRIM(temp_path_in)//TRIM(slipRate_file) OPEN(UNIT = 22, FILE = slipRate_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 2251 END IF CALL Add_Title('Fault slip-rates, for input to Tuned_SHELLS') CALL Add_Title(slipRate_file) DO i = 1, 2 READ (22,"(A)") line ! FEG_line_line, and headers-line END DO ! first 2 lines of slipRate file DO i = 1, nfl READ (22, *) jSHELLS_fE, c5, t slipRate(jSHELLS_fE) = t END DO CLOSE(22) CALL DPrompt_for_Real('The widths of the shaded bands along faults are equal & &to their slip-rates multiplied by a time factor. For how many Ma should & &fault slip-rates be projected?', velocity_Ma, velocity_Ma) CALL DPrompt_for_Real('How large are the dip ticks (in points)?', tick_points, tick_points) WRITE (*,"(/' Working on (input, estimated) slip-rates of fault elements....')") CALL Plot_Fault_Ticks (colored = .FALSE.) ! would conflict with bands ! Chooses color, etc. and defines a group; ! all information is from global. CALL DBegin_Group ! of colored/shaded bands DO i = 1, nfl IF (FEP == "SHELLS") THEN ! (this includes Tuned_SHELLS, of course...) 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. CALL DMake_Uvec(uvec3, uvec4) ! uvec4 is midpoint f_azim_rads_1 = fazim(1,i) f_azim_rads_2 = fazim(2,i) f_azim_rads_c = DCompass(uvec4, uvec2) IF ((ABS(fdip(1,i)) > 75.0D0).AND.(ABS(fdip(2,i)) > 75.0D0)) THEN !for vertical fault only, consider reversing direction! test = 0.7071D0 * DCOS(f_azim_rads_c) + (-0.7071D0) * DSIN(f_azim_rads_c) ! note that test is > 0. when fault trends NW; this puts number label upside-down IF (test > 0.0D0) THEN ! reverse the element (not in arrays, just in temporary variables!) uvec3(1:3) = uvec1(1:3) uvec1(1:3) = uvec2(1:3) uvec2(1:3) = uvec3(1:3) ! note that uvec4: midpoint is unchanged t1 = f_azim_rads_1 t2 = f_azim_rads_2 f_azim_rads_1 = t2 + Pi f_azim_rads_2 = t1 + Pi f_azim_rads_c = f_azim_rads_c + Pi ! no need to swap vertical1, 2 == 0.0 END IF ! reversing fault element END IF ! element is a vertical fault IF (fdip(1,i) >= 0.0D0) THEN x_azim_rads_1 = f_azim_rads_1 - Pi/2.0D0 up_azim_rads(i) = f_azim_rads_c - Pi/2.0D0 ! store for plotting # later! x_azim_rads_2 = f_azim_rads_2 - Pi/2.0D0 ELSE ! negative fdip means dipping from n3-n4 side. x_azim_rads_1 = f_azim_rads_1 + Pi/2.0D0 up_azim_rads(i) = f_azim_rads_c + Pi/2.0D0 ! store for plotting # later! x_azim_rads_2 = f_azim_rads_2 + Pi/2.0D0 END IF offset_radians = 1000.0D0 * slipRate(i) * velocity_Ma / R ! width of the ribbon CALL DTurn_To (azimuth_radians = up_azim_rads(i), & & base_uvec = uvec4, far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) plot_at_uvec(1:3,i) = uvec3(1:3) ! store for plotting # later offset_radians = 1000.0D0 * slipRate(i) * velocity_Ma / R CALL DTurn_To (azimuth_radians = x_azim_rads_1, & & base_uvec = uvec1, far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec4) ! as in nodef(4,i), displaced offset_radians = 1000.0D0 * slipRate(i) * velocity_Ma / R CALL DTurn_To (azimuth_radians = x_azim_rads_2, & & base_uvec = uvec2, far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) ! as in nodef(3,i), displaced IF (ai_using_color) THEN color_name = 'green_____' CALL DSet_Fill_or_Pattern (.FALSE., color_name) CALL DNew_L45_Path (5, uvec1) CALL DGreat_to_L45(uvec2) CALL DGreat_to_L45(uvec3) CALL DGreat_to_L45(uvec4) CALL DGreat_to_L45(uvec1) CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ELSE ! b/w plot CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DNew_L45_Path (5, uvec4) CALL DGreat_to_L45(uvec3) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = 0, 6 ! 7 lines per fault element s = j/6.0D0 CALL DGreatCircle_Point (from_uvec = uvec4, & & to_uvec = uvec3, s = s, & ! inputs & point_uvec = uvec5, azimuth_radians = t) ! outputs CALL DGreatCircle_Point (from_uvec = uvec1, & & to_uvec = uvec2, s = s, & ! inputs & point_uvec = uvec6, azimuth_radians = t) ! outputs CALL DNew_L45_Path (5, uvec5) CALL DGreat_to_L45(uvec6) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! j = 0, 6 END IF ! ai_using_color or not END IF ! FEP selection END DO ! i = 1, nfl CALL DEnd_Group ! of colored/shaded bands CALL Plot_Fault_Traces (colored = .FALSE.) ! would conflict with bands ALLOCATE ( selected(nfl) ) WRITE (*,"(/' There will be ',I7,' slip-rates if they are not thinned.')") nfl 2252 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 2252 END IF CALL DThin_on_Sphere (plot_at_uvec, nfl, label_thinner, selected) CALL DBegin_Group ! of slip-rate numbers, in mm/a CALL DSet_Fill_or_Pattern(.FALSE., 'foreground') DO i = 1, nfl IF (selected(i)) THEN IF (FEP == "SHELLS") THEN uvec1(1:3) = plot_at_uvec(1:3,i) 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 = ADJUSTL(DASCII8(slipRate(i)))) END IF ! FEP selection END IF ! selected(i) END DO ! i = 1, nfl CALL DEnd_Group ! of slip-rate numbers (in mm/a) DEALLOCATE ( selected ) DEALLOCATE ( node_uvec ) DEALLOCATE ( plot_at_uvec ) DEALLOCATE ( up_azim_rads ) DEALLOCATE ( slipRate ) DEALLOCATE ( fazim ) DEALLOCATE ( fault_LRi ) DEALLOCATE ( fdip ) DEALLOCATE ( nodef ) CALL Chooser (bottom, right) CALL DBegin_Group ! sample frictions ! how fast is a 20-point band, in mm/a? sliprate1 = (((20.0D0/2834.0D0)/1000.0D0)*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.0D0 CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(DASCII8(sliprate1)))) IF (ai_using_color) THEN !each takes 20 points plus space below for a dip tick = 30 apart CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-32.0D0, & & color_name = 'green_____', text = 'normal') CALL DDipTick_in_Plane (level = 1, x = xcp, y = y2_points-32.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'N', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-62.0D0, & & color_name = 'green_____', text = 'thrust') CALL DDipTick_in_Plane (level = 1, x = xcp, y = y2_points-62.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'T', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-92.0D0, & & color_name = 'green_____', text = 'dextral') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-122.0D0, & & color_name = 'green_____', text = 'sinistral') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 122.0D0 ELSE ! b/w CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DNew_L12_Path(1, xcp-31.0D0, y2_points-12.0D0) CALL DLine_to_L12(xcp+31., y2_points-12.) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = -30,30,6 CALL DNew_L12_Path(1, xcp+j, y2_points-12.0D0) CALL DLine_to_L12(xcp+j, y2_points-32.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! vertical stripes CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, xcp-31.0D0, y2_points-32.0D0) CALL DLine_to_L12(xcp+31.0D0, y2_points-32.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 32.0D0 END IF ! color or b/w CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Slip-rate (mm/a)') rightlegend_used_points = rightlegend_used_points + 10.0D0 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.0D0, & & y_points = ycp, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Slip-rate (mm/a)') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.0D0 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.0D0, & & y_points = ycp+12.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(DASCII8(sliprate1)))) IF (ai_using_color) THEN CALL Slip_Sample(x_center_points = x1_points+36.0D0, y_base_points = ycp-10.0D0, & & color_name = 'green_____', text = 'normal') CALL DDipTick_in_Plane (level = 1, x = x1_points+36.0D0, y = ycp-10.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'N', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = x1_points+108.0D0, y_base_points = ycp-10.0D0, & & color_name = 'green_____', text = 'thrust') CALL DDipTick_in_Plane (level = 1, x = x1_points+108.0D0, y = ycp-10.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'T', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = x1_points+180.0D0, y_base_points = ycp-10.0D0, & & color_name = 'green_____', text = 'dextral') CALL Slip_Sample(x_center_points = x1_points+252.0D0, y_base_points = ycp-10.0D0, & & color_name = 'green_____', text = 'sinistral') bottomlegend_used_points = bottomlegend_used_points + 288.0D0 ELSE ! b/w CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+5.0D0, ycp+10.0D0) CALL DLine_to_L12(x1_points+67.0D0, ycp+10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = -30,30,6 CALL DNew_L12_Path(1, x1_points+36.0D0+j, ycp+10.0D0) CALL DLine_to_L12(x1_points+36.0D0+j, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! vertical stripes CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+5.0D0, ycp-10.0D0) CALL DLine_to_L12(x1_points+67.0D0, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + 72.0D0 END IF ! color or b/w END IF ! right or bottom CALL DEnd_Group ! sample slip-rates WRITE (*,"('+Working on (estimated, input) slip-rates of fault elements....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of: slip-rate input dataset for Tuned_SHELLS (25) CASE (26) ! effective fault friction, from Tuned_SHELLS (reads Tuned_SHELLS_fault_conclusions.txt). IF (.NOT.got_FEP) CALL Get_FEP 2260 temp_path_in = path_in !CALL File_List( file_type = "*.feg", & ! & suggested_file = feg_file, & ! & using_path = temp_path_in) CALL DPrompt_for_String('Which .feg file should be used?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL DPress_Enter mt_flashby = .FALSE. GO TO 2260 END IF READ (21,"(A)") line CALL Add_Title(line) READ (21,*) numnod ALLOCATE ( node_uvec(3,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 DO i = 1, numel READ (21,*) END DO ! i = 1, numel READ (21,*) nFl ALLOCATE ( nodeF(4, nFl) ) ALLOCATE ( fDip(2, nFl) ) ALLOCATE ( fault_LRi(nFl) ) ALLOCATE ( fAzim(2, nFl) ) ALLOCATE ( friction(nFl) ) ALLOCATE ( up_azim_rads(nFl) ) ALLOCATE ( plot_at_uvec(3,nfl) ) LRn = 0 ! just initializing, before READs DO i = 1, nFl READ (21, "(A)", IOSTAT = ios) longer_line CALL Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output fault_LRi(i) = LRi LRn = MAX(LRn, LRi) READ (shorter_line, *) j, nodeF(1,i), nodeF(2,i), nodeF(3,i), nodeF(4,i), fDip(1,i), fDip(2,i) END DO ! i = 1, nFl CLOSE (21) CALL Fault_Azimuths(FEP, nfl, nodef, node_uvec, fdip, fazim) 2261 temp_path_in = path_in friction_file = "Tuned_SHELLS_fault_conclusions.txt" ! invariant default; not saved in FiniteMap.ini (yet). CALL DPrompt_for_String('Which friction file should be used?', friction_file, friction_file) friction_pathfile = TRIM(temp_path_in)//TRIM(friction_file) OPEN(UNIT = 22, FILE = friction_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 2261 END IF CALL Add_Title('Effective fault friction, from Tuned_SHELLS') DO i = 1, 2 READ (22,"(A)") line ! FEG_line_line, and headers-line END DO ! first 2 lines of velocity file DO i = 1, nfl READ (22, *) jSHELLS_fE, target_sRate, last_sRate, last_fFric friction(jSHELLS_fE) = last_fFric END DO CLOSE(22) friction_width_km = 25.0D0 ! for friction of 0.50; so width of 0.5 km for friction of 0.01, and ! the 20-point band in the Explanation will correspond to 0.56. CALL DPrompt_for_Real('The widths of the shaded bands along faults are equal & &to their friction multiplied by a width factor. How wide (in km) should & &friction of 0.50 be plotted?', friction_width_km, friction_width_km) friction_width_m = friction_width_km * 1000.0D0 CALL DPrompt_for_Real('How large are the dip ticks (in points)?',tick_points,tick_points) WRITE (*,"(/' Working on friction coefficients of fault elements....')") CALL Plot_Fault_Ticks (colored = .FALSE.) ! would conflict with bands ! Chooses color, etc. and defines a group; ! all information is from global. CALL DBegin_Group ! of colored/shaded bands DO i = 1, nfl IF (FEP == "SHELLS") THEN ! (this includes Tuned_SHELLS, of course...) 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. CALL DMake_Uvec(uvec3, uvec4) ! uvec4 is midpoint f_azim_rads_1 = fazim(1,i) f_azim_rads_2 = fazim(2,i) f_azim_rads_c = DCompass(uvec4, uvec2) IF ((ABS(fdip(1,i)) > 75.0D0).AND.(ABS(fdip(2,i)) > 75.0D0)) THEN !for vertical fault only, consider reversing direction! test = 0.7071D0 * DCOS(f_azim_rads_c) + (-0.7071D0) * DSIN(f_azim_rads_c) ! note that test is > 0. when fault trends NW; this puts number label upside-down IF (test > 0.0D0) THEN ! reverse the element (not in arrays, just in temporary variables!) uvec3(1:3) = uvec1(1:3) uvec1(1:3) = uvec2(1:3) uvec2(1:3) = uvec3(1:3) ! note that uvec4: midpoint is unchanged t1 = f_azim_rads_1 t2 = f_azim_rads_2 f_azim_rads_1 = t2 + Pi f_azim_rads_2 = t1 + Pi f_azim_rads_c = f_azim_rads_c + Pi ! no need to swap vertical1, 2 == 0.0 END IF ! reversing fault element END IF ! element is a vertical fault IF (fdip(1,i) >= 0.0D0) THEN x_azim_rads_1 = f_azim_rads_1 - Pi/2.0D0 up_azim_rads(i) = f_azim_rads_c - Pi/2.0D0 ! store for plotting # later! x_azim_rads_2 = f_azim_rads_2 - Pi/2.0D0 ELSE ! negative fdip means dipping from n3-n4 side. x_azim_rads_1 = f_azim_rads_1 + Pi/2.0D0 up_azim_rads(i) = f_azim_rads_c + Pi/2.0D0 ! store for plotting # later! x_azim_rads_2 = f_azim_rads_2 + Pi/2.0D0 END IF offset_radians = friction_width_m * (friction(i) / 0.50D0) / R ! width of the ribbon CALL DTurn_To (azimuth_radians = up_azim_rads(i), & & base_uvec = uvec4, far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) plot_at_uvec(1:3,i) = uvec3(1:3) ! store for plotting # later offset_radians = friction_width_m * (friction(i) / 0.50D0) / R CALL DTurn_To (azimuth_radians = x_azim_rads_1, & & base_uvec = uvec1, far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec4) ! as in nodef(4,i), displaced offset_radians = friction_width_m * (friction(i) / 0.50D0) / R CALL DTurn_To (azimuth_radians = x_azim_rads_2, & & base_uvec = uvec2, far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) ! as in nodef(3,i), displaced IF (ai_using_color) THEN color_name = 'red_______' CALL DSet_Fill_or_Pattern (.FALSE., color_name) CALL DNew_L45_Path (5, uvec1) CALL DGreat_to_L45(uvec2) CALL DGreat_to_L45(uvec3) CALL DGreat_to_L45(uvec4) CALL DGreat_to_L45(uvec1) CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ELSE ! b/w plot CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DNew_L45_Path (5, uvec4) CALL DGreat_to_L45(uvec3) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = 0, 6 ! 7 lines per fault element s = j/6.0D0 CALL DGreatCircle_Point (from_uvec = uvec4, & & to_uvec = uvec3, s = s, & ! inputs & point_uvec = uvec5, azimuth_radians = t) ! outputs CALL DGreatCircle_Point (from_uvec = uvec1, & & to_uvec = uvec2, s = s, & ! inputs & point_uvec = uvec6, azimuth_radians = t) ! outputs CALL DNew_L45_Path (5, uvec5) CALL DGreat_to_L45(uvec6) CALL DEnd_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! j = 0, 6 END IF ! ai_using_color or not END IF ! FEP selection END DO ! i = 1, nfl CALL DEnd_Group ! of colored/shaded bands CALL Plot_Fault_Traces (colored = .FALSE.) ! would conflict with bands ALLOCATE ( selected(nfl) ) WRITE (*,"(/' There will be ',I7,' friction coefficients if they are not thinned.')") nfl 2262 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 2262 END IF CALL DThin_on_Sphere (plot_at_uvec, nfl, label_thinner, selected) CALL DBegin_Group ! of friction-coefficient numbers CALL DSet_Fill_or_Pattern(.FALSE., 'foreground') DO i = 1, nfl IF (selected(i)) THEN IF (FEP == "SHELLS") THEN uvec1(1:3) = plot_at_uvec(1:3,i) 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 = ADJUSTL(DASCII8(friction(i)))) END IF ! FEP selection END IF ! selected(i) END DO ! i = 1, nfl CALL DEnd_Group ! of friction coefficientss DEALLOCATE ( selected ) DEALLOCATE ( node_uvec ) DEALLOCATE ( plot_at_uvec ) DEALLOCATE ( up_azim_rads ) DEALLOCATE ( friction ) DEALLOCATE ( fazim ) DEALLOCATE ( fault_LRi ) DEALLOCATE ( fdip ) DEALLOCATE ( nodef ) CALL Chooser (bottom, right) CALL DBegin_Group ! sample frictions ! What friction corresponds to a 20-point band? [Probably 0.56, if user accepts the default suggestion.] friction1 = 0.50D0 * (((20.0D0 / 2834.0D0) * mp_scale_denominator) / friction_width_m) 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.0D0 CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(DASCII8(friction1)))) IF (ai_using_color) THEN !each takes 20 points plus space below for a dip tick = 30 apart CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-32.0D0, & & color_name = 'red_______', text = 'normal') CALL DDipTick_in_Plane (level = 1, x = xcp, y = y2_points-32.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'N', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-62.0D0, & & color_name = 'red_______', text = 'thrust') CALL DDipTick_in_Plane (level = 1, x = xcp, y = y2_points-62.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'T', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-92.0D0, & & color_name = 'red_______', text = 'dextral') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-122.0D0, & & color_name = 'red_______', text = 'sinistral') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 122.0D0 ELSE ! b/w CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DNew_L12_Path(1, xcp-31.0D0, y2_points-12.0D0) CALL DLine_to_L12(xcp+31., y2_points-12.) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = -30,30,6 CALL DNew_L12_Path(1, xcp+j, y2_points-12.0D0) CALL DLine_to_L12(xcp+j, y2_points-32.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! vertical stripes CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, xcp-31.0D0, y2_points-32.0D0) CALL DLine_to_L12(xcp+31.0D0, y2_points-32.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 32.0D0 END IF ! color or b/w CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Friction:') rightlegend_used_points = rightlegend_used_points + 10.0D0 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.0D0, & & y_points = ycp, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Friction:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72.0D0 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.0D0, & & y_points = ycp+12.0D0, angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(DASCII8(friction1)))) IF (ai_using_color) THEN CALL Slip_Sample(x_center_points = x1_points+36.0D0, y_base_points = ycp-10.0D0, & & color_name = 'red_______', text = 'normal') CALL DDipTick_in_Plane (level = 1, x = x1_points+36.0D0, y = ycp-10.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'N', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = x1_points+108.0D0, y_base_points = ycp-10.0D0, & & color_name = 'red_______', text = 'thrust') CALL DDipTick_in_Plane (level = 1, x = x1_points+108.0D0, y = ycp-10.0D0, & & dip_angle_radians = -Pi/2.0D0, & & style_byte = 'T', size_points = 6.0D0, offset_points = 0.0D0) CALL Slip_Sample(x_center_points = x1_points+180.0D0, y_base_points = ycp-10.0D0, & & color_name = 'red_______', text = 'dextral') CALL Slip_Sample(x_center_points = x1_points+252.0D0, y_base_points = ycp-10.0D0, & & color_name = 'red_______', text = 'sinistral') bottomlegend_used_points = bottomlegend_used_points + 288.0D0 ELSE ! b/w CALL DSet_Stroke_Color ('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+5.0D0, ycp+10.0D0) CALL DLine_to_L12(x1_points+67.0D0, ycp+10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = -30,30,6 CALL DNew_L12_Path(1, x1_points+36.0D0+j, ycp+10.0D0) CALL DLine_to_L12(x1_points+36.0D0+j, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! vertical stripes CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+5.0D0, ycp-10.0D0) CALL DLine_to_L12(x1_points+67.0D0, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + 72.0D0 END IF ! color or b/w END IF ! right or bottom CALL DEnd_Group ! sample friction coefficients WRITE (*,"('+Working on friction coefficients of fault elements....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) ! end of effective fault friction from Tuned_SHELLS (26) END SELECT ! (choice) = overlay type 2999 just_began_deep_flow = .FALSE. ! Completion of any overlay just_began_traction = .FALSE. ! means that the "just" part is just_began_surface_flow = .FALSE. ! no longer true (because file just_began_tau_integral = .FALSE. ! names may have changed). just_began_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!---------------- OPEN (UNIT = 11, FILE = 'FiniteMap.ini') WRITE (11,"(A)") TRIM(path_in) WRITE (11,"(L12,' = same_path_in_out')") same_path_in_out WRITE (11,"(A)") TRIM(path_out) WRITE (11,"(A6,6X,' = FEP')") FEP 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_color_mode')") bitmap_color_mode WRITE (11,"(L12,' = shaded_relief')") shaded_relief WRITE (11,"(I12,' = grid_access_mode')") grid_access_mode 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,"(I12,' = TMoho_C_method')") TMoho_C_method WRITE (11,"(1P,E12.4,' = TMoho_C_interval')") TMoho_C_interval WRITE (11,"(1P,E12.4,' = TMoho_C_midvalue')") TMoho_C_midvalue WRITE (11,"(L12,' = TMoho_C_lowblue')") TMoho_C_lowblue WRITE (11,"(I12,' = Tbase_C_method')") Tbase_C_method WRITE (11,"(1P,E12.4,' = Tbase_C_interval')") Tbase_C_interval WRITE (11,"(1P,E12.4,' = Tbase_C_midvalue')") Tbase_C_midvalue WRITE (11,"(L12,' = Tbase_C_lowblue')") Tbase_C_lowblue WRITE (11,"(I12,' = pressure_MPa_method')") pressure_MPa_method WRITE (11,"(1P,E12.4,' = pressure_MPa_interval')") pressure_MPa_interval WRITE (11,"(1P,E12.4,' = pressure_MPa_midvalue')") pressure_MPa_midvalue WRITE (11,"(L12,' = pressure_MPa_lowblue')") pressure_MPa_lowblue WRITE (11,"(A)") TRIM(boundaries_dig_file) WRITE (11,"(A)") TRIM(plates_dig_file) WRITE (11,"(A)") TRIM(orogens_dig_file) WRITE (11,"(L12,' = velocity_reframe')") velocity_reframe WRITE (11,"(I12,' = fixed_node')") fixed_node WRITE (11,"(I12,' = nonorbiting_node')") nonorbiting_node 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,' = traction_method')") traction_method WRITE (11,"(1P,E12.4,' = traction_interval')") traction_interval WRITE (11,"(1P,E12.4,' = traction_midvalue')") traction_midvalue WRITE (11,"(L12,' = traction_lowblue')") traction_lowblue WRITE (11,"(I12,' = shear_integral_method')") shear_integral_method WRITE (11,"(A12,' = stress_integral_units')") stress_integral_units WRITE (11,"(1P,E12.4,' = shear_integral_interval')") shear_integral_interval WRITE (11,"(1P,E12.4,' = shear_integral_midvalue')") shear_integral_midvalue WRITE (11,"(L12,' = shear_integral_lowblue')") shear_integral_lowblue WRITE (11,"(I12,' = shear_integral_zeromode')") shear_integral_zeromode WRITE (11,"(I12,' = log_viscosity_integral_method')") log_viscosity_integral_method WRITE (11,"(1P,E12.4,' = log_viscosity_integral_interval')") log_viscosity_integral_interval WRITE (11,"(1P,E12.4,' = log_viscosity_integral_midvalue')") log_viscosity_integral_midvalue WRITE (11,"(L12,' = log_viscosity_integral_lowblue')") log_viscosity_integral_lowblue WRITE (11,"(A)") TRIM(OrbScore_feg_file) WRITE (11,"(I12,' = log_strainrate_method')") log_strainrate_method WRITE (11,"(1P,E12.4,' = log_strainrate_interval')") log_strainrate_interval WRITE (11,"(1P,E12.4,' = log_strainrate_midvalue')") log_strainrate_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,"(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(vel_file) WRITE (11,"(A)") TRIM(gps_file) WRITE (11,"(F12.1,' = benchmark_points')") benchmark_points WRITE (11,"(1P,E12.4,' = traction_scale_MPa')") traction_scale_MPa WRITE (11,"(1P,E12.4,' = traction_scale_points')") traction_scale_points WRITE (11,"(F12.3,' = velocity_Ma')") velocity_Ma WRITE (11,"(I12, ' = vector_thinner')") vector_thinner 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,"(1P,E12.4,' = tau_integral_scale_Npm')") tau_integral_scale_Npm WRITE (11,"(F12.1,' = tau_integral_scale_points')") tau_integral_scale_points WRITE (11,"(F12.1,' = s1_size_points')") s1_size_points WRITE (11,"(I12, ' = stress_thinner')") stress_thinner WRITE (11,"(A)") TRIM(s1h_file) WRITE (11,"(I12,' = s_header_lines')") s_header_lines WRITE (11,"(L12,' = regimes_known')") regimes_known WRITE (11,"(A,' = stress_format1')") stress_format1 WRITE (11,"(A,' = stress_format2')") stress_format2 WRITE (11,"(A,' = stress_format3')") stress_format3 WRITE (11,"(A,' = stress_format4')") stress_format4 WRITE (11,"(A,' = stress_format5')") stress_format5 WRITE (11,"(A)") TRIM(force_file) WRITE (11,"(A12,' = force_units')") force_units WRITE (11,"(1P,E12.4,' = force_scale_N')") force_scale_N WRITE (11,"(F12.3,' = force_scale_points')") force_scale_points 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,"(I12, ' = ref_frame_plate_ID')") ref_frame_plate_ID WRITE (11,"(I12, ' = subdivision')") subdivision WRITE (11,"(I12, ' = label_thinner')") label_thinner WRITE (11,"(A)") TRIM(steps_dat_file) WRITE (11,"(A)") TRIM(torque_file) WRITE (11,"(A)") TRIM(spreading_rate_file) WRITE (11,"(I12,' = spreading_header_lines')") spreading_header_lines WRITE (11,"(A,' = spreading_format1')") spreading_format1 WRITE (11,"(A,' = spreading_format2')") spreading_format2 WRITE (11,"(A,' = spreading_format3')") spreading_format3 WRITE (11,"(A,' = spreading_format4')") spreading_format4 WRITE (11,"(A)") TRIM(splitting_file) WRITE (11,"(I12,' = splitting_header_lines')") splitting_header_lines WRITE (11,"(A,' = splitting_format1')") splitting_format1 WRITE (11,"(A,' = splitting_format2')") splitting_format2 WRITE (11,"(A,' = splitting_format3')") splitting_format3 WRITE (11,"(A,' = splitting_format4')") splitting_format4 WRITE (11,"(1P,E12.4,' = splitting_scale_s')") splitting_scale_s WRITE (11,"(1P,E12.4,' = splitting_scale_points')") splitting_scale_points 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 Assign (iUnitT, & ! input & nPBnd, nDPlat, nFl, nodeF, nodes, & & nPlate, numEl, numNod, & & pLat, pLon, & & xNode, yNode, & & whichP, & ! output & checkN) ! work ! Assigns an integer plate# to each node of the grid. IMPLICIT NONE ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - INTEGER, INTENT(IN) :: iUnitT, nPBnd, nFl, nPlate, numEl, numNod ! input INTEGER, INTENT(IN) :: nDPlat ! input INTEGER, INTENT(IN) :: nodeF ! input INTEGER, INTENT(IN) :: nodes ! input REAL*8, INTENT(IN) :: pLat, pLon ! input REAL*8, INTENT(IN) :: xNode, yNode ! input INTEGER, INTENT(OUT) :: whichP ! output LOGICAL checkN, inside ! work ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - INTEGER :: i, iP, iPlate, j, j1, j2, k, n1, n2, n3, nEnd, nPoint, oldIP, outline_count LOGICAL :: gotOut REAL*8 aa, a1, a2, a3, ab1, ab2, ab3, ac, angle, ao, & & b1, b2, b3, bb, bc, bo, dangle, equat, & & g1, g2, g3, gc, length, length2, size, sTheta, tangl, & & x, x1, x2, xInPl, xO, xOff, xPB, xPoint, xVel, & & y, y1, y2, yInPl, yO, yOff, yPB, yPoint, yVel, & & z1, z2, zO, zOff, zPB REAL*8, DIMENSION(3) :: alongv, crossv, uvec, uvec1 DIMENSION nDPlat(nPlate), nodeF(4, nFl), nodes(3, numEl), & & pLat(nPlate, nPBnd), pLon(nPlate, nPBnd), & & xNode(numNod), yNode(numNod), whichP(numNod), checkN(numNod) REAL*8, DIMENSION(:, :), ALLOCATABLE :: plate_outline_uvecs ! PB2002SCEC model of Bird [2003; G**3] + [2017.01 microplates]; ! Already has plate "names" and "omega" vectors in ! main program (DATA statements); ! must also have digitised plate ! outlines in arrays pLat and pLon, ! presumably already read from file "PB2002SCEC_plates.dig". ! (That is, this routine will not read any file.) ALLOCATE ( plate_outline_uvecs(3, nPBnd) ) ! using global/MAIN value of anticipated maximum length for any plate circuit ! Check which nodes are on faults: DO 10 i = 1, numNod checkN(i) = .FALSE. 10 CONTINUE DO 30 i = 1, nFl DO 20 k = 1, 4 checkN(nodeF(k, i)) = .TRUE. 20 CONTINUE 30 CONTINUE ! For nodes on faults, attempt to offset test position ! which is used to determine plate membership ! (but not position used in V = OMEGA x R ). oldIP = 1 ! to guard against possible undefined integer, in case of failure on the first point DO 999 i = 1, numNod xVel = xNode(i) yVel = yNode(i) IF (checkN(i)) THEN ! Node is on fault; seek offset position ! for determination of plate affiliation... gotOut = .FALSE. ! 1st strategy: ! Is there a continuum element including this node ! which has some other node NOT on a fault? ! If so, use that other node's position. DO 100 j = 1, numEl n1 = nodes(1, j) n2 = nodes(2, j) n3 = nodes(3, j) IF ((n1 == i).OR.(n2 == i).OR.(n3 == i)) THEN IF ((n1 /= i).AND.(.NOT.checkN(n1)))THEN gotOut = .TRUE. xInPl = xNode(n1) yInPl = yNode(n1) GO TO 101 END IF IF ((n2 /= i).AND.(.NOT.checkN(n2)))THEN gotOut = .TRUE. xInPl = xNode(n2) yInPl = yNode(n2) GO TO 101 END IF IF ((n3 /= i).AND.(.NOT.checkN(n3)))THEN gotOut = .TRUE. xInPl = xNode(n3) yInPl = yNode(n3) GO TO 101 END IF END IF 100 CONTINUE ! If there is still a problem, try ! 2nd strategy: ! If any continuum element includes this node ! (even though its other nodes are all on faults), ! we can use the midpoint of the continuum element... 101 IF (.NOT.gotOut) THEN DO 200 j = 1, numEl n1 = nodes(1, j) n2 = nodes(2, j) n3 = nodes(3, j) IF ((n1 == i).OR.(n2 == i).OR. & & (n3 == i)) THEN gotOut = .TRUE. a1 = SIN(xNode(n1)) * COS(yNode(n1)) b1 = SIN(xNode(n1)) * SIN(yNode(n1)) g1 = COS(xNode(n1)) a2 = SIN(xNode(n2)) * COS(yNode(n2)) b2 = SIN(xNode(n2)) * SIN(yNode(n2)) g2 = COS(xNode(n2)) a3 = SIN(xNode(n3)) * COS(yNode(n3)) b3 = SIN(xNode(n3)) * SIN(yNode(n3)) g3 = COS(xNode(n3)) ac = (a1 + a2 + a3) / 3.0D0 bc = (b1 + b2 + b3) / 3.0D0 gc = (g1 + g2 + g3) / 3.0D0 size = SQRT(ac**2 + bc**2 + gc**2) ac = ac / size bc = bc / size gc = gc / size equat = SQRT(ac**2 + bc**2) xInPl = ATAN2(equat, gc) yInPl = ATAN2(bc, ac) GO TO 201 END IF 200 CONTINUE END IF ! If there is still a problem, then this fault ! node does not belong to any continuum element. ! It must be on the outer perimeter of the model. ! Try a small offset toward the outside... 201 IF (.NOT.gotOut) THEN ! Find where node #i is on the fault... DO 220 j = 1, nFl DO 210 k = 1, 4 IF (nodeF(k, j) == i) THEN ! N.B. k & j are what we are seeking. GO TO 221 END IF 210 CONTINUE 220 CONTINUE 221 IF (k <= 2) THEN ! Node is on N1-N2 side of fault. n1 = nodeF(1, j) n2 = nodeF(2, j) ELSE ! Node is on N3-N4 side of fault. n1 = nodeF(3, j) n2 = nodeF(4, j) END IF x1 = COS(yNode(n1)) * SIN(xNode(n1)) y1 = SIN(yNode(n1)) * SIN(xNode(n1)) z1 = COS(xNode(n1)) x2 = COS(yNode(n2)) * SIN(xNode(n2)) y2 = SIN(yNode(n2)) * SIN(xNode(n2)) z2 = COS(xNode(n2)) alongV(1) = x2 - x1 alongV(2) = y2 - y1 alongV(3) = z2 - z1 xOff = x1 + 0.50D0 * alongV(1) yOff = y1 + 0.50D0 * alongV(2) zOff = z1 + 0.50D0 * alongV(3) crossV(1) = alongV(2) * zOff - alongV(3) * yOff crossV(2) = alongV(3) * xOff - alongV(1) * zOff crossV(3) = alongV(1) * yOff - alongV(2) * xOff ! "crossV: has same length as alongV, ! and points out of fault (to right, ! when looking from n1 toward n2). xOff = xOff + 0.250D0 * crossV(1) yOff = yOff + 0.250D0 * crossV(2) zOff = zOff + 0.250D0 * crossV(3) equat = SQRT(xOff**2 + yOff**2) xInPl = ATAN2(equat, zOff) yInPl = ATAN2(yOff, xOff) END IF ELSE ! Node is not on any fault; ! no offset of position is needed: xInPl = xVel yInPl = yVel END IF !Convert test position to a spherical uvec: xO = COS(yInPl) * SIN(xInPl) yO = SIN(yInPl) * SIN(xInPl) zO = COS(xInPl) !including a normalization step that (in theory) should not be necessary: length2 = (xO * xO) + (yO * yO) + (zO * zO) length = SQRT(length2) xO = xO / length yO = yO / length zO = zO / length uvec(1) = xO; uvec(2) = yO; uvec(3) = zO !Initialize search(es) for plates enclosing this test point: nPoint = 0 ! number of plates enclosing this test point iPlate = 0 ! INTEGER index of (last) plate enclosing this test point DO 500 iP = 1, nPlate outline_count = nDPlat(iP) DO j = 1, outline_count !Convert plate-boundary positions to spherical uvecs, all around this one plate: !{N.B. Arrays pLat and pLon have already been divided by 57.296... to convert them to radians!} x = 1.57079632679490D0 - pLat(iP, j) ! colatitude, measured from N pole, in radians y = pLon(iP, j) ! East longitude, in radians xPB = COS(y) * SIN(x) yPB = SIN(y) * SIN(x) zPB = COS(x) !including a normalization step that (in theory) should not be necessary: length2 = (xPB * xPB) + (yPB * yPB) + (zPB * zPB) length = SQRT(length2) xPB = xPB / length yPB = yPB / length zPB = zPB / length uvec1(1) = xPB; uvec1(2) = yPB; uvec1(3) = zPB !and store in array (needed by function Within): plate_outline_uvecs(1:3, j) = uvec1(1:3) END DO !================================================================= inside = Within(uvec, outline_count, plate_outline_uvecs) !================================================================= IF(inside) THEN nPoint = nPoint + 1 iPlate = iP END IF 500 CONTINUE IF (iPlate == 0) THEN xPoint = 90.0D0 - (xInPl * 57.2957795130823D0) yPoint = yInPl * 57.2957795130823D0 WRITE(iUnitT, 600) xPoint, yPoint WRITE(*, 600) xPoint, yPoint, oldIP 600 FORMAT(/' THE POINT (',F13.5,'N, ',F13.5'E) DOES NOT BELONG TO ANY PLATE !!!!' & & /' Arbitrarily Assign-ing to last previous plate (#',I4,').') CALL Pause() iPlate = oldIP WRITE(*, "(' Continuing to assign all nodes to plates...')") END IF IF(nPoint > 4) THEN xPoint = 90.0D0 - (xInPl * 57.2957795130823D0) yPoint = yInPl * 57.2957795130823D0 WRITE(iUnitT, 605) xPoint, yPoint 605 FORMAT(' THE POINT (',F13.5,'N, ',F13.5,'E) WAS FOUND IN MORE THAN FOUR PLATES; SOMETHING IS WRONG !!!!') CALL Pause() STOP END IF whichP(i) = iPlate oldIP = iPlate 999 CONTINUE END SUBROUTINE Assign SUBROUTINE Bad_Shells(variable) IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: variable WRITE (*,"(' ERROR reading variable: ',A& & / ' in Input_to_SHELLS.')") TRIM(variable) CALL DTraceback END SUBROUTINE Bad_Shells 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 FiniteMap 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 Compute_geotherms (conduc, dQdTdA, gradie, & & nodes, numEl, numNod, & & radio, tAdiab, tLInt, tSurf, zMoho, & ! input & geothC, geothM) ! output !Code copied from FillIn of Shells: !Computes geotherms at integration points of continuum elements. !However, note that it has been modified so as NOT to introduce or compute array "curviness"! IMPLICIT NONE REAL*8, INTENT(IN) :: conduc, dQdTdA, gradie ! input INTEGER, INTENT(IN) :: nodes, numEl, numNod ! input REAL*8, INTENT(IN) :: radio, tAdiab, tLInt, tSurf, zMoho ! input REAL*8, INTENT(OUT) :: geothC, geothM ! output (4, 7, numEl) DIMENSION conduc(2), nodes(3, numEl), dQdTdA(numNod), radio(2), tLInt(7, numEl), zMoho(7, numEl) DIMENSION geothC(4, 7, numEl), geothM(4, 7, numEl) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DOUBLE PRECISION points COMMON / S1S2S3 / points DIMENSION points(3, 7) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - INTEGER :: i, m REAL*8 :: delta_quadratic, dTdZC, dTdZM, geoth1, geoth2, geoth3, geoth4, & & q, terr0r, test, tAsthK, z ! Geotherm: ! -------------- The following method is easy but WRONG!----------- !CCC CALL Interp (cooling_curvature, nodes, numEl, numNod, & ! input !CCC & curviness) ! output ! ----------The nonlinearities are too great for this approach,---- ! especially when one node of the element is on a ! spreading ridge. ! The correct way is to set curviness(m, i) to make the ! geotherm of each integration point arrive at ! temperature tAsthK = tAdiab + gradie * 100.D3 ! at depth (in lithosphere) of ! (zMoho(M,I)+tLInt(M,I)). ! ----------------------------------------------------------------- tAsthK = tAdiab + gradie * 100.0D3 geoth1 = tSurf geoth3 = -0.5D0 * radio(1) / conduc(1) geoth4 = 0.0D0 geoth7 = -0.5D0 * radio(2) / conduc(2) geoth8 = 0.0D0 DO 90 m = 1, 7 DO 80 i = 1, numEl ! N.B. On first pass, omit curviness: geothC(1, m, i) = geoth1 q = dQdTdA(nodes(1, i)) * points(1, m) + & & dQdTdA(nodes(2, i)) * points(2, m) + & & dQdTdA(nodes(3, i)) * points(3, m) geothC(2, m, i) = q / conduc(1) geothC(3, m, i) = geoth3 geothC(4, m, i) = geoth4 z = zMoho(m, i) geothM(1, m, i) = geothC(1, m, i) + & & geothC(2, m, i) * z + & & geothC(3, m, i) * z**2 + & & geothC(4, m, i) * z**3 dTdZC = geothC(2, m, i) + & & 2.0D0 * geothC(3, m, i) * z + & & 3.0D0 * geothC(4, m, i) * z**2 dTdZM = dTdZC * conduc(1) / conduc(2) geothM(2, m, i) = dTdZM geothM(3, m, i) = geoth7 geothM(4, m, i) = geoth8 ! Now, correct geotherm to hit tAsthK: IF (tLInt(m, i) > 0.0D0) THEN test = geothM(1, m, i) + & & geothM(2, m, i) * tLInt(m, i) + & & geothM(3, m, i) * tLInt(m, i)**2 + & & geothM(4, m, i) * tLInt(m, i)**3 ELSE test = geothC(1, m, i) + & & geothC(2, m, i) * zMoho(m, i) + & & geothC(3, m, i) * zMoho(m, i)**2 + & & geothC(4, m, i) * zMoho(m, i)**3 END IF terr0r = test - tAsthK delta_quadratic = -terr0r / (zMoho(m, i) + tLInt(m, i))**2 !curviness(m, i) = -2.0D0 * delta_quadratic geothC(3, m, i) = geoth3 + delta_quadratic geothM(3, m, i) = geoth7 + delta_quadratic geothM(1, m, i) = geothC(1, m, i) + & & geothC(2, m, i) * zMoho(m, i) + & & geothC(3, m, i) * zMoho(m, i)**2 + & & geothC(4, m, i) * zMoho(m, i)**3 dTdZC = geothC(2, m, i) + & & 2.0D0 * geothC(3, m, i) * zMoho(m, i) + & & 3.0D0 * geothC(4, m, i) * zMoho(m, i)**2 dTdZM = dTdZC * conduc(1) / conduc(2) geothM(2, m, i) = dTdZM 80 CONTINUE 90 CONTINUE END SUBROUTINE Compute_geotherms SUBROUTINE CONVEC (ICONVE,IPAFRI,IPVREF,IUNITM,IUNITT, & & NAMES,NDPLAT, & & NFL,NODEF,NODES, & & NPBND,NPLATE,NUMEL,NUMNOD, & & OMEGA,path_in,PLAT,PLON,RADIUS,VTIMES, & & XNODE,YNODE, & ! inputs & VM ) ! output array !COMPUTES LOWER-MANTLE FLOW VELOCITY BELOW ASTHENOSPHERE !COMPUTATION STRATEGY VARIES BY MODEL; FOR MANY, DATA FILES ! MUST BE READ FROM UNIT IUNITM. !REGARDLESS OF MODEL, THE FACTOR VTIMES IS APPLIED. !VELOCITIES ARE INITIALLY COMPUTED IN THE AFRICA-FIXED ! REFERENCE FRAME (FOR HISTORICAL REASONS); THEN THEY ARE ! TRANSFORMED TO APPEAR IN THE REFERENCE FRAME OF PLATE ! #IPVREF; THIS IS DONE BY A COMMON TRANSFORMATION AT THE END OF ! THIS ROUTINE. !Copied February 1999 from SHELLS, and modified (as little as ! possible) to create free-form Fortran 90. !Another necessary change at that time was introducing explicit ! OPEN statements with informative prompts. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: path_in CHARACTER*2,DIMENSION(:), INTENT(IN) :: NAMES ! (NPLATE) INTEGER, INTENT(IN) :: ICONVE, IPAFRI, IPVREF, & & IUNITM, IUNITT, & & NFL, NPBND, NPLATE, NUMEL, NUMNOD INTEGER, DIMENSION(:), INTENT(IN) :: NDPLAT INTEGER, DIMENSION(:,:),INTENT(IN) :: NODEF, NODES REAL*8, INTENT(IN) :: RADIUS, VTIMES REAL*8, DIMENSION(:), INTENT(IN) :: XNODE, YNODE ! THETA, PHI(NUMNOD) REAL*8, DIMENSION(:,:),INTENT(IN) :: OMEGA, & ! (3,NPLATE) & PLAT, PLON ! (NPLATE,NPBND) REAL*8, DIMENSION(:,:),INTENT(OUT):: VM ! (2, NUMNOD) CHARACTER*1 :: C1 CHARACTER*27 :: ENDSEG CHARACTER*80 :: pathfile INTEGER :: I, IOS, IR, IRBOT, IRTOP, ISOUTH, J, JC, JCLEFT, JCRIGH, JEAST, JVEC, & & K, N1, N2, N3, NUMVEC LOGICAL :: GOTOUT LOGICAL(1), DIMENSION(:), ALLOCATABLE :: CHECKN REAL*8 :: A1, A2, A3, AB1, AB2, AB3, AC, B1, B2, B3, BC, COSDEG, DEG, FE, ELON1, ELON2, EQUAT, & & FS, G1, G2, G3, GC, HX, HY, HZ, NLAT1, NLAT2, OMEGAX, OMEGAY, OMEGAZ, & & PHI, PHIX, PHIY, PHIZ, R2, R2MIN, SINDEG, SIZE, THETA, THETAX, THETAY, THETAZ, & & TX, TY, TZ, VBOT, VPHI, VTHETA, VTOP, VX, VY, VZ, XINPL, XN, XVEL, YINPL, YN, YVEL, ZN REAL*8, DIMENSION(2,-8:8,1:36) :: HOC792 REAL*8, DIMENSION(5,1000) :: BAUM88 !STATEMENT FUNCTIONS: COSDEG(DEG)=DCOS(DEG*0.017453293D0) SINDEG(DEG)=DSIN(DEG*0.017453293D0) !- - - - - - - - - - - - - - IF (ICONVE.EQ.0) THEN DO 99 I=1,NUMNOD VM(1,I)=0.0D0 VM(2,I)=0.0D0 !NOTE: THIS IS IN AFRICA-FIXED REFERENCE FRAME; !SEE BELOW AT END OF ROUTINE FOR TRANSFORMATION. 99 CONTINUE ELSE IF (ICONVE.EQ.1) THEN !HAGER AND O'CONNELL (1979) VISCOSITY MODEL II !READ FROM FILE "HOC79II.DIG" ON DEVICE IUNITM. !VECTORS ARE EVERY 10 DEGREES IN LATITUDE AND LONGITUDE !COLUMNS MARCH EAST FROM 10E TO 360E. !WITHIN EACH COLUMN, TRAVEL IS S FROM 80N TO 80S. !UNITS OF INPUT DATA ARE DEGREES EAST AND NORTH. !2ND END OF LINE SEGMENT SHOWS WHERE THE GRID POINT !WILL BE DISPLACED TO AFTER 50 MA OF FLOW. pathfile=TRIM(path_in)//'HOC79II.DIG' 100 OPEN (UNIT=IUNITM,FILE=pathfile,STATUS='OLD',PAD='YES',IOSTAT=IOS) IF (IOS.NE.0) THEN WRITE(IUNITT,"(' ERROR: File HOC79II.DIG not found in input directory:' & & /' ',A)") path_in WRITE(IUNITT,"(' Please pause this program, move this file in, and press Enter:')") CALL DPress_Enter mt_flashby = .FALSE. GO TO 100 END IF DO 140 JEAST=1,36 DO 130 ISOUTH=-8,8 READ (IUNITM,*,END=101,ERR=101) ELON1,NLAT1 GO TO 103 !-------------------- ERR0R HANDLER ---------- 101 WRITE (IUNITT,102) IUNITM,JEAST,ISOUTH 102 FORMAT (/' ERR0R IN -CONVEC-:' & & /' WHILE READING MANTLE VELOCITIES FROM' & & ,' UNIT ',I3 & & /' TO FILL IN COLUMN ',I2,', ROW ',I2 & & /' ENCOUNTERED A RECORD WHICH DOES NOT' & & ,' HOLD TWO RECOGNIZABLE NUMBERS.') CALL DTraceback !--------------------------------------------- 103 JC=(ELON1/10.D0)+0.5D0 IF (NLAT1.GE.0.D0) THEN IR=(NLAT1/10.D0)+0.5D0 IR= -IR ELSE IR=(-NLAT1/10.D0)+0.5D0 END IF IF ((JC.NE.JEAST).OR.(IR.NE.ISOUTH)) THEN WRITE (IUNITT,104) IUNITM,ISOUTH,JEAST,IR,JC, & & ELON1,NLAT1 104 FORMAT (/' ERR0R: WHILE READING LOWER-MANTLE' & & ,' FLOW VECTORS FROM UNIT ',I3 & & /' AND LOOKING FOR ROW ',I2,', COLUMN ',I2 & & /' ENCOUNTERED ROW ',I2,', COLUMN ',I2 & & /' (LONGITUDE ',F7.2,', LATITUDE ',F6.2,') & & ') CALL DTraceback END IF READ (IUNITM,*,ERR=101,END=101) ELON2,NLAT2 READ (IUNITM,'(A)') ENDSEG TX=COSDEG(NLAT1)*COSDEG(ELON1) TY=COSDEG(NLAT1)*SINDEG(ELON1) TZ=SINDEG(NLAT1) HX=COSDEG(NLAT2)*COSDEG(ELON2) HY=COSDEG(NLAT2)*SINDEG(ELON2) HZ=SINDEG(NLAT2) VX=(HX-TX)*RADIUS/(50.D6*3.15576D7) VY=(HY-TY)*RADIUS/(50.D6*3.15576D7) VZ=(HZ-TZ)*RADIUS/(50.D6*3.15576D7) THETAX=SINDEG(NLAT1)*COSDEG(ELON1) THETAY=SINDEG(NLAT1)*SINDEG(ELON1) THETAZ= -COSDEG(NLAT1) VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ PHIX= -SINDEG(ELON1) PHIY=COSDEG(ELON1) PHIZ=0.0D0 VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ HOC792(1,IR,JC)=VTHETA HOC792(2,IR,JC)=VPHI 130 CONTINUE 140 CONTINUE CLOSE(IUNITM) DO 190 I=1,NUMNOD NLAT1=90.D0-XNODE(I)*57.2958D0 NLAT1=MIN(NLAT1,+79.99D0) NLAT1=MAX(NLAT1,-79.99D0) ELON1=YNODE(I)*57.2958D0 IF (ELON1.LT.0.D0) ELON1=ELON1+360.D0 IF (ELON1.LT.0.D0) ELON1=ELON1+360.D0 IF (ELON1.GT.360.D0) ELON1=ELON1-360.D0 IF (NLAT1.GE.0.D0) THEN IRTOP=(NLAT1/10.D0)+1.0D0 IRTOP= -IRTOP ELSE IRTOP=(-NLAT1/10.D0) END IF IF (IRTOP.LT.8) THEN IRBOT=IRTOP+1 FS=(-IRTOP*10.D0-NLAT1)/10.D0 ELSE IRBOT=IRTOP FS=0.0D0 END IF JCRIGH=ELON1/10.D0+1.0D0 JCRIGH=MIN(JCRIGH,36) IF (JCRIGH.GT.1) THEN JCLEFT=JCRIGH-1 FE=(ELON1-10.D0*JCLEFT)/10.D0 ELSE JCLEFT=36 FE=ELON1/10.D0 END IF VTOP=HOC792(1,IRTOP,JCLEFT)+ & & (HOC792(1,IRTOP,JCRIGH)-HOC792(1,IRTOP,JCLEFT))*FE VBOT=HOC792(1,IRBOT,JCLEFT)+ & & (HOC792(1,IRBOT,JCRIGH)-HOC792(1,IRBOT,JCLEFT))*FE VM(1,I)=VTOP+(VBOT-VTOP)*FS VTOP=HOC792(2,IRTOP,JCLEFT)+ & & (HOC792(2,IRTOP,JCRIGH)-HOC792(2,IRTOP,JCLEFT))*FE VBOT=HOC792(2,IRBOT,JCLEFT)+ & & (HOC792(2,IRBOT,JCRIGH)-HOC792(2,IRBOT,JCLEFT))*FE VM(2,I)=VTOP+(VBOT-VTOP)*FS VM(1,I)=VM(1,I)*VTIMES VM(2,I)=VM(2,I)*VTIMES 190 CONTINUE ELSE IF (ICONVE.EQ.2) THEN !BAUMGARDNER (1988) FIGURE 7, PARTS A-F !READ FROM FILE "BAUM887.DIG" ON DEVICE IUNITM. !VECTORS ARE IN RANDOM ORDER, ABOUT 729 IN ALL. !UNITS OF INPUT DATA ARE DEGREES EAST AND NORTH. !2ND END OF LINE SEGMENT SHOWS WHERE THE GRID POINT !WILL BE DISPLACED TO AFTER 11 MA OF FLOW. !(TIME WOULD BE 110 MA, BUT HE SAYS TO SCALE V UP !*10 BECAUSE EARTH'S RAYLEIGH NUMBER IS HIGHER THAN !THAT OF THE MODEL.) pathfile=TRIM(path_in)//'BAUM887.DIG' 200 OPEN (UNIT=IUNITM,FILE=pathfile,STATUS='OLD',PAD='YES',IOSTAT=IOS) IF (IOS.NE.0) THEN WRITE(IUNITT,"(' ERROR: File BAUM887.DIG not found in input directory:' & & /' ',A)") path_in WRITE(IUNITT,"(' Please pause this program, move this file in, and press Enter:')") READ(*,"(A)") C1 mt_flashby = .FALSE. GO TO 200 END IF NUMVEC=0 DO 220 JVEC=1,1000 READ (IUNITM,*,END=221,ERR=201) ELON1,NLAT1 GO TO 203 !-------------------- ERR0R HANDLER ---------- 201 WRITE (IUNITT,202) IUNITM,JVEC 202 FORMAT (/' ERR0R IN -CONVEC-:' & & /' WHILE READING MANTLE VELOCITIES FROM' & & ,' UNIT ',I3 & & /' TO FILL IN VECTOR ',I2, & & /' ENCOUNTERED A RECORD WHICH DOES NOT' & & ,' HOLD TWO RECOGNIZABLE NUMBERS.') CALL DTraceback !--------------------------------------------- 203 READ (IUNITM,*,ERR=201,END=221) ELON2,NLAT2 READ (IUNITM,'(A)') ENDSEG TX=COSDEG(NLAT1)*COSDEG(ELON1) TY=COSDEG(NLAT1)*SINDEG(ELON1) TZ=SINDEG(NLAT1) HX=COSDEG(NLAT2)*COSDEG(ELON2) HY=COSDEG(NLAT2)*SINDEG(ELON2) HZ=SINDEG(NLAT2) VX=(HX-TX)*RADIUS/(11.D6*3.15576D7) VY=(HY-TY)*RADIUS/(11.D6*3.15576D7) VZ=(HZ-TZ)*RADIUS/(11.D6*3.15576D7) THETAX=SINDEG(NLAT1)*COSDEG(ELON1) THETAY=SINDEG(NLAT1)*SINDEG(ELON1) THETAZ= -COSDEG(NLAT1) VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ PHIX= -SINDEG(ELON1) PHIY=COSDEG(ELON1) PHIZ=0.0D0 VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ BAUM88(1,JVEC)=VTHETA BAUM88(2,JVEC)=VPHI BAUM88(3,JVEC)=TX BAUM88(4,JVEC)=TY BAUM88(5,JVEC)=TZ NUMVEC=NUMVEC+1 220 CONTINUE 221 CLOSE(IUNITM) DO 290 I=1,NUMNOD TX=DSIN(XNODE(I))*DCOS(YNODE(I)) TY=DSIN(XNODE(I))*DSIN(YNODE(I)) TZ=DCOS(XNODE(I)) R2MIN=999.D0 DO 280 J=1,NUMVEC R2=(TX-BAUM88(3,J))**2+ & & (TY-BAUM88(4,J))**2+ & & (TZ-BAUM88(5,J))**2 IF (R2.LT.R2MIN) THEN R2MIN=R2 VM(1,I)=BAUM88(1,J) VM(2,I)=BAUM88(2,J) VM(1,I)=VM(1,I)*VTIMES VM(2,I)=VM(2,I)*VTIMES END IF 280 CONTINUE 290 CONTINUE ELSE IF ((ICONVE.EQ.3).OR.(ICONVE.EQ.4)) THEN !PB2002 plate model of Bird [2003; G**3]; !Already has plate -NAMES- and -OMEGA- vectors from !calling program; must also have digitised plate !boundaries in arrays -PLAT- and -PLON-. !That is, this routine does no I/O. WRITE (*,"(' Assigning nodes to plates...')") ALLOCATE ( CHECKN(NUMNOD) ) !CHECK WHICH NODES ARE ON FAULTS: DO 310 I=1,NUMNOD CHECKN(I)=.FALSE. 310 CONTINUE DO 320 I=1,NFL DO 315 K=1,4 CHECKN(NODEF(K,I))=.TRUE. 315 CONTINUE 320 CONTINUE !FOR NODES ON FAULTS, ATTEMPT TO OFFSET TEST POSITION !WHICH IS USED TO DETERMINE PLATE MEMBERSHIP !(BUT NOT POSITION USED IN V = OMEGA X R ) DO 390 I=1,NUMNOD XVEL=XNODE(I) YVEL=YNODE(I) IF (CHECKN(I)) THEN GOTOUT=.FALSE. DO 330 J=1,NUMEL N1=NODES(1,J) N2=NODES(2,J) N3=NODES(3,J) IF ((N1.EQ.I).OR.(N2.EQ.I).OR.(N3.EQ.I)) THEN IF ((N1.NE.I).AND.(.NOT.CHECKN(N1)))THEN GOTOUT=.TRUE. XINPL=XNODE(N1) YINPL=YNODE(N1) GO TO 331 END IF IF ((N2.NE.I).AND.(.NOT.CHECKN(N2)))THEN GOTOUT=.TRUE. XINPL=XNODE(N2) YINPL=YNODE(N2) GO TO 331 END IF IF ((N3.NE.I).AND.(.NOT.CHECKN(N3)))THEN GOTOUT=.TRUE. XINPL=XNODE(N3) YINPL=YNODE(N3) GO TO 331 END IF END IF 330 CONTINUE 331 IF (.NOT.GOTOUT) THEN DO 340 J=1,NUMEL N1=NODES(1,J) N2=NODES(2,J) N3=NODES(3,J) IF ((N1.EQ.I).OR.(N2.EQ.I).OR. & & (N3.EQ.I)) THEN A1=DSIN(XNODE(N1))*DCOS(YNODE(N1)) B1=DSIN(XNODE(N1))*DSIN(YNODE(N1)) G1=DCOS(XNODE(N1)) A2=DSIN(XNODE(N2))*DCOS(YNODE(N2)) B2=DSIN(XNODE(N2))*DSIN(YNODE(N2)) G2=DCOS(XNODE(N2)) A3=DSIN(XNODE(N3))*DCOS(YNODE(N3)) B3=DSIN(XNODE(N3))*DSIN(YNODE(N3)) G3=DCOS(XNODE(N3)) AC=(A1+A2+A3)/3.D0 BC=(B1+B2+B3)/3.D0 GC=(G1+G2+G3)/3.D0 SIZE=DSQRT(AC**2+BC**2+GC**2) AC=AC/SIZE BC=BC/SIZE GC=GC/SIZE EQUAT=DSQRT(AC**2+BC**2) XINPL=DATAN2(EQUAT,GC) YINPL=DATAN2(BC,AC) GO TO 341 END IF 340 CONTINUE 341 CONTINUE END IF ELSE XINPL=XVEL YINPL=YVEL END IF WRITE (*,"('+Assigning nodes to plates...',I6)") I CALL FINDPV (IPAFRI,IUNITT,NDPLAT,NPBND,NPLATE,OMEGA, & & PLAT,PLON,RADIUS, & & XINPL,XVEL,YINPL,YVEL, & & VPHI,VTHETA) VM(1,I)=VTHETA*VTIMES VM(2,I)=VPHI*VTIMES 390 CONTINUE DEALLOCATE ( CHECKN ) WRITE (*,"('+Assigning nodes to plates...DONE ')") ELSE WRITE (IUNITT,999) ICONVE 999 FORMAT (/' ILLEGAL INTEGER CODE FOR LOWER-MANTLE' & & /' CONVECTION PATTERN (ICONVE): ',I6) CALL DTraceback END IF !END OF SELECTION BASED ON ICONVE; !NOW APPLY VELOCITY REFERENCE FRAME TRANSFORMATION FROM !AFRICA-FIXED (PLATE #IAFRI-FIXED) TO PLATE #IPVREF-FIXED: !ROTATION OF PLATE IPVREF WRT AFRICA, IN RADIANS/SECOND: OMEGAX=(OMEGA(1,IPVREF)-OMEGA(1,IPAFRI))*3.168809D-14 OMEGAY=(OMEGA(2,IPVREF)-OMEGA(2,IPAFRI))*3.168809D-14 OMEGAZ=(OMEGA(3,IPVREF)-OMEGA(3,IPAFRI))*3.168809D-14 !CONVERT TO LENGTH/SECOND: OMEGAX=OMEGAX*RADIUS OMEGAY=OMEGAY*RADIUS OMEGAZ=OMEGAZ*RADIUS DO 2000 I=1,NUMNOD !VELOCITY OF IPVREF WRT AFRICA = OMEGA X POSITION: THETA=XNODE(I) PHI=YNODE(I) XN=DSIN(THETA)*DCOS(PHI) YN=DSIN(THETA)*DSIN(PHI) ZN=DCOS(THETA) VX=OMEGAY*ZN-OMEGAZ*YN VY=OMEGAZ*XN-OMEGAX*ZN VZ=OMEGAX*YN-OMEGAY*XN !CREATE UNIT +THETA AND +PHI VECTORS IN CARTESIAN: THETAX=DCOS(THETA)*DCOS(PHI) THETAY=DCOS(THETA)*DSIN(PHI) THETAZ= -DSIN(THETA) PHIX= -DSIN(PHI) PHIY=DCOS(PHI) PHIZ=0.0D0 !FIND ARGUMENT FROM DOT PRODUCTS: VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ !TRANSFORM THE VELOCITY PREVIOUSLY FOUND IN THE !AFRICA-FIXED REFERENCE FRAME TO ONE IN THE !IPVREF-FIXED REFERENCE FRAME: VM(1,I)=VM(1,I)-VTHETA VM(2,I)=VM(2,I)-VPHI 2000 CONTINUE END SUBROUTINE CONVEC 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 Deriv (iUnitT, mxEl, mxNode, & ! input & nodes, numEl, & & radius, xNode, yNode, & & area, detJ, & ! output & dXS, dYS, dXSP, dYSP, fPSfer, sita) ! Sets up 6 vector nodal functions (fPSfer) of each spherical ! triangle finite element, at each of its 7 integration points. ! Calculates dXS and dYS, the Theta-derivitive and Phi-derivitive ! of each of these 6 vector nodal functions. ! Also computes "area", the areas of the plane triangles. ! Also computes "detJ", the local ratio of areas on the sphere ! to areas on the plane triangles. IMPLICIT NONE ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - INTEGER, INTENT(IN) :: iUnitT, mxEl, mxNode, nodes, numEl ! input REAL*8, INTENT(IN) :: radius, xNode, yNode ! input REAL*8, INTENT(OUT) :: area, detJ, dXS, dYS, dXSP, dYSP, fPSfer, sita ! output ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DOUBLE PRECISION points DOUBLE PRECISION fff, skkc, skke, sncsne, snccse, csccse, cscsne DOUBLE PRECISION xa, xb, xc, ya, yb, yc, za, zb, zc, xyzp INTEGER i, j, m REAL*8 a, areaP, b, c, cka, cosm, cscs, cse, cssn, & & dd, dd1, dd2, dd3, ddpn, dpdc, dpde, & & pfq, phaij, phi, pnx, pny, pnz, pp, rn, rr1, rr2, rr3, & & sitaj, sitami, snc, sne, theta, tx, ty, & & x21, x31, y21, y31, z21, z31 DIMENSION xNode(mxNode), yNode(mxNode), nodes(3, mxEl), area(mxEl) DIMENSION detJ(7, mxEl) DIMENSION dXS(2, 2, 3, 7, mxEl), dYS(2, 2, 3, 7, mxEl) DIMENSION dXSP(3, 7, mxEl), dYSP(3, 7, mxEl), points(3, 7) DIMENSION phi(3), theta(3), skkc(3), skke(3), fff(3), & & sita(7, mxEl), fPSfer(2, 2, 3, 7, mxEl) COMMON / S1S2S3 / points DO 900 i = 1, numEl DO 100 j = 1, 3 theta(j) = xNode(nodes(j, i)) phi(j) = yNode(nodes(j, i)) 100 CONTINUE x21 = SIN(theta(2)) * COS(phi(2)) - SIN(theta(1)) * COS(phi(1)) x31 = SIN(theta(3)) * COS(phi(3)) - SIN(theta(1)) * COS(phi(1)) y21 = SIN(theta(2)) * SIN(phi(2)) - SIN(theta(1)) * SIN(phi(1)) y31 = SIN(theta(3)) * SIN(phi(3)) - SIN(theta(1)) * SIN(phi(1)) z21 = COS(theta(2)) - COS(theta(1)) z31 = COS(theta(3)) - COS(theta(1)) a = y21 * z31 - y31 * z21 b = z21 * x31 - z31 * x21 c = x21 * y31 - x31 * y21 areaP = SQRT(a * a + b * b + c * c) area(i) = radius * radius * (0.5D0 * areaP) pnx = a / areaP pny = b / areaP pnz = c / areaP dd1 = SIN(theta(1)) * COS(phi(1)) * pnx dd2 = SIN(theta(1)) * SIN(phi(1)) * pny dd3 = COS(theta(1)) * pnz dd = dd1 + dd2 + dd3 ! This part is to test if Kong's method and Bird's method give the same ! results for the derivitive: xa = SIN(theta(1)) * COS(phi(1)) xb = SIN(theta(2)) * COS(phi(2)) xc = SIN(theta(3)) * COS(phi(3)) ya = SIN(theta(1)) * SIN(phi(1)) yb = SIN(theta(2)) * SIN(phi(2)) yc = SIN(theta(3)) * SIN(phi(3)) za = COS(theta(1)) zb = COS(theta(2)) zc = COS(theta(3)) cka = (yb * zc - zb * yc) * xa + (zb * xc - xb * zc) * ya + (xb * yc - yb * xc) * za DO 800 m = 1, 7 snccse = 0.0D0 sncsne = 0.0D0 cosm = 0.0D0 DO 200 j = 1, 3 snccse = snccse + points(j, m) * SIN(theta(j)) * COS(phi(j)) sncsne = sncsne + points(j, m) * SIN(theta(j)) * SIN(phi(j)) cosm = cosm + points(j, m) * COS(theta(j)) 200 CONTINUE xyzp = SQRT(snccse * snccse + sncsne * sncsne + cosm * cosm) snccse = snccse / xyzp sncsne = sncsne / xyzp cosm = cosm / xyzp sitaj = ACOS(cosm) ty = sncsne tx = snccse phaij = DATan2F(ty, tx) csccse = COS(sitaj) * COS(phaij) cscsne = COS(sitaj) * SIN(phaij) ! Bird's method: fff(1) = ((yb * zc - zb * yc) * snccse + (zb * xc - xb * zc) * sncsne & & + (xb * yc - yb * xc) * cosm) / cka fff(2) = ((yc * za - zc * ya) * snccse + (zc * xa - xc * za) * sncsne & & + (xc * ya - yc * xa) * cosm) / cka fff(3) = ((ya * zb - za * yb) * snccse + (za * xb - xa * zb) * sncsne & & + (xa * yb - ya * xb) * cosm) / cka skkc(1) = ((yb * zc - zb * yc) * csccse & & + (zb * xc - xb * zc) * cscsne & & - (xb * yc - yb * xc) * SIN(sitaj)) / cka skkc(2) = ((yc * za - zc * ya) * csccse & & + (zc * xa - xc * za) * cscsne & & - (xc * ya - yc * xa) * SIN(sitaj)) / cka skkc(3) = ((ya * zb - za * yb) * csccse & & + (za * xb - xa * zb) * cscsne & & - (xa * yb - ya * xb) * SIN(sitaj)) / cka skke(1) = (-(yb * zc - zb * yc) * sncsne & & + (zb * xc - xb * zc) * snccse) / cka skke(2) = (-(yc * za - zc * ya) * sncsne & & + (zc * xa - xc * za) * snccse) / cka skke(3) = (-(ya * zb - za * yb) * sncsne & & + (za * xb - xa * zb) * snccse) / cka sita(m, i) = sitaj rr1 = SIN(sitaj) * COS(phaij) rr2 = SIN(sitaj) * SIN(phaij) rr3 = COS(sitaj) rn = rr1 * pnx + rr2 * pny + rr3 * pnz pp = dd / rn dpdc = (COS(sitaj) * COS(phaij) * pnx + COS(sitaj) * SIN(phaij) * pny & & - SIN(sitaj) * pnz) dpde = (-SIN(sitaj) * SIN(phaij) * pnx + & & SIN(sitaj) * COS(phaij) * pny) ddpn = pp / rn dpdc = -ddpn * dpdc dpde = -ddpn * dpde IF(sita(m, i) <= 0.0D0.OR.sita(m, i) >= 3.14159265358979D0) THEN sitami = sita(m, i) * 57.2957795130823D0 WRITE(iUnitT, 220) m, i, sitami 220 FORMAT(' COLATITUDE OF INTEGRATION POINT',I5, & & ' OF ELEMENT', & & I5,' IS OUT RANGE', & & D14.4) CALL Pause() STOP END IF DO 500 j = 1, 3 dXSP(j, m, i) = dpdc * fff(j) + pp * skkc(j) dYSP(j, m, i) = dpde * fff(j) + pp * skke(j) cscs = COS(theta(j)) * COS(phi(j)) cssn = COS(theta(j)) * SIN(phi(j)) snc = SIN(theta(j)) sne = SIN(phi(j)) cse = COS(phi(j)) fPSfer(1, 1, j, m, i) = cscs * csccse + cssn * cscsne & & + snc * SIN(sitaj) fPSfer(2, 1, j, m, i) = -sne * csccse + cse * cscsne fPSfer(1, 2, j, m, i) = -cscs * SIN(phaij) + cssn * COS(phaij) fPSfer(2, 2, j, m, i) = sne * SIN(phaij) + cse * COS(phaij) dXS(1, 1, j, m, i) = (-cscs * snccse - cssn * sncsne & & + snc * COS(sitaj)) * fff(j) & & + fPSfer(1, 1, j, m, i) * skkc(j) dXS(2, 1, j, m, i) = (sne * snccse - cse * sncsne) * fff(j) & & + fPSfer(2, 1, j, m, i) * skkc(j) dYS(1, 1, j, m, i) = (-cscs * cscsne + cssn * csccse) * fff(j) & & + fPSfer(1, 1, j, m, i) * skke(j) dYS(2, 1, j, m, i) = (sne * cscsne + cse * csccse) * fff(j) & & + fPSfer(2, 1, j, m, i) * skke(j) dXS(1, 2, j, m, i) = fPSfer(1, 2, j, m, i) * skkc(j) dXS(2, 2, j, m, i) = fPSfer(2, 2, j, m, i) * skkc(j) dYS(1, 2, j, m, i) = (-cscs * COS(phaij) - cssn * SIN(phaij)) & & * fff(j) & & + fPSfer(1, 2, j, m, i) * skke(j) dYS(2, 2, j, m, i) = (sne * COS(phaij) - cse * SIN(phaij)) & & * fff(j) & & + fPSfer(2, 2, j, m, i) * skke(j) fPSfer(1, 1, j, m, i) = fPSfer(1, 1, j, m, i) * fff(j) fPSfer(2, 1, j, m, i) = fPSfer(2, 1, j, m, i) * fff(j) fPSfer(1, 2, j, m, i) = fPSfer(1, 2, j, m, i) * fff(j) fPSfer(2, 2, j, m, i) = fPSfer(2, 2, j, m, i) * fff(j) 500 CONTINUE pfq = fff(1) + fff(2) + fff(3) ! orphan statement, left over from some test? (pfq does not seem to be used.) detJ(m, i) = rn**3 / (dd * dd) 800 CONTINUE 900 CONTINUE END SUBROUTINE Deriv SUBROUTINE Diamnd (aCreep, alphaT, bCreep, & ! input & Biot, cCreep, dCreep, & & eCreep, & & e1, e2, fric, g, & & geoth1, & & geoth2, & & geoth3, & & geoth4, & & pl0, pw0, & & rhoBar, rhoH2O, sigHBi, & & thick, temLim, & & visMax, zOfTop, & & pT1dE1, pT1dE2, & ! output & pT2dE1, pT2dE2, & & pT1, pT2, zTran) ! For one homogeneous layer (crust, *or* mantle lithosphere), ! computes the vertical integral, through the layer, of ! horizontal principal stresses (relative to the vertical stress); ! reports these as pT1 (more negative) and pT2 (more positive). ! Also reports zTran, the depth into the layer of the brittle/ ! ductile transition (greatest depth of earthquakes). ! Finally, recommends layer partial derivitives ! pT1dE1, pT1dE2, pT2dE1, pT2dE2 ! to be used in constructing "alpha" and tOfset (in -Viscos-), ! according to strategy in pages 3973-3977 of Bird (1989). ! In computing these, as in computing pT1 and pT2, the viscosity ! limit visMax is applied to the average behavior of the whole ! frictional layer, and again to the average behavior of the ! whole creeping layer; it is not applied locally at each depth. ! Necessary conditions when calling -Diamnd-: ! -> horizontal principal strain-rates e1 and e2 not both zero; ! -> e2 >= e1; ! -> layer thickness "thick" is positive. ! Note special kludge: if friction "fric" is >2.0D0, then this is ! taken to be a signal that NO frictional layer is desired, ! and that the whole layer should be power-law (or plastic, or ! viscous-- whichever gives the least shear stress). ! New version, May 5, 1998, by Peter Bird; intended to improve ! the convergence behavior of all F-E programs which use it. IMPLICIT NONE ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Arguments (*** all are scalars, even though ! these same names may be arrays in other programs! ***): REAL*8, INTENT(IN) :: aCreep, alphaT, bCreep, Biot, cCreep, dCreep, & ! input & eCreep, e1, e2, fric, g, & ! input & geoth1, geoth2, geoth3, geoth4, & ! input & pl0, pw0, & ! input & rhoBar, rhoH2O, sigHBi, & ! input & thick, temLim, visMax, zOfTop ! input REAL*8, INTENT(OUT) :: pT1, pT2, pT1dE1, pT1dE2, pT2dE1, pT2dE2, zTran ! output ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Internal variables: INTEGER n, nVStep DOUBLE PRECISION secInv REAL*8 angat2, angat3, angle, argume, & & delNeg, delPos, dSFdEV, & & dS1dE1, dS1dE2, dS2dE1, dS2dE2, & & dT1dE1, dT1dE2, dT2dE1, dT2dE2, dz, & & e1at1, e1at2, e1at3, e1at4, & & e2at1, e2at2, e2at3, e2at4, & & eSCrit, ez, & & frac, & & gamma, great, & & pH2O, & & r, rhoUse, & & sigma1, sigma2, s1Eff, s2Eff, s1rel, s2rel, & & sc0, sch, sc1, sf0, sfh, sf1, sTFric, sz, szEff, & & tau1, tau2, tecn, tecs, tect, tMean, tsfn, tsfs, tsft, & & t, t0, th, t1, & & vis, visDCr, visInf, visInt, visMin, visSHB, & & z, z0, zh, z1 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! CHARACTERIZE THE STRAIN-RATE TENSOR: ez = -(e1 + e2) ! (Formula for vertical strain-rate ez comes from the ! incompressibility of all permanent, anelastic strain types.) secInv = -(e1 * e2 + e1 * ez + e2 * ez) ! (One possible form for the second invariant of the matrix.) ! Note that the double-precision is just to prevent underflows ! from squaring small strain rates, not for precision. visInf = 0.5D0 * aCreep * (2.0D0 * SQRT(secInv))**(eCreep - 1.0D0) ! visInf is the viscosity for dislocation creep, lacking only ! the exponential term; therefore, as a mathematical abstraction, ! we can say that it is the viscosity at infinite temperature. ! CHARACTERIZE THE CONTINUUM FRICTION: sTFric = SIN(ATAN(fric)) gamma = (1.0D0 + sTFric) / (1.0D0 - sTFric) ! Note: For thrusting, effective-sigma1h is effective-sigma1z ! times gamma. For normal faulting, effective-sigma2h ! is effective-sigmaz/gamma. For small "fric", gamma ! is approximately equal to 1.+2.*fric ! FIND THE BRITTLE/DUCTILE TRANSITION (zTran, measured from ! the top of the layer): ! In the thrusting quadrant (e1<0, e2<0) and in the normal- ! faulting quadrant (e1>0, e2>0) the brittle/ductile transtion ! is clear: it the greatest depth of frictional behavior ! (possibly including earthquakes) on any fault, which is also ! the greatest depth of frictional behavior on the most active ! fault set. ! However, in the strike-slip quadrant (e1<0, e2>0) the ! transition is less clear. I do not know of any empirical ! field study which has determined how the transition depth ! depends on (e1+e2) within the transtensional and transpressional ! wedges of the strain-rate field. Therefore, we have to choose ! some simple rule. The rule that the transition is at the ! greatest depth of frictional behavior on any fault would ! create two discontinuities (at the e1=0 line, where normal ! faulting appears/dissapears; and at the e2=0 line, where ! strike-slip faulting appears/dissapears). Furthermore, the ! transition depth near to these lines (on the deeper side) would ! be defined by the less-active fault set, which asymptotically ! becomes totally inactive as the line is approached! If we ! chose the alternate rule of taking the deepest frictional ! behavior on the most active fault set, we would still have ! two discontinuities, although at different places, both within ! the strike-slip quadrant. My F-E programs cannot converge well ! when there is any discontinuity; therefore, I have chosen an ! arbitrary rule which smooths the transition depth across each ! of the transpressional and transtensional wedges, giving the ! correct (unambiguous) depths on the lines e1=0, e1=-e2, and ! e2=0. In order to do this, I apply SIN(2*theta) smoothing to ! both the frictional parameter dSFdEV and also to the creep ! parameter eSCrit, and then compute the transition depth from ! the combination of values. (I do this instead of smoothing ! the depth itself because I have no formula for the transition ! depth on any of these three lines, and would have to locate ! it by additional numerical searches.) ! eSCrit is the shear strain rate (tensor type, = ! 0.5*(larger principal rate - smaller principal rate) ! of the shear system which defines the transition ! from the creep side (from below); ! dSFdEV is the partial derivitive of the maximum shear ! stress (on any plane) in the frictional domain ! with respect to effective vertical stress ! (vertical stress plus Biot times water pressure). IF (e1 >= 0.0D0) THEN IF (e2 >= 0.0D0) THEN ! Normal-normal; faster E2 dominates. eSCrit = 0.50D0 * (e2 - ez) dSFdEV = 0.50D0 * (1.0D0 - (1.0D0 / gamma)) ELSE ! (e1 >=0, e2 < 0) ! e2 < e1? Should not happen! WRITE(*, "(/' ERR','OR in DIAMND: e1:',1P,D10.2,' > e2:' & & D10.2)") e1, e2 CALL Pause() STOP END IF ELSE ! Note: (E1 < 0) IF (e2 >= 0.0D0) THEN ! Note: (e1 < 0, E2 >= 0) IF (ez >= 0.0D0) THEN ! Transpression (T/S). ! Enforce smooth transition in dSFdEV ! as the pure strike-slip line is approached. ! (This smoothing cannot be with visMax because ! zTran is not yet known; instead, use a smooth ! function of angle from origin of the ! strain-rate plane, varying over 45 degrees ! from the pure-strike-slip line e1=-e2 ! to the pure-thrust line e2=0.) tsft = 0.50D0 * (gamma - 1.0D0) tsfs = sTFric ! Note: One might expect tsfs=fric, but check on ! a Mohr-circle diagram, remembering that the ! pure strike-slip condition is eZ==0 --> ! szzEff = 0.5 * (s1Eff + s2Eff). ! Also remember that the "SF" in dSFdEV is not the ! shear stress on the fault, but the maximum shear ! stress, because this is what creep will attack and ! lower first, at the brittle/ductile transition. angle = DATan2F(e2, e1) dSFdEV = tsfs + (tsft - tsfs) * SIN(2.0D0 * (angle - 2.3561945D0)) r = SQRT(e1**2 + e2**2) tect = 1.0D0 tecs = 0.7071067D0 eSCrit = r * (tecs + (tect - tecs) * SIN(2.0D0 * (angle - 2.3561945D0))) ELSE ! Note: (e1 < 0, e2 >= 0, eZ < 0) ! Transtension (N/S). ! Enforce smooth transition in dSFdEV ! as the pure strike-slip line is approached. ! (This smoothing cannot be with visMax because ! zTran is not yet known; instead, use a smooth ! function of angle from origin of the ! strain-rate plane, varying over 45 degrees ! from the pure-strike-slip line e1=-e2 to the ! pure-normal faulting line e1=0.) tsfn = 0.5D0 * (1.0D0 - (1.0D0 / gamma)) tsfs = sTFric ! Note: One might expect tsfs=fric, but check on ! a Mohr-circle diagram, remembering that the ! pure strike-slip condition is ez==0 --> ! szzEff = 0.5 * (s1Eff + s2Eff). ! Also remember that the "SF" in dSFdEV is not the ! shear stress on the fault, but the maximum shear ! stress, because this is what creep will attack and ! lower first, at the brittle/ductile transition. angle = DATan2F(e2, e1) dSFdEV = tsfs + (tsfn - tsfs) * SIN(2.0D0 * (2.3561945D0 - angle)) r = SQRT(e1**2 + e2**2) tecn = 1.0D0 tecs = 0.7071067D0 eSCrit = r * (tecs + (tecn - tecs) * SIN(2.0D0 * (2.3561945D0 - angle))) END IF ELSE ! Note: (e1 < 0, e2 < 0) ! Thrust-thrust; faster (more negative) e1 dominates. eSCrit = 0.5D0 * (ez - e1) dSFdEV = 0.5D0 * (gamma - 1.0D0) END IF END IF ! Use eSCrit and dSFdEV to locate zTran (brittle/ductile trans.): IF (fric > 2.0D0) THEN ! Special kludge; no frictional layer is wanted ! (for models with a purely power-law or linear-viscous ! rheology, you specify an unrealistically high friction. ! This makes the transition occur at the surface, and ! below the surface, the friction value is irrelevant.) zTran = 0. ELSE ! Normal case; compute friction and creep at top and bottom: z0 = 0.0D0 sf0 = dSFdEV * (pl0 - Biot * pw0) t0 = MIN(temLim, geoth1) argume = (bCreep + cCreep * zOfTop) / t0 ! Avoid overflow in EXP() by limiting the argument: argume = MAX(MIN(argume, 87.0D0), -87.0D0) sc0 = 2.0D0 * (visInf * eSCrit) * EXP(argume) sc0 = MIN(sc0, dCreep) z1 = thick tMean = geoth1 + & & 0.50D0 * geoth2 * z1 + & & 0.3330D0 * geoth3 * z1**2 + & & 0.250D0 * geoth4 * z1**3 rhoUse = rhoBar * (1.0D0 - alphaT * tMean) sf1 = sf0 + dSFdEV * (rhoUse - Biot * rhoH2O) * g * thick t1 = MIN(temLim, geoth1 + geoth2 * z1 + geoth3 * z1**2 + geoth4 * z1**3) argume = (bCreep + cCreep * (zOfTop + z1)) / t1 argume = MAX(MIN(argume, 87.0D0), -87.0D0) sc1 = 2.0D0 * (visInf * eSCrit) * EXP(argume) sc1 = MIN(sc1, dCreep) sc1 = MAX(sc1, sigHBi) ! Check if whole layer is frictional: IF (sc1 >= sf1) THEN zTran = thick ! Check if none of layer is frictional: ELSE IF (sc0 <= sf0) THEN zTran = 0.0D0 ELSE ! Transition is within layer, between z0 and z1. ! Use a binary-division search to bracket within ! the nearest 1/128 of the layer (usually, within ! 0.5 km); then, finish with linear interpolation. ! Note ASSUMPTION: T increases montonically with z!!! ! Also note that linearity may fail if the ! power-law/dCreep-limit transition falls into the ! remaining interval; however, the error will be small. DO 100 n = 1, 7 zh = 0.50D0 * (z0 + z1) tMean = 0.50D0 * (t0 + t1) rhoUse = rhoBar * (1.0D0 - alphaT * tMean) sfh = sf0 + dSFdEV * (rhoUse - Biot * rhoH2O) * g * (zh - z0) th = MIN(temLim, geoth1 + geoth2 * zh + geoth3 * zh**2 + & & geoth4 * zh**3) argume = (bCreep + cCreep * (zOfTop + zh)) / th argume = MAX(MIN(argume, 87.0D0), -87.0D0) sch = 2.0D0 * (visInf * eSCrit) * EXP(argume) sch = MIN(sch, dCreep) sch = MAX(sch, sigHBi) IF (sch > sfh) THEN ! Transition is between zh and z1. z0 = zh sf0 = sfh t0 = th sc0 = sch ELSE ! Transition is between z0 and zh. z1 = zh sf1 = sfh t1 = th sc1 = sch END IF 100 CONTINUE delNeg = sf0 - sc0 delPos = sf1 - sc1 frac = -delNeg / (delPos - delNeg) IF ((frac < -0.01D0).OR.(frac > 1.01D0)) THEN WRITE(*, "(' WARNING: Failure to bracket zTran', & & ' within -Diamnd-.')") END IF frac = MIN(1.0D0, MAX(0.0D0, frac)) zTran = z0 + frac * (z1 - z0) END IF END IF ! SUM TAU (AND DERIVITIVES) OVER FRICTIONAL AND CREEP LAYERS: ! Initialize sums over (up to) two layers: ! -brittle layer at <= zTran from the top; ! -creeping layer at > zTran from the top. pT1 = 0.0D0 pT2 = 0.0D0 pT1dE1 = 0.0D0 pT1dE2 = 0.0D0 pT2dE1 = 0.0D0 pT2dE2 = 0.0D0 ! COMPUTE AND ADD STRENGTH OF FRICTIONAL PART OF LAYER: IF (zTran > 0.0D0) THEN ! Compute the effective vertical stress at the midpoint ! of the frictional layer: tMean = geoth1 + & & 0.5D0 * geoth2 * (zTran / 2.0D0) + & & 0.333D0 * geoth3 * (zTran / 2.0D0)**2 + & & 0.25D0 * geoth4 * (zTran / 2.0D0)**3 rhoUse = rhoBar * (1.0D0 - alphaT * tMean) sz = -pl0 - rhoUse * g * zTran / 2.0D0 pH2O = pw0 + rhoH2O * g * zTran / 2.0D0 szEff = sz + Biot * pH2O ! Compute effective horizontal principal stresses, ! and their derivitives with respect to e1 and e2, ! at the midpoint of the frictional layer, according ! to the methods in Bird (1989), pages 3973-3977 ! (except, correcting the typos in the caption for ! Figure 4): ! Define the corner points of the diamond in the ! ordered principal strain-rate plane: e1at1 = ((1.0D0 / gamma) - 1.0D0) * szEff / (6.0D0 * visMax) e2at1 = e1at1 e1at2 = (1.0D0 - (1.0D0 / gamma)) * szEff / (6.0D0 * visMax) e2at2 = ((2.0D0 / gamma) - 2.0D0) * szEff / (6.0D0 * visMax) e1at3 = (2.0D0 * gamma - 2.0D0) * szEff / (6.0D0 * visMax) e2at3 = (1.0D0 - gamma) * szEff / (6.0D0 * visMax) e1at4 = (gamma - 1.0D0) * szEff / (6.0D0 * visMax) e2at4 = e1at4 angat2 = DATan2F((e2 - e2at2), (e1 - e1at2)) angat3 = DATan2F((e2 - e2at3), (e1 - e1at3)) ! Select proper segment of diagram and assign effective ! principal stresses. ! Also, begin definition of strategic stiffnesses ! dS1dE1, dS1dE2, dS2dE1, and dS2dE2, by computing ! stiffness required to give warning of local cliffs. ! Afterward, basic minimum stiffness required to avoid ! singularity of stiffness matrix will be imposed with ! a formula common to all regions. IF (e1 > e1at1) THEN ! Region N/N: two conjugate sets of normal faults s1Eff = szEff / gamma s2Eff = s1Eff dS1dE1 = (0.50D0 * ((1.0D0 / gamma) - 1.0D0) * szEff) / e1 dS1dE2 = 0.0D0 dS2dE1 = 0.0D0 dS2dE2 = (0.50D0 * ((1.0D0 / gamma) - 1.0D0) * szEff) / e2 ELSE IF ((e1 >= e1at2).AND.(angat2 > DATan2F((e2at1 - e2at2), (e1at1 - e1at2)))) THEN ! Region N: single conjugate set of normal faults s2Eff = szEff / gamma frac = (e1 - e1at1) / (e1at2 - e1at1) ! fraction increases in -e1 direction, from point 1 -> 2 s1Eff = szEff * ((1 / gamma) + frac * (1.0D0 - (1.0D0 / gamma))) dS1dE1 = 4.0D0 * visMax dS1dE2 = 0.0D0 dS2dE1 = 0.0D0 dS2dE2 = 0.0D0 ELSE IF ((angat2 <= 1.9635D0).AND.(angat2 >= 1.5707D0)) THEN ! Region N/S: transtension, dominantly normal. s1Eff = szEff s2Eff = szEff / gamma dS1dE1 = (0.5D0 * ((1.0D0 - 1.0D0 / gamma)) * szEff) / e1 dS1dE2 = 0.0D0 dS2dE1 = 0.0D0 dS2dE2 = 0.0D0 ELSE IF ((angat2 <= 2.3562D0).AND.(angat2 >= 1.9635D0)) THEN ! Region S/N: transtension, dominantly strike-slip. s1Eff = szEff s2Eff = szEff / gamma ! "great" is the value of dS1dE1 in region S: great = 6.0D0 * visMax * (gamma - 1.0D0) / (gamma - (1.0D0 / gamma)) ! "frac" is also defined exactly as in S, so here it ! will be negative: frac = ((e1 + e2) - (e1at2 + e2at2)) / & & ((e1at3 + e2at3) - (e1at2 + e2at2)) ! Reduce all derivitives according to distance: great = great * (-0.50D0) / (frac - 0.50D0) ! Pattern of derivitives is the same as in S: dS1dE1 = great dS1dE2 = dS1dE1 dS2dE1 = dS1dE1 / gamma dS2dE2 = dS2dE1 ELSE IF ((angat3 <= 2.3562D0).AND.(angat3 >= DATan2F((e2at2 - e2at3), (e1at2 - e1at3)))) THEN ! Region S: single set of conjugate strike-slip faults frac = ((e1 + e2) - (e1at2 + e2at2)) / & & ((e1at3 + e2at3) - (e1at2 + e2at2)) ! "frac" increases across band from the S/N (point 2) side ! toward the S/T (point 3) side; contours of "frac" are ! parallel to the band sides, not normal to the diamond. s1Eff = szEff * (1.0D0 + frac * (gamma - 1.0D0)) s2Eff = szEff * ((1.0D0 / gamma) + frac * (1.0D0 - (1.0D0 / gamma))) ! Notes: The equation of this line is s2Eff=s1Eff/gamma. ! I used algebra to check (1998.04.21) that the ! pure strike-slip stress (s1Eff,s2Eff)= ! szzEff*(1.+sTFric,1.-sTFric) correctly falls on ! this line, at the correct point (e1= -e2). dS1dE1 = 6.0D0 * visMax * (gamma - 1.0D0) / (gamma - (1.0D0 / gamma)) dS1dE2 = dS1dE1 dS2dE1 = dS1dE1 / gamma dS2dE2 = dS2dE1 ELSE IF ((angat3 <= 2.7489D0).AND.(angat3 >= 2.3562D0)) THEN ! Region S/T: transpression; strike-slip dominant. s1Eff = szEff * gamma s2Eff = szEff ! "great" is the value of dS1dE1 in region S: great = 6.0D0 * visMax * (gamma - 1.0D0) / (gamma - (1.0D0 / gamma)) ! "frac" is also defined exactly as in S, so here it ! will be greater than one: frac = ((e1 + e2) - (e1at2 + e2at2)) / & & ((e1at3 + e2at3) - (e1at2 + e2at2)) ! Reduce all derivitives according to distance: great = great * (0.50D0) / (frac - 0.50D0) ! Pattern of derivitives is the same as in S: dS1dE1 = great dS1dE2 = dS1dE1 dS2dE1 = dS1dE1 / gamma dS2dE2 = dS2dE1 ELSE IF ((e2 >= e2at3).AND.(angat3 >= 2.7489D0)) THEN ! Region T/S: transpression; thrusting dominant. s1Eff = szEff * gamma s2Eff = szEff dS1dE1 = 0.0D0 dS1dE2 = 0.0D0 dS2dE1 = 0.0D0 dS2dE2 = (0.50D0 * (1.0D0 - gamma) * szEff) / e2 ELSE IF ((e2 >= e2at4).AND.(angat3 <= DATan2F((e2at4 - e2at3), (e1at4 - e1at3)))) THEN ! Region T: single conjugate thrust fault set. s1Eff = szEff * gamma frac = (e2 - e2at3) / (e2at4 - e2at3) ! "frac" increases in the -e2 direction across the band. s2Eff = szEff * (1.0D0 + frac * (gamma - 1.0D0)) dS1dE1 = 0.0D0 dS1dE2 = 0.0D0 dS2dE1 = 0.0D0 dS2dE2 = 4.0D0 * visMax ELSE IF (e2 <= e2at4) THEN ! Region T/T: Two set of conjugate thrust faults. s1Eff = szEff * gamma s2Eff = s1Eff dS1dE1 = (0.50D0 * (gamma - 1.0D0) * szEff) / e1 dS1dE2 = 0.0D0 dS2dE1 = 0.0D0 dS2dE2 = (0.50D0 * (gamma - 1.0D0) * szEff) / e2 ELSE ! Region V: linear viscosity ! Note that equations are now for sigma1,2 and no ! longer for s1Eff and s2Eff. However, we can ! easily compute both: sigma1 = sz + visMax * (4.0D0 * e1 + 2.0D0 * e2) sigma2 = sz + visMax * (2.0D0 * e1 + 4.0D0 * e2) s1Eff = sigma1 + Biot * pH2O s2Eff = sigma2 + Biot * pH2O dS1dE1 = 0.0D0 dS1dE2 = 0.0D0 dS2dE1 = 0.0D0 dS2dE2 = 0.0D0 END IF ! Regardless of region, be sure that stiffnesses do ! not fall below those which represent a minimum ! effective viscosity-- one based on the weakest of ! the active fault sets. This is to guaruntee that ! the linear system will not have any zero eigenvalues, ! even if a creeping layer does not exist. visMin = visMax IF ((e1 < 0.0D0).AND.(e2 > 0.0D0)) THEN ! strike-slip faults are active visMin = MIN(visMin, 0.50D0 * (s2Eff - s1Eff) / (e2 - e1)) END IF IF ((e1 < 0.0D0).AND.(ez > 0.0D0)) THEN ! thrust faults are active visMin = MIN(visMin, 0.50D0 * (szEff - s1Eff) / (ez - e1)) END IF IF ((e2 > 0.0D0).AND.(ez < 0.0D0)) THEN ! normal faults are active visMin = MIN(visMin, 0.50D0 * (s2Eff - szEff) / (e2 - ez)) END IF dS1dE1 = dS1dE1 + 4.0D0 * visMin dS1dE2 = dS1dE2 + 2.0D0 * visMin dS2dE1 = dS2dE1 + 2.0D0 * visMin dS2dE2 = dS2dE2 + 4.0D0 * visMin ! Convert effective principal stresses at the midpoint ! of the frictional layer into total principal stresses: sigma1 = s1Eff - Biot * pH2O sigma2 = s2Eff - Biot * pH2O ! (Note that correcting S1 and S2 by a constant does not ! affect the values of any of the 4 derivitives dS1dE1, ..., dS2dE2.) ! Convert total principal stresses at the midpoint of ! the frictional layer into relative principal stresses ! (relative to the total vertical stress, that is): s1rel = sigma1 - sz s2rel = sigma2 - sz ! (Note that correcting S1 and S2 by a constant does not ! affect the values of any of the 4 derivitives dS1dE1, ..., dS2dE2.) ! Convert values at midpoint of frictional layer to ! integrals over the frictional layer: tau1 = s1rel * zTran tau2 = s2rel * zTran dT1dE1 = dS1dE1 * zTran dT1dE2 = dS1dE2 * zTran dT2dE1 = dS2dE1 * zTran dT2dE2 = dS2dE2 * zTran ! Add integrals over frictional layer to layer totals: pT1 = pT1 + tau1 pT2 = pT2 + tau2 pT1dE1 = pT1dE1 + dT1dE1 pT1dE2 = pT1dE2 + dT1dE2 pT2dE1 = pT2dE1 + dT2dE1 pT2dE2 = pT2dE2 + dT2dE2 END IF ! (IF the frictional layer thickness zTran > 0) ! COMPUTE AND ADD STRENGTH OF CREEPING PART OF LAYER: IF (zTran < thick) THEN ! Precompute the maximum viscosity limit imposed by the ! requirement that creep shear stress never exceeds ! dCreep on any plane: visDCr = dCreep / (MAX(e1, e2, ez) - MIN(e1, e2, ez)) ! Precompute the lower viscosity limit imposed by the ! requirement that creep shear stress does not ! fall below sigHBI: visSHB = sigHBi / (MAX(e1, e2, ez) - MIN(e1, e2, ez)) ! Compute the vertical integral of viscosity, ! observing the local limit visDCr, and terminating ! the integral if creep shear stress falls below ! sigHBI (because then we are in a horizontally- ! sheared boundary layer which does not contribute ! anything to plate strength): nVStep = 50 dz = (thick - zTran) / nVStep visInt = 0.0D0 DO 200 n = 0, nVStep z = zTran + n * dz ! Note that z is measured from top of layer ! (upper surface of hard crust, or Moho) and ! may not be absolute depth. t = geoth1 + geoth2 * z + geoth3 * z**2 + geoth4 * z**3 t = MIN(t, temLim) argume = (bCreep + cCreep * (zOfTop + z)) / t ! Prevent over/underflow in EXP() by limiting the argument: argume = MAX(MIN(argume, 87.0D0), -87.0D0) vis = visInf * EXP(argume) vis = MIN(vis, visDCr) IF ((n == 0).OR.(n == nVStep)) THEN frac = 0.50D0 ELSE frac = 1.0D0 END IF IF (vis < visSHB) GO TO 201 visInt = visInt + frac * vis * dz 200 CONTINUE 201 CONTINUE ! Limit the mean viscosity of the creeping layer to ! be no more than visMax: visInt = MIN(visInt, visMax * (thick - zTran)) tau1 = 4.0D0 * visInt * e1 + 2.0D0 * visInt * e2 tau2 = 2.0D0 * visInt * e1 + 4.0D0 * visInt * e2 ! Note that these principal values of tau (the two ! horizontal principal values, contributed by the ! creeping layer only) are relative to tauzz, which ! is the vertical integral of the vertical stress ! anomaly through the creeping layer. dT1dE1 = 4.0D0 * visInt dT1dE2 = 2.0D0 * visInt dT2dE1 = 2.0D0 * visInt dT2dE2 = 4.0D0 * visInt ! Add integrals over creeping layer to layer totals: pT1 = pT1 + tau1 pT2 = pT2 + tau2 pT1dE1 = pT1dE1 + dT1dE1 pT1dE2 = pT1dE2 + dT1dE2 pT2dE1 = pT2dE1 + dT2dE1 pT2dE2 = pT2dE2 + dT2dE2 END IF ! (IF the creeping layer thickness (thick - zTran) > 0) END SUBROUTINE Diamnd 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 = .TRUE. REAL*8 :: high_y, low_y, x, y OPEN (UNIT = free_unit, FILE = dig_pathfile, STATUS = 'OLD', & & PAD = 'YES', IOSTAT = ios) 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...')") 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 in spherical continuum element REAL*8, INTENT(IN) :: R ! radius of planet, in m INTEGER, INTENT(IN) :: l_ ! element number INTEGER, DIMENSION(:,:), INTENT(IN) :: nodes REAL*8, DIMENSION(3,2,2) :: G ! nodal functions @ selected point REAL*8, DIMENSION(3,2,2,2):: dG ! derivitives of nodal functions REAL*8, INTENT(IN) :: theta_ ! colatitude, radians REAL*8, DIMENSION(:), INTENT(IN) :: vw REAL*8, DIMENSION(3), INTENT(OUT) :: eps_dot INTEGER :: iv, iw, j REAL*8 :: cott, csct, prefix eps_dot = 0.0D0 ! (1..3) cott = 1.0D0 / DTAN(theta_) csct = 1.0D0 / DSIN(theta_) prefix = 1.0D0 / R DO j = 1, 3 iv = 2 * nodes(j, l_) - 1 iw = iv + 1 ! epsilon_dot_sub_theta_theta eps_dot(1) = eps_dot(1) + & & vw(iv) * prefix * dG(j,1,1,1) + & & vw(iw) * prefix * dG(j,2,1,1) ! epsilon_dot_sub_theta_phi eps_dot(2) = eps_dot(2) + & & vw(iv) * prefix * 0.5 * (csct * dG(j,1,1,2) + dG(j,1,2,1) - cott * G(j,1,2)) + & & vw(iw) * prefix * 0.5 * (csct * dG(j,2,1,2) + dG(j,2,2,1) - cott * G(j,2,2)) ! epsilon_dot_sub_phi_phi eps_dot(3) = eps_dot(3) + & & vw(iv) * prefix * (csct * dG(j,1,2,2) + cott * G(j,1,1)) + & & vw(iw) * prefix * (csct * dG(j,2,2,2) + cott * G(j,2,1)) END DO ! 3 local nodes END SUBROUTINE E_rate CHARACTER*40 FUNCTION Epoch (t_Ma) ! Selects the name of the epoch containing t_Ma before present ! per Geological Society of America's 1998 geologic time scale. IMPLICIT NONE REAL*8, INTENT(IN) :: t_Ma ! age, in millions of years INTEGER, PARAMETER :: ntime = 20 CHARACTER*40, DIMENSION(ntime) :: epoch_name INTEGER :: i REAL*8, DIMENSION(ntime) :: ttop DATA epoch_name/'Holocene ',& & 'Pleistocene ',& & 'Late Pliocene ',& & 'Early Pliocene ',& & 'Late Miocene ',& & 'Middle Miocene ',& & 'Early Miocene ',& & 'Late Oligocene ',& & 'Early Oligocene ',& & 'Late Eocene ',& & 'Middle Eocene ',& & 'Early Eocene ',& & 'Late Paleocene ',& & 'Early Paleocene ',& & 'Late Cretaceous: Maastrichtian ',& & 'Late Cretaceous: Campanian ',& & 'Late Cretaceous: Santonian ',& & 'Late Cretaceous: Coniacian ',& & 'Late Cretaceous: Turonian ',& & 'Late Cretaceous: Cenomanian '/ DATA ttop/0.01D0, 1.8D0, 3.6D0, 5.3D0, 11.2D0, 16.4D0, & & 23.8D0, 28.5D0, 33.7D0, 37.0D0, 49.0D0, 54.8D0, & & 61.0D0, 65.0D0, 78.3D0, 83.5D0, 85.8D0, 89.0D0, 93.5D0, 99.0D0/ IF (ABS(t_Ma) < 0.001D0) THEN Epoch = 'Present' ELSE IF (t_Ma < 0.0D0) THEN Epoch = 'Future' ELSE IF (t_Ma > ttop(ntime)) THEN Epoch = '?' ELSE DO i = 1, ntime IF (t_Ma <= ttop(i)) THEN Epoch = epoch_name(i) RETURN END IF END DO END IF END FUNCTION Epoch SUBROUTINE Extract_LRi (longer_line, & ! input & LRi, shorter_line) ! output ! New routine added for Shells_v5.0+ to support multiple !"Lithospheric Rheology" (abbreviated as "LR") integer codes, ! in any line of the input .feg file which define an element !(either a triangular continuum element, or a ! linear fault element). ! CHARACTER*80, INTENT(IN) :: longer_line is the whole ! element-definition line from the .feg file. ! INTEGER, INTENT(OUT) :: LRi is the rheologic code ! (or 0, if no such code was found). ! CHARACTER*80, INTENT(OUT) :: shorter_line has the " LRi" portion removed (if any), ! so it can be interpreted by the same code as in Shells_v4.1-. IMPLICIT NONE CHARACTER*80, INTENT(IN) :: longer_line INTEGER, INTENT(OUT) :: LRi CHARACTER*80, INTENT(OUT) :: shorter_line CHARACTER*80 :: string INTEGER :: longer_length, LR_start_byte longer_length = LEN_TRIM(longer_line) LR_start_byte = INDEX(longer_line, "LR") IF (LR_start_byte > 0) THEN ! the "LR" flag was found IF (longer_length > (LR_start_byte + 1)) THEN ! some byte(s) follow the "LR" string = longer_line((LR_start_byte + 2):longer_length) READ (string, *) LRi shorter_line = longer_line(1:(LR_start_byte - 1)) ELSE ! "LR" is present, but nothing follows it; infer 0. LRi = 0 shorter_line = longer_line(1:(LR_start_byte - 1)) END IF ELSE ! no "LR" flag is present LRi = 0 shorter_line = longer_line END IF END SUBROUTINE Extract_LRi SUBROUTINE Fault_Azimuths(FEP, nfl, nodef, node_uvec, fdip, fazim) ! Computes forward azimuth (from node1 --> node2) along fault trace. ! Azimuths are in radians, clockwise from North. ! There are as many azimuths computed as there are nodes ! one one side of the fault element (2 for SHELLS). ! The different azimuths along one fault element are only slightly ! different, due to: ! *spherical Earth (SHELLS) ! *curvature of trace (PLATES, FAULTS) ! *averaging of azimuths with neighboring faults (SHELLS) ! which have same end-nodes, same dip, and similar trend. CHARACTER*(*), INTENT(IN) :: FEP INTEGER, INTENT(IN) :: nfl INTEGER, DIMENSION(:,:), INTENT(IN) :: nodef REAL*8, DIMENSION(:,:), INTENT(IN), OPTIONAL :: node_uvec REAL*8, DIMENSION(:,:), INTENT(IN) :: fdip REAL*8, DIMENSION(:,:), INTENT(OUT) :: fazim INTEGER :: i, j, n1, n2, n3, n4, o1, o2, o3, o4 LOGICAL :: flip_next, got_mate REAL*8 :: azi, azj, mean_cos, mean_sin REAL*8, DIMENSION(3):: uvec1, uvec2, uvec3 ! IF (FEP == "SHELLS") THEN DO i = 1, nfl n1 = nodef(1,i) n2 = nodef(2,i) n3 = nodef(3,i) n4 = nodef(4,i) uvec1(1:3) = node_uvec(1:3, n1) uvec2(1:3) = node_uvec(1:3, n2) ! Starting (n1, n4, uvec1) end got_mate = .FALSE. mating: DO j = 1, nfl IF (j /= i) THEN o1 = nodef(1,j) o2 = nodef(2,j) o3 = nodef(3,j) o4 = nodef(4,j) IF ((n1 == o2).AND.(n4 == o3)) THEN got_mate = .TRUE. flip_next = .FALSE. uvec3(1:3) = node_uvec(1:3, o1) EXIT mating ELSE IF ((n1 == o4).AND.(n4 == o1)) THEN got_mate = .TRUE. flip_next = .TRUE. uvec3(1:3) = node_uvec(1:3, o2) EXIT mating END IF ! found a match END IF ! j /= i END DO mating ! j = 1, nfl; loop looking for neighbors IF (got_mate) THEN ! check for same dip IF (flip_next) THEN got_mate = (fdip(1,i) == -fdip(1,j)) ELSE got_mate = (fdip(1,i) == fdip(2,j)) END IF IF (got_mate) THEN ! average azimuths together! azi = DCompass(uvec1, uvec2) azj = DCompass(uvec1, uvec3) + Pi mean_cos = (DCOS(azi) + DCOS(azj))/2.0D0 mean_sin = (DSIN(azi) + DSIN(azj))/2.0D0 fazim(1,i) = DATan2F(mean_sin, mean_cos) ELSE ! dips did not match on n1 end fazim(1,i) = DCompass(uvec1, uvec2) END IF ELSE ! did not find two matching nodes on n1 end fazim(1,i) = DCompass(uvec1, uvec2) END IF ! found a matching nodes, or not, on n1 end ! Final (n2, n3, uvec2) end got_mate = .FALSE. remating: DO j = 1, nfl IF (j /= i) THEN o1 = nodef(1,j) o2 = nodef(2,j) o3 = nodef(3,j) o4 = nodef(4,j) IF ((n2 == o1).AND.(n3 == o4)) THEN got_mate = .TRUE. flip_next = .FALSE. uvec3(1:3) = node_uvec(1:3, o2) EXIT remating ELSE IF ((n2 == o3).AND.(n3 == o2)) THEN got_mate = .TRUE. flip_next = .TRUE. uvec3(1:3) = node_uvec(1:3, o1) EXIT remating END IF ! found a match END IF ! j /= i END DO remating ! j = 1, nfl; loop looking for neighbors IF (got_mate) THEN ! check for same dip IF (flip_next) THEN got_mate = (fdip(2,i) == -fdip(2,j)) ELSE got_mate = (fdip(2,i) == fdip(1,j)) END IF IF (got_mate) THEN ! average azimuths together! azi = DCompass(uvec2, uvec1) + Pi azj = DCompass(uvec2, uvec3) mean_cos = (DCOS(azi) + DCOS(azj))/2.0D0 mean_sin = (DSIN(azi) + DSIN(azj))/2.0D0 fazim(2,i) = DATan2F(mean_sin, mean_cos) ELSE ! dips did not match on n2 end fazim(2,i) = DCompass(uvec2, uvec1) + Pi END IF ELSE ! did not find two matching nodes on n2 end fazim(2,i) = DCompass(uvec2, uvec1) + Pi END IF ! found a matching nodes, or not, on n2 end END DO ! i = 1, nfl (basic loop on faults) ELSE WRITE(*,"(' Error: Fault_Azimuths cannot handle FEP = ',A)") TRIM(ADJUSTL(FEP)) CALL DTraceback END IF ! choice of FEP END SUBROUTINE Fault_Azimuths ! 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*80 :: string0, string1, string2 ! CHARACTER*255 :: files ! INTEGER :: count, full_to, handle, old_result, result ! LOGICAL :: duplicate, matched !! TYPE file$info ! this type as defined in DFLIB.F90 !! INTEGER(4) creation !! INTEGER(4) lastwrite !! INTEGER(4) lastaccess !! INTEGER(4) length !! INTEGER(4) permit !! CHARACTER(255) name !! END TYPE file$info ! TYPE (FILE$INFO) info ! this type as defined in DFLIB.F90 ! !10 count = 0 ! matched = .FALSE. ! until we find a file == suggested_file ! IF (file_type == "*.*") THEN ! WRITE (*,"(/' Here are all the files in the input directory:')") ! files = TRIM(using_path) // & ! defined in FiniteMap above ! & '*.*' ! ! ELSE IF (file_type == "*.dig") THEN ! WRITE (*,"(/' The following appear to be basemap (.dig) files:')") ! files = TRIM(using_path) // & ! defined in FiniteMap above ! & '*.DIG' ! ! ELSE IF (file_type == "*.eqc") THEN ! WRITE (*,"(/' The following appear to be EarthQuake Catalog (.eqc) files:')") ! files = TRIM(using_path) // & ! defined in FiniteMap above ! & '*.EQC' ! ! ELSE IF (file_type == "*.feg") THEN ! WRITE (*,"(/' The following appear to be FE grid (.feg) files:')") ! files = TRIM(using_path) // & ! defined in FiniteMap above ! & '*.FEG' ! ELSE IF (file_type == "f*.out") THEN ! WRITE (*,"(/' The following appear to be nodal force (f*.out) files:')") ! files = TRIM(using_path) // & ! defined in FiniteMap above ! & '*.OUT' ! must filter below to exclude text-logs "t*.out" and torques "q*.out" velocities "v*.out" ! ELSE IF (file_type == "*.grd") THEN ! WRITE (*,"(/' The following appear to be gridded data (.grd) files:')") ! files = TRIM(using_path) // & ! defined in FiniteMap above ! & '*.GRD' ! ELSE IF (file_type == "i*.in") THEN ! WRITE (*,"(/' The following appear to be parameter (i*.in) files:')") ! files = TRIM(using_path) // & ! defined in FiniteMap above ! & '*.IN' ! ELSE IF (file_type == "q*.out") THEN ! WRITE (*,"(/' The following appear to be torque (q*.out) files:')") ! files = TRIM(using_path) // & ! defined in FiniteMap above ! & '*.OUT' ! (must also filter below to exclude force "f*.out" and text "t*.out" and velocity "v*.out" files) ! ELSE IF (file_type == "v*.out") THEN ! WRITE (*,"(/' The following appear to be velocity (v*.out) files:')") ! files = TRIM(using_path) // & ! defined in FiniteMap above ! & '*.OUT' ! (must also filter below to exclude force "f*.out" and text "t*.out" and torque "q*.out" files) ! ELSE IF (file_type == "*.gps") THEN ! WRITE (*,"(/' The following appear to be geodetic velocity (.gps) files:')") ! files = TRIM(using_path) // & ! defined in FiniteMap above ! & '*.GPS' ! 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) ! !reject "force" files that don't start with "f" ! IF ((file_type == "f*.out").AND.((first_letter == 'V').OR.(first_letter == 'v').OR. & ! & (first_letter == 'Q').OR.(first_letter == 'q').OR. & ! & (first_letter == 'S').OR.(first_letter == 's').OR. & ! & (first_letter == 'T').OR.(first_letter == 't'))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !reject "torque" files that don't start with "q" ! IF ((file_type == "q*.out").AND. ((first_letter == 'F').OR.(first_letter == 'f').OR. & ! & (first_letter == 'S').OR.(first_letter == 's').OR. & ! & (first_letter == 'T').OR.(first_letter == 't').OR. & ! & (first_letter == 'V').OR.(first_letter == 'v'))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !reject "velocity" files that don't start with "v" ! IF ((file_type == "v*.out").AND. ((first_letter == 'F').OR.(first_letter == 'f').OR. & ! & (first_letter == 'Q').OR.(first_letter == 'q').OR. & ! & (first_letter == 'S').OR.(first_letter == 's').OR. & ! & (first_letter == 'T').OR.(first_letter == 't'))) 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 FINDPV (IPAFRI, IUNITT, NDPLAT, NPBND, NPLATE, OMEGA, & & PLAT, PLON, RADIUS, & & XINPL, XVEL, YINPL, YVEL, & ! inputs & VPHI, VTHETA) ! output !FINDS OUT IN WHICH PLATE (XINPL,YINPL) IS IN, ! AND CALCULATES THE VELOCITY OF THE POINT (XVEL,YVEL) FROM THE ! PB2002 MODEL OF BIRD [2003].. !REQUIRES THAT NAMES AND OMEGA BE PRE-FILLED WITH NAMES AND ! ROTATION VECTORS, UNDER THE CONVENTION THAT THE PACIFIC PLATE IS ! FIXED. !REQUIRES THAT -GETNUV- HAS ALREADY BEEN CALLED TO FILL IN THE ! ARRAYS WITH DIGITISED PLATES BOUNDARIES. !RETURNS VPHI (SOUTHWARD VELOCITY) AND VTHETA (EASTWARD VELOCITY) ! IN A REFERENCE FRAME WHERE THE AFRICA PLATE IS FIXED. !Copied from SHELLS February 1999 and modified (as little as ! possible) to be legal as free-form Fortran 90. !Modified 4 August 1999 to use DOUBLE PRECISION in vector and ! angle calculations, because too many points were found to ! lie "exactly on" a plate boundary, and not in either plate! !Then, also modified again to assign a plate to such points ! based on closest-proximity-of-a-boundary (coin tossing), ! because this was found necessary for a few points falling ! into tangles around triple-junctions, where the plate ! boundaries have tiny gaps and overlaps left by Link_Up. IMPLICIT NONE INTEGER, INTENT(IN) :: IPAFRI, IUNITT, NPBND, NPLATE INTEGER, DIMENSION(:), INTENT(IN) :: NDPLAT ! (NPLATE) REAL*8, INTENT(IN) :: RADIUS, XINPL, XVEL, YINPL, YVEL REAL*8, DIMENSION(:,:), INTENT(IN) :: OMEGA ! (3,NPLATE) REAL*8, DIMENSION(:,:), INTENT(IN) :: PLAT, PLON ! (NPLATE,NPBND) REAL*8, INTENT(OUT) :: VPHI, VTHETA INTEGER :: I, IPLATE, J, J2, MPLATE, NEND, NPOINT REAL*8 :: DANGLE, DX2, DX2INF, DX2MIN, OMEGAX, OMEGAY, OMEGAZ, & & PHI, PHIX, PHIY, PHIZ, & & THETA, THETAX, THETAY, THETAZ, VX, VY, VZ, & & XN, XPOINT, YN, YPOINT, ZN DOUBLE PRECISION :: A1, A2, A3, AA, AB1, AB2, AB3, AO, ANGLE, & & B1, B2, B3, BB, BO, & & XO, YO, ZO, OXYZ, STHETA, TANGL XO=DCOS(YINPL)*DSIN(XINPL) YO=DSIN(YINPL)*DSIN(XINPL) ZO=DCOS(XINPL) OXYZ=XO*XO+YO*YO+ZO*ZO OXYZ=DSQRT(OXYZ) XO=XO/OXYZ YO=YO/OXYZ ZO=ZO/OXYZ NPOINT=0 ANGLE=0.0D0 IPLATE=0 MPLATE=0 DX2MIN=9.99D37 DO 500 I=1,NPLATE TANGL=0.0D0 DX2INF=9.99D37 NEND=NDPLAT(I) DO 300 J=1,NEND J2=J+1 IF (J.EQ.NEND) THEN J2=1 END IF A1=DCOS(PLON(I,J))*DCOS(PLAT(I,J)) A2=DSIN(PLON(I,J))*DCOS(PLAT(I,J)) A3=DSIN(PLAT(I,J)) DX2=(A1-XO)**2+(A2-YO)**2+(A3-ZO)**2 DX2INF=MIN(DX2INF,DX2) B1=DCOS(PLON(I,J2))*DCOS(PLAT(I,J2)) B2=DSIN(PLON(I,J2))*DCOS(PLAT(I,J2)) B3=DSIN(PLAT(I,J2)) AO=XO*A1+YO*A2+ZO*A3 BO=XO*B1+YO*B2+ZO*B3 A1=A1/AO A2=A2/AO A3=A3/AO B1=B1/BO B2=B2/BO B3=B3/BO A1=A1-XO A2=A2-YO A3=A3-ZO B1=B1-XO B2=B2-YO B3=B3-ZO AA=DSQRT(A1*A1+A2*A2+A3*A3) BB=DSQRT(B1*B1+B2*B2+B3*B3) AB1=A2*B3-A3*B2 AB2=A3*B1-A1*B3 AB3=A1*B2-A2*B1 STHETA=(AB1*XO+AB2*YO+AB3*ZO)/(AA*BB) TANGL=TANGL+DASIN(STHETA) 300 CONTINUE DANGLE=TANGL-3.1415927D0 IF(DANGLE.GE.0.0001D0) THEN NPOINT=NPOINT+1 IPLATE=I END IF IF (DX2INF.LT.DX2MIN) THEN DX2MIN=DX2INF MPLATE=I END IF 500 CONTINUE IF (NPOINT.GE.4) THEN XPOINT=90.0D0-XINPL*57.29577951D0 YPOINT=YINPL*57.29577951D0 WRITE(IUNITT,505) XPOINT,YPOINT 505 FORMAT(' POINT ',2F10.3,' WAS FOUND IN MORE THAN THREE PLATES' & & ,' SOMETHING IS WRONG') CALL DTraceback END IF IF (IPLATE.GT.0) THEN !CONVERT TO AFRICA-FIXED, AND RADIANS/SECOND: OMEGAX=(OMEGA(1,IPLATE)-OMEGA(1,IPAFRI))*3.168809D-14 OMEGAY=(OMEGA(2,IPLATE)-OMEGA(2,IPAFRI))*3.168809D-14 OMEGAZ=(OMEGA(3,IPLATE)-OMEGA(3,IPAFRI))*3.168809D-14 !CONVERT TO LENGTH/SECOND: OMEGAX=OMEGAX*RADIUS OMEGAY=OMEGAY*RADIUS OMEGAZ=OMEGAZ*RADIUS !VELOCITY = OMEGA X POSITION: THETA=XVEL PHI=YVEL XN=DSIN(THETA)*DCOS(PHI) YN=DSIN(THETA)*DSIN(PHI) ZN=DCOS(THETA) VX=OMEGAY*ZN-OMEGAZ*YN VY=OMEGAZ*XN-OMEGAX*ZN VZ=OMEGAX*YN-OMEGAY*XN !CREATE UNIT +THETA AND +PHI VECTORS IN CARTESIAN: THETAX=DCOS(THETA)*DCOS(PHI) THETAY=DCOS(THETA)*DSIN(PHI) THETAZ= -DSIN(THETA) PHIX= -DSIN(PHI) PHIY=DCOS(PHI) PHIZ=0.0D0 !FIND ARGUMENT FROM DOT PRODUCTS: VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ ELSE XPOINT=90.0D0-XINPL*57.29577951D0 YPOINT=YINPL*57.29577951D0 WRITE(IUNITT,600) YPOINT,XPOINT 600 FORMAT(' WARNING: Test point ',2F10.4) XPOINT=90.0D0-XVEL*57.29577951D0 YPOINT=YVEL*57.29577951D0 WRITE(IUNITT,601) YPOINT,XPOINT,MPLATE 601 FORMAT(' (offset from the: ',2F10.4, & & ' location of original point)' & &/' does not fall within any plate;' & &/' plate index number ',I2, & & ' was assigned based on proximity.') WRITE(IUNITT,"(' ')") ! to prevent overwriting of ! this message by FORMAT('+') ! writes in the outer loop, if any. END IF END SUBROUTINE FINDPV SUBROUTINE Flow (fPSfer, mxEl, mxNode, nodes, numEl, v, & ! input & outVec) ! output ! Calculates velocity vectors at integration points, from nodal values IMPLICIT NONE ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL*8, INTENT(IN) :: FPSfer ! input INTEGER, INTENT(IN) :: mxEl, mxNode, nodes, numEl ! input DOUBLE PRECISION, INTENT(IN) :: v ! input REAL*8, INTENT(OUT) :: outVec ! ouput ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - INTEGER i, j, m, nji DIMENSION fPSfer(2, 2, 3, 7, mxEl), nodes(3, mxEl), outVec(2, 7, mxEl), & & v(2, mxNode) DO 50 m = 1, 7 DO 40 i = 1, numEl outVec(1, m, i) = 0.0D0 outVec(2, m, i) = 0.0D0 40 CONTINUE 50 CONTINUE DO 100 j = 1, 3 DO 90 m = 1, 7 DO 80 i = 1, numEl nji = nodes(j, i) outVec(1, m, i) = outVec(1, m, i) & & + v(1, nji) * fPSfer(1, 1, j, m, i) & & + v(2, nji) * fPSfer(2, 1, j, m, i) outVec(2, m, i) = outVec(2, m, i) & & + v(1, nji) * fPSfer(1, 2, j, m, i) & & + v(2, nji) * fPSfer(2, 2, j, m, i) 80 CONTINUE 90 CONTINUE 100 CONTINUE END SUBROUTINE Flow SUBROUTINE Get_FEP() ! Prompt user for CHARACTER*6 :: FEP, set got_FEP = T (both global). IMPLICIT NONE CHARACTER*1 letter CHARACTER*80 string WRITE (*,*) 10 CALL DPrompt_for_String('Which finite-element code are you using: & &SHELLS, PLATES, or FAULTS ?',TRIM(FEP),string) letter = string(1:1) IF ((letter == 'S').OR.(letter == 's')) THEN FEP = "SHELLS" ELSE IF ((letter == 'P').OR.(letter == 'p')) THEN FEP = "PLATES" WRITE (*,"(/' Sorry. This code is not written yet.')") CALL Pause() STOP ' ' ELSE IF ((letter == 'F').OR.(letter == 'f')) THEN FEP = "FAULTS" WRITE (*,"(/' Sorry. This code is not written yet.')") CALL Pause() STOP ' ' ELSE WRITE (*,"(' Your answer was not clear. Try again:')") mt_flashby = .FALSE. GO TO 10 END IF got_FEP = .TRUE. END SUBROUTINE Get_FEP SUBROUTINE GETNUV (path_in,plates_dig_file,IUNITM,IUNITT,NAMES,NPBND,NPLATE, & ! inputs & NDPLAT,PLAT,PLON) ! outputs !SETS UP ARRAYS DEFINING THE PLATES IN THE PB2002 MODEL OF ! BIRD (2003, G**3). !(THE ROTATION VECTORS OF THE PLATES ARE CONTAINED IN DATA ! STATEMENTS IN THE MAIN PROGRAM.) !THE DIGITISED BOUNDARIES OF THE PLATES (CONTINUOUS CLOSED CURVES, ! ALWAYS CIRCLING COUNTERCLOCKWISE, AND REDUNDANTLY DESCRIBING ! EACH PLATE BOUNDARY TWICE- FROM EACH SIDE) ! ARE READ HERE, FROM AN INPUT FILE SUCH AS 'PB2002_plates.dig', ! ON FORTRAN INPUT DEVICE 'IUNITM'. !THE CONVENTION FOR IDENTIFYING THE PLATES IS A 2-CHARACTER SYMBOL. !Copied from SHELLS February 1999 and changed (as little as !possible) to valid Fortran 90. Explicit OPEN statements added. !------------------------------------------------------- IMPLICIT NONE CHARACTER*2, DIMENSION(:), INTENT(IN) :: NAMES CHARACTER*(*), INTENT(IN) :: path_in INTEGER, INTENT(IN) :: IUNITM, IUNITT, NPBND, NPLATE INTEGER, DIMENSION(:), INTENT(OUT):: NDPLAT REAL*8, DIMENSION(:,:),INTENT(OUT):: PLAT, PLON CHARACTER*1 :: C1 CHARACTER*2 :: SYMBOL CHARACTER*3 :: STARS CHARACTER*80 :: pathfile, plates_dig_file INTEGER :: I, IOS, IP, L !------------------------------------------------------ pathfile=TRIM(path_in)//TRIM(plates_dig_file) 1 OPEN (UNIT=IUNITM,FILE=pathfile,STATUS='OLD',PAD='YES',IOSTAT=IOS) IF (IOS.NE.0) THEN WRITE(IUNITT,"(/' ERROR: File ',A,' not found in input directory:' & & /' ',A)") TRIM(plates_dig_file), TRIM(path_in) WRITE(IUNITT,"(' Please pause this program, move this file in, and press Enter:')") CALL DPress_Enter mt_flashby = .FALSE. GO TO 1 END IF 100 READ (IUNITM,101,END=201) SYMBOL 101 FORMAT (A2) DO 120 L=1,NPLATE IF(SYMBOL.EQ.NAMES(L)) THEN IP=L GO TO 140 ENDIF 120 CONTINUE WRITE (IUNITT,121) IUNITM 121 FORMAT (/' ERR0R: BAD PLATE NAME ON INPUT DEVICE ',I3) CALL DTraceback 140 I=0 141 READ (IUNITM,145,END=201) STARS 145 FORMAT (A3) IF (STARS.EQ.'***') THEN NDPLAT(IP)=I GO TO 100 ENDIF BACKSPACE IUNITM I=I+1 IF (I.GT.NPBND) THEN WRITE (*, "(' ERROR: npbnd = ',I5,' is ', & & 'not large enough. Change and recompile.')") NPBND CALL DTraceback ELSE READ (IUNITM, * ) PLON(IP,I), PLAT(IP,I) PLON(IP,I)=PLON(IP,I)*0.017453293D0 PLAT(IP,I)=PLAT(IP,I)*0.017453293D0 END IF GO TO 141 201 CONTINUE CLOSE(IUNITM) END SUBROUTINE GETNUV SUBROUTINE Histogram (real_list, list_length, skip_zeros, maximum, minimum) ! Puts a printer-plot on the default device, no more than ! (n15 + 2) rows tall by n70 bytes wide, showing the range and ! distribution of values within real_list. IMPLICIT NONE REAL*8, DIMENSION(:), INTENT(IN) :: real_list INTEGER, INTENT(IN) :: list_length LOGICAL, INTENT(IN) :: skip_zeros REAL*8, INTENT(OUT) :: maximum, minimum INTEGER, PARAMETER :: n15 = 15, n70 = 70 REAL*8, PARAMETER :: Huge = 9.99D37 CHARACTER*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.0D0 * n15) / (1.0D0 * 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 Input_to_SHELLS (iUnit7, parameter_pathfile, names , numplt, & ! inputs & alphat, conduc, & ! outputs... & d_fFric, d_cFric, d_Biot, d_Byerly, d_aCreep, d_bCreep, d_cCreep, d_dCreep, d_eCreep, & & everyp, & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, radius, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) !Acts like SUBROUTINE READPM of SHELLS / OrbData / OrbMapAI / OrbScore, ! except that it only transmits the ! variables needed for graphics, and does not echo ! the values read, nor does it test for bad values! IMPLICIT NONE !Input variables: INTEGER, INTENT(IN) :: iUnit7 ! a free Fortran device number CHARACTER*(*), INTENT(IN) :: parameter_pathfile ! .in file name CHARACTER*2, DIMENSION(:), INTENT(IN) :: names ! list of 2-byte plate names INTEGER, INTENT(IN) :: numplt ! count of plates in array names !Output variables: CHARACTER*(*), INTENT(OUT) :: title3 INTEGER, INTENT(OUT) :: iconve, ipvref, maxitr LOGICAL, INTENT(OUT) :: everyp REAL*8, INTENT(OUT) :: d_fFric, d_cFric, d_Biot, d_Byerly, d_eCreep, & & gmean, gradie, & & okdelv, oktoqt, onekm, radius, refstr, rhoast, rhoh2o, & & tadiab, trhmax, tsurf, vtimes, zbasth REAL*8, DIMENSION(2), INTENT(OUT) :: alphat, & & conduc, & & d_aCreep, d_bCreep, d_cCreep, d_dCreep, & & radio, rhobar, & & taumax, temlim !Work variables: CHARACTER*2 :: pltref INTEGER :: i, ios !- - - - - - - - - - - - - - - - - - - - - - - OPEN (UNIT = iunit7, FILE = parameter_pathfile, & & STATUS = 'OLD', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) THEN WRITE (*,"(' ERROR opening ',A,' from Input_to_SHELLS')") TRIM(parameter_pathfile) CALL DTraceback END IF READ (iunit7,"(A)",IOSTAT=ios) title3 IF (ios /= 0) CALL Bad_shells('title3') READ (iunit7,*,IOSTAT=ios) d_fFric IF (ios /= 0) CALL Bad_shells('fFric') READ (iunit7,*,IOSTAT=ios) d_cFric IF (ios /= 0) CALL Bad_shells('cFric') READ (iunit7,*,IOSTAT=ios) d_Biot IF (ios /= 0) CALL Bad_shells('Biot') READ (iunit7,*,IOSTAT=ios) d_Byerly IF (ios /= 0) CALL Bad_shells('Byerly') READ (iunit7,*,IOSTAT=ios) d_aCreep(1), d_aCreep(2) IF (ios /= 0) CALL Bad_shells('aCreep(1..2)') READ (iunit7,*,IOSTAT=ios) d_bCreep(1), d_bCreep(2) IF (ios /= 0) CALL Bad_shells('bCreep(1..2)') READ (iunit7,*,IOSTAT=ios) d_cCreep(1), d_cCreep(2) IF (ios /= 0) CALL Bad_shells('cCreep(1..2)') READ (iunit7,*,IOSTAT=ios) d_dCreep(1), d_dCreep(2) IF (ios /= 0) CALL Bad_shells('dCreep(1..2)') READ (iunit7,*,IOSTAT=ios) d_eCreep ! Note: Only one value; same for crust and mantle. IF (ios /= 0) CALL Bad_shells('eCreep') READ (iunit7,*,IOSTAT=ios) tadiab, gradie IF (ios /= 0) CALL Bad_shells('tadiab, gradie') READ (iunit7,*,IOSTAT=ios) zbasth IF (ios /= 0) CALL Bad_shells('zbasth') READ (iunit7,"(A)",IOSTAT=ios) pltref IF (ios /= 0) CALL Bad_shells('pltref') ipvref = 0 DO i = 1, numplt IF (names(i) == pltref) ipvref = i END DO IF (ipvref == 0) THEN WRITE (*,10) (names(i), i = 1, numplt) 10 FORMAT (/' ERROR in parameter input file:' & & /' In line 13 (after ZBASTH, before ICONVE),' & & /' in the first two columns of the line,' & & /' define the velocity reference frame by' & & /' entering one of the following plate names:' & & /' ',26(A2,1X)) CALL DTraceback END IF READ (iunit7,*,IOSTAT=ios) iconve IF (ios /= 0) CALL Bad_shells('iconve') IF (iconve > 0) THEN BACKSPACE iunit7 READ (iunit7, *,IOSTAT=ios) iconve, vtimes IF (ios /= 0) CALL Bad_shells('iconve, vtimes') ELSE vtimes = 1.0D0 END IF READ (iunit7,*,IOSTAT=ios) trhmax IF (ios /= 0) CALL Bad_shells('trhmax') READ (iunit7,*,IOSTAT = ios) taumax(1), taumax(2) IF (ios /= 0) THEN BACKSPACE iunit7 READ (iunit7,*,IOSTAT=ios) taumax(1) IF (ios /= 0) CALL Bad_shells('taumax') taumax(2) = taumax(1) END IF READ (iunit7,*,IOSTAT=ios) rhoh2o IF (ios /= 0) CALL Bad_shells('rhoh2o') READ (iunit7,*,IOSTAT=ios) rhobar(1), rhobar(2) IF (ios /= 0) CALL Bad_shells('rhobar(1..2)') READ (iunit7,*,IOSTAT=ios) rhoast IF (ios /= 0) CALL Bad_shells('rhoast') READ (iunit7,*,IOSTAT=ios) gmean IF (ios /= 0) CALL Bad_shells('gmean') READ (iunit7,*,IOSTAT=ios) onekm IF (ios /= 0) CALL Bad_shells('onekm') READ (iunit7,*,IOSTAT=ios) radius ! redundant with mp_radius_meters IF (ios /= 0) CALL Bad_shells('radius') READ (iunit7,*,IOSTAT=ios) alphat(1), alphat(2) IF (ios /= 0) CALL Bad_shells('alphat(1..2)') READ (iunit7,*,IOSTAT=ios) conduc(1), conduc(2) IF (ios /= 0) CALL Bad_shells('conduc(1..2)') READ (iunit7,*,IOSTAT=ios) radio(1), radio(2) IF (ios /= 0) CALL Bad_shells('radio(1..2)') READ (iunit7,*,IOSTAT=ios) tsurf IF (ios /= 0) CALL Bad_shells('tsurf') READ (iunit7,*,IOSTAT=ios) temlim(1), temlim(2) IF (ios /= 0) CALL Bad_shells('temlim(1..2)') READ (iunit7,*,IOSTAT=ios) maxitr IF (ios /= 0) CALL Bad_shells('maxitr') READ (iunit7,*,IOSTAT=ios) oktoqt IF (ios /= 0) CALL Bad_shells('oktoqt') READ (iunit7,*,IOSTAT=ios) refstr IF (ios /= 0) CALL Bad_shells('refstr') READ (iunit7,*,IOSTAT=ios) okdelv IF (ios /= 0) CALL Bad_shells('oldelv') READ (iunit7,*,IOSTAT=ios) everyp IF (ios /= 0) CALL Bad_shells('everyp') !(Ignore the plot-control parameters that follow.) CLOSE (iunit7) END SUBROUTINE Input_to_SHELLS SUBROUTINE Interp (fAtNod, nodes, numEl, numNod, & ! input & fAtIP) ! output ! Interpolate a scalar function known at the nodes (fAtNod) ! to values at the 7 integration points in each triangular ! continuum element. Note that simple linear interpolation in ! a plane-triangle is used. Thus, this routine is NOT suitable ! for interpolating velocity vectors from nodes to integration points. IMPLICIT NONE ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL*8, INTENT(IN) :: fAtNod ! input INTEGER, INTENT(IN) :: nodes, numEl, numNod ! input REAL*8, INTENT(OUT) :: fAtIP ! output ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DOUBLE PRECISION points COMMON / S1S2S3 / points DIMENSION points(3, 7) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - INTEGER i, m DIMENSION fAtNod(numNod), fAtIP(7, numEl), nodes(3, numEl) DO 100 m = 1, 7 DO 90 i = 1, numEl fAtIP(m, i) = points(1, m) * fAtNod(nodes(1, i)) + & & points(2, m) * fAtNod(nodes(2, i)) + & & points(3, m) * fAtNod(nodes(3, i)) 90 CONTINUE 100 CONTINUE END SUBROUTINE Interp SUBROUTINE Limits_in_SHELLS (EQCM,NODES,NUMEL,NUVECS, & & OKDELV,RADIUS,REFSTR, & & TRHMAX, & ! inputs & CONSTR,ETAMAX,FMUMAX,VISMAX) ! outputs !COMPUTE AREA, MEAN THICKNESS, AND OTHER DIMENSIONAL PARAMETERS ! OF THE PLATE, THEN DETERMINE VALUES OF STIFFNESS LIMITS NEEDED ! TO KEEP VELOCITY ERR0RS DOWN TO ORDER "OKDELV" AT SHEAR STRESS ! LEVEL "REFSTR". !This version extensively modified to work without requiring !precomputation of element areas or determinants, COMMON blocks, etc. IMPLICIT NONE INTEGER, INTENT(IN) :: NUMEL INTEGER, DIMENSION(:,:), INTENT(IN) :: NODES REAL*8, INTENT(IN) :: OKDELV,RADIUS,REFSTR,TRHMAX REAL*8, DIMENSION(:,:), INTENT(IN) :: NUVECS ! (3,numnod) REAL*8, DIMENSION(:,:), INTENT(IN) :: EQCM ! (6,numnod) REAL*8, INTENT(OUT) :: CONSTR,ETAMAX,FMUMAX,VISMAX !------------------------- INTEGER :: I, N1, N2, N3, NFAULT LOGICAL :: SPHERE REAL*8 :: ANGLE1, ANGLE2, ANGLE3, AREA, HALFPI, PI, R2, SIDE, & & THICK, TMLITH, TOTALA, TOTALV, TWOPI, WHOLE, ZMOHO REAL*8, DIMENSION(3) :: UVEC1, UVEC2, UVEC3 PI=3.1415927D0 TWOPI=6.2831853D0 HALFPI=1.5707963D0 TOTALA=0.0D0 TOTALV=0.0D0 R2=RADIUS**2 DO 10 I=1,NUMEL N1=NODES(1,I) N2=NODES(2,I) N3=NODES(3,I) UVEC1(1:3)=NUVECS(1:3,N1) UVEC2(1:3)=NUVECS(1:3,N2) UVEC3(1:3)=NUVECS(1:3,N3) ANGLE1=DRelative_Compass(UVEC1,UVEC2)-DRelative_Compass(UVEC1,UVEC3) IF (ANGLE1.LT.0.0D0) ANGLE1=ANGLE1+TWOPI ANGLE2=DRelative_Compass(UVEC2,UVEC3)-DRelative_Compass(UVEC2,UVEC1) IF (ANGLE2.LT.0.0D0) ANGLE2=ANGLE2+TWOPI ANGLE3=DRelative_Compass(UVEC3,UVEC1)-DRelative_Compass(UVEC3,UVEC2) IF (ANGLE3.LT.0.0D0) ANGLE3=ANGLE3+TWOPI AREA=R2*(ANGLE1+ANGLE2+ANGLE3-PI) TOTALA=TOTALA+AREA ZMOHO=(EQCM(3,N1)+EQCM(3,N2)+EQCM(3,N3))/3.0D0 TMLITH=(EQCM(4,N1)+EQCM(4,N2)+EQCM(4,N3))/3.0D0 TOTALV=TOTALV+AREA*(ZMOHO+TMLITH) 10 CONTINUE WHOLE=4.0D0*3.14159D0*RADIUS**2 SPHERE=(TOTALA.GE.(0.99D0*WHOLE)) IF (TOTALA.GT.(1.02D0*WHOLE)) THEN WRITE (*,21) TOTALA, WHOLE 21 FORMAT (/' AREA OF GRID (',1P,E12.4,') EXCEEDS 102% OF' & & /' AREA OF PLANET (',E12.4,'), WHICH MAKES' & & ,' NO SENSE.' & & /' CHECK GRID FOR ABS(LATITUDE) > 90.' & & /' AND FOR OVERLAPPING ELEMENTS.') CALL DTraceback END IF THICK=TOTALV/TOTALA IF (SPHERE) THEN SIDE=RADIUS NFAULT=1 ELSE SIDE=DSQRT(TOTALA) NFAULT=4 ENDIF CONSTR=NFAULT*REFSTR*THICK/OKDELV ETAMAX=REFSTR*THICK/(SIDE*OKDELV) ETAMAX=MIN(ETAMAX,TRHMAX/OKDELV) FMUMAX=NFAULT*REFSTR/OKDELV VISMAX=0.25D0*REFSTR*SIDE/OKDELV !WRITE (*,50) TOTALA,TOTALV,THICK,SIDE,CONSTR,ETAMAX, & ! & FMUMAX,VISMAX 50 FORMAT (/ /' SUBPROGRAM -LIMITS- PERFORMS DIMENSIONAL ANALYSIS'/ & & ' AND ESTIMATES NECESSARY STIFFNESS LIMITS TO BALANCE'/1P, & & ' THE CONFLICTING OBJECTIVES OF ACCURACY AND PRECISION:'/ / & & ' AREA OF MODEL = ',E10.3,' LENGTH**2'/ & & ' VOLUME OF MODEL = ',E10.3,' LENGTH**3'/ & & ' TYPICAL THICKNESS = ',E10.3,' LENGTH'/ & & ' TYPICAL WIDTH = ',E10.3,' LENGTH'/ & & ' CONSTR (CONSTRAINT WEIGHT) = ',E10.3,' FORCE-SEC/LENGTH**2'/ & & ' ETAMAX (MAX. BASAL COUPLING) = ',E10.3,' FORCE-SEC/LENGTH**3'/ & & ' FMUMAX (MAX. FAULT STIFFNESS) = ',E10.3,' FORCE-SEC/LENGTH**3'/ & & ' VISMAX (MAX. BLOCK VISCOSITY) = ',E10.3,' FORCE-SEC/LENGTH**2') END SUBROUTINE Limits_in_SHELLS SUBROUTINE OneBar (continuum_LRi, & ! input & geothC, geothM, gradie, & ! input & LRn, LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_eCreep, & ! input & numEl, oneKm, tAdiab, & ! input & zBAsth, zMoho, & ! input & glue) ! output ! Calculates "glue" (shear stress required to create one unit of relative ! horizontal velocity across the lithosphere+asthenosphere mantle layer, down to depth zBAsth). IMPLICIT NONE ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - INTEGER, INTENT(IN) :: continuum_LRi ! input REAL*8, INTENT(IN) :: geothC, geothM, gradie ! input INTEGER, INTENT(IN) :: LRn ! input REAL*8, INTENT(IN) :: LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_eCreep ! input INTEGER, INTENT(IN) :: numEl ! input REAL*8, INTENT(IN) :: oneKm, tAdiab, zBAsth, zMoho ! input REAL*8, INTENT(OUT) :: glue ! output ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - INTEGER i, layer, level, limit, m REAL*8 ailog, arg, bi, dz, ecini, gt, t, ta, tg, v, z ! External argument arrays: DIMENSION continuum_LRi(numEl), geothC(4, 7, numEl), geothM(4, 7, numEl), & & glue(7, numEl), & & LR_set_aCreep(1:2, 0:LRn), LR_set_bCreep(1:2, 0:LRn), LR_set_cCreep(1:2, 0:LRn), LR_set_eCreep(0:LRn), & & zMoho(7, numEl) ! Internal variables: INTEGER LRi REAL*8 t_aCreep(2), t_bCreep(2), t_cCreep(2), t_eCreep ! Internal arrays: DIMENSION ailog(2), gt(4) dz = oneKm limit = zBAsth / dz + 0.5D0 DO 100 i = 1, numEl !retrieve desired rheology for this continuum element: LRi = continuum_LRi(i) t_aCreep(1:2) = LR_set_aCreep(1:2, LRi) t_bCreep(1:2) = LR_set_bCreep(1:2, LRi) t_cCreep(1:2) = LR_set_cCreep(1:2, LRi) t_eCreep = LR_set_eCreep(LRi) !statements that were formerly outside the loops: ecini = -1.0D0 / t_eCreep ailog(1) = log(t_aCreep(1)) * ecini ailog(2) = log(t_aCreep(2)) * ecini DO 90 m = 1, 7 !Integrate difference in horizontal velocity over depth: v = 0.0D0 DO 20 level = 1, limit z = (level - 0.5D0) * dz IF (z < zMoho(m, i)) THEN layer = 1 gt(1) = geothC(1, m, i) gt(2) = geothC(2, m, i) gt(3) = geothC(3, m, i) gt(4) = geothC(4, m, i) ELSE layer = 2 gt(1) = geothM(1, m, i) gt(2) = geothM(2, m, i) ! Note: Quadratic and cubic terms could ! cause lithospheric geotherm to have ! multiple (nonphysical) intersections ! with the adiabat! gt(3) = 0.0D0 gt(4) = 0.0D0 END IF tg = gt(1) & & + gt(2) * z & & + gt(3) * z * z & & + gt(4) * z * z * z ta = tAdiab + z * gradie t = MIN(tg, ta) t = MAX(t, 200.0D0) bi = (t_bCreep(layer) + t_cCreep(layer) * z) * ecini arg = MAX(ailog(layer) + bi / t, -87.0D0) v = v + dz * EXP(arg) 20 CONTINUE glue(m, i) = 1.0D0 / (v**t_eCreep) 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE OneBar SUBROUTINE Pause() IMPLICIT NONE WRITE (*,"(' Press [Enter]...'\)") READ (*,*) END SUBROUTINE Pause SUBROUTINE Plot_Fault_Ticks (colored, using_LRi_color, highestLRi) ! uses global variables and arrays LOGICAL, INTENT(IN) :: colored LOGICAL, INTENT(IN), OPTIONAL :: using_LRi_color INTEGER, INTENT(IN), OPTIONAL :: highestLRi LOGICAL :: multicolored INTEGER :: LRi, index CHARACTER*10 :: color_name REAL*8 :: s IF (colored) THEN CALL DSet_Stroke_Color ('red_______') CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'red_______') !BUT note that these may be overridden by later CALLs if using_LRi_color IF (PRESENT(using_LRi_color)) THEN IF (using_LRi_color) THEN IF (PRESENT(highestLRi)) THEN IF (highestLRi > 0) THEN multicolored = .TRUE. ELSE multicolored = .FALSE. END IF ELSE multicolored = .FALSE. END IF ELSE multicolored = .FALSE. END IF ELSE multicolored = .FALSE. END IF ELSE CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') multicolored = .FALSE. END IF CALL DBegin_Group ! of dip ticks CALL DSet_Line_Style (width_points = 0.6D0, dashed = .FALSE.) DO i = 1, nFl IF (FEP == "SHELLS") THEN IF (multicolored) THEN LRi = fault_LRi(i) ! from global array s = (LRi * 1.0D0) / (1.0D0 * highestLRi) !Use predefined (in DAdobe_Illustrator) custom colors #2 (red = high) ~ #12 (dark blue = low) index = 2 + NINT(10.0D0 - (10.0D0 * s)) index = MIN(12, MAX(2, index)) color_name = ai_spectrum(index)%color_name CALL DSet_Stroke_Color (color_name) CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = color_name) END IF dip_degrees = (fdip(1,i) + fdip(2,i)) / 2.0D0 uvec1(1:3) = node_uvec(1:3,nodef(1,i)) uvec2(1:3) = node_uvec(1:3,nodef(2,i)) uvec3(1:3) = (uvec1(1:3) + uvec2(1:3)) / 2.0D0 tick_azimuth = DCompass(from_uvec = uvec3, to_uvec = uvec2) IF (dip_degrees > 0.0D0) THEN tick_azimuth = tick_azimuth + Pi / 2.0D0 ELSE ! negative dip means dipping from N3-N4 side. tick_azimuth = tick_azimuth - Pi / 2.0D0 END IF IF (ABS(dip_degrees) > 75.D0) THEN ! ~Vertical fault; no dip ticks (sense undefined). ELSE IF (ABS(dip_degrees) > 49.99D0) THEN ! use normal fault symbol CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = tick_azimuth, & & style_byte = 'N', & & size_points = tick_points, & & offset_points = 0.8D0) ELSE IF (ABS(dip_degrees) > 32.5D0) THEN ! ~45 deg. dip; use ambiguous/detachment fault symbol CALL DDipTick_on_Sphere (uvec = uvec3, & & dip_azimuth_radians = tick_azimuth, & & style_byte = 'D', & & size_points = tick_points, & & offset_points = 0.8D0) ELSE IF (ABS(dip_degrees) > subdip) THEN ! (high-angle) thrust; i.e., not a subduction orogen 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 orogen 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 IF ! FEP selection END DO ! i = 1, nfl CALL DEnd_Group ! of dip ticks END SUBROUTINE Plot_Fault_Ticks SUBROUTINE Plot_Fault_Traces (colored, using_LRi_color, highestLRi) ! uses global variables and arrays LOGICAL, INTENT(IN) :: colored LOGICAL, INTENT(IN), OPTIONAL :: using_LRi_color INTEGER, INTENT(IN), OPTIONAL :: highestLRi LOGICAL :: multicolored INTEGER :: LRi, index CHARACTER*10 :: color_name REAL*8 :: s IF (colored) THEN CALL DSet_Stroke_Color ('red_______') !BUT note that this may be overridden by later CALLs if using_LRi_color IF (PRESENT(using_LRi_color)) THEN IF (using_LRi_color) THEN IF (PRESENT(highestLRi)) THEN IF (highestLRi > 0) THEN multicolored = .TRUE. ELSE multicolored = .FALSE. END IF ELSE multicolored = .FALSE. END IF ELSE multicolored = .FALSE. END IF ELSE multicolored = .FALSE. END IF ELSE CALL DSet_Stroke_Color ('foreground') multicolored = .FALSE. END IF CALL DBegin_Group ! of fault traces CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) DO i = 1, nFl IF (FEP == "SHELLS") THEN IF (multicolored) THEN LRi = fault_LRi(i) ! from global array s = (LRi * 1.0D0) / (1.0D0 * highestLRi) !Use predefined (in DAdobe_Illustrator) custom colors #2 (red = high) ~ #12 (dark blue = low) index = 2 + NINT(10.0D0 - (10.0D0 * s)) index = MIN(12, MAX(2, index)) color_name = ai_spectrum(index)%color_name CALL DSet_Stroke_Color (color_name) END IF 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 IF ! FEP selection 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 Read_Additional_LRs (temp_path_in, iUnitLR, LRn, continuum_LRi, fault_LRi, numEl, nFl, & ! input & LR_set_fFric, LR_set_cFric, LR_set_Biot, LR_set_Byerly, & ! modify & LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_dCreep, LR_set_eCreep, & ! modify & LR_is_defined, LR_is_used) ! modify !Obtain extra input file with Lithospheric Rheologies from the user: IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: temp_path_in INTEGER, INTENT(IN) :: iUnitLR INTEGER, INTENT(IN) :: LRn ! highest LR# found in .FEG file INTEGER, DIMENSION(numEl), INTENT(IN) :: continuum_LRi INTEGER, DIMENSION(nFl), INTENT(IN) :: fault_LRi INTEGER, INTENT(IN) :: numEl, nFl REAL*8, DIMENSION(0:LRn), INTENT(INOUT) :: LR_set_fFric, LR_set_cFric, LR_set_Biot, LR_set_Byerly REAL*8, DIMENSION(1:2, 0:LRn), INTENT(INOUT) :: LR_set_aCreep, LR_set_bCreep, LR_set_cCreep, LR_set_dCreep REAL*8, DIMENSION(0:LRn), INTENT(INOUT) :: LR_set_eCreep LOGICAL, DIMENSION(0:LRn), INTENT(INOUT) :: LR_is_defined LOGICAL, DIMENSION(0:LRn), INTENT(INOUT) :: LR_is_used CHARACTER*80 :: LR_table_file, LR_table_pathfile INTEGER :: i, ios, j 10 WRITE (*, *) WRITE (*, "(' Lithospheric Rheology indeces from 0 to ', I8, ' are used in this .feg file.')") LRn WRITE (*, "(' Enter name of file with table of additional Lithospheric Rheologies: ')") READ (*, "(A)") LR_table_file LR_table_pathfile = TRIM(temp_path_in) // TRIM(LR_table_file) OPEN (UNIT = iUnitLR, FILE = TRIM(LR_table_pathfile), STATUS = "OLD", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: File not found (in current folder). Please try again...')") CALL Pause() GO TO 10 END IF READ (iUnitLR, * , IOSTAT = ios) ! READ (and discard) column-header line at top IF (ios /= 0) THEN WRITE(*, "(' ERR', 'OR: File not found, or file is empty,' / ' or file is too short.')") CALL Pause() STOP END IF collect_LRs: DO READ (iUnitLR, *, IOSTAT = ios) i IF (ios /= 0) EXIT collect_LRs ! at EOF, probably IF ((i < 1).OR.(i > LRn)) THEN WRITE (*, "(' ERR', 'OR: LR#', I8, ' is outside the legal range of (1:', I8, ').')") i, LRn WRITE (*, "(' To make it legal, some element in the .feg file must use this (or higher) LR#.')") CALL Pause() STOP END IF BACKSPACE(iUnitLR) READ (iUnitLR, *, IOSTAT = ios) i, LR_set_fFric(i), LR_set_cFric(i), LR_set_Biot(i), LR_set_Byerly(i), & & LR_set_aCreep(1:2, i), LR_set_bCreep(1:2, i), LR_set_cCreep(1:2, i), LR_set_dCreep(1:2, i), & & LR_set_eCreep(i) IF (ios == 0) THEN LR_is_defined(i) = .TRUE. ELSE WRITE (*, "(' ERR', 'OR while trying to read 13 REAL*8 values that make up LR#', I8)") i CALL Pause() STOP END IF END DO collect_LRs CLOSE (iUnitLR) !Now, "stress-test" the continuum elements to be sure that each has a defined rheology: DO j = 1, numEl i = continuum_LRi(j) IF (.NOT.LR_is_defined(i)) THEN WRITE (*, "(' ERR', 'OR: Continuum element ', I8,' uses LR#', I8, ' which has NOT been defined!')") j, i CALL Pause() STOP ELSE LR_is_used(i) = .TRUE. END IF END DO !Now, "stress-test" the fault elements to be sure that each has a defined rheology: IF (nFl > 0) THEN DO j = 1, nFl i = fault_LRi(j) IF (.NOT.LR_is_defined(i)) THEN WRITE (*, "(' ERR', 'OR: Fault element ', I8,' uses LR#', I8, ' which has NOT been defined!')") j, i CALL Pause() STOP ELSE LR_is_used(i) = .TRUE. END IF END DO END IF !!Write a report to the log-file, to provide a record of the LRs used: !WRITE (iUnitT, *) !WRITE (iUnitT, "('===========================================================================================================================')") !WRITE (iUnitT, "('Table of alternative Lithospheric Rheologies defined and used:')") !WRITE (iUnitT, "(' LR# fFric cFric Biot Byerly aCreep(1) aCreep(2) bCreep(1) bCreep(2) cCreep(1) cCreep(2) dCreep(1) dCreep(2) eCreep')") !DO i = 0, LRn ! IF (LR_is_defined(i).AND.LR_is_used(i)) THEN ! WRITE (iUnitT, "(I8, F6.3, F6.3, F6.3, F7.3, ES10.2, ES10.2, F10.0, F10.0, F10.4, F10.4, ES10.2, ES10.2, F10.5)") & ! & i, LR_set_fFric(i), LR_set_cFric(i), LR_set_Biot(i), LR_set_Byerly(i), & ! & LR_set_aCreep(1:2, i), LR_set_bCreep(1:2, i), LR_set_cCreep(1:2, i), LR_set_dCreep(1:2, i), & ! & LR_set_eCreep(i) ! END IF !END DO !WRITE (iUnitT, "('===========================================================================================================================')") !WRITE (iUnitT, *) END SUBROUTINE Read_Additional_LRs SUBROUTINE Reframe_Velocity () ! A code fragment made into a SUBR so it need not be repeated. ! Uses global fixed_node, nonorbiting_node, numnod, ! node_uvec(1:3, 1:numnod), vw(1:2*numnod). ! Modifies vw. IMPLICIT NONE 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, theta_uvec, tvec, & & uvec, uvec1, uvec2, velocity1, velocity2 uvec1(1:3) = node_uvec(1:3, fixed_node) 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) CALL DCross(uvec1, velocity1, euler1) ! uvec1 and velocity1 are perpendicular ! 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) v_East_at2 = vw(2 * nonorbiting_node) velocity2(1:3) = v_South_at2 * theta_uvec(1:3) + & & v_East_at2 * phi_uvec(1:3) !correct velocity2 for rotation euler1: CALL DCross (euler1, uvec2, tvec) 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 velocity2(1:3) = v_South_at2 * theta_uvec(1:3) + & & v_East_at2 * phi_uvec(1:3) 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)) / DSIN(DArc(uvec1, uvec2)) euler2(1:3) = uvec1(1:3) * spin ! this component rotates nonorbiting_node about fixed_node euler3 = euler1 + euler2 ! this is the total rotation-rate that we need to subtract DO i = 1, numnod ! remove this rotation from all nodes uvec(1:3) = node_uvec(1:3, i) CALL DCross (euler3, uvec, tvec) 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 SUBROUTINE Replace_Zeros () !The .feg files used by FAULTS and PLATES may have mid-point node locations !entered as (0.0, 0.0). This is a code meaning that the position should be computed !either from: (a) use of "fazim" values at each end of a fault element; or ! (b) node positions at the ends of a straight element side. !The code here was made into a subprogram just to avoid its repetition; !it refers to global variables "numel" and "nfl" and also to global arrays ! "nodef", "nodes", "xy_node_meters", and "fazim". !The values that will be changed are within array "xy_node_meters". IMPLICIT NONE INTEGER :: i, i1, i2, i3, i5, j, jm, jp, n REAL*8 :: az, dx, dy, factor, parral, perpen, phi1, phi2, t1, t2 !Compute coordinates of midpoint nodes that were not input. !First, faults: DO i = 1, nfl i1 = nodef(1, i) i2 = nodef(2, i) i3 = nodef(3, i) i5 = nodef(5, i) dx = xy_node_meters(1, i3) - xy_node_meters(1, i1) dy = xy_node_meters(2, i3) - xy_node_meters(2, i1) az = DATAN2(dy, dx) phi1 = fazim(1, i) - az phi1 = MOD(phi1 + 1.570796D0, 3.14159265D0) - 1.570796D0 phi2 = az - fazim(2, i) phi2 = MOD(phi2 + 1.570796D0, 3.14159265D0) - 1.570796D0 IF ((ABS(phi1) > 0.0D0).OR.(ABS(phi2) > 0.0D0)) THEN t1 = DTAN(phi1) t2 = DTAN(phi2) IF (ABS(t2 - t1) >= ABS(t1 + t2)) THEN factor = 0.99D0 * ABS(t1 + t2) / ABS(t2 - t1) IF (ABS(t1) > ABS(t2)) THEN t2 = t1 + factor * (t2 - t1) ELSE t1 = t2 + factor * (t1 - t2) END IF END IF parral = (t2 - t1) / (4.0D0 * (t1 + t2)) perpen = t1 * t2 / (2.0D0 * (t1 + t2)) xy_node_meters(1, i2) = xy_node_meters(1, i1) + dx / 2.0D0 + parral * dx - perpen * dy xy_node_meters(2, i2) = xy_node_meters(2, i1) + dy / 2.0D0 + perpen * dx + parral * dy ELSE xy_node_meters(1, i2) = (xy_node_meters(1, i1) + xy_node_meters(1, i3)) / 2.0D0 xy_node_meters(2, i2) = (xy_node_meters(2, i1) + xy_node_meters(2, i3)) / 2.0D0 END IF xy_node_meters(1, i5) = xy_node_meters(1, i2) xy_node_meters(2, i5) = xy_node_meters(2, i2) END DO ! i = 1, nfl !Next, other element sides, if needed: DO i = 1, numel DO j = 4, 6 n = nodes (j, i) IF ((xy_node_meters(1, n) == 0.0D0).AND.(xy_node_meters(2, n) == 0.0D0)) THEN jp = j - 2 IF (j == 6) jp = 1 jm = j - 3 xy_node_meters(1, n) = 0.5D0 * (xy_node_meters(1, nodes(jp, i)) + xy_node_meters(1, nodes(jm, i))) xy_node_meters(2, n) = 0.5D0 * (xy_node_meters(2, nodes(jp, i)) + xy_node_meters(2, nodes(jm, i))) END IF END DO ! j = 4, 6 END DO ! i = 1, numel, correcting "0.0 0.0" node locations END SUBROUTINE Replace_Zeros 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) REAL*8, INTENT(IN) :: R ! radius of planet, in m INTEGER, INTENT(IN) :: l_ ! element number INTEGER, DIMENSION(:,:), INTENT(IN) :: nodes REAL*8, DIMENSION(3,2,2) :: G ! nodal functions @ selected point REAL*8, DIMENSION(3,2,2,2):: dG ! derivitives of nodal functions REAL*8, INTENT(IN) :: theta_ ! colatitude, radians REAL*8, DIMENSION(:), INTENT(IN) :: vw REAL*8, 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.) IF (color_name == 'foreground') THEN CALL DSet_Fill_or_Pattern(.FALSE.,'background') ELSE CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') END IF 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 SQUEEZ (ALPHAT, density_anomaly_kgpm3, ELEVAT, & & GEOTH1,GEOTH2,GEOTH3,GEOTH4, & & GEOTH5,GEOTH6,GEOTH7,GEOTH8, & & GMEAN, & & IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, & & TEMLIM,ZM,ZSTOP, & ! inputs & TAUZZ,SIGZZB) ! outputs !CALCULATES "TAUZZ", THE VERTICAL INTEGRAL THROUGH THE PLATE ! OF THE VERTICAL STANDARDIZED STRESS ANOMALY, WHICH IS ! RELATIVE TO A COLUMN OF MANTLE AT ASTHENOSPHERE TEMPERATURE ! WITH A 5 KM CRUST AND A 2.7 KM OCEAN ON TOP, LIKE A MID-OCEAN ! RISE. THE INTEGRAL IS FROM EITHER THE LAND SURFACE OR THE ! SEA SURFACE, DOWN TO A DEPTH OF "ZSTOP" BELOW THE TOP OF ! THE CRUST. ! IF "ZSTOP" EXCEEDS MOHO DEPTH "ZM", THEN PROPERTIES OF THE MANTLE ! WILL BE USED IN THE LOWER PART OF THE INTEGRAL. !ALSO RETURNS "SIGZZB", THE STANDARDIZED VERTICAL STRESS ANOMALY ! AT DEPTH "ZSTOP" BELOW THE SOLID ROCK SURFACE. !NOTE: THIS VERSION IS DIFFERENT FROM THE VERSION FOUND IN THE LARAMY ! PROGRAM PACKAGE. FIRST, IT ACTS ON ONLY A SINGLE POINT. ! SECOND, IT INFERS SUB-PLATE NORMAL-STRESS ANOMALIES FROM ! THE GIVEN TOPOGRAPHY, INSTEAD OF FROM MODEL STRUCTURE. !Copied from SHELLS and changed (minimally) to Fortran 90, Feb. 1999 ! IMPLICIT NONE INTEGER, PARAMETER :: NDREF = 400 ! Arguments: INTEGER, INTENT(IN) :: IUNITT ! text output device, = 6? REAL*8, INTENT(IN) :: density_anomaly_kgpm3, ELEVAT, & & GEOTH1, GEOTH2, GEOTH3, GEOTH4, & & GEOTH5, GEOTH6, GEOTH7, GEOTH8, & & GMEAN, ONEKM, RHOAST, RHOH2O, & & ZM, ZSTOP REAL*8, DIMENSION(2), INTENT(IN) :: ALPHAT, RHOBAR, TEMLIM REAL*8, INTENT(OUT) :: TAUZZ, SIGZZB ! Internal variables: INTEGER :: I, J, LASTDR, LAYER1, LAYER2, N1, N2, NSTEP LOGICAL :: CALLED REAL*8 :: DENSE, DENSE1, DENSE2, FRAC, FRAC1, FRAC2, H, & & OLDPR, OLDSZZ, PR, RESID, RHOTOP, SIGZZ, T, Z, ZBASE, ZTOP REAL*8, DIMENSION(1:NDREF) :: DREF REAL*8, DIMENSION(0:NDREF) :: PREF SAVE CALLED, DREF, PREF DATA CALLED /.FALSE./ ! STATEMENT FUNCTIONS: REAL*8 :: TEMPC, TEMPM TEMPC(H)=MIN(TEMLIM(1),GEOTH1+GEOTH2*H+GEOTH3*H**2 & & +GEOTH4*H**3) TEMPM(H)=MIN(TEMLIM(2),GEOTH5+GEOTH6*H+GEOTH7*H**2 & & +GEOTH8*H**3) !CREATE REFERENCE TEMPERATURE & DENSITY PROFILES TO DEPTH OF NDREF KM IF (.NOT.CALLED) THEN RHOTOP=RHOBAR(1)*(1.0D0-ALPHAT(1)*GEOTH1) DREF(1)=RHOH2O DREF(2)=RHOH2O DREF(3)=0.7D0*RHOH2O+0.3D0*RHOTOP DREF(4)=RHOTOP DREF(5)=RHOTOP DREF(6)=RHOTOP DREF(7)=RHOTOP DREF(8)=0.7D0*RHOTOP+0.3D0*RHOAST DO 50 J=9,NDREF DREF(J)=RHOAST 50 CONTINUE PREF(0)=0.0D0 DO 100 I=1,NDREF PREF(I)=PREF(I-1)+DREF(I)*GMEAN*ONEKM 100 CONTINUE END IF !ROUTINE PROCESSING (ON EVERY CALL): IF (ELEVAT.GT.0.0D0) THEN !LAND ZTOP= -ELEVAT ZBASE=ZSTOP-ELEVAT DENSE1=RHOBAR(1)*(1.0D0-GEOTH1*ALPHAT(1))+density_anomaly_kgpm3 H=0.0D0 LAYER1=1 ELSE !OCEAN ZTOP=0.0D0 ZBASE=ZSTOP+(-ELEVAT) DENSE1=RHOH2O H=ELEVAT LAYER1=0 END IF LASTDR=ZBASE/ONEKM IF (ZBASE.GT.ONEKM*LASTDR) LASTDR=LASTDR+1 IF (LASTDR.GT.NDREF) THEN WRITE(IUNITT,110) LASTDR 110 FORMAT(' IN SUBPROGRAM SQUEEZ, PARAMETER NDREF '/ & & ' MUST BE INCREASED TO AT LEAST ',I10) CALL DTraceback END IF NSTEP=(ZBASE-ZTOP)/ONEKM OLDSZZ=0.0D0 OLDPR=0.0D0 SIGZZ=0.0D0 TAUZZ=0.0D0 Z=ZTOP DO 200 I=1,NSTEP Z=Z+ONEKM H=H+ONEKM IF (H.GT.0.0D0) THEN IF (H.LE.ZM) THEN T=TEMPC(H) DENSE2=RHOBAR(1)*(1.0D0-T*ALPHAT(1)) + & & density_anomaly_kgpm3 LAYER2=1 ELSE T=TEMPM(H-ZM) DENSE2=RHOBAR(2)*(1.0D0-T*ALPHAT(2)) + & & density_anomaly_kgpm3 LAYER2=2 END IF ELSE DENSE2=RHOH2O LAYER2=0 END IF IF ((LAYER1.EQ.0).AND.(LAYER2.EQ.1)) THEN FRAC2=H/ONEKM FRAC1=1.0D0-FRAC2 ELSE IF ((LAYER1.EQ.1).AND.(LAYER2.EQ.2)) THEN FRAC2=(H-ZM)/ONEKM FRAC1=1.0D0-FRAC2 ELSE FRAC1=0.5D0 FRAC2=0.5D0 END IF DENSE=FRAC1*DENSE1+FRAC2*DENSE2 IF (Z.GT.0.0D0) THEN N1=Z/ONEKM N2=N1+1 FRAC=Z/ONEKM-N1 PR=PREF(N1)+FRAC*(PREF(N2)-PREF(N1)) ELSE PR=0.0D0 END IF SIGZZ=SIGZZ-DENSE*GMEAN*ONEKM+(PR-OLDPR) TAUZZ=TAUZZ+0.5*(SIGZZ+OLDSZZ)*ONEKM DENSE1=DENSE2 OLDSZZ=SIGZZ OLDPR=PR LAYER1=LAYER2 200 CONTINUE RESID=ZBASE-Z H=ZSTOP Z=ZBASE IF (ZSTOP.LE.ZM) THEN T=TEMPC(H) DENSE2=RHOBAR(1)*(1.0D0-T*ALPHAT(1)) + & & density_anomaly_kgpm3 ELSE T=TEMPM(H-ZM) DENSE2=RHOBAR(2)*(1.0D0-T*ALPHAT(2)) + & & density_anomaly_kgpm3 END IF DENSE=0.5D0*(DENSE1+DENSE2) IF (Z.GT.0.0D0) THEN N1=Z/ONEKM N2=N1+1 FRAC=Z/ONEKM-N1 PR=PREF(N1)+FRAC*(PREF(N2)-PREF(N1)) ELSE PR=0.0D0 END IF SIGZZB=SIGZZ-DENSE*GMEAN*RESID+(PR-OLDPR) TAUZZ=TAUZZ+0.5*(SIGZZB+OLDSZZ)*RESID CALLED=.TRUE. END SUBROUTINE SQUEEZ 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.0D0, & & 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.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = '(x '//TRIM(number8)//' Ma):') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5D0*(x1_points+x2_points)-14.17D0, from_y = y2_points - 33.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.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8)//' mm/a') CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 48.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.0D0, & & 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.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = '(x '//TRIM(number8)//' Ma):') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.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.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 24.D0, & & angle_radians = 0.0D0, & & 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, d_angle, 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) d_angle = -(t2 - t1) ! reversing sign, so d_angle will typically be positive if uvec is inside. d_angle = ATAN2(SIN(d_angle), COS(d_angle)) ! getting rid any cycle shifts! angle_sum = angle_sum + d_angle END DO ! k = 2, nInEachPlate(j) inside = ((angle_sum > 3.0D0).AND.(angle_sum < 9.0D0)) ! inside a counterclockwise circuit !Note: Generalizing formula to allow for being inside a clockwise circuit would 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 LOGICAL FUNCTION Within(uvec, outline_count, plate_outline_uvecs) ! Determines whether uvec is inside the circuit of plate_outline_uvecs(1:outline_count), ! where the convention is that plate_outline_uvecs(1) == plate_outline_uvecs(outline_count). USE DSphere ! Fortran MODULE DSphere is in file DSphere.f90, provided by Peter Bird of UCLA. IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: uvec INTEGER, INTENT(IN) :: outline_count REAL*8, DIMENSION(3, outline_count), INTENT(IN) :: plate_outline_uvecs INTEGER :: i REAL*8, DIMENSION(3) :: tuvec_0, tuvec_1 REAL*8 :: angle_0, angle_1, angle_sum, d_angle angle_sum = 0.0D0 tuvec_0(1:3) = plate_outline_uvecs(1:3, 1) angle_0 = DRelative_Compass(from_uvec = uvec, to_uvec = tuvec_0) !result is azimuth, clockwise from N, in radians DO i = 2, outline_count tuvec_1(1:3) = plate_outline_uvecs(1:3, i) angle_1 = DRelative_Compass(from_uvec = uvec, to_uvec = tuvec_1) !If uvec is inside, then typically angle_1 < angle_0 (except for cycle shifts) d_angle = -(angle_1 - angle_0) ! reversing sign, so d_angle will typically be positive if uvec is inside. d_angle = ATAN2(SIN(d_angle), COS(d_angle)) ! getting rid any cycle shifts! angle_sum = angle_sum + d_angle !prepare for next plate-boundary step: tuvec_0 = tuvec_1 angle_0 = angle_1 END DO !If uvec is inside, then angle_sum should be somewhere close to 2*Pi. Within = (angle_sum > 3.0D0) .AND. (angle_sum < 9.0D0) !but angle_sum will be either ~0.0 or around -2.0*Pi, if point is outside. END FUNCTION Within END PROGRAM FiniteMap