! Restore4.f90 ! ! A code which uses geologic data on fault offsets and strains in ! balanced cross sections, plus latitude anomalies and vertical- ! axis rotations from paleomagnetism, plus paleostress directions, ! to compute paleotectonic and paleogeologic maps. It can also ! compute velocities and strain-rates (neotectonics) at the present ! or at an older epoch. ! ! in the Fortran 90 language ! (for version and date, search for "version & date" below) ! ! by Peter Bird, Professor Emeritus ! Department of Earth, Planetary, and Space Sciences ! University of California ! Los Angeles, CA 90095-1567 ! ! contacts for Peter Bird: e-mail: pbird@epss.ucla.edu ! WWW: http://peterbird.name ! ! (C) Copyright 1997, 1999, 2016, 2017, 2018, 2020, 2021 by George Peter Bird ! and the Regents of the University of California ! !========================================================================= ! ! 1. GENERAL DESCRIPTION: ! ------------------------ ! This program uses geologic and paleomagnetic data to compute ! paleotectonic flow and deformation patterns, and integrates ! these backward over time to create palinspastic restorations. ! Although information on faults is a major part of the input, ! a continuum finite element approximation is used to describe ! the model results; fault activity can be suggested by ! overprinted icons and overprinted actual traces with ! information about estimated or computed slip-rates, ! or estimated or computed net-offsets, as colored ribbons. ! !========================================================================= ! ! 2. ALGORITHM: !--------------- ! ! The basic algorithm of version Restore2 was given in: ! ! P. Bird (1998), Kinematic history of the Laramide orogeny ! in latitudes 35-49N, western United States, ! Tectonics, vol. 17, #5, p. 780-801. ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! ! Significant changes since that paper: ! *Logic of -Internal- was improved to catch infinite loops ! (cycling through adjacent elements) of period greater than two. ! *Self-straightening of active strike-slip faults by a diffusional ! model of line tension was added after each translation step. ! (This added to computation time, because now all segments and ! all cracks must be redefined before each velocity solution.) ! *Drag-folding of basemap lines and other fault traces ! in the same element as an active strike-slip fault was reduced. ! [N.B. In later versions, 4.0+, this feature is described as ! translation_method = 1, as opposed to translation_method = 0.] ! *Continuum compliance (mu_) has been moved from a nodal variable ! (mu_nod) to an element variable (mu_element); also, a ! geologic time limit has been added (mu_switch), beyond which ! mu_ increases to a second higher value: mu_element(2,l_), ! appropriate before an overlap sequence. ! *Nodes of the initial grid are carried along as an extra ! integrated dataset through all grid exchanges, so that (some) ! original elements can be used to define net strain and rotation. ! Those nodes whose positions can be integrated, and those ! elements which involve (only) those nodes, are now written ! out in a topologically-equivalent pair of .FEG files: ! before.feg (restored positions) and after.feg (present ! positions). This pair of files is used by RetroMap4 to create ! maps of net translation, net rotation, and net strain over ! user-defined stretches of geologic time. (Note that this pair ! of files, and these plots, only become available after Restore4 ! has covered the whole span of geologic time (desired for plotting) ! in a SINGLE run. (However, the creation of the set of hand-edited ! .feg files needed to allow this can be done gradually, in a number ! of shorter runs; then these grids can be reused--as long as NO input ! data values OR model parameter values have changed!) ! *Nodal variables expressing present lithosphere structure ! elevation, heat flow, crustal thickness, mantle-lithosphere thickness) ! are now transported backwards through time. (Beginning 2021.02.12, ! in Restore4, they will be adjusted for vertical-stretch in the lithosphere.) ! *Tabular data files which formerly had extension .dat now must ! have extension .RST or .rst (to prevent confusion with other programs). ! ! The result was Restore3 (version 3.0 of 11 August 1999). ! ! Simulations of OR-WA-BC-AK-YT-AK were run for the 1999 GSA Penrose ! conference on "Baja British Columbia", but were never published. ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! ! Additional changes in August 2016 through July 2020 ! (adapting to new hardware & compilers, and then attempting to restore WUS-Mexico): ! ! * All REAL variables changed to REAL*8, and inline constants also. ! * Node and element numbers in .FEG files now written with I8 (not I7 or I5). ! * Intel's MKL (Math Kernel Library) is now used to solve both big & ! small linear systems (and also small eigenvalue/eigenvector systems). ! * The executable is now compiled for both 32-bit Win32 and 64-bit Win64, ! and also for both sequential ("seq") and parallel ("par") execution. ! (These changes above are for portability, accuracy, and speed-- ! but are not intended to add features or change program behavior.) ! ! In addition, some new features were added: ! * Relative weighting of different classes of data is now ! explicitly and transparently controlled by new input ! parameters L_0 and A_0. ! L_0 is defined as the length of fault trace (in m) whose ! offset gets the same weight as one paleomagnetic site or cross-section. ! A_0 is defined as the area of unfaulted continuum (in m**2) whose ! stiffness and stress-direction get the same weight as one ! paleomagnetic site or cross-section datum. ! -To increase weight on geologic fault offsets, DEcrease L_0. ! -To increase weight on stress-directions, DEcrease A_0. ! -To increase weight on continuum stiffness, DEcrease A_0. ! -To increase weight on paleomagnetic data and cross-sections, ! INcrease both L_0 and A_0 by the same factor. ! Note that L_0 and A_0 are comparable to the similarly-named parameters ! L0 and A0 in my program NeoKinema, and thus optimized NeoKinema models ! of neotectonics can provide rough starting values for L_0 and A_0. ! (However, those values may not provide enough weight on paleomagnetics.) ! Also, note that "neotectonic" (present-velocity) models computed ! with this program Restore4 can be used to check the realism ! obtained with a particular (L_0, A_0) combination, by how ! well, or poorly, it fits neotectonic fault offset rates, ! geodetic velocities, and stress directions. Also, parameter mu_ ! can be adjusted by an iterative or "bootstrap" method; or ! else the neotectonic value found in NeoKinema can be used. ! * I discovered that complex continental-scale problems often ! yielded unrealistically-small estimated uncertainties in ! interpolated stress direction (e.g., 1.6 degrees!) when the ! user chose faults_give_sigma_1h = .TRUE., so I now apply a limit ! of a "lowest plausible" sigma of 10 degrees, based on the best ! uncertainty that World Stress Map editors feel they can achieve ! with abundant present-day data. This protects against an undue ! effective weight on palostress-direction data, and possible artifacts. ! * Fault names, and also any extra trace-related data keywords ! (e.g., "dip_degrees", "throughgoing_master_fault", ! "symmetric_spreading_system", or "other_spreading_system") ! and their subsequent data values (e.g., "22", "first", "last", "both") ! from fault headers in the f_.dig file are now memorized ! and echoed in all the palinspastic f_.dig files ! (which might potentially be used for re-starting). ! * Any "dip_degrees" value found in the f_.dig file is now used ! when converting throw to heave, and vice versa. ! (Other faults that lack these values use generic dips.) ! Note that this change only affects throw data of senses N & T. ! * The former cryptic filename suffix "mmnn" used in names of ! many output files has been expanded to a more legible ! 11- or 13-byte filename suffix such as "_NI_065.2Ma" ! (from a solution that was Not Iterated) or "_i020_065.2Ma" ! (from a solution that has been iterated 20 times). ! This new convention supports smaller time-steps ! (down to 0.1 m.y.) for better accuracy along plate boundaries, ! and also supports up to 999.9 Ma and 999 iterations, if needed(?). ! * A new translation method (#0) is added for any fault-trace points ! that are marked with the "throughgoing_master_fault" ! attribute in data line(s) of its trace header in the f_.dig file. ! For such points, the ! "unhooking" feature of translation_method #1 is NOT used, ! so that successive faults in the same fault system should never ! become disconnected from each other during the integration. ! * A new translation method (#2) is used for any fault-trace points ! that are marked with the "symmetric_spreading_system" attributed ! (either a spreading-center with offset sense of D, D+L, or D+R, ! or a transform fault with offset sense of L or R) ! in the data-line(s) of its trace header in the f_.dig file. ! This new translation rule is "average of the velocities ! of the two surrounding plates" and it restores symmetric-spreading ! ridge systems much more accurately than methods #0 or #1, ! which could seriously shear and/or rotate them. ! * A new translation method (#3) is used for any fault trace points ! that are marked with the "other_spreading_system" attribute ! in the data-line(s) of its trace header in the f_.dig file. ! Fault-joints which have this attribute (at the ends of both traces) ! will remain linked together during translation ! (so that Coordinate_Segments() can work properly), ! but such common joint locations do NOT translate by the complex ! method for symmetric_spreading_system joints; instead, these ! common joint locations are just embedded in their elements. ! * In paleotectonic restorations, new subprogram Look_ahead ! is used to anticipate any FEG folding in the next timestep. ! * The scheduling of grid-swaps (at which a new matched-pair ! of one FEG file and its corresponding BCS file are read in, ! to prevent illegal folding of finite elements), is CHANGED from ! an as-needed (unpredictable) timing to a preset time schedule. ! This change was necessary to prevent mis-alignment between ! fault traces and narrow "corridors" of finite-elements ! which might be in use to better represent them. ! (Note: The user discovers the times at which grid-swaps are ! needed by "plowing ahead blindly" and waiting for trouble. ! The geologic times at which grids were hand-edited (to anticipate ! reconstruction strains in the next backward time-step) ! should be recorded; each hand-edited grid will be read at ! exactly that geologic time, and no other.) ! * The instructions provided to the user (in the REPORT.txt ! output file) on how to cope with a crash due to grid-folding ! have been greatly improved. See new subprogram Recovery_advice. ! * To improve the mapping of net strain and net rotation over a ! long tectonic history (by companion program RetroMap4), ! a new logical indicator is added to element definitions ! in the "before.feg" file, ! and in the "after.feg" file, to mark (with 'T') any ! element that has never been affected by faulting. ! RetroMap4+ will provide an option to use ! this indicator to limit the colored maps to only ! those elements which have never been faulted. ! (Use of this graphical option is strongly recommended.) ! * SUBROUTINE Def_seg was replaced with the new algorithm of ! Def_seg_v2 to more accurately capture all segments that ! arise from long traces defined by only one (or a few) ! digitization step(s). (For example, note that fault traces ! with the "symmetric_spreading_system" attribute are typically ! digitized with only 2 points per fault, at their ends.) ! Because this new algorithm is slower, global memo vector ! f_relevant is also added, to prevent wasting time ! (more than once) on fault traces that are entirely ! outside the area of the F-E grid. ! * New misfit-checking code was added for neotectonic ! velocity results: comparison to neotectonic fault ! offset rates (in columns 7~8 of the f_.rst file); ! comparison to surface velocities in a .GPS file ! (but, without correction of GPS from interseismic ! to long-term-average velocity); and N_0, N_1, N_2 ! dimensionless statistics on stress-direction errors. ! *New output feature: Detailed (per fault segment) ! heave rates of faults whose heave rates exceed 0.1 mm/a ! are now output to a .SHR (Segment Heave Rate) output file, ! which is intended for plotting with RetroMap4+. ! *Better algorithm for smoothing traces of active strike-slip faults: ! the amount of diffusive smoothing is now proportional to ! fault velocity as well as active time-window; therefore, it ! is proportional to net offset. This allows both greater ! smoothing of the throughgoing_master_fault's, and reduced ! distortion of the traces of slower, less critical faults. ! *Subprogram Prediction was improved 2020.04.28 to handle the former ! problem of "negative" continuum strain rates in faulting elements. ! Before this fix, Restore used to report fault offsets that were ! artificially close to their targets, by assuming that unphysical ! "negative" continuum strain in faulting elements was allowed. ! *Subprogram Coordinate_Segments added 2020.05.02 to better ! represent ridge-trench corners in symmetric_spreading_systems ! (and other cases where closely linked faults meet at an angle). ! *Subprogram Unpin_Plate_Corner() was added. ! This uses new logical arrays edge_element(ele#)? and ! plate_boundary(trace#)? to identify elements in which a plate- ! boundary fault (one with any special attribute at either end: ! throughgoing_master_fault, OR symmetric_spreading_system, OR ! other_spreading_system) cuts through the edge of the F-E grid. ! In these special elements, mu_ is increased (*10.) and total ! seg_kappa_ of the (1 or 2) segment(s) is increased to 1.0. Together, ! these changes act to prevent "torquing" and "squashing" of adjacent ! plate corners, that would otherwise occur because the local ! segment does not cross the whole element, and therefore the heave- ! rate goal for that element is less than for others in the same ! plate-boundary chain. ! ! (Version #4.0 of 18 July 2020). !========================================================================== ! ! 3. OVERVIEW OF INPUT DATASETS ! (using suggested filenames for cross-reference in this ! documentation; most actual filenames may be different) ! ! !--------------------------------------------------------- !"PARAMETE[RS].RST":A short file of strategic parameter values, such as ! the names of other input files, the allowable stain- !"paramete[rs].rst" rate for the a-priori stiffness, size of timesteps, ! number of iterations, et cetera. <1> !"Paramete[rs].rst" Note: This is the only filename which is fixed. ! The 8.3-character form can be used under DOS or MVS. ! Under Unix or Windows, almost any upper- or lower-case name ! will be found (except perverse ones like "pARAMETERS.rST"!). ! "F.RST": Fault names, offsets, and age limits on movement. <2> ! "F.DIG": Digitized fault traces, with index #s tied to F.RST. <3> ! "C.RST": Present and restored lengths of balanced cross- ! sections. <4> ! "P.RST": Paleomagnetic paleolatitude anomalies (from inclination ! anomalies remaining after structural corrections), and ! vertical-axis rotations (from declination ! anomalies remaining after structural and plate-tectonic ! corrections). <8> ! "S.RST": Most-compressive horizontal principal stress azimuths ! (from dikes and veins, or from cluster analysis of faults ! with slickensides- or, less reliably, from clusters of ! folds). <9> ! "y.DIG": Digitised traces of any fiducial lines which are to be ! retrodeformed (state lines, coast lines, present ! parallels and meridians, geologic-map objects etc.) <10> ! Typically created by utility programs DIGITISE ! for PCs with DOS, with coordinate transformations ! by program PROJECTOR. ! Limit the name 'y' to 4 characters or less, or it ! will be truncated. (For example, when I restore the ! Geologic Map of North America [2005; digital 2009] ! I usually name it GMNA.dig, or GMUM.dig.) ! "x.FEG": Finite element grid of connected spherical-triangle ! elements on the Earth's spherical surface. <11> ! Filename must have extension ".feg" or ".FEG". ! Typically created with interactive utility program ! OrbWin for Windows (NT, 7, 8, 10, ...) computers. ! The file begins with an ordered list of nodes ! with East longitude, North lattitude for each. ! Following is a list of triangular elements, each ! defined by the numbers of the 3 corner nodes. ! (It is important that these grids have also been processed ! through utility program OrbNumber to reduce bandwidth.) ! Limit the name 'x' to 4 characters or less, or it ! will be truncated. (In solutions that will not be iterated, ! I typically use filenames of NI01.feg, NI02.feg, NI03.feg ... ! In iteration #7 of a multi-iteration solution, I would use ! filenames of 0701.feg, 0702.feg. 0703.feg, ...) ! "x.BCS"; A boundary-conditions file indicating which nodes (at ! least 2!) have specified (usually zero) velocities. <12> ! Notes: Names "x" and "y" are chosen by the user ! and are entered in the "PARAMETE[RS].RST" file, ! but will be truncated to 4 characters maximum ! when creating the names of output files. ! It is permissible (but not recommended) to include ! computer, drive, and path information in filenames ! (up to a maximum of 80 characters total for each). ! (In practice, I ADVISE YOU to create a separate directory ! for this computation, including any restarts or additional ! iterations. Then, run Restore4 from this directory, using ! short, simple filenames. Otherwise, the number of files ! may be overwhelming, and their locations will be scattered!) ! If any of the input datasets is null, enter 'none' ! for the filename. (However, you must provide parameters, ! finite element grid, and boundary conditions at least.) ! !============================================================================= ! ! 4. DATA PREPARATION / INPUT FILE FORMATS ! *** General Note: Do not exceed 132 characters in any line of any file! ! --------------------------------------------------------------------------- ! -Build an ASCII text file "Parameters.rst" containing these lines; comments to right of numbers/names/switches are encouraged (& free-form). ! 0. geologic age at which this run starts, in Ma ( 0.? ) ! 85. greatest geologic age (end of this run), in Ma ( >= 0. ) ! 85. ultimate age target (where iterations end, and all rate-goals are adjusted) ! 0.2 timestep, in Ma (N * 0.1 Ma; >= 0; 0 gives neotectonic velocities only ) ! 6 refinements (for nonlinearity) of each velocity-solution within each timestep ! 0 iterations of entire history COMPLETED prior to this computational run {NOTE: For your first run(s) with Restore4, this will = 0 .} ! 1 iterations of entire history IN THIS computational run {NOTE: For your first run(s) with Restore4, this should = 1 .} ! 10 last_iteration = number of iterations of history planned in ALL runs together {NOTE: When learning Restore4, start with last_iteration = 1 !} ! 2.000E4 L_0 = length of fault trace (in m) whose offset(s) get(s) unit weight ! 3.200E9 A_0 = area of continuum (in m**2) whose stiffness & stress-direction get unit weight ! 5.0E-16 standard deviation of nominally zero strainrates (permanent default mu_), /s ! 2.0E-17 small strain-rate increment (xi_), /s (for use in e_11 = e_22 - xi_ boxing constraint) ! 5.0E-16 scale strain-rate of "rigid" blocks, /s (for early iterations only) ! 1.6E-10 scale offset-rate sigma of faults, m/s (for early iterations only) ! 1.6E-10 scale rate uncertainty of cross-section rates, m/s (for early iterations only) ! 3.2E-10 scale N-S drift uncertainty of paleomag sites, m/s (for early iterations only) ! 5.0E-16 scale spin uncertainty of paleomag sites, radians/s (for early iterations only) ! 6371. radius of planet, in kilometers ! TRUE switch: Do new active faults give sigma_1h direction data? ! Fabc.RST filename of fault offsets (or, 'none') {NOTE: "abc" is any memnonic identifier you like--but only 3 bytes!} ! Fabc.DIG filename of digitized fault traces (or, 'none') {NOTE: "abc" is any memnonic identifier you like--but only 3 bytes!} ! Cabc.RST filename of balanced cross-sections (or, 'none') {NOTE: "abc" is any memnonic identifier you like--but only 3 bytes!} ! Pabc.RST filename of paleomagnetic data (or, 'none') {NOTE: "abc" is any memnonic identifier you like--but only 3 bytes!} ! Sabc.RST filename of horizontal principal stress directions (or, 'none') {NOTE: "abc" is any memnonic identifier you like--but only 3 bytes!} ! Yabc.DIG filename of fiducial lines to be restored (or, 'none') {NOTE: "abc" is any memnonic identifier you like--but only 3 bytes!} ! 0.0 Ma: NI01.FEG loading-time and filename of finite element grid #1 (required) ! [ 3.2 Ma: NI02.FEG (*optionally, list loading-times for additional finite element grids) ] ! ... ... ! 0.0 Ma: NI01.BCS loading-time and filename of boundary conditions for finite element grid #1 (required) ! [ 3.2 Ma: NI02.BCS (*if there is more than 1 .FEG, each must have its own .BCS file) ] ! ... ... ! ------------------------------------------------------------------------- ! *Optionally, you can list up to max_fegs = 1296 finite element grid files. ! Be sure to renumber each grid for minimum bandwidth, with OrbNumber. And, ! for each .FEG file listed, there must be a matching .BCS boundary-conditions ! file. This file must use the new (re-numbered) node-numbers produced ! by OrbNumber. Another valuable reminder is that each .FEG (and each .BCS) ! file should be uniquely identifiable by its first 4 bytes, because any ! later bytes will be truncated when filename suffixes like ! "_NI_001.2Ma" or like "_i020_065.2Ma" are added inside Restore4. ! In a really big problem, it may be advisable to name .FEG and .BCS files as: ! 0101.feg / 0101.bcs, 0102.feg / 0102.BCS, ... ! where the first 2 bytes give the iteration number (or, "NI" if the ! solution will Not be Iterated), and the second two bytes ! give a loading-sequence number (associated with a particular geologic ! time, in a particular iteration of the global solution). ! If you use decimal numbers in these 2-byte slots, you will be limited ! to sequences of no more than (10)^2 = 100 successive grids. ! However, if you use hexadecimal numbers in these 2-byte slots, you ! can have sequences of up to (16)^2 = 256 successive grids. ! If you use the byte sequence 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, A, B, C, ! D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y, Z ! then you can have up to (10 + 26)^2 = 1296 grids in a sequence! ! ------------------------------------------------------------------------- ! *Also note that complex problems requiring iterated solutions must be ! computed one-iteration-per-run, because different iterations may ! require different lists of FEG/BCS files for swapping, and also ! different swapping times. If this sounds too laborious, remember ! that it is possible to compute a NON-iterated solution in a single ! run (once the necessary sequence of swap-grids has been perfected). ! In that case, you might choose to use bytes "NI" (Not Iterated) in ! the first 2 bytes of .FEG and .BCS file-names (instead of "01", which ! might imply that somewhere there should be iterations "02", "03", "04", ... ! ------------------------------------------------------------------------- ! -Build files Fabc.RST, Cabc.RST, Pabc.RST, and Sabc.RST (all optional) as follows. ! A general feature of all of these files is that they are tables ! with one datum per line (except that a paleomagnetic site has both ! a latitude anomaly and a vertical axis rotation on one line). ! To permit reading the table, there are two lines of headers before ! the actual data: ! -the Fortran 90 FORMAT needed to read the table, e.g., ! "(A6,1X,A50,F11.3,F11.3,F11.3,F11.3,F11.3,F11.3)" in the case of F.RST, and ! -human-readable abbreviated column headings ! (which will be copied into the output files). ! NOTE: Create FORMATs carefully, as they are also used to WRITE files ! that will be needed to restart a calculation. Be sure that there are ! enough significant digits provided in the "F11.3" type formats! ! Also, be sure that all input numbers have an included decimal point ! to guard against decimal point misalignment if/when the format is changed! ! After these two header lines, the contents are different in each case: ! -------------------------------------------------------- ! F.RST = Fault Offsets ! For each fault of regional scale: ! 1. Identifier of fault trace, consisting of 5 bytes: ! - first byte is always "F" (in column 1); ! - bytes #2 ~ #5 are a 4-digit integer, used to locate ! the digitized fault trace within the f_.DIG file which contains ! up to 9999 traces. Use leading 0's if number is less than 1000, ! so: F0001, F0002, F0003, ... ! 2. Identifier for sense of measured offset (to be provided as data): ! R = right-lateral (dextral); L = left-lateral (sinistral); T = ! throw with thrust-sense; P = heave with shortening-sense; ! N = throw with normal-sense; D = heave with extensional-sense. ! Thus, a typical trace&sense identifier might be "F0059T". ! [NOTE: Handle faults of oblique offset by using 2 lines of data, ! e.g., one L line + one T/P/N/D line; or one R line + one T/P/N/D line. ! Handle multiple phases of fault movement (which must not ! overlap in time) with multiple data lines in f_.RST as well. ] ! 3. Descriptive text with fault name, location, ... ! 4. Amount of offset, in km. (Always a positive number. ! Letter above (#2) gives sense. In the case of thrust (T) or normal ! (N) faulting, give the relative vertical offset (throw) of ! the two sides, which can usually be measured more ! accurately than the slip. ! In case of a low-angle thrust plate or nappe (P), give the ! heave, or amount of crustal shortening. ! In case of a detachment fault, listric normal fault, domino- ! style set of rotating normal faults, or seafloor-spreading ! center (offset sense D), give the net crustal extension ! measured perpendicular to the trace. ! 4. Standard deviation (sigma_; 68%-confidence ; half of 95%- ! confidence ) of offset, in km. Always positive! Required. ! 5. Maximum age of (this phase of) faulting, in Ma. Required. ! 6. Minimum age of (this phase of) faulting, in Ma. If not known, enter 0. ! -------------------------------------------------------- ! C.RST = Strains Computed from Restored Cross Sections ! For each restored section: ! 1. Citation, in short form (e.g., "Jones, 1991"). ! 2. (present) East longitude of West end, in decimal degrees ! (typically negative, e.g., -106.92) ! 3. (present) North latitude of West end, in decimal degrees ! (e.g., 43.81) ! 4. (present) East longitude of East end, in decimal degrees ! (typically negative, e.g., -104.12) ! 5. (present) North latitude of East end, in decimal degrees ! (e.g., 44.03) ! 6. Map code (e.g., C0001, C0002, C0003, ...). ! 7. Present length of section, in km. ! 8. Restored length of section, in km. ! 9. Standard deviation (sigma_; 68%-confidence; half of 95%- ! confidence) of restored length, in km. Must be positive! ! 10. Age of restoration epoch, in Ma. Required. ! 11. If available, geologic time by which all deformation was ! known to be over (e.g., from overlap assemblages). In Ma. ! If not available, enter 0; do not just omit! Required. ! -------------------------------------------------------- ! P.RST = Paleomagnetic Latitude Anomalies and Vertical-Axis Rotations ! For each virtual geomagnetic pole (preferably from multiple samples, ! spaced in time so as to average-out secular variation, and from ! rocks which include paleo-horizontal markers like bedding): ! 1. Reference. If from IAGA Paleomagnetic database ! (McElhinny & Lock, 1995) then use prefix IAGA: "IAGA: Adams ! & Eve, 1901". If from my Notebook database, then I might use ! prefix NB: "NB: Jones, 1991". ! 2. (present) East longitude of sample(s), in decimal ! degrees (typically negative, e.g., -106.92) ! 3. (present) North latitude of sample(s), in decimal ! degrees (e.g., 43.81) ! 4. Paleolatitude anomaly, in degrees. Paleolatitudes to the South ! of present are typical along the west coast; these are ! defined as negative paleolatitude anomalies. ! 5. Standard deviation (sigma_; 68%-confidence; half of 95%- ! confidence) of latitude anomaly, in degrees. Must be positive! ! 6. Net vertical-axis rotation since magnetization, in ! degrees. Counterclockwise rotations going from past to present ! are considered positive. ! 7. Standard deviation (sigma_; 68%-confidence; half of 95%- ! confidence) of vertical-axis rotation, in degrees. ! Must be positive! ! 8. Maximum age of magnetization, in Ma. Required. ! 9. Minimum age of magnetization, in Ma. Required. ! 10. Longitude of geomagnetic North Pole (in a normal epoch) ! at the time of magnetization, in the reference frame used ! for velocity boundary conditions, in degrees (E = +). ! 11. Latitude of geomagnetic North Pole (in a normal epoch) ! at the time of magnetization, in the reference frame used ! for velocity boundary conditions, in degrees (N = +). ! -------------------------------------------------------- ! S.RST = Most-Compressive Horizontal Principal Stress Directions ! For each assemblage of stress indicators: ! 1. Reference, in short form (e.g., "Jones, 1991"). ! 2. Location and state abbreviation. ! 3. Map code (e.g., S0001, S0002, S0003, ...) ! 4. (present) East longitude, in decimal degrees. (Typically ! negative, e.g., -106.92) ! 5. (present) North latitude, in decimal degrees (e.g., 43.81). ! 6. (present) Azimuth, measured clockwise from North, in degrees. ! 7. Standard deviation (sigma_; 68%-confidence; half of 95%- ! confidence) of stress azimuth, in degrees. Must be positive! ! 8. Maximum age of indicator (dikes/veins/joints/faults), in Ma. ! 9. Minimum age of indicator (dikes/veins/joints/faults), in Ma. ! 10. Enter "Window" if the age of a single stress indicator is ! bracketed between ages (#8) and (#9); otherwise enter "Stage" ! if multiple stress indicators were used to show that the ! stress direction was constant from age (#8) to age (#9). ! -------------------------------------------------------- ! -Build the x.FEG file with OrbWin (using NO fault elements), and ! renumber for minimum bandwidth with OrbNumber. ! -------------------------------------------------------- ! -Build the x.BCS file to go with x.FEG and to specify which nodes ! have fixed velocities (at least 2!). This file is read with ! list-directed input, so column-positions are not critical. For ! each node whose velocity you want to fix (and you can list these ! in any order), provide one line of x.BCS with: ! node_number Southward-velocity Eastward_velocity, e.g.: ! " 129 -1.375E-09 +2.541E-10" ! Specify these velocities in meters/second. In most ! cases, you will probably want to specify zero velocities: ! " 129 0. 0. " ! Please understand that it is NOT necessary or desirable to ! provide boundary conditions all the way around the grid! ! Usually, one stable interior side is fixed, and the other ! sides is left free to move as determined by the geologic data. ! This is appropriate because integrating strain is like solving ! a first-order differential equation for displacement, and ! first-order equations should only have a boundary condition on ! one side of the domain! (If you use conditions on both sides, ! you will get a solution which matches them, but the strain in ! unfaulted elements may be unreasonably large, and the whole ! solution will be contaminated if your BCs are not exactly right!) ! The node numbers you use must be the NEW node numbers ! assigned by renumbering utility OrbNumber; in order to see ! these, load the output x.feg file from OrbNumber back ! into OrbWin, select the Nodes command, and simply wave ! the mouse near the desired node to see its number displayed ! at the bottom-right of the OrbWin window. ! -------------------------------------------------------- ! -F.DIG, the file of digitised fault traces, must have exactly ! the following format: ! V---(column 1). [16 sample lines of F.DIG follow this line.] ! F0489N ! -1.11661E+02,+3.92411E+01 ! -1.11636E+02,+3.92543E+01 ! -1.11615E+02,+3.92747E+01 ! -1.11592E+02,+3.92896E+01 ! -1.11570E+02,+3.93063E+01 ! -1.11549E+02,+3.93249E+01 ! -1.11525E+02,+3.93436E+01 ! -1.11503E+02,+3.93622E+01 ! -1.11484E+02,+3.93824E+01 ! -1.11462E+02,+3.94046E+01 ! -1.11443E+02,+3.94248E+01 ! -1.11434E+02,+3.94274E+01 ! *** end of line segment *** ! F0532T ! -1.12405E+02,+3.91902E+01 ! [... and so on...] ! Each fault trace must be introduced by a label line written by ! WRITE (nn,"('F', I4, A1)") fltnum, fltsns ! where the INTEGER :: fltnum is used to tie the trace to ! data in file F.RST, and the CHARACTER*1 :: fltsns is either: ! 'T' for thrust, 'P' for low-angle thrust plates or nappes, ! 'N' for normal, 'D' for detachment or listric normal or domino-set, ! 'R' for dextral, or 'L' for sinstral. ! (Note: N faults have ~65 degree dip; D faults have varying dip or ! ~0 degrees dip at present, but may have dipped more steeply when ! active. T faults have ~25 degree dip; P faults have very low ! dips (except in ramps). ! See the paper listed under 2. Algorithm.) ! Optionally, there may follow 1~5 data lines containing one or more ! of the following keywords: ! dip_degrees ! throughgoing_master_fault ! symmetric_spreading_system ! other_spreading_system ! where each of these keywords must be followed by a specific value: ! either a number following dip_degrees, or an end-specifier ! of "first" or "last" or "both" following any of the other 3. ! The following lines must give (longitude, latitude) of each ! digitised point along the trace, in degrees, according to: ! FORMAT(1X, SP, ES12.5, ',', ES12.5) ! Notice that the first byte MUST be a space, and the leading ! + sign on positive numbers is REQUIRED (use SP in FORMAT). ! East longitude is positive; West of Greenwich is negative. ! North latitude is positive; Southern hemisphere is negative. ! Each fault trace is concluded by a record with ! "*** end of line segment ***" starting in column 1. ! The order in which faults are digitised is unimportant. ! The number of points in each segment is unimportant ! (but there must be at least 2). ! The order in which they are numbered is unimportant, except ! that the 6-byte (6-character) identifiers must tie to F.RST. ! The easiest way to create these files is to use my program ! DIGITISE (which accepts output from a digitiser through the ! serial port COM1 or COM2) and one of my map-projection ! utility programs like PROJECTOR which converts ! from the (x,y) coordinates of the map projection to ! (longitude, latitude) coordinates. ! Do not bother to digitise a lot of faults that will not fall ! within your finite element grids; these merely waste memory ! during the run(s), and are omitted from output files because ! they cannot be restored. ! -------------------------------------------------------- ! -y.DIG, the fiducial-lines file, has exactly the same format ! as F.DIG above, except that identifying text label(s) before each ! line segment can include 0~3 records. This file might contain ! present-day state lines, coastlines, meridians of longitude, ! parallels of latitude, etc.. They will be restored to their ! former posititions for use in graphics (like those produced ! by RetroMap4). This file is optional. If you wish to ! create one, use my programs DIGITISE and PROJECTOR, ! as described above under file F.DIG. ! Do not bother to digitise a lot of lines that will not fall ! within your finite element grids; these merely waste memory ! during the run(s), and are omitted from output files because ! they cannot be restored. ! !==================================================================== ! ! 5. OVERVIEW OF OUTPUT DATASETS: ! !---------------------------------------------- ! *Text dataset: REPORT.txt contains reports on progress. <21> ! The information is much the same as what you see on the screen, ! so do not be concerned if messages fly by too fast to read. ! This dataset is created in each run. Be careful- old REPORT.txt's ! will be overwritten if they are not moved or renamed first! ! ! THE FOLLOWING ARE PRODUCED IN EVERY TIMESTEP OF THE LAST ITERATION: ! ! *Palinspastic datasets: ! "Fabc_i020_085.0Ma.DIG": Digitised fault traces, restored. <22> ! (assuming that fault data were used in solution). ! "x_i020_085.0Ma.FEG": Finite-element grid, retrodeformed. <23> ! "y_i020_085.0Ma.DIG": Digitised basemap lines, restored. <24> ! (assuming that basemap lines were read). ! These formats are unchanged. However, all positions (decimal ! degrees of East longitude and North latitude) are modified ! back to the geologic-time of the report. ! The iteration number "i020" refers to the global iteration of the ! entire solution, and helps to keep very similar datasets ! catalogued without confusion. ! Points in "Fabc.DIG", "Sabc.RST", and "yabc.DIG" which did not ! fall into the area of the finite element grid "x.FEG" will simply be ! deleted, since they cannot be restored. ! ! *Paleotectonic (or neotectonic) datatset: ! A dataset of velocities of the nodes of the finite-element ! grid "x.FEG" is also produced: x_i020_085.0Ma.VEL <25>. This permits ! plotting diagrams of the paleotectonics using RetroMap4. ! Note that the velocities are NOT the averages over the timestep, ! but are the values at the computational-end (geologic-beginning) ! so that they tie to the node positions in "x_i020_085.0Ma.FEG". ! Also, velocities point forward in time (toward the present), not ! back in time. ! ! *Strain-history datasets: ! These files have some lines identical to the corresponding input datasets: ! Pabs_i020_085.0Ma.RST <28> is expanded from Pabc.RST <8> ! Sabc_i020_085.0Ma.RST <29> is expanded from Sabc.RST <9> ! but have other lines added to show what has happened in the run(s). ! The extra lines are distinguished by a special character (+, *, &, $) in column 1. ! + lines: These record the position of the datum nnn.n Ma ago, ! in the reference frame which is used to define boundary conditions. ! The first number is East longitude in degrees, the second is ! North latitude in degrees. ! Fabc_i020_085.0Ma.RST lacks these lines because the location information ! is in Fabc_i020_085.0Ma.DIG. ! Cabc_i020_085.0Ma.RST has two such lines per datum for the two ends of the section. ! Pabc_i020_085.9Ma.RST has one such line per datum. ! Sabc_i020_085.0Ma.RST has one such line per datum. ! This information is needed to restart a history in the middle of an iteration, ! so as to finish it, before attempting more iterations (in another run). ! * lines: These record the rates of offset/displacement/rotation ! during the most recent iteration of the history (left), ! followed in each case by a new goal (right) for future computations. ! The first number is the age in Ma at the younger end of some timestep. ! The second number is the age in Ma the older end of the same timestep. ! The third number is the computed model rate during that step. ! The fourth number is the goal rate for future computations. ! The units are derived from the original data line above, ! with 1 m.y. used as the time unit to define rates: ! Fabc_i020_085.0Ma.RST has fault offset rates in km/m.y. = mm/a. ! Cabc_i020_085.0Ma.RST has cross-section length rates in km/m.y. = mm/a. ! Extension from past to present has a positive sign. ! Pabc_i020_085.0Ma.RST has latitude rates in degrees/m.y. = mm/a. ! If the point moved toward the S paleopole in going from past to present, ! this rate is entered with a positive sign. ! Sabc_i020_085.0Ma.RST does not have * lines. ! This '*' information is very important, as it is the only way that ! a computation restarted for more iterations can remember what ! it learned from previous iterations! The adjusted rate-goals are ! the ONLY new information carried over from one iteration to another! ! & lines: These are like * lines except they record additional progress: ! Fabc_i020_085.0Ma.RST does not have & lines. ! Cabc_i020_085.0Ma.RST does not have & lines. ! Pabc_i020_085.0Ma.RST has rotation rates in degrees/m.y.. ! Counterclockwise rotation from past to present is positive. ! Sabc_i020_085.0Ma.RST does not have & lines. ! $ lines: These record a paleo-azimuth indicator nnn.n Ma ago. ! The reference frame is that used to define boundary conditions. ! Fabc_i020_085.0Ma.RST does not have $ lines. ! Cabc_i020_085.0Ma.RST does not have $ lines. ! Pabc_i020_085.0Ma.RST does not have $ lines. ! Sabc_i020_085.0Ma.RST has paleo-azimuths of sigma_1h. ! As in Sabc.RST, azimuth is in degrees clockwise from North. ! ! THE FOLLOWING ARE PRODUCED AT THE END OF THE LAST ITERATION: ! ! *Strain-history datasets: ! These files have some lines identical to the corresponding input datasets: ! Fabc_i020_085.0Ma.RST <26> is expanded from Fabc.RST <2> ! Cabc_i020_085.0Ma.RST <27> is expanded from Cabc.RST <4> ! Pabc_i020_085.0Ma.RST <28> is expanded from Pabc.RST <8> ! Sabc_i020_085.0Ma.RST <29> is expanded from Sabc.RST <9> ! but have other lines added to show what has happened in the run(s). ! The extra lines are distinguished by a special character (+, *, &, $) in column 1. ! + lines: These record the position of the datum nnn.n Ma ago, ! in the reference frame which is used to define boundary conditions. ! The first number is East longitude in degrees, the second is ! North latitude in degrees. ! Fabc_i020_085.0Ma.RST lacks these lines because the location ! information is in Fabs_i020_085.0Ma.DIG. ! Cabc_i020_085.0Ma.RST has two such lines per datum for the two ends of the section. ! Pabc_i020_085.0Ma.RST has one such line per datum. ! Sabc_i020_085.0Ma.RST has one such line per datum. ! * lines: These record the rates of offset/displacement/rotation ! during the most recent iteration of the history (left), ! followed in each case by a new goal (right) for future computations. ! The first number is the age in Ma at the young end of some timestep. ! The second number is the age in Ma the old end of the same timestep. ! The third number is the model rate during that step. ! The fourth number is the goal for future computations. ! The units are derived from the original data line above, ! with 1 m.y. used as the time unit to define rates: ! Fabc_i020_085.0Ma.RST has fault offset rates in km/m.y. = mm/a. ! Cabc_i020_085.0Ma.RST has cross-section length rates in km/m.y. = mm/a. ! Extension from past to present has a positive sign. ! Pabc_i020_085.0Ma.RST has latitude rates in degrees/m.y.. ! If the point moved toward the S paleopole in going from past to present, ! this rate is entered with a positive sign. ! Sabc_i020_085.0Ma.RST does not have '*' lines. ! This '*' information is very important, as it is the only way that ! a computation restarted for more iterations can remember what ! it learned in previous iterations! ! & lines: These are like * lines except they record additional progress: ! Fabc_i020_085.0Ma.RST does not have & lines. ! Cabc_i020_085.0Ma.RST does not have & lines. ! Pabc_i020_085.0Ma.RST has rotation rates in degrees/m.y.. ! Counterclockwise rotation from past to present is +. ! Sabc_i020_085.0Ma.RST does not have & lines. ! $ lines: These record a paleo-azimuth indicator nnn.n Ma ago. ! The reference frame is that used to define boundary conditions. ! Fabc_i020_085.0Ma.RST does not have $ lines. ! Cabc_i020_085.0Ma.RST does not have $ lines. ! Pabc_i020_085.0Ma.RST does not have $ lines. ! Sabc_i020_085.0Ma.RST has paleo-azimuths of sigma_1h. ! As in Sabc.RST, azimuth is in degrees clockwise from North. ! ! THE FOLLOWING ARE PRODUCED IN THE EVENT THAT THE PROGRAM TERMINATES ! EARLY (because the FEG grid becomes too strained and folds, and ! no other FEG grids are available to read in): ! ! *Palinspastic datasets (described above): ! "F_NI_001.2Ma.DIG": Digitised fault traces, restored. <22> ! (assuming that fault data were used in solution). ! "x_NI_001.2Ma.FEG": Finite-element grid, retrodeformed. <23> ! "y_NI_001.2Ma.DIG": Digitised basemap lines, restored. <24> ! (assuming that a basemap was read in) ! ! *Strain-history datasets (described above): ! Fabc_NI_001.2Ma.RST <26> is expanded from Fabc.RST (if any) <2> ! Cabc_NI_001.2Ma.RST <27> is expanded from Cabc.RST (if any) <4> ! Pabc_NI_001.2Ma.RST <28> is expanded from Pabc.RST (if any) <8> ! Sabc_NI_001.2Ma.RST <29> is expanded from Sabc.RST (if any) <9> ! Note that in the case of early termination, the rates for ! completed timesteps include actual model predictions, but the rates ! for the remaining timesteps are just goals. When Restore4 is restarted ! with a new grid, these goals will be re-used. !========================================================================= ! ! Fortran 90 free-form source code begins: ! ---------------------------------------------------------------- ! NOTE: Some kludgy coding intended to fix the fatal memory-leaks ! caused by the bugs in MicroSoft Fortran PowerStation 4.0 Pro: ! 1. No array segments are used as actual arguments. ! Instead, temporary vectors are used for input. ! (To locate all these kludges, search on the letters "tv".) ! 2. Array-valued functions were converted to SUBROUTINES (ouch!): ! (Cross, Del_Gjxy_del_thetaphi, Gjxy, Interpolate, Local_Phi, ! Local_Theta, Moved_by_vel, Moved_by_vw, Step_aside, Unitise, ! XYZ_from_lonlat). ! 3. TYPE(is123)-valued function "Inside" was replaced with ! SUBROUTINE Internal, which returns an integer argument ! and 3 real arguments (not one single TYPE(is123) argument)! ! ----------------------------------------------------------------- !******************************************************************* PROGRAM Restore4 USE DSphere ! Peter Bird's library of geometry operations on the surface of a unit sphere; ! provided as file DSphere.f90. The 'D' indicates DOUBLE PRECISION ! (== REAL*8) arguments and accuracy. !========================================================================================================= ! External numerical-library link. !========================================================================================================= ! MKL version: USE MKL95_PRECISION USE MKL95_LAPACK ! Intel's Math Kernel Library (MKL), LAPACK portion; these MODULEs need INTERFACEs. ! These INTERFACEs are provided in file "lapack.f90", which must be available to be ! compiled jointly with the rest of the project. ! I am using the following routines from the LAPACK portion of MKL: ! dgbsv: Solve linear system with REAL*8 banded coefficient matrix ! in proprietary MKL "band storage scheme for LU factorization". ! (Used for the main linear system that computes velocities.) ! dsyev: Eigenvalues and eigenvectors of a REAL*8 symmetric full matrix. ! (Used only for 3x3 matrices). ! dsysv: Solve linear system with REAL*8 symmetric semi-definite coefficient matrix. ! (Used only for small matrices, of rank = 6 + #faults_in_element.) ! The advantage of this library is that I can compile for either 32-bit or ! 64-bit Windows, and with (or without) parallel processing, ! with little or no change to the source code. ! ***REMEMBER*** in the Microsoft Visual Studio GUI provided with ! Intel Parallel Studio XE 2013, you need to set ! Project / Properties / Fortran / Libraries / ! Use Math Kernel Library {to some choice other than "No"}! !====================================================================================== IMPLICIT NONE ! All variable names must be declared. !-------------------------------------------------------------------- TYPE :: is123 ! element & internal coordinates of any point on surface INTEGER :: element ! containing a certain surface point; ! note that element = 0 indicates that the ! point is outside the current FEG area. REAL*8, DIMENSION(3) :: s ! internal coordinate; 0.0D0 <= s_i <= 1.0D0, ! for all i = 1, 2, 3 (if the point is actually ! inside, or on the edge of, triangle "element"). END TYPE is123 TYPE :: crack ! Intersection of a fault offset-rate datum with ! a fault segment. Some segments have > 1 cracks, due to ! > 1 contiguous datum time windows in this timestep, ! or 2 components of offset (L & T, R & D, ...); ! many other fault segments have no cracks (when inactive). INTEGER :: datum ! offset datum index (sequence # in F_.RST) INTEGER :: segment ! segment index (computed internally by Restore) REAL*8 :: s_ ! offset-rate, converted to a component of heave-rate, using rules according to 'sense' REAL*8 :: sigma_ ! standard deviation of heave-rate component, ditto REAL*8, DIMENSION(3) :: H ! see (11)-(16) of Bird (1998) CHARACTER(1) :: sense ! offset sense: R, L, T, N, D, P END TYPE crack TYPE :: needle ! everything one needs to know about a stress datum REAL*8, DIMENSION(3) :: location ! location, as a Cartesian unit vector in unit sphere, ! with +Z axis at North pole, and +X axis at 0 longitude. REAL*8 :: azimuth ! most-compressive azimuth, clockwise from N, in radians REAL*8 :: sigma ! uncertainty angle, radians REAL*8 :: relevance ! 0.0D0 to 1.0D0 END TYPE needle !-------------------------------------------------------------------- !CONSTANTS: Fixed conversion factors, in alphabetical order: INTEGER, PARAMETER :: bytes_per_int = 4 ! descriptive, not prescriptive! INTEGER, PARAMETER :: bytes_per_real = 8 ! descriptive, not prescriptive! !Check documentation of your compiler to see if the above are correct. !If they are wrong, program runs the same, but array-size reporting will be systematically off. INTEGER, PARAMETER :: bytes_per_is = bytes_per_int + 3 * bytes_per_real INTEGER, PARAMETER :: bytes_per_crack = 2 * bytes_per_int + 5 * bytes_per_real + 1 REAL*8, PARAMETER :: bytes_per_GB = (1024.0D0)**3 REAL*8, PARAMETER :: cot_thrust_dip = 2.14451D0 ! 1./TAN(25.) REAL*8, PARAMETER :: cot_normal_dip = 0.46631D0 ! 1./TAN(65.) REAL*8, PARAMETER :: deg_per_rad = 57.2957795130823D0 REAL*8, PARAMETER :: m_per_km = 1000.0D0 INTEGER, PARAMETER :: max_fegs = 1296 ! See text comments above; probably should NOT be increased any further. REAL*8, PARAMETER :: s_per_Ma = 1.0D6 * 365.25D0 * 24.0D0 * 60.0D0 * 60.0D0 !-------------------------------------------------------------------- !VARIABLES: All global variables except arrays, in alphabetical order: REAL*8 :: A_0 ! area of continuum (in m**2) whose stiffness and stress-direction get unit weight INTEGER :: a, a2 ! used in computation of plateward_dAzimuth LOGICAL :: adjust_rates_now ! = (t1 == ultimate_age_Ma).AND.(iteration < last_iteration) CHARACTER(80) :: after_filename ! part of the definition of the before_and_after .feg file-pair, for finite strain and rotation REAL*8 :: allowance ! grace period (s) for association of neotec solution with stage stress data REAL*8 :: angle ! (temporary) LOGICAL :: any_action ! is x_active(j,i) TRUE for any j? LOGICAL :: any_spreading ! did any fault-trace in the f_.dig file have "symmetric_spreading_system" attribute? LOGICAL :: any_other_spreading ! did any fault-trace in the f_.dig file have "other_spreading_system" attribute? REAL*8 :: arc_radians ! used in computation of plateward_dAzimuth REAL*8 :: area_strainrate ! rate (in /s) of fractional growth of area of one element = eps_dot(1) + eps_dot(3) INTEGER :: b, b2 ! used in computation of plateward_dAzimuth REAL*8 :: backward_thickness_ratio ! (temporary) INTEGER :: basemap_object_count ! where a basemap/geologic-map "object" is defined by any occurrence of an "***end of line segment***" record. INTEGER :: basemap_title_count ! total number of title records found in all basemap objects together; size of basemap_title_store. INTEGER :: basemap_point_count ! total number of (Elon, Nlat) points {externally} or 3-component R*8 uvecs {internally} in the basemap. INTEGER :: bcs_count ! # of boundary-condition nodes INTEGER :: before_and_after_numnod ! ~6(?) * num_nod of first FEG grid; reduced whenever nodes fall outside current grid (at any time), and can't be integrated back INTEGER :: before_and_after_numel ! ~num_ele of first FEG grid; reduced ... (as above). REAL*8 :: before_and_after_sizing ! relative-size coefficient for linear dimensions of before_and_after elements (relative to original FEG); suggest ~0.8DD0 CHARACTER(80) :: before_filename REAL*8 :: ccw ! counterclockwise rotation, radians CHARACTER(80) :: c_rst ! filename, X-section data INTEGER :: c_rst_count ! number of X-section data CHARACTER(134) :: c_rst_format ! to read X-section data CHARACTER(134) :: c_rst_titles ! to write X-section data REAL*8 :: c_scale ! scale stretch-rate uncertainty to start iteration, m/s CHARACTER(1) :: c, c1 !(temporary) CHARACTER(4) :: c4 !(temporary) CHARACTER(5) :: c5 !(temporary) CHARACTER(6) :: c6 !(temporary) CHARACTER(30) :: c30, c30a !(temporary) CHARACTER(47) :: c47 !(temporary) CHARACTER(50) :: c50 !(temporary) CHARACTER(80) :: c80 !(temporary) CHARACTER(134) :: c134 !(temporary) LOGICAL :: changed_horses ! have multiple .feg files been used this iteration? LOGICAL :: check_if ! any node lies "on" a fault trace INTEGER :: c_in_time_and_space ! number of data within time, domain windows CHARACTER(10) :: clock_time ! wall clock time LOGICAL :: compare_to_GPS ! an option for testing neotectonic velocity results INTEGER :: complete_timesteps = 0 REAL*8, DIMENSION(0:2) :: continuum_N_numerator_sums = 0.0D0 REAL*8 :: continuum_N_denominator_sum = 0.0D0 REAL*8 :: cott ! cotangent(theta_) (temporary) INTEGER :: crack_count ! total number of cracks in this timestep REAL*8 :: cross_product ! (temporary) REAL*8 :: csct ! cosecant(theta_) (temporary) INTEGER :: current_feg ! ordinal number of loaded .feg file INTEGER :: data_lines_count ! used in READing and WRITEing fault data like "dip_degrees 75" or "throughgoing_master_fault", etc. CHARACTER(8) :: date ! date program is run INTEGER :: Delta_node ! greatest difference between connected node #s INTEGER :: Delta_node_feg ! lower limit of Delta_node, based on x_feg INTEGER :: Delta_node_last = 0 ! memory of previous Delta_node (in a different .feg?) REAL*8 :: Deltat_ ! timestep, in s REAL*8 :: dot_product ! (temporary) REAL*8 :: end_time ! greatest geologic age, in s REAL*8 :: Elon ! East longitude, in degrees LOGICAL :: eof ! SUBR sends signal to calling prog REAL*8 :: equat ! equatorial component of any 3-vector in Cartesian space (temporary) REAL*8 :: exponent ! = n_ / last_iteration LOGICAL :: faults_give_sigma_1h ! are faults stress indicators? INTEGER :: f, f2 ! used in computation of plateward_dAzimuth CHARACTER(80) :: f_dig ! filename, digitized traces INTEGER :: f_dig_count ! # of points in f_dig CHARACTER(80) :: f_rst ! filename for fault-offset data INTEGER :: f_rst_count ! # of data lines in f_rst input file CHARACTER(134) :: f_rst_format ! to read offset data CHARACTER(134) :: f_rst_titles ! to print offset data INTEGER :: f_highest ! max fault index; cannot exceed 9999 (as in: F9999N) INTEGER :: f_in_time_and_space ! number of data within time, domain windows REAL*8 :: f_scale ! scale slip-rate uncertainty to start iteration, m/s REAL*8 :: factor ! converts tabulated offset rate to internal LOGICAL :: feg_brief ! (obsolete) descriptor of any .feg file CHARACTER*80 :: FEG_filename ! temporary, used in output-file section CHARACTER*80 :: filename ! temporary, used in output-file section CHARACTER*13 :: filename_suffix ! built from geologic time and iteration #; e.g., "_i020_065.2Ma", OR "_NI_065.2Ma"; either 13 or 11 bytes long. REAL*8 :: floor = 10.0D0 * EPSILON(floor) LOGICAL :: folding ! finite element grid has folded REAL*8 :: forward_thickness_ratio ! (temporary) REAL*8 :: gamma_ ! azimuth, clockwise from N, radians REAL*8 :: G(3,2,2) ! nodal-function matrix for one surface point LOGICAL :: get_feg ! memo that new .feg file needs to be loaded, at start of any timestep LOGICAL :: got_index ! during reading of f_dig LOGICAL :: got_data_line ! during reading of f_dig LOGICAL :: got_new_FEG_this_timestep ! memo; controls whether 0.0 (or vw1) is sent to Solve_for_vw as initial estimate of velocity field in predictor step! LOGICAL :: got_point ! during reading of f_dig LOGICAL :: got_terminator ! during reading of f_dig CHARACTER*132 :: GPS_comparison_file ! used in an option for testing neotectonic velocity results CHARACTER*132 :: GPS_comparison_title ! used in an option for testing neotectonic velocity results CHARACTER*132 :: GPS_comparison_format ! used in an option for testing neotectonic velocity results CHARACTER*132 :: GPS_comparison_headers ! used in an option for testing neotectonic velocity results REAL*8 :: GPS_Elon ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_Nlat ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_Ve ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_Vn ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_Se ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_Sn ! used in scoring neotectonic velocity components at benchmarks INTEGER :: GPS_line ! used in scoring neotectonic velocity components at benchmarks INTEGER :: GPS_glitches ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_uvec(3) ! used in scoring neotectonic velocity components at benchmarks INTEGER :: GPS_iele ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_s1 ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_s2 ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_s3 ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_site_v ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_site_w ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: GPS_misfit_in_mps(2) ! used in scoring neotectonic velocity components at benchmarks (2 components: v, w = S, E) REAL*8 :: GPS_misfit_in_mmpa(2) ! used in scoring neotectonic velocity components at benchmarks (2 components: v, w = S, E) REAL*8 :: GPS_misfit_in_sigmas(2) ! used in scoring neotectonic velocity components at benchmarks (2 components: v, w = S, E) INTEGER :: grid_to_load_size ! DIMENSION large enough to avoid over-running the end, even if FEG list runs longer than end_time_Ma. REAL*8 :: half_R2 ! R**2/2. LOGICAL :: hit_pFile_end ! (which may occur when reading mal-formed parameter files) CHARACTER*1 :: home_sense_c1 ! used in computation of plateward_dAzimuth INTEGER :: i,i1,i2,i3,i4,i5,i6 ! (temporary) INTEGER :: i_match ! used in matching "identical but renumbered" nodes after a grid-swap interruption INTEGER :: iDiagonal ! global descriptor of the big linear system (in MKL banded-storage form) INTEGER :: in_count ! # of fault offsets in L0, L1, L2 LOGICAL :: in_trace ! during reading of f_dig; means that the first point of this trace has already been recorded LOGICAL :: indication1, indication2 ! used in fixing the "jumping Coachella trace" bug in the Read_dig portion INTEGER :: internal_ios ! IOS value returned by internal READ (from a variable) INTEGER :: ios ! used in READ (n, *, IOSTAT = ios) INTEGER :: iteration ! index for repetitions of whole history INTEGER :: j, j1, j2, j3, jp1, jp2 ! (temporary) INTEGER :: k, k1, k2 ! (temporary) INTEGER :: k_step_1, k_step_2 ! time-step indices (lower, higher) in which the currently-loaded, temporary FEG is used, based on the loading-plan. INTEGER :: l_ ! finite element index REAL*8 :: L_0 ! length of fault trace (in m) whose offset(s) get(s) unit weight REAL*8 :: lat1, lat2, lon1, lon2 ! (used in debugging) INTEGER :: loc_in_c_1, loc_in_c_2, loc_in_c_3 ! byte-indeces used in reading a # after "dip_degrees" in the f_dig file INTEGER :: last_iteration ! planned final iteration of a set (usually built-up over several separate runs). INTEGER :: line ! line number of any input file INTEGER :: m ! (temporary) INTEGER :: max_iter ! # of iterations of history REAL*8 :: memory ! bytes of memory in all arrays; using REAL*8 to avoid INTEGER overflow problems! REAL*8 :: misfits ! a prediction error, in sigmas CHARACTER(4) :: mmnn ! iteration (I2) and timestep (I2) CHARACTER*5 :: memo_0 ! temporary memo used to set translation_method = 0 (as opposed to 1) at end of trace-reading CHARACTER*5 :: memo_2 ! temporary memo used to set translation_method = 2 (as opposed to 1) at end of trace-reading CHARACTER*5 :: memo_3 ! temporary memo used to set translation_method = 3 (as opposed to 1) at end of trace-reading CHARACTER*1 :: memo_c1 ! using in computation of plateward_dAzimuth for fault DIG points with translation_method == 2 REAL*8 :: Nlat ! North latitude, in degrees REAL*8 :: OR_misfit_in_mps ! used in scoring neotectonic fault offset-rate predictions REAL*8 :: OR_misfit_in_mmpa ! used in scoring neotectonic fault offset-rate predictions REAL*8 :: OR_misfit_in_sigmas ! used in scoring neotectonic fault offset-rate predictions REAL*8 :: mu_ ! see Bird (1998); this is the common (default) value; ! see ALSO arrays mu_element and mu_switch for specified local values. REAL*8 :: mu_scale ! scale strain-rate uncertainty to start iteration INTEGER :: n_ ! timestep number, absolute scale, present - >past INTEGER :: n_1 ! 1st timestep number, absolute scale INTEGER :: n_beginning_this_run ! first timestep number for this run, on an absolute geologic timescale (i.e., >1 when restarting mid-iteration). INTEGER :: n_refine ! # refinements of each v solution INTEGER :: n_t_per_it ! timesteps/iteration; <= num_timesteps INTEGER :: n_to_get ! when calling ReadN INTEGER :: n1, n2, n3 ! temporary holders of corner node #s for one element INTEGER :: nCodiagonals ! global descriptor of the big linear system (in MKL banded-storage form) INTEGER :: nDOF ! # of degrees of freedom, =2*num_nod INTEGER :: nearest_f2 ! used in computation of plateward_dAzimuth REAL*8 :: nearest_radians ! used in computation of plateward_dAzimuth LOGICAL :: neotec ! do present velocities only INTEGER :: neotec_GPS_misfit_count ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: neotec_GPS_misfit_mmpa(0:2) ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: neotec_GPS_misfit_sigmas(0:2) ! used in scoring neotectonic velocity components at benchmarks INTEGER :: neotec_GPS_misfit_checkThis_mmpa ! used in scoring neotectonic velocity components at benchmarks INTEGER :: neotec_GPS_misfit_checkThis_sigmas ! used in scoring neotectonic velocity components at benchmarks INTEGER :: neotec_external_OR_misfit_count ! used in scoring neotectonic fault offset-rate predictions against external values of Holocene rates REAL*8 :: neotec_external_OR_misfit_mmpa(0:2) ! used in scoring neotectonic fault offset-rate predictions against external values of Holocene rates REAL*8 :: neotec_external_OR_misfit_sigmas(0:2) ! used in scoring neotectonic fault offset-rate predictions against external values of Holocene rates INTEGER :: neotec_external_OR_misfit_checkThis_mmpa ! used in scoring neotectonic fault offset-rate predictions against external values of Holocene rates INTEGER :: neotec_external_OR_misfit_checkThis_sigmas ! used in scoring neotectonic fault offset-rate predictions against external values of Holocene rates INTEGER :: neotec_internal_OR_misfit_count ! used in scoring neotectonic fault offset-rate predictions against internal f_rate's of f_active data REAL*8 :: neotec_internal_OR_misfit_mmpa(0:2) ! used in scoring neotectonic fault offset-rate predictions against internal f_rate's of f_active data REAL*8 :: neotec_internal_OR_misfit_sigmas(0:2) ! used in scoring neotectonic fault offset-rate predictions against internal f_rate's of f_active data INTEGER :: neotec_internal_OR_misfit_checkThis_mmpa ! used in scoring neotectonic fault offset-rate predictions against internal f_rate's of f_active data INTEGER :: neotec_internal_OR_misfit_checkThis_sigmas ! used in scoring neotectonic fault offset-rate predictions against internal f_rate's of f_active data INTEGER :: nKRows ! global descriptor of the big linear system (in MKL banded-storage form) INTEGER :: nRank ! global descriptor of the big linear system (in MKL banded-storage form) INTEGER :: nRealN ! (obsolete) descriptor of any .feg file INTEGER :: nFakeN ! (obsolete) descriptor of any .feg file INTEGER :: n1000 ! (obsolete) descriptor of any .feg file INTEGER :: num_bad ! # of nodes lying on fault traces INTEGER :: num_ele ! # of finite elements in current grid (A.feg, B.feg, C.feg, ...); distinct from value for before_and_after grids. INTEGER :: num_fegs ! # of .feg and .bcs files in Paramete[rs].rst INTEGER :: num_nod ! # of nodes in the (x_feg) current grid (A.feg, B.feg, C.feg, ...); VERY distinct from value for before_and_after grids. INTEGER :: num_nod_last = 0 ! memory of previous num_nod (in a different .feg?) INTEGER :: num_timesteps ! # of timesteps in one complete iteration of history (even when we start a particular run part-way through...) REAL*8 :: offs ! fault offset, scalar form REAL*8 :: overlap ! time common to two time windows, s REAL*8 :: overlap_threshold ! minimum overlap to consider a "stage" stress datum relevant INTEGER :: object ! identifier of a particular object in the basemap/geologic-map REAL*8 :: old_crust, old_mL ! (temporary) CHARACTER(80) :: p_rst ! filename, paleomagnetic data INTEGER :: p_rst_count ! number of paleomagnetic sites CHARACTER(134) :: p_rst_format ! to read paleomagnetic data CHARACTER(134) :: p_rst_titles ! to write paleomagnetic data REAL*8 :: p_drift_scale ! scale N-S drift uncertainty to start iteration, m/s INTEGER :: p_in_time_and_space ! number of data within time, domain windows REAL*8 :: p_spin_scale ! scale rotation uncertainty to start iteration, radians/s LOGICAL :: paleotec ! paleotectonics; do palinspastic reconstructions INTEGER :: past_iterations ! iterations of history COMPLETED in previous runs; does not count any partial iteration that may be in-progress INTEGER :: points ! local count of digitized points in one basemap/geologic-map object. CHARACTER*13 :: previous_filename_suffix ! built from geologic time and iteration #; e.g., "_i020_065.2Ma", OR "_NI_065.2Ma"; either 13 or 11 bytes long. REAL*8 :: R ! Bird (1998) REAL*8 :: r1, r2, r3, r4 !(temporary) REAL*8 :: r2_in_radian2 ! used in matching "identical but renumbered" nodes after a grid-swap interruption INTEGER :: read_status ! did READ work? INTEGER :: s ! indicates stress datum REAL*8 :: s_error_degrees(0:2) ! used to report overall stress-direction mismatch measures, in degrees, IF (neotec) INTEGER :: s_error_element_count ! used to report overall stress-direction mismatch measures, in degrees, IF (neotec) REAL*8 :: s_per_year = 3.15576D7 ! seconds in 365.25 days (exact) CHARACTER(80) :: s_rst ! filename, stress directions INTEGER :: s_rst_count ! number of paleostress data from s_rst CHARACTER(134) :: s_rst_format ! to read paleostress data CHARACTER(134) :: s_rst_titles ! to write paleostress data INTEGER :: seg_count ! number of fault segments (element ^ trace) INTEGER :: seg_count_doubled ! To avoid costly double-counting of segments before each velocity solution, I use array dimensions ~twice the expected sizes. REAL*8 :: sint ! SIN(theta_) (temporary) INTEGER :: segment ! (used in debugging) REAL*8 :: south ! Sward motion of paleomag site, in m INTEGER :: split_node_count ! used when creating split nodes (and redefined elements) of before_and_after FEGs REAL*8 :: start_time ! youngest geologic age, in s (usually 0.) LOGICAL :: stress_ever ! are there stress data for any timestep? LOGICAL :: stress_now ! any stress constraints this timestep? REAL*8 :: stretch ! actual extension of 1 cross-section LOGICAL :: strike_slip_i, strike_slip_j ! temporaries used while deciding on possible fault-offset-rate demotions (f_rst_code(:,:) = 'D'). CHARACTER*132 :: string REAL*8 :: sum ! (temporary) REAL*8 :: systematic_GPS_denominator ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: systematic_GPS_numerator ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: systematic_GPS_ratio ! used in scoring neotectonic velocity components at benchmarks REAL*8 :: systematic_external_OR_denominator ! used in scoring neotectonic fault offset-rate predictions against external values of Holocene rates REAL*8 :: systematic_external_OR_numerator ! used in scoring neotectonic fault offset-rate predictions against external values of Holocene rates REAL*8 :: systematic_external_OR_ratio ! used in scoring neotectonic fault offset-rate predictions against external values of Holocene rates REAL*8 :: systematic_internal_OR_denominator ! used in scoring neotectonic fault offset-rate predictions against internal f_rate's of f_active data REAL*8 :: systematic_internal_OR_numerator ! used in scoring neotectonic fault offset-rate predictions against internal f_rate's of f_active data REAL*8 :: systematic_internal_OR_ratio ! used in scoring neotectonic fault offset-rate predictions against internal f_rate's of f_active data REAL*8 :: t, t0, t1, t2, t3, t4, t5, t6 ! (temporary) REAL*8 :: tant ! TAN(theta_) (temporary) REAL*8 :: theta_ ! colatitude (angle in radians) REAL*8 :: this_run_starts_Ma, this_run_ends_Ma LOGICAL :: this_seg_slips_this_chapter ! used while computing T/F values of current_element_is_unfaulted(1:num_ele). REAL*8 :: time0, time1 ! ages at young / old end of timestep, in seconds before present INTEGER :: titles ! local count within one basemap/geologic-map object CHARACTER*80 :: t_filename ! name of .FEG or .BCS file (limited to 80 bytes) REAL*8 :: t_Ma ! age in millions of years (Ma) REAL*8 :: tolerance_in_degrees ! used in matching "identical but renumbered" nodes after a grid-swap interruption REAL*8 :: tolerance_in_radian2 ! used in matching "identical but renumbered" nodes after a grid-swap interruption INTEGER :: total_iterations ! = iteration + past_iterations (q.v.) LOGICAL :: trace_needed_this_run ! (only if start-time of this run is less than formation age of the trace) INTEGER :: trace_of_this_seg ! == seg_def(1, i) REAL*8, DIMENSION(3):: tv,tvi,tvo,tv1,tv2,tv3 ! temporary 3-vectors used in kludgy ! coding which avoids passing array ! sub-sections as actual arguments, ! because under MicroSoft Fortran PowerStation ! 4.0 Pro this causes a memory leak! REAL*8, DIMENSION(3) :: tv_j ! used in computation of plateward_dAzimuth REAL*8 :: ultimate_age_Ma, ultimate_age_s ! ultimate age target (where iterations end, and all rate-goals are adjusted) REAL*8, DIMENSION(3) :: uvec, uvec1, uvec2, uvec3 ! Cartesian unit vectors in a unit sphere (temporary) REAL*8, DIMENSION(10) :: vector ! for temporary use by ReadN REAL*8 :: vertical_stretch ! (temporary) CHARACTER(80) :: y_dig ! filename of basemap or geologic map, to be restored CHARACTER(80) :: x_feg, x_vel ! current .feg and .vel names (before mmnn) REAL*8 :: x1, x2, x3, x4 !(temporary) REAL*8 :: xi_ ! Bird (1998) CHARACTER(5) :: zone ! time zone !-------------------------------------------------------------------- !VARS !ARRAYS, in alphabetical order: REAL*8, DIMENSION(:),ALLOCATABLE :: a_ ! area of plane triangle element beneath surface, m**2 !(1:num_ele = element index l_) REAL*8, DIMENSION(:,:), ALLOCATABLE :: ABCD ! coefficient matrix of linear system used to solve for velocity ! components; see (4) to (6) of Bird (1998). ! Stored in special band-storage mode specified by LAPACK codes in MKL, ! in which the diagonal becomes row #iDiagonal, ! and logical element (iRow, jCol) is actually stored at (iDiagonal + iRow - jCol, jCol), ! and some extra "workspace" rows are inserted at the top. REAL*8, DIMENSION(:,:), ALLOCATABLE :: EF ! Right-hand-side forcing vector(s) for the solution of horizontal velocity components vw ! within Solve_for_vw. Note that the second subscript will always be 1, but cannot be omitted! ! This is according to conventions of the LAPACK codes in the MKL library. REAL*8, DIMENSION(:), ALLOCATABLE :: adjustments ! fraction of histories adjusted by equation (33) of Bird(1998), % !(1:max_iter = iteration index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: after_eqcm ! present nodal data of after.feg (deleting those nodes that ! could not be integrated back, and compressing the rest); ! duplicated ~6(?) times to allow separating elements, then ! displaced slightly from original node positions (toward element centers); ! expressed in SI units. !(1:4 = elevation/heatflow/crust/mantle-lithosphere; ! 1:before_and_after_numnod) REAL*8, DIMENSION(:,:),ALLOCATABLE :: after_node_uvec ! present locations of nodes of after.feg (deleting those that ! could not be integrated back, and compressing the rest), ! expressed as unit vectors. ! Note that there are ~6(?) times as many of these nodes (compared to num_nod of the ! first temporary FEG) to allow for splitting nodes and displacing them toward element centers. !(1:3 = x,y,z; 1:before_and_after_numnod) LOGICAL*1, DIMENSION(:), ALLOCATABLE :: banished_DIG_point !Intially .FALSE. for all uvecs in list "trace" (accessed through trace_loc) !which memorizes the main contents of the whole f_dig file (except its headers). !Then, whenever any point falls outside the grid, at any timestep, it is marked .TRUE.. !There is no reversing operation, so .TRUE. can never change to .FALSE.. !This prevents parts of traces that were once outside the grid from ever re-entering it, !even if they are later overridden by far-moving blocks of crust, like Baja California! !(1:f_dig_count) INTEGER, DIMENSION(:,:), ALLOCATABLE :: basemap_object_index, basemap_object_index0 ! Set of counters and pointers that organizes the basemap objects, which were ! divided into entries in basemap_title_store and basemap_point_store. !(1:6 = #titles in this object; ! first title slot (in basemap_title_store) for this object; ! last title slot for this object; ! #points in this object; ! first uvec position (in basemap_uvec_store) for this object; ! last uvec position for this object; ! 1:basemap_object_count) !Version "index0" describes the dataset as originally read in from y_dig. !Version "index" describes time-integrated version, with many points/uvecs ! no longer tracked (but not deleted) because they fell outside the FEG area, ! or because they landed in element #i where throughgoing_master_element(i) = .TRUE. ! Note that points which are no longer tracked are condensed-out of each ! basemap object individually (with basemap_object_index(4 & 6, j) reduced); ! however, objects themselves are not deleted from, or moved in, storage. ! At output time, objects with basemap_object_index(4, j) < 2 (or < 3) ! won't be written; the criteria is different for lines vs. areas. TYPE(is123), DIMENSION(:), ALLOCATABLE :: basemap_point_is ! locations of digitised object points, expressed in internal coordinates !(1:basemap_point_count). This array is parallel to basemap_point_store, ! which holds the uvecs determined from these internal coordinates twice per timestep. CHARACTER*80, DIMENSION(:), ALLOCATABLE :: basemap_title_store ! collection of all title records found in all basemap objects together; ! to find start/end of each title group, consult basemap_object_index. !(1:basemap_title_count) REAL*8, DIMENSION(:,:), ALLOCATABLE :: basemap_uvec_store, basemap_uvec_store0 ! collection of all unit-vectors ("uvecs") representing digitization points in ! the basemap/geologic-map. Version "store0" is based on (Elon, Nlat) pairs read ! in from the y_dig .DIG file, and re-used to start each iteration of the solution. ! Version "store" has positions integrated back in time, in the current iteration. !(1:3 = x, y, z component; 1:basemap_point_count; PRIOR to any shrinkage.) INTEGER, DIMENSION(:,:),ALLOCATABLE :: before_and_after_node ! element definitions common to before.feg and after.feg, ! from which non-integratable elements (those involving ! nonintegratable, unrestored nodes) have been deleted, and the others ! compressed. Note that some elements may be extremely distorted ! or folded over to have negative area, and typically each element is a ! disconnected island. That's OK, because these grids are only ! for production of colored maps in RetroMap4, not for input to Restore itself. ! The range of these node-numbers goes from 1 to ~6(?)*num_nod of the first FEG grid. !(1:3 = 3 corner nodes; 1:before_and_after_numel) LOGICAL*1, DIMENSION(:), ALLOCATABLE :: before_and_after_unfaulted ! .TRUE. for any elements of the topologically-equivalent before.FEG and after.FEG, ! where all of the 3 before.FEG nodes of that element were integrated back in time ! without EVER falling into a currently-faulting ! element of the currently-loaded temporary FEG. ! Such elements are the best for computing (meaningful) values ! of net displacement, rotation, & strain over a long tectonic history, ! because their integrated before.FEG node positions have not been ! contaminated by ficticious strain and rotation that afflicts faulting elements ! of the currently-loaded, temporary FEG. !(1:before_and_after_numel) REAL*8, DIMENSION(:,:),ALLOCATABLE :: before_eqcm ! restored nodal data of before.feg (deleting those nodes that ! could not be integrated, and compressing the rest); ! duplicated ~6(?) times to allow separating elements, then ! displaced slightly from original node positions (toward element centers); ! expressed in SI units. !(1:4 = elevation/heatflow/crust/mantle-lithosphere; 1:before_and_after_numnod) INTEGER, DIMENSION(:), ALLOCATABLE :: before_FEG_midpoint_current_l_ ! element number (l_) in the currently-loaded, temporary FEG (of a paleotectonic run) ! which contains the mid-point of element #j in the backward-deforming before.FEG grid. !(1:before_and_after_numnod = j) TYPE(is123), DIMENSION(:), ALLOCATABLE :: before_node_is ! internal coordinates of nodes of before.feg (deleting those that ! could not be integrated back, and compressing the rest), ! in internal coordinates of the current (temporary) grid. ! Note that there are ~6(?) times as many of these nodes, compared to num_nod of the ! first temporary FEG, to allow for splitting nodes and displacing them toward element centers. !(1:before_and_after_numnod) REAL*8, DIMENSION(:,:),ALLOCATABLE :: before_node_uvec ! restored locations of nodes of before.feg (integrated backward ! from present positions in after_node_uvec, while deleting those ! that could not be integrated back, and compressing the rest). ! Note that there are ~6(?) times as many of these nodes, compared to num_nod of the ! first temporary FEG, to allow for splitting nodes and displacing them toward element centers. ! Expressed as unit vectors. !(1:3 = x,y,z; 1:before_and_after_numnod) INTEGER, DIMENSION(:),ALLOCATABLE :: boundary_node ! index number of node with specified velocities !(1:bcs_count = boundary-condition index) LOGICAL(1), DIMENSION(:),ALLOCATABLE :: boxed ! does this element require boxing for correct sigma_1h direction? !(1:num_ele = element index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: center ! Cartesian unit vectors at center of finite elements !(1:3 = x,y,z; 1:num_ele = element index l_) LOGICAL(1), DIMENSION(:,:),ALLOCATABLE :: c_active ! .TRUE. indicates that the X-section datum is applicable to the timestep !(1:num_timesteps = timestep index; 1:c_rst_count = X-section index) CHARACTER(5), DIMENSION(:),ALLOCATABLE :: c_code ! short name of X-section used on master map ! (1:c_rst_count = X-section index) TYPE(is123), DIMENSION(:,:),ALLOCATABLE :: c_end_is ! locations of both ends of cross-section in internal coordinates !(1:2 = west,east end; 1:c_rst_count = X-section index) REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: c_end_now ! current location of ends of each cross-section (integrated); ! both ends are Cartesian unit vectors from Earth center: ! (1:3 = x,y,z; 1:2 = west,east end; 1:c_rst_count = X-section index) REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: c_end_0 ! present location of ends of each cross-section ! both ends are Cartesian unit vectors from Earth center; ! (1:3 = x,y,z; 1:2 = west,east end; 1:c_rst_count = X-section index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: c_err ! 3 norms of cross-section error (each normalized by sigma before combining): !(0:2 = L0,L1,L2 norm; 0:max_iter = pre-solution:iteration index). REAL*8, DIMENSION(:,:),ALLOCATABLE :: c_goal ! target rates of extension of a X-section in each timestep, in m/s ! (1:num_timesteps = timestep index; 1:c_rst_count = X-section index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: c_length ! present and past length of X-section, in m ! (1:2 = present, past; 1:c_rst_count = X-section index) CHARACTER(47), DIMENSION(:), ALLOCATABLE :: c_ref ! bibliographic reference for each X-section datum ! (1:c_rst_count = X-section index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: c_rate ! rates of extension of a X-section in each timestep, in m/s ! (1:num_timesteps = timestep index; 1:c_rst_count = X-section index) REAL*8, DIMENSION(:), ALLOCATABLE :: c_rate_sigma_ ! uncertainty in rate of extension of cross-section, m/s !(1:c_rst_count = X-section index) REAL*8, DIMENSION(:), ALLOCATABLE :: c_sigma_ ! standard deviation of restored length of X-section (and of stretch) ! (1:c_rst_count = X-section index) REAL*8, DIMENSION(:), ALLOCATABLE :: c_stretch ! extension of X-section from past to present, in m ! (1:c_rst_count = X-section index) REAL*8, DIMENSION(:), ALLOCATABLE :: c_t_max ! restored age of X-section, in s ! (1:c_rst_count = X-section index) REAL*8, DIMENSION(:), ALLOCATABLE :: c_t_min ! age of overlap assemblage on restored X-section, in s ! (1:c_rst_count = X-section index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: condition ! boundary velocities, in m/s !(1:2 = theta(South),phi(East) components; ! 1:bcs_count = boundary condition index) INTEGER, DIMENSION(:,:),ALLOCATABLE :: crack_index ! count and pointer to cracks active in each element; !(1:2 = number, position of 1st one in local_crack; ! 1:num_ele = element index) LOGICAL*1, DIMENSION(:), ALLOCATABLE :: current_element_is_unfaulted ! .TRUE. indicates that in the current (temporary) F-E grid, a certain element ! contains no fault segments that are (potentially) active during the ! time-window when this particular temporary grid is in use. !(1:num_ele = element_index) INTEGER, DIMENSION(8) :: datetimenumber ! for output from DATE_AND_TIME REAL*8, DIMENSION (3,2,2,2) :: dG ! array of 2 derivitives of each of the 2 components of ! each of the 6 nodal functions for one element (l_). ! Results are in 1./radian (dimensionless), NOT 1./m or 1./degree ! ! See subprogram Del_Gjxy_del_thetaphi for meaning of subscripts. REAL*8, DIMENSION(:,:), ALLOCATABLE :: duplicate_ABCD ! see ABCD above; this is an extra copy. REAL*8, DIMENSION(:,:), ALLOCATABLE :: duplicate_EF ! see EF above; this is an extra copy. LOGICAL(1), DIMENSION(:), ALLOCATABLE :: edge_element ! Set .FALSE. by default, but .TRUE. for any element on the edge ! of the F-E grid area that has no neighboring element on !(at least) one side. Needed by Unpin_Plate_Corners(). !(1:num_ele = element index l_) LOGICAL(1), DIMENSION(:), ALLOCATABLE :: edge_question ! temporary array used for spatial broadening of the edge_element population, ! in Find_s1s2s3. !(1:num_ele = element index l_) REAL*8, DIMENSION(:), ALLOCATABLE :: ele_azim ! azimuth of most-compressive horizontal principal stress, at ! each element center, in radians clockwise from North. !(1:num_ele = element index l_) REAL*8, DIMENSION(:), ALLOCATABLE :: ele_q ! relevance of the stress datum (or interpolated) stress ! in each element for a particular timestep, 0.0 to 1.0 !(1:num_ele = element index l_) REAL*8, DIMENSION(:), ALLOCATABLE :: ele_sigma ! standard deviation of azimuth of most-compressive horizontal ! principal stress, at each element center, in radians. !(1:num_ele = element index l_) REAL*8, DIMENSION(:,:),ALLOCATABLE :: ele_strainrate ! continuum strain-rate tensor (not including fault strain) ! at center of each element, saved to be output for plotting ! by RetroMap; no other use by Restore. !(1:3 = theta-theta or N-S, theta-phi or SE, phi-phi or E-W; ! 1:num_ele = element index l_) LOGICAL(1), DIMENSION(:), ALLOCATABLE :: ele_stressed ! is there a useful interpolated value of ele_azim, with associated ! del_az_for_90pc <= 0.7854 radians (45 degrees), for this element? !(1:num_ele = element index l_) REAL*8, DIMENSION(:,:),ALLOCATABLE :: eqcm ! nodal data of .feg which was read most recently ! expressed in SI units. !(1:4 = elevation/heatflow/crust/mantle-lithosphere; 1:num_nod) REAL*8, DIMENSION(3) :: eps_dot ! 3-component 2-D (surface-plane) strain-rate of one element, in /s !(1:3 = eps_dot_theta_theta, eps_dot_theta_phi, eps_dot_phi_phi) LOGICAL(1), DIMENSION(:,:),ALLOCATABLE :: f_active ! .TRUE. indicates that this offset datum is applicable to this timestep !(1:num_timesteps = timestep index; 1:f_rst_count = offset index) !N.B. Contrast with trace_active, which is per-trace, not per-offset-datum. CHARACTER(1), DIMENSION(:), ALLOCATABLE :: f_rst_code ! N = Normal; P = Promoted (e.g., Holocene rate used for whole first ! timestep); D = Demoted (rate for 1st timestep ignored since another ! rate of same sense for same fault trace was Promoted). !(1:f_rst_count = offset datum index) CHARACTER*80, DIMENSION(:), ALLOCATABLE :: f_dig_faultName_lines ! memorized so that they can be copied to palinspastic f_.dig files. !(1:f_highest = trace index) CHARACTER*80, DIMENSION(:,:), ALLOCATABLE :: f_dig_faultData_lines ! memorized so that they can be copied to palinspastic f_.dig files. !(1:5 lines (should be enough?); 1:f_highest = trace index) REAL*8, DIMENSION(:), ALLOCATABLE :: f_dip_degrees ! dip of fault in degrees (range 0 ~ 90), as read from an optional ! "dip_degrees 52" data line in the f_dig file. ! Initialized as 0.0, and and unchanged zero values are NOT used. !(1:f_highest = trace index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: f_divide ! temporary storage for accumulating (over all active segments) ! the numerator and denominator that will be used to compute the ! mean slip rate corresponding to each fault offset datum !(1:2 = numerator/denominator; 1:f_rst_count = offset index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: f_err ! 3 norms of fault offset error (each normalized by sigma before combining): !(0:2 = L0,L1,L2 norm; 0:max_iter = before-solution:iteration index). REAL*8, DIMENSION(:,:),ALLOCATABLE :: f_goal ! target rates of fault offset in each timestep, in m/s; ! interpretation depends on sense. ! (1:num_timesteps = timestep index; 1:f_rst_count = offset datum index) REAL*8, DIMENSION(:), ALLOCATABLE :: f_goal_sigma_ ! uncertainty in target fault offset rate (f_goal), m/s !(1:f_rst_count = offset datum index) LOGICAL(1), DIMENSION(:), ALLOCATABLE :: f_new ! was this the first stage of movement on the fault? ! (1:f_rst_count = offset datum index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: f_rate ! computed model rates of fault offset in each timestep, in m/s; ! interpretation depends on sense. ! (1:num_timesteps = timestep index; 1:f_rst_count = offset datum index) REAL*8, DIMENSION(:), ALLOCATABLE :: f_t_max ! maximum age of fault movement, in s ! (1:f_rst_count = offset datum index) REAL*8, DIMENSION(:), ALLOCATABLE :: f_t_min ! minimum age of fault movement, in s ! (1:f_rst_count = offset datum index) LOGICAL*1, DIMENSION(:), ALLOCATABLE :: f_2_in ! Does this fault have at least 2 points inside the current grid? ! Notes: 1. Once f_2_in(i) is .FALSE., it can never become .TRUE. ! in any later timestep, even though a new grid is read. ! It can only be reset TRUE at the beginning of a run !(which is either at present, or resuming by reading an integrated ! f.dig from which outside fault-trace points have been deleted). ! However, a .TRUE. value can always become .FALSE.. ! Thus, only faults continuously deformed are ever output. ! 2. Faults for which f_2_in is .FALSE. are not output in f_dig; ! however, if they have some computed model rate-history, this will ! appear in f_rst output file(s). !(1:f_highest = trace index) LOGICAL*1, DIMENSION(:), ALLOCATABLE :: f_relevant ! Did this fault trace result in ANY segments, ! when first processed by Def_seg_v2? If not, mark it as useless, ! so that we don't waste more time on it. !(Most of these distant traces are composed of time-consuming '***HARD*** steps.') !(1:f_highest = trace index) LOGICAL*1, DIMENSION(:), ALLOCATABLE :: f_retired !Initially this array is set .FALSE. for all trace numbers (whether actually used, or not). !Later, if a fault that was being modeled (at younger geologic epochs) !goes missing from the area of the finite-element grid ! (e.g., either due to grid drift, or manual editing), !then this flag is set .TRUE. (and never negated afterward). !This is just to prevent multiple warning messages for the same fault trace. !(1:f_highest = trace index) CHARACTER(50), DIMENSION(:), ALLOCATABLE :: fault_name ! (1:f_rst_count = offset datum index) INTEGER, DIMENSION(:), ALLOCATABLE :: first_timestep_for_this_grid ! n_ of timestep in which this FEG# (1:num_fegs) will first be used; ! Note that n_ numbering always begins at n_ = 1 when leaving the present-day, ! even though a particular run may be re-started partway through an iteration, with first n_ > 1. ! (1:num_fegs) INTEGER, DIMENSION(:), ALLOCATABLE :: grid_to_load_this_timestep ! Number of the FEG/BCS pair (1:num_fegs) to be loaded at the beginning of this timestep. ! Note that independent variable is always on a COMPLETE-iteration scale of n_ = 1 to NINT(end_time / Deltat_), ! even though a particular run of this program may start part-way through an iteration, at n_ > 1. ! (1: num_timesteps) CHARACTER(80), DIMENSION(:), ALLOCATABLE :: gridname_bcs ! filenames of finite element grid (.feg) files CHARACTER(80), DIMENSION(:), ALLOCATABLE :: gridname_feg ! filenames of boundary condition files REAL*8, DIMENSION(21,0:29) :: ln_rel_prob ! matrix of natural logarithms of relative probabilities of ! difference angles between two sigma_1h directions at spatially ! separated sites. Values are roughly +0.8 to -0.8. ! First (row) subscript identifies the distance annulus, ! out to 22 degrees arc (but annuli are not of uniform width). ! Second (column) subscript identifies the size of the angular ! discrepancy, in 3-degree steps: column 0 is for differences of ! 0-3 degrees, and column 29 is for differences of 87-90 deg. REAL*8, DIMENSION(:), ALLOCATABLE :: loading_age_in_Ma ! Geologic times (e.g., 0.0, 0.6, 1.0, 1.4, 2.0, ... Ma) at ! which grid-swaps will be needed (to prevent illegal element-folding). ! Note that most projects will begin with a single value of "0.0", ! and the times of subsequent necessary grid-swaps will be discovered by ! trial-and-error. !(1:max_fegs = swapped FEG/BCS file-pair index) TYPE(crack), DIMENSION(:), ALLOCATABLE :: local_crack ! a compilation (using structure type crack) of all needed ! information to describe active fault segment in this timestep, ! sorted by element number. See crack_index for location. !(1:crack_count = crack index). REAL*8, DIMENSION(:,:),ALLOCATABLE :: lookAhead_xyz_nod ! tentative positions of nodes of the finite-element grid (integrated), ! as Cartesian unit vectors from center of a unit sphere. ! Used in a rough estimate of whether the current FEG will fold in ! the next upcoming timestep? !(1:3 = x,y,z; 1:num_nod = node index) LOGICAL*1, DIMENSION(:), ALLOCATABLE :: major_fault ! .TRUE. marks a fault trace which has either ! the "throughgoing_master_fault" or "symmetric_spreading_system" ! or "other_spreading_system" attributes ! (at either end, or at both ends) in the f_dig file. ! This array is used to set values in major_fault_elmement, ! which is turn is used to mark certain basemap/geologic-map ! points for deletion from deformed-basemap output files. ! NOTE that the LOGICAL*1 array plate_boundary(trace#) has a very ! similar meaning, but I am keeping these arrays distinct to prevent cross- ! purposes bugs from appearing if related part(s) of the code logic is/are changed later. !(1:f_highest = trace index) LOGICAL*1, DIMENSION(:), ALLOCATABLE :: major_fault_element ! .TRUE. marks elements (of the currently-loaded, temporary FEG) which ! contain a major plate-boundary fault, defined as one that carries either ! the "throughgoing_master_fault" or "symmetric_spreading_system" ! or "other_spreading_system" ! attribute (at either end, or at both ends) in the f_dig file. ! This array will be used to delete points of the basemap/geologic-map ! which fall into those elements, so that local basemap features are not ! excessively stretched and sheared. (A white stripe on the paleogeologic ! map is considered preferable to an artifact.) !(1:num_ele = element index l_) REAL*8, DIMENSION(:,:), ALLOCATABLE :: mu_element ! uncertainty (sigma_) of the nominally-zero strain-rate of stable ! areas; has two values per element: recent, ancient ! and the time of transition is in mu_switch ! (1:2 = recent:ancient, 1:num_ele = element index in current grid) REAL*8, DIMENSION(:), ALLOCATABLE :: mu_switch ! time before present at which algorithm should ! switch from using "recent" mu_element(1,i) to "ancient" ! mu_element(2,i). Note that input values from the .FEG ! file are in units of Ma, but internal values are in s. ! (1:num_ele = element index in current grid) INTEGER, DIMENSION(:,:), ALLOCATABLE :: neighbor ! list of neighboring finite elements, by integer identifier. ! Any value of 0 indicates a free edge of the F-E grid area. !(1:3 = side crossed; 1:num_ele = element index l_) ! (1:num_ele = element index in current grid) REAL*8, DIMENSION(:), ALLOCATABLE :: neotec_offset_rate ! neotectonic rate of fault offset, in m/s (always positive; see sense) ! (1:f_rst_count = offset datum index) REAL*8, DIMENSION(:), ALLOCATABLE :: neotec_offset_rate_sigma_ ! sigma_ of neotectonic fault offset rate, in m/s (always positive) ! (1:f_rst_count = offset datum index) REAL*8, DIMENSION(:), ALLOCATABLE :: nodal_area_strainrate ! wedge-angle-weighted mean of area strain-rates in all elements ! connected to each node. Equal to mean value of (eps_dot(1) + eps_dot(3)) ! in units of /s. Positive where lithosphere is laterally stretching and ! therefore must be vertically thinning (to conserve volume). ! (1:num_nod = node index) INTEGER, DIMENSION(:,:),ALLOCATABLE :: node ! list of nodes defining each element, in counterclockwise order ! as seen from outside the planet. !(1:3 = 3 corners; 1:num_ele = element index l_) REAL*8, DIMENSION(:), ALLOCATABLE :: offset ! amount of fault offset, in m (always positive; see sense) ! (1:f_rst_count = offset datum index) REAL*8, DIMENSION(:), ALLOCATABLE :: offset_sigma_ ! sigma_ of fault offset, in m (always positive) ! (1:f_rst_count = offset datum index) LOGICAL(1), DIMENSION(:,:),ALLOCATABLE :: p_active ! .TRUE. indicates that the paleomagnetic datum is applicable to the timestep !(1:num_timesteps = timestep index; 1:p_rst_count = offset index) REAL*8, DIMENSION(:), ALLOCATABLE :: p_ccw ! counterclockwise rotation of paleomagnetic site, from past ! to present, in radians ! (1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: p_ccw_err ! 3 norms of rotation error (each normalized by sigma before combining): !(0:2 = L0,L1,L2 norm; 0:max_iter = pre-solution:iteration index). REAL*8, DIMENSION(:,:),ALLOCATABLE :: p_ccw_goal ! target counterclockwise rotation rate of a paleomagnetic site, ! going from past to present, in radians/s !(1:num_timesteps = timestep index; 1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: p_ccw_rate ! model counterclockwise rotation rate of a paleomagnetic site, ! going from past to present, in radians/s !(1:num_timesteps = timestep index; 1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:), ALLOCATABLE :: p_ccw_rate_sigma_ ! uncertainty in counterclockwise rotation rate, radian/s !(1:p_rst_count = paleomagentic site index) REAL*8, DIMENSION(:), ALLOCATABLE :: p_ccw_sigma_ ! standard deviation of counterclockwise rotation of paleomagnetic ! site, from past to present, in radians ! (1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: p_pole ! Paleo-North-pole at time of magnetization of paleomagnetic site, ! in reference frame used for velocity boundary conditions, ! expressed as Cartesian unit vector !(1:3 = x,y,z; 1:p_rst_count = paleomagnetic site index) CHARACTER(50), DIMENSION(:), ALLOCATABLE :: p_ref ! bibliographic reference for each paleomagnetic site ! (1:p_rst_count = paleomagnetic site index) TYPE(is123), DIMENSION(:), ALLOCATABLE :: p_site_is ! locations of paleomagnetic sites in internal coordinates !(1:p_rst_count = paleomagentic site index) REAL*8, DIMENSION(:,:), ALLOCATABLE :: p_site_now ! current location of paleomagnetic site (integrated); ! Cartesian unit vector from Earth center: ! (1:3 = x,y,z; 1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:,:), ALLOCATABLE :: p_site_0 ! present location of paleomagnetic site; ! Cartesian unit vector from Earth center: ! (1:3 = x,y,z; 1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:), ALLOCATABLE :: p_south ! distance that paleomagnetic site has drifted South, in m ! (1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: p_south_err ! 3 norms of paleolatitude error (each normalized by sigma before combining): !(0:2 = L0,L1,L2 norm; 0:max_iter = pre-solution:iteration index). REAL*8, DIMENSION(:,:),ALLOCATABLE :: p_south_goal ! target velocities toward paleo-South of a paleomagnetic site, in m/s !(1:num_timesteps = timestep index; 1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: p_south_rate ! model velocities toward paleo-South of a paleomagnetic site, in m/s !(1:num_timesteps = timestep index; 1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:), ALLOCATABLE :: p_south_sigma_ ! standard deviation of distance that paleomagnetic site has ! drifted South, in m ! (1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:), ALLOCATABLE :: p_south_rate_sigma_ ! uncertainty in Southward drift rate, m/s !(1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:), ALLOCATABLE :: p_t_max ! mean age of magnetization, in seconds !(1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:), ALLOCATABLE :: p_t_min ! this is the age, in s, at which paleomagnetic sites were sampled; ! so all values are 0.; provided as a necessary actual parameter. !(1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:), ALLOCATABLE :: p_t1 ! maximum age of magnetization (averaged with p_t2 to give ! p_t_max), in seconds !(1:p_rst_count = paleomagnetic site index) REAL*8, DIMENSION(:), ALLOCATABLE :: p_t2 ! minimum age of magnetization (averaged with p_t1 to give ! p_t_max), in seconds !(1:p_rst_count = paleomagnetic site index CHARACTER(14), DIMENSION(18) :: param_name ! different possible names of the parameters.rst file. LOGICAL(1), DIMENSION(:), ALLOCATABLE :: plate_boundary ! Set .FALSE. for most fault traces, but .TRUE. for those which have ! any special continuity-property (throughgoing_master_fault, AND/OR ! symmetric_spreading_system, AND/OR other_spreading_system) at either ! end, or at both ends. Default value of .FALSE. also applies to any ! Fnnnn#s that are not currently in use. Needed by Unpin_Plate_Corners. ! NOTE that the LOGICAL*1 array major_fault(trace#) has a very ! similar meaning, but I am keeping these arrays distinct to prevent cross- ! purposes bugs from appearing if related part(s) of the code logic is/are changed later. !(1:f_highest = trace index; i.e., Fnnnn#) REAL*8, DIMENSION(:), ALLOCATABLE :: plateward_dAzimuth ! Used only for faults with the "symmetric_spreading_system" attribute, ! which move according to translation method #2. !(For all other faults, this array is initialized as 0.0D0 and never used.) ! Value, in radians, which indicates the clockwise change in azimuth ! that must be added to the digitization-direction azimuth of a fault ! trace, in order to find the direction that points toward stable plate ! interior. Common values are +-(0.5D0 * Pi), +-(0.25D0 * Pi), and ! +-(0.75D0 * Pi) at fault ends, but other interpolated values may occur ! at interior points along the trace of a symmetric_spreading_system ! fault IFF it was digitized with more than 2 points. !(1:f_dig_count = in order read) REAL*8, DIMENSION(3) :: pole ! temporary Cartesian unit vector REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: rate_err ! 3 norms of rate error (each normalized by sigma before combining): !(0:2 = L0,L1,L2 norm; 0:num_timesteps = mean for iteration, each step; ! 1:max_iter = iteration index). REAL*8, DIMENSION(:,:),ALLOCATABLE :: s_activity ! relevance (q) of a stress datum in the timestep: 0.0 to 1.0 !(1:num_timesteps = timestep index; 1:s_rst_count = offset index) REAL*8, DIMENSION(:), ALLOCATABLE :: s_azim_now ! (integrated) azimuth of most compressive horizontal principal stress, ! in radians clockwise from North (in the reference frame ! used to define velocity boundary conditions) !(1:s_rst_count = paleostress site index) REAL*8, DIMENSION(:), ALLOCATABLE :: s_azim_0 ! present azimuth of most compressive horizontal principal stress, ! in radians clockwise from North !(1:s_rst_count = paleostress site index) CHARACTER(5), DIMENSION(:), ALLOCATABLE :: s_code ! master-map location memo for each paleostress datum ! (1:s_rst_count = paleostress index) CHARACTER(30), DIMENSION(:), ALLOCATABLE :: s_loc ! geographic location memo for each paleostress datum ! (1:s_rst_count = paleostress index) CHARACTER(30), DIMENSION(:), ALLOCATABLE :: s_ref ! bibliographic reference for each paleostress datum ! (1:s_rst_count = paleostress index) REAL*8, DIMENSION(:), ALLOCATABLE :: s_sigma_ ! standard deviation of azimuth of most compressive ! horizontal principal stress, in radians !(1:s_rst_count = paleostress site index) TYPE(is123), DIMENSION(:,:), ALLOCATABLE :: s_site_is ! locations of paleostress sites in internal coordinates !(1:2 = site,neighbor@azimuth_cw_from_N; ! 1:s_rst_count = paleostress site index) REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: s_site_now ! current location of paleostress site (integrated); ! Cartesian unit vector from Earth center: ! (1:3 = x,y,z; 1:2 = site,neighbor@azimuth_cw_from_N; ! 1:s_rst_count = paleostress site index) REAL*8, DIMENSION(:,:), ALLOCATABLE :: s_site_0 ! present-day location of paleostress site; ! Cartesian unit vector from Earth center: ! (1:3 = x,y,z; 1:s_rst_count = paleostress site index) LOGICAL(1), DIMENSION(:), ALLOCATABLE :: s_stage ! .TRUE. indicates that paleostress is valid anytime ! from s_t_max to s_t_min (not just SOME time) !(1:s_rst_count = paleostress site index) REAL*8, DIMENSION(:), ALLOCATABLE :: s_t_max ! maximum age of paleostress, in s ! (1:s_rst_count = paleostress site index) REAL*8, DIMENSION(:), ALLOCATABLE :: s_t_min ! minimum age of paleostress, in s ! (1:s_rst_count = paleostress site index) INTEGER, DIMENSION(:,:),ALLOCATABLE :: seg_def ! defines a fault segment by its fault trace # and element # !(1:2 = trace, element; 1:seg_count = segment index) REAL*8, DIMENSION(:,:,:),ALLOCATABLE :: seg_end !Cartesian unit vectors at each end of fault segment !(a fault segment is the intersection of an element with a trace) !(1:3 = xyz, 1:2 = beginning/end, 1:seg_count = segment index) TYPE(is123), DIMENSION(:,:),ALLOCATABLE :: seg_end_is ! element number and internal coordinates at each end of fault segment !(a fault segment is the intersection of an element with a trace) !(1:2 = beginning/end, 1:seg_count = segment index) REAL*8, DIMENSION(:), ALLOCATABLE :: seg_eta_ ! eta_ (-1.0D0 or +1.0D0) for each fault segment, ! depending on whether isolated node u_ is to left or to right, respectively. !(1:seg_count = segment index) REAL*8, DIMENSION(:), ALLOCATABLE :: seg_kappa_ ! kappa_ (relative length) of each fault segment !(1:seg_count = segment index) INTEGER, DIMENSION(:), ALLOCATABLE :: seg_u_ ! u_ = 1, 2, or 3 to identify isolated node of segment !(1:seg_count = segment index) CHARACTER(1), DIMENSION(:), ALLOCATABLE :: sense ! T = thrust, N = normal, D = detachment, R = dextral, L = sinistral ! (1:f_rst_count = offset datum index) INTEGER, DIMENSION(:), ALLOCATABLE :: timestep_first_faulted ! A "memo" array (for debugging purposes) which records the timestep (n_) ! in which an element of the before_and_after FEGs was first marked .FALSE. ! in its before_and_after_unfaulted(ele) LOGICAL attribute. ! Values are all set as negative numbers. ! The default initialization value of "9999" should persist if the ! element still has before_and_after_unfaulted(ele) = .TRUE. ! (1:before_and_after_numel) REAL*8, DIMENSION(:,:),ALLOCATABLE :: trace ! uvecs of all fault traces in one long list; access through trace_loc. ! (1:3 = x,y,z components of unit vector; 1:f_dig_count = in order read) LOGICAL(1), DIMENSION(:,:),ALLOCATABLE :: trace_active ! .TRUE. indicates that this trace was slipping in this timestep !(1:num_timesteps = timestep index; 1:f_highest = trace index) !N.B. Contrast with f_active, which is per-offset-datum, not per-trace. REAL*8, DIMENSION(:,:),ALLOCATABLE :: trace_premove ! uvecs of all fault traces in one long list; access through trace_loc. ! Note that this provides memory of pre-translation positions ! (copied from trace) which will be needed by translation method #2. ! (1:3 = x,y,z components of unit vector; 1:f_dig_count = in order read) REAL*8, DIMENSION(:,:),ALLOCATABLE :: trace_0 ! present uvecs of all fault traces in one long list; access through trace_loc. ! (1:3 = x,y,z components of unit vector; 1:f_dig_count = in order read) TYPE(is123), DIMENSION(:), ALLOCATABLE :: trace_is ! locations of digitization points along fault traces, in internal coordinates ! (element INTEGER #, and 3 REAL*8 s1, s2, s3 dimensionless coordinates) !(1:f_dig_count = in order read) INTEGER, DIMENSION(:,:),ALLOCATABLE :: trace_loc ! gives locations within "trace" where one fault trace is found, ! both in terms of digitised points (in traces) and in terms of ! fault segments (in seg_def, seg_end, seg_end_is); ! (1:4 = first, last entry in "trace"; first, last segment; ! 0:f_highest = trace index (ties f_rst to f_dig)) REAL*8, DIMENSION(:), ALLOCATABLE :: trace_formed_Ma ! age (in Ma) of beginning of first movement of ANY component of offset ! in ANY chapter when a fault was active. Used to prevent plotting of ! fault traces that did not exist in earlier epochs. ! Value are based entirely on input dataset. !(1:f_highest = trace index) CHARACTER(1), DIMENSION(:), ALLOCATABLE :: trace_type ! records 1-character fault sense from f_dig, for writing !(1:f_highest = trace index) INTEGER*2, DIMENSION(:), ALLOCATABLE :: translation_method ! Values may include: ! 0: throughgoing_master_fault method (trace moves with surrounding element); ! 1: default method (trace moves with surrounding element, except where ! "unhooked" to prevent bending of its ends by other strike-slip faults); ! 2: symmetric_spreading_system method (mean of velocities of two bounding plates); ! 3: other_spreading_system method (ends remain linked, but NO smoothing of joint as ! in method 0, and also NO averaging of adjacent plate velocities as in method 2). !(1:f_dig_count = in order read) LOGICAL(1), DIMENSION(:), ALLOCATABLE :: twisted ! a paleomagnetic site is designated twisted if if shares a ! finite element with an active strike-slip fault at any time ! younger than its magnetization age. Twisted data are not ! used as data, and no corresponding model prediction is output. ! A site never becomes un-twisted once it is twisted ! (even though a different finite-element grid is read in). ! (1:p_rst_count = palemagnetic site index) REAL*8, DIMENSION(:), ALLOCATABLE :: u_flag ! indicator of singularity returned by LSLPB: 0. or 1. !(1:nDOF) REAL*8, DIMENSION(3) :: vec1, vec2 ! temporary Cartesian unit vectors REAL*8, DIMENSION(:), ALLOCATABLE :: vw0 ! alternating theta (South) and phi (East) velocity components ! at finite element nodes, in m/s, at young end of timestep !(1:2:num_nod = position in solution vector of linear system) REAL*8, DIMENSION(:), ALLOCATABLE :: vw1 ! alternating theta (South) and phi (East) velocity components ! at finite element nodes, in m/s, at old end of timestep !(1:2:num_nod = position in solution vector of linear system) REAL*8, DIMENSION(:), ALLOCATABLE :: vw_add ! alternating theta (South) and phi (East) velocity component ! increments at finite lement nodes, in m/s, for the corrector !(1:2:num_nod = position in solution vector of linear system) REAL*8, DIMENSION(:), ALLOCATABLE :: vw_mean ! alternating theta (South) and phi (East) velocity components ! at finite element nodes, in m/s, averaging predictor & corrector !(1:2:num_nod = position in solution vector of linear system) INTEGER, DIMENSION(:), ALLOCATABLE :: which_trace ! which trace index goes with this fault offset datum? ! use value to read actual trace location from trace_loc ! (1:f_rst_count = fault offset datum index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: xyz_nod ! positions of node of the finite-element grid (integrated), ! as Cartesian unit vectors from center of a unit sphere. !(1:3 = x,y,z; 1:num_nod = node index) REAL*8, DIMENSION(:,:),ALLOCATABLE :: xyz_nod_premove ! positions of node of the finite-element grid (integrated; ! but integrated one LESS step than those in array xyz_nod), ! as Cartesian unit vectors from center of a unit sphere. !(1:3 = x,y,z; 1:num_nod = node index) !-------------------------------------------------------------------- ! ! Initialize array of relative probabilities of angular discrepancies, ! as a function of angular (arc) distance between stress indicators. ! (Bird & Li, 1996, J. Geophys. Res., v.101, #B3, 5435-5443) ! We formed 21 annuli for 0-22 deg. angular distance, using ! epsilon = 0.4 and 150 bins for the whole 180-degree range.. ! We used 30 3-degree sectors for beta, covering 0-90 degrees. ! Using all 6000 data of the World Stress Map (Zoback, 1992), we ! counted the frequency of certain differences (beta). ! In each annulus (row), we divided by the total and multiplied by ! 30 to get relative probabilities of order 1. ! Finally, we took the natural logarithm of all numbers, to speed ! formation of extended products. ln_rel_prob( 1,0:29) = & (/+0.790D0,+0.682D0,+0.639D0,+0.606D0,+0.553D0,+0.478D0,+0.449D0,+0.349D0,+0.318D0,+0.216D0,+0.179D0,+0.086D0,-0.006D0,-0.063D0,-0.192D0,& -0.261D0,-0.320D0,-0.401D0,-0.440D0,-0.546D0,-0.607D0,-0.644D0,-0.725D0,-0.727D0,-0.791D0,-0.791D0,-0.790D0,-0.781D0,-0.869D0,-0.843D0/) ln_rel_prob( 2,0:29) = & (/+0.522D0,+0.474D0,+0.449D0,+0.440D0,+0.378D0,+0.351D0,+0.317D0,+0.262D0,+0.252D0,+0.171D0,+0.110D0,+0.091D0,+0.015D0,-0.018D0,-0.088D0,& -0.134D0,-0.185D0,-0.244D0,-0.280D0,-0.309D0,-0.379D0,-0.408D0,-0.442D0,-0.394D0,-0.465D0,-0.447D0,-0.450D0,-0.456D0,-0.475D0,-0.462D0/) ln_rel_prob( 3,0:29) = & (/+0.416D0,+0.409D0,+0.379D0,+0.360D0,+0.357D0,+0.291D0,+0.276D0,+0.225D0,+0.191D0,+0.149D0,+0.123D0,+0.077D0,+0.021D0,-0.022D0,-0.045D0,& -0.109D0,-0.145D0,-0.180D0,-0.214D0,-0.256D0,-0.262D0,-0.295D0,-0.311D0,-0.331D0,-0.379D0,-0.381D0,-0.378D0,-0.387D0,-0.379D0,-0.433D0/) ln_rel_prob( 4,0:29) = & (/+0.361D0,+0.353D0,+0.312D0,+0.318D0,+0.296D0,+0.274D0,+0.256D0,+0.208D0,+0.191D0,+0.150D0,+0.112D0,+0.055D0,+0.031D0,-0.010D0,-0.046D0,& -0.067D0,-0.144D0,-0.143D0,-0.191D0,-0.262D0,-0.248D0,-0.311D0,-0.284D0,-0.342D0,-0.293D0,-0.270D0,-0.266D0,-0.309D0,-0.302D0,-0.347D0/) ln_rel_prob( 5,0:29) = & (/+0.273D0,+0.275D0,+0.267D0,+0.246D0,+0.239D0,+0.220D0,+0.210D0,+0.150D0,+0.126D0,+0.104D0,+0.094D0,+0.062D0,+0.051D0,-0.003D0,-0.028D0,& -0.054D0,-0.081D0,-0.109D0,-0.130D0,-0.158D0,-0.189D0,-0.217D0,-0.214D0,-0.263D0,-0.233D0,-0.225D0,-0.239D0,-0.254D0,-0.253D0,-0.210D0/) ln_rel_prob( 6,0:29) = & (/+0.343D0,+0.332D0,+0.346D0,+0.305D0,+0.270D0,+0.241D0,+0.213D0,+0.182D0,+0.186D0,+0.143D0,+0.117D0,+0.080D0,+0.038D0,+0.031D0,-0.025D0,& -0.056D0,-0.092D0,-0.127D0,-0.143D0,-0.200D0,-0.219D0,-0.289D0,-0.243D0,-0.303D0,-0.294D0,-0.315D0,-0.332D0,-0.343D0,-0.359D0,-0.358D0/) ln_rel_prob( 7,0:29) = & (/+0.327D0,+0.387D0,+0.314D0,+0.279D0,+0.294D0,+0.240D0,+0.236D0,+0.193D0,+0.173D0,+0.133D0,+0.103D0,+0.084D0,+0.060D0,+0.018D0,-0.047D0,& -0.075D0,-0.113D0,-0.123D0,-0.160D0,-0.223D0,-0.241D0,-0.295D0,-0.280D0,-0.289D0,-0.252D0,-0.313D0,-0.291D0,-0.341D0,-0.333D0,-0.329D0/) ln_rel_prob( 8,0:29) = & (/+0.290D0,+0.264D0,+0.282D0,+0.259D0,+0.279D0,+0.226D0,+0.203D0,+0.203D0,+0.163D0,+0.125D0,+0.092D0,+0.084D0,+0.062D0,+0.018D0,-0.009D0,& -0.020D0,-0.076D0,-0.118D0,-0.137D0,-0.143D0,-0.223D0,-0.212D0,-0.246D0,-0.267D0,-0.315D0,-0.276D0,-0.291D0,-0.277D0,-0.296D0,-0.333D0/) ln_rel_prob( 9,0:29) = & (/+0.259D0,+0.254D0,+0.252D0,+0.290D0,+0.223D0,+0.221D0,+0.215D0,+0.195D0,+0.172D0,+0.135D0,+0.098D0,+0.071D0,+0.053D0,-0.004D0,+0.007D0,& -0.062D0,-0.058D0,-0.078D0,-0.135D0,-0.157D0,-0.160D0,-0.205D0,-0.233D0,-0.259D0,-0.263D0,-0.263D0,-0.281D0,-0.265D0,-0.324D0,-0.323D0/) ln_rel_prob(10,0:29) = & (/+0.213D0,+0.208D0,+0.198D0,+0.190D0,+0.192D0,+0.195D0,+0.152D0,+0.158D0,+0.153D0,+0.121D0,+0.105D0,+0.106D0,+0.084D0,+0.048D0,+0.039D0,& +0.005D0,-0.040D0,-0.057D0,-0.109D0,-0.145D0,-0.158D0,-0.184D0,-0.215D0,-0.228D0,-0.237D0,-0.258D0,-0.230D0,-0.204D0,-0.266D0,-0.289D0/) ln_rel_prob(11,0:29) = & (/+0.179D0,+0.139D0,+0.164D0,+0.204D0,+0.183D0,+0.167D0,+0.164D0,+0.158D0,+0.157D0,+0.099D0,+0.071D0,+0.042D0,+0.086D0,+0.031D0,+0.000D0,& -0.001D0,-0.041D0,-0.069D0,-0.084D0,-0.118D0,-0.144D0,-0.170D0,-0.180D0,-0.192D0,-0.181D0,-0.181D0,-0.194D0,-0.193D0,-0.223D0,-0.201D0/) ln_rel_prob(12,0:29) = & (/+0.128D0,+0.192D0,+0.136D0,+0.158D0,+0.159D0,+0.132D0,+0.102D0,+0.118D0,+0.125D0,+0.139D0,+0.109D0,+0.038D0,+0.093D0,+0.033D0,-0.024D0,& +0.002D0,-0.056D0,-0.067D0,-0.091D0,-0.100D0,-0.178D0,-0.119D0,-0.147D0,-0.146D0,-0.164D0,-0.172D0,-0.156D0,-0.141D0,-0.196D0,-0.158D0/) ln_rel_prob(13,0:29) = & (/+0.078D0,+0.114D0,+0.085D0,+0.128D0,+0.090D0,+0.126D0,+0.089D0,+0.079D0,+0.046D0,+0.040D0,+0.037D0,+0.036D0,+0.010D0,-0.033D0,+0.019D0,& -0.072D0,-0.051D0,-0.071D0,-0.064D0,-0.087D0,-0.071D0,-0.065D0,-0.072D0,-0.077D0,-0.071D0,-0.067D0,-0.040D0,-0.056D0,-0.075D0,-0.085D0/) ln_rel_prob(14,0:29) = & (/+0.098D0,+0.069D0,+0.104D0,+0.106D0,+0.117D0,+0.099D0,+0.113D0,+0.130D0,+0.080D0,+0.047D0,+0.080D0,+0.042D0,+0.024D0,+0.021D0,-0.004D0,& -0.001D0,-0.049D0,-0.068D0,-0.032D0,-0.053D0,-0.060D0,-0.081D0,-0.110D0,-0.096D0,-0.080D0,-0.096D0,-0.115D0,-0.116D0,-0.139D0,-0.146D0/) ln_rel_prob(15,0:29) = & (/+0.187D0,+0.133D0,+0.181D0,+0.145D0,+0.138D0,+0.095D0,+0.140D0,+0.128D0,+0.083D0,+0.067D0,+0.085D0,+0.052D0,+0.051D0,+0.038D0,-0.010D0,& -0.066D0,+0.004D0,-0.021D0,-0.075D0,-0.098D0,-0.105D0,-0.150D0,-0.121D0,-0.106D0,-0.162D0,-0.149D0,-0.158D0,-0.174D0,-0.188D0,-0.160D0/) ln_rel_prob(16,0:29) = & (/+0.156D0,+0.172D0,+0.132D0,+0.139D0,+0.155D0,+0.117D0,+0.097D0,+0.087D0,+0.088D0,+0.107D0,+0.057D0,+0.056D0,+0.038D0,+0.026D0,+0.001D0,& -0.016D0,-0.038D0,-0.079D0,-0.077D0,-0.081D0,-0.105D0,-0.113D0,-0.077D0,-0.145D0,-0.143D0,-0.160D0,-0.157D0,-0.138D0,-0.139D0,-0.150D0/) ln_rel_prob(17,0:29) = & (/+0.130D0,+0.136D0,+0.131D0,+0.136D0,+0.107D0,+0.134D0,+0.119D0,+0.109D0,+0.123D0,+0.075D0,+0.027D0,+0.018D0,+0.046D0,+0.041D0,+0.029D0,& -0.036D0,-0.025D0,-0.028D0,-0.081D0,-0.054D0,-0.091D0,-0.070D0,-0.122D0,-0.113D0,-0.144D0,-0.117D0,-0.190D0,-0.162D0,-0.155D0,-0.145D0/) ln_rel_prob(18,0:29) = & (/+0.118D0,+0.097D0,+0.089D0,+0.092D0,+0.074D0,+0.089D0,+0.108D0,+0.122D0,+0.103D0,+0.104D0,+0.030D0,+0.053D0,+0.049D0,+0.055D0,-0.010D0,& +0.010D0,-0.051D0,-0.048D0,-0.056D0,-0.097D0,-0.077D0,-0.146D0,-0.086D0,-0.107D0,-0.098D0,-0.093D0,-0.107D0,-0.098D0,-0.122D0,-0.117D0/) ln_rel_prob(19,0:29) = & (/+0.135D0,+0.067D0,+0.070D0,+0.114D0,+0.110D0,+0.103D0,+0.084D0,+0.040D0,+0.102D0,+0.038D0,+0.011D0,+0.056D0,+0.013D0,+0.003D0,+0.005D0,& -0.024D0,+0.004D0,-0.059D0,-0.008D0,-0.022D0,-0.080D0,-0.064D0,-0.028D0,-0.144D0,-0.089D0,-0.083D0,-0.125D0,-0.123D0,-0.092D0,-0.108D0/) ln_rel_prob(20,0:29) = & (/+0.082D0,+0.047D0,+0.077D0,+0.054D0,+0.066D0,+0.051D0,+0.078D0,+0.049D0,+0.042D0,+0.010D0,+0.055D0,+0.015D0,+0.047D0,+0.049D0,+0.020D0,& +0.033D0,+0.020D0,-0.008D0,-0.002D0,-0.017D0,-0.044D0,-0.036D0,-0.081D0,-0.050D0,-0.070D0,-0.107D0,-0.091D0,-0.112D0,-0.098D0,-0.139D0/) ln_rel_prob(21,0:29) = & (/+0.051D0,+0.076D0,+0.037D0,+0.028D0,+0.037D0,+0.049D0,+0.027D0,+0.043D0,+0.031D0,+0.014D0,+0.022D0,+0.022D0,+0.023D0,+0.001D0,+0.005D0,& +0.020D0,-0.014D0,-0.001D0,-0.004D0,-0.006D0,-0.038D0,-0.036D0,-0.036D0,-0.067D0,-0.037D0,-0.034D0,-0.028D0,-0.042D0,-0.071D0,-0.096D0/) !-------------------------------------------------------------------- memory = 0.0D0 ! total of allocated arrays, in bytes. [N.B. Stored as REAL*8 to avoid INTEGER overflow problems.] seg_count_doubled = -1 ! I use this value as a flag that the variable still needs to be initialized. ! warn user if an old REPORT.txt is about to be overwritten? OPEN (UNIT = 21, FILE = "REPORT.txt", STATUS = "OLD", IOSTAT = ios) IF (ios == 0) THEN ! an old version of REPORT.txt exists (in current folder)... CLOSE (21) ! (release this file, so that user can rename it) WRITE (*, "(' ')") WRITE (*, "(' CAUTION: Existing file REPORT.txt is about to be overwritten!')") WRITE (*, "(' If you wish to save its contents, then you must RENAME')") WRITE (*, "(' this file *NOW* (BEFORE pressing Enter at this prompt!)')") CALL Pause() WRITE (*, "(' ')") END IF ! write the header and initial time stamp WRITE (*, "(' ')") WRITE (*, "(' Starting Restore; for details see REPORT.txt')") OPEN (UNIT = 21, FILE = "REPORT.txt", STATUS = "REPLACE", & ! Note that any older version will be overwritten; ACTION = "WRITE") ! therefore, you should first RENAME any REPORT.txt you wish to save. WRITE (21, "('===========================================================')") WRITE (21, "('A record of one run of program Restore')") WRITE (21, "('(palinspastic restoration by integration of paleotectonics)')") WRITE (21, "('by Peter Bird')") WRITE (21, "(' Department of Earth, Planetary, and Space Sciences')") WRITE (21, "(' University of California')") WRITE (21, "(' Los Angeles, CA 90095-1567')") WRITE (21, "(' pbird@epss.ucla.edu')") WRITE (21, "(' version 4.0, 17 November 2021')") ! "version & date" WRITE (21, "('-----------------------------------------------------------')") CALL DATE_AND_TIME (date, clock_time, zone, datetimenumber) WRITE (21,"('Run began on ',I4,'.',I2,'.',I2,' at ',I2,':',I2,':',I2)") & datetimenumber(1), datetimenumber(2), datetimenumber(3), & datetimenumber(5), datetimenumber(6), datetimenumber(7) WRITE (21, "('-----------------------------------------------------------')") ! parameter section (with immediate conversions to SI units) WRITE (*, "(' Reading parameters for this run...')") WRITE (21, "('Begin reading parameters for this run, from')") WRITE (21, "(' Parameters.rst = parameter file:')") param_name = (/ 'PARAMETE.RST ', 'PARAMETE.Rst ', 'PARAMETE.rst ', & & 'Paramete.RST ', 'Paramete.Rst ', 'Paramete.rst ', & & 'paramete.RST ', 'paramete.Rst ', 'paramete.rst ', & & 'PARAMETERS.RST', 'PARAMETERS.Rst', 'PARAMETERS.rst', & & 'Parameters.RST', 'Parameters.Rst', 'Parameters.rst', & & 'parameters.RST', 'parameters.Rst', 'parameters.rst' /) DO i = 1, 18 OPEN (UNIT = 1, FILE = param_name(i), STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = read_status) IF (read_status == 0) EXIT END DO IF (read_status /= 0) THEN WRITE (*, "(' ERROR: Could not locate file PARAMETE[RS].RST')") WRITE (*, "(' (in either upper, lower, or mixed-case)')") WRITE (21, "('ERROR: Could not locate file PARAMETE[RS].RST')") WRITE (21, "('(in either upper, lower, or mixed-case)')") CALL Pause() STOP ENDIF line = 0 ! start time (of this run) READ (1, *) t ; line = line + 1 IF (t < 0.0D0) CALL Prevent ('negative age', line, "Parameters.rst") WRITE (21,"(F10.2,' geologic age at start of this run, in Ma ( 0? )')") t this_run_starts_Ma = t start_time = t * s_per_Ma ! end time (of this run) READ (1, *) t ; line = line + 1 IF (t < 0.0D0) CALL Prevent ('negative age', line, "Parameters.rst") WRITE (21,"(F10.2,' greatest geologic age (end of run), in Ma ( >=0 )')") t this_run_ends_Ma = t end_time = t * s_per_Ma IF (end_time < start_time) THEN WRITE (*, "(' Error; age in line 2 must be .GE. ( >= ) age in line 1.')") WRITE (21,"('Error; age in line 2 must be .GE. ( >= ) age in line 1.')") CALL Pause() STOP END IF ! ultimate age (end of all iterations) READ (1, *) t ; line = line + 1 IF (t < 0.0D0) CALL Prevent ('negative age', line, "Parameters.rst") WRITE (21,"(F10.2,' ultimate age target (where iterations end, and all rate-goals are adjusted)')") t ultimate_age_Ma = t ultimate_age_s = t * s_per_Ma ! time step READ (1, *) t ; line = line + 1 Deltat_ = t * s_per_Ma WRITE (21,"(F10.2,' time-step, in Ma (or m.y.)')") t neotec = (start_time == end_time).OR.(Deltat_ <= 0.0D0) paleotec = .NOT. neotec IF (paleotec) THEN WRITE (21, "('paleotec = T; Solution will be integrated back through time.')") ELSE ! neotec WRITE (*, *) WRITE (*, "(' *********************************************************************')") WRITE (*, "(' neotec = T; ONLY neotectonic velocity at start-time will be computed.')") WRITE (*, "(' *********************************************************************')") WRITE (*, *) WRITE (21, "('*********************************************************************')") WRITE (21, "('neotec = T; ONLY neotectonic velocity at start-time will be computed.')") WRITE (21, "('*********************************************************************')") END IF ! paleotec, or neotec? ! number of refinements READ (1, *) n_refine ; line = line + 1 IF (n_refine < 0) CALL Prevent ('negative refinements', line, "Parameters.rst") WRITE (21,"(I10,' number of refinements of each velocity solution')") n_refine ! previous iterations READ (1, *) past_iterations ; line = line + 1 IF (paleotec) THEN IF (past_iterations < 0) CALL Prevent ('negative past iterations', line, "Parameters.rst") WRITE (21,"(I10,' number of past iterations of whole history COMPLETED before this run')") past_iterations ELSE ! neotec past_iterations = 0 WRITE (21,"(I10,' number of past iterations [NOT USED in neotectonic mode]')") past_iterations END IF ! iterations in this run READ (1, *) max_iter ; line = line + 1 IF (paleotec) THEN IF (max_iter <= 0) CALL Prevent ('nonpositive iteration limit', line, "Parameters.rst") IF (max_iter > 1) THEN IF (start_time > 0.0D0) THEN WRITE (*,"(' ----------------------------------------------------------')") WRITE (*, "(' Error: Inconsistent parameters.')") WRITE (*,"(' You have requested a starting age > 0. and more than 1 iteration.')") WRITE (*,"(' These are inconsistent because they require different data files.')") WRITE (*,"(' If your data files are present-day, set start_time to 0.')") WRITE (*,"(' If your data files are paleo-data, then set max_iter to 1.')") WRITE (*,"(' This run cannot continue.')") WRITE (*,"(' ----------------------------------------------------------')") WRITE (21,"('----------------------------------------------------------')") WRITE (21,"(' Error: Inconsistent parameters.')") WRITE (21,"('You have requested a starting age > 0. and more than 1 iteration.')") WRITE (21,"('These are inconsistent because they require different data files.')") WRITE (21,"('If your data files are present-day, set start_time to 0.')") WRITE (21,"('If your data files are paleo-data, then set max_iter to 1.')") WRITE (21,"('This run cannot continue.')") WRITE (21,"('----------------------------------------------------------')") CALL Pause() STOP ELSE IF (this_run_ends_Ma < ultimate_age_Ma) THEN WRITE (*,"(' ----------------------------------------------------------')") WRITE (*, "(' Error: Inconsistent parameters.')") WRITE (*,"(' You have requested an ending age for this run that is less')") WRITE (*,"(' than the ultimage age for ending each iteration.')") WRITE (*,"(' Then you also requested more than one iteration in this run.')") WRITE (*,"(' But, you cannot perform multiple iterations in one run')") WRITE (*,"(' unless each starts at 0.0 and ends at ultimate_age_Ma.')") WRITE (*,"(' Either change max_iter to 1, or adjust age limit values.')") WRITE (*,"(' This run cannot continue.')") WRITE (*,"(' ----------------------------------------------------------')") WRITE (21,"('----------------------------------------------------------')") WRITE (21,"('Error: Inconsistent parameters.')") WRITE (21,"('You have requested an ending age for this run that is less')") WRITE (21,"(' than the ultimage age for ending each iteration.')") WRITE (21,"('Then you also requested more than one iteration in this run.')") WRITE (21,"('But, you cannot perform multiple iterations in one run')") WRITE (21,"(' unless each starts at 0.0 and ends at ultimate_age_Ma.')") WRITE (21,"('Either change max_iter to 1, or adjust age limit values.')") WRITE (21,"('This run cannot continue.')") WRITE (21,"('----------------------------------------------------------')") CALL Pause() STOP END IF ! any user-supplied parameters are in conflict END IF ! max_iter > 1; checking for parameter conflicts? WRITE (21,"(I10,' number of iterations of whole history in this run')") max_iter ELSE ! neotec IF (max_iter > 1) THEN WRITE (*, "(' start_time == end_time, so # of iterations set to 1')") WRITE (21,"('----------------------------------------------------------')") WRITE (21,"('Error: This run consumes no time (start_time == end_time),')") WRITE (21,"('and only computes velocities, so iteration is useless.')") WRITE (21,"('Your requested max_iter of ',I3,' has been set to 1.')") max_iter WRITE (21,"('If you want more precision, increase n_refine in line #4.')") WRITE (21,"('----------------------------------------------------------')") max_iter = 1 END IF WRITE (21,"(I10,' number of iterations in this run [NOT USED in neotectonic mode]')") max_iter END IF ! paleotec, or neotec? ALLOCATE ( adjustments(max_iter) ) ! total number of iterations planned READ (1, *) last_iteration IF (paleotec) THEN IF (last_iteration <= 0) CALL Prevent ('nonpositive iteration target', line, "Parameters.rst") WRITE (21, "(I10,' number of iterations planned (total of all runs)')") last_iteration ELSE ! neotec last_iteration = 1 WRITE (21, "(I10,' total number of iterations planned [NOT USED in neotectonic mode]')") last_iteration END IF ! paleotec, or neotec? ! length of fault trace (in m) whose offset(s) get(s) unit weight (L_0): READ (1, *) L_0 ; line = line + 1 IF (L_0 <= 0.0D0) CALL Prevent ('nonpositive L_0', line, "Parameters.rst") WRITE (21,"(1P,E10.2,' length of fault trace whose offset(s) get(s) unit weight (L_0), m')") L_0 ! area of continuum (in m**2) whose stiffness and stress-direction get unit weight (A_0): READ (1, *) A_0 ; line = line + 1 IF (A_0 <= 0.0D0) CALL Prevent ('nonpositive A_0', line, "Parameters.rst") WRITE (21,"(1P,E10.2,' area of continuum whose stiffness & stress-direction get unit weight (A_0), m**2')") A_0 ! default strain-rate uncertainty for rigid blocks (mu_): READ (1, *) mu_ ; line = line + 1 IF (mu_ <= 0.) CALL Prevent ('nonpositive mu_', line, "Parameters.rst") IF (mu_ < SQRT(1.10D0 * TINY(mu_))) CALL Prevent ('mu_**2 will underflow!', line, "Parameters.rst") IF (mu_ > 1.D-10) CALL Prevent ('unreasonably large mu_', line, "Parameters.rst") WRITE (21,"(1P,E10.2,' default standard deviation of nominally zero strainrates (mu_), /s')") mu_ !Note that this default mu_ only applies to elements which have NO mu_ value(s) in the .FEG file(s). ! small strain-rate increment (xi_) for imposing stress-direction polarity ("boxing"): READ (1, *) xi_ ; line = line + 1 IF (xi_ <= 0.) CALL Prevent ('nonpositive xi_', line, "Parameters.rst") WRITE (21,"(1P,E10.2,' small strain-rate increment (xi_), /s')") xi_ ! set of scale rate uncertainties to start off the iteration READ (1, *) mu_scale ; line = line + 1 IF (paleotec) THEN IF (mu_scale <= 0.0D0) CALL Prevent ('nonpositive mu_scale', line, "Parameters.rst") WRITE (21, "(1P,E10.2,' scale strain-rate of rigid blocks, /s (for early iterations only)')") mu_scale ELSE ! neotec WRITE (21, "(1P,E10.2,' scale strain-rate of rigid blocks, /s [NOT USED in neotectonic mode]')") mu_scale END IF ! paleotec, or neotec? READ (1, *) f_scale ; line = line + 1 IF (paleotec) THEN IF (f_scale <= 0.0D0) CALL Prevent ('nonpositive f_scale', line, "Parameters.rst") WRITE (21, "(1P,E10.2,' scale slip-rate sigma of faults, m/s (for early iterations only)')") f_scale ELSE ! neotec WRITE (21, "(1P,E10.2,' scale slip-rate sigma of faults, m/s [NOT USED in neotectonic mode]')") f_scale END IF ! paleotec, or neotec? READ (1, *) c_scale ; line = line + 1 IF (paleotec) THEN IF (c_scale <= 0.0D0) CALL Prevent ('nonpositive c_scale', line, "Parameters.rst") WRITE (21, "(1P,E10.2,' scale rate uncertainty of BCSs, m/s (for early iterations only)')") c_scale ELSE ! neotec WRITE (21, "(1P,E10.2,' scale rate uncertainty of BCSs, m/s [NOT USED in neotectonic mode]')") c_scale END IF ! paleotec, or neotec? READ (1, *) p_drift_scale ; line = line + 1 IF (paleotec) THEN IF (p_drift_scale <= 0.0D0) CALL Prevent ('nonpositive p_drift_scale', line, "Parameters.rst") WRITE (21, "(1P,E10.2,' scale N-S drift uncertainty of PM, m/s (for early iterations only)')") p_drift_scale ELSE ! neotec WRITE (21, "(1P,E10.2,' scale N-S drift uncertainty of PM, m/s [NOT USED in neotectonic mode]')") p_drift_scale END IF ! paleotec, or neotec? READ (1, *) p_spin_scale ; line = line + 1 IF (paleotec) THEN IF (p_spin_scale <= 0.0D0) CALL Prevent ('nonpositive p_spin_scale', line, "Parameters.rst") WRITE (21, "(1P,E10.2,' scale spin uncertainty of PM, radians/s (for early iterations only)')") p_spin_scale ELSE ! neotec WRITE (21, "(1P,E10.2,' scale spin uncertainty of PM, radians/s [NOT USED in neotectonic mode]')") p_spin_scale END IF ! paleotec, or neotec? ! radius of planet READ (1, *) t ; line = line + 1 IF (t <= 0.) CALL Prevent ('nonpositive R', line, "Parameters.rst") WRITE (21,"(F10.2,' radius of the planet (R), in km')") t R = t * m_per_km half_R2 = (R**2) / 2.0D0 ! do new active faults count as sigma_1h data? READ (1, *) faults_give_sigma_1h ; line = line + 1 WRITE (21,"(L10,' that active faults give stress directions')") & faults_give_sigma_1h ! names of additional input files (or, "none ") !Faults: CALL Get_another_parameter_line(unit = 1, string = string); line = line + 1 f_rst = Get_filename (string) WRITE (21,"(' ',A)") TRIM(f_rst) WRITE (21,"(11X,'preceding line = filename of fault offsets')") IF (f_rst(1:5) == 'none ') THEN READ (1,*) ; line = line + 1 ! read and ignore f_dig = 'skipped' ELSE CALL Get_another_parameter_line(unit = 1, string = string); line = line + 1 f_dig = Get_filename (string) END IF WRITE (21,"(' ',A)") TRIM(f_dig) WRITE (21,"(11X,'preceding line = filename of digitised fault traces')") !Cross-sections: CALL Get_another_parameter_line(unit = 1, string = string); line = line + 1 c_rst = Get_filename (string) WRITE (21,"(' ',A)") TRIM(c_rst) WRITE (21,"(11X,'preceding line = filename of balanced cross-sections')") !Paleomag: CALL Get_another_parameter_line(unit = 1, string = string); line = line + 1 p_rst = Get_filename (string) WRITE (21,"(' ',A)") TRIM(p_rst) WRITE (21,"(11X,'preceding line = filename of paleomagnetic data')") !Stress-directions: CALL Get_another_parameter_line(unit = 1, string = string); line = line + 1 s_rst = Get_filename (string) WRITE (21,"(' ',A)") TRIM(s_rst) WRITE (21,"(11X,'preceding line = filename of principal stress directions')") !Basemap (or geologic map) in .DIG format: CALL Get_another_parameter_line(unit = 1, string = string); line = line + 1 y_dig = Get_filename (string) IF (neotec) y_dig = 'skipped' WRITE (21,"(' ',A)") TRIM(y_dig) WRITE (21,"(11X,'preceding line = filename of basemap/geologic-map .DIG')") !Read in one-or-more .FEG files to be used (sequentially) in this run: !Set up lists: !CALL More_mem ('loading_age_in_Ma', 1.0D0 * max_fegs * 80) ! {insignificant, and would disrupt orderly echo of parameter file} ALLOCATE ( loading_age_in_Ma (max_fegs) ) loading_age_in_Ma = 0.0 ! whole list (for tidiness) !CALL More_mem ('gridname_feg', 1.0D0 * max_fegs * 80) ! {insignificant, and would disrupt orderly echo of parameter file} ALLOCATE ( gridname_feg (max_fegs) ) gridname_feg = ' ' !CALL More_mem ('gridname_bcs', 1.0D0 * max_fegs * 80) ! {insignificant, and would disrupt orderly echo of parameter file} ALLOCATE ( gridname_bcs (max_fegs) ) gridname_bcs = ' ' !Get first FEG filename and loading-age in Ma... num_fegs = 1 ! (This first one is NEVER optional!) CALL Get_ageMa_and_filename(unit = 1, t_Ma = t_Ma, t_filename = t_filename, hit_end = hit_pFile_end); line = line + 1 IF (hit_pFile_end) THEN WRITE (*, "(' ERROR: Parameter file ended before providing necessary .FEG file-name.')") WRITE (21, "('ERROR: Parameter file ended before providing necessary .FEG file-name.')") CALL Pause() STOP END IF loading_age_in_Ma(1) = t_Ma gridname_feg(1) = TRIM(t_filename) WRITE (21,"(' ', F6.1, ' Ma: ', A)") t_Ma, TRIM(t_filename) WRITE (21,"(11X,'preceding line = loading-age and filename of finite element grid # 1')") IF ((t_Ma * s_per_Ma) /= start_time) THEN WRITE (*, "(' ERROR: First grid loading-time must equal this run''s start-time of ', F8.3, ' Ma.')") (start_time / s_per_Ma) WRITE (21, "('ERROR: First grid loading-time must equal this run''s start-time of ', F8.3, ' Ma.')") (start_time / s_per_Ma) CALL Pause() STOP END IF CALL Test_file (name = t_filename, unit = 2) !Get as many additional FEG filenames as user provided... more_FEGs: DO i = 2, max_fegs CALL Get_ageMa_and_filename(unit = 1, t_Ma = t_Ma, t_filename = t_filename, hit_end = hit_pFile_end); line = line + 1 j1 = INDEX (t_filename, '.FEG ') j2 = INDEX (t_filename, '.feg ') IF ((j1 > 0) .OR. (j2 > 0)) THEN IF (t_Ma <= loading_age_in_Ma(i - 1)) THEN WRITE (*, "(' ERROR: Loading-ages of FEG files must increase monotonically.')") WRITE (21, "('ERROR: Loading-ages of FEG files must increase monotonically.')") CALL Pause() STOP END IF loading_age_in_Ma(i) = t_Ma gridname_feg(i) = TRIM(t_filename) num_fegs = num_fegs + 1 ELSE ! Presumably, we have accidentally read the first of the matching BCS lines, by accident... BACKSPACE(1) ! To prepare for next block of code EXIT more_FEGs END IF END DO more_FEGs DO i = 2, num_fegs WRITE (21,"(' ', F6.1, ' Ma: ', A)") loading_age_in_Ma(i), TRIM(gridname_feg(i)) WRITE (21,"(11X,'preceding line = loading-age and filename of finite element grid # ', I3)") i CALL Test_file (name = gridname_feg(i), unit = 2) END DO all_BCSs: DO i = 1, num_fegs CALL Get_ageMa_and_filename(unit = 1, t_Ma = t_Ma, t_filename = t_filename, hit_end = hit_pFile_end); line = line + 1 j1 = INDEX (t_filename, '.BCS ') j2 = INDEX (t_filename, '.bcs ') IF ((j1 > 0) .OR. (j2 > 0)) THEN IF (t_Ma /= loading_age_in_Ma(i)) THEN WRITE (*, "(' ERROR: Loading-ages of BCS files must match those of FEG files.')") WRITE (21, "('ERROR: Loading-ages of BCS files must match those of FEG files.')") CALL Pause() STOP END IF gridname_bcs(i) = TRIM(t_filename) ELSE WRITE (*, "(' ERROR: Required parameter-file line with BCS file #', I3, ' was not found.')") i WRITE (21, "('ERROR: Required parameter-file line with BCS file #', I3, ' was not found.')") i CALL Pause() STOP END IF END DO all_BCSs DO i = 1, num_fegs ! (but, referring to BCS list this time) WRITE (21,"(' ', F6.1, ' Ma: ', A)") loading_age_in_Ma(i), TRIM(gridname_bcs(i)) WRITE (21,"(11X,'preceding line = loading-age and filename of boundary-conditions file # ', I3)") i CALL Test_file (name = gridname_bcs(i), unit = 2) END DO CLOSE (UNIT = 1) ! close PARAMETE[RS].RST WRITE (*, "(' Successfully read all run parameters')") WRITE (21, "('End Parameter Section')") WRITE (21, "('-----------------------------------------------------------')") ! Decide number of timesteps in advance, to preallocate rate arrays IF (paleotec) THEN num_timesteps = NINT(end_time / Deltat_) ELSE ! neotec num_timesteps = 1 ! (avoiding possible /0.0) END IF CALL More_mem ('rate_err', 1.0D0 * 3 * (1 + num_timesteps) * max_iter * bytes_per_real) ALLOCATE ( rate_err(0:2, 0:num_timesteps, 1:max_iter) ) rate_err = 0.0D0 ! Create a grid-loading plan, and check it for any problems: IF (paleotec) THEN !num_timesteps = NINT(end_time / Deltat_) is already computed (just above), and describes one COMPLETE iteration (even if we start part-way through). !Note that when the time-integration loop is running, its index n_ is relative to one COMPLETE iteration (even though we might start with n_ > 1). ALLOCATE ( first_timestep_for_this_grid(num_fegs) ) DO i = 1, num_fegs first_timestep_for_this_grid(i) = 1 + NINT((loading_age_in_Ma(i) * s_per_Ma) / Deltat_) ! See above; n_ = 1 means 1st timestep in a COMPLETE iteration, starting at present. END DO grid_to_load_size = MAX(num_timesteps, NINT(1.0D0 + (loading_age_in_Ma(num_fegs) * s_per_Ma / Deltat_))) ALLOCATE ( grid_to_load_this_timestep(grid_to_load_size) ) ! where independent variable is n_ = 1, num_timesteps, and dependent is i = 1, num_fegs grid_to_load_this_timestep = 0 ! default value means "No plans (yet) to load any grid in this timestep." DO i = 1, num_fegs n_ = first_timestep_for_this_grid(i) IF (n_ <= num_timesteps) THEN ! loading will occur during THIS PARTICULAR run... IF (grid_to_load_this_timestep(n_) == 0) THEN ! no previous plans for loading anything... grid_to_load_this_timestep(n_) = i ELSE WRITE (*, "(' ERROR: Bad loading plan:' / ' In timestep ',I6,' cannot load both FEG#', I3, ' and FEG#', I3)") n_, grid_to_load_this_timestep(n_), i WRITE (21, "('ERROR: Bad loading plan:' / 'In timestep ',I6,' cannot load both FEG#', I3, ' and FEG#', I3)") n_, grid_to_load_this_timestep(n_), i CALL Pause() STOP END IF END IF END DO ELSE !num_timesteps = 1, already num_fegs = 1 ! (probably already true, based on user input?) ALLOCATE ( first_timestep_for_this_grid(1) ) first_timestep_for_this_grid(1) = 1 ALLOCATE ( grid_to_load_this_timestep(1) ) grid_to_load_this_timestep(1) = 1 END IF ! Iterate the whole history!!! !=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* outer_loop: DO iteration = 1, max_iter ! Notes: * total_iterations (computed below) will add in past_iterations ! * max_iter = 1 was already assigned for neotectonic mode. IF (paleotec) THEN WRITE (*, "(' Beginning iteration ',I3,' out of ',I3,' (this run), ',I3,' (total)')") iteration, max_iter, last_iteration WRITE (21,"('Beginning iteration ',I3,' out of ',I3,' (this run), ',I3,' (total)')") iteration, max_iter, last_iteration END IF IF (paleotec) THEN total_iterations = iteration + past_iterations ! At least 1, and at least 1 more than past_iterations ELSE ! neotec total_iterations = MAX(1, past_iterations) END IF IF (paleotec) THEN IF (last_iteration > 1) THEN exponent = MIN(1.000D0, (DBLE(total_iterations - 1) / DBLE(last_iteration - 1)) ) ELSE exponent = 1.000D0 END IF WRITE (*, "(' Using exponent = ',F6.4)") exponent WRITE (21, "('Using exponent = ',F6.4)") exponent ELSE ! neotec exponent = 1.000D0 ! So, all those "scale" rate uncertainties in the Parameter.rst file will have NO effects. END IF changed_horses = .FALSE. ! unless set T below when a second .feg is used continuum_N_numerator_sums(0:2) = 0.0D0 ! Prepare for summing over all elements AND over all timesteps in this iteration continuum_N_denominator_sum = 0.0D0 ! (or, at least as many timesteps as are included in this run) IF (iteration == 1) THEN ! Read input datasets ! with immediate conversion of quantities to SI units, except ! geographic positions to Cartesian unit vectors in a unit sphere. WRITE (*, "(' ',4X,'Begin reading data input files')") WRITE (21,"(4X,'Begin reading data input files')") ! read f.rst IF (f_rst(1:5) == 'none ') THEN f_rst_count = 0 f_highest = 0 ELSE WRITE (*, "(' ',8X,'Reading fault offset data from ',A)") TRIM(f_rst) WRITE (21,"(8X,'Reading fault offset data from ',A)") TRIM(f_rst) OPEN (UNIT = 2, FILE = f_rst, STATUS = "OLD", ACTION = "READ", IOSTAT = ios) IF (ios /= 0) CALL File_not_found(f_rst) READ (2, "(A)") f_rst_format READ (2, "(A)") f_rst_titles ! Skim file and count number of data lines, highest fault index f_rst_count = 0 f_highest = 0 get_offset_lines: DO READ (2, "(A)", IOSTAT = read_status) c134 IF (read_status == 0) THEN ! read was successful IF ((c134(1:1) /= '+') .AND. & (c134(1:1) /= '*') .AND. & (c134(1:1) /= '&') .AND. & (c134(1:1) /= '$')) THEN f_rst_count = f_rst_count + 1 READ (c134, "(1X,I4,1X)", IOSTAT = ios) i IF (ios /= 0) THEN WRITE (*, "(' ERROR: Could not read trace index # from line: ')") WRITE (*, "(' ', A)") TRIM(c134) WRITE (*, "(' which follows right after F', I4)") f_highest WRITE (*, "(' Please eliminate any blank lines from the end of the f_.rst file!')") WRITE (21, "('ERROR: Could not read trace index # from line: ')") WRITE (21, "(A)") TRIM(c134) WRITE (21, "('which follows right after F', I4)") f_highest WRITE (21, "('Please eliminate any blank lines from the end of the f_.rst file!')") CALL Pause() STOP END IF f_highest = MAX (f_highest, i) END IF ELSE; EXIT get_offset_lines; END IF END DO get_offset_lines CLOSE (UNIT = 2) ! (will be re-read) ! allocate arrays CALL More_mem ('f_active', 1.0D0 * num_timesteps * f_rst_count + 1) ALLOCATE ( f_active(num_timesteps, f_rst_count) ) CALL More_mem ('trace_active', 1.0D0 * num_timesteps * f_highest * 1) ALLOCATE ( trace_active(num_timesteps, f_highest) ) CALL More_mem ('trace_formed_Ma', 1.0D0 * f_highest * bytes_per_real) ALLOCATE ( trace_formed_Ma(f_highest) ) trace_formed_Ma = 0.0D0 ! Ma; to be augmented with MAX() as offset data are read CALL More_mem ('major_fault', 1.0D0 * f_highest) ALLOCATE ( major_fault(f_highest) ) major_fault = .FALSE. ! unless set .TRUE. below, if fault has certain attributes in f_dig CALL More_mem ('which_trace', 1.0D0 * f_rst_count * bytes_per_int) ALLOCATE ( which_trace (f_rst_count) ) CALL More_mem ('sense', 1.0D0 * f_rst_count * 1) ALLOCATE ( sense (f_rst_count) ) CALL More_mem ('fault_name', 1.0D0 * f_rst_count * 50) ALLOCATE ( fault_name (f_rst_count) ) CALL More_mem ('f_dig_degrees', 1.0D0 * f_highest * bytes_per_real) ALLOCATE ( f_dip_degrees (f_highest) ) f_dip_degrees = 0.0D0 ! To be replaced if a "dip_degrees" tag is found in the f_dig file; ! otherwise any unmodified zero values will be ignored by program logic. CALL More_mem ('plate_boundary', 1.0D0 * f_highest) ALLOCATE ( plate_boundary (f_highest) ) plate_boundary = .FALSE. ! default for all traces (including missing ones); ! some values will be set .TRUE. later, if fault has certain attributes in f_dig CALL More_mem ('offset', 1.0D0 * f_rst_count * bytes_per_real) ALLOCATE ( offset (f_rst_count) ) CALL More_mem ('offset_sigma_', 1.0D0 * f_rst_count * bytes_per_real) ALLOCATE ( offset_sigma_ (f_rst_count) ) CALL More_mem ('f_t_max', 1.0D0 * f_rst_count * bytes_per_real) ALLOCATE ( f_t_max (f_rst_count) ) CALL More_mem ('f_t_min', 1.0D0 * f_rst_count * bytes_per_real) ALLOCATE ( f_t_min (f_rst_count) ) CALL More_mem ('f_goal', 1.0D0 * f_rst_count * num_timesteps * bytes_per_real) ALLOCATE ( f_goal(num_timesteps, f_rst_count) ) CALL More_mem ('f_rate', 1.0D0 * f_rst_count * num_timesteps * bytes_per_real) ALLOCATE ( f_rate(num_timesteps, f_rst_count) ) f_rate = 0.0 CALL More_mem ('f_goal_sigma_', 1.0D0 * f_rst_count * bytes_per_real) ALLOCATE ( f_goal_sigma_(f_rst_count) ) CALL More_mem ('f_rst_code', 1.0D0 * f_rst_count * 1) ALLOCATE ( f_rst_code(f_rst_count) ) CALL More_mem ('f_divide', 1.0D0 * 2 * f_rst_count * bytes_per_real) ALLOCATE ( f_divide(2, f_rst_count) ) CALL More_mem ('f_err', 1.0D0 * 3 * (1 + max_iter) * bytes_per_real) ALLOCATE ( f_err(0:2, 0:max_iter) ) IF (faults_give_sigma_1h) THEN CALL More_mem ('f_new', 1.0D0 * f_rst_count) ALLOCATE ( f_new (f_rst_count) ) f_new = .TRUE. ! just initializing END IF IF (neotec) THEN ! also allocate arrays to hold columns 7~8 (neotectonic offset rates, and sigmas; JUST for scoring of model quality): CALL More_mem ('neotec_offset_rate', 1.0D0 * f_rst_count * bytes_per_real) ALLOCATE ( neotec_offset_rate (f_rst_count) ) neotec_offset_rate = 0.0D0 ! because some (all?) cells will probably be empty CALL More_mem ('neotec_offset_rate_sigma_', 1.0D0 * f_rst_count * bytes_per_real) ALLOCATE ( neotec_offset_rate_sigma_ (f_rst_count) ) neotec_offset_rate_sigma_ = 0.0D0 ! because some (all?) cells will probably be empty END IF ! neotec; allocating arrays for columns 7~8 ! fill arrays OPEN (UNIT = 2, FILE = f_rst, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) ; line = 0 IF (ios /= 0) CALL File_not_found(f_rst) READ (2, *) ; line = 1 ! NOTE that f_rst_format was already memorized. READ (2, *) ; line = 2 ! NOTE that f_rst_titles was already memorized. read_f_rst: DO i = 1, f_rst_count IF (neotec) THEN ! try to read 8 columns, if possible READ (2, f_rst_format, IOSTAT = ios) c6, c50, t1, t2, t3, t4, t5, t6 ; line = line + 1 IF (ios /= 0) THEN ! ATTEMPT to get columns 7~8 apparently failed. (Perhaps they were empty?) BACKSPACE (2) line = line - 1 READ (2, f_rst_format) c6, c50, t1, t2, t3, t4 ; line = line + 1 t5 = 0.0D0; t6 = 0.0D0 END IF ! attempt to read columns 7~8 failed ELSE ! paleotec; only TRY to read 6 columns READ (2, f_rst_format) c6, c50, t1, t2, t3, t4 ; line = line + 1 END IF READ (c6, "(1X,I4,1X)") i1 ! <=== trace index; e.g., "2345" in "F2345RN" IF (i1 > f_highest) THEN WRITE (*, "(' Illegally high trace index: ',I6)") i1 WRITE (21,"('Illegally high trace index: ',I6)") i1 CALL Pause() STOP END IF trace_formed_Ma(i1) = MAX(trace_formed_Ma(i1), t3) ! using all start-times of all chapters and all offset types which_trace(i) = i1 c = c6(6:6) IF (c == 't') c = 'T' IF (c == 'p') c = 'P' IF (c == 'n') c = 'N' IF (c == 'd') c = 'D' IF (c == 'r') c = 'R' IF (c == 'l') c = 'L' IF (.NOT.((c == 'T') .OR. (c == 'N') .OR. (c == 'R') .OR. (c == 'L') & .OR. (c == 'D') .OR. (c == 'P'))) THEN WRITE (*, "(' Illegal slip sense: ',A1,' in line ',I6,' of fault data file f_rst.')") c, line WRITE (21,"('Illegal slip sense: ',A1,' in line ',I6,' of fault data file f_rst.')") c, line CALL Pause() STOP END IF sense(i) = c fault_name(i) = c50 IF (t1 < 0.0D0) CALL Prevent ('negative offset', line, f_rst) offset(i) = t1 * m_per_km IF (t2 <= 0.0D0) CALL Prevent ('nonpositive sigma_', line, f_rst) offset_sigma_(i) = t2 * m_per_km IF (t3 <= 0.0D0) CALL Prevent ('nonpositive maximum age', line, f_rst) f_t_max(i) = t3 * s_per_Ma IF (t4 < 0.0D0) CALL Prevent ('negative minimum age', line, f_rst) f_t_min(i) = t4 * s_per_Ma IF (t3 <= t4) CALL Prevent ('null age span', line, f_rst) IF (neotec) THEN ! save the values from columns 7~8 neotec_offset_rate(i) = t5 * 0.001D0 / s_per_year neotec_offset_rate_sigma_(i) = t6 * 0.001D0 / s_per_year END IF ! neotec CALL Set_goal_A (index = i, total = offset, & & tmin = f_t_min, tmax = f_t_max, & & checkPD = .TRUE., & ! inputs & goal = f_goal, & ! output & active = f_active)! output f_goal_sigma_(i) = offset_sigma_(i) / (f_t_max(i) - f_t_min(i)) CALL Set_goal_B (index = i, & & checkPD = .TRUE., active = f_active, & & unit = 2, signal = '*', eof = eof, & & conversion = (m_per_km / s_per_Ma), & ! inputs & line = line, & ! modify & rate = f_rate, & ! modify & goal = f_goal) ! modify IF (eof) EXIT read_f_rst END DO read_f_rst WRITE (*, "(' ',8X,I4,' fault-offset data were read')") f_rst_count WRITE (21,"(8X,I4,' fault-offset data were read')") f_rst_count CLOSE (UNIT = 2) ! close f_rst !scan for overlapping time windows concerning same offset type; also set f_new? IF (f_rst_count > 1) THEN DO i = 1, f_rst_count - 1 DO j = i + 1, f_rst_count IF ((which_trace(i) == which_trace(j)).AND.(sense(i) == sense(j))) THEN overlap = MIN (f_t_max(i) - f_t_min(i), & & f_t_max(j) - f_t_min(j), & & f_t_max(i) - f_t_min(j), & & f_t_max(j) - f_t_min(i)) IF (overlap > 0.) THEN WRITE (c4, "(I4)") which_trace(i) !BUG: Formatted internal WRITE causes memory leak ! under Microsoft Fortran Powerstation 4.0, ! but it will be unimportant in this case. DO k = 1, 3 IF (c4(k:k) == ' ') c4(k:k) = '0' END DO c6 = 'F' // c4 // sense(i) WRITE (*, "(' Error: Two or more data concerning trace/offset ',A/& & ' have overlapping time windows.'/& & ' Edit these data to make them contiguous.')") c6 WRITE (21,"('Error: Two or more data concerning trace/offset ',A/& & ' have overlapping time windows.'/& & ' Edit these data to make them contiguous.')") c6 CALL Pause() STOP ELSE ! no overlap; set f_new? IF (faults_give_sigma_1h) THEN ! set f_new of later offset FALSE IF (f_t_max(i) < f_t_max(j)) THEN f_new(i) = .FALSE. ELSE f_new(j) = .FALSE. END IF END IF END IF ! overlap / no overlap END IF ! >= 2 data on same trace END DO ! j = i+1, f_rst_count END DO ! i = 1, f_rst_count-1 END IF ! scan for overlapping times ! scan for Demotions (P and N already filled in) DO i = 1, f_rst_count ! may already be P strike_slip_i = ((sense(i) == 'L').OR.(sense(i) == 'R')) DO j = 1, f_rst_count ! may need to be D strike_slip_j = ((sense(j) == 'L').OR.(sense(j) == 'R')) IF (i /= j) THEN ! different datum lines IF (which_trace(i) == which_trace(j)) THEN !same trace IF (strike_slip_i .EQV. strike_slip_j) THEN ! same sort of offset-sense (strike-slip vs. dip-slip) IF (f_rst_code(i) == 'P') THEN ! one was promoted IF (f_active(1, j)) THEN ! conflict f_rst_code(j) = 'D' ! Demote. f_active(1, j) = .FALSE. f_goal(1, j) = 0.0D0 END IF END IF END IF END IF END IF END DO END DO ! scan for Demotions WRITE (21,"(8X,'- - - - - - - - - - - - - - - - - - - - ')") END IF ! IF (f_rst /= 'none') ! summarize information in f_active (per offset datum) to decide trace_active? (per trace): trace_active = .FALSE. ! whole matrix (just initializing...) DO i = 1, num_timesteps DO j = 1, f_rst_count IF (f_active(i, j)) THEN trace_active(i, which_trace(j)) = .TRUE. !N.B. This little logical array will prove useful in Move_data (translation method 0/1? or 2?; ! also decisions about which strike-slip fault traces should be smoothed), ! and also in negating certain elements of current_element_is_unfaulted. !N.B. See also array trace_formed_Ma which contains only the oldest known initiation age for each trace. END IF END DO END DO ! read f.dig IF ((f_dig(1:5) == 'none ') .OR. (f_dig(1:8) == 'skipped ')) THEN f_dig_count = 0 f_highest = 0 ELSE ! there is an f.dig file WRITE (*, "(' ',8X,'Reading fault traces from ',A)") TRIM(f_dig) WRITE (21,"(8X,'Reading fault traces from ',A)") TRIM(f_dig) OPEN (UNIT = 3, FILE = f_dig, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios); line = 0 IF (ios /= 0) CALL File_not_found(f_dig) ! Skim file and count number of data points f_dig_count = 0 loop_thru: DO READ (3, "(A)", IOSTAT = read_status) c50; line = line + 1 IF (read_status == 0) THEN ! read was successful IF ((c50(1:2) == ' +') .OR. (c50(1:2) == ' -')) THEN f_dig_count = f_dig_count + 1 ELSE IF ((c50(1:1) == 'F') .OR. (c50(1:1) == 'f')) THEN READ (c50,"(1X,I4)", IOSTAT = read_status) i IF (read_status == 0) THEN IF (i < 0) CALL Prevent ('negative fault index number', line, f_dig) f_highest = MAX (f_highest, i) ELSE ! unreadable fault number CALL Prevent ('unreadable fault index number', line, f_dig) END IF END IF ELSE; EXIT loop_thru; END IF END DO loop_thru CLOSE (UNIT = 3) ! (will be re-read) ! allocate arrays CALL More_mem ('trace', 1.0D0 * f_dig_count * 3 * bytes_per_real) ALLOCATE ( trace (3, f_dig_count) ) trace = 0.0D0 ! whole array ! CALL More_mem ('trace_premove', 1.0D0 * f_dig_count * 3 * bytes_per_real) ALLOCATE ( trace_premove (3, f_dig_count) ) ! extra "memory" copy (may be used in Move_data) CALL More_mem ('trace_0', 1.0D0 * f_dig_count * 3 * bytes_per_real) ALLOCATE ( trace_0 (3, f_dig_count) ) trace_0 = 0.0D0 ! whole array ! CALL More_mem ('trace_is', 1.0D0 * f_dig_count * bytes_per_is) ALLOCATE ( trace_is(0:f_dig_count) ) ! using 0: to avoid an obscure subscript-out-of-range error trace_is(0)%element = 0 ! outside of the FEG area (if anyone asks) trace_is(1:f_dig_count)%element = 1 ! because '0' has special meaning to Internal CALL More_mem ('translation_method', 1.0D0 * 2 * f_dig_count) ALLOCATE ( translation_method(f_dig_count) ) translation_method = 1 ! most common method for moving fault traces; ! some of these indices may be reset to 0 or 2 or 3 later, ! based on per-fault data in the f_.dig file: ! The "symmetric_spreading_system" attribute may ! imply translation_method() == 2 for selected points, for example. CALL More_mem ('plateward_dAzimuth', 1.0D0 * 8 * f_dig_count) ALLOCATE ( plateward_dAzimuth(f_dig_count) ) plateward_dAzimuth = 0.0D0 ! but values for faults with the ! "symmetric_spreading_system" attribute will have different values set below. CALL More_mem ('trace_loc', 1.0D0 * 4 * f_highest * bytes_per_int) ALLOCATE ( trace_loc (4, 0:f_highest) ) trace_loc = 0 ! whole array! CALL More_mem ('trace_type', 1.0D0 * f_highest * 1) ALLOCATE ( trace_type(f_highest) ) trace_type = ' ' CALL More_mem ('f_2_in', 1.0D0 * f_highest * 1) ALLOCATE ( f_2_in(f_highest) ) f_2_in = .TRUE. ! unless negated later CALL More_mem ('f_relevant', 1.0D0 * f_highest * 1) ALLOCATE ( f_relevant(f_highest) ) f_relevant = .TRUE. ! unless negated later, in Def_seg_v2? CALL More_mem ('f_retired', 1.0D0 * f_highest * 1) ALLOCATE ( f_retired(f_highest) ) f_retired = .FALSE. CALL More_mem ('f_dig_faultName_lines', 1.0D0 * 80 * f_highest) ALLOCATE ( f_dig_faultName_lines(f_highest) ) f_dig_faultName_lines = ' ' ! whole array set blank/empty. CALL More_mem ('f_dig_faultData_lines', 1.0D0 * 5 * 80 * f_highest) ALLOCATE ( f_dig_faultData_lines(5, f_highest) ) ! I hope that 5 lines will be enough... f_dig_faultData_lines = ' ' ! whole array set blank/empty. CALL More_mem('banished_DIG_point', 1.0D0 * f_dig_count) ALLOCATE ( banished_DIG_point(f_dig_count) ) banished_DIG_point = .FALSE. ! initially. Later, may become .TRUE.. (If so, it never reverts.) ! fill arrays on this pass: OPEN (UNIT = 3, FILE = f_dig, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) IF (ios /= 0) CALL File_not_found(f_dig) line = 0 ! begin cumulative count of lines read (for debugging messages) i = 0 ! begin cumulative count of digitized points in trace-storage in_trace = .FALSE. ! so we will need to make an entry in trace_loc(1, ...) any_spreading = .FALSE. ! but this will be changed if any fault has the ! "symmetric_spreading_system" attribute. any_other_spreading = .FALSE. ! but this will be changed if any fault has the ! "other_spreading_system" attribute. read_dig: DO READ (3, "(A)", IOSTAT = read_status) c80; line = line + 1 IF (read_status /= 0) EXIT read_dig ! READ failed to get another line; exit loop IMMEDIATELY IF ((c80(1:1) == 'F') .OR. (c80(1:1) == 'f')) THEN got_index = .TRUE. got_data_line = .FALSE. got_point = .FALSE. got_terminator = .FALSE. data_lines_count = 0 ! just initializing for this new trace; may go up to 5 READ (c80, "(1X,I4,A)") j, c ! new trace number and (primary) sense. (Note: Success of this READ was pre-tested above.) f_dig_faultName_lines(j) = c80 ! memorize header IF (c == 't') c = 'T' IF (c == 'p') c = 'P' IF (c == 'n') c = 'N' IF (c == 'd') c = 'D' IF (c == 'r') c = 'R' IF (c == 'l') c = 'L' IF (.NOT.((c == 'T') .OR. (c == 'N') .OR. (c == 'R') .OR. (c == 'L') & .OR. (c == 'D') .OR. (c == 'P'))) THEN WRITE (*, "(' Illegal slip sense: ', A1, ' for digitized trace ',I4)") c, j WRITE (21,"('Illegal slip sense: ', A1, ' for digitized trace ',I4)") c, j CALL Pause() STOP END IF trace_type(j) = c memo_0 = "none" ! unless a data line with "throughgoing_master_fault" appears later memo_2 = "none" ! unless a data line with "symmetric_spreading_system" appears later memo_3 = "none" ! unless a data line with "other_spreading_system" appears later ELSE IF ((c80(1:2) == ' +') .OR. (c80(1:2) == ' -')) THEN got_index = .FALSE. got_data_line = .FALSE. got_point = .TRUE. got_terminator = .FALSE. READ (c80,*) t1, t2 ! E longitude, N latitude IF (ABS(t2) >= 90.00001D0) THEN WRITE (*, "(' Bad latitude ',F10.2,' in line ',I10,' of ',A)") & t2, line, TRIM(f_dig) WRITE (21,"('Bad latitude ',F10.2,' in line ',I10,' of ',A)") & t2, line, TRIM(f_dig) CALL Pause() STOP END IF i = i + 1 ! increment the INTEGER index for storing digitized points in one long list CALL Xyz_from_lonlat(t1, t2, tvo) trace(1:3, i) = tvo trace_0(1:3, i) = tvo ! (This extra copy will be used to start other iterations.) IF (.NOT.in_trace) THEN ! this is the first point of the trace; make an entry in trace_loc(1, ...) trace_loc(1, j) = i in_trace = .TRUE. ! for all subsequent points on this particular trace END IF trace_loc(2, j) = i ! continually overwriting; thus, "last point" address is always current ELSE ! EITHER "*** end of line segment ***" OR "dip_degrees 22" OR "throughgoing_master_fault" ! OR "symmetric_spreading_system" OR "other_spreading_system", ... [more options could be added ...] got_point = .FALSE. got_index = .FALSE. IF (c80(1:3) /= "***") THEN ! NOTE that we test for "NOT EQUALS" "***" got_data_line = .TRUE. got_terminator = .FALSE. !Memorize this data line (e.g., "dip_degrees 75", or "throughgoing_master_fault both"?) data_lines_count = data_lines_count + 1 IF (data_lines_count > 5) THEN WRITE (*, "(' ERROR: Fault trace F',I4,' has more than 5 data lines added.')") j WRITE (21, "('ERROR: Fault trace F',I4,' has more than 5 data lines added.')") j CALL Pause() STOP END IF f_dig_faultData_lines(data_lines_count, j) = c80 ! memorize !Interpret data, to see if any special action is needed: IF (INDEX(c80, "dip_degrees") > 0) THEN !prepare c4 (the numerals part of "F1234") in advance, for any error/warning message: WRITE (c4, "(I4)") j IF (c4(1:1) == ' ') c4(1:1) = '0' IF (c4(2:2) == ' ') c4(2:2) = '0' IF (c4(3:3) == ' ') c4(3:3) = '0' !locate the part of the input line that contains the dip numbers: loc_in_c_1 = INDEX(c80, "dip_degrees") loc_in_c_2 = loc_in_c_1 + 10 ! location of final 's' in "dip_degrees" loc_in_c_3 = loc_in_c_2 + 1 ! potential start of number c50 = c80(loc_in_c_3:80) ! strip out the text flag, leaving the dip number in leading position READ (c50, *, IOSTAT = internal_ios) t IF (internal_ios == 0) THEN ! t holds the number, but it may be outside the legal, recommended range(?) IF (t < 0.0D0) THEN WRITE (*, "(' CAUTION: Negative dip for fault F',A4,' is illegal; sign will be switched.')") c4 WRITE (21, "('CAUTION: Negative dip for fault F',A4,' is illegal; sign will be switched.')") c4 t = ABS(t) END IF IF (t == 0.0D0) THEN WRITE (*, "(' CAUTION: Zero dip for fault F',A4,' is illegal, and will be ignored.')") c4 WRITE (21, "('CAUTION: Zero dip for fault F',A4,' is illegal, and will be ignored.')") c4 !(Actually, it will recorded below, with 0.0 overwriting 0.0, and then will be ignored by all later code.) ELSE IF (t < 10.0D0) THEN t2 = 1.0D0 / TAN(t * radians_per_degree) WRITE (*, "(' CAUTION: Very low dip of ',F5.2,' degrees for F',A4)") t, c4 WRITE (*, "(' implies a Heave/Throw ratio of ',F10.3,',')") t2 WRITE (*, "(' greatly magnifying any throw-type (N or T) offset data!')") WRITE (*, "(' Please use the MEAN dip across the whole brittle/seismogenic crust!')") WRITE (21, "('CAUTION: Very low dip of ',F5.2,' degrees for F',A4)") t, c4 WRITE (21, "(' implies a Heave/Throw ratio of ',F10.3,',')") t2 WRITE (21, "(' greatly magnifying any throw-type (N or T) offset data!')") WRITE (21, "(' Please use the MEAN dip across the whole brittle/seismogenic crust!')") END IF !Note that high dips, even 90., are allowed, but in later code an upper limit of 80 degrees will apply in all heave/throw conversions. f_dip_degrees(j) = t ELSE ! error during READ of # WRITE (*, "(' ERROR: Number(?)'/' ',A/' following label ""dip_degrees""')") TRIM(c50) WRITE (*, "(' under fault F',A4,' in file ',A)") c4, TRIM(f_dig) WRITE (*, "(' could not be interpreted.')") WRITE (21, "('ERROR: Number(?)'/A/'following label ""dip_degrees""')") TRIM(c50) WRITE (21, "('under fault F',A4,' in file ',A)") c4, TRIM(f_dig) WRITE (21, "('could not be interpreted.')") CALL Pause() STOP END IF ! successful or unsuccessful READ of # following "dip_degrees" END IF ! line contains "dip_degrees" IF (INDEX(c80, "throughgoing_master_fault") > 0) THEN IF (INDEX(c80, "first") > 0) THEN memo_0 = "first" ELSE IF (INDEX(c80, "last") > 0) THEN memo_0 = "last" ELSE IF (INDEX(c80, "both") > 0) THEN memo_0 = "both" ELSE ! input_syntax problem! WRITE (*, "(' ERROR: Key-phrase ""throughgoing_master_fault"" was used incorrectly.')") WRITE (*, "(' In the header lines for the following fault trace:')") WRITE (*, "(' ',A)") TRIM(f_dig_faultName_lines(j)(1:79)) DO a = 1, 5 IF (LEN_TRIM(f_dig_faultData_lines(a, j)) > 0) THEN WRITE (*, "(' ',A)") TRIM(f_dig_faultData_lines(a, j)(1:79)) END IF END DO WRITE (*, "(' the keyword must be followed by one of these specifiers:')") WRITE (*, "(' first')") WRITE (*, "(' last')") WRITE (*, "(' both')") WRITE (21, "('ERROR: keyword ""throughgoing_master_fault"" was used incorrectly.')") WRITE (21, "('In the header lines for the following fault trace:')") WRITE (21, "(A)") TRIM(f_dig_faultName_lines(j)) DO a = 1, 5 IF (LEN_TRIM(f_dig_faultData_lines(a, j)) > 0) THEN WRITE (21, "(A)") TRIM(f_dig_faultData_lines(a, j)) END IF END DO WRITE (21, "('the keyword must be followed by one of these specifiers:')") WRITE (21, "(' first')") WRITE (21, "(' last')") WRITE (21, "(' both')") CALL Pause() STOP END IF ! input syntax problem END IF ! line contains "throughgoing_master_fault"? IF (INDEX(c80, "symmetric_spreading_system") > 0) THEN any_spreading = .TRUE. IF (VERIFY(c, "DdLlRr") > 0) THEN ! value of c is not one of these 6 allowed characters... WRITE (*, "(' ERROR: Key-phrase ""symmetric_spreading_system"" is only allowed with sense D, L, R.')") WRITE (*, "(' The following fault trace violates this rule:')") WRITE (*, "(' ',A)") TRIM(f_dig_faultName_lines(j)(1:79)) DO a = 1, 5 IF (LEN_TRIM(f_dig_faultData_lines(a, j)) > 0) THEN WRITE (*, "(' ',A)") TRIM(f_dig_faultData_lines(a, j)(1:79)) END IF END DO WRITE (21, "('ERROR: Key-phrase ""symmetric_spreading_system"" is only allowed with sense D, L, R.')") WRITE (21, "('The following fault trace violates this rule:')") WRITE (21, "(A)") TRIM(f_dig_faultName_lines(j)) DO a = 1, 5 IF (LEN_TRIM(f_dig_faultData_lines(a, j)) > 0) THEN WRITE (21, "(A)") TRIM(f_dig_faultData_lines(a, j)) END IF END DO CALL Pause() STOP END IF IF (INDEX(c80, "first") > 0) THEN memo_2 = "first" ELSE IF (INDEX(c80, "last") > 0) THEN memo_2 = "last" ELSE IF (INDEX(c80, "both") > 0) THEN memo_2 = "both" ELSE ! input_syntax problem! WRITE (*, "(' ERROR: Key-phrase ""symmetric_spreading_system"" was used incorrectly.')") WRITE (*, "(' In the header lines for the following fault trace:')") WRITE (*, "(' ',A)") TRIM(f_dig_faultName_lines(j)(1:79)) DO a = 1, 5 IF (LEN_TRIM(f_dig_faultData_lines(a, j)) > 0) THEN WRITE (*, "(' ',A)") TRIM(f_dig_faultData_lines(a, j)(1:79)) END IF END DO WRITE (*, "(' the keyword must be followed by one of these specifiers:')") WRITE (*, "(' first')") WRITE (*, "(' last')") WRITE (*, "(' both')") WRITE (21, "('ERROR: keyword ""symmetric_spreading_system"" was used incorrectly.')") WRITE (21, "('In the header lines for the following fault trace:')") WRITE (21, "(A)") TRIM(f_dig_faultName_lines(j)) DO a = 1, 5 IF (LEN_TRIM(f_dig_faultData_lines(a, j)) > 0) THEN WRITE (21, "(A)") TRIM(f_dig_faultData_lines(a, j)) END IF END DO WRITE (21, "('the keyword must be followed by one of these specifiers:')") WRITE (21, "(' first')") WRITE (21, "(' last')") WRITE (21, "(' both')") CALL Pause() STOP END IF ! input syntax problem END IF ! line contains "symmetric_spreading_system"? IF (INDEX(c80, "other_spreading_system") > 0) THEN any_other_spreading = .TRUE. IF (INDEX(c80, "first") > 0) THEN memo_3 = "first" ELSE IF (INDEX(c80, "last") > 0) THEN memo_3 = "last" ELSE IF (INDEX(c80, "both") > 0) THEN memo_3 = "both" ELSE ! input_syntax problem! WRITE (*, "(' ERROR: Key-phrase ""other_spreading_system"" was used incorrectly.')") WRITE (*, "(' In the header lines for the following fault trace:')") WRITE (*, "(' ',A)") TRIM(f_dig_faultName_lines(j)(1:79)) DO a = 1, 5 IF (LEN_TRIM(f_dig_faultData_lines(a, j)) > 0) THEN WRITE (*, "(' ',A)") TRIM(f_dig_faultData_lines(a, j)(1:79)) END IF END DO WRITE (*, "(' the keyword must be followed by one of these specifiers:')") WRITE (*, "(' first')") WRITE (*, "(' last')") WRITE (*, "(' both')") WRITE (21, "('ERROR: keyword ""other_spreading_system"" was used incorrectly.')") WRITE (21, "('In the header lines for the following fault trace:')") WRITE (21, "(A)") TRIM(f_dig_faultName_lines(j)) DO a = 1, 5 IF (LEN_TRIM(f_dig_faultData_lines(a, j)) > 0) THEN WRITE (21, "(A)") TRIM(f_dig_faultData_lines(a, j)) END IF END DO WRITE (21, "('the keyword must be followed by one of these specifiers:')") WRITE (21, "(' first')") WRITE (21, "(' last')") WRITE (21, "(' both')") CALL Pause() STOP END IF ! input syntax problem END IF ! line contains "other_spreading_system"? ELSE ! found "***" got_data_line = .FALSE. got_terminator = .TRUE. in_trace = .FALSE. ! So, if another fault is found later, trace_loc(1, ...) will have to be set for it, too. !Apply throughgoing_master_fault translation method #0 to this trace, if "memo_0" commands: IF (memo_0 == "first") THEN major_fault(j) = .TRUE. plate_boundary(j) = .TRUE. k1 = trace_loc(1, j) k2 = trace_loc(2, j) translation_method(k1) = 0 ! first point IF ((k2-k1) >= 3) THEN ! also mark other points in first half a = k1 + 1 b = k1 + ((k2 - k1) / 2) DO k = a, b translation_method(k) = 0 END DO END IF memo_0 = "none" ! done, and crossed-off ELSE IF (memo_0 == "last") THEN major_fault(j) = .TRUE. plate_boundary(j) = .TRUE. k1 = trace_loc(1, j) k2 = trace_loc(2, j) translation_method(k2) = 0 ! last point IF ((k2-k1) >= 3) THEN ! also mark other points in last half a = k2 - ((k2 - k1) / 2) b = k2 - 1 DO k = a, b translation_method(k) = 0 END DO END IF memo_0 = "none" ! done, and crossed-off ELSE IF (memo_0 == "both") THEN major_fault(j) = .TRUE. plate_boundary(j) = .TRUE. k1 = trace_loc(1, j) k2 = trace_loc(2, j) DO k = k1, k2 translation_method(k) = 0 ! all points END DO memo_0 = "none" ! done, and crossed-off END IF ! N.B. If memo_0 == "none", no action is required, because translation_method was initialized as 1. !Apply spreading-system translation method #2 to this trace, if "memo_2" commands: IF (memo_2 == "first") THEN major_fault(j) = .TRUE. plate_boundary(j) = .TRUE. translation_method(trace_loc(1, j)) = 2 memo_2 = "none" ! done, and crossed-off ELSE IF (memo_2 == "last") THEN major_fault(j) = .TRUE. plate_boundary(j) = .TRUE. translation_method(trace_loc(2, j)) = 2 memo_2 = "none" ! done, and crossed-off ELSE IF (memo_2 == "both") THEN ! usually only 2 points, but let's be thorough, in case there are more. !(For example, a ridge or transform segment that leaves the model domain should have many ! digitized points, so that it will not suddenly fail the f_2_in() test, and be removed ! from the simulation, just because its outermost end projects outside the FEG grid area. ! Such perimeter-cutting symmetric_spreading_system faults should always be given ! the attribute "symmetric_spreading_system both" in the f____.DIG file. major_fault(j) = .TRUE. plate_boundary(j) = .TRUE. k1 = trace_loc(1, j) k2 = trace_loc(2, j) DO k = k1, k2 translation_method(k) = 2 END DO memo_2 = "none" ! done, and crossed-off END IF ! N.B. If memo_2 == "none", no action is required, because translation_method was initialized as 1. !Apply other_spreading_system translation method #3 to this trace, if "memo_3" commands: IF (memo_3 == "first") THEN major_fault(j) = .TRUE. plate_boundary(j) = .TRUE. translation_method(trace_loc(1, j)) = 3 memo_3 = "none" ! done, and crossed-off ELSE IF (memo_3 == "last") THEN major_fault(j) = .TRUE. plate_boundary(j) = .TRUE. translation_method(trace_loc(2, j)) = 3 memo_3 = "none" ! done, and crossed-off ELSE IF (memo_3 == "both") THEN ! usually only 2 points, but let's be thorough, in case there are more. !(For example, a ridge or transform segment that leaves the model domain should have many ! digitized points, so that it will not suddenly fail the f_2_in() test, and be entirely removed ! from the simulation, just because its outermost end projected outside the FEG grid area at some time. ! Such perimeter-cutting other-spreading-system faults should always be given ! the attribute "other_spreading_system both" in the f____.DIG file. major_fault(j) = .TRUE. plate_boundary(j) = .TRUE. k1 = trace_loc(1, j) k2 = trace_loc(2, j) DO k = k1, k2 translation_method(k) = 3 END DO memo_3 = "none" ! done, and crossed-off END IF ! N.B. If memo_3 == "none", no action is required, because translation_method() was initialized as 1. END IF ! data_line? or termination "***"? END IF ! F0001R line, or (x, y)-line, or something else (e.g., "***" or "throughgoing_master_fault") END DO read_dig CLOSE (UNIT = 3) ! close f_dig WRITE (*, "(' ',8X,I6,' fault-trace points were read')") f_dig_count WRITE (21,"(8X,I6,' fault-trace points were read')") f_dig_count WRITE (21,"(8X,'- - - - - - - - - - - - - - - - - - - - - ')") !Correction added 2020.07.09, to prevent the "jumping Coachella trace" bug. !For any fault trace that has interior digitized points (i.e., more than just the 2 end-points), ! and on which ONE end has translation_method == 0 (throughgoing_master_fault), ! while the OTHER end has translation_method == 2 OR 3 (symmetric_spreading_system OR other_spreading_system), ! convert translation_method of ANY INTERIOR POINT that is still left as 1 (default, implying unhooking) ! to a new value of 0 (throughgoing_master_fault), so there will be NO UNHOOKING applied to them, either. !This is to prevent unexpected wierd "sideways jumps" of those parts of the fault trace, perhaps even landing OUTSIDE their fault corridor! DO j = 1, f_highest ! Survey all traces, from F0001 to (perhaps) F9999: k1 = trace_loc(1, j) k2 = trace_loc(2, j) IF ((k2 - k1) > 1) THEN ! this trace has 1 or more interior digitized points (not just 2 end-points): indication1 = (translation_method(k1) == 0).AND.((translation_method(k2) == 2).OR.(translation_method(k2) == 3)) indication2 = ((translation_method(k1) == 2).OR.(translation_method(k1) == 3)).AND.(translation_method(k2) == 0) IF (indication1.OR.indication2) THEN ! This is a fault-trace that we need to process: DO k = (k1+1), (k2-1) ! [all interior digitization points] IF (translation_method(k) == 1) translation_method(k) = 0 ! Now set to throughgoing_master_fault. END DO ! k = (k1+1), (k2-1) [all interior digitization points] END IF ! This is one of those differently-ended traces that we need to process END IF ! This trace has interior digitized points END DO ! j = 1, f_highest; all traces !Block of logic which checks for missing fault traces in f_dig, and handles that according to the present geologic time: IF (start_time == 0.0D0) THEN ! User has access to present fault traces (from maps); prompt user to supply any missing ones. ! Check that all necessary traces where actually read. j = 0 ! number of traces missing from f_dig; to be incremented? DO i = 1, f_rst_count IF (trace_loc(2, which_trace(i)) == 0) THEN ! trace is not loaded in memory j = j + 1 END IF END DO IF (j > 0) THEN ! There is a serious problem, not just a cosmetic problem... WRITE (*, "(' ============================================================================')") WRITE (*, "(' ERROR: The following fault trace(s) is/are missing:')") WRITE (*, "(' ============================================================================')") WRITE (21, "('============================================================================')") WRITE (21, "('ERROR: The following fault trace(s) is/are missing:')") WRITE (21, "('============================================================================')") DO i = 1, f_rst_count IF (trace_loc(2, which_trace(i)) == 0) THEN WRITE (c4, "(I4)") which_trace(i) DO k = 1, 4 ! convert "F 1" to "F0001": IF (c4(k:k) == ' ') c4(k:k) = '0' END DO WRITE (*, "(' F', A4, A1, ' ', A)") c4, sense(i), TRIM(fault_name(i)) WRITE (21,"(' F', A4, A1, ' ', A)") c4, sense(i), TRIM(fault_name(i)) END IF ! trace is not loaded in memory END DO WRITE (*, "(' ============================================================================')") WRITE (*, "(' Fault trace(s) above, mentioned in your f_rst (geologic offsets) input file,')") WRITE (*, "(' is/are NOT FOUND in your f_dig (digitized traces) input file.')") WRITE (*, "(' You have 2 options to correct this discrepancy:')") WRITE (*, "(' (1) Digitize the missing trace(s) and add to your f_dig input file; OR')") WRITE (*, "(' (2) Edit your f_rst input file to omit any reference(s) to these traces.')") WRITE (*, "(' ============================================================================')") WRITE (21, "('============================================================================')") WRITE (21, "('Fault trace(s) above, mentioned in your f_rst (geologic offsets) input file,')") WRITE (21, "(' is/are NOT FOUND in your f_dig (digitized traces) input file.')") WRITE (21, "('You have 2 options to correct this discrepancy:')") WRITE (21, "('(1) Digitize the missing trace(s) and add to your f_dig input file; OR')") WRITE (21, "('(2) Edit your f_rst input file to omit any reference(s) to these traces.')") WRITE (21, "('============================================================================')") CALL Pause() STOP END IF ! IF (j > 0) ELSE ! start_time > 0.0D0; not present-day, so user DOES NOT have access to maps of missing fault traces. ! Check whether all necessary traces are present within the feg area? j = 0 ! number of OLDER (not formed-later!) traces NEWLY missing from grid area and/or f_dig input file; to be incremented? DO i = 1, f_rst_count IF (trace_loc(2, which_trace(i)) == 0) THEN ! trace is not loaded in memory trace_needed_this_run = (this_run_starts_Ma < trace_formed_Ma(which_trace(i))) IF (trace_needed_this_run) THEN ! only mention it when this trace would actually be used again! IF (.NOT.f_retired(i)) THEN ! only take note of NEW problems, not those already flagged. j = j + 1 END IF END IF END IF END DO IF (j > 0) THEN ! When we face this situation, in the middle of a restoration (or one interation of a restoration), ! it is usually because a fault that we were previously modeling (at younger geologic ages) ! has now been left outside the .feg grid area, either due to grid movement relative to the fault, or ! due to user's manual edits of the grid during re-sewing and upkeep. ! There is NO point in forcing a stop to the computation here, because: !(a) At geologic epochs before the present, fault trace locations are unknown, and cannot be supplied. !(b) There is no point in forcing this fault to be dropped from the database; ! perhaps the partial-history already computed has some value. ! Therefore, the only action here will be to display a cautionary notice ! (and this will be done only ONCE per trace, by making use of the memo array f_retired). WRITE (*, "(' ============================================================================')") WRITE (*, "(' CAUTION: The following fault trace(s), previously modeled')") WRITE (*, "(' but not yet modeled back to its/their fault-formation epoch(s),')") WRITE (*, "(' is/are not found within the area of the finite-element grid.')") WRITE (*, "(' (This might be due to grid-edge movement and/or manual edits')") WRITE (*, "(' to the shape and extent of the grid.)')") WRITE (*, "(' ============================================================================')") WRITE (21, "('============================================================================')") WRITE (21, "('CAUTION: The following fault trace(s), previously modeled')") WRITE (21, "(' but not yet modeled back to its/their fault-formation epoch(s),')") WRITE (21, "(' is/are not found within the area of the finite-element grid.')") WRITE (21, "(' (This might be due to grid-edge movement and/or manual edits')") WRITE (21, "(' to the shape and extent of the grid.)')") WRITE (21, "('============================================================================')") DO i = 1, f_rst_count IF (trace_loc(2, which_trace(i)) == 0) THEN trace_needed_this_run = (this_run_starts_Ma < trace_formed_Ma(which_trace(i))) IF (trace_needed_this_run) THEN IF (.NOT.f_retired(i)) THEN ! only take note of NEW problems, not those already flagged. WRITE (c4,"(I4)") which_trace(i) DO k = 1, 4 ! convert "F 1" to "F0001": IF (c4(k:k) == ' ') c4(k:k) = '0' END DO WRITE (*, "(' F', A4, A1, ' ', A)") c4, sense(i), TRIM(fault_name(i)) WRITE (21,"(' F', A4, A1, ' ', A)") c4, sense(i), TRIM(fault_name(i)) f_retired(i) = .TRUE. ! which will prevent any repetition of this message (for this fault) END IF ! trace_needed_this_run END IF ! new problem (not one previously flagged) END IF ! trace is not loaded in memory END DO WRITE (*, "(' ============================================================================')") WRITE (*, "(' Modeling will continue without using this/these fault(s).')") WRITE (*, "(' However, any partial histories (already computed) will continue to')") WRITE (*, "(' be reported in future f_rst output files.')") WRITE (*, "(' ============================================================================')") WRITE (21, "('============================================================================')") WRITE (21, "('Modeling will continue without using this/these fault(s).')") WRITE (21, "('However, any partial histories (already computed) will continue to')") WRITE (21, "(' be reported in future f_rst output files.')") WRITE (21, "('============================================================================')") END IF ! IF (j > 0) END IF ! Two alternative check-points (and handlings) of missing fault traces; present-day, or in-the-past. END IF ! IF (f_dig /= 'none '.OR. 'skipped ') ! read c_rst IF (c_rst(1:5) == 'none ') THEN c_rst_count = 0 ELSE WRITE (*, "(' ',8X,'Reading cross-section data from ',A)") TRIM(c_rst) WRITE (21,"(8X,'Reading cross-section data from ',A)") TRIM(c_rst) OPEN (UNIT = 4, FILE = c_rst, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) IF (ios /= 0) CALL File_not_found(c_rst) READ (4, "(A)") c_rst_format READ (4, "(A)") c_rst_titles ! Skim file and count number of data lines c_rst_count = 0 get_section_lines: DO READ (4, "(A)", IOSTAT = read_status) c134 IF (read_status == 0) THEN ! read was successful IF ((c134(1:1) /= '+') .AND. & (c134(1:1) /= '*') .AND. & (c134(1:1) /= '&') .AND. & (c134(1:1) /= '$')) THEN c_rst_count = c_rst_count + 1 END IF ELSE; EXIT get_section_lines; END IF END DO get_section_lines CLOSE (UNIT = 4) ! (will be re-read) ! allocate arrays CALL More_mem ('c_active', 1.0D0 * num_timesteps * c_rst_count * 1) ALLOCATE ( c_active(num_timesteps, c_rst_count) ) CALL More_mem ('c_ref', 1.0D0 * c_rst_count * 47) ALLOCATE ( c_ref(c_rst_count) ) CALL More_mem ('c_end_0', 1.0D0 * 3 * 2 * c_rst_count * bytes_per_real) ALLOCATE ( c_end_0(3, 2, c_rst_count) ) CALL More_mem ('c_end_is', 1.0D0 * 2 * c_rst_count * bytes_per_is) ALLOCATE ( c_end_is(2, c_rst_count) ) c_end_is(1:2, 1:c_rst_count)%element = 1 ! because '0' has a special meaning to Internal CALL More_mem ('c_end_now', 1.0D0 * 3 * 2 * c_rst_count * bytes_per_real) ALLOCATE ( c_end_now(3, 2, c_rst_count) ) CALL More_mem ('c_code', 1.0D0 * c_rst_count * 5) ALLOCATE ( c_code(c_rst_count) ) CALL More_mem ('c_length', 1.0D0 * 2 * c_rst_count * bytes_per_real) ALLOCATE ( c_length(2, c_rst_count) ) CALL More_mem ('c_stretch', 1.0D0 * c_rst_count * bytes_per_real) ALLOCATE ( c_stretch(c_rst_count) ) CALL More_mem ('c_sigma_', 1.0D0 * c_rst_count * bytes_per_real) ALLOCATE ( c_sigma_(c_rst_count) ) CALL More_mem ('c_t_max', 1.0D0 * c_rst_count * bytes_per_real) ALLOCATE ( c_t_max (c_rst_count) ) CALL More_mem ('c_t_min', 1.0D0 * c_rst_count * bytes_per_real) ALLOCATE ( c_t_min (c_rst_count) ) CALL More_mem ('c_goal', 1.0D0 * c_rst_count * num_timesteps * bytes_per_real) ALLOCATE ( c_goal(num_timesteps, c_rst_count) ) CALL More_mem ('c_rate', 1.0D0 * c_rst_count * num_timesteps * bytes_per_real) ALLOCATE ( c_rate(num_timesteps, c_rst_count) ) c_rate = 0.0D0 CALL More_mem ('c_rate_sigma_', 1.0D0 * c_rst_count * bytes_per_real) ALLOCATE ( c_rate_sigma_(c_rst_count) ) CALL More_mem ('c_err', 1.0D0 * 3 * (1 + max_iter) * bytes_per_real) ALLOCATE ( c_err(0:2, 0:max_iter) ) ! fill arrays OPEN (UNIT = 4, FILE = c_rst, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) ; line = 0 IF (ios /= 0) CALL File_not_found(c_rst) READ (4,*) ; line = line + 1 READ (4,*) ; line = line + 1 read_c_rst: DO i = 1, c_rst_count READ (4, c_rst_format) c47, x1, x2, x3, x4, c5, r1, r2, r3, t2, t1 ; line = line + 1 c_ref(i) = c47 CALL Xyz_from_lonlat(x1, x2, tv) c_end_0(1:3,1,i) = tv CALL Xyz_from_lonlat(x3, x4, tv) c_end_0(1:3,2,i) = tv c_end_now(1:3,1:2,i) = c_end_0(1:3,1:2,i) ! possibly overwritten below c_code(i) = c5 c_length(1,i) = r1 * m_per_km c_length(2,i) = r2 * m_per_km c_stretch(i) = c_length(1,i) - c_length(2,i) IF (r3 <= 0.0D0) CALL Prevent ('nonpositive sigma_', line, c_rst) c_sigma_(i) = r3 * m_per_km IF (t2 <= t1) CALL Prevent ('null age range', line, c_rst) c_t_max(i) = t2 * s_per_Ma c_t_min(i) = t1 * s_per_Ma CALL Set_goal_A (index = i, total = c_stretch, & & tmin = c_t_min, tmax = c_t_max, checkPD = .FALSE., & ! inputs & goal = c_goal, active = c_active)! outputs c_rate_sigma_(i) = c_sigma_(i) / (c_t_max(i) - c_t_min(i)) !read any + lines, but use only if start_time > 0.0D0 READ (4,"(A)", IOSTAT = read_status) c134 IF (read_status /= 0) EXIT read_c_rst IF (c134(1:1) == '+') THEN c134 = c134(2:134) // ' ' READ (c134,*) x1, x2 READ (4,"(A)") c134 c134 = c134(2:134) // ' ' READ (c134,*) x3, x4 IF (start_time > 0.0D0) THEN CALL Xyz_from_lonlat(x1, x2, tv) c_end_now(1:3,1,i) = tv CALL Xyz_from_lonlat(x3, x4, tv) c_end_now(1:3,2,i) = tv END IF ELSE BACKSPACE(4) END IF !read any * lines CALL Set_goal_B (index = i, & & checkPD = .FALSE., active = c_active, & & unit = 4, signal = '*', eof = eof, & & conversion = (m_per_km / s_per_Ma), & ! inputs & line = line, & ! modify & rate = c_rate, & ! modify & goal = c_goal) ! modify IF (eof) EXIT read_c_rst END DO read_c_rst WRITE (*, "(' ',8X,I4,' cross-section data were read')") c_rst_count WRITE (21,"(8X,I4,' cross-section data were read')") c_rst_count CLOSE (UNIT = 4) ! close c_rst WRITE (21,"(8X,'- - - - - - - - - - - - - - - - - - - - ')") END IF ! (c_rst /= 'none') ! read p_rst IF (p_rst(1:5) == 'none ') THEN p_rst_count = 0 ELSE WRITE (*, "(' ',8X,'Reading paleomagnetic data from ',A)") TRIM(p_rst) WRITE (21,"(8X,'Reading paleomagnetic data from ',A)") TRIM(p_rst) OPEN (UNIT = 8, FILE = p_rst, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) IF (ios /= 0) CALL File_not_found(p_rst) READ (8, "(A)") p_rst_format READ (8, "(A)") p_rst_titles ! Skim file and count number of data lines p_rst_count = 0 get_paleo_lines: DO READ (8, "(A)", IOSTAT = read_status) c134 IF (read_status == 0) THEN ! read was successful IF ((c134(1:1) /= '+') .AND. & (c134(1:1) /= '*') .AND. & (c134(1:1) /= '&') .AND. & (c134(1:1) /= '$')) THEN p_rst_count = p_rst_count + 1 END IF ELSE; EXIT get_paleo_lines; END IF END DO get_paleo_lines CLOSE (UNIT = 8) ! (will be re-read) ! allocate arrays CALL More_mem ('p_active', 1.0D0 * num_timesteps * p_rst_count * 1) ALLOCATE ( p_active(num_timesteps, p_rst_count) ) CALL More_mem ('p_ref', 1.0D0 * p_rst_count * 50) ALLOCATE ( p_ref(p_rst_count) ) CALL More_mem ('p_site_0', 1.0D0 * 3 * p_rst_count * bytes_per_real) ALLOCATE ( p_site_0(3, p_rst_count) ) CALL More_mem ('p_site_is', 1.0D0 * p_rst_count * bytes_per_is) ALLOCATE ( p_site_is(p_rst_count) ) p_site_is(1:p_rst_count)%element = 1 ! because '0' has a special meaning to Internal CALL More_mem ('p_site_now', 1.0D0 * 3 * p_rst_count * bytes_per_real) ALLOCATE ( p_site_now(3, p_rst_count) ) CALL More_mem ('p_south', 1.0D0 * p_rst_count * bytes_per_real) ALLOCATE ( p_south(p_rst_count) ) CALL More_mem ('p_south_sigma_', 1.0D0 * p_rst_count * bytes_per_real) ALLOCATE ( p_south_sigma_(p_rst_count) ) CALL More_mem ('p_ccw', 1.0D0 * p_rst_count * bytes_per_real) ALLOCATE ( p_ccw(p_rst_count) ) CALL More_mem ('p_ccw_sigma_', 1.0D0 * p_rst_count * bytes_per_real) ALLOCATE ( p_ccw_sigma_(p_rst_count) ) CALL More_mem ('p_t2', 1.0D0 * p_rst_count * bytes_per_real) ALLOCATE ( p_t2(p_rst_count) ) CALL More_mem ('p_t1', 1.0D0 * p_rst_count * bytes_per_real) ALLOCATE ( p_t1(p_rst_count) ) CALL More_mem ('p_t_max', 1.0D0 * p_rst_count * bytes_per_real) ALLOCATE ( p_t_max(p_rst_count) ) CALL More_mem ('p_t_min', 1.0D0 * p_rst_count * bytes_per_real) ALLOCATE ( p_t_min(p_rst_count) ) p_t_min = 0.0D0 ! whole array; necessary as an actual parameter CALL More_mem ('p_pole', 1.0D0 * 3 * p_rst_count * bytes_per_real) ALLOCATE ( p_pole(3, p_rst_count) ) CALL More_mem ('p_south_goal', 1.0D0 * p_rst_count * num_timesteps * bytes_per_real) ALLOCATE ( p_south_goal(num_timesteps, p_rst_count) ) CALL More_mem ('p_south_rate', 1.0D0 * p_rst_count * num_timesteps * bytes_per_real) ALLOCATE ( p_south_rate(num_timesteps, p_rst_count) ) p_south_rate = 0.0D0 CALL More_mem ('p_south_rate_sigma_', 1.0D0 * p_rst_count * bytes_per_real) ALLOCATE ( p_south_rate_sigma_(p_rst_count) ) CALL More_mem ('p_ccw_goal', 1.0D0 * p_rst_count * num_timesteps * bytes_per_real) ALLOCATE ( p_ccw_goal(num_timesteps, p_rst_count) ) CALL More_mem ('p_ccw_rate', 1.0D0 * p_rst_count * num_timesteps * bytes_per_real) ALLOCATE ( p_ccw_rate(num_timesteps, p_rst_count) ) p_ccw_rate = 0.0D0 CALL More_mem ('p_ccw_rate_sigma_', 1.0D0 * p_rst_count * bytes_per_real) ALLOCATE ( p_ccw_rate_sigma_(p_rst_count) ) CALL More_mem ('twisted', 1.0D0 * p_rst_count) ALLOCATE ( twisted(p_rst_count) ) CALL More_mem ('p_south_err', 1.0D0 * 3 * (1 + max_iter) * bytes_per_real) ALLOCATE ( p_south_err(0:2, 0:max_iter) ) CALL More_mem ('p_ccw_err', 1.0D0 * 3 * (1 + max_iter) * bytes_per_real) ALLOCATE ( p_ccw_err(0:2, 0:max_iter) ) twisted = .FALSE. ! whole array; later statements only -> .TRUE. ! fill arrays OPEN (UNIT = 8, FILE = p_rst, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) ; line = 0 IF (ios /= 0) CALL File_not_found(p_rst) READ (8,*) ; line = line + 1 READ (8,*) ; line = line + 1 read_p_rst: DO i = 1, p_rst_count READ (8, p_rst_format) c50, x1, x2, r1, r2, r3, r4, t2, t1, x3, x4; line = line + 1 p_ref(i) = c50 CALL Xyz_from_lonlat(x1, x2, tv) p_site_0(1:3,i) = tv p_site_now(1:3,i) = p_site_0(1:3,i) ! possibly overwritten below p_south(i) = (r1 / deg_per_rad) * R IF (r2 <= 0.0D0) CALL Prevent ('nonpositive sigma_ for latitude', line, p_rst) p_south_sigma_(i) = (r2 / deg_per_rad) * R p_ccw(i) = r3 / deg_per_rad IF (r4 <= 0.0D0) CALL Prevent ('nonpositive sigma_ for rotation', line, p_rst) p_ccw_sigma_(i) = r4 / deg_per_rad IF (t2 < t1) THEN WRITE (*, "(' Error in line ',I6,' of'/' ',A/' max.age ',F10.2,' is < min.age ',F10.2)") & line, TRIM(p_rst), t2, t1 WRITE (21,"('Error in line ',I6,' of'/A/'max.age ',F10.2,' is < min.age ',F10.2)") & line, TRIM(p_rst), t2, t1 CALL Pause() STOP ENDIF p_t2(i) = t2 * s_per_Ma p_t1(i) = t1 * s_per_Ma p_t_max(i) = (p_t1(i) + p_t2(i)) / 2.0D0 ! mean age of magnetization p_t_min(i) = 0.0D0 ! rocks were sampled only yesterday CALL Xyz_from_lonlat(x3, x4, tv) p_pole(1:3,i) = tv CALL Set_goal_A (index = i, total = p_south, & & tmin = p_t_min, tmax = p_t_max, checkPD = .FALSE., & ! inputs & goal = p_south_goal, active = p_active)! output p_south_rate_sigma_(i) = p_south_sigma_(i) / (p_t_max(i) - p_t_min(i)) CALL Set_goal_A (index = i, total = p_ccw, & & tmin = p_t_min, tmax = p_t_max, checkPD = .FALSE., & ! inputs & goal = p_ccw_goal, active = p_active)! output p_ccw_rate_sigma_(i) = p_ccw_sigma_(i) / (p_t_max(i) - p_t_min(i)) !read any + lines, but use only if start_time > 0.0D0 READ (8,"(A)", IOSTAT = read_status) c134 IF (read_status /= 0) EXIT read_p_rst IF (c134(1:1) == '+') THEN c134 = c134(2:134) // ' ' READ (c134,*) x1, x2 IF (start_time > 0.0D0) THEN CALL Xyz_from_lonlat(x1, x2, tv) p_site_now(1:3,i) = tv END IF ELSE BACKSPACE(8) END IF !read any * and # lines and correct rates and goals CALL Set_goal_B (index = i, & & checkPD = .FALSE., active = p_active, & & unit = 8, signal = '*', eof = eof, & & conversion = (R / (deg_per_rad * s_per_Ma)), & ! inputs & line = line, & ! modify & rate = p_south_rate, & ! modify & goal = p_south_goal) ! modify IF (eof) EXIT read_p_rst CALL Set_goal_B (index = i, & & checkPD = .FALSE., active = p_active, & & unit = 8, signal = '&', eof = eof, & & conversion = (1.0D0 / (deg_per_rad * s_per_Ma)), & ! inputs & line = line, & ! modify & rate = p_ccw_rate, & ! modify & goal = p_ccw_goal) ! modify IF (eof) EXIT read_p_rst END DO read_p_rst WRITE (*, "(' ',8X,I4,' paleomagnetic sites were read')") p_rst_count WRITE (21,"(8X,I4,' paleomagnetic sites were read')") p_rst_count CLOSE (UNIT = 8) ! close p_rst WRITE (21,"(8X,'- - - - - - - - - - - - - - - - - - - - ')") END IF ! IF (p_rst /= 'none') ! read s_rst IF (s_rst(1:5) == 'none ') THEN s_rst_count = 0 ELSE WRITE (*, "(' ',8X,'Reading paleostress data from ',A)") TRIM(s_rst) WRITE (21,"(8X,'Reading paleostress data from ',A)") TRIM(s_rst) OPEN (UNIT = 9, FILE = s_rst, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) IF (ios /= 0) CALL File_not_found(s_rst) READ (9, "(A)") s_rst_format READ (9, "(A)") s_rst_titles ! Skim file and count number of data lines s_rst_count = 0 get_stress_lines: DO READ (9, "(A)", IOSTAT = read_status) c134 IF (read_status == 0) THEN ! read was successful IF ((c134(1:1) /= '+') .AND. & (c134(1:1) /= '*') .AND. & (c134(1:1) /= '&') .AND. & (c134(1:1) /= '$')) THEN s_rst_count = s_rst_count + 1 END IF ELSE; EXIT get_stress_lines; END IF END DO get_stress_lines CLOSE (UNIT = 9) ! (will be re-read) ! allocate arrays CALL More_mem ('s_activity', 1.0D0 * num_timesteps * s_rst_count * bytes_per_real) ALLOCATE (s_activity(num_timesteps, s_rst_count) ) CALL More_mem ('s_ref', 1.0D0 * s_rst_count * 30) ALLOCATE ( s_ref(s_rst_count) ) CALL More_mem ('s_loc', 1.0D0 * s_rst_count * 30) ALLOCATE ( s_loc(s_rst_count) ) CALL More_mem ('s_code', 1.0D0 * s_rst_count * 5) ALLOCATE ( s_code(s_rst_count) ) CALL More_mem ('s_site_0', 1.0D0 * 3 * s_rst_count * bytes_per_real) ALLOCATE ( s_site_0(3, s_rst_count) ) CALL More_mem ('s_site_is', 1.0D0 * 2 * s_rst_count * bytes_per_is) ALLOCATE (s_site_is(2, s_rst_count) ) s_site_is(1:2, 1:s_rst_count)%element = 1 ! because '0' has special meaning to Internal CALL More_mem ('s_site_now', 1.0D0 * 3 * 2 * s_rst_count * bytes_per_real) ALLOCATE ( s_site_now(3, 2, s_rst_count) ) CALL More_mem ('s_azim_0', 1.0D0 * s_rst_count * bytes_per_real) ALLOCATE ( s_azim_0(s_rst_count) ) CALL More_mem ('s_azim_now', 1.0D0 * s_rst_count * bytes_per_real) ALLOCATE ( s_azim_now(s_rst_count) ) CALL More_mem ('s_sigma_', 1.0D0 * s_rst_count * bytes_per_real) ALLOCATE ( s_sigma_(s_rst_count) ) CALL More_mem ('s_t_max', 1.0D0 * s_rst_count * bytes_per_real) ALLOCATE ( s_t_max(s_rst_count) ) CALL More_mem ('s_t_min', 1.0D0 * s_rst_count * bytes_per_real) ALLOCATE ( s_t_min(s_rst_count) ) CALL More_mem ('s_stage', 1.0D0 * s_rst_count * 1) ALLOCATE ( s_stage(s_rst_count) ) ! fill arrays OPEN (UNIT = 9, FILE = s_rst, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) ; line = 0 IF (ios /= 0) CALL File_not_found(s_rst) READ (9,*) ; line = line + 1 READ (9,*) ; line = line + 1 read_s_rst: DO i = 1, s_rst_count READ (9, s_rst_format) c30, c30a, c5, x1, x2, r1, r2, t2, t1, c6; line = line + 1 s_ref(i) = c30 s_loc(i) = c30a s_code(i) = c5 CALL Xyz_from_lonlat(x1, x2, tv) s_site_0(1:3,i) = tv s_azim_0(i) = r1 / deg_per_rad s_azim_now(i) = s_azim_0(i) ! possibly overwritten below s_site_now(1:3,1,i) = s_site_0(1:3,i) ! possibly overwritten below tvi = s_site_now(1:3, 1, i) CALL Step_aside(tvi, s_azim_0(i), tvo) s_site_now(1:3, 2, i) = tvo IF (r2 <= 0.0D0) CALL Prevent ('nonpositive sigma_', line, s_rst) s_sigma_(i) = r2 / deg_per_rad IF (t2 <= t1) THEN WRITE (*, "(' Error in line ',I6,' of'/' ',A/' ',F10.2,' is <= ',F10.2)") & line, TRIM(s_rst), t2, t1 WRITE (21,"('Error in line ',I6,' of'/A/F10.2,' is <= ',F10.2)") & line, TRIM(s_rst), t2, t1 CALL Pause() STOP ENDIF s_t_max(i) = t2 * s_per_Ma s_t_min(i) = t1 * s_per_Ma s_stage(i) = (c6(1:1) == 'S') .OR. (c6(1:1) == 's') IF (paleotec) THEN DO j = 1, num_timesteps t1 = (j - 1) * Deltat_ t2 = j * Deltat_ overlap = MAX(0.0D0, MIN(t2 - t1, s_t_max(i) - s_t_min(i), & & t2 - s_t_min(i), s_t_max(i) - t1)) IF (s_stage(i)) THEN overlap_threshold = MIN(0.1D0 * s_per_Ma, 0.5D0 * Deltat_) IF (overlap >= overlap_threshold) THEN s_activity(j, i) = 1.0D0 ELSE s_activity(j, i) = 0.0D0 END IF ELSE ! "window" type datum s_activity(j, i) = overlap / (s_t_max(i) - s_t_min(i)) END IF END DO ELSE ! neotec IF (s_stage(i)) THEN allowance = 0.1D0 * s_per_Ma IF ((start_time > (s_t_min(i) - allowance)) .AND. & & (start_time < (s_t_max(i) + allowance))) THEN s_activity(1, i) = 1.0D0 ELSE s_activity(1, i) = 0.0D0 END IF ELSE ! "window" type datum s_activity(1, i) = 0.0D0 END IF ! stage(i) END IF ! paleotec or neotec !read any + line, but use only if start_time > 0.0D0 READ (9,"(A)", IOSTAT = read_status) c134 IF (read_status /= 0) EXIT read_s_rst IF (c134(1:1) == '+') THEN c134 = c134(2:134) // ' ' READ (c134,*) x1, x2 IF (start_time > 0.0D0) THEN CALL Xyz_from_lonlat(x1, x2, tv) s_site_now(1:3,1,i) = tv END IF ELSE BACKSPACE(9) END IF !read any $ line, but use only if start_time > 0.0D0 READ (9,"(A)", IOSTAT = read_status) c134 IF (read_status /= 0) EXIT read_s_rst IF (c134(1:1) == '$') THEN c134 = c134(2:134) // ' ' READ (c134,*) t1 IF (start_time > 0.0D0) THEN s_azim_now(i) = t1 / deg_per_rad tvi = s_site_now(1:3, 1, i) CALL Step_aside(tvi, s_azim_now(i), tvo) s_site_now(1:3,2,i) = tvo END IF ELSE BACKSPACE(9) END IF END DO read_s_rst WRITE (*, "(' ',8X,I4,' paleostress sites were read')") s_rst_count WRITE (21,"(8X,I4,' paleostress sites were read')") s_rst_count CLOSE (UNIT = 9) ! close s_rst WRITE (21,"(8X,'- - - - - - - - - - - - - - - - - - - - ')") END IF ! IF (s_rst /= 'none') ! read y_dig IF ((y_dig(1:5) == 'none ') .OR. (y_dig(1:7) == 'skipped')) THEN basemap_object_count = 0 basemap_title_count = 0 basemap_point_count = 0 ELSE WRITE (*, "(' ', 8X, 'Reading basemap/geologic-map from ', A)") TRIM(y_dig) WRITE (21,"(8X, 'Reading basemap/geologic-map from ', A)") TRIM(y_dig) OPEN (UNIT = 10, FILE = y_dig, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios); line = 0 IF (ios /= 0) CALL File_not_found(y_dig) ! Skim file and record totals for 3 types of records: basemap_object_count = 0 ! just initializing, before count basemap_title_count = 0 ! just initializing, before count basemap_point_count = 0 ! just initializing, before count y_loop_thru: DO READ (10, "(A)", IOSTAT = read_status) c80; line = line + 1 IF (read_status == 0) THEN ! read was successful IF ((c80(1:2) == ' +') .OR. (c80(1:2) == ' -')) THEN basemap_point_count = basemap_point_count + 1 ELSE IF (c80(1:3) == "***") THEN basemap_object_count = basemap_object_count + 1 ELSE basemap_title_count = basemap_title_count + 1 END IF ELSE EXIT y_loop_thru END IF END DO y_loop_thru CLOSE (UNIT = 10) ! (will be re-read, after arrays are allocated) ! Allocate arrays: CALL More_mem ('basemap_title_store', 1.0D0 * 80 * basemap_title_count) ALLOCATE ( basemap_title_store(0:basemap_title_count) ) ! N.B. "0:" is used because basemap_title_count MIGHT be zero, too. CALL More_mem ('basemap_uvec_store', 1.0D0 * 3 * basemap_point_count * bytes_per_real) ALLOCATE ( basemap_uvec_store(3, basemap_point_count) ) CALL More_mem ('basemap_uvec_store0', 1.0D0 * 3 * basemap_point_count * bytes_per_real) ALLOCATE ( basemap_uvec_store0(3, basemap_point_count) ) CALL More_mem ('basemap_object_index', 1.0D0 * 6 * basemap_object_count * bytes_per_int) ALLOCATE ( basemap_object_index(6, basemap_object_count) ) CALL More_mem ('basemap_object_index0', 1.0D0 * 6 * basemap_object_count * bytes_per_int) ALLOCATE ( basemap_object_index0(6, basemap_object_count) ) CALL More_mem ('basemap_point_is', 1.0D0 * basemap_point_count * bytes_per_is) ALLOCATE ( basemap_point_is(basemap_point_count) ) basemap_point_is(1:basemap_point_count)%element = 1 ! because '0' has special meaning to Internal ! fill arrays OPEN (UNIT = 10, FILE = y_dig, STATUS = "OLD", ACTION = "READ", PAD = "YES", IOSTAT = ios) ; line = 0 IF (ios /= 0) CALL File_not_found(y_dig) basemap_object_index = 0 ! which 0 will be a flag meaning "still undefined" in the cases of 2:first-title-location & 5:first-point-location !Initialize global counters (which show where the last title or point was stored): basemap_title_count = 0 basemap_point_count = 0 !Initialize local counters (within one object): object = 0 points = 0 titles = 0 ! initializing counts for next object y_read_dig: DO READ (10, "(A)", IOSTAT = read_status) c80; line = line + 1 IF (read_status == 0) THEN ! read was successful IF (c80(1:3) == "***") THEN ! this object is concluded; remember it: object = object + 1 ! Initially 1, then 2, 3, ... basemap_object_count basemap_object_index(1, object) = titles IF (titles == 0) THEN basemap_object_index(2:3, object) = 0 ! which is also a "flag" confirming no titles in this object ELSE ! titles >= 1 basemap_object_index(3, object) = basemap_title_count !(We must remember to set basemap_object_index(2, object+1) below, whenever the first new title is read.) END IF basemap_object_index(4, object) = points IF (points == 0) THEN basemap_object_index(5:6, object) = 0 ELSE ! points >= 1 basemap_object_index(6, object) = basemap_point_count !(We must remember to set basemap_object_index(5, object+1) below, whenever the first new point is read.) END IF !Reset local counts, to begin again for the next object: titles = 0 points = 0 ELSE IF ((c80(1:2) == ' +') .OR. (c80(1:2) == ' -')) THEN READ (c80, *) Elon, Nlat ! E longitude, N latitude CALL DLonLat_2_Uvec(Elon, Nlat, uvec) points = points + 1 ! local count, for this object basemap_point_count = basemap_point_count + 1 ! global store count basemap_uvec_store(1:3, basemap_point_count) = uvec(1:3) IF (basemap_object_index(5, (object + 1)) == 0) basemap_object_index(5, (object + 1)) = basemap_point_count ELSE ! titles titles = titles + 1 ! local count, for this object basemap_title_count = basemap_title_count + 1 ! global store count basemap_title_store(basemap_title_count) = TRIM(c80) IF (basemap_object_index(2, (object + 1)) == 0) basemap_object_index(2, (object + 1)) = basemap_title_count END IF ELSE EXIT y_read_dig END IF END DO y_read_dig CLOSE (UNIT = 10) ! close y_dig WRITE (*, "(' ', 8X, I6, ' basemap objects were read, with total of ', I12, ' points')") basemap_object_count, basemap_point_count WRITE (21,"(8X, I6, ' basemap objects were read, with total of ', I12, ' points')") basemap_object_count, basemap_point_count WRITE (21,"(8X,'- - - - - - - - - - - - - - - - - - - - - ')") !Save copies of arrays needed to re-initialize for iterations #2, #3, ... basemap_uvec_store0 = basemap_uvec_store basemap_object_index0 = basemap_object_index !N.B. Titles do not change with time-integration. Internal coordinates are not defined across FEG reloads. END IF ! IF (y_dig /= 'none') WRITE (*, "(' ',4X,'Successfully read all input datasets')") WRITE (21,"(4X,'Successfully read all input datasets')") stress_ever = (s_rst_count > 0) .OR. (faults_give_sigma_1h.AND.(f_rst_count > 0)) IF ((.NOT.stress_ever).AND.(n_refine > 0)) THEN n_refine = 0 WRITE (*, "(' ',4X,'Lacking any stress data; refinement is useless: n_refine = 0.')") WRITE (21,"(4X,'Lacking any stress data; refinement is useless: n_refine = 0.')") END IF ELSE ! iteration > 1 ! Initialize integrated variables on 2nd and later iterations ! ( where we can assume that start_time = 0.0D0 ) IF (f_dig_count > 0) THEN trace = trace_0 ! whole array f_2_in = .TRUE. ! whole array; later statements can only change individual values -> .FALSE. END IF ! f_dig_count > 0 IF (c_rst_count > 0) c_end_now = c_end_0 ! whole array IF (p_rst_count > 0) p_site_now = p_site_0 ! whole array IF (s_rst_count > 0) THEN s_azim_now = s_azim_0 ! whole array DO i = 1, s_rst_count s_site_now(1:3, 1, i) = s_site_0(1:3, i) tvi = s_site_now(1:3, 1, i) CALL Step_aside(tvi, s_azim_0(i), tvo) s_site_now(1:3, 2,i) = tvo END DO END IF IF (basemap_object_count > 0) THEN basemap_uvec_store = basemap_uvec_store0 ! whole array basemap_object_index = basemap_object_index0 ! whole array END IF END IF ! (iteration =1, or > 1) ! [.feg (and matching .bcs) pairs are read as needed within timestepping loop ] current_feg = 0 ! no FEG/BCS pair is loaded (yet) get_feg = .TRUE. ! better load one; if you've got one (left over from the last iteration), it's deformed! IF (paleotec) THEN n_ = NINT(start_time / Deltat_) ! If starting a new iteration, this will be 0 at first, and then bumped up to 1 (below). ! If re-starting some iteration in the middle, inital n_ will be > ( 0 --> 1 ), at least ( 1 --> 2 ). ELSE ! (neotec) n_ = 0 ! will be bumped to 1, a few lines below here END IF n_beginning_this_run = n_ + 1 ! memo, used to control deletion(?) of surplus output files from step (n_ - 1), IF (n_ > n_beginning_this_run) timestepping: DO !============================================================================================= IF (paleotec) THEN time0 = n_ * Deltat_ ELSE ! neotec time0 = start_time END IF t0 = time0 / s_per_Ma ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ n_ = n_ + 1 ! N.B. This was not coded with "DO n_ = ..." because, ! in previous versions of Restore (Restore1/2/3), ! we sometimes REPEATED some timesteps, using a new FEG. ! (This is no longer done; in Restore4, repeating a timestep ! would imply mean re-reading the same FEG, and would produce ! an infinite loop!) ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF (paleotec) THEN time1 = n_ * Deltat_ t1 = time1 / s_per_Ma WRITE (*, "(' ', 4X, 'Attempting timestep from ', F6.2, ' to ', F6.2, ' Ma')") t0, t1 WRITE (21,"(4X, 'Attempting timestep from ', F6.2, ' to ', F6.2, ' Ma')") t0, t1 ELSE ! (neotec) time1 = time0 END IF get_feg = get_feg .OR. (grid_to_load_this_timestep(n_) > 0) ! In addition to really basic needs (i.e., when starting a new neotec, or new paleotec iteration), ! we will load a new FEG/BCS pair whenever the loading schedule dictates it. IF (get_feg) THEN get_feg = .FALSE. ! (Turn off this flag {before we forget...} so that we only load ONE FEG/BCS pair per timestep, at most.) got_new_FEG_this_timestep = .TRUE. IF (grid_to_load_this_timestep(n_) > 0) THEN current_feg = grid_to_load_this_timestep(n_) ! value 1:num_fegs ELSE ! unexpected problem; we need a new FEG/BCS pair, but we are IN-BETWEEN or BEYOND scheduled loadings ... WRITE (*, "(' ERROR: The grid-loading plan does not provide any new FEG/BCS file-pair at this time.')") WRITE (*, "(' Please provide a new pair, and restart this run/iteration/timestep...')") WRITE (21, "('ERROR: The grid-loading plan does not provide any new FEG/BCS file-pair at this time.')") WRITE (21, "(' Please provide a new pair, and restart this run/iteration/timestep...')") CALL Recovery_advice() ! using a subprogram so that this long special-case message does not obscure program logic. CALL Pause() STOP END IF changed_horses = (current_feg > 1) ! Define time-step index limits (on an absolute scale, starting from the present) ! for the planned use of this new temporary FEG: k_step_1 = n_ ! the current time-step, on an absolute integer scale IF (current_feg == num_fegs) THEN ! this is the last in the list k_step_2 = num_timesteps ELSE ! there are later chapters still to come in this run k_step_2 = first_timestep_for_this_grid(current_feg + 1) - 1 END IF k_step_2 = MAX(k_step_2, k_step_1) ! which should not be necessary (just for safety). k_step_2 = MIN(k_step_2, num_timesteps) ! to avoid subscript-out-of-range error in really short runs ! Note that these limits will be used below, when computing current_element_is_unfaulted() = T/F. ! read .feg x_feg = gridname_feg(current_feg) WRITE (*, "(' ', 8X, 'Reading ', A)") TRIM(x_feg) WRITE (21,"(8X, 'Reading ', A)") TRIM(x_feg) ! create filename with .vel extension IF (INDEX (x_feg, '.FEG') > 0) THEN j = INDEX (x_feg, '.FEG') x_vel = x_feg(1:j) // 'VEL' ELSE IF (INDEX (x_feg, '.feg') > 0) THEN j = INDEX (x_feg, '.feg') x_vel = x_feg(1:j) // 'vel' ELSE WRITE (*, "(' Error: No .FEG (or .feg) found with this filename'/' ',A)") TRIM(x_feg) WRITE (21,"('Error: No .FEG (or .feg) found with this filename'/A)") TRIM(x_feg) CALL Pause() STOP END IF OPEN (UNIT = 11, FILE = x_feg, STATUS = 'OLD', ACTION = 'READ', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL File_not_found(x_feg) READ (11, *) ! skip title READ (11, *) num_nod, nRealN, nFakeN, n1000, feg_brief nDOF = 2 * num_nod line = 2 IF (ALLOCATED (xyz_nod)) THEN DEALLOCATE (xyz_nod) DEALLOCATE (xyz_nod_premove) DEALLOCATE (lookAhead_xyz_nod) DEALLOCATE (eqcm) DEALLOCATE (nodal_area_strainrate) DEALLOCATE (vw0, vw1, vw_add, vw_mean) DEALLOCATE (u_flag) ELSE CALL More_mem ('xyz_nod', 1.0D0 * 3 * num_nod * bytes_per_real) CALL More_mem ('xyz_nod_premove', 1.0D0 * 3 * num_nod * bytes_per_real) CALL More_mem ('lookAhead_xyz_nod', 1.0D0 * 3 * num_nod * bytes_per_real) CALL More_mem ('eqcm', 1.0D0 * 4 * num_nod * bytes_per_real) CALL More_mem ('nodal_area_strainrate', 1.0D0 * num_nod * bytes_per_real) CALL More_mem ('vw0', 1.0D0 * nDOF * bytes_per_real) CALL More_mem ('vw1', 1.0D0 * nDOF * bytes_per_real) CALL More_mem ('vw_add', 1.0D0 * nDOF * bytes_per_real) CALL More_mem ('vw_mean', 1.0D0 * nDOF * bytes_per_real) CALL More_mem ('u-flag', 1.0D0 * nDOF * bytes_per_real) ENDIF ALLOCATE ( xyz_nod(3, num_nod) ) ALLOCATE ( xyz_nod_premove(3, num_nod) ) ALLOCATE ( lookAhead_xyz_nod(3, num_nod) ) ALLOCATE ( eqcm(4, num_nod) ) ALLOCATE ( nodal_area_strainrate(num_nod) ) ALLOCATE ( vw0(nDOF) ) ALLOCATE ( vw1(nDOF) ) ALLOCATE ( vw_add(nDOF) ) ALLOCATE ( vw_mean(nDOF) ) ALLOCATE ( u_flag(nDOF) ) ! If there is any chance, check for nodes lying on fault traces! check_if = (f_rst_count > 0) IF (check_if) THEN WRITE (*, "(' ',8X,'Checking that no node lies on any fault trace')") WRITE (21,"(8X,'Checking that no node lies on any fault trace')") num_bad = 0 END IF DO i = 1, num_nod line = line + 1 n_to_get = 7 CALL ReadN (11, 21, n_to_get, vector) i1 = NINT(vector(1)) IF ((i1 < 1).OR.(i1 > num_nod)) CALL Check_range('x_feg',line) x1 = vector(2) x2 = vector(3) CALL Xyz_from_lonlat(x1, x2, tv) xyz_nod(1:3, i1) = tv eqcm(1, i1) = vector(4) eqcm(2, i1) = vector(5) eqcm(3, i1) = vector(6) eqcm(4, i1) = vector(7) IF (check_if) THEN DO k = 1, f_highest j1 = trace_loc(1, k) j2 = trace_loc(2, k) IF (j2 > j1) THEN vec1 = trace(1:3, j1) DO j = j1 + 1, j2 vec2 = trace(1:3, j) CALL Cross(vec1, vec2, tv) CALL Unitise(tv, pole) tv = xyz_nod(1:3,i1) IF (ABS(Dot_3D(pole, tv)) < floor) THEN t1 = Arc_distance(tv, vec1) t2 = Arc_distance(tv, vec2) t3 = Arc_distance(vec1, vec2) IF ((t1 <= t3) .AND. (t2 <= t3)) THEN num_bad = num_bad + 1 WRITE (*, "(' Error: Node ',I6,' lies on trace F',I4)") i1, k WRITE (21,"('Error: Node ',I6,' lies on trace F',I4)") i1, k END IF END IF vec1 = vec2 END DO END IF END DO END IF ! necessary to check for node on a fault trace END DO ! i = 1, num_nod IF (check_if .AND. (num_bad > 0)) THEN WRITE (*, "(' ERROR: Node(s) exactly on fault trace(s); num_bad = ', I6)") num_bad WRITE (21, "('ERROR: Node(s) exactly on fault trace(s); num_bad = ', I6)") num_bad CALL Pause() STOP END IF READ (11, *) num_ele; line = line + 1 IF (ALLOCATED (node)) THEN DEALLOCATE (node) DEALLOCATE (mu_element) DEALLOCATE (mu_switch) DEALLOCATE (a_) DEALLOCATE (crack_index) DEALLOCATE (major_fault_element) IF (ALLOCATED (ele_stressed)) THEN DEALLOCATE (ele_stressed) DEALLOCATE (ele_azim) DEALLOCATE (ele_q) DEALLOCATE (ele_sigma) DEALLOCATE (ele_strainrate) DEALLOCATE (boxed) DEALLOCATE (edge_element) DEALLOCATE (edge_question) END IF ELSE CALL More_mem ('node', 1.0D0 * 3* num_ele * bytes_per_int) CALL More_mem ('mu_element', 1.0D0 * 2 * num_ele * bytes_per_real) CALL More_mem ('mu_switch', 1.0D0 * num_ele * bytes_per_real) CALL More_mem ('a_', 1.0D0 * num_ele * bytes_per_real) CALL More_mem ('crack_index', 1.0D0 * 2 * num_ele * bytes_per_int) CALL More_mem ('major_fault_element', 1.0D0 * num_ele) IF (stress_ever) THEN CALL More_mem ('ele_azim', 1.0D0 * num_ele * bytes_per_real) CALL More_mem ('ele_q', 1.0D0 * num_ele * bytes_per_real) CALL More_mem ('ele_sigma', 1.0D0 * num_ele * bytes_per_real) CALL More_mem ('ele_stressed', 1.0D0 * num_ele) CALL More_mem ('ele_strainrate', 1.0D0 * 3 * num_ele * bytes_per_real) CALL More_mem ('boxed', 1.0D0 * num_ele) END IF IF (paleotec) CALL More_mem ('current_element_is_unfaulted', 1.0D0 * num_ele * 1) CALL More_mem ('edge_element', 1.0D0 * num_ele) CALL More_mem ('edge_question', 1.0D0 * num_ele) END IF ALLOCATE ( node(3, num_ele) ) ALLOCATE ( mu_element(2, num_ele) ) ALLOCATE ( mu_switch(num_ele) ) ALLOCATE ( a_(num_ele) ) ALLOCATE ( crack_index(2, num_ele) ) ALLOCATE ( major_fault_element(num_ele) ) major_fault_element = .FALSE. ! To cover cases where: neotec, and/or no faults are in use. ! For typical (paleotec, w/faults) cases, more accurate assessments follow below, where some will become .TRUE. IF (stress_ever) THEN ALLOCATE ( ele_azim(num_ele) ) ALLOCATE ( ele_q(num_ele) ) ALLOCATE ( ele_sigma(num_ele) ) ALLOCATE ( ele_stressed(num_ele) ) ALLOCATE ( ele_strainrate(3, num_ele) ) ALLOCATE ( boxed(num_ele) ) END IF IF (paleotec) THEN IF (ALLOCATED(current_element_is_unfaulted)) DEALLOCATE(current_element_is_unfaulted) ALLOCATE ( current_element_is_unfaulted(0:num_ele) ) !N.B. Starting the subscript at 0 prevents a subscript-out-of-range error when any node of the before.FEG falls outside the currently-loaded FEG. current_element_is_unfaulted = .TRUE. ! Just the default; those elements containing active fault segments will get negated later, after segmentation is known. END IF ALLOCATE ( edge_element(num_ele) ) edge_element = .FALSE. !typical case; a few will be set .TRUE. later ALLOCATE ( edge_question(num_ele) ) ! both initialized, and used, in Find_s1s2s3 DO l_ = 1, num_ele !Use ReadN in case .feg file is old and does not have ! element data following each element definition: n_to_get = 7 CALL ReadN (11, 21, n_to_get, vector) j = NINT(vector(1)) j1 = NINT(vector(2)) j2 = NINT(vector(3)) j3 = NINT(vector(4)) t1 = vector(5) t2 = vector(6) t3 = vector(7) IF ((j < 1).OR.(j > num_ele).OR.(j1 < 1).OR.(j1 > num_nod) & & .OR.(j2 < 1).OR.(j2 > num_nod) & & .OR.(j3 < 1).OR.(j3 > num_nod))& & CALL Check_range('x_feg',line) node(1:3,j) = (/ j1, j2, j3 /) IF (t1 == 0.0D0) t1 = mu_ ! use default strain-rate uncertainty to replace zero IF (t2 == 0.0D0) t2 = 9999.9D0 ! replace zero age (in Ma) with a # greater than age of our solar system IF (t3 == 0.0D0) t3 = t1 ! N.B. Net effect of these lines is that "1.0E-15 {followed by blanks}" becomes "1.0E-15 9999.9 1.0E-15". IF (t1 <= 0.0D0) CALL Prevent ('nonpositive mu_', line, x_feg) IF (t3 <= 0.0D0) CALL Prevent ('nonpositive mu_', line, x_feg) IF (t1 < SQRT(1.1D0 * TINY(mu_))) CALL Prevent ('mu_**2 will underflow!', line, x_feg) IF (t3 < SQRT(1.1D0 * TINY(mu_))) CALL Prevent ('mu_**2 will underflow!', line, x_feg) IF (t1 > 1.D-10) CALL Prevent ('unreasonably large mu_', line, x_feg) IF (t3 > 1.D-10) CALL Prevent ('unreasonably large mu_', line, x_feg) mu_element(1, j) = t1 !store away these 3 values (after the pre-screening in lines above) mu_switch(j) = t2 * s_per_Ma mu_element(2, j) = t3 END DO CLOSE (11) ! close x_feg ! Create arrays needed to print "after.feg", ! and also to begin integrating "before.feg" node positions and data IF (paleotec) THEN !(otherwise, no use for "before" and "after" arrays) IF (.NOT.changed_horses) THEN ! Note that current_feg == 1 before_and_after_numnod = 3 * num_ele ! (to allow for duplicating and then splitting nodes and displacing them toward element centers) before_and_after_numel = num_ele IF (iteration == 1) THEN CALL More_mem ('after_node_uvec', 1.0D0 * 3 * num_nod * bytes_per_real) CALL More_mem ('before_node_uvec', 1.0D0 * 3 * num_nod * bytes_per_real) CALL More_mem ('before_node_is', 1.0D0 * num_nod * bytes_per_is) CALL More_mem ('after_eqcm', 1.0D0 * 4 * num_nod * bytes_per_real) CALL More_mem ('before_eqcm', 1.0D0 * 4 * num_nod * bytes_per_real) CALL More_mem ('before_and_after_node', 1.0D0 * 3 * num_ele * bytes_per_int) CALL More_mem ('before_and_after_unfaulted', 1.0D0 * num_ele * 1) CALL More_mem ('timestep_first_faulted', 1.0D0 * num_ele * bytes_per_int) CALL More_mem ('before_FEG_midpoint_current_l_', 1.0D0 * num_ele * bytes_per_int) ALLOCATE ( after_node_uvec(3, before_and_after_numnod) ) ALLOCATE ( before_node_uvec(3, before_and_after_numnod) ) ALLOCATE ( before_node_is(before_and_after_numnod) ) before_node_is(1:before_and_after_numnod)%element = 1 ! because '0' has special meaning to Internal ALLOCATE ( after_eqcm(4, before_and_after_numnod) ) ALLOCATE ( before_eqcm(4, before_and_after_numnod) ) ALLOCATE ( before_and_after_node(3, before_and_after_numel) ) ALLOCATE ( before_and_after_unfaulted(before_and_after_numel) ) ALLOCATE ( timestep_first_faulted(before_and_after_numel) ) ALLOCATE ( before_FEG_midpoint_current_l_(before_and_after_numel) ) END IF ! iteration == 1 split_node_count = 0 ! will increase quickly, up to before_and_after_numnod = 3 * num_ele !----------------------------------------------------------------------------------------------- before_and_after_sizing = 0.8D0 ! relative to upper limit of 1.0D0; suggested minimum is ~0.5D0. !----------------------------------------------------------------------------------------------- DO i = 1, num_ele !Get old node numbers: n1 = node(1, i) n2 = node(2, i) n3 = node(3, i) !Locate element center: uvec(1:3) = xyz_nod(1:3, n1) + xyz_nod(1:3, n2) + xyz_nod(1:3, n3) CALL DMake_Uvec(uvec, uvec) !Create new corner nodes: n1 is shifted and duplicated: uvec1(1:3) = uvec(1:3) + before_and_after_sizing * (xyz_nod(1:3, n1) - uvec(1:3)) CALL DMake_Uvec(uvec1, uvec1) split_node_count = split_node_count + 1 after_node_uvec(1:3, split_node_count) = uvec1(1:3) before_node_uvec(1:3, split_node_count) = uvec1(1:3) after_eqcm(1:4, split_node_count) = eqcm(1:4, n1) before_eqcm(1:4, split_node_count) = eqcm(1:4, n1) before_and_after_node(1, i) = split_node_count !Create new corner nodes: n2 is shifted and duplicated: uvec2(1:3) = uvec(1:3) + before_and_after_sizing * (xyz_nod(1:3, n2) - uvec(1:3)) CALL DMake_Uvec(uvec2, uvec2) split_node_count = split_node_count + 1 after_node_uvec(1:3, split_node_count) = uvec2(1:3) before_node_uvec(1:3, split_node_count) = uvec2(1:3) after_eqcm(1:4, split_node_count) = eqcm(1:4, n2) before_eqcm(1:4, split_node_count) = eqcm(1:4, n2) before_and_after_node(2, i) = split_node_count !Create new corner nodes: n3 is shifted and duplicated: uvec3(1:3) = uvec(1:3) + before_and_after_sizing * (xyz_nod(1:3, n3) - uvec(1:3)) CALL DMake_Uvec(uvec3, uvec3) split_node_count = split_node_count + 1 after_node_uvec(1:3, split_node_count) = uvec3(1:3) before_node_uvec(1:3, split_node_count) = uvec3(1:3) after_eqcm(1:4, split_node_count) = eqcm(1:4, n3) before_eqcm(1:4, split_node_count) = eqcm(1:4, n3) before_and_after_node(3, i) = split_node_count END DO ! i = 1, num_ele before_and_after_unfaulted = .TRUE. ! whole array; elements with faults will be negated later, when segmentation has been computed timestep_first_faulted = 9999 ! whole array; this value should persist if before_and_after_unfaulted(ele) = .TRUE. at end of run. END IF ! need to record "after.feg" into arrays, and initialize before.feg arrays END IF ! paleotec (otherwise, no need for "before" and "after" arrays) ! read .bcs WRITE (*, "(' ', 8X, 'Reading ', A)") TRIM(gridname_bcs(current_feg)) WRITE (21,"(8X, 'Reading ', A)") TRIM(gridname_bcs(current_feg)) OPEN (UNIT = 12, FILE = gridname_bcs(current_feg), STATUS = 'OLD', ACTION = 'READ', PAD = 'YES', IOSTAT = ios) IF (ios /= 0) CALL File_not_found(gridname_bcs(current_feg)) bcs_count = 0 DO READ (12, *, IOSTAT = read_status) j, r1, r2 IF (read_status /= 0) EXIT bcs_count = bcs_count + 1 END DO IF (bcs_count < 2) THEN WRITE (*, "(' Error: Provide at least 2 fixed boundary nodes in ',A)") & & TRIM(gridname_bcs(current_feg)) WRITE (21,"(' Error: Provide at least 2 fixed boundary nodes in ',A)") & & TRIM(gridname_bcs(current_feg)) CALL Pause() STOP END IF IF (ALLOCATED (boundary_node)) THEN DEALLOCATE (boundary_node) DEALLOCATE (condition) ELSE CALL More_mem('boundary_node', 1.0D0 * bcs_count * bytes_per_int) CALL More_mem('condition', 1.0D0 * 2 * bcs_count * bytes_per_real) END IF ALLOCATE ( boundary_node(bcs_count) ) ALLOCATE ( condition(2, bcs_count) ) REWIND (12); line = 0 DO i = 1, bcs_count READ (12,*) j, r1, r2; line = line + 1 IF ((j < 1).OR.(j > num_nod)) CALL Check_range(gridname_bcs(current_feg),line) boundary_node(i) = j condition(1:2, i) = (/ r1, r2 /) END DO CLOSE (12) ! close x.bcs CALL Plane_area (folding) !? IF (folding) THEN WRITE (*, "(' ',8X,'This grid, just read, is ALREADY folded! Edit it with OrbWin/OrbNumber.')") WRITE (21, "(8X,'This grid, just read, is ALREADY folded! Edit it with OrbWin/OrbNumber.')") CALL Pause() STOP END IF IF (ALLOCATED(neighbor)) THEN DEALLOCATE(neighbor) DEALLOCATE(center) ELSE CALL More_mem('neighbor', 1.0D0 * 3 * num_ele * bytes_per_int) CALL More_mem('center', 1.0D0 * 3 * num_ele * bytes_per_real) END IF ALLOCATE ( neighbor(3, num_ele) ) ALLOCATE ( center(3, num_ele) ) IF ((f_dig_count + f_rst_count + c_rst_count + p_rst_count + s_rst_count + basemap_object_count) > 0) THEN WRITE (*, "(' ', 8X, 'Finding all data locations in grid coordinates')") WRITE (21,"(8X, 'Finding all data locations in grid coordinates')") END IF CALL Find_s1s2s3 ! Computes internal coordinates for all uvecs that will move across time. !ALSO DEFINES THESE ARRAYS: center, neighbor, edge_element, and (IF faults are in-use) trace_is; negates(?) f_2_in. IF ((f_dig_count + f_rst_count + c_rst_count + p_rst_count + s_rst_count + basemap_object_count) > 0) THEN ! count number of data actually in play f_in_time_and_space = 0 DO i = 1, f_rst_count IF (f_2_in(which_trace(i))) THEN any_action = .FALSE. DO j = 1, num_timesteps any_action = any_action .OR. f_active(j,i) END DO IF (any_action) f_in_time_and_space = f_in_time_and_space + 1 END IF END DO c_in_time_and_space = 0 DO i = 1, c_rst_count IF ((c_end_is(1,i)%element > 0).AND.(c_end_is(2,i)%element > 0)) THEN any_action = .FALSE. DO j = 1, num_timesteps any_action = any_action .OR. c_active(j,i) END DO IF (any_action) c_in_time_and_space = c_in_time_and_space + 1 END IF END DO p_in_time_and_space = 0 DO i = 1, p_rst_count IF (p_site_is(i)%element > 0) THEN any_action = .FALSE. DO j = 1, num_timesteps any_action = any_action .OR. p_active(j,i) END DO IF (any_action) p_in_time_and_space = p_in_time_and_space + 1 END IF END DO ELSE ! there are NO input data that require internal coordinates f_in_time_and_space = 0 c_in_time_and_space = 0 p_in_time_and_space = 0 END IF ! there is any data needing internal coordinates ! find Delta_node_feg = half-bandwidth, expressed in nodes (2 dof each) Delta_node_feg = 0 DO i = 1, num_ele i1 = node(1, i) i2 = node(2, i) i3 = node(3, i) j1 = MIN(i1, i2, i3) j3 = MAX(i1, i2, i3) Delta_node_feg = MAX(Delta_node_feg, j3 - j1) END DO ELSE ! get_feg = F WRITE (*, "(' ',8X,'Using same finite-element grid again: deformed ', A)") TRIM(gridname_feg(current_feg)) WRITE (21,"(8X,'Using same finite-element grid again: deformed ', A)") TRIM(gridname_feg(current_feg)) got_new_FEG_this_timestep = .FALSE. END IF ! (get_feg, or not) !Survey and then store fault segments. !Notes: Uses arrays "center", "neighbor", ! and "trace_is" defined in Find_s1s2s3. ! Although repeated below (for the corrector), ! cannot be moved to a SUBR because it uses dynamic ! memory. Cannot be moved outside timestepping loop ! because strike-slip faults change their segments ! whenever they are smoothed! IF (f_rst_count > 0) THEN IF (seg_count_doubled < 0) THEN ! not yet initialized; do it! CALL Def_seg_v2 (seg_count = seg_count, savem = .FALSE.) seg_count_doubled = 2 * seg_count ! allowing space for minor changes, without having to count twice each time. END IF IF (seg_count > 0) THEN IF (.NOT.ALLOCATED(seg_def)) THEN CALL More_mem('seg_def', 1.0D0 * 2 * seg_count_doubled * bytes_per_int) CALL More_mem('seg_end', 1.0D0 * 3 * 2 * seg_count_doubled * bytes_per_real) CALL More_mem('seg_end_is', 1.0D0 * 2 * seg_count_doubled * bytes_per_is) CALL More_mem('seg_eta_', 1.0D0 * seg_count_doubled * bytes_per_real) CALL More_mem('seg_kappa_', 1.0D0 * seg_count_doubled * bytes_per_real) CALL More_mem('seg_u_', 1.0D0 * seg_count_doubled * bytes_per_int) ALLOCATE( seg_def(2, seg_count_doubled) ) ALLOCATE( seg_end(1:3, 2, seg_count_doubled) ) ALLOCATE( seg_end_is(2, seg_count_doubled) ) seg_end_is(1:2, 1:seg_count_doubled)%element = 1 ! because '0' has special meaning to Internal ALLOCATE( seg_eta_(seg_count_doubled) ) ALLOCATE( seg_kappa_(seg_count_doubled) ) ALLOCATE( seg_u_(seg_count_doubled) ) END IF CALL Def_seg_v2 (seg_count = seg_count, savem = .TRUE.) CALL Coordinate_Segments() ! improvement added in Spring 2020. CALL Unpin_Plate_Corners() ! improvement added 2020.07.01 IF (paleotec) THEN ! (otherwise, no need for "before.FEG" and "after.FEG", and thus no need for "current_element_is_unfaulted") ! Decide whether each element (of the currently-loaded, temporary FEG) has any active faulting ! during the "chapter" of geologic time in which this grid is used? ! (To decide this, we use the logical matrix trace_active and the chapter time-limits from the loading-plan.) DO i = 1, seg_count trace_of_this_seg = seg_def(1, i) this_seg_slips_this_chapter = .FALSE. ! just initializing before loop below, which will often change it to .TRUE. DO k = k_step_1, k_step_2 ! using time-step indices previously computed above, for the whole currently-loaded FEG. IF (trace_active(k, trace_of_this_seg)) this_seg_slips_this_chapter = .TRUE. END DO IF (this_seg_slips_this_chapter) THEN current_element_is_unfaulted(seg_def(2, i)) = .FALSE. ! Replacing previous, default initialization of .TRUE. ! Note that values of this array only become meaningful AFTER this DO-loop. END IF END DO ! i = 1, seg_count CALL Update_before_FEG() ! which depends, critically, on the array current_element_is_unfaulted, just filled-in above. END IF ! paleotec END IF ! seg_count > 0 END IF ! f_rst_count > 0 ! Set certain values in LOGICAL*1 :: major_fault_element(:) to .TRUE. (based on related array major_fault(:) == .TRUE.); ! then use this array to mark certain basemap/geologic-map points for deletion: IF (paleotec .AND. (f_dig_count > 0)) THEN DO i = 1, seg_count trace_of_this_seg = seg_def(1, i) IF (major_fault(trace_of_this_seg)) THEN major_fault_element(seg_def(2, i)) = .TRUE. ! Replacing previous, default initialization of .FALSE. ! Note that values of this array only become meaningful AFTER this DO-loop. END IF END DO ! i = 1, seg_count !Now, mark all basemap/geologic-map points in these elements for (later) deletion from basemap, !by setting their basemap_point_is(:)%element = 0 IF (basemap_object_count > 0) THEN DO i = 1, basemap_point_count l_ = basemap_point_is(i)%element IF (l_ > 0) THEN ! can look-up nature of enclosing element, so: IF (major_fault_element(l_)) basemap_point_is(i)%element = 0 ! marked for later deletion/compaction/non-Write; see Compact_Basemap(). END IF END DO ! i = 1, basemap_point_count END IF ! basemap or geologic-map is in use END IF ! (paleotec .AND. (f_dig_count > 0)); paleotec; AND faults are in use IF (paleotec .AND. (basemap_object_count > 0)) THEN CALL Compact_Basemap() ! To actually compact-out points deleted above (plus others that wandered outside area of the current FEG). END IF ! basemap needs to be compacted ! Now that faults have internal coordinates and segments and f_2_in computed, DEFINE plateward_dAzimuth for any faults that need it: IF (f_dig_count > 0) THEN ! faults are in use IF (any_spreading) THEN ! initialize values in plateward_dAzimuth for any trace points ! with the "symmetric_spreading_system" attribute, which ! implies translation_method() == 2. WRITE (*, "(' ',12X,'Computing plateward_dAzimuth...')") WRITE (21,"(12X,'Computing plateward_dAzimuth')") DO f = 1, f_highest ! considering all faults IF (f_2_in(f)) THEN ! don't bother about faults that are outside the FEG area a = trace_loc(1, f) ! limiting indices in "trace" and b = trace_loc(2, f) ! in "trace_is", and in translation_method IF ((translation_method(a) == 2).OR.(translation_method(b) == 2)) THEN ! assign plateward_dAzimuth if EITHER end has symmetric_spreading_system attribute! home_sense_c1 = f_dig_faultName_lines(f)(6:6) ! offset sense byte for the primary fault (D, L, R, or maybe d, l, r ?) !FIRST, find plateward_dAzimuth for both ends of any trace with (any) symmetric_spreading_system attribute: DO i = a, b, (b-a) ! for each ENDPOINT of this trace... !Search for ends of other connecting faults at same location: tv(1:3) = trace(1:3, i) ! end-uvec of the primary fault nearest_radians = Pi ! "very large"; will be reduced during search nearest_f2 = 0 ! undefined, for now... DO f2 = 1, f_highest IF (f_2_in(f2)) THEN ! only consider possible matching faults that are in the FEG area a2 = trace_loc(1, f2) ! limiting indices in "trace" and b2 = trace_loc(2, f2) ! in "trace_is", and in translation_method IF ((f2 /= f).AND.((translation_method(a2) == 2).OR.(translation_method(b2) == 2))) THEN ! eligible for comparison of position DO j = a2, b2, (b2-a2) ! consider both ends tv_j(1:3) = trace(1:3, j) arc_radians = Arc_distance(tv, tv_j) IF (arc_radians < nearest_radians) THEN ! replace current "best match" nearest_f2 = f2 nearest_radians = arc_radians END IF ! new "best match" found END DO ! j = a2, b2, (b2-a2); considering both ends of possible companion fault END IF ! possible companion fault-end is eligible for comparison END IF ! f_2_in(f2) END DO ! f2 = 1, f_highest ; considering all potential companion faults IF (nearest_radians <= 0.001D0) THEN ! only a "match is distance is less than 6.371 km memo_c1 = f_dig_faultName_lines(nearest_f2)(6:6) ! expected to be one of: D, L, R (or maybe d, l, r ?) ELSE ! no nearby match was found memo_c1 = '0' ! indicating no connection to other symmetric_spreading_system faults END IF ! found a close match, or not !N.B. All that hard searching work above was just to get the value of memo_c1 ! Now, USE it... IF ((home_sense_c1 == 'D').OR.(home_sense_c1 == 'd')) THEN ! primary fault is a spreading ridge IF ((memo_c1 == 'D').OR.(memo_c1 == 'd')) THEN ! secondary fault is a spreading ridge plateward_dAzimuth(i) = 0.50D0 * Pi ! +90 degrees ELSE IF ((memo_c1 == 'R').OR.(memo_c1 == 'r')) THEN ! secondary fault is a dextral transform plateward_dAzimuth(i) = 0.25D0 * Pi ! +45 degrees ELSE IF ((memo_c1 == 'L').OR.(memo_c1 == 'l')) THEN ! secondary fault is a sinistral transform plateward_dAzimuth(i) = 0.75D0 * Pi ! +135 degrees ELSE IF (memo_c1 == '0') THEN ! no connection was found (i.e., near edge of FEG domain) plateward_dAzimuth(i) = 0.50D0 * Pi ! +90 degrees END IF ! different cases for secondary fault (D, R, L, or no-connection) ELSE IF ((home_sense_c1 == 'R').OR.(home_sense_c1 == 'r')) THEN ! primary fault is dextral transform IF ((memo_c1 == 'D').OR.(memo_c1 == 'd')) THEN ! secondary fault is a spreading ridge plateward_dAzimuth(i) = 0.75D0 * Pi ! +135 degrees ELSE IF ((memo_c1 == 'R').OR.(memo_c1 == 'r')) THEN ! secondary fault is a dextral transform plateward_dAzimuth(i) = 0.50D0 * Pi ! +90 degrees ELSE IF ((memo_c1 == 'L').OR.(memo_c1 == 'l')) THEN ! secondary fault is a sinistral transform WRITE (*, "(' ERROR: Dextral F',I4,'R couples tightly to sinistral F',I4,'L.')") f, f2 WRITE (21, "('ERROR: Dextral F',I4,'R couples tightly to sinistral F',I4,'L.')") f, f2 CALL Pause() STOP ELSE IF (memo_c1 == '0') THEN ! no connection was found (i.e., near edge of FEG domain) plateward_dAzimuth(i) = 0.50D0 * Pi ! +90 degrees END IF ! different cases for secondary fault (D, R, L, or no-connection) ELSE IF ((home_sense_c1 == 'L').OR.(home_sense_c1 == 'l')) THEN ! primary fault is sinistral transform IF ((memo_c1 == 'D').OR.(memo_c1 == 'd')) THEN ! secondary fault is a spreading ridge plateward_dAzimuth(i) = 0.25D0 * Pi ! +45 degrees ELSE IF ((memo_c1 == 'R').OR.(memo_c1 == 'r')) THEN ! secondary fault is a dextral transform WRITE (*, "(' ERROR: Sinistral F',I4,'L couples tightly to dextral F',I4,'D.')") f, f2 WRITE (21, "('ERROR: Sinistral F',I4,'L couples tightly to dextral F',I4,'D.')") f, f2 CALL Pause() STOP ELSE IF ((memo_c1 == 'L').OR.(memo_c1 == 'l')) THEN ! secondary fault is a sinistral transform plateward_dAzimuth(i) = 0.50D0 * Pi ! +90 degrees ELSE IF (memo_c1 == '0') THEN ! no connection was found (i.e., near edge of FEG domain) plateward_dAzimuth(i) = 0.50D0 * Pi ! +90 degrees END IF ! different cases for secondary fault (D, R, L, or no-connection) END IF ! different cases for the primary fault (D, R, L) END DO ! i = a, b, (b-a) ; for each ENDPOINT of this primary trace... !SECOND, interpolate plateward_dAzimuth to any interior digitization points(?) IF ((b-a) > 1) THEN ! there are internal digitization points along the primary fault DO i = (a+1), (b-1) s = (1.0D0 * i - a) / (b - a) ! 0 < s < 1; internal digitization-progress variable plateward_dAzimuth(i) = plateward_dAzimuth(a) + (plateward_dAzimuth(b) - plateward_dAzimuth(a)) * s END DO END IF ! interpolation is needed along the primary trace END IF ! EITHER end of this fault has translation_method == 2 END IF ! f_2_in(f); don't bother about any faults outside the FEG area END DO ! f = 1, f_highest END IF ! any_spreading END IF ! f_dig_count > 0; faults are in use ! Count cracks (~active fault segments), both total and by element. ! Note: A crack is not exactly an active segment; the same segment ! may be used for more than one crack when two or more offset data have ! contiguous time windows both falling into this timestep. ! Also, fault offset may have both strike-slip and dip-slip components, on the same segment at the same time. ! For placement of this block, see comments above regarding the need to RE-define fault segments very frequently! crack_count = 0 crack_index = 0 ! whole array IF (f_rst_count > 0) THEN DO i = 1, f_rst_count IF (f_active(n_, i)) THEN ! datum is active k = which_trace(i) ! trace index j1 = trace_loc(3, k) ! 1st segment of trace j2 = trace_loc(4, k) ! last segment of trace IF (j1 > 0) THEN ! at least one segment exists DO j = j1, j2 IF ((seg_end(1,1,j) /= seg_end(1,2,j)) .OR. & & (seg_end(2,1,j) /= seg_end(2,2,j)) .OR. & & (seg_end(3,1,j) /= seg_end(3,2,j))) THEN ! only count positive-length segments; ignore any zero-length segments crack_count = crack_count + 1 l_ = seg_def(2, j) ! element number crack_index(1, l_) = crack_index(1, l_) + 1 END IF ! not a zero-length segment END DO ! segments in trace END IF ! at least one segment exists END IF ! active END DO ! i = 1, f_rst_count IF (crack_count > 0) THEN ! Decide initial storage positions for local cracks in each element crack_index(2, 1) = 1 DO l_ = 2, num_ele crack_index(2, l_) = crack_index(2, l_ - 1) + crack_index(1, l_ - 1) END DO DO l_ = 1, num_ele IF (crack_index(1, l_) == 0) crack_index(2, l_) = 0 ! clear warning END DO ! allocate local crack storage IF (ALLOCATED(local_crack)) THEN DEALLOCATE (local_crack) ELSE CALL More_mem('local_crack', 1.0D0 * crack_count * bytes_per_crack) END IF ALLOCATE ( local_crack(crack_count) ) ! reset counts to 0 in each element so they can be used to keep track of open spots DO l_ = 1, num_ele crack_index(1, l_) = 0 END DO DO i = 1, f_rst_count ! offset datum index IF (f_active(n_, i)) THEN ! datum is active k = which_trace(i) ! trace index j1 = trace_loc(3, k) ! 1st segment of trace j2 = trace_loc(4, k) ! last segment of trace IF (j1 > 0) THEN ! at least one segment exists DO j = j1, j2 ! segment index IF ((seg_end(1,1,j) /= seg_end(1,2,j)) .OR. & & (seg_end(2,1,j) /= seg_end(2,2,j)) .OR. & & (seg_end(3,1,j) /= seg_end(3,2,j))) THEN ! ignore any zero-length null segments (?) l_ = seg_def(2, j) ! element number k = crack_index(2, l_) + crack_index(1, l_) !storage location crack_index(1, l_) = crack_index(1, l_) + 1 !bump up count local_crack(k)%datum = i ! to refer back when we have p_ local_crack(k)%segment = j ! to access changing length, azimuth, ! eta_, kappa_, u_, ... local_crack(k)%sense = sense(i) ! T, P, N, R, L, D IF (sense(i) == 'T') THEN IF (f_dip_degrees(which_trace(i)) == 0.0D0) THEN !No value was set in the f_dig file; use generic dip: factor = -cot_thrust_dip ELSE ! use value set in the f_dig file: factor = -1.0D0 / TAN(MIN(80.0D0, f_dip_degrees(which_trace(i))) * radians_per_degree) END IF ELSE IF (sense(i) == 'P') THEN factor = -1.0D0 ELSE IF (sense(i) == 'N') THEN IF (f_dip_degrees(which_trace(i)) == 0.0D0) THEN !No value was set in the f_dig file; use generic dip: factor = cot_normal_dip ELSE ! use value set in the f_dig file: factor = 1.0D0 / TAN(MIN(80.0D0, f_dip_degrees(which_trace(i))) * radians_per_degree) END IF ELSE IF (sense(i) == 'D') THEN factor = 1.0D0 ELSE IF (sense(i) == 'R') THEN factor = 1.0D0 ELSE IF (sense(i) == 'L') THEN factor = -1.0D0 ELSE ! should not happen! CALL Prevent ('illegal slip sense', i, 'array "sense"') ENDIF local_crack(k)%s_ = factor * f_goal(n_, i) local_crack(k)%sigma_ = ABS(factor) * f_goal_sigma_(i) END IF ! non-null segment END DO ! segments in trace END IF ! at least one segment exists END IF ! goal is not zero END DO ! i = 1, f_rst_count END IF ! crack_count > 0 END IF ! f_rst_count > 0 ! Check for paleomag. data sharing elements w/ active s-s faults. IF (p_rst_count > 0) THEN IF (seg_count > 0) THEN WRITE (*, "(' ',8X,'Checking for paleomag data in same element as strike-slip fault(s)')") WRITE (21,"(8X,'Checking for paleomag data in same element as strike-slip fault(s)')") num_bad = 0 check_ps: DO i = 1, p_rst_count IF (time0 < p_t_max(i)) THEN ! sharing an element w/ s-s would twist datum DO j = 1, seg_count k = seg_def(1,j) ! fault trace # l_ = seg_def(2,j) ! element # IF (p_site_is(i)%element == l_) THEN DO m = 1, f_rst_count IF (which_trace(m) == k) THEN ! segment has rate info IF ((sense(m) == 'R').OR.(sense(m) == 'L')) THEN IF ((f_t_min(m) < p_t_max(i)).AND.(f_t_max(m) > time0)) THEN num_bad = num_bad + 1 twisted(i) = .TRUE. tv = p_site_0(1:3,i) CALL Lonlat_from_xyz (tv, x1, x2) WRITE (c4,"(I4)") k DO j2 = 1,3 IF (c4(j2:j2) == ' ') c4(j2:j2) = '0' END DO WRITE (*, "(30X, ' WARNING: Paleomag site ', A)") TRIM(p_ref(i)(1:24)) WRITE (*, "(30X, ' now at ', F7.2, 'E, ', F6.2, 'N is twisted by F', A4, A1)") x1, x2, c4, sense(m) WRITE (21,"(30X, 'WARNING: Paleomag site ', A)") TRIM(p_ref(i)) WRITE (21,"(30X, 'now at ', F7.2, 'E, ', F6.2, 'N is twisted by F', A4, A1)") x1, x2, c4, sense(m) CYCLE check_ps END IF ! windows overlap END IF ! strike-slip END IF ! segment has a rate END DO ! m = 1, f_rst_count END IF ! segment and site are in same element END DO ! j = 1, seg_count END IF ! time0 < p_t_max(i) END DO check_ps ! i = 1, p_rst_count IF (num_bad > 0) THEN WRITE (*, "(' ', 30X, 'Vertical-axis rotations at these sites not used.')") WRITE (21,"(30X, 'Vertical-axis rotations at these sites not used.')") END IF ! some were twisted END IF ! seg_count > 0 END IF ! p_rst_count > 0 ! determine how active X-sections might have changed bandwidth, ! and reallocate linear system arrays. Delta_node = Delta_node_feg IF (c_rst_count > 0) THEN scan_sections: DO i = 1, c_rst_count j1 = c_end_is(1, i)%element j2 = c_end_is(2, i)%element IF ((j1 * j2) == 0) CYCLE scan_sections ! Don't consider this section if EITHER end is outside grid domain. IF ((c_t_max(i) < time0) .OR. (c_t_min(i) > time1)) CYCLE scan_sections i1 = node(1, j1) i2 = node(2, j1) i3 = node(3, j1) i4 = node(1, j2) i5 = node(2, j2) i6 = node(3, j2) Delta_node = MAX(Delta_node, MAX(i1,i2,i3,i4,i5,i6) - MIN(i1,i2,i3,i4,i5,i6)) END DO scan_sections END IF ! c_rst_count > 0 IF ((Delta_node /= Delta_node_last).OR.(num_nod /= num_nod_last)) THEN ! this will be T on first pass, and also when the .FEG changes. Delta_node_last = Delta_node ! reset memory for next time num_nod_last = num_nod ! reset memory for next time WRITE (*, "(' ',8X,'Delta_node is ',I4)") Delta_node WRITE (21,"(8X,'Delta_node is ',I4)") Delta_node !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !Compute and store global descriptors of the banded linear system (in MKL banded-storage format): nRank = 2 * num_nod ! number of degrees of freedom in vector vw, computed in Solve_for_vw nCodiagonals = 2 * Delta_node + 1 nKRows = 3 * nCodiagonals + 1 ! per (rather inefficient) banded-storage convention of MKL iDiagonal = 2 * nCodiagonals + 1 ! row index where diagonal matrix elements are stored (in special band-storage format) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF (ALLOCATED (ABCD)) THEN DEALLOCATE (ABCD) ELSE CALL More_mem('ABCD matrix', 1.0D0 * nKRows * nRank * bytes_per_real) END IF ALLOCATE ( ABCD(nKRows, nRank) ) IF (ALLOCATED (EF)) THEN DEALLOCATE (EF) ELSE CALL More_mem('EF vector', 1.0D0 * nRank * 1 * bytes_per_real) END IF ALLOCATE ( EF(nRank, 1) ) IF (n_refine > 0) THEN IF (ALLOCATED (duplicate_ABCD)) THEN DEALLOCATE (duplicate_ABCD) ELSE CALL More_mem ('duplicate_ABCD matrix', 1.0D0 * nKRows * nRank * bytes_per_real) END IF ALLOCATE ( duplicate_ABCD(nKRows, nRank) ) IF (ALLOCATED (duplicate_EF)) THEN DEALLOCATE (duplicate_EF) ELSE CALL More_mem('duplicate_EF vector', 1.0D0 * nRank * 1 * bytes_per_real) END IF ALLOCATE ( duplicate_EF(nRank, 1) ) END IF END IF ! Delta_node or num_nod has changed? IF (paleotec) THEN t0 = time0 / s_per_Ma WRITE (*, "(' ',8X,'Solving for velocities at young end of timestep (',F6.2,' Ma)')") t0 WRITE (21,"(8X,'Solving for velocities at young end of timestep (',F6.2,' Ma)')") t0 ELSE ! neotec WRITE (*, "(' Solving for neotectonic velocities')") WRITE (21,"('Solving for neotectonic velocities')") END IF ! Is there any kind of stress-direction constraint in this timestep? stress_now = .FALSE. ! (initialization only) IF (s_rst_count > 0) THEN all_stresses: DO s = 1, s_rst_count IF (s_activity(n_, s) > 0.0D0) THEN stress_now = .TRUE. EXIT all_stresses END IF END DO all_stresses END IF ! s_rst_count > 0 IF (.NOT. stress_now) THEN IF (faults_give_sigma_1h) THEN IF (f_rst_count > 0) THEN all_faults: DO s = 1, f_rst_count IF (f_active(n_, s)) THEN stress_now = .TRUE. EXIT all_faults END IF END DO all_faults END IF END IF END IF IF (got_new_FEG_this_timestep) THEN vw0 = 0.0D0 ! No initial estimate is possible, because we just loaded a new FEG with different node numbers and positions! ELSE ! The FEG being used in this timestep is the same as we used in the previous timestep, so vw0 = vw1 ! node #s are unchanged, and velocity from end of previous timestep is a decent initial estimate. END IF IF (stress_now) THEN boxed = .FALSE. ! Whole array. Solve-for-vw can only turn some elements to TRUE. CALL Solve_for_vw (passes = (1 + n_refine), vw = vw0) !* < * PREDICTOR * < * * < * * ELSE ! (no stress constraints of any kind) CALL Solve_for_vw (passes = 1, vw = vw0) !* < * PREDICTOR * < * * < * * END IF IF (paleotec) THEN ! check for folding, move in predictor step, then recompute velocity at older end of timestep ! N.B. None of this is necessary IF(neotec). xyz_nod_premove = xyz_nod ! save for use within Move_data (to avoid s-s folding) ! move nodes in predictor and check for grid folding CALL Move_feg (vw = vw0) CALL Plane_area (folding) !? IF (folding) THEN WRITE (*, "(' ', 8X, 'ERROR: This grid FOLDED in predictor displacement step...')") WRITE (21,"(8X, 'ERROR: This grid FOLDED in predictor displacement step...')") IF (grid_to_load_this_timestep(n_) > 0) THEN ! we just loaded a fresh FEG! WRITE (*, "(' ERROR: Although a fresh FEG/BCS file-pair was just loaded,')") WRITE (*, "(' it could not survive even one timestep without folding.')") WRITE (*, "(' Provide valid .FEG and .BCS files and start from scratch.')") WRITE (*, "(' Or, reduce the size of the time step.')") WRITE (*, "(' Or, reduce the scale sigma(s) used in early time steps.')") WRITE (21, "('ERROR: Although a fresh FEG/BCS file-pair was just loaded,')") WRITE (21, "(' it could not survive even one timestep without folding.')") WRITE (21,"(' Provide valid .FEG and .BCS files and start from scratch.')") WRITE (21,"(' Or, reduce the scale sigma(s) used in early time steps.')") WRITE (21,"(' Or, reduce the size of the time step.')") CALL Pause() STOP ELSE ! The FEG in memory was useful for the last time-step, but cannot handle another one. User must intervene... CALL Recovery_advice() ! using a subprogram so that this long special-case message does not obscure program logic. CALL Pause() STOP END IF END IF ! folding? during predictor-displacement of FEG? !N.B. If execution continues beyond this line, then there was no folding during the predictor step. ! move all integrated points to older positions: predictor step WRITE (*, "(' ', 8X, 'Moving all points back in time (""predictor"" step)')") WRITE (21,"(8X, 'Moving all points back in time (""predictor"" step')") CALL Move_data (vw = vw0) t1 = time1 / s_per_Ma WRITE (*, "(' ', 8X, 'Solving for velocities at older end of timestep (', F6.2, ' Ma)')") t1 WRITE (21,"(8X, 'Solving for velocities at older end of timestep (', F6.2, ' Ma)')") t1 !Survey and then store fault segments, all over again! !(Work must be repeated, since straightening strike-slip faults ! and/or using "symmetric_spreading_system" translation mode #2 ! will change their segmentation!) !Notes: Uses arrays "center", "neighbor", ! and "trace_is" defined in Find_s1s2s3. ! Although repeated below (for the corrector), ! cannot be moved to a SUBR because it uses dynamic ! memory. Cannot be moved outside timestepping loop ! because strike-slip faults change their segments ! whenever they are smoothed! IF (f_rst_count > 0) THEN ! begin defining segments IF (seg_count_doubled < 0) THEN ! not yet initialized; do it! CALL Def_seg_v2 (seg_count = seg_count, savem = .FALSE.) seg_count_doubled = 2 * seg_count END IF IF (seg_count > 0) THEN IF (.NOT.ALLOCATED(seg_def)) THEN CALL More_mem('seg_def', 1.0D0 * 2 * seg_count_doubled * bytes_per_int) CALL More_mem('seg_end', 1.0D0 * 3 * 2 * seg_count_doubled * bytes_per_real) CALL More_mem('seg_end_is', 1.0D0 * 2 * seg_count_doubled * bytes_per_is) CALL More_mem('seg_eta_', 1.0D0 * seg_count_doubled * bytes_per_real) CALL More_mem('seg_kappa_', 1.0D0 * seg_count_doubled * bytes_per_real) CALL More_mem('seg_u_', 1.0D0 * seg_count_doubled * bytes_per_int) ALLOCATE( seg_def(2, seg_count_doubled) ) ALLOCATE( seg_end(1:3, 2, seg_count_doubled) ) ALLOCATE( seg_end_is(2, seg_count_doubled) ) seg_end_is(1:2, 1:seg_count_doubled)%element = 1 ! because '0' has special meaning to Internal ALLOCATE( seg_eta_(seg_count_doubled) ) ALLOCATE( seg_kappa_(seg_count_doubled) ) ALLOCATE( seg_u_(seg_count_doubled) ) END IF CALL Def_seg_v2 (seg_count = seg_count, savem = .TRUE.) CALL Coordinate_Segments() ! improvement added in Spring 2020 CALL Unpin_Plate_Corners() ! improvement added 2020.07.01 END IF ! seg_count > 0 END IF ! f_rst_count > 0; defining fault segments ! Count cracks (~active fault segments), both total and by element. ! Note: A crack is not exactly an active segment; the same segment ! may be used for more than one crack when two or more offset data have ! contiguous time windows both falling into this timestep. ! For placement of this block, see comments above regarding fault segments. crack_count = 0 crack_index = 0 ! whole array IF (f_rst_count > 0) THEN ! begin defining cracks DO i = 1, f_rst_count IF (f_active(n_, i)) THEN ! datum is active k = which_trace(i) ! trace index j1 = trace_loc(3, k) ! 1st segment of trace j2 = trace_loc(4, k) ! last segment of trace IF (j1 > 0) THEN ! at least one segment exists DO j = j1, j2 IF ((seg_end(1,1,j) /= seg_end(1,2,j)) .OR. & & (seg_end(2,1,j) /= seg_end(2,2,j)) .OR. & & (seg_end(3,1,j) /= seg_end(3,2,j))) THEN ! ignore any zero-length segments(?) crack_count = crack_count + 1 l_ = seg_def(2, j) ! element number crack_index(1, l_) = crack_index(1, l_) + 1 END IF ! not a null segment END DO ! segments in trace END IF ! at least one segment exists END IF ! active END DO ! i = 1, f_rst_count IF (crack_count > 0) THEN ! Decide initial storage positions for local cracks in each element crack_index(2, 1) = 1 DO l_ = 2, num_ele crack_index(2, l_) = crack_index(2, l_ - 1) + crack_index(1, l_ - 1) END DO DO l_ = 1, num_ele IF (crack_index(1, l_) == 0) crack_index(2, l_) = 0 ! clear warning END DO ! allocate local crack storage IF (ALLOCATED(local_crack)) THEN DEALLOCATE (local_crack) ELSE CALL More_mem('local_crack', 1.0D0 * crack_count * bytes_per_crack) END IF ALLOCATE ( local_crack(crack_count) ) ! reset counts to 0 in each element so they can be used to keep track of open spots DO l_ = 1, num_ele crack_index(1, l_) = 0 END DO DO i = 1, f_rst_count ! offset datum index IF (f_active(n_, i)) THEN ! datum is active k = which_trace(i) ! trace index j1 = trace_loc(3, k) ! 1st segment of trace j2 = trace_loc(4, k) ! last segment of trace IF (j1 > 0) THEN ! at least one segment exists DO j = j1, j2 ! segment index IF ((seg_end(1,1,j) /= seg_end(1,2,j)) .OR. & & (seg_end(2,1,j) /= seg_end(2,2,j)) .OR. & & (seg_end(3,1,j) /= seg_end(3,2,j))) THEN ! ignore any zero-length null segments (?) l_ = seg_def(2, j) ! element number k = crack_index(2, l_) + crack_index(1, l_) !storage location crack_index(1, l_) = crack_index(1, l_) + 1 !bump up count local_crack(k)%datum = i ! to refer back when we have p_ local_crack(k)%segment = j ! to access changing length, azimuth, ! eta_, kappa_, u_, ... local_crack(k)%sense = sense(i) ! T, P, N, R, L, D IF (sense(i) == 'T') THEN IF (f_dip_degrees(which_trace(i)) == 0.0D0) THEN !No value was set in the f_dig file; use generic dip: factor = -cot_thrust_dip ELSE ! use value set in the f_dig file: factor = -1.0D0 / TAN(MIN(80.0D0, f_dip_degrees(which_trace(i))) * radians_per_degree) END IF ELSE IF (sense(i) == 'P') THEN factor = -1.0D0 ELSE IF (sense(i) == 'N') THEN IF (f_dip_degrees(which_trace(i)) == 0.0D0) THEN !No value was set in the f_dig file; use generic dip: factor = cot_normal_dip ELSE ! use value set in the f_dig file: factor = 1.0D0 / TAN(MIN(80.0D0, f_dip_degrees(which_trace(i))) * radians_per_degree) END IF ELSE IF (sense(i) == 'D') THEN factor = 1.0D0 ELSE IF (sense(i) == 'R') THEN factor = 1.0D0 ELSE IF (sense(i) == 'L') THEN factor = -1.0D0 ELSE ! should not happen! CALL Prevent ('illegal slip sense', i, 'array "sense"') ENDIF local_crack(k)%s_ = factor * f_goal(n_, i) local_crack(k)%sigma_ = ABS(factor) * f_goal_sigma_(i) END IF ! non-null segment END DO ! segments in trace END IF ! at least one segment exists END IF ! goal is not zero END DO ! i = 1, f_rst_count END IF ! crack_count > 0 END IF ! f_rst_count > 0; defining cracks !****** OLDER END OF TIMESTEP *************************************************************** vw1 = vw0 ! initial estimate of new (older) velocity field, used by Solve-for-vw to initialize its iteration, is the younger velocity field (on same FEG). IF (stress_now) THEN boxed = .FALSE. ! Whole array. Solve_for_vw() can only turn certain elements to TRUE. CALL Solve_for_vw (passes = (1 + n_refine), vw = vw1) !* < * CORRECTOR * < * * < * * ELSE CALL Solve_for_vw (passes = 1, vw = vw1) !* < * CORRECTOR * < * * < * * END IF !correction velocities are half of changes DO i = 1, nDOF vw_add (i) = (vw1(i) - vw0(i)) / 2.0D0 vw_mean(i) = (vw1(i) + vw0(i)) / 2.0D0 END DO xyz_nod_premove = xyz_nod ! save for use within Move_data (to avoid s-s folding) ! move nodes in corrector and check for grid folding CALL Move_feg (vw = vw_add) CALL Plane_area (folding) !? IF (folding) THEN WRITE (*, "(' ',8X,'ERROR: This grid FOLDED in corrector displacement step...')") WRITE (21,"(8X,'ERROR: This grid FOLDED in corrector displacement step...')") IF (grid_to_load_this_timestep(n_) > 0) THEN ! we just loaded a fresh FEG! WRITE (*, "(' ERROR: Although a fresh FEG/BCS file-pair was just loaded,')") WRITE (*, "(' it could not survive even one timestep without folding.')") WRITE (*, "(' Provide valid .FEG and .BCS files and start from scratch.')") WRITE (*, "(' Or, reduce the size of the time step.')") WRITE (*, "(' Or, reduce the scale sigma(s) used in early time steps.')") WRITE (21, "('ERROR: Although a fresh FEG/BCS file-pair was just loaded,')") WRITE (21, "(' it could not survive even one timestep without folding.')") WRITE (21,"(' Provide valid .FEG and .BCS files and start from scratch.')") WRITE (21,"(' Or, reduce the scale sigma(s) used in early time steps.')") WRITE (21,"(' Or, reduce the size of the time step.')") CALL Pause() STOP ELSE ! The FEG in memory was useful for the last time-step, but cannot handle another one. User must intervene... CALL Recovery_advice() ! using a subprogram so that this long special-case message does not obscure program logic. CALL Pause() STOP END IF ELSE WRITE (*, "(' ',8X,'Adjusting for accelerations (""corrector"" step)')") WRITE (21,"(8X,'Adjusting for accelerations (""corrector"" step)')") CALL Move_data (vw = vw_add) END IF ELSE ! (neotec; no need to check for folding, move data, or "compute velocities at older end of timestep") vw_mean = vw0 ! whole array END IF ! paleotec or neotec ! Compute model predicted rates (p_) of this timestep CALL Prediction (vw = vw_mean, N0 = rate_err(0, n_, iteration), & & N1 = rate_err(1, n_, iteration), N2 = rate_err(2, n_, iteration)) !--------------------------------------------------------------------------------- !New feature added 2021.02.12-03.25 (after the NI-SM model, but before the HP & PM models): ! Compute vertical-stretch factor at each node and use it to adjust nodal data in ! eqcm = (elevation, heat-flow, crustal thickness, mantle-lithosphere thickness) ! for more realistic(?) output graphics in OrbWin and/or RetroMap. ! N.B. Experience shows that all values need realistic limits, or a few go crazy! ! [Note that NONE of these values will be used by Restore, so this change has ! no effect on other existing predictions & products of the Restore process.] ! The vertical-stretch at each node is computed from the wedge-angle-weighted ! mean of the area-dilatation (+) or area-loss (-) strain-rates in elements ! that contain the node, and the length of the timestep. IF (paleotec) THEN nodal_area_strainrate = 0.0D0 ! whole list (1:num_nod); just initializing... DO l_ = 1, num_ele ! accumulating wedge-weighted contributions to areal strainrates i1 = node(1, l_) i2 = node(2, l_) i3 = node(3, l_) ! evaluate nodal function and derivitives at center of element tv = center(1:3, l_) CALL Gjxy(l_, tv, G) CALL Del_Gjxy_del_thetaphi(l_, tv, dG) equat = SQRT(tv(1)**2 + tv(2)**2) IF (equat == 0.0D0) THEN WRITE (*, "(' Error: center of element ', I6, ' is N or S pole.')") l_ WRITE (21,"( 'Error: center of element ', I6, ' is N or S pole.')") l_ STOP END IF theta_ = ATAN2(equat, tv(3)) sint = SIN(theta_) csct = 1.0D0 / sint tant = TAN(theta_) cott = 1.0D0 / tant !compute 3 components of 2-D element strain-rate (including any faulting) CALL E_rate(l_, G, dG, theta_, vw_mean, eps_dot) area_strainrate = eps_dot(1) + eps_dot(3) ! eps_dot_theta_theta + eps_dot_phi_phi = relative rate of area expansion as time goes forward DO j = 1, 3 ! distribute result to 3 corners of this element jp1 = j + 1 ; IF (jp1 > 3) jp1 = jp1 - 3 jp2 = jp1 + 1 ; IF (jp2 > 3) jp2 = jp2 - 3 tv1(1:3) = xyz_nod(1:3, node(jp1, l_)) - xyz_nod(1:3, node(j, l_)) ! side-vector (NOT a uvec) tv2(1:3) = xyz_nod(1:3, node(jp2, l_)) - xyz_nod(1:3, node(j, l_)) ! side-vector (NOT a uvec) dot_product = DDot(tv1, tv2) CALL DCross(tv1, tv2, tv3) cross_product = DMagnitude(tv3) angle = ATAN2(cross_product, dot_product) ! in radians; positive but not necessarily acute k = node(j, l_) nodal_area_strainrate(k) = nodal_area_strainrate(k) + area_strainrate * (angle / Two_Pi) END DO ! j = 1, 3 ! distribute result to 3 corners of this element END DO ! l_ = 1, num_ele ! accumulating wedge-weighted contributions to areal strainrates DO i = 1, num_nod ! apply vertical-stretch factor vertical_stretch = -nodal_area_strainrate(i) * Deltat_ ! fractional change in vertical dimensions over one forward timestep. vertical_stretch = MAX(-0.5D0, MIN(1.0D0, vertical_stretch)) ! arbitrary limits for "safety"; discount "crazy" results forward_thickness_ratio = 1.0D0 + vertical_stretch ! = (younger thickness)/(older thickness) backward_thickness_ratio = 1.0D0 / forward_thickness_ratio ! = (older thickness)/(younger thickness) eqcm(2, i) = eqcm(2, i) / backward_thickness_ratio ! adjust heat-flow to older time eqcm(2, i) = MAX(eqcm(2, i), 0.030D0) ! apply lower limit eqcm(2, i) = MIN(eqcm(2, i), 0.200D0) ! apply upper limit old_crust = eqcm(3, i) ; old_mL = eqcm(4, i) ! save for use in expression below eqcm(3, i) = eqcm(3, i) * backward_thickness_ratio ! adjust thickness of crust to older time eqcm(3, i) = MAX(eqcm(3, i), 5.0D3) ! apply lower limit eqcm(3, i) = MIN(eqcm(3, i), 75.0D3) ! apply upper limit eqcm(4, i) = eqcm(4, i) * backward_thickness_ratio ! adjust thickness of mantle-lithosphere to older time eqcm(4, i) = MAX(eqcm(4, i), 0.0D3) ! apply lower limit eqcm(4, i) = MIN(eqcm(4, i), 250.0D3) ! apply upper limit IF (eqcm(1, i) >= 0.0D0) THEN ! dry land eqcm(1, i) = eqcm(1, i) + ((eqcm(3, i) - old_crust) * 0.151515D0 ) + & ! (subaerial) isostatic adjustment to elevation & ((eqcm(4, i) - old_mL) * (-0.0175D0)) ELSE ! under sea (continental margin) eqcm(1, i) = eqcm(1, i) + ((eqcm(3, i) - old_crust) * 0.214286D0 ) + & ! (submarine) isostatic adjustment to elevation & ((eqcm(4, i) - old_mL) * (-0.0248D0)) END IF eqcm(1, i) = MAX(eqcm(1, i), -10.0D3) ! apply lower limit eqcm(1, i) = MIN(eqcm(1, i), +10.0D3) ! apply upper limit END DO ! i = 1, num_nod ! apply vertical-stretch factor END IF ! (paleotec); adjusting nodal data for vertical-stretch during timestep !--------------------------------------------------------------------------------- !Wrapping up this (successful) time-step: IF (neotec) THEN complete_timesteps = 1 ELSE ! (paleotec) t0 = time0 / s_per_Ma t1 = time1 / s_per_Ma WRITE (*, "(' ',4X,'Completed timestep from ',F6.2,' to ',F6.2,' Ma')") t0, t1 WRITE (21,"(4X,'Completed timestep from ',F6.2,' to ',F6.2,' Ma')") t0, t1 complete_timesteps = complete_timesteps + 1 IF (n_ < num_timesteps) THEN ! There is still at least one time-step to go... CALL Look_ahead(folding) ! Use vw_mean to check for likely folding in NEXT timestep... IF (folding) THEN WRITE (*, "(' ', 8X, 'Caution: subprogram Look_ahead anticipates folding in next timestep;')") WRITE (*, "(' ', 8X, 'therefore, setting a flag to read a new FEG/BCS pair when it starts.')") WRITE (21, "(8X, 'Caution: subprogram Look_ahead anticipates folding in next timestep;')") WRITE (21, "(8X, 'therefore, setting a flag to read a new FEG/BCS pair when it starts.')") get_feg = .TRUE. END IF ! Else, no problem is forseen, so it is OK to try to use the same FEG for one more timestep. END IF ! at least one time-step remains END IF ! (paleotec) !------------------------------------------------------------------------------------------------------------ ! OUTPUT FILES section: IF (paleotec) THEN ! Execution has reached this point because we just successfully completed a timestep. ! (Any case of grid-folding would have already caused a STOP up above this point.) ! ! At the end of a successful timestep, we write all possible output files. ! For example, after the first timestep of 0.2 m.y., we write: ! F_NI_000.2Ma.DIG or F_i001_000.2Ma.DIG ! NInn_NI_000.2Ma.FEG or iinn_i001_000.2Ma.FEG ! NInn_NI_000.2Ma.VEL or iinn_i001_000.2Ma.VEL ! C_NI_000.2Ma.RST or C_i001_000.2Ma.RST ! F_NI_000.2Ma.RST or F_i001_000.2Ma.RST ! P_NI_000.2Ma.RST or P_i001_000.2Ma.RST ! S_NI_000.2Ma.RST or S_i001_000.2Ma.RST ! y_NI_000.2Ma.DIG or y_i001_000.2Ma.DIG ! where the style of filename depends on whether the current solution is ! going to be iterated ("_i001") or Not Iterated ("_NI"). ! ! There are (at least) 4 reasons why these files might be needed: ! (1) Most files (except .VEL) will be needed to resume this iteration if it ! fails (by grid folding) during the NEXT timestep. (In such a case, ! the .VEL file may also be useful to provide insight into why folding happened.) ! (2) Most files (except .VEL) could be needed to continue an iteration to an older ! geologic-time end-point, beyond the (end_time / s_per_Ma) Ma controlling this run, ! if the user decided to extend the reconstruction further back in time. ! (3) ALL .RST files from iteration-ending timesteps should be saved to permit study ! and fine-tuning of the iteration process (via the selected values of starting uncertainties). ! (4) Most files (except .RST files from non-final timesteps) from the final (or only) ! iteration are useful for plotting in RetroMap4 graphics, and for scientific insight. IF (n_ > n_beginning_this_run) THEN ! This is not the first time-step in the current run. previous_filename_suffix = filename_suffix ! Preserve the old suffix, for use in file deletion (below). END IF ! There was a previous successful time-step in this run. !Define the current filename_suffix using the current older-end-of-timestep: filename_suffix = Mangle(last_iteration, total_iterations, time1) !Begin output of all potentially-useful files: filename = Insert (f_dig, filename_suffix) IF (f_dig_count > 0) CALL Write_f_dig(filename) FEG_filename = Insert (x_feg, filename_suffix) CALL Write_x_feg(FEG_filename) i = LEN_TRIM(FEG_filename) filename = FEG_filename(1:(i-3)) // "vel" CALL Write_x_vel (vw = vw1, age_s = time1, filename = filename, FEG_filename = FEG_filename) filename = Insert (c_rst, filename_suffix) IF (c_rst_count > 0) CALL Write_c_rst(filename) filename = Insert (f_rst, filename_suffix) IF (f_rst_count > 0) CALL Write_f_rst(filename) filename = Insert (p_rst, filename_suffix) IF (p_rst_count > 0) CALL Write_p_rst(filename) filename = Insert (s_rst, filename_suffix) IF (s_rst_count > 0) CALL Write_s_rst(filename) filename = Insert (y_dig, filename_suffix) IF (basemap_object_count > 0) CALL Write_y_dig(filename) ! NOTE: This the ORIGINAL, INPUT count; ! objects that fell outside the FEG are marked internally ! by having fewer points left in them. Subprogram Write_y_dig "knows" ! that it should not write out any object with <2 points remaining. ! Next, consider whether output files written at the end of the PREVIOUS timestep (if any) ! can now be deleted? ! After all, motivations #1 and #2 (above) no longer apply to them; only #3 and #4 count now. IF (n_ > n_beginning_this_run) THEN ! This is not the first time-step in this run. !Delete unneeded output files from the PREVIOUS time-step in this iteration. !N.B. There is no need to consider file-motivations #1, #2, or #3 at this point, ! because (a) we have just shown that the previous time-step was not the last successful one; and ! (b) this code will never have a chance to delete any files from timestep #n_ = num_timesteps. ! The only need is to keep (most) files from the last (or only) iteration for "movies" and other ! graphics to be produced by RetroMap4. IF (total_iterations < last_iteration) THEN ! We are NOT in the last (or only) iteration now. filename = Insert (f_dig, previous_filename_suffix) IF (f_dig_count > 0) CALL Delete_output_file(filename) FEG_filename = Insert (x_feg, previous_filename_suffix) CALL Delete_output_file(FEG_filename) i = LEN_TRIM(FEG_filename) filename = FEG_filename(1:(i-3)) // "vel" CALL Delete_output_file(filename) filename = Insert (c_rst, previous_filename_suffix) IF (c_rst_count > 0) CALL Delete_output_file(filename) filename = Insert (f_rst, previous_filename_suffix) IF (f_rst_count > 0) CALL Delete_output_file(filename) filename = Insert (p_rst, previous_filename_suffix) IF (p_rst_count > 0) CALL Delete_output_file(filename) filename = Insert (s_rst, previous_filename_suffix) IF (s_rst_count > 0) CALL Delete_output_file(filename) filename = Insert (y_dig, previous_filename_suffix) IF (basemap_object_count > 0) CALL Delete_output_file(filename) ELSE IF (total_iterations == last_iteration) THEN ! Final iteration; only clean up unwanted .RST files ! from time-steps prior to the last one. filename = Insert (c_rst, previous_filename_suffix) IF (c_rst_count > 0) CALL Delete_output_file(filename) filename = Insert (f_rst, previous_filename_suffix) IF (f_rst_count > 0) CALL Delete_output_file(filename) filename = Insert (p_rst, previous_filename_suffix) IF (p_rst_count > 0) CALL Delete_output_file(filename) filename = Insert (s_rst, previous_filename_suffix) IF (s_rst_count > 0) CALL Delete_output_file(filename) END IF ! total_iterations < last_iteration, OR total_iterations == last_iteration END IF ! There was a previous timestep in this run. ELSE ! neotec filename_suffix = Mangle(last_iteration = 1, iteration = 1, time = 0.0D0) ! Expected to include "_NT" !Begin output of all potentially-useful files: i = LEN_TRIM(x_feg) filename = x_feg(1:(i-3)) // "vel" CALL Write_x_vel (vw = vw0, age_s = 0.0D0, filename = filename, FEG_filename = x_feg) filename = Insert (c_rst, filename_suffix) IF (c_rst_count > 0) CALL Write_c_rst(filename) filename = Insert (f_rst, filename_suffix) IF (f_rst_count > 0) CALL Write_f_rst(filename) filename = Insert (p_rst, filename_suffix) IF (p_rst_count > 0) CALL Write_p_rst(filename) filename = Insert (s_rst, filename_suffix) IF (s_rst_count > 0) CALL Write_s_rst(filename) END IF ! paleotec, or neotec !------------------------------------------------------------------------------------------------------------ IF (neotec .OR. (n_ >= num_timesteps)) EXIT timestepping END DO timestepping ! (with index n_ ) ==================================================================================== ! An iteration of the whole history has been completed! IF (paleotec) THEN ! Describe errors for this iteration ! All rate errors (both data goals and a-priori zero-strain goals); ! note that fault offset-rate errors in elements are weighted by (rho_ / L_0), ! and continuum strain-rate errors in elements are weighted by (a(l_) / A_0), ! but cross-section-elongation, paleolatitude, and vertical-axis-rotation errors are all weighted by 1.0D0. rate_err(0, 0 , iteration) = 0.0D0 rate_err(1, 0 , iteration) = 0.0D0 rate_err(2, 0 , iteration) = 0.0D0 n_1 = NINT(start_time / Deltat_) + 1 n_t_per_it = num_timesteps - n_1 + 1 DO i = n_1, num_timesteps rate_err(0,0,iteration) = rate_err(0,0,iteration) + rate_err(0,i,iteration) rate_err(1,0,iteration) = rate_err(1,0,iteration) + rate_err(1,i,iteration) rate_err(2,0,iteration) = rate_err(2,0,iteration) + rate_err(2,i,iteration) END DO rate_err(0, 0, iteration) = rate_err(0, 0, iteration) / n_t_per_it rate_err(1, 0, iteration) = rate_err(1, 0, iteration) / n_t_per_it rate_err(2, 0, iteration) = rate_err(2, 0, iteration) / n_t_per_it WRITE (*, "(' ',4X,'Mean rate error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & rate_err(0,0,iteration),rate_err(1,0,iteration),rate_err(2,0,iteration) WRITE (21, "(4X,'Mean rate error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & rate_err(0,0,iteration),rate_err(1,0,iteration),rate_err(2,0,iteration) ! Fault offset errors IF (f_in_time_and_space > 0) THEN f_err(0:2, iteration) = 0.0D0 ! initialize sums f_err(0:2, 0) = 0.0D0 ! including pre-solution, for reference in_count = 0 DO i = 1, f_rst_count IF (f_2_in(which_trace(i)) .AND. (f_t_max(i) <= end_time)) THEN in_count = in_count + 1 IF (f_rst_code(i) == 'P') THEN ! Promoted type offs = f_rate(1, i) * f_t_max(i) ELSE ! Normal or Demoted types offs = 0.0D0 DO n_ = 1, num_timesteps IF (f_active(n_, i)) THEN offs = offs + f_rate(n_, i) * Deltat_ END IF END DO END IF ! Promoted or not IF (ABS((offs - offset(i))) > 2.0D0 * offset_sigma_(i)) & & f_err(0,iteration) = f_err(0,iteration) + 1.0D0 IF (ABS(offset(i)) > 2.0D0 * offset_sigma_(i)) & & f_err(0,0) = f_err(0,0) + 1.0D0 f_err(1,iteration) = f_err(1,iteration) + ABS(offs - offset(i)) / offset_sigma_(i) f_err(1,0) = f_err(1,0) + ABS(offset(i)) / offset_sigma_(i) f_err(2,iteration) = f_err(2,iteration) + ((offs - offset(i)) / offset_sigma_(i))**2 f_err(2,0) = f_err(2,0) + (offset(i) / offset_sigma_(i))**2 END IF ! fault is inside time and space windows END DO ! on all fault offset data IF (in_count > 0) THEN f_err(0, iteration) = f_err(0, iteration) / in_count f_err(0, 0) = f_err(0, 0) / in_count f_err(1, iteration) = f_err(1, iteration) / in_count f_err(1, 0) = f_err(1, 0) / in_count f_err(2, iteration) = SQRT(f_err(2, iteration) / in_count) f_err(2, 0) = SQRT(f_err(2, 0) / in_count) WRITE (*, "(' ',4X,'Fault offset error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & f_err(0,iteration),f_err(1,iteration),f_err(2,iteration) WRITE (21, "(4X,'Fault offset error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & f_err(0,iteration),f_err(1,iteration),f_err(2,iteration) END IF END IF ! Cross-section extension errors IF (c_in_time_and_space > 0) THEN c_err(0:2, iteration) = 0.0D0 ! initialize sums c_err(0:2, 0) = 0.0D0 ! including pre-solution values for reference in_count = 0 DO i = 1, c_rst_count IF ( (c_end_is(1,i)%element > 0) .AND. & & (c_end_is(2,i)%element > 0) .AND. & & (c_t_max(i) <= end_time)) THEN in_count = in_count + 1 stretch = 0.0D0 DO n_ = 1, num_timesteps IF (c_active(n_, i)) THEN stretch = stretch + c_rate(n_, i) * Deltat_ END IF END DO misfits = ABS(stretch - c_stretch(i)) / c_sigma_(i) IF (misfits > 2.0D0) c_err(0,iteration) = c_err(0,iteration) + 1.0D0 c_err(1,iteration) = c_err(1,iteration) + misfits c_err(2,iteration) = c_err(2,iteration) + misfits**2 !recompute using no stretch, for pre-solution reference value misfits = ABS(c_stretch(i)) / c_sigma_(i) IF (misfits > 2.0D0) c_err(0, 0) = c_err(0, 0) + 1.0D0 c_err(1, 0) = c_err(1, 0) + misfits c_err(2, 0) = c_err(2, 0) + misfits**2 END IF ! section is inside time and space windows END DO ! on all cross-section data IF (in_count > 0) THEN c_err(0, iteration) = c_err(0, iteration) / in_count c_err(0, 0) = c_err(0, 0) / in_count c_err(1, iteration) = c_err(1, iteration) / in_count c_err(1, 0) = c_err(1, 0) / in_count c_err(2, iteration) = SQRT(c_err(2, iteration) / in_count) c_err(2, 0) = SQRT(c_err(2, 0) / in_count) WRITE (*, "(' ',4X,'Cross-section error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & c_err(0,iteration),c_err(1,iteration),c_err(2,iteration) WRITE (21, "(4X,'Cross-section error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & c_err(0,iteration),c_err(1,iteration),c_err(2,iteration) END IF END IF ! c_rst_count > 0 ! Paleolatitude errors IF (p_in_time_and_space > 0) THEN p_south_err(0:2, iteration) = 0.0D0 ! initialize sums p_south_err(0:2, 0) = 0.0D0 ! including pre-solution errors for reference in_count = 0 DO i = 1, p_rst_count IF ( (p_site_is(i)%element > 0) .AND. & & (p_t_max(i) <= end_time)) THEN in_count = in_count + 1 south = 0.0D0 DO n_ = 1, num_timesteps IF (p_active(n_, i)) & & south = south + p_south_rate(n_, i) * Deltat_ END DO misfits = ABS(south - p_south(i)) / p_south_sigma_(i) IF (misfits > 2.0D0) p_south_err(0,iteration) = p_south_err(0,iteration) + 1.0D0 p_south_err(1,iteration) = p_south_err(1,iteration) + misfits p_south_err(2,iteration) = p_south_err(2,iteration) + misfits**2 !redo with south = 0 to find errors prior to solution: misfits = ABS(p_south(i)) / p_south_sigma_(i) IF (misfits > 2.0D0) p_south_err(0, 0) = p_south_err(0, 0) + 1.0D0 p_south_err(1, 0) = p_south_err(1, 0) + misfits p_south_err(2, 0) = p_south_err(2, 0) + misfits**2 END IF ! site is inside time and space windows END DO ! on all paleomagnetic sites IF (in_count > 0) THEN p_south_err(0, iteration) = p_south_err(0, iteration) / in_count p_south_err(0, 0) = p_south_err(0, 0) / in_count p_south_err(1, iteration) = p_south_err(1, iteration) / in_count p_south_err(1, 0) = p_south_err(1, 0) / in_count p_south_err(2, iteration) = SQRT(p_south_err(2, iteration) / in_count) p_south_err(2, 0) = SQRT(p_south_err(2, 0) / in_count) WRITE (*, "(' ',4X,'Paleolatitude error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & p_south_err(0,iteration),p_south_err(1,iteration),p_south_err(2,iteration) WRITE (21,"(4X,'Paleolatitude error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & p_south_err(0,iteration),p_south_err(1,iteration),p_south_err(2,iteration) END IF END IF ! Vertical-axis rotation errors IF (p_rst_count > 0) THEN p_ccw_err(0:2, iteration) = 0.0D0 ! initialize sums p_ccw_err(0:2, 0) = 0.0D0 ! including pre-solution errors for reference in_count = 0 DO i = 1, p_rst_count IF ( (p_site_is(i)%element > 0) .AND. & & (p_t_max(i) <= end_time)) THEN IF (.NOT.twisted(i)) THEN in_count = in_count + 1 ccw = 0.0D0 DO n_ = 1, num_timesteps IF (p_active(n_, i)) & & ccw = ccw + p_ccw_rate(n_, i) * Deltat_ END DO misfits = ABS(ccw - p_ccw(i)) / p_ccw_sigma_(i) IF (misfits > 2.0D0) p_ccw_err(0,iteration) = p_ccw_err(0,iteration) + 1.0D0 p_ccw_err(1,iteration) = p_ccw_err(1,iteration) + misfits p_ccw_err(2,iteration) = p_ccw_err(2,iteration) + misfits**2 ! redo with ccw = 0.0 to determine pre-solution errors: misfits = ABS(p_ccw(i)) / p_ccw_sigma_(i) IF (misfits > 2.0D0) p_ccw_err(0, 0) = p_ccw_err(0, 0) + 1.0D0 p_ccw_err(1, 0) = p_ccw_err(1, 0) + misfits p_ccw_err(2, 0) = p_ccw_err(2, 0) + misfits**2 END IF ! .NOT.twisted END IF ! site is inside time and space windows END DO ! on all paleomagnetic sites IF (in_count > 0) THEN p_ccw_err(0, iteration) = p_ccw_err(0, iteration) / in_count p_ccw_err(0, 0) = p_ccw_err(0, 0) / in_count p_ccw_err(1, iteration) = p_ccw_err(1, iteration) / in_count p_ccw_err(1, 0) = p_ccw_err(1, 0) / in_count p_ccw_err(2, iteration) = SQRT(p_ccw_err(2, iteration) / in_count) p_ccw_err(2, 0) = SQRT(p_ccw_err(2, 0) / in_count) WRITE (*, "(' ',4X,'Vertical-axis rotation error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & p_ccw_err(0,iteration),p_ccw_err(1,iteration),p_ccw_err(2,iteration) WRITE (21,"(4X,'Vertical-axis rotation error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & p_ccw_err(0,iteration),p_ccw_err(1,iteration),p_ccw_err(2,iteration) END IF END IF ! Continuum-strain-rate errors (all relative to local mu_, and with each element weighted by (a(l_) / A_0), ! and summed over all the timesteps in this iteration: WRITE (*, "(' ',4X,'Continuum strain-rates error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & (continuum_N_numerator_sums(0) / MAX(continuum_N_denominator_sum, 1.0D0)), & & (continuum_N_numerator_sums(1) / MAX(continuum_N_denominator_sum, 1.0D0)), & & SQRT(continuum_N_numerator_sums(2) / MAX(continuum_N_denominator_sum, 1.0D0)) WRITE (21,"(4X,'Continuum strain-rates error: N0 = ',F5.3,', N1 = ',F7.3,', N2 = ',F7.3)") & & (continuum_N_numerator_sums(0) / MAX(continuum_N_denominator_sum, 1.0D0)), & & (continuum_N_numerator_sums(1) / MAX(continuum_N_denominator_sum, 1.0D0)), & & SQRT(continuum_N_numerator_sums(2) / MAX(continuum_N_denominator_sum, 1.0D0)) WRITE (*, "(' ','End of iteration ',I3,' out of ',I3)") iteration, max_iter WRITE (21,"('End of iteration ',I3,' out of ',I3)") iteration, max_iter ELSE ! neotec (So, compare model fault offset rates f_rate to both internal (f_goal) & external (Holocene rates in f_rst) datasets, ! and also check overall error in stress-direction enforcement; and ! and compare surface velocities to external GPS velocities. !NOTE that here I also use the model predictions f_rate previously computed in subprogram Prediction; ! however, "external" offset-rates & GPS velocities ! (used as standards in 2 of these tests) were NOT used to obtain the solution. ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! Comparing f_rate(1, i) to internal targets f_goal(1, i) and f_goal_sigma_(i) { but only if f_active(1, i) }. ! Caution: Subscript (i) of offset-rate arrays has range 1...f_rst_count; it is NOT the trace-index 1...f_highest . ! Use which_trace(i) to get the FnnnnX trace index. neotec_internal_OR_misfit_count = 0 neotec_internal_OR_misfit_mmpa = 0.0D0 ! all (0:2) values neotec_internal_OR_misfit_sigmas = 0.0D0 ! all (0:2) values neotec_internal_OR_misfit_checkThis_mmpa = 0 neotec_internal_OR_misfit_checkThis_sigmas = 0 systematic_internal_OR_numerator = 0.0D0 systematic_internal_OR_denominator = 0.0D0 DO i = 1, f_rst_count IF (f_active(1, i).AND.f_2_in(which_trace(i))) THEN ! we have a standard for comparison (fault is active at present, and inside the feg area). neotec_internal_OR_misfit_count = neotec_internal_OR_misfit_count + 1 OR_misfit_in_mps = f_rate(1, i) - f_goal(1, i) !build toward misfit measures in dimensionless units of sigmas: OR_misfit_in_sigmas = OR_misfit_in_mps / f_goal_sigma_(i) ! where denominator has been pre-checked to be > 0.0D0 IF (ABS(OR_misfit_in_sigmas) > neotec_internal_OR_misfit_sigmas(0)) THEN neotec_internal_OR_misfit_checkThis_sigmas = i ! remember location of worst misfit neotec_internal_OR_misfit_sigmas(0) = ABS(OR_misfit_in_sigmas) END IF neotec_internal_OR_misfit_sigmas(1) = neotec_internal_OR_misfit_sigmas(1) + ABS(OR_misfit_in_sigmas) neotec_internal_OR_misfit_sigmas(2) = neotec_internal_OR_misfit_sigmas(2) + OR_misfit_in_sigmas**2 !build toward misfit measures in popular dimensional units of mm/a: OR_misfit_in_mmpa = OR_misfit_in_mps * 1000.0D0 * s_per_year IF (ABS(OR_misfit_in_mmpa) > neotec_internal_OR_misfit_mmpa(0)) THEN neotec_internal_OR_misfit_checkThis_mmpa = i ! remember location of worst misfit neotec_internal_OR_misfit_mmpa(0) = ABS(OR_misfit_in_mmpa) END IF neotec_internal_OR_misfit_mmpa(1) = neotec_internal_OR_misfit_mmpa(1) + ABS(OR_misfit_in_mmpa) neotec_internal_OR_misfit_mmpa(2) = neotec_internal_OR_misfit_mmpa(2) + OR_misfit_in_mmpa**2 !build toward ratio of sum of offset rates, over sum of correct offset rates: systematic_internal_OR_numerator = systematic_internal_OR_numerator + f_rate(1, i) systematic_internal_OR_denominator = systematic_internal_OR_denominator + f_goal(1, i) END IF ! (f_active(1, i).AND.f_2_in(which_trace(i)) END DO ! i = 1, f_rst_count IF (neotec_internal_OR_misfit_count > 0) THEN neotec_internal_OR_misfit_sigmas(1) = neotec_internal_OR_misfit_sigmas(1) / neotec_internal_OR_misfit_count neotec_internal_OR_misfit_sigmas(2) = SQRT(neotec_internal_OR_misfit_sigmas(2) / neotec_internal_OR_misfit_count) neotec_internal_OR_misfit_mmpa(1) = neotec_internal_OR_misfit_mmpa(1) / neotec_internal_OR_misfit_count neotec_internal_OR_misfit_mmpa(2) = SQRT(neotec_internal_OR_misfit_mmpa(2) / neotec_internal_OR_misfit_count) END IF IF (systematic_internal_OR_denominator > 0.0D0) THEN systematic_internal_OR_ratio = systematic_internal_OR_numerator / systematic_internal_OR_denominator ELSE ! cannot /0.0 systematic_internal_OR_ratio = 0.0D0 ! (actually, undefined) END IF WRITE (*, *) ! create prominent report, on-screen, and in REPORT.txt file: WRITE (21, *) WRITE (*, "(' -----------------------------------------------------------------------------')") WRITE (21, "('-----------------------------------------------------------------------------')") WRITE (*, "(' Measures of misfit between model fault offset rates and internal Restore goal rates:')") WRITE (21, "('Measures of misfit between model fault offset rates and internal Restore goal rates')") IF (neotec_internal_OR_misfit_count == 0) THEN WRITE (*, "(' could not be computed because NO offsets for active faults were found the f_rst file.')") WRITE (21, "('could not be computed because NO offsets for active faults were found the f_rst file.')") ELSE ! normal case: WRITE (*, "(' Worst Mean(ABS) RMS')") WRITE (21, "(' Worst Mean(ABS) RMS')") WRITE (*, "(' Misfits in mm/a: ', 3F12.3)") neotec_internal_OR_misfit_mmpa(0:2) WRITE (21, "('Misfits in mm/a: ', 3F12.3)") neotec_internal_OR_misfit_mmpa(0:2) WRITE (*, "(' Misfits in sigmas: ', 3F12.3)") neotec_internal_OR_misfit_sigmas(0:2) WRITE (21, "('Misfits in sigmas: ', 3F12.3)") neotec_internal_OR_misfit_sigmas(0:2) WRITE (*, "(' based on ',I6, ' internal active-fault offset rates from the f_rst file.')") neotec_internal_OR_misfit_count WRITE (21, "('based on ',I6, ' internal active-fault offset rates from the f_rst file.')") neotec_internal_OR_misfit_count WRITE (*, "(' Worst misfit in mm/a was at f_rst line ',I6,': ',A)") (2+neotec_internal_OR_misfit_checkThis_mmpa), & & TRIM(f_dig_faultName_lines(which_trace(neotec_internal_OR_misfit_checkThis_mmpa))) WRITE (21, "('Worst misfit in mm/a was at f_rst line ',I6,': ',A)") (2+neotec_internal_OR_misfit_checkThis_mmpa), & & TRIM(f_dig_faultName_lines(which_trace(neotec_internal_OR_misfit_checkThis_mmpa))) WRITE (*, "(' Worst misfit in sigmas was at f_rst line ',I6,': ',A)") (2+neotec_internal_OR_misfit_checkThis_sigmas), & & TRIM(f_dig_faultName_lines(which_trace(neotec_internal_OR_misfit_checkThis_sigmas))) WRITE (21, "('Worst misfit in sigmas was at f_rst line ',I6,': ',A)") (2+neotec_internal_OR_misfit_checkThis_sigmas), & & TRIM(f_dig_faultName_lines(which_trace(neotec_internal_OR_misfit_checkThis_sigmas))) WRITE (*, "(' Ratio of sum-of-rates / sum-of-internal-correct-rates = ', F7.3, ' (should be 1.000)')") systematic_internal_OR_ratio WRITE (21, "('Ratio of sum-of-rates / sum-of-internal-correct-rates = ', F7.3, ' (should be 1.000)')") systematic_internal_OR_ratio END IF WRITE (*, "(' -----------------------------------------------------------------------------')") WRITE (21, "('-----------------------------------------------------------------------------')") WRITE (*, *) WRITE (21, *) ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! Comparing f_rate(1, i) to neotectonic_offset_rate(i) and neotectonic_offset_rate_sigma_(i) from columns 7~8 of the f_rst file. ! Caution: Subscript (i) of offset-rate arrays has range 1...f_rst_count; not 1...f_highest! Use which_trace(i) to get the FnnnnX trace index. neotec_external_OR_misfit_count = 0 neotec_external_OR_misfit_mmpa = 0.0D0 ! all (0:2) values neotec_external_OR_misfit_sigmas = 0.0D0 ! all (0:2) values neotec_external_OR_misfit_checkThis_mmpa = 0 neotec_external_OR_misfit_checkThis_sigmas = 0 systematic_external_OR_numerator = 0.0D0 systematic_external_OR_denominator = 0.0D0 DO i = 1, f_rst_count IF ((neotec_offset_rate_sigma_(i) > 0.0D0).AND.f_2_in(which_trace(i))) THEN ! we have a standard for comparison (cells were not empty; and fault within FEG). neotec_external_OR_misfit_count = neotec_external_OR_misfit_count + 1 OR_misfit_in_mps = f_rate(1, i) - neotec_offset_rate(i) !build toward misfit measures in dimensionless units of sigmas: OR_misfit_in_sigmas = OR_misfit_in_mps / neotec_offset_rate_sigma_(i) ! where denominator has been pre-checked to be > 0.0D0 IF (ABS(OR_misfit_in_sigmas) > neotec_external_OR_misfit_sigmas(0)) THEN neotec_external_OR_misfit_checkThis_sigmas = i ! remember location of worst misfit neotec_external_OR_misfit_sigmas(0) = ABS(OR_misfit_in_sigmas) END IF neotec_external_OR_misfit_sigmas(1) = neotec_external_OR_misfit_sigmas(1) + ABS(OR_misfit_in_sigmas) neotec_external_OR_misfit_sigmas(2) = neotec_external_OR_misfit_sigmas(2) + OR_misfit_in_sigmas**2 !build toward misfit measures in popular dimensional units of mm/a: OR_misfit_in_mmpa = OR_misfit_in_mps * 1000.0D0 * s_per_year IF (ABS(OR_misfit_in_mmpa) > neotec_external_OR_misfit_mmpa(0)) THEN neotec_external_OR_misfit_checkThis_mmpa = i ! remember location of worst misfit neotec_external_OR_misfit_mmpa(0) = ABS(OR_misfit_in_mmpa) END IF neotec_external_OR_misfit_mmpa(1) = neotec_external_OR_misfit_mmpa(1) + ABS(OR_misfit_in_mmpa) neotec_external_OR_misfit_mmpa(2) = neotec_external_OR_misfit_mmpa(2) + OR_misfit_in_mmpa**2 !build toward ratio of sum of offset rates, over sum of correct offset rates: systematic_external_OR_numerator = systematic_external_OR_numerator + f_rate(1, i) systematic_external_OR_denominator = systematic_external_OR_denominator + neotec_offset_rate(i) END IF ! (neotec_offset_rate_sigma_(i) > 0.0D0).AND.f_2_in(which_trace(i)) END DO ! i = 1, f_rst_count IF (neotec_external_OR_misfit_count > 0) THEN neotec_external_OR_misfit_sigmas(1) = neotec_external_OR_misfit_sigmas(1) / neotec_external_OR_misfit_count neotec_external_OR_misfit_sigmas(2) = SQRT(neotec_external_OR_misfit_sigmas(2) / neotec_external_OR_misfit_count) neotec_external_OR_misfit_mmpa(1) = neotec_external_OR_misfit_mmpa(1) / neotec_external_OR_misfit_count neotec_external_OR_misfit_mmpa(2) = SQRT(neotec_external_OR_misfit_mmpa(2) / neotec_external_OR_misfit_count) END IF IF (systematic_external_OR_denominator > 0.0D0) THEN systematic_external_OR_ratio = systematic_external_OR_numerator / systematic_external_OR_denominator ELSE ! cannot /0.0 systematic_external_OR_ratio = 0.0D0 ! (actually, undefined) END IF WRITE (*, *) ! create prominent report, on-screen, and in REPORT.txt file: WRITE (21, *) WRITE (*, "(' -----------------------------------------------------------------------------')") WRITE (21, "('-----------------------------------------------------------------------------')") WRITE (*, "(' Measures of misfit between model fault offset rates and external Holocene rates:')") WRITE (21, "('Measures of misfit between model fault offset rates and external Holocene rates')") IF (neotec_external_OR_misfit_count == 0) THEN WRITE (*, "(' could not be computed because NO actual values were found in columns 7~8 of the f_rst file.')") WRITE (21, "('could not be computed because NO actual values were found in columns 7~8 of the f_rst file.')") ELSE ! normal case: WRITE (*, "(' Worst Mean(ABS) RMS')") WRITE (21, "(' Worst Mean(ABS) RMS')") WRITE (*, "(' Misfits in mm/a: ', 3F12.3)") neotec_external_OR_misfit_mmpa(0:2) WRITE (21, "('Misfits in mm/a: ', 3F12.3)") neotec_external_OR_misfit_mmpa(0:2) WRITE (*, "(' Misfits in sigmas: ', 3F12.3)") neotec_external_OR_misfit_sigmas(0:2) WRITE (21, "('Misfits in sigmas: ', 3F12.3)") neotec_external_OR_misfit_sigmas(0:2) WRITE (*, "(' based on ',I6, ' external neotectonic offset rates available in columns 7~8 of the f_rst file.')") neotec_external_OR_misfit_count WRITE (21, "('based on ',I6, ' external neotectonic offset rates available in columns 7~8 of the f_rst file.')") neotec_external_OR_misfit_count WRITE (*, "(' Worst misfit in mm/a was at f_rst line ',I6,': ',A)") (2+neotec_external_OR_misfit_checkThis_mmpa), & & TRIM(f_dig_faultName_lines(which_trace(neotec_external_OR_misfit_checkThis_mmpa))) WRITE (21, "('Worst misfit in mm/a was at f_rst line ',I6,': ',A)") (2+neotec_external_OR_misfit_checkThis_mmpa), & & TRIM(f_dig_faultName_lines(which_trace(neotec_external_OR_misfit_checkThis_mmpa))) WRITE (*, "(' Worst misfit in sigmas was at f_rst line ',I6,': ',A)") (2+neotec_external_OR_misfit_checkThis_sigmas), & & TRIM(f_dig_faultName_lines(which_trace(neotec_external_OR_misfit_checkThis_sigmas))) WRITE (21, "('Worst misfit in sigmas was at f_rst line ',I6,': ',A)") (2+neotec_external_OR_misfit_checkThis_sigmas), & & TRIM(f_dig_faultName_lines(which_trace(neotec_external_OR_misfit_checkThis_sigmas))) WRITE (*, "(' Ratio of sum-of-rates / sum-of-external-correct-rates = ', F7.3, ' (should be 1.000)')") systematic_external_OR_ratio WRITE (21, "('Ratio of sum-of-rates / sum-of-external-correct-rates = ', F7.3, ' (should be 1.000)')") systematic_external_OR_ratio END IF WRITE (*, "(' -----------------------------------------------------------------------------')") WRITE (21, "('-----------------------------------------------------------------------------')") WRITE (*, *) WRITE (21, *) ! ----------------------------------------------------------------------------------------------------------------------------------------------- !Statistics of errors in stress-directions of continuum elements; !only showing absolute errors in degrees, because "sigmas" computed within Restore4 !are debatable ("Which method of interpolation did you use?") and hard to explain to the user. WRITE (*, "(' -----------------------------------------------------------------------------')") WRITE (21, "('-----------------------------------------------------------------------------')") WRITE (*, "(' Measures of misfit between interpolated-stress goals & actual directions')") WRITE (21, "('Measures of misfit between interpolated-stress goals & actual directions')") IF (s_error_element_count <= 0) THEN WRITE (*, "(' could not be computed because NO stress-direction data used in this run.')") WRITE (21, "('could not be computed because NO stress-direction data used in this run.')") ELSE ! normal case; s_error_element_count > 0 WRITE (*, "(' Worst Mean(ABS) RMS')") WRITE (21, "(' Worst Mean(ABS) RMS')") WRITE (*, "(' Misfits in degrees: ', 3F12.3)") s_error_degrees(0:2) WRITE (21, "('Misfits in degrees: ', 3F12.3)") s_error_degrees(0:2) WRITE (*, "(' based on all ',I8,' elements.')") s_error_element_count WRITE (21, "('based on all ',I8,' elements.')") s_error_element_count END IF WRITE (*, "(' -----------------------------------------------------------------------------')") WRITE (21, "('-----------------------------------------------------------------------------')") 999 WRITE (*, *) CALL DPrompt_for_Logical("Do you want to test neotectonic velocities against GPS?", .TRUE., compare_to_GPS) IF (compare_to_GPS) THEN CALL DPrompt_for_String("Enter name of a .GPS-format file for this region:", "wus5.omeS.gps", GPS_comparison_file) OPEN (UNIT = 1, FILE = TRIM(GPS_comparison_file), STATUS = "OLD", IOSTAT = ios) IF (ios /= 0) CALL File_not_found(GPS_comparison_file) IF (ios == 0) THEN WRITE (21, ' ') WRITE (21, "('Neotectonic velocities will be compared to GPS velocities in file')") WRITE (21, "(A)") TRIM(GPS_comparison_file) READ (1, "(A)") GPS_comparison_title READ (1, "(A)") GPS_comparison_format READ (1, "(A)") GPS_comparison_headers neotec_GPS_misfit_count = 0 ! counting components; = 2 * benchmarks (in FEG area) neotec_GPS_misfit_mmpa = 0.0D0 ! all (0:2) values neotec_GPS_misfit_sigmas = 0.0D0 ! all (0:2) values neotec_GPS_misfit_checkThis_mmpa = 0 neotec_GPS_misfit_checkThis_sigmas = 0 systematic_GPS_numerator = 0.0D0 systematic_GPS_denominator = 0.0D0 GPS_line = 3 ! (headers already READ) GPS_glitches = 0 GPS_iele = 1 ! initialized, for first CALL Internal (afterwards, floating) reading_GPS: DO ! indefinite loop, depends on length of .GPS data file READ (1, GPS_comparison_format, IOSTAT = ios) GPS_Elon, GPS_Nlat, GPS_Ve, GPS_Vn, GPS_Se, GPS_Sn; GPS_line = GPS_line + 1 IF (ios /= 0) THEN ! error-handler: IF (ios < 0) EXIT reading_GPS ! EOF encountered GPS_glitches = GPS_glitches + 1 IF (GPS_glitches <= 10) THEN WRITE (*, "(' CAUTION: READ of ', A ,' failed in line ',I6)") TRIM(GPS_comparison_file), GPS_line WRITE (21, "('CAUTION: READ of ', A ,' failed in line ',I6)") TRIM(GPS_comparison_file), GPS_line END IF CYCLE reading_GPS ! don't process this record, but don't give up on the whole GPS file [or the Restore4 run!], either. END IF !Convert all component rates & sigmas from mm/a --> m/s: GPS_Ve = GPS_Ve * 1.0D-3 / s_per_year GPS_Vn = GPS_Vn * 1.0D-3 / s_per_year GPS_Se = GPS_Se * 1.0D-3 / s_per_year GPS_Sn = GPS_Sn * 1.0D-3 / s_per_year !Convert benchmark from (Elon, Nlat) to a unit vector: CALL Xyz_from_lonlat (GPS_Elon, GPS_Nlat, GPS_uvec) CALL Internal (GPS_uvec, GPS_iele, GPS_s1, GPS_s2, GPS_s3) IF (GPS_iele > 0) THEN ! This benchmark is inside the .FEG area. !Get model velocity components here: CALL Gjxy(GPS_iele, GPS_uvec, G) ! returning G, which is a local REAL*8(3,2,2) array specific to this element and uvec. CALL Components(GPS_iele, G, vw0, GPS_site_v, GPS_site_w) ! where GPS_site_v, w are outputs (scalar REAL*8 components, to S and E) !Build toward measures of overall misfit: neotec_GPS_misfit_count = neotec_GPS_misfit_count + 2 ! (2 components: v, w = S, E) GPS_misfit_in_mps(1) = +GPS_site_w - GPS_Ve ! E component of misfit GPS_misfit_in_mps(2) = -GPS_site_v - GPS_Vn ! N component of misfit !build toward misfit measures in dimensionless units of sigmas: GPS_misfit_in_sigmas(1) = GPS_misfit_in_mps(1) / GPS_Se GPS_misfit_in_sigmas(2) = GPS_misfit_in_mps(2) / GPS_Sn IF (ABS(GPS_misfit_in_sigmas(1)) > neotec_GPS_misfit_sigmas(0)) THEN neotec_GPS_misfit_checkThis_sigmas = i ! remember location of worst misfit neotec_GPS_misfit_sigmas(0) = ABS(GPS_misfit_in_sigmas(1)) END IF ! component (1) of misfit is the worst yet IF (ABS(GPS_misfit_in_sigmas(2)) > neotec_GPS_misfit_sigmas(0)) THEN neotec_GPS_misfit_checkThis_sigmas = i ! remember location of worst misfit neotec_GPS_misfit_sigmas(0) = ABS(GPS_misfit_in_sigmas(2)) END IF ! component (2) of misfit is the worst yet neotec_GPS_misfit_sigmas(1) = neotec_GPS_misfit_sigmas(1) + ABS(GPS_misfit_in_sigmas(1)) + ABS(GPS_misfit_in_sigmas(2)) neotec_GPS_misfit_sigmas(2) = neotec_GPS_misfit_sigmas(2) + GPS_misfit_in_sigmas(1)**2 + GPS_misfit_in_sigmas(2)**2 !build toward misfit measures in dimensional units of mm/a: GPS_misfit_in_mmpa(1) = GPS_misfit_in_mps(1) * 1000.0D0 * s_per_year GPS_misfit_in_mmpa(2) = GPS_misfit_in_mps(2) * 1000.0D0 * s_per_year IF (ABS(GPS_misfit_in_mmpa(1)) > neotec_GPS_misfit_mmpa(0)) THEN neotec_GPS_misfit_checkThis_mmpa = i ! remember location of worst misfit neotec_GPS_misfit_mmpa(0) = ABS(GPS_misfit_in_mmpa(1)) END IF ! component (1) of misfit in mm/a is the worst yet IF (ABS(GPS_misfit_in_mmpa(2)) > neotec_GPS_misfit_mmpa(0)) THEN neotec_GPS_misfit_checkThis_mmpa = i ! remember location of worst misfit neotec_GPS_misfit_mmpa(0) = ABS(GPS_misfit_in_mmpa(2)) END IF ! component (2) of misfit in mm/a is the worst yet neotec_GPS_misfit_mmpa(1) = neotec_GPS_misfit_mmpa(1) + ABS(GPS_misfit_in_mmpa(1)) + ABS(GPS_misfit_in_mmpa(2)) neotec_GPS_misfit_mmpa(2) = neotec_GPS_misfit_mmpa(2) + GPS_misfit_in_mmpa(1)**2 + GPS_misfit_in_mmpa(2)**2 !build toward ratio of sum of offset rates, over sum of correct offset rates: systematic_GPS_numerator = systematic_GPS_numerator + ABS(GPS_site_v) + ABS(GPS_site_w) systematic_GPS_denominator = systematic_GPS_denominator + ABS(GPS_Ve) + ABS(GPS_Vn) END IF ! This benchmark is within the .FEG area. END DO reading_GPS CLOSE (1) ! GPS_comparison_file IF (neotec_GPS_misfit_count > 0) THEN neotec_GPS_misfit_sigmas(1) = neotec_GPS_misfit_sigmas(1) / neotec_GPS_misfit_count neotec_GPS_misfit_sigmas(2) = SQRT(neotec_GPS_misfit_sigmas(2) / neotec_GPS_misfit_count) neotec_GPS_misfit_mmpa(1) = neotec_GPS_misfit_mmpa(1) / neotec_GPS_misfit_count neotec_GPS_misfit_mmpa(2) = SQRT(neotec_GPS_misfit_mmpa(2) / neotec_GPS_misfit_count) END IF IF (systematic_GPS_denominator > 0.0D0) THEN systematic_GPS_ratio = systematic_GPS_numerator / systematic_GPS_denominator ELSE ! cannot /0.0 systematic_GPS_ratio = 0.0D0 ! (actually, undefined) END IF ! create prominent report, on-screen, and in REPORT.txt file: WRITE (*, "(' -----------------------------------------------------------------------------')") WRITE (21, "('-----------------------------------------------------------------------------')") WRITE (*, "(' Measures of misfit between neotectonic velocities and GPS')") WRITE (21, "('Measures of misfit between neotectonic velocities and GPS')") IF (neotec_GPS_misfit_count == 0) THEN WRITE (*, "(' could not be computed because NO local values were found in the .GPS file.')") WRITE (21, "('could not be computed because NO local values were found in the .GPS file.')") ELSE ! normal case: WRITE (*, "(' Worst Mean(ABS) RMS')") WRITE (21, "(' Worst Mean(ABS) RMS')") WRITE (*, "(' Misfits in mm/a: ', 3F12.3)") neotec_GPS_misfit_mmpa(0:2) WRITE (21, "('Misfits in mm/a: ', 3F12.3)") neotec_GPS_misfit_mmpa(0:2) WRITE (*, "(' Misfits in sigmas: ', 3F12.3)") neotec_GPS_misfit_sigmas(0:2) WRITE (21, "('Misfits in sigmas: ', 3F12.3)") neotec_GPS_misfit_sigmas(0:2) WRITE (*, "(' based on ',I6, ' GPS components within the .FEG area.')") neotec_GPS_misfit_count WRITE (21, "('based on ',I6, ' GPS components within the .FEG area.')") neotec_GPS_misfit_count WRITE (*, "(' Worst misfit in mm/a was at .GPS line ',I6)") (3+neotec_GPS_misfit_checkThis_mmpa) WRITE (21, "('Worst misfit in mm/a was at .GPS line ',I6)") (3+neotec_GPS_misfit_checkThis_mmpa) WRITE (*, "(' Worst misfit in sigmas was at .GPS line ',I6)") (3+neotec_GPS_misfit_checkThis_sigmas) WRITE (21, "('Worst misfit in sigmas was at .GPS line ',I6)") (3+neotec_GPS_misfit_checkThis_sigmas) WRITE (*, "(' Ratio of sum-of-rates / sum-of-correct-rates = ', F7.3, ' (should be 1.000)')") systematic_GPS_ratio WRITE (21, "('Ratio of sum-of-rates / sum-of-correct-rates = ', F7.3, ' (should be 1.000)')") systematic_GPS_ratio WRITE (*, "(' CAUTION: Keep in mind that this comparison is only a rough guide, because')") WRITE (*, "(' model velocities are long-term-average, but GPS are interseismic.')") WRITE (21, "('CAUTION: Keep in mind that this comparison is only a rough guide, because')") WRITE (21, "(' model velocities are long-term-average, but GPS are interseismic.')") END IF WRITE (*, "(' -----------------------------------------------------------------------------')") WRITE (21, "('-----------------------------------------------------------------------------')") WRITE (*, *) WRITE (21, *) CALL Pause() ! (for reading) ELSE ! named GPS_comparison_file not found in current folder WRITE (*, "(' ERROR: This file not found in current folder.')") CALL Pause() GO TO 999 END IF ! GPS_comparison_file was opened, or not END IF ! compare_to_GPS (desired?) END IF ! paleotec (summary statistics of misfit errors in this iteration); *OR*, neotec (compare to external datasets) IF (paleotec) THEN adjust_rates_now = (iteration < last_iteration).AND.(ABS(t1 - ultimate_age_Ma) < 0.001D0) ! (t1 == ultimate_age_Ma), but allowing for numerical error IF (adjust_rates_now) THEN ! Adjust goals for next iteration based on actual rates ! (which may come from iteration just finished or from restart datasets), ! and then output them in special end-of-time .rst files. IF ((f_rst_count + c_rst_count + p_rst_count) > 0) THEN WRITE (*, "(' Assigning revised goals for the next iteration...')") j1 = 0; j2 = 0 ! numerator and denominator of %-adjusted !Define the current filename_suffix using the current older-end-of-timestep: filename_suffix = Mangle(last_iteration, total_iterations, time1) END IF IF (f_rst_count > 0) THEN CALL New_goal (count = f_rst_count, total = offset, & & tmin = f_t_min, tmax = f_t_max, checkPD = .TRUE., rate = f_rate, & ! inputs & goal = f_goal, active = f_active, n_adjusted = j3) ! outputs j1 = j1 + j3 j2 = j2 + f_in_time_and_space filename = Insert (f_rst, filename_suffix) CALL Write_f_rst(filename) END IF IF (c_rst_count > 0) THEN CALL New_goal (count = c_rst_count, total = c_stretch, & & tmin = c_t_min, tmax = c_t_max, checkPD = .FALSE., rate = c_rate, & ! inputs & goal = c_goal, active = c_active, n_adjusted = j3) ! outputs j1 = j1 + j3 j2 = j2 + c_in_time_and_space filename = Insert (c_rst, filename_suffix) CALL Write_c_rst(filename) END IF IF (p_rst_count > 0) THEN CALL New_goal (count = p_rst_count, total = p_south, & & tmin = p_t_min, tmax = p_t_max, checkPD = .FALSE., rate = p_south_rate, & ! inputs & goal = p_south_goal, active = p_active, n_adjusted = j3) ! outputs j1 = j1 + j3 j2 = j2 + p_in_time_and_space CALL New_goal (count = p_rst_count, total = p_ccw, & & tmin = p_t_min, tmax = p_t_max, checkPD = .FALSE., rate = p_ccw_rate, & ! inputs & goal = p_ccw_goal, active = p_active, n_adjusted = j3) ! outputs j1 = j1 + j3 j2 = j2 + p_in_time_and_space filename = Insert (p_rst, filename_suffix) CALL Write_p_rst(filename) END IF IF ((f_rst_count + c_rst_count + p_rst_count) > 0) THEN t = 100.0D0 * DBLE(j1) / DBLE(j2) WRITE (*, "('+','Assigning revised goals for the next iteration: ',F6.2,'% adjusted')") t WRITE (21,"('Assigning revised goals for the next iteration: ',F6.2,'% adjusted')") t adjustments(iteration) = t END IF ELSE ! no adjustment now adjustments(iteration) = 0.0D0 END IF ! adjust_rates_now, or not END IF ! paleotec END DO outer_loop ! iterations of the whole history, with INTEGER counter "iteration" !=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* ! Output paired before.feg and after.feg !(from which all un-integratible nodes and their elements have ! been deleted, all nodal data have been restored {in position only}, and ! all element data have been deleted): IF (paleotec) THEN !At beginning of this run (either 0, or an intermeditate age where regridding & restart occurred): filename_suffix = Mangle(last_iteration, total_iterations, start_time) after_filename = Insert ("after.feg", filename_suffix) !At end of this run (earliest geologic time reached): filename_suffix = Mangle(last_iteration, total_iterations, time1) before_filename = Insert ("before.feg", filename_suffix) CALL Write_before_and_after_feg (before_filename, after_filename) END IF ! paleotec ! Review error histories, for convergence studies IF (paleotec) THEN IF (adjust_rates_now) THEN ! review history of goal adjustments WRITE (*, "(' ','Review of goal adjustments in each iteration:')") WRITE (21,"('Review of goal adjustments in each iteration:')") WRITE (*, "(' ','Iteration %-adjusted')") WRITE (21,"('Iteration %-adjusted')") DO i = 1, max_iter j = i + past_iterations WRITE (*, "(' ',I5,F13.2,'%')") j, adjustments(i) WRITE (21,"(I5,F13.2,'%')") j, adjustments(i) END DO ! all rate errors (combines all data with a-priori zero-strains) WRITE (*, "(' ','Review of mean rate errors in each iteration:')") WRITE (21,"('Review of mean rate errors in each iteration:')") WRITE (*, "(' ','(these will not always converge, as rate goals shift)')") WRITE (21,"('(these will not always converge, as rate goals shift)')") WRITE (*, "(' ','Iteration N0 N1 N2')") WRITE (21,"('Iteration N0 N1 N2')") DO i = 1, max_iter j = i + past_iterations WRITE (*, "(' ',I5,F8.3,F7.3,F7.3)") j, rate_err(0,0,i),rate_err(1,0,i),rate_err(2,0,i) WRITE (21,"(I5,F8.3,F7.3,F7.3)") j, rate_err(0,0,i),rate_err(1,0,i),rate_err(2,0,i) END DO ! fault offset errors IF (f_rst_count > 0) THEN WRITE (*, "(' ','Review of fault offset errors in each iteration:')") WRITE (21,"('Review of fault offset errors in each iteration:')") WRITE (*, "(' ','Iteration L0 L1 L2')") WRITE (21,"('Iteration L0 L1 L2')") DO i = 0, max_iter j = i + past_iterations WRITE (*, "(' ',I5,F8.3,F7.3,F7.3)") j, f_err(0,i),f_err(1,i),f_err(2,i) WRITE (21,"(I5,F8.3,F7.3,F7.3)") j, f_err(0,i),f_err(1,i),f_err(2,i) END DO END IF ! cross-section errors IF (c_rst_count > 0) THEN WRITE (*, "(' ','Review of cross-section errors in each iteration:')") WRITE (21,"('Review of cross-section errors in each iteration:')") WRITE (*, "(' ','Iteration L0 L1 L2')") WRITE (21,"('Iteration L0 L1 L2')") DO i = 0, max_iter j = i + past_iterations WRITE (*, "(' ',I5,F8.3,F7.3,F7.3)") j, c_err(0,i),c_err(1,i),c_err(2,i) WRITE (21,"(I5,F8.3,F7.3,F7.3)") j, c_err(0,i),c_err(1,i),c_err(2,i) END DO END IF ! paleolatitude errors IF (p_rst_count > 0) THEN WRITE (*, "(' ','Review of paleolatitude errors in each iteration:')") WRITE (21,"('Review of paleolatitude errors in each iteration:')") WRITE (*, "(' ','Iteration L0 L1 L2')") WRITE (21,"('Iteration L0 L1 L2')") DO i = 0, max_iter j = i + past_iterations WRITE (*, "(' ',I5,F8.3,F7.3,F7.3)") j, p_south_err(0,i),p_south_err(1,i),p_south_err(2,i) WRITE (21,"(I5,F8.3,F7.3,F7.3)") j, p_south_err(0,i),p_south_err(1,i),p_south_err(2,i) END DO ! vertical-axis rotation errors WRITE (*, "(' ','Review of vertical-axis rotation errors in each iteration:')") WRITE (21,"('Review of vertical-axis rotation errors in each iteration:')") WRITE (*, "(' ','Iteration L0 L1 L2')") WRITE (21,"('Iteration L0 L1 L2')") DO i = 0, max_iter j = i + past_iterations WRITE (*, "(' ',I5,F8.3,F7.3,F7.3)") j, p_ccw_err(0,i),p_ccw_err(1,i),p_ccw_err(2,i) WRITE (21,"(I5,F8.3,F7.3,F7.3)") j, p_ccw_err(0,i),p_ccw_err(1,i),p_ccw_err(2,i) END DO END IF ! p_rst_count > 0 END IF ! adjust_rates_now END IF ! paleotec; need iteration history ! final time stamp, and close CALL DATE_AND_TIME (date, clock_time, zone, datetimenumber) WRITE (21,"('Run ended on ',I4,'.',I2,'.',I2,' at ',I2,':',I2,':',I2)") & datetimenumber(1), datetimenumber(2), datetimenumber(3), & datetimenumber(5), datetimenumber(6), datetimenumber(7) WRITE (21, "('===========================================================')") CLOSE (UNIT = 21) ! close REPORT.txt WRITE (*, "(' Successful termination of Restore; see REPORT.txt.')") !============================================================================== CONTAINS ! Any code that would otherwise be typed repeatedly SUBROUTINE Add_datum(prefix, f_, g_, goal, A, C, D, E, F) ! Adds a datum to the linear system of one element. ! Note that only the diagonal and lower triangle are filled; ! the upper triangle can be copied, because the matrix is symmetric. ! Note that "prefix" contains all weight factors for this datum, ! including both the systematic weights for all data in a class !(such as A_0, L_0), and also the specific sigma**(-2) factor for ! that specific "goal", based on its uncertainty. IMPLICIT NONE REAL*8, INTENT(IN) :: prefix, goal REAL*8, DIMENSION(3), INTENT(IN) :: f_,g_ REAL*8, DIMENSION(3,3), INTENT(INOUT) :: A,C,D REAL*8, DIMENSION(3), INTENT(INOUT) :: E,F INTEGER i, j DO i = 1, 3 DO j = 1, 3 IF (j <= i) THEN ! diagonal and lower triangle only A(i,j) = A(i,j) + prefix * f_(i) * f_(j) D(i,j) = D(i,j) + prefix * g_(i) * g_(j) END IF ! All of B lies in the upper triangle; transpose of C ! B(i,j) = B(i,j) + prefix * f_(i) *g_(j) ! All of C lies in lower triangle C(i,j) = C(i,j) + prefix * g_(i) * f_(j) END DO ! on j = 1, 6 E(i) = E(i) + prefix * f_(i) * goal F(i) = F(i) + prefix * g_(i) * goal END DO ! on i = 1, 6 END SUBROUTINE Add_datum REAL*8 FUNCTION Arc_distance (a, b) ! distance in radians along a great circle from a to b, ! which are both Cartesian unit vectors IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: a, b REAL*8, DIMENSION(3) :: tv REAL*8 :: cosa, sina cosa = Dot_3D( a, b ) CALL Cross(a, b, tv) sina = Magnitude ( tv ) Arc_distance = ATAN2(sina, cosa) END FUNCTION Arc_distance REAL*8 FUNCTION ATan2F(y, x) ! works like ATAN2 but corrects for case of (0.0D0, 0.0D0). ! returns inverse tangent in radians. REAL*8, INTENT(IN) :: y, x IF (y == 0.0D0) THEN IF (x == 0.0D0) THEN ATan2F = 0.0D0 ELSE ATan2F = ATAN2(y, x) END IF ELSE ATan2F = ATAN2(y, x) END IF END FUNCTION ATan2F SUBROUTINE Check_range (filename, line) IMPLICIT NONE CHARACTER(*), INTENT(IN) :: filename INTEGER, INTENT(IN) :: line WRITE (*, "(' Error: Integer out of range in line ',I5,' of '/' ',A)") line, TRIM(filename) WRITE (21,"('Error: Integer out of range in line ',I5,' of '/A)") line, TRIM(filename) CALL Pause() STOP END SUBROUTINE Check_range SUBROUTINE Compact_Basemap() !Note that this routine should ONLY be called IF: (1) paleotec; AND (2) basemap in use. !Compacts the points-list of each object in the basemap by removing any points that have basemap_point_is(:)%element = 0. !This deletion-flag might result from (a) point outside the FEG area; OR (b) point inside a major_fault_element(:) == .TRUE. (IF faults are in use). !Note that no basemap objects are deleted, and no basemap objects are moved in memory. !Values of basemap_object_index(4, :) and basemap_object_index(6, :) are reduced in these cases. !Potentially, some objects may end up with (only titles, and) zero or one points; if so, !subprogram Write_y_dig "understands" that it should not write these objects out in paleo-basemap files. IMPLICIT NONE ! and all arrays mentioned are global. INTEGER :: i, i1, i2, j, l_, new_points, object, old_points DO object = 1, basemap_object_count old_points = basemap_object_index(4, object) IF (old_points > 0) THEN ! this number might potentially be reduced !Count new_points: new_points = 0 ! just initializing, before count i1 = basemap_object_index(5, object) i2 = basemap_object_index(6, object) DO i = i1, i2 l_ = basemap_point_is(i)%element IF (l_ > 0) new_points = new_points + 1 END DO ! i = i1, i2 !Now, decide whether compaction is needed in this object: IF (new_points < old_points) THEN ! COMPACT: IF (new_points == 0) THEN ! easy case basemap_object_index(4:6, object) = 0 ELSE ! new_points is still positive; points must be shifted! i = i1 !N.B. NOT using a DO-index because it will be necessary to loop twice (or more) on same value of i. compacting_points: DO IF (basemap_point_is(i)%element > 0) THEN ! no problem; keep this point i = i + 1 ! prepare to loop (or exit) ELSE ! eliminate this point #i from all arrays, and from count! !Note that i is not incremented in this branch; must check the NEW #i on the next loop-through. IF (i < i2) THEN ! (otherwise, no need to shift; just drop end-point) DO j = i, (i2 - 1) basemap_point_is(j) = basemap_point_is(j+1) basemap_uvec_store(1:3, j) = basemap_uvec_store(1:3, j+1) END DO ! j = i, (i2 - 1) END IF ! i < i2; shifting points i2 = i2 - 1 END IF ! point is to be kept, or deleted IF (i > i2) EXIT compacting_points ! Note that, on each pass, either i increases, or i2 decreases. So, no infinite-loop! END DO compacting_points basemap_object_index(4, object) = new_points basemap_object_index(6, object) = basemap_object_index(5, object) + new_points - 1 END IF ! simple vs. complex compaction case END IF ! new_points < old_points END IF ! old_points > 0 END DO ! object = 1, basemap_object_count END SUBROUTINE Compact_Basemap SUBROUTINE Components(l_, G, vw, v_, w_) ! Given element l_ and local nodal functions G, ! computes South- and East-components of velocity (v_, w_) ! from the long-vector form vw. IMPLICIT NONE INTEGER, INTENT(IN) :: l_ REAL*8, DIMENSION(3,2,2), INTENT(IN) :: G REAL*8, DIMENSION(:), INTENT(IN) :: vw REAL*8, INTENT(OUT) :: v_, w_ INTEGER :: iv, iw, j v_ = 0.0D0 w_ = 0.0D0 DO j = 1, 3 iv = 2 * node(j, l_) - 1 iw = iv + 1 v_ = v_ + G(j,1,1) * vw(iv) + G(j,2,1) * vw(iw) w_ = w_ + G(j,1,2) * vw(iv) + G(j,2,2) * vw(iw) END DO END SUBROUTINE Components SUBROUTINE Coordinate_Segments() ! When 2 segments meet in an angled "knee" joint, inside a common element, ! their collective effect is *NOT* well described ! by seg_kappa_ values that may add to much more (or less) than 1.0D0, ! nor by seg_u_ values that might identify different isolated nodes, ! nor by possibly inconsistent seg_eta_ values (of -1.0D0 or +1.0D0) ! that refer to these originally distinct seg_u_ nodes. ! It is necessary to coordinate these segment attributes so that, after this subprogram ! finishes working, these pairs will have seg_kappa_ values that add to 1.0D0, ! and they will have seg_u_ values that agree about the isolated node, and also ! seg_eta_ values consistent with that (possibly new) seg_u_ ! and with their (individual) directions of digitization progress. ! Conceptually, it is like bending the segments at the knee until it is straight, ! while keeping the fault entry-points and exit-points fixed, and allowing ! the knee to move to a different location inside the common element. ! But, note that NO changes are made to the actual recorded locations of the segments ! (either in terms of internal coordinates seg_end_is, or external coordinates seg_end). ! Another special case that I deal with here is a knee joint between 2 segments ! that both pass through the SAME side of the element. ! Such segment pairs should be deactivated in both global and local solutions ! (for purposes of computing nodal velocities & in-element strain-rates), ! but not eliminated for purposes of plotting fault traces as segment-groups), ! and here I eliminate their impact by setting their seg_kappa_ values to 0.0D0 . ! (Note that an operation with similar intention is performed by Unloop_Trace(), ! prior to the definition of segments--but that cannot catch any cases ! where 2 different closely-coupled fault traces are involved in the loop!) ! This correction is especially important for ridge-transform corners (RT corners) ! in any symmetric_spreading_system, but is also valuable wherever ! a transform (or "tear") fault meets a dip-slip fault at a large angle. ! Written 2020.05.02 for addition to both Restore4 and NeoKinema. IMPLICIT NONE ! Note that all large arrays (and their current in-use length, seg_count) are global variables: ! INTEGER, INTENT(IN) :: seg_count ! INTEGER, DIMENSION(2, :), INTENT(IN) :: seg_def ! REAL*8, DIMENSION(3, 2, :), INTENT(IN) :: seg_end ! TYPE(is123), DIMENSION(:), INTENT(IN) :: seg_end_is ! REAL*8, DIMENSION(:), INTENT(MODIFY) :: seg_eta_, seg_kappa_ ! INTEGER, DIMENSION(:), INTENT(MODIFY) :: seg_u_ !Following declarations are for small, temporary internal variables & arrays: INTEGER :: coordinations, element1, element2, entry_side, exit_side, isolated_node, segment1, segment2 INTEGER, DIMENSION(1) :: array ! stupid one-element "vector", to satisfy MINLOC type specification LOGICAL :: same_side ! (if true, a problem) REAL*8, PARAMETER :: tolerance_m = 1000.D0 ! permissible mismatch in a knee (1 km); allows for roundoff errors REAL*8 :: kappa_sum, kappa_scale REAL*8 :: seg1start_m_seg2start, seg1start_m_seg2end, seg1end_m_seg2start, seg1end_m_seg2end ! distances in m between segment starts/ends REAL*8, DIMENSION(3) :: seg1start, seg1end, seg2start, seg2end ! Cartesian unit vectors REAL*8, DIMENSION(3) :: s_magnitudes TYPE(is123) :: entry, exit coordinations = 0 DO segment1 = 1, (seg_count - 1) IF (seg_kappa_(segment1) <= 0.99D0) THEN ! Segment has (at least) one free end inside the element. element1 = seg_def(2, segment1) seg1start(1:3) = seg_end(1:3, 1, segment1) seg1end(1:3) = seg_end(1:3, 2, segment1) DO segment2 = (segment1 + 1), seg_count ! Note that these loop limits mean that each possible pair is considered only ONCE. IF (seg_kappa_(segment2) <= 0.99D0) THEN ! Segment has (at least) one free end inside the element. element2 = seg_def(2, segment2) IF (element1 == element2) THEN ! both segments (with free ends) are in the same element !Now, check whether they share an end-point (in any of 4 possible ways)? seg2start(1:3) = seg_end(1:3, 1, segment2) seg2end(1:3) = seg_end(1:3, 2, segment2) seg1start_m_seg2start = R * DArc (seg1start, seg2start) seg1start_m_seg2end = R * DArc (seg1start, seg2end ) seg1end_m_seg2start = R * DArc (seg1end , seg2start) seg1end_m_seg2end = R * DArc (seg1end , seg2end ) IF (seg1start_m_seg2start <= tolerance_m) THEN ! <==== found a knee! !Divergent case: Both segments start at the knee; !arbitrarily defining the entry side according to segment1: entry = seg_end_is(2, segment1) exit = seg_end_is(2, segment2) s_magnitudes(1:3) = ABS(entry%s(1:3)) array = MINLOC(s_magnitudes) ! 1, 2, or 3 entry_side = array(1) ! 1, 2, or 3 s_magnitudes(1:3) = ABS(exit%s(1:3)) array = MINLOC(s_magnitudes) exit_side = array(1) same_side = (entry_side == exit_side) ! comparing 2 INTEGERS IF (same_side) THEN ! I hope this is rare... seg_kappa_(segment1) = 0.0D0 ! So, neither will appear in crack_index, seg_kappa_(segment2) = 0.0D0 ! and they will not affect either the global or local solution. ELSE ! normal(?) case; entry and exit on different sides: isolated_node = 6 - entry_side - exit_side ! result: 1, 2, or 3 seg_u_(segment1) = isolated_node seg_u_(segment2) = isolated_node IF ((isolated_node == (entry_side+1)).OR.(isolated_node == (entry_side-2))) THEN ! isolated node is to the R of digitization direction for seg1, but to L for seg2: seg_eta_(segment1) = +1.0D0 ! R seg_eta_(segment2) = -1.0D0 ! L ELSE ! isolated node is to the L of digitization direction for seg1 but to R for seg2: seg_eta_(segment1) = -1.0D0 ! L seg_eta_(segment2) = +1.0D0 ! R END IF ! left or right kappa_sum = seg_kappa_(segment1) + seg_kappa_(segment2) IF (kappa_sum > 0.0D0) THEN ! normal case kappa_scale = 1.0D0 / kappa_sum seg_kappa_(segment1) = seg_kappa_(segment1) * kappa_scale seg_kappa_(segment2) = seg_kappa_(segment2) * kappa_scale END IF ! kappa_sum > 0.0; normal case END IF ! same_side, or not coordinations = coordinations + 1 ELSE IF (seg1start_m_seg2end <= tolerance_m) THEN ! <==== found a knee! !Shuffled progressive case; !both segments digitized in the same direction (around a plate boundary), !but segment2 comes before segment1 (along the digitization path). entry = seg_end_is(1, segment2) exit = seg_end_is(2, segment1) s_magnitudes(1:3) = ABS(entry%s(1:3)) array = MINLOC(s_magnitudes) ! 1, 2, or 3 entry_side = array(1) ! 1, 2, or 3 s_magnitudes(1:3) = ABS(exit%s(1:3)) array = MINLOC(s_magnitudes) exit_side = array(1) same_side = (entry_side == exit_side) ! comparing 2 INTEGERS IF (same_side) THEN ! I hope this is rare... seg_kappa_(segment1) = 0.0D0 ! So, neither will appear in crack_index, seg_kappa_(segment2) = 0.0D0 ! and they will not affect either the global or local solution. ELSE ! normal(?) case; entry and exit on different sides: isolated_node = 6 - entry_side - exit_side ! result: 1, 2, or 3 seg_u_(segment1) = isolated_node seg_u_(segment2) = isolated_node IF ((isolated_node == (entry_side+1)).OR.(isolated_node == (entry_side-2))) THEN ! isolated node is to the left of digitization direction: seg_eta_(segment1) = -1.0D0 seg_eta_(segment2) = -1.0D0 ELSE ! isolated node is to the right of digitization direction: seg_eta_(segment1) = +1.0D0 seg_eta_(segment2) = +1.0D0 END IF ! left or right kappa_sum = seg_kappa_(segment1) + seg_kappa_(segment2) IF (kappa_sum > 0.0D0) THEN ! normal case kappa_scale = 1.0D0 / kappa_sum seg_kappa_(segment1) = seg_kappa_(segment1) * kappa_scale seg_kappa_(segment2) = seg_kappa_(segment2) * kappa_scale END IF ! kappa_sum > 0.0; normal case END IF ! same_side, or not coordinations = coordinations + 1 ELSE IF (seg1end_m_seg2start <= tolerance_m) THEN ! <==== found a knee! !Simplest progressive case; end of seg1 connects to start of seg2 entry = seg_end_is(1, segment1) exit = seg_end_is(2, segment2) s_magnitudes(1:3) = ABS(entry%s(1:3)) array = MINLOC(s_magnitudes) ! 1, 2, or 3 entry_side = array(1) ! 1, 2, or 3 s_magnitudes(1:3) = ABS(exit%s(1:3)) array = MINLOC(s_magnitudes) exit_side = array(1) same_side = (entry_side == exit_side) ! comparing 2 INTEGERS IF (same_side) THEN ! I hope this is rare... seg_kappa_(segment1) = 0.0D0 ! So, neither will appear in crack_index, seg_kappa_(segment2) = 0.0D0 ! and they will not affect either the global or local solution. ELSE ! normal(?) case; entry and exit on different sides: isolated_node = 6 - entry_side - exit_side ! result: 1, 2, or 3 seg_u_(segment1) = isolated_node seg_u_(segment2) = isolated_node IF ((isolated_node == (entry_side+1)).OR.(isolated_node == (entry_side-2))) THEN ! isolated node is to the left of digitization direction: seg_eta_(segment1) = -1.0D0 seg_eta_(segment2) = -1.0D0 ELSE ! isolated node is to the right of digitization direction: seg_eta_(segment1) = +1.0D0 seg_eta_(segment2) = +1.0D0 END IF ! left or right kappa_sum = seg_kappa_(segment1) + seg_kappa_(segment2) IF (kappa_sum > 0.0D0) THEN ! normal case kappa_scale = 1.0D0 / kappa_sum seg_kappa_(segment1) = seg_kappa_(segment1) * kappa_scale seg_kappa_(segment2) = seg_kappa_(segment2) * kappa_scale END IF ! kappa_sum > 0.0; normal case END IF ! same_side, or not coordinations = coordinations + 1 ELSE IF (seg1end_m_seg2end <= tolerance_m) THEN ! <==== found a knee! !Collision case; 2 segments come together inside element; !arbitrarily considering entry side to be the segment1 side. entry = seg_end_is(1, segment1) exit = seg_end_is(1, segment2) s_magnitudes(1:3) = ABS(entry%s(1:3)) array = MINLOC(s_magnitudes) ! 1, 2, or 3 entry_side = array(1) ! 1, 2, or 3 s_magnitudes(1:3) = ABS(exit%s(1:3)) array = MINLOC(s_magnitudes) exit_side = array(1) same_side = (entry_side == exit_side) ! comparing 2 INTEGERS IF (same_side) THEN ! I hope this is rare... seg_kappa_(segment1) = 0.0D0 ! So, neither will appear in crack_index, seg_kappa_(segment2) = 0.0D0 ! and they will not affect either the global or local solution. ELSE ! normal(?) case; entry and exit on different sides: isolated_node = 6 - entry_side - exit_side ! result: 1, 2, or 3 seg_u_(segment1) = isolated_node seg_u_(segment2) = isolated_node IF ((isolated_node == (entry_side+1)).OR.(isolated_node == (entry_side-2))) THEN ! isolated node is to the left of segment1 digitization direction, but to R for seg2: seg_eta_(segment1) = -1.0D0 ! L seg_eta_(segment2) = +1.0D0 ! R ELSE ! isolated node is to the right of segment1 digitization direction, but to L for seg2: seg_eta_(segment1) = +1.0D0 ! R seg_eta_(segment2) = -1.0D0 ! L END IF ! left or right kappa_sum = seg_kappa_(segment1) + seg_kappa_(segment2) IF (kappa_sum > 0.0D0) THEN ! normal case kappa_scale = 1.0D0 / kappa_sum seg_kappa_(segment1) = seg_kappa_(segment1) * kappa_scale seg_kappa_(segment2) = seg_kappa_(segment2) * kappa_scale END IF ! kappa_sum > 0.0; normal case END IF ! same_side, or not coordinations = coordinations + 1 END IF ! any pair of segment end-points lie within tolerance_m of each other. END IF ! both segments are in the same element END IF ! segment2 has kappa_ <= 0.99 END DO ! segment2 = (segment1 + 1), seg_count END IF ! segment1 has kappa_ <= 0.99 END DO ! segment1 = 1, (seg_count - 1) END SUBROUTINE Coordinate_Segments SUBROUTINE Cross (a, b, c) IMPLICIT NONE REAL*8, DIMENSION(3) :: a, b, c ! vector cross product: c = a x b c(1) = a(2)*b(3) - a(3)*b(2) c(2) = a(3)*b(1) - a(1)*b(3) c(3) = a(1)*b(2) - a(2)*b(1) END SUBROUTINE Cross SUBROUTINE Def_seg_v2 (seg_count, savem) ! Defines fault segments. !(A fault segment is the intersection of one fault trace with one element.) ! IF (savem) THEN segments are recorded; otherwise just counted. ! This version 2 ("_v2") was created 24-27 November 2017, ! after it was discovered that the old Def_seg sometimes ! missed segments near the edges of the grid, in cases where ! adjacent digitized fault-trace points were far apart. !(Such cases were formerly rare, but now occur often because ! faults with the "symmetric_spreading_system" attribute ! or with the "other_spreading_system" attribute ! are often digitized using only their two end-points-- ! unless they project out through the model boundary, ! in which case they may require many small "sacrificial" ! digitization steps of ~1 km each along their trace.) IMPLICIT NONE CHARACTER*79 :: bar_graph INTEGER, INTENT(OUT) :: seg_count LOGICAL, INTENT(IN) :: savem INTEGER, PARAMETER :: library_size = 10000 ! Increase this if you get error messages. ! The current value should do if faults are digitized with point-spacings of 1 km or more. INTEGER :: a, b, e1, e2, ele, i, j, j1, j2, jin, jnew, jold, jout, k, & & n_hits, n_final_in_library, n_new_in_library, n_old_in_library, n_store, n_test_1, n_test_2, n_zero_length, number, & & temp_int, test_1st, test_2nd, which_neighbor, which_side INTEGER, DIMENSION(library_size) :: library_int ! Contains element# for each segment or sub-segment. LOGICAL :: all_in_one, hard_way, internal_step, neighbors, no_cut, overlap REAL*8 :: azimuth1, azimuth2, Elon, length, Nlat, s1, s2, s3 REAL*8, DIMENSION(3) :: omega_uvec, point1_uvec, point2_uvec, pole_a_uvec, pole_b_uvec, tuvec1, tuvec2, tvec, uvec1, uvec2, uvec3, vector REAL*8, DIMENSION(3) :: hit_s, s_triad REAL*8, DIMENSION(3, 3) :: hit_list REAL*8, DIMENSION(7) :: temp_R8 REAL*8, DIMENSION(7, library_size) :: library_R8 ! 1:3 = starting uvec; 4 = s (of midpoint) within digitization step; 5:7 = final uvec REAL*8, DIMENSION(:, :, :), ALLOCATABLE :: pole_cloud ! (1:3 = uvec, 1:3 = side, 1...numEl) !----------------------------------------------------------------------------------------------- IF (savem) THEN ! second CALL; arrays have been allocated; final seg_count is known in advance bar_graph(1:41) = ' Recording fault segments ' DO i = 42, 79 bar_graph(i:i) = CHAR(176) END DO WRITE (*, "(' ',A)") bar_graph WRITE (*, "('+',A)") bar_graph(1:41) jold = 0 WRITE (21,"(12X,'Recording fault segments')") ELSE ! initial CALL, just to determine number of segments (before ALLOCATEing arrays). WRITE (*, "(' ',12X,'Counting fault segments (SLOW) ...')") WRITE (21,"(12X,'Counting fault segments')") END IF ! savem, or not: determines messaging !----------------------------------------------------------------------------------------------- !To save time (in the ***HARD*** case below), create a dataset of poles to all element sides: ALLOCATE ( pole_cloud(3, 3, num_ele) ) DO i = 1, num_ele DO j = 1, 3 k = 1 + MOD (j, 3) ! has values 2, 3, 1 when j = 1, 2, 3 a = node(k, i) ! 1st node along side #j of element# i b = node(1 + MOD (k, 3), i) ! 2nd node along side #j of element# i uvec1(1:3) = xyz_nod(1:3, a) ! 1st node of side# which_neighbor of element# e1 uvec2(1:3) = xyz_nod(1:3, b) ! 2nd node of side# which_neighbor of element# e1 CALL DCross(uvec1, uvec2, tvec) CALL DMake_uvec(tvec, pole_a_uvec) pole_cloud(1:3, j, i) = pole_a_uvec(1:3) END DO ! j = 1, 3 END DO ! i = 1, numEl !----------------------------------------------------------------------------------------------- seg_count = 0 ! Initializing the global count of segments (including all faults). n_zero_length = 0 ! initializing this debugging variable, too. !----------------------------------------------------------------------------------------------- DO i = 1, f_highest ! Consider all possible fault trace #s (F0000, F0001, F0002, ... F9999?). f_highest is global trace_loc(3, i) = 0 ! In case no segments trace_loc(4, i) = 0 ! are found in grid. j1 = trace_loc(1, i) ! trace_loc is global. j2 = trace_loc(2, i) IF ((j1 > 0).AND.(j2 > j1).AND.f_relevant(i)) THEN ! This trace represented by at least 2 points in trace dataset, and did (or MIGHT) produce segment(s). !WRITE (*, "(' F',I4)") i !----------------------------------------------------------------------------------------------- !(Re-)initialize the library (which got dynamically re-ALLOCATED on each entry to Def_seg_v2) for this fault: n_old_in_library = 0 ! # of (sub-)segments in library, for this fault trace, but due to previous great-circle arcs n_new_in_library = 0 ! # of (sub-)segments in library, for this fault trace, and due to current great-circle arc !Note that we will NOT zero the library memory, as that wastes too much execution time! !----------------------------------------------------------------------------------------------- DO j = j1, (j2 - 1) ! consider each digitized point (except the last) as beginning of a great-circle arc !------------------------------------------------------------------------------------------------------------------------ !Improvement added 2020.07.14: !Check for points (at either end of step)) that have been banished because they fell outside the FEG area (at any time): internal_step = (.NOT.banished_DIG_point(j)).AND.(.NOT.banished_DIG_point(j+1)) !N.B. It is likely that the same result could have been obtained with: ! internal_step = (trace_is%element(j) > 0).AND.(trace_is%element(j+1) > 0) ! but the present method is probably more clear to the reader! !------------------------------------------------------------------------------------------------------------------------ !Check for zero-length digitization steps (due to repeated dig. points), and take no action on these... uvec1(1:3) = trace(1:3, j) uvec2(1:3) = trace(1:3, j + 1) length = DArc(uvec1, uvec2) !------------------------------------------------------------------------------------------------------------------------ IF (internal_step.AND.(length > 0.0D0)) THEN ! This digitization step is internal and has positive length; take it seriously... !Set LOGICAL switches: all_in_one, neighbors, and hard_way (which will control execution flow in blocks below): e1 = trace_is(j)%element ! Element containing start-point (or 0, for outside-the-grid). e2 = trace_is(j+1)%element ! Element containing end-point (or 0, for outside-the-grid). all_in_one = (e1 == e2).AND.(e1 > 0) neighbors = (e1 > 0).AND.(e2 > 0).AND.(e1 /= e2) ! As a minimum condition.... IF (neighbors) THEN ! Now, check more carefully... which_neighbor = 0 ! just initializing before tests... IF (e2 == neighbor(1, e1)) which_neighbor = 1 IF (e2 == neighbor(2, e1)) which_neighbor = 2 IF (e2 == neighbor(3, e1)) which_neighbor = 3 neighbors = (which_neighbor > 0) ELSE ! not neighbors which_neighbor = 0 END IF hard_way = .NOT.(all_in_one .OR. neighbors) ! BUT, actually hard_way MAY still get set to T (below) in cases with neighbors = T. !----------------------------------------------------------------------------------------------------------- IF (all_in_one) THEN ! Easiest case; both start- and end-point are located in the same element. n_new_in_library = n_new_in_library + 1 n_store = n_old_in_library + n_new_in_library IF (n_store > library_size) THEN WRITE (*, "(' ERROR: Increase PARAMETER library_size in Def_seg_v2.')") WRITE (21, "('ERROR: Increase PARAMETER library_size in Def_seg_v2.')") CALL Pause() STOP END IF library_int(n_store) = e1 ! == e2 library_R8(1:3, n_store) = trace(1:3, j) ! Start-point of great-circle arc library_R8(4, n_store) = 0.5D0 ! (which will not be used; just for clarity) library_R8(5:7, n_store) = trace(1:3, j+1) ! End-point of great-circle arc END IF ! all_in_one !----------------------------------------------------------------------------------------------------------- IF (neighbors) THEN ! Start- and end-point are in different elements, but they are in neighboring elements. !Find crossing-point where great-circle arc hits side #which_neighbor of element #e1: !"Small" circle 'a' (actually a great-circle) describes the side of element #e1: k = 1 + MOD (which_neighbor, 3) ! has values 2, 3, 1 when which_neighbor = 1, 2, 3 a = node(k, e1) ! 1st node along side #which_neighbor of element# e1 b = node(1 + MOD (k, 3), e1) ! 2nd node along side #which_neighbor of element# e1 uvec1(1:3) = xyz_nod(1:3, a) ! 1st node of side# which_neighbor of element# e1 uvec2(1:3) = xyz_nod(1:3, b) ! 2nd node of side# which_neighbor of element# e1 CALL DCross(uvec1, uvec2, tvec) CALL DMake_uvec(tvec, pole_a_uvec) !"Small" circle 'b' (actually a great-circle) describes the digitization step along the fault trace: tuvec1(1:3) = trace(1:3, j) ! Start-point of great-circle arc (one dig-step in fault trace) tuvec2(1:3) = trace(1:3, j+1) ! End-point of great-circle arc (one dig-step in fault trace) CALL DCross(tuvec1, tuvec2, tvec) CALL DMake_uvec(tvec, pole_b_uvec) CALL DCircles_Intersect (pole_a_uvec = pole_a_uvec, dot_a = 0.0D0, first_a_uvec = uvec1, last_a_uvec = uvec2, & & pole_b_uvec = pole_b_uvec, dot_b = 0.0D0, first_b_uvec = tuvec1, last_b_uvec = tuvec2, & ! input & overlap = overlap, number = number, point1_uvec = point1_uvec, point2_uvec = point2_uvec) ! output IF (number == 1) THEN ! We hope so! !Store the (sub-)segment from the start-point to the crossing point: n_new_in_library = n_new_in_library + 1 n_store = n_old_in_library + n_new_in_library IF (n_store > library_size) THEN WRITE (*, "(' ERROR: Increase PARAMETER library_size in Def_seg_v2.')") WRITE (21, "('ERROR: Increase PARAMETER library_size in Def_seg_v2.')") CALL Pause() STOP END IF library_int(n_store) = e1 library_R8(1:3, n_store) = tuvec1(1:3) ! Start-point of great-circle arc (dig step) library_R8(4, n_store) = 0.5D0 * ( DArc(tuvec1, point1_uvec) / DArc(tuvec1, tuvec2) ) ! s value of mid-point (with dig step) library_R8(5:7, n_store) = point1_uvec(1:3) ! Crossing-point !Store the (sub-)segment from the crossing point to the end-point: n_new_in_library = n_new_in_library + 1 n_store = n_old_in_library + n_new_in_library IF (n_store > library_size) THEN WRITE (*, "(' ERROR: Increase PARAMETER library_size in Def_seg_v2.')") WRITE (21, "('ERROR: Increase PARAMETER library_size in Def_seg_v2.')") CALL Pause() STOP END IF library_int(n_store) = e2 library_R8(1:3, n_store) = point1_uvec(1:3) ! Crossing-point library_R8(4, n_store) = 0.5D0 * ( (DArc(tuvec1, point1_uvec) / DArc(tuvec1, tuvec2) ) + 1.0D0) ! s value of mid-point (with dig step) library_R8(5:7, n_store) = tuvec2(1:3) ! End-point of great-circle arc (dig step) ELSE ! number /= 1 !Although these elements are neighbors, the digitization step did not intersect their common side. !This can happen if one (or both) elements have a large obtuse angle, forming a pair with a !pattern of "rabbit ears" or "swept-back wings". In such cases, there may be another element !intervening; or, there may be an arbitrary amount of complex mesh intervening. !So, we fall back to the slow, but usually reliable method: hard_way = .TRUE. END IF END IF ! neighbors !----------------------------------------------------------------------------------------------------------- IF (hard_way) THEN ! ***HARD*** case; start- and end-points are far apart (and/or, either end is outside the grid); ! we must use a SLOW but fail-proof algorithm to find all possible segments: !WRITE (*, "(' includes a ***HARD*** step.')") !"Small" circle 'b' (actually a great-circle) describes the digitization step along the fault trace: tuvec1(1:3) = trace(1:3, j) ! Start-point of great-circle arc (one dig-step in fault trace) tuvec2(1:3) = trace(1:3, j+1) ! End-point of great-circle arc (one dig-step in fault trace) CALL DCross(tuvec1, tuvec2, tvec) CALL DMake_uvec(tvec, pole_b_uvec) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !Check for an initial (sub-)segment starting inside element e1: IF (e1 > 0) THEN around_e1: DO which_side = 1, 3 !"Small" circle 'a' (actually a great-circle) describes the side of element #ele: k = 1 + MOD (which_side, 3) ! has values 2, 3, 1 when which_side = 1, 2, 3 a = node(k, e1) ! 1st node along side #which_side of element# e1 b = node(1 + MOD (k, 3), e1) ! 2nd node along side #which_side of element# e1 uvec1(1:3) = xyz_nod(1:3, a) ! 1st node of side# which_neighbor of element# e1 uvec2(1:3) = xyz_nod(1:3, b) ! 2nd node of side# which_neighbor of element# e1 pole_a_uvec(1:3) = pole_cloud(1:3, which_side, e1) ! pre-computed at top of this subprogram, for slightly better speed CALL DCircles_Intersect (pole_a_uvec = pole_a_uvec, dot_a = 0.0D0, first_a_uvec = uvec1, last_a_uvec = uvec2, & & pole_b_uvec = pole_b_uvec, dot_b = 0.0D0, first_b_uvec = tuvec1, last_b_uvec = tuvec2, & ! input & overlap = overlap, number = number, point1_uvec = point1_uvec, point2_uvec = point2_uvec) ! output IF (number > 0) THEN n_new_in_library = n_new_in_library + 1 n_store = n_old_in_library + n_new_in_library IF (n_store > library_size) THEN WRITE (*, "(' ERROR: Increase PARAMETER library_size in Def_seg_v2.')") WRITE (21, "('ERROR: Increase PARAMETER library_size in Def_seg_v2.')") CALL Pause() STOP END IF library_int(n_store) = e1 library_R8(1:3, n_store) = tuvec1(1:3) library_R8(4, n_store) = 0.5D0 * DArc(tuvec1, point1_uvec) / DArc(tuvec1, tuvec2) library_R8(5:7, n_store) = point1_uvec(1:3) EXIT around_E1 END IF ! number > 0 END DO around_e1 ! which_side = 1, 3 END IF ! e1 > 0; (sub-)segment starting inside element e1 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !Check for any (sub-)segments that entirely cross an element? DO ele = 1, num_ele n_hits = 0 ! before we have checked any of the 3 sides... DO which_side = 1, 3 !"Small" circle 'a' (actually a great-circle) describes the side of element #ele: k = 1 + MOD (which_side, 3) ! has values 2, 3, 1 when which_side = 1, 2, 3 a = node(k, ele) ! 1st node along side #which_side of element# ele b = node(1 + MOD (k, 3), ele) ! 2nd node along side #which_side of element# ele uvec1(1:3) = xyz_nod(1:3, a) ! 1st node of side# which_neighbor of element# ele uvec2(1:3) = xyz_nod(1:3, b) ! 2nd node of side# which_neighbor of element# ele pole_a_uvec(1:3) = pole_cloud(1:3, which_side, ele) ! pre-computed at top of this subprogram, for slightly better speed CALL DCircles_Intersect (pole_a_uvec = pole_a_uvec, dot_a = 0.0D0, first_a_uvec = uvec1, last_a_uvec = uvec2, & & pole_b_uvec = pole_b_uvec, dot_b = 0.0D0, first_b_uvec = tuvec1, last_b_uvec = tuvec2, & ! input & overlap = overlap, number = number, point1_uvec = point1_uvec, point2_uvec = point2_uvec) ! output IF (number > 0) THEN n_hits = n_hits + 1 ! probably will not exceed 2; definately no more than 3 hit_list(1:3, n_hits) = point1_uvec(1:3) hit_s(n_hits) = DArc(tuvec1, point1_uvec) / DArc(tuvec1, tuvec2) END IF ! number > 0; this dig-step intersected this element side! END DO ! which_side = 1, 3 !We can create a (sub-)segment for the library if we have 2 hits: IF (n_hits >= 2) THEN ! We hope it is not == 3; that should not happen, since no node can lie on a fault. !Check the ordering of the hit_s values of the (sub-)segment ends, and reverse if needed: IF (hit_s(2) < hit_s(1)) THEN ! reverse, using (3) as temporary storage: hit_list(1:3, 3) = hit_list(1:3, 1) ! #1 copied to temp storage hit_s(3) = hit_s(1) ! #1 copied to temp storage hit_list(1:3, 1) = hit_list(1:3, 2) ! #2 overwrites #1 hit_s(1) = hit_s(2) ! #2 overwrites #1 hit_list(1:3, 2) = hit_list(1:3, 3) ! old #1 retrieved from temp storage, placed in #2 hit_s(2) = hit_s(3) ! old #1 retrieved from temp storage, placed in #2 END IF ! reversing the order of the end-points !Now, record this new (sub-)segment in the library: n_new_in_library = n_new_in_library + 1 n_store = n_old_in_library + n_new_in_library IF (n_store > library_size) THEN WRITE (*, "(' ERROR: Increase PARAMETER library_size in Def_seg_v2.')") WRITE (21, "('ERROR: Increase PARAMETER library_size in Def_seg_v2.')") CALL Pause() STOP END IF library_int(n_store) = ele library_R8(1:3, n_store) = hit_list(1:3, 1) library_R8(4, n_store) = 0.5D0 * (hit_s(1) + hit_s(2)) library_R8(5:7, n_store) = hit_list(1:3, 2) END IF END DO ! ele = 1, num_ele !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !Lastly, check for a possible (sub-)segment ending inside element e2: IF (e2 > 0) THEN around_e2: DO which_side = 1, 3 !"Small" circle 'a' (actually a great-circle) describes the side of element #ele: k = 1 + MOD (which_side, 3) ! has values 2, 3, 1 when which_side = 1, 2, 3 a = node(k, e2) ! 1st node along side #which_side of element# e2 b = node(1 + MOD (k, 3), e2) ! 2nd node along side #which_side of element# e2 uvec1(1:3) = xyz_nod(1:3, a) ! 1st node of side# which_neighbor of element# e2 uvec2(1:3) = xyz_nod(1:3, b) ! 2nd node of side# which_neighbor of element# e2 pole_a_uvec(1:3) = pole_cloud(1:3, which_side, e2) ! pre-computed at top of this subprogram, for slightly better speed CALL DCircles_Intersect (pole_a_uvec = pole_a_uvec, dot_a = 0.0D0, first_a_uvec = uvec1, last_a_uvec = uvec2, & & pole_b_uvec = pole_b_uvec, dot_b = 0.0D0, first_b_uvec = tuvec1, last_b_uvec = tuvec2, & ! input & overlap = overlap, number = number, point1_uvec = point1_uvec, point2_uvec = point2_uvec) ! output IF (number > 0) THEN n_new_in_library = n_new_in_library + 1 n_store = n_old_in_library + n_new_in_library IF (n_store > library_size) THEN WRITE (*, "(' ERROR: Increase PARAMETER library_size in Def_seg_v2.')") WRITE (21, "('ERROR: Increase PARAMETER library_size in Def_seg_v2.')") CALL Pause() STOP END IF library_int(n_store) = e2 library_R8(1:3, n_store) = point1_uvec(1:3) library_R8(4, n_store) = 0.5D0 * ( ( DArc(tuvec1, point1_uvec) / DArc(tuvec1, tuvec2) ) + 1.0D0 ) library_R8(5:7, n_store) = tuvec2(1:3) EXIT around_e2 END IF ! number > 0 END DO around_e2 ! which_side = 1, 3 END IF ! e2 > 0; (sub-)segment ending inside element e2 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !Now, sort the new (sub-)segments in the library, if needed, according to internal coordinate s within the dig-step: IF (n_new_in_library > 1) THEN ! It is possible (likely!) that some 's' values are out of order. DO n_test_1 = (n_old_in_library + 1), (n_old_in_library + n_new_in_library - 1) DO n_test_2 = (n_test_1 + 1), (n_old_in_library + n_new_in_library) IF (library_R8(4, n_test_1) > library_R8(4, n_test_2)) THEN ! This pair needs to be reversed. temp_int = library_int(n_test_1) ! save a copy of n_test_1 value temp_R8(1:7) = library_R8(1:7, n_test_1) ! save copies of n_test_1 values library_int(n_test_1) = library_int(n_test_2) ! n_test_2 value overwrites n_test_1 value library_R8(1:7, n_test_1) = library_R8(1:7, n_test_2) ! n_test_2 values overwrite n_test_1 values library_int(n_test_2) = temp_int ! saved copy moved to n_test_2 library_R8(1:7, n_test_2) = temp_R8(1:7) ! saved copes moved to n_test_2 END IF ! This pair needed to be reversed. END DO ! n_test_2 = (n_test_1 + 1), (n_old_in_library + n_new_in_library) END DO ! n_test_1 = n_test_1 = (n_old_in_library + 1), (n_old_in_library + n_new_in_library - 1) END IF ! n_new_in_library > 1; sorting may be required END IF ! hard_way !end of consideration of this particular digitization-step on one fault n_old_in_library = n_old_in_library + n_new_in_library ! What was "new" is about to be "old", on the next pass through loop. n_new_in_library = 0 ! Re-initializing (this variable, but not the whole library). END IF ! This digitization step in internal to the grid, and has positive length (in radians); not a troublesome external or null step. END DO ! j = j1, (j2-1); considering each digitized point (except the last) as beginning of a great-circle arc !At this point, we have considered the whole fault trace, and filled up the (temporary) library. !----------------------------------------------------------------------------------------------------------- !Compress the library by combining any sub-segments that are in the same element: n_final_in_library = n_old_in_library ! just initializing, before any compression: IF (n_old_in_library > 1) THEN ! compression is theoretically possible test_1st = 1 ! initializing (jagged) loop variable compressing: DO test_2nd = test_1st + 1 e1 = library_int(test_1st) e2 = library_int(test_2nd) IF (e1 == e2) THEN ! compression is required !Expand the lower-numbered sub-segment by incorporating the higher-numbered one: library_R8(5:7, test_1st) = library_R8(5:7, test_2nd) ! moving the end-point of this (sub-)segment. !Note that library_R8(4, ...) has served its purpose; it will no longer be maintained or used. !Decrement the size of the library: n_final_in_library = n_final_in_library - 1 !Shift all library contents that remain: IF (test_2nd <= n_final_in_library) THEN DO j = test_2nd, n_final_in_library library_int(j) = library_int(j+1) library_R8(1:7, j) = library_R8(1:7, j+1) END DO ! j = test_2nd, n_final_in_library END IF ! test_2nd <= n_final_in_library !Note that we do NOT increment test_1st++ in this branch, because it needs to be re-checked! This segment could grow again! ELSE ! no need for compression; but OK to increment jagged loop variable (or exit) test_1st = test_1st + 1 END IF ! compression? or not? IF (test_1st >= n_final_in_library) EXIT compressing ! Note the moving target! END DO compressing END IF ! more than one (sub-)segment in library; compression possible !----------------------------------------------------------------------------------------------------------- !Record(?) these newly-found segments (and finish them?) IF (savem) THEN DO j = 1, n_final_in_library seg_count = seg_count + 1 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !- - These next lines are just to provide an on-screen progress bar: jnew = (38 * seg_count * 2) / seg_count_doubled jnew = MIN(jnew, 38) ! because in later timesteps & iterations the upper limit is approximate; don't run off end of bar-graph! IF (jnew > jold) THEN bar_graph(jnew+41:jnew+41) = CHAR(219) WRITE (*, "('+',A)") bar_graph(1:jnew+41) jold = jnew END IF !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ele = library_int(j) seg_def(1, seg_count) = i ! fault-trace index (from outermost loop) seg_def(2, seg_count) = ele ! element# IF (trace_loc(3, i) == 0) trace_loc(3, i) = seg_count ! Replace any 0 with index of first segment (but only ONCE). trace_loc(4, i) = seg_count ! This may, or MAY NOT, be the final answer, as loop progresses... seg_end(1:3, 1, seg_count) = library_R8(1:3, j) seg_end(1:3, 2, seg_count) = library_R8(5:7, j) vector(1:3) = library_R8(1:3, j) ! start seg_end_is(1, seg_count)%element = ele CALL Dumb_s123 (xyz_nod, ele, vector, s1, s2, s3) s_triad(1) = s1; s_triad(2) = s2; s_triad(3) = s3 CALL Pull_in(s_triad) ! correcting any value that is -epsilon due to numerical errors seg_end_is(1, seg_count)%s(1:3) = s_triad(1:3) vector(1:3) = library_R8(5:7, j) ! end seg_end_is(2, seg_count)%element = ele CALL Dumb_s123 (xyz_nod, ele, vector, s1, s2, s3) s_triad(1) = s1; s_triad(2) = s2; s_triad(3) = s3 CALL Pull_in(s_triad) ! correcting any value that is -epsilon due to numerical errors seg_end_is(2, seg_count)%s(1:3) = s_triad(1:3) CALL Finish_seg (seg_count, .FALSE., jin, .FALSE., jout, no_cut) !The above computes jin, jout, and no_cut; !but more important are the side-effects, of computing seg_eta_, seg_kappa_, and seg_u_. !!Write this segment to fault_segments.dig, for graphical-test: !uvec1(1:3) = seg_end(1:3, 1, seg_count) !uvec2(1:3) = seg_end(1:3, 2, seg_count) !length = DArc(uvec1, uvec2) !IF (length > 0.0D0) THEN ! !creating a half-arrowhead to show sense (and end-point): ! azimuth1 = DCompass(from_uvec = uvec1, to_uvec = uvec2) ! in radians, clockwise from North ! azimuth2 = azimuth1 + (135.0D0 * radians_per_degree) ! for half-arrowhead, pointing back at to the right. ! length = 0.25D0 * length ! for half-arrowhead ! CALL DTurn_to(azimuth_radians = azimuth2, base_uvec = uvec2, far_radians = length, & ! inputs ! & omega_uvec = omega_uvec, result_uvec = uvec3) ! WRITE (21, "('F', I4, ', segment ',I6)") i, seg_count ! CALL DUvec_2_LonLat(uvec1, Elon, Nlat) ! WRITE (21, "(1X,SP,ES12.5,',',ES12.5)") Elon, Nlat ! CALL DUvec_2_LonLat(uvec2, Elon, Nlat) ! WRITE (21, "(1X,SP,ES12.5,',',ES12.5)") Elon, Nlat ! CALL DUvec_2_LonLat(uvec3, Elon, Nlat) ! WRITE (21, "(1X,SP,ES12.5,',',ES12.5)") Elon, Nlat ! WRITE (21, "('*** end of line segment ***')") !ELSE ! n_zero_length = n_zero_length + 1 !END IF END DO ! j = 1, n_final_in_library ELSE ! just count the segments, and also mark any faults that failed to produce any segments: IF (n_final_in_library > 0) THEN seg_count = seg_count + n_final_in_library ELSE ! mark this fault, to avoid analyzing it again! f_relevant(i) = .FALSE. END IF END IF ! savem !----------------------------------------------------------------------------------------------------------- END IF ! This trace represented by at least 2 points in external trace dataset, .AND.f_relevant(i). END DO ! i = 1, f_highest (F0000, F0001, F0002, ... F9999?) DEALLOCATE ( pole_cloud ) ! which would happen on RETURN anyway !IF (n_zero_length > 0) THEN ! WRITE (*, *) ! WRITE (*, "(' Caution: ', I6, ' segments had lengths of zero.')") n_zero_length ! CALL Pause() !END IF END SUBROUTINE Def_seg_v2 SUBROUTINE DPrompt_for_Logical (prompt_text, default, answer) ! Writes a line to the default (*) unit, with: ! "prompt_text" ["default"]: ! and accepts an answer with a logical value. ! If [Enter] is pressed with nothing preceding it, ! then "answer" takes the value "default". ! Note that prompt_text should usually end with '?'. ! It can be more than 70 bytes long if necessary, but cannot ! contain line breaks, tabs, or other formatting. ! Trailing blanks in prompt_text are ignored. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: prompt_text LOGICAL, INTENT(IN) :: default LOGICAL, INTENT(OUT) :: answer CHARACTER*1 :: inbyte CHARACTER*3 :: yesno INTEGER :: blank_at, bytes, written LOGICAL :: finished bytes = LEN_TRIM(prompt_text) finished = .FALSE. DO WHILE (.NOT. finished) IF (default) THEN yesno = 'Yes' ELSE yesno = 'No' END IF written = 0 DO WHILE ((bytes - written) > 70) blank_at = written + INDEX(prompt_text((written+1):(written+70)),' ',.TRUE.) ! searching L from end for ' ' IF (blank_at < (written + 2)) blank_at = written + 70 WRITE (*,"(' ',A)") prompt_text((written+1):blank_at) written = blank_at END DO WRITE (*,"(' ',A,' [',A']: '\)") prompt_text((written+1):bytes), TRIM(yesno) finished = .TRUE. ! unless changed below READ (*,"(A)") inbyte IF (LEN_TRIM(inbyte) == 0) THEN answer = default ELSE SELECT CASE (inbyte) CASE ('Y') answer = .TRUE. CASE ('y') answer = .TRUE. CASE ('T') answer = .TRUE. CASE ('t') answer = .TRUE. CASE ('R') answer = .TRUE. CASE ('r') answer = .TRUE. CASE ('O') answer = .TRUE. CASE ('o') answer = .TRUE. CASE ('N') answer = .FALSE. CASE ('n') answer = .FALSE. CASE ('F') answer = .FALSE. CASE ('f') answer = .FALSE. CASE ('W') answer = .FALSE. CASE ('w') answer = .FALSE. CASE DEFAULT WRITE (*,"(' ERROR: Your response (',A,') was not recognized.')") inbyte WRITE (*,"(' (Only the first letter of your answer is used.)')") WRITE (*,"(' To agree, enter Y, y, T, t, O, o, R, or r.')") WRITE (*,"(' To disagree, enter N, n, F, f, W, or w.')") WRITE (*,"(' Please try again:')") finished = .FALSE. END SELECT END IF ! a byte was entered END DO ! until finished END SUBROUTINE DPrompt_for_Logical SUBROUTINE DPrompt_for_String (prompt_text, default, answer) ! Writes a line to the default (*) unit, with: ! "prompt_text" ["default"]: ! and accepts an answer with a character-string value. ! If [Enter] is pressed with nothing preceding it, ! then "answer" takes the value "default". ! Note that prompt_text should usually end with '?'. ! It can be more than 70 bytes long if necessary, but cannot ! contain line breaks, tabs, or other formatting. ! Trailing blanks in prompt_text are ignored. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: prompt_text CHARACTER*(*), INTENT(IN) :: default CHARACTER*(*), INTENT(OUT) :: answer CHARACTER*80 trial INTEGER :: blank_at, default_bytes, leftover, & & prompt_bytes, written prompt_bytes = LEN_TRIM(prompt_text) default_bytes = LEN_TRIM(default) written = 0 leftover = 79 - prompt_bytes - 4 ! unless changed below DO WHILE ((prompt_bytes - written) > 70) blank_at = written + INDEX(prompt_text((written+1):(written+70)),' ',.TRUE.) ! searching L from end for ' ' IF (blank_at < (written + 2)) blank_at = written + 70 WRITE (*,"(' ',A)") prompt_text((written+1):blank_at) leftover = 79 - (blank_at - (written+1) + 1) - 4 written = blank_at END DO IF (leftover >= default_bytes) THEN WRITE (*,"(' ',A,' [',A,']')") prompt_text(written+1:prompt_bytes), TRIM(default) ELSE WRITE (*,"(' ',A)") prompt_text(written+1:prompt_bytes) WRITE (*,"(' [',A,']')") TRIM(default) END IF WRITE (*,"(' ?: '\)") READ (*,"(A)") trial IF (LEN_TRIM(trial) == 0) THEN answer = TRIM(default) ELSE answer = TRIM(trial) END IF END SUBROUTINE DPrompt_for_String SUBROUTINE Del_Gjxy_del_thetaphi (l_, r_, dG) IMPLICIT NONE INTEGER, INTENT(IN) :: l_ ! element number REAL*8, DIMENSION(3), INTENT(IN) :: r_ ! position vector REAL*8, DIMENSION (3,2,2,2), INTENT(OUT) :: dG ! computes array of 2 derivitives of each of the 2 components of ! each of the 6 nodal functions for element l_ at ! position r_ (Cartesian unit vector). ! Results are in 1./radian (dimensionless), NOT 1./m or 1./degree ! ! It is user's responsibility that element l_ contains r_. SAVE ! allows fast re-entry when l_ is unchanged. INTEGER :: l_last = 0 ! remembers l_ from previous invocation INTEGER :: j ! 1:3 = local node numbering in element l_ INTEGER :: x ! 1:2 = node j has unit velocity to South(1) or East(2)? INTEGER :: y ! 1:2 = South(1) or East(2) component of vector nodal function? INTEGER :: m ! 1:2 = theta (S-ward) or phi (E-ward) derivitive? REAL*8, DIMENSION(3,2) :: del_r_ ! theta- and phi-derivitives of r_ (in 3-D) REAL*8, DIMENSION(3,2) :: local ! local Theta, Phi unit vectors at r_ (xyz, SE) REAL*8, DIMENSION(3,2,2) :: del_local ! theta-, phi- derivitives of local REAL*8, DIMENSION(3,3) :: corner ! positions vector of corner nodes (xyz, 123) REAL*8, DIMENSION(3,3,2) :: post ! unit coordinate vectors at corner nodes: ! (xyz, 123, SE) REAL*8, DIMENSION(3) :: tv, tvi, tvo, tv1, tv2, tv3, vfa, vfb ! temporary vector factors REAL*8 :: cos_phi, cos_theta, phi, sin_phi, sin_theta INTEGER :: i1, i2, i3 ! 1, 2, or 3 in cyclic rotation (depends on j) IF (l_ /= l_last) THEN ! new finite element l_last = l_ DO j = 1, 3 corner(1:3, j) = xyz_nod(1:3, node(j, l_)) tvi = corner(1:3, j) CALL Local_Theta(tvi, tvo) post(1:3, j, 1) = tvo CALL Local_Phi (tvi, tvo) post(1:3, j, 2) = tvo END DO END IF ! begin calculations which depend on r_ CALL Local_Theta(r_, tv) local(1:3,1) = tv CALL Local_Phi(r_, tv) local(1:3,2) = tv ! Note: these functions will catch polar points; don't test again phi = ATAN2(r_(2), r_(1)) cos_phi = COS(phi) sin_phi = SIN(phi) cos_theta = r_(3) sin_theta = SQRT(r_(1)**2 + r_(2)**2) del_r_(1:3,1) = local(1:3,1) ! d.r_/d.theta = Theta del_r_(1:3,2) = local(1:3,2) * sin_theta ! d.r_/d.phi = Phi * SIN(theta) del_local(1:3,1,1) = - r_(1:3) ! d.Theta/d.theta = - r_ del_local(1:3,1,2) = local(1:3,2) * cos_theta ! d.Theta/d.phi = Phi * COS(theta) del_local(1:3,2,1) = (/ 0.0D0, 0.0D0, 0.0D0 /) ! d.Phi/d.theta = 0 del_local(1:3,2,2) = (/ -cos_phi, -sin_phi, 0.0D0 /) ! d.Phi/d.phi = (-COS(phi),-SIN(phi,0) DO j = 1, 3 ! 3 corner nodes of element i1 = j i2 = 1 + MOD(j, 3) i3 = 1 + MOD(i2,3) tv1 = corner(1:3, i1) tv2 = corner(1:3, i2) tv3 = corner(1:3, i3) CALL Cross(tv2, tv3, vfa) vfb = vfa / Dot_3D (tv1, vfa) DO x = 1, 2 ! unit velocity at node is S or E DO y = 1, 2 ! S- or E- component of nodal function tv1 = post(1:3, j, x) tvi = local(1:3, y) DO m = 1, 2 ! theta- or phi-derivitive tv = del_r_(1:3, m) tvo = del_local(1:3, y, m) dG(j, x, y, m) = & & (Dot_3D(tv,vfb)*Dot_3D(tv1,tvi)) + & & (Dot_3D(r_,vfb)*Dot_3D(tv1,tvo)) END DO END DO END DO END DO END SUBROUTINE Del_Gjxy_del_thetaphi SUBROUTINE Delete_output_file(filename) IMPLICIT NONE CHARACTER*80, INTENT(IN) :: filename INTEGER, PARAMETER :: temp_unit = 49 !N.B. We make a hopeful assumption that Fortran I/O channel #temp_unit is not currently in use for any other purpose! INTEGER :: ios OPEN (UNIT = temp_unit, FILE = TRIM(filename), STATUS = "OLD", IOSTAT = ios) IF (ios == 0) THEN ! file was successfully OPENed, so it exists WRITE (*, "(' ', 8X, 'Deleting ', A)") TRIM(filename) WRITE (21, "(8X, 'Deleting ', A)") TRIM(filename) CLOSE (UNIT = temp_unit, STATUS = "DELETE") END IF ! file existed END SUBROUTINE Delete_output_file REAL*8 FUNCTION Dot_3D (a_, b_) ! Dot product of 3-component vectors. IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: a_, b_ Dot_3D = a_(1)*b_(1) + a_(2)*b_(2) + a_(3)*b_(3) END FUNCTION Dot_3D SUBROUTINE Dumb_s123 (xyz_nod, element, vector, s1, s2, s3) ! Finds s1, s2, s3 coordinates of position vector "in" element ! (whether the point is actually in the element or NOT). IMPLICIT NONE REAL*8, DIMENSION(:,:), INTENT(IN) :: xyz_nod INTEGER, INTENT(IN) :: element REAL*8, DIMENSION(3), INTENT(IN) :: vector REAL*8, INTENT(OUT) :: s1, s2, s3 INTEGER :: i1, i2, i3 REAL*8, DIMENSION(3) :: tv, tvi, tvo, tv1, tv2, v1 REAL*8 :: d1, dc, t IF (element == 0) THEN CALL Prevent('element = 0', 1, 'Dumb_s123') END IF i1 = node(1, element) i2 = node(2, element) i3 = node(3, element) !shorten(?) vector to just touch plane element -> v1 tv1 = center(1:3, element) dc = Dot_3D(vector, tv1) IF (dc <= 0.0D0) CALL Prevent('"Internal" vector >= 90 deg. from element', 1, 'Dumb_s123') tv2 = xyz_nod(1:3, i1) d1 = Dot_3D(tv2, tv1) t = d1 / dc v1 = t * vector tvi = xyz_nod(1:3,i3) - xyz_nod(1:3,i2) tvo = v1(1:3) - xyz_nod(1:3,i3) CALL Cross(tvi, tvo, tv) s1 = Dot_3D(tv1, tv) * half_R2 / a_(element) tvi = xyz_nod(1:3,i1) - xyz_nod(1:3,i3) tvo = v1(1:3) - xyz_nod(1:3,i1) CALL Cross(tvi, tvo, tv) s2 = Dot_3D(tv1, tv) * half_R2 / a_(element) s3 = 1.00D0 - s1 - s2 END SUBROUTINE Dumb_s123 SUBROUTINE Dump_seg(limit, savem, punt) ! Called for debugging information: dump of segments list, ! when number becomes excessive. IMPLICIT NONE CHARACTER*80 :: filename INTEGER, INTENT(IN) :: limit LOGICAL, INTENT(IN) :: savem LOGICAL, INTENT(OUT) :: punt INTEGER :: i IF (savem) THEN WRITE (*, "(' Error: Number of fault segments exceeds plausible limit of ',I8)") limit WRITE (*, "(' Probable infinite loop in Def_seg.')") WRITE (*, "(' See file REPORT.txt for dump of segments.')") WRITE (21,"('Error: Number of fault segments exceeds plausible limit of ',I8)") limit WRITE (21,"('(2 * number of elements * number of traces)')") WRITE (21,"('Probable infinite loop in Def_seg.')") WRITE (21,"('Use ORBWEAVER to check for gaps/overlaps in area!')") WRITE (21,"('Dump of segments follows')") WRITE (21,"(/'Trace Element I1 S1 S2 S3 I2 S1 S2 S3')") DO i = 1, limit WRITE (21, "(I5, I8, I5, 3F7.4, I5, 3F7.4)") & & seg_def(1, i), seg_def(2,i), & & seg_end_is(1,i)%element, seg_end_is(1,i)%s(1:3), & & seg_end_is(2,i)%element, seg_end_is(2,i)%s(1:3) END DO filename = "Dump_seg.feg" CALL Write_x_feg(filename) filename = "Dump_seg.dig" CALL Write_f_dig(filename) CALL Pause() STOP ELSE punt = .TRUE. WRITE (*, "(' Aborting search for fault segments at count of ',I8)") limit WRITE (21, "('Aborting search for fault segments at count of ',I8)") limit CALL Pause() STOP ENDIF END SUBROUTINE Dump_seg SUBROUTINE Dump_trace (i) ! i is like "460" in "F0460R" IMPLICIT NONE INTEGER, INTENT(IN) :: i INTEGER :: j, j1, j2 REAL*8 :: lat, lon REAL*8, DIMENSION(3) :: tv WRITE (21, "('Trace of fault ',I6,':')") i j1 = trace_loc(1, i) j2 = trace_loc(2, i) DO j = j1, j2 tv(1:3) = trace(1:3, j) CALL Lonlat_from_xyz(tv, lon, lat) WRITE (21,"(I4,F10.4,F9.3,I6,3F10.5)") i, & & lon, lat, & & trace_is(j)%element, & & trace_is(j)%s(1), trace_is(j)%s(2), trace_is(j)%s(3) END DO WRITE (21,*) END SUBROUTINE Dump_trace SUBROUTINE E_rate(l_, G, dG, theta_, vw, eps_dot) ! evaluate strain-rate IMPLICIT NONE INTEGER, INTENT(IN) :: l_ ! element number REAL*8, DIMENSION(3,2,2) :: G ! nodal functions @ selected point REAL*8, DIMENSION(3,2,2,2):: dG ! derivitives of nodal functions REAL*8, INTENT(IN) :: theta_ ! colatitude, radians REAL*8, DIMENSION(:), INTENT(IN) :: vw REAL*8, DIMENSION(3), INTENT(OUT) :: eps_dot INTEGER :: iv, iw, j REAL*8 :: cott, csct, prefix eps_dot = 0.0D0 ! (1..3) cott = 1.0D0 / TAN(theta_) csct = 1.0D0 / SIN(theta_) prefix = 1.0D0 / R ! R is a global variable == planet radius DO j = 1, 3 iv = 2 * node(j, l_) - 1 ! global index array iw = iv + 1 ! epsilon_dot_sub_theta_theta eps_dot(1) = eps_dot(1) + & & vw(iv) * prefix * dG(j,1,1,1) + & & vw(iw) * prefix * dG(j,2,1,1) ! epsilon_dot_sub_theta_phi eps_dot(2) = eps_dot(2) + & & vw(iv) * prefix * 0.5D0 * (csct * dG(j,1,1,2) + dG(j,1,2,1) - cott * G(j,1,2)) + & & vw(iw) * prefix * 0.5D0 * (csct * dG(j,2,1,2) + dG(j,2,2,1) - cott * G(j,2,2)) ! epsilon_dot_sub_phi_phi eps_dot(3) = eps_dot(3) + & & vw(iv) * prefix * (csct * dG(j,1,2,2) + cott * G(j,1,1)) + & & vw(iw) * prefix * (csct * dG(j,2,2,2) + cott * G(j,2,1)) END DO ! 3 local nodes END SUBROUTINE E_rate SUBROUTINE File_not_found(filename) IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: filename WRITE (*, "(' ERROR: Input file ', A, ' not found (in current folder).')") TRIM(filename) WRITE (21, "('ERROR: Input file ', A, ' not found (in current folder).')") TRIM(filename) CALL Pause() STOP END SUBROUTINE File_not_found SUBROUTINE Find_out (element, inside, outside, & ! inputs & border, coords) ! outputs ! Given a directed arc of a great circle from point "inside" ! (which is inside, or on the border of "element") to point ! "outside" (both positions Cartesian unit vectors), finds ! the last point in contact with "element" and reports its ! Cartesian vector as "border" and its internal coordinates as "coords". IMPLICIT NONE INTEGER, INTENT(IN) :: element REAL*8, DIMENSION(3), INTENT(IN) :: inside, outside REAL*8, DIMENSION(3), INTENT(OUT):: border TYPE(is123), INTENT(OUT) :: coords INTEGER :: i, side, sidea, sideb INTEGER, DIMENSION(1) :: array ! stupid, to satisfy MINLOC REAL*8, DIMENSION(3) :: s, far, frac ! NOT vectors REAL*8 :: distance, slope coords%element = element CALL Dumb_s123 (xyz_nod, element, inside, s(1), s(2), s(3)) CALL Pull_in(s) CALL Dumb_s123 (xyz_nod, element, outside, far(1), far(2), far(3)) DO i = 1, 3 slope = far(i) - s(i) IF (slope < 0.0D0) THEN frac(i) = -s(i) / slope ELSE frac(i) = 9.99D+37 ! "huge"; will not be selected as minimum ENDIF END DO distance = MINVAL(frac) distance = MAX(0.0D0, MIN(1.0D0, distance)) array = MINLOC(frac) side = array(1) sidea = 1 + MOD(side, 3) sideb = 1 + MOD(sidea, 3) s(side) = 0.0D0 s(sidea) = s(sidea) + distance * (far(sidea) - s(sidea)) s(sideb) = s(sideb) + distance * (far(sideb) - s(sideb)) CALL Pull_in(s) coords%s(1:3) = s CALL Interpolate(coords, border) END SUBROUTINE Find_out SUBROUTINE Find_s1s2s3 !Determines internal coordinates of all positions that need integration; ! for convenience, also turns off c_active, p_active, ! or turns banished_DIG_point(i) = .TRUE., ! if point is outside the grid area. IMPLICIT NONE REAL*8, DIMENSION(3) :: tv, tvn, v1 INTEGER :: a, b, back1, back2, element, lastel INTEGER :: i, j, jold, j1, j2, jt, k, l_, m, n REAL*8 :: s1, s2, s3 CHARACTER(61) :: bar_graph LOGICAL :: before_node_in_faulted_element, debug = .FALSE., easy_match ! find element center points DO l_ = 1, num_ele v1 = xyz_nod(1:3,node(1,l_)) + xyz_nod(1:3,node(2,l_)) + xyz_nod(1:3,node(3,l_)) CALL Unitise(v1, tv) center(1:3, l_) = tv END DO ! find neighboring elements(?) on all 3 sides of each; also, ! set edge_element(l_) = .TRUE. if any neighbor is missing. neighbor = 0 ! whole array, of 3 values per element homes: DO l_ = 1, num_ele sides: DO j = 1, 3 ! 3 sides k = 1 + MOD (j, 3) a = node(k, l_) ! 1st node along side b = node(1 + MOD (k, 3), l_) ! 2nd node along side strangers: DO m = 1, num_ele IF ((node(1, m) == b) .AND. (node(2, m) == a)) THEN neighbor(j, l_) = m EXIT strangers ELSE IF ((node(2, m) == b) .AND. (node(3, m) == a)) THEN neighbor(j, l_) = m EXIT strangers ELSE IF ((node(3, m) == b) .AND. (node(1, m) == a)) THEN neighbor(j, l_) = m EXIT strangers END IF END DO strangers END DO sides edge_element(l_) = (neighbor(1, l_) == 0).OR.(neighbor(2, l_) == 0).OR.(neighbor(3, l_) == 0) END DO homes !Now, expand edge_element population by one element in each direction (avoiding recursive propagation): edge_question = .FALSE. ! whole array, just initializing, before ... DO l_ = 1, num_ele IF (edge_element(l_)) THEN DO j = 1, 3 n = neighbor(j, l_) IF (n > 0) edge_question(n) = .TRUE. ! note any NEW edge_element additions END DO END IF END DO DO l_ = 1, num_ele edge_element(l_) = edge_element(l_) .OR. edge_question(l_) ! either old or new "edge_element" will be counted END DO IF (f_dig_count > 0) THEN bar_graph(1:41) = ' Locating fault traces ' IF (debug) WRITE (21, "('trace_is before correction:')") IF (debug) WRITE (21, "(' point element s1 s2 s3')") DO i = 42, 61 bar_graph(i:i) = CHAR(176) END DO WRITE (*, "(' ',A)") bar_graph WRITE (*, "('+',A)") bar_graph(1:41) jold = 0 DO i = 1, f_dig_count IF (.NOT.banished_DIG_point(i)) THEN tv = trace(1:3, i) l_ = trace_is(i)%element CALL Internal(tv, l_, s1, s2, s3) trace_is(i)%element = l_ trace_is(i)%s(1) = s1 trace_is(i)%s(2) = s2 trace_is(i)%s(3) = s3 IF ((l_ <= 0).OR.((s1+s2+s3) <= 0.0D0)) banished_DIG_point(i) = .TRUE. IF (debug) WRITE (21, "(I6,I8,3F6.2)") i, trace_is(i)%element, (trace_is(i)%s(j3), j3 = 1, 3) END IF ! .NOT.banished_DIG_point(i) j = (20 * i) / f_dig_count IF (j > jold) THEN bar_graph(j+41:j+41) = CHAR(219) WRITE (*, "('+',A)") bar_graph(1:j+41) jold = j END IF END DO ! Scan for cases where a trace wanders from element a briefly ! into element b and then back into a. Change element assignments ! of b -> a. This does not move the trace, but is does prevent ! serious problems with fault segmentation later. IF (debug) WRITE (21, "('Corrections to trace_is:')") IF (debug) WRITE (21, "('trace point old_ele old_s1 old_s2 old_s3 new_ele new_s1 new_s2 new_s3')") DO i = 1, f_highest CALL Unloop_Trace(i, debug) END DO ! i = 1, f_highest END IF ! f_dig_count > 0 IF (f_highest > 0) THEN DO i = 1, f_highest a = trace_loc(1, i) b = trace_loc(2, i) IF ((a > 0) .AND. (b > a)) THEN n = 0 ! count points of trace inside the grid DO j = a, b IF (.NOT.banished_DIG_point(j)) THEN ! N.B. These 2 tests may be redundant(?). Just being careful. IF (trace_is(j)%element > 0) n = n + 1 END IF END DO IF (n < 2) f_2_in(i) = .FALSE. ELSE f_2_in(i) = .FALSE. END IF END DO END IF IF (c_rst_count > 0) THEN WRITE (*, "(' ',12X,'Locating cross-section ends')") DO i = 1, c_rst_count tv = c_end_now(1:3, 1, i) l_ = c_end_is(1, i)%element CALL Internal (tv, l_, s1, s2, s3) c_end_is(1, i)%element = l_ c_end_is(1, i)%s(1) = s1 c_end_is(1, i)%s(2) = s2 c_end_is(1, i)%s(3) = s3 tv = c_end_now(1:3, 2, i) l_ = c_end_is(2, i)%element CALL Internal (tv, l_, s1, s2, s3) c_end_is(2, i)%element = l_ c_end_is(2, i)%s(1) = s1 c_end_is(2, i)%s(2) = s2 c_end_is(2, i)%s(3) = s3 IF ((l_ == 0) .OR. (c_end_is(1, i)%element == 0)) THEN DO j = 1, num_timesteps c_active(j, i) = .FALSE. END DO END IF END DO ENDIF IF (p_rst_count > 0) THEN WRITE (*, "(' ', 12X, 'Locating paleomagnetic sites')") DO i = 1, p_rst_count tv = p_site_now(1:3, i) l_ = p_site_is(i)%element CALL Internal (tv, l_, s1, s2, s3) p_site_is(i)%element = l_ p_site_is(i)%s(1) = s1 p_site_is(i)%s(2) = s2 p_site_is(i)%s(3) = s3 IF (l_ == 0) THEN DO j = 1, num_timesteps p_active(j, i) = .FALSE. END DO END IF END DO ENDIF IF (s_rst_count > 0) THEN WRITE (*, "(' ', 12X, 'Locating paleostress sites')") DO i = 1, s_rst_count tv = s_site_now(1:3, 1, i) l_ = s_site_is(1, i)%element CALL Internal (tv, l_, s1, s2, s3) s_site_is(1, i)%element = l_ s_site_is(1, i)%s(1) = s1 s_site_is(1, i)%s(2) = s2 s_site_is(1, i)%s(3) = s3 tv = s_site_now(1:3, 2, i) l_ = s_site_is(2, i)%element CALL Internal (tv, l_, s1, s2, s3) s_site_is(2, i)%element = l_ s_site_is(2, i)%s(1) = s1 s_site_is(2, i)%s(2) = s2 s_site_is(2, i)%s(3) = s3 END DO END IF ! s_rst_count > 0 IF (basemap_object_count > 0) THEN bar_graph(1:44) = ' Locating basemap points ' DO i = 45, 61 bar_graph(i:i) = CHAR(176) END DO WRITE (*, "(' ', A)") bar_graph WRITE (*, "('+', A)") bar_graph(1:44) jold = 0 DO i = 1, basemap_point_count tv = basemap_uvec_store(1:3, i) l_ = basemap_point_is(i)%element CALL Internal (tv, l_, s1, s2, s3) basemap_point_is(i)%element = l_ basemap_point_is(i)%s(1) = s1 basemap_point_is(i)%s(2) = s2 basemap_point_is(i)%s(3) = s3 j = (17 * i) / basemap_point_count IF (j > jold) THEN bar_graph(j+44:j+44) = CHAR(219) WRITE (*, "('+', A)") bar_graph(1:j+44) jold = j END IF END DO END IF ! y_dig_count > 0 END SUBROUTINE Find_s1s2s3 SUBROUTINE Finish_seg (segment, cutin, jin, cutout, jout, no_cut) ! completes segment description by deciding u_, eta_, kappa_ ! IF (cutin), uses jin; else, computes it. ! IF (cutout), uses jout; else, computes it. ! IF (jin == jout) sets flag no_cut = T; this is a WARNING ! that the segment lies exactly along one side of the element. ! Refers to global arrays seg_... IMPLICIT NONE LOGICAL, INTENT(IN) :: cutin, cutout INTEGER, INTENT(INOUT) :: jin, jout INTEGER, INTENT(IN) :: segment LOGICAL, INTENT(OUT) :: no_cut INTEGER :: element, n, np1, np2 REAL*8, DIMENSION(3) :: c, in, out, tv, tv1, tv2, uvec_np1, uvec_np2, vn, vs, wvec1, wvec2 TYPE(is123) :: ist1, ist2 LOGICAL :: debug = .FALSE. ! IF (debug), table of segments goes to REPORT.txt. REAL*8 :: lat1, lat2, lon1, lon2 element = seg_def(2, segment) tv1 = seg_end(1:3, 1, segment) tv2 = seg_end(1:3, 2, segment) IF (cutin) THEN in = seg_end(1:3, 1, segment) ELSE ! project backward CALL Find_out (element = element, & & inside = tv2, & & outside = tv1, & & border = in, & & coords = ist1) jin = Which_zero(ist1) END IF IF (cutout) THEN out = seg_end(1:3, 2, segment) ELSE ! project forward CALL Find_out (element = element, & & inside = tv1, & & outside = tv2, & & border = out, & & coords = ist2) jout = Which_zero(ist2) END IF IF (jin == jout) THEN no_cut = .TRUE. !NOTE that in this special case, the segment lies exactly along and on one side of the element, grazing it. !The calling program may need to take some special responsive action in this special case(?) !Here, we will treat it as lying infinitesimally inside, in order to define seg_u_, seg_kappa_, seg_eta_. n = jin ! == jout, identity of isolated node, using local node numbering 1-3 seg_u_(segment) = n np1 = 1 + MOD(n, 3) ! next side (or node), going around counterclockwise, in local numbering scheme np2 = 1 + MOD(np1, 3) ! ditto uvec_np1(1:3) = xyz_nod(1:3, node(np1, element)) uvec_np2(1:3) = xyz_nod(1:3, node(np2, element)) seg_kappa_(segment) = Arc_distance(tv1, tv2) / Arc_distance(uvec_np1, uvec_np2) seg_kappa_(segment) = MAX(0.0D0, MIN(seg_kappa_(segment) , 1.0D0)) ! just for luck... n = node(n, element) ! changing n from local/relative to global/absolute node number wvec1(1:3) = tv2(1:3) - tv1(1:3) ! length of segment, in radians (NOT a uvec) wvec2(1:3) = uvec_np2(1:3) - uvec_np1(1:3) ! length of element side, in radians (NOT a uvec) IF (Dot_3D(wvec1, wvec2) > 0.0D0) THEN ! segment grazes element in counterclockwise direction seg_eta_(segment) = -1.0D0 ! isolated node is to LEFT of segment ELSE ! segment grazes element in clockwise direction seg_eta_(segment) = +1.0D0 ! isolated node is to RIGHT of segment END IF ELSE ! normal case; jin /= jout no_cut = .FALSE. ! This is the normal case, where segment clearly CUTS the interior of the element. n = 6 - jin - jout ! using local node numbering 1-3 IF ((n >=1) .AND. (n <= 3)) THEN seg_u_(segment) = n ELSE WRITE (*, "(' Error: In Finish_seg, jin =',I2,', jout =',I2)") jin, jout WRITE (*, "(' cutin = ',L1,', cutout = ',L1)") cutin, cutout WRITE (*, "(' element =',I5,', segment =',I6)") element, segment WRITE (21,"(' Error: In Finish_seg, jin =',I2,', jout =',I2)") jin, jout WRITE (21,"(' cutin = ',L1,', cutout = ',L1)") cutin, cutout WRITE (21,"(' element =',I5,', segment =',I6)") element, segment CALL Pause() STOP ENDIF IF (cutin .AND. cutout) THEN seg_kappa_(segment) = 1.0D0 ELSE tv1 = seg_end(1:3, 1, segment) tv2 = seg_end(1:3, 2, segment) seg_kappa_(segment) = Arc_distance(tv1, tv2) / & & Arc_distance(in, out) ENDIF n = node(n, element) ! changing n from local/relative to global/absolute node number vn = xyz_nod(1:3, n) - seg_end(1:3, 1, segment) vs = seg_end(1:3, 2, segment) - seg_end(1:3, 1, segment) CALL Cross (vn, vs, c) tv = center(1:3, element) IF (Dot_3D(c, tv) > 0.0D0) THEN seg_eta_(segment) = +1.0D0 ELSE seg_eta_(segment) = -1.0D0 END IF END IF IF (debug) THEN ! A table is printed in file REPORT.txt, listing all segments. tv = seg_end(1:3, 1, segment) CALL Lonlat_from_xyz (tv, lon1, lat1) tv = seg_end(1:3, 2, segment) CALL Lonlat_from_xyz (tv, lon2, lat2) WRITE (21, & &"(' seg& & def(1) def(2)& & tr_lo(3)& & tr_lo(4)& & seg_end_is(1)& & seg_end_is(2)& & seg_end(1)& & seg_end(2)& & cin jin cout jout no_cut& & u_ eta_ kappa_')") WRITE (21, 9921) & &segment,& &seg_def(1,segment),seg_def(2,segment),& &trace_loc(3,seg_def(1,segment)),& &trace_loc(4,seg_def(1,segment)),& &seg_end_is(1,segment)%element,(seg_end_is(1,segment)%s(j3),j3=1,3),& &seg_end_is(2,segment)%element,(seg_end_is(2,segment)%s(j3),j3=1,3),& &lon1,lat1,& &lon2,lat2,& &cutin,jin,cutout,jout,no_cut,& &seg_u_(segment),seg_eta_(segment),seg_kappa_(segment) 9921 FORMAT (I4,& &I7,I7,& &I9,& &I9,& &I4,3F5.2,& &I4,3F5.2,& &F7.2,F6.2,& &F7.2,F6.2,& &L4,I4,L5,I5,L7,& &I4,F5.0,F7.2) END IF ! debug END SUBROUTINE Finish_seg SUBROUTINE Get_ageMa_and_filename(unit, t_Ma, t_filename, hit_end) IMPLICIT NONE INTEGER, INTENT(IN) :: unit ! Fortran device # for input from parameter file REAL*8, INTENT(OUT) :: t_Ma ! grid loading-age in (non-negative) Ma CHARACTER*80, INTENT(OUT) :: t_filename ! name of .FEG or .BCS file LOGICAL, INTENT(OUT) :: hit_end ! of file CHARACTER*80 :: RHS_of_line CHARACTER*132 :: line INTEGER :: ios, M_position, filename_position line = ' ' READ (unit, "(A)", IOSTAT = ios) line ! " 0.0 Ma: 0101_someName.feg blahblahblah", for example IF ((ios /= 0).OR.(LEN_TRIM(line) < 1)) THEN ! EOF error, or trailing empty line (sometimes accidentally present in parameter files)... hit_end = .TRUE. t_Ma = 0.0 t_filename = ' ' RETURN END IF hit_end = .FALSE. READ (line, *, IOSTAT = ios) t_Ma IF (ios /= 0) THEN WRITE (*, "(' ERROR: ios = ',I6, ' when trying to read loading-age in Ma for FEG/BCS #', I2)") ios, num_fegs WRITE (21, "('ERROR: ios = ',I6, ' when trying to read loading-age in Ma for FEG/BCS #', I2)") ios, num_fegs WRITE (*, "(' ', A)") TRIM(line) WRITE (21, "(A)") TRIM(line) CALL Pause() STOP END IF M_position = INDEX(line, "Ma:") IF (M_position > 0) THEN ! This should be the NORMAL branch... filename_position = M_position + 3 ! pointing to either a white-space, or the beginning of the filename RHS_of_line = line(filename_position: 132) ! but note that result is no longer than 80-byte variable size t_filename = Get_filename(RHS_of_line) ! which function will ignore any leading white-space, and also ignore any following comments ELSE ! complain and stop WRITE (*, "(' ERROR: In parameter file, required text "" Ma: "" must separate the ')") WRITE (*, "(' loading-age number from the FEG (or BCS) filename.')") WRITE (21, "('ERROR: In parameter file, required text "" Ma: "" must separate the ')") WRITE (21, "(' loading-age number from the FEG (or BCS) filename.')") WRITE (*, "(' ', A)") TRIM(line) WRITE (21, "(A)") TRIM(line) CALL Pause() STOP END IF END SUBROUTINE Get_ageMa_and_filename SUBROUTINE Get_another_parameter_line(unit, string) IMPLICIT NONE INTEGER, INTENT(IN) :: unit CHARACTER*(*), INTENT(OUT) :: string CHARACTER*132 :: line INTEGER :: ios line = ' ' READ (unit, "(A)", IOSTAT = ios) line IF (ios == 0) THEN string = TRIM(line) ELSE WRITE (*, "(' ERROR: IOSTAT = ',I6, ' encountered while reading parameter-file.')") ios WRITE (21, "('ERROR: IOSTAT = ',I6, ' encountered while reading parameter-file.')") ios CALL Pause() STOP END IF END SUBROUTINE Get_another_parameter_line REAL*8 FUNCTION Get_azimuth (v1, v2) IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: v1, v2 REAL*8, DIMENSION(3) :: Phi, step, Theta REAL*8 :: del_phi_, del_theta_, lon, lat ! v1 and v2 are Cartesian unit vectors. ! Result is azimuth from v1 to v2, measured at v1, in radians, ! and measured clockwise from North. IF (v1(1) == v2(1)) THEN IF (v1(2) == v2(2)) THEN IF (v1(3) == v2(3)) THEN CALL Lonlat_from_xyz(v1, lon, lat) WRITE (*, "(' Error: Get_azimuth of coincident points at ',F8.3,'E, ',F7.3,'N')") lon, lat WRITE (21, "('Error: Get_azimuth of coincident points at ',F8.3,'E, ',F7.3,'N')") lon, lat CALL Pause() STOP END IF END IF END IF step = v2 - v1 CALL Local_Phi (v1, Phi) CALL Local_Theta(v1, Theta) del_phi_ = Dot_3D(step, Phi) del_theta_ = Dot_3D(step, Theta) Get_azimuth = ATAN2(del_phi_, -del_theta_) END FUNCTION Get_azimuth CHARACTER(80) FUNCTION Get_filename (string) ! Obtains a filename from the beginning of the text-string supplied; ! name may be padded with blanks on both sides, and ! may be followed by comments. Note that ! "unit" should have been opened with PAD = "YES". CHARACTER*(*), INTENT(IN) :: string CHARACTER(132) :: buffer INTEGER :: i LOGICAL :: past buffer = TRIM(string) buffer = ADJUSTL(buffer) ! left-justify past = .FALSE. ! will be T when past end of filename blank_right: DO i = 2, 132 IF ((buffer(i:i) == ' ') .OR. & (buffer(i:i) == ',') .OR. & (buffer(i:i) == '=') .OR. & (buffer(i:i) == ':')) past = .TRUE. IF (past) buffer(i:i) = ' ' END DO blank_right IF (((buffer(1:1) == 'N') .OR. (buffer(1:1) == 'n')) .AND. & ((buffer(2:2) == 'O') .OR. (buffer(2:2) == 'o')) .AND. & ((buffer(3:3) == 'N') .OR. (buffer(3:3) == 'n')) .AND. & ((buffer(4:4) == 'E') .OR. (buffer(4:4) == 'e')) .AND. & (buffer(5:5) == ' ')) buffer = 'none' Get_filename = buffer(1:80) END FUNCTION Get_filename SUBROUTINE Gjxy (l_, r_, G) IMPLICIT NONE INTEGER, INTENT(IN) :: l_ ! element number REAL*8, DIMENSION(3), INTENT(IN) :: r_ ! position vector REAL*8, DIMENSION (3,2,2), INTENT(OUT) :: G ! computes matrix of 6 vector nodal functions for element l_ at ! position r_ (Cartesian unit vector). ! It is user's responsibility that element l_ contains r_. SAVE ! allows fast re-entry when l_ is unchanged. INTEGER :: l_last = 0 ! remembers l_ from previous invocation INTEGER :: j ! 1:3 = local node numbering in element l_ INTEGER :: x ! 1:2 = node j has unit velocity to South(1) or East(2) INTEGER :: y ! 1:2 = South(1) or East(2) component of vector nodal function REAL*8, DIMENSION(3,2) :: local ! local unit vectors at r_ (xyz, SE) REAL*8, DIMENSION(3,3) :: corner ! positions vector of corner nodes (xyz, 123) REAL*8, DIMENSION(3,3,2) :: post ! unit coordinate vectors at corner nodes: ! (xyz, 123, SE) REAL*8, DIMENSION(3) :: tvi, tvo, tv1, tv2, tv3, vf ! temporary vector factor REAL*8 :: f_sup_j ! as in Kong and Bird (1995) [ j == k ] INTEGER :: i1, i2, i3 ! 1, 2, or 3 in cyclic rotation (depends on j) IF (l_ /= l_last) THEN ! new finite element l_last = l_ DO j = 1, 3 corner(1:3, j) = xyz_nod(1:3, node(j, l_)) tvi = corner(1:3, j) CALL Local_Theta(tvi, tvo) post(1:3, j, 1) = tvo CALL Local_Phi (tvi, tvo) post(1:3, j, 2) = tvo END DO END IF ! begin computations which depend on r_ CALL Local_Theta(r_, tvo) local(1:3,1) = tvo CALL Local_Phi(r_, tvo) local(1:3,2) = tvo DO j = 1, 3 i1 = j i2 = 1 + MOD(j, 3) i3 = 1 + MOD(i2,3) tv1 = corner(1:3, i1) tv2 = corner(1:3, i2) tv3 = corner(1:3, i3) CALL Cross(tv2, tv3, vf) f_sup_j = Dot_3D(r_, vf) / Dot_3D (tv1, vf) DO x = 1, 2 tv1 = post(1:3, j, x) DO y = 1, 2 tv2 = local(1:3, y) G(j, x, y) = f_sup_j * Dot_3D(tv1, tv2) END DO END DO END DO END SUBROUTINE Gjxy CHARACTER(80) FUNCTION Insert (filename, filename_suffix) ! truncates left part of 'filename' to 4 (or fewer) bytes, and adds 'filename_suffix'; ! should be able to handle complicated names like: ! "../project/restore/NA5AblahBlahBlah.FEG " ! (in either DOS or Unix), producing something like: ! "../project/restore/NA5A_i020_065.2Ma.FEG" (from an iterated solution), or ! "../project/restore/NA5A_NI_065.2Ma.FEG" (from an solution which was Not Iterated). IMPLICIT NONE CHARACTER(*), INTENT(IN) :: filename CHARACTER(13), INTENT(IN) :: filename_suffix ! e.g., "_NI_006.0Ma" {+2 spaces} OR "_065.2Ma_i020" INTEGER :: last, left_frame, right_frame, old_stub, new_stub last = LEN_TRIM(filename) left_frame = MAX (INDEX (filename, '\', .TRUE.), INDEX (filename, '/', .TRUE.)) right_frame = INDEX (filename, '.', .TRUE.) IF ((right_frame == 0) .OR. (right_frame < left_frame)) THEN right_frame = INDEX (filename, ' ') END IF old_stub = (right_frame - left_frame) - 1 new_stub = MIN (old_stub, 4) Insert = filename(1 : (left_frame + new_stub)) // TRIM(filename_suffix) // & ! N.B. filename_suffix is either 13 or 11 bytes long, TRIM(filename(right_frame : last)) ! depending on whether the solution was iterated or Not Iterated. END FUNCTION Insert SUBROUTINE Internal (b_, iele, s1, s2, s3) IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: b_ INTEGER, INTENT(INOUT) :: iele REAL*8, INTENT(OUT) :: s1, s2, s3 ! Input is a Cartesian unit vector in the unit sphere. ! Output is element number and s1, s2, s3 internal coordinates of the ! plane triangle finite element containing the given point. INTEGER, PARAMETER :: memory = 18 ! rather arbitrary; should be big enough(?) INTEGER :: attempts, best_iet_so_far, i, iet, l_ INTEGER, DIMENSION(memory) :: iet_history LOGICAL :: in_loop REAL*8 :: best_minimum_so_far, lon, lat, lowest, & & r2, r2min, s1t, s2t, s3t, s_min_back1, s_min_back2, worst REAL*8, DIMENSION(3):: s_temp, tv ! establish defaults (not found) in case of quick exit s1 = 0.0D0; s2 = 0.0D0; s3 = 0.0D0 ! NOTE: Following line should prevent assigning internal coordinates ! to a point that previously fell outside the grid, sat ! stagnant, and then got overridden by the plate motion of the grid! ! It only allows iele values of 0 to be changed at the ! initial time of the computation (each iteration). IF ((time0 > start_time).AND.(iele <= 0)) RETURN !find closest element center to initialize search r2min = 4.01D0 DO l_ = 1, num_ele r2 = (b_(1) - center(1,l_))**2 +(b_(2) - center(2,l_))**2 +(b_(3) - center(3,l_))**2 IF (r2 < r2min) THEN r2min = r2 iet = l_ END IF END DO ! If closest element center is more than 1 radian away, give up. tv = center(1:3, iet) IF (Dot_3D(b_, tv) < 0.540D0) THEN iele = 0 RETURN END IF ! initialize search memory (with impossible numbers) iet_history = 0 ! whole list attempts = 0 best_iet_so_far = 0 ! (intended to be replaced right away) best_minimum_so_far = -999.9 ! (intended to be replaced right away) is_it_here: DO attempts = attempts + 1 IF (attempts > memory) THEN WRITE (*, "(' ERROR: Parameter ""memory"" in SUBROUTINE Internal is not large enough.')") WRITE (21, "('ERROR: Parameter ""memory"" in SUBROUTINE Internal is not large enough.')") CALL Pause() STOP END IF iet_history(attempts) = iet ! first, check for infinite loop! in_loop = .FALSE. ! but that may change, below ... IF (attempts >= 3) THEN DO j = 1, (attempts - 1) IF (iet_history(j) == iet_history(attempts)) in_loop = .TRUE. END DO END IF IF (in_loop) THEN ! in loop; force location to be in the best element so far iet = best_iet_so_far CALL Dumb_s123 (xyz_nod, iet, b_, s1t, s2t, s3t) s_temp(1) = s1t; s_temp(2) = s2t; s_temp(3) = s3t CALL Pull_in(s_temp) s1t = s_temp(1); s2t = s_temp(2); s3t = s_temp(3) EXIT is_it_here ELSE ! normal operation CALL Dumb_s123 (xyz_nod, iet, b_, s1t, s2t, s3t) ! - - - - (except, maintain memory of the process) - - - worst = MIN(s1t, s2t, s3t) IF (worst > best_minimum_so_far) THEN ! remember the new best... best_minimum_so_far = worst best_iet_so_far = iet END IF ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF ((s1t < s2t) .AND. (s1t < s3t)) THEN ! s1 is most negative; most critical IF (s1t >= 0.0D0) THEN EXIT is_it_here ! success ELSE i = neighbor(1, iet) IF (i > 0) THEN iet = i CYCLE is_it_here ELSE iele = 0 RETURN ! fell off edge of grid ENDIF ENDIF ELSE IF ((s2t < s1t) .AND. (s2t < s3t)) THEN ! s2 is most negative; most critical IF (s2t >= 0.0D0) THEN EXIT is_it_here ! success ELSE i = neighbor(2, iet) IF (i > 0) THEN iet = i CYCLE is_it_here ELSE iele = 0 RETURN ! fell off edge of grid ENDIF ENDIF ELSE ! s3 is most negative; most critical IF (s3t >= 0.0D0) THEN EXIT is_it_here ! success ELSE i = neighbor(3, iet) IF (i > 0) THEN iet = i CYCLE is_it_here ELSE iele = 0 RETURN ! fell off edge of grid ENDIF ENDIF END IF END IF ! in/not in a loop END DO is_it_here ! successful completion iele = iet s1 = s1t s2 = s2t s3 = s3t END SUBROUTINE Internal SUBROUTINE Interpolate (coordinates, v) ! Input is an internal coordinate set. ! Output is v = unit Cartesian (xyz) location vector IMPLICIT NONE TYPE(is123) :: coordinates REAL*8, DIMENSION(3), INTENT(OUT) :: v INTEGER :: i1, i2, i3, iele REAL*8 :: s1, s2, s3 REAL*8, DIMENSION(3) :: vt iele = coordinates%element i1 = node(1, iele) i2 = node(2, iele) i3 = node(3, iele) s1 = coordinates%s(1) s2 = coordinates%s(2) s3 = coordinates%s(3) vt = s1 * xyz_nod(1:3, i1) + s2 * xyz_nod(1:3, i2) + s3 * xyz_nod(1:3, i3) CALL Unitise(vt, v) END SUBROUTINE Interpolate REAL*8 FUNCTION Length(a_vec) IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: a_vec DOUBLE PRECISION :: t t = a_vec(1)**2 + & & a_vec(2)**2 + & & a_vec(3)**2 IF (t == 0.0D0) THEN Length = 0.0D0 ELSE Length = SQRT(t) END IF END FUNCTION Length SUBROUTINE Local_Phi (b_, Phi) ! returns local East-pointing unit vector in Cartesian coordinates ! for location b_; not intended to work at the poles! IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: b_ REAL*8, DIMENSION(3), INTENT(OUT) :: Phi REAL*8, DIMENSION(3) :: temp IF (b_(1) == 0.0D0) THEN IF (b_(2) == 0.0D0) THEN WRITE (*, "(' Error: Local_Phi was requested for N or S pole.')") WRITE (21, "('Error: Local_Phi was requested for N or S pole.')") CALL Pause() STOP END IF END IF temp(1) = - b_(2) temp(2) = b_(1) temp(3) = 0.0D0 CALL Unitise(temp, Phi) END SUBROUTINE Local_Phi SUBROUTINE Local_Theta (b_, Theta) ! returns local South-pointing unit vector in Cartesian coordinates ! for location b_; not intended to work at the poles! IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: b_ REAL*8, DIMENSION(3), INTENT(OUT) :: Theta REAL*8, DIMENSION(3) :: temp REAL*8 :: equat, new_equat equat = SQRT(b_(1)**2 + b_(2)**2) !equatorial component IF (equat == 0.0D0) THEN WRITE (*, "(' Error: Local_Theta was requested for N or S pole.')") WRITE (21, "('Error: Local_Theta was requested for N or S pole.')") CALL Pause() STOP END IF new_equat = b_(3) ! swap components in a meridional plane temp(3) = - equat ! " temp(1) = new_equat * b_(1) / equat ! partition new equatorial component temp(2) = new_equat * b_(2) / equat ! " CALL Unitise(temp, Theta) END SUBROUTINE Local_Theta SUBROUTINE Lonlat_from_xyz (b_, lon, lat) IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: b_ ! Cartesian unit vector from center of planet REAL*8, INTENT(OUT) :: lon, lat REAL*8 :: equat equat = b_(1)**2 + b_(2)**2 IF (equat == 0.0D0) THEN ! N or S pole lon = 0.0D0 ! arbitrary convention IF (b_(3) > 0.0D0) THEN lat = 90.0D0 ELSE lat = -90.0D0 END IF ELSE lat = ATAN2 (b_(3), SQRT(equat)) lon = ATAN2 (b_(2), b_(1)) lon = lon * deg_per_rad lat = lat * deg_per_rad END IF END SUBROUTINE Lonlat_from_xyz SUBROUTINE Look_ahead(folding) !Use vw_mean (from the timestep just completed) to project node locations (tentatively) back one more timestep, !and check whether folding is likely. (This can save a lot of execution time that would otherwise be wasted.) !Note that almost all variables and arrays are global. IMPLICIT NONE LOGICAL, INTENT(OUT) :: folding INTEGER :: i, i1, i2, i3, l_ REAL*8, DIMENSION(3) :: a, b, c, t, tvi, tvo !Move nodes back one more timestep, using vw_mean from timestep just completed, !and put their uvecs into (temporary) array lookAhead_xyz_nod: DO i = 1, num_nod tvi = xyz_nod(1:3, i) CALL Moved_by_vw (tvi, vw_mean(2*i-1), vw_mean(2*i), .FALSE., tvo) lookAhead_xyz_nod(1:3, i) = tvo END DO folding = .FALSE. ! ...unless the following test reveals a likely problem! DO l_ = num_ele, 1, -1 ! num_ele is global, like most variables ! Note that this loop runs "backwards" so that higher-numbered folded elements ! will appear first in the CAUTION list. ! This is important because the user should fix these problems (in OrbWin) ! in the order high-numbered --> low-numbered elements. ! (Otherwise, editing will cause some of the #s of the bad elements to CHANGE!) i1 = node(1, l_) i2 = node(2, l_) i3 = node(3, l_) a = lookAhead_xyz_nod(1:3, i2) - lookAhead_xyz_nod(1:3, i1) b = lookAhead_xyz_nod(1:3, i3) - lookAhead_xyz_nod(1:3, i2) CALL Cross (a, b, c) t = lookAhead_xyz_nod(1:3, i1) + lookAhead_xyz_nod(1:3, i2) + lookAhead_xyz_nod(1:3, i3) !a_(l_) = Magnitude(c) * half_R2 ! (Note that area is neither computed or saved by this subprogram.) IF (Dot_3D(t, c) <= 0.0D0) THEN folding = .TRUE. WRITE (*, "(' Caution: Element ',I8,' is likely to flip next time; change FEG!')") l_ WRITE (21, "(' Caution: Element ',I8,' is likely to flip next time; change FEG!')") l_ END IF END DO END SUBROUTINE Look_ahead REAL*8 FUNCTION Magnitude (b_) IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: b_ Magnitude = SQRT(b_(1)**2 +b_(2)**2 + b_(3)**2) END FUNCTION Magnitude SUBROUTINE Make_Uvec (vector, uvec) ! Shortens or lengthens a three-component vector to a unit vector; ! includes special kludge to prevent extremely small component ! values which result from rounding error and result in later ! numerical underflows. IMPLICIT NONE INTEGER :: i REAL*8, DIMENSION(3), INTENT(IN) :: vector REAL*8, DIMENSION(3), INTENT(OUT):: uvec REAL*8 :: factor, size size = Length(vector) IF (size > 0.0D0) THEN factor = 1.0D0 / size uvec = vector * factor DO i = 1, 3 IF (ABS(uvec(i)) < 1.D-18) uvec(i) = 0.0D0 END DO ELSE WRITE (*,"(' ERROR: Cannot Make_Uvec of (0.0D0, 0.0D0, 0.0D0).')") CALL Traceback() END IF END SUBROUTINE Make_Uvec CHARACTER(13) FUNCTION Mangle (last_iteration, iteration, time) !Creates value of filename_suffix in 13 or 11 bytes; e.g., "_i020_065.2Ma" or "_NI_065.2Ma" or "_NT_000.0Ma". !Note that this allows up to 999 iterations (or none: "_NI" or "_NT"), and also !allows geologic histories back to 999.9 Ma, and supports !time-steps as small as 0.1 m.y.. IMPLICIT NONE INTEGER, INTENT(IN) :: last_iteration, iteration REAL*8, INTENT(IN) :: time REAL*8 :: tMa CHARACTER*3 :: iteration_number CHARACTER*5 :: iteration_ID ! (but in some cases we will only use 3 bytes) CHARACTER*5 :: time_number IF (last_iteration > 1) THEN ! this project involves an iterated solution IF (iteration <= 999) THEN WRITE (iteration_number, "(I3)") iteration IF (iteration_number(1:1) == ' ') iteration_number(1:1) = '0' IF (iteration_number(2:2) == ' ') iteration_number(2:2) = '0' iteration_ID = "_i" // iteration_number ! 5 bytes in all ELSE WRITE (*, "(' Error in Mangle: cannot handle very large input value:', 2I10, F10.1)") last_iteration, iteration, tMa WRITE (21, "('Error in Mangle: cannot handle very large input value:', 2I10, F10.1)") last_iteration, iteration, tMa CALL Pause() STOP END IF ELSE ! This project is either Not Iterated, or NeoTectonic: IF (paleotec) THEN iteration_ID = "_NI" ! only 3 bytes ELSE ! neotec iteration_ID = "_NT" ! only 3 bytes END IF END IF tMa = time / s_per_Ma ! where the denominator is a global value IF (tMa <= 999.9) THEN WRITE (time_number, "(F5.1)") tMa IF (time_number(1:1) == ' ') time_number(1:1) = '0' IF (time_number(2:2) == ' ') time_number(2:2) = '0' IF (time_number(3:3) == ' ') time_number(3:3) = '0' ELSE WRITE (*, "(' Error in Mangle: cannot handle very large input value:', 2I10, F10.1)") last_iteration, iteration, tMa WRITE (21, "('Error in Mangle: cannot handle very large input value:', 2I10, F10.1)") last_iteration, iteration, tMa CALL Pause() STOP END IF Mangle = TRIM(iteration_ID) // '_' // time_number // "Ma" ! either 11 or 13 bytes long, and left-adjusted already. END FUNCTION Mangle SUBROUTINE More_mem (array_name, bytes_added) ! Keeps track of total array allocation IMPLICIT NONE CHARACTER(*) :: array_name ! literal text REAL*8 :: bytes_added REAL*8 :: GB_added, GB_total CHARACTER(80) :: buffer memory = memory + bytes_added GB_added = bytes_added / bytes_per_GB GB_total = memory / bytes_per_GB WRITE (buffer,"('Allocated ',A,' =',F8.3,' GB, total',F8.3,' GB')") & array_name, GB_added, GB_total buffer = ADJUSTR(buffer) WRITE (*, "(A)") buffer WRITE (21,"(A)") buffer END SUBROUTINE More_mem SUBROUTINE Move_data (vw) ! Relocates all integrated positions and orientations (except xyz_nod, ! which is modified by subprogram Move_feg). !------------------------------------------------------------------------ ! Under translation method #0 or #3 (translation_method(point_index) == 0 OR 3), ! this is done by re-interpolating from adjusted xyz_nod positions, ! using long-standing internal coordinates of each point, and ! without any reference to velocity vectors. !----------------------------------------------------------------------------- ! Alternate translation method #1 is often the same, except where !"unhooking" (from their internal coordinates) of the ends of fault ! traces that share an element with a faster strike-slip fault, so that ! they will not become excessively sheared and bent. ! Regardless of whether translation_method == 0 or 1, ! traces of strike-slip faults are smoothed (keeping their end-points fixed). !----------------------------------------------------------------------------- ! Translation method #2 ("symmetric_spreading_system") moves a fault trace ! (often consisting of only 2 points) at the mean velocity of the two ! surrounding plates, which is determined by testing velocity at two ! eccentric points about 100 km away. (We hope that these points will ! be outside the fast-deforming elements that contain this fault trace.) !----------------------------------------------------------------------------- ! Note that for translation methods #0, #2, and #3, there will be an extra ! step to try to eliminate any (small) spatial gaps between trace-ends with ! matching attributes, that may have crept in (e.g., when fault was inactive). !----------------------------------------------------------------------------- IMPLICIT NONE REAL*8, DIMENSION(nDOF), INTENT(IN) :: vw ! Note that this is ONLY used for "symmetric_spreading_system" faults ! under translation method #2. In terms of global arrays, the ! value of vw should be vw0 in the predictor step, or vw_add in the corrector step. ! (Within this routine, we don't have to worry about that distinction.) CHARACTER*1 :: c INTEGER :: a, a_prime, b, b_prime, element, f, fault, i, i1, i2, ii, j, j1, j2, k, l_, & & n, ns, n1, n2, object, points, segment, trial_datum, which_datum LOGICAL :: blocked_left, blocked_right, next_point_outside, unhooked LOGICAL, DIMENSION(:), ALLOCATABLE :: shearing ! temporary, internal TYPE(is123) :: m1, this_is, this_is1, this_is2 REAL*8, PARAMETER :: stepAway_m = 100.0D3 REAL*8 :: azimuth_degrees, azimuth0_radians, azimuth1_radians, azimuth2_radians, & & heaveRateGoal_LR, heaveRateGoal_perpendicular, heaveRateGoal_size, holding, length_Radians, & & mean_step_meters, & & r2_in_radian2, s1, s2, s3, & & smaller_stepAway_radians, smoothing, stepAway_radians, & & tolerance_in_degrees, tolerance_in_radian2, & & v_, v_1, v_2, velocity_factor, w_, w_1, w_2 REAL*8, DIMENSION(3) :: omega_uvec, tvec, tvo, tv1, tv2, & & uvec_i1_end, uvec_i1_inside, uvec_i2_end, uvec_i2_inside, uvec_mean, vector REAL*8, DIMENSION(3,2,2) :: G IF (ALLOCATED(center)) THEN !Re-define element-center uvecs (just moved by CALL Move_feg): m1%s(1:3) = 1.0D0 / 3.0D0 DO l_ = 1, num_ele m1%element = l_ CALL Interpolate(m1, tvo) center(1:3, l_) = tvo END DO END IF !Move nodes of before.feg using their internal coordinates: IF (paleotec) THEN DO i = 1, before_and_after_numnod IF (before_node_is(i)%element > 0) THEN ! should always be true! CALL Interpolate(before_node_is(i), tvo) before_node_uvec(1:3, i) = tvo END IF ! valid internal coordinates END DO END IF !Move ends of balanced cross-sections (always by translation method #0): IF (c_rst_count > 0) THEN DO i = 1, c_rst_count IF (c_end_is(1,i)%element > 0) THEN CALL Interpolate(c_end_is(1, i), tvo) c_end_now(1:3, 1, i) = tvo END IF IF (c_end_is(2,i)%element > 0) THEN CALL Interpolate(c_end_is(2, i), tvo) c_end_now(1:3, 2, i) = tvo END IF END DO END IF !Move paleomagnetic data sites (always by translation method #0): IF (p_rst_count > 0) THEN DO i = 1, p_rst_count IF (p_site_is(i)%element > 0) THEN CALL Interpolate(p_site_is(i), tvo) p_site_now(1:3, i) = tvo END IF END DO END IF !Move stress indicators (always by translation method #0): IF (s_rst_count > 0) THEN DO i = 1, s_rst_count IF ((s_site_is(1,i)%element > 0).AND.(s_site_is(2,i)%element > 0)) THEN CALL Interpolate(s_site_is(1, i), tvo) s_site_now(1:3, 1, i) = tvo CALL Interpolate(s_site_is(2, i), tvo) s_site_now(1:3, 2, i) = tvo tv1 = s_site_now(1:3, 1, i) tv2 = s_site_now(1:3, 2, i) s_azim_now(i) = Get_azimuth(tv1, tv2) END IF END DO END IF !Move points of basemap/geologic-map, if any, by simple translation method #0: IF (basemap_object_count > 0) THEN DO object = 1, basemap_object_count points = basemap_object_index(4, object) IF (points > 0) THEN i1 = basemap_object_index(5, object) i2 = basemap_object_index(6, object) DO i = i1, i2 l_ = basemap_point_is(i)%element IF (l_ > 0) THEN ! I THINK that this will always be true; see Compact_Basemap() which was called earlier. CALL Interpolate(basemap_point_is(i), tvo) basemap_uvec_store(1:3, i) = tvo(1:3) END IF ! l_ > 0 END DO ! i = i1, i2 END IF ! points > 0 END DO ! object = 1, basemap_object_count END IF ! basemap_object_count > 0; using a basemap or geologic-map !Move segment ends in accordance with old fault shapes, for !use during call to Predictor later in each time step. !Note, however, that after this call the segments will be !redefined from scratch before the next velocity solution, !because strike-slip faults will have been smoothed, !and also in case some faults were symmetric_spreading_boundaries !(moved by translation method 2). IF (seg_count > 0) THEN DO i = 1, seg_count IF (seg_end_is(1, i)%element > 0) THEN CALL Interpolate(seg_end_is(1, i), tvo) seg_end(1:3, 1, i) = tvo END IF IF (seg_end_is(2, i)%element > 0) THEN CALL Interpolate(seg_end_is(2, i), tvo) seg_end(1:3, 2, i) = tvo END IF END DO END IF !Move fault traces: !---------------------------------------------------------------------- !In throughgoing_master_fault method #0 or other_spreading_system method #3 !(translation_method(point_index) == 0 OR 3), !each digitization point along the fault trace remains glued to its !surrounding element, with no change to internal coordinates of points. !(This is the same method used for paleomag sites, cross-section ends, ! and basemap translations.) This method avoids introducing any ! unwanted gaps/overlaps between ends of adjacent named sections of one ! throughgoing master fault. However, after this method is applied to ! master fault traces, there will also be 2 post-processing edits applied !(by other blocks of code below this one): !(1) Joints between neighboring ! fault-ends that share method #0, #2, or #3 will have any gap ! removed by averaging of the joint location; and then !(2) Any strike-slip fault traces will be smoothed internally, ! leaving their end-points fixed. !---------------------------------------------------------------------- !In default translation method #1 (translation_method(point_index) == 1), !locating displaced traces is complicated by the need to avoid folding !in elements sheared by OTHER active strike-slip faults. For any !trace crossing such shearing elements, I try to find an adjacent !(along the trace, that is) element that isn't sheared by those !faults, and replace the internal coordinates in the !shearing element with external coordinates of the adjacent element. !(However, these coordinate changes are temporary and not recorded, !because in other time steps different faults may be active.) !---------------------------------------------------------------------- !In the "symmetric_spreading_boundary" method (method 2), this trace point !is moved according to the mean velocity of the two surrounding plates. !To sample these velocities, temporary eccentric points about 100 km on !each side of the trace point are accessed (if possible). The idea is !that these temporary eccentric points should be outside the element(s) !that are being rapidly deformed by the spreading motion. !---------------------------------------------------------------------- IF (f_dig_count > 0) THEN ! There are some faults to be moved, so ... stepAway_radians = stepAway_m / R ! strategic parameter used in translation method #2 trace_premove = trace ! Save whole array of trace uvecs; old values are needed for method #2. !Begin code block with basic (first-draft) movement of fault traces: DO f = 1, f_highest ! F0001, F0002, ... IF (f_2_in(f)) THEN ! Trace has >= 2 points in grid !Characterize magnitude of the heave-rate goal for this trace, for purposes of comparison to others !in the default-mode (mode-1; potentially-unhooking?) procedure which typically follows: heaveRateGoal_LR = 0.0D0 ! initializing, before search for largest magnitude heaveRateGoal_perpendicular = 0.0D0 ! (same) DO i = 1, crack_count ! consider all active cracks that might involve this trace(?) segment = local_crack(i)%segment fault = seg_def(1, segment) IF (fault == f) THEN ! the crack concerns the current fault trace IF ((local_crack(i)%sense == 'R').OR.(local_crack(i)%sense == 'L')) THEN heaveRateGoal_LR = MAX(heaveRateGoal_LR, ABS(local_crack(i)%s_)) ELSE heaveRateGoal_perpendicular = MAX(heaveRateGoal_perpendicular, ABS(local_crack(i)%s_)) END IF END IF END DO ! i = 1, crack_count heaveRateGoal_size = SQRT(heaveRateGoal_LR**2 + heaveRateGoal_perpendicular**2) !which may be 0.0D0 if this fault is not active in the current time-step. !The current fault trace (which we are translating, whether it is slipping or not) !only needs to fear artificial deformation in the fault-corridor(s) of faults which are: ! *OTHER (not the same fault trace); and ! *STRIKE-SLIP (entirely, or as a component of oblique slip); and ! *FASTER (than heaveRateGoal_size). {Note that this 3rd criterion was added 2020.07.17, to reduce extent of unhooking.} !Here, we pre-create a list of all elements, and mark those which contain such "dangerous" faults... ALLOCATE (shearing(num_ele)) shearing = .FALSE. ! whole array, unless changed below: DO i = 1, crack_count IF ((local_crack(i)%sense == 'R').OR.(local_crack(i)%sense == 'L')) THEN ! *STRIKE-SLIP test IF (ABS(local_crack(i)%s_) > heaveRateGoal_size) THEN ! *FASTER test segment = local_crack(i)%segment fault = seg_def(1, segment) IF (fault /= f) THEN ! *OTHER test {implied by FASTER test, but kept for safety & clarity} element = seg_def(2, segment) shearing(element) = .TRUE. END IF ! *OTHER test END IF ! *FASTER test END IF ! *STRIKE-SLIP test END DO ! i = 1, crack_count ! ... because this info will be needed to control unhooking in the very common translation_method == 1 case. ! Note that the table must be pre-created separately for each trace, because of the OTHER and FASTER tests. a = trace_loc(1, f) ! limiting indices in "trace" and b = trace_loc(2, f) ! in "trace_is", and in "translation_method" DO i = a, b ! for each point along this trace... IF (translation_method(i) /= 2) THEN ! most common case; translation_method(i) == 0 OR 1 OR 3: this_is = trace_is(i) ! get internal coordinates; both are TYPE(is123) IF ((translation_method(i) == 0).OR.(translation_method(i) == 3)) THEN unhooked = .FALSE. ! just a comment, really; this is part of the MEANING of translation methods #0 and #3. IF (this_is%element > 0) THEN !Heart of translation method 0: CALL Interpolate(this_is, tvo) trace(1:3, i) = tvo END IF ! this trace point is in the grid ELSE ! translation_method == 1; unhooking may occur unhooked = .FALSE. ! unless changed below ... IF (this_is%element > 0) THEN IF (shearing(this_is%element)) THEN !Now, try to move left and right along trace to find !a non-shearing element as basis for internal coordinates: j1 = i j2 = i blocked_left = .FALSE. blocked_right = .FALSE. sidestepping2: DO !try going left j1 = j1 - 1 blocked_left = blocked_left.OR.(j1 < a) ! past point 1 IF (.NOT.blocked_left) THEN element = trace_is(j1)%element IF (element > 0) THEN IF (.NOT.shearing(element)) THEN ! got it! unhooked = .TRUE. ! must update internal coordinates after move vector(1:3) = trace(1:3, i) CALL Dumb_s123 (xyz_nod_premove, element, vector, s1, s2, s3) this_is%element = element this_is%s(1) = s1 this_is%s(2) = s2 this_is%s(3) = s3 EXIT sidestepping2 END IF ! got an anchor for this trace ELSE ! trace left the grid blocked_left = .TRUE. END IF ! trial element is defined, or not END IF ! .NOT.blocked_left !try going right j2 = j2 + 1 blocked_right = blocked_right.OR.(j2 > b) ! past end point 2 IF (.NOT.blocked_right) THEN element = trace_is(j2)%element IF (element > 0) THEN IF (.NOT.shearing(element)) THEN ! got it! unhooked = .TRUE. ! must update internal coordinates after move vector(1:3) = trace(1:3, i) CALL Dumb_s123 (xyz_nod_premove, element, vector, s1, s2, s3) this_is%element = element this_is%s(1) = s1 this_is%s(2) = s2 this_is%s(3) = s3 EXIT sidestepping2 END IF ! got an anchor for this trace ELSE ! trace has left the grid blocked_right = .TRUE. END IF ! trial element > 0 END IF ! .NOT.blocked_right IF (blocked_left.AND.blocked_right) EXIT sidestepping2 ! no way to fix it END DO sidestepping2 END IF ! this_is needs to be corrected !Heart of translation method 1 (either simple like method #0, or complex, depending on contents of this_is): CALL Interpolate(this_is, tvo) trace(1:3, i) = tvo IF (unhooked) THEN ! special customized version of translation method #1 was used; !recompute internal coordinates after move: l_ = trace_is(i)%element CALL Internal(tvo, l_, s1, s2, s3) trace_is(i)%element = l_ trace_is(i)%s(1) = s1 trace_is(i)%s(2) = s2 trace_is(i)%s(3) = s3 END IF END IF ! this trace point is in the grid END IF ! translation_method == (0, 3), or otherwise 1 ELSE IF (translation_method(i) == 2) THEN ! symmetric_spreading_system method (mean velocity of two surrounding plates): IF (trace_is(i)%element > 0) THEN ! only attempt to translate points that are inside the FEG domain. !Note that the following computations are done for all (usually--"both") points on a fault trace. !This is a small inefficiency, but worthwhile for the improved clarity of this code. !Also, it would not be good enough to use the same eccentric points for each end of a fault, !because this would fail to capture any overall rotation of the bounding plates. !Define azimuths to the 2 eccentric points, in directions normal to the fault trace: a_prime = a ! index of start of trace (before possible adjustment of index) b_prime = b ! index of end of trace (before possible adjustment of index) IF (trace_is(a_prime)%element == 0) THEN ! look for a neighbor to a_prime that is still within the model IF ((b_prime - a_prime) >= 2) THEN ! there are intermediate digitization points that might serve better stepping_a_prime: DO ii = (a_prime + 1), (b_prime - 1) IF (trace_is(ii)%element > 0) THEN a_prime = ii EXIT stepping_a_prime END IF END DO stepping_a_prime END IF END IF IF (trace_is(b_prime)%element == 0) THEN ! look for a neighbor to b_prime that is still within the model IF ((b_prime - a_prime) >= 2) THEN ! there are intermediate digitization points that might serve better stepping_b_prime: DO ii = (b_prime - 1), (a_prime + 1), -1 IF (trace_is(ii)%element > 0) THEN b_prime = ii EXIT stepping_b_prime END IF END DO stepping_b_prime END IF END IF tv1(1:3) = trace_premove(1:3, a_prime) ! start-point and tv2(1:3) = trace_premove(1:3, b_prime) ! end-point of this trace (before translation; and, preferably, using parts within FEG domain) azimuth0_radians = DCompass(from_uvec = tv1, to_uvec = tv2) ! along fault trace, in the digitization direction (which is arbitrary) azimuth1_radians = azimuth0_radians + plateward_dAzimuth(i) ! precomputed, to turn the "look direction" toward stable plate interior. azimuth2_radians = azimuth1_radians - Pi ! opposite to the above. !Compute uvecs of the two eccentric points: tvo(1:3) = trace_premove(1:3, i) ! Step-away from pre-translation position of this trace point. ! NOTE one subtlety: If bounding plates are rotating, then eccentric ! point locations are different for each trace point, and the returned ! mean plate velocity is also slightly different. This should cause ! the symmetric_spreading_system to rotate, too, at the correct rate! CALL DTurn_To (azimuth_radians = azimuth1_radians, base_uvec = tvo, far_radians = stepAway_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = tv1) ! outputs CALL DTurn_To (azimuth_radians = azimuth2_radians, base_uvec = tvo, far_radians = stepAway_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = tv2) ! outputs !Find the internal coordinates of these two eccentric points. (If necessary, use less-distant eccentric points.) !(N.B. I HOPE that it is not important whether we use pre- or post-translation coordinates; I chose the latter, as easier.) !First eccentric point: l_ = trace_is(i)%element ! start search in element containing this trace point CALL Internal(tv1, l_, s1, s2, s3) IF (l_ == 0) THEN ! eccentric point #1 fell outside the grid; fix this! smaller_stepAway_radians = stepAway_radians fixing_point1: DO k = 1, 21 ! (0.8)**21 < 0.01 smaller_stepAway_radians = 0.8D0 * smaller_stepAway_radians tvo(1:3) = trace_premove(1:3, i) CALL DTurn_To (azimuth_radians = azimuth1_radians, base_uvec = tvo, far_radians = smaller_stepAway_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = tv1) ! outputs l_ = trace_is(i)%element ! start search in element containing this trace point CALL Internal(tv1, l_, s1, s2, s3) IF (l_ > 0) EXIT fixing_point1 IF (k == 21) THEN azimuth_degrees = azimuth1_radians * degrees_per_radian IF (azimuth_degrees < 0.0D0) azimuth_degrees = azimuth_degrees + 360.0D0 IF (azimuth_degrees >= 360.0D0) azimuth_degrees = azimuth_degrees - 360.0D0 WRITE (*, "(' ERROR: Translation mode 2 (symmetric_spreading_system)')") WRITE (*, "(' failed for point ',I6,' of fault F',I4,' because eccentric point #1')") 1+i-a, f WRITE (*, "(' projected along azimuth ',F8.2,' degrees')") azimuth_degrees WRITE (*, "(' always falls outside of grid, even with reduced offset.')") WRITE (21, "('ERROR: Translation mode 2 (symmetric_spreading_system)')") WRITE (21, "('failed for point ',I6,' of fault F',I4,' because eccentric point #1')") 1+i-a, f WRITE (21, "('projected along azimuth ',F8.2,' degrees')") azimuth_degrees WRITE (21, "('always falls outside of grid, even with reduced offset.')") CALL Pause() STOP END IF END DO fixing_point1 END IF this_is1%element = l_ this_is1%s(1) = s1 this_is1%s(2) = s2 this_is1%s(3) = s3 !second eccentric point: l_ = trace_is(i)%element ! start search in element containing this trace point CALL Internal(tv2, l_, s1, s2, s3) IF (l_ == 0) THEN ! eccentric point #2 fell outside the grid; fix this! smaller_stepAway_radians = stepAway_radians fixing_point2: DO k = 1, 21 ! (0.8)**21 < 0.01 smaller_stepAway_radians = 0.8D0 * smaller_stepAway_radians tvo(1:3) = trace_premove(1:3, i) CALL DTurn_To (azimuth_radians = azimuth2_radians, base_uvec = tvo, far_radians = smaller_stepAway_radians, & ! inputs & omega_uvec = omega_uvec, result_uvec = tv2) ! outputs l_ = trace_is(i)%element ! start search in element containing this trace point CALL Internal(tv2, l_, s1, s2, s3) IF (l_ > 0) EXIT fixing_point2 IF (k == 21) THEN azimuth_degrees = azimuth2_radians * degrees_per_radian IF (azimuth_degrees < 0.0D0) azimuth_degrees = azimuth_degrees + 360.0D0 IF (azimuth_degrees >= 360.0D0) azimuth_degrees = azimuth_degrees - 360.0D0 WRITE (*, "(' ERROR: Translation mode 2 (symmetric_spreading_system)')") WRITE (*, "(' failed for point ',I6,' of fault F',I4,' because eccentric point #2')") 1+i-a, f WRITE (*, "(' projected along azimuth ',F8.2,' degrees')") azimuth_degrees WRITE (*, "(' always falls outside of grid, even with reduced offset.')") WRITE (21, "('ERROR: Translation mode 2 (symmetric_spreading_system)')") WRITE (21, "('failed for point ',I6,' of fault F',I4,' because eccentric point #2')") 1+i-a, f WRITE (21, "('projected along azimuth ',F8.2,' degrees')") azimuth_degrees WRITE (21, "('always falls outside of grid, even with reduced offset.')") CALL Pause() STOP END IF END DO fixing_point2 END IF this_is2%element = l_ this_is2%s(1) = s1 this_is2%s(2) = s2 this_is2%s(3) = s3 !Find the velocities of the "rigid plates" (we hope) at these two eccentric points, from argument array wv: !Velocity components at eccentric point #1 l_ = this_is1%element CALL Gjxy(l_, tv1, G) ! returning G, which is a local REAL*8(3,2,2) array specific to this element and uvec. CALL Components(l_, G, vw, v_1, w_1) ! where v_, w_ are output (scalar REAL*8 components) !Velocity components at eccentric point #2 l_ = this_is2%element CALL Gjxy(l_, tv2, G) ! returning G, which is a local REAL*8(3,2,2) array specific to this element and uvec. CALL Components(l_, G, vw, v_2, w_2) ! where v_, w_ are output (scalar REAL*8 components) !Average these two eccentric velocities: v_ = (v_1 + v_2) / 2.0D0 w_ = (w_1 + w_2) / 2.0D0 !Apply these horizontal velocity components to move this trace point: tv1 = trace_premove(1:3, i) CALL Moved_by_vw (old_vec = tv1, v_ = v_, w_ = w_, forward = .FALSE., new_vec = tv2) trace(1:3, i) = tv2(1:3) ! storing the result !recompute internal coordinates after move: l_ = trace_is(i)%element ! starting element for search CALL Internal(tv2, l_, s1, s2, s3) trace_is(i)%element = l_ trace_is(i)%s(1) = s1 trace_is(i)%s(2) = s2 trace_is(i)%s(3) = s3 END IF ! This trace point is inside the FEG model domain; thus, eligable for translation. END IF ! translation_method(I) == (0, 1, 3), or ELSE 2 END DO ! i = a, b (digitized points along one trace) DEALLOCATE (shearing) !Correct trace if it still loops across !the same element boundary twice! CALL Unloop_Trace(f, .FALSE.) END IF ! f_2_in(f) END DO ! f = 1, f_highest (F0001, F0002, ...) !End of basic translation (by one of methods #0, #1, #2, or #3) for all faults. !Look for joints between neighboring faults with the "throughgoing_master_fault" !attribute at their relevant ends, and eliminate any gap/overlap OR ANGLE !between these neighboring traces, at their joint, by resetting the joint !position to be the average of the two surrounding trace points. tolerance_in_degrees = 0.03D0 ! Don't average-together any throughgoing_master_fault ends that are further apart than this! ! CAUTION: If this tolerance is too large, there is a DANGER of linking very short fault traces ! at the wrong ends, or linking them to a neighbor which is not their nearest! ! Back when I was using a higher tolerance of 0.05D0 degrees, ! this happened to the "F4073R Elsinore (Stepovers Combined)" trace, ! which started at 11 km long, but shrunk to <5.5 km long during the restoration to 6 Ma. ! On the other hand, a tolerance_in_degrees of 0.01D0 seems too small; when I tried that, ! one of the throughgoing_master_fault joints in the San Gregorio-Hosgri chain came apart, at Big Sur. tolerance_in_radian2 = (tolerance_in_degrees * radians_per_degree)**2 DO i1 = 1, (f_highest - 1) ! F00i1 index of lower-numbered trace !Consider the start of F00i1: IF (f_2_in(i1).AND.(trace_is(trace_loc(1, i1))%element > 0)) THEN ! start is inside the grid; may have a neighbor? IF (translation_method(trace_loc(1, i1)) == 0) THEN ! F00i1 is a throughgoing_master_fault at its start uvec_i1_end(1:3) = trace(1:3, trace_loc(1, i1)) uvec_i1_inside(1:3) = trace(1:3, (trace_loc(1, i1) + 1)) DO i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class, !- - - - - - - - - - - - - - - - - - - - - !whose START might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(1, i2))%element > 0)) THEN ! start is inside the grid; may have a neighbor? IF (translation_method(trace_loc(1, i2)) == 0) THEN ! F00i2 is a throughgoing_master_fault at its start uvec_i2_end(1:3) = trace(1:3, trace_loc(1, i2)) uvec_i2_inside(1:3) = trace(1:3, (trace_loc(1, i2) + 1)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing t_m_f joint between start of F', I4, ' and start of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_inside(1:3) + uvec_i2_inside(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(1, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(1, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(1, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(1, i1))%element = l_ trace_is(trace_loc(1, i1))%s(1) = s1 trace_is(trace_loc(1, i1))%s(2) = s2 trace_is(trace_loc(1, i1))%s(3) = s3 trace_is(trace_loc(1, i2))%element = l_ ! (ditto) trace_is(trace_loc(1, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(1, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(1, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 start and i2 start. END IF ! F00i2 is a throughgoing_master_fault at its start END IF ! start of F00i2 is inside the grid; may have a neighbor? !- - - - - - - - - - - - - - - - - - - - - !OR, whose END might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(2, i2))%element > 0)) THEN ! end of F00i2 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(2, i2)) == 0) THEN ! F00i2 is a throughgoing_master_fault at its end uvec_i2_end(1:3) = trace(1:3, trace_loc(2, i2)) uvec_i2_inside(1:3) = trace(1:3, (trace_loc(2, i2) - 1)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing t_m_f joint between start of F', I4, ' and end of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_inside(1:3) + uvec_i2_inside(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(1, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(2, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(1, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(1, i1))%element = l_ trace_is(trace_loc(1, i1))%s(1) = s1 trace_is(trace_loc(1, i1))%s(2) = s2 trace_is(trace_loc(1, i1))%s(3) = s3 trace_is(trace_loc(2, i2))%element = l_ ! (ditto) trace_is(trace_loc(2, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(2, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(2, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 start and i2 end. END IF ! F00i2 is a throughgoing_master_fault at its end END IF ! end of F00i2 is inside the grid; may have a neighbor? END DO ! i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class END IF ! F00i1 is a throughgoing_master_fault at its start END IF ! start is inside the grid; may have a neighbor? !----------------------------------------------------------------------------------------------- !Consider the END of F00i1: IF (f_2_in(i1).AND.(trace_is(trace_loc(2, i1))%element > 0)) THEN ! end of F00i1 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(2, i1)) == 0) THEN ! F00i1 is a throughgoing_master_fault at its end uvec_i1_end(1:3) = trace(1:3, trace_loc(2, i1)) uvec_i1_inside(1:3) = trace(1:3, (trace_loc(2, i1) - 1)) DO i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class, !- - - - - - - - - - - - - - - - - - - - - !whose START might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(1, i2))%element > 0)) THEN ! start of F00i2 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(1, i2)) == 0) THEN ! F00i2 is a throughgoing_master_fault at its start uvec_i2_end(1:3) = trace(1:3, trace_loc(1, i2)) uvec_i2_inside(1:3) = trace(1:3, (trace_loc(1, i2) + 1)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing t_m_f joint between end of F', I4, ' and start of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_inside(1:3) + uvec_i2_inside(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(2, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(1, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(2, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(2, i1))%element = l_ trace_is(trace_loc(2, i1))%s(1) = s1 trace_is(trace_loc(2, i1))%s(2) = s2 trace_is(trace_loc(2, i1))%s(3) = s3 trace_is(trace_loc(1, i2))%element = l_ ! (ditto) trace_is(trace_loc(1, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(1, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(1, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 end and i2 start. END IF ! F00i2 is a throughgoing_master_fault at its start END IF ! start of F00i2 is inside the grid; may have a neighbor? !- - - - - - - - - - - - - - - - - - - - - !OR, whose END might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(2, i2))%element > 0)) THEN ! end of F00i2 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(2, i2)) == 0) THEN ! F00i2 is a throughgoing_master_fault at its end uvec_i2_end(1:3) = trace(1:3, trace_loc(2, i2)) uvec_i2_inside(1:3) = trace(1:3, (trace_loc(2, i2) - 1)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing t_m_f joint between end of F', I4, ' and end of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_inside(1:3) + uvec_i2_inside(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(2, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(2, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(2, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(2, i1))%element = l_ trace_is(trace_loc(2, i1))%s(1) = s1 trace_is(trace_loc(2, i1))%s(2) = s2 trace_is(trace_loc(2, i1))%s(3) = s3 trace_is(trace_loc(2, i2))%element = l_ ! (ditto) trace_is(trace_loc(2, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(2, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(2, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 end and i2 end. END IF ! F00i2 is a throughgoing_master_fault at its end END IF ! end of F00i2 is inside the grid; may have a neighbor? END DO ! i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class END IF ! F00i1 is a throughgoing_master_fault at its end END IF ! end of F00i1 is inside the grid; may have a neighbor? !----------------------------------------------------------------------------------------------- END DO ! i1 = 1, (f_highest - 1); F00i1 index of lower-numbered trace !End of mating between adjacent fault-ends which share the "throughgoing_master_fault" attribute. !Look for joints between neighboring faults which share the "symmetric_spreading_system" !attribute at their nearest ends, and eliminate any gap/overlap !between these neighboring traces, at their joint, by resetting the joint !position to be the average of the two uncorrected end-points. tolerance_in_degrees = 0.05000 ! Don't average-together any symmetric_spreading_system ends that are further apart than this! tolerance_in_radian2 = (tolerance_in_degrees * radians_per_degree)**2 DO i1 = 1, (f_highest - 1) ! F00i1 index of lower-numbered trace !Consider the start of F00i1: IF (f_2_in(i1).AND.(trace_is(trace_loc(1, i1))%element > 0)) THEN ! start is inside the grid; may have a neighbor? IF (translation_method(trace_loc(1, i1)) == 2) THEN ! F00i1 is a symmetric_spreading_system at its start uvec_i1_end(1:3) = trace(1:3, trace_loc(1, i1)) DO i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class, !- - - - - - - - - - - - - - - - - - - - - !whose START might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(1, i2))%element > 0)) THEN ! start is inside the grid; may have a neighbor? IF (translation_method(trace_loc(1, i2)) == 2) THEN ! F00i2 is a symmetric_spreading_system at its start uvec_i2_end(1:3) = trace(1:3, trace_loc(1, i2)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing s_s_s joint between start of F', I4, ' and start of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_end(1:3) + uvec_i2_end(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(1, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(1, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(1, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(1, i1))%element = l_ trace_is(trace_loc(1, i1))%s(1) = s1 trace_is(trace_loc(1, i1))%s(2) = s2 trace_is(trace_loc(1, i1))%s(3) = s3 trace_is(trace_loc(1, i2))%element = l_ ! (ditto) trace_is(trace_loc(1, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(1, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(1, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 start and i2 start. END IF ! F00i2 is a symmetric_spreading_system at its start END IF ! start of F00i2 is inside the grid; may have a neighbor? !- - - - - - - - - - - - - - - - - - - - - !OR, whose END might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(2, i2))%element > 0)) THEN ! end of F00i2 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(2, i2)) == 2) THEN ! F00i2 is a symmetric_spreading_system at its end uvec_i2_end(1:3) = trace(1:3, trace_loc(2, i2)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing joint between start of F', I4, ' and end of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_end(1:3) + uvec_i2_end(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(1, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(2, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(1, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(1, i1))%element = l_ trace_is(trace_loc(1, i1))%s(1) = s1 trace_is(trace_loc(1, i1))%s(2) = s2 trace_is(trace_loc(1, i1))%s(3) = s3 trace_is(trace_loc(2, i2))%element = l_ ! (ditto) trace_is(trace_loc(2, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(2, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(2, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 start and i2 end. END IF ! F00i2 is a symmetric_spreading_system at its end END IF ! end of F00i2 is inside the grid; may have a neighbor? END DO ! i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class END IF ! F00i1 is a symmetric_spreading_system at its start END IF ! start is inside the grid; may have a neighbor? !----------------------------------------------------------------------------------------------- !Consider the END of F00i1: IF (f_2_in(i1).AND.(trace_is(trace_loc(2, i1))%element > 0)) THEN ! end of F00i1 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(2, i1)) == 2) THEN ! F00i1 is a symmetric_spreading_system at its end uvec_i1_end(1:3) = trace(1:3, trace_loc(2, i1)) DO i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class, !- - - - - - - - - - - - - - - - - - - - - !whose START might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(1, i2))%element > 0)) THEN ! start of F00i2 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(1, i2)) == 2) THEN ! F00i2 is a symmetric_spreading_system at its start uvec_i2_end(1:3) = trace(1:3, trace_loc(1, i2)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing joint between end of F', I4, ' and start of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_end(1:3) + uvec_i2_end(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(2, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(1, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(2, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(2, i1))%element = l_ trace_is(trace_loc(2, i1))%s(1) = s1 trace_is(trace_loc(2, i1))%s(2) = s2 trace_is(trace_loc(2, i1))%s(3) = s3 trace_is(trace_loc(1, i2))%element = l_ ! (ditto) trace_is(trace_loc(1, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(1, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(1, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 end and i2 start. END IF ! F00i2 is a symmetric_spreading_system at its start END IF ! start of F00i2 is inside the grid; may have a neighbor? !- - - - - - - - - - - - - - - - - - - - - !OR, whose END might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(2, i2))%element > 0)) THEN ! end of F00i2 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(2, i2)) == 2) THEN ! F00i2 is a symmetric_spreading_system at its end uvec_i2_end(1:3) = trace(1:3, trace_loc(2, i2)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing joint between end of F', I4, ' and end of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_end(1:3) + uvec_i2_end(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(2, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(2, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(2, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(2, i1))%element = l_ trace_is(trace_loc(2, i1))%s(1) = s1 trace_is(trace_loc(2, i1))%s(2) = s2 trace_is(trace_loc(2, i1))%s(3) = s3 trace_is(trace_loc(2, i2))%element = l_ ! (ditto) trace_is(trace_loc(2, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(2, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(2, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 end and i2 end. END IF ! F00i2 is a symmetric_spreading_system at its end END IF ! end of F00i2 is inside the grid; may have a neighbor? END DO ! i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class END IF ! F00i1 is a symmetric_spreading_system at its end END IF ! end of F00i1 is inside the grid; may have a neighbor? !----------------------------------------------------------------------------------------------- END DO ! i1 = 1, (f_highest - 1); F00i1 index of lower-numbered trace !End of mating between adjacent fault-ends which share the "symmetric_spreading_system" attribute. !Look for joints between neighboring faults which share the "other_spreading_system" !attribute at their nearest ends, and eliminate any gap/overlap !between these neighboring traces, at their joint, by resetting the joint !position to be the average of the two uncorrected end-points. tolerance_in_degrees = 0.05000 ! Don't average-together any other_spreading_system ends that are further apart than this! tolerance_in_radian2 = (tolerance_in_degrees * radians_per_degree)**2 DO i1 = 1, (f_highest - 1) ! F00i1 index of lower-numbered trace !Consider the start of F00i1: IF (f_2_in(i1).AND.(trace_is(trace_loc(1, i1))%element > 0)) THEN ! start is inside the grid; may have a neighbor? IF (translation_method(trace_loc(1, i1)) == 3) THEN ! F00i1 is an other_spreading_system at its start uvec_i1_end(1:3) = trace(1:3, trace_loc(1, i1)) DO i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class, !- - - - - - - - - - - - - - - - - - - - - !whose START might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(1, i2))%element > 0)) THEN ! start is inside the grid; may have a neighbor? IF (translation_method(trace_loc(1, i2)) == 3) THEN ! F00i2 is an other_spreading_system at its start uvec_i2_end(1:3) = trace(1:3, trace_loc(1, i2)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing o_s_s joint between start of F', I4, ' and start of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_end(1:3) + uvec_i2_end(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(1, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(1, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(1, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(1, i1))%element = l_ trace_is(trace_loc(1, i1))%s(1) = s1 trace_is(trace_loc(1, i1))%s(2) = s2 trace_is(trace_loc(1, i1))%s(3) = s3 trace_is(trace_loc(1, i2))%element = l_ ! (ditto) trace_is(trace_loc(1, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(1, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(1, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 start and i2 start. END IF ! F00i2 is an other_spreading_system at its start END IF ! start of F00i2 is inside the grid; may have a neighbor? !- - - - - - - - - - - - - - - - - - - - - !OR, whose END might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(2, i2))%element > 0)) THEN ! end of F00i2 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(2, i2)) == 3) THEN ! F00i2 is an other_spreading_system at its end uvec_i2_end(1:3) = trace(1:3, trace_loc(2, i2)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing joint between start of F', I4, ' and end of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_end(1:3) + uvec_i2_end(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(1, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(2, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(1, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(1, i1))%element = l_ trace_is(trace_loc(1, i1))%s(1) = s1 trace_is(trace_loc(1, i1))%s(2) = s2 trace_is(trace_loc(1, i1))%s(3) = s3 trace_is(trace_loc(2, i2))%element = l_ ! (ditto) trace_is(trace_loc(2, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(2, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(2, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 start and i2 end. END IF ! F00i2 is an other_spreading_system at its end END IF ! end of F00i2 is inside the grid; may have a neighbor? END DO ! i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class END IF ! F00i1 is an other_spreading_system at its start END IF ! start is inside the grid; may have a neighbor? !----------------------------------------------------------------------------------------------- !Consider the END of F00i1: IF (f_2_in(i1).AND.(trace_is(trace_loc(2, i1))%element > 0)) THEN ! end of F00i1 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(2, i1)) == 3) THEN ! F00i1 is an other_spreading_system at its end uvec_i1_end(1:3) = trace(1:3, trace_loc(2, i1)) DO i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class, !- - - - - - - - - - - - - - - - - - - - - !whose START might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(1, i2))%element > 0)) THEN ! start of F00i2 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(1, i2)) == 3) THEN ! F00i2 is an other_spreading_system at its start uvec_i2_end(1:3) = trace(1:3, trace_loc(1, i2)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing joint between end of F', I4, ' and start of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_end(1:3) + uvec_i2_end(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(2, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(1, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(2, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(2, i1))%element = l_ trace_is(trace_loc(2, i1))%s(1) = s1 trace_is(trace_loc(2, i1))%s(2) = s2 trace_is(trace_loc(2, i1))%s(3) = s3 trace_is(trace_loc(1, i2))%element = l_ ! (ditto) trace_is(trace_loc(1, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(1, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(1, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 end and i2 start. END IF ! F00i2 is an other_spreading_system at its start END IF ! start of F00i2 is inside the grid; may have a neighbor? !- - - - - - - - - - - - - - - - - - - - - !OR, whose END might share this same joint: IF (f_2_in(i2).AND.(trace_is(trace_loc(2, i2))%element > 0)) THEN ! end of F00i2 is inside the grid; may have a neighbor? IF (translation_method(trace_loc(2, i2)) == 3) THEN ! F00i2 is an other_spreading_system at its end uvec_i2_end(1:3) = trace(1:3, trace_loc(2, i2)) r2_in_radian2 = (uvec_i1_end(1) - uvec_i2_end(1))**2 + (uvec_i1_end(2) - uvec_i2_end(2))**2 + (uvec_i1_end(3) - uvec_i2_end(3))**2 IF (r2_in_radian2 <= tolerance_in_radian2) THEN ! GOT A PROXIMITY MATCH !WRITE (21, "('Smoothing joint between end of F', I4, ' and end of F', I4)") i1, i2 tvec(1:3) = 0.5D0 * (uvec_i1_end(1:3) + uvec_i2_end(1:3)) CALL Make_Uvec(tvec, uvec_mean) uvec_i1_end(1:3) = uvec_mean(1:3) uvec_i2_end(1:3) = uvec_mean(1:3) ! (the same) trace(1:3, trace_loc(2, i1)) = uvec_i1_end(1:3) trace(1:3, trace_loc(2, i2)) = uvec_i2_end(1:3) ! (the same) !recompute internal coordinates (only once): l_ = trace_is(trace_loc(2, i1))%element ! out-of-date, but close... CALL Internal(uvec_i1_end, l_, s1, s2, s3) trace_is(trace_loc(2, i1))%element = l_ trace_is(trace_loc(2, i1))%s(1) = s1 trace_is(trace_loc(2, i1))%s(2) = s2 trace_is(trace_loc(2, i1))%s(3) = s3 trace_is(trace_loc(2, i2))%element = l_ ! (ditto) trace_is(trace_loc(2, i2))%s(1) = s1 ! (ditto) trace_is(trace_loc(2, i2))%s(2) = s2 ! (ditto) trace_is(trace_loc(2, i2))%s(3) = s3 ! (ditto) END IF ! Got a proximity match between i1 end and i2 end. END IF ! F00i2 is an other_spreading_system at its end END IF ! end of F00i2 is inside the grid; may have a neighbor? END DO ! i2 = (i1 + 1), f_highest ! look for a (higher-numbered) neighbor in same class END IF ! F00i1 is an other_spreading_system at its end END IF ! end of F00i1 is inside the grid; may have a neighbor? !----------------------------------------------------------------------------------------------- END DO ! i1 = 1, (f_highest - 1); F00i1 index of lower-numbered trace !End of mating between adjacent fault-trace-ends which share the "other_spreading_system" attribute. !Smooth traces of any active strike-slip faults with >2 contiguous points in the model, !taking care not to move either of the end-points (in this particular operation). !N.B. Transform-fault traces marked "symmetric_spreading_boundary" are USUALLY ! limited to only 2 points/trace ("first" & "last"), ! so TYPICALLY they will not be affected by this operation. ! {BUT ALSO NOTE that the preceding highly-qualified statement allows of exceptions!} DO i = 1, f_highest ! consider all fault-trace number, F0001 to F9999 IF (trace_active(n_, i)) THEN ! this fault trace is slipping in this timestep !Look for a strike-slip ('R' or 'L') datum# that is active in this timestep: which_datum = 0 ! (Initialization. If not changed to positive integer, this will indicate failure to find strike-slip.) finding_RL_in_f_rst: DO trial_datum = 1, f_rst_count IF (which_trace(trial_datum) == i) THEN ! found the right fault trace (#i, or F000i) IF ((sense(trial_datum) == 'R').OR.(sense(trial_datum) == 'L')) THEN ! found the right kind of component (strike-slip) IF (f_active(n_ , trial_datum)) THEN ! found the strike-slip offset datum on this fault that applies to this timestep which_datum = trial_datum ! remember this success! EXIT finding_RL_in_f_rst ! stop searching, and go, with the correct value of INTEGER :: which_datum END IF END IF END IF END DO finding_RL_in_f_rst IF (which_datum > 0) THEN ! strike-slip is active, for this trace, in this time-step! IF (f_2_in(i)) THEN ! trace has >= 2 points in grid j1 = trace_loc(1,i) j2 = trace_loc(2,i) n1 = 0 ! shows it is undefined DO j = j1, j2 IF (trace_is(j)%element > 0) THEN !Look for start of a contigous train within the grid: IF (n1 == 0) n1 = j !Look for end of a contigous train within the grid: IF (j < j2) THEN ! only check subscript (j+1) when KNOWN to be in-range: next_point_outside = (trace_is(j+1)%element == 0) ELSE ! j == j2, so accessing subscript (j+1) MIGHT trigger an abend next_point_outside = .TRUE. ! (although = .FALSE. would give same results) END IF IF ((j == j2).OR.next_point_outside) THEN n2 = j ! found the end-point for smoothing IF ((n2 - n1) > 1) THEN ! got at least 3 points in the part of the trace that is inside the FEG grid !----------------------------------------------- !Straighten segment from n1 to n2 ! length_radians = 0.0D0 ! compute length of train, in radians DO n = n1, (n2 - 1) length_radians = length_radians + & & SQRT((trace(1, n) - trace(1, n+1))**2 + & & (trace(2, n) - trace(2, n+1))**2 + & & (trace(3, n) - trace(3, n+1))**2) END DO ! n = n1, n2-1, finding length of train mean_step_meters = R * length_radians / (n2 - n1) velocity_factor = ABS(f_goal(n_ , which_datum)) / (3.171D-10) ! <= Note (arbitrary) reference velocity of 10 mm/a = 3.171D-10 m/s. !=========================================================================== smoothing = (Deltat_ / (2.0D0 * s_per_Ma)) * velocity_factor * (10.0D3 / mean_step_meters)**2 !Practical (from trial-and-error!) smoothing formula, ! which may need to be adjusted if smoothing is either excessively-fast, or deficient. !The result "smoothing" is dimensionless, and the next line below will limit it to range of [0.0, 1.0]. !Its value is the product of 3 dimensionless factors: ! *Timestep, relative to (arbitrary) standard of 2 m.y.; and ! *Strike-slip rate, relative to (arbitrary) standard of 10 mm/a; and ! *Mean digitization step, relative to (arbitrary) standard of 10 km, TO THE POWER -2. !Thus, when timestep is 0.2 m.y., and strike-slip rate is 10 mm/a, and ! mean digitization step is 10 km, this product computes to 0.1, or 10% ! of the maximum-possible smoothing rate (that won't cause numerical instability). !Or, if mean digitization step is 3.1 km, this product becomes 1 (or 100%), ! and the smoothing of a fault that offsets 2 km in one timestep and has ! mean digitization step of 3.1 km will be maximum, producing smoothness ! at the 3.1-km-length-scale in just one application. !If mean digitization step is less than 3 km, or if fault-offset-per-timestep ! is greater than 2 km (continuing this arbitrary example), then "smoothing" ! will be limited to 1.0 (or 100%) in the next line, giving less-effective smoothing. !Thus, very small digitization steps along strike-slip fault traces are not generally desirable! !=========================================================================== smoothing = MIN(1.0D0, MAX(smoothing, 0.0D0)) !Note: The line above is necessary for numerical stability; !however, it may cause smoothing to be less than the above formula implies, !if strike-slip faults are digitized with point spacings of less than 3 km (at offset/timestep of 2 km), !and/or where fault offsets in one timestep exceed ~20 km (at digitization step of 10 km). !The take-away messages are: ! (1) If faults slip much faster than 10 mm/a, then limit time-steps to something like 0.2 m.y. {OBVIOUS}; and ! (2) Try to digitize each "master_throughgoing_fault" with digitization step of roughly 10 km {NOT OBVIOUS}. IF (smoothing > 0.0D0) THEN holding = 1.0D0 - smoothing ! must not be negative !First, average "even" points: DO n = (n1 + 1), (n2 - 1), 2 tv1(1:3) = trace(1:3, n) tv2(1:3) = 0.5D0 * (trace(1:3, n-1) + trace(1:3, n+1)) tvo(1:3) = smoothing * tv2(1:3) + holding * tv1(1:3) CALL Make_Uvec(tvo, tv1) trace(1:3, n) = tv1(1:3) !recompute internal coordinates: l_ = trace_is(n)%element CALL Internal(tv1, l_, s1, s2, s3) trace_is(n)%element = l_ trace_is(n)%s(1) = s1 trace_is(n)%s(2) = s2 trace_is(n)%s(3) = s3 END DO ! n is "even" IF ((n2 - n1) > 2) THEN ! got "odd" points as well !Second, average "odd" points: DO n = (n1 + 2), (n2 - 1), 2 tv1(1:3) = trace(1:3, n) tv2(1:3) = 0.5D0 * (trace(1:3, n-1) + trace(1:3, n+1)) tvo(1:3) = smoothing * tv2(1:3) + holding * tv1(1:3) CALL Make_Uvec(tvo, tv1) trace(1:3, n) = tv1(1:3) !recompute internal coordinates: l_ = trace_is(n)%element CALL Internal(tv1, l_, s1, s2, s3) trace_is(n)%element = l_ trace_is(n)%s(1) = s1 trace_is(n)%s(2) = s2 trace_is(n)%s(3) = s3 END DO ! n is "odd" END IF ! got "odd" points END IF ! smoothing > 0.0D0 !----------------------------------------------- END IF ! got at least three points !Processing done; NOW, undefine n1 so another contiguous segment can be found(?) n1 = 0 ! undefined again END IF ! got an end point of a contiguous piece within grid END IF ! point j is in END DO ! j = j1, j2 !Check that f_2_in(i) is still T(?): n = 0 ! count points of trace inside the grid DO j = j1, j2 IF (trace_is(j)%element > 0) n = n + 1 END DO IF (n < 2) f_2_in(i) = .FALSE. ! "forever" !Correct trace if it still loops across !the same element boundary twice! CALL Unloop_Trace(i, .FALSE.) END IF ! f_2_in(i) END IF ! strike-slip trace END IF ! (trace_active(n_, i)); fault is slipping in this timestep END DO ! i = 1, f_highest !End of smoothing of interiors of traces of strike-slip faults. END IF ! (f_dig_count > 0) ... there are any faults to be moved. END SUBROUTINE Move_data SUBROUTINE Move_feg (vw) IMPLICIT NONE REAL*8, DIMENSION(nDOF), INTENT(IN) :: vw INTEGER :: i REAL*8, DIMENSION(3) :: tvi, tvo DO i = 1, num_nod tvi = xyz_nod(1:3, i) CALL Moved_by_vw (tvi, vw(2*i-1), vw(2*i), .FALSE., tvo) xyz_nod(1:3,i) = tvo END DO END SUBROUTINE Move_feg SUBROUTINE Moved_by_vel (old_vec, velocity, forward, new_vec) ! Computes new position (Cartesian unit vector) ! after a great-circle finite rotation with fixed angular ! velocity which begins at position old_vec ! with initial velocity vector 'velocity' (Cartesian, m/s) ! and continues for time interval Deltat_. ! IF (.NOT.forward), rotation is in opposite direction. IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: old_vec, velocity LOGICAL, INTENT(IN) :: forward REAL*8, DIMENSION(3), INTENT(OUT):: new_vec REAL*8, DIMENSION(3) :: temp, v_unit REAL*8 :: angle, cos_a, sin_a, vel_mag vel_mag = SQRT(velocity(1)**2 + velocity(2)**2 + velocity(3)**2) angle = vel_mag * Deltat_ / R ! Deltat_, R are global. IF (angle == 0.0D0) THEN new_vec = old_vec ELSE IF (.NOT. forward) angle = - angle CALL Unitise(velocity, v_unit) sin_a = SIN(angle) cos_a = COS(angle) temp = cos_a * old_vec + sin_a * v_unit CALL Unitise(temp, new_vec) ! just for insurance END IF END SUBROUTINE Moved_by_vel SUBROUTINE Moved_by_vw (old_vec, v_, w_, forward, new_vec) ! Computes new position (Cartesian unit vector) ! after a great-circle finite rotation with fixed angular ! velocity which begins at position old_vec ! with initial velocity components v_ (theta, South) and ! w_ (phi, East), and continues for time interval Deltat_. ! IF (.NOT.forward), rotation is in opposite direction. IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: old_vec REAL*8, INTENT(IN) :: v_, w_ LOGICAL, INTENT(IN) :: forward REAL*8, DIMENSION(3), INTENT(OUT) :: new_vec REAL*8, DIMENSION(3) :: Phi, Theta, veloc REAL*8 :: angle, vel_mag vel_mag = SQRT(v_**2 + w_**2) angle = vel_mag * Deltat_ / R ! Deltat_, R are global. IF (angle == 0.0D0) THEN new_vec = old_vec ELSE CALL Local_Theta (old_vec, Theta) CALL Local_Phi (old_vec, Phi) veloc = v_ * Theta + w_ * Phi CALL Moved_by_vel (old_vec, veloc, forward, new_vec) END IF END SUBROUTINE Moved_by_vw SUBROUTINE New_goal (count, total, tmin, tmax, checkPD, rate, & ! inputs & goal, active, n_adjusted) ! outputs ! Refer to equation (33) of Bird (1998) and adjacent paragraphs. IMPLICIT NONE INTEGER, INTENT(IN) :: count ! number of data in arrays REAL*8,DIMENSION(:), INTENT(IN) :: total ! offset, displacement, angle REAL*8,DIMENSION(:), INTENT(IN) :: tmin ! ending age REAL*8,DIMENSION(:), INTENT(IN) :: tmax ! starting age LOGICAL, INTENT(IN) :: checkPD ! check for P, D (fault offsets only) REAL*8,DIMENSION(:,:),INTENT(IN) :: rate ! results of previous iteration REAL*8,DIMENSION(:,:),INTENT(OUT) :: goal ! targets for next iteration LOGICAL(1),DIMENSION(:,:),INTENT(OUT):: active ! (may be reset by Set-goal-A) INTEGER, INTENT(OUT) :: n_adjusted ! number of data with rescaled (not reset) goals INTEGER :: i, j REAL*8 :: factor, sum, sum_goal LOGICAL :: adjust, promotion_case, demotion_case n_adjusted = 0 DO i = 1, count IF (checkPD) THEN IF (f_rst_code(i) == 'P') THEN ! N.B. Not accessing this array element AT ALL unless checkPD = .TRUE. promotion_case = .TRUE. ELSE promotion_case = .FALSE. END IF ELSE promotion_case = .FALSE. END IF !N.B. This non-transparent coding is to avoid a subscript-out-of-range Debugging abend when ! processing non-fault data (e.g., paleomag). Unfortunately, Microsoft Fortran is not ! smart enough to skip checking for the second condition if the first is .FALSE.! IF (promotion_case) THEN ! reassign the same Promoted goal as in first iteration CALL Set_goal_A (i, total, tmin, tmax, checkPD, goal, active) ELSE ! usual case ... sum_goal = total(i) / Deltat_ IF (sum_goal > 0.0D0) THEN ! we hope most rates are + sum = 0.0D0 adjust = .FALSE. DO j = 1, num_timesteps sum = sum + MAX(0.0D0, rate(j, i)) !count only positive rates adjust = adjust .OR. (rate(j,i) > goal(j,i)) END DO IF (sum > 0.0D0) THEN IF (adjust) THEN n_adjusted = n_adjusted + 1 factor = sum_goal / sum IF ((tmax(i) <= end_time) .OR. (factor < 1.)) THEN ! normal case; scale goals from rates DO j = 1, num_timesteps goal(j,i) = MAX(0.0D0, factor * rate(j,i)) END DO ELSE ! hang-over datum AND factor > 1; don't scale; let drift. DO j = 1, num_timesteps goal(j,i) = MAX(0.0D0, rate(j,i)) END DO END IF END IF ! adjust ELSE ! wrong way; must reassign goals from scratch CALL Set_goal_A (i, total, tmin, tmax, checkPD, goal, active) END IF ELSE IF (sum_goal == 0.0D0) THEN DO j = 1, num_timesteps goal(j,i) = 0.0D0 END DO ELSE ! goal is -; we hope most rates are - sum = 0.0D0 adjust = .FALSE. DO j = 1, num_timesteps sum = sum + MIN(0.0D0, rate(j, i)) !count only negative rates adjust = adjust .OR. (rate(j,i) < goal(j,i)) END DO IF (sum < 0.0D0) THEN IF (adjust) THEN n_adjusted = n_adjusted + 1 factor = sum_goal / sum ! factor is still + = - / - IF ((tmax(i) <= end_time) .OR. (factor < 1.0D0)) THEN ! normal case; scale goals from rates DO j = 1, num_timesteps goal(j,i) = MIN(0.0D0, factor * rate(j,i)) END DO ELSE ! hang-over datum AND factor > 1; don't scale; let drift. DO j = 1, num_timesteps goal(j,i) = MIN(0.0D0, rate(j,i)) END DO END IF END IF ! adjust ELSE ! wrong way; must reassign goals from scratch CALL Set_goal_A (i, total, tmin, tmax, checkPD, goal, active) END IF END IF ! checkPD and 'P' END IF ! goal is - IF (checkPD) THEN IF (f_rst_code(i) == 'D') THEN demotion_case = .TRUE. ELSE demotion_case = .FALSE. END IF ELSE demotion_case = .FALSE. END IF !N.B. See comments above. This rather convoluted coding prevents a possible ! Debugging abend (subscript-out-of-range) during CALLs with checkPD = .FALSE. ! (e.g., CALLs on paleomag data) where f_rst_code(index) would be out-of-range ! because there are more (e.g., paleomag) data than there are fault-offset data. IF (demotion_case) goal(1, i) = 0.0D0 END DO ! on i = datum number END SUBROUTINE New_goal SUBROUTINE Pause() IMPLICIT NONE WRITE (*,"(' Press [Enter]...'\)") READ (*,*) END SUBROUTINE Pause SUBROUTINE Plane_area (folding) IMPLICIT NONE LOGICAL, INTENT(OUT) :: folding !puts areas of plane triangles (below surface) into array a_; !if any is zero or negative, reports folding INTEGER :: i1, i2, i3, l_ REAL*8, DIMENSION(3) :: a, b, c, t folding = .FALSE. DO l_ = num_ele, 1, -1 ! global, like most variables ! Note that this loop runs "backwards" so that higher-numbered folded elements ! will appear first in the ERROR list. ! This is important because the user should fix these problems (in OrbWin) ! in the order high-numbered --> low-numbered elements. ! (Otherwise, editing will cause some of the #s of the bad elements to CHANGE!) i1 = node(1,l_) i2 = node(2,l_) i3 = node(3,l_) a = xyz_nod(1:3,i2) - xyz_nod(1:3,i1) b = xyz_nod(1:3,i3) - xyz_nod(1:3,i2) CALL Cross (a, b, c) t = xyz_nod(1:3,i1) + xyz_nod(1:3,i2) + xyz_nod(1:3,i3) a_(l_) = Magnitude(c) * half_R2 IF (Dot_3D(t, c) <= 0.0D0) THEN folding = .TRUE. WRITE (*, "(' ERROR: Element ',I8,' has flipped over and has negative area!')") l_ WRITE (21, "(' ERROR: Element ',I8,' has flipped over and has negative area!')") l_ END IF END DO END SUBROUTINE Plane_area SUBROUTINE Plug_in_33 (l_, A, B, C, D, E, F) ! Completes upper triangle of element (3-node x 3-node) matrix, then ! adds element matrix and element forcing vector to global system ! arrays ABCD and EF (which store values per conventions of LAPACK in MKL). IMPLICIT NONE INTEGER, INTENT(IN) :: l_ ! element number, to access nodes REAL*8, DIMENSION(3,3):: A, B, C, D ! submatrices of element matrix REAL*8, DIMENSION(3) :: E, F ! subvectors of element forcing vector INTEGER :: i, it, j, jt, m, n ! upper-triangle values filled in by symmetry A(1,2) = A(2,1); A(1,3) = A(3,1); A(2,3) = A(3,2) B = TRANSPOSE(C) D(1,2) = D(2,1); D(1,3) = D(3,1); D(2,3) = D(3,2) ! add element matrix to upper right part of global stiffness matrix: DO m = 1, 3 ! row within A i = 2 * node(m, l_) - 1 ! logical row in square coefficient matrix DO n = 1, 3 ! column of A j = 2 * node(n, l_) - 1 ! logical column in square coefficient matrix it = iDiagonal + i - j ABCD(it, j) = ABCD(it, j) + A(m, n) END DO END DO DO m = 1, 3 ! row within B i = 2 * node(m, l_) - 1 DO n = 1, 3 ! column of B j = 2 * node(n, l_) it = iDiagonal + i - j ABCD(it, j) = ABCD(it, j) + B(m, n) END DO END DO DO m = 1, 3 ! row within C i = 2 * node(m, l_) DO n = 1, 3 ! column of C j = 2 * node(n, l_) - 1 it = iDiagonal + i - j ABCD(it, j) = ABCD(it, j) + C(m, n) END DO END DO DO m = 1, 3 ! row within D i = 2 * node(m, l_) DO n = 1, 3 ! column of D j = 2 * node(n, l_) it = iDiagonal + i - j ABCD(it, j) = ABCD(it, j) + D(m, n) END DO END DO ! add element's forcing vectors to global system: DO m = 1, 3 i = 2 * node(m, l_) - 1 ! logical row EF(i, 1) = EF(i, 1) + E(m) i = i + 1 EF(i, 1) = EF(i, 1) + F(m) END DO END SUBROUTINE Plug_in_33 SUBROUTINE Plug_in_66 (l_1, l_2, A, B, C, D, E, F) ! Completes upper triangle of a super-element ! (6-node x 6-node) matrix created by a restored-cross-section datum, ! then adds this super-element matrix and super-element forcing vector to global system ! arrays ABCD and EF (which are stored according to conventions of LAPACK of MKL). IMPLICIT NONE INTEGER, INTENT(IN) :: l_1, l_2 ! element numbers, to access nodes REAL*8, DIMENSION(6,6):: A, B, C, D ! submatrices of super-element matrix REAL*8, DIMENSION(6) :: E, F ! subvectors of super-element forcing vector INTEGER :: i, it, j, jt, m, n ! upper-triangle values filled in by symmetry A(1,2)=A(2,1); A(1,3)=A(3,1); A(1,4)=A(4,1); A(1,5)=A(5,1); A(1,6)=A(6,1) A(2,3)=A(3,2); A(2,4)=A(4,2); A(2,5)=A(5,2); A(2,6)=A(6,2) A(3,4)=A(4,3); A(3,5)=A(5,3); A(3,6)=A(6,3) A(4,5)=A(5,4); A(4,6)=A(6,4) A(5,6)=A(6,5) B = TRANSPOSE(C) D(1,2)=D(2,1); D(1,3)=D(3,1); D(1,4)=D(4,1); D(1,5)=D(5,1); D(1,6)=D(6,1) D(2,3)=D(3,2); D(2,4)=D(4,2); D(2,5)=D(5,2); D(2,6)=D(6,2) D(3,4)=D(4,3); D(3,5)=D(5,3); D(3,6)=D(6,3) D(4,5)=D(5,4); D(4,6)=D(6,4) D(5,6)=D(6,5) ! add element matrix to upper right part of global stiffness matrix: DO m = 1, 6 ! row within A IF (m <= 3) THEN i = 2 * node(m, l_1) - 1 ! logical row in square coefficient matrix ELSE i = 2 * node(m-3, l_2) - 1 ! logical row in square coefficient matrix END IF DO n = 1, 6 ! column of A IF (n <= 3) THEN j = 2 * node(n, l_1) - 1 ! logical column in square coefficient matrix ELSE j = 2 * node(n-3, l_2) - 1 ! logical column in square coefficient matrix END IF it = iDiagonal + i - j ABCD(it, j) = ABCD(it, j) + A(m, n) END DO END DO DO m = 1, 6 ! row within B IF (m <= 3) THEN i = 2 * node(m, l_1) - 1 ELSE i = 2 * node(m-3, l_2) - 1 END IF DO n = 1, 6 ! column of B IF (n <= 3) THEN j = 2 * node(n, l_1) ELSE j = 2 * node(n-3, l_2) END IF it = iDiagonal + i - j ABCD(it, j) = ABCD(it, j) + B(m, n) END DO END DO DO m = 1, 6 ! row within C IF (m <= 3) THEN i = 2 * node(m, l_1) ELSE i = 2 * node(m-3, l_2) END IF DO n = 1, 6 ! column of C IF (n <= 3) THEN j = 2 * node(n, l_1) - 1 ELSE j = 2 * node(n-3, l_2) - 1 END IF it = iDiagonal + i - j ABCD(it, j) = ABCD(it, j) + C(m, n) END DO END DO DO m = 1, 6 ! row within D IF (m <= 3) THEN i = 2 * node(m, l_1) ELSE i = 2 * node(m-3, l_2) END IF DO n = 1, 6 ! column of D IF (n <= 3) THEN j = 2 * node(n, l_1) ELSE j = 2 * node(n-3, l_2) END IF it = iDiagonal + i - j ABCD(it, j) = ABCD(it, j) + D(m, n) END DO END DO ! add element's forcing vectors to global system: DO m = 1, 6 IF (m <= 3) THEN i = 2 * node(m, l_1) - 1 ! logical row ELSE i = 2 * node(m-3, l_2) - 1 ! logical row END IF EF(i, 1) = EF(i, 1) + E(m) i = i + 1 EF(i, 1) = EF(i, 1) + F(m) END DO END SUBROUTINE Plug_in_66 SUBROUTINE Prediction (vw, N0, N1, N2) ! Computes actual model predictions of rates (p_). ! Also computes 3 norms (L0, L1, L2) of rate errors (all data ! types and a-priori merged) in non-dimensional sigma units. IMPLICIT NONE REAL*8, DIMENSION(:), INTENT(IN) :: vw REAL*8, INTENT(OUT):: N0, N1, N2 DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: A, B, extra_A, extra_B DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: X !NOTE: Double precision was originally to prevent underflow/overflow ! during solution of linear system, not for great accuracy. ! But, now whole program package has been upgraded to REAL*8. REAL*8, DIMENSION(3) :: axis_c_to_f, axis_uvec REAL*8 :: correction_scalar REAL*8, DIMENSION(3) :: correction_vector REAL*8 :: cott REAL*8 :: csct INTEGER :: datum REAL*8, DIMENSION(3,2,2,2) :: dG INTEGER :: dot_byte ! used to create hr2_filename REAL*8 :: equat REAL*8, DIMENSION(3) :: eps_dot, eps_dot_c, eps_dot_f REAL*8 :: error REAL*8 :: error_count REAL*8 :: faulting_correction_factor REAL*8, DIMENSION(3) :: f_, g_ REAL*8, DIMENSION(3,2,2) :: G REAL*8 :: gamma_b, gamma_d INTEGER :: info, iv, iw, i1, i2, i3 INTEGER, DIMENSION(:), ALLOCATABLE :: ipiv ! workspace for solving linear system INTEGER :: l_, lda, ldb, loc, lwork REAL*8 :: Lz ! length of crack, in m REAL*8 :: misfits REAL*8 :: mu_of_r_ INTEGER :: N REAL*8 :: N0_sum, N1_sum, N2_sum REAL*8 :: new_eps_dot_f_scalar REAL*8 :: offset_rate_mmpa ! for output to file, for plotting CHARACTER(1) :: offset_sense_c1 ! '' '' '' '' REAL*8 :: old_eps_dot_c_scalar, old_eps_dot_f_scalar REAL*8, DIMENSION(3) :: outward INTEGER :: p REAL*8 :: p_ REAL*8, DIMENSION(3) :: Phi DOUBLE PRECISION :: prefix LOGICAL :: problem REAL*8, DIMENSION(3) :: r_ REAL*8 :: rho_ INTEGER :: segment CHARACTER(80) :: shr_filename ! for output of per-segment heave-rates, for plotting by RetroMap4+ CHARACTER(13) :: t_filename_suffix REAL*8 :: test REAL*8 :: theta_ REAL*8, DIMENSION(3) :: Theta REAL*8 :: tElon1, tElon2, tNlat1, tNlat2 ! for output to file, for plotting REAL*8, DIMENSION(3) :: tv, tv1, tv2 REAL*8 :: sint REAL*8 :: tant, t_sigma REAL*8 :: v_, w_ REAL*8, DIMENSION(:), ALLOCATABLE :: work ! workspace for solving the linear system REAL*8, DIMENSION(3) :: veloc INTEGER :: z_, Z N0_sum = 0.0D0 N1_sum = 0.0D0 N2_sum = 0.0D0 error_count = 0.0D0 ! Prepare output file for detailed heave-rate predictions (per fault segment): IF (f_rst_count > 0) THEN IF (paleotec) THEN t_filename_suffix = Mangle(last_iteration, total_iterations, time1) ELSE ! neotec t_filename_suffix = Mangle(last_iteration = 1, iteration = 1, time = 0.0D0) ! Expected to include "_NT" END IF ! paleotec, or neotec? shr_filename = Insert (f_rst, t_filename_suffix) dot_byte = INDEX(shr_filename, ".rst") shr_filename(dot_byte:(dot_byte+3)) = ".shr" WRITE (*, "(' Writing per-segment heave-rates to file ', A)") TRIM(shr_filename) WRITE (21, "(' Writing per-segment heave-rates to file ', A)") TRIM(shr_filename) OPEN (UNIT = 26, FILE = TRIM(shr_filename)) ! Unconditional OPEN; overwrites any existing file of same name! END IF ! Continuum strain-rate and active fault segments (cracks). ! Note that seg_end's were displaced by Move_data BEFORE ! smoothing strike-slip faults, and that these segments are used ! here for computing the "old" model prediction, consistent ! with the "old" velocity solution, and before the smoothing. IF (f_rst_count > 0) f_divide = 0.0D0 ! all numerators and denominators DO l_ = 1, num_ele i1 = node(1, l_) i2 = node(2, l_) i3 = node(3, l_) ! evaluate nodal function and derivitives at center of element tv = center(1:3, l_) CALL Gjxy(l_, tv, G) CALL Del_Gjxy_del_thetaphi(l_, tv, dG) equat = SQRT(tv(1)**2 + tv(2)**2) IF (equat == 0.0D0) THEN WRITE (*, "(' Error: center of element ', I6, ' is N or S pole.')") l_ WRITE (21,"( 'Error: center of element ', I6, ' is N or S pole.')") l_ STOP END IF theta_ = ATAN2(equat, tv(3)) sint = SIN(theta_) csct = 1.0D0 / sint tant = TAN(theta_) cott = 1.0D0 / tant CALL E_rate(l_, G, dG, theta_, vw, eps_dot) ! evaluate mu_ at center (constant during each time step) IF (time0 < mu_switch(l_)) THEN mu_of_r_ = mu_element(1, l_) ELSE mu_of_r_ = mu_element(2, l_) END IF IF (f_rst_count > 0) THEN Z = crack_index(1, l_) ELSE Z = 0 END IF IF (Z > 0) THEN ! element has active cracks ! Allocate and build linear system n = Z + 3 + 3 ALLOCATE ( A(n,n) ) ALLOCATE ( extra_A(n,n) ) ALLOCATE ( B(n,1) ) ALLOCATE ( extra_B(n,1) ) ALLOCATE ( X(n) ) lda = n ldb = n A = 0.0D0 ! whole matrix B = 0.0D0 ! whole vector DO z_ = 1, Z !first term: cracks representing faulting: loc = crack_index(2, l_) + z_ - 1 ! storage location in local_crack t_sigma = f_scale * ((local_crack(loc)%sigma_/f_scale)**exponent) segment = local_crack(loc)%segment tv1 = seg_end(1:3, 1, segment) tv2 = seg_end(1:3, 2, segment) Lz = R * DArc(tv1, tv2) ! length of segment in m; also known elsewhere as rho_ A(z_, z_) = 2.0D0 * Lz / (L_0 * t_sigma**2) B(z_, 1) = 2.0D0 * Lz * local_crack(loc)%s_ / (L_0 * t_sigma**2) !and, begin building 3rd term (more follows below): A(z_, Z + 4) = local_crack(loc)%H(1) A(z_, Z + 5) = local_crack(loc)%H(2) A(z_, Z + 6) = local_crack(loc)%H(3) END DO ! z_ = 1, Z !second term: continuum stiffness: t_sigma = mu_scale * ((mu_of_r_ / mu_scale)**exponent) prefix = 2.0D0 * a_(l_) / (A_0 * t_sigma**2) A(Z + 1, Z + 1) = prefix A(Z + 2, Z + 2) = prefix A(Z + 3, Z + 3) = prefix A(Z + 1, Z + 3) = 0.50D0 * prefix !finish the third term: Lagrange constraint on total strain-rate: A(Z + 1, Z + 4) = 1.0D0 A(Z + 2, Z + 5) = 1.0D0 A(Z + 3, Z + 6) = 1.0D0 B(Z + 4, 1) = eps_dot(1) B(Z + 5, 1) = eps_dot(2) B(Z + 6, 1) = eps_dot(3) ! Using the LAPACK portion of MKL (Math Kernel Library, by Intel), ! Compute the solution to the system of linear equations with a symmetric semi-definite coefficient matrix A ! and multiple right-hand sides B. [However, here we have only 1 RHS in B.] ! CALL dsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info ) ! The manual page is here: https://software.intel.com/en-us/node/468912#A2251802-5AE5-4022-9251-D82008A0A64B ! Arguments: ! CHARACTER*1 :: uplo ! = 'U' or 'L' depending on whether upper-triangle or lower-triangle of matrix should be used. ! INTEGER :: n ! The order of the coefficient matrix (number of rows used, which equals number of columns used). ! INTEGER :: nrhs ! = 1 (the number of right-hand-side forcing vectors) ! REAL*8, DIMENSION(lda, *) :: a ! the coefficient matrix; its 1st dimension must be at least n; its 2nd dimension must be at least n ! INTEGER, DIMENSION(n) :: ipiv ! necessary work vector for pivoting operation ! REAL*8, DIMENSION(ldb, *) :: b ! the right-hand-side forcing vector(s); its first dimension must be at least n; its second at least nrhs ! REAL*8, DIMENSION(lwork) :: work ! necessary workspace ! INTEGER :: lwork ! size of workspace; manual suggests using 64*n for best results. ! INTEGER, INTENT(OUT) :: info ! = 0 for success; ! = -i if parameter #i has an illegal value during the CALL; ! = i if the leading minor of order i in the coefficient matrix was NOT positive-definite. ! NOTE that the RHS vector(s) b are over-written by the solution vector(s); also, the coefficient matrix is modified. extra_A = A; extra_B = B ! save copies for debugging purposes ALLOCATE ( ipiv(n) ) lwork = 64 * n ALLOCATE ( work(lwork) ) CALL dsysv ( 'U', n, 1, A, lda, ipiv, B, ldb, work, lwork, info ) IF (info == 0) THEN ! successful termination X(1:n) = B(1:n, 1) ! extract solution vector from two-subscript RHS vector(s). ELSE WRITE (*, "(' ERROR: In SUBROUTINE Prediction, CALL dsysv results in info = ',I5)") info WRITE (21, "('ERROR: In SUBROUTINE Prediction, CALL dsysv results in info = ',I5)") info WRITE (*, "(' Further specifics: element l_ = ',I6,', and rank n = ',I4)") l_, n WRITE (21, "('Further specifics: element l_ = ',I6,', and rank n = ',I4)") l_, n WRITE (*, "(' You can also use the debugger to examine saved matrix copies extra_A & extra_B.')") WRITE (21, "('You can also use the debugger to examine saved matrix copies extra_A & extra_B.')") CALL Pause() STOP END IF DEALLOCATE (work) DEALLOCATE (ipiv) !=================================================================================================== ! Important new step, added 2020.04.28 to Restore4 and (soon after) to NeoKinema: ! Detect and correct cases of "negative" continuum strain-rate !(where the "positive" sense is defined by the inferred fault-related strain-rate). ! These cases can arise when the user assigns high target fault offsets (and offset rates), ! with small associated uncertainties, in an attempt to force some fault to move ! faster than "it wants to" in its regional context. ! If not corrected, this problem can cause the under-slippage of some faults ! to be partially hidden (in the f_rst output file, for example), and the ! overall misfit measures for fault offsets to be underestimated. ! It also causes some paradoxical "negative" continuum strain-rates (in fault corridors) ! to be output by Write_x_feg, and possibly plotted by RetroMap4. ! ! Find inferred (but possibly unphysical) continuum strain-rate inside the local-solution vector: eps_dot_c(1) = X(Z + 1) eps_dot_c(2) = X(Z + 2) eps_dot_c(3) = X(Z + 3) ! Define faulting strain-rate vector, based on definition eps_dot() = eps_dot_f() + eps_dot_c() : eps_dot_f(1:3) = eps_dot(1:3) - eps_dot_c(1:3) !(Note that NOTHING in either the local-solution, nor in this correction ! to the local-solution, ever changes the total strain-rate of the element!) ! We have a problem if the dot-product of eps_dot_f with eps_dot_c is negative: test = eps_dot_f(1)*eps_dot_c(1) + eps_dot_f(2)*eps_dot_c(2) + eps_dot_f(3)*eps_dot_c(3) problem = (test < 0.0D0) IF (problem) THEN ! attempt to correct it! ! Define axis (in 3D strain-rate space) pointing from eps_dot_c to eps_dot_f: axis_c_to_f(1:3) = eps_dot_f(1:3) - eps_dot_c(1:3) test = axis_c_to_f(1)**2 + axis_c_to_f(2)**2 + axis_c_to_f(3)**2 IF (test > 0.0D0) THEN ! normal case test = SQRT(test) ! now equals length of axis vector, in units of /s ! Define dimensionless unit-vector (in 3D strain-rate space) along this axis: axis_uvec(1:3) = axis_c_to_f(1:3) / test ! Measure scalar length of eps_dot_f (before correction) using this ruler: old_eps_dot_f_scalar = eps_dot_f(1)*axis_uvec(1) + eps_dot_f(2)*axis_uvec(2) + eps_dot_f(3)*axis_uvec(3) ! Measure scalar length of eps_dot_c (before correction) using this ruler: old_eps_dot_c_scalar = eps_dot_c(1)*axis_uvec(1) + eps_dot_c(2)*axis_uvec(2) + eps_dot_c(3)*axis_uvec(3) !(Note that the result above will be negative.) ! Find scalar size of correction (now positive): correction_scalar = -old_eps_dot_c_scalar ! Now find 3D correction_vector: correction_vector(1:3) = correction_scalar * axis_uvec(1:3) ! Add correction to eps_dot_c. (Note that this does not make it a zero vector; it just zeroes its coordinate along the axis.) eps_dot_c(1:3) = eps_dot_c(1:3) + correction_vector(1:3) ! Apply same vector correction (with opposite sign) to eps_dot_f: eps_dot_f(1:3) = eps_dot_f(1:3) - correction_vector(1:3) !(Note that correcting eps_dot_c() and eps_dot_f() by opposite amounts PRESERVES their sum, which is eps_dot().) ! Find new scalar measure of eps_dot_f: new_eps_dot_f_scalar = eps_dot_f(1)*axis_uvec(1) + eps_dot_f(2)*axis_uvec(2) + eps_dot_f(3)*axis_uvec(3) ! Find correction-factor (expected to be positive, but < 1.0) for all fault-related strain-rates AND slip-rates! IF (old_eps_dot_f_scalar /= 0.0D0) THEN ! (normal case) faulting_correction_factor = new_eps_dot_f_scalar / old_eps_dot_f_scalar IF ((faulting_correction_factor >= 0.0D0).AND.(faulting_correction_factor < 1.0D0)) THEN ! Finally, pack away the CORRECTED, IMPROVED results in their former locations: DO z_ = 1, Z X(z_) = X(z_) * faulting_correction_factor END DO ! z_ = 1, Z X(Z + 1) = eps_dot_c(1) X(Z + 2) = eps_dot_c(2) X(Z + 3) = eps_dot_c(3) END IF ! value of faulting_correction_factor passes "reasonableness" tests !(Note that there is no ELSE; the correction is simply abandoned in any unexpected case.) END IF ! old_eps_dot_f_scalar /= 0.0D0 (normal case) END IF ! test > 0.0 (normal case) END IF ! problem !=================================================================================================== DO z_ = 1, Z p_ = X(z_) ! PREDICTED OFFSET-RATE OF THIS CRACK (in m/s; D & R positive; P & L negative; N & T here expressed as D & P heave-rates) loc = crack_index(2, l_) + z_ - 1 ! storage location in local_crack segment = local_crack(loc)%segment tv1 = seg_end(1:3, 1, segment) tv2 = seg_end(1:3, 2, segment) rho_ = R * Arc_distance(tv1, tv2) datum = local_crack(loc)%datum f_divide(1, datum) = f_divide(1, datum) + rho_ * p_ f_divide(2, datum) = f_divide(2, datum) + rho_ error = (p_ - local_crack(loc)%s_) / local_crack(loc)%sigma_ IF (ABS(error) > 2.0D0) N0_sum = N0_sum + (rho_ / L_0) N1_sum = N1_sum + ABS(error) * (rho_ / L_0) N2_sum = N2_sum + error**2 * (rho_ / L_0) error_count = error_count + (rho_ / L_0) !------------------------------------------------------------------- !Output heave-rate of segment to file (for plotting by RetroMap4): offset_rate_mmpa = p_ * s_per_Ma / m_per_km ! Convert p_ from units of m/s to units of km/Ma = mm/a. IF (ABS(offset_rate_mmpa) >= 0.1) THEN ! ignore any tiny rates offset_sense_c1 = local_crack(loc)%sense ! R, L, T, N, D, P IF ((offset_sense_c1 == 'R').OR.(offset_sense_c1 == 'D').OR.(offset_sense_c1 == 'N')) THEN !Rate is normally positive; flip sense (and number) if not: IF (offset_rate_mmpa < 0.0D0) THEN ! invert number and invert sense: IF (offset_sense_c1 == 'R') THEN offset_sense_c1 = 'L' ELSE IF (offset_sense_c1 == 'D') THEN offset_sense_c1 = 'P' ELSE IF (offset_sense_c1 == 'N') THEN offset_sense_c1 = 'T' END IF offset_rate_mmpa = -offset_rate_mmpa END IF ! sense R/D/N, and offset_rate_mmpa is negative ELSE ! offset_sense_c1 == L, P, or T !Rate is normally negative; flip it for most cases! offset_rate_mmpa = -offset_rate_mmpa !Flip sense (and number) AGAIN if rate is not now positive: IF (offset_rate_mmpa < 0.0D0) THEN ! invert number and invert sense: IF (offset_sense_c1 == 'L') THEN offset_sense_c1 = 'R' ELSE IF (offset_sense_c1 == 'P') THEN offset_sense_c1 = 'D' ELSE IF (offset_sense_c1 == 'T') THEN offset_sense_c1 = 'N' END IF offset_rate_mmpa = -offset_rate_mmpa END IF ! sense L/P/T, and offset_rate_mmpa is negative END IF ! offset_sense_c1 == R, D, N, versus L, P, T CALL DUvec_2_LonLat(tv1, tElon1, tNlat1) CALL DUvec_2_LonLat(tv2, tElon2, tNlat2) WRITE (26, "(F7.1, 1X, A1, F10.4, F9.4, F10.4, F9.4)") offset_rate_mmpa, offset_sense_c1, tElon1, tNlat1, tElon2, tNlat2 END IF ! ABS(offset_rate_mmpa) >= 0.1 !------------------------------------------------------------------- END DO ! z_ = 1, Z eps_dot_c(1) = X(Z + 1) eps_dot_c(2) = X(Z + 2) eps_dot_c(3) = X(Z + 3) IF (stress_ever) ele_strainrate(1:3,l_) = eps_dot_c(1:3) ! saved for Write_x_feg error = SQRT( eps_dot_c(1)**2 + & & eps_dot_c(1) * eps_dot_c(3) + & & eps_dot_c(3)**2 + & & eps_dot_c(2)**2 ) / mu_of_r_ IF (ABS(error) > 2.0D0) N0_sum = N0_sum + 1.50D0 N1_sum = N1_sum + ABS(error) * (a_(l_) / A_0) N2_sum = N2_sum + error**2 * (a_(l_) / A_0) error_count = error_count + (a_(l_) / A_0) !Save extra copy of area-weighted relative (to mu_) strain-rates, !to be divided-and-output after ALL timesteps are complete and this iteration ends: IF (ABS(error) > 2.0D0) continuum_N_numerator_sums(0) = continuum_N_numerator_sums(0) + (a_(l_) / A_0) ! summing numerator for eventual N0 continuum_N_numerator_sums(1) = continuum_N_numerator_sums(1) + ABS(error) * (a_(l_) / A_0) ! summing numerator for eventual N1 continuum_N_numerator_sums(2) = continuum_N_numerator_sums(2) + error**2 * (a_(l_) / A_0) ! summing numerator for eventual N2 continuum_N_denominator_sum = continuum_N_denominator_sum + (a_(l_) / A_0) ! summing denominator for eventual N0, N1, N2 !...where these 2 little variables are global, and externally initialized to zero DEALLOCATE ( X ) DEALLOCATE ( extra_B ) DEALLOCATE ( B ) ! in LIFO order DEALLOCATE ( extra_A ) DEALLOCATE ( A ) ELSE ! no active cracks in this element IF (stress_ever) ele_strainrate(1:3,l_) = eps_dot(1:3) ! saved for Write_x_feg error = SQRT( eps_dot(1)**2 + & & eps_dot(1) * eps_dot(3) + & & eps_dot(3)**2 + & & eps_dot(2)**2 ) / mu_of_r_ IF (ABS(error) > 2.0D0) N0_sum = N0_sum + (a_(l_) / A_0) N1_sum = N1_sum + ABS(error) * (a_(l_) / A_0) N2_sum = N2_sum + error**2 * (a_(l_) / A_0) error_count = error_count + (a_(l_) / A_0) !Save extra copy of area-weighted relative (to mu_) strain-rates, !to be divided-and-output after ALL timesteps are complete and this iteration ends: IF (ABS(error) > 2.0D0) continuum_N_numerator_sums(0) = continuum_N_numerator_sums(0) + (a_(l_) / A_0) ! summing numerator for eventual N0 continuum_N_numerator_sums(1) = continuum_N_numerator_sums(1) + ABS(error) * (a_(l_) / A_0) ! summing numerator for eventual N1 continuum_N_numerator_sums(2) = continuum_N_numerator_sums(2) + error**2 * (a_(l_) / A_0) ! summing numerator for eventual N2 continuum_N_denominator_sum = continuum_N_denominator_sum + (a_(l_) / A_0) ! summing denominator for eventual N0, N1, N2 !...where these 2 little variables are global, and externally initialized to zero END IF ! active cracks / no active cracks END DO ! l_ = 1, num_ele ! Close the output file for detailed heave-rate predictions (per fault segment): IF (f_rst_count > 0) THEN CLOSE (UNIT = 26) END IF ! nominal rate for each active fault is average over segments IF (f_rst_count > 0) THEN DO i = 1, f_rst_count IF (f_divide(2, i) > 0.0D0) THEN IF (sense(i) == 'T') THEN IF (f_dip_degrees(which_trace(i)) == 0.0D0) THEN !No value was set in the f_dig file; use generic dip: factor = -cot_thrust_dip ELSE ! use value set in the f_dig file: factor = -1.0D0 / TAN(MIN(80.0D0, f_dip_degrees(which_trace(i))) * radians_per_degree) END IF ELSE IF (sense(i) == 'P') THEN factor = -1.0D0 ELSE IF (sense(i) == 'N') THEN IF (f_dip_degrees(which_trace(i)) == 0.0D0) THEN !No value was set in the f_dig file; use generic dip: factor = cot_normal_dip ELSE ! use value set in the f_dig file: factor = 1.0D0 / TAN(MIN(80.0D0, f_dip_degrees(which_trace(i))) * radians_per_degree) END IF ELSE IF (sense(i) == 'D') THEN factor = 1.0D0 ELSE IF (sense(i) == 'R') THEN factor = 1.0D0 ELSE IF (sense(i) == 'L') THEN factor = -1.0D0 ENDIF f_rate(n_, i) = (f_divide(1, i) / f_divide(2, i)) / factor END IF END DO ! i = 1, f_rst_count END IF ! f_rst_count > 0 ! Active cross-sections, if entirely within domain IF (c_rst_count > 0) THEN DO k = 1, c_rst_count IF (c_active(n_,k)) THEN IF ((c_end_is(1,k)%element > 0).AND. & &(c_end_is(2,k)%element > 0)) THEN tv1 = c_end_now(1:3, 1, k) tv2 = c_end_now(1:3, 2, k) gamma_b = Get_azimuth(tv1, tv2) gamma_d = Pi + Get_azimuth(tv2, tv1) ! Note: These both point from b to d, but are evaluated at ! different locations b and d respectively. ! WORK ON WEST END: l_ = c_end_is(1,k)%element CALL Gjxy(l_, tv1, G) CALL Components(l_,G,vw,v_,w_) CALL Local_Theta(tv1, Theta) CALL Local_Phi (tv1, Phi) veloc = v_ * Theta + w_ * Phi outward = COS(gamma_b) * Theta - SIN(gamma_b) * Phi p_ = Dot_3D(veloc, outward) ! WORK ON EAST END: l_ = c_end_is(2,k)%element CALL Gjxy(l_, tv2, G) CALL Components(l_,G,vw,v_,w_) CALL Local_Theta(tv2, Theta) CALL Local_Phi (tv2, Phi) veloc = v_ * Theta + w_ * Phi outward = -COS(gamma_d) * Theta + SIN(gamma_d) * Phi p_ = p_ + Dot_3D(veloc, outward) misfits = ABS(p_ - c_goal(n_,k)) / c_rate_sigma_(k) error_count = error_count + 1.0D0 IF (misfits > 2.) N0_sum = N0_sum + 1.0D0 N1_sum = N1_sum + misfits N2_sum = N2_sum + misfits**2 c_rate(n_,k) = p_ END IF ! this section is entirely in domain END IF ! this section is active in this timestep END DO ! k = 1, c_rst_count END IF ! c_rst_count > 0 ! Paleomagnetic sites IF (p_rst_count > 0) THEN DO p = 1, p_rst_count IF (p_active(n_,p)) THEN l_ = p_site_is(p)%element IF (l_ > 0) THEN r_ = p_site_now(1:3,p) CALL Gjxy(l_, r_, G) ! paleolatitude part tv = p_pole(1:3, p) gamma_ = Get_azimuth(r_, tv) CALL Components(l_,G,vw,v_,w_) p_ = v_ * COS(gamma_) - w_ * SIN(gamma_) misfits = ABS(p_ - p_south_goal(n_,p)) / p_south_rate_sigma_(p) error_count = error_count + 1.0D0 IF (misfits > 2.0D0) N0_sum = N0_sum + 1.0D0 N1_sum = N1_sum + misfits N2_sum = N2_sum + misfits**2 p_south_rate(n_,p) = p_ ! vertical-axis rotation part IF (.NOT.twisted(p)) THEN CALL Del_Gjxy_del_thetaphi(l_, r_, dG) equat = SQRT(r_(1)**2 + r_(2)**2) theta_ = ATAN2(equat, r_(3)) sint = SIN(theta_) csct = 1.0D0 / sint tant = TAN(theta_) cott = 1.0D0 / tant prefix = 1.0D0 / (2.0D0 * R) p_ = 0.0D0 DO j = 1, 3 f_(j) = prefix * (G(j,1,2)*cott + dG(j,1,2,1) - csct*dG(j,1,1,2)) g_(j) = prefix * (G(j,2,2)*cott + dG(j,2,2,1) - csct*dG(j,2,1,2)) iv = 2 * node(j,l_) - 1 iw = iv + 1 p_ = p_ + vw(iv) * f_(j) + vw(iw) * g_(j) END DO misfits = ABS(p_ - p_ccw_goal(n_,p)) / p_ccw_rate_sigma_(p) error_count = error_count + 1.0D0 IF (misfits > 2.0D0) N0_sum = N0_sum + 1.0D0 N1_sum = N1_sum + misfits N2_sum = N2_sum + misfits**2 p_ccw_rate(n_,p) = p_ END IF ! .NOT.twisted END IF ! l_ > 0 END IF ! p_active(n_,p) END DO ! p = 1, p_rst_count END IF ! p_rst_count > 0 ! Finish and report error measures: IF (error_count > 0.0D0) THEN N0 = N0_sum / error_count N1 = N1_sum / error_count N2 = SQRT( N2_sum / error_count ) WRITE (*, "(' ',8X,'Rate errors: N0 = ',F4.3,', N1 = ',F6.3,', N2 = ',F6.3)") N0, N1, N2 WRITE (21,"(8X,'Rate errors: N0 = ',F4.3,', N1 = ',F6.3,', N2 = ',F6.3)") N0, N1, N2 ELSE N0 = 0.0D0 ; N1 = 0.0D0 ; N2 = 0.0D0 END IF END SUBROUTINE Prediction SUBROUTINE Prevent (bad_thing, line, filename) IMPLICIT NONE INTEGER, INTENT(IN) :: line CHARACTER(*), INTENT(IN) :: bad_thing, filename WRITE (*, "(' Error: ',A,' is illegal in line ',I6/' of ',A)") & TRIM(bad_thing), line, TRIM(filename) WRITE (21,"('Error: ',A,' is illegal in line ',I6/' of ',A)") & TRIM(bad_thing), line, TRIM(filename) CALL Traceback END SUBROUTINE Prevent SUBROUTINE Pull_in(s) ! If necessary, adjusts internal coordinates s(1..3) so ! that none is negative. IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(INOUT) :: s INTEGER, DIMENSION(1) :: array ! stupid, to satisfy MINLOC REAL*8 factor, lowest, highest, medium INTEGER :: side, sidea, sideb lowest = MINVAL(s) IF (lowest < 0.0D0) THEN highest = MAXVAL(s) medium = 1.000D0 - lowest - highest IF (medium > 0.0D0) THEN ! correct to nearest edge array = MINLOC(s) side = array(1) s(side) = 0.0D0 sidea = 1 + MOD(side, 3) sideb = 1 + MOD(sidea, 3) factor = 1.000D0 / (1.000D0 - lowest) s(sidea) = factor * s(sidea) ! s(sideb) = factor * s(sideb) would be logical s(sideb) = 1.000D0 - s(sidea) ! is safer ELSE ! correct to nearest vertex array = MAXLOC(s) side = array(1) s(side) = 1.000D0 sidea = 1 + MOD(side, 3) sideb = 1 + MOD(sidea, 3) s(sidea) = 0.0D0 s(sideb) = 0.0D0 END IF END IF END SUBROUTINE Pull_in SUBROUTINE ReadN (iunitp, iunitt, & ! input & n, & ! modify & vector) ! output ! A utility routine designed to permit newer codes to read ! input files designed for older codes, which have fewer ! variables in each line. ! The READ is performed with * format; integers are ! converted to REAL*8 (but can be converted back by NINT()). ! If this routine is NOT used, then an attempt to read ! more variables than present will read more than one ! line, causing misalignment of the file. ! By use of this routine, we return 0.00D0 for missing values. ! Input parameter "iunitp" is the device to read one line from. ! Input parameter "iunitt" tells where to send error messages. ! Modify parameter "n" tells how many values should be/were read. ! Output array "vector" contains the results. IMPLICIT NONE INTEGER, INTENT(IN) :: iunitp, iunitt INTEGER, INTENT(INOUT) :: n ! changes to show how many found REAL*8, DIMENSION(10), INTENT(OUT) :: vector ! check length vs. main program! CHARACTER*1 :: c CHARACTER*80 :: line INTEGER :: i, ios, number LOGICAL :: anyin, dotted, expon, signed line = ' ' READ (iunitp, "(A)", IOSTAT = ios) line number = 0 anyin = .FALSE. expon = .FALSE. signed = .FALSE. dotted = .FALSE. DO i = 1, 80 c = line(i:i) IF ((c == ' ').OR.(C == ',').OR.(C == '/')) THEN signed = .FALSE. expon = .FALSE. dotted = .FALSE. IF (anyin) THEN number = number + 1 anyin = .FALSE. END IF ELSE IF ((c == '+').OR.(c == '-')) THEN IF (signed) THEN GO TO 50 ELSE signed = .TRUE. END IF ELSE IF ((c == 'E').OR.(c == 'D').OR. & & (c == 'e').OR.(c == 'd')) THEN IF (expon) THEN GO TO 50 ELSE expon = .TRUE. signed = .FALSE. dotted = .TRUE. END IF ELSE IF (c == '.') THEN IF (dotted) THEN GO TO 50 ELSE dotted = .TRUE. END IF ELSE IF ((c == '0').OR.(c == '1').OR.(c == '2').OR. & & (c == '3').OR.(c == '4').OR.(c == '5').OR. & & (c == '6').OR.(c == '7').OR.(c == '8').OR. & & (c == '9')) THEN signed = .TRUE. anyin = .TRUE. ELSE GO TO 50 END IF ! values of c END DO ! i = 1, 80 IF (anyin) number = number + 1 50 IF (number == 0) THEN WRITE (iunitt, 91) n, TRIM(line) 91 FORMAT (/' ERR0R: A line of ASCII input which', & & ' was supposed to contain 1-',I2,' numbers'/ & & ' could NOT be interpreted. Line follows:'/ & & ' ',A) WRITE (*, "(' ERR0R in SUBROUTINE ReadN: Detail on device ',I3)") iunitt WRITE (21, "('ERR0R in SUBROUTINE ReadN: Detail on device ',I3)") iunitt CALL Pause() STOP ELSE IF (number >= n) THEN READ (line, *) (vector(i), i= 1, n) ELSE READ (line, *) (vector(i), i = 1, number) DO I = number + 1, n vector(i) = 0.00D0 END DO ! i = number+1, n END IF ! number >= or < n END IF ! number == or > 0 END SUBROUTINE ReadN SUBROUTINE Recovery_advice() ! Text-only output to the user, instructing them on how to get past a crash ! caused by element-folding (when there are no further FEG/BCS file pairs ! in the input parameter list to replace the current bad grid). IMPLICIT NONE WRITE (*, "(' ')") WRITE (*, "(' ----------------------------------------------------------------------')") WRITE (*, "(' MANUAL INTERVENTION IS NEEDED')") WRITE (*, "(' to provide an additional FEG/BCS file-pair, listed in Parameters.rst,')") WRITE (*, "(' that can survive the next time-step without folding-over (flipping)')") WRITE (*, "(' of any of the triangular elements in this new, edited grid.')") WRITE (*, "(' SUGGESTED PROCEDURE:')") WRITE (*, "(' 1. Note the last-good deformed FEG file that was output, at the end')") WRITE (*, "(' of the timestep PRIOR to the one that just crashed.')") WRITE (*, "(' 2. Note the last-good deformed fault-trace (f_.DIG) file,')") WRITE (*, "(' with the same geologic-time and iteration-number built into its name.')") WRITE (*, "(' 3. Open these two files in OrbWin, to see the situation just PRIOR')") WRITE (*, "(' to the fatal timestep (in which folding occurred).')") WRITE (*, "(' 4. Start your edits by saving a new FEG file with a new (but sequential) name;')") WRITE (*, "(' for example, save NI01_NI_001.2Ma.feg as NI02.feg ,')") WRITE (*, "(' or save 0101_i001_001.2Ma.feg as 0102.feg .')") WRITE (*, "(' 5. Consider the ERROR messages (from subprogram Plane_area) that were')") WRITE (*, "(' printed during the most recent fatal timstep. Taking the dangerous')") WRITE (*, "(' elements in order from high-numbered to low-numbered, adjust the grid')") WRITE (*, "(' around each of them, typically with one of these strategies:')") WRITE (*, "(' (A) Along transform faults of large offset, where elements have')") WRITE (*, "(' become excessively sheared, delete the whole belt of elements')") WRITE (*, "(' and redefine it with diagonal sides slanted the other way.')") WRITE (*, "(' (B) Along spreading centers, delete both the innermost')") WRITE (*, "(' (very narrow) belt of elements, and also the two adjacent belts')") WRITE (*, "(' of elements; then delete any free-floating nodes; then define')") WRITE (*, "(' a single belt of (wide) elements to replace what was 3 belts.')") WRITE (*, "(' (C) In other cases, simply Adjusting a few nodes to lie further from')") WRITE (*, "(' the fast-moving fault trace (along the expected heave direction)')") WRITE (*, "(' may be sufficient.')") WRITE (*, "(' 6. Test the edited grid with OrbWin tools Perimeter/Area Test and')") WRITE (*, "(' View Gaps/Overlaps. Fix any topological problems immediately.')") WRITE (*, "(' 7. Save the edited FEG file one last time.')") WRITE (*, "(' 8. Run OrbNumber to renumber the nodes of this new FEG grid for reduced')") WRITE (*, "(' bandwidth, memory conservation, and speed of execution in Restore.')") WRITE (*, "(' 9. Use the file (provided by OrbNumber) that lists boundary nodes in')") WRITE (*, "(' order as the basis for a new BCS boundary conditions file.')") WRITE (*, "(' Typically I use a spreadsheet to delete and insert columns,')") WRITE (*, "(' delete any unwanted rows, and then Save As... Text(space-delimited).')") WRITE (*, "(' 10. Name both the new FEG file and the new BCS file in Parameters.rst,')") WRITE (*, "(' and be sure that copies of them are available to Restore at run-time.')") WRITE (*, "(' 11. Restart Restore, either from the beginning (simpler) or from the')") WRITE (*, "(' end of the last good timestep (a bit tricky!).')") WRITE (*, "(' ----------------------------------------------------------------------')") WRITE (21, "(' ')") WRITE (21, "(' ----------------------------------------------------------------------')") WRITE (21, "('MANUAL INTERVENTION IS NEEDED')") WRITE (21, "('to provide an additional FEG/BCS file-pair, listed in Parameters.rst,')") WRITE (21, "('that can survive the next time-step without folding-over (flipping)')") WRITE (21, "('of any of the triangular elements in this new, edited grid.')") WRITE (21, "('SUGGESTED PROCEDURE:')") WRITE (21, "(' 1. Note the last-good deformed FEG file that was output, at the end')") WRITE (21, "(' of the timestep PRIOR to the one that just crashed.')") WRITE (21, "(' 2. Note the last-good deformed fault-trace (f_.DIG) file,')") WRITE (21, "(' with the same geologic-time and iteration-number built into its name.')") WRITE (21, "(' 3. Open these two files in OrbWin, to see the situation just PRIOR')") WRITE (21, "(' to the fatal timestep (in which folding occurred).')") WRITE (21, "(' 4. Start your edits by saving a new FEG file with a new (but sequential) name;')") WRITE (21, "(' for example, save NI01_NI_001.2Ma.feg as NI02.feg ,')") WRITE (21, "(' or save 0101_i001_001.2Ma.feg as 0102.feg .')") WRITE (21, "(' 5. Consider the ERROR messages (from subprogram Plane_area) that were')") WRITE (21, "(' printed during the most recent fatal timstep. Taking the dangerous')") WRITE (21, "(' elements in order from high-numbered to low-numbered, adjust the grid')") WRITE (21, "(' around each of them, typically with one of these strategies:')") WRITE (21, "(' (A) Along transform faults of large offset, where elements have')") WRITE (21, "(' become excessively sheared, delete the whole belt of elements')") WRITE (21, "(' and redefine it with diagonal sides slanted the other way.')") WRITE (21, "(' (B) Along spreading centers, delete both the innermost')") WRITE (21, "(' (very narrow) belt of elements, and also the two adjacent belts')") WRITE (21, "(' of elements; then delete any free-floating nodes; then define')") WRITE (21, "(' a single belt of (wide) elements to replace what was 3 belts.')") WRITE (21, "(' (C) In other cases, simply Adjusting a few nodes to lie further from')") WRITE (21, "(' the fast-moving fault trace (along the expected heave direction)')") WRITE (21, "(' may be sufficient.')") WRITE (21, "(' 6. Test the edited grid with OrbWin tools Perimeter/Area Test and')") WRITE (21, "(' View Gaps/Overlaps. Fix any topological problems immediately.')") WRITE (21, "(' 7. Save the edited FEG file one last time.')") WRITE (21, "(' 8. Run OrbNumber to renumber the nodes of this new FEG grid for reduced')") WRITE (21, "(' bandwidth, memory conservation, and speed of execution in Restore.')") WRITE (21, "(' 9. Use the file (provided by OrbNumber) that lists boundary nodes in')") WRITE (21, "(' order as the basis for a new BCS boundary conditions file.')") WRITE (21, "(' Typically I use a spreadsheet to delete and insert columns,')") WRITE (21, "(' delete any unwanted rows, and then Save As... Text(space-delimited).')") WRITE (21, "('10. Name both the new FEG file and the new BCS file in Parameters.rst,')") WRITE (21, "(' and be sure that copies of them are available to Restore at run-time.')") WRITE (21, "('11. Restart Restore, either from the beginning (simpler) or from the')") WRITE (21, "(' end of the last good timestep (a bit tricky!).')") WRITE (21, "('----------------------------------------------------------------------')") END SUBROUTINE Recovery_advice SUBROUTINE Set_goal_A (index, total, tmin, tmax, checkPD, & !inputs & goal, active) ! outputs ! Initialize goals as uniform within tmin:tmax, ! except for discretization effect of chopping into timesteps. ! Acts only on datum #index, so typically called from within loop. IMPLICIT NONE INTEGER, INTENT(IN) :: index ! which datum? REAL*8,DIMENSION(:), INTENT(IN) :: total, tmin, tmax ! for all data LOGICAL, INTENT(IN) :: checkPD ! promotions and demotions? REAL*8,DIMENSION(:,:),INTENT(OUT) :: goal LOGICAL(1), DIMENSION(:,:), INTENT(OUT) :: active REAL*8 :: epsilon, overlap, t0, t1 IF (checkPD) THEN ! applies only to faults IF ((tmin(index) == 0.0D0).AND.(tmax(index) < Deltat_)) THEN f_rst_code(index) = 'P' ! Promoted ELSE f_rst_code(index) = 'N' ! Normal; any necessary Demotions will be done later. END IF END IF IF (neotec) THEN active(1, index) = (start_time >= tmin(index)) .AND. (start_time < tmax(index)) ! if model time is exactly on boundary, then only windows extending to older times ! will match; this is based on idea that neotec models actually span a tiny bit of time. IF (active(1, index)) THEN goal(1, index) = total(index) / (tmax(index) - tmin(index)) ELSE goal(1, index) = 0.0D0 END IF ELSE ! paleotec DO j = 1, num_timesteps t0 = (j - 1) * Deltat_ t1 = j * Deltat_ overlap = MIN(t1 - t0, tmax(index) - tmin(index), & & tmax(index) - t0, t1 - tmin(index)) active(j, index) = (overlap > 0.0D0) IF (active(j, index)) THEN epsilon = total(index) * overlap / (tmax(index) - tmin(index)) goal(j, index) = epsilon / Deltat_ ! special kludge: Quaternary fault slip rates apply to whole first timestep IF (checkPD) THEN ! N.B. This compound .AND. is broken into 2 parts in 2 successive statements IF ((j == 1) .AND. (f_rst_code(index) == 'P')) THEN ! to avoid a subscript-out-of-range Debug abend when doing paleomag. goal(j, index) = total(index) / (tmax(index) - tmin(index)) END IF END IF ELSE goal(j, index) = 0.0D0 END IF END DO END IF ! paleotec END SUBROUTINE Set_goal_A SUBROUTINE Set_goal_B (index, checkPD, active, unit, signal, eof, conversion, & !inputs & line, rate, goal) ! modify ! Overwrite the default goals and rates ! (which are constant-rate goals and 0 rates) ! if * or & lines are available in the input file. ! Acts only on datum #index, so typically called from within loop. IMPLICIT NONE INTEGER, INTENT(IN) :: index, unit LOGICAL, INTENT(IN) :: checkPD ! promotion/demotion of Q rates LOGICAL(1), DIMENSION(:,:),INTENT(IN) :: active CHARACTER(1), INTENT(IN) :: signal LOGICAL, INTENT(OUT) :: eof REAL*8, INTENT(IN) :: conversion INTEGER, INTENT(INOUT) :: line REAL*8,DIMENSION(:,:), INTENT(INOUT) :: goal, rate INTEGER :: j, j0, j1, read_status REAL*8 :: overlap, r0, r1, r2, r3, t0, t1 CHARACTER(134) :: c134 LOGICAL :: new, process, synch seek_stars: DO READ (unit, "(A)", IOSTAT = read_status) c134; line = line + 1 eof = .FALSE. IF (read_status /= 0) THEN eof = .TRUE. RETURN ELSE IF (c134(1:1) == signal) THEN c134 = c134(2:134) // ' ' READ (c134, *) r0, r1, r2, r3 process = .NOT. (checkPD .AND. (f_rst_code(index) == 'P')) ! never change Promoted Holocene goals IF (process) THEN r0 = r0 * s_per_Ma ! global r1 = r1 * s_per_Ma r2 = r2 * conversion r3 = r3 * conversion IF (paleotec) THEN j0 = NINT(r0 / Deltat_) ! Deltat_ is global only IF(paleotec) j1 = NINT(r1 / Deltat_) synch = ((j1 - j0) == 1) .AND. & & (ABS((j0 * Deltat_ - r0) / Deltat_) < 0.01D0) .AND. & & (ABS((j1 * Deltat_ - r1) / Deltat_) < 0.01D0) IF (synch) THEN ! 1-to-1 correspondance of input lines with timesteps ! Now, avoid writing beyond end of current arrays "rate" and "goal": IF (j1 <= num_timesteps) THEN rate(j1, index) = r2 goal(j1, index) = r3 END IF ! j1 is in DIMENSIONed range ELSE ! not synch'ed ! more complex logic when steps are staggered or nested DO j = 1, num_timesteps ! global; = 1 IF (neotec) IF (active(j, index)) THEN t0 = (j - 1) * Deltat_ t1 = j * Deltat_ overlap = MIN (Deltat_, r1 - r0, t1 - r0, r1 - t0) IF (overlap > 0.0D0) THEN ! does [interval) just read include t0 of this timestep ? new = (r0 <= t0) .AND. (r1 > t0) IF (new) THEN !overwrite; later records may add IF (j <= num_timesteps) THEN rate(j, index) = r2 * overlap / Deltat_ goal(j, index) = r3 * overlap / Deltat_ END IF ! j is in DIMENSIONed range ELSE ! add IF (j <= num_timesteps) THEN rate(j, index) = rate(j, index) + r2 * overlap / Deltat_ goal(j, index) = goal(j, index) + r3 * overlap / Deltat_ END IF ! j is in DIMENSIONed range END IF ! new / NOT new END IF ! overlap > 0.0D0 END IF ! active(j, index) END DO ! j = 1, num_timesteps END IF ! synch or asynchronous ELSE ! not paleotec, so neotec IF ((r0 <= start_time).AND.(r1 >= start_time)) THEN rate(1, index) = r2 goal(1, index) = r3 END IF END IF ! paleotec / neotec END IF ! process ELSE ! signal not found BACKSPACE (unit) line = line - 1 RETURN END IF END DO seek_stars END SUBROUTINE Set_goal_B SUBROUTINE Sigma_1h(stress_count,needles,x_,azimuth,del_az_for_90pc) ! interpolates most-compressive horizontal principal stress ! direction "azimuth" (in radians clockwise from North), ! and reports the (one-sided, or half-) width of the sector ! that contains it with 90%-confidence, as "del_az_for_90pc" (radians). ! The method is the simple "independent-data" method of ! Bird & Li (1996), J. Geophys. Res., v. 101, #B3, 5435-5443. ! The information about the present global stress field is ! in global array ln_rel_prob. IMPLICIT NONE INTEGER, INTENT(IN) :: stress_count ! count of data TYPE(needle),DIMENSION(:),INTENT(IN):: needles ! data table REAL*8, DIMENSION(3),INTENT(IN) :: x_ ! Cartesian unit vector ! from center of Earth ! to interpolation point REAL*8, INTENT(OUT) :: azimuth, del_az_for_90pc REAL*8, PARAMETER :: Pi = 3.14159265358979D0 INTEGER :: j, jl, jlo, jr, jro, left, n, neighbors, right INTEGER, DIMENSION(1) :: peak REAL*8, DIMENSION(3) :: a_ REAL*8, DIMENSION(0:59) :: probability REAL*8 :: factor, fraction, gamma_a_, gamma_x_, highest, lowest, oldsum, problem, prediction, q_, sum, theta_ neighbors = 0 probability = 0.0D0 ! initialize array DO i = 1, stress_count a_ = needles(i)%location theta_ = Arc_distance(x_, a_) n = 1.00001D0 + 150.0D0 * (0.5D0 - 0.5D0 * COS(theta_))**0.6D0 IF (n <= 21) THEN neighbors = neighbors + 1 gamma_x_ = Get_azimuth(x_, a_) gamma_a_ = Get_azimuth(a_, x_) + Pi prediction = MOD((needles(i)%azimuth - gamma_a_ + gamma_x_ + (6.0D0 * Pi)), Pi) q_ = needles(i)%relevance left = 19.0985D0 * prediction + 0.5D0 left = MOD(left, 60) right = MOD(left + 1, 60) IF (q_ > 0.99D0) THEN ! omit factor for more speed DO j = 0, 29 jl = MOD((left - j + 60), 60) jr = MOD((right + j), 60) probability(jl) = probability(jl) + ln_rel_prob(n,j) probability(jr) = probability(jr) + ln_rel_prob(n,j) END DO ELSE IF (q_ > 0.0D0) THEN DO j = 0, 29 jl = MOD((left - j + 60), 60) jr = MOD((right + j), 60) probability(jl) = probability(jl) + q_ * ln_rel_prob(n,j) probability(jr) = probability(jr) + q_ * ln_rel_prob(n,j) END DO END IF ! q_ = or /= 1. END IF ! inside correlation horizon at 22 deg. END DO ! i = 1, stress_count IF (neighbors > 0) THEN !------------------------------------------------------------- !prevent overflows in the EXP() function, which may happen !when faults are treated as stress-direction indicators, !and there are thousands of active faults! highest = MAXVAL(probability) lowest = MINVAL(probability) problem = MAX(highest, ABS(lowest)) IF (problem > 690.0D0) THEN factor = 690.0D0 / problem probability = probability * factor END IF !------------------------------------------------------------- sum = 0.0D0 DO j = 0, 59 probability(j) = EXP(probability(j)) sum = sum + probability(j) END DO probability = probability / sum peak = MAXLOC(probability) - 1 ! to compensate for (0:59), not (60)! azimuth = (peak(1) + 0.5D0) * 0.05236D0 jlo = peak(1) jro = jlo oldsum = 0.0D0 DO j = 1, 29 jl = MOD(peak(1) - j + 60, 60) jr = MOD(peak(1) + j, 60) sum = oldsum + 0.5D0 *(probability(jl) + probability(jlo) + & & probability(jr) + probability(jro)) IF (sum >= 0.90D0) THEN fraction = (0.90D0 - oldsum) / (sum - oldsum) del_az_for_90pc = 0.05236D0 * (j - 1 + fraction) RETURN END IF oldsum = sum jlo = jl jro = jr END DO ELSE azimuth = 0.0D0 END IF del_az_for_90pc = 1.41372D0 END SUBROUTINE Sigma_1h SUBROUTINE Solve_for_vw (passes, vw) IMPLICIT NONE INTEGER, INTENT(IN) :: passes REAL*8, DIMENSION(nDOF), INTENT(INOUT) :: vw !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! NOTE: vw is used BEFORE it is computed in the first pass ! through the stress section, IF (stress_now), and also to ! track convergence(?) of velocity solution during refinement. ! An array of zeros is OK as input, but undefined values are not! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - TYPE(needle), DIMENSION(:), ALLOCATABLE :: needles !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DOUBLE PRECISION, PARAMETER :: Pi = 3.14159265358979D0 ! These values were confirmed DOUBLE PRECISION, PARAMETER :: Pi_over_2 = 1.57079632679490D0 ! with PROGRAM Check_Pi. DOUBLE PRECISION, PARAMETER :: Pi_over_4 = 0.785398163397448D0 REAL*8, DIMENSION(3,3) :: A, B, C, D REAL*8, DIMENSION(3) :: E, F REAL*8, DIMENSION(6,6) :: A6, B6, C6, D6 REAL*8, DIMENSION(6) :: E6, F6 REAL*8 :: allowance, azimuth REAL*8 :: big_one REAL*8 :: boxed_frac REAL*8 :: cosg, cos2g REAL*8 :: cott, csct REAL*8 :: crackLength_sum_m REAL*8, DIMENSION(3,2,2,2) :: dG REAL*8 :: del_az_for_90pc ! one-sided, in radians REAL*8 :: del_s_, difference, divisor REAL*8 :: dV_frac REAL*8, DIMENSION(3) :: eigenvalues REAL*8, DIMENSION(3,3) :: eigenvectors REAL*8, DIMENSION(3) :: epsilon_dot REAL*8 :: equat REAL*8 :: error REAL*8 :: eta_ REAL*8, DIMENSION(6) :: f_, g_ ! sometimes, only 1..3 are used REAL*8 :: factor REAL*8 :: floor = 2.0D0 * TINY(floor) REAL*8, DIMENSION(3,2,2) :: G REAL*8 :: gamma_ TYPE(is123), DIMENSION(7) :: Gauss_point REAL*8, DIMENSION(7) :: Gauss_weight = (/ 0.225D0, & & 0.13239415D0, 0.13239415D0, 0.13239415D0, & & 0.12593918D0, 0.12593918D0, 0.12593918D0 /) REAL*8 :: goal INTEGER :: h INTEGER :: i, i1, i2, i3, info, it, ita, ite INTEGER, PARAMETER :: ijob = 4 ! mode setting for LSLPB INTEGER, DIMENSION(:), ALLOCATABLE :: ipiv ! workspace needed by dgbsv (of the LAPACK portion of the MKL library) INTEGER :: j, jta, jte, k REAL*8 :: kappa_ INTEGER :: l_, l_1, l_2 INTEGER :: last_pass ! Used to hold most of each line of convergence(?)-report table, until the mean stress "error" is known. REAL*8 :: last_dV_frac, last_new_V, last_stressed_frac, last_boxed_frac ! ditto; see above REAL*8, DIMENSION(3) :: lambda_ REAL*8, DIMENSION(3,3) :: Lambda INTEGER :: loc REAL*8 :: lat, lon INTEGER :: m REAL*8 :: mu_of_r_, mu_2 REAL*8 :: new_V, num_boxed, num_stressed REAL*8 :: one_over_R2 REAL*8 :: overlap_threshold INTEGER :: p, pass LOGICAL :: plot_stress_at_nodes = .FALSE. REAL*8 :: prefix REAL*8, DIMENSION(3) :: r_ REAL*8 :: radius INTEGER :: s REAL*8 :: s_ INTEGER :: segment CHARACTER(1) :: sense REAL*8 :: sigma_ REAL*8 :: sing, sin2g REAL*8 :: sint INTEGER :: stress_count REAL*8 :: stressed_frac REAL*8 :: sum_base_n, sum_base_o, sum_diff, sum_err REAL*8 :: t_sigma, tant, theta REAL*8 :: this_crack_length_m REAL*8 :: top_value INTEGER :: twoi, u_ REAL*8, DIMENSION(3) :: tv, tv1, tv2 REAL*8 :: vn, vo, wn, wo REAL*8, DIMENSION(3,3) :: V DOUBLE PRECISION, DIMENSION(3,3) :: V8 REAL*8, DIMENSION(8) :: work ! required by dsyev INTEGER :: Z, z_ Gauss_point(1)%s(1:3) = (/ 0.33333333D0, 0.33333333D0, 0.33333333D0 /) Gauss_point(2)%s(1:3) = (/ 0.05971587D0, 0.47014206D0, 0.47014206D0 /) Gauss_point(3)%s(1:3) = (/ 0.47014206D0, 0.05971587D0, 0.47014206D0 /) Gauss_point(4)%s(1:3) = (/ 0.47014206D0, 0.47014206D0, 0.05971587D0 /) Gauss_point(5)%s(1:3) = (/ 0.79742698D0, 0.10128650D0, 0.10128650D0 /) Gauss_point(6)%s(1:3) = (/ 0.10128650D0, 0.79742698D0, 0.10128650D0 /) Gauss_point(7)%s(1:3) = (/ 0.10128650D0, 0.10128650D0, 0.79742698D0 /) one_over_R2 = 1.0D0 / R**2 ABCD = 0.0D0 ! global coefficient matrix EF = 0.0D0 ! global forcing vector DO l_ = 1, num_ele i1 = node(1, l_) i2 = node(2, l_) i3 = node(3, l_) A = 0.0D0; B = 0.0D0; C = 0.0D0; D = 0.0D0 ! element submatrices; see (4) ! through (6) of Bird (1998). E = 0.0D0; F = 0.0D0 ! forcing subvectors for element Z = crack_index(1, l_) IF (Z > 0) THEN ! active faulting! IF (time0 < mu_switch(l_)) THEN mu_of_r_ = mu_element(1, l_) ELSE mu_of_r_ = mu_element(2, l_) END IF t_sigma = mu_scale * ((mu_of_r_ / mu_scale)**exponent) mu_2 = t_sigma**2 V8(1,1) = mu_2 * 4.0D0 / 3.0D0 ! begin element covariance matrix V8(1,2) = 0.D0 V8(1,3) = mu_2 * (-2.0D0 / 3.0D0) V8(2,1) = 0.0D0 V8(2,2) = mu_2 V8(2,3) = 0.0D0 V8(3,1) = V8(1,3) V8(3,2) = 0.0D0 V8(3,3) = V8(1,1) epsilon_dot = 0.0D0 ! zero target strainrate vector ! evaluate nodal function and derivitives at center of element tv = center(1:3, l_) CALL Gjxy(l_, tv, G) CALL Del_Gjxy_del_thetaphi(l_, tv, dG) equat = SQRT(tv(1)**2 + tv(2)**2) IF (equat == 0.0D0) THEN WRITE (*, "(' Error: center of element ', I6, ' is N or S pole.')") l_ WRITE (21,"( 'Error: center of element ', I6, ' is N or S pole.')") l_ CALL Pause() STOP END IF theta = ATAN2(equat, tv(3)) sint = SIN(theta) csct = 1.0D0 / sint tant = TAN(theta) cott = 1.0D0 / tant !Initialize sum of crack lengths in this element (to compare to L_0, for weighting purposes) crackLength_sum_m = 0.0D0 DO z_ = 1, Z ! loop on active traces in this element ! segment description loc = crack_index(2, l_) + z_ - 1 ! storage location in local_crack segment = local_crack(loc)%segment tv1 = seg_end(1:3, 1, segment) tv2 = seg_end(1:3, 2, segment) this_crack_length_m = R * Arc_distance(tv1, tv2) crackLength_sum_m = crackLength_sum_m + this_crack_length_m gamma_ = Get_azimuth (tv1, tv2) sense = local_crack(loc)%sense s_ =local_crack(loc)%s_ del_s_ = f_scale * ((local_crack(loc)%sigma_ / f_scale)**exponent) u_ = seg_u_(segment) ! 1, 2, or 3? eta_ = seg_eta_(segment) kappa_ = seg_kappa_(segment) ! H vector of this trace prefix = eta_ * kappa_ / R sing = SIN(gamma_) cosg = COS(gamma_) IF ((sense == 'L') .OR. (sense == 'R')) THEN local_crack(loc)%H(1) = prefix * (dG(u_,1,1,1) * cosg - dG(u_,2,1,1) * sing) local_crack(loc)%H(2) = prefix * 0.50D0 * (dG(u_,1,1,2) * cosg/sint - dG(u_,2,1,2) * sing/sint + & & dG(u_,1,2,1) * cosg - dG(u_,2,2,1) * sing - & & cott * (G(u_,1,2) * cosg - G(u_,2,2) * sing)) local_crack(loc)%H(3) = prefix * (dG(u_,1,2,2) * cosg/sint - dG(u_,2,2,2) * sing/sint + & & cott * (G(u_,1,1) * cosg - G(u_,2,1) * sing)) ELSE IF ((sense == 'T') .OR. (sense == 'P') .OR. (sense == 'N') .OR. (sense == 'D')) THEN local_crack(loc)%H(1) = prefix * (dG(u_,1,1,1) * sing + dG(u_,2,1,1) * cosg) local_crack(loc)%H(2) = prefix * 0.50D0 * (dG(u_,1,1,2) * sing/sint + dG(u_,2,1,2) * cosg/sint + & & dG(u_,1,2,1) * sing + dG(u_,2,2,1) * cosg - & & cott * (G(u_,1,2) * sing + G(u_,2,2) * cosg)) local_crack(loc)%H(3) = prefix * (dG(u_,1,2,2) * sing/sint + dG(u_,2,2,2) * cosg/sint + & & cott * (G(u_,1,1) * sing + G(u_,2,1) * cosg)) ELSE ! should not happen CALL Prevent ('bad slip sense', 65, 'Solve for w') END IF ! increment strain-rate goals and variances DO i = 1, 3 epsilon_dot(i) = epsilon_dot(i) + s_ * local_crack(loc)%H(i) DO j = 1, 3 V8(i,j) = V8(i,j) + del_s_**2 * local_crack(loc)%H(i) * & & local_crack(loc)%H(j) END DO END DO END DO ! z_ = 1, Z ! scale V matrix to prevent underflows V(1:3, 1:3) = V8(1:3, 1:3) * 1.0D30 ! Using the LAPACK portion of MKL (Math Kernel Library, by Intel), ! Compute all eigenvalues and eigenvectors of a real symmetric matrix. ! CALL dsyev ( jobz, uplo, n, a, lda, w, work, lwork, info ) ! The manual page is here: https://software.intel.com/en-us/node/469176#F4730256-22C7-44CD-9A79-20E89E94760C ! Arguments: ! CHARACTER*1 :: jobz ! = 'V' to compute both eigenvalues and eigenvectors. ! CHARACTER*1 :: uplo ! = 'U' if the upper-triangle of the coefficient matrix is to be used, or 'L' for the lower triangle. ! INTEGER :: n ! the order of the matrix a. ! REAL*8, DIMENSION(lda, *) :: a ! where matrix a is symmetric, and both dimensions are at least as large as n. ! INTEGER :: lwork ! must be at least equal to (3*n - 1). ! REAL*8, DIMENSION(lwork) :: work ! (necessary workspace) ! INTEGER :: info ! flag showing success or failure; == 0 for success. ! REAL*8, DIMENSION(n) :: w ! computed eigenvalues, in ascending order ! NOTE that after successful completion, the orthonormal eigenvectors are stored (as columns) in matrix a. CALL dsyev ( 'V', 'U', 3, V, 3, eigenvalues, work, 8, info ) IF (info == 0) THEN ! successful termination eigenvectors = V ! copy from transformed input matrix ELSE WRITE (*, "(' ERROR: In SUBROUTINE Solve_for_vw, CALL dsyev results in info = ',I10)") info WRITE (21, "('ERROR: In SUBROUTINE Solve_for_vw, CALL dsyev results in info = ',I10)") info CALL Pause() STOP END IF top_value = 0.0D0 DO h = 1, 3 ! the eigenvectors each define a new scalar datum ! undo the scaling applied previously to V lambda_(h) = 1.0D-30 * eigenvalues(h) top_value = MAX(top_value, lambda_(h)) END DO DO h = 1,3 IF (lambda_(h) <= 0.0D0) THEN ! prevent needless halts due to loss-of-precision IF (ABS(lambda_(h)) <= (0.01D0 * top_value)) THEN lambda_(h) = mu_2 ELSE CALL Prevent('nonpositive eigenvalue', 185, 'Solve for vw') END IF ! large or small negative eigenvalue END IF ! nonpositive eigenvalue (shouldn't happen) sigma_ = SQRT(lambda_(h)) prefix = (crackLength_sum_m / L_0) / sigma_**2 goal = 0.0D0 DO m = 1, 3 Lambda(h, m) = eigenvectors(m, h) ! sic transpose; see above goal = goal + Lambda(h, m) * epsilon_dot(m) END DO DO j = 1, 3 ! local node numbers f_(j) = (1.0D0 / R) * (dG(j,1,1,1) * Lambda(h, 1) + & & 0.5D0 * (csct * dG(j,1,1,2) + dG(j,1,2,1) - cott * G(j,1,2)) * Lambda(h, 2) + & & (csct * dG(j,1,2,2) + cott * G(j,1,1)) * Lambda(h, 3)) g_(j) = (1.0D0 / R) * (dG(j,2,1,1) * Lambda(h, 1) + & & 0.5D0 * (csct * dG(j,2,1,2) + dG(j,2,2,1) - cott * G(j,2,2)) * Lambda(h, 2) + & & (csct * dG(j,2,2,2) + cott * G(j,2,1)) * Lambda(h, 3)) END DO ! j = 1, 2, 3 (local node numbers) CALL Add_datum(prefix, f_, g_, goal, A, C, D, E, F) END DO ! eigenvalues h = 1, 2, 3 :: 3 more data for linear system ELSE ! use a-priori constraint ! Basic stiffness matrix of nonfaulting elements DO m = 1, 7 IF (time0 < mu_switch(l_)) THEN mu_of_r_ = mu_element(1, l_) ELSE mu_of_r_ = mu_element(2, l_) END IF t_sigma = mu_scale * ((mu_of_r_ / mu_scale)**exponent) prefix = one_over_R2 * (a_(l_) / A_0) * Gauss_weight(m) / (t_sigma**2) Gauss_point(m)%element = l_ CALL Interpolate(Gauss_point(m), r_) CALL Gjxy(l_, r_, G) CALL Del_Gjxy_del_thetaphi(l_, r_, dG) equat = SQRT(r_(1)**2 + r_(2)**2) IF (equat == 0.0D0) THEN WRITE (*, "(' Error: integration point ', I1, ' of element ', I6, ' is N or S pole.')") m, l_ WRITE (21,"( 'Error: integration point ', I1, ' of element ', I6, ' is N or S pole.')") m, l_ CALL Pause() STOP END IF theta = ATAN2(equat, r_(3)) csct = 1.0D0 / SIN(theta) tant = TAN(theta) cott = 1.0D0 / tant DO i = 1, 3 DO j = 1, 3 IF (j <= i) THEN ! diagonal and lower triangle only A(i,j) = A(i,j) + prefix * & & ( 2.0D0*dG(i,1,1,1)*dG(j,1,1,1)+ & & csct*(dG(i,1,1,1)*dG(j,1,2,2)+dG(i,1,2,2)*dG(j,1,1,1))+ & & cott*(dG(i,1,1,1)*G(j,1,1)+G(i,1,1)*dG(j,1,1,1))+ & & 2.0D0*(csct*dG(i,1,2,2)+G(i,1,1)*cott)*(csct*dG(j,1,2,2)+G(j,1,1)*cott)+ & & 0.50D0*(csct*dG(i,1,1,2)+dG(i,1,2,1)-G(i,1,2)*cott)*(csct*dG(j,1,1,2)+dG(j,1,2,1)-G(j,1,2)*cott) ) D(i,j) = D(i,j) + prefix * & & ( 2.0D0*dG(i,2,1,1)*dG(j,2,1,1)+ & & csct*(dG(i,2,1,1)*dG(j,2,2,2)+dG(i,2,2,2)*dG(j,2,1,1))+ & & cott*(dG(i,2,1,1)*G(j,2,1)+G(i,2,1)*dG(j,2,1,1))+ & & 2.0D0*(csct*dG(i,2,2,2)+G(i,2,1)*cott)*(csct*dG(j,2,2,2)+G(j,2,1)*cott)+ & & 0.50D0*(csct*dG(i,2,1,2)+dG(i,2,2,1)-G(i,2,2)*cott)*(csct*dG(j,2,1,2)+dG(j,2,2,1)-G(j,2,2)*cott) ) END IF ! All of B lies in the upper triangle; transpose of C ! B(i,j) = B(i,j) + prefix * & ! & ( 2.0D0*dG(i,1,1,1)*dG(j,2,1,1)+ & ! & csct*(dG(i,1,1,1)*dG(j,2,2,2)+dG(i,1,2,2)*dG(j,2,1,1))+ & ! & cott*(dG(i,1,1,1)*G(j,2,1)+G(i,1,1)*dG(j,2,1,1))+ & ! & 2.0D0*(csct*dG(i,1,2,2)+G(i,1,1)*cott)*(csct*dG(j,2,2,2)+G(j,2,1)*cott)+ & ! & 0.50D0*(csct*dG(i,1,1,2)+dG(i,1,2,1)-G(i,1,2)*cott)*(csct*dG(j,2,1,2)+dG(j,2,2,1)-G(j,2,2)*cott) ) ! All of C lies in lower triangle C(i,j) = C(i,j) + prefix * & & ( 2.0D0*dG(i,2,1,1)*dG(j,1,1,1)+ & & csct*(dG(i,2,1,1)*dG(j,1,2,2)+dG(i,2,2,2)*dG(j,1,1,1))+ & & cott*(dG(i,2,1,1)*G(j,1,1)+G(i,2,1)*dG(j,1,1,1))+ & & 2.0D0*(csct*dG(i,2,2,2)+G(i,2,1)*cott)*(csct*dG(j,1,2,2)+G(j,1,1)*cott)+ & & 0.50D0*(csct*dG(i,2,1,2)+dG(i,2,2,1)-G(i,2,2)*cott)*(csct*dG(j,1,1,2)+dG(j,1,2,1)-G(j,1,2)*cott) ) END DO ! on j = 1, 3 END DO ! on i = 1, 3 END DO ! on 7 Gauss integration points END IF ! faults, OR a-priori stiffness in this element ! Add any paleomagnetic data in this element IF (p_rst_count > 0) THEN DO p = 1, p_rst_count IF (p_active(n_,p)) THEN IF (p_site_is(p)%element == l_) THEN r_ = p_site_now(1:3,p) CALL Gjxy(l_, r_, G) ! paleolatitude anomaly part tv = p_pole(1:3, p) gamma_ = Get_azimuth(r_,tv) sing = SIN(gamma_) cosg = COS(gamma_) DO j = 1, 3 f_(j) = G(j,1,1) * cosg - G(j,1,2) * sing g_(j) = G(j,2,1) * cosg - G(j,2,2) * sing END DO t_sigma = p_drift_scale * ((p_south_rate_sigma_(p) / p_drift_scale)**exponent) prefix = 1.0D0 / (t_sigma**2) CALL Add_datum(prefix,f_,g_,p_south_goal(n_,p),A,C,D,E,F) ! vertical-axis rotation part IF (.NOT.twisted(p)) THEN CALL Del_Gjxy_del_thetaphi(l_, r_, dG) equat = SQRT(r_(1)**2 + r_(2)**2) theta = ATAN2(equat, r_(3)) sint = SIN(theta) csct = 1.0D0 / sint tant = TAN(theta) cott = 1.0D0 / tant prefix = 1.0D0 / (2.0D0 * R) DO j = 1, 3 f_(j) = prefix * (G(j,1,2)*cott + dG(j,1,2,1) - csct*dG(j,1,1,2)) g_(j) = prefix * (G(j,2,2)*cott + dG(j,2,2,1) - csct*dG(j,2,1,2)) END DO t_sigma = p_spin_scale * ((p_ccw_rate_sigma_(p) / p_spin_scale)**exponent) prefix = 1.0D0 / (t_sigma**2) CALL Add_datum(prefix,f_,g_,p_ccw_goal(n_,p),A,C,D,E,F) END IF ! .NOT.twisted END IF ! paleomag site is in this element END IF ! p_active(n_,p) END DO ! p = 1, p_rst_count END IF ! p_rst_count > 0 CALL Plug_in_33 (l_, A, B, C, D, E, F) ! add element matrix,vector to global END DO ! l_ = 1,num_ele, doing a-priori stiffness & faults & paleomag ! Add any active cross-sections with both ends in model IF (c_rst_count > 0) THEN DO k = 1, c_rst_count IF (c_active(n_,k)) THEN IF ((c_end_is(1,k)%element > 0).AND. & &(c_end_is(2,k)%element > 0)) THEN A6 = 0.0D0; B6 = 0.0D0; C6 = 0.0D0; D6 = 0.0D0 E6 = 0.0D0; F6 = 0.0D0 l_1 = c_end_is(1,k)%element ! West end is in this element tv1 = c_end_now(1:3, 1, k) tv2 = c_end_now(1:3, 2, k) gamma_ = Get_azimuth(tv1, tv2) sing = SIN(gamma_) cosg = COS(gamma_) CALL Gjxy(l_1, tv1, G) DO j = 1,3 f_(j) = G(j,1,1) * cosg - G(j,1,2) * sing g_(j) = G(j,2,1) * cosg - G(j,2,2) * sing END DO l_2 = c_end_is(2,k)%element ! East end is in this element gamma_ = Pi + Get_azimuth(tv2, tv1) ! gamma_ is almost same as above, but evaluated at East end now sing = SIN(gamma_) cosg = COS(gamma_) CALL Gjxy(l_2, tv2, G) DO j = 1,3 f_(j+3) = -G(j,1,1) * cosg + G(j,1,2) * sing g_(j+3) = -G(j,2,1) * cosg + G(j,2,2) * sing END DO t_sigma = c_scale * ((c_rate_sigma_(k) / c_scale)**exponent) prefix = 1.0D0 / (t_sigma**2) DO i = 1, 6 DO j = 1, 6 IF (j <= i) THEN ! diagonal and lower triangle only A6(i,j) = A6(i,j) + prefix * f_(i) * f_(j) D6(i,j) = D6(i,j) + prefix * g_(i) * g_(j) END IF ! All of B lies in the upper triangle; transpose of C ! B(i,j) = B(i,j) + prefix * f_(i) *g_(j) ! All of C lies in lower triangle C6(i,j) = C6(i,j) + prefix * g_(i) * f_(j) END DO ! on j = 1, 6 E6(i) = E6(i) + prefix * f_(i) * c_goal(n_, k) F6(i) = F6(i) + prefix * g_(i) * c_goal(n_, k) END DO ! on i = 1, 6 CALL Plug_in_66 (l_1, l_2, A6, B6, C6, D6, E6, F6) END IF ! this cross-section is within domain END IF ! this cross-section is active now END DO ! k = 1, c_rst_count END IF ! c_rst_count > 0 IF (passes > 0) THEN ! selection criterion could be > 1 (0R, > 0 to always print) ! Write headers for convergence report IF (stress_now) THEN WRITE (*, "(' ',18X,'Refinement dV/V RMS(V) Stressed Boxed Mean_error(deg.)')") WRITE (21,"(19X,'Refinement dV/V RMS(V) Stressed Boxed Mean_error(deg.)')") ELSE WRITE (*, "(' ',18X,'Refinement dV/V RMS(V)')") WRITE (21,"(19X,'Refinement dV/V RMS(V)')") END IF END IF many_passes: DO pass = 1, passes ! Shuffle copies of matrix, if needed IF (passes > 1) THEN IF (pass == 1) THEN duplicate_ABCD = ABCD ! save constant part duplicate_EF = EF ! save constant part ELSE ABCD = duplicate_ABCD ! retrieve constant part EF = duplicate_EF ! retrieve constant part END IF END IF num_boxed = 0.0D0; num_stressed = 0.0D0 IF (stress_now) THEN ! Initialize stress in each element IF (pass == 1) THEN !WRITE (*, "(' ',12X,'Interpolating stress directions)')") ! Count the stress data (including cracks?) stress_count = 0 DO s = 1, s_rst_count IF (s_site_is(1,s)%element > 0) THEN IF (s_activity(n_,s) > 0.0D0) stress_count = stress_count + 1 END IF END DO IF (faults_give_sigma_1h) THEN DO s = 1, crack_count i = local_crack(s)%datum IF (f_goal(n_, i) /= 0.0D0) THEN IF (f_new(i)) stress_count = stress_count + 1 END IF END DO END IF ! Allocate the array to hold the data ALLOCATE ( needles(stress_count) ) ! Fill the array with data stress_count = 0 DO s = 1, s_rst_count IF (s_site_is(1,s)%element > 0) THEN IF (s_activity(n_,s) > 0.0D0) THEN stress_count = stress_count + 1 needles(stress_count)%location = s_site_now(1:3,1,s) needles(stress_count)%azimuth = s_azim_now(s) needles(stress_count)%sigma = s_sigma_(s) needles(stress_count)%relevance = s_activity(n_,s) END IF END IF END DO IF (faults_give_sigma_1h) THEN DO s = 1, crack_count i = local_crack(s)%datum IF (f_new(i)) THEN IF (f_goal(n_, i) /= 0.0D0) THEN stress_count = stress_count + 1 segment = local_crack(s)%segment tv = 0.50D0 * (seg_end(1:3,1,segment) + seg_end(1:3,2,segment)) CALL Unitise(tv, r_) needles(stress_count)%location = r_ tv1 = seg_end(1:3, 1, segment) tv2 = seg_end(1:3, 2, segment) gamma_ = Get_azimuth (tv1, tv2) sense = local_crack(s)%sense ! T, N, R, L, D IF ((sense == 'T') .OR. (sense == 'P')) THEN gamma_ = gamma_ + Pi_over_2 ELSE IF (sense == 'R') THEN gamma_ = gamma_ + Pi_over_4 ELSE IF (sense == 'L') THEN gamma_ = gamma_ - Pi_over_4 END IF needles(stress_count)%azimuth = gamma_ needles(stress_count)%sigma = Pi_over_4 / 2.0D0 !Treat as stage data: IF (paleotec) THEN overlap = MAX(0.0D0, MIN(time1 - time0, f_t_max(i) - f_t_min(i), & & time1 - f_t_min(i), f_t_max(i) - time0)) overlap_threshold = MIN(0.1D0 * s_per_Ma, 0.5D0 * Deltat_) IF (overlap >= overlap_threshold) THEN needles(stress_count)%relevance = 1.0D0 ELSE needles(stress_count)%relevance = 0.0D0 END IF ELSE ! neotec allowance = 0.1D0 * s_per_Ma IF ((start_time > (f_t_min(i) - allowance)).AND. & & (start_time < (f_t_max(i) + allowance))) THEN needles(stress_count)%relevance = 1.0D0 ELSE needles(stress_count)%relevance = 0.0D0 END IF END IF ! paleotec / neotec END IF ! f_goal(n_, i) /= 0.0D0 END IF ! new fault END DO ! all local cracks END IF ! faults_give_sigma_1h ! Interpolate stress to centers of elements with no (real) data ele_stressed = .TRUE. ! (just initializing) ele_q = 0.0D0 ! (ditto) ! No interpolation if element contains a datum; use best datum DO s = 1, s_rst_count l_ = s_site_is(1,s)%element IF (l_ > 0) THEN IF (s_activity(n_,s) > ele_q(l_)) THEN IF (ele_stressed(l_)) THEN ele_azim(l_) = s_azim_now(s) ele_q(l_) = s_activity(n_,s) ele_sigma(l_) = s_sigma_(s) END IF END IF END IF END DO IF ((plot_stress_at_nodes).AND.(passes > 1)) THEN WRITE (*, "(' Writing Sigma_1h.feg to show stress field; read with OrbWeave')") WRITE (21, "('Writing Sigma_1h.feg to show stress field; read with OrbWeave')") OPEN (1, FILE = 'Sigma_1h.feg') ! Unconditional OPEN, overwrites any old file. WRITE (1, "('Use with OrbWeave to see stress at node locations')") WRITE (1,"(I5, I5,' 0 30000 T')") num_nod, num_nod DO i = 1, num_nod r_ = xyz_nod(1:3, i) CALL Sigma_1h(stress_count,needles,r_,azimuth,del_az_for_90pc) CALL Lonlat_from_xyz (r_, lon, lat) WRITE (1, "(I5,2F10.4,2F10.2,' 0.0 0.0')") i, lon, lat, azimuth*deg_per_rad, del_az_for_90pc*deg_per_rad END DO WRITE (1, "(I5)") num_ele DO i = 1, num_ele WRITE (1, "(4I5)") i, node(1,i),node(2,i),node(3,i) END DO WRITE (1, "(' 0')") CLOSE (1) END IF ! Interpolate to centers of remaining elements DO l_ = 1, num_ele IF (ele_q(l_) == 0.0D0) THEN ! has no datum r_ = center(1:3,l_) CALL Sigma_1h(stress_count, needles, r_, azimuth, del_az_for_90pc) ele_azim(l_) = azimuth ele_sigma(l_) = del_az_for_90pc * 0.6079D0 ! (assumes Gaussian shape!) !----------------------------------------------------------------------- ! New lower-limit of "lowest plausible" sigma of 10 degrees, when ! input option faults_give_sigma_1h = .TRUE., imposed in Restore4+. ! (This counters the former tendency to report ridiculously-small sigmas ! as little as 1.6 degrees, in Restore3 and before.) IF (faults_give_sigma_1h) THEN ele_sigma(l_) = MAX(ele_sigma(l_), 0.174532925D0) ! END IF !----------------------------------------------------------------------- IF (del_az_for_90pc <= 0.7854D0) THEN ! +- 45 degrees @ 90%-confidence is cutoff ele_q(l_) = 1.00D0 ! (because low q was translated to increased del_az_for_90pc ! during the interpolation process) ELSE ! too uncertain to bother ele_stressed(l_) = .FALSE. END IF END IF ! no datum in this element END DO ! l_ = 1, num_ele END IF ! pass == 1 (stress needs interpolating) sum_err = 0.0D0 ! total of angular errors, in radians IF (neotec) THEN ! build toward summary stress measures (in degrees) to report from main program: s_error_degrees(0:2) = 0.0D0 ! global vector, initialized before sum over elements s_error_element_count = 0 ! initializing future denominator END IF ! Insert stress constraints (different in each refinement) DO l_ = 1, num_ele IF (ele_stressed(l_)) THEN num_stressed = num_stressed + ele_q(l_) A = 0.0D0; B = 0.0D0; C = 0.0D0; D = 0.0D0 E = 0.0D0; F = 0.0D0 r_ = center(1:3, l_) CALL Gjxy(l_, r_, G) CALL Del_Gjxy_del_thetaphi(l_, r_, dG) equat = SQRT(r_(1)**2 + r_(2)**2) theta = ATAN2(equat, r_(3)) csct = 1.0D0 / SIN(theta) tant = TAN(theta) cott = 1.0D0 / tant cos2g = COS(2. * ele_azim(l_)) sin2g = SIN(2. * ele_azim(l_)) prefix = 1.0D0 / (2.0D0 * R) DO j = 1, 3 f_(j) = prefix * ( (csct*dG(j,1,1,2) + dG(j,1,2,1) - cott*G(j,1,2))*cos2g + & & (dG(j,1,1,1) - csct*dG(j,1,2,2) - cott*G(j,1,1))*sin2g ) g_(j) = prefix * ( (csct*dG(j,2,1,2) + dG(j,2,2,1) - cott*G(j,2,2))*cos2g + & & (dG(j,2,1,1) - csct*dG(j,2,2,2) - cott*G(j,2,1))*sin2g ) END DO CALL E_rate(l_, G, dG, theta, vw, epsilon_dot) ! Require: epsilon_alpha_beta = 0 (only if element not faulting!) IF (crack_index(1, l_) == 0) THEN ! element is NOT faulting; stress-direction constraint MIGHT be appropriate... !Next, check on mu_of_r_ value; if unusually large, it might signal an exception... IF (time0 < mu_switch(l_)) THEN mu_of_r_ = mu_element(1, l_) ELSE mu_of_r_ = mu_element(2, l_) END IF IF (mu_of_r_ <= (3.0D0 * mu_)) THEN ! normal case of ordinary unfaulted continuum; OK to consider azimuth constraint... ! ---------------------------------------------------------------------------------------------------- ! Note: Very large values of mu_of_r_ (from mu_element(1:2, l_)) indicate that any ! stress-direction constraint is NOT appropriate for this element. ! The large value may have been set by Unpin_Plate_Corners() to indicate that this element ! should be considered presumptively-faulted, even though it lacks any fault segments. ! In such a case, the presumption of isotropy that underlies the stress-azimuth constraint would be incorrect. ! Also, it would be unfortunate to inadvertently overrule the desired weakness ! with stress-direction-related stiffness! ! ---------------------------------------------------------------------------------------------------- radius = SQRT(epsilon_dot(2)**2 + (0.50D0*(epsilon_dot(1)-epsilon_dot(3)))**2) radius = MAX(radius, xi_) ! global parameter sigma_ = 2.0D0 * ele_sigma(l_) * radius sigma_ = MAX(sigma_, floor) prefix = ele_q(l_) * (a_(l_) / A_0) / (sigma_**2) CALL Add_datum(prefix, f_, g_, 0.0D0, A, C, D, E, F) END IF ! element has modest mu_of_r_, in the normal range END IF ! element is NOT faulting ! assess angular errors in sigma_1h azimuth = 0.50D0 * ATan2F(epsilon_dot(2), 0.50D0*(epsilon_dot(3)-epsilon_dot(1))) error = azimuth - ele_azim(l_) error = MIN(MOD(error + 6.2832D0, 3.1416D0), MOD(-error + 6.2832D0, 3.1416D0)) sum_err = sum_err + error * ele_q(l_) IF (neotec) THEN ! build toward summary stress-error statistics in degrees, to report at end of Restore run: s_error_element_count = s_error_element_count + 1 s_error_degrees(0) = MAX(s_error_degrees(0), (ABS(error) * deg_per_rad)) s_error_degrees(1) = s_error_degrees(1) + (ABS(error) * deg_per_rad) s_error_degrees(2) = s_error_degrees(2) + (ABS(error) * deg_per_rad)**2 END IF IF (crack_index(1, l_) == 0) THEN ! element is NOT faulting; boxed(l_) MIGHT be set to TRUE... !Next, check on mu_of_r_ value; if unusually large, it might signal an exception... IF (time0 < mu_switch(l_)) THEN mu_of_r_ = mu_element(1, l_) ELSE mu_of_r_ = mu_element(2, l_) END IF IF (mu_of_r_ <= (3.0D0 * mu_)) THEN ! normal case of ordinary unfaulted continuum; OK to consider possible boxing... ! ---------------------------------------------------------------------------------------------------- ! Note: Very large values of mu_of_r_ (from mu_element(1:2, l_)) indicate that boxing is not appropriate. ! The large value may have been set by Unpin_Plate_Corners() to indicate that this element ! should be considered presumptively-faulted, even though it lacks any fault segments. ! In such a case, the presumption of isotropy that underlies boxing would be incorrect. ! Also, it would be unfortunate to inadvertently overrule the desired weakness ! with xi_-related boxing stiffness! ! ---------------------------------------------------------------------------------------------------- ! Test for: epsilon_alpha_alpha < epsilon_beta_beta (?) IF (((epsilon_dot(3) - epsilon_dot(1))*cos2g + 2.0D0 * epsilon_dot(2) * sin2g) < 0.0D0) boxed(l_) = .TRUE. END IF ! mu_of_r_ is NOT unusually large END IF ! element is NOT faulting IF (boxed(l_)) THEN ! Needs constraint to enforce correct sense num_boxed = num_boxed + ele_q(l_) prefix = 1.0D0 / R DO j = 1, 3 f_(j) = prefix * ((csct*dG(j,1,2,2)+G(j,1,1)*cott-dG(j,1,1,1)) * cos2g + & & (csct*dG(j,1,1,2)+dG(j,1,2,1)-G(j,1,2)*cott) * sin2g) g_(j) = prefix * ((csct*dG(j,2,2,2)+G(j,2,1)*cott-dG(j,2,1,1)) * cos2g + & & (csct*dG(j,2,1,2)+dG(j,2,2,1)-G(j,2,2)*cott) * sin2g) END DO prefix = ele_q(l_) * (a_(l_) / A_0) / (0.83D0 * xi_)**2 CALL Add_datum(prefix, f_, g_, xi_, A, C, D, E, F) END IF ! boxed(l_): sense constraint needed CALL Plug_in_33 (l_,A,B,C,D,E,F) ! add element matrix,vector to global END IF ! ele_stressed(l_) END DO ! l_ = 1, num_ele IF (neotec) THEN ! finalize 3 measures of overall error in enforcing stress-direction constraints: IF (s_error_element_count > 0) THEN !s_error_degrees(0) holds worst-case; no division for this one s_error_degrees(1) = s_error_degrees(1) / s_error_element_count s_error_degrees(2) = SQRT(s_error_degrees(2) / s_error_element_count) ELSE s_error_degrees(0:2) = 0.0D0 ! (procedurally defined, but logically undefined) END IF END IF IF (pass > 1) THEN ! Print line of convergence(?)-report table, using saved values from LAST pass-thru, and the latest "error" from "sum_err": IF (num_stressed > 0.0D0) THEN error = deg_per_rad * sum_err / num_stressed ELSE error = 0.0D0 END IF WRITE (*, "(' ', 18X, I10, F8.5, ES9.2, F8.2, '%', F7.2, '%', F11.2)") & & last_pass, last_dV_frac, last_new_V, last_stressed_frac, last_boxed_frac, error WRITE (21,"(19X, I10, F8.5, ES9.2, F8.2, '%', F7.2, '%', F11.2)") & & last_pass, last_dV_frac, last_new_V, last_stressed_frac, last_boxed_frac, error END IF ! pass > 1; line of convergence-table report is ready for printing. END IF ! stress_now ! Scale linear system (to prevent overflow/underflow) big_one = MAXVAL(ABCD) factor = 1.0D0 / big_one ABCD = factor * ABCD ! scale the coefficients EF = factor * EF ! scale the RHS forcing vector the same way ! Impose boundary conditions, *without* trying to maintain symmetry ! (which is *NOT* assumed by dgbsv of LAPACK portion of MKL): DO m = 1, bcs_count ! South (theta) component of velocity i = 2 * boundary_node(m) - 1 ! logical row to be replaced j1 = MAX(1, i - nCodiagonals) j2 = MIN(nRank, i + nCodiagonals) DO j = j1, j2 it = iDiagonal + i - j ABCD(it, j) = 0.0D0 END DO ABCD(iDiagonal, i) = 1.0D0 ! put 1 on diagonal in this row #i EF(i, 1) = condition(1, m) ! put BC velocity component in rhs ! - - - - - - - - - - - - - - - - - - - - - - ! East (phi) component of velocity i = 2 * boundary_node(m) ! logical row to be replaced j1 = MAX(1, i - nCodiagonals) j2 = MIN(nRank, i + nCodiagonals) DO j = j1, j2 it = iDiagonal + i - j ABCD(it, j) = 0.0D0 END DO ABCD(iDiagonal, i) = 1.0D0 ! put 1 on diagonal in this row #i EF(i, 1) = condition(2, m) ! put BC velocity component in rhs END DO ! on boundary node index m !USEing LAPACK portion of MKL: !Compute the solution to the system of linear equations with a band coefficient matrix A and multiple right-hand sides ! (or, in this case, only a single right-hand side). !The manual page is here: https://software.intel.com/en-us/node/468882#02FA8CF5-DE40-4016-BCD2-8ACFF4236AAD !CALL dgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) !Arguments: ! INTEGER :: n ! The rank of the coefficient matrix (before special band storage); the number of degrees-of-freedom to be solved for; ! in this application, that the number of horizontal velocity components, which is twice the number of nodes in the .FEG. ! INTEGER :: kl ! The number of sub-diagonals in the band of A; here, set equal to nCoDa. ! INTEGER :: ku ! The number of super-diagonals in the band of A; here, set equal to nCoDa. ! INTEGER :: nrhs ! The number of right-hand-side forcing vectors; here, only 1. ! REAL*8, DIMENSION(ldab, *) :: ab ! The coefficient matrix A in special MKL-style banded storage mode (see online manual). ! See below for minimum first dimension; 2nd dimension must be at least n. ! INTEGER :: ldab ! The leading dimension of compressed-matrix ab (see above); must be at least (2 * kl + ku + 1). ! REAL*8, DIMENSION(ldb, *) :: b ! The right-hand-side forcing vector(s). 1st dimension is at least n. 2nd dimension is 1 in this application. ! INTEGER, DIMENSION(n) :: ipiv ! Some workspace necessary for the solution process. On output, records the pivoting performed. ! INTEGER :: info ! output; marker of success or failure during execution of dgbsv. ! NOTE that the solution vector(s) over-write the original forcing vectors in b. ! NOTE that banded coefficient matrix ab is destroyed during the solution process. ALLOCATE ( ipiv(nDOF) ) CALL dgbsv(nRank, nCodiagonals, nCodiagonals, 1, ABCD, nKRows, ipiv, EF, nRank, info) IF (info /= 0) THEN WRITE (*, "(' ERROR: info = ',I12,' in CALL to dgbsv.')") info WRITE (21, "('ERROR: info = ',I12,' in CALL to dgbsv.')") info CALL Pause() STOP END IF DEALLOCATE ( ipiv ) IF (passes > 0) THEN ! Compare new with old solution sum_base_o = 0.0D0 sum_base_n = 0.0D0 sum_diff = 0.0D0 DO i = 1, num_nod twoi = 2 * i wo = vw(twoi) wn = EF(twoi, 1) twoi = twoi - 1 vo = vw(twoi) vn = EF(twoi, 1) sum_base_o = sum_base_o + vo**2 +wo**2 sum_base_n = sum_base_n + vn**2 +wn**2 sum_diff = sum_diff + (vn - vo)**2 + (wn - wo)**2 END DO new_V = SQRT(sum_base_n/num_nod) divisor = SQRT(MAX(sum_base_o,sum_base_n)/num_nod) difference = SQRT(sum_diff/num_nod) IF (divisor > 0.0D0) THEN dV_frac = difference / divisor ELSE dV_frac = 0.0D0 END IF IF (stress_now) THEN stressed_frac = (100.0D0 * num_stressed) / num_ele boxed_frac = (100.0D0 * num_boxed) / num_ele IF (num_stressed > 0.0D0) THEN error = deg_per_rad * sum_err / num_stressed ELSE error = 0.0D0 END IF !------------------------------------------------------------------------------------------ !N.B. In versions 1~3 of Restore, the following (commented-out) WRITEs occurred here: !WRITE (*, "(' ',18X,I10,F8.5,1P,E9.2,0P,F8.2,'%',F7.2,'%',F11.2)") & ! & pass-1, dV_frac, new_V, stressed_frac, boxed_frac, error !WRITE (21,"(19X,I10,F8.5,1P,E9.2,0P,F8.2,'%',F7.2,'%',F11.2)") & ! & pass-1, dV_frac, new_V, stressed_frac, boxed_frac, error !However, these gave a very confusing report, because the "error" in stress-direction !was always the error BEFORE this velocity-solution; that is, the error of the !PREVIOUS velocity solution. The error corresponding to THIS velocity solution !will not be known until we re-enter many_passes: DO for the next loop, and compute it. !Therefore, I now (Restore4+) produce a less-confusing report by simply !saving the first 5 columns now, to be WRITten later when the appropriate "error" is known: last_pass = pass - 1 ! 0, 1, 2, 3, ... last_dV_frac = dV_frac last_new_V = new_V last_stressed_frac = stressed_frac last_boxed_frac = boxed_frac !------------------------------------------------------------------------------------------ ELSE WRITE (*, "(' ',18X,I10,F8.5,1P,E9.2)") & & pass-1, dV_frac, new_V WRITE (21,"(19X,I10,F8.5,1P,E9.2)") & & pass-1, dV_frac, new_V END IF ! stress_now END IF ! passes > 1 (or 0?) ! Transfer solution to velocity supervector DO i = 1, nDOF vw(i) = EF(i, 1) END DO IF ((passes > 1).AND.(dV_frac < 0.00001D0)) EXIT many_passes END DO many_passes ! pass = 1, passes IF (stress_now) THEN !Print final line of convergence(?) report table, even though it will be lacking mean stress-direction "error": WRITE (*, "(' ', 18X, I10, F8.5, ES9.2, F8.2, '%', F7.2, '%')") & & last_pass, last_dV_frac, last_new_V, last_stressed_frac, last_boxed_frac WRITE (21,"(19X, I10, F8.5, ES9.2, F8.2, '%', F7.2, '%')") & & last_pass, last_dV_frac, last_new_V, last_stressed_frac, last_boxed_frac DEALLOCATE ( needles ) END IF END SUBROUTINE Solve_for_vw SUBROUTINE Step_aside (b_, gamma_, new_vec) IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: b_ REAL*8, INTENT(IN) :: gamma_ REAL*8, DIMENSION(3), INTENT(OUT) :: new_vec ! gives position (Cartesian unit vector) close to b_, ! but displaced toward gamma_ (in radians, clockwise from N) REAL*8, DIMENSION(3) :: offset, Phi, Theta, v1 REAL*8 :: radians = 0.002D0 ! offset ~13 km on Earth CALL Local_Phi (b_, Phi) CALL Local_Theta(b_, Theta) offset = Phi * SIN(gamma_) - Theta * COS(gamma_) v1 = b_ + (offset * radians) CALL Unitise(v1, new_vec) END SUBROUTINE Step_aside SUBROUTINE Test_file (name, unit) ! Tests existing(?) file for validity by briefly opening and then closing IMPLICIT NONE CHARACTER(*) :: name INTEGER :: unit, open_status OPEN (unit, file = name, STATUS = 'OLD', IOSTAT = open_status) IF (open_status == 0) THEN CLOSE (unit) RETURN ELSE WRITE (*, "(' Error: Following filename is invalid or not found:'/' ',A)") TRIM(name) WRITE (21,"('Error: Following filename is invalid or not found:'/A)") TRIM(name) CALL Pause() STOP END IF END SUBROUTINE Test_file SUBROUTINE Traceback () ! The sole function of this unit is to cause a traceable error, ! so that the route into the unit that called it is also traced. ! This unit is a good place to put a breakpoint while debugging! ! The intentional error must NOT be detected during compilation, ! but MUST cause a traceable error at run-time. ! If this routine has any error detected during compilation, ! then change its code to cause a different intentional error. IMPLICIT NONE CHARACTER*80 instring INTEGER :: i REAL*8, DIMENSION(3) :: y WRITE (*,"(' -----------------------------------------------------')") WRITE (*,"(' Traceback was called to execute an intentional error:')") WRITE (*,"(' An array subscript will be intentionally out-of-range.')") WRITE (*,"(/' After you read this notice, press [Enter]' & & /' to stop the program (no other option): '\)") READ (*,"(A)") instring DO i = 1, 4 y(i) = 1.0D0 * i END DO CALL Pause() STOP END SUBROUTINE Traceback SUBROUTINE Unitise (b_, unit_vec) IMPLICIT NONE REAL*8, DIMENSION(3), INTENT(IN) :: b_ REAL*8, DIMENSION(3), INTENT(OUT) :: unit_vec REAL*8 :: length length = Magnitude (b_) IF (length /= 0.0D0) THEN unit_vec(1) = b_(1) / length unit_vec(2) = b_(2) / length unit_vec(3) = b_(3) / length ELSE unit_vec(1) = 1.0D0 unit_vec(2) = 0.0D0 unit_vec(3) = 0.0D0 END IF END SUBROUTINE Unitise SUBROUTINE Unloop_Trace (i, debug) ! Scan for cases where a trace wanders from element "a" briefly ! into element "b" and then back into "a". Pull offending points ! into element "a", changing both external and internal ! coordinates of these points. This is necessary to prevent ! serious problems with fault segmentation later !(such as a segment which begins and ends on the same element ! side, thus failing to isolate any of the three corner nodes). IMPLICIT NONE INTEGER, INTENT(IN) :: i ! trace index LOGICAL, INTENT(IN) :: debug ! controls WRITE's INTEGER :: back1, back2, element, j, jt, j1, j2, lastel REAL*8 :: s1, s2, s3 REAL*8, DIMENSION(3) :: s, tv j1 = trace_loc(1, i) j2 = trace_loc(2, i) IF ((j1 > 0) .AND. (j2 > j1+1)) THEN ! trace has > 2 points lastel = -1 ! deliberately invalid initial values back1 = -1 back2 = -1 DO j = j1, j2 element = trace_is(j)%element IF (element /= lastel) THEN back2 = back1 ! cascade the memory (losing back2) back1 = lastel IF (element == back2) THEN ! MAY be crossing same side twice IF ((element > 0).AND.(back1 > 0)) THEN !Case where both are real elements; definately needs fixing; !move points from back1 to back2 == element. jt = j - 1 fix_back1: DO IF (trace_is(jt)%element == back1) THEN IF (.NOT.banished_DIG_point(jt)) THEN ! Make NO changes to banished points, whose %is = (0, 0.0D0, 0.0D0, 0.0D0)! tv(1:3) = trace(1:3, jt) ! uncorrected location trace_is(jt)%element = element ! assign new element !find (s1, s2, s3) in new element (will not be in bounds): CALL Dumb_s123 (xyz_nod = xyz_nod, element = element, vector = tv, s1 = s(1), s2 = s(2), s3 = s(3)) CALL Pull_in (s) ! correct s1, s2, s3 to fall on bounds trace_is(jt)%s(1) = s(1) ! record corrected s1, s2, s3 trace_is(jt)%s(2) = s(2) trace_is(jt)%s(3) = s(3) CALL Interpolate (trace_is(jt), tv) ! correct the position trace(1:3, jt) = tv(1:3) ! record corrected position END IF ! .NOT.banished_DIG_point(jt) jt = jt - 1 ! prepare to loop ELSE ! we are past the defective loop EXIT fix_back1 END IF END DO fix_back1 back1 = -1 ! reset to a state of innocence back2 = -1 lastel = -1 ELSE IF (element > 0) THEN !Element is real, but back1 was 0 == outside grid. !I think that no action is required; Def_seg can handle this. ELSE !Element = 0 (outside), but back1 was inside. !I think that no action is required; Def_seg can handle this. END IF ! inside/inside, outside/inside, or inside/outside END IF ! element == back2 END IF ! element /= lastel ! prepare to loop lastel = element END DO ! all points in trace END IF ! length of trace exceeds two points END SUBROUTINE Unloop_Trace SUBROUTINE Unpin_Plate_Corners() ! Improvement added 2020.07.01: ! Uses new LOGICAL*1 arrays edge_element(ele#)? and ! plate_boundary(trace#)?, together with *latest update of fault segmentation*, ! to prevent the F-E grid from being "torqued" or "squashed" ! by strong & unwanted continuum connections between adjacent plates, ! near places where a plate-boundary fault trace enters/leaves the F-E grid area. ! It does this by taking two separate, complementary actions: ! (1) Increases mu_ *10.0D0 in such edge_element's with plate_boundary fault(s); and ! (2) Increases total of seg_kappa_'s to 1.0D0 for ! the (one? OR two?) fault segment(s) in that element. ! N.B. In the case of two fault segments, Coordinate_Segments() may have already ! made this second correction; however, this routine also enforces it. !====================================================================================== ! CAUTION: The logic of this fix assumes that plate-boundary fault traces that cut ! the edges of the grid are digitized rather finely, with *AT LEAST ONE ! DIGITIZATION POINT IN EVERY ELEMENT*. If such faults are digitized with ! very few (e.g., only 2) points, such that no point falls in the current ! boundary element, then the artificial gap(s) in the plate-boundary will ! be wider than the boundary elements, and the fix programmed here will fail! ! So, always apply fine digitization (and/or DIG-utility program SubDIGitise) ! to such fault traces! (This can be done to either present or paleo traces.) ! Continuing this thought, we can now see that it is bad grid-editing practice ! (in OrbWin) to have any plate-boundary fault entering the model through ! the narrow/sharp/"knife-edge" part of an edge-element; it is far too likely ! that no digitization point (and thus no segment) will be detected in such ! a very short traverse. It is far better to have the plate-boundary fault ! enter the model through the central or the "fat" part of an edge-element. ! Final bit of advice: This edge-element, where the plate-boundary fault ! enters/leaves the model area, should not be tiny! Make it good-sized! !====================================================================================== IMPLICIT NONE ! all variables and arrays are globals INTEGER :: goal, hot_seg_count, hot_segment_1, hot_segment_2, i, j, l_, n, trace_of_this_seg INTEGER, DIMENSION(1) :: result_of_MINLOC ! This seemingly unnecessary row-index is required by syntax of MINLOC. LOGICAL :: original_edger, real_edger, sliced REAL*8 :: kappa_total, kappa_factor REAL*8, DIMENSION(3) :: r2_to_next !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF (f_dig_count == 0) RETURN ! No need for corrections; also, plate_boundary(trace#) is undefined! DO l_ = 1, num_ele IF (edge_element(l_)) THEN ! Note that we only need to examine a modest # of elements (e.g., 800?); not num_ele = ~40,000 ! sliced = .FALSE. ! just initializing; search below will decide ... hot_seg_count = 0 ! ditto ... hot_segment_1 = 0 ! ditto ... hot_segment_2 = 0 ! ditto ... !Look for any fault segment(s) that lie in this element: scanning_segments: DO i = 1, seg_count IF (seg_def(2, i) == l_) THEN ! segment #i is in this element, #l_ trace_of_this_seg = seg_def(1, i) IF (plate_boundary(trace_of_this_seg)) THEN sliced = .TRUE. hot_seg_count = hot_seg_count + 1 IF (hot_seg_count == 1) THEN hot_segment_1 = i ELSE IF (hot_seg_count == 2) THEN hot_segment_2 = i END IF IF (hot_seg_count == 2) EXIT scanning_segments END IF END IF ! segment #i is in this element, #l_ END DO scanning_segments ! i = 1, seg_count IF (sliced) THEN ! plate_boundary fault trace(s) (in 1 or 2 segments) cut(s) through this element !-------------------------------------------------------------------------------------------------------------------- !CORRECTIVE ACTION #1: !Weaken this element: mu_element(1, l_) = MAX(mu_element(1, l_), (10.0D0 * mu_)) mu_element(2, l_) = MAX(mu_element(2, l_), mu_element(1, l_)) !Further characterize this element: original_edger = (neighbor(1, l_) == 0).OR.(neighbor(2, l_) == 0).OR.(neighbor(3, l_) == 0) IF (.NOT.original_edger) THEN ! The current element has only 1 node on the model perimeter, not a full side. ! That is, in routine Find_s1s2s3, it was one that was added through use of edge_question(). ! However, since execution came here, we know that it has at least one fault-trace ! digitization point, and at least one plate-boundary fault segment. ! Now, we want to provide for the possibility that the adjacent edge-element may ! have been too narrow to capture ANY trace-digitization point(s), and thus too narrow ! to catch ANY plate-boundary fault segment(s). We will extend the weakness of the current ! element to one of its neighbors, based two decision rules: ! (a) The neighbor must be a "real" edger, with a full side along the perimeter. ! This narrows the possibilities to either 1 or 2 out of the original 3 neighbors. ! (b) The targeted neighbor should be the closest one, as measured by centroid-to- ! centroid distance metric (in radians-squared). DO j = 1, 3 ! 3 neighbors of element l_ n = neighbor(j, l_) ! element# of potential candidate r2_to_next(j) = (center(1, n) - center(1, l_))**2 + (center(2, n) - center(2, l_))**2 + (center(3, n) - center(3, l_))**2 !Since "center" contains uvecs, this result is a squared-distance, in units of radians-squared. real_edger = (neighbor(1, n) == 0).OR.(neighbor(2, n) == 0).OR.(neighbor(3, n) == 0) ! Is the target element a "real" edger? IF (.NOT.real_edger) r2_to_next(j) = 4.0D0 ! this is a prohibitive, "huge" distance; antipodal! Will not attract MINLOC. END DO ! j = 1, 3 result_of_MINLOC = MINLOC(r2_to_next) goal = result_of_MINLOC(1) ! its ONLY element, actually; value will be 1, 2, or 3 goal = neighbor(goal, l_) ! "goal" is now the element number of the element to be weakened. mu_element(1, goal) = MAX(mu_element(1, goal), (10.0D0 * mu_)) mu_element(2, goal) = MAX(mu_element(2, goal), mu_element(1, l_)) !Note that this expansion of weakening to element #goal may be unnecessary and redundant !if element #goal ALSO includes fault-trace digitization point(s) and thus segment(s). !However, it does no harm in that case. END IF ! .NOT.original_edger !-------------------------------------------------------------------------------------------------------------------- !CORRECTIVE ACTION #2: IF (hot_seg_count == 1) THEN IF (hot_segment_1 > 0) seg_kappa_(hot_segment_1) = 1.0D0 ! I expect this to always be true. Test is just for safety. ELSE IF (hot_seg_count == 2) THEN kappa_total = seg_kappa_(hot_segment_1) + seg_kappa_(hot_segment_2) IF (kappa_total > 0.0D0) THEN ! more-common case kappa_factor = 1.0D0 / kappa_total seg_kappa_(hot_segment_1) = kappa_factor * seg_kappa_(hot_segment_1) seg_kappa_(hot_segment_2) = kappa_factor * seg_kappa_(hot_segment_2) ELSE ! kappa_total <= 0.0D0; a known special-case: ! This can happen when a "knee joint" connects two segments (in one element) ! that both enter/leave through the same element side. ! In that case, Coordinate_Segments() may have already set both ! seg_kappa_ values to 0.0D0. Leave them alone! No action required here. END IF ! kappa_total is positive, or not(???) END IF ! hot_seg_count == 1, or 2? !-------------------------------------------------------------------------------------------------------------------- !NOTE that corrective action #2, if successful, makes corrective action #1 less important. END IF ! plate_boundary fault trace cuts through this element END IF ! edge_element(l_)? END DO ! l_ = 1, num_ele END SUBROUTINE Unpin_Plate_Corners SUBROUTINE Update_before_FEG() ! Determines internal coordinates of all nodes in the before.FEG grid ! (preferring currently-unfaulting elements, whenever possible), ! to allow these "before" positions to be integrated backward in time. ! Whenever any element midpoint (or node) of the before.FEG falls into a faulting eINElement ! of the currently-loaded temporary FEG file, ! sets all associated elements of the before.FEG to have before_and_after_unfaulted(ele) = .FALSE. ! ALSO provides the routine-maintenance operation of removing any nodes of before.FEG !(and also the topologically-identical after.FEG) which have fallen outside the currently-loaded grid, ! and also removes any associated elements from both grids. ! Note that this routine should only be called IF(paleotec). IMPLICIT NONE INTEGER :: best_match, i, i_match, j, k, k1, k2, k3, l_, n INTEGER :: count1, count2, count3, count4, count5 ! for insight, to help debugging LOGICAL :: easy_match REAL*8 :: best_r2_radian2, delta_degrees, r2_in_radian2, s1, s2, s3, sum_delta_degrees, & & tolerance_in_degrees, tolerance_in_radian2 REAL*8, DIMENSION(3) :: tv, tv1, tv2, tv3, tvmean, tvmid ! Check all mid-points of elements of the before.FEG, because ! we will try (below) to assign all 3 corner nodes to non-faulting elements, ! we might otherwise miss the BASIC FACT that a fault runs through the common element that they define! IF (grid_to_load_this_timestep(n_) > 0) THEN ! We just loaded a new grid; time to find internal coordinates of each before.FEG node: DO j = 1, before_and_after_numel !Compute midpoint of element #j of before.FEG: k1 = before_and_after_node(1, j) k2 = before_and_after_node(2, j) k3 = before_and_after_node(3, j) tv1(1:3) = before_node_uvec(1:3, k1) tv2(1:3) = before_node_uvec(1:3, k2) tv3(1:3) = before_node_uvec(1:3, k3) tvmean(1) = (tv1(1) + tv2(1) + tv3(1)) / 3.0D0 tvmean(2) = (tv1(2) + tv2(2) + tv3(2)) / 3.0D0 tvmean(3) = (tv1(3) + tv2(3) + tv3(3)) / 3.0D0 CALL DMake_uvec(tvmean, tvmid) !Determine its internal coordinates (and save the element# l_): l_ = 1 ! (because zero has special meaning to Internal) CALL Internal (tvmid, l_, s1, s2, s3) before_FEG_midpoint_current_l_(j) = l_ ! save for use in future timesteps of the same chapter (same temporary FEG). END DO ! j = 1, before_and_after_numel END IF ! (grid_to_load_this_timestep(n_) > 0), so we just loaded a new grid; it was time to find internal coordinates of each before.FEG element midpoint. count1 = 0 count2 = 0 DO j = 1, before_and_after_numel l_ = before_FEG_midpoint_current_l_(j) !check LOGICAL status of this current element (#l_), and decide what to do with element #j of the before_and_after FEGs: IF (.NOT.current_element_is_unfaulted(l_)) THEN ! current temporary grid IS FAULTING at midpoint of this element #j of before.FEG! IF (before_and_after_unfaulted(j)) timestep_first_faulted(j) = -n_ ! record this memo for debugging purposes (using - sign to mark which code block negated it). before_and_after_unfaulted(j) = .FALSE. count1 = count1 + 1 ELSE count2 = count2 + 1 END IF ! current element (containing midpoint of this element of the before.FEG) is faulting END DO ! j = 1, before_and_after_numel (checking mid-points for faulting?) !WRITE (*, "(' Update_before_FEG: midpoints: ', I8, ' faulting, and ', I8, ' not.')") count1, count2 !WRITE (21, "('Update_before_FEG: midpoints: ', I8, ' faulting, and ', I8, ' not.')") count1, count2 !Find internal coordinates (in current, temporarily-loaded FEG) for all the nodes of before.feg: IF (grid_to_load_this_timestep(n_) > 0) THEN ! We just loaded a new grid; time to find internal coordinates of each before.FEG node: tolerance_in_degrees = 0.00300 ! {=~= 300 m} !====================================================================== ! NOTES on this tolerance_in_degrees value {local in Update_before_FEG}: ! The SOLE purpose of this tolerance is to allow backwards-integrated ! positions of nodes in before.FEG to "lock on to" essentially-identical ! nodes of the current, temporarily-loaded "chapter" FEG, despite small ! differences in geographic coordinates, so that maps of net strain and ! net rotation produced by RetroMap4 can be as fully-colored as ! possible. ! There are 3 possible causes for these small differences in (Elon, Nlat): ! (1) Rounding errors during manual editing with OrbWin & OrbNumber; ! however, these are typically not more than 0.00002 degrees. ! (2) Step-by-step "chapter" runs of Restore4 are not solving EXACTLY ! the same problem as the final full-iteration run, because of ! minor rounding of geologic constraint data during output/input. ! For example, in 2018.09 this problem was found to amount to ! 0.00200 ~ 0.00400 degrees (i.e., 200 ~ 400 m) in SW CA at 5.2 Ma. ! Planned future improvements to Restore4 should reduce this(?). ! (3) The user of Restore4 is trying to "get away with" re-using a set ! of manually-edited chapter FEGs, even after making some change(s) ! to the input data or program parameters. The size of such effects ! is unbounded; check that fault traces and fault corridors ! do not drift out of alignment! ! If tolerance_in_degrees is too small, then many nodes of before.FEG ! will fail to lock-on at the time-boundaries between chapters when ! new temporary FEGs are loaded, and this raises the risk that they ! will fall into faulted elements of the current temporary FEG, ! and thus the elements in before.FEG which they define will ! also be marked as "faulted" and thus will be omitted from ! RetroMap4 plots of strain & rotation. ! For example, you may notice that rows of elements NEXT TO ! any fault-corridor row of elements are also omitted from plots, ! so that all strain and rotation information is missing from ! critical tectonic areas of closely-spaced faults. ! If tolerance_in_degrees is too large, there is a danger that nodes ! in before.FEG could erroneously lock-on to hand-adjusted node ! positions which are NOT equivalent. This would produce some ! local bad values of strain & rotation for certain elements ! in RetroMap4 plots. (Perhaps these could be detected due to ! element-to-element inconsistencies?) ! PB 2018.09.21 !====================================================================== tolerance_in_radian2 = (tolerance_in_degrees * radians_per_degree)**2 count3 = 0 count4 = 0 count5 = 0 sum_delta_degrees = 0.0D0 DO i = 1, before_and_after_numnod tv = before_node_uvec(1:3, i) best_match = 0; best_r2_radian2 = 4.04D0 ! (just initializing, before search) DO j = 1, num_nod r2_in_radian2 = (tv(1) - xyz_nod(1, j))**2 + (tv(2) - xyz_nod(2, j))**2 + (tv(3) - xyz_nod(3, j))**2 IF (r2_in_radian2 < best_r2_radian2) THEN ! got a better candidate than we had before; remember it! best_r2_radian2 = r2_in_radian2 best_match = j END IF ! close enough END DO ! j = 1, num_nod IF (best_r2_radian2 <= tolerance_in_radian2) THEN ! got a match! easy_match = .TRUE. i_match = best_match delta_degrees = SQRT(best_r2_radian2) * degrees_per_radian sum_delta_degrees = sum_delta_degrees + delta_degrees ELSE ! closest node is too far away to match easy_match = .FALSE. i_match = 0 END IF ! best possible match is good-enough, or not IF (easy_match) THEN ! find which element contains node #i_match (at which corner?) count3 = count3 + 1 l_ = 0 ! but we expect this to be replaced, in next paragraphs... !FIRST TIME, try to place this before node in an unfaulted element: linking: DO j = 1, num_ele IF (current_element_is_unfaulted(j)) THEN IF (i_match == node(1, j)) THEN l_ = j s1 = 1.0D0 s2 = 0.0D0 s3 = 0.0D0 EXIT linking ELSE IF (i_match == node(2, j)) THEN l_ = j s1 = 0.0D0 s2 = 1.0D0 s3 = 0.0D0 EXIT linking ELSE IF (i_match == node(3, j)) THEN l_ = j s1 = 0.0D0 s2 = 0.0D0 s3 = 1.0D0 EXIT linking END IF END IF ! current_element_is_unfaulted(j) END DO linking ! j = 1, num_ele !SECOND TIME; if needed, redo the association WITHOUT the restriction of only matching to unfaulting elements: IF (l_ == 0) THEN ! try again... relinking: DO j = 1, num_ele IF (i_match == node(1, j)) THEN l_ = j s1 = 1.0D0 s2 = 0.0D0 s3 = 0.0D0 EXIT relinking ELSE IF (i_match == node(2, j)) THEN l_ = j s1 = 0.0D0 s2 = 1.0D0 s3 = 0.0D0 EXIT relinking ELSE IF (i_match == node(3, j)) THEN l_ = j s1 = 0.0D0 s2 = 0.0D0 s3 = 1.0D0 EXIT relinking END IF END DO relinking ! j = 1, num_ele END IF ! (l_ == 0) after first try (using only unfaulted elements) IF (l_ == 0) THEN ! something went wrong; use backup plan. (This branch should not occur...) count4 = count4 + 1 ! (In fact, test runs never showed any use of this branch.) l_ = 1 ! (because zero has special meaning to Internal) CALL Internal (tv, l_, s1, s2, s3) END IF ELSE ! (.NOT.easy_match); must look in element interiors... count5 = count5 + 1 l_ = 1 ! (because zero has special meaning to Internal) CALL Internal (tv, l_, s1, s2, s3) END IF before_node_is(i)%element = l_ before_node_is(i)%s(1) = s1 before_node_is(i)%s(2) = s2 before_node_is(i)%s(3) = s3 ! N.B. Note that these internal coordinates (l_, s1, s2, s3) of before.FEG node #i refer to the currently-loaded temporary FEG. ! - - - - - - - - - - - - - - - - - - - - - - END DO ! i = 1, before_and_after_numnod !WRITE (*, "(' Update_before_FEG: corners: ', I8, ' easy_match-ed;', I8, ' thru Internal.')") count3, count5 !WRITE (21, "('Update_before_FEG: corners: ', I8, ' easy_match-ed;', I8, ' thru Internal.')") count3, count5 IF (count3 > 0) THEN delta_degrees = sum_delta_degrees / count3 !WRITE (*, "(' Update_before_FEG: corners: Mean angle of easy_match was', F8.5, ' degrees.')") delta_degrees !WRITE (21, "('Update_before_FEG: corners: Mean angle of easy_match was', F8.5, ' degrees.')") delta_degrees END IF END IF ! (grid_to_load_this_timestep(n_) > 0), so we just loaded a new grid; and it was time to find internal coordinates of each before.FEG node. !Test whether any nodes of before.FEG are in a currently-faulting element of the currently-loaded temporary FEG; !if so, mark associated elements of before_and_after FEG with before_and_after_unfaulted(ele) = .FALSE. {even if FALSE already}. !NOTE that this code has to be repeated EACH timestep, because fault segmentation changes and therefore !current_element_is_unfaulted() changes; also faults become active/inactive as geologic time passes !(even though the internal coordinates of before.FEG nodes in the currently-loaded temporary grid may not change). DO i = 1, before_and_after_numnod l_ = before_node_is(i)%element ! Set before_and_after_unfaulted(element) = .FALSE. for any element OF THE BEFORE.FEG which has node(s) ! falling into a faulting element of the current, temporary FEG: IF (.NOT.current_element_is_unfaulted(l_)) THEN ! current element IS FAULTING; node #i of before.FEG is therefore contaminated! DO j = 1, before_and_after_numel DO k = 1, 3 IF (before_and_after_node(k, j) == i) THEN ! node #i of the before.FEG was used to define this element IF (before_and_after_unfaulted(j)) timestep_first_faulted(j) = n_ ! record this memo for debugging purposes. before_and_after_unfaulted(j) = .FALSE. END IF END DO END DO END IF ! current element (containing node #i of the before.FEG) is faulted END DO ! i = 1, before_and_after_numnod !Check for nodes of before.FEG which fell out of the area of the current temporary grid, and eliminate them !from all before_and_after arrays! i = 1 compacting_nodes: DO IF (before_node_is(i)%element > 0) THEN ! no problem i = i + 1 ! prepare to loop ELSE ! eliminate this node from all arrays and from count! !Note that i is not incremented in this branch; must check the NEW #i on the next loop-through. IF (i < before_and_after_numnod) THEN DO j = i, (before_and_after_numnod - 1) before_node_is(j) = before_node_is(j+1) before_node_uvec(1:3, j) = before_node_uvec(1:3, j+1) after_node_uvec(1:3, j) = after_node_uvec(1:3, j+1) before_eqcm(1:4, j) = before_eqcm(1:4, j+1) after_eqcm(1:4, j) = after_eqcm(1:4, j+1) END DO ! j = i, before_and_after_numnod -1 END IF ! i < before_and_after_numnod before_and_after_numnod = before_and_after_numnod - 1 !adjust values in before_and_after_node DO j = 1, before_and_after_numel DO k = 1, 3 n = before_and_after_node(k, j) IF (n == i) THEN before_and_after_node(k, j) = 0 ! flag value ELSE IF (n > i) THEN before_and_after_node(k, j) = n-1 END IF ! node number needs adjusting END DO ! k = 1, 3 END DO ! j = 1, before_and_after_numel END IF ! node was located in an element (and thus kept), or not located (and deleted) IF (i > before_and_after_numnod) EXIT compacting_nodes END DO compacting_nodes !survey before_and_after_node for bad elements and eliminate them: i = 1 compacting_elements: DO IF ((before_and_after_node(1, i) > 0).AND. & &(before_and_after_node(2, i) > 0).AND. & &(before_and_after_node(3, i) > 0)) THEN ! no problem i = i + 1 ! prepare to loop ELSE ! bad element #i; eliminate it, and shift all elements with higher indexes: IF (i < before_and_after_numel) THEN ! loop will execute at least once DO j = i, (before_and_after_numel - 1) before_and_after_node(1:3, j) = before_and_after_node(1:3, j+1) before_and_after_unfaulted(j) = before_and_after_unfaulted(j+1) timestep_first_faulted(j) = timestep_first_faulted(j+1) before_FEG_midpoint_current_l_(j) = before_FEG_midpoint_current_l_(j+1) END DO ! j = i, before_and_after_numel-1 END IF ! loop would execute at least once before_and_after_numel = before_and_after_numel - 1 !Note that i is not incremented in this branch; must check the NEW #i. END IF ! good or bad element IF (i > before_and_after_numel) EXIT compacting_elements END DO compacting_elements END SUBROUTINE Update_before_FEG INTEGER FUNCTION Which_zero(is) ! Returns 1, 2, or 3 to identify which si is closest to zero. IMPLICIT NONE TYPE(is123), INTENT(IN) :: is INTEGER, DIMENSION(1) :: j REAL*8, DIMENSION(3) :: sabs sabs(1:3) = ABS(is%s(1:3)) j = MINLOC(sabs) Which_zero = j(1) END FUNCTION Which_zero SUBROUTINE Write_before_and_after_feg (before_filename, after_filename) ! Writes before.feg and after.feg output files (without element data). IMPLICIT NONE CHARACTER(*), INTENT(IN) :: before_filename, after_filename INTEGER :: unit = 23 ! see comment lines at top of this source-code file INTEGER :: i, l_ LOGICAL :: faulting REAL*8 :: lon, lat, s1h_azimuth, s1h_sigma, t2 REAL*8, DIMENSION(3) :: tv !In calling program: before_filename = Insert ('before.feg', filename_suffix) WRITE (*, "(' Writing ', A)") TRIM(before_filename) WRITE (21, "('Writing ', A)") TRIM(before_filename) OPEN (unit, ACTION = 'WRITE', FILE = before_filename, STATUS = 'REPLACE') ! Unconditional OPEN; overwrites any old file. WRITE (unit, "(A)") TRIM(before_filename) // ', restored from ' // TRIM(after_filename) WRITE (unit, "(I8, 4X, I8, ' 0 30000 T')") before_and_after_numnod, before_and_after_numnod DO i = 1, before_and_after_numnod tv = before_node_uvec(1:3, i) CALL Lonlat_from_xyz (tv, lon, lat) WRITE (unit, "(I8, 1X, F10.5, 1X, F9.5, 4ES10.2)") & & i, lon, lat, (before_eqcm(k, i), k=1, 4) END DO WRITE (unit, "(I8)") before_and_after_numel DO l_ = 1, before_and_after_numel WRITE (unit, "(4(I8, 1X), L1, I6)") l_, (before_and_after_node(k, l_), k = 1, 3), before_and_after_unfaulted(l_), timestep_first_faulted(l_) END DO WRITE (unit, "(' 0')") CLOSE (unit) !In calling program: after_filename = Insert ('after.feg', filename_suffix) WRITE (*, "(' Writing ', A)") TRIM(after_filename) WRITE (21, "('Writing ', A)") TRIM(after_filename) OPEN (unit, ACTION = 'WRITE', FILE = after_filename, STATUS = 'REPLACE') ! Unconditional OPEN; overwrites any old file. WRITE (unit, "(A)") TRIM(after_filename) WRITE (unit, "(I8, 4X, I8, ' 0 30000 T')") before_and_after_numnod, before_and_after_numnod DO i = 1, before_and_after_numnod tv = after_node_uvec(1:3, i) CALL Lonlat_from_xyz (tv, lon, lat) WRITE (unit, "(I8, 1X, F10.5, 1X, F9.5, 4ES10.2)") i, lon, lat, (after_eqcm(k, i), k=1, 4) END DO WRITE (unit, "(I8)") before_and_after_numel DO l_ = 1, before_and_after_numel WRITE (unit, "(4(I8, 1X), L1, I6)") l_, (before_and_after_node(k, l_), k = 1, 3), before_and_after_unfaulted(l_), timestep_first_faulted(l_) END DO WRITE (unit, "(' 0')") CLOSE (unit) END SUBROUTINE Write_before_and_after_feg SUBROUTINE Write_c_rst (filename) ! Writes cmmnn.rst output file with +, * lines. ! Note that X-sections (even partly) outside the grid are dropped. IMPLICIT NONE CHARACTER(80), INTENT(IN) :: filename !In calling program: filename = Insert (c_rst, filename_suffix) INTEGER :: unit = 27 ! see comment lines at top of file INTEGER :: i REAL*8, DIMENSION(3) :: tv1, tv2 IF (c_rst_count <= 0) RETURN WRITE (*, "(' ', 8X, 'Writing ', A)") TRIM(filename) WRITE (21,"(8X, 'Writing ', A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') ! Overwrites any old file. WRITE (unit, "(A)") c_rst_format WRITE (unit, "(A)") c_rst_titles DO i = 1, c_rst_count IF ((c_end_is(1, i)%element > 0).AND.(c_end_is(2, i)%element > 0)) THEN c47 = c_ref(i) tv1 = c_end_0(1:3, 1, i) CALL Lonlat_from_xyz (tv1, x1, x2) tv2 = c_end_0(1:3, 2, i) CALL Lonlat_from_xyz (tv2, x3, x4) c5 = c_code(i) r1 = c_length(1,i) / m_per_km r2 = c_length(2,i) / m_per_km r3 = c_sigma_(i) / m_per_km t2 = c_t_max(i) / s_per_Ma t1 = c_t_min(i) / s_per_Ma WRITE (unit, c_rst_format) c47, x1, x2, x3, x4, c5, r1, r2, r3, t2, t1 IF (paleotec .OR. (start_time > 0.0D0)) THEN tv1 = c_end_now(1:3, 1, i) CALL Lonlat_from_xyz (tv1, x1, x2) WRITE (unit, "('+',1X,F10.5,1X,F9.5)") x1, x2 tv2 = c_end_now(1:3, 2, i) CALL Lonlat_from_xyz (tv2, x1, x2) WRITE (unit, "('+',1X,F10.5,1X,F9.5)") x1, x2 END IF CALL Write_rates_and_goals & & (index = i, unit = unit, signal = '*', & & conversion = (s_per_Ma / m_per_km), & & goal = c_goal, rate = c_rate, active = c_active) END IF ! section is in domain END DO ! on all sections CLOSE (unit) END SUBROUTINE Write_c_rst SUBROUTINE Write_f_rst (filename) ! Writes fmmnn.rst output file (with * lines by Write_rates_and_goals). IMPLICIT NONE CHARACTER(80), INTENT(IN) :: filename !In calling program: filename = Insert (f_rst, filename_suffix) CHARACTER(6) :: c6 INTEGER :: unit = 26 ! see comment lines at top of file INTEGER :: i, j LOGICAL :: got_history, will_find_history, print_this_datum !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF (f_rst_count <= 0) RETURN WRITE (*, "(' ', 8X, 'Writing ', A)") TRIM(filename) WRITE (21,"(8X, 'Writing ', A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') ! Overwrites any old file. WRITE (unit, "(A)") f_rst_format WRITE (unit, "(A)") f_rst_titles DO i = 1, f_rst_count got_history = .FALSE. ! Just initializing; usually reversed (just below...) checking: DO j = 1, num_timesteps ! global INTEGER num_timesteps; = 1 IF (neotec) IF (f_rate(j, i) /= 0.0D0) THEN got_history = .TRUE. ! So, pass on this history in the f.rst file (even if TRACE is no longer passed along in f.dig files, ! because we are back in geologic epochs when the fault didn't exist yet)! EXIT checking END IF END DO checking will_find_history = f_2_in(which_trace(i)) ! We are integrating this fault's position for use at an earlier geologic time, not yet reached by Restore. print_this_datum = got_history .OR. will_find_history ! The only case excluded here is a fault that was ALWAYS outside the .FEG area; ! e.g., a Canadian fault (when we are modeling western USA and northern Mexico). ! We don't want to print offset data about THOSE in f.rst, or else a continuation run of Restore ! that is launched from this new f.rst file will insist on having their digitized traces, too. IF (print_this_datum) THEN WRITE (c6, "(1X,I4,1X)") which_trace(i) !BUG: Formatted internal WRITE causes memory leak ! under Microsoft Fortran Powerstation 4.0, ! but it will be unimportant in this case. DO j = 2, 5 IF (c6(j:j) == ' ') c6(j:j) = '0' END DO c6(1:1) = 'F' c6(6:6) = sense(i) c50 = fault_name(i) t1 = offset(i) / m_per_km t2 = offset_sigma_(i) / m_per_km t3 = f_t_max(i) / s_per_Ma t4 = f_t_min(i) / s_per_Ma WRITE (unit, f_rst_format) c6, c50, t1, t2, t3, t4 CALL Write_rates_and_goals & & (index = i, unit = unit, signal = '*', & & conversion = (s_per_Ma / m_per_km), & & goal = f_goal, rate = f_rate, active = f_active) END IF END DO CLOSE (unit) END SUBROUTINE Write_f_rst SUBROUTINE Write_f_dig (filename) ! Writes fmmnn.dig output file. ! Note that on 2018.09.20 I changed the output format to have a precision of 0.00001 degrees, ! and also switched from scientific-notation format to fixed-format. ! This is OK because Restore4 is an inherently round-Earth program, ! and all paleo-fault-trace coordinates it produces are in (Elon, Nlat), not (x, y). ! Also, on 2018.09.24 I changed this routine to ONLY write-out traces whose trace_formed_Ma(i) >= t1_Ma IMPLICIT NONE CHARACTER(80), INTENT(IN) :: filename !In calling program: filename = Insert (f_dig, filename_suffix) CHARACTER(4) :: c4 CHARACTER(24) :: c24, c24al INTEGER :: unit = 22 ! see comment lines at top of file INTEGER :: a, i, j, j1, j2, n REAL*8 :: lon, lat, t1_Ma REAL*8, DIMENSION(3) :: tv IF (f_dig_count <= 0) RETURN t1_Ma = t1 ! (local variable = global variable; both in units of Ma) WRITE (*, "(' ', 8X, 'Writing ', A)") TRIM(filename) WRITE (21,"(8X, 'Writing ', A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') ! Overwrites any old file. DO i = 1, f_highest j1 = trace_loc(1, i) j2 = trace_loc(2, i) IF (j2 > j1) THEN IF (f_2_in(i)) THEN IF (trace_formed_Ma(i) >= t1_Ma) THEN WRITE (c4,"(I4)") i !BUG: Formatted internal WRITE causes memory leak ! under Microsoft Fortran Powerstation 4.0, ! but it will be unimportant in this case. IF (c4(1:1) == ' ') c4(1:1) = '0' IF (c4(2:2) == ' ') c4(2:2) = '0' IF (c4(3:3) == ' ') c4(3:3) = '0' IF (c4(4:4) == ' ') c4(4:4) = '0' !WRITE (unit,"('F',A,A)") c4, trace_type(i) WRITE (unit, "(A)") TRIM(f_dig_faultName_lines(i)) ! more complete information (memorized from input f_.dig file). DO a = 1, 5 IF (LEN_TRIM(f_dig_faultData_lines(a, i)) > 0) THEN WRITE (unit, "(A)") TRIM(f_dig_faultData_lines(a, i)) END IF END DO DO j = j1, j2 IF ((trace_is(j)%element > 0).AND.(.NOT.banished_DIG_point(j))) THEN ! These 2 tests may be redundant, but just being sure... tv = trace(1:3, j) CALL Lonlat_from_xyz (tv , lon, lat) WRITE (c24, "(SP, F10.5, ',', F9.5)") lon, lat !N.B. Longitude field may contain 0, 1, or 2 leading blanks. c24al = ADJUSTL(c24) ! necessary so that first byte will always be '+' or '-' WRITE (unit, "(1X, A)") TRIM(c24al) END IF END DO WRITE (unit,"('*** end of polyline ***')") END IF ! trace_formed_Ma(i) >= t1_Ma END IF ! f_2_in(i) END IF ! j2 > j1 END DO ! all traces i = 1, f_highest CLOSE (unit) END SUBROUTINE Write_f_dig SUBROUTINE Write_p_rst (filename) ! Writes pmmnn.rst output file with +, *, & lines. ! Note that points outside the grid are dropped, ! and twisted points have no vertical-axis rotation reported. IMPLICIT NONE CHARACTER(80), INTENT(IN) :: filename !In calling program: filename = Insert (p_rst, filename_suffix) INTEGER :: unit = 28 ! see comment lines at top of file INTEGER :: i REAL*8, DIMENSION(3) :: tv IF (p_rst_count <= 0) RETURN WRITE (*, "(' ', 8X, 'Writing ', A)") TRIM(filename) WRITE (21,"(8X, 'Writing ', A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') ! Overwrites any old file. WRITE (unit, "(A)") p_rst_format WRITE (unit, "(A)") p_rst_titles DO i = 1, p_rst_count IF (p_site_is(i)%element > 0) THEN c50 = p_ref(i) tv = p_site_0(1:3, i) CALL Lonlat_from_xyz (tv, x1, x2) r1 = (p_south(i) / R) * deg_per_rad r2 = (p_south_sigma_(i) / R) * deg_per_rad r3 = p_ccw(i) * deg_per_rad r4 = p_ccw_sigma_(i) * deg_per_rad t2 = p_t2(i) / s_per_Ma t1 = p_t1(i) / s_per_Ma tv = p_pole(1:3, i) CALL Lonlat_from_xyz (tv, x3, x4) WRITE (unit, p_rst_format) c50, x1, x2, r1, r2, r3, r4, t2, t1, x3, x4 IF (paleotec .OR. (start_time > 0.0D0)) THEN tv = p_site_now(1:3, i) CALL Lonlat_from_xyz (tv, x1, x2) WRITE (unit, "('+',1X,F10.5,1X,F9.5)") x1, x2 END IF CALL Write_rates_and_goals & & (index = i, unit = unit, signal = '*', & & conversion = ((deg_per_rad * s_per_Ma) / R), & & goal = p_south_goal, rate = p_south_rate, active = p_active) IF (.NOT. twisted(i)) & & CALL Write_rates_and_goals & & (index = i, unit = unit, signal = '&', & & conversion = (deg_per_rad * s_per_Ma), & & goal = p_ccw_goal, rate = p_ccw_rate, active = p_active) END IF END DO CLOSE (unit) END SUBROUTINE Write_p_rst SUBROUTINE Write_rates_and_goals & & (index, unit, signal, conversion, goal, rate, active) ! Output histories of computed model rates (column #3) and corresponding goals that were in effect (column #4). ! Each line begins with the "signal" byte, followed by lesser-Ma and greater-Ma defining the timestep. IMPLICIT NONE INTEGER, INTENT(IN) :: index, unit CHARACTER(1), INTENT(IN) :: signal REAL*8, INTENT(IN) :: conversion REAL*8, DIMENSION(:,:), INTENT(IN) :: goal, rate LOGICAL(1), DIMENSION(:,:), INTENT(IN) :: active INTEGER :: j LOGICAL :: print_this_line REAL*8 :: g, r, t0, t1 DO j = 1, num_timesteps ! global INTEGER num_timesteps; = 1 IF (neotec) print_this_line = (active(j, index)).AND.(rate(j, index) /= 0.0D0) ! Print ONLY lines with new information! IF (print_this_line) THEN IF (paleotec) THEN t0 = ((j - 1) * Deltat_) / s_per_Ma t1 = (j * Deltat_) / s_per_Ma ELSE ! (neotec) t0 = start_time / s_per_Ma t1 = t0 END IF r = rate(j, index) * conversion g = goal(j, index) * conversion WRITE (unit, "(A, 1X, F7.3, 1X, F7.3, 1X, F11.6, 1X, F11.6)") signal, t0, t1, r, g END IF ! print_this_line END DO END SUBROUTINE Write_rates_and_goals SUBROUTINE Write_s_rst (filename) ! Writes smmnn.rst output file with +, $ lines. ! Note that points outside the grid are dropped. IMPLICIT NONE CHARACTER(80), INTENT(IN) :: filename !In calling program: filename = Insert (s_rst, filename_suffix) INTEGER :: unit = 29 ! see comment lines at top of file INTEGER :: i REAL*8, DIMENSION(3) :: tv IF (s_rst_count <= 0) RETURN WRITE (*, "(' ', 8X, 'Writing ', A)") TRIM(filename) WRITE (21,"(8X, 'Writing ', A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') ! Overwrites any old file. WRITE (unit, "(A)") s_rst_format WRITE (unit, "(A)") s_rst_titles DO i = 1, s_rst_count IF ((s_site_is(1,i)%element > 0).AND.(s_site_is(2,i)%element > 0)) THEN c30 = s_ref(i) c30a = s_loc(i) c5 = s_code(i) tv = s_site_0(1:3, i) CALL Lonlat_from_xyz (tv, x1, x2) r1 = s_azim_0(i) * deg_per_rad r2 = s_sigma_(i) * deg_per_rad t2 = s_t_max(i) / s_per_Ma t1 = s_t_min(i) / s_per_Ma IF (s_stage(i)) THEN c6 = "Stage " ELSE c6 = "Window" END IF WRITE (unit, s_rst_format) c30, c30a, c5, x1, x2, r1, r2, t2, t1, c6 tv = s_site_now(1:3, 1, i) CALL Lonlat_from_xyz (tv, x1, x2) WRITE (unit, "('+',1X,F10.5,1X,F9.5)") x1, x2 r1 = s_azim_now(i) * deg_per_rad r1 = MOD( (r1 + 360.0D0), 180.0D0) WRITE (unit, "('$',1X,F5.1)") r1 END IF END DO CLOSE (unit) END SUBROUTINE Write_s_rst SUBROUTINE Write_x_feg (filename) ! Writes xmmnn.feg output file. IMPLICIT NONE CHARACTER(80), INTENT(IN) :: filename !In calling program: filename = Insert (x_feg, filename_suffix) INTEGER :: unit = 23 ! see comment lines at top of file INTEGER :: i, l_ LOGICAL :: faulting REAL*8 :: lon, lat, s1h_azimuth, s1h_sigma, t2 REAL*8, DIMENSION(3) :: tv WRITE (*, "(' ', 8X, 'Writing ', A)") TRIM(filename) WRITE (21,"(8X, 'Writing ', A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') ! Overwrites any old file. WRITE (unit, "(A)") TRIM(filename)//', restored from '//TRIM(x_feg) WRITE (unit, "(4I8, L8, ' (NUMNOD, NREALN, NFAKEN, N1000, BRIEF)')") num_nod, nRealN, nFakeN, n1000, feg_brief !(all memorized from input .feg) DO i = 1, num_nod tv = xyz_nod(1:3, i) CALL Lonlat_from_xyz (tv, lon, lat) WRITE (unit, "(I8, F11.5, F11.5, 4ES10.2)") i, lon, lat, eqcm(1:4, i) END DO WRITE (unit, "(I10, ' (NUMEL = NUMBER OF TRIANGULAR CONTINUUM ELEMENTS)')") num_ele DO l_ = 1, num_ele t2 = mu_switch(l_) / s_per_Ma ! converting mu_switch age from seconds to Ma IF (stress_ever) THEN s1h_sigma = ele_sigma(l_) * deg_per_rad s1h_azimuth = ele_azim(l_) * deg_per_rad IF (s1h_azimuth < 0.0D0) s1h_azimuth = s1h_azimuth + 180.0D0 IF (s1h_azimuth < 0.0D0) s1h_azimuth = s1h_azimuth + 180.0D0 IF (s1h_azimuth < 0.0D0) s1h_azimuth = s1h_azimuth + 180.0D0 IF (s1h_azimuth >= 180.0D0) s1h_azimuth = s1h_azimuth - 180.0D0 IF (s1h_azimuth >= 180.0D0) s1h_azimuth = s1h_azimuth - 180.0D0 IF (s1h_azimuth >= 180.0D0) s1h_azimuth = s1h_azimuth - 180.0D0 faulting = (crack_index(1, l_) /= 0) WRITE (unit, "(4I8, ES8.1, F7.1, ES8.1, L2, F5.0, F5.1, 3ES10.2, L2)") & & l_, node(1,l_), node(2,l_), node(3,l_), & & mu_element(1, l_), t2, mu_element(2, l_), & & ele_stressed(l_), s1h_azimuth, s1h_sigma, & & ele_strainrate(1:3,l_), faulting ELSE ! Do not include stress-direction or strain-rate info; just reproduce essential mu_ data: IF ((t2 > 0.0D0).AND.(t2 < 5.0D3).AND.(mu_element(2, l_) /= mu_element(1, l_))) THEN WRITE (unit, "(4I8, ES8.1, F7.1, ES8.1)") & & l_, node(1,l_), node(2,l_), node(3,l_), & & mu_element(1, l_), t2, mu_element(2, l_) ELSE IF (mu_element(1, l_) /= mu_) THEN WRITE (unit, "(4I8, ES8.1)") & & l_, node(1,l_), node(2,l_), node(3,l_), & & mu_element(1, l_) ELSE WRITE (unit, "(4I8)") & & l_, node(1,l_), node(2,l_), node(3,l_) END IF END IF END DO WRITE (unit, "(' 0 (NFL = NUMBER OF CURVILINEAR FAULT ELEMENTS)')") CLOSE (unit) END SUBROUTINE Write_x_feg SUBROUTINE Write_x_vel (vw, age_s, filename, FEG_filename) ! Writes nodal-velocity output file. IMPLICIT NONE REAL*8, DIMENSION(:), INTENT(IN) :: vw REAL*8, INTENT(IN) :: age_s ! for time-stamp line in file CHARACTER*80, INTENT(IN) :: filename !In calling program: filename = Insert (x_vel, filename_suffix) CHARACTER*80, INTENT(IN) :: FEG_filename INTEGER :: unit = 25 ! see comment lines at top of file INTEGER :: i REAL*8 :: tMa WRITE (*, "(' ', 8X, 'Writing ', A)") TRIM(filename) WRITE (21,"(8X, 'Writing ', A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') ! Overwrites any old file. WRITE (unit, "(A,', for use with')") TRIM(filename) WRITE (unit, "(A)") TRIM(FEG_filename) tMa = age_s / s_per_Ma CALL DATE_AND_TIME (date, clock_time, zone, datetimenumber) WRITE (unit,"(F6.2, ' Ma; iteration ', I3, '; computed ', I4, '.', I2, '.', I2, ' at ', I2, ':', I2, ':', I2)") & & tMa, total_iterations, & & datetimenumber(1), datetimenumber(2), datetimenumber(3), & & datetimenumber(5), datetimenumber(6), datetimenumber(7) DO i = 1, num_nod WRITE (unit, "(ES16.9, 1X, ES16.9)") vw(2 * i - 1), vw(2 * i) END DO CLOSE (unit) END SUBROUTINE Write_x_vel SUBROUTINE Write_y_dig (filename) ! Writes y_NI_000.2Ma.DIG (or y_i001_000.2Ma.DIG) output file. ! Note that, IF (paleotec), points outside the .FEG grid have been condensed-out already. ! IF (paleotec .AND. faults-in-use) THEN points where master_fault_element(:) = .TRUE. have also been deleted. ! Objects which are reduced to less than "minimum_points" points are not written at all by this subprogram. IMPLICIT NONE CHARACTER(80), INTENT(IN) :: filename !In calling program: filename = Insert (y_dig, filename_suffix) CHARACTER(80) :: title CHARACTER(24) :: c24, c24al INTEGER :: unit = 24 ! see comment lines at top of file INTEGER :: i, i1, i2, minimum_points, object, points, titles REAL*8 :: Elon, Nlat REAL*8, DIMENSION(3) :: tv IF (basemap_object_count <= 0) RETURN WRITE (*, "(' ', 8X, 'Writing ', A)") TRIM(filename) WRITE (21,"(8X, 'Writing ', A)") TRIM(filename) OPEN (unit, FILE = filename) ! Unconditional OPEN overwrites any existing file of same name. DO object = 1, basemap_object_count ! global titles = basemap_object_index(1, object) IF (titles >= 1) THEN ! at least one title line, so check it for "OUTCROP": title = basemap_title_store(basemap_object_index(2, object)) IF (title(1:7) == "OUTCROP") THEN ! An OUTCROP-area outline, from Geologic Map of North America (or other in same format). minimum_points = 3 ELSE ! some other kind of title line (e.g., contact, dike, fault, coastline, state-line, ...) minimum_points = 2 END IF ELSE ! no title lines for this object; assume it is line-type. minimum_points = 2 END IF points = basemap_object_index(4, object) IF (points >= minimum_points) THEN ! we only WRITE objects with >= 2 points... !Titles (if any) ... IF (titles > 0) THEN i1 = basemap_object_index(2, object) ! where first title is stored i2 = basemap_object_index(3, object) ! where last title is stored DO i = i1, i2 WRITE (unit, "(A)") TRIM(basemap_title_store(i)) END DO END IF !Points {should be at least 2 for line-type objects, or at least 3 for (unclosed) areas} ... i1 = basemap_object_index(5, object) ! where first uvec is stored i2 = basemap_object_index(6, object) ! where last uvec is stored DO i = i1, i2 tv(1:3) = basemap_uvec_store(1:3, i) CALL DUvec_2_LonLat(tv, Elon, Nlat) WRITE (c24, "(SP, F10.5, ',', F9.5)") Elon, Nlat !N.B. Longitude field will contain 0, 1, or 2 leading blanks. c24al = ADJUSTL(c24) ! necessary so that first byte will always be '+' or '-' WRITE (unit, "(1X, A)") TRIM(c24al) END DO ! i = i1, i2 !Close this object ... WRITE (unit,"('*** end of line segment ***')") END IF ! This object has at least 2 points (remaining in FEG area, after condensation of others). END DO ! object = 1, basemap_object_count CLOSE (unit) END SUBROUTINE Write_y_dig SUBROUTINE Xyz_from_lonlat (lon, lat, vector) REAL*8, INTENT(IN) :: lon, lat REAL*8, DIMENSION(3), INTENT(OUT) :: vector ! assuming longitude is East longitude in degrees, ! and latitude is North latitude in degrees, ! computes 3 components of Cartesian unit vector ! from center of planet to surface point (on unit sphere). REAL*8 :: theta_, phi_, equat theta_ = (90.0D0 - lat) / deg_per_rad phi_ = lon / deg_per_rad equat = SIN(theta_) vector(1) = equat * COS(phi_) vector(2) = equat * SIN(phi_) vector(3) = COS(theta_) END SUBROUTINE Xyz_from_lonlat END PROGRAM Restore4