! 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 palinspastic 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 by 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).
! *Nodal variables expressing present lithosphere structure
! elevation, heat flow, crustal thickness, mantle-lithosphere thickness)
! are now transported backwards through time. (However, they do not
! evolve or change; additional programming will be needed for that.)
! *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 October 2018
! (adapting to new hardware & compilers, and 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 data entries (e.g., "dip_degrees 22",
! or "symmetric_spreading_system", or "throughgoing_master_fault")
! from fault headers in the f_.dig file are now memorized
! and echoed in all the palinspastic f_.dig files.
! * 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
! that is marked with the "throughgoing_master_fault"
! attribute in the f_.dig file. For such faults, 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
! that is marked with "symmetric_spreading_system"
! (whether a spreading-center with offset sense of D,
! or a transform fault with offset sense of L or R)
! in the data-line 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 spreading
! ridge systems much more accurately than methods #0 or #1,
! which would seriously shear and rotate them.
! However, this new translation method is only used during
! the geologic time-span of the activity of the spreading
! system; in more recent times (if any), it translates like
! any other inactive faults would.
! * 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 a few digitization
! steps. (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.
!
! The result was Restore4 (version 4.0 of 26 October 2018).
!
!==========================================================================
!
! 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 run), in Ma ( >= 0. )
! 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.)
! 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_ ! sliprate, converted, rules according to 'sense'
REAL*8 :: sigma_ ! standard deviation of sliprate, ditto
REAL*8, DIMENSION(3) :: H ! see (11)-(16) of Bird (1998)
CHARACTER(1) :: sense ! offset sense: R, L, T, N, D
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
CHARACTER(80) :: after_filename
REAL*8 :: allowance ! grace period (s) for association of neotec solution with stage stress data
LOGICAL :: any_action ! is x_active(j,i) TRUE for any j?
LOGICAL :: any_spreading ! did any fault in the f_.dig file have "symmetric_spreading_system" attribute?
REAL*8 :: arc_radians ! used in computation of plateward_dAzimuth
INTEGER :: b, b2 ! used in computation of plateward_dAzimuth
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 ! reduced when nodes fall outside current grid (at any time), and can't be integrated back
INTEGER :: before_and_after_numel !(ditto)
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
INTEGER :: crack_count ! total number of cracks in this timestep
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 :: end_time ! greatest geologic age, in s
REAL*8 :: Elon ! East longitude, in degrees
LOGICAL :: eof ! SUBR sends signal to calling prog
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 in f_rst
CHARACTER(134) :: f_rst_format ! to read offset data
CHARACTER(134) :: f_rst_titles ! to print offset data
INTEGER :: f_highest ! max fault index
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 :: 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
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 ! (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
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*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 arrays mu_element and mu_switch.
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 :: 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_OR_misfit_count ! used in scoring neotectonic fault offset-rate predictions
REAL*8 :: neotec_OR_misfit_mmpa(0:2) ! used in scoring neotectonic fault offset-rate predictions
REAL*8 :: neotec_OR_misfit_sigmas(0:2) ! used in scoring neotectonic fault offset-rate predictions
INTEGER :: neotec_OR_misfit_checkThis_mmpa ! used in scoring neotectonic fault offset-rate predictions
INTEGER :: neotec_OR_misfit_checkThis_sigmas ! used in scoring neotectonic fault offset-rate predictions
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, ...); 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
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 :: south ! Sward motion of paleomag site, in m
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_OR_denominator ! used in scoring neotectonic fault offset-rate predictions
REAL*8 :: systematic_OR_numerator ! used in scoring neotectonic fault offset-rate predictions
REAL*8 :: systematic_OR_ratio ! used in scoring neotectonic fault offset-rate predictions
REAL*8 :: t, t0, t1, t2, t3, t4, t5, t6 ! (temporary)
REAL*8 :: this_run_starts_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 ! 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, DIMENSION(3) :: uvec ! unit vector (temporary)
REAL*8, DIMENSION(10) :: vector ! for temporary use by ReadN
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),
! 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.
!(1:3 = x,y,z; 1:before_and_after_numnod)
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, or may even form
! disconnected islands. That's OK, because these grids are only
! for production of colored maps in RetroMap4, not for input to Restore itself.
!(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),
! 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 is a built-in preference for "locating" each node
! in an unfaulted element, when possible. (That is, when the node
! coincides with a node or element-side of the present, temporary, grid,
! so that there is a non-unique assignment to the element.
!(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).
! 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?
!(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(:,:), 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.
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)
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 cannot 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 faults 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 either
! fmmnn.rst or fmmnn.dig.
!(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 tedious '***HARD*** steps.')
!(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"
! 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.
!(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"
! attributes (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 preferable.)
!(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
!(1:3 = side crossed; 1:num_ele = element index l_)
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)
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.
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 or -1) for each fault segment, depending on whether
! isolated node u_ is to right or to left.
!(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.
! 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 faulting 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).
!(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.
! 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 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, 26 October 2018')") ! "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
READ (1, *) t ; line = line + 1
IF (t < 0.0D0) CALL Prevent ('negative age', line, "Parameters.rst")
WRITE (21,"(F10.2,' geologic age at which this run starts, in Ma')") t
this_run_starts_Ma = t
start_time = t * s_per_Ma
! end time
READ (1, *) t ; line = line + 1
IF (t < 0.0D0) CALL Prevent ('negative age', line, "Parameters.rst")
WRITE (21,"(F10.2,' geologic age of older end of history, in 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
! 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 ((start_time > 0.0D0) .AND. (max_iter > 1)) THEN
WRITE (*, "(' Error: Inconsistent parameters; see REPORT.txt.')")
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
END IF
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
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", PAD = "YES", 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 ('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 later,
! based on per-fault data in the f_.dig file:
! The "symmetric_spreading_system" attribute may
! imply translation_method() == 2, 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_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.
! 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.
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
memo_0 = "none"
memo_2 = "none"
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
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", etc.
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"?
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.
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.
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.
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.
translation_method(trace_loc(1, j)) = 2
memo_2 = "none" ! done, and crossed-off
ELSE IF (memo_2 == "last") THEN
major_fault(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 "both" in the f____.DIG file.
major_fault(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.
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,'- - - - - - - - - - - - - - - - - - - - - ')")
! Check that all necessary traces where actually read.
j = 0 ! number of critical traces missing from f_dig
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 object when it makes a difference!
j = j + 1
END IF
END IF
END DO
IF (j > 0) THEN ! There is a serious problem, not just a cosmetic problem...
WRITE (*, "(' Error: The following fault traces were missing:')")
WRITE (21,"('Error: The following fault traces were missing:')")
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
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 j=1,4
IF (c4(j:j) == ' ') c4(j:j) = '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_needed_this_run
END IF ! trace is not loaded in memory
END DO
CALL Pause()
STOP
END IF ! IF (j > 0)
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 arrays
f_2_in = .TRUE. ! later statements can only change -> .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 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 (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 ('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 ( 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)
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)
ENDIF
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
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 = num_nod
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
after_node_uvec = xyz_nod ! whole array; will be saved (except for compression, when nodes & elements must be dropped)
before_node_uvec = xyz_nod ! whole array; will be integrated (and compressed, when nodes & elements must be dropped)
after_eqcm = eqcm ! whole array; will be saved (except for compression, when nodes & elements must be dropped)
before_eqcm = eqcm ! whole array; will be integrated (and compressed, when nodes & elements must be dropped)
before_and_after_node = node ! whole array; will be saved (except for compression, when nodes & elements must be dropped)
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 arrays: center, neighbor, 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.)
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 endes
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.
! 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
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
! 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, ' 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, ' 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. ! Solve-for-vw can only turn it 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.)
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. ! Solve-for-vw can only turn it 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, L0 = rate_err(0, n_, iteration), &
& L1 = rate_err(1, n_, iteration), L2 = rate_err(2, n_, iteration))
!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)
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: L0 = ',F5.3,', L1 = ',F7.3,', L2 = ',F7.3)") &
& rate_err(0,0,iteration),rate_err(1,0,iteration),rate_err(2,0,iteration)
WRITE (21, "(4X,'Mean rate error: L0 = ',F5.3,', L1 = ',F7.3,', L2 = ',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: L0 = ',F5.3,', L1 = ',F7.3,', L2 = ',F7.3)") &
& f_err(0,iteration),f_err(1,iteration),f_err(2,iteration)
WRITE (21, "(4X,'Fault offset error: L0 = ',F5.3,', L1 = ',F7.3,', L2 = ',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: L0 = ',F5.3,', L1 = ',F7.3,', L2 = ',F7.3)") &
& c_err(0,iteration),c_err(1,iteration),c_err(2,iteration)
WRITE (21, "(4X,'Cross-section error: L0 = ',F5.3,', L1 = ',F7.3,', L2 = ',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: L0 = ',F5.3,', L1 = ',F7.3,', L2 = ',F7.3)") &
& p_south_err(0,iteration),p_south_err(1,iteration),p_south_err(2,iteration)
WRITE (21,"(4X,'Paleolatitude error: L0 = ',F5.3,', L1 = ',F7.3,', L2 = ',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: L0 = ',F5.3,', L1 = ',F7.3,', L2 = ',F7.3)") &
& p_ccw_err(0,iteration),p_ccw_err(1,iteration),p_ccw_err(2,iteration)
WRITE (21,"(4X,'Vertical-axis rotation error: L0 = ',F5.3,', L1 = ',F7.3,', L2 = ',F7.3)") &
& p_ccw_err(0,iteration),p_ccw_err(1,iteration),p_ccw_err(2,iteration)
END IF
END IF
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 fault offset rates and surface velocities to external datasets, and check stress-direction enforcement.):
!NOTE that here I also use the model predictions previously computed in subprogram Prediction;
! however, offset-rate & velocity predictions are compared to two datasets that were NOT used to obtain the solution.
!(1) 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_OR_misfit_count = 0
neotec_OR_misfit_mmpa = 0.0D0 ! all (0:2) values
neotec_OR_misfit_sigmas = 0.0D0 ! all (0:2) values
neotec_OR_misfit_checkThis_mmpa = 0
neotec_OR_misfit_checkThis_sigmas = 0
systematic_OR_numerator = 0.0D0
systematic_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_OR_misfit_count = neotec_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_OR_misfit_sigmas(0)) THEN
neotec_OR_misfit_checkThis_sigmas = i ! remember location of worst misfit
neotec_OR_misfit_sigmas(0) = ABS(OR_misfit_in_sigmas)
END IF
neotec_OR_misfit_sigmas(1) = neotec_OR_misfit_sigmas(1) + ABS(OR_misfit_in_sigmas)
neotec_OR_misfit_sigmas(2) = neotec_OR_misfit_sigmas(2) + OR_misfit_in_sigmas**2
!build toward misfit measures in 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_OR_misfit_mmpa(0)) THEN
neotec_OR_misfit_checkThis_mmpa = i ! remember location of worst misfit
neotec_OR_misfit_mmpa(0) = ABS(OR_misfit_in_mmpa)
END IF
neotec_OR_misfit_mmpa(1) = neotec_OR_misfit_mmpa(1) + ABS(OR_misfit_in_mmpa)
neotec_OR_misfit_mmpa(2) = neotec_OR_misfit_mmpa(2) + OR_misfit_in_mmpa**2
!build toward ratio of sum of offset rates, over sum of correct offset rates:
systematic_OR_numerator = systematic_OR_numerator + f_rate(1, i)
systematic_OR_denominator = systematic_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_OR_misfit_count > 0) THEN
neotec_OR_misfit_sigmas(1) = neotec_OR_misfit_sigmas(1) / neotec_OR_misfit_count
neotec_OR_misfit_sigmas(2) = SQRT(neotec_OR_misfit_sigmas(2) / neotec_OR_misfit_count)
neotec_OR_misfit_mmpa(1) = neotec_OR_misfit_mmpa(1) / neotec_OR_misfit_count
neotec_OR_misfit_mmpa(2) = SQRT(neotec_OR_misfit_mmpa(2) / neotec_OR_misfit_count)
END IF
IF (systematic_OR_denominator > 0.0D0) THEN
systematic_OR_ratio = systematic_OR_numerator / systematic_OR_denominator
ELSE ! cannot /0.0
systematic_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 fault offset rates and actual neotec rates')")
WRITE (21, "('Measures of misfit between fault offset rates and actual neotec rates')")
IF (neotec_OR_misfit_count == 0) THEN
WRITE (*, "(' could not be computed because NO actual values were found in the f_rst file.')")
WRITE (21, "('could not be computed because NO actual values were found in 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_OR_misfit_mmpa(0:2)
WRITE (21, "('Misfits in mm/a: ', 3F12.3)") neotec_OR_misfit_mmpa(0:2)
WRITE (*, "(' Misfits in sigmas: ', 3F12.3)") neotec_OR_misfit_sigmas(0:2)
WRITE (21, "('Misfits in sigmas: ', 3F12.3)") neotec_OR_misfit_sigmas(0:2)
WRITE (*, "(' based on ',I6, ' actual offset rates available in the f_rst file.')") neotec_OR_misfit_count
WRITE (21, "('based on ',I6, ' actual offset rates available in the f_rst file.')") neotec_OR_misfit_count
WRITE (*, "(' Worst misfit in mm/a was at f_rst line ',I6,': F',I4)") (2+neotec_OR_misfit_checkThis_mmpa), which_trace(neotec_OR_misfit_checkThis_mmpa)
WRITE (21, "('Worst misfit in mm/a was at f_rst line ',I6,': ',A)") (2+neotec_OR_misfit_checkThis_mmpa), &
& TRIM(f_dig_faultName_lines(which_trace(neotec_OR_misfit_checkThis_mmpa)))
WRITE (*, "(' Worst misfit in sigmas was at f_rst line ',I6,': F',I4)") (2+neotec_OR_misfit_checkThis_sigmas), which_trace(neotec_OR_misfit_checkThis_sigmas)
WRITE (21, "('Worst misfit in sigmas was at f_rst line ',I6,': ',A)") (2+neotec_OR_misfit_checkThis_sigmas), &
& TRIM(f_dig_faultName_lines(which_trace(neotec_OR_misfit_checkThis_sigmas)))
WRITE (*, "(' Ratio of sum-of-rates / sum-of-correct-rates = ', F7.3, ' (should be 1.000)')") systematic_OR_ratio
WRITE (21, "('Ratio of sum-of-rates / sum-of-correct-rates = ', F7.3, ' (should be 1.000)')") systematic_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, "('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
WRITE (*, *) ! create prominent report, on-screen, and in REPORT.txt file:
WRITE (21, *)
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 goals for next iteration based on actual rates, which
! may come from iteration just finished or from restart datasets.
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
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
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
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
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
END IF ! paleotec
END DO outer_loop ! iterations of the whole history
!=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
! 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
filename_suffix = Mangle(last_iteration, total_iterations, time1)
before_filename = Insert ("before.feg", filename_suffix)
after_filename = Insert ("after.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
! 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 ! 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 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
! 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 along their trace.)
IMPLICIT NONE
CHARACTER*79 :: bar_graph
INTEGER, INTENT(OUT) :: seg_count
LOGICAL, INTENT(IN) :: savem
INTEGER, PARAMETER :: library_size = 1000 ! Increase this if you get error messages.
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, 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
!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 (length > 0.0D0) THEN ! This digitization step 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 has positive length (in radians); not a troublesome 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 if outside grid.
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
neighbor = 0
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
END DO homes
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
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 (debug) WRITE (21, "(I6,I8,3F6.2)") i, trace_is(i)%element, &
& (trace_is(i)%s(j3),j3=1,3)
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 (trace_is(j)%element > 0) n = n + 1
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 ! If "0", this cannot be changed when time0 > start_time!
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 prevents assigning internal coordinates
! to a point that previously fell outside the grid, sat
! stagnant, and then got overridden by 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 (translation_method(point_index) == 0),
! 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 major 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.)
!-----------------------------------------------------------------------------
IMPLICIT NONE
REAL*8, DIMENSION(nDOF), INTENT(IN) :: vw ! Note that this is ONLY used for "symmetric_spreading_center" 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, n1, n2, object, points, segment
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, &
& 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, 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 (translation_method(point_index) == 0),
!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 will have any gap or angle eliminated
! by local 3-point 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.
!----------------------------------------------------------------------
stepAway_radians = stepAway_m / R ! used in translation method #2
trace_premove = trace ! Save whole array of trace uvecs; old values are needed for method #2.
IF (f_dig_count > 0) THEN
DO f = 1, f_highest
IF (f_2_in(f)) THEN ! trace has >= 2 points in grid
!First, decide which elements are shearing due to
!OTHER strike-slip 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
segment = local_crack(i)%segment
fault = seg_def(1, segment)
IF (fault /= f) THEN
element = seg_def(2, segment)
shearing(element) = .TRUE.
END IF ! "fault" is a different one from the current trace (f)
END IF ! fault is strike-slip
END DO ! i = 1, crack_count
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).OR.(.NOT.trace_active(n_, f))) THEN ! use "Restore3" rules; not symmetric_spreading_system rules (Restore4)
this_is = trace_is(i) ! get internal coordinates; both are TYPE(is123)
IF ((translation_method(i) == 0).OR.(translation_method(i) == 2)) THEN ! N.B. Because of the enclosing IF() THEN/END IF above,
! the case of translation_method == 2 will only
! occur here during geologic times when the
! spreading system is not active. At such times,
! I treat it like throughgoing_master_fault sets.
unhooked = .FALSE. ! just a comment, really; this is the MEANING of translation method #0.
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
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, or 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 == 1 or 2
END DO ! i = a, b (along 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
END IF
!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.05000 ! Don't average-together any throughgoing_master_fault 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)) == 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 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 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 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 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
!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.
IF (f_dig_count > 0) THEN
DO i = 1, f_highest
IF ((trace_type(i) == 'R').OR.(trace_type(i) == 'L')) THEN
IF (trace_active(n_, i)) THEN ! fault is slipping in this timestep
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
!-----------------------------------------------
!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)
!===========================================================================
smoothing = (Deltat_ / (2.0D0 * s_per_Ma)) * (10.0D3 / mean_step_meters)**2
!Hidden internal parameter, which may need to be adjusted if smoothing is
! either excessively-fast, or deficient.
!Note that the original code (in Restore3, and early versions of Restore4) which read:
! smoothing = (Deltat_ / (2.0D0 * s_per_Ma)) * (20.0D3 / mean_step_meters)**2
! means that the smoothing-distance should be 20 km ("20.0D3") in 2 m.y..
!===========================================================================
smoothing = MIN(1.0D0, MAX(smoothing, 0.0D0))
!Note: The line above is necessary for numerical stability;
!however, it may cause smoothing to be ineffective if strike-slip
!faults are digitized with point spacings of much less than 10 km.
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 ! got at least three points
!Processing done; 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 ! (trace_active(n_, i)); fault is slipping in this timestep
END IF ! strike-slip trace
END DO ! i = 1, f_highest
END IF ! f_dig_count > 0
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 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, L0, L1, L2)
! 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):: L0, L1, L2
DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: A, B, extra_A, extra_B
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: X
!NOTE: Double precision is to prevent underflow/overflow
! during solution of linear system, not for great accuracy.
REAL*8 :: cott
REAL*8 :: csct
INTEGER :: datum
REAL*8, DIMENSION(3,2,2,2) :: dG
REAL*8 :: equat
REAL*8, DIMENSION(3) :: eps_dot, eps_dot_c
REAL*8 :: error
REAL*8 :: error_count
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 :: L0_sum, L1_sum, L2_sum
REAL*8 :: Lz ! length of crack, in m
REAL*8 :: misfits
REAL*8 :: mu_of_r_
INTEGER :: N
REAL*8, DIMENSION(3) :: outward
INTEGER :: p
REAL*8 :: p_
REAL*8, DIMENSION(3) :: Phi
DOUBLE PRECISION :: prefix
REAL*8, DIMENSION(3) :: r_
REAL*8 :: rho_
INTEGER :: segment
REAL*8 :: theta_
REAL*8, DIMENSION(3) :: Theta
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
L0_sum = 0.0D0
L1_sum = 0.0D0
L2_sum = 0.0D0
error_count = 0.0D0
! 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 ',I5,' is N or S pole.')") l_
WRITE (21,"('Error: center of element ',I5,' is N or S pole.')") l_
STOP
END IF
theta_ = ATAN2(equat, 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)
DO z_ = 1, Z
p_ = X(z_) ! PREDICTED SLIP-RATE OF THIS CRACK
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) L0_sum = L0_sum + 1.0D0
L1_sum = L1_sum + ABS(error)
L2_sum = L2_sum + error**2
error_count = error_count + 1.0D0
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) L0_sum = L0_sum + 1.50D0
L1_sum = L1_sum + ABS(error) * 1.50D0
L2_sum = L2_sum + error**2 * 1.50D0
error_count = error_count + 1.50D0
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) L0_sum = L0_sum + (a_(l_) / A_0)
L1_sum = L1_sum + ABS(error) * (a_(l_) / A_0)
L2_sum = L2_sum + error**2 * (a_(l_) / A_0)
error_count = error_count + (a_(l_) / A_0)
END IF ! active cracks / no active cracks
END DO ! l_ = 1, num_ele
! 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.) L0_sum = L0_sum + 1.0D0
L1_sum = L1_sum + misfits
L2_sum = L2_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) L0_sum = L0_sum + 1.0D0
L1_sum = L1_sum + misfits
L2_sum = L2_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) L0_sum = L0_sum + 1.0D0
L1_sum = L1_sum + misfits
L2_sum = L2_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
L0 = L0_sum / error_count
L1 = L1_sum / error_count
L2 = SQRT( L2_sum / error_count )
WRITE (*, "(' ',8X,'Rate errors: N0 = ',F4.3,', N1 = ',F6.3,', N2 = ',F6.3)") L0, L1, L2
WRITE (21,"(8X,'Rate errors: N0 = ',F4.3,', N1 = ',F6.3,', N2 = ',F6.3)") L0, L1, L2
ELSE
L0 = 0.0D0 ; L1 = 0.0D0 ; L2 = 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 ',I5,' is N or S pole.')") l_
WRITE (21,"('Error: center of element ',I5,' 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 ',I5,' is N or S pole.')") m, l_
WRITE (21,"('Error: integration point ',I1,' of element ',I5,' 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)
! epsilon_alpha_beta = 0 (only if element not faulting!)
IF (crack_index(1, l_) == 0) THEN
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 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
! 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.
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
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
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 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 so hard (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 after.feg'
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.
! Note that faults which do not have at least 2 points within the grid
! are dropped.
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
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
IF (f_2_in(which_trace(i))) 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
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) THEN
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 line segment ***')")
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 rates (column #3) and goals for next iteration (column #4).
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
REAL*8 :: g, r, t0, t1
DO j = 1, num_timesteps ! global; = 1 IF (neotec)
IF (active(j, index)) THEN
r = rate(j, index) * conversion
g = goal(j, index) * conversion
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
WRITE (unit, "(A, 1X, F7.3, 1X, F7.3, 1X, F11.6, 1X, F11.6)") signal, t0, t1, r, g
END IF
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