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 ! Department of Earth and Space Sciences ! University of California ! Los Angeles, CA 90095-1567 ! pbird@ess.ucla.edu ! (310) 825-1126 ! !(c) Copyright 1998, 1999, 2000, 2001, 2002, 2005, 2006 by ! Peter Bird and the Regents of the University of California. ! USE Adobe_Illustrator ! provided as Adobe_Illustrator.f90 USE Map_Projections ! provided as Map_Projections.f90 USE Map_Tools ! provided as Map_Tools.f90 USE Icosahedron ! provided as Icosahedron.f90 USE DFLIB, ARCQQ => ARC ! provided with Digital Visual Fortran: ! Using GETFILEINFOQQ, which provides names of files ! matching spec.s like "v*.out". Helps user select correct file. ! If no substitute is available on your system when you compile, ! just omit SUBROUTINE File_List (and any CALLs to it). ! Also, using BEEPQQ to sound PC speaker when each task is done; ! again, this can simply be omitted if there is no substitute. ! However, not using ARC, because I have my own Arc; so I am ! renaming their ARC to ARCQQ to avoid conflicts. !GPBtypes !TYPES IMPLICIT NONE !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 :: number8 CHARACTER*10 :: color_name, string10 CHARACTER*12 :: grid_units, element_scalar_units, force_units, & & format1, format2, format3, format4, format5, & & node_scalar_units, stress_integral_units CHARACTER*27 :: c27 CHARACTER*132 :: input_record CHARACTER*300 :: boundaries_dig_file, boundaries_dig_pathfile, & & gps_file, gps_pathfile, & & grd1_file, grd1_pathfile, grd2_file, grd2_pathfile, & & feg_file, feg_pathfile, & & element_scalar_feg_file, element_scalar_feg_pathfile, & & force_file, force_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, 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*132, DIMENSION(20) :: titles CHARACTER*200 :: appended_data 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_height, & & bitmap_shading_mode, bitmap_width, choice, & & 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, & & grd1_ncols, grd1_nrows, & & grd2_ncols, grd2_nrows, & & element_scalar_zeromode, elev, & & fixed_node, & & group, & & i, i1, i2, iconve, iele, ios, ipAfri, iplate, ipvref, irow, & & j, jcol, jp, jp1, j1, j2, & & k, kilometers, & & l, l_, label_thinner, list_length, & & log_strainrate_method, log_viscosity_integral_method, lp, & & 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, numel, numnod, n1000, & & old_mosaic_count, old_overlay_count, overlay_count, other_plate_ID, & & plate_count, plate_count_times_3, plate_ID, pressure_MPa_method, & & read_status, ref_frame_plate_ID, rotationrate_method, & & s_header_lines, s_rst_count, shear_integral_method, shear_integral_zeromode, & & 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) LOGICAL :: add_titles, any_FPS, any_titles, azimuth_is_integer, & & bottom, & & 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, & & element_scalar_lowblue, ellipses, everyp, & & e1h_partitioned, e2h_partitioned, err_partitioned, & & 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, 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, shear_integral_lowblue, sigma_is_integer, & & skip_0_contour, solid, & & stroke_this, success, suggest_logical, & & Tbase_C_lowblue, TMoho_C_lowblue, traction_lowblue, & & using_A_to_E, & & valid_FPS, velocity_reframe, velocity_lowblue, virgin, visible, & & xy_defined LOGICAL, DIMENSION(nPlates) :: slab_Q ! does this plate have (extensive) driving slabs attached? LOGICAL, DIMENSION(:), ALLOCATABLE :: node_has_area, selected, traction_pole_read LOGICAL(1), DIMENSION(:,:), ALLOCATABLE :: bitmap_success, touching REAL, PARAMETER :: bottomlegend_gap_points = 14. REAL, PARAMETER :: deg_per_rad = 180. / 3.141592654 REAL, PARAMETER :: rad_per_deg = 3.141592654 / 180. REAL, PARAMETER :: rightlegend_gap_points = 14. REAL, PARAMETER :: s_per_Ma = 1000000.*365.25*24.*60.*60. REAL, PARAMETER :: sec_per_year = 31557600. REAL, PARAMETER :: subdip = 19.0 ! degrees; should match SHELLS value REAL :: above, angle_sum, arc2, arc3, argument, aze2, aze3, az1, az2, az3, az_radians, & & below, benchmark_points, big_diff, biot, bitmap_color_highvalue, bitmap_color_lowvalue, & & bottomlegend_used_points, brightness, byerly, & & cfric, constr, cooling_curvature_Cpm2, covariance_11, covariance_12, covariance_22, crust_meters, & & d0, d1, d_vsize_d_theta, d_vsize_d_phi, del_az_for_90pc, delta12, delta13, delta23, & & delta_max, delta_v_mps, delta_quadratic, 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_azim_rads_1, f_azim_rads_2, f_azim_rads_c, f1, f2, f3, & & f_East, ffric, fin, fmumax, fout, force_scale_N, force_scale_points, f_South, fx1, fx2, fy1, fy2, & & geoth1, geoth2, geoth3, geoth4, geoth5, geoth6, geoth7, geoth8, glue, 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, 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, step_points, & & sup_slipnumber, & & t, t_Ma, t_mean, t1, t2, t3, t4, t5, t6, & & tadiab, 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_interval, 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_midvalue, 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, zMoho, zoftop, zstop, ztran REAL, DIMENSION(2) :: acreep, alphat, & & bcreep, ccreep, conduc, & & dcreep, radio, rhobar, & & taumax, temlim REAL, 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, DIMENSION(3) :: eps_dot REAL, DIMENSION(6) :: f_6nodes REAL, DIMENSION(3,2,2,2):: dG REAL, DIMENSION(3,2,2) :: G REAL, DIMENSION(3,7) :: Gauss_point REAL, DIMENSION(3, nPlates) :: omega REAL, DIMENSION(2, 6) :: xy_6nodes REAL, DIMENSION(:), ALLOCATABLE :: a_ ! plane areas (R == 1.0) of spherical elements REAL, DIMENSION(:), ALLOCATABLE :: azimuth ! of tau1h axis, in radians clockwise from North REAL, DIMENSION(:,:),ALLOCATABLE :: balance_point_uvec REAL, DIMENSION(:), ALLOCATABLE :: benchmark_N_velocity, & & benchmark_N_sigma, & & benchmark_E_velocity, & & benchmark_E_sigma, & & benchmark_correlation, & & benchmark_hypotenuse REAL, DIMENSION(:,:),ALLOCATABLE :: benchmark_uvec REAL, DIMENSION(:,:),ALLOCATABLE :: bitmap_value REAL, DIMENSION(:,:),ALLOCATABLE :: center ! uvecs of spherical elements REAL, DIMENSION(:), ALLOCATABLE :: e3_minus_e1_persec REAL, DIMENSION(:), ALLOCATABLE :: element_scalar REAL, DIMENSION(:,:),ALLOCATABLE :: eqcm ! (6,numnod) REAL, DIMENSION(:), ALLOCATABLE :: f_size ! (numnod) REAL, DIMENSION(:,:),ALLOCATABLE :: fazim REAL, DIMENSION(:,:),ALLOCATABLE :: fdip REAL, DIMENSION(:), ALLOCATABLE :: fg ! (2*numnod; like vw) REAL, DIMENSION(:,:),ALLOCATABLE :: grid1, grid2 REAL, DIMENSION(:), ALLOCATABLE :: largest_axis REAL, DIMENSION(:), ALLOCATABLE :: log_largest_ei_persec REAL, DIMENSION(:), ALLOCATABLE :: log_viscosity_integral ! (numel) REAL, DIMENSION(:), ALLOCATABLE :: omega_degperMa ! (numel) REAL, DIMENSION(:), ALLOCATABLE :: node_scalar REAL, DIMENSION(:,:),ALLOCATABLE :: node_uvec REAL, DIMENSION(:,:),ALLOCATABLE :: plat, plon REAL, DIMENSION(:,:),ALLOCATABLE :: plate_center_uvec REAL, DIMENSION(:,:,:),ALLOCATABLE :: plate_uvecs REAL, DIMENSION(:,:),ALLOCATABLE :: plot_at_uvec REAL, DIMENSION(:,:),ALLOCATABLE :: point_force_magnitude REAL, DIMENSION(:,:),ALLOCATABLE :: point_force_azimuth REAL, DIMENSION(:), ALLOCATABLE :: s_azim REAL, DIMENSION(:), ALLOCATABLE :: s_sigma_ REAL, DIMENSION(:,:),ALLOCATABLE :: s_site REAL, DIMENSION(:,:,:),ALLOCATABLE :: segments REAL, DIMENSION(:), ALLOCATABLE :: shear_integral ! (numel; at m=1) REAL, DIMENSION(:), ALLOCATABLE :: slipnumber REAL, DIMENSION(:,:),ALLOCATABLE :: slipnumbers ! 2 components used in steps.dat overlay REAL, DIMENSION(:,:,:),ALLOCATABLE :: strainrate ! (3,7,numel) REAL, DIMENSION(:,:),ALLOCATABLE :: tau_integral ! (3,numel) = t1h, t2h, trr REAL, DIMENSION(:), ALLOCATABLE :: traction_MPa ! (numnod) REAL, DIMENSION(:,:),ALLOCATABLE :: traction_pole_vector ! (3,nPlates) REAL, DIMENSION(:), ALLOCATABLE :: train REAL, DIMENSION(:), ALLOCATABLE :: up_azim_rads REAL, DIMENSION(:,:),ALLOCATABLE :: uvec_list REAL, DIMENSION(:), ALLOCATABLE :: vsize_mma REAL, DIMENSION(:,:),ALLOCATABLE :: vm, vs REAL, DIMENSION(:), ALLOCATABLE :: vw REAL, DIMENSION(:), ALLOCATABLE :: xnode, ynode REAL, DIMENSION(:,:),ALLOCATABLE :: xy_node_meters REAL, DIMENSION(:,:,:),ALLOCATABLE :: orogen_uvecs !================== DATA statements ======================= DATA Gauss_point / & & 0.3333333333333333E0, 0.3333333333333333E0, 0.3333333333333333E0, & & 0.0597158733333333E0, 0.4701420633333333E0, 0.4701420633333333E0, & & 0.4701420633333333E0, 0.0597158733333333E0, 0.4701420633333333E0, & & 0.4701420633333333E0, 0.4701420633333333E0, 0.0597158733333333E0, & & 0.7974269866666667E0, 0.1012865066666667E0, 0.1012865066666667E0, & & 0.1012865066666667E0, 0.7974269866666667E0, 0.1012865066666667E0, & & 0.1012865066666667E0, 0.1012865066666667E0, 0.7974269866666667E0/ ! plate names (in alphabetical order): DATA names / 'AF','AM','AN', & ! 1, 2, 3 & 'AP','AR','AS', & ! 4, 5, 6 & 'AT','AU','BH', & ! 7, 8, 9 & 'BR','BS','BU', & ! 10, 11, 12 & 'CA','CL','CO', & ! 13, 14, 15 & 'CR','EA','EU', & ! 16, 17, 18 & 'FT','GP','IN', & ! 19, 20, 21 & 'JF','JZ','KE', & ! 22, 23, 24 & 'MA','MN','MO', & ! 25, 26, 27 & 'MS','NA','NB', & ! 28, 29, 30 & 'ND','NH','NI', & ! 31, 32, 33 & 'NZ','OK','ON', & ! 34, 35, 36 & 'PA','PM','PS', & ! 37, 38, 39 & 'RI','SA','SB', & ! 40, 41, 42 & 'SC','SL','SO', & ! 43, 44, 45 & 'SS','SU','SW', & ! 46, 47, 48 & 'TI','TO','WL', & ! 49, 50, 51 & 'YA' / ! 52 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.002401, -0.00793, 0.013891, & ! 1 & 0.000949, -0.00864, 0.013725, & ! 2 & 0.000689, -0.00654, 0.013676, & ! 3 & 0.002042, -0.01315, 0.008856, & ! 4 & 0.008570, -0.00560, 0.017497, & ! 5 & 0.000148, -0.00307, 0.010915, & ! 6 & 0.015696, 0.002467, 0.023809, & ! 7 & 0.009349, 0.000284, 0.016253, & ! 8 & 0.000184, 0.005157, 0.001150, & ! 9 & -0.00087, -0.00226, 0.002507, & ! 10 & -0.01912, 0.030087, 0.010227, & ! 11 & 0.011506, -0.04452, 0.007197, & ! 12 & 0.001688, -0.00904, 0.012815, & ! 13 & 0.003716, -0.00379, 0.000949, & ! 14 & -0.00891, -0.02644, 0.020895, & ! 15 & -0.06117, 0.005216, -0.01375, & ! 16 & 0.070136, 0.160534, 0.094328, & ! 17 & 0.000529, -0.00723, 0.013123, & ! 18 & -0.08325, -0.00246, -0.01492, & ! 19 & 0.016256, 0.089364, 0.015035, & ! 20 & 0.008181, -0.00480, 0.016760, & ! 21 & 0.006512, 0.003176, 0.005073, & ! 22 & 0.108013, 0.299461, 0.230528, & ! 23 & 0.033318, -0.00181, 0.036441, & ! 24 & -0.01383, 0.008245, 0.015432, & ! 25 & -0.77784, 0.440872, -0.04743, & ! 26 & 0.001521, 0.007739, 0.013437, & ! 27 & 0.038223, -0.05829, 0.013679, & ! 28 & 0.001768, -0.00843, 0.009817, & ! 29 & -0.00433, 0.003769, -0.00040, & ! 30 & 0.000111, -0.00636, 0.010449, & ! 31 & 0.044913, -0.00954, 0.010601, & ! 32 & -0.05534, -0.01089, 0.006794, & ! 33 & -0.00002, -0.01341, 0.019579, & ! 34 & 0.001041, -0.00830, 0.012143, & ! 35 & -0.02622, 0.020184, 0.037208, & ! 36 & 0.000000, 0.000000, 0.000000, & ! 37 & -0.00004, -0.00929, 0.012815, & ! 38 & 0.012165, -0.01251, -0.00036, & ! 39 & -0.01918, -0.07060, 0.036797, & ! 40 & 0.000472, -0.00635, 0.009100, & ! 41 & 0.121443, -0.07883, 0.027122, & ! 42 & 0.001117, -0.00743, 0.008534, & ! 43 & -0.00083, -0.00670, 0.013323, & ! 44 & 0.001287, -0.00875, 0.014603, & ! 45 & -0.01719, 0.017186, 0.008623, & ! 46 & 0.003201, -0.01044, 0.015854, & ! 47 & 0.023380, -0.01936, -0.01046, & ! 48 & -0.00940, 0.023063, 0.008831, & ! 49 & 0.142118, 0.005616, 0.078214, & ! 50 & -0.01683, 0.018478, 0.010166, & ! 51 & -0.00083, -0.00616, 0.016274/ ! 52 !========================================================== !GPBgo 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 XP, 2000, NT, 98, 95, or MacOS; or by'& &/' Adobe Illustrator 4 for Windows 3.1. In AI they can be edited and'& &/' annotated before they are printed on a wide variety of devices.'& &/' by Peter Bird, UCLA, version of 18 November 2006'& &/' -----------------------------------------------------------------------')") CALL Prompt_for_Logical('Do you want more information about input and output files?',.FALSE.,more_info) IF (more_info) THEN CALL Prompt_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 7+ for Windows XP, 2000, NT, 98, 95, or MacOS; or'& &/' * Adobe Illustrator 4 for Windows 3.1'& &/' (except that AI4 cannot handle colored/shaded bitmaps).'& &//' In Adobe Illustrator you can view, edit, annotate, and print the maps.'& &//' A model .ai file is needed to provide the boiler-plate PostScript'& &/' header that all .ai files carry. Therefore, file AI7Frame.ai'& &/' (or AI4Frame.ai, if you have to use Adobe Illustrator 4)'& &/' must be in a location accessible by this program. You will have'& &/' a chance to specify the path if it is not in your current directory.'& &//' All .ai files are transmitted (e.g., by FTP over the Internet) as'& &/' ASCII, not as binary. This is because different computer systems'& &/' have different ways of marking the end of a line.'& &/' ------------------------------------------------------------------------')") END IF ! more_ai CALL Prompt_for_Logical('Do you want information about .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 Prompt_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 Prompt_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 Prompt_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 OrbWeaver'& &/' 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 Prompt_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 Prompt_for_Logical('Do you want information about reaction-Force (f*.out) files?',.TRUE.,more_force) IF (more_force) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Reaction-Force (f*.out) Files'& &//' These files contain a horizontal vector of consistent nodal force'& &/' for each node in an .feg file. These are the reaction forces'& &/' against 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 Prompt_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 Prompt_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 Prompt_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 Prompt_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 Prompt_for_Logical('Do you want information about map projections?',.TRUE.,more_map) IF (more_map) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About Map Projections'& &//' John Parr Snyder (1983) Map projections used by the U.S. Geological'& &/' Survey, U.S. Geological Survey Bulletin, volume 1532.'& &//' G. B. Newton (1985) Computer programs for common map projections,'& &/' U.S. Geological Survey Publication, B-1642, 33 pages.'& &//' 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 Press_Enter 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 Prompter to get page and projection parameters. ! (4) Ask user what elements are desired in the plot. ! For each element, prompt for necessary files, contour ! intervals, etc. UNLIKE Prompter, 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.) ! !-------------------------------------------------------------------- !GPBmemory 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) 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) format1 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) format2 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) format3 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) format4 problem = problem.OR.(ios /= 0) READ (11,"(A)",IOSTAT=ios) 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, *,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 Press_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. bitmap_shading_mode = 1 intensity = 1.0 grid_units = 'm' grid_interval = 0. grid_midvalue = 0. grid_lowblue = .TRUE. skip_0_contour = .FALSE. element_scalar_method = 2 element_scalar_feg_file = ' ' element_scalar_units = ' ' element_scalar_interval = 0. element_scalar_midvalue = 0. element_scalar_lowblue = .TRUE. element_scalar_zeromode = 0 feg_file = ' ' node_scalar_method = 2 node_scalar_choice = 1 node_scalar_units = ' ' node_scalar_interval = 0. node_scalar_midvalue = 0. node_scalar_lowblue = .TRUE. parameter_file = ' ' TMoho_C_method = 2 TMoho_C_interval = 0. TMoho_C_midvalue = 0. TMoho_C_lowblue = .TRUE. Tbase_C_method = 2 Tbase_C_interval = 0. Tbase_C_midvalue = 0. Tbase_C_lowblue = .TRUE. pressure_MPa_method = 2 pressure_MPa_interval = 0.0 pressure_MPa_midvalue = 0.0 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. velocity_midvalue = 0. velocity_lowblue = .TRUE. traction_method = 2 traction_interval = 0. traction_midvalue = 0. traction_lowblue = .TRUE. shear_integral_method = 2 stress_integral_units = 'N/m' shear_integral_interval = 0.0 shear_integral_midvalue = 0.0 shear_integral_lowblue = .TRUE. shear_integral_zeromode = 0 log_viscosity_integral_method = 2 log_viscosity_integral_interval = 1.0 log_viscosity_integral_midvalue = 0.0 log_viscosity_integral_lowblue = .FALSE. OrbScore_feg_file = ' ' log_strainrate_method = 2 log_strainrate_interval = 1.0 log_strainrate_midvalue = 0.0 log_strainrate_lowblue = .TRUE. rotationrate_method = 2 rotationrate_interval = 1.0 rotationrate_midvalue = 0.0 rotationrate_lowblue = .TRUE. old_overlay_count = 1 overlay_choice = 0 ! whole array overlay_choice(1) = 1 lines_basemap_file = ' ' tick_points = 6.0 node_radius_points = 0.0 vel_file = ' ' gps_file = ' ' benchmark_points = 12.0 traction_scale_MPa = 0.0 traction_scale_points = 36.0 velocity_Ma = 10.0 vector_thinner = 1 dv_scale_mma = 35.0 dv_scale_points = 24.0 R = 6371000. strainrate_mode012 = 2 ref_e3_minus_e1_persec = 5.E-17 strainrate_diameter_points = 20.0 strain_thinner = 1 tau_integral_scale_Npm = 0.0 tau_integral_scale_points = 48.0 ! diameter s1_size_points = 24.0 stress_thinner = 1 s1h_file = ' ' s_header_lines = 1 regimes_known = .TRUE. format1 = '10X,F10.3' format2 = '20X,F10.3' format3 = '30X,F10.3' format4 = '40X,F10.3' format5 = '50X,A2' force_file = ' ' force_units = 'N' force_scale_N = 0.0 force_scale_points = 48.0 old_eqc_file = ' ' plot_FPS = .TRUE. min_mag = 4.4 m8_diam_points = 28.0 volcano_file = 'Volcanoes.dat' volcano_points = 7.0 ref_frame_plate_ID = 28 subdivision = 4 label_thinner = 1 steps_dat_file = "PB2002_steps.dat" torque_file = ' ' 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!'& &/' ----------------------------------------------------------------------')") CALL Prompt_for_String('What is the path for your input files?',path_in,path_in) path_in = ADJUSTL(path_in) CALL Prompt_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 CALL Prompt_for_String('What is the path for your output (.ai graphics) file?',path_out,path_out) path_out = ADJUSTL(path_out) WRITE (*,"(' IT WILL NOT BE NECESSARY TO TYPE THESE PATHS AGAIN!')") END IF !-------------------------(end of defining paths)-------------------- CALL Prompter (xy_mode = .TRUE., lonlat_mode = .TRUE., path_out = path_out, & & xy_defined = xy_defined) ! output; reports whether user set (x,y) system !NOTE: Prompter opens AI7Frame.ai, begins new graphics file. ! At this stage, we are ready to write on the page! !-------------------------- MOSAICS ------------------------------ !----- (layers of shaded/colored polygons; mostly opaque) -------- mosaic_count = 0 ! counts number of mosaics in this map title_count = 0 ! collects possible titles from input files bottomlegend_used_points = 0. ! records filling of bottom legend, from left rightlegend_used_points = 0. ! records filling of right legend, from top 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 !GPBmosaics WRITE (*,"(' 1 :: digitised basemap (polygons type)')") IF (ai_using_color) THEN WRITE (*,"(' 2 :: colored/shaded bitmap from gridded dataset(s)')") ELSE WRITE (*,"(' 2 :: shaded-relief grey-scale bitmap from gridded dataset')") END IF WRITE (*,"(' 3 :: contour map from gridded dataset')") WRITE (*,"(' 4 :: discontinuous scalar (one value per element)')") 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 Prompt_for_Logical('Do you want one (or more) of these mosaics?',suggest_logical,do_mosaic) IF (do_mosaic) THEN mosaic_count = mosaic_count + 1 choice = mosaic_choice(mosaic_count) CALL Prompt_for_Integer('Which mosaic type should be added?',choice,choice) IF ((choice < 1).OR.(choice > 16)) THEN WRITE (*,"(/' ERROR: Please select an integer from the list!')") CALL Press_Enter mt_flashby = .FALSE. GO TO 1000 ! mosaics menu ELSE mosaic_choice(mosaic_count) = choice ! for memory END IF ! illegal or legal choice SELECT CASE (choice) CASE (1) ! basemap (polygons type) 1010 temp_path_in = path_in CALL File_List( file_type = "*.dig", & & suggested_file = polygons_basemap_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file should be plotted?',polygons_basemap_file,polygons_basemap_file) polygons_basemap_pathfile = TRIM(temp_path_in)//TRIM(polygons_basemap_file) CALL Dig_Type (polygons_basemap_pathfile, 21, dig_is_lonlat, any_titles) CALL Prompt_for_Logical('Are these polygons written in (lon,lat) coordinates?',dig_is_lonlat,dig_is_lonlat) IF ((.NOT.xy_defined).AND.(.NOT.dig_is_lonlat)) THEN WRITE (*,"(' ERROR: Start FiniteMap over again and define the (x,y) coordinates.')") CALL Press_Enter STOP ' ' END IF IF (any_titles) THEN WRITE (*, "(/' Title lines were detected in this .dig file;')") CALL Prompt_for_Logical('do you want to include these titles in the plot?',plot_dig_titles,plot_dig_titles) IF (plot_dig_titles) THEN WRITE (*,"(' -------------------------------------------------')") WRITE (*,"(' Choose Alignment Method for Titles:')") WRITE (*,"(' 1: upright, at geometric center of polyline')") WRITE (*,"(' 2: parallel to first segment of polyline')") WRITE (*,"(' -------------------------------------------------')") 1011 CALL Prompt_for_Integer('Which alignment method?',dig_title_method,dig_title_method) IF ((dig_title_method < 1).OR.(dig_title_method > 2)) THEN WRITE (*,"(' ERROR: Illegal choice of method.')") mt_flashby = .FALSE. GO TO 1011 END IF ! bad choice END IF ! plot_dig_titles END IF ! any_titles WRITE (*,"(/' Working on basemap....')") ! gray rectangle for seas goes behind all continental polygons CALL Set_Fill_or_Pattern (.FALSE., 'gray______') CALL New_L12_Path (1, ai_window_x1_points, ai_window_y1_points) CALL Line_To_L12 (ai_window_x2_points, ai_window_y1_points) CALL Line_To_L12 (ai_window_x2_points, ai_window_y2_points) CALL Line_To_L12 (ai_window_x1_points, ai_window_y2_points) CALL Line_To_L12 (ai_window_x1_points, ai_window_y1_points) CALL End_L12_Path (close = .TRUE., stroke = .FALSE., & & fill = .TRUE.) ! continental polygons are foreground line, background fill CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) CALL Set_Stroke_Color (color_name = 'foreground') CALL Set_Fill_or_Pattern (.FALSE., 'background') polygons = .TRUE. IF (dig_is_lonlat) THEN CALL Plot_Dig (7, polygons_basemap_pathfile, polygons, 21, in_ok) ELSE CALL Plot_Dig (3, polygons_basemap_pathfile, polygons, 21, in_ok) END IF IF (.NOT.in_ok) THEN mt_flashby = .FALSE. GO TO 1010 END IF IF (any_titles .AND. plot_dig_titles) THEN CALL Set_Fill_or_Pattern (.FALSE., 'foreground') IF (dig_is_lonlat) THEN CALL Plot_Dig (7, polygons_basemap_pathfile, polygons, 21, in_ok, dig_title_method) ELSE CALL Plot_Dig (3, polygons_basemap_pathfile, polygons, 21, in_ok, dig_title_method) END IF END IF ! any_titles .AND. plot_dig_titles WRITE (*,"('+Working on basemap....DONE.')") ! possible plot titles: filename, and first 3 lines CALL Add_Title(polygons_basemap_file) OPEN (UNIT = 21, FILE = polygons_basemap_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') 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 Prompt_for_Logical('Do you want shaded relief?',shaded_relief,shaded_relief) IF (shaded_relief) THEN WRITE (*,"(/' -------------------------------------------------------')") WRITE (*,"( ' Source of Shaded Relief:')") WRITE (*,"( ' 1 = same dataset as that used to assign colors')") WRITE (*,"( ' 2 = a different dataset (usually a topographic DEM)')") WRITE (*,"( ' -------------------------------------------------------')") 1020 CALL Prompt_for_Integer('Bitmap shading mode (1 or 2)?',bitmap_shading_mode,bitmap_shading_mode) IF ((bitmap_shading_mode < 1).OR.(bitmap_shading_mode > 2)) THEN WRITE (*,"(' ERROR: Please select 1 or 2')") mt_flashby = .FALSE. GO TO 1020 END IF ELSE bitmap_shading_mode = 1 ! only one dataset END IF ELSE ! gray-scale image shaded_relief = .TRUE. bitmap_shading_mode = 1 ! only one dataset END IF 1021 temp_path_in = path_in CALL File_List( file_type = "*.grd", & & suggested_file = grd1_file, & & using_path = temp_path_in) IF (bitmap_shading_mode == 1) THEN CALL Prompt_for_String('Which file should be displayed?',grd1_file,grd1_file) grd2_file = grd1_file ELSE ! bitmap_shading_mode = 2; two .grd files CALL Prompt_for_String('Which file will determine the colors?',grd1_file,grd1_file) CALL Prompt_for_String('Which file will be overlain with shaded relief?',grd2_file,grd2_file) END IF grd1_pathfile = TRIM(temp_path_in)//TRIM(grd1_file) grd2_pathfile = TRIM(temp_path_in)//TRIM(grd2_file) OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (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.).AND.(ABS(grd1_lat_max)<91.) CALL Prompt_for_Logical('Is this grid defined in (lon,lat) coordinates?',grd1_lonlat,grd1_lonlat) IF ((.NOT.xy_defined).AND.(.NOT.grd1_lonlat)) THEN WRITE (*,"(' ERROR: Start FiniteMap over again and define the (x,y) coordinates.')") CALL Press_Enter STOP ' ' END IF OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios) problem = (ios /= 0) IF (grd1_lonlat) THEN READ (21, *, IOSTAT = ios) grd1_lon_min, grd1_d_lon, grd1_lon_max problem = problem .OR. (ios /= 0) IF (ABS(grd1_lon_max - grd1_lon_min - 360.0) < 0.01) THEN grd1_lon_range = 360.0 ELSE grd1_lon_range = Easting(grd1_lon_max - grd1_lon_min) END IF READ (21, *, IOSTAT = ios) grd1_lat_min, grd1_d_lat, grd1_lat_max problem = problem .OR. (ios /= 0) grd1_ncols = 1 + NINT((grd1_lon_max - grd1_lon_min) / grd1_d_lon) grd1_nrows = 1 + NINT((grd1_lat_max - grd1_lat_min) / grd1_d_lat) ELSE ! (x,y) format READ (21, *, IOSTAT = ios) grd1_x_min, grd1_d_x, grd1_x_max problem = problem .OR. (ios /= 0) grd1_x_min = grd1_x_min * mt_meters_per_user grd1_d_x = grd1_d_x * mt_meters_per_user grd1_x_max = grd1_x_max * mt_meters_per_user READ (21, *, IOSTAT = ios) grd1_y_min, grd1_d_y, grd1_y_max problem = problem .OR. (ios /= 0) grd1_y_min = grd1_y_min * mt_meters_per_user grd1_d_y = grd1_d_y * mt_meters_per_user grd1_y_max = grd1_y_max * mt_meters_per_user grd1_ncols = 1 + NINT((grd1_x_max - grd1_x_min) / grd1_d_x) grd1_nrows = 1 + NINT((grd1_y_max - grd1_y_min) / grd1_d_y) END IF problem = problem .OR. (grd1_nrows < 2) .OR. (grd1_ncols < 2) ALLOCATE ( grid1(grd1_nrows, grd1_ncols) ) READ (21, *, IOSTAT = ios) ((grid1(i,j), j = 1, grd1_ncols), i = 1, grd1_nrows) problem = problem .OR. (ios /= 0) CLOSE (21) IF (problem) THEN WRITE (*,"(' ERROR: ',A' defective in structure or truncated.')") TRIM(grd1_file) CALL Press_Enter DEALLOCATE ( grid1 ) mt_flashby = .FALSE. GO TO 1021 END IF CALL Add_Title(grd1_file) train_length = grd1_nrows * grd1_ncols ALLOCATE ( train(train_length) ) WRITE (*,"(/' Here is the distribution of VISIBLE values:' )") k = 0 ! will count visible (in map window) grid points DO irow = 1, grd1_nrows ! top to bottom DO jcol = 1, grd1_ncols ! left to right !decide whether this point is visible in the window IF (grd1_lonlat) THEN lon = grd1_lon_min + (jcol - 1) * grd1_d_lon lat = grd1_lat_max - (irow - 1) * grd1_d_lat CALL LonLat_2_Uvec (lon, lat, uvec) IF (mp_projection_number == 9) THEN ! Orthographic projection ! guard against looking at backside of Earth t = uvec(1) * mp_projpoint_uvec(1) + & & uvec(2) * mp_projpoint_uvec(2) + & & uvec(3) * mp_projpoint_uvec(3) IF (t <= 0.0) CYCLE END IF CALL Project (uvec = uvec, x = x_meters, y = y_meters) ! but no 'guide =' ELSE ! xy data grid x_meters = grd1_x_min + (jcol - 1) * grd1_d_x y_meters = grd1_y_max - (irow - 1) * grd1_d_y END IF ! lonlat, or simple xy CALL Meters_2_Points (x_meters,y_meters, x_points,y_points) c1 = In_Window (x_points, y_points) visible = (c1 == 'I').OR.(c1 == 'B') ! Inside, or Border IF (visible) THEN k = k + 1 train(k) = grid1(irow,jcol) END IF ! visible END DO ! columns of gridded data END DO ! rows of gridded data CALL Histogram (train, k, .FALSE., maximum, minimum) DEALLOCATE ( train ) IF (ai_using_color) THEN CALL Prompt_for_String('What are the units of these values?',TRIM(ADJUSTL(grid_units)),grid_units) 1022 WRITE (*,"(/' How shall the bitmap be colored?')") WRITE (*,"( ' mode 0: Munsell: smooth spectrum (but values of 0 not colored')") WRITE (*,"( ' mode 1: Munsell: smooth spectrum (with values of 0 colored normally)')") WRITE (*,"( ' mode 2: Kansas: 44-color scale of atlas-type colors')") WRITE (*,"( ' mode 3: UNAVCO: 20-color absolute scale (only for topography in m)')") WRITE (*,"( ' mode 4: AI: ',I2,'-color discrete scale, based on contour interval')") ai_spectrum_count WRITE (*,"( ' -------------------------------------------------------')") CALL Prompt_for_Integer('Which coloring mode?',bitmap_color_mode,bitmap_color_mode) IF ((bitmap_color_mode < 0).OR.(bitmap_color_mode > 4)) THEN WRITE (*,"(/' ERROR: Select mode index from list!' )") mt_flashby = .FALSE. GO TO 1022 END IF IF (bitmap_color_mode <= 2) THEN ! need to pin down ends of spectrum CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) 1023 IF (grid_lowblue) THEN CALL Prompt_for_Real('What (low?) value anchors the violet-blue end of the spectrum?',minimum,bitmap_color_lowvalue) CALL Prompt_for_Real('What (high?) value anchors the red-pink end of the spectrum?',maximum,bitmap_color_highvalue) ELSE CALL Prompt_for_Real('What (high?) value anchors the violet-blue end of the spectrum?',maximum,bitmap_color_lowvalue) CALL Prompt_for_Real('What (low?) value anchors the red-pink end of the spectrum?',minimum,bitmap_color_highvalue) END IF ! grid_lowblue, or not IF (bitmap_color_highvalue == bitmap_color_lowvalue) THEN WRITE (*,"(/' ERROR: Red value must differ from blue value!' )") mt_flashby = .FALSE. GO TO 1023 END IF ! bad range ELSE IF (bitmap_color_mode == 4) THEN IF (grid_interval == 0.0) THEN grid_interval = (maximum - minimum)/ai_spectrum_count grid_midvalue = (maximum + minimum)/2. END IF 1024 CALL Prompt_for_Real('What contour interval do you wish?',grid_interval,grid_interval) IF (grid_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") grid_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1024 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',grid_midvalue,grid_midvalue) CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) END IF ! bitmap_color_mode = 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 Prompt_for_Logical('Is this grid defined in (lon,lat) coordinates?',.TRUE.,grd2_lonlat) IF ((.NOT.xy_defined).AND.(.NOT.grd2_lonlat)) THEN WRITE (*,"(' ERROR: Start FiniteMap over again and define the (x,y) coordinates.')") CALL Press_Enter STOP ' ' END IF OPEN (UNIT = 21, FILE = grd2_pathfile, STATUS = 'OLD', IOSTAT = ios) problem = (ios /= 0) IF (grd2_lonlat) THEN READ (21, *, IOSTAT = ios) grd2_lon_min, grd2_d_lon, grd2_lon_max problem = problem .OR. (ios /= 0) IF (ABS(grd2_lon_max - grd2_lon_min - 360.0) < 0.01) THEN grd2_lon_range = 360.0 ELSE grd2_lon_range = Easting(grd2_lon_max - grd2_lon_min) END IF READ (21, *, IOSTAT = ios) grd2_lat_min, grd2_d_lat, grd2_lat_max problem = problem .OR. (ios /= 0) grd2_ncols = 1 + NINT((grd2_lon_max - grd2_lon_min) / grd2_d_lon) grd2_nrows = 1 + NINT((grd2_lat_max - grd2_lat_min) / grd2_d_lat) ELSE ! (x,y) format READ (21, *, IOSTAT = ios) grd2_x_min, grd2_d_x, grd2_x_max problem = problem .OR. (ios /= 0) grd2_x_min = grd2_x_min * mt_meters_per_user grd2_d_x = grd2_d_x * mt_meters_per_user grd2_x_max = grd2_x_max * mt_meters_per_user READ (21, *, IOSTAT = ios) grd2_y_min, grd2_d_y, grd2_y_max problem = problem .OR. (ios /= 0) grd2_y_min = grd2_y_min * mt_meters_per_user grd2_d_y = grd2_d_y * mt_meters_per_user grd2_y_max = grd2_y_max * mt_meters_per_user grd2_ncols = 1 + NINT((grd2_x_max - grd2_x_min) / grd2_d_x) grd2_nrows = 1 + NINT((grd2_y_max - grd2_y_min) / grd2_d_y) END IF problem = problem .OR. (grd2_nrows < 2) .OR. (grd2_ncols < 2) train_length = grd2_nrows * grd2_ncols ALLOCATE ( grid2(grd2_nrows, grd2_ncols) ) READ (21, *, IOSTAT = ios) ((grid2(i,j), j = 1, grd2_ncols), i = 1, grd2_nrows) problem = problem .OR. (ios /= 0) CLOSE (21) IF (problem) THEN WRITE (*,"(' ERROR: ',A' defective in structure or truncated.')") TRIM(grd2_file) CALL Press_Enter DEALLOCATE ( grid2 ) mt_flashby = .FALSE. GO TO 1021 END IF ! problem with grd2 END IF ! bitmap_shading_mode 1 or 2 CALL Prompt_for_Real('Relative intensity of oblique lighting?',intensity,intensity) ! find RMS E-W slope IF (grd2_lonlat) THEN grd2_d_EW = grd2_d_lon ELSE grd2_d_EW = grd2_d_x END IF sum = 0.0 DO irow = 1, grd2_nrows DO jcol = 2, grd2_ncols sum = sum + ((grid2(irow,jcol) - grid2(irow,jcol-1)) / grd2_d_EW)**2 END DO ! jcol END DO ! irow RMS_slope = SQRT(sum / train_length) IF (RMS_slope == 0.0) RMS_slope = 1.0 ! prevent /0.0 END IF ! shaded_relief bitmap_width = ai_window_x2_points - ai_window_x1_points ! suggest one column/point bitmap_height = ai_window_y2_points - ai_window_y1_points ! suggest one row/point 1025 CALL Prompt_for_Integer('How many columns of pixels in bitmap?',bitmap_width,bitmap_width) IF (bitmap_width < 2) THEN WRITE (*,"(' ERROR: Bitmap_width must be >= 2')") mt_flashby = .FALSE. GO TO 1025 END IF 1026 CALL Prompt_for_Integer('How many rows of pixels in bitmap?',bitmap_height,bitmap_height) IF (bitmap_height < 2) THEN WRITE (*,"(' ERROR: Bitmap_height must be >= 2')") mt_flashby = .FALSE. GO TO 1026 END IF WRITE (*,"(/' Working on bitmap from gridded dataset(s)....')") ALLOCATE ( bitmap(bitmap_height,bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) !Get "value" (basis for color of pixel) from grid1: !Note: Even if .NOT.ai_using_color, we will need i1, i2, j1, j2, etc. IF (bitmap_shading_mode == 1) IF (ai_using_color.OR.(bitmap_shading_mode == 1)) THEN IF (grd1_lonlat) THEN ! must undo map projection CALL Reject (x_meters,y_meters, success, uvec) IF (success) THEN ! rejection worked CALL Uvec_2_LonLat (uvec, lon, lat) !define grd1_success as falling within grid1 grd1_success = (lat >= grd1_lat_min).AND. & & (lat <= grd1_lat_max).AND. & & (Easting(lon - grd1_lon_min) <= grd1_lon_range) !note: insensitive to longitude cycle IF (grd1_success) THEN i1 = 1 + (grd1_lat_max - lat) / grd1_d_lat i1 = MAX(1,MIN(i1,grd1_nrows-1)) i2 = i1 + 1 fy2 = ((grd1_lat_max - lat) / grd1_d_lat) - i1 + 1.0 fy1 = 1.00 - fy2 j1 = 1 + Easting(lon - grd1_lon_min) / grd1_d_lon j1 = MAX(1,MIN(j1,grd1_ncols-1)) j2 = j1 + 1 fx2 = (Easting(lon - grd1_lon_min) / grd1_d_lon) - j1 + 1.0 fx1 = 1.00 - fx2 above = fx1 * grid1(i1,j1) + fx2 * grid1(i1,j2) below = fx1 * grid1(i2,j1) + fx2 * grid1(i2,j2) value = fy1 * above + fy2 * below END IF ! point inside lon/lat grid1 ELSE ! rejection failed (i.e., back side of Earth in Orthographic projection) grd1_success = .FALSE. END IF ! rejection worked or failed ELSE ! gridded data is on a x,y grid1 already grd1_success = (x_meters >= grd1_x_min).AND. & & (x_meters <= grd1_x_max).AND. & & (y_meters >= grd1_y_min).AND. & & (y_meters <= grd1_y_max) IF (grd1_success) THEN i1 = 1 + (grd1_y_max - y_meters) / grd1_d_y i1 = MAX(1,MIN(i1,grd1_nrows-1)) i2 = i1 + 1 fy2 = ((grd1_y_max - y_meters) / grd1_d_y) - i1 + 1.0 fy1 = 1.00 - fy2 j1 = 1 + (x_meters - grd1_x_min) / grd1_d_x j1 = MAX(1,MIN(j1,grd1_ncols-1)) j2 = j1 + 1 fx2 = ((x_meters - grd1_x_min) / grd1_d_x) - j1 + 1.0 fx1 = 1.00 - fx2 above = fx1 * grid1(i1,j1) + fx2 * grid1(i1,j2) below = fx1 * grid1(i2,j1) + fx2 * grid1(i2,j2) value = fy1 * above + fy2 * below END IF ! point within x/y grid1 END IF ! need to undo map projection or not for grid1 ELSE ! neither ai_using_color, nor (bitmap_shading_mode == 1) grd1_success = .FALSE. value = 0.0 ! should not be used END IF ! finding i1, i2, j1, j2,,, value in grid1, or not !Finished getting "value" and i1, i2, j1, j2, ... (if possible) !Get "brightness" (basis for brightness of pixel) from grid2??? IF (shaded_relief) THEN IF (bitmap_shading_mode == 1) THEN grd2_success = grd1_success !and fx2, fy2, i1, i2, ... will be reused ELSE ! must find place in grid2! !must recompute fx1, fx2, fy1, fy2, i1, i2, j1, j2 for different grid IF (grd2_lonlat) THEN IF (success) THEN ! lon, lat still valid !define grd2_success as falling within grid2 grd2_success = (lat >= grd2_lat_min).AND. & & (lat <= grd2_lat_max).AND. & & (Easting(lon - grd2_lon_min) <= grd2_lon_range) !note: insensitive to longitude cycle IF (grd2_success) THEN i1 = 1 + (grd2_lat_max - lat) / grd2_d_lat i1 = MAX(1,MIN(i1,grd2_nrows-1)) i2 = i1 + 1 fy2 = ((grd2_lat_max - lat) / grd2_d_lat) - i1 + 1.0 fy1 = 1.00 - fy2 j1 = 1 + Easting(lon - grd2_lon_min) / grd2_d_lon j1 = MAX(1,MIN(j1,grd2_ncols-1)) j2 = j1 + 1 fx2 = (Easting(lon - grd2_lon_min) / grd2_d_lon) - j1 + 1.0 fx1 = 1.00 - fx2 END IF ! point in grid2 ELSE ! Rejection failed; lon, lat undefined grd2_success = .FALSE. END IF ! successful Rejection or not ELSE ! .NOT.grd2_lonlat; grid2 is x,y grd2_success = (x_meters >= grd2_x_min).AND. & & (x_meters <= grd2_x_max).AND. & & (y_meters >= grd2_y_min).AND. & & (y_meters <= grd2_y_max) IF (grd2_success) THEN i1 = 1 + (grd2_y_max - y_meters) / grd2_d_y i1 = MAX(1,MIN(i1,grd2_nrows-1)) i2 = i1 + 1 fy2 = ((grd2_y_max - y_meters) / grd2_d_y) - i1 + 1.0 fy1 = 1.00 - fy2 j1 = 1 + (x_meters - grd2_x_min) / grd2_d_x j1 = MAX(1,MIN(j1,grd2_ncols-1)) j2 = j1 + 1 fx2 = ((x_meters - grd2_x_min) / grd2_d_x) - j1 + 1.0 fx1 = 1.00 - fx2 END IF ! point within x/y grid2 END IF ! grd2_lonlat, or not END IF ! shaded relief grid2 has different framework IF (grd2_success) THEN ! can compute brightness !Compute E-W slope in a way that gives a !result that is piecewise-linear in the E-W direction: fout = ABS(fx2 - 0.5) ! fraction for adjacent cell fin = 1.00 - fout ! fraction for the cell we're in inner = (grid2(i1,j2) - grid2(i1,j1)) / grd2_d_EW IF (fx2 > 0.5) THEN IF (j2 < grd2_ncols) THEN ! normal case outer = (grid2(i1,j2+1) - grid2(i1,j1+1)) / grd2_d_EW ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case outer = (grid2(i1,j2-1) - grid2(i1,j1-1)) / grd2_d_EW ELSE ! at left edge of grid outer = inner END IF END IF above = fin * inner + fout * outer !Repeat for row below the point: inner = (grid2(i2,j2) - grid2(i2,j1)) / grd2_d_EW IF (fx2 > 0.5) THEN IF (j2 < grd2_ncols) THEN ! normal case outer = (grid2(i2,j2+1) - grid2(i2,j1+1)) / grd2_d_EW ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case outer = (grid2(i2,j2-1) - grid2(i2,j1-1)) / grd2_d_EW ELSE ! at left edge of grid outer = inner END IF END IF below = fin * inner + fout * outer !Line below makes slope piecewise-linear in N-S direction: slope = fy1 * above + fy2 * below brightness = 1.0 + 0.5 * intensity * slope / RMS_slope brightness = MAX(0.0, MIN(2.0, brightness)) ELSE ! .NOT. dot2_success; so, point was not in grid2 brightness = 1.0 END IF ! point was in grid2 or not ELSE ! no shaded relief wanted brightness = 1.0 END IF ! shaded relief, or not !End of lookup (value and brightness); now use them! IF (ai_using_color.AND.grd1_success) THEN ! have "value" IF (bitmap_color_mode <= 1) THEN ! Munsell: smooth spectrum IF ((bitmap_color_mode == 0).AND.(value == 0.0)) THEN c3 = CHAR(ai_background%rgb(1))//CHAR(ai_background%rgb(2))//CHAR(ai_background%rgb(3)) ELSE ! normal coloring t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = RGB_Munsell(warmth = t, brightness = brightness) END IF ELSE IF (bitmap_color_mode == 2) THEN ! Kansas: 44-color atlas-type scale t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = RGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = RGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = RGB_AI(value = value, contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, low_is_blue = grid_lowblue, & & brightness = brightness) END IF ! bitmap_color_mode selection bitmap(irow,jcol) = c3 ELSE IF (grd2_success) THEN ! b/w; gray depends only on slope k = brightness * 127.5 k = MAX(0,MIN(255,k)) bitmap(irow,jcol) = CHAR(k)//CHAR(k)//CHAR(k) ELSE ! fill in with background IF (ai_black_background) THEN ! slide copy bitmap(irow,jcol) = CHAR(0)//CHAR(0)//CHAR(0) ELSE ! white background (paper print) bitmap(irow,jcol) = CHAR(255)//CHAR(255)//CHAR(255) END IF END IF ! color, grey-scale, or background END DO ! jcol, left to right WRITE (*,"('+Working on bitmap from gridded dataset(s)....',I6,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Working on bitmap from gridded dataset(s)....Writing to .ai ')") CALL Bitmap_on_L1 (bitmap, ai_window_x1_points, ai_window_x2_points, & & ai_window_y1_points, ai_window_y2_points) IF (ai_using_color) THEN CALL Chooser(bottom, right) IF (bottom) THEN CALL Spectrum_in_BottomLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Spectrum_in_RightLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! ai_using_color --> want spectrum in legend WRITE (*,"('+Working on bitmap from gridded dataset(s)....DONE. ')") CALL BEEPQQ (frequency = 440, duration = 250) ! deallocate by LIFO method: DEALLOCATE ( bitmap ) IF (ALLOCATED(grid2)) DEALLOCATE ( grid2 ) DEALLOCATE ( grid1 ) ! end of colored/shaded bitmap from gridded dataset(s) CASE (3) ! contour map from gridded data 1030 temp_path_in = path_in CALL File_List( file_type = "*.grd", & & suggested_file = grd1_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file should be contoured?',grd1_file,grd1_file) grd1_pathfile = TRIM(temp_path_in)//TRIM(grd1_file) OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') 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.).AND.(ABS(grd1_lat_max)<91.) CALL Prompt_for_Logical('Is this grid defined in (lon,lat) coordinates?',grd1_lonlat,grd1_lonlat) IF ((.NOT.xy_defined).AND.(.NOT.grd1_lonlat)) THEN WRITE (*,"(' ERROR: Start FiniteMap over again and define the (x,y) coordinates.')") CALL Press_Enter STOP ' ' END IF OPEN (UNIT = 21, FILE = grd1_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') problem = (ios /= 0) IF (grd1_lonlat) THEN READ (21, *, IOSTAT = ios) grd1_lon_min, grd1_d_lon, grd1_lon_max problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) grd1_lat_min, grd1_d_lat, grd1_lat_max problem = problem .OR. (ios /= 0) grd1_ncols = 1 + NINT((grd1_lon_max - grd1_lon_min) / grd1_d_lon) grd1_nrows = 1 + NINT((grd1_lat_max - grd1_lat_min) / grd1_d_lat) ELSE ! (x,y) format READ (21, *, IOSTAT = ios) grd1_x_min, grd1_d_x, grd1_x_max problem = problem .OR. (ios /= 0) READ (21, *, IOSTAT = ios) grd1_y_min, grd1_d_y, grd1_y_max problem = problem .OR. (ios /= 0) grd1_ncols = 1 + NINT((grd1_x_max - grd1_x_min) / grd1_d_x) grd1_nrows = 1 + NINT((grd1_y_max - grd1_y_min) / grd1_d_y) END IF problem = problem .OR. (grd1_nrows < 2) .OR. (grd1_ncols < 2) ALLOCATE ( grid1(grd1_nrows, grd1_ncols) ) train_length = grd1_nrows * grd1_ncols ALLOCATE ( train(train_length) ) READ (21, *, IOSTAT = ios) ((grid1(i,j), j = 1, grd1_ncols), i = 1, grd1_nrows) problem = problem .OR. (ios /= 0) CLOSE (21) IF (problem) THEN WRITE (*,"(' ERROR: File defective in structure or truncated.')") CALL Press_Enter DEALLOCATE (grid1, train) mt_flashby = .FALSE. GO TO 1030 END IF CALL Add_Title(grd1_file) WRITE (*,"(/' Here is the distribution of gridded values:' )") k = 0 DO i = 1, grd1_nrows DO j = 1, grd1_ncols k = k + 1 train(k) = grid1(i,j) END DO END DO CALL Histogram (train, train_length, .FALSE., maximum, minimum) CALL Prompt_for_String('What are the units of these values?',TRIM(ADJUSTL(grid_units)),grid_units) IF (grid_interval == 0.0) THEN grid_interval = (maximum - minimum)/ai_spectrum_count grid_midvalue = (maximum + minimum)/2. END IF 1031 CALL Prompt_for_Real('What contour interval do you wish?',grid_interval,grid_interval) IF (grid_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") grid_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1031 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',grid_midvalue,grid_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',grid_lowblue,grid_lowblue) ELSE CALL Prompt_for_Logical('Should low values be shaded darkly (versus lightly)?',grid_lowblue,grid_lowblue) END IF WRITE (*,"(/' If the data is elevation/bathymetry, and you plan to plot the coastline')") WRITE (*,"(' as a separate map element, the zero contour may be redundant (& less accurate)!')") CALL Prompt_for_Logical('Should the 0 contour line be omitted?',skip_0_contour,skip_0_contour) WRITE (*,"(/' Working on gridded data....')") DO group = 1, 2 IF (group == 2) CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) !note that contouring routine will set line colors CALL Begin_Group IF (grd1_lonlat) THEN DO i = 1, grd1_nrows-1 DO j = 1, grd1_ncols-1 ! NW triangle: lon1 = grd1_lon_min + (j-1)*grd1_d_lon lat1 = grd1_lat_max - (i-1)*grd1_d_lat CALL LonLat_2_Uvec(lon1, lat1, uvec1) lon2 = lon1 lat2 = lat1 - grd1_d_lat CALL LonLat_2_Uvec(lon2, lat2, uvec2) lon3 = lon2 + grd1_d_lon lat3 = lat1 CALL LonLat_2_Uvec(lon3, lat3, uvec3) !Skip triangles with two nodes at +90N, !since they have zero area: IF ((lat1 < 90.0).OR.(lat3 < 90.0)) THEN CALL Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = grid1(i,j), & & f2 = grid1(i+1,j), & & f3 = grid1(i,j+1), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) END IF ! area is positive ! SE triangle; defined in terms of NW-triangle values: lon1 = lon3 lat1 = lat2 t = lat2 lat2 = lat3 lat3 = t t = lon2 lon2 = lon3 lon3 = t uvec(1:3) = uvec2(1:3) uvec2(1:3) = uvec3(1:3) uvec3(1:3) = uvec(1:3) CALL LonLat_2_Uvec(lon1, lat1, uvec1) !Skip triangles with two nodes at -90N, !since they have zero area: IF ((lat1 > -90.0).OR.(lat3 > -90.0)) THEN CALL Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = grid1(i+1,j+1), & & f2 = grid1(i,j+1), & & f3 = grid1(i+1,j), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) END IF ! area is positive END DO ! j=1, grd1_ncols-1 END DO ! i = 1, grd1_nrows-1 ELSE ! data are in (x,y) format t = mt_meters_per_user ! (abbreviation) DO i = 1, grd1_nrows-1 DO j = 1, grd1_ncols-1 !upper left triangle CALL Contour_3Node_Scalar_in_Plane & &(x1 = t*(grd1_x_min+grd1_d_x*(j-1)), & & y1 = t*(grd1_y_max-grd1_d_y*(i-1)), & & x2 = t*(grd1_x_min+grd1_d_x*(j-1)), & & y2 = t*(grd1_y_max-grd1_d_y*(i)), & & x3 = t*(grd1_x_min+grd1_d_x*(j)), & & y3 = t*(grd1_y_max-grd1_d_y*(i-1)), & & f1 = grid1(i,j), & & f2 = grid1(i+1,j), & & f3 = grid1(i,j+1), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) ! lower right triangle CALL Contour_3Node_Scalar_in_Plane & &(x1 = t*(grd1_x_min+grd1_d_x*(j)), & & y1 = t*(grd1_y_max-grd1_d_y*(i)), & & x2 = t*(grd1_x_min+grd1_d_x*(j)), & & y2 = t*(grd1_y_max-grd1_d_y*(i-1)), & & x3 = t*(grd1_x_min+grd1_d_x*(j-1)), & & y3 = t*(grd1_y_max-grd1_d_y*(i)), & & f1 = grid1(i+1,j+1), & & f2 = grid1(i,j+1), & & f3 = grid1(i+1,j), & & low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, & & low_is_blue = grid_lowblue, group = group, & & skip_0_contour = skip_0_contour) END DO ! j=1, ncols-1 END DO ! i = 1, nrows-1 END IF ! lonlat, or (x,y) CALL End_Group ! END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value =grid_midvalue, & & low_is_blue = grid_lowblue, & & units = ADJUSTL(grid_units)) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Bar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = grid_interval, & & midspectrum_value =grid_midvalue, & & low_is_blue = grid_lowblue, & & units = ADJUSTL(grid_units)) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on gridded data....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( grid1 ) DEALLOCATE ( train ) ! end of contour map from gridded data CASE (4) ! discontinuous scalar (one value per element) CALL Group_or_Bitmap (latter_mosaic, element_scalar_method, bitmap_height, bitmap_width) IF (.NOT.got_FEP) CALL Get_FEP 1040 temp_path_in = path_in CALL File_List( file_type = "*.feg", & & suggested_file = element_scalar_feg_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file defines the elements?',element_scalar_feg_file,element_scalar_feg_file) element_scalar_feg_pathfile = TRIM(temp_path_in)//TRIM(element_scalar_feg_file) OPEN (UNIT = 21, FILE = element_scalar_feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') !Warning: PAD = "YES" will not be sufficient to zero out the element_scalar(i) if it is !missing, because the READ is unformatted (*). All values must be present in the element- !definition section of the input .feg file, even if 0.0. problem = (ios /= 0) READ (21, *, IOSTAT = ios) ! title line problem = problem .OR. (ios /= 0) 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") READ (21, *, IOSTAT = ios) numnod problem = problem .OR. (ios /= 0) ALLOCATE ( node_uvec(3,numnod) ) DO i = 1, numnod READ (21, *, IOSTAT = ios) j, lon, lat problem = problem .OR. (ios /= 0) .OR. (j /= i) CALL LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( element_scalar(numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i), & & element_scalar(i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel END SELECT IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. GO TO 1040 END IF CLOSE (21) IF ((FEP == "FAULTS").OR.(FEP == "PLATES")) CALL Replace_Zeros() CALL Add_Title(element_scalar_feg_file) WRITE (*,"(/' Here is the distribution of non-zero element values:' )") CALL Histogram (element_scalar, numel, .TRUE., maximum, minimum) CALL Prompt_for_String('What are the units of these numbers?',element_scalar_units,element_scalar_units) IF (element_scalar_method == 1) THEN ! group of colored/shaded polygons IF (element_scalar_interval == 0.0) THEN element_scalar_interval = (maximum - minimum)/ai_spectrum_count element_scalar_midvalue = (maximum + minimum)/2. END IF 1041 CALL Prompt_for_Real('What contour interval do you wish?',element_scalar_interval,element_scalar_interval) IF (element_scalar_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") element_scalar_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1041 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',element_scalar_midvalue,element_scalar_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',element_scalar_lowblue,element_scalar_lowblue) ELSE CALL Prompt_for_Logical('Should low values be shaded darkly (versus lightly)?',element_scalar_lowblue,element_scalar_lowblue) END IF WRITE (*,*) WRITE (*,"(' Non-zero values that lie exactly on a contour')") WRITE (*,"(' (color boundary) are always nudged toward zero')") WRITE (*,"(' in order to assign a color to them.')") WRITE (*,"(' -----------------------------------------------')") WRITE (*,"(' What shall be done with zero values?')") WRITE (*,"(' mode 1 :: round up to the 1st positive color')") WRITE (*,"(' mode 0 :: do not plot this triangle')") WRITE (*,"(' mode -1 :: round down to the 1st negative color')") WRITE (*,"(' ------------------------------------------------')") 1042 CALL Prompt_for_Integer('Which mode do you want?',element_scalar_zeromode,element_scalar_zeromode) IF ((element_scalar_zeromode < -1).OR.(element_scalar_zeromode > 1)) THEN WRITE (*,"(' ERROR: Select mode in legal range.')") element_scalar_zeromode = 0 mt_flashby = .FALSE. GO TO 1042 END IF WRITE (*,"(/' Working on discontinuous scalar (one value per element)....')") CALL Begin_Group ! of colored/shaded triangles (there won't be any contours) DO i = 1, numel t = element_scalar(i) IF (t == 0.0) THEN SELECT CASE (element_scalar_zeromode) CASE (1) ! round up t = 0.001 * element_scalar_interval plot_this = .TRUE. CASE (0) ! do not plot plot_this = .FALSE. CASE (-1) ! round down t = -0.001 * element_scalar_interval plot_this = .TRUE. END SELECT ELSE ! non-zero value plot_this = .TRUE. IF (MOD(t, element_scalar_interval) == 0.0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0) THEN t = t - 0.001* element_scalar_interval ELSE ! t < 0.0 t = t + 0.001 * element_scalar_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) END IF ! zero or non-zero value IF (plot_this) THEN 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 Contour_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 Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = element_scalar_interval, & & midspectrum_value = element_scalar_midvalue, & & low_is_blue = element_scalar_lowblue, group = 1) END SELECT END IF ! plot_this END DO ! i = 1, numel CALL End_Group ! of colored/shaded triangles CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = element_scalar_interval, & & midspectrum_value =element_scalar_midvalue, & & low_is_blue = element_scalar_lowblue, & & units = element_scalar_units) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Bar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = element_scalar_interval, & & midspectrum_value =element_scalar_midvalue, & & low_is_blue = element_scalar_lowblue, & & units = element_scalar_units) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on discontinuous scalar (one value per element)....DONE.')") ELSE ! element_scalar_method == 2 SELECT CASE (FEP) CASE ("FAULTS", "PLATES") ALLOCATE ( center(2, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL Learn_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 Learn_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.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) SELECT CASE (FEP) CASE ("FAULTS", "PLATES") CALL LookUp (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 Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) 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 Bumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & element_scalar_units, minimum, maximum, & & bitmap_color_mode, element_scalar_interval, element_scalar_midvalue, element_scalar_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order 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 Spectrum_in_BottomLegend (minimum, maximum, element_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & element_scalar_interval, element_scalar_midvalue, element_scalar_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Spectrum_in_RightLegend (minimum, maximum, element_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & element_scalar_interval, element_scalar_midvalue, element_scalar_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! element_scalar_method = 1 or 2 SELECT CASE (FEP) CASE ("FAULTS", "PLATES") DEALLOCATE ( fazim ) DEALLOCATE ( nodef ) DEALLOCATE ( element_scalar, & & nodes ) ! in LIFO order DEALLOCATE ( xy_node_meters ) CASE ("SHELLS") DEALLOCATE ( 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 Group_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 Prompt_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.0 cooling_curvature_Cpm2 = 0.0 READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters END IF OrbData5 = OrbData5 .OR. (density_anomaly_kgpm3 /= 0.0) .OR. (cooling_curvature_Cpm2 /= 0.0) 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 Prompt_for_Integer('Which do you want?',node_scalar_choice,node_scalar_choice) IF ((node_scalar_choice < 1).OR.(node_scalar_choice > node_scalar_limit)) THEN mt_flashby = .FALSE. GO TO 1051 END IF IF (node_scalar_choice == 1) THEN CALL Add_Title('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 LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel END SELECT IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_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 Prompt_for_String('What are the units of these numbers?',node_scalar_units,node_scalar_units) IF (node_scalar_method == 1) THEN ! group of colored/shaded polygons IF (node_scalar_interval == 0.0) THEN node_scalar_interval = (maximum - minimum)/ai_spectrum_count node_scalar_midvalue = (maximum + minimum)/2. END IF 1052 CALL Prompt_for_Real('What contour interval do you wish?',node_scalar_interval,node_scalar_interval) IF (node_scalar_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") node_scalar_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1052 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',node_scalar_midvalue,node_scalar_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',node_scalar_lowblue,node_scalar_lowblue) ELSE CALL Prompt_for_Logical('Should low values be shaded darkly (versus lightly)?',node_scalar_lowblue,node_scalar_lowblue) END IF WRITE (*,"(/' Working on nodal data....')") DO group = 1, 2 CALL Begin_Group IF (group == 2) CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) !note that contouring routine will set line colors DO i = 1, numel 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 Contour_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 Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = node_scalar(nodes(1,i)), & & f2 = node_scalar(nodes(2,i)), & & f3 = node_scalar(nodes(3,i)), & & low_value = minimum, high_value = maximum, & & contour_interval = node_scalar_interval, & & midspectrum_value = node_scalar_midvalue, & & low_is_blue = node_scalar_lowblue, group = group) END SELECT END DO ! i = 1, numel CALL End_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = node_scalar_interval, & & midspectrum_value =node_scalar_midvalue, & & low_is_blue = node_scalar_lowblue, & & units = node_scalar_units) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Bar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = node_scalar_interval, & & midspectrum_value =node_scalar_midvalue, & & low_is_blue = node_scalar_lowblue, & & units = node_scalar_units) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on continuous scalar (one value per node)....DONE.')") ELSE ! node_scalar_method == 2 SELECT CASE (FEP) CASE ("FAULTS", "PLATES") ALLOCATE ( center(2, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL Learn_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 Learn_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.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) SELECT CASE (FEP) CASE ("FAULTS", "PLATES") CALL LookUp (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 Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) END SELECT IF (success) THEN SELECT CASE (FEP) CASE ("FAULTS", "PLATES") t = node_scalar(nodes(1,iele)) * (-s1 + 2. * s1**2) + & & node_scalar(nodes(2,iele)) * (-s2 + 2. * s2**2) + & & node_scalar(nodes(3,iele)) * (-s3 + 2. * s3**2) + & & node_scalar(nodes(4,iele)) * (4. * s1 * s2) + & & node_scalar(nodes(5,iele)) * (4. * s2 * s3) + & & node_scalar(nodes(6,iele)) * (4. * 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 Bumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & node_scalar_units, minimum, maximum, & & bitmap_color_mode, node_scalar_interval, node_scalar_midvalue, node_scalar_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order 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 Spectrum_in_BottomLegend (minimum, maximum, node_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & node_scalar_interval, node_scalar_midvalue, node_scalar_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Spectrum_in_RightLegend (minimum, maximum, node_scalar_units, bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & node_scalar_interval, node_scalar_midvalue, node_scalar_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! node_scalar_method = 1 or 2 SELECT CASE (FEP) CASE ("FAULTS", "PLATES") DEALLOCATE ( fazim ) DEALLOCATE ( nodef ) DEALLOCATE ( nodes ) ! in LIFO order DEALLOCATE ( node_scalar ) DEALLOCATE ( xy_node_meters ) CASE ("SHELLS") DEALLOCATE ( nodes ) ! in LIFO order 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 Group_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 Group_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 1070 CALL File_List( file_type = "i*.in", & & suggested_file = parameter_file, & & using_path = temp_path_in) CALL Prompt_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 & acreep, alphat, bcreep, biot , & ! outputs... & byerly, ccreep, cfric , conduc, & & dcreep, ecreep, everyp, ffric , & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, 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 Prompt_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.0 t6 = 0.0 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.0) .OR. (t6 /= 0.0) END IF CALL LonLat_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.5 * radio(1) / conduc(1)) * t3**2 & & - (0.5 * t6) * t3**2 & & - 273.0 ELSE IF (choice == 7) THEN ! Tbase node_scalar(i) = tsurf & & + (t2 / conduc(1)) * t3 & & - (0.5 * radio(1) / conduc(1)) * t3**2 & & + ((t2 - (t3 * radio(1))) / conduc(2)) * t4 & & - (0.5 * radio(2) / conduc(2)) * t4**2 & & - (0.5 * t6) * (t3 + t4)**2 & & - 273.0 END IF END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. 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.0)) THEN TMoho_C_interval = (maximum - minimum)/ai_spectrum_count TMoho_C_midvalue = (maximum + minimum)/2. ELSE IF ((choice == 7).AND.(Tbase_C_interval == 0.0)) THEN Tbase_C_interval = (maximum - minimum)/ai_spectrum_count Tbase_C_midvalue = (maximum + minimum)/2. END IF IF (choice == 6) THEN ! TMoho_C 1062 CALL Prompt_for_Real('What contour interval do you wish?',Tmoho_C_interval,TMoho_C_interval) IF (TMoho_C_interval <= 0.0) 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 Prompt_for_Real('What value should fall at mid-spectrum?',TMoho_C_midvalue,TMoho_C_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',Tmoho_C_lowblue,TMoho_C_lowblue) ELSE CALL Prompt_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 Prompt_for_Real('What contour interval do you wish?',Tbase_C_interval,Tbase_C_interval) IF (Tbase_C_interval <= 0.0) 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 Prompt_for_Real('What value should fall at mid-spectrum?',Tbase_C_midvalue,Tbase_C_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',Tbase_C_lowblue,Tbase_C_lowblue) ELSE CALL Prompt_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 Begin_Group IF (group == 2) CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) !note that contouring routine will set line colors DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) IF (choice == 6) THEN ! TMoho_C CALL Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = node_scalar(nodes(1,i)), & & f2 = node_scalar(nodes(2,i)), & & f3 = node_scalar(nodes(3,i)), & & low_value = minimum, high_value = maximum, & & contour_interval = TMoho_C_interval, & & midspectrum_value = TMoho_C_midvalue, & & low_is_blue = TMoho_C_lowblue, group = group) ELSE IF (choice == 7) THEN ! Tbase_C CALL Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = node_scalar(nodes(1,i)), & & f2 = node_scalar(nodes(2,i)), & & f3 = node_scalar(nodes(3,i)), & & low_value = minimum, high_value = maximum, & & contour_interval = Tbase_C_interval, & & midspectrum_value = Tbase_C_midvalue, & & low_is_blue = Tbase_C_lowblue, group = group) END IF END DO ! i = 1, numel CALL End_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN IF (choice == 6) THEN ! TMoho_C CALL Bar_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 Bar_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 Bar_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 Bar_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 Learn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = node_scalar(nodes(1,iele)) * s1 + & & node_scalar(nodes(2,iele)) * s2 + & & node_scalar(nodes(3,iele)) * s3 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 Bumpy_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 Bumpy_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 Spectrum_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 Spectrum_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 Spectrum_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 Spectrum_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 ( nodes, & & node_scalar, & & node_uvec) ! common arrays, in LIFO order ! 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 Group_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 Prompt_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 & acreep, alphat, bcreep, biot , & ! outputs... & byerly, ccreep, cfric , conduc, & & dcreep, ecreep, everyp, ffric , & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, 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 Prompt_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.0 cooling_curvature_Cpm2 = 0.0 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 LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) geoth1 = tsurf geoth2 = heatflow / conduc(1) geoth3 = -0.5 * (radio(1) / conduc(1)) - 0.5 * cooling_curvature_Cpm2 geoth4 = 0.0 geoth5 = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 geoth6 = ((heatflow - crust_meters * radio(1)) / conduc(2)) - cooling_curvature_Cpm2 * crust_meters geoth7 = -0.5 * (radio(2) / conduc(2)) - 0.5 * cooling_curvature_Cpm2 geoth8 = 0.0 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.0E6 ! in MPa of pressure END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. 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.0) THEN pressure_MPa_interval = (maximum - minimum)/ai_spectrum_count END IF 1082 CALL Prompt_for_Real('What contour interval do you wish?',pressure_MPa_interval,pressure_MPa_interval) IF (pressure_MPa_interval <= 0.0) 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 Prompt_for_Real('What value should fall at mid-spectrum?',pressure_MPa_midvalue,pressure_MPa_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',pressure_MPa_lowblue,pressure_MPa_lowblue) ELSE CALL Prompt_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 Begin_Group IF (group == 2) CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) !note that contouring routine will set line colors DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) CALL Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = node_scalar(nodes(1,i)), & & f2 = node_scalar(nodes(2,i)), & & f3 = node_scalar(nodes(3,i)), & & low_value = minimum, high_value = maximum, & & contour_interval = pressure_MPa_interval, & & midspectrum_value = pressure_MPa_midvalue, & & low_is_blue = pressure_MPa_lowblue, group = group) END DO ! i = 1, numel CALL End_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = 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 Bar_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 Learn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = node_scalar(nodes(1,iele)) * s1 + & & node_scalar(nodes(2,iele)) * s2 + & & node_scalar(nodes(3,iele)) * s3 bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL Bumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & '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 Spectrum_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 Spectrum_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 ( nodes, & & node_scalar, & & node_uvec) ! common arrays, in LIFO order ! 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 Group_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 Prompt_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 Press_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 ( node_has_area(numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) CALL LonLat_2_ThetaPhi (lon, lat, theta, phi) xnode(i) = theta ynode(i) = phi END DO ! i = 1, numnod READ (21,*) numel ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21,*) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21,*) nfl ALLOCATE ( nodef(4,nfl) ) DO i = 1, nfl READ (21,*) 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 Prompt_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 & acreep, alphat, bcreep, biot , & ! outputs... & byerly, ccreep, cfric , conduc, & & dcreep, ecreep, everyp, ffric , & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, 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.0) 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.0) 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.0) 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 Prompt_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. * sec_per_year * SQRT(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.0) THEN velocity_interval = (maximum - minimum)/ai_spectrum_count velocity_midvalue = (maximum + minimum)/2. END IF 1093 CALL Prompt_for_Real('What contour interval do you wish?',velocity_interval,velocity_interval) IF (velocity_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") velocity_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1093 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',velocity_midvalue,velocity_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should slow areas be colored blue (versus red)?',velocity_lowblue,velocity_lowblue) ELSE CALL Prompt_for_Logical('Should slow areas be shaded darkly (versus lightly)?',velocity_lowblue,velocity_lowblue) END IF WRITE (*,"(/' Working on magnitude of deep velocity....')") DO group = 1, 2 CALL Begin_Group ! of colored/shaded spherical triangles IF (group == 2) CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) !note that contouring routine will set line colors DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) v1S_mma = 1000. * sec_per_year * vm(1, nodes(1,i)) v2S_mma = 1000. * sec_per_year * vm(1, nodes(2,i)) v3S_mma = 1000. * sec_per_year * vm(1, nodes(3,i)) v1E_mma = 1000. * sec_per_year * vm(2, nodes(1,i)) v2E_mma = 1000. * sec_per_year * vm(2, nodes(2,i)) v3E_mma = 1000. * sec_per_year * vm(2, nodes(3,i)) CALL Contour_3Node_Sphere_Velocity( & & uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & v1t = v1S_mma, v1p = V1E_mma, & & v2t = v2S_mma, v2p = V2E_mma, & & v3t = v3S_mma, v3p = V3E_mma, & & low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value = velocity_midvalue, & & low_is_blue = velocity_lowblue, group = group) END DO ! i = 1, numel CALL End_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value = velocity_midvalue, & & low_is_blue = velocity_lowblue, & & units = 'mm/a') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Bar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value =velocity_midvalue, & & low_is_blue = velocity_lowblue, & & units = 'mm/a') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on magnitude of deep velocity....DONE.')") ELSE ! velocity_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL Learn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN 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 Velocity_Size_in_3Node_Sphere & & (iele, uvec1, uvec2, uvec3, & ! element input & v1S,v1E, v2S,v2E, v3S,v3E, & ! nodal velocities & uvec, & ! position input & vsize, d_vsize_d_theta, d_vsize_d_phi) ! outputs t = vsize * 1000. * sec_per_year bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL Bumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & 'mm/a', minimum, maximum, & & bitmap_color_mode, velocity_interval, velocity_midvalue, velocity_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL Spectrum_in_BottomLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Spectrum_in_RightLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! velocity_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( vsize_mma ) !NOTE: Deliberately NOT deallocating vm, in case overlay of vecgtors 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 ( nodef, & & nodes, & & node_has_area, & & ynode, & & xnode, & & node_uvec ) ! in LIFO order 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 Group_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 Prompt_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 Press_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 ( 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.0 cooling_curvature_Cpm2 = 0.0 READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters END IF CALL LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) CALL LonLat_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.0) .OR. (cooling_curvature_Cpm2 /= 0.0) END DO ! i = 1, numnod READ (21,*) numel ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21,*) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21,*) nfl ALLOCATE ( nodef(4,nfl) ) DO i = 1, nfl READ (21,*) j, nodef(1,i), nodef(2,i), nodef(3,i), nodef(4,i) END DO ! i = 1, nfl CLOSE(21) !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 Prompt_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 & acreep, alphat, bcreep, biot , & ! outputs... & byerly, ccreep, cfric , conduc, & & dcreep, ecreep, everyp, ffric , & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) 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.0) 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.0) 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.0) 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.0) 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 Prompt_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 Prompt_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 & names, mostInOnePlate, ndplat, nfl, nodef, nodes, & & nPlates, numel, numnod, & & omega, plat, plon, & & xnode, ynode, & & whichp) ! OUTPUT 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 !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 Prompt_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 Press_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, 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 DO i = 1, numnod elevation = eqcm(1,i) heatflow = eqcm(2,i) crust_meters = eqcm(3,i) mantle_meters = eqcm(4,i) density_anomaly_kgpm3 = eqcm(5,i) cooling_curvature_Cpm2 = eqcm(6,i) geoth1 = tsurf geoth2 = heatflow / conduc(1) geoth3 = -0.5 * (radio(1) / conduc(1)) - 0.5 * cooling_curvature_Cpm2 geoth4 = 0.0 geoth5 = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 geoth6 = ((heatflow - crust_meters * radio(1)) / conduc(2)) - cooling_curvature_Cpm2 * crust_meters geoth7 = -0.5 * (radio(2) / conduc(2)) -0.5 * cooling_curvature_Cpm2 geoth8 = 0.0 zMoho = crust_meters CALL Coupling (acreep,bcreep,ccreep,ecreep, & & geoth1,geoth2,geoth3,geoth4,geoth5,geoth6,geoth7,geoth8, & & gradie,onekm,tadiab, & & zbasth,zMoho, & ! inputs (scalars, two-vectors) & glue) ! output (a scalar) delta_v_mps = SQRT((vm(1,i)-vs(1,i))**2 + (vm(2,i)-vs(2,i))**2) traction_MPa(i) = 1.0E-6 * glue * delta_v_mps**ecreep traction_MPa(i) = MIN(traction_MPa(i), etamax * delta_v_mps) traction_MPa(i) = MIN(traction_MPa(i), trhmax*1.E-6) IF (iconve == 4) THEN continental = (elevation > -2500.0).AND.(heatflow < 0.150) IF (.NOT.continental) traction_MPa(i) = 0.0 END IF END DO ! i = 1, numnod 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.0 ! 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 LonLat_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. ELSE ! no (extensive) driving slab attached: IF (traction_pole_read(iplate)) THEN uvec(1) = SIN(xnode(i)) * COS(ynode(i)) ! xnode is theta in radians; ynode is phi. uvec(2) = SIN(xnode(i)) * SIN(ynode(i)) uvec(3) = COS(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 = SQRT(tvec(1)**2 + tvec(2)**2 + tvec(3)**2) t = MIN(t, trhmax) traction_MPa(i) = t / 1.E6 ! from Pa to MPa ELSE traction_MPa(i) = 0.0 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.0) THEN traction_interval = (maximum - minimum)/ai_spectrum_count traction_midvalue = (maximum + minimum)/2. END IF 1104 CALL Prompt_for_Real('What contour interval do you wish?',traction_interval,traction_interval) IF (traction_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") traction_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1104 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',traction_midvalue,traction_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low-traction areas be colored blue (versus red)?',traction_lowblue,traction_lowblue) ELSE CALL Prompt_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 Begin_Group ! of colored/shaded spherical triangles IF (group == 2) CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) !note that contouring routine will set line colors DO i = 1, numel 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 Contour_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 End_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = 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 Bar_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 Learn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN uvec1(1:3) = node_uvec(1:3,nodes(1,iele)) uvec2(1:3) = node_uvec(1:3,nodes(2,iele)) uvec3(1:3) = node_uvec(1:3,nodes(3,iele)) 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 Bumpy_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 Spectrum_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 Spectrum_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 ( nodef, & & nodes, & & eqcm, & ! N.B. Deliberately LEAVING whichp allocated, in case overlay #6 is wanted! & ynode, & & xnode, & & node_uvec ) ! in LIFO order 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 Group_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 Prompt_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 Press_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 LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21,*) numel ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21,*) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel 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 Prompt_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 Press_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 Prompt_for_Logical('Do you wish to CHANGE the velocity reference frame?',velocity_reframe,velocity_reframe) IF (velocity_reframe) THEN 1112 CALL Prompt_for_Integer('Which node should be fixed?',fixed_node,fixed_node) IF ((fixed_node < 1).OR.(fixed_node > numnod)) THEN WRITE (*,"(' ERROR: Illegal node number!')") mt_flashby = .FALSE. GO TO 1112 END IF ! illegal fixed_node 1113 CALL Prompt_for_Integer('Which OTHER node should be prevented from rotating about the first?',nonorbiting_node,nonorbiting_node) IF ((nonorbiting_node < 1).OR.(nonorbiting_node > numnod).OR.(nonorbiting_node == fixed_node)) THEN WRITE (*,"(' ERROR: Illegal node number!')") mt_flashby = .FALSE. GO TO 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. * sec_per_year * SQRT(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.0) THEN velocity_interval = (maximum - minimum)/ai_spectrum_count velocity_midvalue = (maximum + minimum)/2. END IF 1114 CALL Prompt_for_Real('What contour interval do you wish?',velocity_interval,velocity_interval) IF (velocity_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") velocity_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1114 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',velocity_midvalue,velocity_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should slow areas be colored blue (versus red)?',velocity_lowblue,velocity_lowblue) ELSE CALL Prompt_for_Logical('Should slow areas be shaded darkly (versus lightly)?',velocity_lowblue,velocity_lowblue) END IF WRITE (*,"(/' Working on magnitude of velocity....')") DO group = 1, 2 CALL Begin_Group ! of colored/shaded spherical triangles IF (group == 2) CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) !note that contouring routine will set line colors DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) v1S_mma = 1000. * sec_per_year * vw(2*nodes(1,i)-1) v2S_mma = 1000. * sec_per_year * vw(2*nodes(2,i)-1) v3S_mma = 1000. * sec_per_year * vw(2*nodes(3,i)-1) v1E_mma = 1000. * sec_per_year * vw(2*nodes(1,i)) v2E_mma = 1000. * sec_per_year * vw(2*nodes(2,i)) v3E_mma = 1000. * sec_per_year * vw(2*nodes(3,i)) CALL Contour_3Node_Sphere_Velocity( & & uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & v1t = v1S_mma, v1p = V1E_mma, & & v2t = v2S_mma, v2p = V2E_mma, & & v3t = v3S_mma, v3p = V3E_mma, & & low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value = velocity_midvalue, & & low_is_blue = velocity_lowblue, group = group) END DO ! i = 1, numel CALL End_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value = velocity_midvalue, & & low_is_blue = velocity_lowblue, & & units = 'mm/a') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Bar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = velocity_interval, & & midspectrum_value =velocity_midvalue, & & low_is_blue = velocity_lowblue, & & units = 'mm/a') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on magnitude of velocity....DONE.')") ELSE ! velocity_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL Learn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN uvec1(1:3) = node_uvec(1:3,nodes(1,iele)) uvec2(1:3) = node_uvec(1:3,nodes(2,iele)) uvec3(1:3) = node_uvec(1:3,nodes(3,iele)) v1S = vw(2*nodes(1,iele)-1) v2S = vw(2*nodes(2,iele)-1) v3S = vw(2*nodes(3,iele)-1) v1E = vw(2*nodes(1,iele)) v2E = vw(2*nodes(2,iele)) v3E = vw(2*nodes(3,iele)) CALL Velocity_Size_in_3Node_Sphere & & (iele, uvec1, uvec2, uvec3, & ! element input & v1S,v1E, v2S,v2E, v3S,v3E, & ! nodal velocities & uvec, & ! position input & vsize, d_vsize_d_theta, d_vsize_d_phi) ! outputs t = vsize * 1000. * sec_per_year bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL Bumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & 'mm/a', minimum, maximum, & & bitmap_color_mode, velocity_interval, velocity_midvalue, velocity_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL Spectrum_in_BottomLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Spectrum_in_RightLegend (minimum, maximum, 'mm/a', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & velocity_interval, velocity_midvalue, velocity_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! velocity_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( nodes ) DEALLOCATE ( vsize_mma ) DEALLOCATE ( vw ) DEALLOCATE ( node_has_area ) DEALLOCATE ( node_uvec ) ! in LIFO order 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 Group_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 Prompt_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 LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. 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 Prompt_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 Press_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 Make_Uvec (uvec4, uvec) ! center of element equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF theta_ = ATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) !convert to scalar measure, for histogram CALL Principal_Axes_22 (eps_dot(1),eps_dot(2),eps_dot(3), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) err = -(e1h + e2h) largest_ei_persec = MAX(ABS(e1h), ABS(e2h), ABS(err)) IF (largest_ei_persec == 0.0) THEN log_largest_ei_persec(l_) = -20.0 ! arbitrary substitute for -infinity! ELSE log_largest_ei_persec(l_) = LOG10(largest_ei_persec) END IF !(not using loop on m = 1,...,7 since values almost identical) END DO ! l_ = 1, numel, computing strainrates and scalar measure WRITE (*,"(/' Here is the distribution of common logs of largest (absolute value)' & & /' principal strain-rates (LOG10(MAX(ABS(Ei * 1 s)))) for each element:')") CALL Histogram (log_largest_ei_persec, numel, .FALSE., maximum, minimum) IF (log_strainrate_method == 1) THEN ! group of colored/shaded polygons IF (log_strainrate_interval == 0.0) THEN log_strainrate_interval = (maximum - minimum)/ai_spectrum_count log_strainrate_midvalue = (maximum + minimum)/2. END IF 1122 CALL Prompt_for_Real('What contour interval do you wish?',log_strainrate_interval,log_strainrate_interval) IF (log_strainrate_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") log_strainrate_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1122 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',log_strainrate_midvalue,log_strainrate_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',log_strainrate_lowblue,log_strainrate_lowblue) ELSE CALL Prompt_for_Logical('Should low values be shaded darkly (versus lightly)?',log_strainrate_lowblue,log_strainrate_lowblue) END IF WRITE (*,"(/' Working on log of largest (absolute value) principal strain-rate....')") CALL Begin_Group ! of colored/shaded triangles (there won't be any contours) DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) t = log_largest_ei_persec(i) IF (MOD(t, log_strainrate_interval) == 0.0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0) THEN t = t - 0.001* log_strainrate_interval ELSE ! t < 0.0 t = t + 0.001 * log_strainrate_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) CALL Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, group = 1) END DO ! i = 1, numel CALL End_Group ! of colored/shaded triangles WRITE (*,"('+Working on log of largest (absolute value) principal strain-rate....DONE.')") CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Bar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value = log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! ELSE ! log_strainrate_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL Learn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = log_largest_ei_persec(iele) bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL Bumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & ' ', minimum, maximum, & & bitmap_color_mode, log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL Spectrum_in_BottomLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Spectrum_in_RightLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! log_strainrate_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( log_largest_ei_persec, & & vw, & ! in LIFO order & nodes, & & node_uvec) just_began_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 Group_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 Prompt_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 LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. 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 Prompt_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 Press_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 Make_Uvec (uvec4, uvec) ! center of element equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF theta_ = ATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL Rotation_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, rotationrate) !convert to popular units, for histogram (clockwise degrees per Ma) omega_degperMa(l_) = -rotationrate * degrees_per_radian * s_per_Ma !(not using loop on m = 1,...,7 since values almost identical) END DO ! l_ = 1, numel, computing rotation rates in popular units WRITE (*,"(/' Here is the distribution of clockwise rotation rates' & /' (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.0) THEN rotationrate_interval = (maximum - minimum) / ai_spectrum_count rotationrate_midvalue = (maximum + minimum) / 2.0 END IF 1132 CALL Prompt_for_Real('What contour interval do you wish?',rotationrate_interval,rotationrate_interval) IF (rotationrate_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") rotationrate_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1132 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',rotationrate_midvalue,rotationrate_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',rotationrate_lowblue,rotationrate_lowblue) ELSE CALL Prompt_for_Logical('Should low values be shaded darkly (versus lightly)?',rotationrate_lowblue,rotationrate_lowblue) END IF WRITE (*,"(/' Working on rotation rate....')") CALL Begin_Group ! of colored/shaded triangles (there won't be any contours) DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) t = omega_degperMa(i) IF (MOD(t, rotationrate_interval) == 0.0) THEN ! Color is undefined for t = n * element_scalar_interval, ! so nudge the value toward zero: IF (t > 0.0) THEN t = t - 0.001* rotationrate_interval ELSE ! t < 0.0 t = t + 0.001 * rotationrate_interval END IF ! t positive or negative END IF ! t lies exactly on a contour level (color undefined!) CALL Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = rotationrate_interval, & & midspectrum_value = rotationrate_midvalue, & & low_is_blue = rotationrate_lowblue, group = 1) END DO ! i = 1, numel CALL End_Group ! of colored/shaded triangles WRITE (*,"('+Working on rotation rate....DONE.')") CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = rotationrate_interval, & & midspectrum_value = rotationrate_midvalue, & & low_is_blue = rotationrate_lowblue, & & units = 'clockwise degree/Ma') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Bar_in_RightLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = rotationrate_interval, & & midspectrum_value = rotationrate_midvalue, & & low_is_blue = rotationrate_lowblue, & & units = 'clockwise degree/Ma') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! ELSE ! rotationrate_method == 2 ALLOCATE ( a_(numel) ) ALLOCATE ( center(3, numel) ) ALLOCATE ( neighbor(3, numel) ) CALL Learn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = omega_degperMa(iele) bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL Bumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & 'clockwise degree/Ma', minimum, maximum, & & bitmap_color_mode, rotationrate_interval, rotationrate_midvalue, rotationrate_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL Spectrum_in_BottomLegend (minimum, maximum, 'clockwise degree/Ma', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & rotationrate_interval, rotationrate_midvalue, rotationrate_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Spectrum_in_RightLegend (minimum, maximum, 'clockwise degree/Ma', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & rotationrate_interval, rotationrate_midvalue, rotationrate_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! rotationrate_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( omega_degperMa, & & vw, & ! in LIFO order & nodes, & & node_uvec) ! end of 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 Group_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 Prompt_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.0 cooling_curvature_Cpm2 = 0.0 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 LonLat_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.0) .OR. (cooling_curvature_Cpm2 /= 0.0) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( strainrate(3, 7, numel) ) ! 3 components; 7 integration points DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. 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 Prompt_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 Press_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 Make_Uvec (uvec4, uvec) ! integration point equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF theta_ = ATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) strainrate(1:3, m, l_) = eps_dot(1:3) END DO ! m = 1, 7 END DO ! l_ = 1, numel, computing strainrates !Get input parameters: temp_path_in = path_in CALL File_List( file_type = "i*.in", & & suggested_file = parameter_file, & & using_path = temp_path_in) CALL Prompt_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 & acreep, alphat, bcreep, biot , & ! outputs... & byerly, ccreep, cfric , conduc, & & dcreep, ecreep, everyp, ffric , & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) 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.0 ! 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 Principal_Axes_22 (e11, e12, e22, & & e1, e2, u1x,u1y, u2x,u2y) IF ((e1 == 0.0).AND.(e2 == 0.0)) THEN shear_integral(i) = 0.0 ELSE t1 = 0.0 ! prepare to sum layer contributions to vertical integrals of t2 = 0.0 ! 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.E3 !Non-controversial geotherm coefficients: geoth1 = tsurf geoth2 = heatflow / conduc(1) geoth3 = -0.5 * radio(1) / conduc(1) geoth4 = 0.0 geoth7 = -0.5 * radio(2) / conduc(2) geoth8 = 0.0 !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.0) 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.0 * 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. * geoth3 * crust_meters + 3. * geoth4 * crust_meters**2 dtdzm = dtdzc * conduc(1) / conduc(2) geoth6 = dtdzm IF (crust_meters > 0.0) THEN pl0 = 0.0 ! same approximation as in VISCOS; pw0 = 0.0 ! ocean not important since it affects both equally zoftop = 0.0 rho_use = rhobar(1) + density_anomaly_kgpm3 geoth3 = -0.5 * (radio(1) / conduc(1)) -0.5 * 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) t1 = t1 + pt1 t2 = t2 + pt2 END IF ! crust_meters > 0 IF (mantle_meters > 0.0) THEN zoftop = crust_meters pw0 = rhoh2o * gmean * crust_meters t_mean = geoth1 + & & 0.5 * geoth2 * crust_meters + & & 0.333 * geoth3 * crust_meters**2 + & & 0.25 * geoth4 * crust_meters**3 rho_use = rhobar(1) * (1.0 - 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) t1 = t1 + pt1 t2 = t2 + pt2 END IF ! mantle_meters > 0 shear_integral(i) = 0.5 * 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 Make_Uvec (uvec4, uvec) ! integration point visible = L5_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 Prompt_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.0) THEN shear_integral_interval = (maximum - minimum)/ai_spectrum_count shear_integral_midvalue = (maximum + minimum)/2. END IF 1143 CALL Prompt_for_Real('What contour interval do you wish?',shear_integral_interval,shear_integral_interval) IF (shear_integral_interval <= 0.0) 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 Prompt_for_Real('What value should fall at mid-spectrum?',shear_integral_midvalue,shear_integral_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',shear_integral_lowblue,shear_integral_lowblue) ELSE CALL Prompt_for_Logical('Should low values be shaded darkly (versus lightly)?',shear_integral_lowblue,shear_integral_lowblue) END IF IF (minimum == 0.0) 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 Prompt_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 Begin_Group ! of colored/shaded triangles (there won't be any contours) DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) t = shear_integral(i) IF (t == 0.0) THEN SELECT CASE (shear_integral_zeromode) CASE (1) ! round up t = 0.001 * shear_integral_interval plot_this = .TRUE. CASE (0) ! do not plot plot_this = .FALSE. CASE (-1) ! round down t = -0.001 * shear_integral_interval plot_this = .TRUE. END SELECT ELSE ! non-zero value plot_this = .TRUE. IF (MOD(t, shear_integral_interval) == 0.0) THEN ! Color is undefined for t = n * shear_integral_interval, ! so nudge the value toward zero: IF (t > 0.0) THEN t = t - 0.001* shear_integral_interval ELSE ! t < 0.0 t = t + 0.001 * 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 Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = shear_integral_interval, & & midspectrum_value = shear_integral_midvalue, & & low_is_blue = shear_integral_lowblue, group = 1) END DO ! i = 1, numel CALL End_Group ! of colored/shaded triangles CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = 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 Bar_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 Learn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = 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 Bumpy_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 Spectrum_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 Spectrum_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 ( shear_integral ) DEALLOCATE ( strainrate ) DEALLOCATE ( nodes ) DEALLOCATE ( eqcm ) DEALLOCATE ( vw ) DEALLOCATE ( node_uvec ) ! in LIFO order 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 Group_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 Prompt_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.0 cooling_curvature_Cpm2 = 0.0 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 LonLat_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.0) .OR. (cooling_curvature_Cpm2 /= 0.0) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( strainrate(3, 7, numel) ) ! 3 components; 7 integration points DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. 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 Prompt_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 Press_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 Make_Uvec (uvec4, uvec) ! integration point equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF theta_ = ATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) strainrate(1:3, m, l_) = eps_dot(1:3) END DO ! m = 1, 7 END DO ! l_ = 1, numel, computing strainrates !Get input parameters: 1152 temp_path_in = path_in CALL File_List( file_type = "i*.in", & & suggested_file = parameter_file, & & using_path = temp_path_in) CALL Prompt_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 & acreep, alphat, bcreep, biot , & ! outputs... & byerly, ccreep, cfric , conduc, & & dcreep, ecreep, everyp, ffric , & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) 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.0 ! 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 Principal_Axes_22 (e11, e12, e22, & & e1, e2, u1x,u1y, u2x,u2y) IF ((e1 == 0.0).AND.(e2 == 0.0)) THEN log_viscosity_integral(i) = 0.0 ! meaning: undefined ELSE t1 = 0.0 ! prepare to sum layer contributions to vertical integrals of t2 = 0.0 ! 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.E3 !Non-controversial geotherm coefficients: geoth1 = tsurf geoth2 = heatflow / conduc(1) geoth3 = -0.5 * radio(1) / conduc(1) geoth4 = 0.0 geoth7 = -0.5 * radio(2) / conduc(2) geoth8 = 0.0 !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.0) 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.0 * 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. * geoth3 * crust_meters + 3. * geoth4 * crust_meters**2 dtdzm = dtdzc * conduc(1) / conduc(2) geoth6 = dtdzm IF (crust_meters > 0.0) THEN pl0 = 0.0 ! same approximation as in VISCOS; pw0 = 0.0 ! ocean not important since it affects both equally zoftop = 0.0 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) t1 = t1 + pt1 t2 = t2 + pt2 END IF ! crust_meters > 0 IF (mantle_meters > 0.0) THEN zoftop = crust_meters pw0 = rhoh2o * gmean * crust_meters t_mean = geoth1 + & & 0.5 * geoth2 * crust_meters + & & 0.333 * geoth3 * crust_meters**2 + & & 0.25 * geoth4 * crust_meters**3 rho_use = rhobar(1) * (1.0 - 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) 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.5 * ABS(t2 - t1) / ABS(delta12) ELSE IF (delta_max == delta13) THEN viscosity_integral = 0.5 * ABS(t1) / ABS(delta13) ELSE ! delta_max == delta23 viscosity_integral = 0.5 * ABS(t2) / ABS(delta23) END IF log_viscosity_integral(i) = LOG10(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.0) THEN log_viscosity_integral_interval = 1.0 END IF IF (log_viscosity_integral_midvalue == 0.0) THEN log_viscosity_integral_midvalue = (maximum + minimum)/2. END IF 1153 CALL Prompt_for_Real('What contour interval do you wish?',log_viscosity_integral_interval,log_viscosity_integral_interval) IF (log_viscosity_integral_interval <= 0.0) 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 Prompt_for_Real('What value should fall at mid-spectrum?',log_viscosity_integral_midvalue,log_viscosity_integral_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',log_viscosity_integral_lowblue,log_viscosity_integral_lowblue) ELSE CALL Prompt_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 Begin_Group ! of colored/shaded triangles (there won't be any contours) DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) t = log_viscosity_integral(i) IF (MOD(t, log_viscosity_integral_interval) == 0.0) THEN ! Color is undefined for t = n * log_viscosity_integral_interval, ! so nudge the value toward zero: IF (t > 0.0) THEN t = t - 0.001* log_viscosity_integral_interval ELSE ! t < 0.0 t = t + 0.001 * 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 Contour_3Node_Scalar_on_Sphere & &(uvec1 = uvec1, uvec2 = uvec2, uvec3 = uvec3, & & f1 = t, f2 = t, f3 = t, & & low_value = minimum, high_value = maximum, & & contour_interval = log_viscosity_integral_interval, & & midspectrum_value = log_viscosity_integral_midvalue, & & low_is_blue = log_viscosity_integral_lowblue, group = 1) END DO ! i = 1, numel CALL End_Group ! of colored/shaded triangles CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & &(low_value = minimum, high_value = maximum, & & contour_interval = 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 Bar_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 Learn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = log_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.0) 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 Bumpy_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 Spectrum_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 Spectrum_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 ) DEALLOCATE ( strainrate ) DEALLOCATE ( nodes ) DEALLOCATE ( eqcm ) DEALLOCATE ( vw ) DEALLOCATE ( node_uvec ) ! in LIFO order 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 Group_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 Prompt_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 LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) IF (t > 0.0) THEN node_scalar(i) = LOG10(t) ELSE node_scalar(i) = 0.0 END IF END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. 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.0) THEN log_strainrate_interval = 1.0 END IF IF (log_strainrate_midvalue == 0.0) THEN log_strainrate_midvalue = (maximum + minimum)/2. END IF 1162 CALL Prompt_for_Real('What contour interval do you wish?',log_strainrate_interval,log_strainrate_interval) IF (log_strainrate_interval <= 0.0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") log_strainrate_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1162 END IF CALL Prompt_for_Real('What value should fall at mid-spectrum?',log_strainrate_midvalue,log_strainrate_midvalue) IF (ai_using_color) THEN CALL Prompt_for_Logical('Should low values be colored blue (versus red)?',log_strainrate_lowblue,log_strainrate_lowblue) ELSE CALL Prompt_for_Logical('Should low values be shaded darkly (versus lightly)?',log_strainrate_lowblue,log_strainrate_lowblue) END IF WRITE (*,"(/' Working on log10[strain-rate, in /s]....')") DO group = 1, 2 CALL Begin_Group IF (group == 2) CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) !note that contouring routine will set line colors DO i = 1, numel uvec1(1:3) = node_uvec(1:3,nodes(1,i)) uvec2(1:3) = node_uvec(1:3,nodes(2,i)) uvec3(1:3) = node_uvec(1:3,nodes(3,i)) f1 = node_scalar(nodes(1,i)) f2 = node_scalar(nodes(2,i)) f3 = node_scalar(nodes(3,i)) IF ((f1 /= 0.0).AND.(f2 /= 0.0).AND.(f3 /= 0.0)) THEN CALL Contour_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 End_Group ! of contour lines END DO ! group = 1, 2 CALL Chooser(bottom, right) IF (bottom) THEN CALL Bar_in_BottomLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value =log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Bar_in_RightLegend & & (low_value = minimum, high_value = maximum, & & contour_interval = log_strainrate_interval, & & midspectrum_value =log_strainrate_midvalue, & & low_is_blue = log_strainrate_lowblue, & & units = ' ') rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! 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 Learn_Spherical_Triangles (numel, nodes, node_uvec, .TRUE., & & a_, center, neighbor) WRITE (*,"(' Collecting data for bitmap....')") ALLOCATE ( bitmap_success(bitmap_height, bitmap_width) ) ALLOCATE ( bitmap_value(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom cold_start = .TRUE. fy1 = (irow-0.5) / bitmap_height fy2 = 1.00 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol-0.5) / bitmap_width fx1 = 1.00 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL Points_2_Meters (x_points,y_points, x_meters,y_meters) CALL Reject (x_meters,y_meters, success, uvec) CALL Which_Spherical_Triangle (uvec, cold_start, & & numel, nodes, node_uvec, center, a_, neighbor, & & success, iele, s1, s2, s3) IF (success) THEN t = node_scalar(nodes(1,iele)) * s1 + & & node_scalar(nodes(2,iele)) * s2 + & & node_scalar(nodes(3,iele)) * s3 bitmap_success(irow,jcol) = .TRUE. bitmap_value(irow,jcol) = t minimum = MIN(minimum, t) maximum = MAX(maximum, t) ELSE bitmap_success(irow,jcol) = .FALSE. END IF cold_start = .NOT. success END DO ! jcol, left to right WRITE (*,"('+Collecting data for bitmap....',I5,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Collecting data for bitmap....DONE ')") CALL Bumpy_Bitmap (bitmap_height, bitmap_width, bitmap_success, bitmap_value, & & ' ', minimum, maximum, & & bitmap_color_mode, log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue, & & bitmap_color_lowvalue, bitmap_color_highvalue, & & shaded_relief, path_in, grd2_file, intensity) DEALLOCATE (bitmap_value, bitmap_success) ! in LIFO order DEALLOCATE ( neighbor, & & center, & & a_ ) ! in LIFO order CALL Chooser(bottom, right) IF (bottom) THEN CALL Spectrum_in_BottomLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL Spectrum_in_RightLegend (minimum, maximum, ' ', bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & log_strainrate_interval, log_strainrate_midvalue, log_strainrate_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! log_strainrate_method = 1 or 2 CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( node_scalar, & & node_uvec, & & nodes) ! common arrays, in LIFO order ! 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 Prompt_for_Logical('Do you want additional mosaics?',suggest_logical,do_more_mosaics) IF (do_more_mosaics) GO TO 1000 ! mosaics menu END IF ! do mosaic !-------------------------- OVERLAYS ------------------------------ !----- (symbols composed mostly of lines; mostly transparent) ----- overlay_count = 0 ! counts number of overlays in this map !GPBoverlays 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 (*,"( ' ----------------------------------------------------------------------')") suggest_logical = old_overlay_count > overlay_count IF (overlay_count == 0) CALL Prompt_for_Logical('Do you want one (or more) of these overlays?',suggest_logical,do_overlay) IF (do_overlay) THEN overlay_count = overlay_count + 1 choice = overlay_choice(overlay_count) IF (just_began_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 Prompt_for_Integer('Which overlay type should be added?',choice,choice) IF ((choice < 1).OR.(choice > 22)) THEN WRITE (*,"(/' ERROR: Please select an integer from the list!')") CALL Press_Enter mt_flashby = .FALSE. GO TO 2000 ELSE overlay_choice(overlay_count) = choice ! for memory END IF ! illegal or legal choice SELECT CASE (choice) CASE (1) ! basemap (lines type) 2010 temp_path_in = path_in CALL File_List( file_type = "*.dig", & & suggested_file = lines_basemap_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file should be plotted?',lines_basemap_file,lines_basemap_file) lines_basemap_pathfile = TRIM(temp_path_in)//TRIM(lines_basemap_file) CALL Set_Line_Style (width_points = 2.0, dashed = .FALSE.) CALL Set_Stroke_Color (color_name = 'foreground') CALL Dig_Type (lines_basemap_pathfile, 21, dig_is_lonlat, any_titles) CALL Prompt_for_Logical('Is this basemap written in (lon,lat) coordinates?',dig_is_lonlat,dig_is_lonlat) IF ((.NOT.xy_defined).AND.(.NOT.dig_is_lonlat)) THEN WRITE (*,"(' ERROR: Start FiniteMap over again and define the (x,y) coordinates.')") CALL Press_Enter STOP ' ' END IF IF (any_titles) THEN WRITE (*, "(/' Title lines were detected in this .dig file;')") CALL Prompt_for_Logical('do you want to include these titles in the plot?',plot_dig_titles,plot_dig_titles) IF (plot_dig_titles) THEN WRITE (*,"(' -------------------------------------------------')") WRITE (*,"(' Choose Alignment Method for Titles:')") WRITE (*,"(' 1: upright, at geometric center of polyline')") WRITE (*,"(' 2: parallel to first segment of polyline')") WRITE (*,"(' -------------------------------------------------')") 2011 CALL Prompt_for_Integer('Which alignment method?',dig_title_method,dig_title_method) IF ((dig_title_method < 1).OR.(dig_title_method > 2)) THEN WRITE (*,"(' ERROR: Illegal choice of method.')") mt_flashby = .FALSE. GO TO 2011 END IF ! bad choice END IF ! plot_dig_titles END IF ! any_titles WRITE (*,"(/' Working on basemap....')") polygons = .FALSE. IF (dig_is_lonlat) THEN CALL Plot_Dig (7, lines_basemap_pathfile, polygons, 21, in_ok) ELSE CALL Plot_Dig (3, lines_basemap_pathfile, polygons, 21, in_ok) END IF IF (.NOT.in_ok) THEN mt_flashby = .FALSE. GO TO 2010 END IF IF (any_titles .AND. plot_dig_titles) THEN CALL Set_Fill_or_Pattern (.FALSE., 'foreground') IF (dig_is_lonlat) THEN CALL Plot_Dig (7, lines_basemap_pathfile, polygons, 21, in_ok, dig_title_method) ELSE CALL Plot_Dig (3, lines_basemap_pathfile, polygons, 21, in_ok, dig_title_method) END IF END IF ! any_titles .AND. plot_dig_titles WRITE (*,"('+Working on basemap....DONE.')") ! possible plot titles: filename, and first 3 lines CALL Add_Title(lines_basemap_file) OPEN (UNIT = 21, FILE = lines_basemap_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') 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) ! finite-element grid: outline (2), faults (3), all(4) 2020 IF (.NOT.got_FEP) CALL Get_FEP 2030 temp_path_in = path_in 2040 CALL File_List( file_type = "*.feg", & & suggested_file = feg_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which file should be plotted?',feg_file,feg_file) feg_pathfile = TRIM(temp_path_in)//TRIM(feg_file) OPEN(UNIT = 21, FILE = feg_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. GO TO 2030 END IF CALL Add_Title('Finite Element Grid') READ (21,"(A)") line CALL Add_Title(line) READ (21,*) numnod ALLOCATE ( node_uvec(3,numnod), segments(3,2,numnod) ) DO i = 1, numnod READ (21,*) j, lon, lat CALL LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21,*) numel ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21,*) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21,*) nfl ALLOCATE ( nodef(4,nfl), fdip(2,nfl) ) DO i = 1, nfl READ (21,*) j, nodef(1,i), nodef(2,i), nodef(3,i), nodef(4,i), & & fdip(1,i), fdip(2,i) END DO ! i = 1, nfl CLOSE(21) IF (choice == 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 !link segments to create outline CALL Set_Line_Style (width_points = 4.0, dashed = .FALSE.) CALL Set_Stroke_Color ('gray______') j = 1 ! begin with first segment uvec1(1:3) = segments(1:3,1,j) CALL New_L45_Path (5, uvec1) DO i = 1, nseg uvec2(1:3) = segments(1:3,2,j) CALL Great_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 End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) WRITE (*,"('+Working on outline of grid....DONE.')") ELSE ! 3 or 4; plot (at least some) elements and nodes, with numbers (in separate groups) IF (choice ==4) CALL Prompt_for_Real('Desired radius of node circles, in points (or 0 for none)?',node_radius_points,node_radius_points) IF (nfl > 0) CALL Prompt_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.0)) THEN CALL Begin_Group ! of nodes IF (ai_using_color) THEN CALL Set_Fill_or_Pattern (.FALSE., 'dark_blue_') ELSE CALL Set_Fill_or_Pattern (.FALSE., 'foreground') END IF DO i = 1, numnod uvec1(1:3) = node_uvec(1:3,i) node_radius_radians = node_radius_points * 0.0003528 * & & mp_scale_denominator * & & Conformal_Deflation (uvec1) / R CALL Turn_To (azimuth_radians = 0.0, & & base_uvec = uvec1, & & far_radians = node_radius_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL New_L45_Path (5, uvec2) CALL Small_To_L45 (uvec1, uvec2) CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END DO ! i = 1, numnod CALL End_Group ! of nodes END IF ! numnod > 0 and node_radius_points >= 1. IF (choice == 4) THEN ! plot node numbers CALL Begin_Group ! of node numbers IF (ai_using_color) THEN CALL Set_Fill_or_Pattern (.FALSE., 'dark_blue_') ELSE CALL Set_Fill_or_Pattern (.FALSE., 'foreground') END IF DO i = 1, numnod ! 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.0 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.0 !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 L5_Text (uvec = uvec1, angle_radians = 0.0, from_east = .FALSE., & & font_points = 8, lr_fraction = -0.2, ud_fraction = 0.4, & & text = TRIM(c6)) ELSE ! offset direction is available CALL Make_Uvec(uvec3, uvec2) argument = Pi_over_2 - Relative_Compass(uvec1, uvec2) IF (COS(argument) > 0.0) THEN ! number is right-side-up CALL L5_Text (uvec = uvec1, angle_radians = argument, from_east = .TRUE., & & font_points = 8, lr_fraction = -0.2, ud_fraction = 0.4, & & text = TRIM(c6)) ELSE ! number must be flipped or it will be inverted argument = argument + Pi CALL L5_Text (uvec = uvec1, angle_radians = argument, from_east = .TRUE., & & font_points = 8, lr_fraction = 1.2, ud_fraction = 0.4, & & 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 End_Group ! of node numbers END IF ! node numbers are wanted IF ((choice == 4).AND.(numel > 0)) THEN ! plot elements CALL Begin_Group ! of elements CALL Set_Line_Style (width_points = 1.0, dashed = .TRUE., & & on_points = 6., off_points = 3.) IF (ai_using_color) THEN CALL Set_Stroke_Color ('green_____') ELSE CALL Set_Stroke_Color ('gray______') END IF DO i = 1, numel DO j = 1, 3 ! loop on 3 sides jp1 = MOD(j,3) + 1 virgin = .TRUE. ! until proven otherwise IF (i > 1) THEN edges_done: DO m = 1, i-1 DO n = 1, 3 np1 = MOD(n,3) + 1 IF (nodes(n,m) == nodes(jp1,i)) THEN IF (nodes(np1,m) == nodes(j,i)) THEN virgin = .FALSE. EXIT edges_done END IF ! both ends match! END IF ! one end matches END DO ! n = 1, 3 END DO edges_done ! m = 1, i-1 END IF ! there are lower-numbered elements IF (virgin) THEN ! only plot each line once, because of dashing! uvec1(1:3) = node_uvec(1:3,nodes(j,i)) CALL New_L45_Path (5, uvec1) uvec2(1:3) = node_uvec(1:3,nodes(jp1,i)) CALL Great_To_L45 (uvec2) CALL End_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) END IF ! virgin END DO ! j = 1, 3 END DO ! i = 1, numel CALL End_Group ! of elements CALL Begin_Group ! of element numbers IF (ai_using_color) THEN CALL Set_Fill_or_Pattern (.FALSE., 'green_____') ELSE CALL Set_Fill_or_Pattern (.FALSE., 'gray______') END IF DO i = 1, numel uvec2(1:3) = (node_uvec(1:3, nodes(1,i)) + & & node_uvec(1:3, nodes(2,i)) + & & node_uvec(1:3, nodes(3,i))) / 3.0 CALL Make_Uvec(uvec2, uvec1) WRITE (c6,"(I6)") i c6 = ADJUSTL(c6) CALL L5_Text (uvec = uvec1, angle_radians = 0.0, from_east = .FALSE., & & font_points = 8, lr_fraction = 0.5, ud_fraction = 0.4, & & text = TRIM(c6)) END DO ! i = 1, numel CALL End_Group ! of element numbers END IF ! elements should be plotted 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 Begin_Group ! of fault element numbers IF (ai_using_color) THEN CALL Set_Fill_or_Pattern (.FALSE., 'red_______') ELSE CALL Set_Fill_or_Pattern (.FALSE., 'foreground') END IF DO i = 1, nfl ! all fault element numbers CALL Make_Uvec(uvec2, uvec1) 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.0 CALL Make_Uvec(uvec2, uvec1) uvec2(1:3) = node_uvec(1:3, nodef(2,i)) argument = Pi_over_2 - Relative_Compass(uvec1, uvec2) CALL L5_Text (uvec = uvec1, angle_radians = argument, from_east = .TRUE., & & font_points = 8, lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(c6)) END DO ! i = 1, nfl; fault element numbers CALL End_Group ! of fault element numbers END IF ! nfl > 0; plot faults WRITE (*,"('+Working on finite-element grid....DONE.')") END IF ! choice = 2 (outline) or 3:4 (elements) DEALLOCATE ( node_uvec, segments ) DEALLOCATE ( nodes ) DEALLOCATE ( nodef, fdip ) CALL BEEPQQ (frequency = 440, duration = 250) ! end of finite element grid: outline(2), faults(3), all(4) 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 Prompt_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 Press_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 DO i = 1, numnod READ (21,*) j, lon, lat CALL LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) CALL LonLat_2_ThetaPhi (lon, lat, theta, phi) xnode(i) = theta ynode(i) = phi END DO ! i = 1, numnod READ (21,*) numel ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21,*) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21,*) nfl ALLOCATE ( nodef(4,nfl) ) DO i = 1, nfl READ (21,*) 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 Prompt_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 & acreep, alphat, bcreep, biot , & ! outputs... & byerly, ccreep, cfric , conduc, & & dcreep, ecreep, everyp, ffric , & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, 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.0) 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.0) 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.0) 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 Prompt_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. * sec_per_year * SQRT(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 Prompt_for_Real('For how many Ma should velocity be projected?',velocity_Ma,velocity_Ma) WRITE (*,"(/' There will be ',I7,' vectors plotted if they are not thinned.')") numnod 2052 CALL Prompt_for_Integer('What thinning factor ( >=1 ) do you want?',vector_thinner,vector_thinner) IF (vector_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") mt_flashby = .FALSE. GO TO 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 Thin_on_Sphere (node_uvec, numnod, vector_thinner, selected) WRITE (*,"(/' Working on deep velocity vectors....')") CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Begin_Group DO i = 1, numnod IF (selected(i)) THEN uvec1(1:3) = node_uvec(1:3,i) v_South_mps = vm(1, i) v_East_mps = vm(2, i) CALL Velocity_Vector_on_Sphere (from_uvec = uvec1, & & v_theta_mps = v_South_mps, v_phi_mps = v_East_mps, & & dt_sec = velocity_Ma * 1.E6 * sec_per_year, deflate = .TRUE.) END IF ! selected END DO ! actually plotting deep velocity vectors CALL End_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 ( nodef, & & nodes, & & ynode, & & xnode, & & node_uvec ) ! in LIFO order ! 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 Prompt_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 Press_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 ( 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.0 cooling_curvature_Cpm2 = 0.0 READ (input_record, *, IOSTAT = ios) j, lon, lat, elevation, heatflow, crust_meters, mantle_meters END IF CALL LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) CALL LonLat_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.0) .OR. (cooling_curvature_Cpm2 /= 0.0) END DO ! i = 1, numnod READ (21,*) numel ALLOCATE ( nodes(3,numel) ) DO i = 1, numel READ (21,*) j, nodes(1,i), nodes(2,i), nodes(3,i) END DO ! i = 1, numel READ (21,*) nfl ALLOCATE ( nodef(4,nfl) ) DO i = 1, nfl READ (21,*) j, nodef(1,i), nodef(2,i), nodef(3,i), nodef(4,i) END DO ! i = 1, nfl CLOSE(21) !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 Prompt_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 & acreep, alphat, bcreep, biot , & ! outputs... & byerly, ccreep, cfric , conduc, & & dcreep, ecreep, everyp, ffric , & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) 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.0) 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.0) 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.0) 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.0) 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 Prompt_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 Prompt_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 & names, mostInOnePlate, ndplat, nfl, nodef, nodes, & & nPlates, numel, numnod, & & omega, plat, plon, & & xnode, ynode, & & whichp) ! OUTPUT 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 !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 Prompt_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 Press_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 DO i = 1, numnod elevation = eqcm(1,i) heatflow = eqcm(2,i) crust_meters = eqcm(3,i) mantle_meters = eqcm(4,i) density_anomaly_kgpm3 = eqcm(5,i) cooling_curvature_Cpm2 = eqcm(6,i) geoth1 = tsurf geoth2 = heatflow / conduc(1) geoth3 = -0.5 * (radio(1) / conduc(1)) -0.5 * cooling_curvature_Cpm2 geoth4 = 0.0 geoth5 = geoth1 + geoth2 * crust_meters + geoth3 * crust_meters**2 geoth6 = ((heatflow - crust_meters * radio(1)) / conduc(2)) - cooling_curvature_Cpm2 * crust_meters geoth7 = -0.5 * (radio(2) / conduc(2)) -0.5 * cooling_curvature_Cpm2 geoth8 = 0.0 zMoho = crust_meters CALL Coupling (acreep,bcreep,ccreep,ecreep, & & geoth1,geoth2,geoth3,geoth4,geoth5,geoth6,geoth7,geoth8, & & gradie,onekm,tadiab, & & zbasth,zMoho, & ! inputs (scalars, two-vectors) & glue) ! output (a scalar) delta_v_mps = SQRT((vm(1,i)-vs(1,i))**2 + (vm(2,i)-vs(2,i))**2) IF (delta_v_mps > 0.0) THEN South_part = (vm(1,i)-vs(1,i)) / delta_v_mps East_part = (vm(2,i)-vs(2,i)) / delta_v_mps ELSE South_part = 0.0 East_part = 0.0 END IF traction_MPa(i) = 1.0E-6 * glue * delta_v_mps**ecreep traction_MPa(i) = MIN(traction_MPa(i), etamax * delta_v_mps) traction_MPa(i) = MIN(traction_MPa(i), trhmax*1.E-6) IF (iconve == 4) THEN continental = (elevation > -2500.0).AND.(heatflow < 0.150) IF (.NOT.continental) traction_MPa(i) = 0.0 END IF !redefine vm(2,numnod) as the traction vector (in MPa): vm(1,i) = South_part * traction_MPa(i) vm(2,i) = East_part * traction_MPa(i) END DO ! i = 1, numnod DEALLOCATE ( vs ) 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.0 ! 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 LonLat_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. vm(1,i) = 0. vm(2,i) = 0. ELSE ! no (extensive slab attached to this plate): IF (traction_pole_read(iplate)) THEN uvec(1) = SIN(xnode(i)) * COS(ynode(i)) ! xnode is theta in radians; ynode is phi. uvec(2) = SIN(xnode(i)) * SIN(ynode(i)) uvec(3) = COS(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 = SQRT(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.E6 ! from Pa to MPa !saved in 2-D (theta, phi) vector form for plotting, in array vm [kludge]. CALL Local_Theta(uvec, theta_uvec) vm(1,i) = (tvec(1) * theta_uvec(1) + tvec(2) * theta_uvec(2) + tvec(3) * theta_uvec(3)) / 1.E6 CALL Local_Phi(uvec, phi_uvec) vm(2,i) = (tvec(1) * phi_uvec(1) + tvec(2) * phi_uvec(2) + tvec(3) * phi_uvec(3)) / 1.E6 ELSE traction_MPa(i) = 0.0 vm(1,i) = 0.0 vm(2,i) = 0.0 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.0) traction_scale_MPa = (maximum + minimum)/2.0 CALL Prompt_for_Real('What typical traction (in MPa) should be shown in the margin?',traction_scale_MPa,traction_scale_MPa) IF (traction_scale_MPa <= 0.0) THEN WRITE(*,"(' Error: Please enter a positive number!')") mt_flashby = .FALSE. GO TO 2064 END IF 2065 CALL Prompt_for_Real('How long (in points) should this vector be plotted?',traction_scale_points,traction_scale_points) IF (traction_scale_points <= 0.0) THEN WRITE(*,"(' Error: Please enter a positive number!')") mt_flashby = .FALSE. GO TO 2065 END IF WRITE (*,"(/' There will be ',I7,' vectors plotted if they are not thinned.')") numnod 2066 CALL Prompt_for_Integer('What thinning factor ( >=1 ) do you want?',vector_thinner,vector_thinner) IF (vector_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") mt_flashby = .FALSE. GO TO 2066 END IF ALLOCATE ( selected(numnod) ) CALL Thin_on_Sphere (node_uvec, numnod, vector_thinner, selected) WRITE (*,"(/' Working on basal traction vectors....')") CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Begin_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 Velocity_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 End_Group CALL Chooser(bottom, right) IF (right) THEN CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'Shear traction') number8 = ADJUSTL(ASCII8(velocity_Ma)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 12., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'on model base') CALL Vector_in_Plane (level = 1, & & from_x = 0.5*(x1_points+x2_points-traction_scale_points), from_y = y2_points - 33., & & to_x = 0.5*(x1_points+x2_points+traction_scale_points), to_y = y2_points - 33.) number8 = ADJUSTL(ASCII8(traction_scale_Mpa)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 36., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(number8)//' MPa') CALL End_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 48. ELSE IF (bottom) THEN CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) + 12., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Shear traction') number8 = ADJUSTL(ASCII8(velocity_Ma)) CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'on model base') CALL Vector_in_Plane (level = 1, & & from_x = x1_points+29.-0.5*traction_scale_points, from_y = 0.5*(y1_points+y2_points)-10., & & to_x = x1_points+29.+0.5*traction_scale_points, to_y = 0.5*(y1_points+y2_points)-10.) number8 = ADJUSTL(ASCII8(traction_scale_MPa)) CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) - 24., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(number8)//' MPa') CALL End_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 58. 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 ( nodef, & & nodes, & & whichp,& ! N.B. Mosaic code left this in place, but overlay code should scratch it. & eqcm, & & ynode, & & xnode, & & node_uvec ) ! in LIFO order ! 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 Prompt_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 Press_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 LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod CLOSE(21) 2071 IF (.NOT.just_began_surface_flow) THEN temp_path_in = path_in CALL File_List( file_type = "v*.out", & & suggested_file = vel_file, & & using_path = temp_path_in) CALL Prompt_for_String('Which velocity file should be plotted?',vel_file,vel_file) END IF ! need to get vel_file vel_pathfile = TRIM(temp_path_in)//TRIM(vel_file) OPEN(UNIT = 22, FILE = vel_pathfile, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found.')") CLOSE (22) CALL Press_Enter just_began_surface_flow = .FALSE. ! must get file name mt_flashby = .FALSE. GO TO 2071 END IF DO i = 1, 3 READ (22,"(A)") line CALL Add_Title(line) END DO ! first 3 lines of velocity file READ (22,*) (vw(i), i = 1, (2*numnod)) CLOSE(22) IF (.NOT.just_began_surface_flow) THEN CALL Prompt_for_Logical('Do you wish to CHANGE the velocity reference frame?',velocity_reframe,velocity_reframe) END IF IF (velocity_reframe) THEN IF (.NOT.just_began_surface_flow) THEN 2072 CALL Prompt_for_Integer('Which node should be fixed?',fixed_node,fixed_node) IF ((fixed_node < 1).OR.(fixed_node > numnod)) THEN WRITE (*,"(' ERROR: Illegal node number!')") mt_flashby = .FALSE. GO TO 2072 END IF ! illegal fixed_node 2073 CALL Prompt_for_Integer('Which OTHER node should be prevented from rotating about the first?',nonorbiting_node,nonorbiting_node) IF ((nonorbiting_node < 1).OR.(nonorbiting_node > numnod).OR.(nonorbiting_node == fixed_node)) THEN WRITE (*,"(' ERROR: Illegal node number!')") mt_flashby = .FALSE. GO TO 2073 END IF ! illegal nonorbiting_node END IF WRITE (number8, "(I8)") fixed_node 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. * sec_per_year * SQRT(v_South_mps**2 + v_East_mps**2) END DO ! i = 1, numnod WRITE (*,"(/' Here is the distribution of velocities (in mm/a):')") CALL Histogram (vsize_mma, numnod, .FALSE., maximum, minimum) CALL Prompt_for_Real('For how many Ma should velocity be projected?',velocity_Ma,velocity_Ma) WRITE (*,"(/' There will be ',I7,' vectors plotted if they are not thinned.')") numnod 2074 CALL Prompt_for_Integer('What thinning factor ( >=1 ) do you want?',vector_thinner,vector_thinner) IF (vector_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") mt_flashby = .FALSE. GO TO 2074 END IF IF (vector_thinner > 1) THEN WRITE(string10,"(I10)") vector_thinner CALL Add_Title('(1/'//TRIM(ADJUSTL(string10))//') of Velocity Vectors') ELSE ! == 1 CALL Add_Title('Velocity Vectors') END IF CALL Thin_on_Sphere (node_uvec, numnod, vector_thinner, selected) WRITE (*,"(/' Working on velocity vectors....')") CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Begin_Group DO i = 1, numnod IF (selected(i)) THEN uvec1(1:3) = node_uvec(1:3,i) v_South_mps = vw(2*i-1) v_East_mps = vw(2*i) CALL Velocity_Vector_on_Sphere (from_uvec = uvec1, & & v_theta_mps = v_South_mps, v_phi_mps = v_East_mps, & & dt_sec = velocity_Ma * 1.E6 * sec_per_year, deflate = .TRUE.) END IF ! selected END DO ! actually plotting velocity vectors CALL End_Group DEALLOCATE ( vsize_mma, vw, selected, node_uvec) ! LIFO order CALL 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 Prompt_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 Press_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 LonLat_2_Uvec (lon, lat, uvec1) benchmark_uvec(1:3, i) = uvec1(1:3) benchmark_hypotenuse(i) = SQRT(benchmark_N_velocity(i)**2 + & & benchmark_E_velocity(i)**2) 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 = L5_In_Window(uvec) IF (visible) THEN k = k + 1 train(k) = benchmark_hypotenuse(i) END IF END DO WRITE (*,"(/' Here is the distribution of visible velocities (in mm/a):')") CALL Histogram (train, k, .FALSE., maximum, minimum) DEALLOCATE ( train ) CALL Prompt_for_Real('For how many Ma should velocity be projected?',velocity_Ma,velocity_Ma) CALL Prompt_for_Real('How large (in points) should benchmark locations be plotted?',benchmark_points,benchmark_points) WRITE (*,"(/' Working on benchmark velocity vectors....')") CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) !create group of error ellipses: ellipses = .FALSE. ! usually reversed by any finite ellipse, below CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') t = (velocity_Ma * 1.0E6) * 0.001 / mp_radius_meters ! arc-radians per (mm/a) IF (velocity_Ma /= 0.0) THEN CALL Begin_Group DO i = 1, benchmarks IF ((benchmark_N_sigma(i) > 0.0).AND.(benchmark_E_sigma(i) > 0.0)) THEN ellipses = .TRUE. uvec1(1:3) = benchmark_uvec(1:3,i) !locate head of vector, to be center of ellipse: az1 = ATAN2F(benchmark_E_velocity(i),benchmark_N_velocity(i)) t1 = t * Conformal_Deflation (uvec1) ! arc-radians per (mm/a) CALL Turn_To (azimuth_radians = az1, base_uvec = uvec1, far_radians = t1 * benchmark_hypotenuse(i), & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec) t1 = t * Conformal_Deflation (uvec) ! arc-radians per (mm/a) !find rotation principal axes of ellipse: covariance_11 = benchmark_E_sigma(i)**2 covariance_22 = benchmark_N_sigma(i)**2 covariance_12 = benchmark_N_sigma(i) * benchmark_E_sigma(i) * benchmark_correlation(i) CALL Principal_Axes_22 (covariance_11, covariance_12, covariance_22, & & e1, e2, u1x,u1y, u2x,u2y) e1 = 1.96 * SQRT(e1) e2 = 1.96 * SQRT(e2) ! back into units of mm/a, but now amplified by *1.96, to convert from 1-sigma to 95%-confidence start_azimuth = Pi_over_2 - ATAN2F(u1y,u1x) ! smallest axis, in radians clockwise from North !find initial point at top of ellipse: CALL Turn_To (azimuth_radians = start_azimuth, base_uvec = uvec, far_radians = t1 * e1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL New_L45_Path (5, uvec1) ! beginning (e1 axis) of ellipse DO j = 1, 12 ! 12 30-degree sectors, counterclockwise from e1 axis: rel_az2 = -(j - 0.5) * 30.0 * rad_per_deg ! mid-point; relative to e1 axis rel_az3 = -j * 30.0 * rad_per_deg ! end-point; relative to e1 axis az2 = start_azimuth + rel_az2 ! mid-point, in radians clockwise from N az3 = start_azimuth + rel_az3 ! end-point, in radians clockwise from N ds2 = COS(rel_az2) * t1 * e1 ! arc-radians dl2 = SIN(rel_az2) * t1 * e2 arc2 = SQRT(ds2**2 + dl2**2) aze2 = start_azimuth + ATAN2F(dl2,ds2) CALL Turn_To (azimuth_radians = aze2, base_uvec = uvec, far_radians = arc2, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) ds3 = COS(rel_az3) * t1 * e1 ! arc-radians dl3 = SIN(rel_az3) * t1 * e2 arc3 = SQRT(ds3**2 + dl3**2) aze3 = start_azimuth + ATAN2F(dl3,ds3) CALL Turn_To (azimuth_radians = aze3, base_uvec = uvec, far_radians = arc3, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL Small_Through_L45 (uvec2, uvec3) ! through uvec2 to uvec3 END DO ! j = 1, 12 ! 30-degree sectors forming a circle CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF ! ellipise has positive dimensions END DO ! i = 1, benchmarks CALL End_Group ! of error ellipses END IF ! velocity_Ma /= 0.0 !create group of benchmarks: IF (benchmark_points > 0.0) THEN CALL Set_Stroke_Color ('foreground') t = 0.6667 * mp_meters_per_point * benchmark_points / mp_radius_meters CALL Begin_Group ! of benchmark triangles DO i = 1, benchmarks uvec(1:3) = benchmark_uvec(1:3,i) t1 = t * Conformal_Deflation (uvec) CALL Turn_To (azimuth_radians = 0.0, base_uvec = uvec, far_radians = t1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL New_L45_Path (5, uvec1) CALL Turn_To (azimuth_radians = 4.188, base_uvec = uvec, far_radians = t1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL Great_To_L45 (uvec2) CALL Turn_To (azimuth_radians = 2.094, base_uvec = uvec, far_radians = t1, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec3) CALL Great_To_L45 (uvec3) CALL Great_To_L45 (uvec1) CALL End_L45_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END DO ! i = 1, benchmarks CALL End_Group ! of benchmark triangles END IF ! benchmark_points > 0.0 !create group of velocity vectors: IF (velocity_Ma /= 0.0) THEN CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) IF (ai_using_color) THEN CALL Set_Stroke_Color ('red_______') ELSE CALL Set_Stroke_Color ('foreground') END IF CALL Begin_Group DO i = 1, benchmarks uvec1(1:3) = benchmark_uvec(1:3,i) v_South_mps = -0.001 * benchmark_N_velocity(i) / sec_per_year v_East_mps = +0.001 * benchmark_E_velocity(i) / sec_per_year CALL Velocity_Vector_on_Sphere (from_uvec = uvec1, & & v_theta_mps = v_South_mps, v_phi_mps = v_East_mps, & & dt_sec = velocity_Ma * 1.E6 * sec_per_year, deflate = .TRUE.) END DO ! actually plotting benchmark velocity vectors CALL End_Group END IF ! velocity_Ma /= 0.0 IF (ai_using_color) CALL Set_Stroke_Color ('foreground') CALL Chooser(bottom, right) IF (right) THEN CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'Geodetic') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 12.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'Velocity') number8 = ADJUSTL(ASCII8(velocity_Ma)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 24.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(x '//TRIM(number8)//' Ma):') x0p = 0.5 * (x1_points + x2_points) - 14.17 x1p = x0p + 2 * 14.17 ! 1-cm-long vector, expressed in points y0p = y2_points - 47.0 CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') IF (ellipses) THEN CALL Circle_on_L12 (level = 1, x = x1p, y = y0p, radius = 6.0, stroke = .TRUE., fill = .FALSE.) END IF IF (benchmark_points > 0.0) THEN CALL New_L12_Path (1, x0p, y0p + 0.6667 * benchmark_points) CALL Line_to_L12 (x0p - 0.577 * benchmark_points, y0p - 0.333 * benchmark_points) CALL Line_to_L12 (x0p + 0.577 * benchmark_points, y0p - 0.333 * benchmark_points) CALL Line_to_L12 (x0p, y0p + 0.6667 * benchmark_points) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) IF (ai_using_color) CALL Set_Stroke_Color ('red_______') CALL Vector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = x0p, from_y = y0p, & & to_x = x1p, to_y = y0p) IF (ai_using_color) CALL Set_Stroke_Color ('foreground') v_mps = 0.01 * mp_scale_denominator / (velocity_Ma * 1.E6 * sec_per_year) v_mma = v_mps * 1000. * sec_per_year number8 = ADJUSTL(ASCII8(v_mma)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 48., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(number8)//' mm/a') IF (ellipses) THEN CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 60., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = "(95%-c.") CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 72., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = "ellipse)") END IF ! ellipses CALL End_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 60.0 IF (ellipses) rightlegend_used_points = rightlegend_used_points + 24.0 ! for "(95%-c./ellipse)" ELSE IF (bottom) THEN CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) + 12.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'GPS velocity') number8 = ADJUSTL(ASCII8(velocity_Ma)) CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = '(x '//TRIM(number8)//' Ma):') x0p = (x1_points + 29.0) - 14.17 x1p = x0p + 2 * 14.17 ! 1-cm-long vector, expressed in points y0p = 0.5 * (y1_points + y2_points) - 10.0 CALL Set_Line_Style (width_points = 1.0, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') IF (ellipses) THEN CALL Circle_on_L12 (level = 1, x = x1p, y = y0p, radius = 6.0, stroke = .TRUE., fill = .FALSE.) CALL L12_Text (level = 1, & & x_points = x1p + 9., & & y_points = y0p, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = '95%-c.') END IF IF (benchmark_points > 0.0) THEN CALL New_L12_Path (1, x0p, y0p + 0.6667 * benchmark_points) CALL Line_to_L12 (x0p - 0.577 * benchmark_points, y0p - 0.333 * benchmark_points) CALL Line_to_L12 (x0p + 0.577 * benchmark_points, y0p - 0.333 * benchmark_points) CALL Line_to_L12 (x0p, y0p + 0.6667 * benchmark_points) CALL End_L12_Path (close = .TRUE., stroke = .TRUE., fill = .FALSE.) END IF CALL Set_Line_Style (width_points = 1.5, dashed = .FALSE.) IF (ai_using_color) CALL Set_Stroke_Color ('red_______') CALL Vector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = x0p, from_y = y0p, & & to_x = x1p, to_y = y0p) IF (ai_using_color) CALL Set_Stroke_Color ('foreground') v_mps = 0.01 * mp_scale_denominator / (velocity_Ma * 1.E6 * sec_per_year) v_mma = v_mps * 1000. * sec_per_year number8 = ADJUSTL(ASCII8(v_mma)) CALL L12_Text (level = 1, & & x_points = x1_points + 29., & & y_points = 0.5*(y1_points + y2_points) - 24., & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(number8)//' mm/a') CALL End_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 58. IF (ellipses) rightlegend_used_points = rightlegend_used_points + 36. ! 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 Prompt_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 Press_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 LonLat_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 ( fazim(2,nfl) ) ALLOCATE ( slipnumber(nfl) ) ALLOCATE ( up_azim_rads(nfl) ) ALLOCATE ( plot_at_uvec(3,nfl) ) DO i = 1, nfl READ (21,*) j, nodef(1,i), nodef(2,i), nodef(3,i), nodef(4,i), & & fdip(1,i), fdip(2,i) END DO ! i = 1, nfl CLOSE (21) 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 Prompt_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 Press_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 Prompt_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 Prompt_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.0 CALL Begin_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 Make_Uvec(uvec3, uvec4) ! uvec4 is midpoint v1E_mma = 1000. * sec_per_year * vw(2*nodef(1,i)) v2E_mma = 1000. * sec_per_year * vw(2*nodef(2,i)) v3E_mma = 1000. * sec_per_year * vw(2*nodef(3,i)) v4E_mma = 1000. * sec_per_year * vw(2*nodef(4,i)) v1S_mma = 1000. * sec_per_year * vw(2*nodef(1,i)-1) v2S_mma = 1000. * sec_per_year * vw(2*nodef(2,i)-1) v3S_mma = 1000. * sec_per_year * vw(2*nodef(3,i)-1) v4S_mma = 1000. * 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 = Compass(uvec4, uvec2) open1 = (v1E_mma - v4E_mma)*COS(f_azim_rads_1) + & & (v1S_mma - v4S_mma)*SIN(f_azim_rads_1) open2 = (v2E_mma - v3E_mma)*COS(f_azim_rads_2) + & & (v2S_mma - v3S_mma)*SIN(f_azim_rads_2) dextral1 = (v1S_mma - v4S_mma)*COS(f_azim_rads_1) + & & (v4E_mma - v1E_mma)*SIN(f_azim_rads_1) dextral2 = (v2S_mma - v3S_mma)*COS(f_azim_rads_2) + & & (v3E_mma - v2E_mma)*SIN(f_azim_rads_2) IF (ABS(fdip(1,i)) <= 75.) THEN vertical1 = open1 * TAN(ABS(fdip(1,i))*radians_per_degree) ELSE ! vertical fault vertical1 = 0.0 END IF IF (ABS(fdip(2,i)) <= 75.) THEN vertical2 = open2 * TAN(ABS(fdip(2,i))*radians_per_degree) ELSE ! vertical fault vertical2 = 0.0 END IF IF ((ABS(fdip(1,i)) > 75.).AND.(ABS(fdip(2,i)) > 75.)) THEN !for vertical fault only, consider reversing direction! test = 0.7071 * COS(f_azim_rads_c) + (-0.7071) * SIN(f_azim_rads_c) ! note that test is > 0. when fault trends NW; this puts number label upside-down IF (test > 0.) 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 = SQRT(open1**2 + vertical1**2) dipslip2 = SQRT(open2**2 + vertical2**2) IF (choice == 9) THEN ! horizontal only sliprate1 = SQRT(dextral1**2 + open1**2) sliprate2 = SQRT(dextral2**2 + open2**2) ELSE IF (choice == 10) THEN ! 3-D sliprate sliprate1 = SQRT(dextral1**2 + dipslip1**2) sliprate2 = SQRT(dextral2**2 + dipslip2**2) END IF ! choice == 9 or 10 slipnumber(i) = (sliprate1 + sliprate2)/2. ! store for plotting # later! sup_slipnumber = MAX(sup_slipnumber, slipnumber(i)) IF (fdip(1,i) >= 0.) THEN x_azim_rads_1 = f_azim_rads_1 - Pi/2. up_azim_rads(i) = f_azim_rads_c - Pi/2. ! store for plotting # later! x_azim_rads_2 = f_azim_rads_2 - Pi/2. ELSE ! negative fdip means dipping from N3-N4 side. x_azim_rads_1 = f_azim_rads_1 + Pi/2. up_azim_rads(i) = f_azim_rads_c + Pi/2. x_azim_rads_2 = f_azim_rads_2 + Pi/2. END IF offset_radians = velocity_Ma * slipnumber(i) * 1000. / R CALL Turn_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. / R CALL Turn_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. / R CALL Turn_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.) THEN color_name = 'bronze____' ELSE ! thrust color_name = 'mid_blue__' END IF ! normal or thrust ELSE ! strike-slip colors IF ((dextral1 + dextral2) > 0.) THEN color_name = 'green_____' ELSE ! sinistral color_name = 'brown_____' END IF ! dextral or sinistral END IF !dipslip or strike-slip colors CALL Set_Fill_or_Pattern (.FALSE., color_name) CALL New_L45_Path (5, uvec1) CALL Great_to_L45(uvec2) CALL Great_to_L45(uvec3) CALL Great_to_L45(uvec4) CALL Great_to_L45(uvec1) CALL End_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) ELSE ! b/w plot CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL New_L45_Path (5, uvec4) CALL Great_to_L45(uvec3) CALL End_L45_Path (close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = 0, 6 ! 7 lines per fault element s = j/6.0 CALL GreatCircle_Point (from_uvec = uvec4, & & to_uvec = uvec3, s = s, & ! inputs & point_uvec = uvec5, azimuth_radians = t) ! outputs CALL GreatCircle_Point (from_uvec = uvec1, & & to_uvec = uvec2, s = s, & ! inputs & point_uvec = uvec6, azimuth_radians = t) ! outputs CALL New_L45_Path (5, uvec5) CALL Great_to_L45(uvec6) CALL End_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 End_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 plotted if they are not thinned.')") nfl 2092 CALL Prompt_for_Integer('What thinning factor ( >=1 ) do you want?',label_thinner,label_thinner) IF (label_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") mt_flashby = .FALSE. GO TO 2092 END IF CALL Thin_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 Begin_Group ! of rate numbers CALL Set_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 L5_Text (uvec = uvec1, angle_radians = -up_azim_rads(i), from_east = .TRUE., & & font_points = 10, lr_fraction = 0.5, ud_fraction = -0.2, & & text = ADJUSTL(ASCII8(slipnumber(i)))) END IF ! FEP selection END IF ! selected(i) END DO ! i = 1, nfl CALL End_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 ( nodef ) CALL Chooser (bottom, right) CALL Begin_Group ! sample sliprates ! how fast is a 20-point band, in mm/a? sliprate1 = (((20./2834.)/1000.)*mp_scale_denominator)/velocity_Ma ! ( bandwidth, in km, on Earth ) CALL Set_Fill_or_Pattern(.FALSE., 'foreground') IF (right) THEN CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points xcp = (x1_points + x2_points)/2. CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(ADJUSTL(ASCII8(sliprate1)))//' mm/a') 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., & & color_name = 'bronze____', text = 'normal') CALL DipTick_in_Plane (level = 1, x = xcp, y = y2_points-32., & & dip_angle_radians = -Pi/2., & & style_byte = 'N', size_points = 6.0, offset_points = 0.0) CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-62., & & color_name = 'mid_blue__', text = 'thrust') CALL DipTick_in_Plane (level = 1, x = xcp, y = y2_points-62., & & dip_angle_radians = -Pi/2., & & style_byte = 'T', size_points = 6.0, offset_points = 0.0) CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-92., & & color_name = 'green_____', text = 'dextral') CALL Slip_Sample(x_center_points = xcp, y_base_points = y2_points-122., & & color_name = 'brown_____', text = 'sinistral') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 122. ELSE ! b/w CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL New_L12_Path(1, xcp-31., y2_points-12.) CALL Line_to_L12(xcp+31., y2_points-12.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = -30,30,6 CALL New_L12_Path(1, xcp+j, y2_points-12.) CALL Line_to_L12(xcp+j, y2_points-32.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! vertical stripes CALL Set_Line_Style (width_points = 2.0, dashed = .FALSE.) CALL New_L12_Path(1, xcp-31., y2_points-32.) CALL Line_to_L12(xcp+31., y2_points-32.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 32. END IF ! color or b/w CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points IF (choice == 9) THEN ! delta Vh CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Horizontal') CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'part of') CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-30., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'slip rate') rightlegend_used_points = rightlegend_used_points + 30. ELSE IF (choice == 10) THEN ! 3-D sliprate CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Slip rate') rightlegend_used_points = rightlegend_used_points + 10. END IF ! choice == 9 or 10 ELSE ! bottom CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points)/2. IF (choice == 9) THEN ! delta Vh CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp+10., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'Horizontal') CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp, angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'part of') CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp-10., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'slip rate:') ELSE IF (choice == 10) THEN ! 3-D sliprate CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp, angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'Slip rate:') END IF ! choice == 9 or 10 bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72. CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points !each sample: 5 pt gap + 62 pt wide + 5 pt gap = 72 pt CALL L12_Text (level = 1, x_points = x1_points+36., & & y_points = ycp+12., angle_radians = 0.0, & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(ADJUSTL(ASCII8(sliprate1)))//' mm/a') IF (ai_using_color) THEN CALL Slip_Sample(x_center_points = x1_points+36., y_base_points = ycp-10., & & color_name = 'bronze____', text = 'normal') CALL DipTick_in_Plane (level = 1, x = x1_points+36., y = ycp-10., & & dip_angle_radians = -Pi/2., & & style_byte = 'N', size_points = 6.0, offset_points = 0.0) CALL Slip_Sample(x_center_points = x1_points+108., y_base_points = ycp-10., & & color_name = 'mid_blue__', text = 'thrust') CALL DipTick_in_Plane (level = 1, x = x1_points+108., y = ycp-10., & & dip_angle_radians = -Pi/2., & & style_byte = 'T', size_points = 6.0, offset_points = 0.0) CALL Slip_Sample(x_center_points = x1_points+180., y_base_points = ycp-10., & & color_name = 'green_____', text = 'dextral') CALL Slip_Sample(x_center_points = x1_points+252., y_base_points = ycp-10., & & color_name = 'brown_____', text = 'sinistral') bottomlegend_used_points = bottomlegend_used_points + 288. ELSE ! b/w CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL New_L12_Path(1, x1_points+5., ycp+10.) CALL Line_to_L12(x1_points+67., ycp+10.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) DO j = -30,30,6 CALL New_L12_Path(1, x1_points+36.+j, ycp+10.) CALL Line_to_L12(x1_points+36.+j, ycp-10.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) END DO ! vertical stripes CALL Set_Line_Style (width_points = 2.0, dashed = .FALSE.) CALL New_L12_Path(1, x1_points+5., ycp-10.) CALL Line_to_L12(x1_points+67., ycp-10.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) bottomlegend_used_points = bottomlegend_used_points + 72. END IF ! color or b/w END IF ! right or bottom CALL End_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 Prompt_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 LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( e3_minus_e1_persec(numel) ) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( selected(numel) ) ALLOCATE ( strainrate(3, 7, numel) ) ALLOCATE ( uvec_list(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter just_began_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 Prompt_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 Press_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 Make_Uvec (uvec4, uvec) ! center of element IF (m == 1) uvec_list(1:3, l_) = uvec(1:3) equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF theta_ = ATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) strainrate(1:3, m, l_) = eps_dot(1:3) END DO ! m = 1, 7 END DO ! l_ = 1, numel, computing strainrates !convert to scalar measure, for histogram DO i = 1, numel ! compute 3 principal values, and partition one with unique sign CALL Principal_Axes_22 (strainrate(1,1,i),strainrate(2,1,i),strainrate(3,1,i), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) err = -(e1h + e2h) ! Decide which principal strain(-rate) is partitioned: e1h_partitioned = (e1h /= 0.).AND.((e1h*e2h) <= 0.).AND.((e1h*err) <= 0.) e2h_partitioned = (e2h /= 0.).AND.((e2h*e1h) <= 0.).AND.((e2h*err) <= 0.) err_partitioned = (err /= 0.).AND.((err*e1h) <= 0.).AND.((err*e2h) <= 0.) ! Decide how big largest symbol is (in terms of partitioned e3-e1). big_diff = 0. IF (e1h*e2h < 0.) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(e2h)) ELSE big_diff = MAX(big_diff, 2.*ABS(e1h)) END IF END IF IF (e1h*err < 0.) THEN IF (e1h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(err)) ELSE big_diff = MAX(big_diff, 2.*ABS(e1h)) END IF END IF IF (e2h*err < 0.) THEN IF (e2h_partitioned) THEN big_diff = MAX(big_diff, 2.*ABS(err)) ELSE big_diff = MAX(big_diff, 2.*ABS(e2h)) END IF END IF e3_minus_e1_persec(i) = big_diff END DO WRITE (*, "(/ & & ' Available modes for plotting strain-rate are:'/ & & ' 0 : All symbols are the same size (for legibility).'/ & & ' 1 : Symbol diameter is linearly proportional to strain-rate.'/ & & ' 2 : Symbol area (diameter**2) is proportional to strain-rate.')") CALL Prompt_for_Integer('Which mode do you want?',strainrate_mode012,strainrate_mode012) IF (strainrate_mode012 == 0) THEN CALL Prompt_for_Real('What diameter should the symbols be, in points?',strainrate_diameter_points,strainrate_diameter_points) ELSE WRITE (*,"(/' Here is the distribution of differential strain-rates' & & /' (e3 - e1) across the elements (in /s):')") CALL Histogram (e3_minus_e1_persec, numel, .FALSE., maximum, minimum) IF (ref_e3_minus_e1_persec <= 0.0) ref_e3_minus_e1_persec = maximum CALL Prompt_for_Real('What is the reference strain-rate, in /s?',ref_e3_minus_e1_persec,ref_e3_minus_e1_persec) CALL Prompt_for_Real('What diameter should the reference strain-rate have, in points?',strainrate_diameter_points,strainrate_diameter_points) END IF WRITE (*,"(/' There will be ',I7,' tensors plotted if they are not thinned.')") numel 2112 CALL Prompt_for_Integer('What thinning factor ( >=1 ) do you want?',strain_thinner,strain_thinner) IF (strain_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") mt_flashby = .FALSE. GO TO 2112 END IF IF (strain_thinner > 1) THEN WRITE(string10,"(I10)") strain_thinner CALL Add_Title('(1/'//TRIM(ADJUSTL(string10))//') of 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 Thin_on_Sphere (uvec_list, numel, strain_thinner, selected) CALL Begin_Group ! of strain-rates CALL Set_Stroke_Color ('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells DO i = 1, numel IF (selected(i)) THEN uvec(1:3) = uvec_list(1:3, i) CALL Strain_on_Sphere (uvec, & & strainrate(1,1,i), strainrate(2,1,i), strainrate(3,1,i), & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) END IF ! selected END DO ! i = 1, numel CALL End_Group ! of strain-rate tensors CALL Chooser (bottom, right) IF (right) THEN ! sample strain-rate in rightlegend CALL Begin_Group ! text part of strain-rate in legend; begin with a gap rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points ! y2 is top of next text line CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'Strain-rate of') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'continuum, as') rightlegend_used_points = rightlegend_used_points + 20. y2_points = y2_points - 20. CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'conjugate') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'microfaults:') rightlegend_used_points = rightlegend_used_points + 25. ! 5 points extra for minigap y2_points = y2_points - 25. ! symbol part of paleostress in legend; CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL Strain_in_Plane (1, 0.8*x1_points + 0.2*x2_points, & & y2_points - 0.5*strainrate_diameter_points , & & -0.5*ref_e3_minus_e1_persec, 0., 0., & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL Strain_in_Plane (1, 0.5*x1_points + 0.5*x2_points, & & y2_points - 0.5*strainrate_diameter_points , & & 0.5*ref_e3_minus_e1_persec, 0., -0.5*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL Strain_in_Plane (1, 0.2*x1_points + 0.8*x2_points, & & y2_points - 0.5*strainrate_diameter_points , & & 0.5*ref_e3_minus_e1_persec, 0., 0., & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) rightlegend_used_points = rightlegend_used_points + strainrate_diameter_points y2_points = y2_points - strainrate_diameter_points IF (strainrate_mode012 > 0) THEN ! label with e3-e1 = # CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'E3 - E1 =') number8 = ASCII8(ref_e3_minus_e1_persec) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(Diameter') ELSE ! mode012 = 2 CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(Area is') END IF ! mode 1 or 2 CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 30., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'proportional to') rightlegend_used_points = rightlegend_used_points + 40. y2_points = y2_points - 40. ELSE ! all symbols are of equal size CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = '(Size is') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'independent of') rightlegend_used_points = rightlegend_used_points + 20. y2_points = y2_points - 20. END IF ! labelling with numerical strainrate, or not CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'strain-rate.)') rightlegend_used_points = rightlegend_used_points + 10. y2_points = y2_points - 10. CALL End_Group ELSE IF (bottom) THEN ! sample strain-rate in bottomlegend CALL Begin_Group ! text part of strain-rate in legend; begin with a gap CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Strain-rate of') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'continuum, as') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'conjugate') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) -20., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'microfaults:') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 72. ! text1 only ! symbol part of paleostress in legend; CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Set_Fill_or_Pattern (.FALSE., 'foreground') ! for dumbells ! vertical thrust bar on left: CALL Strain_in_Plane (1, x1_points + 14., & & 0.5*(y1_points + y2_points), & & -0.5*ref_e3_minus_e1_persec, 0., 0., & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! X for strike-slip in center CALL Strain_in_Plane (1, x1_points + 36., & & 0.5*(y1_points + y2_points), & & 0.5*ref_e3_minus_e1_persec, 0., -0.5*ref_e3_minus_e1_persec, & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) ! vertical graben symbol on right: CALL Strain_in_Plane (1, x1_points + 58., & & 0.5*(y1_points + y2_points) , & & 0.5*ref_e3_minus_e1_persec, 0., 0., & & ref_e3_minus_e1_persec, strainrate_diameter_points, & & strainrate_mode012) bottomlegend_used_points = bottomlegend_used_points + 72. ! now, including middle symbols block x1_points = x1_points + 72. !note that x1_points now indicates right side of middle symbol block IF (strainrate_mode012 > 0) THEN ! label with e3-e1 = # CALL L12_Text (level = 1, & & x_points = x1_points - 36., & & y_points = y1_points + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'E3 - E1 =') number8 = ASCII8(ref_e3_minus_e1_persec) CALL L12_Text (level = 1, & & x_points = x1_points - 36., & & y_points = y1_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = TRIM(ADJUSTL(number8)) // ' /s') IF (strainrate_mode012 == 1) THEN CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = '(Diameter') ELSE ! mode012 = 2 CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = '(Area is') END IF ! mode 1 or 2 CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = 'proportional to') ELSE ! all symbols are of equal size CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) + 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = '(Size is') CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = 'independent of') END IF ! labelling with numerical strainrate, or not CALL L12_Text (level = 1, & & x_points = x1_points + 36., & & y_points = 0.5*(y1_points + y2_points) - 10., & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.5, & & text = 'strain-rate.)') CALL End_Group bottomlegend_used_points = bottomlegend_used_points + 72. ! right text block END IF ! sample strain-rate in bottom/right legend WRITE (*,"('+Working on strain-rates....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( e3_minus_e1_persec, & & node_uvec, & & nodes, & & selected, strainrate, & & uvec_list, 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 Prompt_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.0 cooling_curvature_Cpm2 = 0.0 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 LonLat_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.0) .OR. (cooling_curvature_Cpm2 /= 0.0) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( strainrate(3, 7, numel) ) ! 3 components; 7 integration points DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. GO TO 2120 END IF CLOSE (21) 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 Prompt_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 Press_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 Make_Uvec (uvec4, uvec) ! integration point equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP ' ' END IF theta_ = ATAN2(equat, uvec(3)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) strainrate(1:3, m, l_) = eps_dot(1:3) END DO ! m = 1, 7 END DO ! l_ = 1, numel, computing strainrates !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 Prompt_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 & acreep, alphat, bcreep, biot , & ! outputs... & byerly, ccreep, cfric , conduc, & & dcreep, ecreep, everyp, ffric , & & gmean , gradie, iconve, ipvref, & & maxitr, okdelv, oktoqt, onekm, & & radio, refstr, rhoast, rhobar, & & rhoh2o, tadiab, taumax, temlim, & & title3, trhmax, tsurf, vtimes, & & zbasth) 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 Make_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.E3 !Non-controversial geotherm coefficients: geoth1 = tsurf geoth2 = heatflow / conduc(1) geoth3 = -0.5 * radio(1) / conduc(1) geoth4 = 0.0 geoth7 = -0.5 * radio(2) / conduc(2) geoth8 = 0.0 !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.0) 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.0 * 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. * geoth3 * crust_meters + 3. * 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.0 ! 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 Principal_Axes_22 (e11, e12, e22, & & e1, e2, u1x,u1y, u2x,u2y) azimuth(i) = Pi - ATAN2F(u1y, u1x) ! save for plotting, below IF ((e1 == 0.0).AND.(e2 == 0.0)) 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.0) THEN pl0 = 0.0 ! same approximation as in VISCOS; pw0 = 0.0 ! ocean not important since it affects both equally zoftop = 0.0 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) t1 = t1 + pt1 t2 = t2 + pt2 END IF ! crust_meters > 0 IF (mantle_meters > 0.0) THEN zoftop = crust_meters pw0 = rhoh2o * gmean * crust_meters t_mean = geoth1 + & & 0.5 * geoth2 * crust_meters + & & 0.333 * geoth3 * crust_meters**2 + & & 0.25 * geoth4 * crust_meters**3 rho_use = rhobar(1) * (1.0 - 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) 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 Prompt_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.0) tau_integral_scale_Npm = (maximum + minimum)/2.0 CALL Prompt_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.0) THEN WRITE(*,"(' Error: Please enter a positive number!')") mt_flashby = .FALSE. GO TO 2123 END IF 2124 CALL Prompt_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.0) THEN WRITE(*,"(' Error: Please enter a positive number!')") mt_flashby = .FALSE. GO TO 2124 END IF WRITE (*,"(/' There will be ',I7,' tensors plotted if they are not thinned.')") numel 2125 CALL Prompt_for_Integer('What thinning factor ( >=1 ) do you want?',stress_thinner,stress_thinner) IF (stress_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") 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 Thin_on_Sphere (uvec_list, numel, stress_thinner, selected) WRITE (*,"(/' Working on vertical integral of stress anomaly tensors....')") CALL Set_Line_Style (width_points = 0.5, dashed = .FALSE.) CALL Set_Stroke_Color ('foreground') CALL Begin_Group DO i = 1, numel IF (selected(i)) THEN uvec(1:3) = uvec_list(1:3,i) CALL Stress_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 End_Group DEALLOCATE ( selected ) CALL Chooser(bottom, right) IF (right) THEN CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'Vertical Integral') CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 12.0, & & angle_radians = 0., & & font_points = 10, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = 'of Stress Anomaly') CALL Stress_in_Plane (level = 1, & & x = 0.5*(x1_points + x2_points), & & y = y2_points - 24.0 - 0.5 * tau_integral_scale_points, & & s11 = -tau_integral_scale_Npm, & & s12 = 0.0, & & 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(ASCII8(tau_integral_scale_Npm)) CALL L12_Text (level = 1, & & x_points = 0.5*(x1_points + x2_points), & & y_points = y2_points - 24.0 - tau_integral_scale_points, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 1.0, & & text = TRIM(number8) // ' ' // TRIM(stress_integral_units)) CALL End_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 36.0 + tau_integral_scale_points ELSE IF (bottom) THEN CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL Begin_Group CALL Set_Fill_or_Pattern (.FALSE., 'foreground') CALL L12_Text (level = 1, & & x_points = x1_points + 50.0, & & y_points = 0.5*(y1_points + y2_points) + 12.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.4, & & text = 'Vertical Integral of') CALL L12_Text (level = 1, & & x_points = x1_points + 50.0, & & y_points = 0.5*(y1_points + y2_points), & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.4, & & text = 'Stress Anomaly:') number8 = ADJUSTL(ASCII8(tau_integral_scale_Npm)) CALL L12_Text (level = 1, & & x_points = x1_points + 50.0, & & y_points = 0.5*(y1_points + y2_points) - 12.0, & & angle_radians = 0., & & font_points = 12, & & lr_fraction = 0.5, ud_fraction = 0.4, & & text = TRIM(number8) // ' ' // TRIM(stress_integral_units)) CALL Stress_in_Plane (level = 1, & & x = x1_points + 100.0 + 0.5 * tau_integral_scale_points, & & y = 0.5 * (y1_points + y2_points), & & s11 = -tau_integral_scale_Npm, & & s12 = 0.0, & & 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 Stress_in_Plane (level = 1, & & x = x1_points + 106.0 + 1.5 * tau_integral_scale_points, & & y = 0.5 * (y1_points + y2_points), & & s11 = +tau_integral_scale_Npm, & & s12 = 0.0, & & 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 End_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 106.0 + 2.0 * tau_integral_scale_points END IF ! bottom or right legend WRITE (*,"('+Working on vertical integral of stress anomaly tensors....DONE.')") DEALLOCATE ( uvec_list ) ! in FIFO order DEALLOCATE ( largest_axis ) DEALLOCATE ( azimuth ) DEALLOCATE ( tau_integral ) DEALLOCATE ( strainrate ) DEALLOCATE ( nodes ) DEALLOCATE ( eqcm ) DEALLOCATE ( vw ) DEALLOCATE ( node_uvec ) ! in LIFO order ! 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 Prompt_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 LonLat_2_Uvec (lon, lat, uvec1) node_uvec(1:3,i) = uvec1(1:3) END DO ! i = 1, numnod READ (21, *, IOSTAT = ios) numel problem = problem .OR. (ios /= 0) ALLOCATE ( nodes(3,numel) ) ALLOCATE ( selected(numel) ) ALLOCATE ( uvec_list(3,numel) ) DO i = 1, numel READ (21, *, IOSTAT = ios) j, nodes(1,i), nodes(2,i), nodes(3,i) problem = problem .OR. (ios /= 0) END DO ! i = 1, numel IF (problem) THEN WRITE (*,"(' ERROR: Necessary information absent or defective in this file.')") CLOSE (21) CALL Press_Enter mt_flashby = .FALSE. 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 Prompt_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 Press_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 Prompt_for_Real('How long should the symbols be, in points?',s1_size_points,s1_size_points) WRITE (*,"(/' There will be ',I7,' symbols plotted if they are not thinned.')") numel 2132 CALL Prompt_for_Integer('What thinning factor ( >=1 ) do you want?',stress_thinner,stress_thinner) IF (stress_thinner < 1) THEN WRITE(*,"(' Error: Please enter a positive integer!')") 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 Make_Uvec (uvec1, uvec) ! center of element uvec_list(1:3, l_) = uvec(1:3) END DO ! l_ = 1, numel CALL Thin_on_Sphere (uvec_list, numel, stress_thinner, selected) CALL Begin_Group DO l_ = 1, numel ! compute strainrates at element centers ! evaluate nodal function and derivitives at center of element IF (selected(l_)) THEN uvec(1:3) = uvec_list(1:3, l_) equat = SQRT(uvec(1)**2 + uvec(2)**2) IF (equat == 0.) THEN PRINT "(' Error: center of element ',I5,' is N or S pole.')", l_ WRITE (21,"('Error: center of element ',I5,' is N or S pole.')") l_ STOP ' ' END IF theta_ = ATAN2(equat, uvec(3)) uvec1(1:3) = node_uvec(1:3, nodes(1, l_)) uvec2(1:3) = node_uvec(1:3, nodes(2, l_)) uvec3(1:3) = node_uvec(1:3, nodes(3, l_)) CALL Gjxy (l_, uvec1, & & uvec2, & & uvec3, & & uvec, G) CALL Del_Gjxy_del_thetaphi (l_, uvec1, & & uvec2, & & uvec3, & & uvec, dG) CALL E_rate(mp_radius_meters, l_, nodes, G, dG, theta_, vw, eps_dot) ! compute 3 principal values, and partition one with unique sign CALL Principal_Axes_22 (eps_dot(1),eps_dot(2),eps_dot(3), & & e1h, e2h, u1theta,u1phi, u2theta,u2phi) divergence = e1h + e2h err = -divergence s1h_azim_radians = ATAN2F(u1phi, -u1theta) eh_max = MAX(ABS(e1h),ABS(e2h)) offset_radians = Conformal_Deflation(uvec) * ((0.5*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 Set_Line_Style (width_points = 3.0, dashed = .FALSE.) IF ((err >= (e1h + 0.01 * (e2h - e1h))).AND. & & (err <= (e2h - 0.01 * (e2h - e1h)))) THEN ! e_rr is e2 CALL Set_Stroke_Color('green_____') ! strike-slip ELSE IF (err > 0.0) THEN ! e_rr is e3 CALL Set_Stroke_Color('mid_blue__') ! thrust ELSE ! e_rr is e1 CALL Set_Stroke_Color('red_______') ! normal END IF ! different colors CALL Turn_To (azimuth_radians = s1h_azim_radians, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL Turn_To (azimuth_radians = s1h_azim_radians+Pi, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL New_L45_Path(5,uvec1) CALL Great_to_L45(uvec2) CALL End_L45_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! b/w symbol ! black-stroked white box for normal, unstroked grey box for s-s, black for thrusting CALL Set_Stroke_Color('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) IF ((err >= (e1h + 0.01 * (e2h - e1h))).AND. & ! e_rr is e2 & (err <= (e2h - 0.01 * (e2h - e1h)))) THEN CALL Set_Fill_or_Pattern(.FALSE.,'gray______') ! strike-slip stroke_this = .FALSE. ELSE IF (err > 0.0) THEN ! e_rr is e3 CALL Set_Fill_or_Pattern(.FALSE.,'foreground') ! thrust stroke_this = .FALSE. ELSE ! e_rr is e1 CALL Set_Fill_or_Pattern(.FALSE.,'background') ! normal stroke_this = .TRUE. END IF ! different grays CALL Turn_To (azimuth_radians = s1h_azim_radians+0.10, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec1) CALL New_L45_Path(5,uvec1) CALL Turn_To (azimuth_radians = s1h_azim_radians-0.10, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL Great_to_L45(uvec2) CALL Turn_To (azimuth_radians = s1h_azim_radians+Pi+0.10, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL Great_to_L45(uvec2) CALL Turn_To (azimuth_radians = s1h_azim_radians+Pi-0.10, & & base_uvec = uvec, & & far_radians = offset_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = uvec2) CALL Great_to_L45(uvec2) CALL Great_to_L45(uvec1) CALL End_L45_Path(close = .TRUE., stroke = stroke_this, fill = .TRUE.) END IF END IF ! selected for plotting END DO ! l_ = 1, numel, computing strainrates CALL End_Group ! s1h directions on map CALL Begin_Group ! sample s1h directions in legend CALL Chooser (bottom, right) IF (right) THEN CALL Report_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points xcp = (x1_points + x2_points)/2. CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'Model s1h') CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'direction and') CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-30., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.5, ud_fraction = 0.0, & & text = 'stress regime:') IF (ai_using_color) THEN CALL Set_Stroke_Color('red_______') CALL Set_Line_Style (width_points = 3.00, dashed = .FALSE.) CALL New_L12_Path(1,xcp-4.,y2_points-40.) CALL Line_to_L12(xcp-4.-s1_size_points,y2_points-40.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL Set_Stroke_Color('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Fill_or_Pattern(.FALSE.,'background') CALL New_L12_Path(1,xcp-4.,y2_points-40.-1.5) CALL Line_to_L12(xcp-4.,y2_points-40.+1.5) CALL Line_to_L12(xcp-4.-s1_size_points,y2_points-40.+1.5) CALL Line_to_L12(xcp-4.-s1_size_points,y2_points-40.-1.5) CALL Line_to_L12(xcp-4.,y2_points-40.-1.5) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL Set_Line_Style (width_points = 3.00, dashed = .FALSE.) CALL Set_Fill_or_Pattern(.FALSE.,'foreground') CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-40., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'normal') IF (ai_using_color) THEN CALL Set_Stroke_Color('green_____') ELSE CALL Set_Stroke_Color('gray______') END IF CALL New_L12_Path(1,xcp-4.,y2_points-50.) CALL Line_to_L12(xcp-4.-s1_size_points,y2_points-50.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-50., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'strike-slip') IF (ai_using_color) THEN CALL Set_Stroke_Color('mid_blue__') ELSE CALL Set_Stroke_Color('foreground') END IF CALL New_L12_Path(1,xcp-4.,y2_points-60.) CALL Line_to_L12(xcp-4.-s1_size_points,y2_points-60.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL L12_Text (level = 1, x_points = xcp, & & y_points = y2_points-60., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'thrust') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 64. ELSE ! bottom CALL Report_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points)/2. CALL Set_Fill_or_Pattern(.FALSE.,'foreground') CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp+10., & & angle_radians = 0., font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'Model s1h') CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp, & & angle_radians = 0., font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'direction and') CALL L12_Text (level = 1, x_points = x1_points+72., & & y_points = ycp-10., & & angle_radians = 0., font_points = 10, & & lr_fraction = 1.0, ud_fraction = 0.4, & & text = 'stress regime:') IF (ai_using_color) THEN CALL Set_Stroke_Color('red_______') CALL Set_Line_Style (width_points = 3.00, dashed = .FALSE.) CALL New_L12_Path(1,x1_points+76.,ycp+10.) CALL Line_to_L12(x1_points+76.+s1_size_points,ycp+10.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL Set_Stroke_Color('foreground') CALL Set_Line_Style (width_points = 0.75, dashed = .FALSE.) CALL Set_Fill_or_Pattern(.FALSE.,'background') CALL New_L12_Path(1,x1_points+76.,ycp+10.-1.5) CALL Line_to_L12(x1_points+76.+s1_size_points,ycp+10.-1.5) CALL Line_to_L12(x1_points+76.+s1_size_points,ycp+10.+1.5) CALL Line_to_L12(x1_points+76.,ycp+10.+1.5) CALL Line_to_L12(x1_points+76.,ycp+10.-1.5) CALL End_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL Set_Line_Style (width_points = 3.00, dashed = .FALSE.) CALL Set_Fill_or_Pattern(.FALSE.,'foreground') CALL L12_Text (level = 1, x_points = x1_points+80.+s1_size_points, & & y_points = ycp+10., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'normal') IF (ai_using_color) THEN CALL Set_Stroke_Color('green_____') ELSE CALL Set_Stroke_Color('gray______') END IF CALL New_L12_Path(1,x1_points+76.,ycp) CALL Line_to_L12(x1_points+76.+s1_size_points,ycp) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL L12_Text (level = 1, x_points = x1_points+80.+s1_size_points, & & y_points = ycp, & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'strike-slip') IF (ai_using_color) THEN CALL Set_Stroke_Color('mid_blue__') ELSE CALL Set_Stroke_Color('foreground') END IF CALL New_L12_Path(1,x1_points+76.,ycp-10.) CALL Line_to_L12(x1_points+76.+s1_size_points,ycp-10.) CALL End_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL L12_Text (level = 1, x_points = x1_points+80.+s1_size_points, & & y_points = ycp-10., & & angle_radians = 0., font_points = 10, & & lr_fraction = 0.0, ud_fraction = 0.4, & & text = 'thrust') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 116. + s1_size_points END IF ! right or bottom CALL End_Group ! sample s1h directions in legend WRITE (*,"(/' Working on s1h directions....DONE.')") CALL BEEPQQ (frequency = 440, duration = 250) DEALLOCATE ( node_uvec, & & 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 Prompt_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 Press_Enter mt_flashby = .FALSE. GO TO 2140 END IF CALL Check_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 Prompt_for_Integer('How many title/header lines are there?',0,s_header_lines) CALL Prompt_for_Logical('Is there a column with stress regime (NF, SS, TF, ...)?',.TRUE.,regimes_known) CALL Prompt_for_Logical('Are these data in (lon,lat) coordinates?',.TRUE.,lonlat) IF (lonlat) THEN CALL Prompt_for_String('What FORMAT will extract the longitude?',format1,format1) CALL Prompt_for_String('What FORMAT will extract the latitude ?',format2,format2) ELSE ! x,y CALL Prompt_for_String('What FORMAT will extract the X coordinate?',format1,format1) CALL Prompt_for_String('What FORMAT will extract the Y coordinate?',format2,format2) END IF ! lon,lat or x,y CALL Prompt_for_String('What FORMAT will extract the s1h azimuth?',format3,format3) azimuth_is_integer = (SCAN(format3, 'I') > 0).OR.(SCAN(format3, 'i') > 0) CALL Prompt_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.)',& & format4,format4) using_A_to_E = (SCAN(format4, 'A') > 0).OR.(SCAN(format4, 'a') > 0) sigma_is_integer = (SCAN(format4, 'I') > 0).OR.(SCAN(format4, 'i') > 0) IF (regimes_known) THEN CALL Prompt_for_String('What FORMAT will extract the stress regime?',format5,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, '('//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