PROGRAM FlatMaxwell !Version 1.5 (w/ borehole report) of 2015.08.29 !FlatMaxwell is a program for estimating stresses in a planar flat-Earth ! lithosphere which has been transformed from the real spherical-shell ! lithosphere by a map projection. !It assumes (total stress anomaly) = (topographic stress) + (tectonic stress), ! by definition, where topographic stress may include effects of partial ! or exact isostatic compensation. !The topographic stress field is computed using Green's functions ! (from Boussinesq, Cerruti, and Mindlin) for effects of point forces ! on/in a uniform isotropic elastic halfspace. !The tectonic stress is derived from second-derivatives of a Maxwell ! potential vector field, each component of which is described by sums ! of triple-products of simple functions of x, y, and z. !Constraints are required for a solution. Typically they will include ! many point data (e.g., focal mechanisms & hydrofracs) and also a ! dynamic model of the same volume (to constrain regions with no data). !After computing a solution (or loading an old solution), maps, sections, ! and reports (in SCEC Community Stress Model format) may be created from ! an interactive menu. These refer to real-Earth (lon, lat) coordinates. !By Peter Bird, UCLA, 2013-2015 for the Southern California Earthquake Center. !Copyright 2011, 2013, 2014, 2015 by Peter Bird and the ! Regents of the University of California. USE DAdobe_Illustrator ! provided by Peter Bird in file DAdobe_Illustrator.f90 USE DMap_Projections ! provided by Peter Bird in file DMap_Projections.f90 USE DMap_Tools ! provided by Peter Bird in file DMap_Tools.f90 USE DFlat_Section ! provided by Peter Bird in file DFlat_Section.f90 USE Quaternion ! by Yan Kagan; provided by Peter Bird in file Quaternion.f90 USE MKL95_PRECISION ! provided by Intel in file LAPACK.f90 USE MKL95_LAPACK ! provided by Intel in file LAPACK.f90 !------------------------------------------------------------------------------------------ ! All of the above .f90 files (mentioned in my comments) need to be available ! to be compiled jointly with this program. !------------------------------------------------------------------------------------------ ! ***REMEMBER*** in the Microsoft Visual Studio GUI provided with ! Intel Parallel Studio XE 2013, you also need to set ! Project / Properties / Fortran / Libraries / ! Use Math Kernel Library {to some choice other than "No"}! !------------------------------------------------------------------------------------------ IMPLICIT NONE !Note that state variables defined in the above 3 modules will be used freely. CHARACTER*1 :: c1, fmc1_section_letter CHARACTER*4 :: c4 CHARACTER*10 :: CPU_time_c10 CHARACTER*12 :: fmc12_linear_system_size, fmc12_tectonic_token, fmc12_topographic_token CHARACTER*13, DIMENSION(:), ALLOCATABLE :: fmc13v_name ! e.g., "3DO1S01C01S01" CHARACTER*80 :: fmc80_CSM_model_filename, & & fmc80_DEM_filename, & & fmc80_model_AI_filename, & & fmc80_Moho_filename, & & fmc80_new_AI_filename, & & fmc80_WSM_data_filename CHARACTER*132 :: fmc132_CSM_model_pathfile, fmc132_DEM_pathfile, fmc132_path_in, fmc132_path_out, fmc132_Moho_pathfile, fmc132_WSM_data_pathfile CHARACTER*132, DIMENSION(20) :: fmc132v_titles INTEGER :: fmi_CSM_points_in_box, & & fmi_DEM_columns, fmi_DEM_rows, & & fmi_last_1DO, fmi_last_2DO, fmi_Moho_columns, fmi_Moho_rows, fmi_minutes, & & fmi_N_coefficients, fmi_new_or_old_Moho, fmi_new_or_old_tectonic, fmi_new_or_old_topographic, & & fmi_output_menu_choice, & & fmi_projection_choice, & & fmi_sites_in_box, & & fmi_tectonic_model_mode, fmi_title_count, fmi_top_lmn, fmi_topo_nx, fmi_topo_ny, fmi_topo_nz, & & fmi_unit_choice, & & fmi_waves, & & i, ios, & & j, & & k, & & l, & & m, & & n, n_file_megabytes, n_memory_megabytes, n_points, & & path_length INTEGER(KIND = 2), DIMENSION(:, :), ALLOCATABLE :: fmim_DEM INTEGER(KIND = 4), DIMENSION(:, :), ALLOCATABLE :: fmim_Moho_elevation_m !Note that KIND = 4 is needed for Moho; with KIND = 2 it would be limited to -32768 m. INTEGER, DIMENSION(:), ALLOCATABLE :: fmiv_ipiv, fmiv_iWork, fmiv_k LOGICAL :: fml_black, fml_do_scoring_vs_data, fml_do_scoring_vs_model, & & fml_plan_bottomlegend, fml_plan_rightlegend, fml_plan_top_titles, & & fml_plan_section_bottomlegend, fml_plan_section_rightlegend, fml_plan_section_top_titles, & & fml_using_color, & & reconsider, try_again REAL*8 :: CPU_time_hours, CPU_time_days, CPU_time_years, & & file_megabytes, & & fmr_1_bar, & & fmr_atmosphere_scale_height_meters, & & fmr_belt_azimuth_degrees, fmr_borehole_latitude, fmr_borehole_longitude, fmr_bottom_margin_points, & & fmr_cone_lat, fmr_cone_lon, fmr_crustal_density_at_top, fmr_crustal_density_at_Moho, & & fmr_DEM_lon_min, fmr_DEM_dLon, fmr_DEM_lon_max, fmr_DEM_lat_min, fmr_DEM_dLat, fmr_DEM_lat_max, fmr_DEM_lon_range, & & fmr_gravity, & & fmr_horizontal_resolution_m, & & fmr_LAB_depth, fmr_LAB_elevation, fmr_left_margin_points, & & fmr_linear_system_bytes, fmr_linear_system_KB, fmr_linear_system_MB, fmr_linear_system_GB, & & fmr_mantle_density_at_Moho, fmr_mantle_density_at_LAB, fmr_Moho_depth, fmr_Moho_elevation, & & fmr_Moho_lon_min, fmr_Moho_dLon, fmr_Moho_lon_max, fmr_Moho_lat_min, fmr_Moho_dLat, fmr_Moho_lat_max, fmr_Moho_lon_range, & & fmr_map_paper_height_points, fmr_map_paper_width_points, fmr_Poisson_ratio, fmr_projpoint_Elon, fmr_projpoint_Nlat, & & fmr_radius_meters, fmr_right_margin_points, & & fmr_seawater_density, fmr_section_azimuth_degrees, fmr_section_pin_Elon, fmr_section_pin_Nlat, & & fmr_section_paper_height_points, fmr_section_paper_width_points, & & fmr_section_x1_m, fmr_section_x2_m, fmr_section_y1_m, fmr_section_y2_m, fmr_standard_parallel_gap_degrees, & & fmr_top_margin_points, & & fmr_vertical_resolution_m, & & fmr_x_LENGTH_meters, & & fmr_y_WIDTH_meters, & & fmr_z_DEPTH_meters, & & memory_megabytes, & & resolution_m REAL*8, DIMENSION(3) :: fmrv_topo_stress_dXYZ REAL*8, DIMENSION(:), ALLOCATABLE :: fmrv_reference_P_Pa ! (-nz:nz) REAL*8, DIMENSION(:, :, :, :), ALLOCATABLE :: fmrt_topo_stress_anomaly_Pa ! (1:6, -nx:nx, -ny:ny, -nz:nz) REAL*8, DIMENSION(:, :, :, :), ALLOCATABLE :: fmrt_tectonic_stress_anomaly_Pa ! (1:6, -nx:nx, -ny:ny, -nz:nz) {pre-computed on topo grid for graphics} DOUBLE PRECISION :: fmd_BC_group_weight, fmd_CSM_group_weight, fmd_WSM_group_weight, highest, topo_work_index, topo_base_index DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: fmdv_a, fmdv_b, fmdv_c, fmdv_F_at_x, fmdv_G_at_y, fmdv_H_at_z, & & fmdv_d_F_d_x_at_x, fmdv_d_G_d_y_at_y, fmdv_d_H_d_z_at_z, & & fmdv_d2_F_d_x2_at_x, fmdv_d2_G_d_y2_at_y, fmdv_d2_H_d_z2_at_z, & & fmdv_Q DOUBLE PRECISION, DIMENSION(:, :), ALLOCATABLE :: fmdV_coefficients ! NOTE: The 2nd subscript is (1:1), required to avoid a compiler error ! when searching for the proper generic form of gesvx in LAPACK! DOUBLE PRECISION, DIMENSION(:, :), ALLOCATABLE :: fmdm_MATRIX, fmdm_matrix_COPY, fmdm_matrix_WIP ! huge linear-system matrix (up to 33 GB for fmi_waves = 6). DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: fmdv_row_scale_factors, fmdv_column_scale_factors, fmdv_WORK DOUBLE PRECISION, DIMENSION(:, :), ALLOCATABLE :: fmdv_RHS, fmdv_rhs_WIP ! Right-Hand-Side or forcing vector for linear system. ! NOTE: The 2nd subscript is (1:1), required to avoid a compiler error ! when searching for the proper generic form of gesvx in LAPACK! DOUBLE PRECISION, DIMENSION(:, :), ALLOCATABLE :: fmdm_d_tau_d_c_at_point ! (1:6, 1:fmi_N_coefficients); used to compute entries in fmdm_MATRIX and fmdV_RHS. TYPE :: stress_data REAL*8 :: Elon ! in decimal degrees; E = +, W = - REAL*8 :: Nlat ! in decimal degrees, N = +, S = - REAL*8 :: depth_km ! measured positive downwards from land or seafloor hard surface, NOT from sea-level REAL*8 :: s1_azimuth_deg ! measured CW from North in degrees; s1 is most-compressive principal stress REAL*8 :: s1_plunge_deg ! measured downwards from horizontal in degrees REAL*8 :: s2_azimuth_deg ! measured CW from North in degrees REAL*8 :: s2_plunge_deg ! measured downwards from horizontal in degrees REAL*8 :: s3_azimuth_deg ! measured CW from North in degrees; s3 is least-compressive principal stress REAL*8 :: s3_plunge_deg ! measured downwards from horizontal in degrees REAL*8 :: s1_mag_int ! per WSM2008: in MPa, positive = compression REAL*8 :: s2_mag_int ! per WSM2008: in MPa, positive = compression REAL*8 :: s3_mag_int ! per WSM2008: in MPa, positive = compression REAL*8 :: x_meters ! FlatMaxwell Cartesian coordinate (+ or -) REAL*8 :: y_meters ! FlatMaxwell Cartesian coordinate (+ or -) REAL*8 :: z_meters ! FlatMaxwell Cartesian coordinate (never positive) REAL*8 :: s1_argument_radians ! measured CCW from +x REAL*8 :: s1_plunge_radians REAL*8 :: s2_argument_radians ! measured CCW from +x REAL*8 :: s2_plunge_radians REAL*8 :: s3_argument_radians ! measured CCW from +x REAL*8 :: s3_plunge_radians REAL*8 :: s1_tensor_Pa ! per SI and FlatMaxwell: In Pa; tension positive. REAL*8 :: s2_tensor_Pa ! per SI and FlatMaxwell: In Pa; tension positive. REAL*8 :: s3_tensor_Pa ! per SI and FlatMaxwell: In Pa; tension positive. CHARACTER*2 :: regime ! TF, TS, SS, NS, NF, U CHARACTER*1 :: quality ! A, B, C, D, E CHARACTER*5 :: dummy ! to preserve alignment of stress_data items into 8-byte (64-bit) words in memory END TYPE stress_data TYPE(stress_data), DIMENSION(:), ALLOCATABLE :: fmtv_stress_data TYPE :: CSM_model REAL*8 :: Elon ! longitude, in decimal degrees; East is positive REAL*8 :: Nlat ! latitude, in decimal degrees; North is positive REAL*8 :: depth_below_MSL_in_km ! MSL = Mean Sea Level; this is the negative of elevation REAL*8 :: s1H_azimuth_degrees ! azimuth, in degrees CW from North, of most-compressive horizontal principal stress axis REAL*8 :: sigma_EE_MPa REAL*8 :: sigma_EN_MPa REAL*8 :: sigma_Er_MPa REAL*8 :: sigma_NN_MPa REAL*8 :: sigma_Nr_MPa REAL*8 :: sigma_rr_MPa !---division between reported and inferred values REAL*8 :: x_meters ! of FlatMaxwell (x, y, z) system REAL*8 :: y_meters ! of FlatMaxwell (x, y, z) system REAL*8 :: z_meters ! of FlatMaxwell (x, y, z) system ! (Note that only points falling within the model box will be stored in the array below, fmtv_CSM_data.) REAL*8, DIMENSION(3, 3) :: ENr_tensor_Pa ! stress restated in (East, North, up) right-handed orthogonal coordinates, in Pa. !Note that compressive stress is considered negative everywhere in the CSM file, and in the inferred ENr_tensor_Pa. !Total length of 22 4-byte REALs in one CSM_model item will pack into 11 8-byte (64-bit) words in memory. END TYPE CSM_model TYPE(CSM_model), DIMENSION(:), ALLOCATABLE :: fmtv_CSM_model !------------------------------------------------------------------------------------------ WRITE (*, *) WRITE (*, "(' ------===== FlatMaxwell =====------')") WRITE (*, "(' Version 1.5 of 2015.08.29')") WRITE (*, "(' FlatMaxwell is a program for estimating stresses in a planar flat-Earth')") WRITE (*, "(' lithosphere which has been transformed from the real spherical-shell')") WRITE (*, "(' lithosphere by a map projection.')") WRITE (*, "(' It assumes (total stress anomaly) = (topographic stress) + (tectonic stress),')") WRITE (*, "(' by definition, where topographic stress may include effects of partial')") WRITE (*, "(' or exact isostatic compensation.')") WRITE (*, "(' The topographic stress field is computed using Green''s functions')") WRITE (*, "(' (from Boussinesq, Cerruti, and Mindlin) for effects of point forces')") WRITE (*, "(' on/in a uniform isotropic elastic halfspace.')") WRITE (*, "(' The tectonic stress is derived from second-derivatives of a Maxwell')") WRITE (*, "(' potential vector field, each component of which is described by sums')") WRITE (*, "(' of triple-products of simple functions of x, y, and z.')") WRITE (*, "(' Constraints are required for a solution. Typically they will include')") WRITE (*, "(' many point data (e.g., focal mechanisms & hydrofracs) and also a')") WRITE (*, "(' dynamic model of the same volume (to constrain regions with no data).')") WRITE (*, "(' After computing a solution (or loading an old solution), maps, sections,')") WRITE (*, "(' and reports (in SCEC Community Stress Model format) may be created from')") WRITE (*, "(' an interactive menu. These refer to real-Earth (lon, lat) coordinates.')") WRITE (*, "(' By Peter Bird, UCLA, 2013-2015, for the Southern California Earthquake Center.')") WRITE (*, "(' Copyright 2011, 2013, 2014, 2015 by Peter Bird and the')") WRITE (*, "(' Regents of the University of California.')") CALL Pause() CALL Initialize() !-------------------------(Define Paths)----------------------------- WRITE (*,"(//' ----------------------------------------------------------------------'& &/' Setting PATHS to Input and Output Files'& &//' FlatMaxwell stores its memory in FlatMaxwell.ini,'& &/' which is placed in the current directory where FlatMaxwell is run.'& &/' Normally, this should be the directory holding FlatMaxwell.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 files separate in their own directory (or 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'& &/' FlatMaxwell!'& &/' ----------------------------------------------------------------------')") 1 CALL DPrompt_for_String('What is the path for your input files?',fmc132_path_in,fmc132_path_in) fmc132_path_in = ADJUSTL(fmc132_path_in) !warn about apparently-illegal path! --------------------------------------------------- path_length = LEN_TRIM(fmc132_path_in) IF (path_length > 0) THEN c1 = fmc132_path_in(path_length:path_length) IF (.NOT.((c1 == '\').OR.(c1 == '/'))) THEN WRITE (*, "(' ERROR: Each path must end in ''\'' (Windows) or ''/'' (Unix)!')") CALL DPrompt_for_Logical('Do you need to re-type this path?', .TRUE., try_again) IF (try_again) GO TO 1 END IF END IF !---------------------------------------------------------------------------------------- 2 CALL DPrompt_for_String('What is the path for your output (.ai graphics) file?',fmc132_path_out,fmc132_path_out) fmc132_path_out = ADJUSTL(fmc132_path_out) !warn about apparently-illegal path! --------------------------------------------------- path_length = LEN_TRIM(fmc132_path_out) IF (path_length > 0) THEN c1 = fmc132_path_out(path_length:path_length) IF (.NOT.((c1 == '\').OR.(c1 == '/'))) THEN WRITE (*, "(' ERROR: Each path must end in ''\'' (Windows) or ''/'' (Unix)!')") CALL DPrompt_for_Logical('Do you need to re-type this path?', .TRUE., try_again) IF (try_again) GO TO 2 END IF END IF !---------------------------------------------------------------------------------------- WRITE (*,"(' IT WILL NOT BE NECESSARY TO TYPE THESE PATHS AGAIN!')") !-------------------------(end of defining paths)-------------------- WRITE (*, *) WRITE (*, "(' DECISION POINT: Will you ...')") WRITE (*, "(' (1) Create a new topographic stress model? (OR)')") WRITE (*, "(' (2) Load an existing topographic stress model computed previously?')") 10 CALL DPrompt_for_Integer('Please select option 1 or 2.', fmi_new_or_old_topographic, fmi_new_or_old_topographic) IF ((fmi_new_or_old_topographic < 1).OR.(fmi_new_or_old_topographic > 2)) GO TO 10 IF (fmi_new_or_old_topographic == 1) THEN ! ========================= CREATE A NEW TOPOGRAPHIC STRESS MODEL ========== WRITE (*, *) 11 WRITE (*, "(' Please enter a name (1~12 alphanumeric characters; no spaces)')") WRITE (*, "(' for this new topographic stress model:')") READ (*, "(A)") fmc12_topographic_token fmc12_topographic_token = ADJUSTL(fmc12_topographic_token) IF (LEN_TRIM(fmc12_topographic_token) == 0) GO TO 11 IF (LEN_TRIM(fmc12_topographic_token) >=3) THEN DO i = 2, (LEN_TRIM(fmc12_topographic_token) - 1) IF (fmc12_topographic_token(i:i) == ' ') fmc12_topographic_token(i:i) = '_' END DO END IF WRITE (*, "(' -----------------------------------------------------------------------')") CALL Define_Map_Projection() WRITE (*, "(' -----------------------------------------------------------------------')") CALL Define_Volume() WRITE (*, "(' -----------------------------------------------------------------------')") CALL Define_Reference_Density_Model() WRITE (*, "(' -----------------------------------------------------------------------')") !Read DEM !N.B. This must be done in MAIN because we will ALLOCATE a large permanent array. !Note that a DEM will also be read along the branch where an old topographic stress model is reloaded; ! but, in that case, the user will no longer be free to choose the DEM filename. WRITE (*, *) WRITE (*, "(' A Digital Elevation Model (DEM) must be provided in Bird''s .GRD format,')") WRITE (*, "(' which is documented in a web page with URL of:')") WRITE (*, "(' http://peterbird.name/guide/grd_format.htm')") WRITE (*, "(' The horizontal coordinates must be decimal degrees (E, N), with')") WRITE (*, "(' the elevations in meters (positive above sea level).')") 14 CALL DPrompt_for_String("DEM file name:", fmc80_DEM_filename, fmc80_DEM_filename) fmc132_DEM_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_DEM_filename) OPEN (UNIT = 1, FILE = TRIM(fmc132_DEM_pathfile), STATUS = "OLD", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: DEM file named ', A / ' was not found in folder'/' ', A)") TRIM(fmc80_DEM_filename), TRIM(fmc132_path_in) WRITE (*, "(' Please create or move this file, and try again...')") CALL Pause() GO TO 14 END IF READ (1, *, IOSTAT = ios) fmr_DEM_lon_min, fmr_DEM_dLon, fmr_DEM_lon_max fmr_DEM_lon_range = fmr_DEM_lon_max - fmr_DEM_lon_min IF (ios /= 0) THEN WRITE (*, "(' ERROR: DEM is not in .GRD format.')"); CALL Pause(); GO TO 14 END IF READ (1, *, IOSTAT = ios) fmr_DEM_lat_min, fmr_DEM_dLat, fmr_DEM_lat_max IF (ios /= 0) THEN WRITE (*, "(' ERROR: DEM is not in .GRD format.')"); CALL Pause(); GO TO 14 END IF fmi_DEM_columns = NINT(1 + (fmr_DEM_lon_max - fmr_DEM_lon_min) / fmr_DEM_dLon) fmi_DEM_rows = NINT(1 + (fmr_DEM_lat_max - fmr_DEM_lat_min) / fmr_DEM_dLat) ALLOCATE ( fmim_DEM(fmi_DEM_rows, fmi_DEM_columns) ) WRITE (*, "(' Reading DEM array...')") READ (1, *, IOSTAT = ios) ((fmim_DEM(i, j), j = 1, fmi_DEM_columns), i = 1, fmi_DEM_rows) IF (ios /= 0) THEN WRITE (*, "(' ERROR: DEM is not in .GRD format.')"); CALL Pause(); GO TO 14 END IF CLOSE(1) WRITE (*, "(' -----------------------------------------------------------------------')") WRITE (*, *) WRITE (*, "(' DECISION POINT: Will you ...')") WRITE (*, "(' (1) Compute an ideal Moho shape for pure isostasy? (OR)')") WRITE (*, "(' (2) Load a gridded Moho-depth file?')") 15 CALL DPrompt_for_Integer('Please select option 1 or 2.', fmi_new_or_old_Moho, fmi_new_or_old_Moho) IF ((fmi_new_or_old_Moho < 1).OR.(fmi_new_or_old_Moho > 2)) GO TO 15 IF (fmi_new_or_old_Moho == 1) THEN ! compute an ideal Moho shape for perfect isostasy fmi_Moho_rows = fmi_DEM_rows fmi_Moho_columns = fmi_DEM_columns fmr_Moho_lon_min = fmr_DEM_lon_min fmr_Moho_dLon = fmr_DEM_dLon fmr_Moho_lon_max = fmr_DEM_lon_max fmr_Moho_lat_min = fmr_DEM_lat_min fmr_Moho_dLat = fmr_DEM_dLat fmr_Moho_lat_max = fmr_DEM_lat_max fmr_Moho_lon_range = fmr_DEM_lon_range ALLOCATE ( fmim_Moho_elevation_m(fmi_Moho_rows, fmi_Moho_columns) ) WRITE (*, *) WRITE (*, "(' Computing Moho elevation, assuming perfect local isostasy...')") CALL Compute_Moho() ELSE ! read Moho elevations from .GRD file !READ MOHO !Note that this must be done in MAIN, as we will ALLOCATE a large permanent array. 18 WRITE (*, *) WRITE (*, "(' Ready to read seismic Moho elevations (in m; all negative)')") WRITE (*, "(' from a file in Bird''s .GRD format.')") CALL DPrompt_for_String("Seismic Moho elevation file:", fmc80_Moho_filename, fmc80_Moho_filename) fmc132_Moho_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_Moho_filename) OPEN (UNIT = 1, FILE = TRIM(fmc132_Moho_pathfile), STATUS = "OLD", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: File not found along input path. Move or retype and try again.')") CALL Pause() GO TO 18 END IF READ (1, *) fmr_Moho_lon_min, fmr_Moho_dLon, fmr_Moho_lon_max fmr_Moho_lon_range = fmr_Moho_lon_max - fmr_Moho_lon_min READ (1, *) fmr_Moho_lat_min, fmr_Moho_dLat, fmr_Moho_lat_max fmi_Moho_rows = 1 + NINT((fmr_Moho_lat_max - fmr_Moho_lat_min) / fmr_Moho_dLat) fmi_Moho_columns = 1 + NINT((fmr_Moho_lon_max - fmr_Moho_lon_min) / fmr_Moho_dLon) ALLOCATE ( fmim_Moho_elevation_m(fmi_Moho_rows, fmi_Moho_columns) ) READ (1, *) ((fmim_Moho_elevation_m(i, j), j = 1, fmi_Moho_columns), i = 1, fmi_Moho_rows) CLOSE (1) END IF ! fmi_new_or_old_Moho == 1, or 2 WRITE (*, "(' -----------------------------------------------------------------------')") !COMPUTE TOPOGRAPHIC STRESS !This process must be started in MAIN because we will ALLOCATE a large permanent array; !however, it will be filled in a subprogram. WRITE (*, *) WRITE (*, "(' Choose vertical resolution (in m) for topo-stress grid (& overlays in sections)')") WRITE (*, "(' keeping in mind that seismogenic zone may be only 10,000 ~ 15,000 m deep:')") CALL DPrompt_for_Real("Vertical grid resolution in meters:", fmr_vertical_resolution_m, fmr_vertical_resolution_m) fmi_topo_nz = NINT(0.5D0 * fmr_z_DEPTH_meters / fmr_vertical_resolution_m) fmi_topo_nz = MAX(fmi_topo_nz, 1) fmrv_topo_stress_dXYZ(3) = 0.5D0 * fmr_z_DEPTH_meters / fmi_topo_nz WRITE (*, *) WRITE (*, "(' Choose horizontal resolution (in m) for topo-stress grid (& overlays on maps)')") WRITE (*, "(' avoiding excessively HUGE output files (& overcrowded maps), and')") WRITE (*, "(' avoiding excessive computation times:')") WRITE (*, *) WRITE (*, "(' Horizontal 3-D TopoStress')") WRITE (*, "(' Resolution Grid Points Memory Size File Size CPU Time')") WRITE (*, "(' ---------- ----------- ----------- --------- --------')") DO resolution_m = 20000.0D0, 2000.0D0, -2000.0D0 fmi_topo_nx = NINT(0.5D0 * fmr_x_LENGTH_meters / resolution_m) fmi_topo_nx = MAX(fmi_topo_nx, 1) fmi_topo_ny = NINT(0.5D0 * fmr_y_WIDTH_meters / resolution_m) fmi_topo_ny = MAX(fmi_topo_ny, 1) n_points = (2 * fmi_topo_nx + 1) * (2 * fmi_topo_ny + 1) * (2 * fmi_topo_nz + 1) file_megabytes = n_points * (3.0D0 * 7.0D0 + 6.0D0 * 10.0D0 + 2.0D0) / (1024.0D0**2) n_file_megabytes = NINT(file_megabytes) memory_megabytes = n_points * 6.0D0 * 4.0D0 / (1024.0D0**2) n_memory_megabytes = NINT(memory_megabytes) topo_work_index = n_points**2.0D0 topo_base_index = ((2.0D0 * 19.0D0 + 1.0D0) * (2.0D0 * 15.0D0 + 1.0D0) * (2.0D0 * 20.0D0 + 1.0D0))**2. CPU_time_hours = 8.6D0 * (topo_work_index / topo_base_index) ! where coefficient "8.6 hours" was measured for case "topo_base_index" {-19:19, -15:15, -20:20}, ! using single-processor version of FlatMaxwell, and Release mode (optimized for speed), and ! running outside the Microsoft Visual Studio environment, under Windows 7. ! For this test, the internal parameters of subprogram Compute_Topographic_Stress were: ! INTEGER, PARAMETER :: horizontal_refinement = 10 ! INTEGER, PARAMETER :: vertical_refinement = 10 ! and these choices were selected to give reasonable accuracy for topographic models ! computed "quickly" with large horizontal resolutions such as 20000. meters. IF (CPU_time_hours <= 99.0D0) THEN WRITE (c4, "(I4)") NINT(CPU_time_hours) CPU_time_c10 = c4 // " hours" ELSE CPU_time_days = CPU_time_hours / 24.0D0 IF (CPU_time_days <= 365.25D0) THEN WRITE (c4, "(I4)") NINT(CPU_time_days) CPU_time_c10 = c4 // " days " ELSE CPU_time_years = CPU_time_days / 365.25D0 WRITE (c4, "(I4)") NINT(CPU_time_years) CPU_time_c10 = c4 // " years" END IF END IF WRITE (*, "(' ', F10.0,' ',I11,' ',I8,' MB ',I7,' MB',A)") resolution_m, n_points, n_memory_megabytes, n_file_megabytes, CPU_time_c10 END DO CALL DPrompt_for_Real("Horizontal grid resolution in meters:", fmr_horizontal_resolution_m, fmr_horizontal_resolution_m) fmi_topo_nx = NINT(0.5D0 * fmr_x_LENGTH_meters / fmr_horizontal_resolution_m) fmi_topo_ny = NINT(0.5D0 * fmr_y_WIDTH_meters / fmr_horizontal_resolution_m) fmrv_topo_stress_dXYZ(1) = 0.5D0 * fmr_x_LENGTH_meters / fmi_topo_nx fmrv_topo_stress_dXYZ(2) = 0.5D0 * fmr_y_WIDTH_meters / fmi_topo_ny n_points = (2 * fmi_topo_nx + 1) * (2 * fmi_topo_ny + 1) * (2 * fmi_topo_nz + 1) memory_megabytes = n_points * 6.0D0 * 4.0D0 / (1024.0D0**2) n_memory_megabytes = NINT(memory_megabytes) file_megabytes = n_points * (3.0D0 * 7.0D0 + 6.0D0 * 10.0D0 + 2.0D0) / (1024.0D0**2) n_file_megabytes = NINT(file_megabytes) WRITE (*, "(' The available grid spacings closest to your target resolutions are')") WRITE (*, "(' (dX, dY, dZ) = (',F6.0,', ',F6.0,', ',F6.0,') meters')") fmrv_topo_stress_dXYZ(1), fmrv_topo_stress_dXYZ(2), fmrv_topo_stress_dXYZ(3) WRITE (*, "(' leading to topographic-stress subscript ranges of')") WRITE (*, "(' (-nx:nx, -ny:ny, -nz:nz) = (',I4,':',I3,', ',I4,':',I3,' ',I4,':',I3,')')") & & -fmi_topo_nx, fmi_topo_nx, -fmi_topo_ny, fmi_topo_ny, -fmi_topo_nz, fmi_topo_nz WRITE (*, "(' with a total of ',I10,' grid points requiring stress anomaly tensors,')") n_points WRITE (*, "(' which will require ',I7,' MB of memory and a save file of ',I7,' MB.')") n_memory_megabytes, n_file_megabytes ALLOCATE ( fmrv_reference_P_Pa(-fmi_topo_nz:fmi_topo_nz) ) ALLOCATE ( fmrt_topo_stress_anomaly_Pa(6, -fmi_topo_nx:fmi_topo_nx, -fmi_topo_ny:fmi_topo_ny, -fmi_topo_nz:fmi_topo_nz) ) !First subscript: 1) s_xx, 2) s_yy, 3) s_zz, 4) s_yz, 5) s_xz, 6) s_xy !Note that the total topographic stess model is the sum of the reference pressure and the topographic stress anomaly. CALL Compute_Topographic_Stress() WRITE (*, "(' -----------------------------------------------------------------------')") CALL Write_Topographic_Stress() ELSE ! ======================== LOAD A TOPOGRAPHIC STRESS MODEL COMPUTED PREVIOUSLY ============================== CALL Read_Topographic_Stress_part1() ALLOCATE ( fmim_DEM(fmi_DEM_rows, fmi_DEM_columns) ) ! to contain data about to be read from unit 2 CALL Read_Topographic_Stress_part2() IF (fmi_new_or_old_Moho == 1) THEN ! compute an ideal Moho shape for perfect isostasy fmi_Moho_rows = fmi_DEM_rows fmi_Moho_columns = fmi_DEM_columns fmr_Moho_lon_min = fmr_DEM_lon_min fmr_Moho_dLon = fmr_DEM_dLon fmr_Moho_lon_max = fmr_DEM_lon_max fmr_Moho_lat_min = fmr_DEM_lat_min fmr_Moho_dLat = fmr_DEM_dLat fmr_Moho_lat_max = fmr_DEM_lat_max fmr_Moho_lon_range = fmr_DEM_lon_range ALLOCATE ( fmim_Moho_elevation_m(fmi_Moho_rows, fmi_Moho_columns) ) WRITE (*, *) WRITE (*, "(' Re-computing Moho elevation, assuming perfect local isostasy...')") CALL Compute_Moho() fmc80_Moho_filename = "[undefined]" ELSE ! read Moho elevations from .GRD file !RE-READ MOHO !Note that this must be done in MAIN, as we will ALLOCATE a large permanent array. WRITE (*, *) WRITE (*, "(' Ready to re-read seismic Moho elevations (in m; all negative)')") WRITE (*, "(' from a file in Bird''s .GRD format.')") 511 WRITE (*, "(' You MUST re-use the same Moho .GRD file as before: '/' ',A)") TRIM(fmc80_Moho_filename) WRITE (*, "(' Please check now that it is available, in the input path...')") CALL Pause() fmc132_Moho_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_Moho_filename) OPEN (UNIT = 2, FILE = TRIM(fmc132_Moho_pathfile), STATUS = "OLD", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: File not found along input path. Move or retype and try again.')") CALL Pause() GO TO 511 END IF READ (2, *) fmr_Moho_lon_min, fmr_Moho_dLon, fmr_Moho_lon_max fmr_Moho_lon_range = fmr_Moho_lon_max - fmr_Moho_lon_min READ (2, *) fmr_Moho_lat_min, fmr_Moho_dLat, fmr_Moho_lat_max fmi_Moho_rows = 1 + NINT((fmr_Moho_lat_max - fmr_Moho_lat_min) / fmr_Moho_dLat) fmi_Moho_columns = 1 + NINT((fmr_Moho_lon_max - fmr_Moho_lon_min) / fmr_Moho_dLon) ALLOCATE ( fmim_Moho_elevation_m(fmi_Moho_rows, fmi_Moho_columns) ) READ (2, *) ((fmim_Moho_elevation_m(i, j), j = 1, fmi_Moho_columns), i = 1, fmi_Moho_rows) CLOSE (2) END IF ! fmi_new_or_old_Moho == 1, or CALL Read_Topographic_Stress_part3() ALLOCATE ( fmrv_reference_P_Pa(-fmi_topo_nz:fmi_topo_nz) ) ALLOCATE ( fmrt_topo_stress_anomaly_Pa(6, -fmi_topo_nx:fmi_topo_nx, -fmi_topo_ny:fmi_topo_ny, -fmi_topo_nz:fmi_topo_nz) ) CALL Read_Topographic_Stress_part4() END IF ! fmi_new_or_old_topographic = 1, or 2 (new topographic stress model, or reload an old model?) ================ !================================================================================================================= IF (fmi_new_or_old_topographic == 1) THEN fmi_new_or_old_tectonic = 1 ! no choice ELSE ! let user decide ... WRITE (*, *) WRITE (*, "(' DECISION POINT: Will you ...')") WRITE (*, "(' (1) Create a new tectonic stress model? (OR)')") WRITE (*, "(' (2) Load an existing tectonic stress model computed previously?')") 600 CALL DPrompt_for_Integer('Please select option 1 or 2.', fmi_new_or_old_tectonic, fmi_new_or_old_tectonic) IF ((fmi_new_or_old_tectonic < 1).OR.(fmi_new_or_old_tectonic > 2)) GO TO 600 END IF !We plan to project the tectonic stress anomaly model onto the topographic-stress grid, for graphical purposes: ALLOCATE ( fmrt_tectonic_stress_anomaly_Pa(6, -fmi_topo_nx:fmi_topo_nx, -fmi_topo_ny:fmi_topo_ny, -fmi_topo_nz:fmi_topo_nz) ) IF (fmi_new_or_old_tectonic == 1) THEN ! ========================= CREATE A NEW TECTONIC STRESS MODEL ================ 601 WRITE (*, *) WRITE (*, "(' -----------------------------------------------------------------------')") WRITE (*, "(' BEGINNING COMPUTATION OF A NEW TECTONIC STRESS MODEL...')") WRITE (*, "(' -----------------------------------------------------------------------')") WRITE (*, *) WRITE (*, "(' Which type of tectonic-stress-anomaly model do you want?')") WRITE (*, "(' (0) NO tectonic stress anomaly (only topographic stress).')") WRITE (*, "(' (1) Best-fit to existing CSM MODEL.')") WRITE (*, "(' (2) Compromise-fit to WSM data and existing CSM MODEL.')") 610 CALL DPrompt_for_Integer('Please select an integer option:', fmi_tectonic_model_mode, fmi_tectonic_model_mode) IF ((fmi_tectonic_model_mode < 0).OR.(fmi_tectonic_model_mode > 2)) GO TO 610 IF (fmi_tectonic_model_mode == 0) THEN ! dummy (all-zero) tectonic stress model fmc12_tectonic_token = "[none]" fmrt_tectonic_stress_anomaly_Pa = 0.0D0 ! values on grid, for graphical purposes. !Create dummy W = -1 tectonic stress coefficients (6 values of 0.0): fmi_waves = -1 fmi_N_coefficients = 6 fmi_top_lmn = 0 ALLOCATE ( fmdV_coefficients(fmi_N_coefficients, 1) ) ! coefficients in 1-subscript vector form; ! NOTE: The 2nd subscript is (1:1), required to avoid a compiler/linker error ! when searching for the proper generic form of GESVX in LAPACK! fmdV_coefficients = 0.0D0 ! all 6 set to zero ALLOCATE ( fmiv_k(fmi_N_coefficients) ) ALLOCATE ( fmc13v_name(fmi_N_coefficients) ) !ALLOCATE ( fmdv_a(fmi_top_lmn) ) !ALLOCATE ( fmdv_b(fmi_top_lmn) ) !ALLOCATE ( fmdv_c(fmi_top_lmn) ) ALLOCATE ( fmdv_F_at_x(fmi_N_coefficients) ) ALLOCATE ( fmdv_G_at_y(fmi_N_coefficients) ) ALLOCATE ( fmdv_H_at_z(fmi_N_coefficients) ) ALLOCATE ( fmdv_d_F_d_x_at_x(fmi_N_coefficients) ) ALLOCATE ( fmdv_d_G_d_y_at_y(fmi_N_coefficients) ) ALLOCATE ( fmdv_d_H_d_z_at_z(fmi_N_coefficients) ) ALLOCATE ( fmdv_d2_F_d_x2_at_x(fmi_N_coefficients) ) ALLOCATE ( fmdv_d2_G_d_y2_at_y(fmi_N_coefficients) ) ALLOCATE ( fmdv_d2_H_d_z2_at_z(fmi_N_coefficients) ) ALLOCATE ( fmdv_Q(fmi_N_coefficients) ) CALL Define_Coefficients() ELSE ! compute a new "real" tectonic stress model (fmi_tectonic_model_mode > 0): WRITE (*, *) WRITE (*, "(' Please enter a name (1~12 alphanumeric characters; no spaces)')") WRITE (*, "(' for this new tectonic stress model:')") READ (*, "(A)") fmc12_tectonic_token fmc12_tectonic_token = ADJUSTL(fmc12_tectonic_token) IF (LEN_TRIM(fmc12_tectonic_token) == 0) GO TO 601 IF (LEN_TRIM(fmc12_tectonic_token) >=3) THEN DO i = 2, (LEN_TRIM(fmc12_tectonic_token) - 1) IF (fmc12_tectonic_token(i:i) == ' ') fmc12_tectonic_token(i:i) = '_' END DO END IF 700 WRITE (*, *) CALL DPrompt_for_Integer("How many wavelengths in tectonic stress variation along each side of the model box?", fmi_waves, fmi_waves) IF ((fmi_waves < -1).OR.(fmi_waves > 10)) THEN WRITE (*, "(' ERROR: Please enter an integer in the range 0 to 6.')") CALL Pause() GO TO 700 END IF fmi_top_lmn = 2 * MAX(0, fmi_waves) IF (fmi_waves > 0) THEN ! normal case fmi_N_coefficients = 6 + 15 + 6 * 2 * fmi_top_lmn + 6 * 4 * fmi_top_lmn**2 + 3 * 8 * fmi_top_lmn**3 fmi_last_2DO = 6 + 15 + 6 * 2 * fmi_top_lmn + 6 * 4 * fmi_top_lmn**2 fmi_last_1DO = 6 + 15 + 6 * 2 * fmi_top_lmn ELSE IF (fmi_waves == 0) THEN ! only constant tau plus linear variation in space fmi_N_coefficients = 6 + 15 ELSE ! fmi_waves == -1; only constant tau fmi_N_coefficients = 6 END IF IF (fmi_tectonic_model_mode == 1) THEN fmr_linear_system_bytes = 8.0D0 * ( 2.0D0 * (fmi_N_coefficients**2) + 4.5D0 * fmi_N_coefficients) ELSE ! fmi_tectonic_model_mode == 2; an extra copy of CSM-part of linear system must be stored: fmr_linear_system_bytes = 8.0D0 * ( 3.0D0 * (fmi_N_coefficients**2) + 5.5D0 * fmi_N_coefficients) END IF fmr_linear_system_KB = fmr_linear_system_bytes / 1024.0D0 fmr_linear_system_MB = fmr_linear_system_bytes / ((1024.0D0)**2) fmr_linear_system_GB = fmr_linear_system_bytes / ((1024.0D0)**3) IF (fmr_linear_system_GB > 2.0D0) THEN WRITE (fmc12_linear_system_size, "(I9,' GB')") DInt_Above(fmr_linear_system_GB) ELSE IF (fmr_linear_system_MB > 2.0D0) THEN WRITE (fmc12_linear_system_size, "(I9,' MB')") DInt_Above(fmr_linear_system_MB) ELSE IF (fmr_linear_system_KB > 2.0D0) THEN WRITE (fmc12_linear_system_size, "(I9,' KB')") DInt_Above(fmr_linear_system_KB) ELSE WRITE (fmc12_linear_system_size, "(I6,' bytes')") NINT(fmr_linear_system_bytes) END IF WRITE (*, "(' This will require ',I12,' coefficients and')") fmi_N_coefficients WRITE (*, "(' solution of a linear system occupying ',A,' of computer memory.')") fmc12_linear_system_size CALL DPrompt_for_Logical("Do you wish to reconsider?", .FALSE., reconsider) IF (reconsider) GO TO 700 ALLOCATE ( fmdV_coefficients(fmi_N_coefficients, 1) ) ! coefficients in 1-subscript vector form; ! NOTE: The 2nd subscript is (1:1), required to avoid a compiler/linker error ! when searching for the proper generic form of GESVX in LAPACK! ALLOCATE ( fmiv_k(fmi_N_coefficients) ) ALLOCATE ( fmc13v_name(fmi_N_coefficients) ) ALLOCATE ( fmdv_a(fmi_top_lmn) ) ALLOCATE ( fmdv_b(fmi_top_lmn) ) ALLOCATE ( fmdv_c(fmi_top_lmn) ) ALLOCATE ( fmdv_F_at_x(fmi_N_coefficients) ) ALLOCATE ( fmdv_G_at_y(fmi_N_coefficients) ) ALLOCATE ( fmdv_H_at_z(fmi_N_coefficients) ) ALLOCATE ( fmdv_d_F_d_x_at_x(fmi_N_coefficients) ) ALLOCATE ( fmdv_d_G_d_y_at_y(fmi_N_coefficients) ) ALLOCATE ( fmdv_d_H_d_z_at_z(fmi_N_coefficients) ) ALLOCATE ( fmdv_d2_F_d_x2_at_x(fmi_N_coefficients) ) ALLOCATE ( fmdv_d2_G_d_y2_at_y(fmi_N_coefficients) ) ALLOCATE ( fmdv_d2_H_d_z2_at_z(fmi_N_coefficients) ) ALLOCATE ( fmdv_Q(fmi_N_coefficients) ) ALLOCATE ( fmdm_MATRIX(fmi_N_coefficients, fmi_N_coefficients) ) ALLOCATE ( fmdm_matrix_COPY(fmi_N_coefficients, fmi_N_coefficients) ) IF (fmi_tectonic_model_mode > 1) ALLOCATE ( fmdm_matrix_WIP(fmi_N_coefficients, fmi_N_coefficients) ) ALLOCATE ( fmdv_row_scale_factors(fmi_N_coefficients) ) ALLOCATE ( fmdv_column_scale_factors(fmi_N_coefficients) ) ALLOCATE ( fmiv_ipiv(fmi_N_coefficients) ) ALLOCATE ( fmdv_WORK(4*fmi_N_coefficients) ) ALLOCATE ( fmiv_iWork(fmi_N_coefficients) ) ALLOCATE ( fmdv_RHS(fmi_N_coefficients, 1) ) IF (fmi_tectonic_model_mode > 1) ALLOCATE ( fmdv_rhs_WIP(fmi_N_coefficients, 1) ) ! NOTE: The 2nd subscript is (1:1), required to avoid a compiler/linker error ! when searching for the proper generic form of GESVX in LAPACK! ALLOCATE ( fmdm_d_tau_d_c_at_point(6, fmi_N_coefficients) ) fmdm_d_tau_d_c_at_point = 0.0D0 ! whole array (1:6, 1:fmi_N_coefficients) CALL Define_Coefficients() IF ((fmi_tectonic_model_mode == 1).OR.(fmi_tectonic_model_mode == 2)) THEN ! read the existing CSM-format stress model: 710 WRITE (*, *) CALL DPrompt_for_String("Filename of existing CSM stress model?", fmc80_CSM_model_filename, fmc80_CSM_model_filename) fmc132_CSM_model_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_CSM_model_filename) OPEN (UNIT = 12, FILE = TRIM(fmc132_CSM_model_pathfile), STATUS = "OLD", PAD = "YES", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: This CSM model file not found'/' (in current input folder, ',A,').')") TRIM(fmc132_path_in) CALL Pause() GO TO 710 END IF CALL Read_CSM_Model(12, fmi_CSM_points_in_box) ! just counting them, this time CLOSE (UNIT = 12, DISP = "KEEP") ! CSM model file ALLOCATE ( fmtv_CSM_model(fmi_CSM_points_in_box) ) OPEN (UNIT = 12, FILE = TRIM(fmc132_CSM_model_pathfile), STATUS = "OLD", PAD = "YES") CALL Read_CSM_Model(12, fmi_CSM_points_in_box, fmtv_CSM_model) ! recording model predictions this time !Note that routine Read_CSM_Model will provide a few lines of output characterizing dataset size. CLOSE (UNIT = 12, DISP = "KEEP") ! CSM model file END IF ! tectonic_model_mode == 1.OR.2, so we need to read in the existing CSM stress model. IF (fmi_tectonic_model_mode == 2) THEN 720 WRITE (*, *) CALL DPrompt_for_String("Filename of WSM dataset?", fmc80_WSM_data_filename, fmc80_WSM_data_filename) fmc132_WSM_data_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_WSM_data_filename) OPEN (UNIT = 11, FILE = TRIM(fmc132_WSM_data_pathfile), STATUS = "OLD", PAD = "YES", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: This data file not found'/' (in current input folder, ',A,').')") TRIM(fmc132_path_in) CALL Pause() GO TO 720 END IF CALL Read_Stress_Data(11, fmi_sites_in_box) ! just counting them, this time CLOSE (UNIT = 11, DISP = "KEEP") ! scoring data file ALLOCATE ( fmtv_stress_data(fmi_sites_in_box) ) OPEN (UNIT = 11, FILE = TRIM(fmc132_WSM_data_pathfile), STATUS = "OLD", PAD = "YES") CALL Read_Stress_Data(11, fmi_sites_in_box, fmtv_stress_data) ! recording data this time !Note that routine Read_Stress_Data will provide a few lines of output characterizing dataset size and quality. CLOSE (UNIT = 11, DISP = "KEEP") ! scoring data file END IF ! tectonic_model_mode == 2, so we need to read in the WSM point data. CALL Compute_Tectonic_Stress() ! includes CALL Matrix_to_Vector(reverse = .TRUE.) CALL Write_Tectonic_Stress() CALL Tectonic_Stress_on_Grid() ! values on grid, for graphical purposes. ! Note that this routine will provide a progress indicator. CALL Mean_Tectonic_Stress() !DEALLOCATE by LIFO system: IF (ALLOCATED(fmtv_stress_data)) DEALLOCATE( fmtv_stress_data ) IF (ALLOCATED(fmtv_CSM_model)) DEALLOCATE ( fmtv_CSM_model ) DEALLOCATE ( fmdm_d_tau_d_c_at_point ) IF (ALLOCATED(fmdv_rhs_WIP)) DEALLOCATE ( fmdv_rhs_WIP ) DEALLOCATE ( fmdv_RHS ) DEALLOCATE ( fmiv_iWork ) DEALLOCATE ( fmdv_WORK ) DEALLOCATE ( fmiv_ipiv ) DEALLOCATE ( fmdv_column_scale_factors ) ! <=== GETTING RID of arrays only needed for solving the linear system. DEALLOCATE ( fmdv_row_scale_factors ) IF (ALLOCATED(fmdm_matrix_WIP)) DEALLOCATE ( fmdm_matrix_WIP ) DEALLOCATE ( fmdm_matrix_COPY ) DEALLOCATE ( fmdm_MATRIX ) !DEALLACATE ( fmdv_Q ) ! <==== KEEPING this group of arrays, for evaluation of tectonic stress !DEALLOCATE ( fmdv_d2_H_d_z2_at_z ) !DEALLOCATE ( fmdv_d2_G_d_y2_at_y ) !DEALLOCATE ( fmdv_d2_F_d_x2_at_x ) !DEALLOCATE ( fmdv_d_H_d_z_at_z ) !DEALLOCATE ( fmdv_d_G_d_y_at_y ) !DEALLOCATE ( fmdv_d_F_d_x_at_x ) !DEALLOCATE ( fmdv_H_at_z ) !DEALLOCATE ( fmdv_G_at_y ) !DEALLOCATE ( fmdv_F_at_x ) !DEALLOCATE ( fmdv_c ) !DEALLOCATE ( fmdv_b ) !DEALLOCATE ( fmdv_a ) !DEALLOCATE ( fmc13v_name ) !DEALLOCATE ( fmiv_k ) !DEALLOCATE ( fmdV_coefficients ) END IF ! fmi_tectonic_model_mode == 0 (null model), or POSITIVE (usually) ELSE ! ======================== LOAD A TECTONIC STRESS MODEL COMPUTED PREVIOUSLY ================================= CALL Read_Tectonic_Stress_part1() fmi_top_lmn = 2 * MAX(0, fmi_waves) IF (fmi_waves > 0) THEN ! normal case fmi_N_coefficients = 6 + 15 + 6 * 2 * fmi_top_lmn + 6 * 4 * fmi_top_lmn**2 + 3 * 8 * fmi_top_lmn**3 fmi_last_2DO = 6 + 15 + 6 * 2 * fmi_top_lmn + 6 * 4 * fmi_top_lmn**2 fmi_last_1DO = 6 + 15 + 6 * 2 * fmi_top_lmn ELSE IF (fmi_waves == 0) THEN ! only constant tau plus linear variation in space fmi_N_coefficients = 6 + 15 ELSE ! only constant tau fmi_N_coefficients = 6 END IF ALLOCATE ( fmdV_coefficients(fmi_N_coefficients, 1) ) ! coefficients in 1-subscript vector form; ! NOTE: The 2nd subscript is (1:1), required to avoid a compiler/linker error ! when searching for the proper generic form of GESVX in LAPACK! ALLOCATE ( fmiv_k(fmi_N_coefficients) ) ALLOCATE ( fmc13v_name(fmi_N_coefficients) ) ALLOCATE ( fmdv_a(fmi_top_lmn) ) ALLOCATE ( fmdv_b(fmi_top_lmn) ) ALLOCATE ( fmdv_c(fmi_top_lmn) ) ALLOCATE ( fmdv_F_at_x(fmi_N_coefficients) ) ALLOCATE ( fmdv_G_at_y(fmi_N_coefficients) ) ALLOCATE ( fmdv_H_at_z(fmi_N_coefficients) ) ALLOCATE ( fmdv_d_F_d_x_at_x(fmi_N_coefficients) ) ALLOCATE ( fmdv_d_G_d_y_at_y(fmi_N_coefficients) ) ALLOCATE ( fmdv_d_H_d_z_at_z(fmi_N_coefficients) ) ALLOCATE ( fmdv_d2_F_d_x2_at_x(fmi_N_coefficients) ) ALLOCATE ( fmdv_d2_G_d_y2_at_y(fmi_N_coefficients) ) ALLOCATE ( fmdv_d2_H_d_z2_at_z(fmi_N_coefficients) ) ALLOCATE ( fmdv_Q(fmi_N_coefficients) ) CALL Define_Coefficients() CALL Read_Tectonic_Stress_part2() CALL Tectonic_Stress_on_Grid() ! values on grid, for graphical purposes. WRITE (*, "(' Tectonic stress model (and program state) restored from save file.')") WRITE (*, "(' ==================================================================')") CALL Mean_Tectonic_Stress() END IF ! fmi_new_or_old_tectonic = 1, or 2 (new tectonic stress model, or reload an old model?) ====================== !===================================== MISFIT MEASURES ========================================================= WRITE (*, "(' ===============================================================================')") WRITE (*, *) WRITE (*, "(' MISFIT MEASURES:')") WRITE (*, *) !scoring with respect to data, such as World Stress Map (WSM): IF (ALLOCATED(fmtv_stress_data)) DEALLOCATE( fmtv_stress_data ) ! and re-read (as user may want to change datasets!). 800 CALL DPrompt_for_Logical("Do you wish to score this stress model against data (e.g., WSM2008)?", fml_do_scoring_vs_data, fml_do_scoring_vs_data) IF (fml_do_scoring_vs_data) THEN CALL DPrompt_for_String("Filename of scoring dataset?", fmc80_WSM_data_filename, fmc80_WSM_data_filename) fmc132_WSM_data_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_WSM_data_filename) OPEN (UNIT = 11, FILE = TRIM(fmc132_WSM_data_pathfile), STATUS = "OLD", PAD = "YES", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: This data file not found'/' (in current input folder, ',A,').')") TRIM(fmc132_path_in) CALL Pause() GO TO 800 END IF CALL Read_Stress_Data(11, fmi_sites_in_box) ! just counting them, this time CLOSE (UNIT = 11, DISP = "KEEP") ! scoring data file ALLOCATE ( fmtv_stress_data(fmi_sites_in_box) ) OPEN (UNIT = 11, FILE = TRIM(fmc132_WSM_data_pathfile), STATUS = "OLD", PAD = "YES") CALL Read_Stress_Data(11, fmi_sites_in_box, fmtv_stress_data) ! recording data this time !Note that routine Read_Stress_Data will provide a few lines of output characterizing dataset size and quality. CLOSE (UNIT = 11, DISP = "KEEP") ! scoring data file !----------------------- CALL Misfits_wrt_Data() ! which will provide output to user !----------------------- DEALLOCATE ( fmtv_stress_data ) END IF ! fml_do_scoring_vs_data WRITE (*, "(' ')") WRITE (*, *) !scoring with respect to an existing Community Stress Model (CSM), such as Shells_for_CSM [Bird, 2012, unpublished]. IF (ALLOCATED(fmtv_CSM_model)) DEALLOCATE( fmtv_CSM_model ) ! and re-read (as user may want to change datasets!). 850 CALL DPrompt_for_Logical("Do you wish to score this stress model against an existing CSM model?", fml_do_scoring_vs_model, fml_do_scoring_vs_model) IF (fml_do_scoring_vs_model) THEN CALL DPrompt_for_String("Filename of existing CSM model?", fmc80_CSM_model_filename, fmc80_CSM_model_filename) fmc132_CSM_model_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_CSM_model_filename) OPEN (UNIT = 12, FILE = TRIM(fmc132_CSM_model_pathfile), STATUS = "OLD", PAD = "YES", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: This CSM model file not found'/' (in current input folder, ',A,').')") TRIM(fmc132_path_in) CALL Pause() GO TO 850 END IF CALL Read_CSM_Model(12, fmi_CSM_points_in_box) ! just counting them, this time CLOSE (UNIT = 12, DISP = "KEEP") ! CSM model file ALLOCATE ( fmtv_CSM_model(fmi_CSM_points_in_box) ) OPEN (UNIT = 12, FILE = TRIM(fmc132_CSM_model_pathfile), STATUS = "OLD", PAD = "YES") CALL Read_CSM_Model(12, fmi_CSM_points_in_box, fmtv_CSM_model) ! recording model predictions this time !Note that routine Read_CSM_Model will provide a few lines of output characterizing dataset size. CLOSE (UNIT = 12, DISP = "KEEP") ! CSM model file !----------------------- CALL Misfits_wrt_CSM_Model() ! which will provide misfit measures to user !----------------------- DEALLOCATE ( fmtv_CSM_model ) ! release LARGE amount of memory used to store CSM model END IF ! fml_do_scoring_vs_model WRITE (*, *) !===================================== BEGIN OUTPUT MENU ========================================================= !Menu: WRITE (*, "(' ===============================================================================')") 900 WRITE (*, *) WRITE (*, "(' TOP-LEVEL OUTPUT OPTIONS MENU:')") WRITE (*, "(' (1) Create a MAP.')") WRITE (*, "(' (2) Create a vertical SECTION profile.')") WRITE (*, "(' (3) Create a virtual-borehole REPORT in tab-delimited ASCII format.')") WRITE (*, "(' (4) Create a stress-model REPORT in CSM format.')") WRITE (*, "(' (5) EXIT from FlatMaxwell.')") CALL DPrompt_for_Integer('Please select from 1~5:', fmi_output_menu_choice, fmi_output_menu_choice) IF ((fmi_output_menu_choice < 1).OR.(fmi_output_menu_choice > 5)) GO TO 900 IF (fmi_output_menu_choice == 1) THEN ! create a MAP ================================================================= CALL Create_Map() ELSE IF (fmi_output_menu_choice == 2) THEN ! create a SECTION ======================================================== CALL Create_Section() ELSE IF (fmi_output_menu_choice == 3) THEN ! create a virtual-borehole tab-delimited ASCII report ==================== CALL Create_Borehole() ELSE IF (fmi_output_menu_choice == 4) THEN ! create a REPORT in CSM format =========================================== CALL Create_Report() END IF ! fmi_output_menu_choice == 1, 2, or 3. (If == 5, then just exit.) ============================================ IF (fmi_output_menu_choice < 5) GO TO 900 CALL Write_INI_file() WRITE (*, *) WRITE (*, "(' Thank you for trying FlatMaxwell.')") CALL Pause() CONTAINS !************************************************************************************************************ SUBROUTINE Add_Title(line) ! Adds "line" to global array "fmc132v_titles" and bumps global "fmi_title_count" ! if "line" is non-blank and also is novel. CHARACTER*(*), INTENT(IN) :: line CHARACTER*132 :: copy LOGICAL :: blank, novel INTEGER :: i blank = LEN_TRIM(line) <= 0 IF (.NOT.blank) THEN copy = ADJUSTL(TRIM(line)) novel = .TRUE. IF (fmi_title_count > 0) THEN DO i = 1, fmi_title_count IF (TRIM(copy) == TRIM(fmc132v_titles(i))) novel = .FALSE. END DO ! i = 1, fmi_title_count END IF ! have stored fmc132v_titles already IF (novel) THEN fmi_title_count = MIN(20, fmi_title_count + 1) fmc132v_titles(fmi_title_count) = TRIM(copy) END IF ! novel END IF ! not blank END SUBROUTINE Add_Title SUBROUTINE Argument_of_North(longitude, latitude, argument_000_radians) !Projects a companion point (1 degree further North) onto the map, !and then computes the argument, relative to +x axis (CCW, in radians) !of the North-pointing line that defines azimuth = 000. IMPLICIT NONE REAL*8, INTENT(IN) :: longitude, latitude ! in degrees; E and N are +. REAL*8, INTENT(OUT) :: argument_000_radians REAL*8 :: d_x, d_y, x_0, x_N, y_0, y_N REAL*8, DIMENSION(3) :: uvec_0, uvec_N CALL DLonLat_2_Uvec(longitude, latitude, uvec_0) CALL DLonLat_2_Uvec(longitude, (latitude+1.0D0), uvec_N) CALL DProject(uvec = uvec_0, x = x_0, y = y_0) CALL DProject(uvec = uvec_N, x = x_N, y = y_N) d_x = x_N - x_0 d_y = y_N - y_0 argument_000_radians = DATAN2(d_y, d_x) END SUBROUTINE Argument_of_North SUBROUTINE Cats_Eye (xp, yp, radius_points) !Creates a horizontal lens in the margin; used to avoid !repeating same code 4x in fault-plane-solution explanation IMPLICIT NONE REAL*8, INTENT(IN) :: xp, yp, radius_points REAL*8 :: xp0,xp1,xp2,xp3,xps,yp0,yp1,yp2,yp3 xp0 = xp - radius_points xp1 = xp - 0.4D0 * radius_points ! adjust? xp2 = xp + 0.4D0 * radius_points ! adjust? xp3 = xp + radius_points yp0 = yp yp1 = yp + 0.6D0 * radius_points ! adjust? yp2 = yp1 yp3 = yp CALL DNew_L12_Path (1, xp0, yp0) CALL DCurve_to_L12 (xp1,yp1,xp2,yp2,xp3,yp3) xps = xp1 xp1 = xp2 xp2 = xps xp3 = xp0 yp1 = yp - (yp2 - yp) yp2 = yp1 CALL DCurve_to_L12 (xp1,yp1,xp2,yp2,xp3,yp3) CALL DEnd_L12_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE.) END SUBROUTINE Cats_Eye SUBROUTINE Chooser(bottomlegend_used_points, rightlegend_used_points, bottom, right) ! Decides whether there is more margin space at "bottom" or "right". ! Will return both = F if NOT (ai_bottomlegend_reserved OR ai_rightlegend_reserved). ! Refers to FiniteMap global variables: bottomlegend_used_points, rightlegend_used_points. REAL*8, INTENT(IN) :: bottomlegend_used_points, rightlegend_used_points LOGICAL, INTENT(OUT) :: bottom, right REAL*8 :: bottomlegend_free_points, rightlegend_free_points, & & x1_points, x2_points, y1_points, y2_points bottom = ai_bottomlegend_reserved right = ai_rightlegend_reserved IF (bottom.AND.right) THEN ! must choose one CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) bottomlegend_free_points = x2_points - x1_points - bottomlegend_used_points CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) rightlegend_free_points = y2_points - y1_points - rightlegend_used_points IF (rightlegend_free_points >= bottomlegend_free_points) THEN right = .TRUE. bottom = .FALSE. ELSE right = .FALSE. bottom = .TRUE. END IF END IF ! choice is needed END SUBROUTINE Chooser SUBROUTINE Compute_Moho() IMPLICIT NONE !but variables defined in FlatMaxwell are referenced freely, !including all the fmr_... values that define the 1-D reference density model. !Results are placed in predefined fmim_Moho_elevation_m(fmi_Moho_rows, fmi_Moho_columns) INTEGER :: elevation, i, j, Moho_ele REAL*8 :: Moho_density_contrast, topographic_load_Pa Moho_density_contrast = 0.5D0 * (fmr_mantle_density_at_Moho + fmr_mantle_density_at_LAB) - & & 0.5D0 * (fmr_crustal_density_at_top + fmr_crustal_density_at_Moho) !Note that this is positive. DO i = 1, fmi_Moho_rows DO j = 1, fmi_Moho_columns elevation = fmim_DEM(i, j) ! in meters above sea level IF (elevation >= 0) THEN ! land topographic_load_Pa = elevation * fmr_gravity * 0.5D0 * (fmr_crustal_density_at_top + fmr_crustal_density_at_Moho) + & & fmr_1_bar * (EXP(-elevation / fmr_atmosphere_scale_height_meters) - 1.0D0) ! Note that topographic_load_Pa is positive on land and negative at sea. ELSE ! sea topographic_load_Pa = elevation * fmr_gravity * 0.5D0 * (fmr_crustal_density_at_top + fmr_crustal_density_at_Moho) + & & ABS(elevation) * fmr_gravity * fmr_seawater_density END IF Moho_ele = -fmr_Moho_depth - topographic_load_Pa / (fmr_gravity * Moho_density_contrast) fmim_Moho_elevation_m(i, j) = Moho_ele END DO END DO END SUBROUTINE Compute_Moho SUBROUTINE Compute_Tectonic_Stress() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. CHARACTER*1 :: equed, fact, trans INTEGER :: b, b3, b6, & & i, ii, info, iteration, j, jj, k, k_goal, kk, kz1, kz2, & & l, last_iteration, last_kk, m, mm, n, nn, & & old_percent_done, percent_done LOGICAL :: continue, DEM_success, got_orientation, new_map_point, Reject_success, success REAL*8 :: argument_000_radians, Elon, fz1, fz2, grad_h_x, grad_h_y, lon, lat, Nlat, & & old_Elon, old_Nlat, reference_P_Pa, & & s1_argument_radians, s1_plunge_radians, s1_tensor_Pa, & & s2_argument_radians, s2_plunge_radians, s2_tensor_Pa, & & s3_argument_radians, s3_plunge_radians, s3_tensor_Pa, surface, & & test, WSM_group_weight, x_meters, y_meters, z_meters REAL*8, DIMENSION(3) :: a_vec, b_vec, c_vec, t_vec, nHat REAL*8, DIMENSION(3, 3) :: CSM_xyz_tensor, ENr_tensor_Pa, mu_s123_tensor, mu_xyz_tensor, pointers, Rmatrix, tau_s123_tensor, tau_xyz_tensor !------------------------------------------------------------------------------------------------------------------------ DOUBLE PRECISION, PARAMETER :: sigma_b = 2.0D6 ! The CSM-format model file SHELLS_for_CSM.txt has no uncertainties; ! therefore it seems reasonable to use a constant uncertainty for all stress ! components at all points. (This causes the uncertainty to scale out ! of the mode-1 linear system, having no effect on the answer.) It is also ! consistent with weighting all angular discrepancies equally during ! post-computational scoring of models. Here I arbitrarily choose ! the median seismic stress drop, which gives a characteristic amount of time- ! dependence, which is ONE lower-limit on uncertainty of any time-independent model or dataset. DOUBLE PRECISION, PARAMETER :: sigma_factor = 0.0D0 ! New parameter added 2014.12 for version 1.2. ! Increases sigma for constraints which have a non-zero target magnitude, to: ! ! sigma_this_time = MAX(sigma_b, sigma_factor * ABS(target_stress_component)). ! ! If this sigma_factor is 0.0D0, then it has no effect and the program runs as it ! did in version 1.1; in that case, the specific value of sigma_b is not important. ! However, if sigma_factor is a small positive number, then uncertainties are increased ! proportionally for high target stress components (e.g., ~400 MPa = ~4.0D8 Pa just below Moho). ! This helps to reduce aliasing effects caused by the spectral cut-off at Waves = 5~6, ! and thus reduce unwanted "ringing" or "waviness" in the deeper parts of the solution. ! On the other hand, I have found that positive sigma_factor leads to more serious underfitting ! of shear-stress maxima from the dynamic (e.g., Shells) model that is read in CSM format. ! With positive sigma_factor, the value of sigma_b becomes important, and should be plausible. DOUBLE PRECISION, PARAMETER :: conditioner = 2.0D12 ! cancels factors of 2/(2E6)**2, to simplify debugging & aid precision DOUBLE PRECISION, PARAMETER :: damper = 1.000D-8 ! Puts upper limit on condition number of linear system by increasing the smallest ! diagonal elements of the coefficient matrix, and thus increasing the lowest eigenvalues. ! Note that 1.0E-09 and 1.0D-10 have been tried, but they give up to 8~18% errors (worst-case ! forward error bounds) in the solution of the basic linear system, and also exhibit "inflation" ! of all coefficients (not a healthy sign), and noisy tau around the edges of the model ! domain, especially in unconstrained regions like the ocean. ! Values of 1.0D-7 and 1.0D-6 have also been tested, and these give "safe but blurred" solutions ! with less short-wavelength detail, and much of the computational time essentially wasted, ! because a large fraction of the eigenvalue/eigenvector balances are replaced by the damping. ! Another problem with over-damped solutions is that they give systematically less deviatoric ! stress than the Shells (or other dynamic) CSM model solution used as a target. ! My suggestion is to use 1.0D-8 as a starting point for experiments, and to consider ! many different kinds of plots & misfit-metrics of your output before making a final choice. !------------------------------------------------------------------------------------------------------------------------ DOUBLE PRECISION :: BC_weight_per_point, booster, common_mode, CSM_weight_per_point, delta_M, delta_RHS, & & high_diagonal, initial_CSM_weight_per_point, lead_factor, lead_factor_except_sigmaStarsM2, lead_factor_this_time, low_diagonal, & & mean_diagonal, rcond, rpvgrw, sigma_this_time, sum_over_q, WSM_weight_per_point DOUBLE PRECISION, DIMENSION(1) :: ferr, berr DOUBLE PRECISION, DIMENSION(6) :: d DOUBLE PRECISION, DIMENSION(6, 6) :: d_pB_d_tauQ DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: d_p_d_c ! for a single prediction p, at a single spatial point; subscript identifies coefficient c. DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: eigenvalues ! <=== used in study of eigenvalue structure; then commented-out for production WRITE (*, *) WRITE (*, "(' Computing tectonic stress ...')") ALLOCATE ( d_p_d_c(fmi_N_coefficients) ) fmd_BC_group_weight = 10.0D0 ! relative to 1.0D0 for total (fmd_CSM_group_weight + fmd_WSM_group_weight) IF (fmi_tectonic_model_mode == 1) THEN ! fit tectonic stress to an existing CSM model fmd_WSM_group_weight = 0.0D0 ! compare to fmd_CSM_weight and fmd_BC_group_weight. WSM_weight_per_point = 0.0D0 fmd_CSM_group_weight = 1.0D0 ! compare to fmd_WSM_weight and fmd_BC_group_weight. IF (fmi_CSM_points_in_box > 0) THEN CSM_weight_per_point = fmd_CSM_group_weight / (1.0D0 * fmi_CSM_points_in_box) initial_CSM_weight_per_point = CSM_weight_per_point ELSE WRITE (*, "(' ERROR: Cannot base solution on this CSM model because it has no points in model domain.')") CALL Pause() STOP END IF last_iteration = 1 ELSE IF (fmi_tectonic_model_mode == 2) THEN 20 WRITE (*, *) WRITE (*, "(' Choose weight for stress data (between 0.0 and 1.0), understanding')") WRITE (*, "(' that the complement of this weight will apply to the old CSM model.')") WSM_group_weight = fmd_WSM_group_weight CALL DPrompt_for_Real('Enter total weight for stress data: ', WSM_group_weight, WSM_group_weight) IF ((WSM_group_weight <= 0.0D0).OR.(WSM_group_weight >= 1.0D0)) THEN WRITE (*, "(' ERROR: Value is unacceptable; number must be greater than 0.0 and less than 1.0.')") CALL Pause() GO TO 20 END IF fmd_WSM_group_weight = WSM_group_weight ! compare to fmd_CSM_weight and fmd_BC_group_weight. fmd_CSM_group_weight = 1.0D0 - fmd_WSM_group_weight ! compare to fmd_WSM_weight and fmd_BC_group_weig IF (fmi_CSM_points_in_box > 0) THEN CSM_weight_per_point = fmd_CSM_group_weight / (1.0D0 * fmi_CSM_points_in_box) initial_CSM_weight_per_point = 1.0D0 / (1.0D0 * fmi_CSM_points_in_box) ! full weight in the first iteration ELSE WRITE (*, "(' ERROR: Cannot base solution on this CSM model because it has no points in model domain.')") CALL Pause() STOP END IF IF (fmi_sites_in_box > 0) THEN WSM_weight_per_point = fmd_WSM_group_weight / (1.0D0 * fmi_sites_in_box) ELSE WRITE (*, "(' ERROR: Cannot base solution on this WSM dataset because it has no points in model domain.')") CALL Pause() STOP END IF last_iteration = 2 ! first is in mode-1, to get principal stresses at sites of focal mechanisms END IF ! fmit_tectonic_model_mode == 1 or 2 DO iteration = 1, last_iteration IF (last_iteration > 1) THEN WRITE (*, *) WRITE (*, "(' --------------- Beginning iteration ',I2,' of ',I2,' -------------------')") iteration, last_iteration END IF !Zero the linear system: WRITE (*, "(' Zeroing the linear system ...')") fmdm_MATRIX = 0.0D0 ! size is (1:fmi_N_coefficients, 1:fmi_N_coefficients). fmdv_RHS = 0.0D0 ! N.B. Remember that this "vector" is really a "matrix" because it has a second subscript, which is always ", 1". !Build the linear system: WRITE (*, "(' Building the linear system ...')") IF (iteration == 1) THEN !MATCH TO CSM MODEL: !Note that the model must already have been READ and stored by calling main program. IF ((last_iteration > 1).AND.(iteration == 1)) THEN ! start mode-2 solution with one iteration in mode-1 lead_factor = initial_CSM_weight_per_point * conditioner * (2.0D0 / (sigma_b**2)) lead_factor_except_sigmaStarsM2 = initial_CSM_weight_per_point * conditioner * 2.0D0 ELSE ! mode == 1 (single iteration), or a later iteration in a mode == 2 solution lead_factor = CSM_weight_per_point * conditioner * (2.0D0 / (sigma_b**2)) lead_factor_except_sigmaStarsM2 = CSM_weight_per_point * conditioner * 2.0D0 END IF !-------------------------------------------------------------------------- d_pB_d_tauQ = 0.0D0 ! to clear the field before supplying non-zero entries: d_pB_d_tauQ(1,1) = 2.0D0/3.0D0 ; d_pB_d_tauQ(1,2) = -1.0D0/3.0D0 ; d_pB_d_tauQ(1,3) = -1.0D0/3.0D0 ! constraint on deviator component tauDEV_xx d_pB_d_tauQ(2,1) = -1.0D0/3.0D0 ; d_pB_d_tauQ(2,2) = 2.0D0/3.0D0 ; d_pB_d_tauQ(2,3) = -1.0D0/3.0D0 ! constraint on deviator component tauDEV_yy d_pB_d_tauQ(3,1) = -1.0D0/3.0D0 ; d_pB_d_tauQ(3,2) = -1.0D0/3.0D0 ; d_pB_d_tauQ(3,3) = 2.0D0/3.0D0 ! constraint on deviator component tauDEV_zz d_pB_d_tauQ(4,4) = 1.0D0 ! not actually used; diagonal part of matrix condensed out of the formula d_pB_d_tauQ(5,5) = 1.0D0 ! not actually used; diagonal part of matrix condensed out of the formula d_pB_d_tauQ(6,6) = 1.0D0 ! not actually used; diagonal part of matrix condensed out of the formula !-------------------------------------------------------------------------- WRITE (*, *) old_percent_done = 0 old_Nlat = -99.0D0 old_Elon = -999.0D0 ! just so we don't get an "undefined variable" error in Debug mode DO b = 1, fmi_CSM_points_in_box !retrieve critical data on target stress: x_meters = fmtv_CSM_model(b)%x_meters y_meters = fmtv_CSM_model(b)%y_meters z_meters = fmtv_CSM_model(b)%z_meters ENr_tensor_Pa(1:3, 1:3) = fmtv_CSM_model(b)%ENr_tensor_Pa(1:3, 1:3) !subtract P_0 * I to get target stress anomaly tensor: ! single subscript: k = -fmi_topo_nz, fmi_topo_nz kz1 = MAX(-fmi_topo_nz, DInt_Below((z_meters + (0.5D0 * fmr_z_DEPTH_meters)) / fmrv_topo_stress_dXYZ(3))) kz2 = MIN(fmi_topo_nz, (kz1+1)) fz2 = (z_meters - (-0.5D0 * fmr_z_DEPTH_meters + kz1 * fmrv_topo_stress_dXYZ(3))) / fmrv_topo_stress_dXYZ(3) fz1 = 1.0D0 - fz2 reference_P_Pa = fz1 * fmrv_reference_P_Pa(kz1) + fz2 * fmrv_reference_P_Pa(kz2) ENr_tensor_Pa(1, 1) = ENr_tensor_Pa(1, 1) + reference_P_Pa ! cancelling most of the strongly negative value ENr_tensor_Pa(2, 2) = ENr_tensor_Pa(2, 2) + reference_P_Pa ! cancelling most of the strongly negative value ENr_tensor_Pa(3, 3) = ENr_tensor_Pa(3, 3) + reference_P_Pa ! cancelling most of the strongly negative value !rotate target CSM stress anomaly to (x, y, z) coordinates: Elon = fmtv_CSM_model(b)%Elon Nlat = fmtv_CSM_model(b)%Nlat new_map_point = (Elon /= old_Elon).OR.(Nlat /= old_Nlat) IF (new_map_point) THEN ! Compute rotation matrix. (Otherwise, just continue to reuse the existing one.) old_Nlat = Nlat ! update memory old_Elon = Elon CALL Argument_of_North(Elon, Nlat, argument_000_radians) !Set up unit-vectors expressing (+East, +North, +r) for this map point, !expressing everything in model coordinates (+x{East}, +y{North}, +z{up}): pointers(1, 1) = DSIN(argument_000_radians) pointers(2, 1) = -DCOS(argument_000_radians) pointers(3, 1) = 0.0D0 ! which ends the first unit vector, giving +East in model (x, y, z). pointers(1, 2) = DCOS(argument_000_radians) pointers(2, 2) = DSIN(argument_000_radians) pointers(3, 2) = 0.0D0 ! which ends the second unit vector, giving +North in model (x, y, z). pointers(1, 3) = 0.0D0 pointers(2, 3) = 0.0D0 pointers(3, 3) = 1.0D0 ! which ends the third unit vector, giving +r in model (x, y, z). !Compute rotation matrix Rmatrix(3, 3) which rotates stress from (E, N, r) to model (x, y, z) coordinates: !DO ii = 1, 3 ! DO jj = 1, 3 ! Rmatrix(ii, jj) = identity(1, ii) * pointers(1, jj) + & ! & identity(2, ii) * pointers(2, jj) + & ! & identity(3, ii) * pointers(3, jj) ! END DO !END DO ! OR, equivalent but faster code: Rmatrix = pointers END IF ! new rotation matrix required !Rotate this CSM stress tensor from (E, N, r) to model (x, y, z) coordinates: DO ii = 1, 3 DO jj = 1, 3 CSM_xyz_tensor(ii, jj) = 0.0D0 DO mm = 1, 3 DO nn = 1, 3 CSM_xyz_tensor(ii, jj) = CSM_xyz_tensor(ii, jj) + Rmatrix(ii, mm) * ENr_tensor_Pa(mm, nn) * Rmatrix(jj, nn) END DO END DO END DO ! Note: These subscripts ii, jj, mm, nn are not used anywhere else in this routine. END DO !look up and subtract current FlatMaxwell topographic stress, to get target tectonic stress: CALL Get_Stress_Tensor(x = x_meters, y = y_meters, z = z_meters, choice = 1, success = success, xyz_tensor = mu_xyz_tensor) CSM_xyz_tensor = CSM_xyz_tensor - mu_xyz_tensor ! So, CSM_xyz_tensor is now the target tectonic stress. common_mode = (CSM_xyz_tensor(1,1) + CSM_xyz_tensor(2,2) + CSM_xyz_tensor(3,3)) / 3.0D0 CSM_xyz_tensor(1,1) = CSM_xyz_tensor(1,1) - common_mode CSM_xyz_tensor(2,2) = CSM_xyz_tensor(2,2) - common_mode CSM_xyz_tensor(3,3) = CSM_xyz_tensor(3,3) - common_mode ! So, now CSM_xyz_tensor is converted to the DEVIATOR of the target tectonic stress (dropping any systematic offsets in P!). d(1) = CSM_xyz_tensor(1, 1) ! deviatoric normal stress target d(2) = CSM_xyz_tensor(2, 2) ! deviatoric normal stress target d(3) = CSM_xyz_tensor(3, 3) ! deviatoric normal stress target d(4) = CSM_xyz_tensor(2, 3) !(deviatoric) shear stress target d(5) = CSM_xyz_tensor(1, 3) !(deviatoric) shear stress target d(6) = CSM_xyz_tensor(1, 2) !(deviatoric) shear stress target !get matrix of tectonic stress partials at this point: CALL Tectonic_Stress_at_Point(x_meters = x_meters, y_meters = y_meters, z_meters = z_meters, & & d_tau_d_c_at_point = fmdm_d_tau_d_c_at_point) !============================== BEGIN MOST TIME-CONSUMING PART OF PROGRAM: ============================================= !INCREMENT LINEAR SYSTEM FOR EACH CSM POINT: !First part: Match of deviator of tectonic stress tau to its CSM-model counterpart: DO b6 = 1, 3 ! 3 constraints on deviator of tectonic stress at each space point sigma_this_time = MAX(sigma_b, sigma_factor * ABS(d(b6))) lead_factor_this_time = lead_factor_except_sigmaStarsM2 / (sigma_this_time**2) !dir$ loop count min(64) DO i = 1, fmi_N_coefficients ! pre-build d_p_d_c, for this prediction p {value of b6}, at this particular spatial point {b}: d_p_d_c(i) = d_pB_d_tauQ(b6, 1) * fmdm_d_tau_d_c_at_point(1, i) + & & d_pB_d_tauQ(b6, 2) * fmdm_d_tau_d_c_at_point(2, i) + & & d_pB_d_tauQ(b6, 3) * fmdm_d_tau_d_c_at_point(3, i) ! omitting rows 4~6 of d_pB_d_tauQ, which add nothing END DO !Increment RHS in each row of linear system !dir$ loop count min(8) DO i = 1, fmi_N_coefficients delta_RHS = lead_factor_this_time * d(b6) * d_p_d_c(i) fmdv_RHS(i, 1) = fmdv_RHS(i, 1) + delta_RHS END DO ! i = 1, fmi_N_coefficients; rows of linear system !Increment coefficient matrix, working on COLUMNS instead of ROWS to avoid big memory strides in inner loop! DO j = 1, fmi_N_coefficients ! columns of the linear system IF (d_p_d_c(j) /= 0.0D0) THEN !dir$ loop count min(128) DO i = 1, j ! rows in one column of linear system; doing center diagonal and upper triangle only (to save 49% of time). delta_M = lead_factor_this_time * d_p_d_c(i) * d_p_d_c(j) fmdm_MATRIX(i, j) = fmdm_MATRIX(i, j) + delta_M END DO ! i = 1, j; half-column END IF ! we would not be wasting time adding zeros END DO ! j = 1, fmi_N_coefficients; columns of linear system END DO ! b6 = 1, 3; 3 constraints on deviator of tectonic stress at each space point !------------------------------------------------------------------------------------------------------------------------- DO b6 = 4, 6 ! 3 constraints on tectonic shear stress components at each space point sigma_this_time = MAX(sigma_b, sigma_factor * ABS(d(b6))) lead_factor_this_time = lead_factor_except_sigmaStarsM2 / (sigma_this_time**2) !Note: For speed, omitting the matrix d_pB_d_tauQ (which is just diagonal in these rows): !Increment RHS in each row of linear system: !dir$ loop count min(64) DO i = 1, fmi_N_coefficients ! row of linear system delta_RHS = lead_factor_this_time * d(b6) * fmdm_d_tau_d_c_at_point(b6, i) fmdv_RHS(i, 1) = fmdv_RHS(i, 1) + delta_RHS END DO ! i = 1, fmi_N_coefficients !Increment coefficient matrix, working on COLUMNS instead of ROWS to avoid big memory strides in inner loop! DO j = 1, fmi_N_coefficients ! column of linear system IF (fmdm_d_tau_d_c_at_point(b6, j) /= 0.0D0) THEN !dir$ loop count min(128) DO i = 1, j ! rows in one column; doing center diagonal and upper triangle only (to save 49% of time). delta_M = lead_factor_this_time * fmdm_d_tau_d_c_at_point(b6, i) * fmdm_d_tau_d_c_at_point(b6, j) fmdm_MATRIX(i, j) = fmdm_MATRIX(i, j) + delta_M END DO ! i = 1, j; half-column END IF ! we would not be wasting time adding zeros END DO ! j = 1, fmi_N_coefficients; columns of linear system END DO ! b6 = 4, 6 ! 3 constraints on tectonic shear stress components at each space point !============================== END MOST TIME-CONSUMING PART OF PROGRAM: ============================================= percent_done = DInt_Below((100.0D0 * b) / (1.0D0 * fmi_CSM_points_in_box)) IF (percent_done == 0) THEN WRITE (*, "('+',I10,' CSM data points considered...')") b ELSE IF (percent_done > old_percent_done) THEN WRITE (*, "('+ ',I3,'% of CSM data points considered...')") percent_done old_percent_done = percent_done END IF END IF END DO ! loop b = 1, fmi_CSM_points_in_box IF (last_iteration > 1) THEN ! save CSM-part of linear system for later reuse: WRITE (*, "(' Saving CSM-portion of linear system from memory, for later re-use...')") fmdm_matrix_WIP = fmdm_MATRIX ! whole matrix copied (even though lower triangle is zero) fmdv_rhs_WIP = fmdv_RHS ! whole forcing vector copied END IF ELSE ! iteration > 1, so recall saved CSM-portion of linear system from WIP storage arrays, and scale: WRITE (*, "(' Recalling CSM-portion of linear system from memory, and down-weighting it...')") fmdm_MATRIX = fmd_CSM_group_weight * fmdm_matrix_WIP ! reducing weight on CSM in later iterations. fmdv_RHS = fmd_CSM_group_weight * fmdv_rhs_WIP ! reducing weight on CSM in later iterations. END IF ! iteration == 1, and we need to create the CSM part of the linear system, OR iteration == 2, so we recall it! !UPPER BOUNDARY CONDITION of zero tractions (due to tau field) on sea-floor (under ocean) or sea-level (on land) BC_weight_per_point = fmd_BC_group_weight / ((2 * fmi_topo_nx + 1) * (2 * fmi_topo_ny + 1)) lead_factor = BC_weight_per_point * conditioner * (2.0D0 / (sigma_b**2)) lead_factor_except_sigmaStarsM2 = BC_weight_per_point * conditioner * 2.0D0 ! (never used in this section, since all targets are 0.0D0) WRITE (*, *) old_percent_done = 0 k = 0 k_goal = (2 * fmi_topo_nx + 1) * (2 * fmi_topo_ny + 1) DO ii = -fmi_topo_nx, fmi_topo_nx x_meters = ii * fmrv_topo_stress_dXYZ(1) DO jj = -fmi_topo_ny, fmi_topo_ny y_meters = jj * fmrv_topo_stress_dXYZ(2) CALL DEM_Lookup(x_meters, y_meters, & & Reject_success, lon, lat, & & DEM_success, surface, grad_h_x, grad_h_y) !-------------------------------------------------------------------------- d_pB_d_tauQ = 0.0D0 ! to clear the field before supplying non-zero entries (in initial 3 rows): IF (surface >= 0.0D0) THEN ! below land. BC applies on flat plane at sea-level. z_meters = 0.0D0 d_pB_d_tauQ(1,5) = 1.0D0 ! T_x = tau_xz == 0. d_pB_d_tauQ(2,4) = 1.0D0 ! T_y = tau_yz == 0. d_pB_d_tauQ(3,3) = 1.0D0 ! T_z = tau_zz == 0. ELSE ! sea-floor, presumably sloping: z_meters = surface ! Compute ~upward normal vector nHat: nHat(1) = -DSIN(DATAN(grad_h_x)) ! small? nHat(2) = -DSIN(DATAN(grad_h_y)) ! small? nHat(3) = DSQRT(1.0D0 - nHat(1)**2 - nHat(2)**2) ! near 1? d_pB_d_tauQ(1,5) = nHat(3); d_pB_d_tauQ(1,1) = nHat(1); d_pB_d_tauQ(1,6) = nHat(2) ! T_x = (tau_xz*nHat(3) + tau_xx*NHat(1) + tau_xy*nHat(2)) == 0. d_pB_d_tauQ(2,4) = nHat(3); d_pB_d_tauQ(2,6) = nHat(1); d_pB_d_tauQ(2,2) = nHat(2) ! T_y = (tau_yz*nHat(3) + tau_yx*nHat(1) + tau_yy*nHat(2)) == 0. d_pB_d_tauQ(3,3) = nHat(3); d_pB_d_tauQ(3,5) = nHat(1); d_pB_d_tauQ(3,4) = nHat(2) ! T_z = (tau_zz*nHat(3) + tau_zx*nHat(1) + tau_zy*nHat(2)) == 0. END IF ! below land, or sea? !get matrix of tectonic stress partials at this point: CALL Tectonic_Stress_at_Point(x_meters = x_meters, y_meters = y_meters, z_meters = z_meters, & & d_tau_d_c_at_point = fmdm_d_tau_d_c_at_point) !INCREMENT LINEAR SYSTEM FOR EACH UPPER-BC POINT: DO b3 = 1, 3 ! 3 constraints on traction components !dir$ loop count min(32) DO i = 1, fmi_N_coefficients d_p_d_c(i) = d_pB_d_tauQ(b3, 1) * fmdm_d_tau_d_c_at_point(1, i) + & & d_pB_d_tauQ(b3, 2) * fmdm_d_tau_d_c_at_point(2, i) + & & d_pB_d_tauQ(b3, 3) * fmdm_d_tau_d_c_at_point(3, i) + & & d_pB_d_tauQ(b3, 4) * fmdm_d_tau_d_c_at_point(4, i) + & & d_pB_d_tauQ(b3, 5) * fmdm_d_tau_d_c_at_point(5, i) + & & d_pB_d_tauQ(b3, 6) * fmdm_d_tau_d_c_at_point(6, i) END DO !dir$ loop count min(8) DO i = 1, fmi_N_coefficients ! row of linear system IF (d_p_d_c(i) /= 0.0D0) THEN DO j = i, fmi_N_coefficients ! column of linear system; doing center diagonal and upper triangle only (to save 49% of time). delta_M = lead_factor * d_p_d_c(j) * d_p_d_c(i) fmdm_MATRIX(i, j) = fmdm_MATRIX(i, j) + delta_M END DO ! j = 1, fmi_N_coefficients; column of linear system END IF END DO ! i = 1, fmi_N_coefficients; row of linear system END DO ! b3 = 1, 3; 3 constraints on traction components k = k + 1 percent_done = DInt_Below((100.0D0 * k) / (1.0D0 * k_goal)) IF (percent_done == 0) THEN WRITE (*, "('+',I10,' Upper-surface boundary points considered...')") k ELSE IF (percent_done > old_percent_done) THEN WRITE (*, "('+ ',I3,'% of upper-surface boundary points considered...')") percent_done old_percent_done = percent_done END IF END IF END DO ! loop on jj (surface points) END DO ! loop on ii (surface points) !conclusion of upper-surface BC !LOWER BOUNDARY CONDITION of zero tractions (due to total stress anomaly) !-------------------------------------------------------------------------- d_pB_d_tauQ = 0.0D0 ! to clear the field before supplying non-zero entries (in initial 3 rows): d_pB_d_tauQ(1,5) = 1.0D0 ! T_x = {stress-anomaly}_xz == 0., so tau_xz = -mu_xz d_pB_d_tauQ(2,4) = 1.0D0 ! T_y = {stress-anomaly}_yz == 0., so tau_yz = -mu_yz d_pB_d_tauQ(3,3) = 1.0D0 ! T_z = {stress-anomaly}_zz == 0., so tau_zz = -mu_zz !-------------------------------------------------------------------------- WRITE (*, *) old_percent_done = 0 k = 0 k_goal = (2 * fmi_topo_nx + 1) * (2 * fmi_topo_ny + 1) z_meters = -fmr_z_DEPTH_meters DO ii = -fmi_topo_nx, fmi_topo_nx x_meters = ii * fmrv_topo_stress_dXYZ(1) DO jj = -fmi_topo_ny, fmi_topo_ny y_meters = jj * fmrv_topo_stress_dXYZ(2) !look up and subtract current FlatMaxwell topographic stress, to get target tectonic stress: CALL Get_Stress_Tensor(x = x_meters, y = y_meters, z = z_meters, choice = 1, success = success, xyz_tensor = mu_xyz_tensor) IF (.NOT.success) THEN WRITE (*, "(' ERROR: Could not obtain mu tensor at (x, y, z) = ',3ES12.4)") x_meters, y_meters, z_meters WRITE (*, "(' Even though this position should have been pre-tested to be in the model domain.')") CALL Pause() STOP END IF d(1) = -mu_xyz_tensor(1,3) d(2) = -mu_xyz_tensor(2,3) d(3) = -mu_xyz_tensor(3,3) CALL Tectonic_Stress_at_Point(x_meters = x_meters, y_meters = y_meters, z_meters = z_meters, & & d_tau_d_c_at_point = fmdm_d_tau_d_c_at_point) !INCREMENT LINEAR SYSTEM FOR EACH LOWER-BC POINT: DO b3 = 1, 3 ! 3 constraints on traction components !dir$ loop count min(32) DO i = 1, fmi_N_coefficients d_p_d_c(i) = d_pB_d_tauQ(b3, 1) * fmdm_d_tau_d_c_at_point(1, i) + & & d_pB_d_tauQ(b3, 2) * fmdm_d_tau_d_c_at_point(2, i) + & & d_pB_d_tauQ(b3, 3) * fmdm_d_tau_d_c_at_point(3, i) + & & d_pB_d_tauQ(b3, 4) * fmdm_d_tau_d_c_at_point(4, i) + & & d_pB_d_tauQ(b3, 5) * fmdm_d_tau_d_c_at_point(5, i) + & & d_pB_d_tauQ(b3, 6) * fmdm_d_tau_d_c_at_point(6, i) END DO !dir$ loop count min(8) DO i = 1, fmi_N_coefficients ! row of linear system delta_RHS = lead_factor * d(b3) * d_p_d_c(i) fmdv_RHS(i, 1) = fmdv_RHS(i, 1) + delta_RHS IF (d_p_d_c(i) /= 0.0D0) THEN DO j = i, fmi_N_coefficients ! column of linear system; doing center diagonal and upper triangle only (to save 49% of time). delta_M = lead_factor * d_p_d_c(j) * d_p_d_c(i) fmdm_MATRIX(i, j) = fmdm_MATRIX(i, j) + delta_M END DO ! j = 1, fmi_N_coefficients; column of linear system END IF END DO ! i = 1, fmi_N_coefficients; row of linear system END DO ! b3 = 1, 3; 3 constraints on traction components k = k + 1 percent_done = DInt_Below((100.0D0 * k) / (1.0D0 * k_goal)) IF (percent_done == 0) THEN WRITE (*, "('+',I10,' Lower-surface boundary points considered...')") k ELSE IF (percent_done > old_percent_done) THEN WRITE (*, "('+ ',I3,'% of lower-surface boundary points considered...')") percent_done old_percent_done = percent_done END IF END IF END DO ! loop on jj (basal points) END DO ! loop on ii (basal points) !conclusion of bottom BC !LOWER (asthenospheric) SIDE BOUNDARY CONDITION of zero tractions (due to total stress anomaly) IF (fmr_LAB_depth <= fmr_z_DEPTH_meters) THEN ! lower parts of model side-walls exend into asthenosphere last_kk = NINT((-fmr_LAB_depth - (-0.5D0 * FMr_z_DEPTH_meters)) / fmrv_topo_stress_dXYZ(3)) WRITE (*, "(' Applying side BCs from z-index of ',I3,' to z-index of ',I3)") -fmi_topo_nz, last_kk old_percent_done = 0 k = 0 k_goal = (2 * (2 * fmi_topo_nx + 1) + 2 * (2 * fmi_topo_ny - 1)) * (last_kk + fmi_topo_nz + 1) WRITE (*, *) DO kk = -fmi_topo_nz, last_kk z_meters = kk * fmrv_topo_stress_dXYZ(3) - 0.5D0 * fmr_z_DEPTH_meters DO ii = -fmi_topo_nx, fmi_topo_nx x_meters = ii * fmrv_topo_stress_dXYZ(1) inner_jj_loop: DO jj = -fmi_topo_ny, fmi_topo_ny y_meters = jj * fmrv_topo_stress_dXYZ(2) IF ((jj == -fmi_topo_ny).OR.(jj == fmi_topo_ny)) THEN ! on S or N wall (y-plane) !-------------------------------------------------------------------------- d_pB_d_tauQ = 0.0D0 ! to clear the field before supplying non-zero entries (in initial 3 rows): d_pB_d_tauQ(1,6) = 1.0D0 ! T_x = {stress-anomaly}_xy == 0., so tau_xy = -mu_xy d_pB_d_tauQ(2,2) = 1.0D0 ! T_y = {stress-anomaly}_yy == 0., so tau_yy = -mu_yy d_pB_d_tauQ(3,4) = 1.0D0 ! T_z = {stress-anomaly}_zy == 0., so tau_zy = -mu_zy !-------------------------------------------------------------------------- !look up and subtract current FlatMaxwell topographic stress, to get target tectonic stress: CALL Get_Stress_Tensor(x = x_meters, y = y_meters, z = z_meters, choice = 1, success = success, xyz_tensor = mu_xyz_tensor) IF (.NOT.success) THEN WRITE (*, "(' ERROR: Could not obtain mu tensor at (x, y, z) = ',3ES12.4)") x_meters, y_meters, z_meters WRITE (*, "(' Even though this position should have been pre-tested to be in the model domain.')") CALL Pause() STOP END IF d(1) = -mu_xyz_tensor(1,2) d(2) = -mu_xyz_tensor(2,2) d(3) = -mu_xyz_tensor(3,2) ELSE IF ((ii == -fmi_topo_nx).OR.(ii == fmi_topo_nx)) THEN ! on an E or W wall (x-plane): !-------------------------------------------------------------------------- d_pB_d_tauQ = 0.0D0 ! to clear the field before supplying non-zero entries (in initial 3 rows): d_pB_d_tauQ(1,1) = 1.0D0 ! T_x = {stress-anomaly}_xx == 0., so tau_xx = -mu_xx d_pB_d_tauQ(2,6) = 1.0D0 ! T_y = {stress-anomaly}_yx == 0., so tau_yx = -mu_yx d_pB_d_tauQ(3,5) = 1.0D0 ! T_z = {stress-anomaly}_zx == 0., so tau_zx = -mu_zx !-------------------------------------------------------------------------- !look up and subtract current FlatMaxwell topographic stress, to get target tectonic stress: CALL Get_Stress_Tensor(x = x_meters, y = y_meters, z = z_meters, choice = 1, success = success, xyz_tensor = mu_xyz_tensor) IF (.NOT.success) THEN WRITE (*, "(' ERROR: Could not obtain mu tensor at (x, y, z) = ',3ES12.4)") x_meters, y_meters, z_meters WRITE (*, "(' Even though this position should have been pre-tested to be in the model domain.')") CALL Pause() STOP END IF d(1) = -mu_xyz_tensor(1,1) d(2) = -mu_xyz_tensor(2,1) d(3) = -mu_xyz_tensor(3,1) ELSE ! not on any side-wall CYCLE inner_jj_loop ! which only abandons the current point (in a full 3-D grid of points) END IF !At this point, we must be on SOME side-wall, with planes and goals predefined. CALL Tectonic_Stress_at_Point(x_meters = x_meters, y_meters = y_meters, z_meters = z_meters, & & d_tau_d_c_at_point = fmdm_d_tau_d_c_at_point) !INCREMENT LINEAR SYSTEM FOR EACH LOWER-BC POINT: DO b3 = 1, 3 ! 3 constraints on traction components !dir$ loop count min(32) DO i = 1, fmi_N_coefficients d_p_d_c(i) = d_pB_d_tauQ(b3, 1) * fmdm_d_tau_d_c_at_point(1, i) + & & d_pB_d_tauQ(b3, 2) * fmdm_d_tau_d_c_at_point(2, i) + & & d_pB_d_tauQ(b3, 3) * fmdm_d_tau_d_c_at_point(3, i) + & & d_pB_d_tauQ(b3, 4) * fmdm_d_tau_d_c_at_point(4, i) + & & d_pB_d_tauQ(b3, 5) * fmdm_d_tau_d_c_at_point(5, i) + & & d_pB_d_tauQ(b3, 6) * fmdm_d_tau_d_c_at_point(6, i) END DO !dir$ loop count min(8) DO i = 1, fmi_N_coefficients ! row of linear system delta_RHS = lead_factor * d(b3) * d_p_d_c(i) fmdv_RHS(i, 1) = fmdv_RHS(i, 1) + delta_RHS IF (d_p_d_c(i) /= 0.0D0) THEN DO j = i, fmi_N_coefficients ! column of linear system; doing center diagonal and upper triangle only (to save 49% of time). delta_M = lead_factor * d_p_d_c(j) * d_p_d_c(i) fmdm_MATRIX(i, j) = fmdm_MATRIX(i, j) + delta_M END DO ! j = 1, fmi_N_coefficients; column of linear system END IF END DO ! i = 1, fmi_N_coefficients; row of linear system END DO ! b3 = 1, 3; 3 constraints on traction components k = k + 1 percent_done = DInt_Below((100.0D0 * k) / (1.0D0 * k_goal)) IF (percent_done == 0) THEN WRITE (*, "('+',I10,' Lower-sidewall boundary points considered...')") k ELSE IF (percent_done > old_percent_done) THEN WRITE (*, "('+ ',I3,'% of lower-sidewall boundary points considered...')") percent_done old_percent_done = percent_done END IF END IF END DO inner_jj_loop ! loop on jj (y) END DO ! loop on ii (x) END DO ! kk = -fmi_topo_nz, last_kk END IF ! side-walls extend down into asthenosphere !conclusion of lower (asthenospheric) side BCs !============================================================================================== IF ((fmi_tectonic_model_mode == 2).AND.(iteration > 1)) THEN ! add constraints at each WSM data point: WRITE (*, "(' Applying principal-axis directions at most of ',I6,' WSM data points...')") fmi_sites_in_box old_percent_done = 0 k = 0 k_goal = fmi_sites_in_box WRITE (*, *) !MATCH TO WSM DATA: !Note that the data must already have been READ and stored by calling main program. lead_factor = WSM_weight_per_point * conditioner * (2.0D0 / (sigma_b**2)) lead_factor_except_sigmaStarsM2 = WSM_weight_per_point * conditioner * 2.0D0 !-------------------------------------------------------------------------- DO b = 1, fmi_sites_in_box !Retrieve critical parameters about this stress datum (usually, but not always, and EQ FPS): x_meters = fmtv_stress_data(b)%x_meters y_meters = fmtv_stress_data(b)%y_meters z_meters = fmtv_stress_data(b)%z_meters s1_argument_radians = fmtv_stress_data(b)%s1_argument_radians s1_plunge_radians = fmtv_stress_data(b)%s1_plunge_radians s2_argument_radians = fmtv_stress_data(b)%s2_argument_radians s2_plunge_radians = fmtv_stress_data(b)%s2_plunge_radians s3_argument_radians = fmtv_stress_data(b)%s3_argument_radians s3_plunge_radians = fmtv_stress_data(b)%s3_plunge_radians got_orientation = (s1_argument_radians > -998.0D0).AND.(s1_plunge_radians > -998.0D0).AND. & & (s2_argument_radians > -998.0D0).AND.(s2_plunge_radians > -998.0D0).AND. & & (s3_argument_radians > -998.0D0).AND.(s3_plunge_radians > -998.0D0) IF (got_orientation) THEN !Set up unit-vectors expressing (+s1, +s2, +s3) for this map point, !expressing everything in model coordinates (+x{~East}, +y{~North}, +z{up}): pointers(1, 1) = DCOS(s1_argument_radians) * DCOS(s1_plunge_radians) pointers(2, 1) = DSIN(s1_argument_radians) * DCOS(s1_plunge_radians) pointers(3, 1) = -DSIN(s1_plunge_radians) ! which ends the first unit vector, giving +s1 in model (x, y, z). pointers(1, 2) = DCOS(s2_argument_radians) * DCOS(s2_plunge_radians) pointers(2, 2) = DSIN(s2_argument_radians) * DCOS(s2_plunge_radians) pointers(3, 2) = -DSIN(s2_plunge_radians) ! which ends the second unit vector, giving +s2 in model (x, y, z). pointers(1, 3) = DCOS(s3_argument_radians) * DCOS(s3_plunge_radians) pointers(2, 3) = DSIN(s3_argument_radians) * DCOS(s3_plunge_radians) pointers(3, 3) = -DSIN(s3_plunge_radians) ! which ends the third unit vector, giving +s3 in model (x, y, z). !Check for right-handedness(?) of 3 pointers, and reverse column #3 (the s3-axis) if necessary: a_vec(1:3) = pointers(1:3, 1) b_vec(1:3) = pointers(1:3, 2) c_vec(1:3) = pointers(1:3, 3) CALL DCross(a_vec, b_vec, t_vec) test = DDot(t_vec, c_vec) IF (test < 0.0D0) THEN pointers(1:3, 3) = -pointers(1:3, 3) END IF !Note: "pointers" is now a stress-tensor-rotation matrix, which could be used to rotate from (+s1, +s2, +s3) coordinates to (x, y, z). !However, what we need is the inverse operator, which is the transpose of this matrix: Rmatrix(1, 1) = pointers(1, 1) Rmatrix(1, 2) = pointers(2, 1) Rmatrix(1, 3) = pointers(3, 1) Rmatrix(2, 1) = pointers(1, 2) Rmatrix(2, 2) = pointers(2, 2) Rmatrix(2, 3) = pointers(3, 2) Rmatrix(3, 1) = pointers(1, 3) Rmatrix(3, 2) = pointers(2, 3) Rmatrix(3, 3) = pointers(3, 3) !Look up current FlatMaxwell topographic stress, to we can negate it to get the target tectonic stress: CALL Get_Stress_Tensor(x = x_meters, y = y_meters, z = z_meters, choice = 1, success = success, xyz_tensor = mu_xyz_tensor) !Rotate FlatMaxwell topographic stress to stress-datum-principal-axis coordinates: DO ii = 1, 3 DO jj = 1, 3 mu_s123_tensor(ii, jj) = 0.0D0 DO mm = 1, 3 DO nn = 1, 3 mu_s123_tensor(ii, jj) = mu_s123_tensor(ii, jj) + Rmatrix(ii, mm) * mu_xyz_tensor(mm, nn) * Rmatrix(jj, nn) END DO END DO END DO END DO !Note that mu_s123_tensor is now the current FlatMaxwell topographic stress in datum principal-axis coordinates. d_pB_d_tauQ = 0.0D0 ! to clear the field before supplying non-zero entries (B = 1~6, Q = 1~6). !--------------------------------------------------------------------------------------------------------------- !For b6 = 1 (out of 6), arbitrarily select shear stress s_23 {ii = 2; jj = 3} to be evaluated (and set to zero): ! DO mm = 1, 3 ! DO nn = 1, 3 ! s123_tensor(2, 3) = s123_tensor(2, 3) + Rmatrix(2, mm) * xyz_tensor(mm, nn) * Rmatrix(3, nn) ! END DO ! END DO d_pB_d_tauQ(1, 1) = Rmatrix(2, 1) * Rmatrix(3, 1) ! coefficient of xyz_tensor(1, 1) {mm = 1, nn = 1} d_pB_d_tauQ(1, 2) = Rmatrix(2, 2) * Rmatrix(3, 2) ! coefficient of xyz_tensor(2, 2) {mm = 2, nn = 2} d_pB_d_tauQ(1, 3) = Rmatrix(2, 3) * Rmatrix(3, 3) ! coefficient of xyz_tensor(3, 3) {mm = 3, nn = 3} d_pB_d_tauQ(1, 4) = Rmatrix(2, 2) * Rmatrix(3, 3) + Rmatrix(2, 3) * Rmatrix(3, 2) ! coefficient of xyz_tensor(2, 3) {mm = 2; nn = 3} = xyz_tensor(3, 2) {mm = 3; nn = 2} d_pB_d_tauQ(1, 5) = Rmatrix(2, 1) * Rmatrix(3, 3) + Rmatrix(2, 3) * Rmatrix(3, 1) ! coefficient of xyz_tensor(1, 3) {mm = 1; nn = 3} = xyz_tensor(3, 1) {mm = 3; nn = 1} d_pB_d_tauQ(1, 6) = Rmatrix(2, 1) * Rmatrix(3, 2) + Rmatrix(2, 2) * Rmatrix(3, 1) ! coefficient of xyz_tensor(1, 2) {mm = 1; nn = 2} = xyz_tensor(2, 1) {mm = 2; nn = 1} d(1) = -mu_s123_tensor(2, 3) !--------------------------------------------------------------------------------------------------------------- !For b6 = 2 (out of 6), sequentially select shear stress s_13 {ii = 1; jj = 3} to be evaluated (and set to zero): ! DO mm = 1, 3 ! DO nn = 1, 3 ! s123_tensor(1, 3) = s123_tensor(1, 3) + Rmatrix(1, mm) * xyz_tensor(mm, nn) * Rmatrix(3, nn) ! END DO ! END DO d_pB_d_tauQ(2, 1) = Rmatrix(1, 1) * Rmatrix(3, 1) ! coefficient of xyz_tensor(1, 1) {mm = 1, nn = 1} d_pB_d_tauQ(2, 2) = Rmatrix(1, 2) * Rmatrix(3, 2) ! coefficient of xyz_tensor(2, 2) {mm = 2, nn = 2} d_pB_d_tauQ(2, 3) = Rmatrix(1, 3) * Rmatrix(3, 3) ! coefficient of xyz_tensor(3, 3) {mm = 3, nn = 3} d_pB_d_tauQ(2, 4) = Rmatrix(1, 2) * Rmatrix(3, 3) + Rmatrix(1, 3) * Rmatrix(3, 2) ! coefficient of xyz_tensor(2, 3) {mm = 2; nn = 3} = xyz_tensor(3, 2) {mm = 3; nn = 2} d_pB_d_tauQ(2, 5) = Rmatrix(1, 1) * Rmatrix(3, 3) + Rmatrix(1, 3) * Rmatrix(3, 1) ! coefficient of xyz_tensor(1, 3) {mm = 1; nn = 3} = xyz_tensor(3, 1) {mm = 3; nn = 1} d_pB_d_tauQ(2, 6) = Rmatrix(1, 1) * Rmatrix(3, 2) + Rmatrix(1, 2) * Rmatrix(3, 1) ! coefficient of xyz_tensor(1, 2) {mm = 1; nn = 2} = xyz_tensor(2, 1) {mm = 2; nn = 1} d(2) = -mu_s123_tensor(1, 3) !--------------------------------------------------------------------------------------------------------------- !For b6 = 3 (out of 6), sequentially select shear stress s_12 {ii = 1; jj = 2} to be evaluated (and set to zero): ! DO mm = 1, 3 ! DO nn = 1, 3 ! s123_tensor(1, 3) = s123_tensor(1, 3) + Rmatrix(1, mm) * xyz_tensor(mm, nn) * Rmatrix(3, nn) ! END DO ! END DO d_pB_d_tauQ(3, 1) = Rmatrix(1, 1) * Rmatrix(2, 1) ! coefficient of xyz_tensor(1, 1) {mm = 1, nn = 1} d_pB_d_tauQ(3, 2) = Rmatrix(1, 2) * Rmatrix(2, 2) ! coefficient of xyz_tensor(2, 2) {mm = 2, nn = 2} d_pB_d_tauQ(3, 3) = Rmatrix(1, 3) * Rmatrix(2, 3) ! coefficient of xyz_tensor(3, 3) {mm = 3, nn = 3} d_pB_d_tauQ(3, 4) = Rmatrix(1, 2) * Rmatrix(2, 3) + Rmatrix(1, 3) * Rmatrix(2, 2) ! coefficient of xyz_tensor(2, 3) {mm = 2; nn = 3} = xyz_tensor(3, 2) {mm = 3; nn = 2} d_pB_d_tauQ(3, 5) = Rmatrix(1, 1) * Rmatrix(2, 3) + Rmatrix(1, 3) * Rmatrix(2, 1) ! coefficient of xyz_tensor(1, 3) {mm = 1; nn = 3} = xyz_tensor(3, 1) {mm = 3; nn = 1} d_pB_d_tauQ(3, 6) = Rmatrix(1, 1) * Rmatrix(2, 2) + Rmatrix(1, 2) * Rmatrix(2, 1) ! coefficient of xyz_tensor(1, 2) {mm = 1; nn = 2} = xyz_tensor(2, 1) {mm = 2; nn = 1} d(3) = -mu_s123_tensor(1, 2) !--------------------------------------------------------------------------------------------------------------- !Find the 3 principal tectonic stresses, and impose: !(Note that MOST will come from iteration-1 solution (that was done in mode-1); only a FEW will come from actual data.) !Look up current estimate of tectonic stress, to we can enforce it in iteration #2: CALL Get_Stress_Tensor(x = x_meters, y = y_meters, z = z_meters, choice = 2, success = success, xyz_tensor = tau_xyz_tensor) !Rotate iteration-1 tectonic stress to stress-datum-principal-axis coordinates: DO ii = 1, 3 DO jj = 1, 3 tau_s123_tensor(ii, jj) = 0.0D0 DO mm = 1, 3 DO nn = 1, 3 tau_s123_tensor(ii, jj) = tau_s123_tensor(ii, jj) + Rmatrix(ii, mm) * tau_xyz_tensor(mm, nn) * Rmatrix(jj, nn) END DO END DO END DO END DO !Note that tau_s123_tensor is now the iteration-1 tectonic stress in datum principal-axis coordinates. !--------------------------------------------------------------------------------------------------------------- ! S1 principal tectonic stress constraint (in datum principal-axis coordinates): s1_tensor_Pa = fmtv_stress_data(b)%s1_tensor_Pa IF ((s1_tensor_Pa > -1000.0D0).AND.(s1_tensor_Pa < -998.0D0)) THEN ! "-999." is conventional flag for a missing value (TYPICAL): d(4) = tau_s123_tensor(1, 1) ! goal, inherited from mode-1 solution in iteration 1. ELSE ! data value is meaningful; now, subtract topographic stress to get goal for tectonic stress: d(4) = s1_tensor_Pa - mu_s123_tensor(1, 1) ! goal, from (datum stress) - (topographic stress) END IF !For b6 = 4 (out of 6), select tectonic stress s_11 {ii = 1; jj = 1} to be constrained: ! DO mm = 1, 3 ! DO nn = 1, 3 ! s123_tensor(1, 1) = s123_tensor(1, 1) + Rmatrix(1, mm) * xyz_tensor(mm, nn) * Rmatrix(1, nn) ! END DO ! END DO d_pB_d_tauQ(4, 1) = Rmatrix(1, 1) * Rmatrix(1, 1) ! coefficient of xyz_tensor(1, 1) {mm = 1, nn = 1} d_pB_d_tauQ(4, 2) = Rmatrix(1, 2) * Rmatrix(1, 2) ! coefficient of xyz_tensor(2, 2) {mm = 2, nn = 2} d_pB_d_tauQ(4, 3) = Rmatrix(1, 3) * Rmatrix(1, 3) ! coefficient of xyz_tensor(3, 3) {mm = 3, nn = 3} d_pB_d_tauQ(4, 4) = Rmatrix(1, 2) * Rmatrix(1, 3) + Rmatrix(1, 3) * Rmatrix(1, 2) ! coefficient of xyz_tensor(2, 3) {mm = 2; nn = 3} = xyz_tensor(3, 2) {mm = 3; nn = 2} d_pB_d_tauQ(4, 5) = Rmatrix(1, 1) * Rmatrix(1, 3) + Rmatrix(1, 3) * Rmatrix(1, 1) ! coefficient of xyz_tensor(1, 3) {mm = 1; nn = 3} = xyz_tensor(3, 1) {mm = 3; nn = 1} d_pB_d_tauQ(4, 6) = Rmatrix(1, 1) * Rmatrix(1, 2) + Rmatrix(1, 2) * Rmatrix(1, 1) ! coefficient of xyz_tensor(1, 2) {mm = 1; nn = 2} = xyz_tensor(2, 1) {mm = 2; nn = 1} !--------------------------------------------------------------------------------------------------------------- ! S2 principal tectonic stress constraint (in datum principal-axis coordinates): s2_tensor_Pa = fmtv_stress_data(b)%s2_tensor_Pa IF ((s2_tensor_Pa > -1000.0D0).AND.(s2_tensor_Pa < -998.0D0)) THEN ! "-999." is conventional flag for a missing value (TYPICAL): d(5) = tau_s123_tensor(2, 2) ! goal, inherited from mode-1 solution in iteration 1. ELSE ! data value is meaningful; now, subtract topographic stress to get goal for tectonic stress: d(5) = s2_tensor_Pa - mu_s123_tensor(2, 2) ! goal, from (datum stress) - (topographic stress) END IF !For b6 = 5 (out of 6), select tectonic stress s_22 {ii = 2; jj = 2} to be constrained: ! DO mm = 1, 3 ! DO nn = 1, 3 ! s123_tensor(2, 2) = s123_tensor(2, 2) + Rmatrix(2, mm) * xyz_tensor(mm, nn) * Rmatrix(2, nn) ! END DO ! END DO d_pB_d_tauQ(5, 1) = Rmatrix(2, 1) * Rmatrix(2, 1) ! coefficient of xyz_tensor(1, 1) {mm = 1, nn = 1} d_pB_d_tauQ(5, 2) = Rmatrix(2, 2) * Rmatrix(2, 2) ! coefficient of xyz_tensor(2, 2) {mm = 2, nn = 2} d_pB_d_tauQ(5, 3) = Rmatrix(2, 3) * Rmatrix(2, 3) ! coefficient of xyz_tensor(3, 3) {mm = 3, nn = 3} d_pB_d_tauQ(5, 4) = Rmatrix(2, 2) * Rmatrix(2, 3) + Rmatrix(2, 3) * Rmatrix(2, 2) ! coefficient of xyz_tensor(2, 3) {mm = 2; nn = 3} = xyz_tensor(3, 2) {mm = 3; nn = 2} d_pB_d_tauQ(5, 5) = Rmatrix(2, 1) * Rmatrix(2, 3) + Rmatrix(2, 3) * Rmatrix(2, 1) ! coefficient of xyz_tensor(1, 3) {mm = 1; nn = 3} = xyz_tensor(3, 1) {mm = 3; nn = 1} d_pB_d_tauQ(5, 6) = Rmatrix(2, 1) * Rmatrix(2, 2) + Rmatrix(2, 2) * Rmatrix(2, 1) ! coefficient of xyz_tensor(1, 2) {mm = 1; nn = 2} = xyz_tensor(2, 1) {mm = 2; nn = 1} !--------------------------------------------------------------------------------------------------------------- ! S3 principal tectonic stress constraint (in datum principal-axis coordinates): s3_tensor_Pa = fmtv_stress_data(b)%s3_tensor_Pa IF ((s3_tensor_Pa > -1000.0D0).AND.(s3_tensor_Pa < -998.0D0)) THEN ! "-999." is conventional flag for a missing value (TYPICAL): d(6) = tau_s123_tensor(3, 3) ! goal, inherited from mode-1 solution in iteration 1. ELSE ! data value is meaningful; now, subtract topographic stress to get goal for tectonic stress: d(6) = s3_tensor_Pa - mu_s123_tensor(3, 3) ! goal, from (datum stress) - (topographic stress) END IF !For b6 = 6 (out of 6), select tectonic stress s_22 {ii = 2; jj = 2} to be constrained: ! DO mm = 1, 3 ! DO nn = 1, 3 ! s123_tensor(3, 3) = s123_tensor(3, 3) + Rmatrix(3, mm) * xyz_tensor(mm, nn) * Rmatrix(3, nn) ! END DO ! END DO d_pB_d_tauQ(6, 1) = Rmatrix(3, 1) * Rmatrix(3, 1) ! coefficient of xyz_tensor(1, 1) {mm = 1, nn = 1} d_pB_d_tauQ(6, 2) = Rmatrix(3, 2) * Rmatrix(3, 2) ! coefficient of xyz_tensor(2, 2) {mm = 2, nn = 2} d_pB_d_tauQ(6, 3) = Rmatrix(3, 3) * Rmatrix(3, 3) ! coefficient of xyz_tensor(3, 3) {mm = 3, nn = 3} d_pB_d_tauQ(6, 4) = Rmatrix(3, 2) * Rmatrix(3, 3) + Rmatrix(3, 3) * Rmatrix(3, 2) ! coefficient of xyz_tensor(2, 3) {mm = 2; nn = 3} = xyz_tensor(3, 2) {mm = 3; nn = 2} d_pB_d_tauQ(6, 5) = Rmatrix(3, 1) * Rmatrix(3, 3) + Rmatrix(3, 3) * Rmatrix(3, 1) ! coefficient of xyz_tensor(1, 3) {mm = 1; nn = 3} = xyz_tensor(3, 1) {mm = 3; nn = 1} d_pB_d_tauQ(6, 6) = Rmatrix(3, 1) * Rmatrix(3, 2) + Rmatrix(3, 2) * Rmatrix(3, 1) ! coefficient of xyz_tensor(1, 2) {mm = 1; nn = 2} = xyz_tensor(2, 1) {mm = 2; nn = 1} !--------------------------------------------------------------------------------------------------------------- !Impose these 6 constraints on the linear system; !start by getting the necessary matrix of partial derivatives of stresses at this point: CALL Tectonic_Stress_at_Point(x_meters = x_meters, y_meters = y_meters, z_meters = z_meters, & & d_tau_d_c_at_point = fmdm_d_tau_d_c_at_point) DO b6 = 1, 6 sigma_this_time = MAX(sigma_b, sigma_factor * ABS(d(b6))) lead_factor_this_time = lead_factor_except_sigmaStarsM2 / (sigma_this_time**2) !dir$ loop count min(64) DO i = 1, fmi_N_coefficients ! pre-build d_p_d_c, for this prediction p {value of b6}, at this particular spatial point {b}: d_p_d_c(i) = d_pB_d_tauQ(b6, 1) * fmdm_d_tau_d_c_at_point(1, i) + & & d_pB_d_tauQ(b6, 2) * fmdm_d_tau_d_c_at_point(2, i) + & & d_pB_d_tauQ(b6, 3) * fmdm_d_tau_d_c_at_point(3, i) + & & d_pB_d_tauQ(b6, 4) * fmdm_d_tau_d_c_at_point(4, i) + & & d_pB_d_tauQ(b6, 5) * fmdm_d_tau_d_c_at_point(5, i) + & & d_pB_d_tauQ(b6, 6) * fmdm_d_tau_d_c_at_point(6, i) END DO !Increment RHS in each row of linear system !dir$ loop count min(8) DO i = 1, fmi_N_coefficients delta_RHS = lead_factor_this_time * d(b6) * d_p_d_c(i) fmdv_RHS(i, 1) = fmdv_RHS(i, 1) + delta_RHS END DO ! i = 1, fmi_N_coefficients; rows of linear system !Increment coefficient matrix, working on COLUMNS instead of ROWS to avoid big memory strides in inner loop! DO j = 1, fmi_N_coefficients ! columns of the linear system IF (d_p_d_c(j) /= 0.0D0) THEN !dir$ loop count min(128) DO i = 1, j ! rows in one column of linear system; doing center diagonal and upper triangle only (to save 49% of time). delta_M = lead_factor_this_time * d_p_d_c(i) * d_p_d_c(j) fmdm_MATRIX(i, j) = fmdm_MATRIX(i, j) + delta_M END DO ! i = 1, j; half-column END IF ! we would not be wasting time adding zeros END DO ! j = 1, fmi_N_coefficients; columns of linear system END DO ! b6 = 1, 3; 3 constraints on tectonic shear stresses (in s1, s2, s3 coordinates) at this WSM data point !------------------------------------------------------------------------------------------------------------------------- END IF ! got_orientation, so this WSM datum can be used !Monitor and report progress... k = k + 1 percent_done = DInt_Below((100.0D0 * k) / (1.0D0 * k_goal)) IF (percent_done == 0) THEN WRITE (*, "('+',I10,' WSN data points considered...')") k ELSE IF (percent_done > old_percent_done) THEN WRITE (*, "('+ ',I3,'% of WSM data points considered...')") percent_done old_percent_done = percent_done END IF END IF END DO ! b = 1, fmi_sites_in_box END IF ! (fmi_tectonic_model_mode == 2) .AND. (iteration > 1) !============================================================================================== !RESTORE SYMMETRY BY COPYING TRIANGLE: WRITE (*, "(' Copying lower triangle of coefficient matrix from upper triangle...')") !dir$ loop count min(32) DO i = 2, fmi_N_coefficients !dir$ ivdep DO j = 1, (i-1) fmdm_MATRIX(i, j) = fmdm_MATRIX(j, i) END DO END DO WRITE (*, *) !===================================================================================== !Apply damping to keep condition number acceptable and restrain "flighty" eigenvectors with small eigenvalues: low_diagonal = 9.9999D+99 high_diagonal = -9.9999D+99 DO i = 1, fmi_N_coefficients low_diagonal = MIN(low_diagonal, fmdm_MATRIX(i, i)) high_diagonal = MAX(high_diagonal, fmdm_MATRIX(i, i)) END DO WRITE (*, "(' Diagonal values range from ',ES14.6,' to ',ES14.6)") low_diagonal, high_diagonal booster = damper * high_diagonal WRITE (*, "(' Adding increment of ',ES14.6,' to all diagonal coefficients')") booster WRITE (*, "(' to damp the solution very slightly.')") DO i = 1, fmi_N_coefficients fmdm_MATRIX(i, i) = fmdm_MATRIX(i, i) + booster END DO !IF (last_iteration == 1) THEN !WRITE (*, *) !WRITE (*, "(' Conducting eigenvalue analysis of linear system...')") !OPEN (UNIT = 17, FILE = "fmdm_MATRIX_diagonals.dat") !DO i = 1, fmi_N_coefficients ! WRITE (17, "(I10,ES10.2)") i, fmdm_MATRIX(i, i) !END DO !CLOSE(17) !ALLOCATE ( eigenvalues(fmi_N_coefficients) ) !fmdm_matrix_COPY = fmdm_MATRIX ! work on the copy; leave the original intact !!Manual page for LAPACK's syevd is at: https://software.intel.com/en-us/node/469180 !!The manual quotes the following "Fortran 95" CALL model: !!CALL dsyevd(jobz, uplo,n, a, lda, w, work, lwork, iwork, liwork, info) !CALL dsyevd('N', 'U', fmi_N_coefficients,fmdm_matrix_COPY,fmi_N_coefficients,eigenvalues,fmdv_WORK,4*fmi_N_coefficients,fmiv_iWork,fmi_N_coefficients,info) !OPEN (UNIT = 18, FILE = "eigenvalues.dat") !DO i = 1, fmi_N_coefficients ! WRITE (18, "(I6,ES14.6)") i, eigenvalues(i) !END DO !CLOSE(18) !WRITE (*, "(' dsyevd reports info = ',I12)") info !WRITE (*, *) !END IF ! last_iteration == 1 !Use linear-system-solver GESVX from MKL/LAPACK which includes option for equilibration: WRITE (*, "(' Solving the linear system with GESVX from MKL/LAPACK, using REAL*8 ...')") fact = 'E' ! "Equilibrate, please" given as a variable, just in case gesvx wants to change this. trans = 'N' ! "No transpose" given as a variable, just in case gesvx wants to change this. !Manual page is at: https://software.intel.com/en-us/node/520974#A4716EBA-52AE-489B-8208-42C6EAA572B4 !The manual quotes the following "Fortran 95" CALL model, where brackets [] hold optional arguments: !CALL gesvx( a, b, x [,af] [,ipiv] [,fact] [,trans] [,equed] [,r] [,c] [,ferr] [,berr] [,rcond] [,rpvgrw] [,info] ) ! or the following minimal CALL: !CALL gesvx( a = fmdm_MATRIX, b = fmdv_RHS, x = fmdV_coefficients ) ! Experimentation with this helped to clarify the need for a declared ! 2nd subscript (range 1:1) in both the b = fmdv_RHS and the x = fmdV_coefficients. !The following Fortran-95-style CALL is elegant, and compiles correctly, but leads to a linker error LNK2019 "unresolved external symbol" ! (even when compiler switches are properly set to link-in MKL/LAPACK. Therefore, I cannot use it. !CALL gesvx( a = fmdm_MATRIX, b = fmdv_RHS, x = fmdV_coefficients, & ! & fact = fact, trans = trans, af = fmdm_matrix_COPY, r = fmdv_row_scale_factors, c = fmdv_column_scale_factors, & ! & rcond = rcond, ferr = ferr, berr = berr, ipiv = fmiv_ipiv, equed = equed, rpvgrw = rpvgrw, info = info ) !Instead, I use the old FORTRAN-77-style CALL below, which both compiles and links correctly: !CALL dgesvx( fact, trans, n, nrhs, a, lda, af, & ! & ldaf, ipiv, equed, r, c, & ! & b, ldb, x, ldx, rcond, ferr, berr, & ! & work, iwork, info ) CALL DGESVX( fact, trans, fmi_N_coefficients, 1, fmdm_MATRIX, fmi_N_coefficients, fmdm_matrix_COPY, & & fmi_N_coefficients, fmiv_ipiv, equed, fmdv_row_scale_factors, fmdv_column_scale_factors, & & fmdv_RHS, fmi_N_coefficients, fmdV_coefficients, fmi_N_coefficients, rcond, ferr, berr, & & fmdv_WORK, fmiv_iWork, info ) WRITE (*, "(' The following characterization of the solution was provided by GESVX:')") WRITE (*, "(' Processing method indicator equed = ',A)") equed WRITE (*, "(' Reciprocal conditional number rcond = ',ES14.6)") rcond WRITE (*, "(' Forward error estimate ferr(1) = ',ES14.6)") ferr(1) WRITE (*, "(' Backward error estimate berr(1) = ',ES14.6)") berr(1) !WRITE (*, "(' Reciprocal pivot growth factor norm work(1) = ',ES14.6)") rpvgrw !Caution: The above metric is not provided when we use the Fortran-77-style CALL DGESVX, so rpvgrw will be undefined. ! Any attempt to write out the value of an undefined variable will cause an abend in Debug mode. WRITE (*, "(' Overall success measure info = ',I10)") info WRITE (*, "(' -----------------------------------------------')") IF ((last_iteration > 1).AND.(iteration == 1)) THEN ! compute tectonic stress estimate based solely on CSM fitting (as in mode == 1): CALL Tectonic_Stress_on_Grid() ! values on grid, for graphical purposes. ! Note that this routine will provide a progress indicator. END IF IF (last_iteration > 1) THEN WRITE (*, *) WRITE (*, "(' ------------------ Ending iteration ',I2,' of ',I2,' -------------------')") iteration, last_iteration END IF END DO ! iteration = 1, last_iteration WRITE (*, "(' ======== Solution for coefficients of tectonic stress completed. ========')") WRITE (*, *) END SUBROUTINE Compute_Tectonic_Stress SUBROUTINE Compute_Topographic_Stress() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. !------------------------------------------------ INTEGER, PARAMETER :: horizontal_refinement = 8 ! refers to both finer sampling of topography AND (* h_r**2) more source points, both at-surface and at-depth !CAUTION: If you reduce horizontal_refinement, then topographic-stress solutions may be unrealistic under mountains, ! down to depths of several kilometers below sea-level! Make test-plots, and be sure that results are acceptable! ! (Note: You can save time by making these tests in a mountainous region only ~100000 m x 100000 m square, and omitting the tectonic-stress calculation.) INTEGER, PARAMETER :: vertical_refinement = 10 ! refers to finer sampling of density anomalies vertically, but not a greater number of source points in depth !Note: The cost, in execution time, of large vertical_refinement is much less than that of large horizontal_refinement. !------------------------------------------------ INTEGER :: i, i_fine, i1, i2, ii, j, j_fine, j1, j2, jj, k, kk, l, m, mm, n, nn, n_deeper, n_x_margin, n_y_margin, old_percent, percent_done LOGICAL :: DEM_success, Moho_success, Reject_success REAL*8 :: azimuth_radians, c_M, Cerruti_load_N_x, Cerruti_load_N_y, Cerruti_traction_x, Cerruti_traction_y, & & dA_m2, dV_m3, density_anomaly, dx, dy, east, elevation_m, elevation_test, & & f, fx1, fx2, fy1, fy2, grad_h_x, grad_h_y, lat, lon, load_P, load_Pa, local_density, & & Moho_elevation, mu_M, north, & & P_M, part, pressure_anomaly, r, r_M, R1_M, R2_M, Rcap, & & sigma_r, sigma_r_M, sigma_theta, sigma_theta_M, sigma_z, sigma_z_M, south, surface, & & tau_rz, tau_rz_M, & & west, x_source, x_test, x_W, y_source, y_test, y_W, & & z_M, z_source, z_source_floor, z_source_fine, z_test, z_W REAL*8, DIMENSION(3) :: uvec REAL*8, DIMENSION(horizontal_refinement) :: fraction REAL*8, DIMENSION(3, 3) :: B_ds_cylindrical, B_ds_model, C_x_ds, C_y_ds, pointers, M_ds_cylindrical, M_ds_model, Rmatrix 10 WRITE (*, *) CALL DPrompt_for_Real("Poisson ratio for uniform elastic half-space:", fmr_Poisson_ratio, fmr_Poisson_ratio) IF ((fmr_Poisson_ratio < 0.0D0).OR.(fmr_Poisson_ratio > 0.5D0)) THEN WRITE (*, "(' ERROR: Poisson_ratio should be in the range 0.0 ~ 0.5.')") CALL Pause() GO TO 10 END IF !compute reference pressure, based on 1-D reference density model: DO k = -fmi_topo_nz, fmi_topo_nz elevation_m = -0.5D0 * fmr_z_DEPTH_meters + k * fmrv_topo_stress_dXYZ(3) IF (elevation_m >= fmr_Moho_elevation) THEN ! in the crust fmrv_reference_P_Pa(k) = fmr_1_bar + fmr_gravity * fmr_crustal_density_at_top * (-elevation_m) + & & 0.5D0 * fmr_gravity * ((fmr_crustal_density_at_Moho - fmr_crustal_density_at_top) / fmr_Moho_depth) * (elevation_m**2) ELSE IF (elevation_m >= fmr_LAB_elevation) THEN ! in the mantle lithosphere fmrv_reference_P_Pa(k) = fmr_1_bar + fmr_gravity * 0.5D0 * (fmr_crustal_density_at_top + fmr_crustal_density_at_Moho) * fmr_Moho_depth + & & fmr_gravity * fmr_mantle_density_at_Moho * (fmr_Moho_elevation - elevation_m) + & & 0.5D0 * fmr_gravity * ((fmr_mantle_density_at_LAB - fmr_mantle_density_at_Moho) / (fmr_LAB_depth - fmr_Moho_depth)) * & & ((elevation_m - fmr_Moho_elevation)**2) ELSE ! into the asthenosphere fmrv_reference_P_Pa(k) = fmr_1_bar + fmr_gravity * 0.5D0 * (fmr_crustal_density_at_top + fmr_crustal_density_at_Moho) * fmr_Moho_depth + & & fmr_gravity * 0.5D0 * (fmr_mantle_density_at_Moho + fmr_mantle_density_at_LAB) * (fmr_LAB_depth - fmr_Moho_depth) + & & fmr_gravity * fmr_mantle_density_at_LAB * (fmr_LAB_elevation - elevation_m) END IF END DO !OPEN (UNIT = 3, FILE = TRIM(fmc132_path_out)//"fmrv_reference_P_Pa.dat") !DO k = -fmi_topo_nz, fmi_topo_nz ! elevation_m = -0.5D0 * fmr_z_DEPTH_meters + k * fmrv_topo_stress_dXYZ(3) ! WRITE (3, *) elevation_m, fmrv_reference_P_Pa(k) !END DO !CLOSE(3) WRITE (*, *) WRITE (*, "(' Computing topographic stress (SLOW)...'/)") fmrt_topo_stress_anomaly_Pa = 0.0D0 ! initialize whole array, before starting to sum. !All 3 of the analytic solutions that are here convolved with distributed density anomalies !are for point forces, so they have stress singularities at their source points. !To tame these singularities, I put the equivalent point loads !(each representing a volume with an anomalous density) !on a staggered grid which is offset by vector (dx/2, dy/2, dz/2) from the grid !of test points (fmrt_topo_stress_anomaly_Pa) we are computing. !In the horizontal dimensions, this source grid extends ~100 km beyond !each edge of the grid of test points, to minimize unwanted edge effects. !In the vertical dimension, there are no points outside the depth limits !of the model box; instead, mountains above the box are represented by !external loads on the flat surface of an elastic half-space, at sea level. n_x_margin = NINT(100000.0D0 / fmrv_topo_stress_dXYZ(1)) n_y_margin = NINT(100000.0D0 / fmrv_topo_stress_dXYZ(2)) DO i = 1, horizontal_refinement fraction(i) = - 0.5D0 + ((i - 0.5D0) / horizontal_refinement) !e.g.: -0.4, -0.2, 0.0, 0.2, 0.4 when horizontal_refinement = 5 END DO part = 1.0D0 / (horizontal_refinement**2) dA_m2 = part * fmrv_topo_stress_dXYZ(1) * fmrv_topo_stress_dXYZ(2) dV_m3 = part * fmrv_topo_stress_dXYZ(1) * fmrv_topo_stress_dXYZ(2) * fmrv_topo_stress_dXYZ(3) old_percent = 0 DO i = -(fmi_topo_nx + n_x_margin + 1), (fmi_topo_nx + n_x_margin) DO i_fine = 1, horizontal_refinement ! e.g., 5? x_source = (i + 0.5D0 + fraction(i_fine)) * fmrv_topo_stress_dXYZ(1) DO j = -(fmi_topo_ny + n_y_margin + 1), (fmi_topo_ny + n_y_margin) DO j_fine = 1, horizontal_refinement ! e.g., 5? y_source = (j + 0.5D0 + fraction(j_fine)) * fmrv_topo_stress_dXYZ(2) !Determine surface (hard-rock surface) elevation and its gradient: CALL DEM_Lookup(x_source, y_source, & & Reject_success, lon, lat, & & DEM_success, surface, grad_h_x, grad_h_y) IF (Reject_success.AND.DEM_success) THEN !Compute stress due to point load of mountains (if any) outside the upper surface of the model box: IF (surface > 0.0D0) THEN load_P = dA_m2 * & ! <--surface area of one (refined) source-grid point & (surface * fmr_gravity * fmr_crustal_density_at_top + & ! <--main positive term (force pointing down) & fmr_1_bar * (EXP(-surface / fmr_atmosphere_scale_height_meters) - 1.0D0)) ! secondary negative correction !Note that load_P is always positive, and Cerruti_load_N_x, y are the 2 components of horizontal force !exerted by the rocks above sea level (outside the model) on the half-space below sea level (inside the model). Cerruti_load_N_x = -load_P * grad_h_x Cerruti_load_N_y = -load_P * grad_h_y !Now, apply solution of the "Boussinessq problem": stress an a uniform elastic half-space (z > 0) !due to a vertical load P, pointing down, at the origin of a cylindrical coordinate system. !Do this for every test point in the 3-D grid that will record topographic stress: DO l = -fmi_topo_nx, fmi_topo_nx x_test = l * fmrv_topo_stress_dXYZ(1) DO m = -fmi_topo_ny, fmi_topo_ny y_test = m * fmrv_topo_stress_dXYZ(2) DO n = -fmi_topo_nz, fmi_topo_nz elevation_test = n * fmrv_topo_stress_dXYZ(3) - 0.5D0 * fmr_z_DEPTH_meters z_test = -elevation_test ! as defined in the solution to the Boussinesq problem r = DSQRT(((x_test - x_source)**2) + ((y_test - y_source)**2)) ! ditto; 2nd cylindrical coordinate Rcap = DSQRT((z_test**2) + (r**2)) ! ditto; diagonal distance from source to test point !Note that the following stress results are in cylindrical coordinates, !with +z downward (parallel to the point force), using modern sign convention !that compressive normal stresses are negative. Source: !T. G. Sitharam & L. Govindaraju [2013] "Module 8: Elastic solutions and applications !in geomechanics", in: Applied Elasticity for Engineers, National Programme for !Technology Enhanced Learning, Ministry of HRD, Government of India, !http://nptel.iitm.ac.in/courses/105108070/module8/lecture17.pdf (downloaded 2013.10.10). sigma_z = -(3.0D0 * load_P * (z_test**3)) / (Two_Pi * (Rcap**5)) ! everywhere .LE. 0. sigma_r = (load_P / Two_Pi) * & & (((1.0D0 - 2.0D0 * fmr_Poisson_ratio) / (Rcap * (Rcap + z_test))) - (3.0D0 * (r**2) * z_test / (Rcap**5))) sigma_theta = (load_P * (1.0D0 - 2.0D0 * fmr_Poisson_ratio) / Two_Pi) * & & ((z_test / (Rcap**3)) - 1.0D0 / (Rcap * (Rcap + z_test))) tau_rz = -3.0D0 * load_P * r * (z_test**2) / (Two_Pi * (Rcap**5)) ! everywhere .LE. 0. !Now load into stress tensor in cylindrical coordinates (z{down}, r{horizontal, away}, theta{CW around source}): B_ds_cylindrical(1, 1) = sigma_z B_ds_cylindrical(1, 2) = tau_rz B_ds_cylindrical(1, 3) = 0.0D0 B_ds_cylindrical(2, 1) = tau_rz B_ds_cylindrical(2, 2) = sigma_r B_ds_cylindrical(2, 3) = 0.0D0 B_ds_cylindrical(3, 1) = 0.0D0 B_ds_cylindrical(3, 2) = 0.0D0 B_ds_cylindrical(3, 3) = sigma_theta !Set up unit-vectors expressing (+z{down}, +r{horizontal, away}, theta{CW around source}) for this (source, test) pair, !expressing everything in model coordinates (+x{East}, +y{North}, +z{up}): pointers(1, 1) = 0.0D0 pointers(2, 1) = 0.0D0 pointers(3, 1) = -1.0D0 ! which ends the first unit vector, giving +z{down} in model (x, y, z). azimuth_radians = DATAN2((x_test - x_source), (y_test - y_source)) pointers(1, 2) = DSIN(azimuth_radians) pointers(2, 2) = DCOS(azimuth_radians) pointers(3, 2) = 0.0D0 ! which ends the second unit vector, giving +r{away-from-load, horizontally} in model (x, y, z). pointers(1, 3) = DCOS(azimuth_radians) pointers(2, 3) = -DSIN(azimuth_radians) pointers(3, 3) = 0.0D0 ! which ends the third unit vector, giving +theta{CW-around-the-load, horizontally} in model (x, y, z). !Compute rotation matrix Rmatrix(3, 3) which rotates stress from cylindrical to model coordinates: !DO ii = 1, 3 ! DO jj = 1, 3 ! Rmatrix(ii, jj) = identity(1, ii) * pointers(1, jj) + & ! & identity(2, ii) * pointers(2, jj) + & ! & identity(3, ii) * pointers(3, jj) ! END DO !END DO ! OR, equivalent but faster code: Rmatrix = pointers !Actually rotate this increment of stress to model (x, y, z) coordinates: DO ii = 1, 3 DO jj = 1, 3 B_ds_model(ii, jj) = 0.0D0 DO mm = 1, 3 DO nn = 1, 3 B_ds_model(ii, jj) = B_ds_model(ii, jj) + Rmatrix(ii, mm) * B_ds_cylindrical(mm, nn) * Rmatrix(jj, nn) END DO END DO END DO END DO !Add this increment of stress to compact storage, with convention: !that first subscript: 1) s_xx, 2) s_yy, 3) s_zz, 4) s_yz, 5) s_xz, 6) s_xy fmrt_topo_stress_anomaly_Pa(1, l, m, n) = fmrt_topo_stress_anomaly_Pa(1, l, m, n) + B_ds_model(1, 1) fmrt_topo_stress_anomaly_Pa(2, l, m, n) = fmrt_topo_stress_anomaly_Pa(2, l, m, n) + B_ds_model(2, 2) fmrt_topo_stress_anomaly_Pa(3, l, m, n) = fmrt_topo_stress_anomaly_Pa(3, l, m, n) + B_ds_model(3, 3) fmrt_topo_stress_anomaly_Pa(4, l, m, n) = fmrt_topo_stress_anomaly_Pa(4, l, m, n) + B_ds_model(2, 3) fmrt_topo_stress_anomaly_Pa(5, l, m, n) = fmrt_topo_stress_anomaly_Pa(5, l, m, n) + B_ds_model(1, 3) fmrt_topo_stress_anomaly_Pa(6, l, m, n) = fmrt_topo_stress_anomaly_Pa(6, l, m, n) + B_ds_model(1, 2) !------------------------------------------------------------------------------------------------------------ !Augment this increment of stress with the Cerruti stresses due to horizontal point loads at (x=0, y=0, z =0) !pointing in the +x and +y directions, respectively. BE CAREFUL OF SIGNS! In my reference: !Westergaard [1952] Theory of Elasticity and Plasticity, Harvard University Press, 176 pages, equation (539) !+z points down, so presumably +y is CW from +x in the horizontal plane. Thus, I will have to reverse !the signs of 2 shear stress components (t_xy & t_zx) from the formulas given by Westergaard !Fortunately, Westergaard considers extension positive, as I do. ! {AVOID using the distorted version of Lanbo Liu & Mark D.Zoback [1992, J. Geophys. Res.] in which they arbitrarily ! reversed the signs of ALL 6 stress components! (Perhaps they wanted compression = + for normal stresses, but by ! reversing signs of all 6 components they switched to a shear-stress sign convention that no one else uses.) ! Later, it seems that Sitharam & Govindaraju [2013] copied these formulas from Liu & Zoback [1992] with ! incorrect signs on all 6 terms!} !First, x-component of horizontal load: x_W = x_test - x_source ! test-point wrt source coordinates, aligning my +x with Westgaard's coordinate system. y_W = -(y_test - y_source) ! because our +y axes point opposite ways in horizontal plane (for equal +x) z_W = z_test ! = -elevation_test; reversed because Westgaard's +z axis points down instead of up. C_x_ds(1, 1) = (Cerruti_load_N_x * x_W / (2.0D0 * Pi * (Rcap**3))) * ( & ! opening [ & (-3.0D0 * (x_W**2) / (Rcap**2)) + & & ((1.0D0 - 2.0D0 * fmr_Poisson_ratio)/((Rcap + z_W)**2)) * & & ( (Rcap**2) - (y_W**2) - (2.0D0 * Rcap * (y_W**2))/(Rcap + z_W) ) & & ) ! closing ] ! ^ sigma_x of Westgaard [1952] (eg. 539); sign OK C_x_ds(2, 2) = (Cerruti_load_N_x * x_W / (2.0D0 * Pi * (Rcap**3))) * ( & ! opening [ & (-3.0D0 * (y_W**2) / (Rcap**2)) + & & ((1.0D0 - 2.0D0 * fmr_Poisson_ratio)/((Rcap + z_W)**2)) * & & ( 3.0D0 * (Rcap**2) - (x_W**2) - (2.0D0 * Rcap * (x_W**2))/(Rcap + z_W) ) & & ) ! closing ] ! sigma_y of Westgaard [1952] (eg. 539); sign OK C_x_ds(3, 3) = -3.0D0 * Cerruti_load_N_x * x_W * (z_W**2) / (2.0D0 * Pi * (Rcap**5)) ! ^ sigma_z of Westgaard [1952] (eg. 539); sign OK C_x_ds(1, 2) = -(Cerruti_load_N_x * y_W / (2.0D0 * Pi * (Rcap**3))) * ( & ! opening [ & (-3.0D0 * (x_W**2) / (Rcap**2)) + & & ((1.0D0 - 2.0D0 * fmr_Poisson_ratio)/((Rcap + z_W)**2)) * & & ( -(Rcap**2) + (x_W**2) + (2.0D0 * Rcap * (x_W**2))/(Rcap + z_W) ) & & ) ! closing ] ! ^ tau_xy of Westgaard [1952] (eg. 539); REVERSING SIGN because my +y is opposite to Westgaard's. C_x_ds(2, 3) = -(3.0D0 * Cerruti_load_N_x * x_W * y_W * z_W)/(2.0D0 * Pi * (Rcap**5)) ! ^ tau_yz of Westgaard [1952] (eg. 539); sign OK because BOTH my axes are opposite to Westgaard's. C_x_ds(3, 1) = (3.0D0 * Cerruti_load_n_x * (x_W**2) * z_W)/(2.0D0 * Pi * (Rcap**5)) ! ^ tau_zx of Westgaard [1952] (eg. 539); REVERSING SIGN because my +z is opposite to Westgaard's. C_x_ds(2, 1) = C_x_ds(1, 2) ! by symmetry C_x_ds(3, 2) = C_x_ds(2, 3) ! by symmetry C_x_ds(1, 3) = C_x_ds(3, 1) ! by symmetry fmrt_topo_stress_anomaly_Pa(1, l, m, n) = fmrt_topo_stress_anomaly_Pa(1, l, m, n) + C_x_ds(1, 1) fmrt_topo_stress_anomaly_Pa(2, l, m, n) = fmrt_topo_stress_anomaly_Pa(2, l, m, n) + C_x_ds(2, 2) fmrt_topo_stress_anomaly_Pa(3, l, m, n) = fmrt_topo_stress_anomaly_Pa(3, l, m, n) + C_x_ds(3, 3) fmrt_topo_stress_anomaly_Pa(4, l, m, n) = fmrt_topo_stress_anomaly_Pa(4, l, m, n) + C_x_ds(2, 3) fmrt_topo_stress_anomaly_Pa(5, l, m, n) = fmrt_topo_stress_anomaly_Pa(5, l, m, n) + C_x_ds(1, 3) fmrt_topo_stress_anomaly_Pa(6, l, m, n) = fmrt_topo_stress_anomaly_Pa(6, l, m, n) + C_x_ds(1, 2) !Second, effects of the y-component of horizontal load (Cerruti_load_N_y): !Note that rotation of coordinates is partly in the next 3 lines, !and partly in the storage locations for resulting components; !however, complex Cerruti formulas for stress components are not changed from above. x_W = y_test - y_source ! i.e., distance in advance of the horizontal force vector y_W = x_test - x_source ! distance to the side, positive when CW from load vector z_W = z_test C_y_ds(2, 2) = (Cerruti_load_N_y * x_W / (2.0D0 * Pi * (Rcap**3))) * ( & ! opening [ & (-3.0D0 * (x_W**2) / (Rcap**2)) + & & ((1.0D0 - 2.0D0 * fmr_Poisson_ratio)/((Rcap + z_W)**2)) * & & ( (Rcap**2) - (y_W**2) - (2.0D0 * Rcap * (y_W**2))/(Rcap + z_W) ) & & ) ! closing ] ! ^ sigma_x of Westgaard [1952] (eg. 539); sign OK; now stored as ds_yy. C_y_ds(1, 1) = (Cerruti_load_N_y * x_W / (2.0D0 * Pi * (Rcap**3))) * ( & ! opening [ & (-3.0D0 * (y_W**2) / (Rcap**2)) + & & ((1.0D0 - 2.0D0 * fmr_Poisson_ratio)/((Rcap + z_W)**2)) * & & ( 3.0D0 * (Rcap**2) - (x_W**2) - (2.0D0 * Rcap * (x_W**2))/(Rcap + z_W) ) & & ) ! closing ] ! sigma_y of Westgaard [1952] (eg. 539); sign OK; now stored as ds_xx. C_y_ds(3, 3) = -3.0D0 * Cerruti_load_N_y * x_W * (z_W**2) / (2.0D0 * Pi * (Rcap**5)) ! ^ sigma_z of Westgaard [1952] (eg. 539); sign OK C_y_ds(1, 2) = (Cerruti_load_N_y * y_W / (2.0D0 * Pi * (Rcap**3))) * ( & ! opening [ & (-3.0D0 * (x_W**2) / (Rcap**2)) + & & ((1.0D0 - 2.0D0 * fmr_Poisson_ratio)/((Rcap + z_W)**2)) * & & ( -(Rcap**2) + (x_W**2) + (2.0D0 * Rcap * (x_W**2))/(Rcap + z_W) ) & & ) ! closing ] ! ^ tau_xy of Westgaard [1952] (eg. 539); sign OK in this application. C_y_ds(1, 3) = -(3.0D0 * Cerruti_load_N_y * x_W * y_W * z_W)/(2.0D0 * Pi * (Rcap**5)) ! ^ tau_yz of Westgaard [1952] (eg. 539); sign OK because BOTH my axes are opposite to Westgaard's; stored as ds_xz. C_y_ds(3, 2) = (3.0D0 * Cerruti_load_N_y * (x_W**2) * z_W)/(2.0D0 * Pi * (Rcap**5)) ! ^ tau_zx of Westgaard [1952] (eg. 539); REVERSING SIGN because my +z is opposite to Westgaard's; stored as ds_zy. C_y_ds(2, 1) = C_y_ds(1, 2) ! by symmetry C_y_ds(3, 1) = C_y_ds(1, 3) ! by symmetry C_y_ds(2, 3) = C_y_ds(3, 2) ! by symmetry fmrt_topo_stress_anomaly_Pa(1, l, m, n) = fmrt_topo_stress_anomaly_Pa(1, l, m, n) + C_y_ds(1, 1) fmrt_topo_stress_anomaly_Pa(2, l, m, n) = fmrt_topo_stress_anomaly_Pa(2, l, m, n) + C_y_ds(2, 2) fmrt_topo_stress_anomaly_Pa(3, l, m, n) = fmrt_topo_stress_anomaly_Pa(3, l, m, n) + C_y_ds(3, 3) fmrt_topo_stress_anomaly_Pa(4, l, m, n) = fmrt_topo_stress_anomaly_Pa(4, l, m, n) + C_y_ds(2, 3) fmrt_topo_stress_anomaly_Pa(5, l, m, n) = fmrt_topo_stress_anomaly_Pa(5, l, m, n) + C_y_ds(1, 3) fmrt_topo_stress_anomaly_Pa(6, l, m, n) = fmrt_topo_stress_anomaly_Pa(6, l, m, n) + C_y_ds(1, 2) END DO ! test-z: n = -fmi_topo_nz, fmi_topo_nz END DO ! test-y: m = -fmi_topo_ny, fmi_topo_ny END DO ! test-x: l = -fmi_topo_nx, fmi_topo_nx END IF ! on land !Now, look up the "Moho" elevation at this coarse (lon, lat) grid point: !define Moho_success as point-falling-within-the-Moho-grid: Moho_success = (lat >= fmr_Moho_lat_min).AND. & & (lat <= fmr_Moho_lat_max).AND. & & (DEasting(lon - fmr_Moho_lon_min) <= fmr_Moho_lon_range) !note: insensitive to longitude cycle IF (Moho_success) THEN i1 = 1 + (fmr_Moho_lat_max - lat) / fmr_Moho_dLat i1 = MAX(1, MIN(i1, fmi_Moho_rows - 1)) i2 = i1 + 1 fy2 = ((fmr_Moho_lat_max - lat) / fmr_Moho_dLat) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + DEasting(lon - fmr_Moho_lon_min) / fmr_Moho_dLon j1 = MAX(1, MIN(j1, fmi_Moho_columns - 1)) j2 = j1 + 1 fx2 = (DEasting(lon - fmr_Moho_lon_min) / fmr_Moho_dLon) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 north = fx1 * fmim_Moho_elevation_m(i1, j1) + fx2 * fmim_Moho_elevation_m(i1, j2) south = fx1 * fmim_Moho_elevation_m(i2, j1) + fx2 * fmim_Moho_elevation_m(i2, j2) Moho_elevation = fy1 * north + fy2 * south DO k = -fmi_topo_nz, (fmi_topo_nz - 1) ! defining floors (maximum depths) of vertically-coarse cells z_source_floor = -0.5D0 * fmr_z_DEPTH_meters + k * fmrv_topo_stress_dXYZ(3) !which is the depth-centroid of the mean density anomaly to be computed in the next loop: density_anomaly = 0.0D0 ! just initializing, before sum in the following loop DO kk = 1, vertical_refinement ! dividing each coarse depth source cell into subdivisions z_source_fine = z_source_floor + (kk - 0.5D0) * fmrv_topo_stress_dXYZ(3) / vertical_refinement !Note that z_source_fine is an elevation in meters, and will always be negative (below sea level). IF (z_source_fine >= surface) THEN ! in the ocean (because this integration of density anomalies only occurs in the halfspace below sea level) local_density = fmr_seawater_density ELSE IF (z_source_fine >= Moho_elevation) THEN ! in the crust f = (surface - z_source_fine) / (surface - Moho_elevation) ! fraction of way down through the crust local_density = fmr_crustal_density_at_top + f * (fmr_crustal_density_at_Moho - fmr_crustal_density_at_top) ELSE IF (z_source_fine >= -fmr_LAB_depth) THEN ! in the mantle lithosphere f = (Moho_elevation - z_source_fine) / (Moho_elevation + fmr_LAB_depth) ! fraction of way down through the mantle lithosphere local_density = fmr_mantle_density_at_Moho + f * (fmr_mantle_density_at_LAB - fmr_mantle_density_at_Moho) ELSE ! in the asthenosphere local_density = fmr_mantle_density_at_LAB END IF ! selection of layer density_anomaly = density_anomaly + (local_density - Reference_Density(z_source_fine)) / vertical_refinement END DO ! kk implements vertical_refinement z_source = z_source_floor + 0.5D0 * fmrv_topo_stress_dXYZ(3) !We now have the mean "density_anomaly" for the vertically-coarse (dZ) cell based at elevation "z_source_floor", !centered at z_source, with volume of dV_m3 = part * dX * dY * dZ (and surface area of dA_m2 = part * dX * dY). IF (ABS(density_anomaly) >= 1.0D0) THEN ! 1 kg/m^3 is quite small; anything less may be "numerical noise" not worth modeling. !Insert Mindlin solution for vertical point force within a uniform isotropic elastic half-space. !Source is: Raymond D. Mindlin [1936] Force at a point in the interior of a semi-infinite solid, ! Physics, volume 7, pages 195-202 (especially equation set 9). P_M = density_anomaly * dV_m3 * fmr_gravity ! Mindlin's point force P, which is positive downward. c_M = -z_source ! positive; measured downward from the free surface. mu_M = fmr_Poisson_ratio ! usually 0.25~0.50 DO l = -fmi_topo_nx, fmi_topo_nx x_test = l * fmrv_topo_stress_dXYZ(1) DO m = -fmi_topo_ny, fmi_topo_ny y_test = m * fmrv_topo_stress_dXYZ(2) r_M = DSQRT(((x_test - x_source)**2) + ((y_test - y_source)**2)) ! r coordinate of cylindrical (r, z, theta) relative to load point !Set up unit-vectors expressing (+z{down}, +r{horizontal, away}, theta{CW around source}) for this (source, test) pair, !expressing everything in model coordinates (+x{East}, +y{North}, +z{up}): pointers(1, 1) = 0.0D0 pointers(2, 1) = 0.0D0 pointers(3, 1) = -1.0D0 ! which ends the first unit vector, giving +z{down} in model (x, y, z). azimuth_radians = DATAN2((x_test - x_source), (y_test - y_source)) pointers(1, 2) = DSIN(azimuth_radians) pointers(2, 2) = DCOS(azimuth_radians) pointers(3, 2) = 0.0D0 ! which ends the second unit vector, giving +r{away-from-load, horizontally} in model (x, y, z). pointers(1, 3) = DCOS(azimuth_radians) pointers(2, 3) = -DSIN(azimuth_radians) pointers(3, 3) = 0.0D0 ! which ends the third unit vector, giving +theta{CW-around-the-load, horizontally} in model (x, y, z). !Compute rotation matrix Rmatrix(3, 3) which rotates stress from cylindrical to model coordinates: !DO ii = 1, 3 ! DO jj = 1, 3 ! Rmatrix(ii, jj) = identity(1, ii) * pointers(1, jj) + & ! & identity(2, ii) * pointers(2, jj) + & ! & identity(3, ii) * pointers(3, jj) ! END DO !END DO ! OR, equivalent but faster code: Rmatrix = pointers DO n = -fmi_topo_nz, fmi_topo_nz elevation_test = n * fmrv_topo_stress_dXYZ(3) - 0.5D0 * fmr_z_DEPTH_meters z_M = -elevation_test ! positive downward from the free surface R1_M = DSQRT((r_M**2) + ((z_M - c_M)**2)) ! distance from load point R2_M = DSQRT((r_M**2) + ((z_M + c_M)**2)) ! distance from image load point in the atmosphere sigma_r_M = (P_M / (8.0D0 * Pi * (1.0D0 - mu_M))) * ( & & ( (1.0D0 - 2.0D0 * mu_M) * (z_M - c_M) / (R1_M**3) ) - & & ( (1.0D0 - 2.0D0 * mu_M) * (z_M + 7.0D0 * c_M) / (R2_M**3) ) + & & ( 4.0D0 * (1.0D0 - mu_M) * (1.0D0 - 2.0D0 * mu_M) / ( R2_M * (R2_M + z_M + c_M) ) ) - & & ( 3.0D0 * (r_M**2) * (z_M - c_M) / (R1_M**5) ) + & & ( ( 6.0D0*c_M*(1.0D0-2.0D0*mu_M)*((z_M+c_M)**2) - 6.0D0*(c_M**2)*(z_M+c_M) - & & 3.0D0*(3.0D0-4.0D0*mu_M)*(r_M**2)*(z_M-c_M) ) / (R2_M**5) ) - & & ( 30.0D0 * c_M * (r_M**2) * z_M * (z_M + c_M) / (R2_M**7) ) & & ) sigma_theta_M = (P_M / (8.0D0 * Pi * (1.0D0 - mu_M))) * ( & & ( (1.0D0 - 2.0D0 * mu_M) * (z_M - c_M) / (R1_M**3) ) + & & ( (1.0D0 - 2.0D0 * mu_M) * ( (3.0D0 - 4.0D0 * mu_M) * (z_M + c_M) - 6.0D0 * c_M ) / (R2_M**3) ) - & & ( 4.0D0 * (1.0D0 - 2.0D0 * mu_M) * (1.0D0 - mu_M) / ( R2_M * ( R2_M + z_M + c_M ) ) ) + & & ( 6.0D0 * (1.0D0 - 2.0D0 * mu_M) * c_M * ((z_M + c_M)**2) / (R2_M**5) ) - & & ( 6.0D0 * (c_M**2) * (z_M + c_M) / ( R2_M**5 ) ) & & ) !Note: In Mindlin's original formula (9), the last term in sigma_theta_M (above) ! is computationally unstable as mu --> 0.5, ! because it includes (1-2mu)/(1-2mu), going to 0/0 = NaN. ! (There is no theoretical problem because the limit rule tells us to treat this ratio as 1.) ! As in the restatement of Mindlin's solution by ! Westergaard [1952, Theory of Elasticity and Plasticity], equation (547), ! I have removed the leading factor of (1-2mu) and introduced it into all terms ! EXCEPT the last, giving an equivalent but computationally-stable formula. sigma_z_M = (P_M / (8.0D0 * Pi * (1.0D0 - mu_M))) * ( & & -( (1.0D0 - 2.0D0 * mu_M) * (z_M - c_M) / R1_M**3 ) + & & ( (1.0D0 - 2.0D0 * mu_M) * (z_M - c_M) / R2_M**3 ) - & & ( 3.0D0 * ((z_M - c_M)**3) / (R1_M**5) ) - & & ( ( 3.0D0*(3.0D0-4.0D0*mu_M)*z_M*((z_M+c_M)**2) - 3.0D0*c_M*(z_M+c_M)*(5.0D0*z_M-c_M) ) / (R2_M**5) ) - & & ( 30.0D0 * c_M * z_M * ((z_M + c_M)**3) / (R2_M**7) ) & & ) tau_rz_M = (P_M * r_M / (8.0D0 * Pi * (1.0D0 - mu_M))) * ( & & -( (1.0D0 - 2.0D0 * mu_M) / (R1_M**3) ) + & & ( (1.0D0 - 2.0D0 * mu_M) / (R2_M**3) ) - & & ( 3.0D0 * ((z_M - c_M)**2) / (R1_M**5) ) - & & ( (3.0D0*(3.0D0-4.0D0*mu_M)*z_M*(z_M+c_M) - 3.0D0*c_M*(3.0D0*z_M+c_M)) / (R2_M**5) ) - & & ( 30.0D0 * c_M * z_M * ((z_M + c_M)**2) / (R2_M**7) ) & & ) !Now load into stress tensor in cylindrical coordinates (z{down}, r{horizontal, away}, theta{CW around source}): M_ds_cylindrical(1, 1) = sigma_z_M M_ds_cylindrical(1, 2) = tau_rz_M M_ds_cylindrical(1, 3) = 0.0D0 M_ds_cylindrical(2, 1) = tau_rz_M M_ds_cylindrical(2, 2) = sigma_r_M M_ds_cylindrical(2, 3) = 0.0D0 M_ds_cylindrical(3, 1) = 0.0D0 M_ds_cylindrical(3, 2) = 0.0D0 M_ds_cylindrical(3, 3) = sigma_theta_M !Actually rotate this increment of stress to model (x, y, z) coordinates: DO ii = 1, 3 DO jj = 1, 3 M_ds_model(ii, jj) = 0.0D0 DO mm = 1, 3 DO nn = 1, 3 M_ds_model(ii, jj) = M_ds_model(ii, jj) + Rmatrix(ii, mm) * M_ds_cylindrical(mm, nn) * Rmatrix(jj, nn) END DO END DO END DO END DO !Add this increment of stress to compact storage, with convention: !that first subscript: 1) s_xx, 2) s_yy, 3) s_zz, 4) s_yz, 5) s_xz, 6) s_xy fmrt_topo_stress_anomaly_Pa(1, l, m, n) = fmrt_topo_stress_anomaly_Pa(1, l, m, n) + M_ds_model(1, 1) fmrt_topo_stress_anomaly_Pa(2, l, m, n) = fmrt_topo_stress_anomaly_Pa(2, l, m, n) + M_ds_model(2, 2) fmrt_topo_stress_anomaly_Pa(3, l, m, n) = fmrt_topo_stress_anomaly_Pa(3, l, m, n) + M_ds_model(3, 3) fmrt_topo_stress_anomaly_Pa(4, l, m, n) = fmrt_topo_stress_anomaly_Pa(4, l, m, n) + M_ds_model(2, 3) fmrt_topo_stress_anomaly_Pa(5, l, m, n) = fmrt_topo_stress_anomaly_Pa(5, l, m, n) + M_ds_model(1, 3) fmrt_topo_stress_anomaly_Pa(6, l, m, n) = fmrt_topo_stress_anomaly_Pa(6, l, m, n) + M_ds_model(1, 2) !------------------------------------------------------------------------------------------------------------ END DO ! z-test END DO ! y-test END DO ! x-test END IF ! density_anomaly /= 0.0 END DO ! k = -fmi_topo_nz, (fmi_topo_nz - 1) : defining floors of vertically-coarse source cells END IF ! source point is (laterally) inside Moho grid END IF ! Reject_success.AND.DEM_success (so, we got the elevation and its gradient) END DO ! j_fine = 1, horizontal_refinement (applied along y-axis) percent_done = 100.0D0 * ((i + fmi_topo_nx + n_x_margin + 1.0D0) * (2.0D0 * (fmi_topo_ny + n_y_margin) + 2.0D0) + & & (j + fmi_topo_ny + n_y_margin - 1.0D0)) / & & ((2.0D0 * (fmi_topo_nx + n_x_margin) + 2.0D0) * (2.0D0 * (fmi_topo_ny + n_y_margin) + 2.0D0)) IF (percent_done > old_percent) THEN WRITE (*, "('+... ',I3,'% done ...')") percent_done old_percent = percent_done END IF END DO ! source-y: j = -(fmi_topo_ny + n_y_margin + 1), (fmi_topo_ny + n_y_margin) END DO ! i_fine = 1, horizontal_refinement (applied along x-axis END DO ! source-x: i = -(fmi_topo_nx + n_x_margin + 1), (fmi_topo_nx + n_x_margin) !Correct top-layer values, which are never correct under the current numerical integration scheme. !(Many of these top-layer stress components are zero, as all discretized point loads are exactly level with ! these particular test points, and no discrete point loads are directly on these test points, to avoid singularity.) DO i = -fmi_topo_nx, fmi_topo_nx x_source = i * fmrv_topo_stress_dXYZ(1) DO j = -fmi_topo_ny, fmi_topo_ny y_source = j * fmrv_topo_stress_dXYZ(2) CALL DEM_Lookup(x_source, y_source, & & Reject_success, lon, lat, & & DEM_success, surface, grad_h_x, grad_h_y) IF (Reject_success.AND.DEM_success) THEN !Compute stress due to point load of mountains (if any) outside the upper surface of the model box: IF (surface > 0.0D0) THEN ! land load_Pa = surface * fmr_gravity * fmr_crustal_density_at_top + & ! <--main positive term (force pointing down) & fmr_1_bar * (DEXP(-surface / fmr_atmosphere_scale_height_meters) - 1.0D0) ! secondary negative correction !Note that load_Pa is always positive, even though this implies vertical compression in terms of stress components. Cerruti_traction_x = -grad_h_x * load_Pa ! horizontally-directed tractions on sea-level plane applied by rock above sea level Cerruti_traction_y = -grad_h_y * load_Pa ! on the half-space of rock that is below sea level. !Memo: first subscript: 1) s_xx, 2) s_yy, 3) s_zz, 4) s_yz, 5) s_xz, 6) s_xy fmrt_topo_stress_anomaly_Pa(3, i, j, fmi_topo_nz) = -load_Pa ! should be approximately = fmrt_topo_stress_anomaly_Pa(3, i, j, fmi_topo_nz - 1) !The next 2 statements impose the shear traction at sea level: fmrt_topo_stress_anomaly_Pa(5, i, j, fmi_topo_nz) = Cerruti_traction_x fmrt_topo_stress_anomaly_Pa(4, i, j, fmi_topo_nz) = Cerruti_traction_y !The next 3 statements use linear extrapolation up to sea level to estimate the 3 horizontal ! (t_xx, t_yy, and t_xy) topographic stress anomalies at z = 0. !This is a better kludge than assuming a constant coefficient applied to t_zz, because !the coefficients would be different for the 3 horizontal directions, and they would depend !on the local shape & orientation of topography in a complex way. !However, since the momentum equation enforces a balance between spatial gradients !of stress components, we can rely on these gradients being fairly smooth and well-behaved. fmrt_topo_stress_anomaly_Pa(1, i, j, fmi_topo_nz) = 2.0D0 * fmrt_topo_stress_anomaly_Pa(1, i, j, fmi_topo_nz - 1) - & & fmrt_topo_stress_anomaly_Pa(1, i, j, fmi_topo_nz - 2) fmrt_topo_stress_anomaly_Pa(2, i, j, fmi_topo_nz) = 2.0D0 * fmrt_topo_stress_anomaly_Pa(2, i, j, fmi_topo_nz - 1) - & & fmrt_topo_stress_anomaly_Pa(2, i, j, fmi_topo_nz - 2) fmrt_topo_stress_anomaly_Pa(6, i, j, fmi_topo_nz) = 2.0D0 * fmrt_topo_stress_anomaly_Pa(6, i, j, fmi_topo_nz - 1) - & & fmrt_topo_stress_anomaly_Pa(6, i, j, fmi_topo_nz - 2) ELSE ! sea; no stress anomaly at the surface fmrt_topo_stress_anomaly_Pa(1:6, i, j, fmi_topo_nz) = 0.0D0 IF (surface < 0.0D0) THEN ! check for subsurface points that are in the ocean? n_deeper = DInt_Below(-surface / fmrv_topo_stress_dXYZ(3)) ELSE ! surface == 0.0; should not happen except in highly idealized test problems n_deeper = 0 END IF IF (n_deeper > 0) THEN DO k = (fmi_topo_nz - n_deeper), (fmi_topo_nz - 1) pressure_anomaly = (fmi_topo_nz - k) * fmrv_topo_stress_dXYZ(3) * fmr_gravity * & & (fmr_seawater_density - fmr_crustal_density_at_top) ! always negative fmrt_topo_stress_anomaly_Pa(1:3, i, j, k) = -pressure_anomaly fmrt_topo_stress_anomaly_Pa(4:6, i, j, k) = 0.0D0 END DO END IF ! need to correct subsurface ocean points END IF ! land or sea (on top-layer of grid) END IF ! Reject_success.AND.DEM_success END DO END DO END SUBROUTINE Compute_Topographic_Stress SUBROUTINE Create_Borehole() !Computes and writes out a virtual-borehole profile of shear stress at a specifed (lon, lat), !using a tab-delimited ASCII format that will be easy to load into a spreadsheet (e.g., Excel) !for creation of a graph. Only depths below sea level (negative z values) can be output. IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. CHARACTER*1, PARAMETER :: tab = CHAR(9) ! special "HT" tab character in ASCII sequence CHARACTER*1 :: EW_c1, NS_c1 CHARACTER*5 :: latitude_c5 CHARACTER*6 :: longitude_c6, z_km_c6 CHARACTER*8 :: datum_z_km_c8 CHARACTER*10 :: maximum_shear_stress_MPa_c10 CHARACTER*60 :: borehole_filename CHARACTER*132 :: borehole_pathfilename INTEGER :: deepest_one, i, j LOGICAL :: good_location, show_CSM_data, success REAL*8 :: datum_x_meters, datum_y_meters, datum_z_meters, datum_z_km, & & local_x_max, local_x_min, local_y_max, local_y_min, maximum_shear_stress_MPa, radius_m, r2, test_r2, & & x_meters, y_meters, z_meters, z_km REAL*8, DIMENSION(3) :: borehole_uvec, eigenvalues REAL*8, DIMENSION(3, 3) :: eigenvectors, total_stress_anomaly_xyz_tensor, ENr_tensor_Pa WRITE (*, *) WRITE (*, "(' ---------------------------------------------------------------------------------------------')") WRITE (*, "(' Computes and writes out a virtual-borehole profile')") WRITE (*, "(' of shear stress at a specifed (longitude, latitude),')") WRITE (*, "(' using a tab-delimited ASCII format that will be')") WRITE (*, "(' easy to load into a spreadsheet (e.g., Excel)')") WRITE (*, "(' for creation of a graph.')") WRITE (*, "(' Only depths below sea level (negative z values) can be output.')") 10 WRITE (*, *) CALL DPrompt_for_Real('Longitude of virtual borehole (using - for W):', fmr_borehole_longitude, fmr_borehole_longitude) CALL DPrompt_for_Real('Latitude of virtual borehole (using - for S):', fmr_borehole_latitude, fmr_borehole_latitude) !check whether location is in the model box? good_location = .TRUE. ! unless... CALL DLonLat_2_Uvec(fmr_borehole_longitude, fmr_borehole_latitude, borehole_uvec) CALL DProject(uvec = borehole_uvec, x = x_meters, y = y_meters) IF (x_meters < (-0.5D0 * fmr_x_LENGTH_meters)) good_location = .FALSE. IF (x_meters > ( 0.5D0 * fmr_x_LENGTH_meters)) good_location = .FALSE. IF (y_meters < (-0.5D0 * fmr_y_WIDTH_meters)) good_location = .FALSE. IF (y_meters > ( 0.5D0 * fmr_y_WIDTH_meters)) good_location = .FALSE. IF (good_location) THEN ! proceed with borehole... IF (fmr_borehole_longitude >= 0.0D0) THEN EW_c1 = 'E' WRITE (longitude_c6, "(F6.2)") fmr_borehole_longitude ELSE EW_c1 = 'W' WRITE (longitude_c6, "(F6.2)") ABS(fmr_borehole_longitude) END IF IF (fmr_borehole_latitude >= 0.0D0) THEN NS_c1 = 'N' WRITE (latitude_c5, "(F5.2)") fmr_borehole_latitude ELSE NS_c1 = 'S' WRITE (latitude_c5, "(F5.2)") ABS(fmr_borehole_latitude) END IF borehole_filename = TRIM(fmc12_tectonic_token) // '_' // TRIM(ADJUSTL(longitude_c6)) // EW_c1 // & & '_' // TRIM(ADJUSTL(latitude_c5)) // NS_c1 // "_MODEL_borehole.dat" borehole_pathfilename = TRIM(fmc132_path_out) // TRIM(borehole_filename) OPEN (UNIT = 29, FILE = TRIM(borehole_pathfilename)) ! absolute OPEN; overwrites any pre-existing file !WRITE (29, "(A)") TRIM(borehole_filename) !WRITE (29, "('located at (',F10.5,'E, ',F9.5,'N):')") fmr_borehole_longitude, fmr_borehole_latitude !WRITE (29, "('with shear stresses stated in MPa, and (negative) elevations stated in km.')") WRITE (29, "(A)") "MODEL" // tab // " Z" deepest_one = NINT(fmr_z_DEPTH_meters / 100.0D0) DO i = 0, deepest_one !create rows in report for model values, every 0.1 km: z_meters = -100.0D0 * i ! used internally; negative z_km = -0.1D0 * i ! used externally; also negative (so Excel will plot surface at top of page) WRITE (z_km_c6, "(F6.1)") z_km CALL Get_Stress_Tensor(x = x_meters, y = y_meters, z = z_meters, choice = 3, success = success, xyz_tensor = total_stress_anomaly_xyz_tensor) IF (success) THEN CALL Eigenanalysis_3x3(total_stress_anomaly_xyz_tensor, eigenvalues, eigenvectors) maximum_shear_stress_MPa = 0.5D-6 * ABS(eigenvalues(3) - eigenvalues(1)) WRITE (maximum_shear_stress_MPa_c10, "(F10.3)") maximum_shear_stress_MPa WRITE (29, "(A)") TRIM(ADJUSTL(maximum_shear_stress_MPa_c10)) // tab // TRIM(ADJUSTL(z_km_c6)) END IF END DO CLOSE (UNIT = 29) WRITE (*, *) WRITE (*, "(' MODEL borehole completed. See output file ',A)") TRIM(borehole_filename) !------------------------------------------------------------------------------------------------------------------------------ WRITE (*, *) CALL DPrompt_for_Logical("Do you want to display data as well (from a dynamic model in CSM format)?", .TRUE., show_CSM_data) IF (show_CSM_data) THEN ! prepare to select and display CSM-format data: !Read in dataset: IF (ALLOCATED(fmtv_CSM_model)) DEALLOCATE( fmtv_CSM_model ) ! and re-read (as user may want to change datasets!). 50 CALL DPrompt_for_String("Filename of existing CSM model?", fmc80_CSM_model_filename, fmc80_CSM_model_filename) fmc132_CSM_model_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_CSM_model_filename) OPEN (UNIT = 12, FILE = TRIM(fmc132_CSM_model_pathfile), STATUS = "OLD", PAD = "YES", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: This CSM model file not found'/' (in current input folder, ',A,').')") TRIM(fmc132_path_in) CALL Pause() GO TO 50 END IF CALL Read_CSM_Model(12, fmi_CSM_points_in_box) ! just counting them, this time CLOSE (UNIT = 12, DISP = "KEEP") ! CSM model file ALLOCATE ( fmtv_CSM_model(fmi_CSM_points_in_box) ) OPEN (UNIT = 12, FILE = TRIM(fmc132_CSM_model_pathfile), STATUS = "OLD", PAD = "YES") CALL Read_CSM_Model(12, fmi_CSM_points_in_box, fmtv_CSM_model) ! recording model predictions this time !Note that routine Read_CSM_Model will provide a few lines of output characterizing dataset size. CLOSE (UNIT = 12, DISP = "KEEP") ! finished READing the CSM model file WRITE (*, *) CALL DPrompt_for_Real("Enter radius (in meters) for data-collection around the borehole:", 10000.0D0, radius_m) r2 = radius_m**2 local_x_max = x_meters + radius_m local_x_min = x_meters - radius_m local_y_max = y_meters + radius_m local_y_min = y_meters - radius_m borehole_filename = TRIM(fmc12_tectonic_token) // '_' // TRIM(ADJUSTL(longitude_c6)) // EW_c1 // & & '_' // TRIM(ADJUSTL(latitude_c5)) // NS_c1 // "_DATA_borehole.dat" borehole_pathfilename = TRIM(fmc132_path_out) // TRIM(borehole_filename) OPEN (UNIT = 29, FILE = TRIM(borehole_pathfilename)) ! absolute OPEN; overwrites any pre-existing file !WRITE (29, "(A)") TRIM(borehole_filename) !WRITE (29, "('located at (',F10.5,'E, ',F9.5,'N):')") fmr_borehole_longitude, fmr_borehole_latitude !WRITE (29, "('with shear stresses stated in MPa, and (negative) elevations stated in km.')") WRITE (29, "(A)") "DATA" // tab // " Z" DO i = 1, deepest_one !search for any (CSM-format, dynamic-model) input data within a cylinder about borehole, in this depth range: DO j = 1, fmi_CSM_points_in_box datum_x_meters = fmtv_CSM_model(j)%x_meters datum_y_meters = fmtv_CSM_model(j)%y_meters datum_z_meters = fmtv_CSM_model(j)%z_meters IF (datum_x_meters >= local_x_min) THEN IF (datum_x_meters <= local_x_max) THEN IF (datum_y_meters >= local_y_min) THEN IF (datum_y_meters <= local_y_max) THEN test_r2 = (datum_x_meters - x_meters)**2 + (datum_y_meters - y_meters)**2 IF (test_r2 <= r2) THEN IF (datum_z_meters >= (-100.0D0 * i)) THEN IF (datum_z_meters < (-100.0D0 * (i-1))) THEN !This datum is admissable, at this time in the report: datum_z_km = 1.0D-3 * datum_z_meters WRITE (datum_z_km_c8, "(F8.3)") datum_z_km ENr_tensor_Pa(1:3, 1:3) = fmtv_CSM_model(j)%ENr_tensor_Pa(1:3, 1:3) CALL Eigenanalysis_3x3(ENr_tensor_Pa, eigenvalues, eigenvectors) maximum_shear_stress_MPa = 0.5D-6 * ABS(eigenvalues(3) - eigenvalues(1)) WRITE (maximum_shear_stress_MPa_c10, "(F10.3)") maximum_shear_stress_MPa WRITE (29, "(A)") TRIM(ADJUSTL(maximum_shear_stress_MPa_c10)) // tab // TRIM(ADJUSTL(datum_z_km_c8)) END IF END IF END IF END IF END IF END IF END IF ! selecting data ... END DO ! looping through all data points END DO ! depth steps END IF ! show_CSM_data CLOSE (UNIT = 29) IF (ALLOCATED(fmtv_CSM_model)) DEALLOCATE ( fmtv_CSM_model ) ! release LARGE amount of memory used to store CSM model WRITE (*, *) WRITE (*, "(' DATA borehole completed. See output file ',A)") TRIM(borehole_filename) CALL Pause() ELSE ! bad location (outside box); get user to try again: WRITE (*, "(' ERROR: This location is outside the model. Please try again...')") CALL Pause() GO TO 10 END IF END SUBROUTINE Create_Borehole SUBROUTINE Create_Map() !Note that most of the page-initializing code here is copied from !subprogram Prompter in module Map_Tools; however, ordering is changed, !so that page is defined AFTER the map-projection, not before. !General structure of a map page (optional mosaic, plus optional overlays) !is copied from programs FiniteMap and NeoKineMap, with options customized !for this FlatMaxwell project. IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. CHARACTER*1 :: c1 CHARACTER*2 :: c2 CHARACTER*3 :: c3, grid_units CHARACTER*5 :: c5 CHARACTER*8 :: number8 CHARACTER*11 :: unit_name CHARACTER*132 :: bottom_line, CSM_input_pathfile, line, lines_basemap_file, lines_basemap_pathfile, & & new_AI_path_and_filename, temp_path_in, top_line CHARACTER(LEN=3), DIMENSION(:,:), ALLOCATABLE :: bitmap ! array of RGB pixels INTEGER :: bitmap_color_mode, bitmap_height, bitmap_shading_mode, bitmap_width, & & choice, CSM_grid_height_nPoints, & & desired_scalar, desired_symbol, dig_title_method, dX, dY, & & format_choice, & & grd1_ncols, grd1_nrows, grid_access_mode, & & highest_choice, & & i, i1, i2, il, info, ios, irow, isuppz, iu, & & j1, j2, jcol, & & k, kz, kz1, kz2, & & m, mosaic_count, most_vertical_axis, & & n, & & overlay_count, & & title_choice, train_length INTEGER :: AI_out_unit = 26 ! arbitrary choice, used only for test OPENs in problematic situations. LOGICAL :: default_xy = .TRUE. ! because (x, y) was defined by FlatMaxwell, not by user LOGICAL :: add_titles, AI_ok, any_titles, bottom, dig_is_lonlat, do_more_overlays, do_mosaic, do_overlay, & & grd1_lonlat, grd1_success, grid_lowblue, in_ok, out_ok, overwrite, plot_dig_titles, polygons, & & right, shaded_relief, stroke_this, success, visible REAL*8, PARAMETER :: bottomlegend_gap_points = 14.0D0 REAL*8, PARAMETER :: rightlegend_gap_points = 14.0D0 REAL*8 :: above, & & below, bitmap_color_highvalue, bitmap_color_lowvalue, bottom_margin, bottomlegend_used_points, brightness, & & center_lat, center_lon, CSM_grid_height_degrees, CSM_grid_width_degrees, & & desired_depth, dx_meters, dy_meters, dZ, & & e1_lat, e1_lon, e2_lat, e2_lon, e3_lat, e3_lon, East, & & fin, fout, fx1, fx2, fy1, fy2, fz1, fz2, & & grd1_d_EW, grd1_lon_min, grd1_d_lon, grd1_lon_max, grd1_lat_min, grd1_d_lat, grd1_lat_max, & & grd1_lon_range, grid_interval, grid_midvalue, & & horizontal, & & inner, intensity, & & km_deep, & & lat, lat_prime, left_margin, lon, lon_prime, & & maximum, maximum_diameter_points, minimum, mu_M, & & old_lat, old_lon, outer, & & paper_height, paper_width, & & radius_points, relative_symbol_size, right_margin, rightlegend_used_points, RMS_slope, s1_argument_radians, s1_plunge_radians, & & s1_size_points, scale_denominator, slope, step_points, suggested_scale_denominator, sum, symbol_diameter_meters, symbol_diameter_points, & & t, T_x, T_y, T_z, test_ele, top_margin, traction_MPa, traction_MPa_per_cm, traction_Npm, traction_Npm_per_cm, & & trial_x_denominator, trial_y_denominator, & & unit_points, & & value, vector_length_meters, vl, vu, & & West, window_height_meters, window_width_meters, & & x_center_meters, x_meters, x_points, x1_points, x2_points, xcp, xp, xpt, x_used_points, & & y_center_meters, y_meters, y_points, y1_points, y2_points, ycp, yp, ypt, y_used_points REAL*8, DIMENSION(2) :: tv2 REAL*8, DIMENSION(3) :: eigenvalues, plunge_radians, trend_radians, uvec, & & e1_b_uvec, e1_f_uvec, e2_b_uvec, e2_f_uvec, e3_b_uvec, e3_f_uvec, tvec, & & turn_1_uvec, turn_2_uvec, turn_3_uvec, turn_4_uvec REAL*8, DIMENSION(4) :: trial_r REAL*8, DIMENSION(:), ALLOCATABLE :: train REAL*8, DIMENSION(2, 4) :: trial_xy REAL*8, DIMENSION(3, 3) :: eigenvectors, tensor REAL*8, DIMENSION(:, :), ALLOCATABLE :: scalars_in_a_plane REAL*8, DIMENSION(:, :, :), ALLOCATABLE :: tensors_in_a_plane ! (6, -fmi_topo_nx:fmi_topo_nx, -fmi_topo_ny:fmi_topo_ny) TYPE(stress_data), DIMENSION(:), ALLOCATABLE :: cmtv_stress_data fmi_title_count = 0 desired_scalar = 1 desired_symbol = 1 !---------------------------------------------------------- ! Get output file name (frequently, the MAIN thing changed ! between two consecutive runs of Create_Map, so don't bury this question ! where it won't be noticed! IF (fmc80_new_ai_filename == "FlatMaxwell_section.ai") fmc80_new_ai_filename = "FlatMaxwell_map.ai" WRITE (*,*) CALL DPrompt_for_String('New __.ai (output map) filename?', fmc80_new_ai_filename, fmc80_new_ai_filename) !----------------------------------------------------------- ! Display Adobe_Illustrator data 100 WRITE (*,"(' ')") WRITE (*,"(' ----------------------------------------------------------------------')") WRITE (*,"(' PAGE-DEFINITION SETTINGS')") SELECT CASE (fmi_unit_choice) CASE (1); unit_name = 'millimeters'; unit_points = 2.83465D0 CASE (2); unit_name = 'inches'; unit_points = 72.0D0 CASE (3); unit_name = 'points'; unit_points = 1.0D0 END SELECT WRITE (*,"(' Page-definition entries are in units of: ',A)") TRIM(unit_name) paper_width = fmr_map_paper_width_points / unit_points WRITE (*,"(' Paper width is: ',F8.2,' ',A)") paper_width, unit_name paper_height = fmr_map_paper_height_points / unit_points WRITE (*,"(' Paper height is: ',F8.2,' ',A)") paper_height, unit_name IF (fml_black) THEN WRITE (*,"(' Basic format is: white marks on black background')") ELSE WRITE (*,"(' Basic format is: black marks on white background')") END IF top_margin = fmr_top_margin_points / unit_points left_margin = fmr_left_margin_points / unit_points right_margin = fmr_right_margin_points / unit_points bottom_margin = fmr_bottom_margin_points / unit_points WRITE (*,"(' Unprintable margins are:')") WRITE (*,"(' top margin: ',F8.2,' ',A)") top_margin, TRIM(unit_name) WRITE (*,"(' left margin: ',F8.2,' ',A,' right margin: ',F8.2,' ',A)") & & left_margin, TRIM(unit_name), right_margin, TRIM(unit_name) WRITE (*,"(' bottom margin: ',F8.2,' ',A)") bottom_margin, TRIM(unit_name) IF (fml_plan_top_titles) THEN WRITE (*,"(' Reserve space for title lines at top?: Yes')") ELSE WRITE (*,"(' Reserve space for title lines at top?: No')") END IF IF (fml_plan_rightlegend) THEN WRITE (*,"(' Reserve space for legend at right?: Yes')") ELSE WRITE (*,"(' Reserve space for legend lines at right?: No')") END IF IF (fml_plan_bottomlegend) THEN WRITE (*,"(' Reserve space for legend at bottom?: Yes')") ELSE WRITE (*,"(' Reserve space for legend at bottom?: No')") END IF IF (fml_using_color) THEN WRITE (*,"(' Use COLOR in this figure?: Yes')") ELSE WRITE (*,"(' Use COLOR in this figure?: No')") END IF WRITE (*,"(' Model .ai (input) filename: ',A)") TRIM(fmc80_model_ai_filename) WRITE (*,"(' New .ai (output) filename: ',A)") TRIM(fmc80_new_ai_filename) WRITE (*,"(' ----------------------------------------------------------------------')") CALL DPrompt_for_Logical('ARE THESE SETTINGS ACCEPTABLE?', .TRUE., AI_ok) IF (AI_ok) GO TO 300 !---------------------------------------------------------- ! Edit Adobe_Illustrator data 101 WRITE (*,"(' Available unit selections are:')") WRITE (*,"(' 1 :: millimeters')") WRITE (*,"(' 2 :: inches')") WRITE (*,"(' 3 :: points')") CALL DPrompt_for_Integer('Which code do you wish?', fmi_unit_choice, fmi_unit_choice) IF ((fmi_unit_choice < 1).OR.(fmi_unit_choice > 3)) THEN WRITE (*,"(' ERROR: Choose an integer from the list above.')") fmi_unit_choice = 2 GO TO 101 END IF SELECT CASE (fmi_unit_choice) CASE (1); unit_name = 'millimeters'; unit_points = 2.83465D0 CASE (2); unit_name = 'inches'; unit_points = 72.0D0 CASE (3); unit_name = 'points'; unit_points = 1.0D0 END SELECT 102 paper_width = fmr_map_paper_width_points / unit_points CALL DPrompt_for_Real('Width of paper?', paper_width, paper_width) fmr_map_paper_width_points = paper_width * unit_points IF (fmr_map_paper_width_points < 144.0D0) THEN WRITE (*,"(' ERROR: Unreasonably small paper width.')") WRITE (*,"(' (Compose slides as normal-sized pages.)')") fmr_map_paper_width_points = 11.0D0 * 72.0D0 GO TO 102 END IF 103 paper_height = fmr_map_paper_height_points / unit_points CALL DPrompt_for_Real('Height of paper?',paper_height,paper_height) fmr_map_paper_height_points = paper_height * unit_points IF (fmr_map_paper_height_points < 144.0D0) THEN WRITE (*,"(' ERROR: Unreasonably small paper height.')") WRITE (*,"(' (Compose slides as normal-sized pages.)')") fmr_map_paper_height_points = 8.5D0 * 72.0D0 GO TO 103 END IF 104 WRITE (*,"(' Available basic formats are:')") WRITE (*,"(' 1 :: black marks on white background (for paper)')") WRITE (*,"(' 2 :: white marks on black background (for slides?)')") IF (fml_black) THEN; format_choice = 2; ELSE; format_choice = 1; END IF CALL DPrompt_for_Integer('Which format do you wish?', format_choice, format_choice) IF ((format_choice < 1).OR.(format_choice > 2)) THEN WRITE (*,"(' ERROR: Choose an integer from the list above.')") fml_black = .FALSE. GO TO 104 END IF SELECT CASE (format_choice) CASE (1); fml_black = .FALSE. CASE (2); fml_black = .TRUE. END SELECT 105 top_margin = fmr_top_margin_points / unit_points CALL DPrompt_for_Real('Top margin?', top_margin, top_margin) fmr_top_margin_points = top_margin * unit_points IF (fmr_top_margin_points < 0.0D0) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") fmr_top_margin_points = 0.0D0 GO TO 105 END IF 106 left_margin = fmr_left_margin_points / unit_points CALL DPrompt_for_Real('Left margin?', left_margin, left_margin) fmr_left_margin_points = left_margin * unit_points IF (fmr_left_margin_points < 0.0D0) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") fmr_left_margin_points = 0.0D0 GO TO 106 END IF 107 right_margin = fmr_right_margin_points / unit_points CALL DPrompt_for_Real('Right margin?', right_margin, right_margin) fmr_right_margin_points = right_margin * unit_points IF (fmr_right_margin_points < 0.0D0) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") fmr_right_margin_points = 0.0D0 GO TO 107 END IF 108 bottom_margin = fmr_bottom_margin_points / unit_points CALL DPrompt_for_Real('Bottom margin?', bottom_margin, bottom_margin) fmr_bottom_margin_points = bottom_margin * unit_points IF (fmr_bottom_margin_points < 0.0D0) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") fmr_bottom_margin_points = 0.0D0 GO TO 108 END IF 109 CALL DPrompt_for_Logical('Reserve space for title lines at top?', fml_plan_top_titles, fml_plan_top_titles) 110 CALL DPrompt_for_Logical('Reserve space for legend at right?', fml_plan_rightlegend, fml_plan_rightlegend) 111 CALL DPrompt_for_Logical('Reserve space for legend at bottom?', fml_plan_bottomlegend, fml_plan_bottomlegend) 112 CALL DPrompt_for_Logical('Use COLOR in this figure?', fml_using_color, fml_using_color) 113 CALL DPrompt_for_String('Model .ai (input) filename?', fmc80_model_ai_filename, fmc80_model_ai_filename) 114 CALL DPrompt_for_String('New .ai (output) filename?', fmc80_new_ai_filename, fmc80_new_ai_filename) GO TO 100 ! review settings, ask again for changes? !---------------------------------------------------------- ! Issue initializing calls: 300 CALL DSelect_Paper (fmr_map_paper_width_points, fmr_map_paper_height_points) CALL DSet_Background (fml_black) CALL DDefine_Margins (fmr_top_margin_points, & & fmr_left_margin_points, fmr_right_margin_points, & & fmr_bottom_margin_points) 400 new_AI_path_and_filename = TRIM(fmc132_path_out) // TRIM(fmc80_new_AI_filename) CALL DBegin_Page (fmc80_model_AI_filename, in_ok, & & new_AI_path_and_filename, out_ok, & & fml_using_color, & & fml_plan_top_titles, & & fml_plan_rightlegend, & & fml_plan_bottomlegend) IF ((.NOT.in_ok).OR.(.NOT.out_ok)) THEN IF (.NOT.in_ok) THEN WRITE (*,"(/' ERROR: Model .AI file named: ',A)") TRIM(fmc80_model_AI_filename) WRITE (*,"(' was not found (in this directory).')") CALL DPrompt_for_String('Model .AI (input) file [path\]name?', 'AI4Frame.ai', fmc80_model_AI_filename) END IF IF (.NOT.out_ok) THEN ! error opening output file: deduce the reason and act! !First, try opening same file with STATUS = 'OLD', to see if it already exists: OPEN (UNIT = AI_out_unit, FILE = new_AI_path_and_filename, & STATUS = 'OLD', IOSTAT = ios) IF (ios == 0) THEN ! file already exists, and is now open WRITE (*,"(/' WARNING: An .AI file named: ',A,' already exists.')") TRIM(fmc80_new_AI_filename) CALL DPrompt_for_Logical('Do you want to overwrite it?', .TRUE., overwrite) IF (overwrite) THEN CLOSE (UNIT = AI_out_unit, DISP = 'DELETE') !Now it is eliminated, and can be re-created by Begin_Page. ELSE ! don't overwrite; get new name CLOSE (UNIT = AI_out_unit, DISP = 'KEEP') 411 CALL DPrompt_for_String('New .AI (output) file name?', ' ', fmc80_new_ai_filename) IF (LEN_TRIM(fmc80_new_ai_filename) == 0) THEN WRITE (*,"(' ERROR: You must supply a non-blank name.')") GO TO 411 END IF ! no name entered END IF ! overwrite, or not ELSE ! file does not already exist; the problem is elsewhere !Test whether a file named "t9375" can be opened in this directory? new_ai_path_and_filename = TRIM(fmc132_path_out) // "t9375" OPEN (UNIT = AI_out_unit, FILE = new_ai_path_and_filename, & & IOSTAT = ios) IF (ios == 0) THEN ! this file was successfully opened; the path is OK CLOSE (UNIT = ai_out_unit, DISP = 'DELETE') ! clean up WRITE (*, "(/' Apparently, the file name you requested: ',A,' is illegal.')") TRIM(fmc80_new_AI_filename) 421 CALL DPrompt_for_String('New .AI (output) file name?', ' ', fmc80_new_AI_filename) IF (LEN_TRIM(fmc80_new_AI_filename) == 0) THEN WRITE (*,"(' ERROR: You must supply a non-blank name.')") GO TO 421 END IF ! no name entered ELSE ! most likely, the path is at fault! WRITE (*, "(/' Apparently, the [Drive:][\path\] you requested, ' & /' ', A / ' is illegal. Please look for typos.')") TRIM(fmc132_path_out) CALL DPrompt_for_String('Revised [Drive:][\path\]?', ' ', fmc132_path_out) END IF ! opening "t9375" succeeded or failed END IF ! file already exists, or not END IF GO TO 400 END IF ! errors occurred during creation of (template) .AI graphical output file !compute a suggested scale denominator to fit model box into map window: window_width_meters = (ai_window_x2_points - ai_window_x1_points) * 0.000352777D0 window_height_meters = (ai_window_y2_points - ai_window_y1_points) * 0.000352777D0 trial_x_denominator = fmr_x_LENGTH_meters / window_width_meters trial_y_denominator = fmr_y_WIDTH_meters / window_height_meters suggested_scale_denominator = 1.1D0 * MAX(trial_x_denominator, trial_y_denominator) WRITE (*, *) WRITE (*, "(' Please note that the map scale denominator suggested below is intended')") WRITE (*, "(' to comfortably fit the model box entirely within the map window.')") CALL DPrompt_for_Real('Map scale denominator? 1:', suggested_scale_denominator, scale_denominator) !If user wants to zoom-in, find out what center point is wanted: IF (scale_denominator < (suggested_scale_denominator / 1.1D0)) THEN WRITE (*, *) WRITE (*, "(' As you are zooming-in to see detail, please choose a center point:')") CALL DPrompt_for_Real('East longitude of center point?:', fmr_projpoint_Elon, center_lon) CALL DPrompt_for_Real('North latitude of center point?:', fmr_projpoint_Nlat, center_lat) CALL DLonLat_2_Uvec(center_lon, center_lat, uvec) CALL DProject(uvec = uvec, x = x_center_meters, y = y_center_meters) ELSE ! keep default center x_center_meters = 0.0D0 y_center_meters = 0.0D0 END IF 500 CALL DSet_Zoom(scale_denominator = scale_denominator, & & x_center_meters = x_center_meters, & & y_center_meters = y_center_meters, & & xy_wrt_page_radians = 0.0D0) ! finishes the job of defining map-projection !=============================================================================== !GPBmosaic !-------------------------- MOSAICS ------------------------------ !----- (layers of shaded/colored polygons; mostly opaque) -------- mosaic_count = 0 bottomlegend_used_points = 0.0D0 ! records filling of bottom legend, from left rightlegend_used_points = 0.0D0 ! records filling of right legend, from top 1000 WRITE (*,"(//' ------------------------------------------------------------------------------')") IF (ai_using_color) THEN WRITE (*,"(' MOSAIC (colored-area) LAYERS AVAILABLE:')") ELSE WRITE (*,"(' MOSAIC (patterned-area) LAYERS AVAILABLE:')") END IF IF (ai_using_color) THEN WRITE (*,"(' 1 :: colored/shaded(?) bitmap of elevations (DEM)')") WRITE (*,"(' 2 :: colored/shaded(?) bitmap of Moho depth')") ELSE WRITE (*,"(' 1 :: shaded-relief grey-scale bitmap of elevations (DEM)')") WRITE (*,"(' 2 :: shaded-relief grey-scale bitmap of Moho depth')") END IF IF (ai_using_color) THEN WRITE (*,"(' 3 :: colored bitmap of topographic stress anomaly')") WRITE (*,"(' 4 :: colored bitmap of tectonic stress anomaly')") WRITE (*,"(' 5 :: colored bitmap of total stress anomaly')") WRITE (*,"(' 6 :: colored bitmap of vertically-integrated topographic stress anomaly')") WRITE (*,"(' 7 :: colored bitmap of vertically-integrated tectonic stress anomaly')") WRITE (*,"(' 8 :: colored bitmap of vertically-integrated total stress anomaly')") END IF WRITE (*,"(' ------------------------------------------------------------------------------')") IF (mosaic_count == 0) CALL DPrompt_for_Logical('Do you want one (or more) of these mosaics?', .TRUE., do_mosaic) IF (do_mosaic) THEN CALL DPrompt_for_Integer('Which mosaic type should be added?', 1, choice) IF (ai_using_color) THEN highest_choice = 8 ELSE highest_choice = 2 END IF IF ((choice < 1).OR.(choice > highest_choice)) THEN WRITE (*,"(/' ERROR: Please select an integer from the list!')") CALL Pause() mt_flashby = .FALSE. GO TO 1000 ! mosaics menu ELSE ! legal choice mosaic_count = mosaic_count + 1 END IF ! illegal or legal choice SELECT CASE (choice) CASE (1, 2) ! bitmap of DEM(1) or of Moho depth(2) 1010 IF (ai_using_color) THEN IF (choice == 1) shaded_relief = .TRUE. ! DEM IF (choice == 2) shaded_relief = .FALSE. ! Moho CALL DPrompt_for_Logical('Do you want shaded relief?', shaded_relief, shaded_relief) bitmap_shading_mode = 1 ! only one dataset considered for this mosaic {and Fortran was simplified accordingly} ELSE ! gray-scale image shaded_relief = .TRUE. bitmap_shading_mode = 1 ! only one dataset END IF grid_access_mode = 1 ! linear interpolation; no alternative {and Fortran was simplified accordingly} IF (choice == 1) THEN ! plotting the surface elevations: CALL Add_Title("Digital Elevation Model") CALL Add_Title(TRIM(fmc80_DEM_filename)) grd1_lon_min = fmr_DEM_lon_min grd1_d_lon = fmr_DEM_dLon grd1_lon_max = fmr_DEM_lon_max grd1_lat_min = fmr_DEM_lat_min grd1_d_lat = fmr_DEM_dLat grd1_lat_max = fmr_DEM_lat_max grd1_nrows = fmi_DEM_rows grd1_ncols = fmi_DEM_columns ELSE ! choice = 2; plotting the Moho: IF (fmi_new_or_old_Moho == 1) THEN ! isostatic Moho CALL Add_Title("Moho Elevation, assuming perfect local isostasy") CALL Add_Title("Topographic stress model "//TRIM(fmc12_topographic_token)) ELSE ! Moho from seismic data .grd file CALL Add_Title("Seismic Moho Elevation") CALL Add_Title(TRIM(fmc80_Moho_filename)) END IF grd1_lon_min = fmr_Moho_lon_min grd1_d_lon = fmr_Moho_dLon grd1_lon_max = fmr_Moho_lon_max grd1_lat_min = fmr_Moho_lat_min grd1_d_lat = fmr_Moho_dLat grd1_lat_max = fmr_Moho_lat_max grd1_nrows = fmi_Moho_rows grd1_ncols = fmi_Moho_columns END IF grd1_lon_range = grd1_lon_max - grd1_lon_min grd1_lonlat = .TRUE. ! {and Fortran was simplified accordingly} 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 lon = grd1_lon_min + (jcol - 1) * grd1_d_lon lat = grd1_lat_max - (irow - 1) * grd1_d_lat CALL DLonLat_2_Uvec (lon, lat, uvec) IF (mp_projection_number == 9) THEN ! Orthographic projection ! guard against looking at backside of Earth t = uvec(1) * mp_projpoint_uvec(1) + & & uvec(2) * mp_projpoint_uvec(2) + & & uvec(3) * mp_projpoint_uvec(3) IF (t <= 0.0D0) CYCLE END IF CALL DProject (uvec = uvec, x = x_meters, y = y_meters) ! but no 'guide =' CALL DMeters_2_Points (x_meters,y_meters, x_points,y_points) c1 = DIn_Window (x_points, y_points) visible = (c1 == 'I').OR.(c1 == 'B') ! Inside, or Border IF (visible) THEN k = k + 1 IF (choice == 1) THEN ! DEM train(k) = fmim_DEM(irow, jcol) ELSE ! choice == 2, Moho train(k) = fmim_Moho_elevation_m(irow, jcol) END IF END IF ! visible END DO ! columns of gridded data END DO ! rows of gridded data CALL Histogram (train, k, .FALSE., maximum, minimum) IF (maximum == minimum) THEN ! prevent division-by-zero, etc. IF (minimum == 0.0D0) THEN maximum = 1.0D0 ELSE maximum = minimum * 1.01D0 END IF END IF DEALLOCATE ( train ) IF (ai_using_color) THEN grid_units = 'm' ! for either choice (DEM or Moho) 1023 WRITE (*,"(/' How shall the bitmap be colored?')") WRITE (*,"( ' mode 0: Munsell: smooth spectrum (but values of 0 not colored)')") WRITE (*,"( ' mode 1: Munsell: smooth spectrum (with values of 0 colored normally)')") WRITE (*,"( ' mode 2: Kansas: 44-color scale of atlas-type colors')") WRITE (*,"( ' mode 3: UNAVCO: 20-color absolute scale (only for topography in m)')") WRITE (*,"( ' mode 4: AI: ',I2,'-color discrete scale, based on contour interval')") ai_spectrum_count WRITE (*,"( ' -------------------------------------------------------')") IF (choice == 1) bitmap_color_mode = 2 ! DEM IF (choice == 2) bitmap_color_mode = 1 ! Moho CALL DPrompt_for_Integer('Which coloring mode?', bitmap_color_mode, bitmap_color_mode) IF ((bitmap_color_mode < 0).OR.(bitmap_color_mode > 4)) THEN WRITE (*,"(/' ERROR: Select mode index from list!' )") CALL Pause() mt_flashby = .FALSE. GO TO 1023 END IF IF (bitmap_color_mode <= 2) THEN ! need to pin down ends of spectrum CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?', .TRUE., grid_lowblue) 1024 IF (grid_lowblue) THEN CALL DPrompt_for_Real('What (low?) value anchors the violet-blue end of the spectrum?', minimum, bitmap_color_lowvalue) CALL DPrompt_for_Real('What (high?) value anchors the red-pink end of the spectrum?', maximum, bitmap_color_highvalue) ELSE CALL DPrompt_for_Real('What (high?) value anchors the violet-blue end of the spectrum?', maximum, bitmap_color_lowvalue) CALL DPrompt_for_Real('What (low?) value anchors the red-pink end of the spectrum?', minimum, bitmap_color_highvalue) END IF ! grid_lowblue, or not IF (bitmap_color_highvalue == bitmap_color_lowvalue) THEN WRITE (*,"(/' ERROR: Red value must differ from blue value!' )") CALL Pause() mt_flashby = .FALSE. GO TO 1024 END IF ! bad range ELSE IF (bitmap_color_mode == 4) THEN grid_interval = (maximum - minimum) / ai_spectrum_count grid_midvalue = (maximum + minimum) / 2.0D0 1025 CALL DPrompt_for_Real('What contour interval do you wish?', grid_interval, grid_interval) IF (grid_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") CALL Pause() grid_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1025 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?', grid_midvalue, grid_midvalue) CALL DPrompt_for_Logical('Should low values be colored blue (versus red)?', .TRUE., grid_lowblue) END IF ! bitmap_color_mode = 0/1,2 versus 4 END IF ! ai_using_color, or not IF (shaded_relief) THEN CALL DPrompt_for_Real('Relative intensity of oblique lighting?', 0.5D0, intensity) ! find RMS E-W slope grd1_d_EW = grd1_d_lon sum = 0.0D0 DO irow = 1, grd1_nrows DO jcol = 2, grd1_ncols IF (choice == 1) THEN ! DEM: sum = sum + ((fmim_DEM(irow, jcol) - fmim_DEM(irow, jcol-1)) / (grd1_d_EW)**2) ELSE sum = sum + (((fmim_Moho_elevation_m(irow, jcol) - fmim_Moho_elevation_m(irow, jcol-1)) / grd1_d_EW)**2) END IF END DO ! jcol END DO ! irow RMS_slope = DSQRT(sum / train_length) IF (RMS_slope == 0.0D0) RMS_slope = 1.0D0 ! prevent /0.0 END IF ! shaded_relief bitmap_width = ai_window_x2_points - ai_window_x1_points ! suggest one column/point bitmap_height = ai_window_y2_points - ai_window_y1_points ! suggest one row/point 1026 CALL DPrompt_for_Integer('How many columns of pixels in bitmap?', bitmap_width, bitmap_width) IF (bitmap_width < 2) THEN WRITE (*,"(' ERROR: Bitmap_width must be >= 2')") CALL Pause() mt_flashby = .FALSE. GO TO 1026 END IF 1027 CALL DPrompt_for_Integer('How many rows of pixels in bitmap?', bitmap_height, bitmap_height) IF (bitmap_height < 2) THEN WRITE (*,"(' ERROR: Bitmap_height must be >= 2')") CALL Pause() mt_flashby = .FALSE. GO TO 1027 END IF WRITE (*,"(/' Working on bitmap....')") ALLOCATE ( bitmap(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom fy1 = (irow - 0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol - 0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) !Get "value" (basis for color of pixel) from grid1: !Note: Even if .NOT.ai_using_color, we will need i1, i2, j1, j2, etc. CALL DReject (x_meters,y_meters, success, uvec) IF (success) THEN ! rejection worked CALL DUvec_2_LonLat (uvec, lon, lat) !define grd1_success as falling within grid1 grd1_success = (lat >= grd1_lat_min).AND. & & (lat <= grd1_lat_max).AND. & & (DEasting(lon - grd1_lon_min) <= grd1_lon_range) !note: insensitive to longitude cycle IF (grd1_success) THEN i1 = 1 + (grd1_lat_max - lat) / grd1_d_lat i1 = MAX(1,MIN(i1,grd1_nrows-1)) i2 = i1 + 1 fy2 = ((grd1_lat_max - lat) / grd1_d_lat) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + DEasting(lon - grd1_lon_min) / grd1_d_lon j1 = MAX(1,MIN(j1,grd1_ncols-1)) j2 = j1 + 1 fx2 = (DEasting(lon - grd1_lon_min) / grd1_d_lon) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 IF (choice == 1) THEN ! DEM: above = fx1 * fmim_DEM(i1, j1) + fx2 * fmim_DEM(i1, j2) below = fx1 * fmim_DEM(i2, j1) + fx2 * fmim_DEM(i2, j2) ELSE ! choice == 2; Moho: above = fx1 * fmim_Moho_elevation_m(i1, j1) + fx2 * fmim_Moho_elevation_m(i1, j2) below = fx1 * fmim_Moho_elevation_m(i2, j1) + fx2 * fmim_Moho_elevation_m(i2, j2) END IF 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 !Finished getting "value" and i1, i2, j1, j2, ... (if possible) !Get "brightness" (basis for brightness of pixel) from grid2??? IF (shaded_relief) THEN IF (grd1_success) THEN ! can compute brightness !Compute E-W slope in a way that gives a !result that is piecewise-linear in the E-W direction: fout = ABS(fx2 - 0.5D0) ! fraction for adjacent cell fin = 1.00D0 - fout ! fraction for the cell we're in IF (choice == 1) THEN ! DEM: inner = (fmim_DEM(i1, j2) - fmim_DEM(i1, j1)) / grd1_d_EW ELSE ! choice == 2; Moho inner = (fmim_Moho_elevation_m(i1, j2) - fmim_Moho_elevation_m(i1, j1)) / grd1_d_EW END IF IF (fx2 > 0.5D0) THEN IF (j2 < grd1_ncols) THEN ! normal case IF (choice == 1) THEN ! DEM: outer = (fmim_DEM(i1, j2 + 1) - fmim_DEM(i1, j1 + 1)) / grd1_d_EW ELSE ! choice == 2; Moho outer = (fmim_Moho_elevation_m(i1, j2 + 1) - fmim_Moho_elevation_m(i1, j1 + 1)) / grd1_d_EW END IF ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case IF (choice == 1) THEN ! DEM: outer = (fmim_DEM(i1, j2 - 1) - fmim_DEM(i1, j1 - 1)) / grd1_d_EW ELSE ! choice == 2; Moho outer = (fmim_Moho_elevation_m(i1, j2 - 1) - fmim_Moho_elevation_m(i1, j1 - 1)) / grd1_d_EW END IF ELSE ! at left edge of grid outer = inner END IF END IF above = fin * inner + fout * outer !Repeat for row below the point: IF (choice == 1) THEN ! DEM: inner = (fmim_DEM(i2, j2) - fmim_DEM(i2, j1)) / grd1_d_EW ELSE ! choice == 2; Moho: inner = (fmim_Moho_elevation_m(i2, j2) - fmim_Moho_elevation_m(i2, j1)) / grd1_d_EW END IF IF (fx2 > 0.5D0) THEN IF (j2 < grd1_ncols) THEN ! normal case IF (choice == 1) THEN ! DEM: outer = (fmim_DEM(i2, j2 + 1) - fmim_DEM(i2, j1 + 1)) / grd1_d_EW ELSE ! choice == 2; Moho: outer = (fmim_Moho_elevation_m(i2, j2 + 1) - fmim_Moho_elevation_m(i2, j1 + 1)) / grd1_d_EW END IF ELSE ! at right edge of grid outer = inner END IF ELSE ! fx2 < 0.5 IF (j1 > 1) THEN ! normal case IF (choice == 1) THEN ! DEM: outer = (fmim_DEM(i2, j2 - 1) - fmim_DEM(i2, j1 - 1)) / grd1_d_EW ELSE ! choice == 2; Moho: outer = (fmim_Moho_elevation_m(i2, j2 - 1) - fmim_Moho_elevation_m(i2, j1 - 1)) / grd1_d_EW END IF ELSE ! at left edge of grid outer = inner END IF END IF below = fin * inner + fout * outer !Line below makes slope piecewise-linear in N-S direction: slope = fy1 * above + fy2 * below brightness = 1.0D0 + 0.5D0 * intensity * slope / RMS_slope brightness = MAX(0.0D0, MIN(2.0D0, brightness)) ELSE ! .NOT. dot1_success; so, point was not in grid1 brightness = 1.0D0 END IF ! point was in grid1 or not ELSE ! no shaded relief wanted brightness = 1.0D0 END IF ! shaded relief, or not !End of lookup (value and brightness); now use them! IF (ai_using_color.AND.grd1_success) THEN ! have "value" IF (bitmap_color_mode <= 1) THEN ! Munsell: smooth spectrum IF ((bitmap_color_mode == 0).AND.(value == 0.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 = DRGB_Munsell(warmth = t, brightness = brightness) END IF ELSE IF (bitmap_color_mode == 2) THEN ! Kansas: 44-color atlas-type scale t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = DRGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = DRGB_AI(value = value, contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, low_is_blue = grid_lowblue, & & brightness = brightness) END IF ! bitmap_color_mode selection bitmap(irow, jcol) = c3 ELSE IF (grd1_success) THEN ! b/w; gray depends only on slope k = brightness * 127.5D0 k = MAX(0, MIN(255, k)) bitmap(irow, jcol) = CHAR(k) // CHAR(k) // CHAR(k) ELSE ! fill in with background IF (ai_black_background) THEN ! slide copy bitmap(irow, jcol) = CHAR(0) // CHAR(0) // CHAR(0) ELSE ! white background (paper print) bitmap(irow, jcol) = CHAR(255) // CHAR(255) // CHAR(255) END IF END IF ! color, grey-scale, or background END DO ! jcol, left to right IF (MOD(irow, 100) == 0) WRITE (*,"('+Working on bitmap....',I6,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Working on bitmap....Writing to .ai ')") CALL DBitmap_on_L1 (bitmap, ai_window_x1_points, ai_window_x2_points, & & ai_window_y1_points, ai_window_y2_points) IF (ai_using_color) THEN CALL Chooser(bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! END IF ! ai_using_color --> want spectrum in legend WRITE (*,"('+Working on bitmap....DONE. ')") DEALLOCATE ( bitmap ) ! end of colored/shaded(?) bitmap from DEM or Moho CASE (3, 4, 5) ! colored bitmap of (3)topographic, (4)tectonic, or (5)total stress anomaly shaded_relief = .FALSE. IF (choice == 3) THEN CALL Add_Title("Topographic stress anomaly model "//TRIM(fmc12_topographic_token)) ELSE IF (choice == 4) THEN CALL Add_Title("Tectonic stress anomaly model "//TRIM(fmc12_tectonic_token)) ELSE ! choice == 5 CALL Add_Title("Total stress anomaly model "//TRIM(fmc12_tectonic_token)) END IF 1030 WRITE (*,"(/' Which scalar measure of this stress-anomaly tensor field should be plotted?')") WRITE (*,"( ' measure 1: normal stress anomaly on selected horizontal plane')") WRITE (*,"( ' measure 2: shear traction magnitude on selected horizontal plane')") WRITE (*,"( ' measure 3: pressure anomaly in selected horizontal plane')") WRITE (*,"( ' measure 4: greatest shear stress (any orientation) in a horizontal plane')") WRITE (*,"( ' -------------------------------------------------------------------------')") CALL DPrompt_for_Integer('Which scalar measure?', desired_scalar, desired_scalar) IF ((desired_scalar < 1).OR.(desired_scalar > 4)) THEN WRITE (*,"(/' ERROR: Select measure index from list!' )") CALL Pause() mt_flashby = .FALSE. GO TO 1030 END IF 1031 CALL DPrompt_for_Real("Depth of horizontal plane below MSL (meters):", 10000.0D0, desired_depth) IF ((desired_depth < 0.0D0).OR.(desired_depth > fmr_z_DEPTH_meters)) THEN WRITE (*, "(' ERROR: This depth is not within the model domain. Range 0. to ',F7.0)") fmr_z_DEPTH_meters CALL Pause() GO TO 1031 END IF km_deep = desired_depth / 1000.0D0 WRITE (c5, "(F5.1)") km_deep IF (c5(5:5) == '0') WRITE (c5, "(I5)") NINT(km_deep) c5 = ADJUSTL(c5) IF (desired_scalar == 1) THEN CALL Add_Title("Normal stress anomaly on horizontal plane "//TRIM(c5)//" km below MSL") ELSE IF (desired_scalar == 2) THEN CALL Add_Title("Shear traction magnitude on horizontal plane "//TRIM(c5)//" km below MSL") ELSE IF (desired_scalar == 3) THEN CALL Add_Title("Pressure anomaly on horizontal plane "//TRIM(c5)//" km below MSL") ELSE IF (desired_scalar == 4) THEN CALL Add_Title("Greatest shear stress in horizontal plane "//TRIM(c5)//" km below MSL") END IF kz = NINT((-desired_depth - (-0.5D0 * fmr_z_DEPTH_meters)) / fmrv_topo_stress_dXYZ(3)) test_ele = -0.5D0 * fmr_z_DEPTH_meters + kz * fmrv_topo_stress_dXYZ(3) IF (-desired_depth >= test_ele) THEN kz1 = kz kz2 = MIN(kz1 + 1, fmi_topo_nz) fz2 = (-desired_depth - test_ele) / fmrv_topo_stress_dXYZ(3) fz1 = 1.0D0 - fz2 ELSE kz2 = kz kz1 = MAX(kz2 - 1, -fmi_topo_nz) fz1 = (test_ele - (-desired_depth)) / fmrv_topo_stress_dXYZ(3) fz2 = 1.0D0 - fz1 END IF ALLOCATE (scalars_in_a_plane(-fmi_topo_nx:fmi_topo_nx, -fmi_topo_ny:fmi_topo_ny) ) train_length = (2 * fmi_topo_nx + 1) * (2 * fmi_topo_ny + 1) ALLOCATE ( train(train_length) ) WRITE (*,"(/' Here is the distribution of values (on topographic-stress grid, in MPa):' )") k = 0 DO i = -fmi_topo_nx, fmi_topo_nx ! W to E DO j = -fmi_topo_ny, fmi_topo_ny ! S to N k = k + 1 IF (desired_scalar == 1) THEN ! normal stress anomaly IF (choice == 3) THEN ! topographic stress anomaly train(k) = fz1 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz2) ELSE IF (choice == 4) THEN ! tectonic stress anomaly wanted train(k) = fz1 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz2) ELSE ! choice == 5; total stress anomaly wanted train(k) = fz1 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz2) END IF ! choice == 3, 4, or 5 ELSE IF (desired_scalar == 2) THEN ! shear traction magnitude IF (choice == 3) THEN ! topographic stress anomaly T_x = fz1 * fmrt_topo_stress_anomaly_Pa(5, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(5, i, j, kz2) T_y = fz1 * fmrt_topo_stress_anomaly_Pa(4, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(4, i, j, kz2) ELSE IF (choice == 4) THEN ! tectonic stress anomaly wanted T_x = fz1 * fmrt_tectonic_stress_anomaly_Pa(5, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(5, i, j, kz2) T_y = fz1 * fmrt_tectonic_stress_anomaly_Pa(4, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(4, i, j, kz2) ELSE ! choice == 5; total stress anomaly wanted T_x = fz1 * fmrt_topo_stress_anomaly_Pa(5, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(5, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(5, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(5, i, j, kz2) T_y = fz1 * fmrt_topo_stress_anomaly_Pa(4, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(4, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(4, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(4, i, j, kz2) END IF ! choice == 3, 4, or 5 train(k) = DSQRT((T_x**2) + (T_y**2)) ELSE IF (desired_scalar == 3) THEN ! pressure anomaly IF (choice == 3) THEN ! topographic stress anomaly T_x = fz1 * fmrt_topo_stress_anomaly_Pa(1, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(1, i, j, kz2) T_y = fz1 * fmrt_topo_stress_anomaly_Pa(2, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(2, i, j, kz2) T_z = fz1 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz2) ELSE IF (choice == 4) THEN ! tectonic stress anomaly wanted T_x = fz1 * fmrt_tectonic_stress_anomaly_Pa(1, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(1, i, j, kz2) T_y = fz1 * fmrt_tectonic_stress_anomaly_Pa(2, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(2, i, j, kz2) T_z = fz1 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz2) ELSE ! choice == 5; total stress anomaly wanted T_x = fz1 * fmrt_topo_stress_anomaly_Pa(1, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(1, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(1, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(1, i, j, kz2) T_y = fz1 * fmrt_topo_stress_anomaly_Pa(2, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(2, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(2, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(2, i, j, kz2) T_z = fz1 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz2) END IF ! choice == 3, 4, or 5 train(k) = -(T_x + T_y + T_z)/3. ELSE IF (desired_scalar == 4) THEN ! greatest shear traction IF (choice == 3) THEN ! topographic stress anomaly !form the full (3, 3) tensor of the desired stress anomaly tensor(1, 1) = fz1 * fmrt_topo_stress_anomaly_Pa(1, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(1, i, j, kz2) tensor(2, 2) = fz1 * fmrt_topo_stress_anomaly_Pa(2, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(2, i, j, kz2) tensor(3, 3) = fz1 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz2) tensor(2, 3) = fz1 * fmrt_topo_stress_anomaly_Pa(4, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(4, i, j, kz2) tensor(1, 3) = fz1 * fmrt_topo_stress_anomaly_Pa(5, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(5, i, j, kz2) tensor(1, 2) = fz1 * fmrt_topo_stress_anomaly_Pa(6, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(6, i, j, kz2) ELSE IF (choice == 4) THEN ! tectonic stress anomaly wanted tensor(1, 1) = fz1 * fmrt_tectonic_stress_anomaly_Pa(1, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(1, i, j, kz2) tensor(2, 2) = fz1 * fmrt_tectonic_stress_anomaly_Pa(2, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(2, i, j, kz2) tensor(3, 3) = fz1 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz2) tensor(2, 3) = fz1 * fmrt_tectonic_stress_anomaly_Pa(4, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(4, i, j, kz2) tensor(1, 3) = fz1 * fmrt_tectonic_stress_anomaly_Pa(5, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(5, i, j, kz2) tensor(1, 2) = fz1 * fmrt_tectonic_stress_anomaly_Pa(6, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(6, i, j, kz2) ELSE ! choice == 5; total stress anomaly wanted tensor(1, 1) = fz1 * fmrt_topo_stress_anomaly_Pa(1, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(1, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(1, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(1, i, j, kz2) tensor(2, 2) = fz1 * fmrt_topo_stress_anomaly_Pa(2, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(2, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(2, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(2, i, j, kz2) tensor(3, 3) = fz1 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(3, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(3, i, j, kz2) tensor(2, 3) = fz1 * fmrt_topo_stress_anomaly_Pa(4, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(4, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(4, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(4, i, j, kz2) tensor(1, 3) = fz1 * fmrt_topo_stress_anomaly_Pa(5, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(5, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(5, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(5, i, j, kz2) tensor(1, 2) = fz1 * fmrt_topo_stress_anomaly_Pa(6, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(6, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(6, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(6, i, j, kz2) END IF ! choice == 3, 4, or 5 tensor(2, 1) = tensor(1, 2) tensor(3, 1) = tensor(1, 3) tensor(3, 2) = tensor(2, 3) CALL Eigenanalysis_3x3(tensor, eigenvalues) train(k) = 0.5D0 * ABS(eigenvalues(1) - eigenvalues(3)) END IF ! desired_scalar == 1, 2, 3, or 4 train(k) = train(k) * 1.0D-6 ! converting from Pa to MPa. scalars_in_a_plane(i, j) = train(k) END DO ! j = -fmi_topo_ny, fmi_topo_ny ; S to N END DO ! i = -fmi_topo_nx, fmi_topo_nx ; W to E CALL Histogram (train, train_length, .FALSE., maximum, minimum) IF (maximum == minimum) THEN ! prevent division-by-zero, etc. IF (minimum == 0.0D0) THEN maximum = 1.0D0 ELSE maximum = minimum * 1.01D0 END IF END IF DEALLOCATE ( train ) grid_units = 'MPa' ! for any of the choices (topographic, tectonic, or total anomalies) 1032 WRITE (*,"(/' How shall the bitmap be 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: AI: ',I2,'-color discrete scale, based on contour interval')") ai_spectrum_count WRITE (*,"( ' -------------------------------------------------------')") bitmap_color_mode = 1 ! Munsell CALL DPrompt_for_Integer('Which coloring mode?', bitmap_color_mode, bitmap_color_mode) IF ((bitmap_color_mode < 1).OR.(bitmap_color_mode > 3)) THEN WRITE (*,"(/' ERROR: Select mode index from list!' )") CALL Pause() mt_flashby = .FALSE. GO TO 1032 END IF IF (bitmap_color_mode <= 2) THEN ! need to pin down ends of spectrum CALL DPrompt_for_Logical('Should low (more negative) values be colored blue (versus red)?', .TRUE., grid_lowblue) 1033 IF (grid_lowblue) THEN CALL DPrompt_for_Real('What (low?) value anchors the violet-blue end of the spectrum?', minimum, bitmap_color_lowvalue) CALL DPrompt_for_Real('What (high?) value anchors the red-pink end of the spectrum?', maximum, bitmap_color_highvalue) ELSE CALL DPrompt_for_Real('What (high?) value anchors the violet-blue end of the spectrum?', maximum, bitmap_color_lowvalue) CALL DPrompt_for_Real('What (low?) value anchors the red-pink end of the spectrum?', minimum, bitmap_color_highvalue) END IF ! grid_lowblue, or not IF (bitmap_color_highvalue == bitmap_color_lowvalue) THEN WRITE (*,"(/' ERROR: Red value must differ from blue value!' )") CALL Pause() mt_flashby = .FALSE. GO TO 1033 END IF ! bad range ELSE IF (bitmap_color_mode == 3) THEN grid_interval = (maximum - minimum) / ai_spectrum_count grid_midvalue = (maximum + minimum) / 2.0D0 1034 CALL DPrompt_for_Real('What contour interval do you wish?', grid_interval, grid_interval) IF (grid_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") CALL Pause() grid_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1034 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?', grid_midvalue, grid_midvalue) CALL DPrompt_for_Logical('Should low (more negative) values be colored blue (versus red)?', .TRUE., grid_lowblue) END IF ! bitmap_color_mode = 0/1,2 versus 3 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 1035 CALL DPrompt_for_Integer('How many columns of pixels in bitmap?', bitmap_width, bitmap_width) IF (bitmap_width < 2) THEN WRITE (*,"(' ERROR: Bitmap_width must be >= 2')") CALL Pause() mt_flashby = .FALSE. GO TO 1035 END IF 1036 CALL DPrompt_for_Integer('How many rows of pixels in bitmap?', bitmap_height, bitmap_height) IF (bitmap_height < 2) THEN WRITE (*,"(' ERROR: Bitmap_height must be >= 2')") CALL Pause() mt_flashby = .FALSE. GO TO 1036 END IF WRITE (*,"(/' Working on bitmap....')") ALLOCATE ( bitmap(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom fy1 = (irow - 0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol - 0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) !Define "success" as falling within the model box: success = (x_meters >= -0.5D0 * fmr_x_LENGTH_meters).AND.(x_meters <= 0.5D0 * fmr_x_LENGTH_meters).AND. & & (y_meters >= -0.5D0 * fmr_y_WIDTH_meters ).AND.(y_meters <= 0.5D0 * fmr_y_WIDTH_meters) IF (success) THEN i1 = DInt_Below(x_meters / fmrv_topo_stress_dXYZ(1)) i1 = MAX(-fmi_topo_nx, MIN(i1, fmi_topo_nx - 1)) i2 = i1 + 1 fy2 = (x_meters / fmrv_topo_stress_dXYZ(1)) - i1 fy1 = 1.00D0 - fy2 j1 = DInt_Below(y_meters / fmrv_topo_stress_dXYZ(2)) j1 = MAX(-fmi_topo_ny, MIN(j1, fmi_topo_ny - 1)) j2 = j1 + 1 fx2 = (y_meters / fmrv_topo_stress_dXYZ(2)) - j1 fx1 = 1.00D0 - fx2 West = fx1 * scalars_in_a_plane(i1, j1) + fx2 * scalars_in_a_plane(i1, j2) East = fx1 * scalars_in_a_plane(i2, j1) + fx2 * scalars_in_a_plane(i2, j2) value = fy1 * West + fy2 * East END IF ! point inside lon/lat grid1 !End of lookup of value; now use it! brightness = 1.0D0 ! which gives full color saturation IF (success) THEN ! have "value" IF (bitmap_color_mode == 1) THEN ! Munsell: smooth spectrum t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Munsell(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 2) THEN ! Kansas: 44-color atlas-type scale t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = DRGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = DRGB_AI(value = value, contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, low_is_blue = grid_lowblue, & & brightness = brightness) END IF ! bitmap_color_mode selection bitmap(irow, jcol) = c3 ELSE ! point was outside model box; 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, or background END DO ! jcol, left to right IF (MOD(irow, 100) == 0) WRITE (*,"('+Working on bitmap....',I6,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Working on bitmap....Writing to .ai ')") CALL DBitmap_on_L1 (bitmap, ai_window_x1_points, ai_window_x2_points, & & ai_window_y1_points, ai_window_y2_points) CALL Chooser(bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on bitmap....DONE. ')") DEALLOCATE ( bitmap ) DEALLOCATE ( scalars_in_a_plane ) ! end of colored bitmap of topographic, tectonic, or total stress anomaly CASE (6, 7, 8) ! colored bitmap of vertical-integral of: (3)topographic, (4)tectonic, or (5)total stress anomaly shaded_relief = .FALSE. IF (choice == 6) THEN CALL Add_Title("Topographic stress anomaly model "//TRIM(fmc12_topographic_token)) ELSE IF (choice == 7) THEN CALL Add_Title("Tectonic stress anomaly model "//TRIM(fmc12_tectonic_token)) ELSE ! choice == 8 CALL Add_Title("Total stress anomaly model "//TRIM(fmc12_tectonic_token)) END IF 1060 WRITE (*,"(/' Which scalar measure of this stress-anomaly tensor field should be plotted?')") WRITE (*,"( ' measure 1: vertical-integral of normal stress anomaly on horizontal planes')") WRITE (*,"( ' measure 2: vertical-integral of shear traction on horizontal planes')") WRITE (*,"( ' measure 3: vertical-integral of pressure anomaly')") WRITE (*,"( ' measure 4: vertical-integral of greatest shear stress')") WRITE (*,"( ' ---------------------------------------------------------------------------')") CALL DPrompt_for_Integer('Which scalar measure?', desired_scalar, desired_scalar) IF ((desired_scalar < 1).OR.(desired_scalar > 4)) THEN WRITE (*,"(/' ERROR: Select measure index from list!' )") CALL Pause() mt_flashby = .FALSE. GO TO 1060 END IF IF (desired_scalar == 1) THEN CALL Add_Title("Vertical-integral of: Normal stress anomaly on horizontal planes") ELSE IF (desired_scalar == 2) THEN CALL Add_Title("Vertical-integral of: Shear traction on horizontal planes") ELSE IF (desired_scalar == 3) THEN CALL Add_Title("Vertical-integral of: Pressure anomaly") ELSE IF (desired_scalar == 4) THEN CALL Add_Title("Vertical-integral of: Greatest shear stress") END IF ALLOCATE (scalars_in_a_plane(-fmi_topo_nx:fmi_topo_nx, -fmi_topo_ny:fmi_topo_ny) ) scalars_in_a_plane = 0.0D0 ! simplifies debugging ALLOCATE (tensors_in_a_plane(6, -fmi_topo_nx:fmi_topo_nx, -fmi_topo_ny:fmi_topo_ny) ) tensors_in_a_plane = 0.0D0 ! whole array, prior to the sums below train_length = (2 * fmi_topo_nx + 1) * (2 * fmi_topo_ny + 1) ALLOCATE ( train(train_length) ) WRITE (*,"(/' Here is the distribution of values (on topographic-stress grid, in N/m):' )") n = 0 ! no train yet DO i = -fmi_topo_nx, fmi_topo_nx ! W to E DO j = -fmi_topo_ny, fmi_topo_ny ! S to N n = n + 1 ! getting ready to add to train DO k = -fmi_topo_nz, fmi_topo_nz IF (k == -fmi_topo_nz) THEN dZ = 0.5D0 * fmrv_topo_stress_dXYZ(3) ELSE IF (k == fmi_topo_nz) THEN dZ = 0.5D0 * fmrv_topo_stress_dXYZ(3) ELSE dZ = fmrv_topo_stress_dXYZ(3) END IF IF (choice == 6) THEN ! topographic stress anomaly: tensors_in_a_plane(1:6, i, j) = tensors_in_a_plane(1:6, i, j) + fmrt_topo_stress_anomaly_Pa(1:6, i, j, k) * dZ ELSE IF (choice == 7) THEN ! tectonic stress anomaly: tensors_in_a_plane(1:6, i, j) = tensors_in_a_plane(1:6, i, j) + fmrt_tectonic_stress_anomaly_Pa(1:6, i, j, k) * dZ ELSE ! choice == 8; total stress anomaly tensors_in_a_plane(1:6, i, j) = tensors_in_a_plane(1:6, i, j) + (fmrt_topo_stress_anomaly_Pa(1:6, i, j, k) + & & fmrt_tectonic_stress_anomaly_Pa(1:6, i, j, k)) * dZ END IF END DO ! k = -fmi_topo_nz, fmi_topo_nz IF (desired_scalar == 1) THEN ! vertical-integral of normal stress anomaly on horizontal planes scalars_in_a_plane(i, j) = tensors_in_a_plane(3, i, j) ELSE IF (desired_scalar == 2) THEN ! vertical-integral of shear traction on horizontal planes scalars_in_a_plane(i, j) = DSQRT((tensors_in_a_plane(4, i, j)**2) + (tensors_in_a_plane(5, i, j)**2)) ELSE IF (desired_scalar == 3) THEN ! vertical-integral of pressure anomaly scalars_in_a_plane(i, j) = -(tensors_in_a_plane(1, i, j) + tensors_in_a_plane(2, i, j) + tensors_in_a_plane(3, i, j)) / 3.0D0 ELSE IF (desired_scalar == 4) THEN ! vertical-integral of greatest shear stress tensor(1, 1) = tensors_in_a_plane(1, i, j) tensor(1, 2) = tensors_in_a_plane(6, i, j) tensor(1, 3) = tensors_in_a_plane(5, i, j) tensor(2, 1) = tensors_in_a_plane(6, i, j) tensor(2, 2) = tensors_in_a_plane(2, i, j) tensor(2, 3) = tensors_in_a_plane(4, i, j) tensor(3, 1) = tensors_in_a_plane(5, i, j) tensor(3, 2) = tensors_in_a_plane(4, i, j) tensor(3, 3) = tensors_in_a_plane(3, i, j) CALL Eigenanalysis_3x3(tensor, eigenvalues) scalars_in_a_plane(i, j) = 0.5D0 * ABS(eigenvalues(1) - eigenvalues(3)) END IF ! desired_scalar == 1, 2, 3, or 4 train(n) = scalars_in_a_plane(i, j) END DO ! j = -fmi_topo_ny, fmi_topo_ny ; S to N END DO ! i = -fmi_topo_nx, fmi_topo_nx ; W to E CALL Histogram (train, train_length, .FALSE., maximum, minimum) IF (maximum == minimum) THEN ! prevent division-by-zero, etc. IF (minimum == 0.0D0) THEN maximum = 1.0D0 ELSE maximum = minimum * 1.01D0 END IF END IF DEALLOCATE ( train ) grid_units = 'N/m' ! for any of the choices (topographic, tectonic, or total anomalies) 1062 WRITE (*,"(/' How shall the bitmap be 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: AI: ',I2,'-color discrete scale, based on contour interval')") ai_spectrum_count WRITE (*,"( ' -------------------------------------------------------')") bitmap_color_mode = 1 ! Munsell CALL DPrompt_for_Integer('Which coloring mode?', bitmap_color_mode, bitmap_color_mode) IF ((bitmap_color_mode < 1).OR.(bitmap_color_mode > 3)) THEN WRITE (*,"(/' ERROR: Select mode index from list!' )") CALL Pause() mt_flashby = .FALSE. GO TO 1062 END IF IF (bitmap_color_mode <= 2) THEN ! need to pin down ends of spectrum CALL DPrompt_for_Logical('Should low (more negative) values be colored blue (versus red)?', .TRUE., grid_lowblue) 1063 IF (grid_lowblue) THEN CALL DPrompt_for_Real('What (low?) value anchors the violet-blue end of the spectrum?', minimum, bitmap_color_lowvalue) CALL DPrompt_for_Real('What (high?) value anchors the red-pink end of the spectrum?', maximum, bitmap_color_highvalue) ELSE CALL DPrompt_for_Real('What (high?) value anchors the violet-blue end of the spectrum?', maximum, bitmap_color_lowvalue) CALL DPrompt_for_Real('What (low?) value anchors the red-pink end of the spectrum?', minimum, bitmap_color_highvalue) END IF ! grid_lowblue, or not IF (bitmap_color_highvalue == bitmap_color_lowvalue) THEN WRITE (*,"(/' ERROR: Red value must differ from blue value!' )") CALL Pause() mt_flashby = .FALSE. GO TO 1063 END IF ! bad range ELSE IF (bitmap_color_mode == 3) THEN grid_interval = (maximum - minimum) / ai_spectrum_count grid_midvalue = (maximum + minimum) / 2.0D0 1064 CALL DPrompt_for_Real('What contour interval do you wish?', grid_interval, grid_interval) IF (grid_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") CALL Pause() grid_interval = (maximum - minimum) / ai_spectrum_count mt_flashby = .FALSE. GO TO 1064 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?', grid_midvalue, grid_midvalue) CALL DPrompt_for_Logical('Should low (more negative) values be colored blue (versus red)?', .TRUE., grid_lowblue) END IF ! bitmap_color_mode = 0/1,2 versus 3 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 1065 CALL DPrompt_for_Integer('How many columns of pixels in bitmap?', bitmap_width, bitmap_width) IF (bitmap_width < 2) THEN WRITE (*,"(' ERROR: Bitmap_width must be >= 2')") CALL Pause() mt_flashby = .FALSE. GO TO 1065 END IF 1066 CALL DPrompt_for_Integer('How many rows of pixels in bitmap?', bitmap_height, bitmap_height) IF (bitmap_height < 2) THEN WRITE (*,"(' ERROR: Bitmap_height must be >= 2')") CALL Pause() mt_flashby = .FALSE. GO TO 1066 END IF WRITE (*,"(/' Working on bitmap....')") ALLOCATE ( bitmap(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom fy1 = (irow - 0.5D0) / bitmap_height fy2 = 1.00D0 - fy1 y_points = ai_window_y1_points * fy1 + ai_window_y2_points * fy2 DO jcol = 1, bitmap_width ! left to right fx2 = (jcol - 0.5D0) / bitmap_width fx1 = 1.00D0 - fx2 x_points = ai_window_x1_points * fx1 + ai_window_x2_points * fx2 CALL DPoints_2_Meters (x_points,y_points, x_meters,y_meters) !Define "success" as falling within the model box: success = (x_meters >= -0.5D0 * fmr_x_LENGTH_meters).AND.(x_meters <= 0.5D0 * fmr_x_LENGTH_meters).AND. & & (y_meters >= -0.5D0 * fmr_y_WIDTH_meters ).AND.(y_meters <= 0.5D0 * fmr_y_WIDTH_meters ) IF (success) THEN i1 = DInt_Below(x_meters / fmrv_topo_stress_dXYZ(1)) i1 = MAX(-fmi_topo_nx, MIN(i1, fmi_topo_nx - 1)) i2 = i1 + 1 fy2 = (x_meters / fmrv_topo_stress_dXYZ(1)) - i1 fy1 = 1.00D0 - fy2 j1 = DInt_Below(y_meters / fmrv_topo_stress_dXYZ(2)) j1 = MAX(-fmi_topo_ny, MIN(j1, fmi_topo_ny - 1)) j2 = j1 + 1 fx2 = (y_meters / fmrv_topo_stress_dXYZ(2)) - j1 fx1 = 1.00D0 - fx2 West = fx1 * scalars_in_a_plane(i1, j1) + fx2 * scalars_in_a_plane(i1, j2) East = fx1 * scalars_in_a_plane(i2, j1) + fx2 * scalars_in_a_plane(i2, j2) value = fy1 * West + fy2 * East END IF ! point inside lon/lat grid1 !End of lookup of value; now use it! brightness = 1.0D0 ! which gives full color saturation IF (success) THEN ! have "value" IF (bitmap_color_mode == 1) THEN ! Munsell: smooth spectrum t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Munsell(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 2) THEN ! Kansas: 44-color atlas-type scale t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = DRGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = DRGB_AI(value = value, contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, low_is_blue = grid_lowblue, & & brightness = brightness) END IF ! bitmap_color_mode selection bitmap(irow, jcol) = c3 ELSE ! point was outside model box; 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, or background END DO ! jcol, left to right IF (MOD(irow, 100) == 0) WRITE (*,"('+Working on bitmap....',I6,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Working on bitmap....Writing to .ai ')") CALL DBitmap_on_L1 (bitmap, ai_window_x1_points, ai_window_x2_points, & & ai_window_y1_points, ai_window_y2_points) CALL Chooser(bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (bottom) THEN CALL DSpectrum_in_BottomLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin ELSE IF (right) THEN CALL DSpectrum_in_RightLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) rightlegend_used_points = ai_paper_height_points ! reserve right margin END IF ! bottom or right margin free ! WRITE (*,"('+Working on bitmap....DONE. ')") DEALLOCATE ( bitmap ) DEALLOCATE ( scalars_in_a_plane ) DEALLOCATE ( tensors_in_a_plane ) ! end CASE(6, 7, 8): colored bitmap of vertical-integal of: topographic, tectonic, or total stress anomaly END SELECT ! choice of mosaic END IF ! do_mosaic !=============================================================================== !GPBoverlays !-------------------------- OVERLAYS ------------------------------ !----- (symbols composed mostly of lines; mostly transparent) ----- overlay_count = 0 2000 WRITE (*,"(//' -----------------------------------------------------------------------')") WRITE (*,"( ' LINE AND SYMBOL OVERLAY LAYERS AVAILABLE:')") WRITE (*,"( ' 1 :: digitised basemap (.DIG file)')") WRITE (*,"( ' 2 :: grid-point locations from a CSM file')") WRITE (*,"( ' 3 :: outline of FlatMaxwell model box')") WRITE (*,"( ' 4 :: point measures of topographic stress anomaly in horizonal plane')") WRITE (*,"( ' 5 :: point measures of tectonic stress anomaly in horizonal plane')") WRITE (*,"( ' 6 :: point measures of total stress anomaly in horizonal plane')") WRITE (*,"( ' 7 :: point measures of vertical integral of topographic stress anomaly')") WRITE (*,"( ' 8 :: point measures of vertical integral of tectonic stress anomaly')") WRITE (*,"( ' 9 :: point measures of vertical integral of total stress anomaly')") WRITE (*,"( ' 10 :: location line for a vertical section')") WRITE (*,"( ' 11 :: most-compressive principal stress axes from dataset')") WRITE (*,"( ' -----------------------------------------------------------------------')") IF (overlay_count == 0) CALL DPrompt_for_Logical('Do you want one (or more) of these overlays?', .TRUE., do_overlay) IF (do_overlay) THEN CALL DPrompt_for_Integer('Which overlay type should be added?', 1, choice) IF ((choice < 1).OR.(choice > 11)) THEN WRITE (*,"(/' ERROR: Please select an integer from the list!')") CALL Pause() mt_flashby = .FALSE. GO TO 2000 ELSE ! legal choice overlay_count = overlay_count + 1 END IF ! illegal or legal choice SELECT CASE (choice) CASE (1) ! basemap (lines type) 2010 temp_path_in = fmc132_path_in CALL DPrompt_for_String('Which .DIG file should be plotted?', ' ', lines_basemap_file) lines_basemap_pathfile = TRIM(temp_path_in) // TRIM(lines_basemap_file) CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color (color_name = 'foreground') CALL Dig_Type (lines_basemap_pathfile, 21, dig_is_lonlat, any_titles) CALL DPrompt_for_Logical('Is this basemap written in (lon,lat) coordinates?', dig_is_lonlat, dig_is_lonlat) IF (.NOT.dig_is_lonlat) THEN WRITE (*,"(' ERROR: FlatMaxwell can only plot .DIG files in (lon, lat) coordinates.')") CALL Pause() GO TO 2000 END IF IF (any_titles) THEN WRITE (*, "(/' Title lines were detected in this .dig file;')") CALL DPrompt_for_Logical('do you want to include these titles in the plot?', .FALSE., plot_dig_titles) IF (plot_dig_titles) THEN WRITE (*,"(' -------------------------------------------------')") WRITE (*,"(' Choose Alignment Method for titles:')") WRITE (*,"(' 1: upright, at geometric center of polyline')") WRITE (*,"(' 2: parallel to first segment of polyline')") WRITE (*,"(' -------------------------------------------------')") 2011 CALL DPrompt_for_Integer('Which alignment method?', dig_title_method, dig_title_method) IF ((dig_title_method < 1).OR.(dig_title_method > 2)) THEN WRITE (*,"(' ERROR: Illegal choice of method.')") mt_flashby = .FALSE. GO TO 2011 END IF ! bad choice END IF ! plot_dig_titles END IF ! any_titles WRITE (*,"(/' Working on basemap....')") polygons = .FALSE. CALL DPlot_Dig (7, lines_basemap_pathfile, polygons, 21, in_ok) IF (.NOT.in_ok) THEN mt_flashby = .FALSE. GO TO 2010 END IF IF (any_titles .AND. plot_dig_titles) THEN CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DPlot_Dig (7, lines_basemap_pathfile, polygons, 21, in_ok, dig_title_method) END IF ! any_titles .AND. plot_dig_titles WRITE (*,"('+Working on basemap....DONE.')") ! possible plot titles: filename, and first 3 lines CALL Add_Title(TRIM(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) ! end of basemap overlay CASE (2) ! grid-point locations in a CSM file 2020 CALL DPrompt_for_String('Enter filename of a CSM stress grid:', fmc80_CSM_model_filename, fmc80_CSM_model_filename) CSM_input_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_CSM_model_filename) OPEN (UNIT = 21, FILE = TRIM(CSM_input_pathfile), STATUS = "OLD", PAD = "YES", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR; file not found; try again...')") CALL Pause() GO TO 2020 END IF CALL Add_Title("Grid points from " // TRIM(fmc80_CSM_model_filename)) CALL DPrompt_for_Integer('Height of grid-point symbol, in points:', 2, CSM_grid_height_nPoints) CSM_grid_height_degrees = degrees_per_radian * ((CSM_grid_height_nPoints * 0.000352777D0) * scale_denominator / fmr_radius_meters) CALL DBegin_Group() CALL DSet_Line_Style (width_points = 0.25D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color(color_name = 'dark_blue_') ELSE CALL DSet_Stroke_Color(color_name = 'foreground') END IF CALL DSet_Fill_or_Pattern(use_pattern = .FALSE., color_name = 'background') WRITE (*,"(/' Working on grid of points....')") old_lat = 99.0D0; old_lon = 0.0D0 scan_CSM: DO READ (21, "(A)", IOSTAT = ios) line IF (ios == -1) EXIT scan_CSM ! EOF IF (line(1:1) /= '#') THEN ! line is not a title or comment; should contain a location READ (line, *) lon, lat IF ((lon /= old_lon).OR.(lat /= old_lat)) THEN ! new location; plot a point !N-S bar: lat_prime = lat + 0.5D0 * CSM_grid_height_degrees CALL DLonLat_2_Uvec(lon, lat_prime, uvec) CALL DProject(uvec = uvec, x = x_meters, y = y_meters) CALL DNew_L3_Path(x_meters, y_meters) lat_prime = lat - 0.5D0 * CSM_grid_height_degrees CALL DLonLat_2_Uvec(lon, lat_prime, uvec) CALL DProject(uvec = uvec, x = x_meters, y = y_meters) CALL DLine_to_L3(x_meters, y_meters) CALL DEnd_L3_Path (close = .FALSE., stroke = .TRUE., fill=.FALSE.) !E-W bar: CSM_grid_width_degrees = CSM_grid_height_degrees / DCOS(lat * radians_per_degree) lon_prime = lon - 0.5D0 * CSM_grid_width_degrees CALL DLonLat_2_Uvec(lon_prime, lat, uvec) CALL DProject(uvec = uvec, x = x_meters, y = y_meters) CALL DNew_L3_Path(x_meters, y_meters) lon_prime = lon + 0.5D0 * CSM_grid_width_degrees CALL DLonLat_2_Uvec(lon_prime, lat, uvec) CALL DProject(uvec = uvec, x = x_meters, y = y_meters) CALL DLine_to_L3(x_meters, y_meters) CALL DEnd_L3_Path (close = .FALSE., stroke = .TRUE., fill=.FALSE.) END IF ! new location; plotting a point old_lon = lon; old_lat = lat END IF ! line contains a location END DO scan_CSM CALL DEnd_Group() CLOSE (21) WRITE (*,"('+Working on grid of points....DONE.')") ! end of grid-point location in a CSM file CASE (3) ! outline of model box 2030 CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) IF (ai_using_color) THEN CALL DSet_Stroke_Color(color_name = 'green_____') ELSE CALL DSet_Stroke_Color(color_name = 'foreground') END IF CALL DSet_Fill_or_Pattern(use_pattern = .FALSE., color_name = 'background') CALL DNew_L3_Path (x_meters = -fmr_x_LENGTH_meters*0.5D0, y_meters = -fmr_y_WIDTH_meters*0.5D0) CALL DLine_To_L3(x_meters = fmr_x_LENGTH_meters*0.5D0, y_meters = -fmr_y_WIDTH_meters*0.5D0) CALL DLine_To_L3(x_meters = fmr_x_LENGTH_meters*0.5D0, y_meters = fmr_y_WIDTH_meters*0.5D0) CALL DLine_To_L3(x_meters = -fmr_x_LENGTH_meters*0.5D0, y_meters = fmr_y_WIDTH_meters*0.5D0) CALL DLine_To_L3(x_meters = -fmr_x_LENGTH_meters*0.5D0, y_meters = -fmr_y_WIDTH_meters*0.5D0) CALL DEnd_L3_Path (close = .TRUE., stroke = .TRUE., fill=.FALSE.) WRITE (*, "(' DONE.')") !end of model box CASE (4, 5, 6) ! point measures of: {(4) topographic / (5) tectonic / (6) total} stress anomaly in a horizontal plane IF (choice == 4) THEN CALL Add_Title("Topographic stress anomaly model "//TRIM(fmc12_topographic_token)) ELSE IF (choice == 5) THEN CALL Add_Title("Tectonic stress anomaly model "//TRIM(fmc12_tectonic_token)) ELSE ! choice == 6 CALL Add_Title("Total stress anomaly model "//TRIM(fmc12_tectonic_token)) END IF 2040 WRITE (*,"(/' Which measure of this stress-anomaly tensor field should be plotted?')") WRITE (*,"( ' measure 1: shear traction vector on selected horizontal plane')") WRITE (*,"( ' measure 2: full tensor in selected horizontal plane')") WRITE (*,"( ' measure 3: most-compressive axes & styles in selected horizontal plane')") WRITE (*,"( ' measure 4: planes of greatest shear stress in selected horizontal plane')") WRITE (*,"( ' -------------------------------------------------------------------------')") CALL DPrompt_for_Integer('Which scalar measure?', desired_symbol, desired_symbol) IF ((desired_symbol < 1).OR.(desired_symbol > 4)) THEN WRITE (*,"(/' ERROR: Select measure index from list!' )") CALL Pause() mt_flashby = .FALSE. GO TO 2040 END IF 2041 CALL DPrompt_for_Real("Depth of horizontal plane below MSL (meters):", 10000.0D0, desired_depth) IF ((desired_depth < 0.0D0).OR.(desired_depth > fmr_z_DEPTH_meters)) THEN WRITE (*, "(' ERROR: This depth is not within the model domain. Range 0. to ',F7.0)") fmr_z_DEPTH_meters CALL Pause() GO TO 2041 END IF km_deep = desired_depth / 1000.0D0 WRITE (c5, "(F5.1)") km_deep IF (c5(5:5) == '0') WRITE (c5, "(I5)") NINT(km_deep) c5 = ADJUSTL(c5) IF (desired_symbol == 1) THEN CALL Add_Title("Shear traction vector on horizontal plane "//TRIM(c5)//" km below MSL") ELSE IF (desired_symbol == 2) THEN CALL Add_Title("Full tensor in horizontal plane "//TRIM(c5)//" km below MSL") ELSE IF (desired_symbol == 3) THEN CALL Add_Title("Most-compressive axes & styles in horizontal plane "//TRIM(c5)//" km below MSL") ELSE IF (desired_symbol == 4) THEN CALL Add_Title("Planes of greatest shear stress in horizontal plane "//TRIM(c5)//" km below MSL") END IF kz = NINT((-desired_depth - (-0.5D0 * fmr_z_DEPTH_meters)) / fmrv_topo_stress_dXYZ(3)) test_ele = -0.5D0 * fmr_z_DEPTH_meters + kz * fmrv_topo_stress_dXYZ(3) IF (-desired_depth >= test_ele) THEN kz1 = kz kz2 = MIN(kz1 + 1, fmi_topo_nz) fz2 = (-desired_depth - test_ele) / fmrv_topo_stress_dXYZ(3) fz1 = 1.0D0 - fz2 ELSE kz2 = kz kz1 = MAX(kz2 - 1, -fmi_topo_nz) fz1 = (test_ele - (-desired_depth)) / fmrv_topo_stress_dXYZ(3) fz2 = 1.0D0 - fz1 END IF ALLOCATE ( tensors_in_a_plane(6, -fmi_topo_nx:fmi_topo_nx, -fmi_topo_ny:fmi_topo_ny) ) IF (desired_symbol <= 2) THEN train_length = (2 * fmi_topo_nx + 1) * (2 * fmi_topo_ny + 1) ALLOCATE ( train(train_length) ) WRITE (*,"(/' Here is the distribution of values (on topographic-stress grid, in MPa):' )") END IF k = 0 ! (not used if desired_symbol > 2) DO i = -fmi_topo_nx, fmi_topo_nx ! W to E DO j = -fmi_topo_ny, fmi_topo_ny ! S to N IF (choice == 4) THEN ! topographic stress anomaly tensor, in MPa: tensors_in_a_plane(1:6, i, j) = 1.D-6 * (fz1 * fmrt_topo_stress_anomaly_Pa(1:6, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(1:6, i, j, kz2)) ELSE IF (choice == 5) THEN ! tectonic stress anomaly tensor, in MPa: tensors_in_a_plane(1:6, i, j) = 1.D-6 * (fz1 * fmrt_tectonic_stress_anomaly_Pa(1:6, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(1:6, i, j, kz2)) ELSE IF (choice == 6) THEN ! total stress anomaly tensor, in MPa: tensors_in_a_plane(1:6, i, j) = 1.D-6 * (fz1 * fmrt_topo_stress_anomaly_Pa(1:6, i, j, kz1) + & & fz2 * fmrt_topo_stress_anomaly_Pa(1:6, i, j, kz2) + & & fz1 * fmrt_tectonic_stress_anomaly_Pa(1:6, i, j, kz1) + & & fz2 * fmrt_tectonic_stress_anomaly_Pa(1:6, i, j, kz2)) END IF ! choice of type of stress anomaly tensor !First subscript: 1) s_xx, 2) s_yy, 3) s_zz, 4) s_yz, 5) s_xz, 6) s_xy IF (desired_symbol == 1) THEN ! shear traction vector on horizontal plane k = k + 1 train(k) = DSQRT((tensors_in_a_plane(4, i, j)**2) + (tensors_in_a_plane(5, i, j)**2)) ELSE IF (desired_symbol == 2) THEN ! full stress anomaly tensor k = k + 1 train(k) = MAX(ABS(tensors_in_a_plane(1, i, j)), & & ABS(tensors_in_a_plane(2, i, j)), & & ABS(tensors_in_a_plane(3, i, j)), & & ABS(tensors_in_a_plane(4, i, j)), & & ABS(tensors_in_a_plane(5, i, j)), & & ABS(tensors_in_a_plane(6, i, j))) END IF ! need to create a value for train END DO ! j = -fmi_topo_ny, fmi_topo_ny ; S to N END DO ! i = -fmi_topo_nx, fmi_topo_nx ; W to E IF (desired_symbol <= 2) THEN CALL Histogram (train, train_length, .FALSE., maximum, minimum) IF (maximum == minimum) THEN ! prevent division-by-zero, etc. IF (minimum == 0.0D0) THEN maximum = 1.0D0 ELSE maximum = minimum * 1.01D0 END IF END IF DEALLOCATE ( train ) END IF grid_units = 'MPa' ! for any of the choices (topographic, tectonic, or total anomalies) symbol_diameter_meters = MIN((fmr_x_LENGTH_meters / (2 * fmi_topo_nx)), & & (fmr_y_WIDTH_meters) / (2 * fmi_topo_ny)) ! to fit in model box without overlapping WRITE (*, *) WRITE (*, "(' Symbols are auto-scaled-to-fit if you choose relative size of 1.0 below:')") CALL DPrompt_for_Real("Relative symbol size:", 1.0D0, relative_symbol_size) symbol_diameter_meters = symbol_diameter_meters * relative_symbol_size s1_size_points = 2834.6D0 * symbol_diameter_meters / mp_scale_denominator IF (desired_symbol == 2) THEN ! plot full anomaly tensor CALL DBegin_Group() CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') maximum_diameter_points = 2834.6D0 * (symbol_diameter_meters / mp_scale_denominator) DO i = -fmi_topo_nx, fmi_topo_nx ! W to E DO j = -fmi_topo_ny, fmi_topo_ny ! S to N x_meters = i * fmrv_topo_stress_dXYZ(1) y_meters = j * fmrv_topo_stress_dXYZ(2) CALL DStress_in_Plane (level = 3, x = x_meters, y = y_meters, & & s11 = tensors_in_a_plane(1, i, j), & & s12 = tensors_in_a_plane(6, i, j), & & s22 = tensors_in_a_plane(2, i, j), & & s33 = tensors_in_a_plane(3, i, j), & & ref_pressure_SI = maximum, ref_diameter_points = maximum_diameter_points) END DO ! j = -fmi_topo_ny, fmi_topo_ny ; S to N END DO ! i = -fmi_topo_nx, fmi_topo_nx ; W to E CALL DEnd_Group number8 = ADJUSTL(DASCII8(maximum)) CALL Chooser(bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Stress Anomaly') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Tensor') CALL DStress_in_Plane (level = 1, & & x = 0.5D0*(x1_points + x2_points), & & y = y2_points - 24.0D0 - 0.5D0 * maximum_diameter_points, & & s11 = -maximum, & & s12 = 0.0D0, & & s22 = -maximum, & & s33 = -maximum, & & ref_pressure_SI = maximum, & & ref_diameter_points = maximum_diameter_points) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.0D0 - maximum_diameter_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8) // ' ' // "MPa") CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 36.0D0 + maximum_diameter_points ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Stress Anomaly') CALL DL12_Text (level = 1, & & x_points = x1_points + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Tensor:') CALL DL12_Text (level = 1, & & x_points = x1_points + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = TRIM(number8) // ' ' // "MPa") CALL DStress_in_Plane (level = 1, & & x = x1_points + 100.0D0 + 0.5D0 * maximum_diameter_points, & & y = 0.5D0 * (y1_points + y2_points), & & s11 = -maximum, & & s12 = 0.0D0, & & s22 = -maximum, & & s33 = -maximum, & & ref_pressure_SI = maximum, & & ref_diameter_points = maximum_diameter_points) CALL DStress_in_Plane (level = 1, & & x = x1_points + 106.0D0 + 1.5D0 * maximum_diameter_points, & & y = 0.5D0 * (y1_points + y2_points), & & s11 = +maximum, & & s12 = 0.0D0, & & s22 = +maximum, & & s33 = +maximum, & & ref_pressure_SI = maximum, & & ref_diameter_points = maximum_diameter_points) CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 106.0D0 + 2.0D0 * maximum_diameter_points END IF ! bottom or right legend END IF ! desired_symbol == 2; full anomaly tensor IF ((desired_symbol == 1).OR.(desired_symbol == 2)) THEN ! plot shear traction vectors on horizontal plane CALL DBegin_Group() CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) IF (mosaic_count > 0) THEN CALL DSet_Stroke_Color ('background') ELSE CALL DSet_Stroke_Color ('foreground') END IF DO i = -fmi_topo_nx, fmi_topo_nx ! W to E DO j = -fmi_topo_ny, fmi_topo_ny ! S to N x_meters = i * fmrv_topo_stress_dXYZ(1) y_meters = j * fmrv_topo_stress_dXYZ(2) traction_MPa = DSQRT((tensors_in_a_plane(4, i, j)**2) + (tensors_in_a_plane(5, i, j)**2)) IF (traction_MPa > 0.0D0) THEN vector_length_meters = traction_MPa * symbol_diameter_meters / maximum dx_meters = vector_length_meters * tensors_in_a_plane(5, i, j) / traction_MPa dy_meters = vector_length_meters * tensors_in_a_plane(4, i, j) / traction_MPa CALL DVector_in_Plane (level = 3, from_x = x_meters-0.5D0*dx_meters, from_y = y_meters-0.5D0*dy_meters, & & to_x = x_meters+0.5D0*dx_meters, to_y = y_meters+0.5D0*dy_meters) END IF END DO ! j = -fmi_topo_ny, fmi_topo_ny ; S to N END DO ! i = -fmi_topo_nx, fmi_topo_nx ; W to E CALL DEnd_Group traction_MPa_per_cm = maximum * 0.01D0 / (symbol_diameter_meters / mp_scale_denominator) number8 = ADJUSTL(DASCII8(traction_MPa_per_cm)) CALL DSet_Stroke_Color ('foreground') ! in case it was set to background earlier? CALL Chooser(bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Traction') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8)//' MPa:') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5D0*(x1_points+x2_points)-14.17D0, from_y = y2_points - 33.0D0, & & to_x = 0.5D0*(x1_points+x2_points)+14.17D0, to_y = y2_points - 33.0D0) CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 40.0D0 ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Traction') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)//' MPa:') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.0D0)-14.17D0, from_y = 0.5D0*(y1_points+y2_points)-10.0D0, & & to_x = (x1_points+29.0D0)+14.17D0, to_y = 0.5D0*(y1_points+y2_points)-10.0D0) CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58.0D0 END IF ! bottom or right legend END IF ! plotting shear traction vectors (desired_symbol == 1, or 2) IF ((desired_symbol == 3).OR.(desired_symbol == 4)) THEN IF (desired_symbol == 3) THEN WRITE (*,"(/' Working on trends of most-compressive principal directions (& tectonic styles)..')") ELSE IF (desired_symbol == 4) THEN WRITE (*,"(/' Working on planes of greatest anomalous shear traction...')") symbol_diameter_meters = MIN((fmr_x_LENGTH_meters / (2 * fmi_topo_nx)), & & (fmr_y_WIDTH_meters) / (2 * fmi_topo_ny)) ! to fit in model box without overlapping END IF CALL DBegin_Group DO i = -fmi_topo_nx, fmi_topo_nx x_meters = i * fmrv_topo_stress_dXYZ(1) DO j = -fmi_topo_ny, fmi_topo_ny y_meters = j * fmrv_topo_stress_dXYZ(2) !First subscript: 1) s_xx, 2) s_yy, 3) s_zz, 4) s_yz, 5) s_xz, 6) s_xy tensor(1, 1) = tensors_in_a_plane(1, i, j) tensor(2, 2) = tensors_in_a_plane(2, i, j) tensor(3, 3) = tensors_in_a_plane(3, i, j) tensor(2, 3) = tensors_in_a_plane(4, i, j) tensor(1, 3) = tensors_in_a_plane(5, i, j) tensor(1, 2) = tensors_in_a_plane(6, i, j) tensor(2, 1) = tensor(1, 2) tensor(3, 1) = tensor(1, 3) tensor(3, 2) = tensor(2, 3) CALL Eigenanalysis_3x3(tensor, eigenvalues, eigenvectors) !find trend and plunge of each principal axis: DO k = 1, 3 IF (eigenvectors(3, k) <= 0.0D0) THEN trend_radians(k) = DATAN2(eigenvectors(1, k), eigenvectors(2, k)) ELSE trend_radians(k) = DATAN2(-eigenvectors(1, k), -eigenvectors(2, k)) END IF !These trends are relative to FlatMaxwell axis +y, which is also plot axis +y (up on map sheet); !they are NOT relative to local North. They are measured clockwise in radians. !I always choose the trend (sense) as the direction with positive plunge. horizontal = DSQRT((eigenvectors(1, k)**2) + (eigenvectors(2, k)**2)) plunge_radians(k) = DATAN2(ABS(eigenvectors(3, k)), horizontal) ! both arguments non-negative !These plunges are relative to the FlatMaxwell (x, y) plane, which is the surface of the projected flat-Earth. !They are measured downward from horizontal in radians, and will always be positive (or zero). END DO IF (desired_symbol == 3) THEN !determine tectonic sense by most-vertical axis: IF ((plunge_radians(3) > plunge_radians(2)).AND.(plunge_radians(3) > plunge_radians(1))) THEN most_vertical_axis = 3 ELSE IF ((plunge_radians(2) > plunge_radians(1)).AND.(plunge_radians(2) > plunge_radians(3))) THEN most_vertical_axis = 2 ELSE most_vertical_axis = 1 END IF dX = 0.5D0 * symbol_diameter_meters * DSIN(trend_radians(1)) * DCOS(plunge_radians(1)) dY = 0.5D0 * symbol_diameter_meters * DCOS(trend_radians(1)) * DCOS(plunge_radians(1)) IF (ai_using_color) THEN ! wide line of green (s-s), mid_blue (thrust), or bronze (normal) CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) IF (most_vertical_axis == 2) THEN CALL DSet_Stroke_Color('green_____') ! strike-slip ELSE IF (most_vertical_axis == 3) THEN ! e_rr is e3 CALL DSet_Stroke_Color('mid_blue__') ! thrust ELSE ! e_rr is e1 CALL DSet_Stroke_Color('red_______') ! normal END IF ! different colors CALL DNew_L3_Path(x_meters + dX, y_meters + dY) CALL DLine_to_L3(x_meters - dX, y_meters - dY) CALL DEnd_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! b/w symbol ! black-stroked white box for normal, unstroked grey box for s-s, black for thrusting CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) IF (most_vertical_axis == 2) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'gray______') ! strike-slip stroke_this = .FALSE. ELSE IF (most_vertical_axis == 3) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') ! thrust stroke_this = .FALSE. ELSE ! most_vertical_axis == 1; normal CALL DSet_Fill_or_Pattern(.FALSE.,'background') ! normal stroke_this = .TRUE. END IF ! different grays CALL DNew_L3_Path(x_meters + dX - 0.1D0 * dY, y_meters + dY + 0.1D0 * dX) CALL DLine_to_L3 (x_meters - dX - 0.1D0 * dY, y_meters - dY + 0.1D0 * dX) CALL DLine_to_L3 (x_meters - dX + 0.1D0 * dY, y_meters - dY - 0.1D0 * dX) CALL DLine_to_L3 (x_meters + dX + 0.1D0 * dY, y_meters + dY - 0.1D0 * dX) CALL DLine_to_L3 (x_meters + dX - 0.1D0 * dY, y_meters + dY + 0.1D0 * dX) CALL DEnd_L3_Path(close = .TRUE., stroke = stroke_this, fill = .TRUE.) END IF ! ai_using_color, or not ELSE ! desired_symbol == 4 (FM) CALL DSet_Line_Style (0.6D0, .FALSE.) CALL DBegin_Group ! of ALL FPS symbols CALL DBegin_Group ! for this one FPS symbol ! Plot a white background circle (even for slide copy!): CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_L3 (x_meters, y_meters, 0.5D0 * symbol_diameter_meters, .TRUE., .TRUE.) ! Save state of module Map_Projections: CALL DSave_mp_State () ! Reset Map_Projections to show a tiny world at right location and size: ! NOTE: Since projection-plane (x,y) system is arbitrary, I will leave it set as ! the FlatMaxwell (x, y) coordinate system. CALL DSet_Stereographic (radius_meters = 0.25D0 * symbol_diameter_meters, & ! extra factor of 0.5 counters stereographic blowup of outer circle & projpoint_uvec = (/ -0.01745241D0, 0.0D0, 0.9998477D0 /), & ! see comment below & x_projpoint_meters = x_meters, & & y_projpoint_meters = y_meters, & & y_azimuth_radians = 0.0D0) ! Plot two black sectors on (front) side of little world. ! NOTE: Little world is seen from ~North pole ! (actually, from 89N, 180 E to prevent degeneracy), with ! its Greenwich meridian pointing toward +y on the map page, ! so that if 1.0*plunge is used as a North latitude, and ! -1.0*trend is used as a longitude, points plot correctly on ! the lower focal hemisphere. Points with negative ! plunge will not be seen, as they will be on the back side. CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') e1_lon = -1.0D0 * trend_radians(1) * degrees_per_radian ! -1 * e1_trend e2_lon = -1.0D0 * trend_radians(2) * degrees_per_radian ! -1 * e2_trend e3_lon = -1.0D0 * trend_radians(3) * degrees_per_radian ! -1 * e3_trend e1_lat = 1.0D0 * plunge_radians(1) * degrees_per_radian ! 1 * e1_plunge e2_lat = 1.0D0 * plunge_radians(2) * degrees_per_radian ! 1 * e2_plunge e3_lat = 1.0D0 * plunge_radians(3) * degrees_per_radian ! 1 * e3_plunge CALL DLonLat_2_Uvec (lon = e1_lon, lat = e1_lat, uvec = e1_f_uvec) ! front or visible end CALL DLonLat_2_Uvec (lon = e2_lon, lat = e2_lat, uvec = e2_f_uvec) ! front or visible end CALL DLonLat_2_Uvec (lon = e3_lon, lat = e3_lat, uvec = e3_f_uvec) ! front or visible end !To prevent topological problems during drafting, adjust these three axes !to be exactly perpendicular to each other! Preserve e2_f_uvec exactly, !since this is the one that comes directly from data. CALL DCross (e1_f_uvec, e2_f_uvec, tvec) ! replacing e3, now perp. to e2 IF (tvec(3) < 0.0D0) tvec = -tvec CALL DMake_Uvec (tvec, e3_f_uvec) CALL DCross (e2_f_uvec, e3_f_uvec, tvec) ! replacing e1, now perp. to both IF (tvec(3) < 0.0D0) tvec = -tvec CALL DMake_Uvec (tvec, e1_f_uvec) e1_b_uvec = -e1_f_uvec ! back end of e1 axis; invisible e2_b_uvec = -e2_f_uvec ! back end of e2 axis; invisible e3_b_uvec = -e3_f_uvec ! back end of e3 axis; invisible tvec = e3_f_uvec + e1_b_uvec CALL DMake_uvec (tvec, turn_1_uvec) ! pole of 1st small circle arc tvec = e3_f_uvec + e1_f_uvec CALL DMake_uvec (tvec, turn_2_uvec) ! pole of 2nd small circle arc turn_3_uvec = -turn_1_uvec ! pole of 3rd small circle turn_4_uvec = -turn_2_uvec ! pole of 4th small circle CALL DNew_L45_Path (5, e2_f_uvec) CALL DSmall_To_L45 (pole_uvec = turn_1_uvec, to_uvec = e2_b_uvec) ! front to back CALL DSmall_To_L45 (pole_uvec = turn_2_uvec, to_uvec = e2_f_uvec) ! back to front CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE., retro = .TRUE.) CALL DNew_L45_Path (5, e2_f_uvec) CALL DSmall_To_L45 (pole_uvec = turn_3_uvec, to_uvec = e2_b_uvec) ! front to back CALL DSmall_To_L45 (pole_uvec = turn_4_uvec, to_uvec = e2_f_uvec) ! back to front CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE., retro = .TRUE.) ! Reset (saved) state of module Map_Projections CALL DRestore_mp_State () ! Plot the outer circle of lower focal hemisphere CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'white_____') CALL DCircle_on_L3 (x_meters, y_meters, 0.5D0 * symbol_diameter_meters, .TRUE., .FALSE.) CALL DEnd_Group ! for this one FPS symbol CALL DEnd_Group ! of ALL FPS symbols END IF ! desired_symbol == 3 (most-compressive trend & style), OR 4 (FM) END DO ! j = -fmi_topo_ny, fmi_topo_ny END DO ! i = -fmi_topo_nx, fmi_topo_nx CALL DEnd_Group ! either of desired_symbolS == 3, or == 4 CALL DBegin_Group ! sample s_1 directions, or sample FMs, in legend CALL Chooser (bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (desired_symbol == 3) THEN ! most-compressive trends and styles: IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points xcp = (x1_points + x2_points) / 2.0D0 CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Model s_1') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'direction and') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-30.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'stress regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('red_______') CALL DSet_Line_Style (width_points = 3.00D0, dashed = .FALSE.) CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-40.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'background') CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-40.0D0-1.5D0) CALL DLine_to_L12(xcp-4.0D0, y2_points-40.0D0+1.5D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0+1.5D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0-1.5D0) CALL DLine_to_L12(xcp-4.0D0, y2_points-40.0D0-1.5D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-40.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'normal') IF (ai_using_color) THEN CALL DSet_Stroke_Color('green_____') ELSE CALL DSet_Stroke_Color('gray______') END IF CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-50.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-50.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-50.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'strike-slip') IF (ai_using_color) THEN CALL DSet_Stroke_Color('mid_blue__') ELSE CALL DSet_Stroke_Color('foreground') END IF CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-60.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-60.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-60.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 64.0D0 ELSE ! bottom CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points) / 2.0D0 CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Model s_1') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'direction and') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'stress regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('red_______') CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+76.0D0, ycp+10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'background') CALL DNew_L12_Path(1, x1_points+76.0D0, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0-1.5D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'normal') IF (ai_using_color) THEN CALL DSet_Stroke_Color('green_____') ELSE CALL DSet_Stroke_Color('gray______') END IF CALL DNew_L12_Path(1, x1_points+76.0D0, ycp) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'strike-slip') IF (ai_using_color) THEN CALL DSet_Stroke_Color('mid_blue__') ELSE CALL DSet_Stroke_Color('foreground') END IF CALL DNew_L12_Path(1, x1_points+76.0D0, ycp-10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 116.0D0 + s1_size_points END IF ! right or bottom legend for desired_symbol == 3? ELSE ! desired_symbol == 4; FM legend !sample EQ magnitudes in the margin CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') ! EQs have black fill with white outline (to separate points) CALL DSet_Stroke_Color ('background') CALL DSet_Line_Style (0.6D0, .FALSE.) IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x_used_points = 0.0D0 yp = (y1_points + y2_points) / 2.0D0 ! sample thrust and normal in bottom legend CALL DBegin_Group step_points = MAX((0.5D0 * s1_size_points + 6.0D0), 24.0D0) xp = x1_points + bottomlegend_used_points + x_used_points + MAX(radius_points, 16.0D0) + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL Cats_Eye (xp, yp, 0.5D0 * s1_size_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) ypt = yp - radius_points - 12.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.6D0, 0.0D0, & & 'thrust') x_used_points = x_used_points + 2.0D0 * MAX(radius_points, 16.0D0) + 6.0D0 CALL DEnd_Group CALL DBegin_Group xp = x1_points + bottomlegend_used_points + x_used_points + MAX(radius_points, 16.0D0) + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL DCircle_on_L12 (1, xp,yp, 0.5D0 * s1_size_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL Cats_Eye (xp, yp, 0.5D0 * s1_size_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, 0.5D0 * s1_size_points, .TRUE., .FALSE.) ypt = yp - radius_points - 12.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.4D0, 0.0D0, & & 'normal') x_used_points = x_used_points + 2.0D0 * MAX(radius_points, 16.0D0) + 6.0D0 + step_points bottomlegend_used_points = bottomlegend_used_points + x_used_points ELSE IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y_used_points = 0.0D0 radius_points = 0.5D0 * s1_size_points xp = x1_points + radius_points yp = y2_points - rightlegend_used_points - y_used_points - radius_points - 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL Cats_Eye (xp, yp, radius_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) xpt = xp + radius_points + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xpt, yp, 0.0D0, & & 12, 0.0D0, 0.4D0, & & 'thrust') y_used_points = y_used_points + 2.0D0 * radius_points + 6.0D0 CALL DEnd_Group CALL DBegin_Group yp = y2_points - rightlegend_used_points - y_used_points - radius_points - 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL Cats_Eye (xp, yp, radius_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) xpt = xp + radius_points + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xpt, yp, 0.0D0, & & 12, 0.0D0, 0.4D0, & & 'normal') y_used_points = y_used_points + 2.0D0 * radius_points + 6.0D0 rightlegend_used_points = rightlegend_used_points + y_used_points END IF ! bottom, or right, legend in use END IF ! sample s1? or sample FM? in legend CALL DEnd_Group ! of legend (either for s1 or for FM) END IF ! GROUP of desired_symbols :: 3 OR 4 DEALLOCATE ( tensors_in_a_plane ) ! end of (4, 5, 6): point measures of: {(4) topographic / (5) tectonic / (6) total} stress anomaly in a horizontal plane CASE (7, 8, 9) ! point measures of vertically-integrated {(7) topographic / (8) tectonic / (9) total} stress anomaly IF (choice == 7) THEN CALL Add_Title("Topographic stress anomaly model "//TRIM(fmc12_topographic_token)) ELSE IF (choice == 8) THEN CALL Add_Title("Tectonic stress anomaly model "//TRIM(fmc12_tectonic_token)) ELSE ! choice == 9 CALL Add_Title("Total stress anomaly model "//TRIM(fmc12_tectonic_token)) END IF 2070 WRITE (*,"(/' Which measure of this stress-anomaly tensor field should be plotted?')") WRITE (*,"( ' measure 1: vertically-integrated shear traction on horizontal planes')") WRITE (*,"( ' measure 2: vertically-integrated stress anomaly tensor')") WRITE (*,"( ' measure 3: vertically-averaged most-compressive axes & styles')") WRITE (*,"( ' measure 4: vertically-averaged planes of greatest shear stress')") WRITE (*,"( ' -------------------------------------------------------------------------')") CALL DPrompt_for_Integer('Which symbol type?', desired_symbol, desired_symbol) IF ((desired_symbol < 1).OR.(desired_symbol > 4)) THEN WRITE (*,"(/' ERROR: Select measure index from list!' )") CALL Pause() mt_flashby = .FALSE. GO TO 2070 END IF IF (desired_symbol == 1) THEN CALL Add_Title("Vertically-integrated shear traction on horizontal planes") ELSE IF (desired_symbol == 2) THEN CALL Add_Title("Vertically-integrated stress anomaly tensor") ELSE IF (desired_symbol == 3) THEN CALL Add_Title("Vertically-averaged most-compressive axes & styles") ELSE IF (desired_symbol == 4) THEN CALL Add_Title("Vertically-averaged planes of greatest shear stress") END IF IF (desired_symbol <= 2) THEN ! need to compile train of scalar values train_length = (2 * fmi_topo_nx + 1) * (2 * fmi_topo_ny + 1) ALLOCATE ( train(train_length) ) END IF ALLOCATE (scalars_in_a_plane(-fmi_topo_nx:fmi_topo_nx, -fmi_topo_ny:fmi_topo_ny) ) scalars_in_a_plane = 0.0D0 ! whole array (simplifies debugging) ALLOCATE (tensors_in_a_plane(6, -fmi_topo_nx:fmi_topo_nx, -fmi_topo_ny:fmi_topo_ny) ) tensors_in_a_plane = 0.0D0 ! whole array; initializing before sums below n = 0 ! no train yet DO i = -fmi_topo_nx, fmi_topo_nx ! W to E DO j = -fmi_topo_ny, fmi_topo_ny ! S to N n = n + 1 ! getting ready to add to train DO k = -fmi_topo_nz, fmi_topo_nz IF (k == -fmi_topo_nz) THEN dZ = 0.5D0 * fmrv_topo_stress_dXYZ(3) ELSE IF (k == fmi_topo_nz) THEN dZ = 0.5D0 * fmrv_topo_stress_dXYZ(3) ELSE dZ = fmrv_topo_stress_dXYZ(3) END IF IF (choice == 7) THEN ! topographic stress anomaly: tensors_in_a_plane(1:6, i, j) = tensors_in_a_plane(1:6, i, j) + fmrt_topo_stress_anomaly_Pa(1:6, i, j, k) * dZ ELSE IF (choice == 8) THEN ! tectonic stress anomaly: tensors_in_a_plane(1:6, i, j) = tensors_in_a_plane(1:6, i, j) + fmrt_tectonic_stress_anomaly_Pa(1:6, i, j, k) * dZ ELSE ! choice == 9; total stress anomaly tensors_in_a_plane(1:6, i, j) = tensors_in_a_plane(1:6, i, j) + (fmrt_topo_stress_anomaly_Pa(1:6, i, j, k) + & & fmrt_tectonic_stress_anomaly_Pa(1:6, i, j, k)) * dZ END IF END DO ! k = -fmi_topo_nz, fmi_topo_nz IF (desired_symbol == 1) THEN ! vertical-integral of shear tractions on horizontal planes !First subscript: 1) s_xx, 2) s_yy, 3) s_zz, 4) s_yz, 5) s_xz, 6) s_xy scalars_in_a_plane(i, j) = DSQRT((tensors_in_a_plane(4, i, j)**2) + (tensors_in_a_plane(5, i, j)**2)) train(n) = scalars_in_a_plane(i, j) ELSE IF (desired_symbol == 2) THEN ! vertical-integral of full stress anomaly tensor scalars_in_a_plane(i, j) = MAX(ABS(tensors_in_a_plane(1, i, j)), & & ABS(tensors_in_a_plane(2, i, j)), & & ABS(tensors_in_a_plane(3, i, j)), & & ABS(tensors_in_a_plane(4, i, j)), & & ABS(tensors_in_a_plane(5, i, j)), & & ABS(tensors_in_a_plane(6, i, j))) train(n) = scalars_in_a_plane(i, j) END IF ! desired_symbol == 1 or 2 (requiring train(n) value), versus 3 or 4 (which don't). END DO ! j = -fmi_topo_ny, fmi_topo_ny ; S to N END DO ! i = -fmi_topo_nx, fmi_topo_nx ; W to E IF (desired_symbol <= 2) THEN WRITE (*,"(/' Here is the distribution of values (on topographic-stress grid, in N/m):' )") CALL Histogram (train, train_length, .FALSE., maximum, minimum) IF (maximum == minimum) THEN ! prevent division-by-zero, etc. IF (minimum == 0.0D0) THEN maximum = 1.0D0 ELSE maximum = minimum * 1.01D0 END IF END IF DEALLOCATE ( train ) END IF grid_units = 'N/m' ! for any of the choices (vertical-integral of: topographic, tectonic, or total anomalies) symbol_diameter_meters = MIN((fmr_x_LENGTH_meters / (2 * fmi_topo_nx)), & & (fmr_y_WIDTH_meters) / (2 * fmi_topo_ny)) ! to fit in model box without overlapping WRITE (*, *) WRITE (*, "(' Symbols are auto-scaled-to-fit if you choose relative size of 1.0 below:')") CALL DPrompt_for_Real("Relative symbol size:", 1.0D0, relative_symbol_size) symbol_diameter_meters = symbol_diameter_meters * relative_symbol_size s1_size_points = 2834.6D0 * symbol_diameter_meters / mp_scale_denominator IF (desired_symbol == 2) THEN ! plot vertical-integral of full stress anomaly tensor, as a tensor in N/m. CALL DBegin_Group() CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') maximum_diameter_points = 2834.6D0 * (symbol_diameter_meters / mp_scale_denominator) DO i = -fmi_topo_nx, fmi_topo_nx ! W to E DO j = -fmi_topo_ny, fmi_topo_ny ! S to N x_meters = i * fmrv_topo_stress_dXYZ(1) y_meters = j * fmrv_topo_stress_dXYZ(2) CALL DStress_in_Plane (level = 3, x = x_meters, y = y_meters, & & s11 = tensors_in_a_plane(1, i, j), & & s12 = tensors_in_a_plane(6, i, j), & & s22 = tensors_in_a_plane(2, i, j), & & s33 = tensors_in_a_plane(3, i, j), & & ref_pressure_SI = maximum, ref_diameter_points = maximum_diameter_points) END DO ! j = -fmi_topo_ny, fmi_topo_ny ; S to N END DO ! i = -fmi_topo_nx, fmi_topo_nx ; W to E CALL DEnd_Group number8 = ADJUSTL(DASCII8(maximum)) CALL Chooser(bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Vertical-Integral') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'of Anomaly Tensor') CALL DStress_in_Plane (level = 1, & & x = 0.5D0*(x1_points + x2_points), & & y = y2_points - 24.0D0 - 0.5D0 * maximum_diameter_points, & & s11 = -maximum, & & s12 = 0.0D0, & & s22 = -maximum, & & s33 = -maximum, & & ref_pressure_SI = maximum, & & ref_diameter_points = maximum_diameter_points) CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.0D0 - maximum_diameter_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8) // ' ' // "N/m") CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 36.0D0 + maximum_diameter_points ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Vertical-Integral') CALL DL12_Text (level = 1, & & x_points = x1_points + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'of AnomalyTensor:') CALL DL12_Text (level = 1, & & x_points = x1_points + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = TRIM(number8) // ' ' // "N/m") CALL DStress_in_Plane (level = 1, & & x = x1_points + 100.0D0 + 0.5D0 * maximum_diameter_points, & & y = 0.5D0 * (y1_points + y2_points), & & s11 = -maximum, & & s12 = 0.0D0, & & s22 = -maximum, & & s33 = -maximum, & & ref_pressure_SI = maximum, & & ref_diameter_points = maximum_diameter_points) CALL DStress_in_Plane (level = 1, & & x = x1_points + 106.0D0 + 1.5D0 * maximum_diameter_points, & & y = 0.5D0 * (y1_points + y2_points), & & s11 = +maximum, & & s12 = 0.0D0, & & s22 = +maximum, & & s33 = +maximum, & & ref_pressure_SI = maximum, & & ref_diameter_points = maximum_diameter_points) CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 106.0D0 + 2.0D0 * maximum_diameter_points END IF ! bottom or right legend END IF ! desired_symbol == 2; vertical-integral of full stress anomaly tensor IF ((desired_symbol == 1).OR.(desired_symbol == 2)) THEN ! plot vertically-integrated shear traction vectors on horizontal planes CALL DBegin_Group() CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) IF (mosaic_count > 0) THEN CALL DSet_Stroke_Color ('background') ELSE CALL DSet_Stroke_Color ('foreground') END IF DO i = -fmi_topo_nx, fmi_topo_nx ! W to E DO j = -fmi_topo_ny, fmi_topo_ny ! S to N x_meters = i * fmrv_topo_stress_dXYZ(1) y_meters = j * fmrv_topo_stress_dXYZ(2) traction_Npm = DSQRT((tensors_in_a_plane(4, i, j)**2) + (tensors_in_a_plane(5, i, j)**2)) vector_length_meters = traction_Npm * symbol_diameter_meters / maximum dx_meters = vector_length_meters * tensors_in_a_plane(5, i, j) / traction_Npm dy_meters = vector_length_meters * tensors_in_a_plane(4, i, j) / traction_Npm CALL DVector_in_Plane (level = 3, from_x = x_meters-0.5D0*dx_meters, from_y = y_meters-0.5D0*dy_meters, & & to_x = x_meters+0.5D0*dx_meters, to_y = y_meters+0.5D0*dy_meters) END DO ! j = -fmi_topo_ny, fmi_topo_ny ; S to N END DO ! i = -fmi_topo_nx, fmi_topo_nx ; W to E CALL DEnd_Group traction_Npm_per_cm = maximum * 0.01D0 / (symbol_diameter_meters / mp_scale_denominator) number8 = ADJUSTL(DASCII8(traction_Npm_per_cm)) CALL DSet_Stroke_Color ('foreground') ! in case it was set to background earlier? CALL Chooser(bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'Vertical Integral') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = 'of Traction on HPs') CALL DL12_Text (level = 1, & & x_points = 0.5D0*(x1_points + x2_points), & & y_points = y2_points - 24.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 1.0D0, & & text = TRIM(number8)//' N/m:') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = 0.5D0*(x1_points+x2_points)-14.17D0, from_y = y2_points - 45.0D0, & & to_x = 0.5D0*(x1_points+x2_points)+14.17D0, to_y = y2_points - 45.0D0) CALL DEnd_Group rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 52.0D0 ELSE IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Vertical Integral') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'of Traction on HPs') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)//' N/m') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.0D0)-14.17D0, from_y = 0.5D0*(y1_points+y2_points)-22.0D0, & & to_x = (x1_points+29.0D0)+14.17D0, to_y = 0.5D0*(y1_points+y2_points)-22.0D0) CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58.0D0 END IF ! bottom or right legend END IF ! plotting shear traction vectors (desired_symbol == 1, or 2) IF ((desired_symbol == 3).OR.(desired_symbol == 4)) THEN symbol_diameter_meters = MIN((fmr_x_LENGTH_meters / (2 * fmi_topo_nx)), & & (fmr_y_WIDTH_meters) / (2 * fmi_topo_ny)) ! to fit in model box without overlapping IF (desired_symbol == 3) THEN WRITE (*,"(/' Working on vertical-averages of most-compressive principal directions (& tectonic styles)...')") ELSE IF (desired_symbol == 4) THEN WRITE (*,"(/' Working on vertical-averaged planes of greatest shear traction...')") END IF CALL DBegin_Group DO i = -fmi_topo_nx, fmi_topo_nx x_meters = i * fmrv_topo_stress_dXYZ(1) DO j = -fmi_topo_ny, fmi_topo_ny y_meters = j * fmrv_topo_stress_dXYZ(2) !First subscript: 1) s_xx, 2) s_yy, 3) s_zz, 4) s_yz, 5) s_xz, 6) s_xy tensor(1, 1) = tensors_in_a_plane(1, i, j) tensor(2, 2) = tensors_in_a_plane(2, i, j) tensor(3, 3) = tensors_in_a_plane(3, i, j) tensor(2, 3) = tensors_in_a_plane(4, i, j) tensor(1, 3) = tensors_in_a_plane(5, i, j) tensor(1, 2) = tensors_in_a_plane(6, i, j) tensor(2, 1) = tensor(1, 2) tensor(3, 1) = tensor(1, 3) tensor(3, 2) = tensor(2, 3) CALL Eigenanalysis_3x3(tensor, eigenvalues, eigenvectors) !find trend and plunge of each principal axis: DO k = 1, 3 IF (eigenvectors(3, k) <= 0.0D0) THEN trend_radians(k) = DATAN2(eigenvectors(1, k), eigenvectors(2, k)) ELSE trend_radians(k) = DATAN2(-eigenvectors(1, k), -eigenvectors(2, k)) END IF !These trends are relative to FlatMaxwell axis +y, which is also plot axis +y (up on map sheet); !they are NOT relative to local North. They are measured clockwise in radians. !I always choose the trend (sense) as the direction with positive plunge. horizontal = DSQRT((eigenvectors(1, k)**2) + (eigenvectors(2, k)**2)) plunge_radians(k) = DATAN2(ABS(eigenvectors(3, k)), horizontal) ! both arguments non-negative !These plunges are relative to the FlatMaxwell (x, y) plane, which is the surface of the projected flat-Earth. !They are measured downward from horizontal in radians, and will always be positive (or zero). END DO IF (desired_symbol == 3) THEN !determine tectonic sense by most-vertical axis: IF ((plunge_radians(3) > plunge_radians(2)).AND.(plunge_radians(3) > plunge_radians(1))) THEN most_vertical_axis = 3 ELSE IF ((plunge_radians(2) > plunge_radians(1)).AND.(plunge_radians(2) > plunge_radians(3))) THEN most_vertical_axis = 2 ELSE most_vertical_axis = 1 END IF dX = 0.5D0 * symbol_diameter_meters * DSIN(trend_radians(1)) * DCOS(plunge_radians(1)) dY = 0.5D0 * symbol_diameter_meters * DCOS(trend_radians(1)) * DCOS(plunge_radians(1)) IF (ai_using_color) THEN ! wide line of green (s-s), mid_blue (thrust), or bronze (normal) CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) IF (most_vertical_axis == 2) THEN CALL DSet_Stroke_Color('green_____') ! strike-slip ELSE IF (most_vertical_axis == 3) THEN ! e_rr is e3 CALL DSet_Stroke_Color('mid_blue__') ! thrust ELSE ! e_rr is e1 CALL DSet_Stroke_Color('red_______') ! normal END IF ! different colors CALL DNew_L3_Path(x_meters + dX, y_meters + dY) CALL DLine_to_L3(x_meters - dX, y_meters - dY) CALL DEnd_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! b/w symbol ! black-stroked white box for normal, unstroked grey box for s-s, black for thrusting CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) IF (most_vertical_axis == 2) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'gray______') ! strike-slip stroke_this = .FALSE. ELSE IF (most_vertical_axis == 3) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') ! thrust stroke_this = .FALSE. ELSE ! most_vertical_axis == 1; normal CALL DSet_Fill_or_Pattern(.FALSE.,'background') ! normal stroke_this = .TRUE. END IF ! different grays CALL DNew_L3_Path(x_meters + dX - 0.1D0 * dY, y_meters + dY + 0.1D0 * dX) CALL DLine_to_L3 (x_meters - dX - 0.1D0 * dY, y_meters - dY + 0.1D0 * dX) CALL DLine_to_L3 (x_meters - dX + 0.1D0 * dY, y_meters - dY - 0.1D0 * dX) CALL DLine_to_L3 (x_meters + dX + 0.1D0 * dY, y_meters + dY - 0.1D0 * dX) CALL DLine_to_L3 (x_meters + dX - 0.1D0 * dY, y_meters + dY + 0.1D0 * dX) CALL DEnd_L3_Path(close = .TRUE., stroke = stroke_this, fill = .TRUE.) END IF ! ai_using_color, or not ELSE ! desired_symbol == 4 (FM) CALL DSet_Line_Style (0.6D0, .FALSE.) CALL DBegin_Group CALL DBegin_Group ! for this one FPS symbol ! Plot a white background circle (even for slide copy!): CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_L3 (x_meters, y_meters, 0.5D0 * symbol_diameter_meters, .TRUE., .TRUE.) ! Save state of module Map_Projections: CALL DSave_mp_State () ! Reset Map_Projections to show a tiny world at right location and size: ! NOTE: Since projection-plane (x,y) system is arbitrary, I will leave it set as ! the FlatMaxwell (x, y) coordinate system. CALL DSet_Stereographic (radius_meters = 0.25D0 * symbol_diameter_meters, & ! extra factor of 0.5 counters stereographic blowup of outer circle & projpoint_uvec = (/ -0.01745241D0, 0.0D0, 0.9998477D0 /), & ! see comment below & x_projpoint_meters = x_meters, & & y_projpoint_meters = y_meters, & & y_azimuth_radians = 0.0D0) ! Plot two black sectors on (front) side of little world. ! NOTE: Little world is seen from ~North pole ! (actually, from 89N, 180 E to prevent degeneracy), with ! its Greenwich meridian pointing toward +y on the map page, ! so that if 1.0*plunge is used as a North latitude, and ! -1.0*trend is used as a longitude, points plot correctly on ! the lower focal hemisphere. Points with negative ! plunge will not be seen, as they will be on the back side. CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') e1_lon = -1.0D0 * trend_radians(1) * degrees_per_radian ! -1 * e1_trend e2_lon = -1.0D0 * trend_radians(2) * degrees_per_radian ! -1 * e2_trend e3_lon = -1.0D0 * trend_radians(3) * degrees_per_radian ! -1 * e3_trend e1_lat = 1.0D0 * plunge_radians(1) * degrees_per_radian ! 1 * e1_plunge e2_lat = 1.0D0 * plunge_radians(2) * degrees_per_radian ! 1 * e2_plunge e3_lat = 1.0D0 * plunge_radians(3) * degrees_per_radian ! 1 * e3_plunge CALL DLonLat_2_Uvec (lon = e1_lon, lat = e1_lat, uvec = e1_f_uvec) ! front or visible end CALL DLonLat_2_Uvec (lon = e2_lon, lat = e2_lat, uvec = e2_f_uvec) ! front or visible end CALL DLonLat_2_Uvec (lon = e3_lon, lat = e3_lat, uvec = e3_f_uvec) ! front or visible end !To prevent topological problems during drafting, adjust these three axes !to be exactly perpendicular to each other! Preserve e2_f_uvec exactly, !since this is the one that comes directly from data. CALL DCross (e1_f_uvec, e2_f_uvec, tvec) ! replacing e3, now perp. to e2 IF (tvec(3) < 0.0D0) tvec = -tvec CALL DMake_Uvec (tvec, e3_f_uvec) CALL DCross (e2_f_uvec, e3_f_uvec, tvec) ! replacing e1, now perp. to both IF (tvec(3) < 0.0D0) tvec = -tvec CALL DMake_Uvec (tvec, e1_f_uvec) e1_b_uvec = -e1_f_uvec ! back end of e1 axis; invisible e2_b_uvec = -e2_f_uvec ! back end of e2 axis; invisible e3_b_uvec = -e3_f_uvec ! back end of e3 axis; invisible tvec = e3_f_uvec + e1_b_uvec CALL DMake_uvec (tvec, turn_1_uvec) ! pole of 1st small circle arc tvec = e3_f_uvec + e1_f_uvec CALL DMake_uvec (tvec, turn_2_uvec) ! pole of 2nd small circle arc turn_3_uvec = -turn_1_uvec ! pole of 3rd small circle turn_4_uvec = -turn_2_uvec ! pole of 4th small circle CALL DNew_L45_Path (5, e2_f_uvec) CALL DSmall_To_L45 (pole_uvec = turn_1_uvec, to_uvec = e2_b_uvec) ! front to back CALL DSmall_To_L45 (pole_uvec = turn_2_uvec, to_uvec = e2_f_uvec) ! back to front CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE., retro = .TRUE.) CALL DNew_L45_Path (5, e2_f_uvec) CALL DSmall_To_L45 (pole_uvec = turn_3_uvec, to_uvec = e2_b_uvec) ! front to back CALL DSmall_To_L45 (pole_uvec = turn_4_uvec, to_uvec = e2_f_uvec) ! back to front CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE., retro = .TRUE.) ! Reset (saved) state of module Map_Projections CALL DRestore_mp_State () ! Plot the outer circle of lower focal hemisphere CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_L3 (x_meters, y_meters, 0.5D0 * symbol_diameter_meters, .TRUE., .FALSE.) CALL DEnd_Group ! for this one FPS symbol CALL DEnd_Group ! for ALL FPS symbols END IF ! desired_symbol == 3 (most-compressive trend & style), OR 4 (FM) END DO ! j = -fmi_topo_ny, fmi_topo_ny END DO ! i = -fmi_topo_nx, fmi_topo_nx CALL DEnd_Group ! either of desired_symbolS == 3, or == 4 CALL DBegin_Group ! sample s_1 directions, or sample FMs, in legend CALL Chooser (bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (desired_symbol == 3) THEN ! most-compressive trends and styles: IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points xcp = (x1_points + x2_points) / 2.0D0 CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Vert.-Averaged') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 's_1 direction &') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-30.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'stress regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('red_______') CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-40.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'background') CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-40.0D0-1.5D0) CALL DLine_to_L12(xcp-4.0D0, y2_points-40.0D0+1.5D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0+1.5D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0-1.5D0) CALL DLine_to_L12(xcp-4.0D0, y2_points-40.0D0-1.5D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-40.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'normal') IF (ai_using_color) THEN CALL DSet_Stroke_Color('green_____') ELSE CALL DSet_Stroke_Color('gray______') END IF CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-50.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-50.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-50.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'strike-slip') IF (ai_using_color) THEN CALL DSet_Stroke_Color('mid_blue__') ELSE CALL DSet_Stroke_Color('foreground') END IF CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-60.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-60.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-60.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 64.0D0 ELSE ! bottom CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points) / 2.0D0 CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Vertic.-Averaged') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 's_1 direction &') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'stress regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('red_______') CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+76.0D0, ycp+10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'background') CALL DNew_L12_Path(1, x1_points+76.0D0, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0-1.5D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'normal') IF (ai_using_color) THEN CALL DSet_Stroke_Color('green_____') ELSE CALL DSet_Stroke_Color('gray______') END IF CALL DNew_L12_Path(1, x1_points+76.0D0, ycp) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'strike-slip') IF (ai_using_color) THEN CALL DSet_Stroke_Color('mid_blue__') ELSE CALL DSet_Stroke_Color('foreground') END IF CALL DNew_L12_Path(1, x1_points+76.0D0, ycp-10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 116.0D0 + s1_size_points END IF ! right or bottom legend for desired_symbol == 3? ELSE ! desired_symbol == 4; FM legend !sample EQ magnitudes in the margin CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') ! EQs have black fill with white outline (to separate points) CALL DSet_Stroke_Color ('background') CALL DSet_Line_Style (0.6D0, .FALSE.) IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x_used_points = 0.0D0 yp = (y1_points + y2_points) / 2.0D0 ! sample thrust and normal in bottom legend CALL DBegin_Group step_points = MAX((0.5D0 * s1_size_points + 6.0D0), 24.0D0) xp = x1_points + bottomlegend_used_points + x_used_points + MAX(radius_points, 16.0D0) + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL Cats_Eye (xp, yp, 0.5D0 * s1_size_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) ypt = yp - radius_points - 12.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.6D0, 0.0D0, & & 'thrust') x_used_points = x_used_points + 2.0D0 * MAX(radius_points, 16.0D0) + 6.0D0 CALL DEnd_Group CALL DBegin_Group xp = x1_points + bottomlegend_used_points + x_used_points + MAX(radius_points, 16.0D0) + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL DCircle_on_L12 (1, xp,yp, 0.5D0 * s1_size_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL Cats_Eye (xp, yp, 0.5D0 * s1_size_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, 0.5D0 * s1_size_points, .TRUE., .FALSE.) ypt = yp - radius_points - 12.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.4D0, 0.0D0, & & 'normal') x_used_points = x_used_points + 2.0D0 * MAX(radius_points, 16.0D0) + 6.0D0 + step_points bottomlegend_used_points = bottomlegend_used_points + x_used_points ELSE IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y_used_points = 0.0D0 radius_points = 0.5D0 * s1_size_points xp = x1_points + radius_points yp = y2_points - rightlegend_used_points - y_used_points - radius_points - 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL Cats_Eye (xp, yp, radius_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) xpt = xp + radius_points + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xpt, yp, 0.0D0, & & 12, 0.0D0, 0.4D0, & & 'thrust') y_used_points = y_used_points + 2.0D0 * radius_points + 6.0D0 CALL DEnd_Group CALL DBegin_Group yp = y2_points - rightlegend_used_points - y_used_points - radius_points - 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL Cats_Eye (xp, yp, radius_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) xpt = xp + radius_points + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xpt, yp, 0.0D0, & & 12, 0.0D0, 0.4D0, & & 'normal') y_used_points = y_used_points + 2.0D0 * radius_points + 6.0D0 rightlegend_used_points = rightlegend_used_points + y_used_points END IF ! bottom, or right, legend in use END IF ! sample s1? or sample FM? in legend CALL DEnd_Group ! of legend (either for s1 or for FM) END IF ! GROUP of desired_symbols :: 6 OR 7 CASE (10) ! plot a line-of-section 2101 WRITE (*, *) CALL DPrompt_for_Real("East-longitude (use - for W) of reference point on section:", fmr_section_pin_Elon, fmr_section_pin_Elon) CALL DPrompt_for_Real("North-latitude (use - for S) of reference point on section:", fmr_section_pin_Nlat, fmr_section_pin_Nlat) CALL DLonLat_2_Uvec(fmr_section_pin_Elon, fmr_section_pin_Nlat, uvec) CALL DProject(uvec = uvec, x = x_meters, y = y_meters) IF ((x_meters < -0.5D0 * fmr_x_LENGTH_meters).OR.(x_meters > 0.5D0 * fmr_x_LENGTH_meters).OR. & & (y_meters < -0.5D0 * fmr_y_WIDTH_meters ).OR.(y_meters > 0.5D0 * fmr_y_WIDTH_meters)) THEN WRITE (*, "(' ERROR: Reference point must be within the model domain/box.')") CALL Pause() GO TO 2101 END IF WRITE (*, *) WRITE (*, "(' When choosing azimuth of section, you should consider facing direction.')") WRITE (*, "(' Select an azimuth that is 90 degrees greater than the viewer''s look direction.')") CALL DPrompt_for_Real("Azimuth (degrees, CW from North) of section at this point:", fmr_section_azimuth_degrees, fmr_section_azimuth_degrees) CALL DPrompt_for_String("Select a capital letter to identify this section:", fmc1_section_letter, fmc1_section_letter) IF (ABS(DCOS(fmr_section_azimuth_degrees * radians_per_degree)) < 0.01D0) THEN ! section is E-W IF (DSIN(fmr_section_azimuth_degrees * radians_per_degree) > 0.0D0) THEN ! section points East fmr_section_x1_m = -0.5D0 * fmr_x_LENGTH_meters fmr_section_x2_m = +0.5D0 * fmr_x_LENGTH_meters fmr_section_y1_m = y_meters fmr_section_y2_m = y_meters ELSE ! section points W fmr_section_x1_m = +0.5D0 * fmr_x_LENGTH_meters fmr_section_x2_m = -0.5D0 * fmr_x_LENGTH_meters fmr_section_y1_m = y_meters fmr_section_y2_m = y_meters END IF ELSE IF (ABS(DSIN(fmr_section_azimuth_degrees * radians_per_degree)) < 0.01D0) THEN ! section is N-S IF (DCOS(fmr_section_azimuth_degrees * radians_per_degree) > 0.0D0) THEN ! section points North fmr_section_x1_m = x_meters fmr_section_x2_m = x_meters fmr_section_y1_m = -0.5D0 * fmr_y_WIDTH_meters fmr_section_y2_m = +0.5D0 * fmr_y_WIDTH_meters ELSE ! section points S fmr_section_x1_m = x_meters fmr_section_x2_m = x_meters fmr_section_y1_m = +0.5D0 * fmr_y_WIDTH_meters fmr_section_y2_m = -0.5D0 * fmr_y_WIDTH_meters END IF ELSE ! section is oblique; compute 4 points of intersection with model box, sort by r, and choose #2-#3: trial_r(1) = ((-0.5D0 * fmr_x_LENGTH_meters) - x_meters) / DSIN(fmr_section_azimuth_degrees * radians_per_degree) trial_r(2) = ((+0.5D0 * fmr_x_LENGTH_meters) - x_meters) / DSIN(fmr_section_azimuth_degrees * radians_per_degree) trial_r(3) = ((-0.5D0 * fmr_y_WIDTH_meters) - y_meters) / DCOS(fmr_section_azimuth_degrees * radians_per_degree) trial_r(4) = ((+0.5D0 * fmr_y_WIDTH_meters) - y_meters) / DCOS(fmr_section_azimuth_degrees * radians_per_degree) DO i = 1, 4 trial_xy(1, i) = x_meters + trial_r(i) * DSIN(fmr_section_azimuth_degrees * radians_per_degree) trial_xy(2, i) = y_meters + trial_r(i) * DCOS(fmr_section_azimuth_degrees * radians_per_degree) END DO DO i = 1, 3 DO j = (i + 1), 4 IF (trial_r(i) > trial_r(j)) THEN ! this is wrong; swap these 2 points t = trial_r(i) trial_r(i) = trial_r(j) trial_r(j) = t tv2(1:2) = trial_xy(1:2, i) trial_xy(1:2, i) = trial_xy(1:2, j) trial_xy(1:2, j) = tv2(1:2) END IF END DO END DO fmr_section_x1_m = trial_xy(1, 2) fmr_section_x2_m = trial_xy(1, 3) fmr_section_y1_m = trial_xy(2, 2) fmr_section_y2_m = trial_xy(2, 3) END IF ! section is E-W, N-S, or oblique CALL DBegin_Group() CALL DSet_Line_Style (width_points = 2.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color (color_name = 'dark_blue_') CALL DNew_L3_Path(fmr_section_x1_m, fmr_section_y1_m) CALL DLine_to_L3(fmr_section_x2_m, fmr_section_y2_m) CALL DEnd_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL3_Text (x_meters = fmr_section_x1_m, y_meters = fmr_section_y1_m, & & angle_radians = (90.0D0 - fmr_section_azimuth_degrees)*radians_per_degree, from_x = .TRUE., & & font_points = 16, lr_fraction = 1.5D0, ud_fraction = 0.4D0, & & text = fmc1_section_letter) CALL DL3_Text (x_meters = fmr_section_x2_m, y_meters = fmr_section_y2_m, & & angle_radians = (90.0D0 - fmr_section_azimuth_degrees)*radians_per_degree, from_x = .TRUE., & & font_points = 16, lr_fraction = -0.3D0, ud_fraction = 0.4D0, & & text = fmc1_section_letter//"'") CALL DEnd_Group() CALL Add_Title("Location of section(s)") !end of CASE(10): plotting line of section CASE(11) ! plot orientations of stress data: 2110 CALL DPrompt_for_String("Filename of scoring dataset?", fmc80_WSM_data_filename, fmc80_WSM_data_filename) CALL Add_Title("Most-compressive stress directions & regimes from dataset") CALL Add_Title(TRIM(fmc80_WSM_data_filename)) fmc132_WSM_data_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_WSM_data_filename) OPEN (UNIT = 11, FILE = TRIM(fmc132_WSM_data_pathfile), STATUS = "OLD", PAD = "YES", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: This data file not found'/' (in current input folder, ',A,').')") TRIM(fmc132_path_in) CALL Pause() GO TO 2110 END IF CALL Read_Stress_Data(11, fmi_sites_in_box) ! just counting them, this time CLOSE (UNIT = 11, DISP = "KEEP") ! scoring data file ALLOCATE ( cmtv_stress_data(fmi_sites_in_box) ) OPEN (UNIT = 11, FILE = TRIM(fmc132_WSM_data_pathfile), STATUS = "OLD", PAD = "YES") CALL Read_Stress_Data(11, fmi_sites_in_box, cmtv_stress_data) ! recording data this time CLOSE (UNIT = 11, DISP = "KEEP") ! scoring data file symbol_diameter_points = 24.0D0 CALL DPrompt_for_Real("Maximum symbol diameter (in points):", symbol_diameter_points, symbol_diameter_points) symbol_diameter_meters = scale_denominator * symbol_diameter_points * 0.000352777D0 WRITE (*,"(/' Working on most-compressive principal directions (& tectonic styles) from data...')") CALL DBegin_Group DO i = 1, fmi_sites_in_box s1_argument_radians = cmtv_stress_data(i)%s1_argument_radians s1_plunge_radians = cmtv_stress_data(i)%s1_plunge_radians IF ((s1_argument_radians >= 0.0D0).AND.(s1_plunge_radians >= 0.0D0)) THEN c2 = cmtv_stress_data(i)%regime !determine tectonic sense by %regime: IF ((c2 == "TF").OR.(c2 == "TS")) THEN most_vertical_axis = 3 ! thrusting ELSE IF (c2 == "SS") THEN most_vertical_axis = 2 ! strike-slip ELSE IF ((c2 == "NS").OR.(c2 == "NF")) THEN most_vertical_axis = 1 ! normal-faulting ELSE most_vertical_axis = 0 ! undefined; use black symbol END IF x_meters = cmtv_stress_data(i)%x_meters y_meters = cmtv_stress_data(i)%y_meters dX = 0.5D0 * symbol_diameter_meters * DCOS(cmtv_stress_data(i)%s1_argument_radians) * DCOS(cmtv_stress_data(i)%s1_plunge_radians) dY = 0.5D0 * symbol_diameter_meters * DSIN(cmtv_stress_data(i)%s1_argument_radians) * DCOS(cmtv_stress_data(i)%s1_plunge_radians) IF (ai_using_color) THEN ! wide line of green (s-s), mid_blue (thrust), or bronze (normal) CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) IF (most_vertical_axis == 1) THEN ! s_rr is s1 CALL DSet_Stroke_Color('red_______') ! normal ELSE IF (most_vertical_axis == 2) THEN CALL DSet_Stroke_Color('green_____') ! strike-slip ELSE IF (most_vertical_axis == 3) THEN ! s_rr is s3 CALL DSet_Stroke_Color('mid_blue__') ! thrust ELSE ! undefined regime CALL DSet_Stroke_Color('foreground') END IF ! different colors CALL DNew_L3_Path(x_meters + dX, y_meters + dY) CALL DLine_to_L3(x_meters - dX, y_meters - dY) CALL DEnd_L3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! b/w symbol ! black-stroked white box for normal, unstroked grey box for s-s, black for thrusting CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) IF (most_vertical_axis == 1) THEN ! normal CALL DSet_Fill_or_Pattern(.FALSE.,'background') ! normal stroke_this = .TRUE. ELSE IF (most_vertical_axis == 2) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'gray______') ! strike-slip stroke_this = .FALSE. ELSE IF (most_vertical_axis == 3) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') ! thrust stroke_this = .FALSE. ELSE ! undefined regime CALL DSet_Fill_or_Pattern(.FALSE.,'gray______') ! strike-slip stroke_this = .FALSE. END IF ! different grays CALL DNew_L3_Path(x_meters + dX - 0.1D0 * dY, y_meters + dY + 0.1D0 * dX) CALL DLine_to_L3 (x_meters - dX - 0.1D0 * dY, y_meters - dY + 0.1D0 * dX) CALL DLine_to_L3 (x_meters - dX + 0.1D0 * dY, y_meters - dY - 0.1D0 * dX) CALL DLine_to_L3 (x_meters + dX + 0.1D0 * dY, y_meters + dY - 0.1D0 * dX) CALL DLine_to_L3 (x_meters + dX - 0.1D0 * dY, y_meters + dY + 0.1D0 * dX) CALL DEnd_L3_Path(close = .TRUE., stroke = stroke_this, fill = .TRUE.) END IF ! ai_using_color, or not END IF ! meaningful sigma_1 principal stress orientation in dataset END DO ! i = 1, fmi_sites_in_box CALL DEnd_Group DEALLOCATE ( cmtv_stress_data ) CALL DBegin_Group ! sample s_1 directions (from data) in legend CALL Chooser (bottomlegend_used_points, rightlegend_used_points, bottom, right) s1_size_points = symbol_diameter_points IF (right) THEN CALL DReport_RightLegend_Frame (x1_points, x2_points, y1_points, y2_points) y2_points = y2_points - rightlegend_used_points - rightlegend_gap_points xcp = (x1_points + x2_points) / 2.0D0 CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Datum s_1') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-20.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'direction and') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-30.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'stress regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('red_______') CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-40.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'background') CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-40.0D0-1.5D0) CALL DLine_to_L12(xcp-4.0D0, y2_points-40.0D0+1.5D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0+1.5D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-40.0D0-1.5D0) CALL DLine_to_L12(xcp-4.0D0, y2_points-40.0D0-1.5D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-40.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'normal') IF (ai_using_color) THEN CALL DSet_Stroke_Color('green_____') ELSE CALL DSet_Stroke_Color('gray______') END IF CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-50.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-50.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-50.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'strike-slip') IF (ai_using_color) THEN CALL DSet_Stroke_Color('mid_blue__') ELSE CALL DSet_Stroke_Color('foreground') END IF CALL DNew_L12_Path(1, xcp-4.0D0, y2_points-60.0D0) CALL DLine_to_L12(xcp-4.0D0-s1_size_points, y2_points-60.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = xcp, & & y_points = y2_points-60.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') rightlegend_used_points = rightlegend_used_points + rightlegend_gap_points + 64.0D0 ELSE ! bottom CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points) / 2.0D0 CALL dSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Datum s_1') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'direction and') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'stress regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('red_______') CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+76.0D0, ycp+10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'background') CALL DNew_L12_Path(1, x1_points+76.0D0, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0-1.5D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'normal') IF (ai_using_color) THEN CALL DSet_Stroke_Color('green_____') ELSE CALL DSet_Stroke_Color('gray______') END IF CALL DNew_L12_Path(1, x1_points+76.0D0, ycp) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'strike-slip') IF (ai_using_color) THEN CALL DSet_Stroke_Color('mid_blue__') ELSE CALL DSet_Stroke_Color('foreground') END IF CALL DNew_L12_Path(1, x1_points+76.0D0, ycp-10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 116.0D0 + s1_size_points END IF ! right or bottom legend for sigma_1 orientations & regimes from data? CALL DEnd_Group ! of legend !end of CASE(11): plot orientations of stress data END SELECT ! (choice) of overlay type WRITE (*,"(' ')") CALL DPrompt_for_Logical('Do you want additional overlays?', .TRUE., do_more_overlays) IF (do_more_overlays) GO TO 2000 END IF ! do_overlay? !=============================================================================== !FINALIZE THE MAP: !Graticule of parallels and meridians CALL DSet_Line_Style (width_points = 0.25D0, dashed = .FALSE.) CALL DSet_Stroke_Color (color_name = 'foreground') WRITE (*,"(' ')") 3020 CALL DPrompt_for_Integer('How many minutes apart should parallels& & and meridians be plotted?', fmi_minutes, fmi_minutes) IF (fmi_minutes < 1) THEN WRITE (*, "(' ERROR: This value must be an integer >= 1')") CALL Pause() GO TO 3020 END IF CALL DGraticule (fmi_minutes) !numbered margin: CALL DLonLat_Frame (fmi_minutes) !titles at top of map IF (ai_toptitles_reserved) THEN WRITE (*,"(' ')") mt_flashby = .FALSE. ! Do NOT flash by the prompts for titles, if there is space! CALL DPrompt_for_Logical('Do you want to add a title to this map?', .TRUE., add_titles) IF (add_titles) THEN 900 WRITE (*,"(/' ----------------------------------------------------------------------')") WRITE (*,"(' SOME SUGGESTED TITLE OPTIONS')") WRITE (*,"(/' 0 :: ANYTHING YOU CHOOSE TO TYPE!')") DO i = 1, fmi_title_count WRITE (*,"(' ',I2,' :: ',A)") i, TRIM(fmc132v_titles(i)) END DO ! i = 1, fmi_title_count WRITE (*,"(' ----------------------------------------------------------------------')") CALL DPrompt_for_Integer('Which option do you want for the upper line?', 0, title_choice) IF ((title_choice < 0).OR.(title_choice > fmi_title_count)) THEN WRITE (*,"(' ERROR: Please choose a number from the list.')") mt_flashby = .FALSE. GO TO 900 END IF ! illegal choice IF (title_choice == 0) THEN CALL DPrompt_for_String('Enter top title (or one space for none)', ' ', top_line) ELSE ! selection from list top_line = TRIM(fmc132v_titles(title_choice)) END IF CALL DPrompt_for_Integer('Which option do you want for the lower line?', 0, title_choice) IF ((title_choice < 0).OR.(title_choice > fmi_title_count)) THEN WRITE (*,"(' ERROR: Please choose a number from the list.')") mt_flashby = .FALSE. GO TO 900 END IF ! illegal choice IF (title_choice == 0) THEN CALL DPrompt_for_String('Enter sub-title (or one space for none)', ' ', bottom_line) ELSE ! selection from list bottom_line = TRIM(fmc132v_titles(title_choice)) END IF CALL DTop_Titles (top_line, & & bottom_line) END IF ! add_titles END IF ! ai_top_titles_reserved CALL DEnd_Page END SUBROUTINE Create_Map SUBROUTINE Create_Report() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. CHARACTER*132 :: CSM_output_file, CSM_output_pathfile, CSM_template_file, CSM_template_pathfile INTEGER :: choice, ii, ios, jj, mm, nn, points_done LOGICAL :: good_location, new_surface_point, success REAL*8 :: argument_000_radians, center, depth_below_MSL_in_km, Elon, Nlat, old_lat, old_lon, radius, reference_P_in_Pa, x_meters, y_meters, z_meters REAL*8 :: s1h, s2h, u1theta,u1phi, u2theta,u2phi REAL*8 :: sigma_EE_MPa, sigma_EN_MPa, sigma_Er_MPa, sigma_NN_MPa, sigma_Nr_MPa, sigma_rr_MPa, sigma_1h_MPa, sigma_2h_Mpa, target_azimuth_degrees REAL*8, DIMENSION(3) :: uvec REAL*8, DIMENSION(3, 3) :: ENr_tensor, pointers, Rmatrix, R_inverse_matrix, xyz_tensor CSM_template_file = "CSM_grid.txt" 10 WRITE (*, "(' ')") CALL DPrompt_for_String('Enter filename of the existing CSM template file:', CSM_template_file, CSM_template_file) CSM_template_pathfile = TRIM(fmc132_path_in) // TRIM(CSM_template_file) OPEN (UNIT = 11, FILE = TRIM(CSM_template_pathfile), STATUS = "OLD", IOSTAT = ios) IF (ios /= 0) THEN IF (ios == 29) THEN WRITE (*, "(' ERROR: ',A,' not found (in this folder). Please supply it.')") TRIM(CSM_template_pathfile) ELSE WRITE (*, "(' ERROR: During attempted OPEN operation, IOSTAT = ',I6)") ios END IF CALL Pause() GO TO 10 END IF WRITE (*, *) CSM_output_file = "FlatMaxwell_for_CSM.txt" CALL DPrompt_for_String('Enter filename for new CSM-format output file:', CSM_output_file, CSM_output_file) CSM_output_pathfile = TRIM(fmc132_path_in) // TRIM(CSM_output_file) OPEN (UNIT = 12, FILE = TRIM(CSM_output_pathfile)) ! unconditional; overwrites any existing WRITE (12, "('# Stress model FlatMaxwell_for_CSM, output from source code FlatMaxwell.f90.')") WRITE (12, "('# General characteristics of FlatMaxwell models:')") WRITE (12, "('# -Domain includes crust below sealevel, and often mantle lithosphere (if any, depending on heat-flow).')") WRITE (12, "('# -Modeling is done in a flat-Earth approximation, but then translated to spherical-Earth.')") WRITE (12, "('# -Except for some numerical limitations, output should always satisfy static equillibrium.')") WRITE (12, "('# -Models are typically fit, by weighted least-squares, to multiple target values:')") WRITE (12, "('# (1) Boundary conditions of free upper surface, and inviscid asthenosphere;')") WRITE (12, "('# [Note that side-boundary tractions are left free at lithospheric depths.]')") WRITE (12, "('# (2) Principal stress directions (and some magnitudes) from a dataset like WSM.')") WRITE (12, "('# (3) Stresses from a dynamic model with realistic rheology, such as Shells.')") WRITE (12, "('# Specific characteristics of this model [SHOULD BE ADDED MANUALLY BY CREATOR OF THIS FILE!]:')") WRITE (12, "('# By Peter Bird, UCLA, 2015.03.19 (or later), for the SCEC Community Stress Model.')") points_done = 0 WRITE (*, *) old_lat = 999.0D0 old_lon = 999.0D0 WRITE (*, "(' ')") processing: DO ! indefinite loop, defined by length of template grid file on unit 11 READ (11, *, IOSTAT = ios) ELon, NLat, depth_below_MSL_in_km IF (ios == -1) EXIT processing ! EOF condition new_surface_point = (ELon /= old_lon).OR.(NLat /= old_lat) IF (new_surface_point) THEN CALL DLonLat_2_Uvec(ELon, NLat, uvec) CALL DProject(uvec = uvec, x = x_meters, y = y_meters) CALL Argument_of_North(Elon, Nlat, argument_000_radians) !Projects a companion point (1 degree further North) onto the map, !and then computes the argument, relative to +x axis (CCW, in radians) !of the North-pointing line that defines azimuth = 000. !Set up unit-vectors expressing (+East, +North, +r) for this map point, !expressing everything in model coordinates (+x{East}, +y{North}, +z{up}): pointers(1, 1) = DSIN(argument_000_radians) pointers(2, 1) = -DCOS(argument_000_radians) pointers(3, 1) = 0.0D0 ! which ends the first unit vector, giving +East in model (x, y, z). pointers(1, 2) = DCOS(argument_000_radians) pointers(2, 2) = DSIN(argument_000_radians) pointers(3, 2) = 0.0D0 ! which ends the second unit vector, giving +North in model (x, y, z). pointers(1, 3) = 0.0D0 pointers(2, 3) = 0.0D0 pointers(3, 3) = 1.0D0 ! which ends the third unit vector, giving +r in model (x, y, z). !Compute rotation matrix Rmatrix(3, 3) which rotates stress from (E, N, r) to model (x, y, z) coordinates: !DO ii = 1, 3 ! DO jj = 1, 3 ! Rmatrix(ii, jj) = identity(1, ii) * pointers(1, jj) + & ! & identity(2, ii) * pointers(2, jj) + & ! & identity(3, ii) * pointers(3, jj) ! END DO !END DO ! OR, equivalent but faster code: Rmatrix = pointers !Now, we need the INVERSE of this rotation to get from (x, y, z) to (E, N, r): R_inverse_matrix(1, 1) = Rmatrix(1, 1) R_inverse_matrix(1, 2) = Rmatrix(2, 1) R_inverse_matrix(1, 3) = Rmatrix(3, 1) R_inverse_matrix(2, 1) = Rmatrix(1, 2) R_inverse_matrix(2, 2) = Rmatrix(2, 2) R_inverse_matrix(2, 3) = Rmatrix(3, 2) R_inverse_matrix(3, 1) = Rmatrix(1, 3) R_inverse_matrix(3, 2) = Rmatrix(2, 3) R_inverse_matrix(3, 3) = Rmatrix(3, 3) END IF ! new_surface_point, so recompute rotation matrices !check whether location is in the model box (first in 2-D, then in 3-D)? good_location = .TRUE. ! until proven otherwise ... IF (x_meters < (-0.5D0 * fmr_x_LENGTH_meters)) good_location = .FALSE. IF (x_meters > ( 0.5D0 * fmr_x_LENGTH_meters)) good_location = .FALSE. IF (y_meters < (-0.5D0 * fmr_y_WIDTH_meters)) good_location = .FALSE. IF (y_meters > ( 0.5D0 * fmr_y_WIDTH_meters)) good_location = .FALSE. IF (good_location) THEN z_meters = -1000.0D0 * depth_below_MSL_in_km IF (z_meters > 0.0D0) good_location = .FALSE. IF (z_meters < -fmr_z_DEPTH_meters) good_location = .FALSE. END IF ! (seemed to be) good_location, at the time... !attempt to get stress (in Cartesian coordinates) for this location: IF (good_location) THEN choice = 3 ! request total stress anomaly CALL Get_Stress_Tensor(x_meters, y_meters, z_meters, choice, success, xyz_tensor) !Looks up a stress tensor in (x, y, z) coordinates for location; !(x, y, z) in meters. In FlatMaxwell it is expected that z.LE.0. !If choice == 1, topographic stress anomaly is returned. !If choice == 2, tectonic stress anomaly is returned. !If choice == 3, total stress anomaly is returned. !Return value success = .FALSE. indicates a problem; either !(x, y, z) was outside the FlatMaxwell model domain, !or (in case of choice == 2 or 3) perhaps the tectonic !component of the stress was not available !on the same grid as topographic stress? !In problem cases a zero stress anomaly tensor is returned. !Remember that you can turn any stress anomaly tensor into a stress tensor !by just adding (literally, subtracting) the reference pressure at that (negative) elevation. !- - - - - - - - - - - - - - - - - - - - - - !Rotate this FlatMaxwell total stress anomaly tensor from model (x, y, z) coordinates to (E, N, r) coordinates: DO ii = 1, 3 DO jj = 1, 3 ENr_tensor(ii, jj) = 0.0D0 DO mm = 1, 3 DO nn = 1, 3 ENr_tensor(ii, jj) = ENr_tensor(ii, jj) + R_inverse_matrix(ii, mm) * xyz_tensor(mm, nn) * R_inverse_matrix(jj, nn) END DO END DO END DO ! Note: These subscripts ii, jj, mm, nn are not used anywhere else in this routine. END DO ELSE success = .FALSE. END IF ! good_location, or not IF (success) THEN !At this point, we have the total stress anomaly tensor in (E, N, r) coordinates, as ENr_tensor(3, 3), which is in Pa. !So, we need to subtract the reference pressure: reference_P_in_Pa = P0_Pressure_in_Pa(z_meters) ! calling the function... ENr_tensor(1, 1) = ENr_tensor(1, 1) - reference_P_in_Pa ENr_tensor(2, 2) = ENr_tensor(2, 2) - reference_P_in_Pa ENr_tensor(3, 3) = ENr_tensor(3, 3) - reference_P_in_Pa !FINALLY, report the full stress tensor, using MPa units! sigma_EE_MPa = ENr_tensor(1, 1) / 1.0D6 sigma_EN_MPa = ENr_tensor(1, 2) / 1.0D6 sigma_Er_MPa = ENr_tensor(1, 3) / 1.0D6 sigma_NN_MPa = ENr_tensor(2, 2) / 1.0D6 sigma_Nr_MPa = ENR_tensor(2, 3) / 1.0D6 sigma_rr_MPa = ENr_tensor(3, 3) / 1.0D6 CALL DPrincipal_Axes_22 (sigma_NN_Mpa, -sigma_EN_MPa, sigma_EE_MPa, & ! = (s_ThetaTheta, s_ThetaPhi, s_PhiPhi) = (s_SS, s_SE, s_EE) & s1h, s2h, u1theta,u1phi, u2theta,u2phi) !where principal axis #1 is the more-compressive of the two. target_azimuth_degrees = 180.0D0 - degrees_per_radian * DATan2F(u1phi, u1theta) IF (target_azimuth_degrees < 0.0D0) target_azimuth_degrees = target_azimuth_degrees + 180.0D0 IF (target_azimuth_degrees < 0.0D0) target_azimuth_degrees = target_azimuth_degrees + 180.0D0 IF (target_azimuth_degrees > 180.0D0) target_azimuth_degrees = target_azimuth_degrees - 180.0D0 IF (target_azimuth_degrees > 180.0D0) target_azimuth_degrees = target_azimuth_degrees - 180.0D0 sigma_1h_MPa = s1h ! most negative sigma_2h_MPa = s2h ! most positive WRITE (12, "(F9.4, F9.4, F7.2, ' 1',F6.1,9F8.1,' 1 1 1')") & & ELon, NLat, depth_below_MSL_in_km, target_azimuth_degrees, & & sigma_1h_MPa, sigma_2h_MPa, sigma_rr_MPa, & & sigma_EE_MPa, sigma_EN_MPa, sigma_Er_MPa, sigma_NN_MPa, sigma_Nr_MPa, sigma_rr_MPa WRITE (12, "(F9.4, F9.4, F7.2, ' 2 NaN NaN NaN NaN 0 NaN 0 NaN NaN NaN NaN NaN NaN')") & & ELon, NLat, depth_below_MSL_in_km END IF ! "success" in finding the 8 grid points that contains the target (ELon, NLat, depth); no reporting otherwise! old_lat = NLat ! memory of last point processed old_lon = Elon points_done = points_done + 1 IF (MOD(points_done, 10000) == 0) THEN WRITE (*, "('+points processed = ',I8)") points_done END IF END DO processing ! indefinite loop, defined by length of grid file on unit 11 WRITE (*, "('+points processed = DONE')") WRITE (*, *) CLOSE (UNIT = 11) ! CSM_grid.txt (or similar input template file) CLOSE (UNIT = 12) ! FlatMaxwell_for_CSM.txt (output) END SUBROUTINE Create_Report SUBROUTINE Create_Section() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. CHARACTER*1 :: c1 CHARACTER*2 :: c2 CHARACTER*3 :: c3, grid_units CHARACTER*4 :: left_label, right_label CHARACTER*5 :: c5 CHARACTER*6 :: c6 CHARACTER*8 :: number8 CHARACTER*11 :: unit_name CHARACTER*17 :: coordinates ! "{118.12W, 34.12N}" or shorter, e.g., "{118W, 34N}" IF (MOD(lon/lat, 1.) == 0.) CHARACTER*132 :: bottom_line, CSM_input_pathfile, line, lines_basemap_file, lines_basemap_pathfile, & & new_AI_path_and_filename, temp_path_in, top_line CHARACTER(LEN=3), DIMENSION(:,:), ALLOCATABLE :: bitmap ! array of RGB pixels INTEGER :: bitmap_color_mode, bitmap_height, bitmap_shading_mode, bitmap_width, & & choice, CSM_grid_height_nPoints, & & desired_scalar, desired_symbol, dig_title_method, dX, dY, & & format_choice, & & grd1_ncols, grd1_nrows, grid_access_mode, & & highest_choice, & & i, i1, i2, info, ios, irow, & & j, j1, j2, jcol, jiggle, & & k, kt, kz, kz1, kz2, & & m, mosaic_count, most_vertical_axis, & & n, n_columns, n_in_sum, n_rows, & & overlay_count, & & title_choice, train_length INTEGER :: AI_out_unit = 26 ! arbitrary choice, used only for test OPENs in problematic situations. INTEGER, DIMENSION(:, :), ALLOCATABLE :: tectonic_style ! == 1 (normal), 2 (strike-slip), or 3 (thrust) LOGICAL :: default_xy = .TRUE. ! because (x, y) was defined by FlatMaxwell, not by user LOGICAL :: add_titles, AI_ok, any_titles, bottom, DEM_success, dig_is_lonlat, do_more_overlays, do_mosaic, do_overlay, draw_box, & & grd1_lonlat, grd1_success, grid_lowblue, in_ok, Moho_success, out_ok, overwrite, plot_dig_titles, polygons, & & Reject_success, right, shaded_relief, stroke_this, success, visible REAL*8, PARAMETER :: bottomlegend_gap_points = 14. REAL*8, PARAMETER :: rightlegend_gap_points = 14. REAL*8 :: above, & & below, bitmap_color_highvalue, bitmap_color_lowvalue, bottom_margin, bottomlegend_used_points, brightness, & & center_lat, center_lon, CSM_grid_height_degrees, CSM_grid_width_degrees, & & Delta_r, Delta_z, depth_km, desired_depth, dr, dr_meters, dx_meters, dy_meters, dz, dz_meters, & & e1_lat, e1_lon, e2_lat, e2_lon, e3_lat, e3_lon, East, & & fin, fout, fx1, fx2, fy1, fy2, fz1, fz2, & & grad_h_x, grad_h_y, grd1_d_EW, grd1_lon_min, grd1_d_lon, grd1_lon_max, grd1_lat_min, grd1_d_lat, grd1_lat_max, & & grd1_lon_range, grid_interval, grid_midvalue, & & horizontal, & & inner, intensity, & & km_deep, & & lat, lat_prime, left_margin, lon, lon_prime, & & maximum, maximum_diameter_points, mean, minimum, & & north, & & old_lat, old_lon, outer, & & paper_height, paper_width, pointsRight, pointsUp, & & r, r_meters, radius_points, relative_symbol_size, right_margin, rightlegend_used_points, RMS_slope, & & s1_argument_radians, s1_plunge_radians, s1_size_points, scale_denominator, section_length_m, slope, south, step_points, & & sum, surface, symbol_diameter_meters, symbol_diameter_points, & & t, T_x, T_y, T_z, test_ele, top_margin, total, traction_MPa, traction_MPa_per_cm, traction_Npm, traction_Npm_per_cm, & & trial_horizontal_denominator, trial_vertical_denominator, & & unit_points, & & v, v_meters, v_tolerance_km, v_tolerance_meters, value, vector_length_meters, & & West, window_height_meters, window_width_meters, & & x, x_c_points, x_center_meters, x_meters, x_points, x1_points, x2_points, xcp, xp, xpt, x_used_points, & & y, y_center_meters, y_meters, y_points, y1_points, y2_points, ycp, yp, ypt, y_used_points, & & z, z_meters REAL*8, DIMENSION(2) :: tv2 REAL*8, DIMENSION(3) :: eigenvalues, plunge_radians, trend_radians, & & e1_b_uvec, e1_f_uvec, e2_b_uvec, e2_f_uvec, e3_b_uvec, e3_f_uvec, tvec, & & turn_1_uvec, turn_2_uvec, turn_3_uvec, turn_4_uvec, uvec REAL*8, DIMENSION(4) :: trial_r REAL*8, DIMENSION(:), ALLOCATABLE :: train REAL*8, DIMENSION(2, 4) :: trial_xy REAL*8, DIMENSION(3, 3) :: eigenvectors, rzv_tensor, tensor, xyz_tensor REAL*8, DIMENSION(:, :), ALLOCATABLE :: scalars_in_a_plane REAL*8, DIMENSION(:, :, :), ALLOCATABLE :: tensors_in_a_plane ! (6, -fmi_topo_nx:fmi_topo_nx, -fmi_topo_ny:fmi_topo_ny) TYPE(stress_data), DIMENSION(:), ALLOCATABLE :: cstv_stress_data fmi_title_count = 0 desired_scalar = 1 desired_symbol = 1 !---------------------------------------------------------- ! Get output file name (frequently, the MAIN thing changed ! between two consecutive runs of Create_Section, so DON'T bury this question ! where it won't be noticed! IF (fmc80_new_ai_filename == "FlatMaxwell_map.ai") fmc80_new_ai_filename = "FlatMaxwell_section.ai" WRITE (*,*) CALL DPrompt_for_String('New __.ai (output map) filename?', fmc80_new_ai_filename, fmc80_new_ai_filename) !----------------------------------------------------------- ! Display Adobe_Illustrator data 100 WRITE (*,"(' ')") WRITE (*,"(' ----------------------------------------------------------------------')") WRITE (*,"(' PAGE-DEFINITION SETTINGS')") SELECT CASE (fmi_unit_choice) CASE (1); unit_name = 'millimeters'; unit_points = 2.83465 CASE (2); unit_name = 'inches'; unit_points = 72. CASE (3); unit_name = 'points'; unit_points = 1. END SELECT WRITE (*,"(' Page-definition entries are in units of: ',A)") TRIM(unit_name) paper_width = fmr_section_paper_width_points / unit_points WRITE (*,"(' Paper width is: ',F8.2,' ',A)") paper_width, unit_name paper_height = fmr_section_paper_height_points / unit_points WRITE (*,"(' Paper height is: ',F8.2,' ',A)") paper_height, unit_name IF (fml_black) THEN WRITE (*,"(' Basic format is: white marks on black background')") ELSE WRITE (*,"(' Basic format is: black marks on white background')") END IF top_margin = fmr_top_margin_points / unit_points left_margin = fmr_left_margin_points / unit_points right_margin = fmr_right_margin_points / unit_points bottom_margin = fmr_bottom_margin_points / unit_points WRITE (*,"(' Unprintable margins are:')") WRITE (*,"(' top margin: ',F8.2,' ',A)") top_margin, TRIM(unit_name) WRITE (*,"(' left margin: ',F8.2,' ',A,' right margin: ',F8.2,' ',A)") & & left_margin, TRIM(unit_name), right_margin, TRIM(unit_name) WRITE (*,"(' bottom margin: ',F8.2,' ',A)") bottom_margin, TRIM(unit_name) IF (fml_plan_section_top_titles) THEN WRITE (*,"(' Reserve space for title lines at top?: Yes')") ELSE WRITE (*,"(' Reserve space for title lines at top?: No')") END IF IF (fml_plan_section_rightlegend) THEN WRITE (*,"(' Reserve space for legend at right?: Yes')") ELSE WRITE (*,"(' Reserve space for legend lines at right?: No')") END IF IF (fml_plan_section_bottomlegend) THEN WRITE (*,"(' Reserve space for legend at bottom?: Yes')") ELSE WRITE (*,"(' Reserve space for legend at bottom?: No')") END IF IF (fml_using_color) THEN WRITE (*,"(' Use COLOR in this figure?: Yes')") ELSE WRITE (*,"(' Use COLOR in this figure?: No')") END IF WRITE (*,"(' Model .ai (input) filename: ',A)") TRIM(fmc80_model_ai_filename) WRITE (*,"(' New .ai (output) filename: ',A)") TRIM(fmc80_new_ai_filename) WRITE (*,"(' ----------------------------------------------------------------------')") CALL DPrompt_for_Logical('ARE THESE SETTINGS ACCEPTABLE?', .TRUE., AI_ok) IF (AI_ok) GO TO 300 !---------------------------------------------------------- ! Edit Adobe_Illustrator data 101 WRITE (*,"(' Available unit selections are:')") WRITE (*,"(' 1 :: millimeters')") WRITE (*,"(' 2 :: inches')") WRITE (*,"(' 3 :: points')") CALL DPrompt_for_Integer('Which code do you wish?', fmi_unit_choice, fmi_unit_choice) IF ((fmi_unit_choice < 1).OR.(fmi_unit_choice > 3)) THEN WRITE (*,"(' ERROR: Choose an integer from the list above.')") fmi_unit_choice = 2 GO TO 101 END IF SELECT CASE (fmi_unit_choice) CASE (1); unit_name = 'millimeters'; unit_points = 2.83465 CASE (2); unit_name = 'inches'; unit_points = 72. CASE (3); unit_name = 'points'; unit_points = 1. END SELECT 102 paper_width = fmr_section_paper_width_points / unit_points CALL DPrompt_for_Real('Width of paper?', paper_width, paper_width) fmr_section_paper_width_points = paper_width * unit_points IF (fmr_section_paper_width_points < 144.0D0) THEN WRITE (*,"(' ERROR: Unreasonably small paper width.')") WRITE (*,"(' (Compose slides as normal-sized pages.)')") fmr_section_paper_width_points = 11.0D0 * 72.0D0 GO TO 102 END IF 103 paper_height = fmr_section_paper_height_points / unit_points CALL DPrompt_for_Real('Height of paper?',paper_height,paper_height) fmr_section_paper_height_points = paper_height * unit_points IF (fmr_section_paper_height_points < 144.0D0) THEN WRITE (*,"(' ERROR: Unreasonably small paper height.')") WRITE (*,"(' (Compose slides as normal-sized pages.)')") fmr_map_paper_height_points = 8.5D0 * 72.0D0 GO TO 103 END IF 104 WRITE (*,"(' Available basic formats are:')") WRITE (*,"(' 1 :: black marks on white background (for paper)')") WRITE (*,"(' 2 :: white marks on black background (for slides?)')") IF (fml_black) THEN; format_choice = 2; ELSE; format_choice = 1; END IF CALL DPrompt_for_Integer('Which format do you wish?', format_choice, format_choice) IF ((format_choice < 1).OR.(format_choice > 2)) THEN WRITE (*,"(' ERROR: Choose an integer from the list above.')") fml_black = .FALSE. GO TO 104 END IF SELECT CASE (format_choice) CASE (1); fml_black = .FALSE. CASE (2); fml_black = .TRUE. END SELECT 105 top_margin = fmr_top_margin_points / unit_points CALL DPrompt_for_Real('Top margin?', top_margin, top_margin) fmr_top_margin_points = top_margin * unit_points IF (fmr_top_margin_points < 0.0D0) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") fmr_top_margin_points = 0.0D0 GO TO 105 END IF 106 left_margin = fmr_left_margin_points / unit_points CALL DPrompt_for_Real('Left margin?', left_margin, left_margin) fmr_left_margin_points = left_margin * unit_points IF (fmr_left_margin_points < 0.0D0) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") fmr_left_margin_points = 0.0D0 GO TO 106 END IF 107 right_margin = fmr_right_margin_points / unit_points CALL DPrompt_for_Real('Right margin?', right_margin, right_margin) fmr_right_margin_points = right_margin * unit_points IF (fmr_right_margin_points < 0.0D0) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") fmr_right_margin_points = 0.0D0 GO TO 107 END IF 108 bottom_margin = fmr_bottom_margin_points / unit_points CALL DPrompt_for_Real('Bottom margin?', bottom_margin, bottom_margin) fmr_bottom_margin_points = bottom_margin * unit_points IF (fmr_bottom_margin_points < 0.0D0) THEN WRITE (*,"(' ERROR: Negative margins not allowed.')") fmr_bottom_margin_points = 0.0D0 GO TO 108 END IF 109 CALL DPrompt_for_Logical('Reserve space for title lines at top?', fml_plan_section_top_titles, fml_plan_section_top_titles) 112 CALL DPrompt_for_Logical('Use COLOR in this figure?', fml_using_color, fml_using_color) 113 CALL DPrompt_for_String('Model .ai (input) filename?', fmc80_model_ai_filename, fmc80_model_ai_filename) 114 CALL DPrompt_for_String('New .ai (output) filename?', fmc80_new_ai_filename, fmc80_new_ai_filename) GO TO 100 ! review settings, ask again for changes? !---------------------------------------------------------- ! Issue initializing calls: 300 CALL DSelect_Paper (fmr_section_paper_width_points, fmr_section_paper_height_points) CALL DSet_Background (fml_black) CALL DDefine_Margins (fmr_top_margin_points, & & fmr_left_margin_points, fmr_right_margin_points, & & fmr_bottom_margin_points) 400 new_AI_path_and_filename = TRIM(fmc132_path_out) // TRIM(fmc80_new_AI_filename) CALL DBegin_Page (fmc80_model_AI_filename, in_ok, & & new_AI_path_and_filename, out_ok, & & fml_using_color, & & fml_plan_section_top_titles, & & fml_plan_section_rightlegend, & & fml_plan_section_bottomlegend) IF ((.NOT.in_ok).OR.(.NOT.out_ok)) THEN IF (.NOT.in_ok) THEN WRITE (*,"(/' ERROR: Model .AI file named: ',A)") TRIM(fmc80_model_AI_filename) WRITE (*,"(' was not found (in this directory).')") CALL DPrompt_for_String('Model .AI (input) file [path\]name?', 'AI4Frame.ai', fmc80_model_AI_filename) END IF IF (.NOT.out_ok) THEN ! error opening output file: deduce the reason and act! !First, try opening same file with STATUS = 'OLD', to see if it already exists: OPEN (UNIT = AI_out_unit, FILE = new_AI_path_and_filename, & STATUS = 'OLD', IOSTAT = ios) IF (ios == 0) THEN ! file already exists, and is now open WRITE (*,"(/' WARNING: An .AI file named: ',A,' already exists.')") TRIM(fmc80_new_AI_filename) CALL DPrompt_for_Logical('Do you want to overwrite it?', .TRUE., overwrite) IF (overwrite) THEN CLOSE (UNIT = AI_out_unit, DISP = 'DELETE') !Now it is eliminated, and can be re-created by Begin_Page. ELSE ! don't overwrite; get new name CLOSE (UNIT = AI_out_unit, DISP = 'KEEP') 411 CALL DPrompt_for_String('New .AI (output) file name?', ' ', fmc80_new_ai_filename) IF (LEN_TRIM(fmc80_new_ai_filename) == 0) THEN WRITE (*,"(' ERROR: You must supply a non-blank name.')") GO TO 411 END IF ! no name entered END IF ! overwrite, or not ELSE ! file does not already exist; the problem is elsewhere !Test whether a file named "t9375" can be opened in this directory? new_ai_path_and_filename = TRIM(fmc132_path_out) // "t9375" OPEN (UNIT = AI_out_unit, FILE = new_ai_path_and_filename, & & IOSTAT = ios) IF (ios == 0) THEN ! this file was successfully opened; the path is OK CLOSE (UNIT = ai_out_unit, DISP = 'DELETE') ! clean up WRITE (*, "(/' Apparently, the file name you requested: ',A,' is illegal.')") TRIM(fmc80_new_AI_filename) 421 CALL DPrompt_for_String('New .AI (output) file name?', ' ', fmc80_new_AI_filename) IF (LEN_TRIM(fmc80_new_AI_filename) == 0) THEN WRITE (*,"(' ERROR: You must supply a non-blank name.')") GO TO 421 END IF ! no name entered ELSE ! most likely, the path is at fault! WRITE (*, "(/' Apparently, the [Drive:][\path\] you requested, ' & /' ', A / ' is illegal. Please look for typos.')") TRIM(fmc132_path_out) CALL DPrompt_for_String('Revised [Drive:][\path\]?', ' ', fmc132_path_out) END IF ! opening "t9375" succeeded or failed END IF ! file already exists, or not END IF GO TO 400 END IF ! errors occurred during creation of (template) .AI graphical output file !Although the recent CALL to DBegin_Page resulted in a CALL to DSet_Window, ! the usual map window is not ideal for a section: !-We don't need to reserve space on both left and right for number labels; ! a single number scale of depth along the left side will be enough. !-We can compute the scale_denominator from the ratio of section length to ! page-width (minus L & R margins and depth-scale). !-Once this is determined, the vertical extent of the section is implied. !-We need ~1" space between section top and top_titles for graticule, section letters, ! and perhaps for manual insertion of place names in Adobe Illustrator. !The first step in planning is to get the user to define the section location ! and therefore its length: 1 WRITE (*, *) CALL DPrompt_for_Real("East-longitude (use - for W) of reference point on section:", fmr_section_pin_Elon, fmr_section_pin_Elon) CALL DPrompt_for_Real("North-latitude (use - for S) of reference point on section:", fmr_section_pin_Nlat, fmr_section_pin_Nlat) CALL DLonLat_2_Uvec(fmr_section_pin_Elon, fmr_section_pin_Nlat, uvec) CALL DProject(uvec = uvec, x = x_meters, y = y_meters) IF ((x_meters < -0.5D0 * fmr_x_LENGTH_meters).OR.(x_meters > 0.5D0 * fmr_x_LENGTH_meters).OR. & & (y_meters < -0.5D0 * fmr_y_WIDTH_meters ).OR.(y_meters > 0.5D0 * fmr_y_WIDTH_meters)) THEN WRITE (*, "(' ERROR: Reference point must be within the model domain/box.')") CALL Pause() GO TO 1 END IF WRITE (*, *) WRITE (*, "(' When choosing azimuth of section, you should consider facing direction.')") WRITE (*, "(' Select an azimuth that is 90 degrees greater than the viewer''s look direction.')") CALL DPrompt_for_Real("Azimuth (degrees, CW from North) of section at this point:", fmr_section_azimuth_degrees, fmr_section_azimuth_degrees) CALL DPrompt_for_String("Select a capital letter to identify this section:", fmc1_section_letter, fmc1_section_letter) IF (ABS(DCOS(fmr_section_azimuth_degrees * radians_per_degree)) < 0.01D0) THEN ! section is E-W IF (DSIN(fmr_section_azimuth_degrees * radians_per_degree) > 0.0D0) THEN ! section points East fmr_section_x1_m = -0.5D0 * fmr_x_LENGTH_meters fmr_section_x2_m = +0.5D0 * fmr_x_LENGTH_meters fmr_section_y1_m = y_meters fmr_section_y2_m = y_meters left_label = "W"; right_label = "E" ELSE ! section points W fmr_section_x1_m = +0.5D0 * fmr_x_LENGTH_meters fmr_section_x2_m = -0.5D0 * fmr_x_LENGTH_meters fmr_section_y1_m = y_meters fmr_section_y2_m = y_meters left_label = "E"; right_label = "W" END IF ELSE IF (DABS(SIN(fmr_section_azimuth_degrees * radians_per_degree)) < 0.01D0) THEN ! section is N-S IF (DCOS(fmr_section_azimuth_degrees * radians_per_degree) > 0.0D0) THEN ! section points North fmr_section_x1_m = x_meters fmr_section_x2_m = x_meters fmr_section_y1_m = -0.5D0 * fmr_y_WIDTH_meters fmr_section_y2_m = +0.5D0 * fmr_y_WIDTH_meters left_label = "S"; right_label = "N" ELSE ! section points S fmr_section_x1_m = x_meters fmr_section_x2_m = x_meters fmr_section_y1_m = +0.5D0 * fmr_y_WIDTH_meters fmr_section_y2_m = -0.5D0 * fmr_y_WIDTH_meters left_label = "N"; right_label = "S" END IF ELSE ! section is oblique; compute 4 points of intersection with model box, sort by r, and choose #2-#3: trial_r(1) = ((-0.5D0 * fmr_x_LENGTH_meters) - x_meters) / DSIN(fmr_section_azimuth_degrees * radians_per_degree) trial_r(2) = ((+0.5D0 * fmr_x_LENGTH_meters) - x_meters) / DSIN(fmr_section_azimuth_degrees * radians_per_degree) trial_r(3) = ((-0.5D0 * fmr_y_WIDTH_meters) - y_meters ) / DCOS(fmr_section_azimuth_degrees * radians_per_degree) trial_r(4) = ((+0.5D0 * fmr_y_WIDTH_meters) - y_meters ) / DCOS(fmr_section_azimuth_degrees * radians_per_degree) DO i = 1, 4 trial_xy(1, i) = x_meters + trial_r(i) * DSIN(fmr_section_azimuth_degrees * radians_per_degree) trial_xy(2, i) = y_meters + trial_r(i) * DCOS(fmr_section_azimuth_degrees * radians_per_degree) END DO DO i = 1, 3 DO j = (i + 1), 4 IF (trial_r(i) > trial_r(j)) THEN ! this is wrong; swap these 2 points t = trial_r(i) trial_r(i) = trial_r(j) trial_r(j) = t tv2(1:2) = trial_xy(1:2, i) trial_xy(1:2, i) = trial_xy(1:2, j) trial_xy(1:2, j) = tv2(1:2) END IF END DO END DO fmr_section_x1_m = trial_xy(1, 2) fmr_section_x2_m = trial_xy(1, 3) fmr_section_y1_m = trial_xy(2, 2) fmr_section_y2_m = trial_xy(2, 3) IF (fmr_section_azimuth_degrees < -90.0D0) THEN WRITE (c2, "(I2)") NINT(180.0D0 + fmr_section_azimuth_degrees) right_label(1:1) = 'S' right_label(2:3) = c2 right_label(4:4) = 'W' ELSE IF (fmr_section_azimuth_degrees < 0.0D0) THEN WRITE (c2, "(I2)") NINT(-fmr_section_azimuth_degrees) right_label(1:1) = 'N' right_label(2:3) = c2 right_label(4:4) = 'W' ELSE IF (fmr_section_azimuth_degrees < 90.0D0) THEN WRITE (c2, "(I2)") NINT(fmr_section_azimuth_degrees) right_label(1:1) = 'N' right_label(2:3) = c2 right_label(4:4) = 'E' ELSE IF (fmr_section_azimuth_degrees < 180.0D0) THEN WRITE (c2, "(I2)") NINT(180.0D0 - fmr_section_azimuth_degrees) right_label(1:1) = 'S' right_label(2:3) = c2 right_label(4:4) = 'E' ELSE IF (fmr_section_azimuth_degrees < 270.0D0) THEN WRITE (c2, "(I2)") NINT(fmr_section_azimuth_degrees - 180.0D0) right_label(1:1) = 'S' right_label(2:3) = c2 right_label(4:4) = 'W' ELSE IF (fmr_section_azimuth_degrees < 360.0D0) THEN WRITE (c2, "(I2)") NINT(360.0D0 - fmr_section_azimuth_degrees) right_label(1:1) = 'N' right_label(2:3) = c2 right_label(4:4) = 'W' END IF IF (right_label(2:2) == ' ') right_label(2:2) = '0' left_label = right_label ! just initializing, before reversals IF (right_label(1:1) == 'N') THEN left_label(1:1) = 'S' ELSE left_label(1:1) = 'N' END IF IF (right_label(4:4) == 'E') THEN left_label(4:4) = 'W' ELSE left_label(4:4) = 'E' END IF END IF ! section is E-W, N-S, or oblique section_length_m = DSQRT(((fmr_section_x1_m - fmr_section_x2_m)**2) + ((fmr_section_y1_m - fmr_section_y2_m)**2)) !Now, fit this section of known length into the width of paper available: x2_points = ai_right_limit_points x1_points = ai_left_limit_points + 40.0D0 ! where 40 allows for tics and numbers of the depth scale trial_horizontal_denominator = section_length_m / ((x2_points - x1_points) / 2834.6D0) !Also, be sure that figure fits into the height of paper available: y2_points = ai_top_limit_points - ai_lonlatlabel_points - 72.0D0 ! where 72 allows an inch for Section_Graticule markings (A-A', lons, lats), ! the height of the (optional) topographic profile, ! and perhaps for user's additions of place names, in Adobe Illustrator. y1_points = ai_bottom_limit_points + 40.0D0 + 72.0D0 ! where 40 allows for tics and numbers of the r-scale, and 72 allows for the color-bar. trial_vertical_denominator = fmr_z_DEPTH_meters / ((y2_points - y1_points) / 2834.6D0) scale_denominator = MAX(trial_horizontal_denominator, trial_vertical_denominator) WRITE (*, *) WRITE (*, "(' Scale for this section will be 1:',ES12.4)") scale_denominator IF (trial_horizontal_denominator > trial_vertical_denominator) THEN WRITE (*, "(' NOTE: To plot everything larger, start over, and select wider (virtual) paper.')") ELSE WRITE (*, "(' NOTE: To plot everything larger, start over, and select taller (virtual) paper.')") END IF y2_points = ai_top_limit_points - ai_lonlatlabel_points - 72.0D0 ! where 72 allows an inch for Section_Graticule markings (A-A', lons, lats), ! the height of the (optional) topographic profile, ! and perhaps for user's additions of place names, in Adobe Illustrator. y1_points = y2_points - 2834.6D0 * fmr_z_DEPTH_meters/scale_denominator !These are the top and bottom of the "window" (for clipping, and also for bitmaps); the r-scale will go slightly below y1, ! and the bottomlegend will go even further down the page. !Notice that any mountains in the topographic profile will extend above this window, and so they must be ! plotted using Level-1 graphical routines, not subject to clipping. IF (trial_vertical_denominator > trial_horizontal_denominator) THEN x_c_points = (x1_points + x2_points) / 2.0D0 x1_points = x_c_points - (trial_horizontal_denominator/trial_vertical_denominator) * (x_c_points - x1_points) x2_points = x_c_points + (trial_horizontal_denominator/trial_vertical_denominator) * (x2_points - x_c_points) END IF CALL DSet_Window (x1_points, x2_points, y1_points, y2_points) ! all measured from lower-left corner of page; x1 < x2; y1 < y2. CALL DSet_Section_Zoom (scale_denominator, & & fmr_section_x1_m, fmr_section_y1_m, & & fmr_section_x2_m, fmr_section_y2_m, & & x1_points, y2_points) !=============================================================================== !GPBmosaic !-------------------------- MOSAICS ------------------------------ !----- (layers of shaded/colored polygons; mostly opaque) -------- mosaic_count = 0 bottomlegend_used_points = 0.0D0 ! records filling of bottom legend, from left rightlegend_used_points = 0.0D0 ! records filling of right legend, from top 1000 WRITE (*,"(//' ------------------------------------------------------------------------------')") IF (ai_using_color) THEN WRITE (*,"(' MOSAIC (colored-bitmap) LAYERS AVAILABLE:')") ELSE WRITE (*,"(' MOSAIC (patterned-area) LAYERS AVAILABLE:')") END IF IF (ai_using_color) THEN WRITE (*,"(' 1 :: colored bitmap of topographic stress anomaly')") WRITE (*,"(' 2 :: colored bitmap of tectonic stress anomaly')") WRITE (*,"(' 3 :: colored bitmap of total stress anomaly')") ELSE WRITE (*,"(' 1 :: gray-pattern contour map of topographic stress anomaly')") WRITE (*,"(' 2 :: gray-pattern contour map of tectonic stress anomaly')") WRITE (*,"(' 3 :: gray-pattern contour map of total stress anomaly')") END IF WRITE (*,"(' ------------------------------------------------------------------------------')") IF (mosaic_count == 0) CALL DPrompt_for_Logical('Do you want one (or more) of these mosaics?', .TRUE., do_mosaic) IF (do_mosaic) THEN CALL DPrompt_for_Integer('Which mosaic type should be added?', 1, choice) IF ((choice < 1).OR.(choice > 3)) THEN WRITE (*,"(/' ERROR: Please select an integer from the list!')") CALL Pause() mt_flashby = .FALSE. GO TO 1000 ! mosaics menu ELSE ! legal choice mosaic_count = mosaic_count + 1 END IF ! illegal or legal choice 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 1005 CALL DPrompt_for_Integer('How many columns of pixels in bitmap?', bitmap_width, bitmap_width) IF (bitmap_width < 2) THEN WRITE (*,"(' ERROR: Bitmap_width must be >= 2')") CALL Pause() mt_flashby = .FALSE. GO TO 1005 END IF 1006 CALL DPrompt_for_Integer('How many rows of pixels in bitmap?', bitmap_height, bitmap_height) IF (bitmap_height < 2) THEN WRITE (*,"(' ERROR: Bitmap_height must be >= 2')") CALL Pause() mt_flashby = .FALSE. GO TO 1006 END IF SELECT CASE (choice) CASE (1, 2, 3) ! colored bitmap of (1)topographic, (2)tectonic, or (3)total stress anomaly IF (choice == 1) THEN CALL Add_Title("Topographic stress anomaly model "//TRIM(fmc12_topographic_token)) ELSE IF (choice == 2) THEN CALL Add_Title("Tectonic stress anomaly model "//TRIM(fmc12_tectonic_token)) ELSE IF (choice == 3) THEN CALL Add_Title("Total stress anomaly model "//TRIM(fmc12_tectonic_token)) END IF 1030 WRITE (*,"(/' Which scalar measure of this stress-anomaly tensor field should be plotted?')") WRITE (*,"( ' measure 1: normal stress anomaly on plane of section')") WRITE (*,"( ' measure 2: shear traction magnitude on plane of section')") WRITE (*,"( ' measure 3: pressure anomaly at plane of section')") WRITE (*,"( ' measure 4: greatest shear stress (any orientation) at plane of section')") WRITE (*,"( ' -------------------------------------------------------------------------')") CALL DPrompt_for_Integer('Which scalar measure?', desired_scalar, desired_scalar) IF ((desired_scalar < 1).OR.(desired_scalar > 4)) THEN WRITE (*,"(/' ERROR: Select measure index from list!' )") CALL Pause() mt_flashby = .FALSE. GO TO 1030 END IF IF (desired_scalar == 1) THEN CALL Add_Title("Normal stress anomaly on plane of section") ELSE IF (desired_scalar == 2) THEN CALL Add_Title("Shear traction magnitude on plane of section") ELSE IF (desired_scalar == 3) THEN CALL Add_Title("Pressure anomaly at plane of section") ELSE IF (desired_scalar == 4) THEN CALL Add_Title("Greatest shear stress at plane of section") END IF ALLOCATE ( scalars_in_a_plane(bitmap_height, bitmap_width) ) train_length = bitmap_height * bitmap_width ALLOCATE ( train(train_length) ) k = 0 v = 0.0D0 ! defines the plane of the section grid_units = 'MPa' ! for any of the choices (topographic, tectonic, or total anomalies) WRITE (*, *) WRITE (*, "(' Depth (km) Mean value (MPa)')") WRITE (*, "(' ---------- ----------------')") DO irow = 1, bitmap_height ! bitmap rows, top to bottom; decreasing z pointsUp = ai_window_y2_points - ((irow - 0.5D0)/bitmap_height) * (ai_window_y2_points - ai_window_y1_points) z = fs_pointsUp_2_z_partial * pointsUp + fs_pointsUp_2_z_constant total = 0.0D0 ! for this new row, initially n_in_sum = 0 ! for this new row, initially DO jcol = 1, bitmap_width ! bitmap columns, left to right; increasing r pointsRight = ai_window_x1_points + ((jcol - 0.5D0)/bitmap_width) * (ai_window_x2_points - ai_window_x1_points) r = fs_pointsRight_2_r_partial * pointsRight + fs_pointsRight_2_r_constant x = fs_rzv_2_xyz_constants(1) + fs_rzv_2_xyz_partials(1, 1) * r y = fs_rzv_2_xyz_constants(2) + fs_rzv_2_xyz_partials(2, 1) * r !Terms involving v (== 0.) and z (which has a zero coefficient) have been removed from the !equations for x and y, to save time. Also, there is no need to set z equal to itself. CALL Get_Stress_Tensor(x, y, z, choice, success, xyz_tensor) ! N.B. We don't expect any failures. IF (success) THEN CALL DTensor_xyz_2_rzv(xyz_tensor, rzv_tensor) IF (desired_scalar == 1) THEN ! normal stress anomaly scalars_in_a_plane(irow, jcol) = rzv_tensor(3, 3) ELSE IF (desired_scalar == 2) THEN ! shear traction magnitude scalars_in_a_plane(irow, jcol) = DSQRT((rzv_tensor(1, 3)**2) + (rzv_tensor(2, 3)**2)) ELSE IF (desired_scalar == 3) THEN ! pressure anomaly scalars_in_a_plane(irow, jcol) = -(rzv_tensor(1, 1) + rzv_tensor(2, 2) + rzv_tensor(3, 3)) / 3.0D0 ELSE IF (desired_scalar == 4) THEN ! greatest shear stress CALL Eigenanalysis_3x3(rzv_tensor, eigenvalues) ! NOT requesting eigenvalues because tensor might be degenerate (simple dP, or 0) scalars_in_a_plane(irow, jcol) = 0.5D0 * ABS(eigenvalues(1) - eigenvalues(3)) END IF ! desired_scalar == 1, 2, 3, 4 scalars_in_a_plane(irow, jcol) = 1.0D-6 * scalars_in_a_plane(irow, jcol) k = k + 1 train(k) = scalars_in_a_plane(irow, jcol) n_in_sum = n_in_sum + 1 total = total + scalars_in_a_plane(irow, jcol) ELSE ! failed in Get_Stress_Tensor (unexpected) scalars_in_a_plane(irow, jcol) = 0.0D0 WRITE (*, "(' CALL Get_Stress_Tensor from DCreate_Section failed.')") CALL Pause() END IF ! success in Get_Stress_Tensor, or not END DO ! jcol = 1, bitmap_width mean = total / n_in_sum depth_km = -z / 1000.0D0 WRITE (*, "(' ',F10.3,F20.3)") depth_km, mean IF (MOD(irow, 20) == 0) THEN CALL Pause() WRITE (*, "(' Depth (km) Mean value (MPa)')") WRITE (*, "(' ---------- ----------------')") END IF END DO ! irow = 1, bitmap_height WRITE (*,"(/' Here is the distribution of values (in MPa):' )") CALL Histogram (train, train_length, .FALSE., maximum, minimum) IF (maximum == minimum) THEN ! prevent division-by-zero, etc. IF (minimum == 0.0D0) THEN maximum = 1.0D0 ELSE maximum = minimum * 1.01D0 END IF END IF DEALLOCATE ( train ) 1032 WRITE (*,"(/' How shall the bitmap be 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: AI: ',I2,'-color discrete scale, based on contour interval')") ai_spectrum_count WRITE (*,"( ' -------------------------------------------------------')") bitmap_color_mode = 1 ! Munsell CALL DPrompt_for_Integer('Which coloring mode?', bitmap_color_mode, bitmap_color_mode) IF ((bitmap_color_mode < 1).OR.(bitmap_color_mode > 3)) THEN WRITE (*,"(/' ERROR: Select mode index from list!' )") CALL Pause() mt_flashby = .FALSE. GO TO 1032 END IF IF (bitmap_color_mode <= 2) THEN ! need to pin down ends of spectrum CALL DPrompt_for_Logical('Should low (more negative) values be colored blue (versus red)?', .TRUE., grid_lowblue) 1033 IF (grid_lowblue) THEN CALL DPrompt_for_Real('What (low?) value anchors the violet-blue end of the spectrum?', minimum, bitmap_color_lowvalue) CALL DPrompt_for_Real('What (high?) value anchors the red-pink end of the spectrum?', maximum, bitmap_color_highvalue) ELSE CALL DPrompt_for_Real('What (high?) value anchors the violet-blue end of the spectrum?', maximum, bitmap_color_lowvalue) CALL DPrompt_for_Real('What (low?) value anchors the red-pink end of the spectrum?', minimum, bitmap_color_highvalue) END IF ! grid_lowblue, or not IF (bitmap_color_highvalue == bitmap_color_lowvalue) THEN WRITE (*,"(/' ERROR: Red value must differ from blue value!' )") CALL Pause() mt_flashby = .FALSE. GO TO 1033 END IF ! bad range ELSE IF (bitmap_color_mode == 3) THEN grid_interval = (maximum - minimum) / ai_spectrum_count grid_midvalue = (maximum + minimum) / 2.0D0 1034 CALL DPrompt_for_Real('What contour interval do you wish?', grid_interval, grid_interval) IF (grid_interval <= 0.0D0) THEN WRITE (*,"(/' ERROR: Contour interval must be positive!' )") CALL Pause() grid_interval = (maximum - minimum)/ai_spectrum_count mt_flashby = .FALSE. GO TO 1034 END IF CALL DPrompt_for_Real('What value should fall at mid-spectrum?', grid_midvalue, grid_midvalue) CALL DPrompt_for_Logical('Should low (more negative) values be colored blue (versus red)?', .TRUE., grid_lowblue) END IF ! bitmap_color_mode = 0/1,2 versus 3 WRITE (*,"(/' Working on bitmap....')") ALLOCATE ( bitmap(bitmap_height, bitmap_width) ) DO irow = 1, bitmap_height ! top to bottom DO jcol = 1, bitmap_width ! left to right value = scalars_in_a_plane(irow, jcol) ! previously computed above, in MPa brightness = 1.0D0 ! which gives full color saturation IF (bitmap_color_mode == 1) THEN ! Munsell: smooth spectrum t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Munsell(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 2) THEN ! Kansas: 44-color atlas-type scale t = (value - bitmap_color_lowvalue) / (bitmap_color_highvalue - bitmap_color_lowvalue) c3 = DRGB_Kansas(warmth = t, brightness = brightness) ELSE IF (bitmap_color_mode == 3) THEN ! UNAVCO: absolute elevation scale c3 = DRGB_UNAVCO(elevation_meters = value, brightness = brightness) ELSE IF (bitmap_color_mode == 4) THEN ! AI: ai_spectrum, with contour interval c3 = DRGB_AI(value = value, contour_interval = grid_interval, & & midspectrum_value = grid_midvalue, low_is_blue = grid_lowblue, & & brightness = brightness) END IF ! bitmap_color_mode selection bitmap(irow, jcol) = c3 END DO ! jcol, left to right IF (MOD(irow, 100) == 0) WRITE (*,"('+Working on bitmap....',I6,' rows done')") irow END DO ! irow, top to bottom WRITE (*,"('+Working on bitmap....Writing to .ai ')") CALL Chooser(bottomlegend_used_points, rightlegend_used_points, bottom, right) !Note: There is no real choice; section legends will always be in the bottom margin. !This CALL is left in because it may have side effects in the ai_ and/or mp_ and/or mt_ systems. CALL DBitmap_on_L1 (bitmap, ai_window_x1_points, ai_window_x2_points, & & ai_window_y1_points, ai_window_y2_points) shaded_relief = .FALSE. CALL DSpectrum_in_BottomLegend (minimum, maximum, ADJUSTL(grid_units), bitmap_color_mode, & & bitmap_color_lowvalue, bitmap_color_highvalue, shaded_relief, & & grid_interval, grid_midvalue, grid_lowblue) bottomlegend_used_points = ai_paper_width_points ! reserve bottom margin WRITE (*,"('+Working on bitmap....DONE. ')") DEALLOCATE ( bitmap ) DEALLOCATE ( scalars_in_a_plane ) ! end of CASE(1, 2, 3) colored (or gray-patterned) bitmap of: choice == (1)topographic, (2)tectonic, or (3)total stress anomaly END SELECT ! choice of mosaic END IF ! do_mosaic !=============================================================================== !GPBoverlays !-------------------------- OVERLAYS ------------------------------ !----- (symbols composed mostly of lines; mostly transparent) ----- overlay_count = 0 2000 WRITE (*,"(//' -----------------------------------------------------------------------')") WRITE (*,"( ' LINE AND SYMBOL OVERLAY LAYERS AVAILABLE:')") WRITE (*,"( ' 1 :: topographic/bathymetric profile')") WRITE (*,"( ' 2 :: Moho profile')") WRITE (*,"( ' 3 :: lithosphere-asthenosphere boundary (LAB)')") WRITE (*,"( ' 4 :: point measures of topographic stress anomaly in section plane')") WRITE (*,"( ' 5 :: point measures of tectonic stress anomaly in section plane')") WRITE (*,"( ' 6 :: point measures of total stress anomaly in section plane')") WRITE (*,"( ' 7 :: most-compressive axes & stress regimes from data')") WRITE (*,"( ' -----------------------------------------------------------------------')") IF (overlay_count == 0) CALL DPrompt_for_Logical('Do you want one (or more) of these overlays?', .TRUE., do_overlay) IF (do_overlay) THEN CALL DPrompt_for_Integer('Which overlay type should be added?', 1, choice) IF ((choice < 1).OR.(choice > 7)) THEN WRITE (*,"(/' ERROR: Please select an integer from the list!')") CALL Pause() mt_flashby = .FALSE. GO TO 2000 ELSE ! legal choice overlay_count = overlay_count + 1 END IF ! illegal or legal choice SELECT CASE (choice) CASE (1) ! topographic/bathymetric profile !Note: Most of the topography (land) is outside the model window, so if it were !drawn on FSL3, it would be clipped. Therefore, this profile is drawn on L1, !using primitive ai subprograms. 2010 CALL DSet_Stroke_Color('foreground') CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = "gray______") CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) pointsRight = fs_r_2_pointsRight_constant pointsUp = fs_z_2_pointsUp_constant CALL DNew_L12_Path(level = 1, x_points = pointsRight, y_points = pointsUp) pointsRight = fs_r_2_pointsRight_constant + fs_r_2_pointsRight_partial * section_length_m ! ^ result should be ai_window_x2_points, but this way is clearer CALL DLine_To_L12(pointsRight, pointsUp) DO i = 100, 0, -1 r_meters = MIN(section_length_m, (i * section_length_m / 100.0D0)) x_meters = fs_rzv_2_xyz_constants(1) + & & fs_rzv_2_xyz_partials(1, 1) * r_meters ! no more, because z = v = 0. y_meters = fs_rzv_2_xyz_constants(2) + & & fs_rzv_2_xyz_partials(2, 1) * r_meters ! no more, because z = v = 0. CALL DEM_Lookup(x_meters, y_meters, & & Reject_success, lon, lat, & & DEM_success, surface, grad_h_x, grad_h_y) pointsRight = fs_r_2_pointsRight_constant + fs_r_2_pointsRight_partial * r_meters pointsUp = fs_z_2_pointsUp_constant + fs_z_2_pointsUp_partial * surface CALL DLine_To_L12(pointsRight, pointsUp) END DO CALL DLine_to_L12(fs_r_2_pointsRight_constant, fs_z_2_pointsUp_constant) ! back to initial point CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) WRITE (*, "(' **** DONE ! ****')") ! psychologically necessary, as it typically seems to take "no time at all" ! end of CASE(choice == 1) topographic/bathymetric profile CASE (2) ! Moho profile 2020 CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) DO i = 0, 100 r_meters = i * section_length_m / 100.0D0 x_meters = fs_rzv_2_xyz_constants(1) + & & fs_rzv_2_xyz_partials(1, 1) * r_meters ! no more, because z = v = 0. y_meters = fs_rzv_2_xyz_constants(2) + & & fs_rzv_2_xyz_partials(2, 1) * r_meters ! no more, because z = v = 0. CALL DReject (x_meters, y_meters, Reject_success, uvec) IF (Reject_success) THEN ! rejection worked CALL DUvec_2_LonLat (uvec, lon, lat) !Now, look up the "surface" elevation at this (lon, lat): !define Moho_success as point-falling-within-the-Moho-grid: Moho_success = (lat >= fmr_Moho_lat_min).AND. & & (lat <= fmr_Moho_lat_max).AND. & & (DEasting(lon - fmr_Moho_lon_min) <= fmr_Moho_lon_range) !note: insensitive to longitude cycle IF (Moho_success) THEN !determine Moho elevation: i1 = 1 + (fmr_Moho_lat_max - lat) / fmr_Moho_dLat i1 = MAX(1, MIN(i1, fmi_Moho_rows - 1)) i2 = i1 + 1 fy2 = ((fmr_Moho_lat_max - lat) / fmr_Moho_dLat) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + DEasting(lon - fmr_Moho_lon_min) / fmr_Moho_dLon j1 = MAX(1, MIN(j1, fmi_Moho_columns - 1)) j2 = j1 + 1 fx2 = (DEasting(lon - fmr_Moho_lon_min) / fmr_Moho_dLon) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 north = fx1 * fmim_Moho_elevation_m(i1, j1) + fx2 * fmim_Moho_elevation_m(i1, j2) south = fx1 * fmim_Moho_elevation_m(i2, j1) + fx2 * fmim_Moho_elevation_m(i2, j2) east = fy1 * fmim_Moho_elevation_m(i1, j2) + fy2 * fmim_Moho_elevation_m(i2, j2) west = fy1 * fmim_Moho_elevation_m(i1, j1) + fy2 * fmim_Moho_elevation_m(i2, j1) surface = 0.5D0 * (fy1 * north + fy2 * south + fx1 * west + fx2 * east) ELSE surface = 0.0D0 END IF ! source point is inside Moho grid, or not ELSE ! Reject failed surface = 0.0D0 END IF ! Reject_success, or not IF (i == 0) THEN CALL DNew_FSL3_Path(r_meters = r_meters, z_meters = surface) ELSE CALL DLine_to_FSL3(r_meters = r_meters, z_meters = surface) END IF END DO CALL DEnd_FSL3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) WRITE (*, "(' **** DONE ! ****')") ! psychologically necessary, as it typically seems to take "no time at all" ! end of CASE(choice == 2) Moho profile CASE (3) ! lithosphere-asthenosphere boundary (LAB) 2030 CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 1.0D0, dashed = .TRUE., on_points = 3.0D0, off_points = 1.0D0) CALL DNew_FSL3_Path(r_meters = 0.0D0, z_meters = -fmr_LAB_depth) CALL DLine_to_FSL3(r_meters = section_length_m, z_meters = -fmr_LAB_depth) CALL DEnd_FSL3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) WRITE (*, "(' **** DONE ! ****')") ! psychologically necessary, as it typically seems to take "no time at all" !end of CASE(choice == 3) lithosphere-asthenosphere boundary (LAB) CASE (4, 5, 6) ! point measures of: {choice == (4) topographic / (5) tectonic / (6) total} stress anomaly in section plane IF (choice == 4) THEN CALL Add_Title("Topographic stress anomaly model "//TRIM(fmc12_topographic_token)) ELSE IF (choice == 5) THEN CALL Add_Title("Tectonic stress anomaly model "//TRIM(fmc12_tectonic_token)) ELSE ! choice == 6 CALL Add_Title("Total stress anomaly model "//TRIM(fmc12_tectonic_token)) END IF 2040 WRITE (*,"(/' Which measure of this stress-anomaly tensor field should be plotted?')") WRITE (*,"( ' measure 1: Shear traction vector on plane of section')") WRITE (*,"( ' measure 2: Full tensor in plane of section')") WRITE (*,"( ' measure 3: Most-compressive axes & tectonic styles')") WRITE (*,"( ' measure 4: Planes of greatest shear stress')") WRITE (*,"( ' -------------------------------------------------------------------------')") CALL DPrompt_for_Integer('Which scalar measure?', desired_symbol, desired_symbol) IF ((desired_symbol < 1).OR.(desired_symbol > 4)) THEN WRITE (*,"(/' ERROR: Select measure index from list!' )") CALL Pause() mt_flashby = .FALSE. GO TO 2040 END IF IF (desired_symbol == 1) THEN CALL Add_Title("Shear traction vector on plane of section") ELSE IF (desired_symbol == 2) THEN CALL Add_Title("Full tensors along plane of section") ELSE IF (desired_symbol == 3) THEN CALL Add_Title("Most-compressive axes & tectonic styles") ELSE IF (desired_symbol == 4) THEN CALL Add_Title("Planes of greatest shear stress") END IF v = 0.0D0 ! defines the section plane; I probably won't refer to it again. n_columns = fmi_topo_nx + fmi_topo_ny + 1 ! so horizontal spacing will be comparable to that in maps. Delta_r = section_length_m / (n_columns - 1) n_rows = 2 * fmi_topo_nz + 1 Delta_z = fmr_z_DEPTH_meters / (n_rows - 1) ALLOCATE ( tensors_in_a_plane(6, n_rows, n_columns) ) ALLOCATE ( tectonic_style(n_rows, n_columns) ) IF (desired_symbol <= 2) THEN train_length = n_rows * n_columns ALLOCATE ( train(train_length) ) WRITE (*,"(/' Here is the distribution of values (in MPa):' )") END IF kt = 0 ! (not used if desired_symbol > 2) DO j = 1, n_columns ! r increases, L to R DO i = 1, n_rows ! z decreases, going down from surface r = (j - 1.0D0) * Delta_r jiggle = MOD(i, 3) - 1 r = r + jiggle * 0.3D0 * Delta_r x_meters = fs_rzv_2_xyz_constants(1) + fs_rzv_2_xyz_partials(1, 1) * r ! with no contribution from z or v. y_meters = fs_rzv_2_xyz_constants(2) + fs_rzv_2_xyz_partials(2, 1) * r ! with no contribution from z or v. z = -(i - 1) * Delta_z ! non-positive, in meters, going down CALL Get_Stress_Tensor(x_meters, y_meters, z, (choice - 3), success, xyz_tensor) ! ^ Note that this routine returns a zero tensor if point is outside the model. !Determine tectonic style (before rotating tensor): tensor = xyz_tensor ! creating a copy (in case it might be overwritten during eigen-analysis) CALL Eigenanalysis_3x3(tensor, eigenvalues) ! on first call, DON'T request eigenvectors; tensor may be degenerate (pure dP, or 0). IF (eigenvalues(1) == eigenvalues(3)) THEN ! degenerate tensor; eigenvectors are not defined. tectonic_style(i, j) = 0 ! nothing to plot! This will be used as a flag below in code... ELSE ! normal, non-degenerate tensor !find trend and plunge of each principal axis: CALL Eigenanalysis_3x3(tensor, eigenvalues, eigenvectors) DO k = 1, 3 IF (eigenvectors(3, k) <= 0.) THEN trend_radians(k) = DATAN2(eigenvectors(1, k), eigenvectors(2, k)) ELSE trend_radians(k) = DATAN2(-eigenvectors(1, k), -eigenvectors(2, k)) END IF !These trends are relative to FlatMaxwell axis +y, which is also plot axis +y (up on map sheet); !they are NOT relative to local North. They are measured clockwise in radians. !I always choose the trend (sense) as the direction with positive plunge. horizontal = DSQRT((eigenvectors(1, k)**2) + (eigenvectors(2, k)**2)) plunge_radians(k) = DATAN2(ABS(eigenvectors(3, k)), horizontal) ! both arguments non-negative !These plunges are relative to the section (r, z) plane. !They are positive away-from-viewer (v < 0.) from (r, z) plane in radians, and will always be positive (or zero). END DO !determine tectonic sense by most-vertical axis: IF ((plunge_radians(3) > plunge_radians(2)).AND.(plunge_radians(3) > plunge_radians(1))) THEN tectonic_style(i, j) = 3 ! thrust ELSE IF ((plunge_radians(2) > plunge_radians(1)).AND.(plunge_radians(2) > plunge_radians(3))) THEN tectonic_style(i, j) = 2 ! strike-slip ELSE tectonic_style(i, j) = 1 ! normal (also serves as default for a zero tensor) END IF END IF ! zero or non-zero stress tensor !Convert (x, y, z) stress tensor to (r, z, v) coordinate system: CALL DTensor_xyz_2_rzv(xyz_tensor, rzv_tensor) ! Note that conversion of degenerate tensors will not cause any problem here. !Save rotated tensor, in units of MPa: !First subscript: 1) s_rr, 2) s_zz, 3) s_vv, 4) s_zv, 5) s_rv, 6) s_rz tensors_in_a_plane(1, i, j) = 1.0D-6 * rzv_tensor(1, 1) tensors_in_a_plane(2, i, j) = 1.0D-6 * rzv_tensor(2, 2) tensors_in_a_plane(3, i, j) = 1.0D-6 * rzv_tensor(3, 3) tensors_in_a_plane(4, i, j) = 1.0D-6 * rzv_tensor(2, 3) tensors_in_a_plane(5, i, j) = 1.0D-6 * rzv_tensor(1, 3) tensors_in_a_plane(6, i, j) = 1.0D-6 * rzv_tensor(1, 2) IF (desired_symbol == 1) THEN ! shear traction vector on plane of section kt = kt + 1 train(kt) = DSQRT((tensors_in_a_plane(4, i, j)**2) + (tensors_in_a_plane(5, i, j)**2)) ELSE IF (desired_symbol == 2) THEN ! full stress anomaly tensor kt = kt + 1 train(kt) = MAX(ABS(tensors_in_a_plane(1, i, j)), & & ABS(tensors_in_a_plane(2, i, j)), & & ABS(tensors_in_a_plane(3, i, j)), & & ABS(tensors_in_a_plane(4, i, j)), & & ABS(tensors_in_a_plane(5, i, j)), & & ABS(tensors_in_a_plane(6, i, j))) END IF ! need to create a value for train END DO ! i = 1, n_rows (from sea level, z going down) END DO ! j = 1, n_columns (left to right; r increasing) IF (desired_symbol <= 2) THEN CALL Histogram (train, train_length, .TRUE., maximum, minimum) IF (maximum == minimum) THEN ! prevent division-by-zero, etc. IF (minimum == 0.0D0) THEN maximum = 1.0D0 ELSE maximum = minimum * 1.01D0 END IF END IF DEALLOCATE ( train ) END IF grid_units = 'MPa' ! for any of the choices (topographic, tectonic, or total anomalies) symbol_diameter_meters = MIN((0.3D0 * Delta_r), (3.0D0 * Delta_z)) ! to fit in model box without overlapping WRITE (*, *) WRITE (*, "(' Symbols are auto-scaled-to-fit if you choose relative size of 1.0 below:')") CALL DPrompt_for_Real("Relative symbol size:", 1.0D0, relative_symbol_size) symbol_diameter_meters = symbol_diameter_meters * relative_symbol_size s1_size_points = 2834.6D0 * symbol_diameter_meters / fs_scale_denominator IF (desired_symbol == 2) THEN ! plot full anomaly tensor CALL DBegin_Group() CALL DSet_Line_Style (width_points = 0.5D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') maximum_diameter_points = 2834.6D0 * (symbol_diameter_meters / fs_scale_denominator) DO j = 1, n_columns ! r increases, L to R DO i = 1, n_rows ! z decreases, going down from surface IF (tectonic_style(i, j) == 0) CYCLE ! skip over any degenerate tensors r = (j - 1.0D0) * Delta_r jiggle = MOD(i, 3) - 1 r = r + jiggle * 0.3D0 * Delta_r z = -(i - 1) * Delta_z ! non-positive, in meters, going down CALL DStress_in_Section (r = r, z = z, & & s_rr = tensors_in_a_plane(1, i, j), & & s_rz = tensors_in_a_plane(6, i, j), & & s_zz = tensors_in_a_plane(2, i, j), & & s_vv = tensors_in_a_plane(3, i, j), & & ref_pressure_SI = maximum, ref_diameter_points = maximum_diameter_points) END DO ! i = 1, n_rows (from sea level, z going down) END DO ! j = 1, n_columns (left to right; r increasing) CALL DEnd_Group number8 = ADJUSTL(DASCII8(maximum)) CALL Chooser(bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Stress Anomaly') CALL DL12_Text (level = 1, & & x_points = x1_points + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = 'Tensor:') CALL DL12_Text (level = 1, & & x_points = x1_points + 50.0D0, & & y_points = 0.5D0*(y1_points + y2_points) - 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.4D0, & & text = TRIM(number8) // ' ' // "MPa") CALL DStress_in_Plane (level = 1, & & x = x1_points + 100.0D0 + 0.5D0 * maximum_diameter_points, & & y = 0.5D0 * (y1_points + y2_points), & & s11 = -maximum, & & s12 = 0.0D0, & & s22 = -maximum, & & s33 = -maximum, & & ref_pressure_SI = maximum, & & ref_diameter_points = maximum_diameter_points) CALL DStress_in_Plane (level = 1, & & x = x1_points + 106.0D0 + 1.5D0 * maximum_diameter_points, & & y = 0.5D0 * (y1_points + y2_points), & & s11 = +maximum, & & s12 = 0.0D0, & & s22 = +maximum, & & s33 = +maximum, & & ref_pressure_SI = maximum, & & ref_diameter_points = maximum_diameter_points) CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 106.0D0 + 2.0D0 * maximum_diameter_points END IF ! bottom legend END IF ! desired_symbol == 2; full anomaly tensor IF ((desired_symbol == 1).OR.(desired_symbol == 2)) THEN ! plot shear traction vectors on section plane CALL DBegin_Group() CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) IF (mosaic_count > 0) THEN CALL DSet_Stroke_Color ('background') ELSE CALL DSet_Stroke_Color ('foreground') END IF DO j = 1, n_columns ! r increases, L to R DO i = 1, n_rows ! z decreases, going down from surface IF (tectonic_style(i, j) == 0) CYCLE ! skip over any zero tensors r = (j - 1.0D0) * Delta_r jiggle = MOD(i, 3) - 1 r = r + jiggle * 0.3D0 * Delta_r z = -(i - 1) * Delta_z ! non-positive, in meters, going down traction_MPa = DSQRT((tensors_in_a_plane(4, i, j)**2) + (tensors_in_a_plane(5, i, j)**2)) vector_length_meters = traction_MPa * symbol_diameter_meters / maximum dr_meters = vector_length_meters * tensors_in_a_plane(5, i, j) / traction_MPa dz_meters = vector_length_meters * tensors_in_a_plane(4, i, j) / traction_MPa CALL DVector_in_Section (from_r = r-0.5D0*dr_meters, from_z = z-0.5D0*dz_meters, & & to_r = r+0.5D0*dr_meters, to_z = z+0.5D0*dz_meters) END DO ! i = 1, n_rows (from sea level, z going down) END DO ! j = 1, n_columns (left to right; r increasing) CALL DEnd_Group traction_MPa_per_cm = maximum * 0.01D0 / (symbol_diameter_meters / fs_scale_denominator) number8 = ADJUSTL(DASCII8(traction_MPa_per_cm)) CALL DSet_Stroke_Color ('foreground') ! in case it was set to background earlier? CALL Chooser(bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points CALL DBegin_Group CALL DSet_Fill_or_Pattern (.FALSE., 'foreground') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points) + 12.0D0, & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = 'Traction') CALL DL12_Text (level = 1, & & x_points = x1_points + 29.0D0, & & y_points = 0.5D0*(y1_points + y2_points), & & angle_radians = 0.0D0, & & font_points = 12, & & lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(number8)//' MPa:') CALL DVector_in_Plane (level = 1, & ! 1-cm-long vector & from_x = (x1_points+29.0D0)-14.17D0, from_y = 0.5D0*(y1_points+y2_points)-10.0D0, & & to_x = (x1_points+29.0D0)+14.17D0, to_y = 0.5D0*(y1_points+y2_points)-10.0D0) CALL DEnd_Group bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 58.0D0 END IF ! bottom or legend END IF ! plotting shear traction vectors (desired_symbol == 1, or 2) IF ((desired_symbol == 3).OR.(desired_symbol == 4)) THEN IF (desired_symbol == 3) THEN WRITE (*,"(/' Working on trends of most-compressive principal directions (& tectonic styles)...')") ELSE IF (desired_symbol == 4) THEN WRITE (*,"(/' Working on planes of greatest anomalous shear traction...')") END IF CALL DBegin_Group ! either of sigma1 or of focal mechanisms DO j = 1, n_columns ! r increases, L to R DO i = 1, n_rows ! z decreases, going down from surface IF (tectonic_style(i, j) == 0) CYCLE ! skip over any zero tensors r = (j - 1.0D0) * Delta_r jiggle = MOD(i, 3) - 1 r = r + jiggle * 0.3D0 * Delta_r z = -(i - 1) * Delta_z ! non-positive, in meters, going down !First subscript: 1) s_rr, 2) s_zz, 3) s_vv, 4) s_zv, 5) s_rv, 6) s_rz tensor(1, 1) = tensors_in_a_plane(1, i, j) tensor(2, 2) = tensors_in_a_plane(2, i, j) tensor(3, 3) = tensors_in_a_plane(3, i, j) tensor(2, 3) = tensors_in_a_plane(4, i, j) tensor(1, 3) = tensors_in_a_plane(5, i, j) tensor(1, 2) = tensors_in_a_plane(6, i, j) tensor(2, 1) = tensor(1, 2) tensor(3, 1) = tensor(1, 3) tensor(3, 2) = tensor(2, 3) CALL Eigenanalysis_3x3(tensor, eigenvalues, eigenvectors) ! (which can handle all-zero tensors) IF ((eigenvalues(1) == 0.0D0).AND.(eigenvalues(3) == 0.0D0)) CYCLE ! guard against errors that occur when trying to plot an all-zero tensor. !GPBhere !find "trend" and "plunge" of each principal axis: DO k = 1, 3 IF (eigenvectors(3, k) <= 0.0D0) THEN trend_radians(k) = DATAN2(eigenvectors(1, k), eigenvectors(2, k)) ELSE trend_radians(k) = DATAN2(-eigenvectors(1, k), -eigenvectors(2, k)) END IF !These trends are relative to FlatMaxwell axis +z, which is also plot axis +y (up on section); !they are NOT relative to local North. They are measured clockwise in radians. !I always choose the trend (sense) as the direction with positive plunge (down into the section; dv < 0.). horizontal = DSQRT((eigenvectors(1, k)**2) + (eigenvectors(2, k)**2)) plunge_radians(k) = DATAN2(ABS(eigenvectors(3, k)), horizontal) ! both arguments non-negative !These plunges are relative to the FlatMaxwell (x, y) plane, which is the surface of the projected flat-Earth. !They are measured downward from horizontal in radians, and will always be positive (or zero). END DO IF (desired_symbol == 3) THEN !determine tectonic sense by stored analysis that used xyz_tensor: most_vertical_axis = tectonic_style(i, j) IF (most_vertical_axis > 0) THEN dr = 0.5D0 * symbol_diameter_meters * DSIN(trend_radians(1)) * DCOS(plunge_radians(1)) dz = 0.5D0 * symbol_diameter_meters * DCOS(trend_radians(1)) * DCOS(plunge_radians(1)) IF (ai_using_color) THEN ! wide line of green (s-s), mid_blue (thrust), or bronze (normal) CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) IF (most_vertical_axis == 2) THEN CALL DSet_Stroke_Color('green_____') ! strike-slip ELSE IF (most_vertical_axis == 3) THEN ! e_rr is e3 CALL DSet_Stroke_Color('mid_blue__') ! thrust ELSE ! e_rr is e1 CALL DSet_Stroke_Color('red_______') ! normal END IF ! different colors CALL DNew_FSL3_Path(r + dr, z + dz) CALL DLine_to_FSL3(r - dr, z - dz) CALL DEnd_FSL3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! b/w symbol ! black-stroked white box for normal, unstroked grey box for s-s, black for thrusting CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) IF (most_vertical_axis == 2) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'gray______') ! strike-slip stroke_this = .FALSE. ELSE IF (most_vertical_axis == 3) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') ! thrust stroke_this = .FALSE. ELSE ! most_vertical_axis == 1; normal CALL DSet_Fill_or_Pattern(.FALSE.,'background') ! normal stroke_this = .TRUE. END IF ! different grays CALL DNew_FSL3_Path(r + dr - 0.1D0 * dz, z + dz + 0.1D0 * dr) CALL DLine_to_FSL3 (r - dr - 0.1D0 * dz, z - dz + 0.1D0 * dr) CALL DLine_to_FSL3 (r - dr + 0.1D0 * dz, z - dz - 0.1D0 * dr) CALL DLine_to_FSL3 (r + dr + 0.1D0 * dz, z + dz - 0.1D0 * dr) CALL DLine_to_FSL3 (r + dr - 0.1D0 * dz, z + dz + 0.1D0 * dr) CALL DEnd_FSL3_Path(close = .TRUE., stroke = stroke_this, fill = .TRUE.) END IF ! ai_using_color, or not END IF ! tectonic style is defined (non-zero tensor) ELSE ! desired_symbol == 4 (FM) CALL DSet_Line_Style (0.6D0, .FALSE.) CALL DBegin_Group ! for this one FPS symbol ! Plot a white background circle (even for slide copy!): CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_FSL3 (r, z, 0.5D0 * symbol_diameter_meters, .TRUE., .TRUE.) ! Define (x, y) coordinate system of Level-3 map plane in AI module, ! in such a way that r can be used as x, and z can be used as y ! in order to place the little world of the focal mechanism. CALL DSet_Zoom(scale_denominator = fs_scale_denominator, & & x_center_meters = 0.5D0 * section_length_m, & & y_center_meters = -0.5D0 * fmr_z_DEPTH_meters, & & xy_wrt_page_radians = 0.0D0) ! finishes the job of defining map-projection ! Save state of module Map_Projections: CALL DSave_mp_State () ! Reset Map_Projections to show a tiny world at right location and size: CALL DSet_Stereographic (radius_meters = 0.25D0 * symbol_diameter_meters, & ! extra factor of 0.5 counters stereographic blowup of outer circle & projpoint_uvec = (/ -0.01745241D0, 0.0D0, 0.9998477D0 /), & ! see comment below & x_projpoint_meters = r, & & y_projpoint_meters = z, & & y_azimuth_radians = 0.0D0) ! Plot two black sectors on (front) side of little world. ! NOTE: Little world is seen from ~North pole ! (actually, from 89N, 180 E to prevent degeneracy), with ! its Greenwich meridian pointing toward +y on the map page, ! so that if 1.0*plunge is used as a North latitude, and ! -1.0*trend is used as a longitude, points plot correctly on ! the lower focal hemisphere. Points with negative ! plunge will not be seen, as they will be on the back side. e1_lon = -1.0D0 * trend_radians(1) * degrees_per_radian ! -1 * e1_trend e2_lon = -1.0D0 * trend_radians(2) * degrees_per_radian ! -1 * e2_trend e3_lon = -1.0D0 * trend_radians(3) * degrees_per_radian ! -1 * e3_trend e1_lat = 1.0D0 * plunge_radians(1) * degrees_per_radian ! 1 * e1_plunge e2_lat = 1.0D0 * plunge_radians(2) * degrees_per_radian ! 1 * e2_plunge e3_lat = 1.0D0 * plunge_radians(3) * degrees_per_radian ! 1 * e3_plunge CALL DLonLat_2_Uvec (lon = e1_lon, lat = e1_lat, uvec = e1_f_uvec) ! front or visible end CALL DLonLat_2_Uvec (lon = e2_lon, lat = e2_lat, uvec = e2_f_uvec) ! front or visible end CALL DLonLat_2_Uvec (lon = e3_lon, lat = e3_lat, uvec = e3_f_uvec) ! front or visible end !To prevent topological problems during drafting, adjust these three axes !to be exactly perpendicular to each other! Preserve e2_f_uvec exactly, !since this is the one that comes directly from data. CALL DCross (e1_f_uvec, e2_f_uvec, tvec) ! replacing e3, now perp. to e2 IF (tvec(3) < 0.0D0) tvec = -tvec CALL DMake_Uvec (tvec, e3_f_uvec) CALL DCross (e2_f_uvec, e3_f_uvec, tvec) ! replacing e1, now perp. to both IF (tvec(3) < 0.0D0) tvec = -tvec CALL DMake_Uvec (tvec, e1_f_uvec) e1_b_uvec = -e1_f_uvec ! back end of e1 axis; invisible e2_b_uvec = -e2_f_uvec ! back end of e2 axis; invisible e3_b_uvec = -e3_f_uvec ! back end of e3 axis; invisible tvec = e3_f_uvec + e1_b_uvec CALL DMake_uvec (tvec, turn_1_uvec) ! pole of 1st small circle arc tvec = e3_f_uvec + e1_f_uvec CALL DMake_uvec (tvec, turn_2_uvec) ! pole of 2nd small circle arc turn_3_uvec = -turn_1_uvec ! pole of 3rd small circle turn_4_uvec = -turn_2_uvec ! pole of 4th small circle CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL DNew_L45_Path (5, e2_f_uvec) CALL DSmall_To_L45 (pole_uvec = turn_1_uvec, to_uvec = e2_b_uvec) ! front to back CALL DSmall_To_L45 (pole_uvec = turn_2_uvec, to_uvec = e2_f_uvec) ! back to front CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE., retro = .TRUE.) CALL DNew_L45_Path (5, e2_f_uvec) CALL DSmall_To_L45 (pole_uvec = turn_3_uvec, to_uvec = e2_b_uvec) ! front to back CALL DSmall_To_L45 (pole_uvec = turn_4_uvec, to_uvec = e2_f_uvec) ! back to front CALL DEnd_L45_Path (close = .TRUE., stroke = .FALSE., fill = .TRUE., retro = .TRUE.) ! Reset (saved) state of module Map_Projections CALL DRestore_mp_State () ! Plot the outer circle of lower focal hemisphere CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_L3 (x_meters, y_meters, 0.5D0 * symbol_diameter_meters, .TRUE., .FALSE.) CALL DEnd_Group ! for this one FPS symbol END IF ! desired_symbol == 3 (most-compressive trend & style), OR 4 (FM) END DO ! i = 1, n_rows (from sea level, z going down) END DO ! j = 1, n_columns (left to right; r increasing) CALL DEnd_Group ! either of desired_symbolS == 3, or == 4 CALL DBegin_Group ! sample s_1 directions, or sample FMs, in legend CALL Chooser (bottomlegend_used_points, rightlegend_used_points, bottom, right) IF (desired_symbol == 3) THEN ! most-compressive trends and styles: IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points) / 2.0D0 CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Model s_1') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'direction and') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'stress regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('red_______') CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+76.0D0, ycp+10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'background') CALL DNew_L12_Path(1, x1_points+76.0D0, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0-1.5D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL DSet_Line_Style (width_points = 1.5D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'normal') IF (ai_using_color) THEN CALL DSet_Stroke_Color('green_____') ELSE CALL DSet_Stroke_Color('gray______') END IF CALL DNew_L12_Path(1, x1_points+76.0D0, ycp) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'strike-slip') IF (ai_using_color) THEN CALL DSet_Stroke_Color('mid_blue__') ELSE CALL DSet_Stroke_Color('foreground') END IF CALL DNew_L12_Path(1, x1_points+76.0D0, ycp-10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 116.0D0 + s1_size_points END IF ! bottom legend for desired_symbol == 3? ELSE ! desired_symbol == 4; FM legend !sample EQ magnitudes in the margin CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') ! EQs have black fill with white outline (to separate points) CALL DSet_Stroke_Color ('background') CALL DSet_Line_Style (0.6D0, .FALSE.) IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x_used_points = 0.0D0 yp = (y1_points + y2_points) / 2.0D0 ! sample thrust and normal in bottom legend CALL DBegin_Group radius_points = 16.0D0 step_points = MAX((0.5D0 * s1_size_points + 6.0D0), 24.0D0) xp = x1_points + bottomlegend_used_points + x_used_points + MAX(radius_points, 16.0D0) + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL Cats_Eye (xp, yp, radius_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) ypt = yp - radius_points - 12.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.6D0, 0.0D0, & & 'normal') x_points = xp ! saved for an additional comment line of text at end legend x_used_points = x_used_points + 2.0D0 * MAX(radius_points, 16.0D0) + 6.0D0 CALL DEnd_Group CALL DBegin_Group xp = x1_points + bottomlegend_used_points + x_used_points + MAX(radius_points, 16.0D0) + 6.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='black_____') CALL DCircle_on_L12 (1, xp,yp, radius_points, .FALSE., .TRUE.) CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='white_____') CALL Cats_Eye (xp, yp, radius_points) CALL DSet_Stroke_Color ('foreground') CALL DCircle_on_L12 (1, xp,yp, radius_points, .TRUE., .FALSE.) ypt = yp - radius_points - 12.0D0 CALL DSet_Fill_or_Pattern (use_pattern=.FALSE., color_name='foreground') CALL DL12_Text (1, xp, ypt, 0.0D0, & & 12, 0.4D0, 0.0D0, & & 'thrust') x_used_points = x_used_points + 2.0D0 * MAX(radius_points, 16.0D0) + 6.0D0 + step_points bottomlegend_used_points = bottomlegend_used_points + x_used_points CALL DEnd_Group CALL DL12_Text (1, x_points, ypt-12.0D0, 0.0D0, & & 12, 0.25D0, 0.0D0, & & '(SIDE focal hemispheres)') END IF ! bottom legend in use END IF ! sample s1? or sample FM? in legend CALL DEnd_Group ! of legend (either for s1 or for FM) END IF ! GROUP of desired_symbols :: 3 OR 4 DEALLOCATE ( tectonic_style ) DEALLOCATE ( tensors_in_a_plane ) ! end of (4, 5, 6): point measures of: {(4) topographic / (5) tectonic / (6) total} stress anomaly in section plane CASE(7) ! plot orientations of stress data: 2070 CALL DPrompt_for_String("Filename of scoring dataset?", fmc80_WSM_data_filename, fmc80_WSM_data_filename) fmc132_WSM_data_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_WSM_data_filename) OPEN (UNIT = 11, FILE = TRIM(fmc132_WSM_data_pathfile), STATUS = "OLD", PAD = "YES", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: This data file not found'/' (in current input folder, ',A,').')") TRIM(fmc132_path_in) CALL Pause() GO TO 2070 END IF CALL Read_Stress_Data(11, fmi_sites_in_box) ! just counting them, this time CLOSE (UNIT = 11, DISP = "KEEP") ! scoring data file ALLOCATE ( cstv_stress_data(fmi_sites_in_box) ) OPEN (UNIT = 11, FILE = TRIM(fmc132_WSM_data_pathfile), STATUS = "OLD", PAD = "YES") CALL Read_Stress_Data(11, fmi_sites_in_box, cstv_stress_data) ! recording data this time CLOSE (UNIT = 11, DISP = "KEEP") ! scoring data file 2071 v_tolerance_meters = 25000.0D0 ! arbitrary; roughly comparable to crustal thickness CALL DPrompt_for_Real("Out-of-section tolerance for selecting data (in meters):", v_tolerance_meters, v_tolerance_meters) IF (v_tolerance_meters <= 0.0D0) THEN WRITE (*, "(' ERROR: tolerance must be positive; values from 1E3 to 1E5 meters recommended.')") CALL Pause() GO TO 2071 END IF v_tolerance_km = v_tolerance_meters / 1000.0D0 WRITE (c5, "(F5.1)") v_tolerance_km IF (c5(5:5) == '0') WRITE (c5, "(I5)") NINT(v_tolerance_km) c5 = ADJUSTL(c5) CALL Add_Title("S_1 & stress regimes from data within "//TRIM(c5)//" km of section plane") CALL Add_Title(TRIM(fmc80_WSM_data_filename)) symbol_diameter_points = 24.0D0 CALL DPrompt_for_Real("Maximum symbol diameter (in points):", symbol_diameter_points, symbol_diameter_points) symbol_diameter_meters = scale_denominator * symbol_diameter_points * 0.000352777D0 WRITE (*,"(/' Working on most-compressive principal directions (& tectonic styles) from data...')") CALL DBegin_Group DO i = 1, fmi_sites_in_box s1_argument_radians = cstv_stress_data(i)%s1_argument_radians s1_plunge_radians = cstv_stress_data(i)%s1_plunge_radians IF ((s1_argument_radians >= 0.0D0).AND.(s1_plunge_radians >= 0.0D0)) THEN c2 = cstv_stress_data(i)%regime !determine tectonic sense by %regime: IF ((c2 == "TF").OR.(c2 == "TS")) THEN most_vertical_axis = 3 ! thrusting ELSE IF (c2 == "SS") THEN most_vertical_axis = 2 ! strike-slip ELSE IF ((c2 == "NS").OR.(c2 == "NF")) THEN most_vertical_axis = 1 ! normal-faulting ELSE most_vertical_axis = 0 ! undefined; use black symbol END IF x_meters = cstv_stress_data(i)%x_meters y_meters = cstv_stress_data(i)%y_meters z_meters = cstv_stress_data(i)%z_meters !determine section coordinates (r, z, v): r_meters = fs_xyz_2_rzv_constants(1) + fs_xyz_2_rzv_partials(1, 1) * x_meters + fs_xyz_2_rzv_partials(1, 2) * y_meters v_meters = fs_xyz_2_rzv_constants(3) + fs_xyz_2_rzv_partials(3, 1) * x_meters + fs_xyz_2_rzv_partials(3, 2) * y_meters IF (ABS(v_meters) <= v_tolerance_meters) THEN !define half-length of symbol in (dX, dY, dZ) coordinates: dx_meters = 0.5D0 * symbol_diameter_meters * DCOS(cstv_stress_data(i)%s1_argument_radians) * DCOS(cstv_stress_data(i)%s1_plunge_radians) dy_meters = 0.5D0 * symbol_diameter_meters * DSIN(cstv_stress_data(i)%s1_argument_radians) * DCOS(cstv_stress_data(i)%s1_plunge_radians) dz_meters = 0.5D0 * symbol_diameter_meters * DSIN(cstv_stress_data(i)%s1_plunge_radians) !convert this half-length vector into (dr, dz, dv) coordinates. (Actually, only dr needs to be recomputed.) dr_meters = dx_meters * fs_xyz_2_rzv_partials(1, 1) + dy_meters * fs_xyz_2_rzv_partials(1, 2) !now plot vector from (r_meters-dr_meters, z_meters-dz_meters) to (r_meters+dr_meters, z_meters+dz_meters): IF (ai_using_color) THEN ! wide line of green (s-s), mid_blue (thrust), or bronze (normal) CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) IF (most_vertical_axis == 1) THEN ! s_rr is s1 CALL DSet_Stroke_Color('red_______') ! normal ELSE IF (most_vertical_axis == 2) THEN CALL DSet_Stroke_Color('green_____') ! strike-slip ELSE IF (most_vertical_axis == 3) THEN ! s_rr is s3 CALL DSet_Stroke_Color('mid_blue__') ! thrust ELSE ! undefined regime CALL DSet_Stroke_Color('foreground') END IF ! different colors CALL DNew_FSL3_Path(r_meters - dr_meters, z_meters - dz_meters) CALL DLine_To_FSL3(r_meters + dr_meters, z_meters + dz_meters) CALL DEnd_FSL3_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE ! b/w symbol ! black-stroked white box for normal, unstroked grey box for s-s, black for thrusting CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) IF (most_vertical_axis == 1) THEN ! normal CALL DSet_Fill_or_Pattern(.FALSE.,'background') ! normal stroke_this = .TRUE. ELSE IF (most_vertical_axis == 2) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'gray______') ! strike-slip stroke_this = .FALSE. ELSE IF (most_vertical_axis == 3) THEN CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') ! thrust stroke_this = .FALSE. ELSE ! undefined regime CALL DSet_Fill_or_Pattern(.FALSE.,'gray______') ! strike-slip stroke_this = .FALSE. END IF ! different grays CALL DNew_FSL3_Path(r_meters + dr_meters - 0.1D0 * dz_meters, z_meters + dz_meters + 0.1D0 * dr_meters) CALL DLine_To_FSL3 (r_meters - dr_meters - 0.1D0 * dz_meters, z_meters - dz_meters + 0.1D0 * dr_meters) CALL DLine_To_FSL3 (r_meters - dr_meters + 0.1D0 * dz_meters, z_meters - dz_meters - 0.1D0 * dr_meters) CALL DLine_To_FSL3 (r_meters + dr_meters + 0.1D0 * dz_meters, z_meters + dz_meters - 0.1D0 * dr_meters) CALL DLine_To_FSL3 (r_meters + dr_meters - 0.1D0 * dz_meters, z_meters + dz_meters + 0.1D0 * dr_meters) CALL DEnd_FSL3_Path(close = .TRUE., stroke = stroke_this, fill = .TRUE.) END IF ! ai_using_color, or not END IF ! datum is within v_tolerance_meters of section plane END IF ! meaningful sigma_1 principal stress orientation in dataset END DO ! i = 1, fmi_sites_in_box CALL DEnd_Group DEALLOCATE ( cstv_stress_data ) CALL DBegin_Group ! sample s_1 directions (from data) in legend CALL Chooser (bottomlegend_used_points, rightlegend_used_points, bottom, right) s1_size_points = symbol_diameter_points IF (bottom) THEN CALL DReport_BottomLegend_Frame (x1_points, x2_points, y1_points, y2_points) x1_points = x1_points + bottomlegend_used_points + bottomlegend_gap_points ycp = (y1_points + y2_points) / 2.0D0 CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'Datum s_1') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'direction and') CALL DL12_Text (level = 1, x_points = x1_points+72.0D0, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 1.0D0, ud_fraction = 0.4D0, & & text = 'stress regime:') IF (ai_using_color) THEN CALL DSet_Stroke_Color('red_______') CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DNew_L12_Path(1, x1_points+76.0D0, ycp+10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) ELSE CALL DSet_Stroke_Color('foreground') CALL DSet_Line_Style (width_points = 0.75D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'background') CALL DNew_L12_Path(1, x1_points+76.0D0, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0-1.5D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0+1.5D0) CALL DLine_to_L12(x1_points+76.0D0, ycp+10.0D0-1.5D0) CALL DEnd_L12_Path(close = .TRUE., stroke = .TRUE., fill = .TRUE.) END IF CALL DSet_Line_Style (width_points = 3.0D0, dashed = .FALSE.) CALL DSet_Fill_or_Pattern(.FALSE.,'foreground') CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp+10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'normal') IF (ai_using_color) THEN CALL DSet_Stroke_Color('green_____') ELSE CALL DSet_Stroke_Color('gray______') END IF CALL DNew_L12_Path(1, x1_points+76.0D0, ycp) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'strike-slip') IF (ai_using_color) THEN CALL DSet_Stroke_Color('mid_blue__') ELSE CALL DSet_Stroke_Color('foreground') END IF CALL DNew_L12_Path(1, x1_points+76.0D0, ycp-10.0D0) CALL DLine_to_L12(x1_points+76.0D0+s1_size_points, ycp-10.0D0) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .FALSE.) CALL DL12_Text (level = 1, x_points = x1_points+80.0D0+s1_size_points, & & y_points = ycp-10.0D0, & & angle_radians = 0.0D0, font_points = 10, & & lr_fraction = 0.0D0, ud_fraction = 0.4D0, & & text = 'thrust') bottomlegend_used_points = bottomlegend_used_points + bottomlegend_gap_points + 116.0D0 + s1_size_points END IF ! bottom legend for sigma_1 orientations & regimes from data? CALL DEnd_Group ! of legend !end of CASE(7): plot orientations of stress data END SELECT ! (choice) of overlay type WRITE (*,"(' ')") CALL DPrompt_for_Logical('Do you want additional overlays?', .TRUE., do_more_overlays) IF (do_more_overlays) GO TO 2000 END IF ! do_overlay? !=============================================================================== !FINALIZE THE SECTION: draw_box = (mosaic_count.EQ.0) CALL DSection_Km_Frame (draw_box) !add A--A' labels above section window: CALL DBegin_Group CALL DWrite_L1_Text (x_points = ai_window_x1_points, y_points = ai_window_y2_points + 72.0D0, angle_radians = 0.0D0, & & font_points = 20, lr_fraction = 0.0D0, ud_fraction = 1.0D0, & & text = fmc1_section_letter) CALL DWrite_L1_Text (x_points = ai_window_x2_points, y_points = ai_window_y2_points + 72.0D0, angle_radians = 0.0D0, & & font_points = 20, lr_fraction = 1.0D0, ud_fraction = 1.0D0, & & text = fmc1_section_letter//"'") CALL DEnd_Group !mark pivot point of section with {lon, lat} above pointer triangle: CALL DBegin_Group CALL DLonLat_2_Uvec(fmr_section_pin_Elon, fmr_section_pin_Nlat, uvec) CALL DProject(uvec = uvec, x = x_meters, y = y_meters) r = fs_xyz_2_rzv_constants(1) + fs_xyz_2_rzv_partials(1, 1) * x_meters + fs_xyz_2_rzv_partials(1, 2) * y_meters x1_points = fs_r_2_pointsRight_constant + fs_r_2_pointsRight_partial * r y1_points = ai_window_y2_points + 5.0D0 !with clearance to allow for topography CALL DNew_L12_Path(1, x1_points, y1_points) CALL DLine_To_L12(x1_points+4.0D0, y1_points+7.0D0) CALL DLine_To_L12(x1_points-4.0D0, y1_points+7.0D0) CALL DLine_To_L12(x1_points, y1_points) CALL DEnd_L12_Path(close = .TRUE., stroke = .FALSE., fill = .TRUE.) IF (fmr_section_pin_Elon >= 0.0D0) THEN WRITE (c6, "(F6.2)") fmr_section_pin_Elon IF (c6(4:6) == ".00") THEN c6(4:6) = " " ELSE IF (c6(6:6) == '0') THEN c6(6:6) = ' ' END IF c6 = ADJUSTL(c6) coordinates = '{' // TRIM(c6) // "E," ELSE ! negative ELon is West. WRITE (c6, "(F6.2)") -fmr_section_pin_Elon IF (c6(4:6) == ".00") THEN c6(4:6) = " " ELSE IF (c6(6:6) == '0') THEN c6(6:6) = ' ' END IF c6 = ADJUSTL(c6) coordinates = '{' // TRIM(c6) // "W," END IF IF (fmr_section_pin_Nlat >= 0.) THEN WRITE (c5, "(F5.2)") fmr_section_pin_Nlat IF (c5(3:5) == ".00") THEN c5(3:5) = " " ELSE IF (c5(5:5) == '0') THEN c5(5:5) = ' ' END IF c5 = ADJUSTL(c5) coordinates = TRIM(coordinates) // ' ' // TRIM(c5) // "N}" ELSE ! negative Nlat is South. WRITE (c5, "(F5.2)") -fmr_section_pin_Nlat IF (c5(3:5) == ".00") THEN c5(3:5) = " " ELSE IF (c5(5:5) == '0') THEN c5(5:5) = ' ' END IF c5 = ADJUSTL(c5) coordinates = TRIM(coordinates) // ' ' // TRIM(c5) // "S}" END IF CALL DWrite_L1_Text (x_points = x1_points, y_points = y1_points+10.0D0, angle_radians = 0.0D0, & & font_points = 10, lr_fraction = 0.5D0, ud_fraction = 0.0D0, & & text = TRIM(ADJUSTL(coordinates))) CALL DEnd_Group !create W<------->E orientation symbol above section CALL DBegin_Group CALL DSet_Line_Style (width_points = 1.0D0, dashed = .FALSE.) CALL DSet_Stroke_Color ('foreground') CALL DSet_Fill_or_Pattern (use_pattern = .FALSE., color_name = 'foreground') x1_points = 0.6D0 * ai_window_x1_points + 0.4D0 * ai_window_x2_points x2_points = 0.4D0 * ai_window_x1_points + 0.6D0 * ai_window_x2_points y2_points = ai_window_y2_points + 45.0D0 CALL DNew_L12_Path(1, x1_points+7.0D0, y2_points) CALL DLine_To_L12(x1_points+11.0D0, y2_points+4.0D0) CALL DLine_To_L12(x1_points , y2_points ) CALL DLine_To_L12(x1_points+11.0D0, y2_points-4.0D0) CALL DLine_To_L12(x1_points+7.0D0 , y2_points ) CALL DLine_To_L12(x2_points-7.0D0 , y2_points ) CALL DLine_To_L12(x2_points-11.0D0, y2_points-4.0D0) CALL DLine_To_L12(x2_points , y2_points ) CALL DLine_To_L12(x2_points-11.0D0, y2_points+4.0D0) CALL DLine_To_L12(x2_points-7.0D0 , y2_points) CALL DEnd_L12_Path(close = .FALSE., stroke = .TRUE., fill = .TRUE.) CALL DWrite_L1_Text (x_points = x1_points, y_points = y2_points, angle_radians = 0.0D0, & & font_points = 14, lr_fraction = 1.2D0, ud_fraction = 0.3D0, & & text = TRIM(ADJUSTL(left_label))) CALL DWrite_L1_Text (x_points = x2_points, y_points = y2_points, angle_radians = 0.0D0, & & font_points = 14, lr_fraction = -0.2D0, ud_fraction = 0.3D0, & & text = TRIM(ADJUSTL(right_label))) CALL DEnd_Group !titles at top of map IF (ai_toptitles_reserved) THEN WRITE (*,"(' ')") mt_flashby = .FALSE. ! Do NOT flash by the prompts for titles, if there is space! CALL DPrompt_for_Logical('Do you want to add a title to this section?', .TRUE., add_titles) IF (add_titles) THEN 900 WRITE (*,"(/' ----------------------------------------------------------------------')") WRITE (*,"(' SOME SUGGESTED TITLE OPTIONS')") WRITE (*,"(/' 0 :: ANYTHING YOU CHOOSE TO TYPE!')") DO i = 1, fmi_title_count WRITE (*,"(' ',I2,' :: ',A)") i, TRIM(fmc132v_titles(i)) END DO ! i = 1, fmi_title_count WRITE (*,"(' ----------------------------------------------------------------------')") CALL DPrompt_for_Integer('Which option do you want for the upper line?', 0, title_choice) IF ((title_choice < 0).OR.(title_choice > fmi_title_count)) THEN WRITE (*,"(' ERROR: Please choose a number from the list.')") mt_flashby = .FALSE. GO TO 900 END IF ! illegal choice IF (title_choice == 0) THEN CALL DPrompt_for_String('Enter top title (or one space for none)', ' ', top_line) ELSE ! selection from list top_line = TRIM(fmc132v_titles(title_choice)) END IF CALL DPrompt_for_Integer('Which option do you want for the lower line?', 0, title_choice) IF ((title_choice < 0).OR.(title_choice > fmi_title_count)) THEN WRITE (*,"(' ERROR: Please choose a number from the list.')") mt_flashby = .FALSE. GO TO 900 END IF ! illegal choice IF (title_choice == 0) THEN CALL DPrompt_for_String('Enter sub-title (or one space for none)', ' ', bottom_line) ELSE ! selection from list bottom_line = TRIM(fmc132v_titles(title_choice)) END IF CALL DTop_Titles (top_line, & & bottom_line) END IF ! add_titles END IF ! ai_top_titles_reserved CALL DEnd_Page END SUBROUTINE Create_Section SUBROUTINE Define_Coefficients() IMPLICIT NONE CHARACTER*1 :: c1j CHARACTER*2 :: c2l, c2m, c2n CHARACTER*13 :: name, name_base INTEGER :: i, j, k, l, m, n !NOTE that Define_Coefficients() executes all statements which never change value ! {because they do not depend on position (x, y, z)} and that corresponding statements ! in Tectonic_Stress_at_Point() are commented-out for speed. !Leading factor fmdv_Q(i) is individually chosen for each basis function so that the RMS value of the dominant stress component !will be ~1 over the 3-D model domain. Then, many diagonal values in linear system coefficient matrix !should also be ~1, assuming that "conditioner" cancels out 2/(sigma_b**2), and weight_per_point adds to unity, !and that the collocation points are uniformly and equally spaced within the model volume(?!?). !Note that some basis functions (those with 2 or 3 active stress components) will have higher diagonals, up to ~2.99, !even if all the previous conditions are met. !Start by unitizing-or-zeroing all vectors. fmdv_F_at_x = 1.0D0 ! pass-through factor, in case F(x), G(y), or H(z) is not mentioned in formula. fmdv_G_at_y = 1.0D0 fmdv_H_at_z = 1.0D0 fmdv_d_F_d_x_at_x = 0.0D0 ! in case F(x), G(y), or H(z) is not mentioned in formula (see above). fmdv_d_G_d_y_at_y = 0.0D0 fmdv_d_H_d_z_at_z = 0.0D0 fmdv_d2_F_d_x2_at_x = 0.0D0 ! in case F(x), G(y), or H(z) is not mentioned in formula (see above). fmdv_d2_G_d_y2_at_y = 0.0D0 fmdv_d2_H_d_z2_at_z = 0.0D0 !---------------------------------------------------------------------------------- !6 independent components of the constant tau tensor (tau_xx, tau_yy, tau_zz, tau_yz, tau_xz, tau_xy): fmc13v_name(1) = "C1"; fmiv_k(1) = 3 fmdv_d2_G_d_y2_at_y(1) = 1.0D0 fmdv_Q(1) = 1.0D0 fmc13v_name(2) = "C2"; fmiv_k(2) = 3 fmdv_d2_F_d_x2_at_x(2) = 1.0D0 fmdv_Q(2) = 1.0D0 fmc13v_name(3) = "C3"; fmiv_k(3) = 2 fmdv_d2_F_d_x2_at_x(3) = 1.0D0 fmdv_Q(3) = 1.0D0 fmc13v_name(4) = "C4"; fmiv_k(4) = 1 fmdv_d_G_d_y_at_y(4) = -1.0D0 fmdv_d_H_d_z_at_z(4) = 1.0D0 fmdv_Q(4) = 1.0D0 fmc13v_name(5) = "C5"; fmiv_k(5) = 2 fmdv_d_F_d_x_at_x(5) = -1.0D0 fmdv_d_H_d_z_at_z(5) = 1.0D0 fmdv_Q(5) = 1.0D0 fmc13v_name(6) = "C6"; fmiv_k(6) = 3 fmdv_d_F_d_x_at_x(6) = -1.0D0 fmdv_d_G_d_y_at_y(6) = 1.0D0 fmdv_Q(6) = 1.0D0 i = 6 !---------------------------------------------------------------------------------- IF (fmi_waves >= 0) THEN ! include the 15 independent linear-in-space variations; see file basis_functions.xlsx fmc13v_name( 7) = "L01"; fmiv_k( 7) = 3 fmdv_d_F_d_x_at_x( 7) = 1.0D0 fmdv_d2_G_d_y2_at_y( 7) = 1.0D0 fmdv_Q( 7) = 3.4641D0 / fmr_x_LENGTH_meters fmc13v_name( 8) = "L02"; fmiv_k( 8) = 2 fmdv_d_F_d_x_at_x( 8) = 1.0D0 fmdv_d2_H_d_z2_at_z( 8) = 1.0D0 fmdv_Q( 8) = 3.4641D0 / fmr_x_LENGTH_meters fmc13v_name( 9) = "L03"; fmiv_k( 9) = 2 fmdv_d_G_d_y_at_y( 9) = 1.0D0 fmdv_d2_H_d_z2_at_z( 9) = 1.0D0 fmdv_Q( 9) = 3.4641D0 / fmr_y_WIDTH_meters fmc13v_name(10) = "L04"; fmiv_k(10) = 3 fmdv_d2_G_d_y2_at_y(10) = 1.0D0 fmdv_d_H_d_z_at_z(10) = 1.0D0 fmdv_Q(10) = 1.732D0 / fmr_z_DEPTH_meters fmc13v_name(11) = "L05"; fmiv_k(11) = 1 fmdv_d_F_d_x_at_x(11) = 1.0D0 fmdv_d2_H_d_z2_at_z(11) = 1.0D0 fmdv_Q(11) = 3.4641D0 / fmr_x_LENGTH_meters fmc13v_name(12) = "L06"; fmiv_k(12) = 3 fmdv_d2_F_d_x2_at_x(12) = 1.0D0 fmdv_d_G_d_y_at_y(12) = 1.0D0 fmdv_Q(12) = 3.4641D0 / fmr_x_LENGTH_meters fmc13v_name(13) = "L07"; fmiv_k(13) = 1 fmdv_d_G_d_y_at_y(13) = 1.0D0 fmdv_d2_H_d_z2_at_z(13) = 1.0D0 fmdv_Q(13) = 3.4641D0 / fmr_y_WIDTH_meters fmc13v_name(14) = "L08"; fmiv_k(14) = 3 fmdv_d2_F_d_x2_at_x(14) = 1.0D0 fmdv_d_H_d_z_at_z(14) = 1.0D0 fmdv_Q(14) = 1.732D0 / fmr_z_DEPTH_meters fmc13v_name(15) = "L09"; fmiv_k(15) = 1 fmdv_d_F_d_x_at_x(15) = 1.0D0 fmdv_d2_G_d_y2_at_y(15) = 1.0D0 fmdv_Q(15) = 3.4641D0 / fmr_x_LENGTH_meters fmc13v_name(16) = "L10"; fmiv_k(16) = 2 fmdv_d2_F_d_x2_at_x(16) = 1.0D0 fmdv_d_G_d_y_at_y(16) = 1.0D0 fmdv_Q(16) = 3.4641D0 / fmr_y_WIDTH_meters fmc13v_name(17) = "L11"; fmiv_k(17) = 2 fmdv_d2_F_d_x2_at_x(17) = 1.0D0 fmdv_d_H_d_z_at_z(17) = 1.0D0 fmdv_Q(17) = 3.4641D0 / fmr_x_LENGTH_meters fmc13v_name(18) = "L12"; fmiv_k(18) = 1 fmdv_d2_G_d_y2_at_y(18) = 1.0D0 fmdv_d_H_d_z_at_z(18) = 1.0D0 fmdv_Q(18) = 3.4641D0 / fmr_x_LENGTH_meters fmc13v_name(19) = "L13"; fmiv_k(19) = 1 fmdv_d_F_d_x_at_x(19) = -1.0D0 fmdv_d_G_d_y_at_y(19) = 1.0D0 fmdv_d_H_d_z_at_z(19) = 1.0D0 fmdv_Q(19) = 3.4641D0 / fmr_x_LENGTH_meters fmc13v_name(20) = "L14"; fmiv_k(20) = 2 fmdv_d_F_d_x_at_x(20) = -1.0D0 fmdv_d_G_d_y_at_y(20) = 1.0D0 fmdv_d_H_d_z_at_z(20) = 1.0D0 fmdv_Q(20) = 3.4641D0 / fmr_y_WIDTH_meters fmc13v_name(21) = "L15"; fmiv_k(21) = 3 fmdv_d_F_d_x_at_x(21) = -1.0D0 fmdv_d_G_d_y_at_y(21) = 1.0D0 fmdv_d_H_d_z_at_z(21) = 1.0D0 fmdv_Q(21) = 1.732D0 / fmr_z_DEPTH_meters i = 21 END IF ! fmi_waves >= 0 !---------------------------------------------------------------------------------- IF (fmi_waves > 0) THEN ! include oscillating basis functions; see file basis_functions.xlsx DO l = 1, fmi_top_lmn fmdv_a(l) = l * Pi / fmr_x_LENGTH_meters END DO DO m = 1, fmi_top_lmn fmdv_b(m) = m * Pi / fmr_y_WIDTH_meters END DO DO n = 1, fmi_top_lmn fmdv_c(n) = n * Pi / fmr_z_DEPTH_meters END DO !------------------------------------------------------ !First, add 1-D oscillations: DO j = 1, 6 ! 1DO1 -- 1DO6 WRITE (c1j, "(I1)") j name_base = "1DO" // c1j DO k = 1, 2 ! SIN, COS DO l = 1, fmi_top_lmn i = i + 1 fmdv_Q(i) = 1.4142D0 WRITE (c2l, "(I2)") l IF (c2l(1:1) == ' ') c2l(1:1) = '0' SELECT CASE(k) CASE(1) ! SIN fmc13v_name(i) = TRIM(name_base) // 'S' // c2l CASE(2) ! COS fmc13v_name(i) = TRIM(name_base) // 'C' // c2l END SELECT SELECT CASE(j) CASE(1) fmiv_k(i) = 2 ! Phi_y CASE(2) fmiv_k(i) = 3 ! Phi_z CASE(3) fmiv_k(i) = 1 ! Phi_x CASE(4) fmiv_k(i) = 3 ! Phi_z CASE(5) fmiv_k(i) = 1 ! Phi_x CASE(6) fmiv_k(i) = 2 ! Phi_y END SELECT END DO ! l = 1, fmi_top_lmn END DO ! k = 1, 2 (SIN, COS) END DO ! j = 1, 6 (1DO#) !------------------------------------------------------ !Second, add 2-D oscillations: DO j = 1, 6 ! 2DO# WRITE (c1j, "(I1)") j name_base = "2DO" // c1j DO k = 1, 4 ! SS, CS, SC, CC DO l = 1, fmi_top_lmn DO m = 1, fmi_top_lmn i = i + 1 WRITE (c2l, "(I2)") l IF (c2l(1:1) == ' ') c2l(1:1) = '0' WRITE (c2m, "(I2)") m IF (c2m(1:1) == ' ') c2m(1:1) = '0' SELECT CASE(k) CASE(1) ! SIN SIN fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'S' // c2m CASE(2) ! COS SIN fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'S' // c2m CASE(3) ! SIN COS fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'C' // c2m CASE(4) ! COS COS fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'C' // c2m END SELECT SELECT CASE(j) CASE(1) fmiv_k(i) = 1 ! Phi_x CASE(2) fmiv_k(i) = 2 ! Phi_y CASE(3) fmiv_k(i) = 1 ! Phi_x CASE(4) fmiv_k(i) = 2 ! Phi_y CASE(5) fmiv_k(i) = 1 ! Phi_x CASE(6) fmiv_k(i) = 3 ! Phi_z END SELECT SELECT CASE(j) CASE(1, 2) ! sin(by) sin(cz) IF (j == 1) THEN fmdv_Q(i) = 2.0D0 / MAX(fmdv_b(l), fmdv_c(m))**2 ELSE ! j == 2 fmdv_Q(i) = 2.0D0 / fmdv_c(m)**2 END IF CASE(3, 4) ! sin(ax) sin(cz) IF (j == 3) THEN fmdv_Q(i) = 2.0D0 / fmdv_c(m)**2 ELSE ! j == 4 fmdv_Q(i) = 2.0D0 / MAX(fmdv_a(l), fmdv_c(m))**2 END IF CASE(5, 6) ! sin(ax) sin(by) IF (j == 5) THEN fmdv_Q(i) = 2.0D0 / fmdv_b(m)**2 ELSE ! j == 6 fmdv_Q(i) = 2.0D0 / MAX(fmdv_a(l), fmdv_b(m))**2 END IF END SELECT !(j) END DO ! m = 1, fmi_top_lmn END DO ! l = 1, fmi_top_lmn END DO ! k = 1, 4 (SS, CS, SC, CC) END DO ! j = 1, 6 (2DO#) !------------------------------------------------------ !Third, add 3-D oscillations: DO j = 1, 3 ! 3DO# WRITE (c1j, "(I1)") j name_base = "3DO" // c1j DO k = 1, 8 ! SSS, CSS, SCS, CCS, SSC, CSC, SCC, CCC DO l = 1, fmi_top_lmn DO m = 1, fmi_top_lmn DO n = 1, fmi_top_lmn i = i + 1 WRITE (c2l, "(I2)") l IF (c2l(1:1) == ' ') c2l(1:1) = '0' WRITE (c2m, "(I2)") m IF (c2m(1:1) == ' ') c2m(1:1) = '0' WRITE (c2n, "(I2)") n IF (c2n(1:1) == ' ') c2n(1:1) = '0' SELECT CASE(k) CASE(1) ! SIN SIN SIN fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'S' // c2m // 'S' // c2n CASE(2) ! COS SIN SIN fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'S' // c2m // 'S' // c2n CASE(3) ! SIN COS SIN fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'C' // c2m // 'S' // c2n CASE(4) ! COS COS SIN fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'C' // c2m // 'S' // c2n CASE(5) ! SIN SIN COS fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'S' // c2m // 'C' // c2n CASE(6) ! COS SIN COS fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'S' // c2m // 'C' // c2n CASE(7) ! SIN COS COS fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'C' // c2m // 'C' // c2n CASE(8) ! COS COS COS fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'C' // c2m // 'C' // c2n END SELECT SELECT CASE(j) CASE(1) fmiv_k(i) = 1 ! Phi_x CASE(2) fmiv_k(i) = 2 ! Phi_y CASE(3) fmiv_k(i) = 3 ! Phi_z END SELECT SELECT CASE(j) CASE(1) fmdv_Q(i) = 2.8284D0 / MAX(fmdv_b(m), fmdv_c(n))**2 CASE(2) fmdv_Q(i) = 2.8284D0 / MAX(fmdv_a(l), fmdv_c(n))**2 CASE(3) fmdv_Q(i) = 2.8284D0 / MAX(fmdv_a(l), fmdv_b(m))**2 END SELECT ! on j; component of Maxwell vector field END DO ! n = 1, fmi_top_lmn END DO ! m = 1, fmi_top_lmn END DO ! l = 1, fmi_top_lmn END DO ! k = 1, 8 (SSS, CSS, SCS, CCS, SSC, CSC, SCC, CCC) END DO ! j = 1, 3 (3DO#) END IF ! fmi_waves > 0 !check completeness of list above IF (i /= fmi_N_coefficients) THEN WRITE (*, "(' ERROR: Last i = ',I6,' /= fmi_N_coefficients = ',I6)") CALL Pause() STOP END IF END SUBROUTINE Define_Coefficients SUBROUTINE Define_Map_Projection() !Most of the code here is copied from subprogram DPrompter in module DMap_Tools; !but there are a few important differences: !*choice of map scale denominator is postponed (until DCreate_Map or DCreate_Section); !*origin of the (x, y) system is always at the model center (and projection point), ! with x trending initially East, and y trending North; !*map projection always has North at the top (toward y = +infinity), ! because anything else would be just too confusing! IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. CHARACTER*43 :: projection_name INTEGER :: i REAL*8 :: belt_azimuth_radians, standard_parallel_gap_radians, & & x_projpoint_meters, xy_wrt_page_degrees, xy_wrt_page_radians, & & y_azimuth_radians, y_projpoint_meters REAL*8, DIMENSION(3) :: cone_pole_uvec, projpoint_uvec x_projpoint_meters = 0.0D0 y_projpoint_meters = 0.0D0 xy_wrt_page_degrees = 0.0D0 xy_wrt_page_radians = 0.0D0 y_azimuth_radians = 0.0D0 207 WRITE (*,"(/' Available map projections are:')") DO i = 1, 10 CALL Map_Type(i, projection_name) WRITE (*,"(' ',I2,' :: ',A)") i, TRIM(projection_name) END DO CALL DPrompt_for_Integer('Which projection type do you want?', fmi_projection_choice, fmi_projection_choice) IF ((fmi_projection_choice < 1).OR.(fmi_projection_choice > 10)) THEN WRITE (*,"(' ERROR: Please select an integer from list; try again:')") GOTO 207 ELSE CALL Map_Type(fmi_projection_choice, projection_name) END IF WRITE (*,"(' ')") 208 CALL DPrompt_for_Real('Radius of planet, in meters?', fmr_radius_meters, fmr_radius_meters) WRITE (*,"(/' *** About Choosing the Projection Point: ***')") WRITE (*,"(' Choose where you want the center of the model to be.')") WRITE (*,"(' The projection point will be placed there, for minimum distortion.')") 209 CALL DPrompt_for_Real('Longitude at center of model (degrees, East = +)?', fmr_projpoint_Elon, fmr_projpoint_Elon) 210 CALL DPrompt_for_Real('Latitude at center of model (degrees, North = +)?', fmr_projpoint_Nlat, fmr_projpoint_Nlat) IF ((fmr_projpoint_Nlat > 90.0D0).OR.(fmr_projpoint_Nlat < -90.0D0)) THEN WRITE (*,"(' ERROR: -90.0 <= latitude <= +90.0; try again:')") fmr_projpoint_Nlat = MAX(MIN(fmr_projpoint_Nlat, 90.0D0), -90.0D0) GOTO 210 END IF IF (fmi_projection_choice == 1) THEN ! Mercator 213 WRITE (*,"(' ')") CALL DPrompt_for_Real('Azimuth (in degrees, clockwise from North) of the circle& & of tangency, at the projection point?', fmr_belt_azimuth_degrees, fmr_belt_azimuth_degrees) belt_azimuth_radians = fmr_belt_azimuth_degrees * radians_per_degree !- - - - - - - - - - - - - - - - - - - - - - - - - fmr_cone_lat = 90.0D0 ! (just so it is not undefined) fmr_cone_lon = 0.0D0 ! (just so it is not undefined) fmr_standard_parallel_gap_degrees = 30.0D0 ! (just so it is not undefined) standard_parallel_gap_radians = fmr_standard_parallel_gap_degrees * radians_per_degree ! (ditto) ELSE IF ((fmi_projection_choice >= 2).AND.(fmi_projection_choice <= 5)) THEN ! conic WRITE (*,"(' ')") 215 CALL DPrompt_for_Real('Latitude of axis of cone (North = +)?', fmr_cone_lat, fmr_cone_lat) IF ((fmr_cone_lat > 90.0D0).OR.(fmr_cone_lat < -90.0D0)) THEN WRITE (*,"(' ERROR: -90.0 <= latitude <= +90.0; try again:')") fmr_cone_lat = MAX(MIN(fmr_cone_lat, 90.0D0), -90.0D0) GOTO 215 END IF CALL DPrompt_for_Real('Longitude of axis of cone (East = +)?', fmr_cone_lon, fmr_cone_lon) IF (fmi_projection_choice <= 3) THEN 216 WRITE (*,"(' ')") CALL DPrompt_for_Real('Gap between 2 standard parallels (degrees)?', & & fmr_standard_parallel_gap_degrees, fmr_standard_parallel_gap_degrees) IF (fmr_standard_parallel_gap_degrees < 0.0D0) THEN WRITE (*,"(' ERROR: Enter a positive number.')") GOTO 216 END IF standard_parallel_gap_radians = fmr_standard_parallel_gap_degrees * radians_per_degree !- - - - - - - - - - - - - - - - - - - - - - - - - fmr_belt_azimuth_degrees = 90.0D0 ! (just so it is not undefined) belt_azimuth_radians = fmr_belt_azimuth_degrees * radians_per_degree ! (ditto) END IF ! fmi_projection_choice <= 3 ELSE ! other projection_choice !(no more parameters need to be defined) !- - - - - - - - - - - - - - - - - - - - - - - - - fmr_belt_azimuth_degrees = 90.0D0 ! (just so it is not undefined) belt_azimuth_radians = fmr_belt_azimuth_degrees * radians_per_degree ! (ditto) fmr_cone_lat = 90.0D0 ! (just so it is not undefined) fmr_cone_lon = 0.0D0 ! (just so it is not undefined) fmr_standard_parallel_gap_degrees = 30.0D0 ! (just so it is not undefined) standard_parallel_gap_radians = fmr_standard_parallel_gap_degrees * radians_per_degree ! (ditto) END IF ! projection_choice CALL DLonLat_2_Uvec(fmr_projpoint_Elon, fmr_projpoint_Nlat, projpoint_uvec) !Call inititalizing routine in module DMap_Projections: SELECT CASE (fmi_projection_choice) CASE (1); CALL DSet_Mercator (fmr_radius_meters, & & projpoint_uvec, belt_azimuth_radians, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (2) CALL DLonLat_2_Uvec(fmr_cone_lon, fmr_cone_lat, cone_pole_uvec) CALL DSet_Lambert_Conformal_Conic & & (fmr_radius_meters, & & projpoint_uvec, cone_pole_uvec, & & standard_parallel_gap_radians, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (3) CALL DLonLat_2_Uvec(fmr_cone_lon, fmr_cone_lat, cone_pole_uvec) CALL DSet_Albers_Equal_Area_Conic & & (fmr_radius_meters, & & projpoint_uvec, cone_pole_uvec, & & standard_parallel_gap_radians, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (4) CALL DLonLat_2_Uvec(fmr_cone_lon, fmr_cone_lat, cone_pole_uvec) CALL DSet_Polyconic (fmr_radius_meters, & & projpoint_uvec, cone_pole_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (5) CALL DLonLat_2_Uvec(fmr_cone_lon, fmr_cone_lat, cone_pole_uvec) CALL DSet_Geometric_Conic & & (fmr_radius_meters, & & projpoint_uvec, cone_pole_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (6); CALL DSet_Stereographic (fmr_radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (7); CALL DSet_Lambert_Azimuthal_EqualArea ( & & fmr_radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (8); CALL DSet_Azimuthal_Equidistant ( & & fmr_radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (9); CALL DSet_Orthographic ( & & fmr_radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE(10); CALL DSet_Gnomonic ( & & fmr_radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) END SELECT ! fmi_projection_choice END SUBROUTINE Define_Map_Projection SUBROUTINE Define_Reference_Density_Model() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. WRITE (*, *) WRITE (*, "(' ')") WRITE (*, "(' Define (or just approve) the 1-D reference density model,')") WRITE (*, "(' which is used to define topographic loads and isostatic')") WRITE (*, "(' compensation at the Moho, and also to define the reference')") WRITE (*, "(' pressure versus depth which complements the stress anomaly.')") WRITE (*, *) CALL DPrompt_for_Real("Gravitational acceleration (m/s^2):", fmr_gravity, fmr_gravity) WRITE (*, *) CALL DPrompt_for_Real("Atmospheric pressure (Pa) at sea level:", fmr_1_bar, fmr_1_bar) CALL DPrompt_for_Real("Scale height (m) for air pressure decline:", fmr_atmosphere_scale_height_meters, fmr_atmosphere_scale_height_meters) WRITE (*, *) CALL DPrompt_for_Real("Density of sea water (kg/m^3):", fmr_seawater_density, fmr_seawater_density) WRITE (*, *) CALL DPrompt_for_Real("Mean or reference depth of Moho (m) below sea level:", fmr_Moho_depth, fmr_Moho_depth) fmr_Moho_elevation = -ABS(fmr_Moho_depth) ! guaranteeing negative elevation, despite user's convention WRITE (*, *) CALL DPrompt_for_Real("Crustal density (kg/m^3) at top:", fmr_crustal_density_at_top, fmr_crustal_density_at_top) CALL DPrompt_for_Real("Crustal density (kg/m^3) at Moho:", fmr_crustal_density_at_Moho, fmr_crustal_density_at_Moho) WRITE (*, *) CALL DPrompt_for_Real("Mantle lithosphere density (kg/m^3) at Moho:", fmr_mantle_density_at_Moho, fmr_mantle_density_at_Moho) CALL DPrompt_for_Real("Mantle density at lithosphere/asthenosphere boundary (LAB):", fmr_mantle_density_at_LAB, fmr_mantle_density_at_LAB) WRITE (*, *) CALL DPrompt_for_Real("Mean depth of LAB (m) below sealevel:", fmr_LAB_depth, fmr_LAB_depth) fmr_LAB_elevation = -ABS(fmr_LAB_depth) ! guaranteeing negative elevation, despite user's convention END SUBROUTINE Define_Reference_Density_Model SUBROUTINE Define_Volume() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. WRITE (*, *) WRITE (*, "(' Please define the length, width, and depth of the model box:')") WRITE (*, "(' (and please enter all dimensions in units of meters)')") 10 CALL DPrompt_for_Real('East- West (x-axis) length:', fmr_x_LENGTH_meters, fmr_x_LENGTH_meters) IF (fmr_x_LENGTH_meters <= 0.0D0) THEN WRITE (*, "(' ERROR: Please enter a positive length.')") CALL Pause() GO TO 10 END IF 20 CALL DPrompt_for_Real('North-South (y-axis) width:', fmr_y_WIDTH_meters, fmr_y_WIDTH_meters) IF (fmr_y_WIDTH_meters <= 0.0D0) THEN WRITE (*, "(' ERROR: Please enter a positive width.')") CALL Pause() GO TO 20 END IF 30 CALL DPrompt_for_Real('Vertical (z-axis) depth, below sea level:', fmr_z_DEPTH_meters, fmr_z_DEPTH_meters) IF (fmr_z_DEPTH_meters <= 0.0D0) THEN WRITE (*, "(' ERROR: Please enter a positive depth.')") CALL Pause() GO TO 30 END IF END SUBROUTINE Define_Volume SUBROUTINE DEM_Lookup(x_meters, y_meters, & & Reject_success, lon, lat, & & DEM_success, surface, grad_h_x, grad_h_y) !Use DEM data (already in arrays in memory) to find "surface" elevation !(in meters, positive above sea level), and its gradient at one point (x, y). IMPLICIT NONE REAL*8, INTENT(IN) :: x_meters, y_meters LOGICAL, INTENT(OUT) :: Reject_success, DEM_success REAL*8, INTENT(OUT) :: lon, lat, surface, grad_h_x, grad_h_y INTEGER :: i1, i2, j1, j2 REAL*8 :: dx, dy, east, fx1, fx2, fy1, fy2, north, south, west REAL*8, DIMENSION(3) :: uvec !begin consideration of the map point (x_source, y_source) by !Rejecting from (x, y) to its geographic coordinates (lon, lat): CALL DReject (x_meters, y_meters, Reject_success, uvec) IF (Reject_success) THEN ! rejection worked CALL DUvec_2_LonLat (uvec, lon, lat) !Now, look up the "surface" elevation at this (lon, lat); !define DEM_success as point-falling-within-the-DEM-grid: DEM_success = (lat >= fmr_DEM_lat_min).AND. & & (lat <= fmr_DEM_lat_max).AND. & & (DEasting(lon - fmr_DEM_lon_min) <= fmr_DEM_lon_range) !note: insensitive to longitude cycle IF (DEM_success) THEN !determine surface elevation and both components of its gradient: i1 = 1 + (fmr_DEM_lat_max - lat) / fmr_DEM_dLat i1 = MAX(1, MIN(i1, fmi_DEM_rows - 1)) i2 = i1 + 1 fy2 = ((fmr_DEM_lat_max - lat) / fmr_DEM_dLat) - i1 + 1.0D0 fy1 = 1.00D0 - fy2 j1 = 1 + DEasting(lon - fmr_DEM_lon_min) / fmr_DEM_dLon j1 = MAX(1, MIN(j1, fmi_DEM_columns - 1)) j2 = j1 + 1 fx2 = (DEasting(lon - fmr_DEM_lon_min) / fmr_DEM_dLon) - j1 + 1.0D0 fx1 = 1.00D0 - fx2 north = fx1 * fmim_DEM(i1, j1) + fx2 * fmim_DEM(i1, j2) south = fx1 * fmim_DEM(i2, j1) + fx2 * fmim_DEM(i2, j2) east = fy1 * fmim_DEM(i1, j2) + fy2 * fmim_DEM(i2, j2) west = fy1 * fmim_DEM(i1, j1) + fy2 * fmim_DEM(i2, j1) surface = 0.5D0 * (fy1 * north + fy2 * south + fx1 * west + fx2 * east) dx = fmr_DEM_dLon * radians_per_degree * mp_radius_meters * DCOS(lat * radians_per_degree) dy = fmr_DEM_dLat * radians_per_degree * mp_radius_meters grad_h_x = (east - west) / dx grad_h_y = (north - south) / dy ELSE ! DEM_success = .FALSE. surface = 0.0D0 grad_h_x = 0.0D0 grad_h_y = 0.0D0 END IF ! source point is inside DEM, or not ELSE ! Reject_success = .FALSE. surface = 0.0D0 grad_h_x = 0.0D0 grad_h_y = 0.0D0 END IF ! Reject_success, or not END SUBROUTINE DEM_Lookup SUBROUTINE Dig_Type (dig_pathfile, free_unit, dig_is_lonlat, any_titles) ! Decide whether dig_pathfile is (lon,lat) or (x,y) based ! on the extreme range displayed in the y (or latitude) ! component. ! Also reports "any_titles" = T/F. ! Note that there can be trouble when a title like "TX" is ! interpreted by (*) format-free READ as x, and then y is ! taken from the start of the next line (a longitude!). ! So, we have to test the first two bytes to rule out fmc132v_titles. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: dig_pathfile ! points to .dig file INTEGER, INTENT(IN) :: free_unit ! Fortran device number LOGICAL, INTENT(OUT) :: dig_is_lonlat, any_titles ! Yes or No CHARACTER*2 :: c2 CHARACTER*26 :: line INTEGER :: ios LOGICAL :: first REAL*8 :: high_y, low_y, x, y OPEN (UNIT = free_unit, FILE = dig_pathfile, STATUS = 'OLD', & & PAD = 'YES', IOSTAT = ios) IF (ios /= 0) THEN WRITE (*,"(' ERROR in Dig_Type: Following file cannot be opened:' & & /' ',A)") TRIM(dig_pathfile) CALL DTraceback END IF first = .TRUE. any_titles = .FALSE. ! unless changed below... WRITE (*,"(/' Scanning through .dig file...')") scanning: DO READ (free_unit, "(A)", IOSTAT = ios) c2 IF (ios == -1) EXIT scanning ! EOF IF ((c2 == ' +').OR.(c2 == ' -')) THEN BACKSPACE (free_unit) READ (free_unit, *, IOSTAT = ios) x, y IF (ios == 0) THEN IF (first) THEN first = .FALSE. high_y = y low_y = y END IF high_y = MAX(high_y, y) low_y = MIN(low_y, y) END IF ! read was successful ELSE ! not a number line; either *** or a title BACKSPACE (free_unit) READ (free_unit, "(A)") line any_titles = any_titles .OR. (line(1:3) /= '***') END IF ! line has two numbers, or not END DO scanning CLOSE (UNIT = free_unit, IOSTAT = ios) WRITE (*,"('+Scanning through .dig file...DONE')") dig_is_lonlat = (low_y > -91.0D0).AND.(high_y < 91.0D0) END SUBROUTINE Dig_Type SUBROUTINE Eigenanalysis_3x3(tensor, eigenvalues, eigenvectors) !Computes eigenvalues (and, optionally, eigenvectors) of a 3x3 symmetric matrix of REAL*8s, !using a routine from the MKL library. Note that eigenvalues (and associated !eigenvectors, if computed) are returned in ascending order: ! eigenvectors(1) <= eigenvectors(2) <= eigenvectors(3). !The normalized eigenvector associated with eigenvalues(j) is stored in eigenvectors(1:3, j). IMPLICIT NONE REAL*8, DIMENSION(3, 3), INTENT(IN) :: tensor REAL*8, DIMENSION(3), INTENT(OUT) :: eigenvalues REAL*8, DIMENSION(3, 3), INTENT(OUT), OPTIONAL :: eigenvectors INTEGER :: info, il, iu INTEGER, DIMENSION(6) :: isuppz INTEGER, DIMENSION(30) :: iwork REAL*8 :: tensor_magnitude, vl, vu REAL*8, DIMENSION(3, 3) :: tensor_copy REAL*8, DIMENSION(78) :: work !Guarantee that input tensor is not overwritten... tensor_copy = tensor !Normalize the tensor_copy to have magnitudes of roughly 1.0D0, so that the small !value of abstol (chosen to enforce eigenvector precision) will not imply a ridiculously !small relative tolerance for eigenvalues of a tensor which might be in Pa, rather than MPa. tensor_magnitude = MAX(ABS(tensor_copy(1, 1)),ABS(tensor_copy(1, 2)),ABS(tensor_copy(1, 3)), & & ABS(tensor_copy(2, 2)),ABS(tensor_copy(2, 3)), & & ABS(tensor_copy(3, 3))) ! (assuming symmetry) IF (tensor_magnitude > 0.0D0) THEN tensor_copy = tensor_copy / tensor_magnitude IF (PRESENT(eigenvectors)) THEN ! eigenvectors should be computed, if possible !------------------------------------------------------------------------------------------- ! On first pass, request ONLY eigenvalues (because tensor might be degenerate, e.g., pure dP, or all-0). !------------------------------------------------------------------------------------------- !Call Intel® Math Kernel Library (Intel® MKL) library routine to compute eigenvalues (only). !The manual page is at: https://software.intel.com/en-us/node/469188 !The following Fortran-95-style CALL is elegant, and compiles correctly: !CALL SYEVR(a = tensor, w = eigenvalues, uplo = 'U', m = m) ! *HOWEVER*, it leads to a linker error LNK2019 "unresolved external symbol" ! even when compiler switches are correctly set to link in MKL/LAPACK. !Therefore, I have had to use the old-fashioned FORTRAN-77-style CALL: !CALL DSYEVR( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info ) CALL DSYEVR( 'N', 'A', 'U', 3, tensor_copy, 3, vl, vu, il, iu, 1.0D-6, m, eigenvalues, eigenvectors, 3, isuppz, work, 78, iwork, 30, info ) IF (info /= 0) THEN WRITE (*, "(' ERROR: In Eigenanalysis_3x3, DSYEVR returned info = ',I10)") info CALL Pause() END IF IF (m /= 3) THEN WRITE (*, "(' ERROR: In Eigenanalysis_3x3, DSYEVR found only ',I1,' eigenvalues, not 3.')") m CALL Pause() END IF IF ((eigenvalues(1) /= eigenvalues(2)).AND.(eigenvalues(2) /= eigenvalues(3))) THEN ! normal case (non-degenerate): !------------------------------------------------------------------------------------------- ! On second pass, request eigenvectors: !------------------------------------------------------------------------------------------- ! First, refresh the tensor_copy (which may have been altered in previous CALL): tensor_copy = tensor / tensor_magnitude !Call Intel® Math Kernel Library (Intel® MKL) library routine to compute eigenvalues and eigenvectors: !The manual page is at: https://software.intel.com/en-us/node/469188 !The following Fortran-95-style CALL is elegant, and compiles correctly: !CALL SYEVR(a = tensor, w = eigenvalues, z = eigenvectors, uplo = 'U', m = m) ! *HOWEVER*, it leads to a linker error LNK2019 "unresolved external symbol" ! even when compiler switches are correctly set to link in MKL/LAPACK. !Therefore, I have had to use the old-fashioned FORTRAN-77-style CALL: !CALL DSYEVR( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info ) CALL DSYEVR( 'V', 'A', 'U', 3, tensor_copy, 3, vl, vu, il, iu, 1.0D-6, m, eigenvalues, eigenvectors, 3, isuppz, work, 78, iwork, 30, info ) IF (info /= 0) THEN WRITE (*, "(' ERROR: In Eigenanalysis_3x3, DSYEVR returned info = ',I10)") info CALL Pause() END IF IF (m /= 3) THEN WRITE (*, "(' ERROR: In Eigenanalysis_3x3, DSYEVR found only ',I1,' eigenvalues/eigenvectors, not 3.')") m CALL Pause() END IF ELSE ! degenerate case; eigenvectors are not defined! eigenvectors = 0.0D0 ! whole 3x3 matrix; then... eigenvectors(1, 1) = 1.0D0 eigenvectors(2, 2) = 1.0D0 eigenvectors(3, 3) = 1.0D0 END IF ! normal case, or degenerate case? !------------------------------------------------------------------------------------------- ELSE ! only eigenvalues are wanted: !------------------------------------------------------------------------------------------- !Call Intel® Math Kernel Library (Intel® MKL) library routine to compute eigenvalues (only). !The manual page is at: https://software.intel.com/en-us/node/469188 !The following Fortran-95-style CALL is elegant, and compiles correctly: !CALL SYEVR(a = tensor, w = eigenvalues, uplo = 'U', m = m) ! *HOWEVER*, it leads to a linker error LNK2019 "unresolved external symbol" ! even when compiler switches are correctly set to link in MKL/LAPACK. !Therefore, I have had to use the old-fashioned FORTRAN-77-style CALL: !CALL DSYEVR( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info ) CALL DSYEVR( 'N', 'A', 'U', 3, tensor_copy, 3, vl, vu, il, iu, 1.0D-6, m, eigenvalues, eigenvectors, 3, isuppz, work, 78, iwork, 30, info ) IF (info /= 0) THEN WRITE (*, "(' ERROR: In Eigenanalysis_3x3, DSYEVR returned info = ',I10)") info CALL Pause() END IF IF (m /= 3) THEN WRITE (*, "(' ERROR: In Eigenanalysis_3x3, DSYEVR found only ',I1,' eigenvalues, not 3.')") m CALL Pause() END IF !------------------------------------------------------------------------------------------- END IF ! wanting eigenvectors? Or, just eigenvalues? eigenvalues = eigenvalues * tensor_magnitude ELSE ! tensor_magnitude = 0.0D0 eigenvalues = 0.0D0 ! whole 3-vector IF (PRESENT(eigenvectors)) THEN eigenvectors = 0.0D0 ! whole 3x3 matrix; then... eigenvectors(1, 1) = 1.0D0 eigenvectors(2, 2) = 1.0D0 eigenvectors(3, 3) = 1.0D0 END IF END IF ! tensor_magnitude positive? Or, zero? END SUBROUTINE Eigenanalysis_3x3 SUBROUTINE Get_Stress_Tensor(x, y, z, choice, success, xyz_tensor) !Looks up a stress tensor in (x, y, z) coordinates for location !(x, y, z) in meters. In FlatMaxwell it is expected that z.LE.0. !If choice == 1, topographic stress anomaly is returned. !If choice == 2, tectonic stress anomaly is returned. !If choice == 3, total stress anomaly is returned. !Return value success = .FALSE. indicates a problem; either !(x, y, z) was outside the FlatMaxwell model domain, !or (in case of choice == 2 or 3) perhaps the tectonic !component of the stress was not available !on the same grid as topographic stress? !In problem cases a zero tensor is returned. IMPLICIT NONE REAL*8, INTENT(IN) :: x, y, z INTEGER, INTENT(IN) :: choice LOGICAL, INTENT(OUT) :: success REAL*8, DIMENSION(3, 3), INTENT(OUT) :: xyz_tensor INTEGER :: ix1, ix2, jy1, jy2, kz1, kz2 REAL*8 :: fx1, fx2, fy1, fy2, fz1, fz2 IF ((x < -0.5D0 * fmr_x_LENGTH_meters).OR.(x > 0.5D0 * fmr_x_LENGTH_meters).OR. & & (y < -0.5D0 * fmr_y_WIDTH_meters ).OR.(y > 0.5D0 * fmr_y_WIDTH_meters ).OR. & & (z > 0.0D0).OR.(z < -fmr_z_DEPTH_meters)) THEN !WRITE (*, "(' In CALL Get_Stress_Tensor, (x, y, z) = (',ES12.4,', ',ES12.4,', ',ES12.4,') meters')") x, y, z !WRITE (*, "(' falls outside the FlatMaxwell model domain.')") !CALL Pause() success = .FALSE. xyz_tensor = 0.0D0 ELSE ! proceed with look-up IF ((choice > 1).AND.(.NOT.ALLOCATED(fmrt_tectonic_stress_anomaly_Pa))) THEN WRITE (*, "(' ERROR: CALL Get_Stress_Tensor cannot return choice == 2, 3 because')") WRITE (*, "(' the tectonic stress tensor grid (parallel to the topographic stress grid)')") WRITE (*, "(' is not currently allocated.')") CALL Pause() success = .FALSE. xyz_tensor = 0.0D0 END IF ! tectonic stress availability is a problem?, or not !routine look-up in 3-D can proceed ix1 = MIN(MAX(-fmi_topo_nx, DInt_Below(x / fmrv_topo_stress_dXYZ(1))), fmi_topo_nx - 1) ix2 = ix1 + 1 fx2 = (x - (ix1 * fmrv_topo_stress_dXYZ(1))) / fmrv_topo_stress_dXYZ(1) fx1 = 1.0D0 - fx2 jy1 = MIN(MAX(-fmi_topo_ny, DInt_Below(y / fmrv_topo_stress_dXYZ(2))), fmi_topo_ny - 1) jy2 = jy1 + 1 fy2 = (y - (jy1 * fmrv_topo_stress_dXYZ(2))) / fmrv_topo_stress_dXYZ(2) fy1 = 1.0D0 - fy2 kz1 = MIN(MAX(-fmi_topo_nz, DInt_Below((z + 0.5D0 * fmr_z_DEPTH_meters) / fmrv_topo_stress_dXYZ(3))), fmi_topo_nz - 1) kz2 = kz1 + 1 fz2 = ((z + 0.5D0 * fmr_z_DEPTH_meters) - (kz1 * fmrv_topo_stress_dXYZ(3))) / fmrv_topo_stress_dXYZ(3) fz1 = 1.0D0 - fz2 IF (choice == 1) THEN ! topographic stress anomaly xyz_tensor(1, 1) = fx1 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(1, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(1, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(1, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(1, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(1, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(1, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(1, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(1, ix2, jy2, kz2) xyz_tensor(2, 2) = fx1 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(2, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(2, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(2, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(2, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(2, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(2, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(2, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(2, ix2, jy2, kz2) xyz_tensor(3, 3) = fx1 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(3, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(3, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(3, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(3, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(3, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(3, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(3, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(3, ix2, jy2, kz2) xyz_tensor(2, 3) = fx1 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(4, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(4, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(4, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(4, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(4, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(4, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(4, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(4, ix2, jy2, kz2) xyz_tensor(1, 3) = fx1 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(5, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(5, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(5, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(5, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(5, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(5, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(5, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(5, ix2, jy2, kz2) xyz_tensor(1, 2) = fx1 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(6, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(6, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(6, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(6, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_topo_stress_anomaly_Pa(6, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_topo_stress_anomaly_Pa(6, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_topo_stress_anomaly_Pa(6, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_topo_stress_anomaly_Pa(6, ix2, jy2, kz2) ELSE IF (choice == 2) THEN ! tectonic stress anomaly xyz_tensor(1, 1) = fx1 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(1, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(1, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(1, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(1, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(1, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(1, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(1, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(1, ix2, jy2, kz2) xyz_tensor(2, 2) = fx1 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(2, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(2, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(2, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(2, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(2, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(2, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(2, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(2, ix2, jy2, kz2) xyz_tensor(3, 3) = fx1 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(3, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(3, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(3, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(3, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(3, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(3, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(3, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(3, ix2, jy2, kz2) xyz_tensor(2, 3) = fx1 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(4, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(4, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(4, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(4, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(4, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(4, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(4, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(4, ix2, jy2, kz2) xyz_tensor(1, 3) = fx1 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(5, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(5, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(5, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(5, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(5, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(5, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(5, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(5, ix2, jy2, kz2) xyz_tensor(1, 2) = fx1 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(6, ix1, jy1, kz1) + & & fx1 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(6, ix1, jy1, kz2) + & & fx1 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(6, ix1, jy2, kz1) + & & fx1 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(6, ix1, jy2, kz2) + & & fx2 * fy1 * fz1 * fmrt_tectonic_stress_anomaly_Pa(6, ix2, jy1, kz1) + & & fx2 * fy1 * fz2 * fmrt_tectonic_stress_anomaly_Pa(6, ix2, jy1, kz2) + & & fx2 * fy2 * fz1 * fmrt_tectonic_stress_anomaly_Pa(6, ix2, jy2, kz1) + & & fx2 * fy2 * fz2 * fmrt_tectonic_stress_anomaly_Pa(6, ix2, jy2, kz2) ELSE IF (choice == 3) THEN xyz_tensor(1, 1) = fx1 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(1, ix1, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(1, ix1, jy1, kz1)) + & & fx1 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(1, ix1, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(1, ix1, jy1, kz2)) + & & fx1 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(1, ix1, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(1, ix1, jy2, kz1)) + & & fx1 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(1, ix1, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(1, ix1, jy2, kz2)) + & & fx2 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(1, ix2, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(1, ix2, jy1, kz1)) + & & fx2 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(1, ix2, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(1, ix2, jy1, kz2)) + & & fx2 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(1, ix2, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(1, ix2, jy2, kz1)) + & & fx2 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(1, ix2, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(1, ix2, jy2, kz2)) xyz_tensor(2, 2) = fx1 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(2, ix1, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(2, ix1, jy1, kz1)) + & & fx1 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(2, ix1, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(2, ix1, jy1, kz2)) + & & fx1 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(2, ix1, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(2, ix1, jy2, kz1)) + & & fx1 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(2, ix1, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(2, ix1, jy2, kz2)) + & & fx2 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(2, ix2, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(2, ix2, jy1, kz1)) + & & fx2 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(2, ix2, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(2, ix2, jy1, kz2)) + & & fx2 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(2, ix2, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(2, ix2, jy2, kz1)) + & & fx2 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(2, ix2, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(2, ix2, jy2, kz2)) xyz_tensor(3, 3) = fx1 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(3, ix1, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(3, ix1, jy1, kz1)) + & & fx1 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(3, ix1, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(3, ix1, jy1, kz2)) + & & fx1 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(3, ix1, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(3, ix1, jy2, kz1)) + & & fx1 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(3, ix1, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(3, ix1, jy2, kz2)) + & & fx2 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(3, ix2, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(3, ix2, jy1, kz1)) + & & fx2 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(3, ix2, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(3, ix2, jy1, kz2)) + & & fx2 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(3, ix2, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(3, ix2, jy2, kz1)) + & & fx2 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(3, ix2, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(3, ix2, jy2, kz2)) xyz_tensor(2, 3) = fx1 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(4, ix1, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(4, ix1, jy1, kz1)) + & & fx1 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(4, ix1, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(4, ix1, jy1, kz2)) + & & fx1 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(4, ix1, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(4, ix1, jy2, kz1)) + & & fx1 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(4, ix1, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(4, ix1, jy2, kz2)) + & & fx2 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(4, ix2, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(4, ix2, jy1, kz1)) + & & fx2 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(4, ix2, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(4, ix2, jy1, kz2)) + & & fx2 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(4, ix2, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(4, ix2, jy2, kz1)) + & & fx2 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(4, ix2, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(4, ix2, jy2, kz2)) xyz_tensor(1, 3) = fx1 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(5, ix1, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(5, ix1, jy1, kz1)) + & & fx1 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(5, ix1, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(5, ix1, jy1, kz2)) + & & fx1 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(5, ix1, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(5, ix1, jy2, kz1)) + & & fx1 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(5, ix1, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(5, ix1, jy2, kz2)) + & & fx2 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(5, ix2, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(5, ix2, jy1, kz1)) + & & fx2 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(5, ix2, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(5, ix2, jy1, kz2)) + & & fx2 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(5, ix2, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(5, ix2, jy2, kz1)) + & & fx2 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(5, ix2, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(5, ix2, jy2, kz2)) xyz_tensor(1, 2) = fx1 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(6, ix1, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(6, ix1, jy1, kz1)) + & & fx1 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(6, ix1, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(6, ix1, jy1, kz2)) + & & fx1 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(6, ix1, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(6, ix1, jy2, kz1)) + & & fx1 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(6, ix1, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(6, ix1, jy2, kz2)) + & & fx2 * fy1 * fz1 * (fmrt_topo_stress_anomaly_Pa(6, ix2, jy1, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(6, ix2, jy1, kz1)) + & & fx2 * fy1 * fz2 * (fmrt_topo_stress_anomaly_Pa(6, ix2, jy1, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(6, ix2, jy1, kz2)) + & & fx2 * fy2 * fz1 * (fmrt_topo_stress_anomaly_Pa(6, ix2, jy2, kz1) + & & fmrt_tectonic_stress_anomaly_Pa(6, ix2, jy2, kz1)) + & & fx2 * fy2 * fz2 * (fmrt_topo_stress_anomaly_Pa(6, ix2, jy2, kz2) + & & fmrt_tectonic_stress_anomaly_Pa(6, ix2, jy2, kz2)) ELSE ! illegal choice WRITE (*, "(' Illegal choice = ',I6,' in CALL Get_Stress_Tensor')") choice CALL Pause() success = .FALSE. xyz_tensor = 0.0D0 END IF ! choice == 1, 2, or 3 xyz_tensor(2, 1) = xyz_tensor(1, 2) ! by symmetry xyz_tensor(3, 1) = xyz_tensor(1, 3) xyz_tensor(3, 2) = xyz_tensor(2, 3) success = .TRUE. END IF ! outside or inside the model domain END SUBROUTINE Get_Stress_Tensor SUBROUTINE Histogram (real_list, list_length, skip_zeros, maximum, minimum) ! Puts a printer-plot on the default device, no more than ! (n15 + 2) rows tall by n70 bytes wide, showing the range and ! distribution of values within real_list. IMPLICIT NONE REAL*8, DIMENSION(:), INTENT(IN) :: real_list INTEGER, INTENT(IN) :: list_length LOGICAL, INTENT(IN) :: skip_zeros REAL*8, INTENT(OUT) :: maximum, minimum INTEGER, PARAMETER :: n15 = 15, n70 = 70 REAL*8, PARAMETER :: Huge = 9.99D37 CHARACTER*10 :: number10 CHARACTER*(n70) :: line INTEGER :: highest, i, j, length INTEGER, DIMENSION(:), ALLOCATABLE :: counters REAL*8 :: dx, factor IF (list_length < 1) RETURN IF (skip_zeros) THEN maximum = -Huge minimum = +Huge DO i = 1, list_length IF (real_list(i) /= 0.0D0) THEN maximum = MAX(maximum, real_list(i)) minimum = MIN(minimum, real_list(i)) END IF END DO ELSE maximum = real_list(1) minimum = maximum DO i = 2, list_length maximum = MAX(maximum, real_list(i)) minimum = MIN(minimum, real_list(i)) END DO END IF dx = (maximum - minimum) / (n70 - 1) IF (dx == 0.0D0) dx = 1.00D0 ! avoid divide-by-zero ALLOCATE ( counters(n70) ) counters = 0 ! whole array DO i = 1, list_length IF (skip_zeros) THEN IF (real_list(i) /= 0.0D0) THEN j = 1 + DInt_Below((real_list(i) - minimum) / dx) counters(j) = counters(j) + 1 END IF ELSE j = 1 + DInt_Below((real_list(i) - minimum) / dx) counters(j) = counters(j) + 1 END IF END DO highest = 0 DO j = 1, n70 highest = MAX(highest,counters(j)) END DO factor = (1.0D0 * n15) / (1.0D0 * highest) DO i = n15, 1, -1 ! rows, from top to bottom line = ' ' DO j = 1, n70 ! columns !In bottom row only, put "." to show non-zero contents: IF (i == 1) THEN ! bottom row IF (counters(j) > 0) line(j:j) = '.' END IF IF (NINT(factor * counters(j)) >= i) line(j:j) = '*' END DO ! columns WRITE (*,"(' ',A)") TRIM(line) END DO ! rows line = REPEAT('-',n70) WRITE (*,"(' ', A)") line number10 = DASCII10(minimum) line = TRIM(ADJUSTL(number10)) number10 = DASCII10(maximum) number10 = ADJUSTL(number10) length = LEN_TRIM(number10) line((n70 - length + 1):n70) = TRIM(number10) WRITE (*,"(' ', A)") line DEALLOCATE ( counters ) END SUBROUTINE Histogram SUBROUTINE Initialize() !Establishes suggested values for all the things the user will (or may) be prompted to enter. !First, an attempt is made to read them from NeoKinema.ini, if present in the home folder. !If not, defaults appropriate to study of the SCEC region in southern California are supplied. !Note that many of these values will be overwritten if a precomputed topographic and/or ! tectonic stress model is read from a file previously created by FlatMaxwell. IMPLICIT NONE !but liberal use is made of global-scope variables in the main program FlatMaxwell. INTEGER :: ios !Look for existing FlatMaxwell.ini in program's home directory ! (not the same as the current value of fmc132_path_in, but the directory/folder where FlatMaxwell.exe lives). OPEN (UNIT = 91, FILE = "FlatMaxwell.ini", STATUS = "OLD", PAD = "YES", IOSTAT = ios) IF (ios == 0) THEN ! successful OPEN of existing .INI READ (91, "(A)") fmc132_path_in fmc132_path_out = TRIM(fmc132_path_in) READ (91, *) fmi_new_or_old_topographic READ (91, *) fmi_projection_choice ! = 4 READ (91, *) fmr_radius_meters ! = 6371000. READ (91, *) fmr_projpoint_Elon ! = -118. READ (91, *) fmr_projpoint_Nlat ! = 34. READ (91, *) fmr_belt_azimuth_degrees ! = 90.0 READ (91, *) fmr_cone_lat ! = 90. READ (91, *) fmr_cone_lon ! = 0. READ (91, *) fmr_standard_parallel_gap_degrees ! = 30.0 READ (91, *) fmr_x_LENGTH_meters ! = 750000. READ (91, *) fmr_y_WIDTH_meters ! = 600000. READ (91, *) fmr_z_DEPTH_meters ! = 100000. ! intentionally deeper than mean LAB below READ (91, *) fmr_gravity ! = 9.7964938296 ! World Geodetic System 1984 (at 34 North) READ (91, *) fmr_1_bar ! = 101325. ! Wikipedia "Atmospheric pressure" 2013.10 READ (91, *) fmr_atmosphere_scale_height_meters ! = 8435. ! Wikipedia "Atmospheric pressure" 2013.10 READ (91, *) fmr_seawater_density ! = 1025. ! Wikipedia "Seawater" 2013.10 READ (91, *) fmr_Moho_depth ! = 25000. ! eyeball average of coastal values from Tape et al. [2012, SRL] READ (91, *) fmr_crustal_density_at_top ! = 2500. ! less than 2670 of shields due to sedimentary rocks READ (91, *) fmr_crustal_density_at_Moho ! = 2957. ! Hyndman & Drury (1977, DSDP37-13): MAR gabbro. READ (91, *) fmr_mantle_density_at_Moho ! = 3230. ! scaled from value below, density 3300 at 0 C, and Moho and LAB depths READ (91, *) fmr_mantle_density_at_LAB ! = 3125. ! my ESS 246 lecture notes on "Density Moments" READ (91, *) fmr_LAB_depth ! = 63000. ! rough visual average from SHELLS_for_CSM-unfaulted_OrbData.feg, 2012 READ (91, "(A)") fmc80_DEM_filename ! = "ETOPO5.grd" READ (91, *) fmi_new_or_old_Moho ! = 2 ! using seismic Moho from Carl Tape READ (91, "(A)") fmc80_Moho_filename ! = "Tape_et_al_2012_seismic_Moho.grd" READ (91, *) fmr_vertical_resolution_m ! = 2500. ! fine vertical resolution is needed because seismogenic zone may be only 10~15 km deep. READ (91, *) fmr_horizontal_resolution_m ! = 20000. ! good for graphics; at finer lateral resolution, too many tiny symbols! READ (91, *) fmr_Poisson_ratio ! = 0.25 !---- end of topographic model parameters; beginning tectonic model parameters ------- READ (91, *) fmi_new_or_old_tectonic ! = 1 READ (91, *) fmi_tectonic_model_mode ! = 2 ! fit to WSM data *AND* existing CSM model READ (91, *) fmd_WSM_group_weight ! = 0.5D0 READ (91, *) fmi_waves ! = 4 ! probably requires ~12 hours on a 16x parallel computer. READ (91, "(A)") fmc80_CSM_model_filename ! = "SHELLS_for_CSM_expanded_regridded.txt" READ (91, "(A)") fmc80_WSM_data_filename ! = "wsm2008.csv" !------------- misfit-measures section follows: -------------------------------- READ (91, *) fml_do_scoring_vs_data ! = .TRUE. ! (quick) READ (91, *) fml_do_scoring_vs_model ! = .TRUE. ! (time-consuming, but valuable) !------------- graphical output section follows: ---------------------------- READ (91, *) fmi_output_menu_choice ! = 1 READ (91, *) fmi_unit_choice ! = 2 READ (91, *) fmr_map_paper_width_points ! = 11. * 72. READ (91, *) fmr_map_paper_height_points ! = 8.5 * 72. READ (91, *) fml_black ! = .FALSE. READ (91, *) fmr_top_margin_points ! = 18. READ (91, *) fmr_left_margin_points ! = 18. READ (91, *) fmr_right_margin_points ! = 18. READ (91, *) fmr_bottom_margin_points ! = 18. ! Result: Suggested map scale denominator will be 3574000. READ (91, *) fml_plan_top_titles ! = .TRUE. READ (91, *) fml_plan_rightlegend ! = .TRUE. READ (91, *) fml_plan_bottomlegend ! = .FALSE. READ (91, *) fml_using_color ! = .TRUE. READ (91, *) fmc80_model_AI_filename ! = "AI7Frame.ai" READ (91, *) fmc80_new_AI_filename ! = "FlatMaxwell_map.ai" READ (91, *) fmi_minutes ! = 60 READ (91, *) fmr_section_pin_Elon ! = fmr_projpoint_Elon READ (91, *) fmr_section_pin_Nlat ! = fmr_projpoint_Nlat READ (91, *) fmr_section_azimuth_degrees ! = 90. READ (91, "(A)") fmc1_section_letter ! = 'A' READ (91, *) fmr_section_paper_width_points ! = 14. * 72. READ (91, *) fmr_section_paper_height_points ! = 8.5 * 72. READ (91, *) fml_plan_section_top_titles ! = .TRUE. READ (91, *) fml_plan_section_rightlegend ! = .FALSE. READ (91, *) fml_plan_section_bottomlegend ! = .TRUE. READ (91, *) fmr_borehole_latitude READ (91, *) fmr_borehole_longitude CLOSE (UNIT = 91, DISP = "KEEP") ELSE ! OPEN failed; use standard defaults instead: fmc132_path_in = 'C:\temp\testbed\' fmc132_path_out = TRIM(fmc132_path_in) fmi_new_or_old_topographic = 1 ! new topographic-stress to be computed fmi_projection_choice = 4 fmr_radius_meters = 6371000.0D0 fmr_projpoint_Elon = -118.0D0 fmr_projpoint_Nlat = 34.0D0 fmr_belt_azimuth_degrees = 90.0D0 fmr_cone_lat = 90.0D0 fmr_cone_lon = 0.0D0 fmr_standard_parallel_gap_degrees = 30.0D0 fmr_x_LENGTH_meters = 750000.0D0 fmr_y_WIDTH_meters = 600000.0D0 fmr_z_DEPTH_meters = 100000.0D0 ! intentionally deeper than mean LAB below fmr_gravity = 9.7964938296D0 ! World Geodetic System 1984 (at 34 North) fmr_1_bar = 101325.0D0 ! Wikipedia "Atmospheric pressure" 2013.10 fmr_atmosphere_scale_height_meters = 8435.0D0 ! Wikipedia "Atmospheric pressure" 2013.10 fmr_seawater_density = 1025.0D0 ! Wikipedia "Seawater" 2013.10 fmr_Moho_depth = 25000.0D0 ! eyeball average of coastal values from Tape et al. [2012, SRL] fmr_crustal_density_at_top = 2500.0D0 ! less than 2670 of shields due to sedimentary rocks fmr_crustal_density_at_Moho = 2957.0D0 ! Hyndman & Drury (1977, DSDP37-13): MAR gabbro. fmr_mantle_density_at_Moho = 3230.0D0 ! scaled from value below, density 3300 at 0 C, and Moho and LAB depths fmr_mantle_density_at_LAB = 3125.0D0 ! my ESS 246 lecture notes on "Density Moments" fmr_LAB_depth = 63000.0D0 ! rough visual average from SHELLS_for_CSM-unfaulted_OrbData.feg, 2012 fmc80_DEM_filename = "ETOPO5.grd" fmi_new_or_old_Moho = 1 ! computing isostatic Moho; NOT using seismic Moho from Carl Tape fmc80_Moho_filename = "Tape_et_al_2012_seismic_Moho.grd" fmr_vertical_resolution_m = 2500.0D0 ! fine vertical resolution is needed because seismogenic zone may be only 10~15 km deep. fmr_horizontal_resolution_m = 20000.0D0 ! good for graphics; at finer lateral resolution, too many tiny symbols! fmr_Poisson_ratio = 0.5D0 ! representative(?) of long-term solutions in halfspaces which are actually VISCOelastic. !---- end of topographic model parameters; beginning tectonic model parameters ------- fmi_new_or_old_tectonic = 1 fmi_tectonic_model_mode = 2 ! fit to WSM data *AND* existing CSM model fmd_WSM_group_weight = 0.5D0 fmi_waves = 4 ! probably requires ~12 hours on a 16x parallel computer. fmc80_CSM_model_filename = "SHELLS_for_CSM_expanded_regridded_randomized.txt" fmc80_WSM_data_filename = "wsm2008.csv" !------------- misfit-measures section follows: -------------------------------- fml_do_scoring_vs_data = .TRUE. ! (quick) fml_do_scoring_vs_model = .TRUE. ! (time-consuming, but valuable) !------------- graphical output section follows: ---------------------------- fmi_output_menu_choice = 1 fmi_unit_choice = 2 fmr_map_paper_width_points = 11.0D0 * 72.0D0 fmr_map_paper_height_points = 8.5D0 * 72.0D0 fml_black = .FALSE. fmr_top_margin_points = 18.0D0 fmr_left_margin_points = 18.0D0 fmr_right_margin_points = 18.0D0 fmr_bottom_margin_points = 18.0D0 ! Result: Suggested map scale denominator will be 3574000. fml_plan_top_titles = .TRUE. fml_plan_rightlegend = .TRUE. fml_plan_bottomlegend = .FALSE. fml_using_color = .TRUE. fmc80_model_AI_filename = "AI7Frame.ai" fmc80_new_AI_filename = "FlatMaxwell_map.ai" fmi_minutes = 60 fmr_section_pin_Elon = fmr_projpoint_Elon fmr_section_pin_Nlat = fmr_projpoint_Nlat fmr_section_azimuth_degrees = 90.0D0 fmc1_section_letter = 'A' fmr_section_paper_width_points = 14.0D0 * 72.0D0 fmr_section_paper_height_points = 8.5D0 * 72.0D0 fml_plan_section_top_titles = .TRUE. fml_plan_section_rightlegend = .FALSE. fml_plan_section_bottomlegend = .TRUE. fmr_borehole_latitude = 34.1D0 fmr_borehole_longitude = -118.4D0 END IF ! Attempted OPEN of FlatMaxwell.ini succeeded, or failed? END SUBROUTINE Initialize SUBROUTINE Map_Type(projection_choice, projection_name) IMPLICIT NONE INTEGER, INTENT(IN) :: projection_choice CHARACTER*43, INTENT(OUT) :: projection_name SELECT CASE (projection_choice) CASE (0); projection_name = 'None; to plot (x,y) data without conversion' CASE (1); projection_name = 'Mercator' CASE (2); projection_name = 'Lambert Conformal Conic' CASE (3); projection_name = 'Albers Equal-Area Conic' CASE (4); projection_name = 'Polyconic' CASE (5); projection_name = 'Geometric Conic' CASE (6); projection_name = 'Stereographic' CASE (7); projection_name = 'Lambert Azimuthal Equal-Area' CASE (8); projection_name = 'Azimuthal Equidistant' CASE (9); projection_name = 'Orthographic' CASE (10); projection_name = 'Gnomonic' END SELECT END SUBROUTINE Map_Type ! contained in Prompter SUBROUTINE Mean_Tectonic_Stress() !Called after computation of tau on the 3-D grid, this routine !computes the average and reports it to the user. !Note that the mean is not the same as the spatially-constant tau !described by the first 6 coefficients, because some of the following !basis functions do NOT have zero means, even though they oscillate. IMPLICIT NONE INTEGER :: i, j, k, m, plunge_int, trend_int LOGICAL :: axes_defined REAL*8 :: denominator, factor, horizontal REAL*8, DIMENSION(3) :: eigenvalues, plunge_radians, trend_radians REAL*8, DIMENSION(6) :: total_xyz_tensor REAL*8, DIMENSION(3, 3) :: eigenvectors, mean_tau_xyz_tensor denominator = 0.0D0 total_xyz_tensor = 0.0D0 DO i = -fmi_topo_nx, fmi_topo_nx DO j = -fmi_topo_ny, fmi_topo_ny DO k = -fmi_topo_nz, fmi_topo_nz factor = 1.0D0 IF ((i == -fmi_topo_nx).OR.(i == fmi_topo_nx)) factor = factor / 2.0D0 IF ((j == -fmi_topo_ny).OR.(j == fmi_topo_ny)) factor = factor / 2.0D0 IF ((k == -fmi_topo_nz).OR.(k == fmi_topo_nz)) factor = factor / 2.0D0 denominator = denominator + factor total_xyz_tensor(1:6) = total_xyz_tensor(1:6) + factor * fmrt_tectonic_stress_anomaly_Pa(1:6, i, j, k) END DO END DO END DO total_xyz_tensor = total_xyz_tensor / denominator mean_tau_xyz_tensor(1, 1) = total_xyz_tensor(1) mean_tau_xyz_tensor(2, 2) = total_xyz_tensor(2) mean_tau_xyz_tensor(3, 3) = total_xyz_tensor(3) mean_tau_xyz_tensor(2, 3) = total_xyz_tensor(4) mean_tau_xyz_tensor(1, 3) = total_xyz_tensor(5) mean_tau_xyz_tensor(1, 2) = total_xyz_tensor(6) mean_tau_xyz_tensor(3, 2) = mean_tau_xyz_tensor(2, 3) mean_tau_xyz_tensor(3, 1) = mean_tau_xyz_tensor(1, 3) mean_tau_xyz_tensor(2, 1) = mean_tau_xyz_tensor(1, 2) CALL Eigenanalysis_3x3(mean_tau_xyz_tensor, eigenvalues, eigenvectors) axes_defined = (eigenvalues(1) /= eigenvalues(2)).OR.(eigenvalues(2) /= eigenvalues(3)) ! otherwise, just isotropic Pressure, or all-ZERO! IF (axes_defined) THEN !Find trend and plunge of each principal axis. !Note that Eigenanalysis_3x3 returns eigenvalue(1) <= eigenvalue(2) <= eigenvalue(3), !so that k = 1, 2, 3 corresponds to s1, s2, s3. DO k = 1, 3 IF (eigenvectors(3, k) <= 0.0D0) THEN trend_radians(k) = DATAN2F(eigenvectors(1, k), eigenvectors(2, k)) ELSE trend_radians(k) = DATAN2F(-eigenvectors(1, k), -eigenvectors(2, k)) END IF !These trends are relative to North; they are measured clockwise in radians. !I always choose the trend (sense) as the direction with positive plunge. horizontal = DSQRT((eigenvectors(1, k)**2) + (eigenvectors(2, k)**2)) plunge_radians(k) = DATan2F(ABS(eigenvectors(3, k)), horizontal) ! both arguments non-negative !These plunges are measured downward from horizontal in radians, and will always be positive (or zero). END DO WRITE (*, *) WRITE (*, "(' Mean tectonic stress anomaly (averaging each component separately)')") WRITE (*, "(' in the model volume (including any modeled asthenosphere) is:')") DO m = 1, 3 trend_int = NINT(trend_radians(m)*degrees_per_radian) IF (trend_int < 0) trend_int = trend_int + 360 plunge_int = NINT(plunge_radians(m)*degrees_per_radian) IF (eigenvalues(m) <= 0.0D0) THEN WRITE (*, "(' ',F10.3,' MPa (compressive) trending ',I3,' and plunging ',I2)") eigenvalues(m)/1.E6, trend_int, plunge_int ELSE WRITE (*, "(' ',F10.3,' MPa (tensional) trending ',I3,' and plunging ',I2)") eigenvalues(m)/1.E6, trend_int, plunge_int END IF END DO CALL Pause() END IF ! axes_defined END SUBROUTINE Mean_Tectonic_Stress SUBROUTINE Misfits_wrt_CSM_Model() IMPLICIT NONE !but makes free use of global variables from FlatMaxwell, such as: ! fmtv_CSM_model (huge vector of TYPE(CSM_model) data points); and ! fmi_CSM_points_in_box (data count in this vector). INTEGER :: angular_error_denominator, bad_regimes_denominator, bad_regimes_numerator, & & i, iTrain, k, m, old_percent_complete, percent_complete, shear_stress_error_denominator INTEGER*2, DIMENSION(4) :: orientation1, orientation2 LOGICAL :: CSM_axes_defined, FM_axes_defined, match, success REAL*8 :: argument_000_radians, azimuth_correction_radians, & & bad_regimes_percent, & & CSM_P_Pa, & & error_MPa, error_Pa, & & FM_P_Pa, & & horizontal, & & latitude, longitude, & & maximum, mean_angular_error, mean_shear_stress_error, minimum, model_shear_stress, & & reference_P_Pa, RMS_angular_error, RMS_shear_stress_error, & & s1_azimuth_degrees, s1_Pa, s1_plunge_degrees, s3_azimuth_degrees, s3_Pa, s3_plunge_degrees, shear_stress, & & x_meters, y_meters, z_meters REAL*8, DIMENSION(3) :: eigenvalues_CSM, eigenvalues_FM, plunge_radians_CSM, plunge_radians_FM, trend_radians_CSM, trend_radians_FM REAL*8, DIMENSION(3, 3) :: CSM_deviatoric_ENr_tensor, eigenvectors, ENr_tensor_Pa, & & FM_anomaly_xyz_tensor, FM_deviatoric_xyz_tensor, FM_stress_xyz_tensor, & & mu_xyz_tensor, tau_xyz_tensor REAL*8, DIMENSION(:), ALLOCATABLE :: train DOUBLE PRECISION :: mean_angular_error_numerator, mean_shear_stress_error_numerator, minimum_angle, & & RMS_angular_error_numerator, RMS_shear_stress_error_numerator DOUBLE PRECISION, DIMENSION(6) :: mean_component_error_numerator, RMS_component_error_numerator angular_error_denominator = 0 mean_angular_error_numerator = 0.0D0 RMS_angular_error_numerator = 0.0D0 bad_regimes_numerator = 0 bad_regimes_denominator = 0 shear_stress_error_denominator = 0 mean_shear_stress_error_numerator = 0.0D0 RMS_shear_stress_error_numerator = 0.0D0 mean_component_error_numerator = 0.0D0 RMS_component_error_numerator = 0.0D0 old_percent_complete = -1 WRITE (*, "(' Beginning detailed comparison of current stress model with older CSM model...')") WRITE (*, *) ALLOCATE ( train(fmi_CSM_points_in_box) ) ! even though not all of this will be used... iTrain = 0 DO i = 1, fmi_CSM_points_in_box ! ---- Determine CSM-model stress tensor and its principal directions and maximum shear stress: -------------------------- ENr_tensor_Pa(1:3, 1:3) = fmtv_CSM_model(i)%ENr_tensor_Pa(1:3, 1:3) CALL Eigenanalysis_3x3(ENr_tensor_Pa, eigenvalues_CSM, eigenvectors) CSM_P_Pa = -(ENR_tensor_Pa(1,1) + ENr_tensor_Pa(2,2) + ENr_tensor_Pa(3,3)) / 3.0D0 CSM_deviatoric_ENr_tensor = ENr_tensor_Pa ! except for diagonal, ... CSM_deviatoric_ENr_tensor(1,1) = CSM_deviatoric_ENr_tensor(1,1) + CSM_P_Pa CSM_deviatoric_ENr_tensor(2,2) = CSM_deviatoric_ENr_tensor(2,2) + CSM_P_Pa CSM_deviatoric_ENr_tensor(3,3) = CSM_deviatoric_ENr_tensor(3,3) + CSM_P_Pa CSM_axes_defined = (eigenvalues_CSM(1) < eigenvalues_CSM(2)).AND.(eigenvalues_CSM(2) < eigenvalues_CSM(3)) ! otherwise, just isotropic Pressure! IF (CSM_axes_defined) THEN !Find trend and plunge of each principal axis. !Note that Eigenanalysis_3x3 returns eigenvalue(1) <= eigenvalue(2) <= eigenvalue(3), !so that k = 1, 2, 3 corresponds to s1, s2, s3. DO k = 1, 3 IF (eigenvectors(3, k) <= 0.0D0) THEN trend_radians_CSM(k) = DATan2F(eigenvectors(1, k), eigenvectors(2, k)) ELSE trend_radians_CSM(k) = DATan2F(-eigenvectors(1, k), -eigenvectors(2, k)) END IF !These trends are relative to North; they are measured clockwise in radians. !I always choose the trend (sense) as the direction with positive plunge. horizontal = DSQRT((eigenvectors(1, k)**2) + (eigenvectors(2, k)**2)) plunge_radians_CSM(k) = DATan2F(ABS(eigenvectors(3, k)), horizontal) ! both arguments non-negative !These plunge are measured downward from horizontal in radians, and will always be positive (or zero). END DO orientation1(1) = NINT(plunge_radians_CSM(3) * degrees_per_radian) orientation1(2) = NINT(trend_radians_CSM(3) * degrees_per_radian) orientation1(3) = NINT(plunge_radians_CSM(1) * degrees_per_radian) orientation1(4) = NINT(trend_radians_CSM(1) * degrees_per_radian) END IF ! CSM_axes_defined ! ---- Determine FM-model stress anomaly tensor and its principal directions and maximum shear stress: -------------------------- x_meters = fmtv_CSM_model(i)%x_meters y_meters = fmtv_CSM_model(i)%y_meters z_meters = fmtv_CSM_model(i)%z_meters !First, the topographic part: CALL Get_Stress_Tensor(x = x_meters, y = y_meters, z = z_meters, choice = 1, success = success, xyz_tensor = mu_xyz_tensor) IF (.NOT.success) THEN WRITE (*, "(' ERROR: Get_Stress_Tensor does not succeed, for (x, y, z) point pre-screened to be in model box.')") CALL Pause() STOP END IF ! unlikely failure mode !Second, the tectonic part: CALL Tectonic_Stress_at_Point(x_meters = x_meters, y_meters = y_meters, z_meters = z_meters, xyz_tensor = tau_xyz_tensor) !Add together to get the full (FlatMaxwell model) stress anomaly tensor in xyz coordinates, in Pa: FM_anomaly_xyz_tensor = mu_xyz_tensor + tau_xyz_tensor !Add reference pressure to get full FM model stress tensor, still in xyz system: reference_P_Pa = P0_Pressure_in_Pa(z_meters) FM_stress_xyz_tensor = FM_anomaly_xyz_tensor ! except for diagonal, ... FM_stress_xyz_tensor(1,1) = FM_stress_xyz_tensor(1,1) - reference_P_Pa FM_stress_xyz_tensor(2,2) = FM_stress_xyz_tensor(2,2) - reference_P_Pa FM_stress_xyz_tensor(3,3) = FM_stress_xyz_tensor(3,3) - reference_P_Pa FM_P_Pa = -(FM_stress_xyz_tensor(1,1) + FM_stress_xyz_tensor(2,2) + FM_stress_xyz_tensor(3,3)) / 3.0D0 FM_deviatoric_xyz_tensor = FM_stress_xyz_tensor ! except for diagonal, ... FM_deviatoric_xyz_tensor(1,1) = FM_deviatoric_xyz_tensor(1,1) + FM_P_Pa FM_deviatoric_xyz_tensor(2,2) = FM_deviatoric_xyz_tensor(2,2) + FM_P_Pa FM_deviatoric_xyz_tensor(3,3) = FM_deviatoric_xyz_tensor(3,3) + FM_P_Pa CALL Eigenanalysis_3x3(FM_anomaly_xyz_tensor, eigenvalues_FM, eigenvectors) FM_axes_defined = (eigenvalues_FM(1) < eigenvalues_FM(2)).AND.(eigenvalues_FM(2) < eigenvalues_FM(3)) ! otherwise, just isotropic Pressure! IF (FM_axes_defined) THEN !Find trend and plunge of each principal axis. !Note that Eigenanalysis_3x3 returns eigenvalue(1) <= eigenvalue(2) <= eigenvalue(3), !so that k = 1, 2, 3 corresponds to s1, s2, s3. DO k = 1, 3 IF (eigenvectors(3, k) <= 0.0D0) THEN trend_radians_FM(k) = DATan2F(eigenvectors(1, k), eigenvectors(2, k)) ELSE trend_radians_FM(k) = DATan2F(-eigenvectors(1, k), -eigenvectors(2, k)) END IF !These trends are relative to FlatMaxwell axis +y, which is also plot axis +y (up on map sheet); !they are NOT relative to local North. They are measured clockwise in radians. !I always choose the trend (sense) as the direction with positive plunge. horizontal = DSQRT((eigenvectors(1, k)**2) + (eigenvectors(2, k)**2)) plunge_radians_FM(k) = DATan2F(ABS(eigenvectors(3, k)), horizontal) ! both arguments non-negative !These plunges are relative to the FlatMaxwell (x, y) plane, which is the surface of the projected flat-Earth. !They are measured downward from horizontal in radians, and will always be positive (or zero). END DO !correct azimuths of model principal stresses from (x, y) system to (E, N) system: longitude = fmtv_CSM_model(i)%Elon latitude = fmtv_CSM_model(i)%Nlat CALL Argument_of_North(longitude, latitude, argument_000_radians) azimuth_correction_radians = argument_000_radians - Pi_over_2 orientation2(1) = NINT(plunge_radians_FM(3) * degrees_per_radian) orientation2(2) = NINT((trend_radians_FM(3) + azimuth_correction_radians) * degrees_per_radian) orientation2(3) = NINT(plunge_radians_FM(1) * degrees_per_radian) orientation2(4) = NINT((trend_radians_FM(1) + azimuth_correction_radians) * degrees_per_radian) END IF ! FM_axes_defined !compare deviatoric stresses by individual components: ---------------------------------------------- error_Pa = ABS( CSM_deviatoric_ENr_tensor(1,1) - FM_deviatoric_xyz_tensor(1,1) ) ! (ignoring small rotations in 1st draft) mean_component_error_numerator(1) = mean_component_error_numerator(1) + error_Pa RMS_component_error_numerator(1) = RMS_component_error_numerator(1) + error_Pa**2 error_Pa = ABS( CSM_deviatoric_ENr_tensor(2,2) - FM_deviatoric_xyz_tensor(2,2) ) ! (ignoring small rotations in 1st draft) mean_component_error_numerator(2) = mean_component_error_numerator(2) + error_Pa RMS_component_error_numerator(2) = RMS_component_error_numerator(2) + error_Pa**2 error_Pa = ABS( CSM_deviatoric_ENr_tensor(3,3) - FM_deviatoric_xyz_tensor(3,3) ) ! (ignoring small rotations in 1st draft) mean_component_error_numerator(3) = mean_component_error_numerator(3) + error_Pa RMS_component_error_numerator(3) = RMS_component_error_numerator(3) + error_Pa**2 error_Pa = ABS( CSM_deviatoric_ENr_tensor(2,3) - FM_deviatoric_xyz_tensor(2,3) ) ! (ignoring small rotations in 1st draft) mean_component_error_numerator(4) = mean_component_error_numerator(4) + error_Pa RMS_component_error_numerator(4) = RMS_component_error_numerator(4) + error_Pa**2 error_Pa = ABS( CSM_deviatoric_ENr_tensor(1,3) - FM_deviatoric_xyz_tensor(1,3) ) ! (ignoring small rotations in 1st draft) mean_component_error_numerator(5) = mean_component_error_numerator(5) + error_Pa RMS_component_error_numerator(5) = RMS_component_error_numerator(5) + error_Pa**2 error_Pa = ABS( CSM_deviatoric_ENr_tensor(1,2) - FM_deviatoric_xyz_tensor(1,2) ) ! (ignoring small rotations in 1st draft) mean_component_error_numerator(6) = mean_component_error_numerator(6) + error_Pa RMS_component_error_numerator(6) = RMS_component_error_numerator(6) + error_Pa**2 !compare orientations and sum the angular errors: ---------------------------------------------------- IF (CSM_axes_defined.AND.FM_axes_defined) THEN angular_error_denominator = angular_error_denominator + 1 minimum_angle = DCROT(orientation1, orientation2) iTrain = iTrain + 1 train(iTrain) = minimum_angle mean_angular_error_numerator = mean_angular_error_numerator + minimum_angle RMS_angular_error_numerator = RMS_angular_error_numerator + (minimum_angle**2) !compare stress regimes: ---------------------------------------------------------------------------- IF ((plunge_radians_CSM(1) > plunge_radians_CSM(2)).AND. & & (plunge_radians_CSM(1) > plunge_radians_CSM(3))) THEN ! s1_CSM most vertical; normal faulting in CSM match = (plunge_radians_FM(1) > plunge_radians_FM(2)).AND. & & (plunge_radians_FM(1) > plunge_radians_FM(3)) ELSE IF ((plunge_radians_CSM(3) > plunge_radians_CSM(1)).AND. & & (plunge_radians_CSM(3) > plunge_radians_CSM(2))) THEN ! s3_CSM most vertical; thrust faulting in CSM match = (plunge_radians_FM(3) > plunge_radians_FM(1)).AND. & & (plunge_radians_FM(3) > plunge_radians_FM(2)) ELSE ! strike-slip faulting in CSM: match = (plunge_radians_FM(2) > plunge_radians_FM(1)).AND. & & (plunge_radians_FM(2) > plunge_radians_FM(3)) END IF ! normal, thrust, or strike-slip regime in CSM bad_regimes_denominator = bad_regimes_denominator + 1 IF (.NOT.match) bad_regimes_numerator = bad_regimes_numerator + 1 END IF ! CSM_axes_defined.AND.FM_axes_defined (If not, then only shear-stress magnitude can be compared, below...) !compare stress magnitudes: -------------------------------------------------------------------------- shear_stress = 0.5D0 * ABS(eigenvalues_CSM(3) - eigenvalues_CSM(1)) ! temporarily treating CSM model as "truth" or "data" model_shear_stress = 0.5D0 * ABS(eigenvalues_FM(3) - eigenvalues_FM(1)) ! in the current FlatMaxwell stress model shear_stress_error_denominator = shear_stress_error_denominator + 1 mean_shear_stress_error_numerator = mean_shear_stress_error_numerator + ABS(model_shear_stress - shear_stress) RMS_shear_stress_error_numerator = RMS_shear_stress_error_numerator + ((model_shear_stress - shear_stress)**2) !describe progress for the (im)patient user.... ------------------------------------------------------ percent_complete = NINT((100.0D0 * i) / (1.0D0 * fmi_CSM_points_in_box)) IF (percent_complete > old_percent_complete) THEN WRITE (*, "('+ ',I3,'% done...')") percent_complete old_percent_complete = percent_complete END IF ! printing 1% done... END DO ! i = 1, fmi_CSM_points_in_box !----- report overall misfit measures: ----------------------------------------------------------------- WRITE (*, *) mean_component_error_numerator = 1.0D-6 * mean_component_error_numerator / fmi_CSM_points_in_box ! all 6 RMS_component_error_numerator = 1.0D-6 * DSQRT(RMS_component_error_numerator / fmi_CSM_points_in_box) ! all 6 WRITE (*, "(' Deviatoric stress error, in MPa, by component: Mean RMS')") DO i = 1, 6 WRITE (*, "(' i = ',I1,':',2F10.2)") i, mean_component_error_numerator(i), RMS_component_error_numerator(i) END DO CALL Pause() IF (angular_error_denominator == 0) THEN WRITE (*, "(' No stress orientations found in data, so no angular-error scoring performed.')") ELSE ! normal case CALL Histogram (real_list = train, list_length = iTrain, skip_zeros = .FALSE., maximum = maximum, minimum = minimum) DEALLOCATE( train ) mean_angular_error = mean_angular_error_numerator / angular_error_denominator RMS_angular_error = DSQRT(RMS_angular_error_numerator / angular_error_denominator) WRITE (*, *) WRITE (*, "(' Based on ',I8,' stress orientation data in model domain,')") angular_error_denominator WRITE (*, "(' Mean angular error = ',F10.2,' degrees.')") mean_angular_error WRITE (*, "(' RMS angular error = ',F10.2,' degrees.')") RMS_angular_error CALL Pause() END IF IF (bad_regimes_denominator == 0) THEN WRITE (*, *) WRITE (*, "(' No stress regimes found in data, so no %-bad_regimes scoring performed.')") ELSE ! normal case bad_regimes_percent = (100.0D0 * bad_regimes_numerator) / bad_regimes_denominator WRITE (*, *) WRITE (*, "(' Based on ',I8,' stress regime data in model domain,')") bad_regimes_denominator WRITE (*, "(' Incorrect stress regimes = ',F6.2,'%.')") bad_regimes_percent CALL Pause() END IF IF (shear_stress_error_denominator == 0) THEN WRITE (*, "(' No stress magnitudes found in data, so no shear-stress-error scoring performed.')") ELSE ! normal case mean_shear_stress_error = mean_shear_stress_error_numerator / shear_stress_error_denominator RMS_shear_stress_error = DSQRT(RMS_shear_stress_error_numerator / shear_stress_error_denominator) WRITE (*, *) WRITE (*, "(' Based on ',I8,' stress magnitude data in model domain,')") shear_stress_error_denominator WRITE (*, "(' Mean shear-stress error = ',ES10.2,' Pa, or ',F10.2,' MPa.')") mean_shear_stress_error, (mean_shear_stress_error * 1.E-6) WRITE (*, "(' RMS shear-stress error = ',ES10.2,' Pa, or ',F10.2,' MPa.')") RMS_shear_stress_error, (RMS_shear_stress_error * 1.E-6) CALL Pause() END IF END SUBROUTINE Misfits_wrt_CSM_Model SUBROUTINE Misfits_wrt_Data() IMPLICIT NONE !but makes frequent use of global data in FlatMaxwell. CHARACTER*2 :: c2 INTEGER :: angular_error_denominator, bad_regimes_denominator, bad_regimes_numerator, & & i, k, m, shear_stress_error_denominator INTEGER*2, DIMENSION(4) :: orientation1, orientation2 LOGICAL :: match, success REAL*8 :: argument_000_radians, azimuth_correction_radians, & & bad_regimes_percent, & & horizontal, & & latitude, longitude, & & mean_angular_error, mean_shear_stress_error, model_shear_stress, & & RMS_angular_error, RMS_shear_stress_error, & & s1_azimuth_degrees, s1_Pa, s1_plunge_degrees, s3_azimuth_degrees, s3_Pa, s3_plunge_degrees, shear_stress, & & x_meters, y_meters, z_meters REAL*8, DIMENSION(3) :: eigenvalues, plunge_radians, trend_radians REAL*8, DIMENSION(3, 3) :: eigenvectors, FM_anomaly_xyz_tensor, mu_xyz_tensor, tau_xyz_tensor, xyz_tensor DOUBLE PRECISION :: mean_angular_error_numerator, mean_shear_stress_error_numerator, minimum_angle, & & RMS_angular_error_numerator, RMS_shear_stress_error_numerator !Evaluate measures of ANGULAR ERROR: ------------------------------ angular_error_denominator = 0 ! just initializing this integer count mean_angular_error_numerator = 0.0D0 RMS_angular_error_numerator = 0.0D0 DO i = 1, fmi_sites_in_box s1_azimuth_degrees = fmtv_stress_data(i)%s1_azimuth_deg s1_plunge_degrees = fmtv_stress_data(i)%s1_plunge_deg s3_azimuth_degrees = fmtv_stress_data(i)%s3_azimuth_deg s3_plunge_degrees = fmtv_stress_data(i)%s3_plunge_deg IF ((s1_azimuth_degrees >= 0.0D0).AND.(s1_plunge_degrees >= 0.0D0).AND.(s3_azimuth_degrees >= 0.0D0).AND.(s3_plunge_degrees >= 0.0D0)) THEN !data (e.g., from World Stress Map FPS): orientation1(1) = NINT(s3_plunge_degrees) orientation1(2) = NINT(s3_azimuth_degrees) orientation1(3) = NINT(s1_plunge_degrees) orientation1(4) = NINT(s1_azimuth_degrees) !model (total stress): x_meters = fmtv_stress_data(i)%x_meters y_meters = fmtv_stress_data(i)%y_meters z_meters = fmtv_stress_data(i)%z_meters !First, the topographic part of the model: CALL Get_Stress_Tensor(x = x_meters, y = y_meters, z = z_meters, choice = 1, success = success, xyz_tensor = mu_xyz_tensor) IF (.NOT.success) THEN WRITE (*, "(' ERROR: Get_Stress_Tensor does not succeed, for (x, y, z) point pre-screened to be in model box.')") CALL Pause() STOP END IF ! unlikely failure mode !Second, the teconic part of the model: CALL Tectonic_Stress_at_Point(x_meters = x_meters, y_meters = y_meters, z_meters = z_meters, xyz_tensor = tau_xyz_tensor) !Add together to get the full (FlatMaxwell model) stress anomaly tensor in xyz coordinates, in Pa: FM_anomaly_xyz_tensor = mu_xyz_tensor + tau_xyz_tensor CALL Eigenanalysis_3x3(FM_anomaly_xyz_tensor, eigenvalues, eigenvectors) !Find trend and plunge of each principal axis. !Note that Eigenanalysis_3x3 returns eigenvalue(1) <= eigenvalue(2) <= eigenvalue(3), !so that k = 1, 2, 3 corresponds to s1, s2, s3. DO k = 1, 3 IF (eigenvectors(3, k) <= 0.0D0) THEN trend_radians(k) = DATan2F(eigenvectors(1, k), eigenvectors(2, k)) ELSE trend_radians(k) = DATan2F(-eigenvectors(1, k), -eigenvectors(2, k)) END IF !These trends are relative to FlatMaxwell axis +y, which is also plot axis +y (up on map sheet); !they are NOT relative to local North. They are measured clockwise in radians. !I always choose the trend (sense) as the direction with positive plunge. horizontal = DSQRT((eigenvectors(1, k)**2) + (eigenvectors(2, k)**2)) plunge_radians(k) = DATan2F(ABS(eigenvectors(3, k)), horizontal) ! both arguments non-negative !These plunges are relative to the FlatMaxwell (x, y) plane, which is the surface of the projected flat-Earth. !They are measured downward from horizontal in radians, and will always be positive (or zero). END DO !correct azimuths of model principal stresses from (x, y) system to (E, N) system: longitude = fmtv_stress_data(i)%Elon latitude = fmtv_stress_data(i)%Nlat CALL Argument_of_North(longitude, latitude, argument_000_radians) azimuth_correction_radians = argument_000_radians - Pi_over_2 orientation2(1) = NINT(plunge_radians(3) * degrees_per_radian) orientation2(2) = NINT((trend_radians(3) + azimuth_correction_radians) * degrees_per_radian) orientation2(3) = NINT(plunge_radians(1) * degrees_per_radian) orientation2(4) = NINT((trend_radians(1) + azimuth_correction_radians) * degrees_per_radian) minimum_angle = DCROT(orientation1, orientation2) !accumulate angular error measures: angular_error_denominator = angular_error_denominator + 1 mean_angular_error_numerator = mean_angular_error_numerator + minimum_angle RMS_angular_error_numerator = RMS_angular_error_numerator + (minimum_angle**2) END IF ! datum includes stress orientation END DO ! scanning through (memorized) stress data IF (angular_error_denominator == 0) THEN WRITE (*, "(' No stress orientations found in data, so no angular-error scoring performed.')") ELSE ! normal case mean_angular_error = mean_angular_error_numerator / angular_error_denominator RMS_angular_error = DSQRT(RMS_angular_error_numerator / angular_error_denominator) WRITE (*, *) WRITE (*, "(' Based on ',I6,' stress orientation data in model domain,')") angular_error_denominator WRITE (*, "(' Mean angular error = ',F10.2,' degrees.')") mean_angular_error WRITE (*, "(' RMS angular error = ',F10.2,' degrees.')") RMS_angular_error CALL Pause() END IF !Evaluate fraction of BAD-REGIME ERRORS: ------------------------------ bad_regimes_numerator = 0 bad_regimes_denominator = 0 DO i = 1, fmi_sites_in_box c2 = fmtv_stress_data(i)%regime IF (c2 /= "U ") THEN ! correct stress regime is known !check stress regime in the model (total stress): x_meters = fmtv_stress_data(i)%x_meters y_meters = fmtv_stress_data(i)%y_meters z_meters = fmtv_stress_data(i)%z_meters !First, the topographic part: CALL Get_Stress_Tensor(x = x_meters, y = y_meters, z = z_meters, choice = 1, success = success, xyz_tensor = mu_xyz_tensor) IF (.NOT.success) THEN WRITE (*, "(' ERROR: Get_Stress_Tensor does not succeed, for (x, y, z) point pre-screened to be in model box.')") CALL Pause() STOP END IF ! unlikely failure mode !Second, the teconic part of the model: CALL Tectonic_Stress_at_Point(x_meters = x_meters, y_meters = y_meters, z_meters = z_meters, xyz_tensor = tau_xyz_tensor) !Add together to get the full (FlatMaxwell model) stress anomaly tensor in xyz coordinates, in Pa: FM_anomaly_xyz_tensor = mu_xyz_tensor + tau_xyz_tensor CALL Eigenanalysis_3x3(FM_anomaly_xyz_tensor, eigenvalues, eigenvectors) !Find trend and plunge of each principal axis. !Note that Eigenanalysis_3x3 returns eigenvalue(1) <= eigenvalue(2) <= eigenvalue(3), !so that k = 1, 2, 3 corresponds to s1, s2, s3. DO k = 1, 3 IF (eigenvectors(3, k) <= 0.0D0) THEN trend_radians(k) = DATan2F(eigenvectors(1, k), eigenvectors(2, k)) ELSE trend_radians(k) = DATan2F(-eigenvectors(1, k), -eigenvectors(2, k)) END IF !These trends are relative to FlatMaxwell axis +y, which is also plot axis +y (up on map sheet); !they are NOT relative to local North. They are measured clockwise in radians. !I always choose the trend (sense) as the direction with positive plunge. horizontal = DSQRT((eigenvectors(1, k)**2) + (eigenvectors(2, k)**2)) plunge_radians(k) = DATan2F(ABS(eigenvectors(3, k)), horizontal) ! both arguments non-negative !These plunges are relative to the FlatMaxwell (x, y) plane, which is the surface of the projected flat-Earth. !They are measured downward from horizontal in radians, and will always be positive (or zero). END DO SELECT CASE(c2) CASE("TF") ! s3 should be the most vertical match = (plunge_radians(3) > plunge_radians(2)).AND.(plunge_radians(3) > plunge_radians(1)) CASE("SS") ! s2 should be the most vertical match = (plunge_radians(2) > plunge_radians(1)).AND.(plunge_radians(2) > plunge_radians(3)) CASE("NF") ! s1 should be the most vertical match = (plunge_radians(1) > plunge_radians(2)).AND.(plunge_radians(1) > plunge_radians(3)) CASE("TS") ! transpression; s2 or s3 should be the most vertical match = (plunge_radians(3) > plunge_radians(2)).AND.(plunge_radians(3) > plunge_radians(1)).OR. & & (plunge_radians(2) > plunge_radians(1)).AND.(plunge_radians(2) > plunge_radians(3)) CASE("NS") ! transtension: s1 or s2 should be most vertical match = (plunge_radians(1) > plunge_radians(2)).AND.(plunge_radians(1) > plunge_radians(3)).OR. & & (plunge_radians(2) > plunge_radians(1)).AND.(plunge_radians(2) > plunge_radians(3)) CASE DEFAULT match = .FALSE. WRITE (*, "(' WARNING: Unknown stress-regime code (other than ""U ""): ',A)") c2 !CALL Pause() END SELECT bad_regimes_denominator = bad_regimes_denominator + 1 IF (.NOT.match) bad_regimes_numerator = bad_regimes_numerator + 1 END IF ! stress regime is known in dataset END DO ! scanning through (memorized) stress data IF (bad_regimes_denominator == 0) THEN WRITE (*, *) WRITE (*, "(' No stress regimes found in data, so no %-bad_regimes scoring performed.')") ELSE ! normal case bad_regimes_percent = (100.0D0 * bad_regimes_numerator) / bad_regimes_denominator WRITE (*, *) WRITE (*, "(' Based on ',I6,' stress regime data in model domain,')") bad_regimes_denominator WRITE (*, "(' Incorrect stress regimes = ',F6.2,'%.')") bad_regimes_percent CALL Pause() END IF !Evaluate measures of SHEAR-STRESS ERROR: ------------------------------ shear_stress_error_denominator = 0 mean_shear_stress_error_numerator = 0.0D0 RMS_shear_stress_error_numerator = 0.0D0 DO i = 1, fmi_sites_in_box s1_Pa = fmtv_stress_data(i)%s1_tensor_Pa s3_Pa = fmtv_stress_data(i)%s3_tensor_Pa IF ((ABS(s1_Pa + 999.0D0) > 1.).AND.(ABS(s3_Pa + 999.0D0) > 1.)) THEN ! real data; /= -999. shear_stress = 0.5D0 * ABS(s3_Pa - s1_Pa) !model (shear stress attribute of the total stress tensor): x_meters = fmtv_stress_data(i)%x_meters y_meters = fmtv_stress_data(i)%y_meters z_meters = fmtv_stress_data(i)%z_meters !First, the topographic part: CALL Get_Stress_Tensor(x = x_meters, y = y_meters, z = z_meters, choice = 1, success = success, xyz_tensor = mu_xyz_tensor) IF (.NOT.success) THEN WRITE (*, "(' ERROR: Get_Stress_Tensor does not succeed, for (x, y, z) point pre-screened to be in model box.')") CALL Pause() STOP END IF ! unlikely failure mode !Second, the teconic part of the model: CALL Tectonic_Stress_at_Point(x_meters = x_meters, y_meters = y_meters, z_meters = z_meters, xyz_tensor = tau_xyz_tensor) !Add together to get the full (FlatMaxwell model) stress anomaly tensor in xyz coordinates, in Pa: FM_anomaly_xyz_tensor = mu_xyz_tensor + tau_xyz_tensor CALL Eigenanalysis_3x3(FM_anomaly_xyz_tensor, eigenvalues) model_shear_stress = 0.5D0 * ABS(eigenvalues(3) - eigenvalues(1)) shear_stress_error_denominator = shear_stress_error_denominator + 1 mean_shear_stress_error_numerator = mean_shear_stress_error_numerator + ABS(model_shear_stress - shear_stress) RMS_shear_stress_error_numerator = RMS_shear_stress_error_numerator + ((model_shear_stress - shear_stress)**2) END IF ! datum includes stress magnitude END DO IF (shear_stress_error_denominator == 0) THEN WRITE (*, "(' No stress magnitudes found in data, so no shear-stress-error scoring performed.')") ELSE ! normal case mean_shear_stress_error = mean_shear_stress_error_numerator / shear_stress_error_denominator RMS_shear_stress_error = DSQRT(RMS_shear_stress_error_numerator / shear_stress_error_denominator) WRITE (*, *) WRITE (*, "(' Based on ',I6,' stress magnitude data in model domain,')") shear_stress_error_denominator WRITE (*, "(' Mean shear-stress error = ',ES10.2,' Pa, or ',F10.2,' MPa.')") mean_shear_stress_error, (mean_shear_stress_error * 1.E-6) WRITE (*, "(' RMS shear-stress error = ',ES10.2,' Pa, or ',F10.2,' MPa.')") RMS_shear_stress_error, (RMS_shear_stress_error * 1.E-6) CALL Pause() END IF END SUBROUTINE Misfits_wrt_Data SUBROUTINE Pause() IMPLICIT NONE WRITE (*,"(' Press [Enter]...'\)") READ (*,*) END SUBROUTINE Pause SUBROUTINE Read_CSM_Model(iunit, CSM_points_in_box, tv_CSM_model) IMPLICIT NONE !but global variables defined in FlatMaxwell are used freely. INTEGER, INTENT(IN) :: iunit ! Fortran device number to READ from; assume file OPENed and CLOSEd by calling program (both times). INTEGER, INTENT(OUT) :: CSM_points_in_box ! count of model points within the FlatMaxwell model box domain TYPE(CSM_model), DIMENSION(:), OPTIONAL :: tv_CSM_model ! To only count the data, omit this argument from the CALL; next, ALLOCATE ! the array in the calling program; finally, call this routine again with this argument included to get data values into memory. CHARACTER*1 :: c1 CHARACTER*84 :: half_line CHARACTER*132 :: full_line INTEGER :: ios, line1or2 REAL*8 :: Elon, Nlat, depth_below_MSL_in_km, & & s1H_azimuth_degrees, sigma_1h_MPa, sigma_2h_MPa, sigma_rr_MPa, & & sigma_EE_MPa, sigma_EN_MPa, sigma_Er_MPa, sigma_NN_MPa, sigma_Nr_MPa, & & x_meters, y_meters, z_meters REAL*8, DIMENSION(3) :: uvec REAL*8, DIMENSION(3, 3) :: ENr_tensor_Pa IF (.NOT.PRESENT(tv_CSM_model)) THEN ! this is just a counting CALL, so: WRITE (*, "(' Scanning CSM model file to count the number of points...')") ELSE ! this is a recording CALL: WRITE (*, "(' Loading CSM model stresses into memory...')") END IF !get past header lines of text headers: DO READ (iunit, "(A)", IOSTAT = ios) full_line c1 = full_line(1:1) IF (c1 /= '#') THEN BACKSPACE (iunit) EXIT headers END IF END DO headers !primary open-ended loop continues until EOF CSM_points_in_box = 0 ! just initializing before sum reading: DO READ (iunit, "(F9.4,F9.4,F7.2,I2,A)", IOSTAT = ios) Elon, Nlat, depth_below_MSL_in_km, line1or2, half_line IF (ios == -1) EXIT reading ! at EOF IF (line1or2 == 1) THEN ! process this line (otherwise; ignore it): z_meters = -1000.0D0 * depth_below_MSL_in_km CALL DLonLat_2_Uvec(Elon, Nlat, uvec) CALL DProject(uvec = uvec, x = x_meters, y = y_meters) IF ((x_meters >= (-0.5D0 * fmr_x_LENGTH_meters)).AND.(x_meters <= (0.5D0 * fmr_x_LENGTH_meters)).AND. & & (y_meters >= (-0.5D0 * fmr_y_WIDTH_meters )).AND.(y_meters <= (0.5D0 * fmr_y_WIDTH_meters )).AND. & & (z_meters >= -fmr_z_DEPTH_meters).AND.(z_meters <= 0.0D0)) THEN CSM_points_in_box = CSM_points_in_box + 1 IF (PRESENT(tv_CSM_model)) THEN ! record these values tv_CSM_model(CSM_points_in_box)%Elon = Elon tv_CSM_model(CSM_points_in_box)%Nlat = Nlat tv_CSM_model(CSM_points_in_box)%depth_below_MSL_in_km = depth_below_MSL_in_km tv_CSM_model(CSM_points_in_box)%x_meters = x_meters tv_CSM_model(CSM_points_in_box)%y_meters = y_meters tv_CSM_model(CSM_points_in_box)%z_meters = z_meters READ (half_line, *) s1H_azimuth_degrees, sigma_1h_MPa, sigma_2h_MPa, sigma_rr_MPa, sigma_EE_MPa, sigma_EN_MPa, sigma_Er_MPa, sigma_NN_MPa, sigma_Nr_MPa tv_CSM_model(CSM_points_in_box)%s1H_azimuth_degrees = s1H_azimuth_degrees tv_CSM_model(CSM_points_in_box)%sigma_EE_MPa = sigma_EE_MPa tv_CSM_model(CSM_points_in_box)%sigma_EN_MPa = sigma_EN_MPa tv_CSM_model(CSM_points_in_box)%sigma_Er_MPa = sigma_Er_MPa tv_CSM_model(CSM_points_in_box)%sigma_NN_MPa = sigma_NN_MPa tv_CSM_model(CSM_points_in_box)%sigma_Nr_MPa = sigma_Nr_MPa tv_CSM_model(CSM_points_in_box)%sigma_rr_MPa = sigma_rr_MPa ENr_tensor_Pa(1, 1) = 1.0D6 * sigma_EE_Mpa ENr_tensor_Pa(1, 2) = 1.0D6 * sigma_EN_MPa ENr_tensor_Pa(1, 3) = 1.0D6 * sigma_Er_MPa ENr_tensor_Pa(2, 1) = 1.0D6 * sigma_EN_MPa ENr_tensor_Pa(2, 2) = 1.0D6 * sigma_NN_Mpa ENr_tensor_Pa(2, 3) = 1.0D6 * sigma_Nr_MPa ENr_tensor_Pa(3, 1) = 1.0D6 * sigma_Er_MPa ENr_tensor_Pa(3, 2) = 1.0D6 * sigma_Nr_MPa ENr_tensor_Pa(3, 3) = 1.0D6 * sigma_rr_MPa tv_CSM_model(CSM_points_in_box)%ENr_tensor_Pa(1:3, 1:3) = ENr_tensor_Pa(1:3, 1:3) END IF ! this is a recording CALL. END IF ! point falls inside the box END IF ! line1or2 == 1 END DO reading IF (.NOT.PRESENT(tv_CSM_model)) THEN ! this is just a counting CALL, so: WRITE (*, "(' Found ',I8,' CSM model points within the FlatMaxwell model domain.')") CSM_points_in_box ELSE ! this is a recording CALL: WRITE (*, "(' CSM model now loaded into memory.')") END IF END SUBROUTINE Read_CSM_Model SUBROUTINE Read_Stress_Data(iunit, fmi_sites_in_box, tv_stress_data) !Assumes that a file similar to wsm2008.csv has been successfully opened on UNIT = iunit; also, that calling program will close this file. !Typically first called WITHOUT argument tv_stress_data to count sites in the FlatMaxwell model box domain; !then called again (after resetting the input file to start on UNIT = 11) WITH argument tv_stress_data present, !to store these data in memory, in a tv_stress_data array that has been allocated by/in the calling program. IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. INTEGER, INTENT(IN) :: iunit INTEGER, INTENT(OUT) :: fmi_sites_in_box ! data count (to be used in ALLOCATE in calling program). TYPE(stress_data), DIMENSION(:), INTENT(OUT), OPTIONAL :: tv_stress_data ! allocated in calling program. !------------------------------------------------------------------------------------------------------- CHARACTER*1 :: c1, comma_byte ! <-- may be either ',' or ';' (must check in first line of file) CHARACTER*2 :: c2 CHARACTER*40 :: field CHARACTER*400 :: line INTEGER, PARAMETER :: max_commas = 60 INTEGER :: comma_count, i, i1, i2, ios, j1, j2, line_length, nCommas, nSemicolons, & & orientations_in_box, S1AZ, S1PL, S2AZ, S2PL, S3AZ, S3PL, shears_in_box INTEGER, DIMENSION(6) :: percent_quality INTEGER, DIMENSION(max_commas) :: comma_map LOGICAL :: DEM_success, good_location, good_orientation, good_shear, Reject_success REAL*8 :: argument_000_radians, depth, east, elevation, fx1, fx2, fy1, fy2, grad_h_x, grad_h_y, latitude, longitude, & & MAG_INT_s1, MAG_INT_S2, MAG_INT_S3, north, & & s1_argument_radians, s2_argument_radians, s3_argument_radians, south, surface, west, x_meters, y_meters REAL*8, DIMENSION(3) :: uvec fmi_sites_in_box = 0 orientations_in_box = 0 shears_in_box = 0 !Determine whether ',' or ';' is the separator in this file: READ (iunit, *) line nCommas = 0 nSemicolons = 0 DO i = 1, LEN_TRIM(line) IF (line(i:i) == ',') nCommas = nCommas + 1 IF (line(i:i) == ';') nSemicolons = nSemicolons + 1 END DO IF (nCommas >= nSemicolons) THEN comma_byte = ',' ELSE ! nSemicolons is larger comma_byte = ';' END IF reading: DO READ (iunit, "(A)", IOSTAT = ios) line IF (ios == -1) EXIT reading ! at EOF mark !build map of byte-locations of comma (actually, semi-colon) separators: comma_count = 0 DO i = 1, max_commas comma_map(i) = -i ! impossible values, showing lack of success in finding these commas END DO line_length = LEN_TRIM(line) DO i = 1, line_length IF (line(i:i) == comma_byte) THEN ! checking for ',' OR ';' (depending on comma_byte) comma_count = comma_count + 1 IF (comma_count <= max_commas) THEN comma_map(comma_count) = i ELSE WRITE (*, "(' ERROR: In routine Score_Stress_vs_Data, increase max_commas, now = ',I3)") max_commas CALL Pause() STOP END IF END IF END DO ! scanning line for commas !get latitude: good_location = .TRUE. ! unless... IF ((comma_map(3) - comma_map(2)) > 0) THEN ! something there field = line((comma_map(2)+1):(comma_map(3)-1)) READ (field, *, IOSTAT = ios) latitude IF (ios /= 0) good_location = .FALSE. ELSE good_location = .FALSE. END IF !get longitude: IF ((comma_map(4) - comma_map(3)) > 0) THEN ! something there field = line((comma_map(3)+1):(comma_map(4)-1)) READ (field, *, IOSTAT = ios) longitude IF (ios /= 0) THEN good_location = .FALSE. ELSE IF ((longitude - fmr_projpoint_Elon) > 180.0D0) longitude = longitude - 360.0D0 IF ((longitude - fmr_projpoint_Elon) < -180.0D0) longitude = longitude + 360.0D0 END IF ELSE good_location = .FALSE. END IF !get depth (relative to surface) in km: IF ((comma_map(7) - comma_map(6)) > 0) THEN ! something there field = line((comma_map(6)+1):(comma_map(7)-1)) READ (field, *, IOSTAT = ios) depth IF (ios /= 0) good_location = .FALSE. ELSE good_location = .FALSE. END IF !check whether location is in the model box (first in 2-D, then in 3-D)? IF (good_location) THEN CALL DLonLat_2_Uvec(longitude, latitude, uvec) CALL DProject(uvec = uvec, x = x_meters, y = y_meters) IF (x_meters < (-0.5D0 * fmr_x_LENGTH_meters)) good_location = .FALSE. IF (x_meters > ( 0.5D0 * fmr_x_LENGTH_meters)) good_location = .FALSE. IF (y_meters < (-0.5D0 * fmr_y_WIDTH_meters)) good_location = .FALSE. IF (y_meters > ( 0.5D0 * fmr_y_WIDTH_meters)) good_location = .FALSE. IF (good_location) THEN ! obtain "surface" elevation in meters, to interpret "depth" field: CALL DEM_Lookup(x_meters, y_meters, & & Reject_success, longitude, latitude, & & DEM_success, surface, grad_h_x, grad_h_y) IF (Reject_success.AND.DEM_success) THEN elevation = surface - 1000.0D0 * depth IF (elevation > 0.0D0) good_location = .FALSE. IF (elevation < -fmr_z_DEPTH_meters) good_location = .FALSE. ELSE good_location = .FALSE. END IF ! Reject_success.AND.DEM_success END IF ! (seemed to be) good_location, at the time... END IF ! (seemed to be) good_location, at the time... IF (good_location) THEN ! count this site; then, try to read (and perhaps store) the data... fmi_sites_in_box = fmi_sites_in_box + 1 IF (PRESENT(tv_stress_data)) THEN tv_stress_data(fmi_sites_in_box)%Elon = longitude tv_stress_data(fmi_sites_in_box)%Nlat = latitude tv_stress_data(fmi_sites_in_box)%depth_km = depth tv_stress_data(fmi_sites_in_box)%x_meters = x_meters tv_stress_data(fmi_sites_in_box)%y_meters = y_meters tv_stress_data(fmi_sites_in_box)%z_meters = elevation END IF ! recording good_orientation = .TRUE. ! unless... ! get S1AZ: IF ((comma_map(17) - comma_map(16)) > 0) THEN ! something there field = line((comma_map(16)+1):(comma_map(17)-1)) READ (field, *, IOSTAT = ios) S1AZ IF (ios /= 0) good_orientation = .FALSE. ELSE good_orientation = .FALSE. END IF ! get S1PL: IF ((comma_map(18) - comma_map(17)) > 0) THEN ! something there field = line((comma_map(17)+1):(comma_map(18)-1)) READ (field, *, IOSTAT = ios) S1PL IF (ios /= 0) good_orientation = .FALSE. ELSE good_orientation = .FALSE. END IF ! get S2AZ: IF ((comma_map(19) - comma_map(18)) > 0) THEN ! something there field = line((comma_map(18)+1):(comma_map(19)-1)) READ (field, *, IOSTAT = ios) S2AZ IF (ios /= 0) good_orientation = .FALSE. ELSE good_orientation = .FALSE. END IF ! get S2PL: IF ((comma_map(20) - comma_map(19)) > 0) THEN ! something there field = line((comma_map(19)+1):(comma_map(20)-1)) READ (field, *, IOSTAT = ios) S2PL IF (ios /= 0) good_orientation = .FALSE. ELSE good_orientation = .FALSE. END IF ! get S3AZ: IF ((comma_map(21) - comma_map(20)) > 0) THEN ! something there field = line((comma_map(20)+1):(comma_map(21)-1)) READ (field, *, IOSTAT = ios) S3AZ IF (ios /= 0) good_orientation = .FALSE. ELSE good_orientation = .FALSE. END IF ! get S3PL: IF ((comma_map(22) - comma_map(21)) > 0) THEN ! something there field = line((comma_map(21)+1):(comma_map(22)-1)) READ (field, *, IOSTAT = ios) S3PL IF (ios /= 0) good_orientation = .FALSE. ELSE good_orientation = .FALSE. END IF IF (good_orientation) orientations_in_box = orientations_in_box + 1 IF (PRESENT(tv_stress_data)) THEN ! recording IF (good_orientation) THEN IF (S1AZ < 0) S1AZ = S1AZ + 360 ! non-negative value is a sign of real data IF (S2AZ < 0) S2AZ = S2AZ + 360 IF (S3AZ < 0) S3AZ = S3AZ + 360 tv_stress_data(fmi_sites_in_box)%s1_azimuth_deg = S1AZ ! converting INTEGER to REAL tv_stress_data(fmi_sites_in_box)%s1_plunge_deg = S1PL tv_stress_data(fmi_sites_in_box)%s2_azimuth_deg = S2AZ tv_stress_data(fmi_sites_in_box)%s2_plunge_deg = S2PL tv_stress_data(fmi_sites_in_box)%s3_azimuth_deg = S3AZ tv_stress_data(fmi_sites_in_box)%s3_plunge_deg = S3PL CALL Argument_of_North(longitude, latitude, argument_000_radians) s1_argument_radians = argument_000_radians - S1AZ * radians_per_degree IF (s1_argument_radians < 0.0D0) s1_argument_radians = s1_argument_radians + Two_Pi tv_stress_data(fmi_sites_in_box)%s1_argument_radians = s1_argument_radians tv_stress_data(fmi_sites_in_box)%s1_plunge_radians = S1PL * radians_per_degree s2_argument_radians = argument_000_radians - S2AZ * radians_per_degree IF (s2_argument_radians < 0.0D0) s2_argument_radians = s2_argument_radians + Two_Pi tv_stress_data(fmi_sites_in_box)%s2_argument_radians = s2_argument_radians tv_stress_data(fmi_sites_in_box)%s2_plunge_radians = S2PL * radians_per_degree s3_argument_radians = argument_000_radians - S3AZ * radians_per_degree IF (s3_argument_radians < 0.0D0) s3_argument_radians = s3_argument_radians + Two_Pi tv_stress_data(fmi_sites_in_box)%s3_argument_radians = s3_argument_radians tv_stress_data(fmi_sites_in_box)%s3_plunge_radians = S3PL * radians_per_degree ELSE ! unusable orientation info; mark as bad data tv_stress_data(fmi_sites_in_box)%s1_azimuth_deg = -999.0D0 ! negative value indicates no-data or bad-data tv_stress_data(fmi_sites_in_box)%s1_plunge_deg = -999.0D0 tv_stress_data(fmi_sites_in_box)%s2_azimuth_deg = -999.0D0 tv_stress_data(fmi_sites_in_box)%s2_plunge_deg = -999.0D0 tv_stress_data(fmi_sites_in_box)%s3_azimuth_deg = -999.0D0 tv_stress_data(fmi_sites_in_box)%s3_plunge_deg = -999.0D0 tv_stress_data(fmi_sites_in_box)%s1_argument_radians = -999.0D0 tv_stress_data(fmi_sites_in_box)%s1_plunge_radians = -999.0D0 tv_stress_data(fmi_sites_in_box)%s2_argument_radians = -999.0D0 tv_stress_data(fmi_sites_in_box)%s2_plunge_radians = -999.0D0 tv_stress_data(fmi_sites_in_box)%s3_argument_radians = -999.0D0 tv_stress_data(fmi_sites_in_box)%s3_plunge_radians = -999.0D0 END IF END IF ! recording !try to get principal stress magnitudes: good_shear = .TRUE. ! unless... ! get S1 magnitude: IF ((comma_map(23) - comma_map(22)) > 0) THEN ! something there field = line((comma_map(22)+1):(comma_map(23)-1)) READ (field, *, IOSTAT = ios) MAG_INT_S1 IF (ios /= 0) good_shear = .FALSE. ELSE good_shear = .FALSE. END IF ! get S2 magnitude: IF ((comma_map(25) - comma_map(24)) > 0) THEN ! something there field = line((comma_map(24)+1):(comma_map(25)-1)) READ (field, *, IOSTAT = ios) MAG_INT_S2 IF (ios /= 0) good_shear = .FALSE. ELSE good_shear = .FALSE. END IF ! get S3 magnitude: IF ((comma_map(27) - comma_map(26)) > 0) THEN ! something there field = line((comma_map(26)+1):(comma_map(27)-1)) READ (field, *, IOSTAT = ios) MAG_INT_S3 IF (ios /= 0) good_shear = .FALSE. ELSE good_shear = .FALSE. END IF IF (good_shear) shears_in_box = shears_in_box + 1 IF (PRESENT(tv_stress_data)) THEN ! recording IF (good_shear) THEN tv_stress_data(fmi_sites_in_box)%s1_mag_int = MAG_INT_s1 tv_stress_data(fmi_sites_in_box)%s2_mag_int = MAG_INT_s2 tv_stress_data(fmi_sites_in_box)%s3_mag_int = MAG_INT_s3 tv_stress_data(fmi_sites_in_box)%s1_tensor_Pa = -1.0D6 * MAG_INT_s1 tv_stress_data(fmi_sites_in_box)%s2_tensor_Pa = -1.0D6 * MAG_INT_s2 tv_stress_data(fmi_sites_in_box)%s3_tensor_Pa = -1.0D6 * MAG_INT_s3 ELSE ! no-data or bad-data: tv_stress_data(fmi_sites_in_box)%s1_mag_int = -999.0D0 tv_stress_data(fmi_sites_in_box)%s2_mag_int = -999.0D0 tv_stress_data(fmi_sites_in_box)%s3_mag_int = -999.0D0 tv_stress_data(fmi_sites_in_box)%s1_tensor_Pa = -999.0D0 tv_stress_data(fmi_sites_in_box)%s2_tensor_Pa = -999.0D0 tv_stress_data(fmi_sites_in_box)%s3_tensor_Pa = -999.0D0 END IF ! good_shear, or not END IF ! recording !try to get quality: IF ((comma_map(8) - comma_map(7)) > 0) THEN ! something there; length should be either 1 or 2 bytes field = line((comma_map(7)+1):(comma_map(8)-1)) IF (PRESENT(tv_stress_data)) tv_stress_data(fmi_sites_in_box)%quality = ADJUSTL(field) ELSE IF (PRESENT(tv_stress_data)) tv_stress_data(fmi_sites_in_box)%quality = 'U' END IF !try to get stress regime: IF ((comma_map(9) - comma_map(8)) > 0) THEN ! something there; length should be either 1 or 2 bytes field = line((comma_map(8)+1):(comma_map(9)-1)) IF (PRESENT(tv_stress_data)) tv_stress_data(fmi_sites_in_box)%regime = ADJUSTL(field) ELSE IF (PRESENT(tv_stress_data)) tv_stress_data(fmi_sites_in_box)%regime = "U " END IF END IF ! good_location; count this site, and try to get data specifics END DO reading IF (.NOT.PRESENT(tv_stress_data)) THEN ! this is a counting CALL... WRITE (*, *) WRITE (*, "(' ',I6,' stress data sites were read within model box volume.')") fmi_sites_in_box WRITE (*, "(' ',I6,' stress orientations were read within model box volume.')") orientations_in_box WRITE (*, "(' ',I6,' stress intensities were read within model box volume.')") shears_in_box ELSE ! this is a recording CALL, and data were closely examined: IF (fmi_sites_in_box > 0) THEN percent_quality = 0 ! all 6 values DO i = 1, fmi_sites_in_box c1 = tv_stress_data(i)%quality IF (c1 == 'A') THEN percent_quality(1) = percent_quality(1) + 1 ELSE IF (c1 == 'B') THEN percent_quality(2) = percent_quality(2) + 1 ELSE IF (c1 == 'C') THEN percent_quality(3) = percent_quality(3) + 1 ELSE IF (c1 == 'D') THEN percent_quality(4) = percent_quality(4) + 1 ELSE IF (c1 == 'E') THEN percent_quality(5) = percent_quality(5) + 1 ELSE ! U, undefined percent_quality(6) = percent_quality(6) + 1 END IF END DO percent_quality(1:6) = NINT(100.0D0 * percent_quality(1:6) / fmi_sites_in_box) WRITE (*, "(' Qualities: ',I3,'% A, ',I3,'% B, ',I3,'% C, ',I3,'% D, ',I3,'% E, ',I3,'% U.')") (percent_quality(i), i = 1, 6) WRITE (*, *) END IF ! counting CALL, or recording CALL END IF END SUBROUTINE Read_Stress_Data REAL*8 FUNCTION Reference_Density(elevation_meters) !Argument is an elevation, in meters, relative to sea level. !It is intended that this argument should be zero or negative; !that is, that the query should refer to points below MSL. !If so, the result returned will be the density (in kg/m^3) of !the current FlatMaxwell 1-D reference density model. !If elevation_meters is positive, the result will be a very !approximate density of the atmosphere. IMPLICIT NONE !but variables defined in FlatMaxwell are referenced freely. REAL*8, INTENT(IN) :: elevation_meters IF (elevation_meters > 0.0D0) THEN Reference_Density = 1.2D0 * DEXP(-elevation_meters / 7640.0D0) !Wikipedia, "Atmosphere of Earth" 2013.10 ELSE IF (elevation_meters >= -fmr_Moho_depth) THEN !within the crust: Reference_Density = fmr_crustal_density_at_top + (fmr_crustal_density_at_Moho - fmr_crustal_density_at_top) * & & (-elevation_meters / fmr_Moho_depth) ELSE IF (elevation_meters >= -fmr_LAB_depth) THEN !within the mantle lithosphere: Reference_Density = fmr_mantle_density_at_Moho + (fmr_mantle_density_at_LAB - fmr_mantle_density_at_Moho) * & & ((-elevation_meters - fmr_Moho_depth) / (fmr_LAB_depth - fmr_Moho_depth)) ELSE ! within the asthenosphere Reference_Density = fmr_mantle_density_at_LAB END IF END FUNCTION Reference_Density REAL*8 FUNCTION P0_Pressure_in_Pa(elevation_meters) !Argument is an elevation, in meters, relative to sea level. !It is intended that this argument should be zero or negative; !that is, that the query should refer to points below MSL. !If so, the result returned will be the reference pressure !the current FlatMaxwell 1-D density/pressure model. IMPLICIT NONE !but variables defined in FlatMaxwell are referenced freely. REAL*8, INTENT(IN) :: elevation_meters INTEGER :: kz1, kz2 REAL*8 :: fz1, fz2 IF (elevation_meters > 0.0D0) THEN P0_Pressure_in_Pa = 101.3D3 * DEXP(-elevation_meters / 7640.0D0) !Wikipedia, "Atmosphere of Earth" 2013.12 ELSE ! within the model domain ! single subscript: k = -fmi_topo_nz, fmi_topo_nz kz1 = MAX(-fmi_topo_nz, DInt_Below((elevation_meters + (0.5D0 * fmr_z_DEPTH_meters)) / fmrv_topo_stress_dXYZ(3))) kz2 = MIN(fmi_topo_nz, (kz1+1)) fz2 = (elevation_meters - (-0.5D0 * fmr_z_DEPTH_meters + kz1 * fmrv_topo_stress_dXYZ(3))) / fmrv_topo_stress_dXYZ(3) fz1 = 1.0D0 - fz2 P0_Pressure_in_Pa = fz1 * fmrv_reference_P_Pa(kz1) + fz2 * fmrv_reference_P_Pa(kz2) END IF END FUNCTION P0_Pressure_in_Pa SUBROUTINE Read_Tectonic_Stress_part1() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. CHARACTER*1 :: asterisk CHARACTER*12 :: desired_token, trial_topo_token CHARACTER*132 :: tecto_stress_filename, tecto_stress_pathfile INTEGER :: i, ios, it, k, kt, l, lt, m, mt, n, nt 10 CALL DPrompt_for_String("Enter name token (1~12 characters, no spaces) of FlatMaxwell_tectoStress_[token].dat:", ' ', desired_token) tecto_stress_filename = "FlatMaxwell_tectoStress_" // TRIM(desired_token) // ".dat" tecto_stress_pathfile = TRIM(fmc132_path_out) // TRIM(tecto_stress_filename) OPEN (UNIT = 2, FILE = TRIM(tecto_stress_pathfile), STATUS = "OLD", PAD = "YES", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: File ',A,' not found.'/'Please move file, or retype name, and try again.')") TRIM(tecto_stress_pathfile) CALL Pause() GO TO 10 END IF READ (2, "(A)", IOSTAT = ios) fmc12_tectonic_token IF (ios /= 0) THEN WRITE (*, "(' ERROR: Tectonic-stress-model name token could not be READ from first line.')") CALL Pause() GO TO 10 END IF READ (2, "(A)", IOSTAT = ios) trial_topo_token IF (ios /= 0) THEN WRITE (*, "(' ERROR: Topographic-stress-model name token could not be READ from 2nd line.')") CALL Pause() GO TO 10 END IF IF (trial_topo_token /= fmc12_topographic_token) THEN WRITE (*, "(' ERROR: Topographic-stress-model token ',A,' in this tectonic-stress file, ',A)") TRIM(trial_topo_token), TRIM(tecto_stress_filename) WRITE (*, "(' does not match the token (',A,') for the topographic-stress model now loaded.')") TRIM(fmc12_topographic_token) WRITE (*, "(' You may NEVER overload a tectonic model onto a topographic model different from its basis!')") WRITE (*, "(' Please, either: (1) Specify the correct file name for a tectonic model based on ',A)") TRIM(fmc12_topographic_token) WRITE (*, "(' OR: (2) Quit FlatMaxwell, restart it, and load a different topographic-stress model.')") CALL Pause() GO TO 10 END IF READ (2, *) fmi_tectonic_model_mode READ (2, *) fmi_waves READ (2, "(A)") fmc80_CSM_model_filename READ (2, "(A)") fmc80_WSM_data_filename READ (2, *) fmd_CSM_group_weight READ (2, *) fmd_WSM_group_weight READ (2, *) fmd_BC_group_weight CLOSE (2) !Now, return to calling main program so that array fmdV_coefficients (etc.) can be ALLOCATED: fmc12_tectonic_token = desired_token !(only remembering the token, which is now assumed to be validated). END SUBROUTINE Read_Tectonic_Stress_part1 SUBROUTINE Read_Tectonic_Stress_part2() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. CHARACTER*1 :: asterisk CHARACTER*12 :: desired_token, trial_topo_token CHARACTER*13 :: expected_name, name_found CHARACTER*132 :: tecto_stress_filename, tecto_stress_pathfile INTEGER :: expected_k, i, ios, it, k_found tecto_stress_filename = "FlatMaxwell_tectoStress_" // TRIM(fmc12_tectonic_token) // ".dat" tecto_stress_pathfile = TRIM(fmc132_path_out) // TRIM(tecto_stress_filename) OPEN (UNIT = 2, FILE = TRIM(tecto_stress_pathfile), STATUS = "OLD", PAD = "YES", IOSTAT = ios) READ (2, *) ! reread tectonic token READ (2, *) ! reread topographic token READ (2, *) fmi_tectonic_model_mode READ (2, *) fmi_waves READ (2, "(A)") fmc80_CSM_model_filename READ (2, "(A)") fmc80_WSM_data_filename READ (2, *) fmd_CSM_group_weight READ (2, *) fmd_WSM_group_weight READ (2, *) fmd_BC_group_weight DO i = 1, fmi_N_coefficients READ (2, "(I8,1X,A13,I2,ES18.10)") it, name_found, k_found, fmdV_coefficients(i, 1) expected_name = fmc13v_name(i) expected_k = fmiv_k(i) IF ((it /= i).OR.(name_found /= expected_name).OR.(k_found /= expected_k)) THEN WRITE (*, "(' ERROR: When expecting to read ',I8,' ',A13,I2)") i, expected_name, expected_k WRITE (*, "(' actually encountered ',I8,' ',A13,I2)") it, name_found, k_found CALL Pause() STOP END IF END DO CLOSE (2) END SUBROUTINE Read_Tectonic_Stress_part2 SUBROUTINE Read_Topographic_Stress_part1() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. CHARACTER*12 :: desired_token CHARACTER*132 :: topo_stress_filename, topo_stress_pathfile INTEGER :: ios REAL*8 :: belt_azimuth_radians, & & standard_parallel_gap_radians, & & x_projpoint_meters, xy_wrt_page_degrees, xy_wrt_page_radians, y_azimuth_radians, y_projpoint_meters REAL*8, DIMENSION(3) :: cone_pole_uvec, projpoint_uvec 10 CALL DPrompt_for_String("Enter name token (1~12 characters, no spaces) of FlatMaxwell_topoStress_[token].dat:", ' ', desired_token) topo_stress_filename = "FlatMaxwell_topoStress_" // TRIM(desired_token) // ".dat" topo_stress_pathfile = TRIM(fmc132_path_out) // TRIM(topo_stress_filename) OPEN (UNIT = 1, FILE = TRIM(topo_stress_pathfile), STATUS = "OLD", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: File ',A,' not found.'/'Please move file, or retype name, and try again.')") TRIM(topo_stress_pathfile) CALL Pause() GO TO 10 END IF READ (1, "(A12)") fmc12_topographic_token !---Define_Map_Projection--- x_projpoint_meters = 0.0D0 y_projpoint_meters = 0.0D0 xy_wrt_page_degrees = 0.0D0 xy_wrt_page_radians = 0.0D0 y_azimuth_radians = 0.0D0 READ (1, "(I12)") fmi_projection_choice READ (1, "(F12.0)") fmr_radius_meters READ (1, "(F12.4)") fmr_projpoint_Elon READ (1, "(F12.4)") fmr_projpoint_Nlat READ (1, "(F12.2)") fmr_belt_azimuth_degrees belt_azimuth_radians = fmr_belt_azimuth_degrees * radians_per_degree READ (1, "(F12.4)") fmr_cone_lat READ (1, "(F12.4)") fmr_cone_lon READ (1, "(F12.2)") fmr_standard_parallel_gap_degrees standard_parallel_gap_radians = fmr_standard_parallel_gap_degrees * radians_per_degree CALL DLonLat_2_Uvec(fmr_projpoint_Elon, fmr_projpoint_Nlat, projpoint_uvec) !Call inititalizing routine in module Map_Projections: SELECT CASE (fmi_projection_choice) CASE (1); CALL DSet_Mercator (fmr_radius_meters, & & projpoint_uvec, belt_azimuth_radians, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (2) CALL DLonLat_2_Uvec(fmr_cone_lon, fmr_cone_lat, cone_pole_uvec) CALL DSet_Lambert_Conformal_Conic & & (fmr_radius_meters, & & projpoint_uvec, cone_pole_uvec, & & standard_parallel_gap_radians, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (3) CALL DLonLat_2_Uvec(fmr_cone_lon, fmr_cone_lat, cone_pole_uvec) CALL DSet_Albers_Equal_Area_Conic & & (fmr_radius_meters, & & projpoint_uvec, cone_pole_uvec, & & standard_parallel_gap_radians, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (4) CALL DLonLat_2_Uvec(fmr_cone_lon, fmr_cone_lat, cone_pole_uvec) CALL DSet_Polyconic (fmr_radius_meters, & & projpoint_uvec, cone_pole_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (5) CALL DLonLat_2_Uvec(fmr_cone_lon, fmr_cone_lat, cone_pole_uvec) CALL DSet_Geometric_Conic & & (fmr_radius_meters, & & projpoint_uvec, cone_pole_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (6); CALL DSet_Stereographic (fmr_radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (7); CALL DSet_Lambert_Azimuthal_EqualArea ( & & fmr_radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (8); CALL DSet_Azimuthal_Equidistant ( & & fmr_radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE (9); CALL DSet_Orthographic ( & & fmr_radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) CASE(10); CALL DSet_Gnomonic ( & & fmr_radius_meters, & & projpoint_uvec, & & x_projpoint_meters, y_projpoint_meters, & & y_azimuth_radians) END SELECT ! fmi_projection_choice !---Define_Volume--- READ (1, "(F12.0)") fmr_x_LENGTH_meters READ (1, "(F12.0)") fmr_y_WIDTH_meters READ (1, "(F12.0)") fmr_z_DEPTH_meters !---Define_Reference_Density_Model--- READ (1, "(F12.6)") fmr_gravity READ (1, "(F12.0)") fmr_1_bar READ (1, "(F12.0)") fmr_atmosphere_scale_height_meters READ (1, "(F12.0)") fmr_seawater_density READ (1, "(F12.0)") fmr_Moho_depth fmr_Moho_elevation = -ABS(fmr_Moho_depth) ! guaranteeing negative elevation, despite user's convention READ (1, "(F12.0)") fmr_crustal_density_at_top READ (1, "(F12.0)") fmr_crustal_density_at_Moho READ (1, "(F12.0)") fmr_mantle_density_at_Moho READ (1, "(F12.0)") fmr_mantle_density_at_LAB READ (1, "(F12.0)") fmr_LAB_depth fmr_LAB_elevation = -ABS(fmr_LAB_depth) !---DEM--- READ (1, "(A)") fmc80_DEM_filename !The DEM must be re-read because it will probably be needed for graphics. !Note that a DEM will also be read along the branch where a new topographic stress model is computed; ! but, in that case, the user will be free to choose the DEM filename. WRITE (*, *) WRITE (*, "(' A Digital Elevation Model (DEM) must be provided in Bird''s .GRD format,')") WRITE (*, "(' which is documented in a web page with URL of:')") WRITE (*, "(' http://peterbird.name/guide/grd_format.htm')") 21 WRITE (*, "(' You MUST re-use the same DEM as before: ',A)") TRIM(fmc80_DEM_filename) WRITE (*, "(' Please check now that it is available, in the input path...')") CALL Pause() fmc132_DEM_pathfile = TRIM(fmc132_path_in) // TRIM(fmc80_DEM_filename) OPEN (UNIT = 2, FILE = TRIM(fmc132_DEM_pathfile), STATUS = "OLD", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*, "(' ERROR: DEM file named ', A / ' was not found in folder'/' ', A)") TRIM(fmc80_DEM_filename), TRIM(fmc132_path_in) WRITE (*, "(' Please create or move this file, and try again...')") CALL Pause() GO TO 21 END IF READ (2, *, IOSTAT = ios) fmr_DEM_lon_min, fmr_DEM_dLon, fmr_DEM_lon_max fmr_DEM_lon_range = fmr_DEM_lon_max - fmr_DEM_lon_min IF (ios /= 0) THEN WRITE (*, "(' ERROR: DEM is not in .GRD format.')"); CALL Pause(); GO TO 21 END IF READ (2, *, IOSTAT = ios) fmr_DEM_lat_min, fmr_DEM_dLat, fmr_DEM_lat_max IF (ios /= 0) THEN WRITE (*, "(' ERROR: DEM is not in .GRD format.')"); CALL Pause(); GO TO 21 END IF fmi_DEM_columns = NINT(1 + (fmr_DEM_lon_max - fmr_DEM_lon_min) / fmr_DEM_dLon) fmi_DEM_rows = NINT(1 + (fmr_DEM_lat_max - fmr_DEM_lat_min) / fmr_DEM_dLat) !We must now return to MAIN_ because there we will ALLOCATE a large permanent array. END SUBROUTINE Read_Topographic_Stress_part1 SUBROUTINE Read_Topographic_Stress_part2() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. INTEGER :: i, ios, j WRITE (*, "(' Reading DEM array...')") READ (2, *, IOSTAT = ios) ((fmim_DEM(i, j), j = 1, fmi_DEM_columns), i = 1, fmi_DEM_rows) IF (ios /= 0) THEN WRITE (*, "(' ERROR: DEM is not in .GRD format.')") WRITE (*, "(' Please correct the problem and re-run FlatMaxwell.')") CALL Pause() STOP END IF CLOSE(2) !---Moho--- READ (1, "(I12)") fmi_new_or_old_Moho READ (1, "(A)") fmc80_Moho_filename !Now returning to MAIN_, because there we must ALLOCATE a large permanent array. END SUBROUTINE Read_Topographic_Stress_part2 SUBROUTINE Read_Topographic_Stress_part3() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. INTEGER :: i, ii, j, jj, k, kk, n !---Compute_Topographic_Stress--- READ (1, "(F12.0)") fmr_vertical_resolution_m READ (1, "(F12.0)") fmr_horizontal_resolution_m READ (1, "(I12)") fmi_topo_nx READ (1, "(I12)") fmi_topo_ny READ (1, "(I12)") fmi_topo_nz READ (1, "(3F12.2)") fmrv_topo_stress_dXYZ(1:3) READ (1, "(F12.3)") fmr_Poisson_ratio END SUBROUTINE Read_Topographic_Stress_part3 SUBROUTINE Read_Topographic_Stress_part4() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. INTEGER :: i, ii, j, jj, k, kk, n READ (1, *) (kk, fmrv_reference_P_Pa(k), k = -fmi_topo_nz, fmi_topo_nz) READ (1, *) (((ii, jj, kk, (fmrt_topo_stress_anomaly_Pa(n, i, j, k), n = 1, 6), i = -fmi_topo_nx, fmi_topo_nx), j = -fmi_topo_ny, fmi_topo_ny), k = -fmi_topo_nz, fmi_topo_nz) CLOSE (1) WRITE (*, *) WRITE (*, "(' Topographic stress model (and program state) restored from save file.')") WRITE (*, "(' =====================================================================')") END SUBROUTINE Read_Topographic_Stress_part4 SUBROUTINE Tectonic_Stress_at_Point(x_meters, y_meters, z_meters, xyz_tensor, d_tau_d_c_at_point) IMPLICIT NONE REAL*8, INTENT(IN) :: x_meters, y_meters, z_meters REAL*8, DIMENSION(3, 3), INTENT(OUT), OPTIONAL :: xyz_tensor DOUBLE PRECISION, DIMENSION(6, fmi_N_coefficients), INTENT(OUT), OPTIONAL :: d_tau_d_c_at_point !NOTE: Typically, only ONE of these TWO optional arguments will be requested in one CALL. !A single subprogram is used for both because of the large amount of common code, !especially setting up the basis functions and their derivatives. !It would not be wise to have two parallel copies of such code; a bug might be fixed in only one copy! INTEGER :: i, j, k, l, m, n DOUBLE PRECISION :: common_COS, common_SIN, factor, x, x2, y, y2, z, z2 x = x_meters ! (N.B. This copy step formerly converted the coordinates to REAL*8. Now it has no effect, except safety.) y = y_meters z = z_meters x2 = x**2 y2 = y**2 z2 = z**2 !---------------------------------------------------------------------------------------------- !Evaluate all basis functions Fl(x), Fm(y), Fn(z) and their 1st- and 2nd-derivatives at these coordinates. !Presume that Define_Coefficients() has already been called, ONCE. !NOTE that Define_Coefficients() executes all statements which never change value ! {because they do not depend on postion (x, y, z)} and that here they are commented-out to save time. !Leading factor fmdv_Q(i) is individually chosen for each basis function so that the RMS value of the dominant stress component !will be ~1 over the 3-D model domain. Then, many diagonal values in linear system coefficient matrix !should also be ~1, assuming that "conditioner" cancels out 2/(sigma_b**2), and weight_per_point adds to unity, !and that the collocation points are uniformly and equally spaced within the model volume(?!?). !Note that some basis functions (those with 2 or 3 active stress components) will have higher diagonals, up to ~2.99, !even if all the previous conditions are met. !6 constant components of tau are always included: fmdv_G_at_y(1) = 0.5D0 * y2 ; fmdv_d_G_d_y_at_y(1) = y !; fmdv_d2_G_d_y2_at_y(1) = 1.0D0 ! C1 Phi_z = y2/2 !fmdv_Q(1) = 1.0D0 fmdv_F_at_x(2) = 0.5D0 * x2 ; fmdv_d_F_d_x_at_x(2) = x !; fmdv_d2_F_d_x2_at_x(2) = 1.0D0 ! C2 Phi_z = x2/2 !fmdv_Q(2) = 1.0D0 fmdv_F_at_x(3) = 0.5D0 * x2 ; fmdv_d_F_d_x_at_x(3) = x !; fmdv_d2_F_d_x2_at_x(3) = 1.0D0 ! C3 Phi_y = x2/2 !fmdv_Q(3) = 1.0D0 fmdv_G_at_y(4) = -y !; fmdv_d_G_d_y_at_y(4) = -1.0D0 ! C4 Phi_x = -yz fmdv_H_at_z(4) = z !; fmdv_d_H_d_z_at_z(4) = 1.0D0 ! C4 Phi_x = -yz !fmdv_Q(4) = 1.0D0 fmdv_F_at_x(5) = -x !; fmdv_d_F_d_x_at_x(5) = -1.0D0 ! C5 Phi_y = -xz fmdv_H_at_z(5) = z !; fmdv_d_H_d_z_at_z(5) = 1.0D0 ! C5 Phi_y = -xz !fmdv_Q(5) = 1.0D0 fmdv_F_at_x(6) = -x !; fmdv_d_F_d_x_at_x(6) = -1.0D0 ! C6 Phi_z = -xy fmdv_G_at_y(6) = y !; fmdv_d_G_d_y_at_y(6) = 1.0D0 ! C6 Phi_z = -xy !fmdv_Q(6) = 1.0D0 i = 6 IF (fmi_waves >= 0) THEN ! include 15 linear-in-space functions (#07 ~ #21): fmdv_F_at_x( 7) = x !; fmdv_d_F_d_x_at_x( 7) = 1.0D0 ! L01 Phi_z = x y^2 / (2L) fmdv_G_at_y( 7) = 0.5D0 * y2 ; fmdv_d_G_d_y_at_y( 7) = y !; fmdv_d2_G_d_y2_at_y( 7) = 1.0D0 ! L01 Phi_z = x y^2 / (2L) !fmdv_Q( 7) = 3.4641D0 / fmr_x_LENGTH_meters fmdv_F_at_x( 8) = x !; fmdv_d_F_d_x_at_x( 8) = 1.0D0 ! L02 Phi_y = x z^2 / (2L) fmdv_H_at_z( 8) = 0.5D0 * z2 ; fmdv_d_H_d_z_at_z( 8) = z !; fmdv_d2_H_d_z2_at_z( 8) = 1.0D0 ! L02 Phi_y = x z^2 / (2L) !fmdv_Q( 8) = 3.4641D0 / fmr_x_LENGTH_meters fmdv_G_at_y( 9) = y !; fmdv_d_G_d_y_at_y( 9) = 1.0D0 ! L03 Phi_y = y z^2 / (2L) fmdv_H_at_z( 9) = 0.5D0 * z2 ; fmdv_d_H_d_z_at_z( 9) = z !; fmdv_d2_H_d_z2_at_z( 9) = 1.0D0 ! L03 Phi_y = y z^2 / (2L) !fmdv_Q( 9) = 3.4641D0 / fmr_y_WIDTH_meters fmdv_G_at_y(10) = 0.5D0 * y2 ; fmdv_d_G_d_y_at_y(10) = y !; fmdv_d2_G_d_y2_at_y(10) = 1.0D0 ! L04 Phi_z = y^2 z / (2L) fmdv_H_at_z(10) = z !; fmdv_d_H_d_z_at_z(10) = 1.0D0 ! L04 Phi_z = y^2 z / (2L) !fmdv_Q(10) = 1.732D0 / fmr_z_DEPTH_meters fmdv_F_at_x(11) = x !; fmdv_d_F_d_x_at_x(11) = 1.0D0 ! L05 Phi_x = x z^2 / (2L) fmdv_H_at_z(11) = 0.5D0 * z2 ; fmdv_d_H_d_z_at_z(11) = z !; fmdv_d2_H_d_z2_at_z(11) = 1.0D0 ! L05 Phi_x = x z^2 / (2L) !fmdv_Q(11) = 3.4641D0 / fmr_x_LENGTH_meters fmdv_F_at_x(12) = 0.5D0 * x2 ; fmdv_d_F_d_x_at_x(12) = x !; fmdv_d2_F_d_x2_at_x(12) = 1.0D0 ! L06 Phi_z = x^2 y / (2L) fmdv_G_at_y(12) = y !; fmdv_d_G_d_y_at_y(12) = 1.0D0 ! L06 Phi_z = x^2 y / (2L) !fmdv_Q(12) = 3.4641D0 / fmr_x_LENGTH_meters fmdv_G_at_y(13) = y !; fmdv_d_G_d_y_at_y(13) = 1.0D0 ! L07 Phi_x = y z^2 / (2L) fmdv_H_at_z(13) = 0.5D0 * z2 ; fmdv_d_H_d_z_at_z(13) = z !; fmdv_d2_H_d_z2_at_z(13) = 1.0D0 ! L07 Phi_x = y z^2 / (2L) !fmdv_Q(13) = 3.4641D0 / fmr_y_WIDTH_meters fmdv_F_at_x(14) = 0.5D0 * x2 ; fmdv_d_F_d_x_at_x(14) = x !; fmdv_d2_F_d_x2_at_x(14) = 1.0D0 ! L08 Phi_z = x^2 z / (2L) fmdv_H_at_z(14) = z !; fmdv_d_H_d_z_at_z(14) = 1.0D0 ! L08 Phi_z = x^2 z / (2L) !fmdv_Q(14) = 1.732D0 / fmr_z_DEPTH_meters fmdv_F_at_x(15) = x !; fmdv_d_F_d_x_at_x(15) = 1.0D0 ! L09 Phi_x = x y^2 / (2L) fmdv_G_at_y(15) = 0.5D0 * y2 ; fmdv_d_G_d_y_at_y(15) = y !; fmdv_d2_G_d_y2_at_y(15) = 1.0D0 ! L09 Phi_x = x y^2 / (2L) !fmdv_Q(15) = 3.4641D0 / fmr_x_LENGTH_meters fmdv_F_at_x(16) = 0.5D0 * x2 ; fmdv_d_F_d_x_at_x(16) = x !; fmdv_d2_F_d_x2_at_x(16) = 1.0D0 ! L10 Phi_y = x^2 y / (2L) fmdv_G_at_y(16) = y !; fmdv_d_G_d_y_at_y(16) = 1.0D0 ! L10 Phi_y = x^2 y / (2L) !fmdv_Q(16) = 3.4641D0 / fmr_y_WIDTH_meters fmdv_F_at_x(17) = 0.5D0 * x2 ; fmdv_d_F_d_x_at_x(17) = x !; fmdv_d2_F_d_x2_at_x(17) = 1.0D0 ! L11 Phi_y = x^2 z / (2L) fmdv_H_at_z(17) = z !; fmdv_d_H_d_z_at_z(17) = 1.0D0 ! L11 Phi_y = x^2 z / (2L) !fmdv_Q(17) = 3.4641D0 / fmr_x_LENGTH_meters fmdv_G_at_y(18) = 0.5D0 * y2 ; fmdv_d_G_d_y_at_y(18) = y !; fmdv_d2_G_d_y2_at_y(18) = 1.0D0 ! L12 Phi_x = y^2 z / (2L) fmdv_H_at_z(18) = z !; fmdv_d_H_d_z_at_z(18) = 1.0D0 ! L12 Phi_x = y^2 z / (2L) !fmdv_Q(18) = 3.4641D0 / fmr_x_LENGTH_meters fmdv_F_at_x(19) = -x !; fmdv_d_F_d_x_at_x(19) = -1.0D0 ! L13 Phi_x = -x y z/L fmdv_G_at_y(19) = y !; fmdv_d_G_d_y_at_y(19) = 1.0D0 ! L13 Phi_x = -x y z/L fmdv_H_at_z(19) = z !; fmdv_d_H_d_z_at_z(19) = 1.0D0 ! L13 Phi_x = -x y z/L !fmdv_Q(19) = 3.4641D0 / fmr_x_LENGTH_meters fmdv_F_at_x(20) = -x !; fmdv_d_F_d_x_at_x(20) = -1.0D0 ! L13 Phi_y = -x y z/L fmdv_G_at_y(20) = y !; fmdv_d_G_d_y_at_y(20) = 1.0D0 ! L13 Phi_y = -x y z/L fmdv_H_at_z(20) = z !; fmdv_d_H_d_z_at_z(20) = 1.0D0 ! L13 Phi_y = -x y z/L !fmdv_Q(20) = 3.4641D0 / fmr_y_WIDTH_meters fmdv_F_at_x(21) = -x !; fmdv_d_F_d_x_at_x(21) = -1.0D0 ! L13 Phi_z = -x y z/L fmdv_G_at_y(21) = y !; fmdv_d_G_d_y_at_y(21) = 1.0D0 ! L13 Phi_z = -x y z/L fmdv_H_at_z(21) = z !; fmdv_d_H_d_z_at_z(21) = 1.0D0 ! L13 Phi_z = -x y z/L !fmdv_Q(21) = 1.732D0 / fmr_z_DEPTH_meters i = 21 END IF ! fmi_waves >= 0; include 15 linear-in-space functions IF (fmi_waves > 0) THEN ! include oscillating basis functions; see file basis_functions.xlsx !Presume that vectors fmdv_a,b,c(1..fmi_top_lmn) have been set in subprogram Define_Coefficients !------------------------------------------------------ !First, add 1-D oscillations: DO j = 1, 6 ! 1DO1 -- 1DO6 !WRITE (c1j, "(I1)") j !name_base = "1DO" // c1j DO k = 1, 2 ! SIN, COS DO l = 1, fmi_top_lmn i = i + 1 !WRITE (c2l, "(I2)") l !IF (c2l(1:1) == ' ') c2l(1:1) = '0' SELECT CASE(j) ! which 1DO# ? CASE(1, 2) SELECT CASE(k) CASE(1) ! SIN !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l ! -sin(ax)/a^2 !fmdv_F_at_x(i) = -SIN(fmdv_a(l)*x)/fmdv_a(l)**2 ; fmdv_d_F_d_x_at_x(i) = -COS(fmdv_a(l)*x)/fmdv_a(l) ; fmdv_d2_F_d_x2_at_x(i) = SIN(fmdv_a(l)*x) common_SIN = DSIN(fmdv_a(l)*x) fmdv_F_at_x(i) = -common_SIN/fmdv_a(l)**2 ; fmdv_d_F_d_x_at_x(i) = -DCOS(fmdv_a(l)*x)/fmdv_a(l) ; fmdv_d2_F_d_x2_at_x(i) = common_SIN !fmdv_Q(i) = 1.4142D0 CASE(2) ! COS !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l ! -cos(ax)/a^2 !fmdv_F_at_x(i) = -COS(fmdv_a(l)*x)/fmdv_a(l)**2 ; fmdv_d_F_d_x_at_x(i) = SIN(fmdv_a(l)*x)/fmdv_a(l) ; fmdv_d2_F_d_x2_at_x(i) = COS(fmdv_a(l)*x) common_COS = DCOS(fmdv_a(l)*x) fmdv_F_at_x(i) = -common_COS/fmdv_a(l)**2 ; fmdv_d_F_d_x_at_x(i) = DSIN(fmdv_a(l)*x)/fmdv_a(l) ; fmdv_d2_F_d_x2_at_x(i) = common_COS !fmdv_Q(i) = 1.41420D0 END SELECT !(k) !CASE(1) has fmiv_k(i) = 2 ! Phi_y !CASE(2) has fmiv_k(i) = 3 ! Phi_z CASE(3, 4) SELECT CASE(k) CASE(1) ! SIN !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l ! -sin(by)/b^2 !fmdv_G_at_y(i) = -SIN(fmdv_b(l)*y)/fmdv_b(l)**2 ; fmdv_d_G_d_y_at_y(i) = -COS(fmdv_b(l)*y)/fmdv_b(l) ; fmdv_d2_G_d_y2_at_y(i) = SIN(fmdv_b(l)*y) common_SIN = DSIN(fmdv_b(l)*y) fmdv_G_at_y(i) = -common_SIN/fmdv_b(l)**2 ; fmdv_d_G_d_y_at_y(i) = -DCOS(fmdv_b(l)*y)/fmdv_b(l) ; fmdv_d2_G_d_y2_at_y(i) = common_SIN !fmdv_Q(i) = 1.4142D0 CASE(2) ! COS !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l ! -cos(by)/b^2 !fmdv_G_at_y(i) = -COS(fmdv_b(l)*y)/fmdv_b(l)**2 ; fmdv_d_G_d_y_at_y(i) = SIN(fmdv_b(l)*y)/fmdv_b(l) ; fmdv_d2_G_d_y2_at_y(i) = COS(fmdv_b(l)*y) common_COS = DCOS(fmdv_b(l)*y) fmdv_G_at_y(i) = -common_COS/fmdv_b(l)**2 ; fmdv_d_G_d_y_at_y(i) = DSIN(fmdv_b(l)*y)/fmdv_b(l) ; fmdv_d2_G_d_y2_at_y(i) = common_COS !fmdv_Q(i) = 1.4142D0 END SELECT !(k) !CASE(3) has fmiv_k(i) = 1 ! Phi_x !CASE(4) has fmiv_k(i) = 3 ! Phi_z CASE(5, 6) SELECT CASE(k) CASE(1) ! SIN !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l ! -sin(cz)/c^2 !fmdv_H_at_z(i) = -SIN(fmdv_c(l)*z)/fmdv_c(l)**2 ; fmdv_d_H_d_z_at_z(i) = -COS(fmdv_c(l)*z)/fmdv_c(l) ; fmdv_d2_H_d_z2_at_z(i) = SIN(fmdv_c(l)*z) common_SIN = DSIN(fmdv_c(l)*z) fmdv_H_at_z(i) = -common_SIN/fmdv_c(l)**2 ; fmdv_d_H_d_z_at_z(i) = -DCOS(fmdv_c(l)*z)/fmdv_c(l) ; fmdv_d2_H_d_z2_at_z(i) = common_SIN !fmdv_Q(i) = 1.4142D0 CASE(2) ! COS !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l ! -cos(cz)/c^2 !fmdv_H_at_z(i) = -COS(fmdv_c(l)*z)/fmdv_c(l)**2 ; fmdv_d_H_d_z_at_z(i) = SIN(fmdv_c(l)*z)/fmdv_c(l) ; fmdv_d2_H_d_z2_at_z(i) = COS(fmdv_c(l)*z) common_COS = DCOS(fmdv_c(l)*z) fmdv_H_at_z(i) = -common_COS/fmdv_c(l)**2 ; fmdv_d_H_d_z_at_z(i) = DSIN(fmdv_c(l)*z)/fmdv_c(l) ; fmdv_d2_H_d_z2_at_z(i) = common_COS !fmdv_Q(i) = 1.4142D0 END SELECT !(k) !CASE(5) has fmiv_k(i) = 1 ! Phi_x !CASE(6) has fmiv_k(i) = 2 ! Phi_y END SELECT !(j) END DO ! l = 1, fmi_top_lmn END DO ! k = 1, 2 (SIN, COS) END DO ! j = 1, 6 (1DO#) !------------------------------------------------------ !Second, add 2-D oscillations: DO j = 1, 6 ! 2DO# !WRITE (c1j, "(I1)") j !name_base = "2DO" // c1j DO k = 1, 4 ! SS, CS, SC, CC DO l = 1, fmi_top_lmn DO m = 1, fmi_top_lmn i = i + 1 !WRITE (c2l, "(I2)") l !IF (c2l(1:1) == ' ') c2l(1:1) = '0' !WRITE (c2m, "(I2)") m !IF (c2m(1:1) == ' ') c2m(1:1) = '0' SELECT CASE(j) CASE(1, 2) ! sin(by) sin(cz) SELECT CASE(k) CASE(1) ! SIN SIN !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'S' // c2m !fmdv_G_at_y(i) = SIN(fmdv_b(l)*y) ; fmdv_d_G_d_y_at_y(i) = fmdv_b(l)*COS(fmdv_b(l)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(l)**2)*SIN(fmdv_b(l)*y) common_SIN = DSIN(fmdv_b(l)*y) fmdv_G_at_y(i) = common_SIN ; fmdv_d_G_d_y_at_y(i) = fmdv_b(l)*DCOS(fmdv_b(l)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(l)**2)*common_SIN !fmdv_H_at_z(i) = SIN(fmdv_c(m)*z) ; fmdv_d_H_d_z_at_z(i) = fmdv_c(m)*COS(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*SIN(fmdv_c(m)*z) common_SIN = DSIN(fmdv_c(m)*z) fmdv_H_at_z(i) = common_SIN ; fmdv_d_H_d_z_at_z(i) = fmdv_c(m)*DCOS(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*common_SIN CASE(2) ! COS SIN !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'S' // c2m !fmdv_G_at_y(i) = COS(fmdv_b(l)*y) ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(l)*SIN(fmdv_b(l)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(l)**2)*COS(fmdv_b(l)*y) common_COS = DCOS(fmdv_b(l)*y) fmdv_G_at_y(i) = common_COS ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(l)*DSIN(fmdv_b(l)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(l)**2)*common_COS !fmdv_H_at_z(i) = SIN(fmdv_c(m)*z) ; fmdv_d_H_d_z_at_z(i) = fmdv_c(m)*COS(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*SIN(fmdv_c(m)*z) common_SIN = DSIN(fmdv_c(m)*z) fmdv_H_at_z(i) = common_SIN ; fmdv_d_H_d_z_at_z(i) = fmdv_c(m)*DCOS(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*common_SIN CASE(3) ! SIN COS !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'C' // c2m !fmdv_G_at_y(i) = SIN(fmdv_b(l)*y) ; fmdv_d_G_d_y_at_y(i) = fmdv_b(l)*COS(fmdv_b(l)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(l)**2)*SIN(fmdv_b(l)*y) common_SIN = DSIN(fmdv_b(l)*y) fmdv_G_at_y(i) = common_SIN ; fmdv_d_G_d_y_at_y(i) = fmdv_b(l)*DCOS(fmdv_b(l)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(l)**2)*common_SIN !fmdv_H_at_z(i) = COS(fmdv_c(m)*z) ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(m)*SIN(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*COS(fmdv_c(m)*z) common_COS = DCOS(fmdv_c(m)*z) fmdv_H_at_z(i) = common_COS ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(m)*DSIN(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*common_COS CASE(4) ! COS COS !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'C' // c2m !fmdv_G_at_y(i) = COS(fmdv_b(l)*y) ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(l)*SIN(fmdv_b(l)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(l)**2)*COS(fmdv_b(l)*y) common_COS = DCOS(fmdv_b(l)*y) fmdv_G_at_y(i) = common_COS ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(l)*DSIN(fmdv_b(l)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(l)**2)*common_COS !fmdv_H_at_z(i) = COS(fmdv_c(m)*z) ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(m)*SIN(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*COS(fmdv_c(m)*z) common_COS = DCOS(fmdv_c(m)*z) fmdv_H_at_z(i) = common_COS ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(m)*DSIN(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*common_COS END SELECT ! (k) !IF (j == 1) THEN ! fmdv_Q(i) = 2.0D0 / MAX(fmdv_b(l), fmdv_c(m))**2 !ELSE ! j == 2 ! fmdv_Q(i) = 2.0D0 / fmdv_c(m)**2 !END IF !CASE(1) has fmiv_k(i) = 1 ! Phi_x !CASE(2) has fmiv_k(i) = 2 ! Phi_y CASE(3, 4) ! sin(ax) sin(cz) SELECT CASE(k) CASE(1) ! SIN SIN !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'S' // c2m !fmdv_F_at_x(i) = SIN(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*COS(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*SIN(fmdv_a(l)*x) common_SIN = DSIN(fmdv_a(l)*x) fmdv_F_at_x(i) = common_SIN ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*DCOS(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_SIN !fmdv_H_at_z(i) = SIN(fmdv_c(m)*z) ; fmdv_d_H_d_z_at_z(i) = fmdv_c(m)*COS(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*SIN(fmdv_c(m)*z) common_SIN = DSIN(fmdv_c(m)*z) fmdv_H_at_z(i) = common_SIN ; fmdv_d_H_d_z_at_z(i) = fmdv_c(m)*DCOS(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*common_SIN !fmdv_Q(i) = 2.0D0 / MAX(fmdv_a(l), fmdv_c(m))**2 CASE(2) ! COS SIN !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'S' // c2m !fmdv_F_at_x(i) = COS(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*SIN(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*COS(fmdv_a(l)*x) common_COS = DCOS(fmdv_a(l)*x) fmdv_F_at_x(i) = common_COS ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*DSIN(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_COS !fmdv_H_at_z(i) = SIN(fmdv_c(m)*z) ; fmdv_d_H_d_z_at_z(i) = fmdv_c(m)*COS(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*SIN(fmdv_c(m)*z) common_SIN = DSIN(fmdv_c(m)*z) fmdv_H_at_z(i) = common_SIN ; fmdv_d_H_d_z_at_z(i) = fmdv_c(m)*DCOS(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*common_SIN !fmdv_Q(i) = 2.0D0 / MAX(fmdv_a(l), fmdv_c(m))**2 CASE(3) ! SIN COS !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'C' // c2m !fmdv_F_at_x(i) = SIN(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*COS(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*SIN(fmdv_a(l)*x) common_SIN = DSIN(fmdv_a(l)*x) fmdv_F_at_x(i) = common_SIN ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*DCOS(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_SIN !fmdv_H_at_z(i) = COS(fmdv_c(m)*z) ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(m)*SIN(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*COS(fmdv_c(m)*z) common_COS = DCOS(fmdv_c(m)*z) fmdv_H_at_z(i) = common_COS ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(m)*DSIN(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*common_COS !fmdv_Q(i) = 2.0D0 / MAX(fmdv_a(l), fmdv_c(m))**2 CASE(4) ! COS COS !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'C' // c2m !fmdv_F_at_x(i) = COS(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*SIN(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*COS(fmdv_a(l)*x) common_COS = DCOS(fmdv_a(l)*x) fmdv_F_at_x(i) = common_COS ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*DSIN(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_COS !fmdv_H_at_z(i) = COS(fmdv_c(m)*z) ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(m)*SIN(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*COS(fmdv_c(m)*z) common_COS = DCOS(fmdv_c(m)*z) fmdv_H_at_z(i) = common_COS ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(m)*DSIN(fmdv_c(m)*z) ; fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(m)**2)*common_COS !fmdv_Q(i) = 2.0D0 / MAX(fmdv_a(l), fmdv_c(m))**2 END SELECT ! (k) !IF (j == 3) THEN ! fmdv_Q(i) = 2.0D0 / fmdv_c(m)**2 !ELSE ! j == 4 ! fmdv_Q(i) = 2.0D0 / MAX(fmdv_a(l), fmdv_c(m))**2 !END IF !CASE(3) has fmiv_k(i) = 1 ! Phi_x !CASE(4) has fmiv_k(i) = 2 ! Phi_y CASE(5, 6) ! sin(ax) sin(by) SELECT CASE(k) CASE(1) ! SIN SIN !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'S' // c2m !fmdv_F_at_x(i) = SIN(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*COS(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*SIN(fmdv_a(l)*x) common_SIN = DSIN(fmdv_a(l)*x) fmdv_F_at_x(i) = common_SIN ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*DCOS(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_SIN !fmdv_G_at_y(i) = SIN(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*COS(fmdv_b(m)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*SIN(fmdv_b(m)*y) common_SIN = DSIN(fmdv_b(m)*y) fmdv_G_at_y(i) = common_SIN ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*DCOS(fmdv_b(m)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_SIN CASE(2) ! COS SIN !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'S' // c2m !fmdv_F_at_x(i) = COS(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*SIN(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*COS(fmdv_a(l)*x) common_COS = DCOS(fmdv_a(l)*x) fmdv_F_at_x(i) = common_COS ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*DSIN(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_COS !fmdv_G_at_y(i) = SIN(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*COS(fmdv_b(m)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*SIN(fmdv_b(m)*y) common_SIN = DSIN(fmdv_b(m)*y) fmdv_G_at_y(i) = common_SIN ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*DCOS(fmdv_b(m)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_SIN CASE(3) ! SIN COS !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'C' // c2m !fmdv_F_at_x(i) = SIN(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*COS(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*SIN(fmdv_a(l)*x) common_SIN = DSIN(fmdv_a(l)*x) fmdv_F_at_x(i) = common_SIN ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*DCOS(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_SIN !fmdv_G_at_y(i) = COS(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*SIN(fmdv_b(m)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*COS(fmdv_b(m)*y) common_COS = DCOS(fmdv_b(m)*y) fmdv_G_at_y(i) = common_COS ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*DSIN(fmdv_b(m)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_COS CASE(4) ! COS COS !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'C' // c2m !fmdv_F_at_x(i) = COS(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*SIN(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*COS(fmdv_a(l)*x) common_COS = DCOS(fmdv_a(l)*x) fmdv_F_at_x(i) = common_COS ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*DSIN(fmdv_a(l)*x) ; fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_COS !fmdv_G_at_y(i) = COS(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*SIN(fmdv_b(m)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*COS(fmdv_b(m)*y) common_COS = DCOS(fmdv_b(m)*y) fmdv_G_at_y(i) = common_COS ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*DSIN(fmdv_b(m)*y) ; fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_COS END SELECT ! (k) !IF (j == 5) THEN ! fmdv_Q(i) = 2.0D0 / fmdv_b(m)**2 !ELSE ! j == 6 ! fmdv_Q(i) = 2.0D0 / MAX(fmdv_a(l), fmdv_b(m))**2 !END IF !CASE(5) has fmiv_k(i) = 1 ! Phi_x !CASE(6) has fmiv_k(i) = 3 ! Phi_z END SELECT !(j) END DO ! m = 1, fmi_top_lmn END DO ! l = 1, fmi_top_lmn END DO ! k = 1, 4 (SS, CS, SC, CC) END DO ! j = 1, 6 (2DO#) !------------------------------------------------------ !Third, add 3-D oscillations: DO j = 1, 3 ! 3DO# !WRITE (c1j, "(I1)") j !name_base = "3DO" // c1j !NOTE that component functions in this group are independent of j; only fmiv_k(i) = j, and that was already set in Define_Coefficients. DO k = 1, 8 ! SSS, CSS, SCS, CCS, SSC, CSC, SCC, CCC DO l = 1, fmi_top_lmn DO m = 1, fmi_top_lmn DO n = 1, fmi_top_lmn i = i + 1 !WRITE (c2l, "(I2)") l !IF (c2l(1:1) == ' ') c2l(1:1) = '0' !WRITE (c2m, "(I2)") m !IF (c2m(1:1) == ' ') c2m(1:1) = '0' !WRITE (c2n, "(I2)") n !IF (c2n(1:1) == ' ') c2n(1:1) = '0' SELECT CASE(k) CASE(1) ! SIN SIN SIN !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'S' // c2m // 'S' // c2n !fmdv_F_at_x(i) = SIN(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*COS(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*SIN(fmdv_a(l)*x) common_SIN = DSIN(fmdv_a(l)*x) fmdv_F_at_x(i) = common_SIN ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*DCOS(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_SIN !fmdv_G_at_y(i) = SIN(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*COS(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*SIN(fmdv_b(m)*y) common_SIN = DSIN(fmdv_b(m)*y) fmdv_G_at_y(i) = common_SIN ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*DCOS(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_SIN !fmdv_H_at_z(i) = SIN(fmdv_c(n)*z) ; fmdv_d_H_d_z_at_z(i) = fmdv_c(n)*COS(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*SIN(fmdv_c(n)*z) common_SIN = DSIN(fmdv_c(n)*z) fmdv_H_at_z(i) = common_SIN ; fmdv_d_H_d_z_at_z(i) = fmdv_c(n)*DCOS(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*common_SIN CASE(2) ! COS SIN SIN !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'S' // c2m // 'S' // c2n !fmdv_F_at_x(i) = COS(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*SIN(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*COS(fmdv_a(l)*x) common_COS = DCOS(fmdv_a(l)*x) fmdv_F_at_x(i) = common_COS ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*DSIN(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_COS !fmdv_G_at_y(i) = SIN(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*COS(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*SIN(fmdv_b(m)*y) common_SIN = DSIN(fmdv_b(m)*y) fmdv_G_at_y(i) = common_SIN ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*DCOS(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_SIN !fmdv_H_at_z(i) = SIN(fmdv_c(n)*z) ; fmdv_d_H_d_z_at_z(i) = fmdv_c(n)*COS(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*SIN(fmdv_c(n)*z) common_SIN = DSIN(fmdv_c(n)*z) fmdv_H_at_z(i) = common_SIN ; fmdv_d_H_d_z_at_z(i) = fmdv_c(n)*DCOS(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*common_SIN CASE(3) ! SIN COS SIN !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'C' // c2m // 'S' // c2n !fmdv_F_at_x(i) = SIN(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*COS(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*SIN(fmdv_a(l)*x) common_SIN = DSIN(fmdv_a(l)*x) fmdv_F_at_x(i) = common_SIN ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*DCOS(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_SIN !fmdv_G_at_y(i) = COS(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*SIN(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*COS(fmdv_b(m)*y) common_COS = DCOS(fmdv_b(m)*y) fmdv_G_at_y(i) = common_COS ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*DSIN(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_COS !fmdv_H_at_z(i) = SIN(fmdv_c(n)*z) ; fmdv_d_H_d_z_at_z(i) = fmdv_c(n)*COS(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*SIN(fmdv_c(n)*z) common_SIN = DSIN(fmdv_c(n)*z) fmdv_H_at_z(i) = common_SIN ; fmdv_d_H_d_z_at_z(i) = fmdv_c(n)*DCOS(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*common_SIN CASE(4) ! COS COS SIN !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'C' // c2m // 'S' // c2n !fmdv_F_at_x(i) = COS(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*SIN(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*COS(fmdv_a(l)*x) common_COS = DCOS(fmdv_a(l)*x) fmdv_F_at_x(i) = common_COS ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*DSIN(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_COS !fmdv_G_at_y(i) = COS(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*SIN(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*COS(fmdv_b(m)*y) common_COS = DCOS(fmdv_b(m)*y) fmdv_G_at_y(i) = common_COS ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*DSIN(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_COS !fmdv_H_at_z(i) = SIN(fmdv_c(n)*z) ; fmdv_d_H_d_z_at_z(i) = fmdv_c(n)*COS(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*SIN(fmdv_c(n)*z) common_SIN = DSIN(fmdv_c(n)*z) fmdv_H_at_z(i) = common_SIN ; fmdv_d_H_d_z_at_z(i) = fmdv_c(n)*DCOS(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*common_SIN CASE(5) ! SIN SIN COS !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'S' // c2m // 'C' // c2n !fmdv_F_at_x(i) = SIN(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*COS(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*SIN(fmdv_a(l)*x) common_SIN = DSIN(fmdv_a(l)*x) fmdv_F_at_x(i) = common_SIN ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*DCOS(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_SIN !fmdv_G_at_y(i) = SIN(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*COS(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*SIN(fmdv_b(m)*y) common_SIN = DSIN(fmdv_b(m)*y) fmdv_G_at_y(i) = common_SIN ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*DCOS(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_SIN !fmdv_H_at_z(i) = COS(fmdv_c(n)*z) ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(n)*SIN(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*COS(fmdv_c(n)*z) common_COS = DCOS(fmdv_c(n)*z) fmdv_H_at_z(i) = common_COS ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(n)*DSIN(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*common_COS CASE(6) ! COS SIN COS !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'S' // c2m // 'C' // c2n !fmdv_F_at_x(i) = COS(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*SIN(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*COS(fmdv_a(l)*x) common_COS = DCOS(fmdv_a(l)*x) fmdv_F_at_x(i) = common_COS ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*DSIN(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_COS !fmdv_G_at_y(i) = SIN(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*COS(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*SIN(fmdv_b(m)*y) common_SIN = DSIN(fmdv_b(m)*y) fmdv_G_at_y(i) = common_SIN ; fmdv_d_G_d_y_at_y(i) = fmdv_b(m)*DCOS(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_SIN !fmdv_H_at_z(i) = COS(fmdv_c(n)*z) ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(n)*SIN(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*COS(fmdv_c(n)*z) common_COS = DCOS(fmdv_c(n)*z) fmdv_H_at_z(i) = common_COS ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(n)*DSIN(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*common_COS CASE(7) ! SIN COS COS !fmc13v_name(i) = TRIM(name_base) // 'S' // c2l // 'C' // c2m // 'C' // c2n !fmdv_F_at_x(i) = SIN(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*COS(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*SIN(fmdv_a(l)*x) common_SIN = DSIN(fmdv_a(l)*x) fmdv_F_at_x(i) = common_SIN ; fmdv_d_F_d_x_at_x(i) = fmdv_a(l)*DCOS(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_SIN !fmdv_G_at_y(i) = COS(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*SIN(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*COS(fmdv_b(m)*y) common_COS = DCOS(fmdv_b(m)*y) fmdv_G_at_y(i) = common_COS ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*DSIN(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_COS !fmdv_H_at_z(i) = COS(fmdv_c(n)*z) ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(n)*SIN(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*COS(fmdv_c(n)*z) common_COS = DCOS(fmdv_c(n)*z) fmdv_H_at_z(i) = common_COS ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(n)*DSIN(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*common_COS CASE(8) ! COS COS COS !fmc13v_name(i) = TRIM(name_base) // 'C' // c2l // 'C' // c2m // 'C' // c2n !fmdv_F_at_x(i) = COS(fmdv_a(l)*x) ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*SIN(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*COS(fmdv_a(l)*x) common_COS = DCOS(fmdv_a(l)*x) fmdv_F_at_x(i) = common_COS ; fmdv_d_F_d_x_at_x(i) = -fmdv_a(l)*DSIN(fmdv_a(l)*x); fmdv_d2_F_d_x2_at_x(i) = -(fmdv_a(l)**2)*common_COS !fmdv_G_at_y(i) = COS(fmdv_b(m)*y) ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*SIN(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*COS(fmdv_b(m)*y) common_COS = DCOS(fmdv_b(m)*y) fmdv_G_at_y(i) = common_COS ; fmdv_d_G_d_y_at_y(i) = -fmdv_b(m)*DSIN(fmdv_b(m)*y); fmdv_d2_G_d_y2_at_y(i) = -(fmdv_b(m)**2)*common_COS !fmdv_H_at_z(i) = COS(fmdv_c(n)*z) ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(n)*SIN(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*COS(fmdv_c(n)*z) common_COS = DCOS(fmdv_c(n)*z) fmdv_H_at_z(i) = common_COS ; fmdv_d_H_d_z_at_z(i) = -fmdv_c(n)*DSIN(fmdv_c(n)*z); fmdv_d2_H_d_z2_at_z(i) = -(fmdv_c(n)**2)*common_COS END SELECT !(k) !SELECT CASE(j) !CASE(1) ! fmdv_Q(i) = 2.8284D0 / MAX(fmdv_b(m), fmdv_c(n))**2 !CASE(2) ! fmdv_Q(i) = 2.8284D0 / MAX(fmdv_a(l), fmdv_c(n))**2 !CASE(3) ! fmdv_Q(i) = 2.8284D0 / MAX(fmdv_a(l), fmdv_b(m))**2 !END SELECT ! on j; component of Maxwell vector field !SELECT CASE(j) <=== this code moved to subprogram Define_Coefficients !CASE(1) ! fmiv_k(i) = 1 ! Phi_x !CASE(2) ! fmiv_k(i) = 2 ! Phi_y !CASE(3) ! fmiv_k(i) = 3 ! Phi_z !END SELECT !(j) END DO ! n = 1, fmi_top_lmn END DO ! m = 1, fmi_top_lmn END DO ! l = 1, fmi_top_lmn END DO ! k = 1, 8 (SSS, CSS, SCS, CCS, SSC, CSC, SCC, CCC) END DO ! j = 1, 3 (3DO#) END IF ! fmi_waves > 0 !-------------------------------------------------------------------------------------------------- IF (PRESENT(xyz_tensor)) THEN ! compute tectonic stress tensor tau as sum of coefficients times basis functions: !initialize sums for diagonal and upper triangle (only): xyz_tensor = 0.0D0 ! all 3 x 3 DO i = 1, fmi_N_coefficients SELECT CASE (fmiv_k(i)) ! look-up which component of Maxwell potential vector is non-zero in this basis function: CASE (1) ! Phi_x is non-zero !first term in t_yy is 2nd-z-derivative of the x(k=1)-component of vector potential: xyz_tensor(2, 2) = xyz_tensor(2, 2) + fmdv_coefficients(i, 1) * fmdv_Q(i) * & & fmdv_F_at_x(i) * fmdv_G_at_y(i) * fmdv_d2_H_d_z2_at_z(i) !only term in t_yz is MINUS the cross-derivative of the x(k=1)-component of vector potential: xyz_tensor(2, 3) = xyz_tensor(2, 3) - fmdv_coefficients(i, 1) * fmdv_Q(i) * & & fmdv_F_at_x(i) * fmdv_d_G_d_y_at_y(i) * fmdv_d_H_d_z_at_z(i) !second term in t_zz is 2nd-y-derivative of the x(k=1)-component of vector potential: xyz_tensor(3, 3) = xyz_tensor(3, 3) + fmdv_coefficients(i, 1) * fmdv_Q(i) * & & fmdv_F_at_x(i) * fmdv_d2_G_d_y2_at_y(i) * fmdv_H_at_z(i) CASE (2) ! Phi_y is non-zero !second term in t_xx is 2nd-z-derivative of the y(k=2)-component of vector potential: xyz_tensor(1, 1) = xyz_tensor(1, 1) + fmdv_coefficients(i, 1) * fmdv_Q(i) * & & fmdv_F_at_x(i) * fmdv_G_at_y(i) * fmdv_d2_H_d_z2_at_z(i) !only term in t_xz is MINUS the cross-derivative of the y(k=2)-component of vector potential: xyz_tensor(1, 3) = xyz_tensor(1, 3) - fmdv_coefficients(i, 1) * fmdv_Q(i) * & & fmdv_d_F_d_x_at_x(i) * fmdv_G_at_y(i) * fmdv_d_H_d_z_at_z(i) !first term in t_zz is 2nd-x-derivative of the y(k=2)-component of vector potential: xyz_tensor(3, 3) = xyz_tensor(3, 3) + fmdv_coefficients(i, 1) * fmdv_Q(i) * & & fmdv_d2_F_d_x2_at_x(i) * fmdv_G_at_y(i) * fmdv_H_at_z(i) CASE (3) ! Phi_z is non-zero !first term in t_xx is 2nd-y-derivative of the z(k=3)-component of vector potential: xyz_tensor(1, 1) = xyz_tensor(1, 1) + fmdv_coefficients(i, 1) * fmdv_Q(i) * & & fmdv_F_at_x(i) * fmdv_d2_G_d_y2_at_y(i) * fmdv_H_at_z(i) !only term in t_xy is MINUS the cross-derivative of the z(k=3)-component of vector potential: xyz_tensor(1, 2) = xyz_tensor(1, 2) - fmdv_coefficients(i, 1) * fmdv_Q(i) * & & fmdv_d_F_d_x_at_x(i) * fmdv_d_G_d_y_at_y(i) * fmdv_H_at_z(i) !second term in t_yy is 2nd-x-derivative of the z(k=3)-component of vector potential: xyz_tensor(2, 2) = xyz_tensor(2, 2) + fmdv_coefficients(i, 1) * fmdv_Q(i) * & & fmdv_d2_F_d_x2_at_x(i) * fmdv_G_at_y(i) * fmdv_H_at_z(i) END SELECT END DO ! sum over all coefficients * (particular derivatives of) basis functions !complete the tectonic stress anomaly tensor, using its symmetry: xyz_tensor(2, 1) = xyz_tensor(1, 2) xyz_tensor(3, 1) = xyz_tensor(1, 3) xyz_tensor(3, 2) = xyz_tensor(2, 3) END IF ! PRESENT(xyz_tensor); computing tectonic stress tau !NOTE that most CALLs to this routine will only request the output above or the output below, not both. IF (PRESENT(d_tau_d_c_at_point)) THEN ! compute derivatives of tectonic stress tensor tau with respect to solution coefficients: !First subscript: 1) tau_xx, 2) tau_yy, 3) tau_zz, 4) tau_yz, 5) tau_xz, 6) tau_xy !dir$ loop count min(64) DO i = 1, fmi_N_coefficients SELECT CASE (fmiv_k(i)) CASE(1) ! Phi_x is non-zero !EFFECTS OF X-COMPONENT OF MAXWELL VECTOR POTENTIAL: !first term in t_yy is 2nd-z-derivative of the x(k=1)-component of vector potential: d_tau_d_c_at_point(2, i) = fmdv_Q(i) * fmdv_F_at_x(i) * fmdv_G_at_y(i) * fmdv_d2_H_d_z2_at_z(i) !only term in t_yz is MINUS the cross-derivative of the x(k=1)-component of vector potential: d_tau_d_c_at_point(4, i) = -fmdv_Q(i) * fmdv_F_at_x(i) * fmdv_d_G_d_y_at_y(i) * fmdv_d_H_d_z_at_z(i) !second term in t_zz is 2nd-y-derivative of the x(k=1)-component of vector potential: d_tau_d_c_at_point(3, i) = fmdv_Q(i) * fmdv_F_at_x(i) * fmdv_d2_G_d_y2_at_y(i) * fmdv_H_at_z(i) CASE(2) ! Phi_y is non-zero !EFFECTS OF Y-COMPONENT OF MAXWELL VECTOR POTENTIAL: !second term in t_xx is 2nd-z-derivative of the y(k=2)-component of vector potential: d_tau_d_c_at_point(1, i) = fmdv_Q(i) * fmdv_F_at_x(i) * fmdv_G_at_y(i) * fmdv_d2_H_d_z2_at_z(i) !only term in t_xz is MINUS the cross-derivative of the y(k=2)-component of vector potential: d_tau_d_c_at_point(5, i) = -fmdv_Q(i) * fmdv_d_F_d_x_at_x(i) * fmdv_G_at_y(i) * fmdv_d_H_d_z_at_z(i) !first term in t_zz is 2nd-x-derivative of the y(k=2)-component of vector potential: d_tau_d_c_at_point(3, i) = fmdv_Q(i) * fmdv_d2_F_d_x2_at_x(i) * fmdv_G_at_y(i) * fmdv_H_at_z(i) CASE(3) ! Phi_z is non-zero !EFFECTS OF Z-COMPONENT OF MAXWELL VECTOR POTENTIAL: !first term in t_xx is 2nd-y-derivative of the z(k=3)-component of vector potential: d_tau_d_c_at_point(1, i) = fmdv_Q(i) * fmdv_F_at_x(i) * fmdv_d2_G_d_y2_at_y(i) * fmdv_H_at_z(i) !only term in t_xy is MINUS the cross-derivative of the z(k=3)-component of vector potential: d_tau_d_c_at_point(6, i) = -fmdv_Q(i) * fmdv_d_F_d_x_at_x(i) * fmdv_d_G_d_y_at_y(i) * fmdv_H_at_z(i) !second term in t_yy is 2nd-x-derivative of the z(k=3)-component of vector potential: d_tau_d_c_at_point(2, i) = fmdv_Q(i) * fmdv_d2_F_d_x2_at_x(i) * fmdv_G_at_y(i) * fmdv_H_at_z(i) !CASE DEFAULT ! WRITE (*, "(' ERROR: fmiv_k(',I6,') = ',I12,' but only legal values are 1, 2, or 3.')") i, fmiv_k(i) ! CALL Pause() ! STOP END SELECT END DO ! i = 1, fmi_N_coefficients END IF ! PRESENT(d_tau_d_c_at_point); computing partial derivatives of tectonic stress tau with respect to solution coefficients END SUBROUTINE Tectonic_Stress_at_Point SUBROUTINE Tectonic_Stress_on_Grid() !Evaluate tectonic stress (tau_tensor_xyz; array called fmrt_tectonic_stress_anomaly_Pa) !tensors on a grid parallel to that which stores topographic stress. IMPLICIT NONE INTEGER :: i, j, k, N_points, old_percent_done, percent_done, points_done LOGICAL :: DEM_success, Reject_success REAL*8 :: grad_h_x, grad_h_y, lat, lon, surface, x_meters, y_meters, z_meters REAL*8, DIMENSION(3, 3) :: xyz_tensor WRITE (*, *) WRITE (*, "(' Evaluating tectonic stress at points on a 3-D grid...')") WRITE (*, *) ! so following '+' WRITE does not cover the line above. N_points = (1 + 2 * fmi_topo_nx) * (1 + 2 * fmi_topo_ny) * (1 + 2 * fmi_topo_nz) points_done = 0 old_percent_done = -1 DO i = -fmi_topo_nx, fmi_topo_nx x_meters = i * fmrv_topo_stress_dXYZ(1) DO j = -fmi_topo_ny, fmi_topo_ny y_meters = j * fmrv_topo_stress_dXYZ(2) CALL DEM_Lookup(x_meters, y_meters, & & Reject_success, lon, lat, & & DEM_success, surface, grad_h_x, grad_h_y) DO k = -fmi_topo_nz, fmi_topo_nz z_meters = -0.5D0 * fmr_z_DEPTH_meters + k * fmrv_topo_stress_dXYZ(3) IF (z_meters >= surface) THEN ! in the water! fmrt_tectonic_stress_anomaly_Pa(1, i, j, k) = 0.0D0 fmrt_tectonic_stress_anomaly_Pa(2, i, j, k) = 0.0D0 fmrt_tectonic_stress_anomaly_Pa(3, i, j, k) = 0.0D0 fmrt_tectonic_stress_anomaly_Pa(4, i, j, k) = 0.0D0 fmrt_tectonic_stress_anomaly_Pa(5, i, j, k) = 0.0D0 fmrt_tectonic_stress_anomaly_Pa(6, i, j, k) = 0.0D0 ELSE ! underground CALL Tectonic_Stress_at_Point(x_meters = x_meters, y_meters = y_meters, z_meters = z_meters, xyz_tensor = xyz_tensor) !First subscript: 1) s_xx, 2) s_yy, 3) s_zz, 4) s_yz, 5) s_xz, 6) s_xy fmrt_tectonic_stress_anomaly_Pa(1, i, j, k) = xyz_tensor(1, 1) fmrt_tectonic_stress_anomaly_Pa(2, i, j, k) = xyz_tensor(2, 2) fmrt_tectonic_stress_anomaly_Pa(3, i, j, k) = xyz_tensor(3, 3) fmrt_tectonic_stress_anomaly_Pa(4, i, j, k) = xyz_tensor(2, 3) fmrt_tectonic_stress_anomaly_Pa(5, i, j, k) = xyz_tensor(1, 3) fmrt_tectonic_stress_anomaly_Pa(6, i, j, k) = xyz_tensor(1, 2) END IF ! in the water, or underground? points_done = points_done + 1 percent_done = NINT(100.0D0 * (1.0D0 * points_done) / (1.0D0 * N_points)) IF (percent_done > old_percent_done) THEN WRITE (*, "('+ ',I3,'% done...')") percent_done old_percent_done = percent_done END IF END DO END DO END DO WRITE (*, *) END SUBROUTINE Tectonic_Stress_on_Grid SUBROUTINE Write_INI_file IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. INTEGER :: ios OPEN (UNIT = 91, FILE = "FlatMaxwell.ini") ! unconditional OPEN; overwrites any existing file. WRITE (91, "(A)") TRIM(fmc132_path_in) WRITE (91, "(I12, ' fmi_new_or_old_topographic')") fmi_new_or_old_topographic WRITE (91, "(I12, ' fmi_projection_choice')") fmi_projection_choice ! = 4 WRITE (91, "(F12.0, ' fmr_radius_meters')") fmr_radius_meters ! = 6371000. WRITE (91, "(F12.3, ' fmr_projpoint_Elon')") fmr_projpoint_Elon ! = -118. WRITE (91, "(F12.3, ' fmr_projpoint_Nlat')") fmr_projpoint_Nlat ! = 34. WRITE (91, "(F12.3, ' fmr_belt_azimuth_degrees')") fmr_belt_azimuth_degrees ! = 90.0 WRITE (91, "(F12.3, ' fmr_cone_lat')") fmr_cone_lat ! = 90. WRITE (91, "(F12.3, ' fmr_cone_lon')") fmr_cone_lon ! = 0. WRITE (91, "(F12.3, ' fmr_standard_parallel_gap_degrees')") fmr_standard_parallel_gap_degrees ! = 30.0 WRITE (91, "(F12.0, ' fmr_x_LENGTH_meters')") fmr_x_LENGTH_meters ! = 750000. WRITE (91, "(F12.0, ' fmr_y_WIDTH_meters')") fmr_y_WIDTH_meters ! = 600000. WRITE (91, "(F12.0, ' fmr_z_DEPTH_meters')") fmr_z_DEPTH_meters ! = 100000. ! intentionally deeper than mean LAB below WRITE (91, "(F12.9, ' fmr_gravity')") fmr_gravity ! = 9.7964938296 ! World Geodetic System 1984 (at 34 North) WRITE (91, "(F12.0, ' fmr_1_bar')") fmr_1_bar ! = 101325. ! Wikipedia "Atmospheric pressure" 2013.10 WRITE (91, "(F12.0, ' fmr_atmosphere_scale_height_meters')") fmr_atmosphere_scale_height_meters ! = 8435. ! Wikipedia "Atmospheric pressure" 2013.10 WRITE (91, "(F12.0, ' fmr_seawater_density')") fmr_seawater_density ! = 1025. ! Wikipedia "Seawater" 2013.10 WRITE (91, "(F12.0, ' fmr_Moho_depth')") fmr_Moho_depth ! = 25000. ! eyeball average of coastal values from Tape et al. [2012, SRL] WRITE (91, "(F12.0, ' fmr_crustal_density_at_top')") fmr_crustal_density_at_top ! = 2500. ! less than 2670 of shields due to sedimentary rocks WRITE (91, "(F12.0, ' fmr_crustal_density_at_Moho')") fmr_crustal_density_at_Moho ! = 2957. ! Hyndman & Drury (1977, DSDP37-13): MAR gabbro. WRITE (91, "(F12.0, ' fmr_mantle_density_at_Moho')") fmr_mantle_density_at_Moho ! = 3230. ! scaled from value below, density 3300 at 0 C, and Moho and LAB depths WRITE (91, "(F12.0, ' fmr_mantle_density_at_LAB')") fmr_mantle_density_at_LAB ! = 3125. ! my ESS 246 lecture notes on "Density Moments" WRITE (91, "(F12.0, ' fmr_LAB_depth')") fmr_LAB_depth ! = 63000. ! rough visual average from SHELLS_for_CSM-unfaulted_OrbData.feg, 2012 WRITE (91, "(A)") TRIM(fmc80_DEM_filename) ! = "ETOPO5.grd" WRITE (91, "(I12, ' fmi_new_or_old_Moho')") fmi_new_or_old_Moho ! = 2 ! using seismic Moho from Carl Tape WRITE (91, "(A)") TRIM(fmc80_Moho_filename) ! = "Tape_et_al_2012_seismic_Moho.grd" WRITE (91, "(F12.0, ' fmr_vertical_resolution_m')") fmr_vertical_resolution_m ! = 2500. ! fine vertical resolution is needed because seismogenic zone may be only 10~15 km deep. WRITE (91, "(F12.0, ' fmr_horizontal_resolution_m')") fmr_horizontal_resolution_m ! = 20000. ! good for graphics; at finer lateral resolution, too many tiny symbols! WRITE (91, "(F12.3, ' fmr_Poisson_ratio')") fmr_Poisson_ratio ! = 0.25 !---- end of topographic model parameters; beginning tectonic model parameters ------- WRITE (91, "(I12, ' fmi_new_or_old_tectonic')") fmi_new_or_old_tectonic ! = 1 WRITE (91, "(I12, ' fmi_tectonic_model_mode')") fmi_tectonic_model_mode ! = 2 ! fit to WSM data *AND* existing CSM model WRITE (91, "(D12.4, ' fmd_WSM_group_weight')") fmd_WSM_group_weight ! = 0.5D0 WRITE (91, "(I12, ' fmi_waves')") fmi_waves ! = 4 ! probably requires ~12 hours on a 16x parallel computer. WRITE (91, "(A)") TRIM(fmc80_CSM_model_filename) ! = "SHELLS_for_CSM_expanded_regridded.txt" WRITE (91, "(A)") TRIM(fmc80_WSM_data_filename) ! = "wsm2008.csv" !------------- misfit-measures section follows: -------------------------------- WRITE (91, "(L12, ' fml_do_scoring_vs_data')") fml_do_scoring_vs_data ! = .TRUE. ! (quick) WRITE (91, "(L12, ' fml_do_scoring_vs_model')") fml_do_scoring_vs_model ! = .TRUE. ! (time-consuming, but valuable) !------------- graphical output section follows: ---------------------------- WRITE (91, "(I12, ' fmi_output_menu_choice')") fmi_output_menu_choice ! = 1 WRITE (91, "(I12, ' fmi_unit_choice')") fmi_unit_choice ! = 2 WRITE (91, "(F12.3, ' fmr_map_paper_width_points')") fmr_map_paper_width_points ! = 11. * 72. WRITE (91, "(F12.3, ' fmr_map_paper_height_points')") fmr_map_paper_height_points ! = 8.5 * 72. WRITE (91, "(L12, ' fml_black')") fml_black ! = .FALSE. WRITE (91, "(F12.3, ' fmr_top_margin_points')") fmr_top_margin_points ! = 18. WRITE (91, "(F12.3, ' fmr_left_margin_points')") fmr_left_margin_points ! = 18. WRITE (91, "(F12.3, ' fmr_right_margin_points')") fmr_right_margin_points ! = 18. WRITE (91, "(F12.3, ' fmr_bottom_margin_points')") fmr_bottom_margin_points ! = 18. ! Result: Suggested map scale denominator will be 3574000. WRITE (91, "(L12, ' fml_plan_top_titles')") fml_plan_top_titles ! = .TRUE. WRITE (91, "(L12, ' fml_plan_rightlegend')") fml_plan_rightlegend ! = .TRUE. WRITE (91, "(L12, ' fml_plan_bottomlegend')") fml_plan_bottomlegend ! = .FALSE. WRITE (91, "(L12, ' fml_using_color')") fml_using_color ! = .TRUE. WRITE (91, "(A)") TRIM(fmc80_model_AI_filename) ! = "AI7Frame.ai" WRITE (91, "(A)") TRIM(fmc80_new_AI_filename) ! = "FlatMaxwell_map.ai" WRITE (91, "(I12, ' fmi_minutes')") fmi_minutes ! = 60 WRITE (91, "(F12.3, ' fmr_section_pin_Elon')") fmr_section_pin_Elon ! = fmr_projpoint_Elon WRITE (91, "(F12.3, ' fmr_section_pin_Nlat')") fmr_section_pin_Nlat ! = fmr_projpoint_Nlat WRITE (91, "(F12.3, ' fmr_section_azimuth_degrees')") fmr_section_azimuth_degrees ! = 90. WRITE (91, "(A1, 11X, ' fmc1_section_letter')") fmc1_section_letter ! = 'A' WRITE (91, "(F12.3, ' fmr_section_paper_width_points')") fmr_section_paper_width_points ! = 14. * 72. WRITE (91, "(F12.3, ' fmr_section_paper_height_points')") fmr_section_paper_height_points ! = 8.5 * 72. WRITE (91, "(L12, ' fml_plan_section_top_titles')") fml_plan_section_top_titles ! = .TRUE. WRITE (91, "(L12, ' fml_plan_section_rightlegend')") fml_plan_section_rightlegend ! = .FALSE. WRITE (91, "(L12, ' fml_plan_section_bottomlegend')") fml_plan_section_bottomlegend ! = .TRUE. WRITE (91, "(F12.5, ' fmr_borehole_latitude')") fmr_borehole_latitude WRITE (91, "(F12.5, ' fmr_borehole_longitude')") fmr_borehole_longitude CLOSE (UNIT = 91, DISP = "KEEP") END SUBROUTINE Write_INI_file SUBROUTINE Write_Tectonic_Stress() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. CHARACTER*132 :: tecto_stress_filename, tecto_stress_pathfile INTEGER :: i tecto_stress_filename = "FlatMaxwell_tectoStress_" // TRIM(fmc12_tectonic_token) // ".dat" tecto_stress_pathfile = TRIM(fmc132_path_out) // TRIM(tecto_stress_filename) WRITE (*, "(' Writing tectonic-stress-anomaly model file ',A,'...')") TRIM(tecto_stress_filename) OPEN (UNIT = 2, FILE = TRIM(tecto_stress_pathfile)) ! uncondition OPEN; overwrites any existing file with same name token WRITE (2, "(A12,' fmc12_tectonic_token')") fmc12_tectonic_token WRITE (2, "(A12,' fmc12_topographic_token')") fmc12_topographic_token WRITE (2, "(I12,' fmi_tectonic_model_mode')") fmi_tectonic_model_mode WRITE (2, "(I12,' fmi_waves')") fmi_waves WRITE (2, "(A)") TRIM(fmc80_CSM_model_filename) WRITE (2, "(A)") TRIM(fmc80_WSM_data_filename) WRITE (2, "(ES12.2,' fmd_CSM_group_weight')") fmd_CSM_group_weight WRITE (2, "(ES12.2,' fmd_WSM_group_weight')") fmd_WSM_group_weight WRITE (2, "(ES12.2,' fmd_BC_group_weight')") fmd_BC_group_weight DO i = 1, fmi_N_coefficients WRITE (2, "(I8,' ',A13,I2,ES18.10,' Pa')") i, fmc13v_name(i), fmiv_k(i), fmdV_coefficients(i, 1) END DO WRITE (2, "(' For definitions of the basis functions, see the file basis_functions.xlsx, or')") WRITE (2, "(' study the code in SUBROUTINEs Define_Coefficients & Tectonic_Stress_at_Point.')") CLOSE (2) END SUBROUTINE Write_Tectonic_Stress SUBROUTINE Write_Topographic_Stress() IMPLICIT NONE !but variables defined in FlatMaxwell and/or USEd modules are referenced freely. CHARACTER*132 :: topo_stress_filename, topo_stress_pathfile INTEGER :: i, j, k, n topo_stress_filename = "FlatMaxwell_topoStress_" // TRIM(fmc12_topographic_token) // ".dat" topo_stress_pathfile = TRIM(fmc132_path_out) // TRIM(topo_stress_filename) OPEN (UNIT = 1, FILE = TRIM(topo_stress_pathfile)) ! uncondition OPEN; overwrites any existing file with same name token WRITE (1, "(A12,' fmc12_topographic_token')") fmc12_topographic_token WRITE (1, "(I12,' fmi_projection_choice')") fmi_projection_choice WRITE (1, "(F12.0,' fmr_radius_meters')") fmr_radius_meters WRITE (1, "(F12.4,' fmr_projpoint_Elon')") fmr_projpoint_Elon WRITE (1, "(F12.4,' fmr_projpoint_Nlat')") fmr_projpoint_Nlat WRITE (1, "(F12.2,' fmr_belt_azimuth_degrees')") fmr_belt_azimuth_degrees WRITE (1, "(F12.4,' fmr_cone_lat')") fmr_cone_lat WRITE (1, "(F12.4,' fmr_cone_lon')") fmr_cone_lon WRITE (1, "(F12.2,' fmr_standard_parallel_gap_degrees')") fmr_standard_parallel_gap_degrees WRITE (1, "(F12.0,' fmr_x_LENGTH_meters')") fmr_x_LENGTH_meters WRITE (1, "(F12.0,' fmr_y_WIDTH_meters')") fmr_y_WIDTH_meters WRITE (1, "(F12.0,' fmr_z_DEPTH_meters')") fmr_z_DEPTH_meters WRITE (1, "(F12.6,' fmr_gravity')") fmr_gravity WRITE (1, "(F12.0,' fmr_1_bar')") fmr_1_bar WRITE (1, "(F12.0,' fmr_atmosphere_scale_height_meters')") fmr_atmosphere_scale_height_meters WRITE (1, "(F12.0,' fmr_seawater_density')") fmr_seawater_density WRITE (1, "(F12.0,' fmr_Moho_depth')") fmr_Moho_depth WRITE (1, "(F12.0,' fmr_crustal_density_at_top')") fmr_crustal_density_at_top WRITE (1, "(F12.0,' fmr_crustal_density_at_Moho')") fmr_crustal_density_at_Moho WRITE (1, "(F12.0,' fmr_mantle_density_at_Moho')") fmr_mantle_density_at_Moho WRITE (1, "(F12.0,' fmr_mantle_density_at_LAB')") fmr_mantle_density_at_LAB WRITE (1, "(F12.0,' fmr_LAB_depth')") fmr_LAB_depth WRITE (1, "(A)") TRIM(fmc80_DEM_filename) WRITE (1, "(I12,' fmi_new_or_old_Moho')") fmi_new_or_old_Moho WRITE (1, "(A)") TRIM(fmc80_Moho_filename) WRITE (1, "(F12.0,' fmr_vertical_resolution_m')") fmr_vertical_resolution_m WRITE (1, "(F12.0,' fmr_horizontal_resolution_m')") fmr_horizontal_resolution_m WRITE (1, "(I12,' fmi_topo_nx')") fmi_topo_nx WRITE (1, "(I12,' fmi_topo_ny')") fmi_topo_ny WRITE (1, "(I12,' fmi_topo_nz')") fmi_topo_nz WRITE (1, "(3F12.2,' fmrv_topo_stress_dXYZ(1:3)')") fmrv_topo_stress_dXYZ(1:3) WRITE (1, "(F12.3, ' fmr_Poisson_ratio')") fmr_Poisson_ratio WRITE (1, "(I6,ES14.6)") (k, fmrv_reference_P_Pa(k), k = -fmi_topo_nz, fmi_topo_nz) WRITE (1, "(3I6,6ES10.2)") (((i, j, k, (fmrt_topo_stress_anomaly_Pa(n, i, j, k), n = 1, 6), i = -fmi_topo_nx, fmi_topo_nx), j = -fmi_topo_ny, fmi_topo_ny), k = -fmi_topo_nz, fmi_topo_nz) CLOSE (1) WRITE (*, *) WRITE (*, "(' ',A,' (topographic stress save file) was written.')") TRIM(topo_stress_filename) END SUBROUTINE Write_Topographic_Stress END PROGRAM FlatMaxwell