! 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, see the 8th WRITE 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: phone: (310) 825-1126
! 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/or by overprinted actual traces with
! information about estimated slip-rates.
!
!=========================================================================
!
! 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 for version Restore3 since that paper:
! *Logic of -Internal- was improved to catch infinite loops
! of period greater than two (adjacent elements).
! *Self-straightening of strike-slip faults by a diffusional
! model of line tension is added after each translation step.
! (This adds 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
! adjacent to active strike-slip faults has been 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 before.feg (restored positions) and after.feg (present
! positions).
! *Nodal variables expressing lithosphere structure (elevation,
! heat flow, crustal thickness, mantle lithosphere thickness)
! are now integrated backwards in time.
! *Tabular data files which formerly had extension .dat now must
! have extension .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 never published.
!
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
! Additional changes in August 2016+ (adapting to new hardware & compilers):
!
! * 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 Win32 and Win64,
! and also for both sequential and parallel versions of MKL.
! (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 paleomag.)
! 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). 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.
! * Fault names, and any data entries (e.g., "dip_degrees 22")
! 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 types N, T.
! * 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 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 spreading-center D, or transform L/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, it translates like any
! other faults would.
! * 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 the "after.feg" file to mark ('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.
! * 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 reduce 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 14 June 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 odd ones like "pARAMETERS.rST"!).
! "F.RST": Fault names, offsets, and age limits on movement. <2>
! "F.DIG": Digitized fault traces, with codes to match 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, 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.
! "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 PCs with DOS or Windows (NT, 7, 8, 10).
! 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 been processed
! through utility program OrbNumber to reduce bandwidth.)
! Limit the name 'x' to 4 characters or less, or it
! will be truncated.
! "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 Restore 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. )
! 1. timestep, in Ma ( >= 0.; 0. gives neotectonic velocities only )
! 8 refinements (for nonlinearity) within each timestep
! 0 iterations of entire history PRIOR TO this computational run
! 20 iterations of entire history IN THIS computational run
! 20 number of iterations of history planned in ALL runs
! FALSE watch? (adds 1~4 rate files/iteration, for convergence studies)
! TRUE map_set? Do you want 2-4 output files/timestep in last iteration?
! 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 for 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 slip-rate sigma of faults, m/s (for early iterations only)
! 1.6E-10 scale rate uncertainty of SCS's, m/s (for early iterations only)
! 3.2E-10 scale N-S drift uncertainty of PM, m/s (for early iterations only)
! 5.0E-16 scale spin uncertainty of PM, radians/s (for early iterations only)
! 6371. radius of planet, in kilometers
! TRUE switch: Do new active faults give sigma_1h direction data?
! F78DEMO.RST filename of fault offsets (or, 'none')
! F78DDEMO.DIG filename of digitized fault traces (or, 'none')
! C78.RST filename of balanced cross-sections (or, 'none')
! P78.RST filename of paleomagnetic data (or, 'none')
! S78.RST filename of horizontal principal stress directions (or, 'none')
! STATES.DIG filename of fiducial lines to be restored (or, 'none')
! DEMO78A.FEG filename of finite element grid #1 (required)
! [ DEMO78B.FEG (*optionally, list additional finite element grids) ]
! DEMO78A.BCS filename of boundary conditions for finite element grid #1 (required)
! [ DEMO78B.BCS (*if there is more than 1 .FEG, each must have a .BCS file) ]
! -------------------------------------------------------------------------
! *Optionally, you can list up to max_fegs = 200 finite element grid files.
! When the first grid becomes exessively distorted, the second will be
! used. When it is excessively distorted, the third will be used, and so
! on. When the last grid is excessively distorted, the program stops.
! You can list the same grid multiple times; this works well in the interior,
! but will not match the changing shape of the continental margin; for that,
! you need hand-edited custom grids based on untangling the topology of
! the previous deformed grid without changing its overall shape. Be sure to
! renumber each grid for minimum bandwidth, with OrbNumber. For each
! .FEG file listed, there must be a corresponding .BCS boundary-conditions
! file. This file must use the new (re-numbered) node identifiers produced
! by OrbNumber.
! -------------------------------------------------------------------------
! -Build files F.RST, C.RST, P.RST, and S.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.2,F11.3,2F11.1)" 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.2" type formats!
! Also, be sure that all input numbers have an included decimal point
! to guard against decimal point misalignment if 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, consisting of 6 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 a .DIG file which contains
! many traces. Use leading 0's if number is less than 1000.
! - byte #6 is the sense of offset (measurable component):
! R = right-lateral (dextral); L = left-lateral (sinistral); T =
! thrust (of ~25 degree dip); P = low-angle thrust plate or nappe;
! N = normal (high-dip, ~65 degrees); D = detachment (low-dip).
! Thus, a typical identifier might be "F0059T".
! 2. Descriptive text with fault name, location, ...
! 3. Amount of offset, in km. (Always a positive number.
! Letter above 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 slip.
! In case of a low-angle thrust plate or nappe (P), give the
! amount of crustal shortening.
! In case of a detachment fault, listric normal fault, or domino-
! style set of rotating normal faults (D), give the net crustal
! extension.
! 4. Standard deviation (sigma_; 68%-confidence ; half of 95%-
! confidence ) of offset, in km
! 5. Maximum age of faulting, in Ma.
! 6. Minimum age of faulting, in Ma. If not known, enter 0.
! C.RST = Strains Computed from Balanced Cross Sections
! For each balanced section:
! 1. Reference, 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").
! 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
! 10. Age of restoration epoch, in Ma.
! 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!
! P.RST = Paleomagnetic Latitude Anomalies and Vertical-Axis Rotations
! For each virtual geomagnetic pole (preferably from multiple samples):
! 1. Reference. If from IAGA Paleomagnetic database
! (McElhinny & Lock, 1995) then use prefix IAGA: "IAGA: Adams
! & Eve, 1901". If from my Notebook database, then 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
! 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
! 8. Maximum age of magnetization, in Ma
! 9. Minimum age of magnetization, in Ma
! 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")
! 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
! 8. Maximum age of dikes/veins/joints/faults, in Ma
! 9. Minimum age of dikes/veins/joints/faults, in Ma
! 10. Enter "Window" if the age of a single stress indicator is
! bracketed between (8.) and (9.); otherwise enter "Stage" if
! multiple stress indicators were used to show that the
! stress direction was constant from time (8.) to time (9.).
! --------------------------------------------------------
! -Build the x.FEG file with ORBWEAVE (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 format is 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. (However, 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
! rest 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!)
! 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 ORBWEAVE, select the Nodes command, and simply wave
! the mouse near the desired node to see its number displayed
! at the bottom center of the screen.
! --------------------------------------------------------
! -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 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,1P,E12.5,',',E12.5)
! Notice that the first column must be blank, 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 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 are optional (if present, they will not be
! transferred to the output file). 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 (which are your
! responsibility). 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!
!
! THE FOLLOWING ARE PRODUCED IN EVERY TIMESTEP OF THE LAST ITERATION
! -=IF=- the input parameter "map_set" is .TRUE. ("T"):
!
! *Palinspastic datasets:
! "Fmmnn.DIG": Digitised fault traces, restored. <22>
! (assuming that fault data were used in solution).
! "xmmnn.FEG": Finite-element grid, retrodeformed. <23>
! "ymmnn.DIG": Digitised fiducial lines, restored. <24>
! (assuming that fiducial points were read).
! These formats are unchanged. However, all positions (decimal
! degrees of East longitude and North latitude) are modified
! back to the time of the report.
! The fiducial time "nn" (a geologic age in Ma, rounded to the
! nearest integer) is inserted in each filename created.
! (Note: if the age in Ma is over 99, the tens digit will be a
! letter, allowing values from A0 = 100 to Z9 = 359 in two bytes.)
! The iteration number "mm" refers to the global iteration of the
! entire solution, and helps to keep very similar datasets
! catalogued without confusion. The same convention using values
! up to Z9 is used for iteration #. (The parameter old_iterations in
! the Parameters.rst input file is needed to keep these bytes accurate.)
! Points in "F.DIG", "S.RST", and "y.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 "xmmnn.FEG" is also produced: xmmnn.VEL <25>. This permits
! plotting diagrams of the paleotectonics using RetroMap.
! 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 "xnnn.FEG".
! Also, velocities point forward in time (toward the present), not
! back in time; they show what was happening at a previous epoch.
!
! *Strain-history datasets:
! See explanation of "mmnn" in filenames in "palinspastic datasets" above.
! These files have some lines identical to the corresponding input datasets:
! Pmmnn.RST <28> is expanded from P.RST <8>
! Smmnn.RST <29> is expanded from S.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 nn 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.
! Fmmnn.RST lacks these lines because the information is in Fmmnn.DIG.
! Cmmnn.RST has two such lines per datum for the two ends of the section.
! Pmmnn.RST has one such line per datum.
! Smmnn.RST has one such line per datum.
! This information is needed to restart a history in the middle.
! * 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:
! Fmmnn.RST has fault offset rates in km/m.y.. Always positive.
! Cmmnn.RST has cross-section length rates in km/m.y.. Extension
! from past to present has a positive sign.
! Pmmnn.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.
! Smmnn.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:
! Fmmnn.RST does not have & lines.
! Cmmnn.RST does not have & lines.
! Pmmnn.RST has rotation rates in degrees/m.y..
! Counterclockwise rotation from past to present is +.
! Smmnn.RST does not have & lines.
! $ lines: These record a paleo-azimuth indicator nn Ma ago.
! The reference frame is that used to define boundary conditions.
! Fmmnn.RST does not have $ lines.
! Cmmnn.RST does not have $ lines.
! Pmmnn.RST does not have $ lines.
! Smmnn.RST has paleo-azimuths of sigma_1h. As in S.RST,
! azimuth is in degrees clockwise from North.
!
! THE FOLLOWING ARE PRODUCED AT THE END OF THE LAST ITERATION
!(or, at the end of EVERY iteration if parameter "watch" is .TRUE. ('T'):
!
! *Strain-history datasets:
! See explanation of "mmnn" in filenames in "palinspastic datasets" above.
! These files have some lines identical to the corresponding input datasets:
! Fmmnn.RST <26> is expanded from F.RST <2>
! Cmmnn.RST <27> is expanded from C.RST <4>
! Pmmnn.RST <28> is expanded from P.RST <8>
! Smmnn.RST <29> is expanded from S.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 nn 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.
! Fmmnn.RST lacks these lines because the information is in Fmmnn.DIG.
! Cmmnn.RST has two such lines per datum for the two ends of the section.
! Pmmnn.RST has one such line per datum.
! Smmnn.RST has one such line per datum.
! This information is needed to restart a history in the middle.
! * 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:
! Fmmnn.RST has fault offset rates in km/m.y.. Always positive.
! Cmmnn.RST has cross-section length rates in km/m.y.. Extension
! from past to present has a positive sign.
! Pmmnn.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.
! Smmnn.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:
! Fmmnn.RST does not have & lines.
! Cmmnn.RST does not have & lines.
! Pmmnn.RST has rotation rates in degrees/m.y..
! Counterclockwise rotation from past to present is +.
! Smmnn.RST does not have & lines.
! $ lines: These record a paleo-azimuth indicator nn Ma ago.
! The reference frame is that used to define boundary conditions.
! Fmmnn.RST does not have $ lines.
! Cmmnn.RST does not have $ lines.
! Pmmnn.RST does not have $ lines.
! Smmnn.RST has paleo-azimuths of sigma_1h. As in S.RST,
! azimuth is in degrees clockwise from North.
!
! THE FOLLOWING ARE PRODUCED IN THE EVENT THAT THE PROGRAM TERMINATES
! EARLY (because the grid becomes too strained, and no other grids are
! available to read in):
!
! *Palinspastic datasets (described above):
! "Fmmnn.DIG": Digitised fault traces, restored. <22>
! (assuming that fault data were used in solution).
! "xmmnn.FEG": Finite-element grid, retrodeformed. <23>
! "ymmnn.DIG": Digitised fiducial lines, restored. <24>
! (assuming that fiducial points were read, AND
! that input parameter "map_set" is .TRUE.)
!
! *Strain-history datasets (described above):
! Fmmnn.RST <26> is expanded from F.RST (if any) <2>
! Cmmnn.RST <27> is expanded from C.RST (if any) <4>
! Pmmnn.RST <28> is expanded from P.RST (if any) <8>
! Smmnn.RST <29> is expanded from S.RST (if any) <9>
! Note that in the case of early termination, the rates for
! completed timesteps are actual model predictions, but the rates
! for the remaining timesteps are goals. When Restore 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 a 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 = 3 + 3 + #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
REAL*8, DIMENSION(3) :: s
END TYPE is123
TYPE :: crack ! Intersection of a fault offset rate datum with
! a fault segment. Some segments have > 1 crack, due to
! > 1 contiguous datum time windows in this timestep;
! many fault segments have no crack (inactive).
INTEGER :: datum ! offset datum index
INTEGER :: segment ! segment index
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 ! fault type: R, L, T, N, D
END TYPE crack
TYPE :: needle ! everything one needs to know about a stress datum
REAL*8, DIMENSION(3) :: location ! Cartesian unit vector
REAL*8 :: azimuth ! clockwise from N, in radians
REAL*8 :: sigma ! uncertainty, radians
REAL*8 :: relevance ! 0.0 to 1.
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 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 = 200 !(could be increased)
REAL*8, PARAMETER :: s_per_Ma = 1000000.0D0 * 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
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 :: bcs_count ! # of boundary-condition nodes
INTEGER :: before_and_after_numnod ! reduced when nodes fall outside current grid
INTEGER :: before_and_after_numel !(ditto)
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
LOGICAL :: eof ! SUBR sends signal to calling prog
REAL*8 :: exponent ! = n_ / last_iter
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, 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
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 is needed
LOGICAL :: got_index ! during reading of f_dig
LOGICAL :: got_data_line ! during reading of f_dig
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)
REAL*8 :: half_R2 ! R**2/2.
CHARACTER*1 :: home_sense_c1 ! used in computation of plateward_dAzimuth
INTEGER :: i,i1,i2,i3,i4,i5,i6 ! (temporary)
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 :: 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 :: look_at_element ! number of folded element
INTEGER :: last_iter ! planned final iteration of a set
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)
LOGICAL :: map_set ! do you want complete graphical detail for every timestep of the last iteration?
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 :: 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_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
INTEGER :: num_fegs ! # of .feg and .bcs files in Paramete[rs].rst
INTEGER :: num_nod ! # of nodes in x_feg
INTEGER :: num_nod_last = 0 ! memory of previous num_nod (in a different .feg?)
INTEGER :: num_timesteps ! # of timesteps in one iteration of history
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
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 ! do palinspastic reconstructions
INTEGER :: past_iterations ! iterations of history in previous runs
REAL*8 :: R ! Bird (1998)
REAL*8 :: r1, r2, r3, r4 !(temporary)
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
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 :: time0, time1 ! age at young, old end of timestep, s
INTEGER :: total_iterations ! = iteration + past_iterations (q.v.)
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(10) :: vector ! for temporary use by ReadN
LOGICAL :: watch ! outputs all rates files each iteration
CHARACTER(80) :: y_dig ! filename of digitised fiducial lines
INTEGER :: y_dig_count ! number of digitised points in y_dig
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, 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, and compressing the rest),
! expressed as unit vectors.
!(1:3 = x,y,z; 1:before_and_after_numnod)
INTEGER, DIMENSION(:,:),ALLOCATABLE :: before_and_after_node
! element definitions common to before.feg and after.feg,
! from which non-integratable elements (those involving
! nonintegratable 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.
!(1:3 = 3 corner nodes; 1:before_and_after_numel)
LOGICAL*1, DIMENSION(:), ALLOCATABLE :: before_and_after_unfaulted
! indicates elements which have never hosted any active fault
!(i.e., because there is no digitized fault trace there in the
! present-day fault map). Such elements are the best for computing
!(meaningful) values of net strain and net rotation over a long
! tectonic history.
!(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)
TYPE(is123), DIMENSION(:), ALLOCATABLE :: before_node_is
! restored locations of nodes of before.feg (deleting those that
! could not be integrated, and compressing the rest),
! in internal coordinates of the current (temporary) grid.
!(1:before_and_after_numnod)
REAL*8, DIMENSION(:,:),ALLOCATABLE :: before_node_uvec
! restored locations of nodes of before.feg (deleting those that
! could not be integrated, 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)
INTEGER, DIMENSION(8) :: datetimenumber
! for output from DATE_AND_TIME
REAL*8, DIMENSION(:,:),ALLOCATABLE :: dot
! integrated positions of fiducial points read from y_dig,
! as Cartesian unit vectors
!(1:3 = x,y,z; 1:y_dig_count = fiducial point index)
REAL*8, DIMENSION(:,:),ALLOCATABLE :: dot_0
! present-day positions of fiducial points read from y_dig,
! as Cartesian unit vectors
!(1:3 = x,y,z; 1:y_dig_count = fiducial point index)
LOGICAL(1), DIMENSION(:), ALLOCATABLE :: dot_last
! If T, given point is the last in a line segment.
!(1:y_dig_count = fiducial point index)
TYPE(is123), DIMENSION(:), ALLOCATABLE :: dot_is
! locations of digitised fiducial points in internal coordinates
!(1:y_dig_count = fiducial point index)
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 (Quaternary rate used for whole first
! timestep); D = Demoted (rate for 1st timestep ignored since another
! rate 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)
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.
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 :: 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)
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))
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. Using 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", &
ACTION = "WRITE")
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, "(' version 4.0, 14 June 2018')")
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')")
WRITE (21, "(' Paramete[rs].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 (21, "('ERROR: Could not locate file PARAMETE[RS].RST')")
WRITE (21, "('(in either upper, lower, or mixed-case)')")
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
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.')")
STOP
END IF
! time step
READ (1, *) t ; line = line + 1
Deltat_ = t * s_per_Ma
WRITE (21,"(ES10.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 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,"('----------------------------------------------------------')")
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 (*, "(' Number 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_iter
IF (paleotec) THEN
IF (last_iter <= 0) CALL Prevent ('nonpositive iteration target', line, "Parameters.rst")
WRITE (21, "(I10,' number of iterations planned (total of all runs)')") last_iter
ELSE ! neotec
last_iter = 1
WRITE (21, "(I10,' total number of iterations planned [NOT USED in neotectonic mode]')") last_iter
END IF ! paleotec, or neotec?
! watch convergence(?) of rate histories?
READ (1, *) watch
IF (paleotec) THEN
WRITE (21, "(L10,1X,'that 1-4 rate files will be written/iteration for convergence watch.')") watch
ELSE ! neotec
watch = .FALSE.
WRITE (21, "(L10,1X,'that 1-4 rate files will be written/iteration [NOT USED in neotectonic mode]')") watch
END IF ! paleotec, or neotec?
! output map information each timestep of last iteration?
READ (1, *) map_set
IF (paleotec) THEN
WRITE (21, "(L10,1X,'that 2-4 output files will be written/timestep in last iteration.')") map_set
ELSE ! neotec
map_set = .FALSE.
WRITE (21, "(L10,1X,'that 2-4 output files will be written [neotectonic mode]')") map_set
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,"(1P,E10.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 ")
f_rst = Get_filename (unit = 1) ; line = line + 1
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
f_dig = Get_filename (unit = 1) ; line = line + 1
END IF
WRITE (21,"(' ',A)") TRIM(f_dig)
WRITE (21,"(11X,'preceding line = filename of digitised fault traces')")
c_rst = Get_filename (unit = 1) ; line = line + 1
WRITE (21,"(' ',A)") TRIM(c_rst)
WRITE (21,"(11X,'preceding line = filename of balanced cross-sections')")
p_rst = Get_filename (unit = 1) ; line = line + 1
WRITE (21,"(' ',A)") TRIM(p_rst)
WRITE (21,"(11X,'preceding line = filename of paleomagnetic data')")
s_rst = Get_filename (unit = 1) ; line = line + 1
WRITE (21,"(' ',A)") TRIM(s_rst)
WRITE (21,"(11X,'preceding line = filename of principal stress directions')")
y_dig = Get_filename (unit = 1) ; line = line + 1
IF (neotec .OR. (.NOT.map_set)) y_dig = 'skipped'
WRITE (21,"(' ',A)") TRIM(y_dig)
WRITE (21,"(11X,'preceding line = filename of digitised fiducial lines')")
CALL More_mem ('gridname_feg', 1.0D0 * max_fegs * 80)
ALLOCATE ( gridname_feg (max_fegs) )
CALL More_mem ('gridname_bcs', 1.0D0 * max_fegs * 80)
ALLOCATE ( gridname_bcs (max_fegs) )
gridname_feg(1) = Get_filename (unit = 1) ; line = line + 1
WRITE (21,"(' ',A)") TRIM(gridname_feg(1))
WRITE (21,"(11X,'preceding line = filename of finite element grid # 1')")
CALL Test_file (name = gridname_feg(1), unit = 2)
num_fegs = 1
DO i = 2, max_fegs
c80 = Get_filename (unit = 1) ; line = line + 1
j1 = INDEX (c80, '.FEG ')
j2 = INDEX (c80, '.feg ')
IF ((j1 > 0) .OR. (j2 > 0)) THEN
gridname_feg(i) = c80
num_fegs = num_fegs + 1
ELSE
EXIT
END IF
END DO
DO i = 2, num_fegs
WRITE (21,"(' ',A)") TRIM(gridname_feg(i))
WRITE (21,"(11X,'preceding line = filename of finite element grid #',I2)") i
CALL Test_file (name = gridname_feg(i), unit = 2)
END DO
gridname_bcs(1) = c80
DO i = 2, num_fegs
gridname_bcs(i) = Get_filename (unit = 1) ; line = line + 1
END DO
DO i = 1,num_fegs
WRITE (21,"(' ',A)") TRIM(gridname_bcs(i))
WRITE (21,"(11X,'preceding line = filename of boundary conditions #',I2)") 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
! Iterate the whole history!!!
outer_loop: DO iteration = 1, max_iter ! Note that 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_iter
WRITE (21,"('Beginning iteration ',I3,' out of ',I3,' (this run), ',I3,' (total)')") iteration, max_iter, last_iter
END IF
IF (paleotec .AND. (start_time == 0.0D0)) THEN
total_iterations = iteration + past_iterations
ELSE ! neotec, or else a restart
total_iterations = MAX(1, past_iterations)
END IF
IF (paleotec) THEN
IF (last_iter > 1) THEN
exponent = MIN(1.000D0, (DBLE(total_iterations - 1) / DBLE(last_iter - 1)) )
ELSE
exponent = 1.000D0
END IF
WRITE (*, "(' using exponent = ',F6.4)") exponent
WRITE (21, "('using exponent = ',F6.4)") exponent
ELSE
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")
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 ('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 rate, and sigma):
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") ; line = 0
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
IF (i1 > f_highest) THEN
WRITE (*, "(' Illegally high trace index: ',I6)") i1
WRITE (21,"('Illegally high trace index: ',I6)") i1
STOP
END IF
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
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
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
DO j = 1, f_rst_count ! may need to be D
IF (i /= j) THEN ! different datum lines
IF (which_trace(i) == which_trace(j)) THEN !same trace
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 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?)
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"); line = 0
! 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(f_dig_count) )
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")
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
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.001D0) 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)
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
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
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
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
translation_method(trace_loc(1, j)) = 2
memo_2 = "none" ! done, and crossed-off
ELSE IF (memo_2 == "last") THEN
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.
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) j = j + 1
END DO
IF (j > 0) THEN
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
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
END DO
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")
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) )
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") ; line = 0
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")
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) )
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") ; line = 0
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
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")
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) )
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") ; line = 0
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
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
y_dig_count = 0
ELSE
WRITE (*, "(' ',8X,'Reading fiducial lines from ',A)") TRIM(y_dig)
WRITE (21,"(8X,'Reading fiducial lines from ',A)") TRIM(y_dig)
OPEN (UNIT = 10, FILE = y_dig, STATUS = "OLD", ACTION = "READ", &
PAD = "YES"); line = 0
! Skim file and count number of data points
y_dig_count = 0
y_loop_thru: DO
READ (10, "(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
y_dig_count = y_dig_count + 1
END IF
ELSE; EXIT y_loop_thru; END IF
END DO y_loop_thru
CLOSE (UNIT = 10) ! (will be re-read)
! allocate arrays
CALL More_mem ('dot', 1.0D0 * 3 * y_dig_count * bytes_per_real)
ALLOCATE ( dot(3, y_dig_count) )
CALL More_mem ('dot_0', 1.0D0 * 3 * y_dig_count * bytes_per_real)
ALLOCATE ( dot_0(3, y_dig_count) )
CALL More_mem ('dot_is', 1.0D0 * y_dig_count * bytes_per_is)
ALLOCATE ( dot_is(y_dig_count) )
CALL More_mem ('dot_last', 1.0D0 * (y_dig_count + 1) * 1)
ALLOCATE ( dot_last(0:y_dig_count) )
! fill arrays
OPEN (UNIT = 10, FILE = y_dig, STATUS = "OLD", ACTION = "READ", &
PAD = "YES") ; line = 0
i = 0 ! will be used to count points again
y_read_dig: DO
READ (10, "(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
got_point = .TRUE.
READ (c50,*) t1, t2 ! E longitude, N latitude
IF (ABS(t2) > 90.001D0) THEN
WRITE (*, "(' Bad latitude ',F10.2,' in line ',I10,' of ',A)") &
t2, line, TRIM(y_dig)
WRITE (21,"('Bad latitude ',F10.2,' in line ',I10,' of ',A)") &
t2, line, TRIM(y_dig)
STOP
END IF
ELSE ! titles, or '*** end of line segment ***'
got_point = .FALSE.
END IF
ELSE; EXIT y_read_dig; END IF
IF (got_point) THEN
i = i + 1
CALL Xyz_from_lonlat(t1, t2, tv)
dot(1:3,i) = tv
dot_0(1:3,i) = tv ! (will be used to restart later iterations)
dot_last(i) = .FALSE.
ELSE ! titles, or '*** end ...'
dot_last(i) = .TRUE.
ENDIF
END DO y_read_dig
CLOSE (UNIT = 10) ! close y_dig
WRITE (*, "(' ',8X,I6,' fiducial points were read')") y_dig_count
WRITE (21,"(8X,I6,' fiducial points were read')") y_dig_count
WRITE (21,"(8X,'- - - - - - - - - - - - - - - - - - - - - ')")
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 (y_dig_count > 0) dot = dot_0 ! whole array
END IF ! (iteration =1, or > 1)
! [.feg and .bcs are read as needed within timestepping loop ]
current_feg = 0 ! start at beginning of the list each iteration
get_feg = .TRUE. ! better load one; if you've got one, it's deformed!
IF (ALLOCATED (vw0)) vw0 = 0.0D0 ! so strain-rate is defined in Solve-for-vw
IF (ALLOCATED (vw1)) vw1 = 0.0D0 ! so strain-rate is defined in Solve-for-vw
IF (paleotec) THEN
n_ = NINT(start_time / Deltat_)
ELSE ! (neotec)
n_ = 0 ! will be bumped to 1
END IF
timestepping: DO
IF (paleotec) THEN
time0 = n_ * Deltat_
ELSE ! neotec
time0 = start_time
END IF
t0 = time0 / s_per_Ma
! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
n_ = n_ + 1 ! not using DO index because we may repeat steps
! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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 ! mostly for use by Write_x_vel
END IF
IF (get_feg) THEN
get_feg = .FALSE.
current_feg = current_feg + 1 ! progress through list
changed_horses = (current_feg > 1)
IF (current_feg > num_fegs) THEN ! ERROR
WRITE (*, "(' Error: Needed but could not find another .FEG file, #',I2)") current_feg
WRITE (21,"('Error: Needed but could not find another .FEG file, #',I2)") current_feg
IF (current_feg == 1) THEN
STOP ! (this shouldn't happen)
ELSE ! there is an .feg in memory
IF ((complete_timesteps == 0) .OR. (n_ == 1)) THEN
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,"(' 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.')")
mmnn = Mangle(total_iterations, time1)
CALL Write_x_feg(shift = 0)
STOP
ELSE
WRITE (*, "(' Writing output files necessary to restart:')")
WRITE (21,"('Writing output files necessary to restart:')")
mmnn = Mangle(total_iterations, time1)
CALL Write_x_feg(shift = 0)
IF (f_dig_count > 0) CALL Write_f_dig(shift = 0)
IF (y_dig_count > 0) CALL Write_y_dig(shift = 0)
IF (f_rst_count > 0) CALL Write_f_rst(shift = 0)
IF (c_rst_count > 0) CALL Write_c_rst(shift = 0)
IF (p_rst_count > 0) CALL Write_p_rst(shift = 0)
IF (s_rst_count > 0) CALL Write_s_rst(shift = 0)
WRITE (*, "(' See further instructions in REPORT.txt.')")
t1 = time0 / s_per_Ma
WRITE (21,"('To resume this calculation:')")
WRITE (21,"(' 1. Fix or replace deformed .FEG file.')")
WRITE (21,"(' 2. Create corresponding .BCS file.')")
WRITE (21,"(' 3. Correct PARAMETE[RS].RST file:')")
WRITE (21,"(' Use these, with the files just written, as input files.')")
WRITE (21,"(' Set start_time to ',F7.3,' Ma in line 1.')") t1
WRITE (21,"(' Set old_iterations to ',I2,' in line 5.')") total_iterations
WRITE (21,"(' Set max_iter to 1 in line 6.')")
WRITE (21,"(' 4. Rerun Restore to complete this iteration.')")
WRITE (21,"(' 5. Correct PARAMETE[RS].RST file:')")
WRITE (21,"(' Use present-day .DIG, .RST files for input.')")
WRITE (21,"(' Add any new .FEG, .BCS files to the corresponding lists.')")
WRITE (21,"(' Set start_time to 0.0D0 in line 1.')")
WRITE (21,"(' Set old_iterations to ',I2,' in line 5.')") total_iterations + 1
WRITE (21,"(' Set max_iter as high as desired in line 6.')")
WRITE (21,"(' 6. Run Restore, and cross your fingers!')")
STOP
END IF ! (n_ > 1)
END IF
ELSE ! next name on list should be pre-tested as valid
! 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 in this filename'/' ',A)") TRIM(x_feg)
WRITE (21,"('Error: No .FEG (or .feg) found in this filename'/A)") TRIM(x_feg)
STOP
END IF
WRITE (*, "(' ',8X,'Reading finite-element grid from ',A)") TRIM(x_feg)
WRITE (21,"(8X,'Reading finite-element grid from ',A)") TRIM(x_feg)
OPEN (UNIT = 11, FILE = x_feg, STATUS = 'OLD', ACTION = 'READ', PAD = 'YES')
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 (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 ('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 ( eqcm(4, num_nod) )
ALLOCATE ( vw0(nDOF) )
vw0 = 0.0D0 ! so strain-rate is defined in first Solve-for-vw
ALLOCATE ( vw1(nDOF) )
vw1 = 0.0D0 ! so strain-rate is defined in first Solve-for-vw
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)) STOP
READ (11, *) num_ele; line = line + 1
IF (ALLOCATED (node)) THEN
DEALLOCATE (node)
DEALLOCATE (mu_element)
DEALLOCATE (mu_switch)
DEALLOCATE (a_)
DEALLOCATE (crack_index)
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)
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
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) )
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
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 = mu_ ! use default strain-rate uncertainty to replace zero
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
! record 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)
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) )
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) )
END IF ! iteration == 1
after_node_uvec = xyz_nod ! whole array; will be saved (except for compression)
before_node_uvec = xyz_nod ! whole array; will be integrated (and compressed)
after_eqcm = eqcm ! whole array; will be saved (except for compression)
before_eqcm = eqcm ! whole array; will be integrated (and compressed)
before_and_after_node = node ! whole array; will be saved (except for compressions)
before_and_after_unfaulted = .TRUE. ! whole array; elements with faults will be negated later, when segmentation occurs
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')
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))
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, look_at_element) !?
IF (folding) THEN
WRITE (*, "(' ',8X,'This grid is ALREADY folded (element ',I8,'); starting timestep over')") look_at_element
WRITE (21,"(8X,'This grid is ALREADY folded (element ',I8,'); starting timestep over')") look_at_element
get_feg = .TRUE.
n_ = n_ - 1
CYCLE timestepping
END IF
!get internal coordinates for all integrated data points
IF ((f_dig_count + f_rst_count + c_rst_count + p_rst_count + s_rst_count + y_dig_count) > 0) THEN
WRITE (*, "(' ',8X,'Finding all data locations in grid coordinates')")
WRITE (21,"(8X,'Finding all data locations in grid coordinates')")
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) )
CALL Find_s1s2s3
!Also defines arrays: center, neighbor, trace_is; negates(?) f_2_in.
! 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
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
END IF ! next .feg on list is valid
ELSE ! get_feg = F
WRITE (*, "(' ',8X,'Using same finite-element grid again')")
WRITE (21,"(8X,'Using same finite-element grid again')")
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) )
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" and "after")
IF (current_feg == 1) THEN ! Provide a more meaningful initialization of before_and_after_unfaulted(1:num_ele); previously all .TRUE.
DO i = 1, seg_count
before_and_after_unfaulted(seg_def(2, i)) = .FALSE.
END DO
END IF
END IF ! paleotec
END IF ! seg_count > 0
END IF ! f_rst_count > 0
! 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
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
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
vw0 = vw1 ! initial estimate, used in Solve-for-vw
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 * < * * < * *
!CALL Write_x_vel(vw = vw0, age_s = time0, shift = 0) ! useful while debugging; otherwise, not necessary.
ELSE
CALL Solve_for_vw (passes = 1, vw = vw0) !* < * PREDICTOR * < * * < * *
!CALL Write_x_vel(vw = vw0, age_s = time0, shift = 0) ! useful while debugging; otherwise, not necessary.
END IF
IF (paleotec) THEN
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, look_at_element) !?
IF (folding) THEN
WRITE(*, "(' ',8X,'This grid FOLDED in predictor (element ',I8,'); starting timestep over')") look_at_element
WRITE (21,"(8X,'This grid FOLDED in predictor (element ',I8,'); starting timestep over')") look_at_element
get_feg = .TRUE.
n_ = n_ - 1
CYCLE timestepping
END IF ! paleotec
! move all integrated points to older positions: explicit part
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) )
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
vw1 = vw0 ! initial estimate, used by Solve-for-vw
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 * < * * < * *
!CALL Write_x_vel(vw = vw1, age_s = time1, shift = 0) ! useful while debugging; otherwise, not necessary.
ELSE
CALL Solve_for_vw (passes = 1, vw = vw1) !* < * CORRECTOR * < * * < * *
!CALL Write_x_vel(vw = vw1, age_s = time1, shift = 0) ! useful while debugging; otherwise, not necessary.
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, look_at_element) !?
IF (folding) THEN
WRITE(*, "(' ',8X,'This grid FOLDED in corrector (element ',I8,'); abandoning correction')") look_at_element
WRITE (21,"(8X,'This grid FOLDED in corrector (element ',I8,'); abandoning correction')") look_at_element
get_feg = .TRUE.
vw_mean = vw0 !whole array
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 "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))
! provide complete basis for graphics if desired
IF (neotec) THEN
mmnn = Mangle(total_iterations, time0)
mmnn(1:2) = "NT"
CALL Write_x_vel(vw = vw0, age_s = time0, shift = 0)
complete_timesteps = 1
ELSE ! (paleotec)
IF ((iteration == max_iter) .AND. map_set) THEN
mmnn = Mangle(total_iterations, time1)
CALL Write_x_feg(shift = 8)
CALL Write_x_vel(vw = vw1, age_s = time1, shift = 8)
IF (f_dig_count > 0) CALL Write_f_dig(shift = 8)
IF (y_dig_count > 0) CALL Write_y_dig(shift = 8)
END IF
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
END IF ! (paleotec)
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 SUBROUTINE 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) 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
! output histories of strain, to permit more iterations, or scoring of model,
! or studies of model convergence.
IF (watch .OR. neotec .OR. (iteration == max_iter)) THEN
mmnn = Mangle(total_iterations, time1)
IF (neotec) mmnn(1:2) = "NT"
IF (f_rst_count > 0) CALL Write_f_rst(shift = 0)
IF (c_rst_count > 0) CALL Write_c_rst(shift = 0)
IF (p_rst_count > 0) CALL Write_p_rst(shift = 0)
IF (paleotec .AND. (s_rst_count > 0)) CALL Write_s_rst(shift = 0)
END IF
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, and
! all element data have been deleted):
IF (paleotec) THEN
CALL Write_before_and_after_feg (shift = 0)
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)
STOP
END SUBROUTINE Check_range
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 postive 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.')")
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.')")
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.')")
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.')")
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.')")
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.')")
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, 79) ! because in later timesteps & iterations the upper limit is approximate
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
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
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
mmnn = '_BAD'
CALL Write_x_feg(shift = 0)
CALL Write_f_dig(shift = 0)
STOP
ELSE
punt = .TRUE.
WRITE (*, "(' Aborting search for fault segments at count of ',I8)") limit
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 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 :: 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 (y_dig_count > 0) THEN
bar_graph(1:44) = ' Locating fiducial 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, y_dig_count
tv = dot(1:3, i)
l_ = dot_is(i)%element
CALL Internal (tv, l_, s1, s2, s3)
dot_is(i)%element = l_
dot_is(i)%s(1) = s1
dot_is(i)%s(2) = s2
dot_is(i)%s(3) = s3
j = (17 * i) / y_dig_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
!find internal coordinates for nodes of before.feg:
IF (paleotec) THEN ! (otherwise, no need for "before" and "after" arrays)
DO i = 1, before_and_after_numnod
tv = before_node_uvec(1:3, i)
!Check for an easy match with current node #i; especially a good idea at start-up! (Also, Internal may fail along grid edges.)
easy_match = ((tv(1) == xyz_nod(1, i)).AND.(tv(2) == xyz_nod(2, i)).AND.(tv(3) == xyz_nod(3, i)))
IF (easy_match) THEN ! find which element contains node #i (at which corner?)
l_ = 0 ! but we expect this to be replaced, in next paragraphs...
linking: DO j = 1, num_ele
IF (i == node(1, j)) THEN
l_ = j
s1 = 1.0D0
s2 = 0.0D0
s3 = 0.0D0
EXIT linking
ELSE IF (i == node(2, j)) THEN
l_ = j
s1 = 0.0D0
s2 = 1.0D0
s3 = 0.0D0
EXIT linking
ELSE IF (i == node(3, j)) THEN
l_ = j
s1 = 0.0D0
s2 = 0.0D0
s3 = 1.0D0
EXIT linking
END IF
END DO linking
IF (l_ == 0) THEN ! something went wrong; use backup plan
l_ = 1 ! (because zero has special meaning to Internal)
CALL Internal (tv, l_, s1, s2, s3)
END IF
ELSE ! must look in element interiors...
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
END DO ! i = 1, before_and_after_numnod
!check for nodes which fell out of grid, and eliminate them
!from all 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!
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, or not
!Note that i is not incremented in this branch; must check the NEW #i.
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)
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 IF ! paleotec
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
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
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
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 (unit)
! Obtains a filename from the beginning of the next line;
! 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(132) :: buffer
INTEGER :: i
LOGICAL :: past
INTEGER, INTENT (IN) :: unit ! Fortran device number
READ (unit,"(A)") buffer
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, mmnn)
! truncates left part of filename to 4 or less bytes, and adds 'mmnn';
! should be able to handle complicated names like:
! "../project/restore/NA5Ablah.FEG "
! (in either DOS or Unix)
IMPLICIT NONE
CHARACTER(80) :: filename
CHARACTER(4) :: mmnn
INTEGER :: left_frame, right_frame, old_stub, new_stub
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)) // mmnn // &
TRIM(filename(right_frame : 80))
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.
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 value 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.')")
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.')")
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.')")
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
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(4) FUNCTION Mangle (iteration, time)
IMPLICIT NONE
INTEGER :: iteration, it
REAL*8 :: time, tMa
CHARACTER*2 :: c2l, c2r
CHARACTER*3 :: c3
tMa = time / s_per_Ma
it = NINT(tMa)
IF ((iteration < 360) .AND. (it < 360)) THEN
IF (iteration < 100) THEN
! use decimal integers
WRITE (c2l,"(I2)") iteration
!BUG: Formatted internal WRITE causes memory leak
! under Microsoft Fortran Powerstation 4.0,
! but it will be unimportant in this case.
ELSE
! Use A .. Z in the tens digit
c2l(1:1)=CHAR(64 + INT(iteration / 10.0D0) - 9) ! A..Z
! Use 0 .. 9 in the ones digit
c2l(2:2)=CHAR(48 + MOD(iteration, 10)) ! 0..9
ENDIF
IF (tMa < 0.95D0) THEN
! use ".1" for fractions of the first Ma
WRITE (c3, "(F3.1)") tMa
c2r = c3(2:3)
ELSE IF (it < 100) THEN
! use decimal integers
WRITE (c2r,"(I2)") it
!BUG: Formatted internal WRITE causes memory leak
! under Microsoft Fortran Powerstation 4.0,
! but it will be unimportant in this case.
ELSE
! Use A .. Z in the tens digit
c2r(1:1)=CHAR(64 + INT(it / 10.0D0) - 9) ! A..Z
! Use 0 .. 9 in the ones digit
c2r(2:2)=CHAR(48 + MOD(it, 10)) ! 0..9
ENDIF
ELSE
WRITE (*, "(' Error in Mangle: cannot handle ',2I10)") iteration, it
WRITE (21,"(' Error in Mangle: cannot handle ',2I10)") iteration, it
STOP
END IF
IF (c2l(1:1) == ' ') c2l(1:1) = '0'
IF (c2r(1:1) == ' ') c2r(1:1) = '0'
Mangle = c2l // c2r
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, ii, j, j1, j2, k, l_, n, n1, n2, 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, smaller_stepAway_radians, smoothing, stepAway_radians, s1, s2, s3, &
& v_, v_1, v_2, w_, w_1, w_2
REAL*8, DIMENSION(3) :: omega_uvec, tvo, tv1, tv2, 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
!Motion of basemap is always by translation method #1.
!It is locally complicated by the need for "unhooking" to avoid folding
!in elements sheared by active strike-slip faults. For basemap
!lines crossing such shearing elements, I try to find an adjacent
!unshearing element, and replace the internal ccordinates 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 will be active.)
IF (y_dig_count > 0) THEN
!First, decide which elements are shearing:
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
element = seg_def(2, segment)
shearing(element) = .TRUE.
END IF
END DO ! i = 1, crack_count
DO i = 1, y_dig_count
this_is = dot_is(i) ! both are TYPE(is123)
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 basemap line to find
!a non-shearing element as basis for internal coordinates:
j1 = i
j2 = i
blocked_left = .FALSE.
blocked_right = .FALSE.
sidestepping: DO
!try going left
j1 = j1 - 1
blocked_left = blocked_left.OR.(j1 == 0) ! and, to avoid dot_last(-1) abend:
IF (j1 > 0) blocked_left = blocked_left.OR.dot_last(j1) ! past point 1
IF (.NOT.blocked_left) THEN
element = dot_is(j1)%element
IF (element > 0) THEN
IF (.NOT.shearing(element)) THEN ! got it!
unhooked = .TRUE.
vector(1:3) = dot(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 sidestepping
END IF ! got an anchor for this line segment
ELSE ! line segment 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 > y_dig_count) ! and, to avoid dot_last(TOO HIGH):
IF ((j2-1) <= y_dig_count) blocked_right = blocked_right.OR.dot_last(j2-1) ! past end point 2
IF (.NOT.blocked_right) THEN
element = dot_is(j2)%element
IF (element > 0) THEN
IF (.NOT.shearing(element)) THEN ! got it!
unhooked = .TRUE.
vector(1:3) = dot(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 sidestepping
END IF ! got an anchor for this line segment
ELSE ! line segment has left the grid
blocked_right = .TRUE.
END IF ! trial element > 0
END IF ! .NOT.blocked_right
IF (blocked_left.AND.blocked_right) EXIT sidestepping ! no way to fix it
END DO sidestepping
END IF ! this_is needs to be corrected
!Heart of translation method #1:
CALL Interpolate(this_is, tvo)
dot(1:3, i) = tvo
IF (unhooked) THEN
!recompute internal coordinates after move:
l_ = dot_is(i)%element
CALL Internal(tvo, l_, s1, s2, s3)
dot_is(i)%element = l_
dot_is(i)%s(1) = s1
dot_is(i)%s(2) = s2
dot_is(i)%s(3) = s3
END IF
END IF
END DO
DEALLOCATE (shearing)
END IF
!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 translation 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.)
!----------------------------------------------------------------------
!In 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 ccordinates 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 will 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
!Smooth traces of any 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 (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)) * (20.0D3 / mean_step_meters)**2
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 ! 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
n_adjusted = 0
DO i = 1, count
IF (checkPD .AND. (f_rst_code(i) == 'P')) 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 .AND. (f_rst_code(i) == 'D')) 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, look_at_element)
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, INTENT(OUT) :: look_at_element
!reports element # in which folding occurred (first);
!if none, then reports zero.
INTEGER :: i1, i2, i3, l_
REAL*8, DIMENSION(3) :: a, b, c, t
folding = .FALSE.
look_at_element = 0
DO l_ = 1, num_ele ! global, like most variables
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)
IF (Dot_3D(t, c) > 0.0D0) THEN
a_(l_) = Magnitude(c) * half_R2
ELSE
folding = .TRUE.
look_at_element = l_
RETURN
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.')")
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 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; Demotions 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 .AND. (j == 1) .AND. (f_rst_code(index) == 'P')) THEN
goal(j, index) = total(index) / (tmax(index) - tmin(index))
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 Quaternary 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_) ! 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
rate(j1, index) = r2
goal(j1, index) = r3
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
rate(j, index) = r2 * overlap / Deltat_
goal(j, index) = r3 * overlap / Deltat_
ELSE ! add
rate(j, index) = rate(j, index) + r2 * overlap / Deltat_
goal(j, index) = goal(j, index) + r3 * overlap / Deltat_
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(2, 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, 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
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_
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
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_
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')
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
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
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
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
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) DEALLOCATE ( needles )
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:'/' ',A)") TRIM(name)
WRITE (21,"('Error: Following filename is invalid:'/A)") TRIM(name)
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
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
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 (shift)
! Writes before.feg and after.feg output files (without element data).
IMPLICIT NONE
INTEGER :: shift ! controls placement of announcement on screen, in REPORT.txt
CHARACTER(80) :: filename
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
!filename = Insert ('before.feg', mmnn) ! both arguments global variables; typical
filename = 'before.feg'
IF (shift == 8) THEN
WRITE (*, "(' ',8X,'Writing ',A)") TRIM(filename)
WRITE (21,"(8X,'Writing ',A)") TRIM(filename)
ELSE
WRITE (*, "(' Writing ',A)") TRIM(filename)
WRITE (21,"('Writing ',A)") TRIM(filename)
END IF
OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE')
WRITE (unit, "(A)") TRIM(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,F9.4,1X,F8.4,1P,4E10.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)") l_, (before_and_after_node(k, l_), k = 1, 3), before_and_after_unfaulted(l_)
END DO
WRITE (unit, "(' 0')")
CLOSE (unit)
!filename = Insert ('after.feg', mmnn) ! both arguments global variables; typical
filename = 'after.feg'
IF (shift == 8) THEN
WRITE (*, "(' ',8X,'Writing ',A)") TRIM(filename)
WRITE (21,"(8X,'Writing ',A)") TRIM(filename)
ELSE
WRITE (*, "(' Writing ',A)") TRIM(filename)
WRITE (21,"('Writing ',A)") TRIM(filename)
END IF
OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE')
WRITE (unit, "(A)") TRIM(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,F9.4,1X,F8.4,1P,4E10.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)") l_, (before_and_after_node(k, l_), k = 1, 3), before_and_after_unfaulted(l_)
END DO
WRITE (unit, "(' 0')")
CLOSE (unit)
END SUBROUTINE Write_before_and_after_feg
SUBROUTINE Write_c_rst (shift)
! Writes cmmnn.rst output file with +, * lines.
! Note that X-sections (even partly) outside the grid are dropped.
IMPLICIT NONE
INTEGER :: shift ! controls placement of announcement on screen, in REPORT.txt
CHARACTER(80) :: filename
INTEGER :: unit = 27 ! see comment lines at top of file
INTEGER :: i
REAL*8, DIMENSION(3) :: tv1, tv2
filename = Insert (c_rst, mmnn) ! both arguments global variables; typical
IF (shift == 8) THEN
WRITE (*, "(' ',8X,'Writing ',A)") TRIM(filename)
WRITE (21,"(8X,'Writing ',A)") TRIM(filename)
ELSE
WRITE (*, "(' Writing ',A)") TRIM(filename)
WRITE (21,"('Writing ',A)") TRIM(filename)
END IF
OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE')
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,F8.3,1X,F7.3)") x1, x2
tv2 = c_end_now(1:3, 2, i)
CALL Lonlat_from_xyz (tv2, x1, x2)
WRITE (unit, "('+',1X,F8.3,1X,F7.3)") 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 (shift)
! 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
INTEGER :: shift ! controls placement of announcement on screen, in REPORT.txt
CHARACTER(80) :: filename
CHARACTER(6) :: c6
INTEGER :: unit = 26 ! see comment lines at top of file
INTEGER :: i, j
filename = Insert (f_rst, mmnn) ! both arguments global variables; typical
IF (shift == 8) THEN
WRITE (*, "(' ',8X,'Writing ',A)") TRIM(filename)
WRITE (21,"(8X,'Writing ',A)") TRIM(filename)
ELSE
WRITE (*, "(' Writing ',A)") TRIM(filename)
WRITE (21,"('Writing ',A)") TRIM(filename)
END IF
OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE')
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 (shift)
! Writes fmmnn.dig output file.
IMPLICIT NONE
INTEGER :: shift ! controls placement of announcement on screen, in REPORT.txt
CHARACTER(80) :: filename
CHARACTER(4) :: c4
INTEGER :: unit = 22 ! see comment lines at top of file
INTEGER :: a, i, j, j1, j2, n
REAL*8 :: lon, lat
REAL*8, DIMENSION(3) :: tv
filename = Insert (f_dig, mmnn) ! both arguments global variables; typical
IF (shift == 8) THEN
WRITE (*, "(' ',8X,'Writing ',A)") TRIM(filename)
WRITE (21,"(8X,'Writing ',A)") TRIM(filename)
ELSE
WRITE (*, "(' Writing ',A)") TRIM(filename)
WRITE (21,"('Writing ',A)") TRIM(filename)
END IF
OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE')
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
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 (unit, "(1X,SP,1P,E12.5,',',E12.5)") lon, lat
END IF
END DO
WRITE (unit,"('*** end of line segment ***')")
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 (shift)
! 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
INTEGER :: shift ! controls placement of announcement on screen, in REPORT.txt
CHARACTER(80) :: filename
INTEGER :: unit = 28 ! see comment lines at top of file
INTEGER :: i
REAL*8, DIMENSION(3) :: tv
filename = Insert (p_rst, mmnn) ! both arguments global variables; typical
IF (shift == 8) THEN
WRITE (*, "(' ',8X,'Writing ',A)") TRIM(filename)
WRITE (21,"(8X,'Writing ',A)") TRIM(filename)
ELSE
WRITE (*, "(' Writing ',A)") TRIM(filename)
WRITE (21,"('Writing ',A)") TRIM(filename)
END IF
OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE')
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,F8.3,1X,F7.3)") 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 (left) and goals for next iteration (right).
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,F9.4,1X,F9.4)") signal, t0, t1, r, g
END IF
END DO
END SUBROUTINE Write_rates_and_goals
SUBROUTINE Write_s_rst (shift)
! Writes smmnn.rst output file with +, $ lines.
! Note that points outside the grid are dropped.
IMPLICIT NONE
INTEGER :: shift ! controls placement of announcement on screen, in REPORT.txt
CHARACTER(80) :: filename
INTEGER :: unit = 29 ! see comment lines at top of file
INTEGER :: i
REAL*8, DIMENSION(3) :: tv
filename = Insert (s_rst, mmnn) ! both arguments global variables; typical
IF (shift == 8) THEN
WRITE (*, "(' ',8X,'Writing ',A)") TRIM(filename)
WRITE (21,"(8X,'Writing ',A)") TRIM(filename)
ELSE
WRITE (*, "(' Writing ',A)") TRIM(filename)
WRITE (21,"('Writing ',A)") TRIM(filename)
END IF
OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE')
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,F8.3,1X,F7.3)") 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 (shift)
! Writes xmmnn.feg output file.
IMPLICIT NONE
INTEGER :: shift ! controls placement of announcement on screen, in REPORT.txt
CHARACTER(80) :: filename
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
filename = Insert (x_feg, mmnn) ! both arguments global variables; typical
IF (shift == 8) THEN
WRITE (*, "(' ',8X,'Writing ',A)") TRIM(filename)
WRITE (21,"(8X,'Writing ',A)") TRIM(filename)
ELSE
WRITE (*, "(' Writing ',A)") TRIM(filename)
WRITE (21,"('Writing ',A)") TRIM(filename)
END IF
OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE')
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, shift)
! Writes xmmnn.vel output file.
IMPLICIT NONE
REAL*8, DIMENSION(:), INTENT(IN) :: vw
REAL*8, INTENT(IN) :: age_s ! positive geologic age, in seconds
INTEGER, INTENT(IN) :: shift ! controls placement of announcement on screen, in REPORT.txt
CHARACTER*4 :: mmnn ! local version; not global
CHARACTER*80 :: filename
INTEGER :: unit = 25 ! see comment lines at top of file
INTEGER :: i
REAL*8 :: tMa
IF (paleotec) THEN ! global LOGICAL control variable
mmnn = Mangle(iteration, age_s) ! mmnn is local; iteration is global; age_s is an argument
ELSE ! neotec; also global
mmnn = Mangle(iteration, time0) ! using global variables
mmnn(1:2) = "NT"
END IF ! paleotec, or neotec?
filename = Insert (x_vel, mmnn) ! both arguments global variables; typical
IF (shift == 8) THEN
WRITE (*, "(' ',8X,'Writing ',A)") TRIM(filename)
WRITE (21,"(8X,'Writing ',A)") TRIM(filename)
ELSE
WRITE (*, "(' Writing ',A)") TRIM(filename)
WRITE (21,"('Writing ',A)") TRIM(filename)
END IF
OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE')
WRITE (unit, "(A,', for use with')") TRIM(filename)
IF (neotec) THEN
WRITE (unit, "(A)") TRIM(x_feg)
ELSE
WRITE (unit, "('a deformed version of ',A)") TRIM(x_feg)
END IF
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, "(1P,E13.6,1X,E13.6)") vw(2 * i - 1), vw(2 * i)
END DO
CLOSE (unit)
END SUBROUTINE Write_x_vel
SUBROUTINE Write_y_dig (shift)
! Writes ymmnn.dig output file.
! Note that points outside the grid are dropped;
! segments which are reduced to less than 2 points are also dropped.
IMPLICIT NONE
INTEGER, INTENT(IN) :: shift ! controls placement of announcement on screen, in REPORT.txt
INTEGER :: unit = 24 ! see comment lines at top of file
INTEGER :: i, n_in_seg
REAL*8 :: lon, lat
LOGICAL :: seg_open
CHARACTER(80) :: filename
REAL*8, DIMENSION(3) :: tv
filename = Insert (y_dig, mmnn) ! both arguments global variables; typical
IF (shift == 8) THEN
WRITE (*, "(' ',8X,'Writing ',A)") TRIM(filename)
WRITE (21,"(8X,'Writing ',A)") TRIM(filename)
ELSE
WRITE (*, "(' Writing ',A)") TRIM(filename)
WRITE (21,"('Writing ',A)") TRIM(filename)
END IF
OPEN (unit, ACTION = 'READWRITE', FILE = filename, STATUS = 'REPLACE')
! note that READWRITE is needed to permit BACKSPACE, below
seg_open = .FALSE. ; n_in_seg = 0
DO i = 1, y_dig_count ! global
IF (dot_is(i)%element > 0) THEN ! point lies within grid; location known
tv = dot(1:3, i)
CALL Lonlat_from_xyz (tv, lon, lat)
WRITE (unit, "(1X,SP,1P,E12.5,',',E12.5)") lon, lat
seg_open = .TRUE. ; n_in_seg = n_in_seg +1
ELSE ! this point fell outside the grid; location undefined
IF (seg_open) THEN
IF (n_in_seg > 1) THEN
WRITE (unit,"('*** END OF SEGMENT ***')")
ELSE
BACKSPACE (unit)
END IF
seg_open = .FALSE. ; n_in_seg = 0
END IF
END IF
IF (dot_last(i)) THEN
IF (seg_open) THEN
IF (n_in_seg > 1) THEN
WRITE (unit,"('*** END OF SEGMENT ***')")
ELSE
BACKSPACE (unit)
END IF
seg_open = .FALSE. ; n_in_seg = 0
END IF
END IF
END DO
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
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
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