! NeoKinema.f90 ! ! A code which uses Neotectonic Kinematic data (geodesy, fault slip ! rates, stress directions) as additional constraints on a viscous-shell ! model of the lithosphere with plate-rotation boundary conditions, ! and computes present long-term-average horizontal velocities ! and distributed permanent strain rates. ! ! in the Fortran 90 language ! (for version and date, search below for "version =") ! ! 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 ! pbird@epss.ucla.edu ! ! (c) Copyright 1997, 2001, 2002, 2003, 2007, 2008, 2010, 2012, 2014 by ! Peter Bird and the Regents of the University of California ! !========================================================================= ! ! 1. GENERAL DESCRIPTION: ! ------------------------ ! This code uses Neotectonic Kinematic data (geodesy, fault slip ! rates, stress directions) as additional constraints on a viscous-shell ! model of the lithosphere with plate-rotation boundary conditions, ! and computes present long-term-average horizontal velocities ! and fault slip rates, and also permanent strain rates between faults. ! Although information on faults is a major part of the input, ! a continuum finite element approximation is used to describe ! the velocity field. In output graphics (usually prepared with ! companion program NeoKineMap) fault activity can be suggested by ! overprinted icons and/or by overprinted actual traces with ! information about estimated slip-rates. (The plotted slip rates can ! be either a-priori model inputs, or a-posteriori model outputs.) ! Also, NeoKineMap is capable of displaying maps of velocity magnitude ! which show all fault discontinuities, using some kludgy, ad-hoc ! post-processing code. If this is not desired, the distributed ! or "smeared" offsets across faults can be plotted to rigorously ! represent the internal solution mechanism in NeoKinema. ! !========================================================================= ! ! 2. ALGORITHM: !--------------- ! ! The algorithm of NeoKinema versions 2.0~2.1 was described in ! Appendix S1 to Liu & Bird [2008; Geophys. J. Int., 172(2), ! 779-797, doi: 10.1111/j.1365-246X.2007.03640.x ]. ! ! The same file is available at URL of: ! http://peterbird.name/oldFTP/NeoKinema/ ! ! The method by which most-compressive horizontal principal stress ! directions are interpolated on the sphere was given by: ! Bird & Li [1996), J. Geophys. Res., v. 101, #B3, 5435-5443]. ! ! Model predictions of geodetic data are optimized under the criteria ! of minimizing (P - D) N (P - D), where: ! P is the vector of predicted horizontal velocity components at benchmarks ! D is the vector of actual* horizontal velocity components at benchmarks ! N is the normal matrix, or inverse of the covariance matrix of D. ! ! It is not necessary to pre-compute the normal matrix N; if needed (v.3+) ! NeoKinema will compute this from the covariance matrix of D. ! The covariance matrix of D can be represented by the block-diagonal ! error ellipses (for each benchmark in isolation) contained in the .gps file, ! or it can be supplemented by a full covariance matrix read from ! a .gp2 file. In either case, terms may be added to the covariance matrix ! to indicate that the velocity frame of reference is free-floating. ! Therefore, it is not necessary to use .gps data files in the same ! reference frame as the boundary condition--it is only necessary that all ! the lines in the .gps data file have the SAME velocity reference frame. ! ! *As the iteration of the solution proceeds, the geodetic data are corrected ! by adding velocities equal to the estimated long-term average of coseismic ! displacements caused by all faults within the model domain. In order ! to make this correction, estimated depth ranges of locking are read ! in two places: {1} default values from the parameter input file; and ! {2} local per-fault values, if available, from the right-hand columns ! of the f*.nki file (where negative numbers signal ignorance, in which ! case the default values {1} are used). ! !========================================================================== ! ! 3. FILE-NAMING CONVENTIONS ! ! NOTE: Adhering to these conventions will make use of ! the associated graphics package NeoKineMap MUCH EASIER! !----------------------------------------------------------------- ! Some pre-existing file-name conventions are retained: ! ! .dig indicates DIGitized polylines, from Digitise ! (or from coordinate-transformation utility Projector), ! such as digitized fault traces, or coastlines, ! or political boundaries. ! (such files can be read by NeoKineMap and FiniteMap as well). ! ! .feg indicates a Finite Element Grid, from OrbWin or OrbWeaver, ! plus post-processing utility program OrbNumber ! (such files can be read by NeoKineMap and FiniteMap as well). ! ! v*.out indicates a Velocity Output file, with 3 lines of titles, ! followed by (v_South, v_East) for each node, in m/s ! (such files can be read by NeoKineMap and FiniteMap as well). ! v_[token].out is the long-term-average velocity field ! (comparable to fault offset rates and plate tectonics); and ! v_interseismic-[token].out is the short-term interseismic field ! (comparable to GPS and other geodetic data). ! ! .gps indicates a geodetic-velocity file, of the sort ! that can be plotted by FiniteMap and NeoKineMap, ! or converted to a new velocity reference frame by ! ReframeGPS. ! ! .gp2 indicates an appendix to a .gps file, giving the ! covariance matrix for the geodetic velocity components. ! ! New file formats created for NeoKinema have one of two suffixes: ! ! .nki for NeoKinema Input (must be created before running NeoKinema); ! ! .nko for NeoKinema Output (created by NeoKinema). ! ! Specific file types are indicated by the first letter: ! ! .nki (Input): ! ! p*.nki Parameters, such as data weights and default fault locking depths, ! and names of other input files. ! ! b*.nki Boundary conditions ! ! f*.nki Fault offset-rates, with uncertainties (possibly huge!) ! ! s*.nki Stress directions ! ! .nko (Output): ! ! t*.nko Text record of the progress and success of the run ! ! f*.nko Offset-rates of faults estimated by NeoKinema ! ! h*.nko Heave-rates of faults estimated by NeoKinema ! (In version 1.3+, slip rates are also given to ! support PROGRAM Long_Term_Seismicity.) ! ! s*.nko Stress directions interpolated by NeoKinema ! ! e*.nko Continuum strain-rates, excluding faulting ! ! g*.nko Geodetic velocities of benchmarks, with velocity ! reference frame (optionally) redefined by NeoKinema, ! and with estimated mean coseismic velocities added ! to produce estimated long-term-average velocities. ! ! The first line of your p*.nki Parameter file lists a "name token" ! which will be built into all output file names. For example, ! ! _test01 results in the creation of t_test01.nko ! ! 2001-01 results in the creation of t2001-01.nko ! ! It is suggested (but not required) that you build the same token ! into the names of any input files that you prepare, IF they are ! created anew for this particular model. (If they are likely to be ! re-used in many model runs, this is not advised because it requires ! keeping redundant copies of the file.) !========================================================================== ! ! 4. OVERVIEW OF INPUT DATASETS ! ! !--------------------------------------------------------- ! p*.nki short file of parameter values, such as the weight factors ! for fault-slip and continuum constraints, the names ! of all other input files, etc. REQUIRED <1> ! ! f*.nki Fault names, slip-senses, and offset rates (or priors). OPTIONAL <2> ! As of NeoKinema v.3, "bracket" limits on offset rates may be added. ! ! f*.dig Digitized fault traces, with serial numbers to ! match f*.nki. REQUIRED if f.nki is used. <3> ! As of NeoKinema version 3, additional information on fault dip ! and depth of the "trace" (for blind thrusts) may be included. ! ! s*.nki Most-compressive horizontal principal stress azimuths ! (from centroid moment tensors of earthquakes, ! from dikes and veins, or from cluster analysis of faults ! with slickensides. Or, less reliably, from clusters of ! folds). OPTIONAL <9> ! ! *.gps Geodetic velocities at benchmarks, with error ! ellipses. OPTIONAL <10> ! ! *.gp2 Covariance matrix for geodetic velocity components. <10> ! (Note: This file is OPTIONAL and can be omitted, even if ! a .gps file was provided.) ! ! *.feg Finite element grid of connected spherical-triangle ! elements on the Earth's spherical surface. REQUIRED <11> ! Filename must have extension ".feg" or ".FEG". ! Typically created with interactive utility program ! ORBWEAVE for PCs with DOS or Windows (any version). ! 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 ORBNUMBR to reduce bandwidth.) ! The last line of the file contains "0" to show that ! there are no fault elements in an .feg file for NeoKinema. ! ! b*.nki A boundary-conditions file indicating which nodes (at ! least 2!) have specified velocities. <12> ! ! Notes: 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 folder ! for this computation. Then, run NeoKinema from this folder, ! using short, simple filenames. ! This method will also make it easier to run the graphic program ! NeoKineMap, which assumes that input files are grouped in one folder. ! If any of the input datasets is null, enter 'none' ! for the filename. (However, you must always provide ! parameters, finite element grid, and boundary conditions.) ! !============================================================================= ! ! 4. DATA PREPARATION / INPUT FILE FORMATS ! *** General Note: Do not exceed 132 characters in any line of any file! ! -------------------------------------------------------------------------------------- ! ! -Build Parameter file p*.nki containing these lines; comments to right are OK. ! (V----beginning each in column 1): ! _test01 [name token for this run of NeoKinema] ! 1.00E3 L0 = length of fault trace whose offset rate gets unit weight (in m) ! 4.00E8 A0 = area of continuum whose stiffness & isotropy get unit weight (in m**2) ! 40 refinements (for nonlinearity) allowed in this solution (try 20-40) ! 1.0E-15 mu_ = scalar measure of typical anelastic strain rates in continuum (/s) ! 3.2E-17 xi_ = small strain-rate increment, in /s (Not TOO small! Try 3.2E-17 /s.) ! 20. sigma, in degrees, of angle between [heave vectors of dip-slip faults] & [trace-normal direction] ! 6371. radius of planet, in kilometers ! 1. 12. minimum and maximum default locking depths of intraplate faults, in km (may be overridden by f*.nki) ! 14. 40. minimum and maximum default locking depths of subduction zones, in km (may be overridden by f*.nki) ! FALSE switch: Do active faults give sigma_1h direction data? ! f_test01.nki filename of fault offset-rates (or, 'none') ! f_test01.dig filename of digitized fault traces (or, 'none') ! 1 stress interpolation method: (1) Bird & Li [1996]; (2) Carafa & Barba [2013]. ! s_test01.nki filename of horizontal principal stress directions (or, 'none') ! WUSC002.gps filename of geodetic velocity data (or, 'none') ! WUSC002.gp2 filename of covariance matrix for geodetic velocity components (or, 'none') ! FALSE switch: Is the reference frame of geodetic-velocity data allowed to free-float? ! TRUE conservative_geodetic_adjustment? (uses geologic slip rates; not self-consistent) ! test01.feg filename of finite element grid (required) ! b_test01.nki filename of boundary conditions for finite element grid (required) ! NA plate defining velocity reference frame for type-4 boundary conditions ! FALSE dump_all_solutions? Creates velocity log file for studying convergence. ! ------------------------------------------------------------------------------------- ! ! -Build files f*.nki and s*.nki (both optional) as follows: ! A general feature of all of these files is that they are tables ! with one datum per 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,F12.0,F12.0,L2,F6.1,F6.1,F6.1,F6.1)" for f*.nki ! (BE SURE TO INCLUDE formats for the 2 optional columns ! on the right, WHETHER ACTUALLY FILLED-IN OR NOT), ! or "(A8,1X,A8,1X,F8.3,F8.3,1X,I3,1X,A1)" in the case of s*.nki. ! [Special note on these 2 FORMATs; do *NOT* use format-repetition ! integers, as in "2F8.3"; instead, list each item separately, ! as in "F8.3,F8.3". This is necessary to avoid confusing my ! (rather primitive) code that will interpret the format: {1} in ! order to figure out whether your stress-quality indices are numeric ! or alphabetical; and {2} in order to change precision of output ! to 0.001 mm/a in f*.nko. ! -human-readable abbreviated column headings ! (which will be copied into the output files). ! NOTE: Create FORMATs carefully. Be sure that all input numbers ! have an included decimal point to guard against decimal point ! misalignment if the format is changed! If there is a chance ! that some input values do NOT have an included decimal, then ! be sure they are right-aligned, and use a corresponding format ! item like F12.0 or F6.0 (but not F12.3, for example). ! ! After these two header lines, the contents are different in ! each case: ! ! f*.nki = Fault offset-rate components ! For each fault of regional scale: ! 1. Identifier of fault and slip component*, 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 determines the sense and component of slip ! whose rate is provided in this datum: ! R = Right-lateral (dextral) heave rate; ! L = Left-lateral (sinistral); ! D = Divergent or Detachment (extensional) heave rate; ! N = Normal (extensional) throw rate; ! P = thrust Plate or naPpe (convergent) heave rate; ! T = Thrust (convergent) throw rate; ! S = Subduction (convergent) heave rate. ! (*Note: More than one component can be entered for an oblique-slip ! fault, simply by using one line for the strike-slip component (R or L) ! and another line for the dip-slip component (D, N, P, T, or S). ! To reduce confusion, it is probably best to enter these two lines ! as adjacent data, but NeoKinema does not actually require this.) ! It is NOT permitted to enter more than one strike-slip component ! or more than one dip-slip component for any single fault trace. ! 2. Descriptive text with fault name, location, ... ! 3. Offset rate (slip, throw, or heave rate), in mm/year. ! Always a positive number, or zero. ! In the case of thrust (T) or normal (N) faulting, this number ! is the relative vertical offset (throw) rate ! of the two sides, which can usually be measured more ! accurately than slip rate. ! In all other cases (D, N, P, T, S) this number gives the ! relative horizontal velocity (heave rate) component ! perpendicular to the fault trace. ! 4. Standard error (sigma_; 68%-confidence ; half of 95%- ! confidence) of offset rate, in mm/year. May be large. ! However, may NOT be zero or negative. ! NOTE: It is perfectly reasonable to enter an offset rate of "0.0" ! and a large uncertainty (e.g., "49.9") for any fault for which ! you have no information. Then, this fault will be free to slip ! at any rate that will improve the fit of other data. (However, ! it will also be free to slip in the "wrong" direction! ! 5. Creeping? (T/F). If this fault is known to be creeping, at more ! than half of its long-term rate, then insert "T" in this column. ! This will indicate that nearby geodetic velocities should NOT ! be corrected for elastic strain accumulation along this fault. ! (This logical flag will also be copied to the h_token_nko ! output file, where it will eliminate any seismicity footprint ! for this fault in runs of PROGRAM Long_Term_Seismicity.) ! Otherwise, insert "F" for the normal case of a stick-slip fault. ! 6. Minimum/upper limit of seismogenic locked patch, in km of depth. ! Use a negative number if not known ("-1.0") and NeoKinema will ! substitute the appropriate value from the parameter input file ! p*.nki. {This entry is not used if Creeping? flag = T.} ! 7. Maximum/lower limit of seismogenic locked patch, in km of depth. ! Use a negative number if not known ("-1.0") and NeoKinema will ! substitute the appropriate value from the parameter input file ! p*.nki. {This entry is not used if Creeping? flag = T.} ! - - - - OPTIONAL additional columns added in NeoKinema version 3.01: - - - ! 8. Lower limit on offset rate in column 3, in mm/a. Must be lower. ! 9. Upper limit on offset rate in column 3, in mm/a. Must be higher. ! [Note: It is permissible to include a lower limit in column 8 but ! omit the upper limit. You may even wish to give a lower limit ! of "0.0" for all faults, to prevent them slipping in the ! wrong direction. However, if you wish to specify only ! an upper limit, you will need to enter a dummy place-holder ! lower limit, which can be very negative (e.g., "-999.").] ! ! s*.nki = most-compressive horizontal principal Stress directions ! For each assemblage of stress indicators: ! 1. Text-string #1, which could be a reference ! in short form (e.g., "Jones, 1991")? ! 2. Text-string #2, which might give location and state abbreviation? ! 3. East longitude, in decimal degrees (e.g., -106.92) ! 4. North latitude, in decimal degrees (e.g., 43.81) ! 5. Azimuth, measured clockwise from North, in degrees; ! may be either integer (I format) or real (F/E/D format). ! 6. Standard deviation (sigma_; +- for 68%-confidence; half of +- for ! 95%-confidence) of stress azimuth, in degrees, integer or real, ! OR: ! letter quality index (A, B, C, D, E) from World Stress Map ! (in which case the corresponding FORMAT item #7 is an A, not I or F). ! Note that stress-direction data should not be restricted to those ! within the area of the F-E grid (.feg file). Additional data up to ! 22 degrees arc distance from the grid edge can provide additional ! constraints on interpolated stress directions, and should be provided ! as input if available. (In this respect, NeoKinema differs from ! Restore, which is not able to utilize stress directions outside the ! .feg grid area.) ! ! -f*.dig, the file of digitised fault traces, must have some combination ! of the following formats (basic, or more complex): ! V---(column 1). [16 sample lines of f*.dig follow this line.] ! F0489 ! -1.11661E+02,+3.92411E+01 ! -1.11636E+02,+3.92543E+01 ! -1.11615E+02,+3.92747E+01 ! -1.11592E+02,+3.92896E+01 ! -1.11570E+02,+3.93063E+01 ! -1.11549E+02,+3.93249E+01 ! -1.11525E+02,+3.93436E+01 ! -1.11503E+02,+3.93622E+01 ! -1.11484E+02,+3.93824E+01 ! -1.11462E+02,+3.94046E+01 ! -1.11443E+02,+3.94248E+01 ! -1.11434E+02,+3.94274E+01 ! *** end of line segment *** ! F0532RT Doozy dextral transpressive fault, MI ! dig_degrees 72.1 ! -1.12405E+02,+3.91402E+01 ! -1.123795+02,+3.91117E+01 ! -1.12365E+02,+3.90894E+01 ! -1.12355E+02,+3.90844E+01 ! -1.12317E+02,+3.90801E+01 ! [... and so on...] ! Each fault trace must be introduced by a label line written ! by WRITE (nn,"('F',I4)") fltnum ! where the INTEGER :: fltnum is used to tie the trace to ! data in file f*.nki. ! (If you wish, you can follow the F1234 number with one or two ! bytes indicating the sense of slip on the fault, such as ! F1234R or F1234RT. These notations are IGNORED by NeoKinema, ! which takes the sense of each slip component from the f*.nki ! file. However, these notations are USED by NeoKineMap for ! plotting fault traces in the appropriate color(s).) ! You are also encouraged to include the fault name on this line. ! Beginning with NeoKinema v3.02, there may be an optional ! second header line giving the fault dip, in any of these formats: ! "dip_degrees 45" or "dip_degrees 45.7" or "dip_degrees45" or ! "dip_degess45.7". What you can NOT enter is: ! "dip_degrees45SomethingElse" because there must be white-space ! immediately to the right of the dip number. (White-space ! characters include the new-line bytes CR and/or LF.) ! 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 line segment ***" starting in column 1. ! The order in which faults are digitised is unimportant. ! The number of points in each segment is unimportant ! (but there must be at least 2). ! The order in which they are numbered is unimportant, except ! that the 6-byte (6-character) identifiers must tie to F.DAT. ! 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. ! ! *.gps = Geodetic-velocity data file. ! Each .gps file will have 3 lines of headers: ! ------------------------------------------------------ ! File name and source(s) ! FORTRAN format for reading the data lines that follow the headers ! [ column header labels, in a standard order: ] ! E_lon_deg N_lat_deg v_E_mmpa v_N_mmpa v_E_sigma v_N_sigma correlation frame identifier(s) ! ------------------------------------------------------------------------------------------ ! with the (obvious) meanings: ! E_lon_deg = longitude, in degrees from Greenwich meridian, with East positive ! N_lat_deg = latitude, in degrees from equator, with North positive ! v_E_mmpa = velocity component to East, in millimeters per year ! v_N_mmpa = velocity component to North, in millimeters per year ! v_E_sigma = standard deviation (1-sigma) of v_E_mmpa, also in mm/a ! v_N_sigma = standard deviation (1-sigma) of v_N_mmpa, also in mm/a ! correlation = coefficient of correlation between v_E_mmpa and v_N_mmpa ! reference_frame = reference frame for velocity, left-justified, limited to 15 bytes ! identifier(s) = optional station name and/or source reference, if a compilation ! Following these headers there is one line of data per benchmark. ! ! *.gp2 Covariance matrix for velocity components listed in the ! preceding .gps file. Order of degrees of freedom is: ! East component before North component for each benchmark, ! and benchmarks in same order as in the .gps file. ! Note that the .gp2 file is symmetrical, so it is sufficient ! to enter the diagonal and upper (or lower) triangle. ! Zero values do not need to be entered. ! Values can be entered in any order. ! Each line in the .gp2 file has: ! irow jcolumn variance ! where: irow is an integer ! jcolumn is an integer ! variance is a real number in units of (mm/a)**2. ! Note that variance is required to be positive for all diagonal entries; ! zero is not acceptable on the diagonal. ! If "variance" does not agree with information from the .gps file, ! then information from the .gps file is over-written and replaced. ! -------------------------------------------------------- ! ! -Build the *.feg file with ORBWEAVE (using no fault elements), and ! renumber for minimum bandwidth with ORBNUMBR. ! -------------------------------------------------------- ! ! -Build the b*.nki file to go with *.feg and to specify which nodes ! have fixed velocities. (Unless you use GPS constraints, there ! must be at least 2 nodes!). This file begins with a title line; ! the bulk of the file is read with the Fortran list-directed ! input method, so column spacing and alignment are not important, ! but plate names (if used) must be inside quotation marks. ! Notice that my post-processing utility program OrbNumber, ! applied to any NeoKinema-type .FEG grid file, will produce ! an ordered list of boundary nodes; you can use this as the ! basis for your b*.nki file. ! For each node whose velocity you want to fix ! provide one line of b*.nki with EITHER: ! ! ordinal_integer node_number 2 velocity_in_m/s azimuth_in_degrees_clockwise_from_North, e.g.: ! 1 431 2 3.109E-09 90.0 ! ! --== OR ==-- ! ordinal_integer node_number 4 plate_ID_for_this_node, e.g.: ! 2 432 4 "PA" ! ! The leading ordinal_integer can be anything you like, but may not ! be omitted; I use it to count the boundary nodes. ! The following node number must refer to a boundary node in *.feg. ! The node numbers you use must be the NEW node numbers ! assigned by my renumbering utility OrbNumber; in order to see ! these, load the output *.feg file from OrbNumber back ! into OrbWin or OrbWeaver, 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. ! The code "2" means that both components of velocity are fixed ! by the velocity magnitude and azimuth you have specified; ! velocities are in meters per second, in any reference frame you like! ! The azimuth of the velocity is measured in degrees, clockwise ! from local North. Negative (counterclockwise) azimuths are allowed. ! The code "4" means that velocities should be computed from the ! PB2002 global plate model of Bird [2003; Geochemistry, Geophysics, ! Geosystems]. (The reference frame for velocities was previously ! specified in the last line of the parameter input file.) ! If you wish, you may also list other boundary nodes with code "0" ! which will just leave them free. No other codes are supported now. ! If relative plate rotations are available for the ! surrounding plates, then it is certainly desirable to ! provide boundary conditions all the way around the grid! ! Otherwise, one stable interior side is fixed, and the ! rest left free to move as determined by the geologic data. ! A free edge may be appropriate to represent the edge of the ! overriding plate in a subduction zone. ! -------------------------------------------------------- !==================================================================== ! ! 5. OVERVIEW OF OUTPUT DATASETS: ! !---------------------------------------------- ! *Text dataset: t*.nko 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 t*.nko's ! will be overwritten if they are not moved or renamed! ! ! *Interpolated stresses: s*.nko <22> ! These are created to record the stress directions ! interpolated to each element center, for plotting by NeoKineMap. ! Produced only if stress directions were input, and/or if faults ! were designated as stress indicators. ! There are 4 columns in the file, in this order: ! ! element_number successful_interpolation? azimuth standard_deviation ! ! Element numbers refer to the .feg file used in the run of NeoKinema. ! Successful_interpolation is a logical value (T/F). ! Azimuth is in degrees clockwise from North. ! Standard deviation (sigma) is also in degrees. ! (If successful_interpolation = F, the following two values ! are meaningless, and should not be used in graphics.) ! ! *Model offset-rates for faults: f*.nko <23> ! Same format as f*.nki, but limits on locking depth are omitted. ! Instead two new columns are added at the right-hand side ! to show the model prediction, and prediction error in units of sigma. ! Rates are mean heave or throw rates depending on fault sense; all are in mm/a. ! This is the low-resolution form of fault offset-rate ! output; for the high-resolution heave rates, see h*.nko. ! Note that NeoKinema takes no special action to prevent faults ! from slipping in the wrong direction (although this becomes quite ! unlikely if the ratio of neotectonic rate to uncertainty exceeds ! 2-3). Slip on faults can reverse over time, and the sign of the ! neotectonic rate is not always known with certainty; one may wish ! to see what sense NeoKinema predicts. If "wrong-way" slipping ! on any fault is unacceptable, one can simply delete that fault's ! rate(s) from the f*.nki file, and run NeoKinema again. ! ! *Model heave-rates of faults: h*.nko <24> ! Each fault trace is divided into a number of short segments ! (a segment is the intersection of a fault trace with a triangular finite element), ! and the segments will appear in seemingly random order in the file. ! Each segment is described by a line in the file, whose initial (left-hand) part looks like: ! F9078T heave-rate = 1.878 mm/a in (-120.399, 34.460)-(-120.391, 34.460) = element 1887 ! This information is used by NeoKineMap to plot model fault heave rates in detail. ! The full output line contains additional information on the right, e.g.: ! F9078T heave-rate = 1.878 mm/a in (-120.399, 34.460)-(-120.391, 34.460) = element 1887 creeping?: F, slip-rate = 1.999 mm/a ! and this information on fault creep (T/F) and slip rate is used by ! PROGRAM Long_Term_Seismicity ! ! *Reframed, unlocked geodetic velocities: g*.nko <27>. ! If a *.gps file was provided as input, a g*.nko file will be written ! as output. It may be different from the input file in 3 ways: ! (1) Re-framing of the velocities (if allowed) into the velocity reference ! frame which allows them to best-fit the current NeoKinema solution. ! Note that errors will remain; the velocities in g*.nko will ! not generally be equal to the computed model velocities around ! them (although they should be close). ! (Note that this correction is optional, and only occurs if ! parameter "floating_frame" = .TRUE. in the parameter input file. ! (2) Deletion of any benchmarks which did not fall within the area ! of the finite-element grid in the current .feg file. ! (3) Addition of estimated long-term-average coseismic velocities ! to benchmarks, based on the current fault slip rates in the ! model, and the fault locking depths read from the parameter ! input file, or from the right-hand columns of the f*.nki file. ! (Note that this correction is also optional; if you set Creeps? = T ! for all faults in f*.nki, no such correction will be performed. ! Use this option where faults creep freely ! at all times, or where the authors of the *.gps file have already ! corrected the velocities to add estimated mean coseismic rates.) ! ! *Neotectonic (long-term-average) velocities: v*.out <25>. ! A dataset of velocities at the nodes of the finite-element ! grid "*.feg" is also produced. This permits ! plotting diagrams of the neotectonics using NeoKineMap (or FiniteMap). ! Maps produced from this output file are comparable to plate tectonics ! and long-term-average fault offset rates. ! ! *Interseismic (short-term) velocities: v_interseismic_*.out <25>. ! A dataset of velocities at the nodes of the finite-element ! grid "*.feg" is also produced. This permits ! plotting diagrams of the neotectonics using NeoKineMap (or FiniteMap). ! Maps produced from this output file are comparable to geodetic ! (e.g., GPS) velocities collected in years with no major earthquakes. ! ! *Distributed permanent strain-rates of the elements: e*.nko <26>. ! For every continuum finite element in x_feg, a logical value (T/F) ! indicates whether the strain-rate in that element contained a ! contribution from faulting. If so, T is shown, followed by the ! non-faulting or distributed part of the strain-rate tensor. ! If not, then F is shown, followed by the strain-rate tensor (that ! could just as well have been computed from v*.out). ! All strain-rate tensors are horizontal-plane only (2 x 2) ! and are in (theta = S, phi = E) coordinates, so that the ! 3 values given are: theta-theta or N-S, theta-phi or SE, phi-phi or E-W. ! Note: All strain-rates discussed here are permanent (non-elastic) ! strain-rates which are achieved by some combination of frictional ! plasticity at shallow depths and/or dislocation creep at greater ! depths. Thus, they are considered to be independent of time, ! unlike the elastic part of the strain-rate which reverses sense ! during each earthquake cycle, and tends to a long-term mean ! rate of zero. ! !========================================================================= ! ! Fortran 90 free-form source code begins: ! ---------------------------------------------------------------- ! NOTE: Some kludgy coding intended to prevent 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. ! 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 NeoKinema USE Sphere ! my spherical-geometry code Sphere.f90; needed for Circles_Intersect, etc. USE Dislocation ! my code to correct observed benchmark velocities by ! adding estimated long-term-average coseismic velocities !========================================================================================================= ! External numerical-library links. Choose one (set) of USE statement(s), and comment-out the other(s)! !========================================================================================================= ! IMSL version (see MKL version below): !USE NUMERICAL_LIBRARIES !! DIGITAL version of International Mathematics Subroutine Library: !! DLSLPB: solves systems of linear equations with REAL*8 !! coefficients arranged in a special band storage mode. !! LSLSF & DLSLSF: solves systems of linear equations with symmetric !! matrix of real coefficients in uncompressed form. !! EVCRG: eigenvectors and eigenvalues of a real matrix. !! DLINDS: inverse of a real symmetric positive definite matrix. !! ERSET: diagnostic message options !! NOTE that the version I know (for 32-bit Windows XP) did not support !! 64-bit memory space, or parallel processing. However, there !! may be newer versions of IMSL that will do this(?). !! My one attempt to update IMSL to 64-bit, by buying a newer version !! from the Portland Group, was a miserable failure. !! This Portland Group version of IMSL is really intended to !! use in Unix, and the interface with GUI compiler interfaces !! like Microsoft Visual Studio is far too confusing and buggy. !====================================================================================== ! MKL version (see IMSL version above): USE MKL95_PRECISION USE MKL95_LAPACK ! Intel 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 MKL: ! dgbsv: Solve linear system with REAL*8 banded coefficient matrix ! in proprietary MKL "band storage scheme for LU factorization ". ! ssyevd: Eigenvalues and eigenvectors of a REAL symmetric full matrix. ! dsysv: Solve linear system with real symmetric indefinite matrix. ! dpotrf: Cholesky factorization of REAL*8 symmetric full matrix ! dpotri: Inversion of (factorized) REAL*8 symmetric full matrix ! {N.B. Calling generics like "potrf" and "potri" should work, but doesn't; ! the linker returns an "unresolved external symbol" error.} ! 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"}! !====================================================================================== !USE DFLIB, ARCQQ => ARC ! provided with Digital Visual Fortran, and ALSO ! available from within Intel Parallel Studio XE 2013 !(and its GUI of Microsoft Visual Studio), but ONLY by selecting ! Project/Properties/Fortran/Compatibility/Use PowerStation ! Portability Library. {Caution: May only work in 32-bit realm.} ! I am using only GETFILEINFOQQ, which provides names of files ! matching specifications like "p*.nki". Helps user select input file. ! If no substitute is available on your system when you compile, ! just omit SUBROUTINE File_List (and any CALLs to it). ! Note that I am not using their ARC, because I have my own Arc; so I am ! renaming their ARC to ARCQQ to avoid conflicts. IMPLICIT NONE ! All variable names must be declared. Prevents typos. !-------------------------------------------------------------------- TYPE :: is123 ! element & internal coordinates of any point on surface INTEGER :: element REAL, DIMENSION(3) :: s END TYPE is123 TYPE :: crack ! Intersection of a fault offset-rate component datum with ! a fault segment (which is itself the intersection a fault trace with an element). ! (There could be more than one one crack per segment, ! if the fault has known offset rates for both dip-slip and strike-slip; ! also, the crack concept appears in this code for compatibility with program Restore.) INTEGER :: datum ! offset-rate datum index (1..f_dat_count) INTEGER :: segment ! segment index REAL :: s_ ! goal heave-rate, converted from offset-rate, by rules according to 'f_sense' ! and the units are SI = m/s. REAL :: sigma_ ! standard deviation of goal heave-rate; ditto. REAL, DIMENSION(3) :: H ! see (11)-(17) of Bird (1998, Tectonics) CHARACTER(1) :: sense ! fault type is one of: T, P, N, D, R, L, S. LOGICAL :: shadow ! was this crack added to allow strike-slip flexibility on dip-slip faults? REAL :: p_ ! latest model estimate of heave-rate in m/s REAL :: component_dip_degrees ! variable fault dip, added in NeoKinema v.3.02 to ! optionally replace pre-programmed standard dips for dip-slip components. REAL :: extra_weight ! initially 1.0, but may be raised during latter 2/3 of iterations. END TYPE crack TYPE :: needle ! everything one needs to know about a stress datum REAL, DIMENSION(3) :: location ! Cartesian unit vector (need not be within .feg area) REAL :: azimuth ! clockwise from N, in radians REAL :: sigma ! uncertainty, radians !Note: Type "needle" in program Restore also includes component "relevance" (0.0 to 1.0) ! but that is omitted in NeoKinema because relevance == 1.0. END TYPE needle !-------------------------------------------------------------------- !CONSTANTS: Fixed conversion factors, in alphabetical order: INTEGER, PARAMETER :: bytes_per_int = 4 ! descriptive, not prescriptive! INTEGER, PARAMETER :: bytes_per_real = 4 ! descriptive, not prescriptive! INTEGER, PARAMETER :: bytes_per_double = 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 + 7 * bytes_per_real + 1 INTEGER, PARAMETER :: bytes_per_Mb = 1024 * 1024 INTEGER, PARAMETER :: nPlates = 52 ! referring to PB2002_plates.dig; not counting others that user may add INTEGER, PARAMETER :: nPlatesPlus = 152 ! expanding storage by (up to) 100 user-defined plates; should be enough! REAL, PARAMETER :: deg_per_rad = 180./3.141592654 !REAL, PARAMETER :: Pi = 3.14159265 ! commented-out because it also appears in MODULE Sphere, REAL, PARAMETER :: loosening_degpMa = 10. ! reference-frame-loosening rotation for geodesy (IF floating_frame) REAL, PARAMETER :: m_per_km = 1000. REAL, PARAMETER :: s_per_year = 365.25 * 24. * 60. * 60. REAL, PARAMETER :: small_rate_in_mps = 0.1 * 0.001 / s_per_year ! 0.1 mm/year ! and duplicate definitions cause a compiler error. REAL, PARAMETER :: normal_dip_degrees = 55.0 ! consistent with Bird & Kagan [2004] Table 5 value used in Long_Term_Seismicity REAL, PARAMETER :: thrust_dip_degrees = 20.0 ! consistent with Bird & Kagan [2004] Table 5 value used in Long_Term_Seismicity REAL, PARAMETER :: subduction_dip_degrees = 14.0 ! consistent with Bird & Kagan [2004] Table 5 value used in Long_Term_Seismicity !-------------------------------------------------------------------- !VARIABLES: All global variables except arrays, in alphabetical order: REAL :: A0 ! area of continuum whose stiffness & isotropy gets unit weight (in m**2) LOGICAL :: any_shadow_pseudodata LOGICAL :: any_stress ! any stress constraints? REAL :: argume ! property of a dislocation patch; input to Change LOGICAL :: azimuth_is_integer ! while reading s_dat INTEGER :: external_benchmarks ! count of benchmarks in the .gps file (or zero if none) CHARACTER(61) :: bar_graph ! ASCII version of progress graph INTEGER :: bcs_count ! # of boundary-condition nodes REAL :: bracket_high ! temp storage for upper limit on fault offset rate, in mm/a REAL :: bracket_low ! temp storage for lower limit on fault offset rate, in mm/a INTEGER*8 :: bytes_added_I8 ! increment to memory_bytes_I8; must be INTEGER*8 because one array may exceed 4 GB. ! N.B. Create these large values by mutiplying INT8(rows) * INT8(columns), for example. DOUBLE PRECISION:: c11,c12,c21,c22 ! local covariance of velocities at one geodetic benchmark CHARACTER(1) :: c, c1 !(temporary) CHARACTER(4) :: c4 !(temporary) CHARACTER(6) :: c6 !(temporary) CHARACTER(30) :: c30, c30a !(temporary) CHARACTER(50) :: c50 !(temporary) CHARACTER(80) :: c80 !(temporary) CHARACTER(134) :: c134 !(temporary) LOGICAL :: check_if ! any node lies "on" a fault trace CHARACTER(10) :: clock_time ! wall clock time LOGICAL :: conservative_geodetic_adjustment ! IF (T), use geologic slip rates for ! coseismic adjustment of geodetic velocities; ! this switch may suppress troublesome instabilities ! that sometimes appear during iteration of velocity solution. REAL :: correlation ! coefficient of correlation between vE_mmpa and vN_mmpa INTEGER :: crack_count ! total number of cracks LOGICAL :: creeping ! is this fault creeping? 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_gps ! lower limit of Delta_node, based on internal geodetic benchmarks DOUBLE PRECISION:: determinant ! used in inverting 2x2 GPS covariance matrix to local normal matrix REAL :: dip_degrees ! temporary storage for a single fault dip REAL :: dipf ! dip of a dislocation patch; input to Change; note that it is usually >= 1.570796 LOGICAL :: dump_all_solutions ! flag, for outputting velocity solutions in EVERY iteration REAL :: duphi, duthet ! output from Change; E, S components of velocity due to one dislocation patch INTEGER :: entries_read ! number of entries processed in .gp2 file LOGICAL :: faults_give_sigma_1h ! are faults stress indicators? CHARACTER(80) :: f_dig ! filename, digitized traces INTEGER :: f_dig_count ! # of points in f_dig CHARACTER(80) :: f_dat ! filename, offset-rate data INTEGER :: f_dat_count ! # of data in f_dat (including shadow pseudo-data) INTEGER :: f_dat_dimension ! size of arrays of fault slip rate components; may be a bit larger ! than strictly necessary, due to allowance for shadow pseudo-data ! which will not necessarily be inserted (because user may have ! specified both slip-rate components). CHARACTER(134) :: f_dat_format ! to read offset-rate data CHARACTER(134) :: f_dat_titles ! to print offset-rate data INTEGER :: f_highest ! max fault trace index (.LE. 9999) REAL :: factor ! converts tabulated offset-rate to internal LOGICAL :: floating_frame ! is the reference-frame of geodetic-velocity data allowed to float? REAL :: floor = 10. * EPSILON(floor) LOGICAL :: folding ! finite element grid is folded (illegal) REAL :: fphi, ftheta ! fault location in spherical coordinates (radians) REAL :: gamma_ ! uncertainty of stress direction INTEGER :: geodetic_nDOF ! = 2 * internal_benchmarks LOGICAL :: got_dip_degrees ! flag "dip_degrees" was found in this line of f*.dig LOGICAL :: got_index ! during reading of f_dig LOGICAL :: got_point ! during reading of f_dig CHARACTER(80) :: gps_file ! filename, geodetic velocities at benchmarks CHARACTER(80) :: gp2_file ! filename, covariance matrix of geodetic velocity components CHARACTER(134) :: gps_format ! format (second) line of .gps file CHARACTER(134) :: gps_header ! header (third) line of .gps file CHARACTER(134) :: gps_title ! title (first) line of .gps file REAL :: half_R2 ! R**2/2. CHARACTER*80 :: h_token_nko_file ! name of annotated .dig file for output of heave rates of segments INTEGER :: i_external, i_internal ! benchmark indexes, used in error-reporting INTEGER :: i,i1,i2,i3 ! (temporary) INTEGER :: ibase ! (temporary) LOGICAL :: ignore_warning ! user's decision at the keyboard INTEGER :: info ! success code returned from LAPACK in MKL INTEGER :: internal_benchmarks ! count of geodetic benchmarks in the area of the .feg file INTEGER :: internal_ios ! (temporary; I/O status from an internal READ) INTEGER :: ios ! (temporary; I/O status; like read_status) LOGICAL :: in_trace ! during reading of f_dig INTEGER :: j, j1, j2, j3 ! (temporary) INTEGER :: jold, jtest ! (temporary, for use with bar_graph) INTEGER :: k ! (temporary) INTEGER :: l_ ! finite element index REAL :: L0 ! length of fault trace whose offset rate gets unit weight (in m) REAL :: lat, lon ! latitude, longitude INTEGER :: leading_text_bytes ! adjustable leading label of oft-repeated completion-bar code INTEGER :: lda ! leading DIMENSION of ABCDEF, for LSLPB of IMSL package DOUBLE PRECISION:: lf ! dislocation property; input to Change; DP for historical continuity w/ OrbScore INTEGER :: line ! line number of any input file INTEGER :: loc_in_c_1 ! position in a text string INTEGER :: loc_in_c_2 ! position in a text string INTEGER :: loc_in_c_3 ! position in a text string REAL :: locking_depth_m_min ! default value for any fault with "negative" locking depth in f*.nki REAL :: locking_depth_m_max ! default value for any fault with "negative" locking depth in f*.nki REAL :: locking_depth_m_subduction_min ! default value for any fault with "negative" locking depth in f*.nki REAL :: locking_depth_m_subduction_max ! default value for any fault with "negative" locking depth in f*.nki INTEGER*8 :: memory_bytes_I8 ! bytes of memory in all arrays; must be INTEGER*8 because total may exceed 4 GB. REAL :: minimal_bracket_gap_mps ! 0.0008 mm/a expressed in units of m/s INTEGER :: MKLdRow ! global addressing parameter, used instead of statement-function indirect addressing {which is buggy!} REAL :: mu_ ! scalar measure (L1?) of anelastic strain rates in continuum (/s) DOUBLE PRECISION:: N11,N12,N21,N22 ! local normal matrix of velocities at one geodetic benchmark INTEGER :: n, n1, n2 ! temporary counters INTEGER :: n_brackets_tightened ! added up in subprogram Prediction, but reported from subprogram Solve_for_vw INTEGER :: n_items_done ! temporary counter INTEGER :: n_refine ! # refinements of each velocity solution; now required to be at least 6 INTEGER :: nCoDa ! # of codiagonals (each side) in ABCD (or ABCD portion of ABCDEF) INTEGER :: nDOF ! # of degrees of freedom, = 2 * num_nod REAL :: new_mu_from_L1 ! suggestion for mu_ in future run(s) of NeoKinema REAL :: new_mu_from_L2 ! suggestion for mu_ in future run(s) of NeoKinema INTEGER :: nfl ! # of fault elements (must be zero!) INTEGER :: node_high, node_low ! highest- and lowest-numbered nodes associated with geodetic benchmarks REAL :: node_phi, node_theta ! node location in spherical coordinates, in radians INTEGER :: nPlatesDefined ! begins =nPlates, but user defintions may expand the list, up through nPlatesPlus INTEGER :: num_bad ! # of nodes lying on fault traces INTEGER :: num_ele ! # of finite elements INTEGER :: num_nod ! # of nodes in x_feg CHARACTER(80) :: parameter_file ! name of p*.nki file CHARACTER(80) :: path_in !(dummy, to satisfy File_List) CHARACTER(2) :: plate_c2 ! two-byte name of moving plate in a type-4 BC INTEGER :: plate_index ! subscript of moving plate in arrays names and omega REAL :: pole_lat, pole_lon ! Euler pole latitude and longitude in decimal degrees (N, E = +) REAL :: pole_degPerMa ! Euler pole rate in degrees/Ma (counterclockwise = +) LOGICAL :: pole_table_needed ! if any value in pole_used becomes TRUE CHARACTER(12) :: pole_note_c12 ! either "built-in " or "user-defined" REAL :: R ! see Bird (1998) CHARACTER(2) :: reference_plate_c2 ! two-byte name of plate giving velocity reference frame for type-4 BC's INTEGER :: reference_plate_index ! subscript of reference plate in arrays names and omega REAL, DIMENSION(3) :: r_ ! position on sphere, as unit vector from its center; NOT the same as R = Earth radius. REAL :: r1, r2 !(temporary) REAL :: rate_mps ! fault offset rate in meters per second INTEGER :: read_status ! did READ work? INTEGER :: s ! loop index for stress-related computations CHARACTER(80) :: s_dat ! filename, stress directions INTEGER :: s_dat_count ! number of paleostress data from s_dat CHARACTER(134) :: s_dat_format ! to read paleostress data CHARACTER(134) :: s_dat_titles ! to write paleostress data REAL :: s_error_count ! total area of elements with interpolated stress direction / A0 REAL :: s1h_azim_degrees ! while reading s_dat; will convert to radians INTEGER :: s1h_azim_int ! while reading s_dat; will convert to real degrees CHARACTER*1 :: s1h_sigma_c1 ! (ditto) REAL :: s1h_sigma_degrees ! while reading s_dat; will convert to radians INTEGER :: s1h_sigma_int ! while reading s_dat; will convert to real degrees INTEGER :: seg_count ! number of fault segments (element ^ trace) INTEGER :: segment ! counter, along a single fault trace CHARACTER*1 :: sense ! R, L, T, N, D, S, ... LOGICAL :: sigma_is_integer ! while reading s_dat REAL :: sigma_offnormal_degrees ! sigma, in degrees, of angle between [heave vectors of dip-slip faults] & [trace-normal direction] REAL, DIMENSION(3):: sliprate_mps_x1x2x3 ! 3-vector of dislocation (anti-)slip rate, in meters/second, input to Change INTEGER :: stress_count ! number of "real" and/or rake-based pseudo- stress directions available INTEGER :: stress_interpolation_method ! user input parameter: (1) Bird & Li [1996]; (2) Carafa & Barba [2013]. INTEGER :: stressed_continuum_elements ! count of elements with no faults, but interpolated stress direction REAL :: sum !(temporary) REAL :: t, t1, t2, t3 !(temporary) DOUBLE PRECISION:: t_mps2 !(temporary geodetic covariance component, in (m/s)**2) CHARACTER(80) :: t_nko_file_name ! full name of text output file: t*.nko, where * = token CHARACTER(80) :: token ! name token, for use in building output file names REAL, DIMENSION(3):: tv,tv1,tv2,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! INTEGER :: unsafe_GPS_count ! returned by Unsafe_Benchmarks() CHARACTER*1 :: uplo ! 'U' or 'L'; used in calls to LAPACK of MKL LOGICAL :: using_A_to_E ! while reading s_dat LOGICAL :: using_gp2_file ! if gp2_file /= "none" LOGICAL :: using_GPS_matrices ! = floating_frame.OR.using_gp2_file REAL :: vE_mmpa, vN_mmpa ! geodetic velocity components in mm/a REAL :: vE_sigma, vN_sigma ! standard deviations of geodetic velocity components, in mm/a CHARACTER(80) :: version ! NeoKinema version number and date (etc.) in a short comment LOGICAL :: warned_of_big_offset_sigma ! if so, then don't warn again INTEGER :: x !(temporary; = 1 or 2; see Gjxy) CHARACTER(80) :: x_bcs, x_feg ! current b*.nki and .feg file names REAL :: x1, x2 !(temporary) REAL :: xi_ !"small" increment in strain rate; try 3.2E-17 /s (with a 32-bit solver) INTEGER :: y !(temporary; = 1 or 2; see Gjxy) REAL :: z1, z2 ! minimum and maximum locking depth for one fault, in km (later converted to m) CHARACTER(5) :: zone ! time zone REAL :: zbot, ztop ! depth limits on dislocation; input to Change !-------------------------------------------------------------------- !VARS !ARRAYS, in alphabetical order: REAL, DIMENSION(:),ALLOCATABLE :: a_ ! area of plane triangle element beneath surface, m**2 !(1:num_ele = element index l_) !============================================================================ ! IMSL version (see MKL version below): ! Note that IMSL requires combining the banded coefficient matrix (ABCD) ! and the right-hand-side vector (EF) into a single array (ABCDEF). ! Thus, the IMSL version has no array ABCD. See entry ABCDEF above. !============================================================================ ! MKL version (see IMSL version above): DOUBLE PRECISION, DIMENSION (:,:), ALLOCATABLE :: ABCD ! coefficient matrix of linear system used to solve for velocity ! components; see (4) and (5) of Bird (1998?). ! Stored in MKL's "band storage scheme for LU factorization", in which column ! #s are unchanged, but row #s are flattened to produce a smaller, rectangular ! matrix with (nCoDa + (nCoDa+1+nCoDa)) rows. The diagonal becomes a row. ! Unfortunately, there does not seem to be any provision for ! designating the matrix symmetric, and thus storing only one side! !============================================================================ !============================================================================ ! IMSL version (see MKL version below): DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: ABCDEF ! coefficient matrix of linear system used to solve for velocity ! components; see (4) and (5) of Bird (1998?). ! Stored in codiagonal band symmetric storage mode of Microsoft IMSL, ! in which an extra column is added on right to contain right-hand-side ! vector of the linear system. Also, extra rows are provided at top. ! Logically-diagonal entries are found in column 1, rows nCoDa+1:nCoDa+nDOF=lda. ! The right-hand-side vector is in column nCoDa+2, rows nCoDa+1:nCoDa+nDOF=lda. !(1:nCoDa+nDOF=lda; 1:nCoDa+2). !============================================================================ ! MKL version (see IMSL version above): ! Note that MKL does NOT combine the right-hand-side (EF) with the ! coefficient matrix (ABCD) to create a single matrix (ABCDEF). ! Therefore, in the MKL version of NeoKinema, there are different ! ALLOCATE statements. See arrays ABCD and EF in this guide. !============================================================================ !============================================================================ ! IMSL version (see MKL version below): ! Note that IMSL requires combining the banded coefficient matrix (ABCD) ! and the right-hand-side vector (EF) into a single array (ABCDEF). ! Thus, the IMSL version has no array ER. See entry ABCDEF above. !============================================================================ ! MKL version (see IMSL version above): DOUBLE PRECISION, DIMENSION (:,:), ALLOCATABLE :: EF ! right-hand-side forcing vector used to solve for velocity ! components; see (4) and (5) of Bird (1998?). ! The second subscript is always 1 (one column) but linker ! errors will result if this dummy column index is omitted! !============================================================================ DOUBLE PRECISION, DIMENSION(:,:,:), ALLOCATABLE :: benchmark_covariance ! local 2x2 covariance matrix of velocity components, in (Theta, Phi) ! coordinate system, and units of (m/s)**2; ! (1:2 = Theta,Phi; 1:2 = Theta,Phi; 1:external_benchmarks = external benchmark index); LATER: ! (1:2 = Theta,Phi; 1:2 = Theta,Phi; 1:internal_benchmarks = internal benchmark index) after compaction DOUBLE PRECISION,DIMENSION(:,:,:,:),ALLOCATABLE:: benchmark_G ! 3 x 2 x 2 matrix of nodal functions for the element containing the benchmark; ! dimensionless, of order 1. !(j=1:3 : local node numbering in element) !(x=1:2 : node j has unit velocity to South(1) or East(2)) !(y=1:2 : South(1) or East(2) component of vector nodal function) !(1:external_benchmarks = external benchmark index); LATER: !(1:internal_benchmarks = internal benchmark index) after compaction TYPE(is123), DIMENSION(:), ALLOCATABLE :: benchmark_is ! locations of geodetic benchmarks in internal coordinates ! (1:external_benchmarks = external benchmark index); LATER: ! (1:internal_benchmarks = internal benchmark index) after compaction REAL, DIMENSION(:), ALLOCATABLE :: benchmark_model_vw ! model predictions of velocity components at geodetic benchmarks, ! m/s, in NeoKinema coordinate system: Theta(S), Phi(E). ! There are two entries per benchmark. !(1:internal_benchmarks = internal benchmark index) CHARACTER(80), DIMENSION(:), ALLOCATABLE :: benchmark_name ! any site name or reference to source that follows the velocity reference frame in the .gps file; ! saved to be output into the g*.nko file. ! (1:external_benchmarks = external benchmark index); LATER: ! (1:internal_benchmarks = internal benchmark index) after compaction DOUBLE PRECISION,DIMENSION(:,:,:),ALLOCATABLE :: benchmark_normal ! local 2x2 normal matrix; inverse of the local covariance of velocity components, which (cov.) is in (Theta, Phi) ! coordinate system, and units of (m/s)**2; ! (1:2 = Theta,Phi; 1:2 = Theta,Phi; 1:external_benchmarks = external benchmark index); LATER: ! (1:2 = Theta,Phi; 1:2 = Theta,Phi; 1:internal_benchmarks = internal benchmark index) after compaction REAL, DIMENSION(:), ALLOCATABLE :: benchmark_phi ! longitude of benchmark, in radians E from Greenwich meridian ! (1:external_benchmarks = external benchmark index); LATER: ! (1:internal_benchmarks = internal benchmark index) after compaction REAL, DIMENSION(:), ALLOCATABLE :: benchmark_theta ! colatitude of benchmark, in radians from N pole ! (1:external_benchmarks = external benchmark index); LATER: ! (1:internal_benchmarks = internal benchmark index) after compaction REAL, DIMENSION(:), ALLOCATABLE :: benchmark_reframed_vw ! velocity components at geodetic benchmarks, ! after change of reference frame so as to best-fit the NeoKinema model, ! in m/s, in NeoKinema coordinate system: Theta(S), Phi(E). ! There are two entries per benchmark. !(1:internal_benchmarks = internal benchmark index) REAL, DIMENSION(:), ALLOCATABLE :: benchmark_unlocked_vw ! velocity components at geodetic benchmarks, ! corrected for (estimated) missing coseismic slip/year, ! in m/s, in NeoKinema coordinate system: Theta(S), Phi(E). ! There are two entries per benchmark. ! When first read, all (external) benchmarks are included. ! After compaction, only internal benchmarks are included. REAL, DIMENSION(:,:), ALLOCATABLE :: benchmark_uvec ! location of geodetic benchmark; ! Cartesian unit vector from Earth center: ! (1:3 = x,y,z; 1:external_benchmarks = external benchmark index); LATER: ! (1:3 = x,y,z; 1:internal_benchmarks = internal benchmark index) after compaction REAL, DIMENSION(:), ALLOCATABLE :: benchmark_vw ! observed velocity components at geodetic benchmarks, ! m/s, in NeoKinema coordinate system: Theta(S), Phi(E). ! There are two entries per benchmark. ! When first read, all (external) benchmarks are included. ! After compaction, only internal benchmarks are included. 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, DIMENSION(:,:),ALLOCATABLE :: center ! Cartesian unit vectors at center of finite elements !(1:3 = x,y,z; 1:num_ele = element index l_) REAL, 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) DOUBLE PRECISION,DIMENSION(:,:),ALLOCATABLE :: covariance_mps2 ! geodetic covariance matrix for horizontal velocity components, ! in units of (m/s)**2. Only internal benchmarks are included. ! Ordering is same as in external .gps file. ! vTheta = vSouth is numbered before vPhi = vEast for each benchmark. ! Matrix is symmetric so half of the information is redundant. !(1:geodetic_nDOF, 1:geodetic_nDOF) ! See matrix "normal" for the inverse matrix. INTEGER, DIMENSION(8) :: datetimenumber ! for output from DATE_AND_TIME REAL, 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, 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, DIMENSION(:,:),ALLOCATABLE :: ele_strainrate ! continuum strain-rate tensor (not including fault strain) ! at center of each element, saved to be output for plotting ! by NeoKineMap; also used by Long_Term_Seismicity; ! no other use by NeoKinema. !(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 an 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, DIMENSION(3) :: Euler ! Cartesian representation of Euler rotation-rate vector for ! relative plate rotation, in units of radians per second. INTEGER, DIMENSION(:), ALLOCATABLE :: external_benchmark_index ! pointer to geodetic benchmark in .gps and .gp2 files; ! needed because indeces are changed when benchmarks are ! decimated to retain only those within the .feg area. !(1:internal_benchmarks = internal benchmark index) LOGICAL(1), DIMENSION(:), ALLOCATABLE :: f_creeping ! Is this fault creeping? (If so, no need to correct local geodetic velocities.) !(1:f_dat_count) REAL, DIMENSION(:), ALLOCATABLE :: f_dat_dip_degrees ! dip angle associated with one offset-rate component. ! If dip_degrees header was read from f*.dig, value is inherited from that. ! If not, standard default dip values (normal_dip_degrees, thrust_dip_degrees, ! or subduction_dip_degrees, or 90.0 for strike-slip) are used. ! The f_dat_dip_degrees for a shadow R/L strike-slip component is ! inherited from its parent dip-slip fault. ! Note that when a fault is user-specified as having oblique slip ! (e.g., RT, LT, RN, LN, RP, LP, RD, LD) but no dip_degrees is ! given for that fault trace, the two components will have ! *DIFFERENT* values for f_dat_dip_degrees; this is intentional, ! and give the fault an effectively steep dip if it turns out ! to be primarily strike-slip, or an effectively gentler dip ! if it turns out to be primarily dip-slip. !(1:f_dat_count) LOGICAL(1), DIMENSION(:), ALLOCATABLE :: f_dat_shadow ! is this entry a shadow strike-slip component on a dip-slip fault? !(1:f_dat_count) REAL, DIMENSION(:), ALLOCATABLE :: f_dip_degrees ! Fault dip read from optional header line with "dip_degrees" flag ! in the f*.dig file. New feature added in NeoKinema v. 3.02. ! Will remain as "0.0" if no "dip_degrees" flag was found, ! and this will be interpreted as meaning that standard pre-programmed ! fault dips should be used. !(0:f_highest = trace index, e.g., "1234" in "F1234N My fault" header) REAL, 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-rate datum !(1:2 = numerator/denominator; 1:f_dat_count = offset-rate index) REAL, DIMENSION(0:2) :: f_err ! 3 norms of fault offset-rate error !(each normalized by sigma before combining): !(0:2 = N0,N1,N2 norm). REAL, DIMENSION(:),ALLOCATABLE :: f_locking_depth_m_max ! Maximum/lower/deeper limit of seismogenic locked patch, in m. ! Measured vertically, not down dip! Should be zero or positive. ! Negative value is treated as a flag indicating ! unknown depth, in which case default value locking_depth_m_max ! or locking_depth_m_subduction_max from the p*.nki file will be applied. ! (1:f_dat_count = offset-rate datum index) REAL, DIMENSION(:),ALLOCATABLE :: f_locking_depth_m_min ! Minimum/upper/shallower limit of seismogenic locked patch, in m. ! Measured vertically, not down dip! Should be zero or positive. ! Negative value is treated as a flag indicating ! unknown depth, in which case default value locking_depth_m_min ! or locking_depth_m_subduction_min from the p*.nki file will be applied. ! NOTE: Beginning in NeoKinema v2.3, this upper (minimum) locking depth ! is no longer used in correcting the geodetic velocities to long-term ! (fault-unlocked) targets. ! (1:f_dat_count = offset-rate datum index) REAL, DIMENSION(:),ALLOCATABLE :: f_model_offset_rate ! rates of fault offset, according to NeoKinema solution, in m/s; ! may be heave or throw rate; interpretation depends on f_sense. ! (1:f_dat_count = offset-rate datum index) REAL, DIMENSION(:),ALLOCATABLE :: f_old_model_offset_rate ! rates of fault offset, according to NeoKinema solution, in m/s; ! may be heave or throw rate; interpretation depends on f_sense. ! Unlike f_model_offset_rate, this array remembers PREVIOUS values ! used in the preceding iteration, so that damping can be implemented. ! (1:f_dat_count = offset-rate datum index) REAL, DIMENSION(:),ALLOCATABLE :: f_offset_rate ! rates of fault offset, according to input datum, in m/s; ! may be heave or throw rate; interpretation depends on f_sense. ! (1:f_dat_count = offset-rate datum index) LOGICAL(1), DIMENSION(:), ALLOCATABLE :: f_offset_rate_bracketed ! TRUE at end of computation if f_offset_extra_weight was increased ! above 1.0 to force f_offset_rate to lie between f_offset_rate_floor ! and f_offset_rate_ceiling. !(1:f_dat_count = offset-rate datum index) REAL, DIMENSION(:), ALLOCATABLE :: f_offset_rate_floor ! hard lower limit on fault offset rate, m/s; ! interpretation depends on f_sense; may be negative. !(1:f_dat_count = offset-rate datum index) REAL, DIMENSION(:), ALLOCATABLE :: f_offset_rate_ceiling ! hard lower limit on fault offset rate, m/s; ! interpretation depends on f_sense. !(1:f_dat_count = offset-rate datum index) REAL, DIMENSION(:), ALLOCATABLE :: f_offset_rate_sigma_ ! uncertainty in fault offset rate, m/s; ! interpretation depends on f_sense. !(1:f_dat_count = offset-rate datum index) CHARACTER(1), DIMENSION(:), ALLOCATABLE :: f_sense ! T = thrust, P = nappe, N = normal, D = detachment, R = dextral, L = sinistral, S = subduction ! (1:f_dat_count = offset-rate datum index) CHARACTER(50), DIMENSION(:), ALLOCATABLE :: fault_name ! (1:f_dat_count = offset datum index) DOUBLE PRECISION, DIMENSION(3,2,2) :: G ! matrix of nodal functions for one point in one element; ! dimensionless, of order one. !(j=1:3 : local node numbering in element) !(x=1:2 : node j has unit velocity to South(1) or East(2)) !(y=1:2 : South(1) or East(2) component of vector nodal function) REAL, DIMENSION(0:2) :: gps_err ! 3 norms of geodetic velocity error !(each normalized by sigma before combining): !(0:2 = N0,N1,N2 norm). REAL, DIMENSION(:,:), ALLOCATABLE :: 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. ! Note that stress_interpolation_method = 1 [Bird & Li, 1996] ! versus stress_interpolation_method = 2 [Carafa & Barba, 2013] ! result in different matrix dimensions and values. INTEGER, DIMENSION(:), ALLOCATABLE :: internal_benchmark_index ! pointer to geodetic benchmark in NeoKinema arrays; ! needed because indeces are changed when benchmarks are ! decimated to retain only those within the .feg area. ! A value of zero means the benchmark is not inside the .feg area. !(1:external_benchmarks = external benchmark index) TYPE(crack), DIMENSION(:), ALLOCATABLE :: local_crack ! a compilation (using structure type crack) of all needed ! information to describe active fault segment, ! sorted by element number. See crack_index for location. !(1:crack_count = crack index). REAL, DIMENSION(:), ALLOCATABLE :: looseness ! vector of horizontal velocity components (vTheta, vPhi) ! at internal geodetic benchmarks produced by applying ! Eulerian rotation of loosening_degpMa about one of the ! three Cartesian axes. Units of m/s. !(1:geodetic_nDOF, or 1:2*internal_benchmarks) REAL, DIMENSION(0:2) :: mu_err ! 3 norms of error wrt continuum stiffness constraint, !(that is, strain-rate of nominally rigid lithosphere) ! each normalized by mu_: !(0:2 = N0,N1,N2 norm). REAL, DIMENSION(:), ALLOCATABLE :: mu_nod ! uncertainty (sigma_) of the nominally-zero strain-rate of stable ! areas; if 0. is read, mu_ is substituted for that node ! (1:num_nod = node index) CHARACTER(LEN=2), DIMENSION(nPlatesPlus) :: names ! two-character identifiers for the rigid plates; ! see Bird [2002] for global plate model PB2002, which identifies plates #1-52. TYPE(needle),DIMENSION(:), ALLOCATABLE :: needles ! stress data table !(1:stress_count = stress datum index; e.g., s) INTEGER, DIMENSION(:,:), ALLOCATABLE :: neighbor ! list of neighboring finite elements !(1:3 = side crossed; 1:num_ele = element index l_) 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, DIMENSION(3) :: node_uvec ! temporary Cartesian unit vector REAL, DIMENSION(3, nPlatesPlus) :: omega ! Euler rotation-rate vectors for all rigid plates in global ! plate model PB2002 of Bird [2002], plus any others that user may define at run-time. DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: normal ! geodetic "normal" matrix which is the inverse of the geodetic ! covariance matrix "covariance_mps2" for horizontal velocity components, ! and therefore is in units of (m/s)**-2. Only internal benchmarks are included. ! Ordering is same as in external .gps file. ! vTheta = vSouth is numbered before vPhi = vEast for each benchmark. ! Matrix is symmetric so half of the information is redundant, but still provided. !(1:geodetic_nDOF, 1:geodetic_nDOF) REAL, DIMENSION(3) :: pole ! temporary Cartesian unit vector LOGICAL, DIMENSION(nPlatesPlus) :: pole_used ! will be set to .TRUE. whenever any given names(i) <==> omega(1:3, i) ! is used to generate one or more type-4 boundary velocities. REAL, DIMENSION(0:2) :: potrate_err ! 3 norms of fault offset-rate error !(each normalized by sigma before combining): !(0:2 = N0,N1,N2 norm). REAL, DIMENSION(0:2) :: rate_err ! 3 norms of rate error (combining together continuum stiffness, ! interpolated stress-directions, fault offset-rates, and geodesy; ! each normalized by its own sigma before combining): !(0:2 = N0,N1,N2 norm). REAL, DIMENSION(:), ALLOCATABLE :: s_azim ! present azimuth of most compressive horizontal principal stress, ! in radians clockwise from North !(1:s_dat_count = paleostress site index) REAL, DIMENSION(0:2) :: s_err ! 3 norms of fault offset-rate error !(each normalized by sigma before combining): !(0:2 = N0,N1,N2 norm). CHARACTER(30), DIMENSION(:), ALLOCATABLE :: s_loc ! geographic location memo for each paleostress datum ! (1:s_dat_count = paleostress index) CHARACTER(30), DIMENSION(:), ALLOCATABLE :: s_ref ! bibliographic reference for each paleostress datum ! (1:s_dat_count = paleostress index) REAL, DIMENSION(:), ALLOCATABLE :: s_sigma_ ! standard deviation of azimuth of most compressive ! horizontal principal stress, in radians !(1:s_dat_count = paleostress site index) REAL, DIMENSION(:,:), ALLOCATABLE :: s_site ! location of stress-direction site; ! Cartesian unit vector from Earth center: ! (1:3 = x,y,z; 1:s_dat_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, 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, DIMENSION(:), ALLOCATABLE :: seg_eta_ ! eta_ (+1.0 or -1.0) for each fault segment, depending on whether ! isolated node u_ is to right or to left. !(1:seg_count = segment index) REAL, DIMENSION(:), ALLOCATABLE :: seg_kappa_ ! 0.0 < kappa_ <= 1.0 is relative length of fault segment, compared to width of element along the same line !(1:seg_count = segment index) INTEGER, DIMENSION(:), ALLOCATABLE :: seg_u_ ! u_ = 1, 2, or 3 to identify isolated node of segment, using the internal node numbering scheme !(1:seg_count = segment index) REAL, DIMENSION(:,:),ALLOCATABLE :: trace ! all digitized points on 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_has_dipslip_rate ! records whether the user entered a dip-slip rate constraint (sense D, N, P, S, or T) ! anywhere in the f*.nki file; use to prevent multiple dip-slip rate entries on one trace! ! (0:f_highest = trace index) LOGICAL(1), DIMENSION(:), ALLOCATABLE :: trace_has_strikeslip_rate ! records whether the user entered a strike-slip rate constraint (sense L or R) ! anywhere in the f*.nki file; if so, no shadow datum for strike-slip should ever be created. ! Also, useful for preventing multiple strike-slip rate entries on one trace! ! (0:f_highest = trace index) TYPE(is123), DIMENSION(:), ALLOCATABLE :: trace_is ! locations of fault traces in internal coordinates !(1:f_dig_count = in order read) INTEGER, DIMENSION(:,:),ALLOCATABLE :: trace_loc ! gives locations where each 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 traces; first, last segment; ! 0:f_highest = trace index (ties f_dat to f_dig)) ! Notes: If trace_loc(1, i) == 0 then no fault with this index number was read in. ! If trace_loc(3, i) == 0 then the trace has no segments, ! either because it lies entirely outside the .feg area, ! or because of bad analysis by subprogram Def_Seg. REAL, DIMENSION(:), ALLOCATABLE :: u_flag ! indicator of singularity returned by LSLPB: 0. or 1. !(1:nDOF) REAL, DIMENSION(3) :: uvec, vec1, vec2 ! temporary Cartesian unit vectors DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: vw ! alternating theta (South) and phi (East) velocity components ! at finite element nodes, in m/s, !(1:2:num_nod = position in solution vector of linear system) DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: vw_interseismic ! alternating theta (South) and phi (East) velocity components ! at finite element nodes, in m/s. ! This differs from the long-term solution vector vw by the ! addition of elastic straining due to temporary locking of ! of all active fault dislocations during interseismic periods. !(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 as index to read trace locations in trace_loc. ! (1:f_dat_count = fault offset datum index) REAL, 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) !-------------------------------------------------------------------- !-------------------------------------------------------------------- ! Global plate model PB2002. ! Note: The only use made of this model is in converting type-4 boundary conditions ! from mnemonic codes like "PA" to actual horizontal velocity vectors. ! Plate names (in alphabetical order): DATA (names(i), i = 1, nPlates) & &/ 'AF','AM','AN', & ! 1, 2, 3 & 'AP','AR','AS', & ! 4, 5, 6 & 'AT','AU','BH', & ! 7, 8, 9 & 'BR','BS','BU', & ! 10, 11, 12 & 'CA','CL','CO', & ! 13, 14, 15 & 'CR','EA','EU', & ! 16, 17, 18 & 'FT','GP','IN', & ! 19, 20, 21 & 'JF','JZ','KE', & ! 22, 23, 24 & 'MA','MN','MO', & ! 25, 26, 27 & 'MS','NA','NB', & ! 28, 29, 30 & 'ND','NH','NI', & ! 31, 32, 33 & 'NZ','OK','ON', & ! 34, 35, 36 & 'PA','PM','PS', & ! 37, 38, 39 & 'RI','SA','SB', & ! 40, 41, 42 & 'SC','SL','SO', & ! 43, 44, 45 & 'SS','SU','SW', & ! 46, 47, 48 & 'TI','TO','WL', & ! 49, 50, 51 & 'YA' / ! 52 ! The following Euler (rotation-rate) vectors for plates are in Cartesian (x,y,z) components, ! with units of radians per million years. ! The motions of the 14 large plate are from DeMets et al., 1990, Table 1, * 0.9562 [DeMets et al., 1994], ! as restated by Bird [2003, Table 1] in model PB2002. ! Rotations for most of the 38 small plates of the PB2002 model of Bird [2003] are from Table 1 in that paper, ! except as noted in the right-hand (comment) column below: DATA ((omega(i, j),i = 1, 3), j = 1, nPlates) / & ! following lines come from PB2002_omega.xls except IN, AR, SU, & AM. & 0.002401, -0.007930, 0.013891, & ! 1 AF-PA from Bird [2003] & 0.000245, -0.007120, 0.013630, & ! 2 AM-PA from Kreemer et al. [2003] & 0.000689, -0.006540, 0.013676, & ! 3 AN-PA from Bird [2003] & 0.002042, -0.013150, 0.008856, & ! 4 AP-PA from Bird [2003] & 0.006689, -0.004640, 0.016415, & ! 5 AR-PA from Sella et al. [2002] & 0.000148, -0.003070, 0.010915, & ! 6 AS-PA from Bird [2003] & 0.015696, 0.002467, 0.023809, & ! 7 AT-PA from Bird [2003] & 0.009349, 0.000284, 0.016253, & ! 8 AU-PA from Bird [2003] & 0.000184, 0.005157, 0.001150, & ! 9 BH-PA from Bird [2003] & -0.000870, -0.002260, 0.002507, & ! 10 BR-PA from Bird [2003] & -0.019120, 0.030087, 0.010227, & ! 11 BS-PA from Bird [2003] & 0.009290, -0.043781, 0.005295, & ! 12 BU-PA from SU-PA [Kreemer et al., 2003] + (BU-SU) [Bird, 2003]. & 0.001405, -0.009890, 0.013623, & ! 13 CA-NA* from DeMets et al. [2000], endorsed by Mann et al. [2002]. & 0.003716, -0.003790, 0.000949, & ! 14 CL-PA from Bird [2003] & -0.008910, -0.026440, 0.020895, & ! 15 CO-PA from Bird [2003] & -0.061170, 0.005216, -0.013750, & ! 16 CR-PA from Bird [2003] & 0.070136, 0.160534, 0.094328, & ! 17 EA-PA from Bird [2003] & 0.000529, -0.007230, 0.013123, & ! 18 EU-PA from Bird [2003] & -0.083250, -0.002460, -0.014920, & ! 19 FT-PA from Bird [2003] & 0.016256, 0.089364, 0.015035, & ! 20 GP-PA from Bird [2003] & 0.005889, -0.006130, 0.016101, & ! 21 IN-PA from Sella et al. [2002] & 0.006512, 0.003176, 0.005073, & ! 22 JF-PA from Bird [2003] & 0.108013, 0.299461, 0.230528, & ! 23 JZ-PA from Bird [2003] & 0.033318, -0.001810, 0.036441, & ! 24 KE-PA from Bird [2003] & -0.013830, 0.008245, 0.015432, & ! 25 MA-PA from Bird [2003] & -0.777840, 0.440872, -0.047430, & ! 26 MN-PA from Bird [2003] & 0.001521, 0.007739, 0.013437, & ! 27 MO-PA from Bird [2003] & 0.038223, -0.058290, 0.013679, & ! 28 MS-PA from Bird [2003] & 0.001936, -0.008393, 0.010225, & ! 29 NA*-PA from Gonzalez-Garcia et al. [2003], aka "Guadalupe" pole in Bird [2009]. & -0.004330, 0.003769, -0.000400, & ! 30 NB-PA from Bird [2003] & 0.000111, -0.006360, 0.010449, & ! 31 ND-PA from Bird [2003] & 0.044913, -0.009540, 0.010601, & ! 32 NH-PA from Bird [2003] & -0.055340, -0.010890, 0.006794, & ! 33 NI-PA from Bird [2003] & -0.000020, -0.013410, 0.019579, & ! 34 NZ-PA from Bird [2003] & 0.001041, -0.008300, 0.012143, & ! 35 OK-PA from Bird [2003] & -0.026220, 0.020184, 0.037208, & ! 36 ON-PA from Bird [2003] & 0.000000, 0.000000, 0.000000, & ! 37 PA-PA from Bird [2003] & -0.000040, -0.009290, 0.012815, & ! 38 PM-PA from Bird [2003] & 0.012165, -0.012510, -0.000360, & ! 39 PS-PA from Bird [2003] & -0.019180, -0.070600, 0.036797, & ! 40 RI-PA from Bird [2003] & 0.000472, -0.006350, 0.009100, & ! 41 SA-PA from Bird [2003] & 0.121443, -0.078830, 0.027122, & ! 42 SB-PA from Bird [2003] & 0.001117, -0.007430, 0.008534, & ! 43 SC-PA from Bird [2003] & -0.000830, -0.006700, 0.013323, & ! 44 SL-PA from Bird [2003] & 0.001287, -0.008750, 0.014603, & ! 45 SO-PA from Bird [2003] & -0.017190, 0.017186, 0.008623, & ! 46 SS-PA from Bird [2003] & 0.000864, -0.009215, 0.014100, & ! 47 SU-PA from Kreemer et al. [2003] & 0.023380, -0.019360, -0.010460, & ! 48 SW-PA from Bird [2003] & -0.009400, 0.023063, 0.008831, & ! 49 TI-PA from Bird [2003] & 0.142118, 0.005616, 0.078214, & ! 50 TO-PA from Bird [2003] & -0.016830, 0.018478, 0.010166, & ! 51 WL-PA from Bird [2003] & -0.000830, -0.006160, 0.016274/ ! 52 YA-PA from Bird [2003] nPlatesDefined = nPlates ! but this may increase later, if user-defined extra plates are needed to interpret b_*.nki !========================================================== memory_bytes_I8 = 0 ! total of allocated arrays, in bytes version = 'NeoKinema: Version 4.0 of 19 December 2014' !============================================================================ ! VERSION HISTORY ! Version 1.0, Summer 2002: released only to Zhen Liu, who used ! it for the preliminary modeling of the Persia-Tibet-Burma orogen. !---------------------------------------------------------------------------- ! *Eliminated redundant shadow strike-slip pseudo-datum for any fault ! trace which already has a user-specified strike-slip component. ! *Added damping during the updating of shadow strike-slip rate sigmas. ! *Sigma_perSecond, associated with enforcing no continuum shear ! straining on the stress principal axis directions ! was limited to be no less than xi_, in order to protect the ! condition number of the linear system and enhance reproducibility ! of iterated results (thus allowing for better convergence). ! *Input parameter dump_all_solutions added to control production of ! velocity-solution log file v_log.nko, which is intended for use ! with programs Analyze_Velocity_Evolution and FiniteMap. ! *Input parameter conservative_geodetic_adjustment added to provide ! an option in which the fault-unlocking velocity adjustment at ! geodetic benchmarks is based on the input/prior geologic slip rate, not ! the self-consistent current slip rate estimate. This may be necessary ! to preserve stability of the iteration of the solution, in cases of ! benchmarks sitting over two antithetic thrusts (or detachments) which ! dip together and intersect in the seismogenic depth range. !---------------------------------------------------------------------------- ! Version 1.1, 2003.10.06: also released to Zhen Liu (2nd-round Persia-Tibet-Burma). ! I also used it for reconnaissance (unpublished) Gorda-California-Nevada ! and SCEC sub-region models through September 2004. !---------------------------------------------------------------------------- ! *Fixed bug in code that was written to prevent ill-conditioning of ! linear system, by limiting highest eigenvalues: ! Previously, I subjected sigma_perSecond to a lower limit of xi_ ! to achieve this. However, when I later used the (inflated) ! sigma_perSecond to evaluate prediction error, the stress-direction ! errors were incorrectly biased downward. (The effect was largest ! for high values of xi_.) The fix is to leave sigma_perSecond ! unchanged, but introduce a new "effective_sigma_perSecond" to prevent ! ill-conditioning. The old, correct sigma_perSecond is used to assess ! the post-fit residuals (prediction errors) in continuum stress directions. !--------------------------------------------------------------------------------- ! Version 1.2, 2004.10.26: Tested fix for effectiveness, and found that overall ! change to best solutions was minor; kept on file. !--------------------------------------------------------------------------------- ! *Added label "!Write_h_token_nko" to help find code that writes this ! file. (It is not in a separate SUBROUTINE.) Altered this code to ! provide the additional REAL value slip_rate_mmpa for every dip-slip ! fault, and for every strike-slip fault in the input data file. ! However, no slip rate is provided for shadow strike-slip components ! on dip-slip faults; instead, this motion is merged with the dip-slip ! rate by Pythagorean theorom to give the total slip rates quoted. ! This information is needed by PROGRAM Long_Term_Seismicity. !--------------------------------------------------------------------------------- ! Version 1.3, 2004.10.26: used for 2004 SCEC Annual Report and 2005 SCEC proposal ! (N.B. These run-logs have erroneous labels of "NK v.2"!) !--------------------------------------------------------------------------------- ! *Altered comments to clarify that "D" and "N" are just 2 different ! ways of entering fault offset rates (as heave or throw components) for ! normal faults; and likewise, "P" and "T" are just 2 different ways ! of entering fault offset rates (as heave or throw components) for thrust ! faults, and these class distinctions do NOT imply different fault dips, ! or any other geometric or behavioral distinction. ! *Set compiled-in parameters of: ! REAL, PARAMETER :: normal_dip_degrees = 55.0 ! REAL, PARAMETER :: thrust_dip_degrees = 20.0 ! REAL, PARAMETER :: subduction_dip_degrees = 14.0 ! consistent with Bird & Kagan [2004] Table 5 values used in Long_Term_Seismicity, ! because these values are used in the Write_h_token_nko code section, ! and consistency between programs in a chain is highly desirable. !---------------------------------------------------------------------------- ! Version 1.4, 2004.11.22: used to test simple plate boundary cases with ! PROGRAM Long_Term_Seismicity for consistency with ! Bird & Kagan [2004, BSSA]. !---------------------------------------------------------------------------- ! *Eliminated input parameter "geodesy_weight" and set it internally to 1.0. ! The weight of one geodetic velocity component at one geodetic benchmark ! is now the standard unit in which other adjustable weights are measured. ! (N.B.: I do not consider a "weight" to include the associated factor ! of (sigma)**(-2), or any geometric factors specific to a datum site.) ! *Added new user-controlled dimensional weighting parameters: ! L0 = length of fault trace whose offset rate gets unit weight (in m) ! A0 = area of continuum whose stiffness & isotropy get unit weight (in m**2) ! and recoded to eliminate hidden dimensional factors of finite element size. !--------------------------------------------------------------------------------- ! Version 2.0, 2004.12.07: Used for final RELM/publication verion of the ! Gorda-California-Nevada orogen ! [Bird & Liu, 2007, Seismol. Res. Lett.]. ! Also used by Zhen Liu for most of the models ! (but not the final preferred model) ! in the Persia-Tibet-Burma orogen project ! [Liu & Bird, 2008, Geophys. J. Int.] !--------------------------------------------------------------------------------- ! *Modified Euler rotation-rate poles (all expressed relative to PA) ! for plates AM, AR, IN, SU: replaced the PB2002 [Bird, 2003, G^3] ! values with new values from last column of Table 1 in ! Liu & Bird [2008, Geophys. J. Int. = Persia-Tibet- ! Burma model]. Sources for this update (selected by Liu): ! -Sella et al. [2002] for AR, IN; ! -Kreemer et al. [2003] for AM, SU. !--------------------------------------------------------------------------------- ! Version 2.1, 2007.08.14 used for the final preferred Persia-Tibet-Burma model ! of Liu & Bird [2008, Geophys. J. Int.] !--------------------------------------------------------------------------------- ! *Added test of input stress-direction azimuths for range -360~+360, ! after having endless grief over undetected azimuths ! of "999" degrees in the World Stress Map dataset. ! *Subduction zone faults (S) are allowed to slip ! obliquely EVEN IF parameter "sigma_offnormal_degrees" ! permitting oblique slip on other dip-slip faults is ! set to a small value or zero. [2007.11.21] ! *Corrected FORMAT in subprogram Write_f_token_nki() to provide 0.001 mm/a precision ! in echoed datum offset rates and their standard deviations. [2008.01.10] ! *Modified input section to permit reading at most ONE strike-slip offset rate ! (sense R or L) and at most ONE dip-slip offset rate (sense D, N, P, S, or T) ! for any given fault trace (e.g., F4253). Note that allowing multiple rates ! would cause stacking of multiple virtual faults along the trace, rather than ! weighting of multiple opinions about the single fault, as the user might ! have intended! [2008.01.17] ! *Added two right-hand columns to f*.nki input file, after logical indicator ! for fault creep, with the upper/smaller seismogenic locking depth (in km), ! and the lower/deeper seismogenic locking depth (in km). ! These new columns are NOT optional; old input files must be upgraded by ! adding such columns! (However, negative values like "-1.0" can be used ! for unknown locking depths, which will then be replaced with the default ! values in the parameter input file p_*.nki. [2008.01.21] ! [Also, note that 2 MORE optional columns were later added; see v.3 below.] ! *Cosmetic changes in error-measure output: Old norms "L0, L1, L2" ! renamed to "N0, N1, N2" to avoid confusion with input "reference length" ! L0 used for weighting fault offset-rate data. ! "Fault" error measures are still reported, but now called "Offset-rate" errors. ! Also, printing of "Global" error measures is now suppressed, ! because with the addition of alternative "Potency" error measures ! to replace misleading "Fault" error measures, it is no longer ! clear how a "Global" error measure should be defined. ! *Added new "Potency-rate" error measures to final output. These are just ! the N0, N1, and N2 norms of [(model_offset_rate - datum_offset_rate)/ ! (datum_standard_error)] * [(model_potency_rate)/MEAN(model_potency_rates)]. ! The difference from the old "Faults" error measures (now called "Offset-rate" ! error measures) is the insertion of the second, potency-rate factor, ! in place of the simpler trace-length factor used in Offset-rate errors. ! [PB, 2008.01.30] !--------------------------------------------------------------------------------- ! Version 2.2, 2008.01.30: Used for: ! -Bird [2009, JGR] models of the western U.S. and adjacent offshore regions. ! -Howe & Bird [2010, Tectonophysics] models of the Alpine-Aegean orogen. !--------------------------------------------------------------------------------- ! *General revision of Euler poles used in type-4 velocity boundary conditions: ! -Adopted "Guadalupe" Euler pole for NA-PA from Gonzalez-Garcia et al. [2003] ! (endorsed by Bird [2009]). ! -Added CA-NA of DeMets et al. [2000] (endorsed by Mann et al. [2002]) to ! this revised NA-PA to get a better CA-PA pole. ! -Corrected BU-PA pole to be consistent with SU-PA of Kreemer [2003] ! (as in NeoKinema v. 2.0+) plus BU-SU of PB2002 [Bird, 2003]. ! {However, note that Robinson & Bird [2011?] later found this ! BU-SU rotation from PB2002 to be too fast, by about a factor of 2.} ! -Added capability to handle unexpected two-character plate abbreviations ! (such as "C?" or "C2" replacing "CA") in the boundary conditions ! b_*.nki file, in lines that specify type-4 boundary conditions. ! The user is now prompted to provide the Euler pole for any new ! (or revised) plate motions, relative to the current reference frame ! (variable "reference_plate_c2" of the input parameter p_*.nki file). ! This allows altering boundary velocities without recompiling ! NeoKinema. A record of user input is copied to the log file. ! -Added an automatically-generated table listing all Euler poles used in ! generating type-4 velocity boundary conditions in the current run. ! This table is also copied to the log file. ! *Added warning when any assigned uncertainty (sigma, standard deviation) of ! any fault offset rate exceeds 50 mm/a (which may cause ill-conditioning). ! User must manually override warning to continue, and a record is left ! in the log file. ! *Added warning(s) when any geodetic benchmark falls into the same finite ! element as a fast-moving fault (offset rate > 1 mm/a), because this ! is likely to cause solution errors of same order as the offset rate. ! There is both a prospective warning (based on input, prior offset rates) ! and a retrospective warning (based on posterior, output offset rates). ! After any prospective warning, user must choose whether to ignore warning. ! Both sets of warnings are copied to the log file. ! *Now allowing fault offset-senses and traces to be used as stress-direction ! pseudo-data (assuming user specifies faults_give_sigma_1h = .TRUE.) ! even when the target offset rate is zero. (Zero is often assigned ! where there is no slip-rate datum for a fault, but in fact ! the slip sense may be well-established.) ! *A minimum of 6 solution refinements by iteration is now enforced; ! this is a safety measure, because naieve users cannot always judge ! which types of problem require iteration for accurate solution. ! *Master SUBROUTINE Solve_for_vw now CALLs Prediction in every pass ! except the first. This solves a non-updating bug that appeared only ! in some artifically simple test problems. ! *Changed the computation of revised (long-term, fault-unlocked) geodetic ! velocity targets, so it is now based on fault locking from the surface ! down to the lower locking depth. (The upper locking depth is still ! read from the f_*.nki file and passed on to Long_Term_Seismicity ! for use in seismicity forecasts, but it is no longer used within ! NeoKinema.) The reason is that shallow strips of fault plane above ! the uppper (shallower) locking depth may creep a bit, and may not ! contribute much (or any) stress drop during earthquakes, but they creep ! at only a tiny fraction of the long-term relative microplate velocity. ! Therefore, for purposes of correcting geodetic velocities it is better ! to approximate these shallow strips as locked, rather than approximate ! them as creeping at the full long-term relative microplate velocity. !--------------------------------------------------------------------------------- ! Version 2.3, 2010.01.15: Used for: ! -modeling of the Ninety East-Sumatra orogen with Tom Robinson. ! -modeling of the Hispaniola orogen with Rafal Jankowski. ! -posted on web site and sent to Zhen Liu, GeoPentech, etc. !--------------------------------------------------------------------------------- ! *Added one more output file resulting from each run: ! v_interseismic_[token].out is now added to represent short-term ! interseismic velocities of nodes. This can be displayed in NeoKineMap, ! for comparison with GPS strain-rates, or with other codes that do not ! compute long-term velocities. It can be differentiated in ! NeoKineMap to display short-term interseismic strain-rates. ! Also, it can be used with Strainrate_exporter.f90/.exe to convert ! short-term interseismic strain-rates to the gridded-values format ! used by David Sandwell et al. for their comparison studies. ! (However, note that these strain-rates will be an undifferentiated ! mixture of elastic and permanent.) !--------------------------------------------------------------------------------- ! Version 2.4 of 10 March 2010: ! -used for GPS/UCERF3 comparison study run by Kaj Johnson, Wayne Thatcher, ! David Sandwell, and Liz Hearn in March-April 2010. ! -used for UCERF3 block-modeling exercises (under the same organizers) in ! Spring-Fall 2011. ! -used for the fault-based UCERF3064~UCERF3077 deformation models submitted to ! UCERF3 in 2011-2012. ! -used for exploratory block-models of the western US (through WUS3_003) ! prepared for the USGS NSHMP/WUS project in 2012.10. !--------------------------------------------------------------------------------- ! MAJOR REVISIONS FOR VERSION 3: ! -Large geodetic matrices (covariance, and normal) are only formed and used ! if required by user input: using_GPS_matrices = using_gp2_file.OR.floating_frame ! This permits MAJOR decreases in bandwidth and MAJOR increases in speed, and ! also frees up memory, allowing 32-bit computers to handle >>1,500 GPS sites ! when no geodetic covariance matrix is used. ! -Optional brackets (lower and upper limits) on each fault offset-rate can now ! be prescribed using 2 extra columns in the f*.nki input file. ! These are enforced by automatically increasing the weight on the geologic ! target offset rate (for nonconforming faults only) by successive factors ! of 2 in iterations during the latter 2/3rds of the model run. ! [N.B. Although the 2 new columns are optional in most lines of the file, ! there MUST be entries for these columns in the fixed-FORMAT at the top.] ! -Adjusted iteration strategy, and raised minimum iterations (refinements) to 12. ! During the first 1/3 of iterations, the program runs without any nonlinear ! constraints (which are irreversible). During the second 1/3 of iterations, ! it adds any brackets on fault offset rates. During the final 1/3, it boxes ! any continuum elements where eDot_1H would otherwise be off by 90 degrees, ! and continues to survey fault offset rates for possible bracket tightening. ! -Input file of digitized fault traces (f*.dig) is now scanned for an optional ! additional header line after the F1234 number, sense(s), and title of each ! fault. This new header line may contain the flag "dip_degrees" followed by a ! number (either integer or decimal), and the indicated dip will be used in ! all computations. Faults without this optional header will continue to dip ! 90 degrees for strike-slip, or according to these pre-coded values: ! REAL, PARAMETER :: normal_dip_degrees = 55.0 ! REAL, PARAMETER :: thrust_dip_degrees = 20.0 ! REAL, PARAMETER :: subduction_dip_degrees = 14.0 ! consistent with Bird & Kagan [2004] Table 5 value used in Long_Term_Seismicity. ! -Made dips of "shadow" strike-slip offset-rate components equal to the dips ! of their parent dip-slip offset-rate components, whether that dip came ! from a pre-coded value or from a "dip_degrees" flag. !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- ! Version 3.0, 2012.12.06: Used for production runs of NSHM-WUS fault-based models ! prepared for USGS, to be one branch of the deformation- ! model tree in the Western U. S. (WUS) portion of the ! 2014 update of the National Seismic Hazard Map (NSHM). ! (These runs occurred in 2012.12..., although the map was ! not released until 2014.) !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- ! *Corrected a logical bug that prevented the matrix of covariances of GPS ! velocity components from being read, even if the filename was given. ! *Changed the default behavior to always output the e[token].nko file, ! even when no faults are included in the model. While this file is ! not needed for plotting long-term permanent strain-rates with ! NeoKineMap, it might be useful for other purposes, such as seismic ! hazard assessment. It can always be deleted, if not wanted. ! *Fixed an underflow problem when computing inversion of 2x2 geodetic ! covariance in (m/s)^2. This may have caused some geodetic uncertainties ! to be treated imprecisely in previous versions. !--------------------------------------------------------------------------------- ! Version 3.1, 2014.05.06: Provided to Michele Carafa for modeling of Europe. !--------------------------------------------------------------------------------- ! *Corrected the computation of geodetic misfits (geodetic N0, N1, N2), ! in the case where a full covariance matrix (.gp2 file) is provided, ! so that this error computation uses the full normal matrix. ! (In versions 1.x~3.x only the block-diagonal parts were used.) ! *Provided choice of 2 methods for interpolation of stress directions: ! Bird & Li [1996], or Carafa & Barba [2013]. The choice is ! controlled by one new input parameter in the p_[token].nki file. ! *Changed all arrays involved in building and solving the big linear system ! to REAL*8 (from REAL*4). This reduces numerical errors in strain-rates, ! especially of small fast-moving elements. Affected arrays include G, dG, ! vw; element matrices A, B, C, D, E, F; and the big linear-system arrays ! ABCD and EF. New double-precision subprograms ! for elementary vector operations were placed at the bottom of ! this program. (Note that NeoKineMap was upgraded in parallel, ! with similar DP vector routines added to Map_Tools.) ! *To get the advantages of parallel processing and 64-bit memory space, ! I converted the external USE and CALLs to numerical routines in ! the Linear Algebra Package (LAPACK) portion of the ! Intel Math Kernel Library (MKL), which I purchased along with ! Intel Parallel Studio XE 2013 (a 32/64-bit scalar/vector/parallel ! Fortran compiler for Windows 7+). ! This new library continues to support the compilation of 32-bit ! and/or scalar versions, if these are still wanted. ! Also, for backward compatibility, the old USE and CALLs to the ! International Mathematics Subroutine Library (IMSL) routines ! {that were used in NeoKinema versions up to 3.1} were not ! removed; they were just commented-out. Thus, other users ! could (in principle) reverse this change, yet keep all other new ! features that have been added in NK versions 4.0+. ! *Fixed a minor bug that allowed some simple test-cases to stop iterating ! their solution befores all stress-direction information had been ! imposed {before the "boxing" step}. !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- ! Version 4.0, 2014.10.05+: Tested, jointly with Michele Carafa. ! Then, used for "faultless" stress/geodetic models of Europe. !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- WRITE (*, "(' ',A)") TRIM(version) ! open the Parameter (p*.nki) file and get the name token from the first line: WRITE (*, "(' Program NeoKinema requires the name of a parameter file.')") parameter_file = ' ' path_in = ' ' !CALL File_List( file_type = "p*.nki", & ! & suggested_file = parameter_file, & ! & using_path = path_in ) CALL Prompt_for_String('Which parameter file should control this run?',parameter_file,parameter_file) OPEN (UNIT = 1, FILE = parameter_file, STATUS = "OLD", ACTION = "READ", PAD = "YES") token = Get_Filename(unit = 1) ! will generate CALL_Bad_Parameters() if an error occurs ! write the header and initial time stamp t_nko_file_name = 't' // TRIM(token) // ".nko" PRINT "(' ')" ! All PRINTs have a space in 1st byte for "carriage-control"! PRINT "(' Starting NeoKinema; for details see ', A)", t_nko_file_name OPEN (UNIT = 21, FILE = t_nko_file_name, STATUS = "REPLACE", & ACTION = "WRITE") WRITE (21, "('===========================================================')") WRITE (21, "('A record of a run of program NeoKinema:')") WRITE (21, "('(NEOtectonic, anelastic velocity solution from KINEMAtic data')") WRITE (21, "(' such as plate rotations, geodetic velocities, and fault slip rates')") WRITE (21, "(' with thin-viscous-shell interpolation guided by a smooth')") WRITE (21, "(' interpolated stress field)')") WRITE (21, "('by Peter Bird')") WRITE (21, "(' Department of Earth and Space Sciences')") WRITE (21, "(' University of California')") WRITE (21, "(A)") TRIM(version) 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 (everything after the first line, with immediate conversions to SI units) PRINT "(' Reading parameters for this run from file ',A)", TRIM(parameter_file) WRITE (21, "('Begin reading parameters for this run from file ',A)") TRIM(parameter_file) WRITE (21, "(A,' [name token for use in building output file names]')") TRIM(token) line = 1 ! reference length (for determining weight of fault offset rate data): READ (1, *, IOSTAT = ios) L0 ; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() IF (L0 <= 0.) CALL Prevent ('nonpositive L0', line, TRIM(parameter_file)) WRITE (21,"(1P,E10.2,' L0 = length of fault trace whose offset rate gets unit weight (in m)')") L0 ! reference area (for determining weight of continuum stiffness & isotropy constraints): READ (1, *, IOSTAT = ios) A0 ; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() IF (A0 <= 0.) CALL Prevent ('nonpositive A0', line, TRIM(parameter_file)) WRITE (21,"(1P,E10.2,' A0 = area of continuum whose stiffness & isotropy get unit weight (in m**2)')") A0 ! number of refinements READ (1, *, IOSTAT = ios) n_refine ; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() IF (n_refine < 0) CALL Prevent ('negative refinements', line, TRIM(parameter_file)) IF (n_refine >= 6) THEN ! no problem; this is safe WRITE (21,"(I10,' number of refinements of each velocity solution')") n_refine ELSE ! require at least 12 refinements: WRITE (*, *) WRITE (*, "(' NOTE: n_refine was increased from ',I1,' to the new minimum of 12.')") n_refine WRITE (*, "(' This is a safety measure, to protect against misinterpretation of unconverged solutions.')") WRITE (*, *) WRITE (21, *) WRITE (21, "(' 12 number of refinements of each velocity solution')") WRITE (21, "('NOTE: n_refine was increased from ',I1,' to the new minimum of 6.')") n_refine WRITE (21, "('This is a safety measure, to protect against misinterpretation of unconverged solutions.')") WRITE (21, *) n_refine = 12 END IF ! strain-rate uncertainty for rigid blocks READ (1, *, IOSTAT = ios) mu_ ; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() IF (mu_ <= 0.) CALL Prevent ('nonpositive mu_', line, TRIM(parameter_file)) IF (mu_ < SQRT(1.1 * TINY(mu_))) CALL Prevent ('mu_**2 will underflow!', line, TRIM(parameter_file)) IF (mu_ > 1.E-10) CALL Prevent ('unreasonably large mu_', line, TRIM(parameter_file)) WRITE (21,"(1P,E10.2,' mu_ = scalar measure of typical anelastic strain rates in continuum (/s)')") mu_ ! small strain-rate increment (xi_) for imposing stress-directions READ (1, *, IOSTAT = ios) xi_ ; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() IF (xi_ <= 0.) CALL Prevent ('nonpositive xi_', line, TRIM(parameter_file)) WRITE (21,"(1P,E10.2,' xi_ = small strain-rate increment, /s')") xi_ ! sigma, in degrees, of angle between [heave vectors of dip-slip faults] & [trace-normal direction] READ (1, *, IOSTAT = ios) sigma_offnormal_degrees ; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() IF (sigma_offnormal_degrees < 0.) CALL Prevent ('negative sigma_offnormal_degrees', line, TRIM(parameter_file)) IF (sigma_offnormal_degrees > 80.) CALL Prevent ('sigma_offnormal_degrees exceeds 80.0', line, TRIM(parameter_file)) WRITE (21,"(F10.1,' sigma, in degrees, of angle between [heave vectors of dip-slip faults] & [trace-normal direction]')") sigma_offnormal_degrees ! radius of planet READ (1, *, IOSTAT = ios) t ; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() IF (t <= 0.) CALL Prevent ('nonpositive R', line, TRIM(parameter_file)) WRITE (21,"(1P,E10.3,' radius of the planet (R), in km')") t R = t * m_per_km half_R2 = (R**2)/2. ! minimum and maximum default locking depths of intraplate faults, in km READ (1, *, IOSTAT = ios) t1, t2; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() WRITE (21,"(2F10.2,' minimum and maximum locking depths of intraplate faults, in km')") t1, t2 IF (t1 < 0.) CALL Prevent ('negative minimum locking depth', line, TRIM(parameter_file)) IF (t2 < 0.) CALL Prevent ('negative maximum locking depth', line, TRIM(parameter_file)) locking_depth_m_min = t1 * 1000.0 locking_depth_m_max = t2 * 1000.0 ! minimum and maximum default locking depths of subduction zones, in km READ (1, *, IOSTAT = ios) t1, t2; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() WRITE (21,"(2F10.2,' minimum and maximum locking depths of subduction zones, in km')") t1, t2 IF (t1 < 0.) CALL Prevent ('negative minimum locking depth', line, TRIM(parameter_file)) IF (t2 < 0.) CALL Prevent ('negative maximum locking depth', line, TRIM(parameter_file)) locking_depth_m_subduction_min = t1 * 1000.0 locking_depth_m_subduction_max = t2 * 1000.0 ! do active faults count as sigma_1h data? READ (1, *, IOSTAT = ios) faults_give_sigma_1h ; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() WRITE (21,"(L10,' that faults are treated as stress direction data')") & faults_give_sigma_1h ! names of fault slip rate input file (or, "none") f_dat = Get_filename (unit = 1) ; line = line + 1 WRITE (21,"(' ',A)") TRIM(f_dat) WRITE (21,"(11X,'preceding line = filename of fault offset rates')") ! names of fault traces input file (or, "none") IF (f_dat(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')") ! names of stress directions input file (or, "none") s_dat = Get_filename (unit = 1) ; line = line + 1 WRITE (21,"(' ',A)") TRIM(s_dat) WRITE (21,"(11X,'preceding line = filename of principal stress directions')") ! stress interpolation method (INTEGER index): line = line + 1 READ (1, *, IOSTAT = ios) stress_interpolation_method IF (ios /= 0) CALL Bad_Parameters() WRITE (21,"(I10,' stress interpolation method: (1) Bird & Li [1996]; (2) Carafa & Barba [2013].')") stress_interpolation_method ! names of .gps geodetic-velocity input file (or, "none") gps_file = Get_filename (unit = 1) ; line = line + 1 WRITE (21,"(' ',A)") TRIM(gps_file) WRITE (21,"(11X,'preceding line = filename of geodetic velocities')") ! names of .gp2 velocity-covariance input file (or, "none") gp2_file = Get_filename (unit = 1) ; line = line + 1 WRITE (21,"(' ',A)") TRIM(gp2_file) WRITE (21,"(11X,'preceding line = filename of velocity-covariance matrix')") ! is the velocity reference frame of the geodetic data allowed to float? READ (1, *, IOSTAT = ios) floating_frame ; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() WRITE (21,"(L10,' that velocity reference frame of geodetic data is allowed to float')") floating_frame ! conservative_geodetic_adjustment? (use geologic fault slip rates for coseismic adjustments to geodesy?) READ (1, *, IOSTAT = ios) conservative_geodetic_adjustment ; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() WRITE (21,"(L10,' conservative_geodetic adjustment? (using geologic slip rates)')") conservative_geodetic_adjustment ! names of finite element grid file (required) x_feg = Get_filename (unit = 1) ; line = line + 1 WRITE (21,"(' ',A)") TRIM(x_feg) WRITE (21,"(11X,'preceding line = filename of finite element grid')") ! names of boundary conditions file (required) x_bcs = Get_filename (unit = 1) ; line = line + 1 WRITE (21,"(' ',A)") TRIM(x_bcs) WRITE (21,"(11X,'preceding line = filename of boundary conditions')") ! name of reference plate for any type-4 velocity boundary conditions READ(1, "(A)", IOSTAT = ios) reference_plate_c2; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() reference_plate_index = 0 DO i = 1, nPlates IF (names(i) == reference_plate_c2) THEN reference_plate_index = i EXIT END IF END DO IF (reference_plate_index == 0) THEN CALL Prevent ('unknown identifier for reference plate', line, TRIM(parameter_file)) END IF WRITE (21,"(A2,9X,'plate defining velocity reference frame for type-4 boundary conditions')") reference_plate_c2 ! dump velocity solution in every iteration? READ (1, *, IOSTAT = ios) dump_all_solutions ; line = line + 1 IF (ios /= 0) CALL Bad_Parameters() WRITE (21,"(L10,' that velocity solutions in all iterations will be written to v_log.nko')") dump_all_solutions ! end of parameter input file CLOSE (UNIT = 1) ! close PARAMETE[RS].DAT PRINT "(' Successfully read all run parameters')" WRITE (21, "('End Parameter Section')") WRITE (21,"('===============================================================================')") ! Read input datasets, ! with immediate conversion of quantities to SI units, except ! geographic positions to Cartesian unit vectors in a unit sphere. PRINT "(' ','Begin reading input data files')" WRITE (21,"('Begin reading input data files')") ! read f.dig IF ((f_dig(1:5) == 'none ') .OR. (f_dig(1:8) == 'skipped ')) THEN f_dig_count = 0 f_highest = 0 any_shadow_pseudodata = .FALSE. ELSE PRINT "(' ',4X,'Reading fault traces from ',A)", TRIM(f_dig) WRITE (21,"(4X,'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 f_highest = 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 number', line, f_dig) f_highest = MAX (f_highest, i) END IF END IF !N.B. In this pass, any "dip_degrees" headers are just ignored. ELSE; EXIT loop_thru; END IF END DO loop_thru CLOSE (UNIT = 3) ! (will be re-read) ! allocate arrays bytes_added_I8 = f_dig_count * 3 * bytes_per_real CALL More_mem ('trace', bytes_added_I8) ALLOCATE ( trace (3, f_dig_count) ) trace = 0. ! whole array ! bytes_added_I8 = f_dig_count * bytes_per_is CALL More_mem ('trace_is', bytes_added_I8) ALLOCATE ( trace_is(f_dig_count) ) bytes_added_I8 = 4 * f_highest * bytes_per_int CALL More_mem ('trace_loc', bytes_added_I8) ALLOCATE ( trace_loc (4, 0:f_highest) ) trace_loc = 0 ! whole array; (1:2, ?) will be replaced below; (3:4, ?) are to be replaced by Def_seg, IF (savem). bytes_added_I8 = f_highest * bytes_per_real CALL More_mem ('f_dig_degrees', bytes_added_I8) ALLOCATE ( f_dip_degrees (0:f_highest) ) ! N.B. Inclusion of "0" protects against ! abend if "dip_degrees" precedes "F0001" in the f*.dig file. f_dip_degrees = 0.0 ! and will remain 0.0 unless "dip_degrees" is found for this fault trace. ! fill arrays OPEN (UNIT = 3, FILE = f_dig, STATUS = "OLD", ACTION = "READ", & PAD = "YES") ; line = 0 in_trace = .FALSE. i = 0 read_dig: 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 got_point = .TRUE. got_index = .FALSE. READ (c50,*) t1, t2 ! E longitude, N latitude IF (ABS(t2) > 90.001) THEN PRINT "(' 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 ELSE IF ((c50(1:1) == 'F') .OR. (c50(1:1) == 'f')) THEN got_point = .FALSE. READ (c50,"(1X,I4)") j2 ! new trace number (NOTE: Any slip-sense bytes are ignored.) got_index = .TRUE. got_dip_degrees = .FALSE. ! (but, it may follow in the next line?) ELSE IF (c50(1:3) == "***") THEN ! '*** end of line segment ***' got_point = .FALSE. got_index = .FALSE. ELSE ! check for optional "dip_degrees" header" loc_in_c_1 = INDEX(c50, "dip_degrees") IF (loc_in_c_1 > 0) THEN ! found this flag 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 = c50(loc_in_c_3:50) ! strip out the text flag, leaving the number READ (c50, *, IOSTAT = internal_ios) t IF (internal_ios == 0) THEN dip_degrees = t got_dip_degrees = .TRUE. ELSE WRITE (c4, "(I4)") j2 IF (c4(1:1) == ' ') c4(1:1) = '0' IF (c4(2:2) == ' ') c4(2:2) = '0' IF (c4(3:3) == ' ') c4(3:3) = '0' 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 END IF END IF ! (lon, lat) line, or F1234 line, or "*** end" line, or "dip_degrees" line ELSE; EXIT read_dig; END IF IF (in_trace) THEN IF (got_point) THEN i = i + 1 CALL Xyz_from_lonlat(t1, t2, tvo) trace(1:3,i) = tvo trace_loc(2,j1) = i ELSE ! *** end ... in_trace = .FALSE. ENDIF ELSE ! (not in_trace) IF (got_index) THEN j1 = j2 ! new index becomes current index ELSE IF (got_point) THEN i = i + 1 CALL Xyz_from_lonlat(t1, t2, tv) trace(1:3,i) = tv trace_loc(1,j1) = i in_trace = .TRUE. ELSE ! *** end ... END IF END IF ! (in_trace) IF (got_dip_degrees) THEN IF ((dip_degrees >= 5.0).AND.(dip_degrees <= 90.0)) THEN f_dip_degrees(j2) = dip_degrees ELSE PRINT "(' ','ERROR: dip_degrees of ',F10.2,' for fault trace ',I4)", dip_degrees, j2 PRINT "(' ','is outside the legal range of 5~90 degrees.')" WRITE (21,"('ERROR: dip_degrees of ',F10.2,' for fault trace ',I4)") dip_degrees, j2 WRITE (21,"('is outside the legal range of 5~90 degrees.')") CALL Pause() STOP END IF END IF END DO read_dig CLOSE (UNIT = 3) ! close f_dig PRINT "(' ',I8,' fault-trace points were read')", f_dig_count WRITE (21,"(I8,' fault-trace points were read')") f_dig_count !Note: Typically this output will look like "4X,I4,..." but I want to allow for larger integers. WRITE (21,"(4X,'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -')") ! read f.nki IF (f_dat(1:5) == 'none ') THEN f_dat_dimension = 0 f_dat_count = 0 f_highest = 0 any_shadow_pseudodata = .FALSE. ELSE PRINT "(' ',4X,'Reading fault offset-rate data from ',A)", TRIM(f_dat) WRITE (21,"(4X,'Reading fault offset-rate data from ',A)") TRIM(f_dat) OPEN (UNIT = 2, FILE = f_dat, STATUS = "OLD", ACTION = "READ", & PAD = "YES") ! PAD = YES necessary to interpret short FORMAT string on line 1, ! and to allow reading any lines that lack optional columns #8,9 on right. READ (2, "(A)") f_dat_format ! N.B. This FORMAT **MUST** include entries for optional columns #8,9 on right, ! even if those columns will be blank/missing in every row! READ (2, "(A)") f_dat_titles ! Skim file and count number of data lines, highest fault index; ! also, IF (sigma_offnormal_degrees > 0.0).OR.(S fault(s)), then allow for extra R/L offset-rate components. f_dat_dimension = 0 ! initializing; to be augmented below f_highest = 0 ! initializing; maximum value to be noted below get_real_offset_rate_count: DO READ (2, "(A)", IOSTAT = read_status) c134 IF (read_status == 0) THEN ! read was successful f_dat_dimension = f_dat_dimension + 1 ! one for each datum line int the input file READ (c134, "(1X,I4,A1)") i, c IF (c == 't') c = 'T' IF (c == 'p') c = 'P' IF (c == 'n') c = 'N' IF (c == 'd') c = 'D' IF (c == 's') c = 'S' IF (c == 'S') f_dat_dimension = f_dat_dimension + 1 ! allowing space in arrays for possible strike-slip shadow pseudo-datum IF (((c == 'T').OR.(c == 'P').OR.(c == 'N').OR.(c == 'D')) & &.AND.(sigma_offnormal_degrees > 0.0)) f_dat_dimension = f_dat_dimension + 1 ! allowing space in arrays for possible strike-slip shadow pseudo-datum f_highest = MAX (f_highest, i) ELSE EXIT get_real_offset_rate_count END IF END DO get_real_offset_rate_count CLOSE (UNIT = 2) ! (will be re-read twice more below) ! allocate arrays bytes_added_I8 = f_dat_dimension * bytes_per_int CALL More_mem ('which_trace', bytes_added_I8) ALLOCATE ( which_trace (f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * 1 CALL More_mem ('f_sense', bytes_added_I8) ALLOCATE ( f_sense (f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * bytes_per_real CALL More_mem ('f_dat_dip_degrees', bytes_added_I8) ALLOCATE ( f_dat_dip_degrees(f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * 50 CALL More_mem ('fault_name', bytes_added_I8) ALLOCATE ( fault_name (f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * bytes_per_real CALL More_mem ('f_offset_rate', bytes_added_I8) ALLOCATE ( f_offset_rate (f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * 1 CALL More_mem ('f_offset_rate_bracketed', bytes_added_I8) ALLOCATE ( f_offset_rate_bracketed (f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * bytes_per_real CALL More_mem ('f_old_model_offset_rate', bytes_added_I8) ALLOCATE ( f_old_model_offset_rate (f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * bytes_per_real CALL More_mem ('f_model_offset_rate', bytes_added_I8) ALLOCATE ( f_model_offset_rate (f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * bytes_per_real CALL More_mem ('f_offset_rate_sigma_', bytes_added_I8) ALLOCATE ( f_offset_rate_sigma_ (f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * bytes_per_real CALL More_mem ('f_offset_rate_floor', bytes_added_I8) ALLOCATE ( f_offset_rate_floor (f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * bytes_per_real CALL More_mem ('f_offset_rate_ceiling', bytes_added_I8) ALLOCATE ( f_offset_rate_ceiling (f_dat_dimension) ) bytes_added_I8 = 2 * f_dat_dimension * bytes_per_real CALL More_mem ('f_divide', bytes_added_I8) ALLOCATE ( f_divide(2, f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * 1 CALL More_mem ('f_dat_shadow', bytes_added_I8) ALLOCATE ( f_dat_shadow(f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * 1 CALL More_mem ('f_creeping', bytes_added_I8) ALLOCATE ( f_creeping(f_dat_dimension) ) bytes_added_I8 = f_highest * 1 CALL More_mem ('trace_has_dipslip_rate', bytes_added_I8) ALLOCATE ( trace_has_dipslip_rate(f_highest) ) bytes_added_I8 = f_highest * 1 CALL More_mem ('trace_has_strikeslip_rate', bytes_added_I8) ALLOCATE ( trace_has_strikeslip_rate(f_highest) ) bytes_added_I8 = f_dat_dimension * bytes_per_real CALL More_mem ('f_locking_depth_m_max', bytes_added_I8) ALLOCATE ( f_locking_depth_m_max(f_dat_dimension) ) bytes_added_I8 = f_dat_dimension * bytes_per_real CALL More_mem ('f_locking_depth_m_min', bytes_added_I8) ALLOCATE ( f_locking_depth_m_min(f_dat_dimension) ) trace_has_dipslip_rate = .FALSE. ! initializing; some value to be changed below trace_has_strikeslip_rate = .FALSE. ! initializing; some value to be changed below OPEN (UNIT = 2, FILE = f_dat, STATUS = "OLD", ACTION = "READ", & PAD = "YES") ; line = 0 READ (2,*) ; line = line + 1 READ (2,*) ; line = line + 1 scan_f_dat: DO READ (2, f_dat_format, IOSTAT = ios) c6, c50, t1, t2, creeping, z1, z2; line = line + 1 IF (ios /= 0) EXIT scan_f_dat READ (c6, "(1X,I4,1X)") i1 IF (i1 > f_highest) THEN PRINT "(' Illegally high trace index: ',I6)", i1 WRITE (21,"('Illegally high trace index: ',I6)") i1 STOP END IF c = c6(6:6) IF (c == 'd') c = 'D' IF (c == 'l') c = 'L' IF (c == 'n') c = 'N' IF (c == 'p') c = 'P' IF (c == 'r') c = 'R' IF (c == 's') c = 'S' IF (c == 't') c = 'T' IF (.NOT.((c == 'T') .OR. (c == 'N') .OR. (c == 'R') .OR. (c == 'L') & .OR. (c == 'D') .OR. (c == 'P').OR. (c == 'S'))) THEN PRINT "(' Illegal slip sense: ',A1)", c WRITE (21,"('Illegal slip sense: ',A1)") c STOP END IF !finally, the main point of this loop, and this reading of the file: IF ((c == 'D').OR.(c == 'N').OR.(c == 'P').OR.(c == 'S').OR.(c == 'T')) THEN IF (trace_has_dipslip_rate(i1)) THEN PRINT "(' ERROR: More than one dip-slip offset rate datum for trace F',I4)", i1 WRITE (21,"('ERROR: More than one dip-slip offset rate datum for trace F',I4)") i1 STOP ELSE trace_has_dipslip_rate(i1) = .TRUE. END IF END IF IF ((c == 'L').OR.(c == 'R')) THEN IF (trace_has_strikeslip_rate(i1)) THEN PRINT "(' ERROR: More than one strike-slip offset rate datum for trace F',I4)", i1 WRITE (21,"('ERROR: More than one strike-slip offset rate datum for trace F',I4)") i1 STOP ELSE trace_has_strikeslip_rate(i1) = .TRUE. END IF END IF END DO scan_f_dat CLOSE (UNIT = 2) ! close f_dat (to allow re-opening below) ! Second, re-read same file and record its data; add shadow strike-slip pseudo-data if appropriate. ! Also, scan for possible columns #8 and #9 with f_offset_rate_floor and f_offset_rate_ceiling. any_shadow_pseudodata = .FALSE. ! just initializing; may be changed below f_offset_rate_floor = -999.0 * 0.001 / s_per_year ! whole array; in case no column #8 found. f_offset_rate_ceiling = +999.0 * 0.001 / s_per_year ! whole array; in case no column #9 found. f_offset_rate_bracketed = .FALSE. ! whole array; may be switched (only to TRUE) during computation. minimal_bracket_gap_mps = 0.0008 * 0.001 / s_per_year ! leave at least 0.0008 mm/a between target and either bracket! OPEN (UNIT = 2, FILE = f_dat, STATUS = "OLD", ACTION = "READ", & PAD = "NO") ; line = 0 ! Note: PAD = "NO" is critical for logic below which detects optional columns #8,9 READ (2,*) ; line = line + 1 ! FORMAT line READ (2,*) ; line = line + 1 ! Headers line f_dat_count = 0 ! cannot use "DO i" because dextral components may be inserted for dip-slip faults! warned_of_big_offset_sigma = .FALSE. read_f_dat: DO READ (2, f_dat_format, IOSTAT = ios) c6, c50, t1, t2, creeping, z1, z2; line = line + 1 IF (ios /= 0) EXIT read_f_dat f_dat_count = f_dat_count + 1 ! use this index for storage READ (c6, "(1X,I4,1X)") i1 IF (i1 > f_highest) THEN PRINT "(' Illegally high trace index: ',I6)", i1 WRITE (21,"('Illegally high trace index: ',I6)") i1 STOP END IF c = c6(6:6) IF (c == 'd') c = 'D' IF (c == 'l') c = 'L' IF (c == 'n') c = 'N' IF (c == 'p') c = 'P' IF (c == 'r') c = 'R' IF (c == 's') c = 'S' IF (c == 't') c = 'T' IF (.NOT.((c == 'T') .OR. (c == 'N') .OR. (c == 'R') .OR. (c == 'L') & .OR. (c == 'D') .OR. (c == 'P').OR. (c == 'S'))) THEN PRINT "(' Illegal slip sense: ',A1)", c WRITE (21,"('Illegal slip sense: ',A1)") c STOP END IF which_trace(f_dat_count) = i1 !Note: The present context is creating primary data; shadow "R" data will be added below: dip_degrees = f_dip_degrees(i1) IF (dip_degrees > 0.0) THEN ! use this value: f_dat_dip_degrees(f_dat_count) = dip_degrees !test for impossible cases (that would abend with divide-by-zero): IF ((dip_degrees == 90.0).AND. & & ((c == 'T').OR.(c == 'P').OR.(c == 'S').OR. & & (c == 'N').OR.(c == 'D'))) THEN WRITE (c4, "(I4)") i1 IF (c4(1:1) == ' ') c4(1:1) = '0' IF (c4(2:2) == ' ') c4(2:2) = '0' IF (c4(3:3) == ' ') c4(3:3) = '0' WRITE (*, "(' ERROR: Fault F',A4,' has 90-degree dip in f*.dig,')") c4 WRITE (*, "(' and has a T, P, S, N, or D component of offset in f*.nki.')") WRITE (*, "(' These choices are incompatible! Please reduce the dip significantly,')") WRITE (*, "(' or just omit the dip_degrees line from f*.dig.')") WRITE (21, "('ERROR: Fault F',A4,' has 90-degree dip in f*.dig,')") c4 WRITE (21, "('and has a T, P, S, N, or D component of offset in f*.nki.')") WRITE (21, "('These choices are incompatible! Please reduce the dip significantly,')") WRITE (21, "('or just omit the dip_degrees line from f*.dig.')") CALL Pause() STOP END IF ELSE ! use default dip values based on sense: IF (c == 'D') f_dat_dip_degrees(f_dat_count) = normal_dip_degrees IF (c == 'L') f_dat_dip_degrees(f_dat_count) = 90.0 IF (c == 'N') f_dat_dip_degrees(f_dat_count) = normal_dip_degrees IF (c == 'P') f_dat_dip_degrees(f_dat_count) = thrust_dip_degrees IF (c == 'R') f_dat_dip_degrees(f_dat_count) = 90.0 IF (c == 'S') f_dat_dip_degrees(f_dat_count) = subduction_dip_degrees IF (c == 'T') f_dat_dip_degrees(f_dat_count) = thrust_dip_degrees END IF f_sense(f_dat_count) = c fault_name(f_dat_count) = c50 IF (t1 < 0.) CALL Prevent ('negative offset-rate', line, f_dat) f_offset_rate(f_dat_count) = t1 * 0.001 / s_per_year IF (t2 <= 0.) CALL Prevent ('nonpositive sigma_', line, f_dat) f_offset_rate_sigma_(f_dat_count) = t2 * 0.001 / s_per_year IF (t2 >= 50.01) THEN ! consider warning about excessive offset-rate sigma of more than 50 mm/a IF (.NOT.warned_of_big_offset_sigma) THEN WRITE (*, *) WRITE (*, "(' CAUTION: Some uncertainties (sigmas, standard errors) in offset rates')") WRITE (*, "(' are entered as >50 mm/a. Experience shows that this may lead to')") WRITE (*, "(' ill-conditioned linear systems and spurious volatility in fault')") WRITE (*, "(' slip rates predicted by NeoKinema. I suggest that you edit the')") WRITE (*, "(' f_*.nki file to limit offset-rate uncertainties to <50 mm/a.')") WRITE (21, *) WRITE (21, "('CAUTION: Some uncertainties (sigmas, standard errors) in offset rates')") WRITE (21, "(' are entered as >50 mm/a. Experience shows that this may lead to')") WRITE (21, "(' ill-conditioned linear systems and spurious volatility in fault')") WRITE (21, "(' slip rates predicted by NeoKinema. I suggest that you edit the')") WRITE (21, "(' f_*.nki file to limit offset-rate uncertainties to <50 mm/a.')") CALL Prompt_for_Logical('Do you want to IGNORE this warning and continue?',.FALSE.,ignore_warning) IF (ignore_warning) THEN WRITE (*, *) WRITE (21, "('Do you want to IGNORE this warning and continue?: YES')") WRITE (21, *) ELSE WRITE (21, "('Do you want to IGNORE this warning and continue?: No')") STOP END IF warned_of_big_offset_sigma = .TRUE. END IF END IF f_dat_shadow(f_dat_count) = .FALSE. f_creeping(f_dat_count) = creeping ! Trap cases of missing depth-range columns #6, 7, or reversed min/max locking depths, ! or illogical input of a "locked" fault with zero depth range for its locking !(which might result from missing entries, defaulting both min and max to zero). ! However, note that I do NOT trap illogical cases of a "creeping" fault with ! a finite depth range for locking; this illogic is a prominent feature of the ! WGCEP Fault Models 2.x. Instead, we just omit dislocation correction entirely ! for any fault with creeping == .TRUE.. IF ((.NOT.creeping).AND.(z1 >= 0.0).AND.(z2 >= 0.0)) THEN IF (z1 >= z2) THEN PRINT "(' Illogical or missing creeping/locking data for fault ',A6)", c6 WRITE (21,"('Illogical or missing creeping/locking data for fault ',A6)") c6 STOP END IF END IF IF (z1 >= 0.0) THEN f_locking_depth_m_min(f_dat_count) = z1 * 1000.0 ELSE IF (c == 'S') THEN f_locking_depth_m_min(f_dat_count) = locking_depth_m_subduction_min ELSE f_locking_depth_m_min(f_dat_count) = locking_depth_m_min END IF END IF IF (z2 >= 0.0) THEN f_locking_depth_m_max(f_dat_count) = z2 * 1000.0 ELSE IF (c == 'S') THEN f_locking_depth_m_max(f_dat_count) = locking_depth_m_subduction_max ELSE f_locking_depth_m_max(f_dat_count) = locking_depth_m_max END IF END IF !See if f_offset_rate_floor and/or f_offset_rate_ceiling are contained in optional columns #8,9: BACKSPACE (2) READ (2, f_dat_format, IOSTAT = ios) c6, c50, t1, t2, creeping, z1, z2, bracket_low IF (ios == 0) THEN f_offset_rate_floor(f_dat_count) = bracket_low * 0.001 / s_per_year IF ((f_offset_rate(f_dat_count) - f_offset_rate_floor(f_dat_count)) < minimal_bracket_gap_mps) THEN WRITE (*, "(' ERROR in line ',I6,' of ',A)") line, TRIM(f_dat) WRITE (*, "(' Left bracket (lower limit) on offset rate must be less than rate.')") CALL Pause() STOP END IF END IF BACKSPACE (2) READ (2, f_dat_format, IOSTAT = ios) c6, c50, t1, t2, creeping, z1, z2, bracket_low, bracket_high IF (ios == 0) THEN f_offset_rate_ceiling(f_dat_count) = bracket_high * 0.001 / s_per_year IF ((f_offset_rate_ceiling(f_dat_count) - f_offset_rate(f_dat_count)) < minimal_bracket_gap_mps) THEN WRITE (*, "(' ERROR in line ',I6,' of ',A)") line, TRIM(f_dat) WRITE (*, "(' Right bracket (upper limit) on offset rate must be greater than rate.')") CALL Pause() STOP END IF END IF !consider creating a "shadow" strike-slip component datum for dip-slip faults: IF ((c == 'T').OR.(c == 'P').OR.(c == 'N').OR.(c == 'D').OR.(c == 'S')) THEN IF ((sigma_offnormal_degrees > 0.0).OR.(c == 'S')) THEN IF (.NOT.trace_has_strikeslip_rate(i1)) THEN ! no user-specified strike-slip rate; OK to add shadow component: any_shadow_pseudodata = .TRUE. ! there is now at least one f_dat_count = f_dat_count + 1 which_trace (f_dat_count) = i1 f_dat_dip_degrees (f_dat_count) = f_dat_dip_degrees(f_dat_count - 1) ! inherited from parent dip-slip component f_sense (f_dat_count) = 'R' ! generic for strike-slip; if it's really L, heave rate will go negative fault_name (f_dat_count) = "shadow datum, which adds strike-slip flexibility" f_offset_rate (f_dat_count) = 0.0 ! target rate is always zero for strike-slip component f_offset_rate_sigma_ (f_dat_count) = small_rate_in_mps ! start small; may be increased in proportion to dip-slip f_dat_shadow (f_dat_count) = .TRUE. f_creeping (f_dat_count) = creeping ! inherited from parent dip-slip component f_locking_depth_m_min(f_dat_count) = f_locking_depth_m_min(f_dat_count - 1) ! inherited f_locking_depth_m_max(f_dat_count) = f_locking_depth_m_max(f_dat_count - 1) ! inherited END IF ! this trace does not already have a strike-slip component entered by the user END IF END IF END DO read_f_dat IF (any_shadow_pseudodata) THEN PRINT "(' ',I8,' offset-rate data (& shadow strike-slip components) were registered')", f_dat_count WRITE (21,"(I8,' offset-rate data (& shadow strike-slip components) were registered')") f_dat_count !Note: Typically this output will look like "4X,I4,..." but I want to allow for larger integers. ELSE PRINT "(' ',8X,I4,' offset-rate data were read')", f_dat_count WRITE (21,"(8X,I4,' offset-rate data were read')") f_dat_count END IF CLOSE (UNIT = 2) ! close f_dat END IF ! IF (f_dat /= 'none') WRITE (21,"(4X,'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -')") ! Check that all necessary traces where actually read. j = 0 ! number of critical traces missing from f_dig DO i = 1, f_dat_count IF (trace_loc(2,which_trace(i)) == 0) j = j + 1 END DO IF (j > 0) THEN PRINT "(' Error: The following fault traces were missing:')" WRITE (21,"('Error: The following fault traces were missing:')") DO i = 1, f_dat_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 PRINT "(' F',A4,A1,' ',A)", & c4, f_sense(i), TRIM(fault_name(i)) WRITE (21,"(' F',A4,A1,' ',A)") & c4, f_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 s_dat IF (s_dat(1:5) == 'none ') THEN s_dat_count = 0 ELSE PRINT "(' ',4X,'Reading stress-direction data from ',A)", TRIM(s_dat) WRITE (21,"(4X,'Reading stress-direction data from ',A)") TRIM(s_dat) ! open 1st time to get FORMAT, and count data OPEN(UNIT = 9, FILE = s_dat, STATUS = "OLD", ACTION = "READ", PAD = "YES") READ (9, "(A)") s_dat_format ! isolate the FORMAT item for the azimuth and determine if it is an integer or a real; ! also determine whether the error is integer, real, or character. n_items_done = 0 DO i = 1, LEN_TRIM(s_dat_format) c1 = s_dat_format(i:i) ! ignore any of: ( [number] X . [comma] [space] ) IF ((c1 == 'A').OR.(c1 == 'H').OR.(c1 == 'I').OR.(c1 == 'F').OR.(c1 == 'E').OR.(c1 == 'D').OR. & & (c1 == 'a').OR.(c1 == 'h').OR.(c1 == 'i').OR.(c1 == 'f').OR.(c1 == 'e').OR.(c1 == 'd')) THEN n_items_done = n_items_done + 1 IF (n_items_done == 5) THEN ! this is the azimuth item azimuth_is_integer = ((c1 == 'I').OR.(c1 == 'i')) ELSE IF (n_items_done == 6) THEN ! this is the error item using_A_to_E = ((c1 == 'A').OR.(c1 == 'a').OR.(c1 == 'H').OR.(c1 == 'h')) sigma_is_integer = ((c1 == 'I').OR.(c1 == 'i')) END IF END IF END DO READ (9, *) s_dat_titles ! count data lines, without storing them (yet) s_dat_count = 0 DO READ (9, s_dat_format, IOSTAT = ios) c30, c30a, t1, t2 ! deliberately skipping the problematic azimuth (I?, F?) sigma/letter IF (ios == 0) THEN s_dat_count = s_dat_count + 1 ELSE EXIT END IF END DO CLOSE (UNIT = 9) ! allocate arrays bytes_added_I8 = s_dat_count * 30 CALL More_mem ('s_ref', bytes_added_I8) ALLOCATE ( s_ref(s_dat_count) ) bytes_added_I8 = s_dat_count * 30 CALL More_mem ('s_loc', bytes_added_I8) ALLOCATE ( s_loc(s_dat_count) ) bytes_added_I8 = 3 * s_dat_count * bytes_per_real CALL More_mem ('s_site', bytes_added_I8) ALLOCATE ( s_site(3, s_dat_count) ) bytes_added_I8 = s_dat_count * bytes_per_real CALL More_mem ('s_azim', bytes_added_I8) ALLOCATE ( s_azim(s_dat_count) ) bytes_added_I8 = s_dat_count * bytes_per_real CALL More_mem ('s_sigma_', bytes_added_I8) ALLOCATE ( s_sigma_(s_dat_count) ) ! open 2nd time to read and record the data lines OPEN(UNIT = 9, FILE = s_dat, STATUS = "OLD", ACTION = "READ", PAD = "YES"); line = 0 READ (9, "(A)") s_dat_format; line = line + 1 READ (9, *) s_dat_titles; line = line + 1 recording: DO i = 1, s_dat_count IF (using_A_to_E) THEN IF (azimuth_is_integer) THEN READ (9, s_dat_format, IOSTAT = ios) c30, c30a, lon, lat, s1h_azim_int, s1h_sigma_c1; line = line + 1 s1h_azim_degrees = s1h_azim_int ELSE ! azimuth is a real number READ (9, s_dat_format, IOSTAT = ios) c30, c30a, lon, lat, s1h_azim_degrees, s1h_sigma_c1; line = line + 1 END IF IF ((s1h_sigma_c1 == 'A').OR.(s1h_sigma_c1 == 'a')) THEN ! per Zoback (1992): s.d. <= 12 s1h_sigma_degrees = 8.0 ELSE IF ((s1h_sigma_c1 == 'B').OR.(s1h_sigma_c1 == 'b')) THEN ! per Zoback (1992): 12 < s.d. <= 25 s1h_sigma_degrees = 18.0 ELSE IF ((s1h_sigma_c1 == 'C').OR.(s1h_sigma_c1 == 'c')) THEN s1h_sigma_degrees = 30.0 ELSE IF ((s1h_sigma_c1 == 'D').OR.(s1h_sigma_c1 == 'e')) THEN s1h_sigma_degrees = 40.0 ELSE ! quality E; per Zoback (1992) : s.d. > 40 s1h_sigma_degrees = 50.0 END IF ELSE IF (sigma_is_integer) THEN IF (azimuth_is_integer) THEN READ (9, s_dat_format, IOSTAT = ios) c30, c30a, lon, lat, s1h_azim_int, s1h_sigma_int; line = line + 1 s1h_azim_degrees = s1h_azim_int ELSE ! azimuth is a real number READ (9, s_dat_format, IOSTAT = ios) c30, c30a, lon, lat, s1h_azim_degrees, s1h_sigma_int; line = line + 1 END IF s1h_sigma_degrees = s1h_sigma_int ELSE ! sigma is a real number IF (azimuth_is_integer) THEN READ (9, s_dat_format, IOSTAT = ios) c30, c30a, lon, lat, s1h_azim_int, s1h_sigma_degrees; line = line + 1 s1h_azim_degrees = s1h_azim_int ELSE ! azimuth is a real number READ (9, s_dat_format, IOSTAT = ios) c30, c30a, lon, lat, s1h_azim_degrees, s1h_sigma_degrees; line = line + 1 END IF END IF ! sigma is A-E, integer, or real s_ref(i) = c30 s_loc(i) = c30a CALL Xyz_from_lonlat(lon, lat, uvec) s_site(1:3,i) = uvec(1:3) IF ((s1h_azim_degrees < -360.).OR.(s1h_azim_degrees > 360.)) THEN PRINT "(' ',4X,'Check stress data: unreasonable azimuth of ',F12.3)", s1h_azim_degrees WRITE (21,"(4X,'Check stress data: unreasonable azimuth of ',F12.3)") s1h_azim_degrees CALL TraceBack() END IF s_azim(i) = s1h_azim_degrees / deg_per_rad IF (s1h_sigma_degrees <= 0.) CALL Prevent ('nonpositive sigma_', line, s_dat) s_sigma_(i) = s1h_sigma_degrees / deg_per_rad END DO recording ! reading stress-direction data CLOSE (UNIT = 9) PRINT "(' ',I8,' stress-direction sites were read')", s_dat_count WRITE (21,"(I8,' stress-direction sites were read')") s_dat_count !Note: Typically this output will look like "4X,I4,..." but I want to allow for larger integers. WRITE (21,"(4X,'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -')") CLOSE (UNIT = 9) ! close s_dat END IF ! IF (s_dat /= 'none') any_stress = (s_dat_count > 0) .OR. (faults_give_sigma_1h.AND.(f_dat_count > 0)) ! read .gps file (if any) IF (gps_file(1:5) == 'none ') THEN external_benchmarks = 0 internal_benchmarks = 0 gp2_file = "none" using_gp2_file = .FALSE. floating_frame = .FALSE. using_GPS_matrices = .FALSE. ELSE PRINT "(' ',4X,'Reading geodetic-velocity data from ',A)", TRIM(gps_file) WRITE (21,"(4X,'Reading geodetic-velocity data from ',A)") TRIM(gps_file) ! open 1st time to get FORMAT, and count benchmarks OPEN(UNIT = 10, FILE = gps_file, STATUS = "OLD", ACTION = "READ", PAD = "YES") READ (10, "(A)") gps_title READ (10, "(A)") gps_format READ (10, "(A)") gps_header external_benchmarks = 0 benchmarking: DO READ (10, gps_format, IOSTAT = ios) lon, lat IF (ios == 0) THEN external_benchmarks = external_benchmarks + 1 ELSE EXIT benchmarking END IF END DO benchmarking CLOSE (10) bytes_added_I8 = external_benchmarks * bytes_per_int CALL More_mem ('external_benchmark_index', bytes_added_I8) ALLOCATE ( external_benchmark_index(external_benchmarks) ) bytes_added_I8 = external_benchmarks * bytes_per_int CALL More_mem ('internal_benchmark_index', bytes_added_I8) ALLOCATE ( internal_benchmark_index(external_benchmarks) ) bytes_added_I8 = external_benchmarks * bytes_per_real CALL More_mem ('benchmark_theta', bytes_added_I8) ALLOCATE ( benchmark_theta(external_benchmarks) ) bytes_added_I8 = external_benchmarks * bytes_per_real CALL More_mem ('benchmark_phi', bytes_added_I8) ALLOCATE ( benchmark_phi(external_benchmarks) ) bytes_added_I8 = 3 * external_benchmarks * bytes_per_real CALL More_mem ('benchmark_uvec', bytes_added_I8) ALLOCATE ( benchmark_uvec(3, external_benchmarks) ) bytes_added_I8 = external_benchmarks * bytes_per_is CALL More_mem ('benchmark_is', bytes_added_I8) ALLOCATE (benchmark_is(external_benchmarks) ) bytes_added_I8 = 3 * 2 * 2 * external_benchmarks * bytes_per_double CALL More_mem ('benchmark_G', bytes_added_I8) ALLOCATE ( benchmark_G(3, 2, 2, external_benchmarks) ) bytes_added_I8 = 2 * external_benchmarks * bytes_per_real CALL More_mem ('benchmark_vw', bytes_added_I8) ALLOCATE ( benchmark_vw(2 * external_benchmarks) ) benchmark_vw = 0.0 bytes_added_I8 = 2 * external_benchmarks * bytes_per_real CALL More_mem ('benchmark_unlocked_vw', bytes_added_I8) ALLOCATE ( benchmark_unlocked_vw(2 * external_benchmarks) ) bytes_added_I8 = 2 * external_benchmarks * bytes_per_real CALL More_mem ('benchmark_reframed_vw', bytes_added_I8) ALLOCATE ( benchmark_reframed_vw(2 * external_benchmarks) ) bytes_added_I8 = 2 * external_benchmarks * bytes_per_real CALL More_mem ('benchmark_model_vw', bytes_added_I8) ALLOCATE ( benchmark_model_vw(2 * external_benchmarks) ) bytes_added_I8 = 4 * external_benchmarks * bytes_per_double CALL More_mem ('benchmark_covariance', bytes_added_I8) ALLOCATE ( benchmark_covariance(2, 2, external_benchmarks) ) bytes_added_I8 = 4 * external_benchmarks * bytes_per_double CALL More_mem ('benchmark_normal', bytes_added_I8) ALLOCATE ( benchmark_normal(2, 2, external_benchmarks) ) bytes_added_I8 = 80 * external_benchmarks CALL More_mem ('benchmark_name', bytes_added_I8) ALLOCATE ( benchmark_name(external_benchmarks) ) OPEN(UNIT = 10, FILE = gps_file, STATUS = "OLD", ACTION = "READ", PAD = "YES") READ (10, "(A)") gps_title READ (10, "(A)") gps_format READ (10, "(A)") gps_header !second time through, data is remembered (using internal NeoKinema conventions but external indices) DO i = 1, external_benchmarks READ (10, gps_format, IOSTAT = ios) lon, lat, vE_mmpa, vN_mmpa, vE_sigma, vN_sigma, correlation, c80, benchmark_name(i) external_benchmark_index(i) = i ! typically changed when benchmarks outside .feg are dropped; ! but needed to access externally-provided .gp2 file, if any. internal_benchmark_index(i) = i ! To become different in a later code section. benchmark_theta(i) = (90.0 - lat) / deg_per_rad benchmark_phi(i) = lon / deg_per_rad CALL Xyz_from_lonlat(lon, lat, uvec) benchmark_uvec(1:3, i) = uvec(1:3) benchmark_vw(2*i-1) = -vN_mmpa / (1000. * s_per_year) ! vTheta (vSouth) in m/s benchmark_vw(2*i ) = vE_mmpa / (1000. * s_per_year) ! vPhi (vEast) in m/s IF (vE_sigma <= 0.0) THEN ! prevent non-positive entries on diagonal PRINT "(' ',8X,'ERROR: vE_sigma is non-positive at benchmark ',A)", TRIM(benchmark_name(i)) WRITE (21,"(8X,'ERROR: vE_sigma is non-positive at benchmark ',A)") TRIM(benchmark_name(i)) STOP END IF IF (vN_sigma <= 0.0) THEN ! prevent non-positive entries on diagonal PRINT "(' ',8X,'ERROR: vN_sigma is non-positive at benchmark ',A)", TRIM(benchmark_name(i)) WRITE (21,"(8X,'ERROR: vN_sigma is non-positive at benchmark ',A)") TRIM(benchmark_name(i)) STOP END IF benchmark_covariance(1, 1, i) = (vN_sigma / (1000.D0 * s_per_year))**2 ! Theta-Theta benchmark_covariance(2, 2, i) = (vE_sigma / (1000.D0 * s_per_year))**2 ! Phi-Phi benchmark_covariance(1, 2, i) = -correlation * (vN_sigma / (1000.D0 * s_per_year)) & & * (vE_sigma / (1000.D0 * s_per_year)) ! Theta-Phi benchmark_covariance(2, 1, i) = benchmark_covariance(1, 2, i) ! symmetric ! Invert this local benchmark matrix to get the normal matrix: c11 = benchmark_covariance(1, 1, i) c12 = benchmark_covariance(1, 2, i) c21 = benchmark_covariance(2, 1, i) c22 = benchmark_covariance(2, 2, i) determinant = (c11 * 1.0D0 * c22) - (c21 * 1.0D0 * c12) ! needs to be REAL*8 to avoid underflowing! IF (determinant <= 0.0D0) THEN WRITE (*, "(' ERROR: Determinant of covariance matrix (in m^2/s^2)'/' of benchmark ',I6,' is ',ES12.3)") i, determinant WRITE (*, "(' because of data: vE_sigma =',F8.3,', vN_sigma =',F8.3,', correlation =',F8.3)") vE_sigma, vN_sigma, correlation WRITE (*, "(' in units of mm/year. After conversion to m/s, and squaring:')") WRITE (*, "(' Benchmark_covariance =', 2ES12.3)") benchmark_covariance(1, 1, i), benchmark_covariance(1, 2, i) WRITE (*, "(' Benchmark_covariance =', 2ES12.3)") benchmark_covariance(2, 1, i), benchmark_covariance(2, 2, i) CALL Pause() STOP END IF N11 = +c22 / determinant N12 = -c12 / determinant N21 = -c21 / determinant N22 = +c11 / determinant benchmark_normal(1, 1, i) = N11 benchmark_normal(1, 2, i) = N12 benchmark_normal(2, 1, i) = N21 benchmark_normal(2, 2, i) = N22 END DO CLOSE (10) PRINT "(' ',I8,' geodetic-velocity data were read')", external_benchmarks WRITE (21,"(I8,' geodetic-velocity data were read')") external_benchmarks !Note: Typically this output will look like "4X,I4,..." but I want to allow for larger integers. WRITE (21,"(4X,'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -')") END IF ! gps_file /= 'none' ! NOTE: Reading of the .gp2 file (if any) will be postponed until after ! compaction of the benchmark data, to keep only "internal" benchmarks ! which fall within the area of the .feg file. ! read .feg PRINT "(' ',4X,'Reading finite element grid file ',A)", TRIM(x_feg) WRITE (21,"(4X,'Reading finite element grid file ',A)") TRIM(x_feg) OPEN (UNIT = 11, FILE = x_feg, STATUS = 'OLD', ACTION = 'READ', PAD = 'YES') READ (11, *) ! skip title READ (11, *) num_nod nDOF = 2 * num_nod line = 2 bytes_added_I8 = 3 * num_nod * bytes_per_real CALL More_mem ('xyz_nod', bytes_added_I8) bytes_added_I8 = num_nod * bytes_per_real CALL More_mem ('mu_nod', bytes_added_I8) bytes_added_I8 = nDOF * bytes_per_real CALL More_mem ('vw', bytes_added_I8) bytes_added_I8 = nDOF * bytes_per_real CALL More_mem ('vw_interseismic', bytes_added_I8) bytes_added_I8 = nDOF * bytes_per_real CALL More_mem ('u-flag', bytes_added_I8) ALLOCATE ( xyz_nod(3, num_nod) ) ALLOCATE ( mu_nod(num_nod) ) ALLOCATE ( vw(nDOF) ) vw = 0. ! so strain-rate is defined (as zero) in Solve-for-vw ALLOCATE ( vw_interseismic(nDOF) ) ALLOCATE ( u_flag(nDOF) ) ! If there is any chance, check for nodes lying on fault traces! check_if = (f_dat_count > 0) IF (check_if) THEN PRINT "(' ',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 READ (11, *) i1, x1, x2, t; line = line + 1 IF ((i1 < 1).OR.(i1 > num_nod)) CALL Check_range('x_feg',line) CALL Xyz_from_lonlat(x1, x2, tv) xyz_nod(1:3, i1) = tv(1:3) 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 PRINT "(' 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 IF (t == 0.) t = mu_ ! use default strain-rate uncertainty IF (t <= 0.) CALL Prevent ('nonpositive mu_', line, x_feg) IF (t < SQRT(1.1 * TINY(mu_))) CALL Prevent ('mu_**2 will underflow!', line, x_feg) IF (t > 1.E-10) CALL Prevent ('unreasonably large mu_', line, x_feg) mu_nod(i1) = t END DO ! i = 1, num_nod IF (check_if .AND. (num_bad > 0)) STOP READ (11, *) num_ele; line = line + 1 bytes_added_I8 = 3 * num_ele * bytes_per_int CALL More_mem ('node', bytes_added_I8) bytes_added_I8 = num_ele * bytes_per_real CALL More_mem ('a_', bytes_added_I8) bytes_added_I8 = 2 * num_ele * bytes_per_int CALL More_mem ('crack_index', bytes_added_I8) bytes_added_I8 = 3 * num_ele * bytes_per_real CALL More_mem ('ele_strainrate', bytes_added_I8) ALLOCATE ( node(3, num_ele) ) ALLOCATE ( a_(num_ele) ) ALLOCATE ( crack_index(2, num_ele) ) ALLOCATE ( ele_strainrate(3, num_ele) ) IF (any_stress) THEN bytes_added_I8 = num_ele * bytes_per_real CALL More_mem ('ele_azim', bytes_added_I8) bytes_added_I8 = num_ele * bytes_per_real CALL More_mem ('ele_sigma', bytes_added_I8) bytes_added_I8 = num_ele * 1 CALL More_mem ('ele_stressed', bytes_added_I8) bytes_added_I8 = num_ele * 1 CALL More_mem ('boxed', bytes_added_I8) ALLOCATE ( ele_azim(num_ele) ) ALLOCATE ( ele_sigma(num_ele) ) ALLOCATE ( ele_stressed(num_ele) ) ALLOCATE ( boxed(num_ele) ) END IF DO l_ = 1, num_ele READ (11, *) j, j1, j2, j3; line = line + 1 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, j) = j1 node(2, j) = j2 node(3, j) = j3 END DO READ (11, *) nfl IF (nfl > 0) CALL No_Fault_Elements_Allowed() CLOSE (11) ! close x_feg PRINT "(' ',I8,' nodes and ',I8,' elements were read')", num_nod, num_ele WRITE (21,"(I8,' nodes and ',I8,' elements were read')") num_nod, num_ele !Note: Typically this output will look like "4X,I4,..." but I want to allow for larger integers. WRITE (21,"(4X,'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -')") ! read .bcs pole_used = .FALSE. ! whole vector, of length nPlatesPlus; may be changed to TRUE below as type-4 BC's are computed. PRINT "(' ',4X,'Reading velocity boundary conditions from file ',A)", TRIM(x_bcs) WRITE (21,"(4X,'Reading velocity boundary conditions from file ',A)") TRIM(x_bcs) OPEN (UNIT = 12, FILE = x_bcs, STATUS = 'OLD',& & ACTION = 'READ', PAD = 'YES') READ (12, "(A)") c134 ! title line; not used bcs_count = 0 DO READ (12, *, IOSTAT = read_status) i, j, k IF (read_status /= 0) EXIT IF ((k == 2).OR.(k == 4)) bcs_count = bcs_count + 1 END DO IF (bcs_count < 2) THEN IF (external_benchmarks >= 2) THEN PRINT "(' CAUTION: You are relying on GPS constraints for a well-posed (not-singular) solution!')" WRITE (21,"('CAUTION: You are relying on GPS constraints for a well-posed (not-singular) solution!')") ELSE PRINT "(' Error: Provide at least 2 fixed boundary nodes in ',A)", & & TRIM(x_bcs) WRITE (21,"('Error: Provide at least 2 fixed boundary nodes in ',A)") & & TRIM(x_bcs) STOP END IF ! at least 2 GPS benchmarks END IF ! bcs_count < 2 bytes_added_I8 = bcs_count * bytes_per_int CALL More_mem('boundary_node', bytes_added_I8) bytes_added_I8 = 2 * bcs_count * bytes_per_real CALL More_mem('condition', bytes_added_I8) ALLOCATE ( boundary_node(bcs_count) ) ALLOCATE ( condition(2, bcs_count) ) REWIND (12); line = 0 READ (12, *); line = 1 ! title line; not used or saved i = 0 DO READ (12, *, IOSTAT = ios) i1, j, k; line = line + 1 !Note: i1 is the boundary ordinal number and is never used; ! j is the node number; ! k is 2 for fixed velocity or 0 for a free node; ! r1 is velocity in m/s ! r2 is azimuth in degrees clockwise from North. IF (ios /= 0) THEN WRITE (*, "(' ERROR: Line ',I6,' of boundary-conditions file could not be interpreted.')") line WRITE (21, "('ERROR: Line ',I6,' of boundary-conditions file could not be interpreted.')") line CALL PAUSE() STOP END IF IF (k == 4) THEN ! type-4 BC; compute velocity from Euler vectors in omega BACKSPACE 12 READ (12, *, IOSTAT = ios) i1, j, k, plate_c2 IF (ios /= 0) THEN WRITE (*, "(' ERROR: Line ',I6,' of boundary-conditions file could not be interpreted.')") line WRITE (21, "('ERROR: Line ',I6,' of boundary-conditions file could not be interpreted.')") line CALL PAUSE() STOP END IF IF ((j < 1).OR.(j > num_nod)) CALL Check_range(x_bcs, line) i = i + 1 boundary_node(i) = j plate_index = 0 ! until correct value is found in loop below DO n = 1, nPlatesDefined IF (names(n) == plate_c2) THEN plate_index = n EXIT END IF END DO IF (plate_index == 0) THEN WRITE (*, "(' Unknown plate identifier ',A2,' found in line ',I6,' of BC file ',A)") plate_c2, line, TRIM(x_bcs) WRITE (21, "('Unknown plate identifier ',A2,' found in line ',I6,' of BC file ',A)") plate_c2, line, TRIM(x_bcs) WRITE (*, "(' You must now enter the Euler rotation-rate pole for this plate relative to ',A2,':')") reference_plate_c2 WRITE (21, "('You must now enter the Euler rotation-rate pole for this plate relative to ',A2,':')") reference_plate_c2 CALL Prompt_for_Real('Latitude in degrees (N = +, S = -)?', 0.0, pole_lat) WRITE (21, "('Latitude in degrees (N = +, S = -)? ',F8.3)") pole_lat CALL Prompt_for_Real('Longitude in degrees (E = +, W = -)?', 0.0, pole_lon) WRITE (21, "('Longitude in degrees (E = +, W = -)? ',F8.3)") pole_lon CALL Prompt_for_Real('Degrees/Ma (counterclockwise = +)?', 0.0, pole_degPerMa) WRITE (21, "('Degrees/Ma (counterclockwise = +)? ',F8.3)") pole_degPerMa IF (nPlatesDefined < nPlatesPlus) THEN nPlatesDefined = nPlatesDefined + 1 names(nPlatesDefined) = plate_c2 CALL LonLat_2_Uvec(pole_lon, pole_lat, uvec) Euler(1:3) = (pole_degPerMa / 57.296) * uvec(1:3) ! radian/Ma Euler(1:3) = Euler(1:3) + omega(1:3, reference_plate_index) ! adding motion of reference plate wrt PA omega(1:3, nPlatesDefined) = Euler(1:3) ! copy to master list plate_index = nPlatesDefined ELSE WRITE (*, "(' ERROR: Number of plates exceeds nPlatesPlus = ',I4,'. Change and recompile.')") nPlatesPlus WRITE (21, "('ERROR: Number of plates exceeds nPlatesPlus = ',I4,'. Change and recompile.')") nPlatesPlus CALL Pause() STOP END IF END IF Euler(1:3) = omega(1:3, plate_index) - omega(1:3, reference_plate_index) ! radian/Ma Euler(1:3) = Euler(1:3) / (1E6 * s_per_year) ! radians/s node_uvec(1:3) = xyz_nod(1:3, j) vec1(1:3) = R * node_uvec(1:3) ! nodal position vector, in m CALL Cross(Euler, vec1, vec2) ! vec2 is velocity in m/s in Cartesian coordinates CALL Local_Theta(node_uvec, uvec) condition(1, i) = Dot_3D(vec2, uvec) ! theta or South component, m/s CALL Local_Phi (node_uvec, uvec) condition(2, i) = Dot_3D(vec2, uvec) ! phi or East component, m/s pole_used(plate_index) = .TRUE. ELSE IF (k == 2) THEN ! velocity and azimuth are given on same line BACKSPACE 12 READ (12, *, IOSTAT = ios) i1, j, k, r1, r2 IF (ios /= 0) THEN WRITE (*, "(' ERROR: Line ',I6,' of boundary-conditions file could not be interpreted.')") line WRITE (21, "('ERROR: Line ',I6,' of boundary-conditions file could not be interpreted.')") line CALL PAUSE() STOP END IF IF ((j < 1).OR.(j > num_nod)) CALL Check_range(x_bcs, line) i = i + 1 boundary_node(i) = j condition(1, i) = -r1 * COS(r2 / deg_per_rad) ! theta or South component condition(2, i) = r1 * SIN(r2 / deg_per_rad) ! phi or East component ELSE IF (k == 0) THEN !do nothing; node remains free ELSE ! illegal code WRITE (*, "(' ERROR: Illegal boundary-condition code ',I6,' in line ',I6)") k, line WRITE (21, "('ERROR: Illegal boundary-condition code ',I6,' in line ',I6)") k, line CALL PAUSE() STOP END IF IF (i == bcs_count) EXIT END DO CLOSE (12) ! close x.bcs PRINT "(' ',I8,' velocity boundary conditions were read')", bcs_count WRITE (21,"(I8,' velocity boundary conditions were read')") bcs_count !Note: Typically this output will look like "4X,I4,..." but I want to allow for larger integers. pole_table_needed = .FALSE. ! unless changed in loop below DO i = 1, nPlatesDefined IF (pole_used(i)) THEN pole_table_needed = .TRUE. EXIT END IF END DO IF (pole_table_needed) THEN WRITE (*, "(4X,' Table of Euler poles used to compute type-4 velocity boundary conditions:')") WRITE (*, "(4X,' (Note that all are relative to current reference plate ',A2,'.)')") reference_plate_c2 WRITE (*, "(4X,' PLATE N_latitude E_longitude Degrees/Ma Note ')") WRITE (*, "(4X,' ----- ---------- ----------- ---------- ------------')") WRITE (21, "(4X,'Table of Euler poles used to compute type-4 velocity boundary conditions:')") WRITE (21, "(4X,'(Note that all are relative to current reference plate ',A2,'.)')") reference_plate_c2 WRITE (21, "(4X,'PLATE N_latitude E_longitude Degrees/Ma Note ')") WRITE (21, "(4X,'----- ---------- ----------- ---------- ------------')") DO i = 1, nPlatesDefined IF (pole_used(i)) THEN IF (i <= nPlates) THEN pole_note_c12 = "built-in " ELSE pole_note_c12 = "user-defined" END IF IF (i /= reference_plate_index) THEN uvec(1:3) = omega(1:3, i) - omega(1:3, reference_plate_index) pole_degPerMa = Magnitude(uvec) * 57.296 CALL Make_Uvec(uvec, uvec) CALL Uvec_2_LonLat(uvec, pole_lon, pole_lat) ELSE ! zero rotation of plate relative to itself (included in table for code simplicity and clarity) pole_lon = 0.0; pole_lat = 0.0; pole_degPerMa = 0.0 pole_note_c12 = "stationary " END IF WRITE (*, "(4X,' ',A2,'-',A2,2X,F10.3,2X,F11.3,2X,F10.4,2X,A12)") & & names(i), reference_plate_c2, pole_lat, pole_lon, pole_degPerMa, pole_note_c12 WRITE (21, "(4X,A2,'-',A2,2X,F10.3,2X,F11.3,2X,F10.4,2X,A12)") & & names(i), reference_plate_c2, pole_lat, pole_lon, pole_degPerMa, pole_note_c12 END IF END DO WRITE (*, "(4X,' ----- ---------- ----------- ---------- ------------')") WRITE (21, "(4X,'----- ---------- ----------- ---------- ------------')") END IF WRITE (21,"(4X,'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -')") PRINT "(' ','Successfully read all input datasets')" WRITE (21,"('Successfully read all input datasets')") WRITE (21,"('===============================================================================')") ! !==================================================================================== ! End of input reading (except .gp2, if any) and beginning of processing CALL Plane_area (folding) !? IF (folding) THEN PRINT "(' ERROR: Finite element grid has folded (negative area) elements.')" WRITE (21,"('ERROR: Finite element grid has folded (negative area) elements.')") STOP END IF !get internal coordinates for all data points PRINT "(' ','Finding all data locations in grid coordinates')" WRITE (21,"('Finding all data locations in grid coordinates')") bytes_added_I8 = 3 * num_ele * bytes_per_int CALL More_mem('neighbor', bytes_added_I8) bytes_added_I8 = 3 * num_ele * bytes_per_real CALL More_mem('center', bytes_added_I8) ALLOCATE ( neighbor(3, num_ele) ) ALLOCATE ( center(3, num_ele) ) CALL Find_s1s2s3 IF ((f_dig_count + f_dat_count + s_dat_count + external_benchmarks) > 0) THEN !Survey and then store fault segments !Note: Uses arrays "center" and "neighbor" created by Find-s1s2s3. !Also uses "trace_is" from Find-s1s2s3. IF (f_dat_count > 0) THEN !PRINT "(' ','Counting fault segments (slow)')" ! replaced by bar-graph code inside subprogram Def_seg WRITE (21,"('Counting fault segments')") CALL Def_seg (f_highest, neighbor, node, num_ele, & ! input & .FALSE., & ! input & trace, trace_is, xyz_nod, & ! input & trace_loc, & ! modify & seg_count, seg_def, seg_end, seg_end_is, seg_eta_, seg_kappa_, seg_u_) ! output IF (seg_count > 0) THEN bytes_added_I8 = 2 * seg_count * bytes_per_int CALL More_mem('seg_def', bytes_added_I8) bytes_added_I8 = 3 * 2 * seg_count * bytes_per_real CALL More_mem('seg_end', bytes_added_I8) bytes_added_I8 = 2 * seg_count * bytes_per_is CALL More_mem('seg_end_is', bytes_added_I8) bytes_added_I8 = seg_count * bytes_per_real CALL More_mem('seg_eta_', bytes_added_I8) bytes_added_I8 = seg_count * bytes_per_real CALL More_mem('seg_kappa_', bytes_added_I8) bytes_added_I8 = seg_count * bytes_per_int CALL More_mem('seg_u_', bytes_added_I8) ALLOCATE( seg_def(2, seg_count) ) ALLOCATE( seg_end(1:3, 2, seg_count) ) ALLOCATE( seg_end_is(2, seg_count) ) ALLOCATE( seg_eta_(seg_count) ) ALLOCATE( seg_kappa_(seg_count) ) ALLOCATE( seg_u_(seg_count) ) !PRINT "(' ','Recording fault segments (slow)')" ! replaced by bar-graph code in subprogram Def_seg WRITE (21,"('Recording fault segments')") CALL Def_seg (f_highest, neighbor, node, num_ele, & ! input & .TRUE., & ! input & trace, trace_is, xyz_nod, & ! input & trace_loc, & ! modify & seg_count, seg_def, seg_end, seg_end_is, seg_eta_, seg_kappa_, seg_u_) ! output END IF ! seg_count > 0 END IF END IF ! there is any data needing internal coordinates PRINT "(' ','Found all data locations in grid coordinates')" WRITE (21,"('Found all data locations in grid coordinates')") ! compact geodetic benchmarks, to list only those inside the .feg IF (external_benchmarks > 0) THEN internal_benchmarks = 0 ! but will grow... Delta_node_gps = 0 ! initialized in case no internal benchmarks are found; typically, it will be increased below! node_high = 1 ! perverse initialization; will be changed node_low = num_nod ! ditto DO i = 1, external_benchmarks IF (benchmark_is(i)%element > 0) THEN internal_benchmarks = internal_benchmarks + 1 j = internal_benchmarks ! for brevity in this code l_ = benchmark_is(i)%element node_high = MAX(node_high, node(1, l_), node(2, l_), node(3, l_)) node_low = MIN(node_low, node(1, l_), node(2, l_), node(3, l_)) Delta_node_gps = MAX(Delta_node_gps, node_high - node_low) uvec(1:3) = benchmark_uvec(1:3, i) CALL Gjxy(l_, uvec, G) DO k = 1, 3 DO x = 1, 2 DO y = 1, 2 benchmark_G(k, x, y, j) = G(k, x, y) END DO END DO END DO IF (j /= i) THEN external_benchmark_index(j) = i internal_benchmark_index(i) = j benchmark_theta(j) = benchmark_theta(i) benchmark_phi(j) = benchmark_phi(i) benchmark_uvec(1:3, j) = benchmark_uvec(1:3, i) benchmark_is(j) = benchmark_is(i) benchmark_vw(2*j-1) = benchmark_vw(2*i-1) benchmark_vw(2*j ) = benchmark_vw(2*i ) benchmark_covariance(1:2, 1:2, j) = benchmark_covariance(1:2, 1:2, i) benchmark_normal(1:2, 1:2, j) = benchmark_normal(1:2, 1:2, i) benchmark_name(j) = benchmark_name(i) END IF ELSE ! this external benchmark is not on the internal list internal_benchmark_index(i) = 0 END IF ! found another internal one on the external list, or not END DO ! i = 1, external_benchmarks PRINT "(' ','Count of geodetic benchmarks inside the .feg area: ',I6)", internal_benchmarks WRITE (21,"('Count of geodetic benchmarks inside the .feg area: ',I6)") internal_benchmarks ! prospective test for unsafe benchmarks (those in the same element with any fast fault(s)): IF (internal_benchmarks > 0) THEN IF (f_dat_count > 0) THEN CALL Unsafe_Benchmarks (f_offset_rate = f_offset_rate, & ! variable inputs & tabulate = .FALSE., & & unsafe_GPS_count = unsafe_GPS_count) ! output IF (unsafe_GPS_count > 0) THEN CALL Unsafe_Benchmarks (f_offset_rate = f_offset_rate, & ! variable inputs & tabulate = .TRUE., & & unsafe_GPS_count = unsafe_GPS_count) ! output CALL Prompt_for_Logical('Do you want to IGNORE this warning and continue?',.FALSE.,ignore_warning) IF (ignore_warning) THEN WRITE (*, *) WRITE (21, "('Do you want to IGNORE this warning and continue?: YES')") WRITE (21, *) ELSE WRITE (21, "('Do you want to IGNORE this warning and continue?: No')") STOP END IF END IF ! unsafe_GPS_count > 0 END IF ! f_dat_count > 0; prospective test for unsafe locations END IF ! internal_benchmarks > 0 using_gp2_file = (gp2_file(1:5) /= 'none ') using_GPS_matrices = using_gp2_file .OR. floating_frame ! create geodetic covariance matrix (if needed) from info in the .gps file IF (using_GPS_matrices) THEN geodetic_nDOF = 2 * internal_benchmarks IF (geodetic_nDOF > 0) THEN bytes_added_I8 = INT8(bytes_per_double) * INT8(geodetic_nDOF)**2 CALL More_mem ('covariance_mps2 matrix', bytes_added_I8) ALLOCATE ( covariance_mps2(geodetic_nDOF, geodetic_nDOF) ) covariance_mps2 = 0.0D0 ! whole array; part of initialization DO i = 1, internal_benchmarks ibase = 2 * (i - 1) covariance_mps2(ibase+1, ibase+1) = benchmark_covariance(1, 1, i) covariance_mps2(ibase+2, ibase+2) = benchmark_covariance(2, 2, i) covariance_mps2(ibase+1, ibase+2) = benchmark_covariance(1, 2, i) covariance_mps2(ibase+2, ibase+1) = benchmark_covariance(2, 1, i) END DO ! i = 1, internal_benchmarks ! read .gp2 file (if any) IF (using_gp2_file) THEN PRINT "(' ','Reading geodetic covariance matrix from ',A)", TRIM(gp2_file) WRITE (21,"('Reading geodetic covariance matrix from ',A)") TRIM(gp2_file) OPEN(UNIT = 10, FILE = gp2_file, STATUS = "OLD", ACTION = "READ", PAD = "YES") entries_read = 0 entering: DO READ (10, *, IOSTAT = ios) i, j, t IF (ios /= 0) EXIT entering entries_read = entries_read + 1 IF ((i == j).AND.(t <= 0.0)) THEN ! prevent non-positive entries on diagonal PRINT "(' ',8X,'ERROR: Diagonal element is non-positive: ',2I6,E12.4)", i, j, t WRITE (21,"(8X,'ERROR: Diagonal element is non-positive: ',2I6,E12.4)") i, j, t STOP END IF !NOTE: Complexity arises from 3 sources: ! (1) The .gp2 file has units of (mm/a)**2, but the internal matrix uses (m/s)**2. ! (2) External versus internal benchmark numbering. ! (3) Because .gp2 file uses (vE, vN) for each benchmark, ! while internal storage uses (vTheta, vPhi) = (vSouth, vEast), ! there is a swap of rows and columns, and ! a change of sign for Theta-Phi (relative to East-North) elements, ! within the 2x2 submatrix associated with each benchmark pair. t_mps2 = t / (1000.D0 * s_per_year)**2 ! See (1) above. i1 = (i + 1) / 2 ! external number of benchmark associated with external dof i i1 = internal_benchmark_index(i1) ! now, i1 is internal number of benchmark associated with external dof i (or 0) IF (i1 > 0) THEN i2 = (j + 1) / 2 ! external number of benchmark associated with external dof j i2 = internal_benchmark_index(i2) ! now, i2 is internal number of benchmark associated with external dof j (or 0) IF (i2 > 0) THEN !At this point, we have dealt with issues (1) and (2), but still have to deal with (3). IF (Even(i)) THEN ! i is associated with vNorth IF (Even(j)) THEN ! vNorth, vNorth ==> vSouth, vSouth (keep sign) covariance_mps2(2*i1-1, 2*i2-1) = t_mps2 covariance_mps2(2*i2-1, 2*i1-1) = t_mps2 ELSE ! Odd(j) ! vNorth, vEast ==> vSouth, vEast (change sign) covariance_mps2(2*i1-1, 2*i2) = -t_mps2 covariance_mps2(2*i2, 2*i1-1) = -t_mps2 END IF ! Even(j), or Odd ELSE ! Odd(i) ! i is associated with vEast IF (Even(j)) THEN ! vEast, vNorth ==> vEast, vSouth (change sign) covariance_mps2(2*i1, 2*i2-1) = -t_mps2 covariance_mps2(2*i2-1, 2*i1) = -t_mps2 ELSE ! Odd(j) ! vEast, vEast ==> vEast, vEast (keep sign) covariance_mps2(2*i1, 2*i2) = t_mps2 covariance_mps2(2*i2, 2*i1) = t_mps2 END IF ! Even(j), or Odd END IF ! Even(i) or Odd END IF END IF ! first benchmark is internal END DO entering CLOSE (10) WRITE (21,"(I10,' entries were processed from this file.')") entries_read END IF ! need to read .gp2 file IF (floating_frame) THEN ! add the reference-frame-loosening rotations to the covariance matrix: PRINT "(' ','Adding reference-frame-loosening rotations of ',F10.2,' degree/Ma')", loosening_degpMa WRITE (21,"('Adding reference-frame-loosening rotations of ',F10.2,' degree/Ma')") loosening_degpMa ALLOCATE ( looseness(geodetic_nDOF) ) DO k = 1, 3 ! 3 rotation axes Euler = 0.0 Euler(k) = loosening_degpMa / (deg_per_rad * 1e6 * s_per_year) !now we have Euler in radians per second DO i = 1, internal_benchmarks uvec(1:3) = benchmark_uvec(1:3, i) CALL Cross (Euler, uvec, vec1) ! vec1 is in radians/s vec1 = vec1 * R ! now, vec1 is in m/s CALL Local_Theta(uvec, vec2) looseness(2*i-1) = Dot_3D(vec1, vec2) ! vTheta produced by rotation, in m/s CALL Local_Phi (uvec, vec2) looseness(2*i) = Dot_3D(vec1, vec2) ! vPhi produced by rotation, in m/s END DO DO i = 1, geodetic_nDOF DO j = 1, geodetic_nDOF covariance_mps2(i, j) = covariance_mps2(i, j) + (looseness(i) * 1.0D0 * looseness(j)) END DO END DO END DO ! 3 rotations DEALLOCATE ( looseness ) END IF ! floating_frame ! create the normal matrix (inverse of geodetic covariance matrix): PRINT "(' ','Inverting covariance matrix to get normal matrix')" WRITE (21,"('Inverting covariance matrix to get normal matrix')") bytes_added_I8 = INT8(bytes_per_double) * INT8(geodetic_nDOF)**2 CALL More_mem ('normal matrix', bytes_added_I8) ALLOCATE ( normal(geodetic_nDOF, geodetic_nDOF) ) !============================================================================================ ! IMSL version follows (see further down for MKL version): !CALL ERSET(1,1,0) ! for any error code other than zero, print message but don't stop !CALL ERSET(2,1,0) !(so that error message can be read before window closes!) !CALL ERSET(3,1,0) !CALL ERSET(4,1,0) !CALL ERSET(5,1,0) !CALL DLINDS (geodetic_nDOF, covariance_mps2, geodetic_nDOF, normal, geodetic_nDOF) !! !! LINDS/DLINDS !! Compute the inverse of a real symmetric positive definite matrix. !! !! Usage !! !! CALL LINDS (N, A, LDA, AINV, LDAINV) !! !! Arguments !! !! N - Order of the matrix A. (Input) !! A - N by N matrix containing the symmetric positive definite matrix to be inverted. (Input) !! (Only the upper triangle of A is referenced.) !! LDA - Leading dimension of A exactly as specified in the dimension statement of the calling program. (Input) !! AINV - N by N matrix containing the inverse of A. (Output) !! (If A is not needed, A and AINV can share the same storage locations.) !! LDAINV - Leading dimension of AINV exactly as specified in the dimension statement of the calling program. (Input) !============================================================================================ ! MKL version follows (see above for IMSL version): normal = covariance_mps2 ! copy whole matrix to future inverse-matrix location ! NOTE: Following 2 CALLs are in Fortran 77 format, because the Fortran 95 format is buggy! uplo = 'U' ! but it could equally well be 'L' CALL dpotrf(uplo, geodetic_NDOF, normal, geodetic_NDOF, info) ! Cholesky factorization of real symmetric positive-definite matrix in-place IF (info /= 0) THEN WRITE (*, "(' While attempting to invert the geodetic covariance matrix,')") WRITE (*, "(' ERROR: CALL dpotrf (of LAPACK of MKL) reports info = ',I10)") info WRITE (21, "('While attempting to invert the geodetic covariance matrix,')") WRITE (21, "('ERROR: CALL dpotrf (of LAPACK of MKL) reports info = ',I10)") info IF (info > 0) THEN i_internal = (info+1)/2 i_external = external_benchmark_index(i_internal) WRITE (*, "(' This geodetic covariance matrix is singular (not positive definite).')") WRITE (*, "(' The problem occurs at benchmark #',I6,' (row #',I6,') in the .gps file.')") i_external, (i_external + 3) WRITE (*, "(' Perhaps its diagonal variances are not positive? Or, too small?')") WRITE (*, "(' Or, perhaps this benchmark is a duplicate of one entered previously?')") WRITE (*, "(' Or, perhaps its 2 rows (and 2 columns) of covariances are duplicates')") WRITE (*, "(' (or multiples) of a pair of covariance rows/columns entered previously?')") WRITE (21, "('This geodetic covariance matrix is singular (not positive definate).')") WRITE (21, "('The problem occurs at benchmark #',I6,' (row #',I6,') in the .gps file.')") i_external, (i_external + 3) WRITE (21, "('Perhaps its diagonal variances are not positive? Or, too small?')") WRITE (21, "('Or, perhaps this benchmark is a duplicate of one entered previously?')") WRITE (21, "('Or, perhaps its 2 rows (and 2 columns) of covariances are duplicates')") WRITE (21, "('(or multiples) of a pair of covariance rows/columns entered previously?')") END IF CALL Pause() STOP END IF CALL dpotri(uplo, geodetic_NDOF, normal, geodetic_NDOF, info) ! invert factorized matrix in-place IF (info /= 0) THEN WRITE (*, "(' While attempting to invert the geodetic covariance matrix,')") WRITE (*, "(' ERROR: CALL dpotri (of LAPACK of MKL) reports info = ',I10)") info WRITE (21, "('While attempting to invert the geodetic covariance matrix,')") WRITE (21, "('ERROR: CALL dpotri (of LAPACK of MKL) reports info = ',I10)") info CALL Pause() STOP END IF !Copy upper-triangle of resulting normal matrix into its lower triangle: DO i = 2, geodetic_NDOF DO j = 1, (i-1) normal(i, j) = normal(j, i) END DO END DO WRITE (*, "(' Geodetic covariance matrix was successfully inverted to create normal matrix')") WRITE (21, "('Geodetic covariance matrix was successfully inverted to create normal matrix')") !============================================================================================ ! Peter Bird's NOTE: Experience shows that small values in covariance_mp2 ! will underflow if squared in REAL (single-precision) arithmetic. ! This results in an erroneous report from LINDS (in IMSL) that the matrix ! is singular. Therefore, it is necessary to create covariance_mps2 ! as DOUBLE PRECISION and to use DLINDS (in IMSL) for inversion. ! Furthermore, loosening of the reference frame (IF floating_frame) ! causes a wide spread in the eigenvalues of covariance_mps2, ! so an accurate inversion is needed to preserve information. ! I suspect there will be similar issues when using MKL, so ! I have invoked dpotrf and dpotri, the DOUBLE PRECISION versions. END IF ! geodetic_nDOF > 0, which means internal_benchmarks > 0 ELSE ! .NOT. using_GPS_matrices Delta_node_gps = 0 END IF ! using_GPS_matrices, or not ELSE ! there are no geodetic benchmarks (even external ones) Delta_node_gps = 0 END IF ! external_benchmarks > 0, or not ! find Delta_node_feg = half-bandwidth of .feg file, 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 Delta_node = MAX(Delta_node_gps, Delta_node_feg) ! determines the bandwidth of the huge linear systems! ! Count cracks, both total and by element. ! Note: A crack is the intersection of a segment (fault intersection element) with a slip component (dip-slip or strike-slip). crack_count = 0 crack_index = 0 ! whole array IF (f_dat_count > 0) THEN PRINT "(' ','Counting active cracks')" WRITE (21,"('Counting active cracks')") DO i = 1, f_dat_count 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 DO ! i = 1, f_dat_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 bytes_added_I8 = crack_count * bytes_per_crack CALL More_mem('local_crack', bytes_added_I8) ALLOCATE ( local_crack(crack_count) ) PRINT "(' ','Recording active cracks')" WRITE (21,"('Recording active cracks')") ! 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_dat_count ! offset datum index j1 = trace_loc(3, which_trace(i)) ! 1st segment of trace j2 = trace_loc(4, which_trace(i)) ! 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 in local_crack 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_, ... (in Restore) local_crack(k)%sense = f_sense(i) ! T, P, N, D, R, L, S local_crack(k)%shadow = f_dat_shadow(i) local_crack(k)%p_ = 0.0 ! will be supplied by Prediction local_crack(k)%component_dip_degrees = f_dat_dip_degrees(i) IF (f_sense(i) == 'T') THEN factor = -1.0 / TAN(f_dat_dip_degrees(i) * radians_per_degree) ELSE IF (f_sense(i) == 'P') THEN factor = -1. ELSE IF (f_sense(i) == 'S') THEN factor = -1. ELSE IF (f_sense(i) == 'N') THEN factor = 1.0 / TAN(f_dat_dip_degrees(i) * radians_per_degree) ELSE IF (f_sense(i) == 'D') THEN factor = 1. ELSE IF (f_sense(i) == 'R') THEN factor = 1. ELSE IF (f_sense(i) == 'L') THEN factor = -1. ELSE ! should not happen! CALL Prevent ('illegal slip sense', i, 'array "f_sense"') ENDIF local_crack(k)%s_ = factor * f_offset_rate(i) local_crack(k)%sigma_ = ABS(factor) * f_offset_rate_sigma_(i) local_crack(k)%extra_weight = 1.0 ! unless higher value needed later to honor rate brackets END IF ! non-null segment END DO ! segments in trace END IF ! at least one segment exists END DO ! i = 1, f_dat_count END IF ! crack_count > 0 END IF ! f_dat_count > 0 !interpolate stress directions (if any) to element centers, using selected method: ! Count the stress data (including cracks?) stress_count = s_dat_count ! (as first term; sum will increase it) IF (faults_give_sigma_1h) THEN DO s = 1, crack_count i = local_crack(s)%datum stress_count = stress_count + 1 END DO END IF !Allocate the array to hold the data (plus fault pseudo-data?) ALLOCATE ( needles(stress_count) ) ! Fill the array with data DO s = 1, s_dat_count needles(s)%location = s_site(1:3, s) needles(s)%azimuth = s_azim(s) needles(s)%sigma = s_sigma_(s) END DO stress_count = s_dat_count ! re-initializing before sum, as we did before IF (faults_give_sigma_1h) THEN DO s = 1, crack_count i = local_crack(s)%datum stress_count = stress_count + 1 segment = local_crack(s)%segment tv = 0.5 * (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, S IF ((sense == 'T') .OR. (sense == 'P') .OR. (sense == 'S')) THEN gamma_ = gamma_ + 1.5708 ! Pi / 2 ELSE IF (sense == 'R') THEN gamma_ = gamma_ + 0.7854 ! Pi / 4 ELSE IF (sense == 'L') THEN gamma_ = gamma_ - 0.7854 ! Pi / 4 END IF needles(stress_count)%azimuth = gamma_ needles(stress_count)%sigma = 0.3928 ! Pi / 8, or 22.5 degrees END DO ! all local cracks END IF ! faults_give_sigma_1h IF (stress_count > 0) THEN ! (may include "real" stress directions and/or rake-based pseudo-stress directions CALL Stress_Interpolation(stress_interpolation_method) !NOTE: Other input is in global array needles (just allocated and filled, above). ! Primary output is global arrays ele_azim(l_ = 1, num_ele) and ele_sigma(l_ = 1, num_ele) . END IF DEALLOCATE ( needles ) ! (original data no longer needs to be stored) !Create and solve linear system for velocities at nodes: PRINT "(' ','Delta_node = ',I8)", Delta_node WRITE (21,"('Delta_node = ',I8)") Delta_node nCoDa = 2 * Delta_node + 1 !========================================================================= ! IMSL version (see MKL version below): !lda = nDOF + nCoDa !CALL More_mem ('ABCDEF matrix', lda * (nCoDa + 2) * bytes_per_double) !ALLOCATE ( ABCDEF(lda, nCoDa+2) ) !========================================================================= ! MKL version (see IMSL version above): bytes_added_I8 = INT8(nCoDa + (nCoDa + 1 + nCoDa)) * INT8(nDOF) * INT8(bytes_per_double) CALL More_mem ('ABCD matrix', bytes_added_I8) WRITE (*, "(' N.B. If an out-of-memory abend occurs here, you have several options:')") WRITE (*, "(' (1) Use NeoKinema-Win64.exe (if not using it already);')") WRITE (*, "(' (2) Add more/larger memory chips to your computer;')") WRITE (*, "(' (3) Design a finite-element grid with fewer nodes; or')") WRITE (*, "(' (4) Do not use any geodetic covariance (.gp2) file.')") WRITE (*, *) ! This extra WRITE is to flush the output text buffer, ! and thus display the More_mem message line before any abend can occur! ALLOCATE ( ABCD((nCoDa + (nCoDa + 1 + nCoDa)), nDOF) ) ! Stored in MKL's "band storage scheme for LU factorization", in which column ! #s are unchanged, but row #s are flattened to produce a smaller, rectangular ! matrix with only nCoDa+1+nCoDa rows. The diagonal becomes a row. ! Unfortunately, there does not seem to be any provision for ! designating the matrix symmetric, and thus storing only one side! bytes_added_I8 = nDOF * 1 * bytes_per_double CALL More_mem ('EF vector', bytes_added_I8) ALLOCATE ( EF(nDOF, 1) ) ! note that dummy column index is NOT optional. MKLdRow = (2 * nCoDa) + 1 ! row-addess of logical diagonal of matrix; ! so logical element ABCD(i, j) is actually ! stored to (or retrieved from) ! ABCD(MKLdRow + i - j, j), as in MKL's ! "band storage scheme for LU factorization" ! I hope this will be less buggy (during ! compilation) than use of statement-functions ! for indirect addressing! !========================================================================= !------------------------ solve linear system (and interate) ------------------------------ ! Is there any kind of stress-direction constraint? any_stress = (s_dat_count > 0).OR. & & (faults_give_sigma_1h.AND.(f_dat_count > 0)) vw = 0.0 ! initial estimate, used in Solve-for-vw IF (any_stress.OR.((any_shadow_pseudodata).AND.(f_dat_count > 0))) THEN ! use iteration boxed = .FALSE. ! whole array; Solve-for-vw can only turn values to TRUE, but not return them IF (dump_all_solutions) THEN OPEN (UNIT = 22, FILE = "v_log.nko") WRITE (22, "(2I8,' num_nod, passes = 1 + n_refine')") num_nod, (1 + n_refine) END IF !=========================================================================== ! IMSL version (see MKL version below): !CALL Solve_for_vw_with_IMSL (passes = (1 + n_refine), vw = vw) !=========================================================================== ! MKL version (see IMSL version above): CALL Solve_for_vw_with_MKL (passes = (1 + n_refine), vw = vw) !=========================================================================== IF (dump_all_solutions) CLOSE(22) ELSE ! iteration is not necessary or useful !=========================================================================== ! IMSL version (see MKL version below): !CALL Solve_for_vw_with_IMSL (passes = 1, vw = vw) !=========================================================================== ! MKL version (see IMSL version above): CALL Solve_for_vw_with_MKL (passes = 1, vw = vw) !=========================================================================== END IF !------------------------------- evaluate success of model --------------------------------- ! Compute model predicted (p_) fault heave-rates, and summarize them in: ! mu_err, f_err, potrate_err, s_err, gps_err, rate_err [the last is a summary of the others]: CALL Prediction (vw = vw, verbose = .TRUE., adjust_some_weights = .FALSE.) !Note: This code can not be made global, because it must also be ! called from within the refinement loop in Solve_for_vw. !------------------------------- begin output section --------------------------------------- !Suggest possible values for mu_ in future runs (boot-strap method): new_mu_from_L1 = mu_err(1) * mu_ new_mu_from_L2 = mu_err(2) * mu_ WRITE (*, "(' Mean (absolute) value of continuum strain rate = ',ES10.2)") new_mu_from_L1 WRITE (21, "('Mean (absolute) value of continuum strain rate = ',ES10.2)") new_mu_from_L1 WRITE (*, "(' Root-mean-square value of continuum strain rate = ',ES10.2)") new_mu_from_L2 WRITE (21, "('Root-mean-square value of continuum strain rate = ',ES10.2)") new_mu_from_L2 IF ((mu_ >= new_mu_from_L1).AND.(mu_ <= new_mu_from_L2)) THEN WRITE (*, "(' Present mu_ of ',ES10.2,' falls in this range.')") mu_ WRITE (21, "('Present mu_ of ',ES10.2,' falls in this range.')") mu_ ELSE IF (mu_ < new_mu_from_L1) THEN WRITE (*, "(' Present mu_ of ',ES10.2,' is less;' & & /' consider increasing it to ',ES10.2,' in future runs.')") mu_, new_mu_from_L1 WRITE (21, "('Present mu_ of ',ES10.2,' is less;' & & /'consider increasing it to ',ES10.2,' in future runs.')") mu_, new_mu_from_L1 ELSE IF (mu_ > new_mu_from_L2) THEN WRITE (*, "(' Present mu_ of ',ES10.2,' is larger;' & & /' consider decreasing it to ',ES10.2,' in future runs.')") mu_, new_mu_from_L2 WRITE (21, "('Present mu_ of ',ES10.2,' is larger;' & & /'consider decreasing it to ',ES10.2,' in future runs.')") mu_, new_mu_from_L2 END IF IF (f_dat_count > 0) THEN CALL Write_f_token_nko WRITE (*, "(' Writing ',A)") TRIM(h_token_nko_file) ! N.B. This was actually already written by SUBROUTINE Prediction. WRITE (21, "('Writing ',A)") TRIM(h_token_nko_file) END IF CALL Write_e_token_nko IF (any_stress) CALL Write_s_token_nko CALL Write_v_token_out WRITE (*, "(' Computing short-term vw_interseismic from long-term velocity solution vw...')") vw_interseismic = vw ! whole vector; true if there are no faults; otherwise, just an initialization. IF (f_dat_count > 0) THEN DO i = 1, f_dat_count !depths of top and bottom of the locked patch: ztop = 0.0 ! Was: "ztop = f_locking_depth_m_min(i)" in NeoKinema versions before 2.3 zbot = f_locking_depth_m_max(i) !Note that these were already converted from km-->m, and replaced with default values if negative, in the input section. IF ((.NOT.f_creeping(i)).AND.(zbot > ztop)) THEN ! compute correction only if locked area is positive!!! !Fault dip !Note: The forward direction is the digitizing direction, which is L-->R on the footwall side; ! thus dips measured from the RHS are all 90-165 degrees (but, converted to radians). dipf = 3.1415927 - (f_dat_dip_degrees(i) * radians_per_degree) !Slip-rate, in m/s, in the (x1, x2, x3) coordinate system of Aura, in which: ! x1 is along the trace, and the sliprate is positive if sinistral; ! x2 is horizontal and perpendicular to trace, sliprate is positive if divergent; ! x3 is down, and sliprate is positive when the RHS (looking in the forward direction) moves relatively down. rate_mps = f_model_offset_rate(i) ! This is not locally accurate; it uses the trace-averaged offset rate. IF (rate_mps /= 0.0) THEN ! contribution of this fault trace to geodetic adjustment is non-zero: IF (f_sense(i) == 'L') THEN sliprate_mps_x1x2x3(1) = rate_mps sliprate_mps_x1x2x3(2) = 0.0 sliprate_mps_x1x2x3(3) = 0.0 ELSE IF (f_sense(i) == 'R') THEN sliprate_mps_x1x2x3(1) = -rate_mps sliprate_mps_x1x2x3(2) = 0.0 sliprate_mps_x1x2x3(3) = 0.0 ELSE IF (f_sense(i) == 'D') THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = rate_mps sliprate_mps_x1x2x3(3) = rate_mps * TAN(dipf) ELSE IF (f_sense(i) == 'N') THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = rate_mps / ABS(TAN(dipf)) sliprate_mps_x1x2x3(3) = -rate_mps ELSE IF (f_sense(i) == 'T') THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = -rate_mps / ABS(TAN(dipf)) sliprate_mps_x1x2x3(3) = rate_mps ELSE IF ((f_sense(i) == 'P').OR.(f_sense(i) == 'S')) THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = -rate_mps sliprate_mps_x1x2x3(3) = -rate_mps * TAN(dipf) END IF k = which_trace(i) IF (trace_loc(3, k) > 0) THEN ! trace has at least one segment in the .feg area n1 = trace_loc(3, k) n2 = trace_loc(4, k) ! first and last segments associated with this trace DO n = n1, n2 ! segment index tv1(1:3) = seg_end(1:3, 1, n) ! Cartesian unit vector of initial point tv2(1:3) = seg_end(1:3, 2, n) ! and final point of this segment tv(1:3) = (tv1(1:3) + tv2(1:3)) / 2. ! location of midpoint fphi = ATAN2F(tv(2), tv(1)) ! phi, or longitude, in radians ftheta = ATAN2F(SQRT(tv(1)**2 + tv(2)**2), tv(3)) ! theta, or colatitude, in radians lf = 0.5D0 * R * SQRT((tv2(1)-tv1(1))**2 + (tv2(2)-tv1(2))**2 + (tv2(3)-tv1(3))**2) ! half-length, in m argume = 3.14159 - Get_Azimuth(tv1, tv2) ! radians counterclockwise from +theta (South) DO j = 1, num_nod tv(1:3) = xyz_nod(1:3, j) CALL Uvec_2_ThetaPhi (tv, node_theta, node_phi) CALL Change (argume = argume, & & btheta = node_theta, bphi = node_phi, & & dipf = dipf, lf = lf, & & ftheta = ftheta, fphi = fphi, & & radius = R, & & slip = sliprate_mps_x1x2x3, & & wedge = 0.2618, & & ztop = ztop, zbot = zbot, & ! input & duthet = duthet, duphi = duphi) ! output ! For a typical year with no earthquakes, ! correct the long-term nodal velocities to short-term interseismic velocities ! by subtracting the (mean rate of) coseismic contributions: vw_interseismic(2 * j - 1) = vw_interseismic(2 * j - 1) - duthet vw_interseismic(2 * j ) = vw_interseismic(2 * j ) - duphi END DO ! j = 1, internal_benchmarks END DO ! n = n1, n2; segment index END IF ! trace_loc(3, k) > 0; trace has at least one segment in the .feg area END IF ! rate_mpa /= 0.0 for this trace END IF ! zbot > ztop, so locked area is positive END DO ! i = 1, f_dat_count END IF ! f_dat_count > 0; adding corrections to vw_interseismic CALL Write_v_interseismic_token_out ! retrospective test for unsafe benchmarks (those in the same element with any fast fault(s)): IF (internal_benchmarks > 0) THEN IF (f_dat_count > 0) THEN CALL Unsafe_Benchmarks (f_offset_rate = f_model_offset_rate, & ! variable inputs & tabulate = .FALSE., & & unsafe_GPS_count = unsafe_GPS_count) ! output IF (unsafe_GPS_count > 0) THEN CALL Unsafe_Benchmarks (f_offset_rate = f_model_offset_rate, & ! variable inputs & tabulate = .TRUE., & & unsafe_GPS_count = unsafe_GPS_count) ! output WRITE (*, *) WRITE (21, *) END IF ! unsafe_GPS_count > 0 END IF ! f_dat_count > 0; retrospective test for unsafe locations END IF ! internal_benchmarks > 0 ! 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 t_nko_file_name PRINT "(' Successful termination of NeoKinema; see ',A)", TRIM(t_nko_file_name) PRINT "(' ')" ! Deallocate all arrays to free memory, using LIFO method. ! (This is necessary because program would otherwise continue to ! hold onto its memory until someone came to work and closed the window!) IF (ALLOCATED( ABCDEF )) DEALLOCATE ( ABCDEF ) ! in IMSL version; OR: IF (ALLOCATED( EF )) DEALLOCATE ( EF ) ! in MKL version IF (ALLOCATED( ABCD )) DEALLOCATE ( ABCD ) ! in MKL version IF (ALLOCATED( normal )) DEALLOCATE ( normal ) IF (ALLOCATED( covariance_mps2 )) DEALLOCATE ( covariance_mps2 ) IF (ALLOCATED( trace_loc )) DEALLOCATE ( trace_loc ) IF (ALLOCATED( center )) DEALLOCATE ( center ) IF (ALLOCATED( neighbor )) DEALLOCATE ( neighbor ) IF (ALLOCATED( ele_strainrate )) DEALLOCATE ( ele_strainrate ) IF (ALLOCATED( node )) DEALLOCATE ( node ) IF (ALLOCATED( benchmark_name )) DEALLOCATE ( benchmark_name ) IF (ALLOCATED( crack_index )) DEALLOCATE ( crack_index ) IF (ALLOCATED( s_loc )) DEALLOCATE ( s_loc ) IF (ALLOCATED( s_ref )) DEALLOCATE ( s_ref ) IF (ALLOCATED( local_crack )) DEALLOCATE ( local_crack ) IF (ALLOCATED( xyz_nod )) DEALLOCATE ( xyz_nod ) IF (ALLOCATED( benchmark_G )) DEALLOCATE ( benchmark_G ) IF (ALLOCATED( seg_end_is )) DEALLOCATE ( seg_end_is ) IF (ALLOCATED( u_flag )) DEALLOCATE ( u_flag ) IF (ALLOCATED( vw_interseismic )) DEALLOCATE ( vw_interseismic ) IF (ALLOCATED( vw )) DEALLOCATE ( vw ) IF (ALLOCATED( seg_end )) DEALLOCATE ( seg_end ) IF (ALLOCATED( ele_sigma )) DEALLOCATE ( ele_sigma ) IF (ALLOCATED( ele_azim )) DEALLOCATE ( ele_azim ) IF (ALLOCATED( a_ )) DEALLOCATE ( a_ ) IF (ALLOCATED( s_site )) DEALLOCATE ( s_site ) IF (ALLOCATED( mu_nod )) DEALLOCATE ( mu_nod ) IF (ALLOCATED( benchmark_covariance )) DEALLOCATE ( benchmark_covariance ) IF (ALLOCATED( benchmark_normal )) DEALLOCATE ( benchmark_normal ) IF (ALLOCATED( benchmark_is )) DEALLOCATE ( benchmark_is ) IF (ALLOCATED( trace_is )) DEALLOCATE ( trace_is ) IF (ALLOCATED( benchmark_uvec )) DEALLOCATE ( benchmark_uvec ) IF (ALLOCATED( fault_name )) DEALLOCATE ( fault_name ) IF (ALLOCATED( seg_def )) DEALLOCATE ( seg_def ) IF (ALLOCATED( trace )) DEALLOCATE ( trace ) IF (ALLOCATED( boxed )) DEALLOCATE ( boxed ) IF (ALLOCATED( ele_stressed )) DEALLOCATE ( ele_stressed ) IF (ALLOCATED( benchmark_model_vw )) DEALLOCATE ( benchmark_model_vw ) IF (ALLOCATED( benchmark_reframed_vw )) DEALLOCATE ( benchmark_reframed_vw ) IF (ALLOCATED( benchmark_unlocked_vw )) DEALLOCATE ( benchmark_unlocked_vw ) IF (ALLOCATED( benchmark_vw )) DEALLOCATE ( benchmark_vw ) IF (ALLOCATED( trace_has_strikeslip_rate )) DEALLOCATE ( trace_has_strikeslip_rate ) IF (ALLOCATED( s_sigma_ )) DEALLOCATE ( s_sigma_ ) IF (ALLOCATED( s_azim )) DEALLOCATE ( s_azim ) IF (ALLOCATED( seg_u_ )) DEALLOCATE ( seg_u_ ) IF (ALLOCATED( seg_kappa_ )) DEALLOCATE ( seg_kappa_ ) IF (ALLOCATED( seg_eta_ )) DEALLOCATE ( seg_eta_ ) IF (ALLOCATED( benchmark_phi )) DEALLOCATE ( benchmark_phi ) IF (ALLOCATED( benchmark_theta )) DEALLOCATE ( benchmark_theta ) IF (ALLOCATED( internal_benchmark_index )) DEALLOCATE ( internal_benchmark_index ) IF (ALLOCATED( external_benchmark_index )) DEALLOCATE ( external_benchmark_index ) IF (ALLOCATED( condition )) DEALLOCATE ( condition ) IF (ALLOCATED( f_divide )) DEALLOCATE ( f_divide ) IF (ALLOCATED( boundary_node )) DEALLOCATE ( boundary_node ) IF (ALLOCATED( f_offset_rate_sigma_ )) DEALLOCATE ( f_offset_rate_sigma_ ) IF (ALLOCATED( f_offset_rate_floor )) DEALLOCATE ( f_offset_rate_floor ) IF (ALLOCATED( f_offset_rate_ceiling )) DEALLOCATE ( f_offset_rate_ceiling ) IF (ALLOCATED( f_model_offset_rate )) DEALLOCATE ( f_model_offset_rate ) IF (ALLOCATED( f_old_model_offset_rate )) DEALLOCATE ( f_old_model_offset_rate ) IF (ALLOCATED( f_offset_rate )) DEALLOCATE ( f_offset_rate ) IF (ALLOCATED( which_trace )) DEALLOCATE ( which_trace ) IF (ALLOCATED( f_dat_shadow )) DEALLOCATE ( f_dat_shadow ) IF (ALLOCATED( f_creeping )) DEALLOCATE ( f_creeping ) IF (ALLOCATED( f_sense )) DEALLOCATE ( f_sense ) CALL Pause() ! Logical end point of main program for NeoKinema, ! although END PROGRAM NeoKinema is not found until the ! last line of this file. !============================================================================== 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 is symmetric. ! NOTE that this routine does NOT require separate IMSL vs. MKL versions; ! the following routines Plug_in_33_for_x will both complete the ! element matrices (especially B) by symmetry. DOUBLE PRECISION, INTENT(IN) :: prefix, goal REAL, DIMENSION(3), INTENT(IN) :: f_, g_ DOUBLE PRECISION, DIMENSION(3,3), INTENT(INOUT) :: A, C, D DOUBLE PRECISION, 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 FUNCTION Arc_distance (a, b) ! distance in radians along a great circle from a to b, ! which are both Cartesian unit vectors REAL, DIMENSION(3), INTENT(IN) :: a, b REAL, DIMENSION(3) :: tv REAL :: cosa, sina cosa = Dot_3D( a, b ) CALL Cross(a, b, tv) sina = Magnitude ( tv ) Arc_distance = ATAN2(sina, cosa) END FUNCTION Arc_distance CHARACTER*10 FUNCTION ASCII10(x) ! Returns a right-justified 10-byte (or shorter) version of a ! floating-point number, in "human" format, with no more ! than 4 significant digits. IMPLICIT NONE REAL, INTENT(IN) :: x CHARACTER*10 :: temp10 CHARACTER*20 :: temp20 INTEGER :: j, k1, k10, zeros LOGICAL :: punt REAL :: x_log DOUBLE PRECISION :: y IF (x == 0.0) THEN ASCII10=' 0' RETURN ELSE IF (x > 0.0) THEN punt = (x >= 999999999.5).OR.(x < 0.0000100) ELSE ! x < 0.0 punt = (x <= -99999999.5).OR.(x > -0.000100) END IF IF (punt) THEN ! need exponential notation; use Fortran utility WRITE (temp10,'(1P,E10.3)') x !consider possible improvements, from left to right: IF (temp10(3:6) == '.000') THEN ! right-shift 4 spaces over it temp20(7:10) = temp10(7:10) temp20(5:6) = temp10(1:2) temp20(1:4) = ' ' temp10 = temp20(1:10) ELSE IF (temp10(5:6) == '00') THEN ! right-shift 2 spaces over it temp20(7:10) = temp10(7:10) temp20(3:6) = temp10(1:4) temp20(1:2) = ' ' temp10 = temp20(1:10) ELSE IF (temp10(6:6) == '0') THEN ! right-shift 1 space over it temp20(7:10) = temp10(7:10) temp20(2:6) = temp10(1:5) temp20(1:1) = ' ' temp10 = temp20(1:10) END IF IF (temp10(8:8) == '+') THEN ! right-shift over + sign in exponent temp20(9:10) = temp10(9:10) temp20(2:8) = temp10(1:7) temp20(1:1) = ' ' temp10 = temp20(1:10) END IF IF (temp10(9:9) == '0') THEN ! right-shift over leading 0 in exponent temp20(10:10) = temp10(10:10) temp20(2:9) = temp10(1:8) temp20(1:1) = ' ' temp10 = temp20(1:10) END IF ASCII10 = temp10 ELSE ! can represent without exponential notation x_log = LOG10(ABS(x)) zeros = Int_Below(x_log) - 3 y = (10.D0**zeros) * NINT(ABS(x) / (10.D0**zeros)) IF (x < 0.0) y = -y WRITE (temp20,"(F20.9)") y ! byte 11 is the '.' !Avoid results like "0.7400001" due to rounding error! IF (temp20(19:20) == '01') temp20(19:20) = '00' !Find first important byte from right; change 0 -> ' ' k10 = 10 ! (if no non-0 found to right of .) right_to_left: DO j = 20, 12, -1 IF (temp20(j:j) == '0') THEN temp20(j:j) = ' ' ELSE k10 = j EXIT right_to_left END IF END DO right_to_left !put leading (-)0 before . of fractions, if it fits IF (x > 0.0) THEN IF (temp20(10:11) == ' .') temp20(10:11) = '0.' ELSE ! x < 0.0 IF (k10 <= 18) THEN IF (temp20(9:11) == ' -.') temp20(9:11) = '-0.' END IF END IF k1 = k10 - 9 ASCII10 = temp20(k1:k10) END IF ! punt, or not END FUNCTION ASCII10 SUBROUTINE Bad_Parameters() !prints admonition screen, calls Pause(), and STOP's. IMPLICIT NONE WRITE (*, *) WRITE (*, "(' ==========================================================================')") WRITE (*, "(' ERROR DURING READING OF PARAMETER FILE')") WRITE (*, "(' ')") WRITE (*, "(' Please review the proper format, which is listed in the introductory')") WRITE (*, "(' comment lines of NeoKinema.f90.')") WRITE (*, "(' ')") WRITE (*, "(' The number (and ordering) of parameters changed between NeoKinema v1.x')") WRITE (*, "(' and NeoKinema v2.x~3.x; then changed again with NeoKinema v4.x.')") WRITE (*, "(' ')") WRITE (*, "(' Errors may occur when input parameter files prepared for NeoKinema v1.x,')") WRITE (*, "(' 2.x, or 3.x are read by this program, NeoKinema v.4, which has different')") WRITE (*, "(' parameters and/or parameter ordering.')") WRITE (*, "(' ')") WRITE (*, "(' After you have read this message, NeoKinema will stop.')") WRITE (*, "(' Please correct the input parameter file and re-start it.')") WRITE (*, "(' ==========================================================================')") Call Pause() STOP END SUBROUTINE Bad_Parameters SUBROUTINE Check_range (filename, line) CHARACTER(*):: filename INTEGER :: line PRINT "(' 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 S and E components of velocity (v_,w_) ! from the long-vector form vw. INTEGER, INTENT(IN) :: l_ REAL, DIMENSION(3,2,2), INTENT(IN) :: G REAL, DIMENSION(:), INTENT(IN) :: vw REAL, INTENT(OUT) :: v_, w_ INTEGER :: iv, iw, j v_ = 0. w_ = 0. 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 DCross (a_vec, b_vec, c_vec) ! DOUBLE PRECISION version of Cross(); ! vector cross product: a x b = c IMPLICIT NONE DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: a_vec, b_vec DOUBLE PRECISION, DIMENSION(3), INTENT(OUT) :: c_vec c_vec(1) = a_vec(2)*b_vec(3) - a_vec(3)*b_vec(2) c_vec(2) = a_vec(3)*b_vec(1) - a_vec(1)*b_vec(3) c_vec(3) = a_vec(1)*b_vec(2) - a_vec(2)*b_vec(1) END SUBROUTINE DCross DOUBLE PRECISION FUNCTION DDot (a_vec, b_vec) ! DOUBLE PRECISION version of Dot() {also called Dot_3D()}; ! returns scalar (dot) product of two 3-component vectors IMPLICIT NONE DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: a_vec, b_vec DDot = a_vec(1)*b_vec(1) + a_vec(2)*b_vec(2) + a_vec(3)*b_vec(3) END FUNCTION DDot SUBROUTINE Def_seg (f_highest, neighbor, node, num_ele, & ! input & savem, & ! input & trace, trace_is, xyz_nod, & ! input & trace_loc, & ! modify & seg_count, seg_def, seg_end, seg_end_is, seg_eta_, seg_kappa_, seg_u_) ! output ! Defines fault segments. (A fault segment is the intersection of a trace with an element.) ! IF (savem) THEN segments are recorded; otherwise they are just counted, ! and "seg_count" is the only INTENT(OUT) variable which is actually set. ! This switch is provided so that segments can be counted in one CALL, ! and then recorded in another CALL (after the necessary arrays have been allocated). ! This job is complicated because digitization "steps" may be either longer or shorter ! than "segments". To reduce confusion, I divide the job into two parts: !(1) Cut(?) steps if/where they cross an element boundary, to produce "bits". !(2) Link bits in the same element to make a segment for that element. ! Bits reside in temporary storage, and are discarded when one fault trace is done. ! When bits are created (either singly, or in groups) they are sorted so that they are ! all pointing in the positive direction along the digitized trace, and put in order; ! this makes step (2) very easy! IMPLICIT NONE INTEGER, PARAMETER :: maxBits = 1000 ! arbitrary size of scratch storage arrays for bits (on one fault trace) INTEGER, INTENT(IN) :: f_highest INTEGER, DIMENSION(:,:), INTENT(IN) :: neighbor !(1:3, 1:num_ele) INTEGER, DIMENSION(:,:), INTENT(IN) :: node INTEGER, INTENT(IN) :: num_ele LOGICAL, INTENT(IN) :: savem ! should segments be recorded in arrays? !(.FALSE. on 1st CALL; .TRUE. on 2nd CALL, after arrays are ALLOCATED) REAL, DIMENSION(:,:), INTENT(IN) :: trace !(1:3, j_traces) TYPE(is123), DIMENSION(:), INTENT(IN) :: trace_is REAL, DIMENSION(:,:), INTENT(IN) :: xyz_nod INTEGER, DIMENSION(:,0:), INTENT(INOUT) :: trace_loc ! (1:4, 0:f_highest); (1:2, already known; (3:4, to be supplied are 1st, last segment # INTEGER, INTENT(OUT) :: seg_count ! number of segments found INTEGER, DIMENSION(:,:), INTENT(OUT) :: seg_def ! defines a fault segment by its fault trace # and element # !(1:2 = trace, element; 1:seg_count = segment index) REAL, DIMENSION(:,:,:), INTENT(OUT) :: seg_end !Cartesian unit vectors at each end of fault segment !(1:3 = xyz, 1:2 = beginning/end, 1:seg_count = segment index) TYPE(is123), DIMENSION(:,:), INTENT(OUT) :: 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, DIMENSION(:), INTENT(OUT) :: 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, DIMENSION(:), INTENT(OUT) :: seg_kappa_ ! kappa_ = relative length, <= 1.00 (if spanning whole element). !(1:seg_count = segment index) INTEGER, DIMENSION(:), INTENT(OUT) :: seg_u_ ! u_ = 1, 2, or 3 to identify isolated node of segment !(1:seg_count = segment index) !internal variables and arrays: CHARACTER(61) :: bar_graph ! for display of progress bar LOGICAL :: end_of_chain, end_of_list, overlap INTEGER :: favorite, first_bit, & & i, i_element, i_element_1st, i_element_2nd, i_trace, & & j, j_critical_1st, j_critical_2nd, j_traces_1st, j_traces_2nd, j1_traces, j2_traces, jold, jtest, & & k, & & l, last_bit, last_used_bit, leading_text_bytes, & & m, & & n, n_bits, n_sorted_bits, nj, nk, number, & & side, side_intersections INTEGER, DIMENSION(maxBits) :: element_of_bit REAL :: fraction1, fraction2, low_fraction, s1, s2, s3, segment_radians, step_radians, t REAL, DIMENSION(3) :: side_1st_uvec, side_2nd_uvec, side_pole_uvec, & & step_1st_uvec, step_2nd_uvec, step_pole_uvec, & & tvec, tvec1, tvec2, & & uvec1, uvec2 REAL, DIMENSION(3) :: ds_dseg, fraction_at_zero ! NOT Cartesian vectors; subscript refers to s(1:3). REAL, DIMENSION(3) :: testor ! NOT a Cartesian vector; subscript refers to 3 nodes in the element REAL, DIMENSION(3, 3) :: crossing_uvecs ! 1st subscript refers to uvec components; 2nd to list of uvecs REAL, DIMENSION(3, 2, maxBits) :: s123s_of_bit, uvecs_of_bit REAL, DIMENSION(2, maxBits) :: fraction_of_step ! 1st subscript refers to two ends of the bit (possibly backwards) DOUBLE PRECISION :: side_dot, step_dot bar_graph = ' ' ! to avoid printing undefined bytes IF (savem) THEN leading_text_bytes = 36 ! no more than 41 !!! bar_graph(1:leading_text_bytes) = ' Recording fault segments (slow) ' ELSE leading_text_bytes = 35 ! no more than 41 !!! bar_graph(1:leading_text_bytes) = ' Counting fault segments (slow) ' END IF DO i = (leading_text_bytes + 1), (leading_text_bytes + 20) bar_graph(i:i) = CHAR(176) END DO PRINT "(' ',A)", bar_graph PRINT "('+',A)", bar_graph(1:leading_text_bytes) jold = 0 seg_count = 0 ! initialize count; to be incremented below DO i_trace = 1, f_highest ! consider all possible fault-trace index values (real or not) j1_traces = trace_loc(1, i_trace) ! initial position in trace and trace_is j2_traces = trace_loc(2, i_trace) ! final position in trace and trace_is IF ((j1_traces > 0) .AND. (j2_traces > j1_traces)) THEN !=== found a fault trace with at least two digitized points =============== !=== Begin step (1) Creation of (sorted) bit list========== =============== ! initialize temporary storage: n_bits = 0 n_sorted_bits = 0 !element_of_bit = 0 ! whole array (just to assist debugging); comment out this line for speed! !uvecs_of_bit = 0.0 ! whole array (just to assist debugging); comment out this line for speed! !s123s_of_bit = 0.0 ! whole array (just to assist debugging); comment out this line for speed! !fraction_of_step = 0.0 ! whole array (just to assist debugging); comment out this line for speed! DO j_traces_1st = j1_traces, (j2_traces - 1) ! work along this fault trace, one digitization step at a time j_traces_2nd = j_traces_1st + 1 step_1st_uvec(1:3) = trace(1:3, j_traces_1st) step_2nd_uvec(1:3) = trace(1:3, j_traces_2nd) !ignore steps of zero length: IF ((step_1st_uvec(1) /= step_2nd_uvec(1)).OR. & & (step_1st_uvec(2) /= step_2nd_uvec(2)).OR. & & (step_1st_uvec(3) /= step_2nd_uvec(3))) THEN step_radians = Arc(step_1st_uvec, step_2nd_uvec) ! should always be positive i_element_1st = trace_is(j_traces_1st)%element i_element_2nd = trace_is(j_traces_2nd)%element !characterize the topology of this step (to save computer time when step is short): IF ((i_element_1st > 0).AND.(i_element_2nd == i_element_1st)) THEN ! simplest case; whole step is in one element, ! so the bit is equal to the step: n_bits = n_bits + 1 IF (n_bits <= maxBits) THEN !------------ create a bit ----------------------------------- element_of_bit(n_bits) = i_element_1st uvecs_of_bit(1:3, 1, n_bits) = step_1st_uvec(1:3) uvecs_of_bit(1:3, 2, n_bits) = step_2nd_uvec(1:3) s123s_of_bit(1:3, 1, n_bits) = trace_is(j_traces_1st)%s(1:3) s123s_of_bit(1:3, 2, n_bits) = trace_is(j_traces_2nd)%s(1:3) n_sorted_bits = n_bits ! no need to sort this bit (created in order, in the positive direction!) !Note: fraction_of_step is not needed (to support sorting) !------------ end creation of bit ----------------------------- ELSE WRITE (*, "(' In SUBROUTINE Def_seg, increase PARAMETER maxBits, and recompile.')") CALL Pause() STOP END IF ELSE IF ((i_element_1st > 0).AND.(i_element_2nd > 0).AND. & ((i_element_2nd == neighbor(1, MAX(i_element_1st,1))).OR. & ! NOTE: MAX(i_element_1st,1) is JUST to prevent (i_element_2nd == neighbor(2, MAX(i_element_1st,1))).OR. & ! an unwanted and unecessary subscript-out-of-range (i_element_2nd == neighbor(3, MAX(i_element_1st,1))))) THEN ! abend in case i_element_1st = 0. ! slightly harder case; step crosses from one element into its immediate neighbor; ! so this step will generate two bits; ! first find the point of intersection with the common side of this pair of elements: side = 0 three_sides: DO i = 1, 3 IF (i_element_2nd == neighbor(i, i_element_1st)) THEN side = i j = 1 + MOD(side, 3) k = 1 + MOD(j, 3) nj = node(j, i_element_1st) nk = node(k, i_element_1st) side_1st_uvec(1:3) = xyz_nod(1:3, nj) side_2nd_uvec(1:3) = xyz_nod(1:3, nk) EXIT three_sides END IF END DO three_sides CALL Cross(step_1st_uvec, step_2nd_uvec, tvec) CALL Make_Uvec(tvec, step_pole_uvec) step_dot = Double_dot(step_1st_uvec, step_pole_uvec) CALL Cross(side_1st_uvec, side_2nd_uvec, tvec) CALL Make_Uvec(tvec, side_pole_uvec) side_dot = Double_dot(side_1st_uvec, side_pole_uvec) CALL Circles_Intersect (pole_a_uvec = step_pole_uvec, dot_a = step_dot, & & first_a_uvec = step_1st_uvec, last_a_uvec = step_2nd_uvec, & & pole_b_uvec = side_pole_uvec, dot_b = side_dot, & & first_b_uvec = side_1st_uvec, last_b_uvec = side_2nd_uvec, & ! input & overlap = overlap, number = number, point1_uvec = uvec1, point2_uvec = uvec2) ! output IF (number < 1) THEN ! should not happen WRITE (*, "(' Logical error in SUBROUTINE Def_seg; Circles_Intersect returns number = 0')") CALL Pause() STOP END IF !create first bit in i_element_1st: !(Note: If number = 2 (finite-length overlap with side), assume crossing occurs at uvec1.) n_bits = n_bits + 1 IF (n_bits <= maxBits) THEN !------------ create a bit ----------------------------------- element_of_bit(n_bits) = i_element_1st uvecs_of_bit(1:3, 1, n_bits) = step_1st_uvec(1:3) uvecs_of_bit(1:3, 2, n_bits) = uvec1(1:3) s123s_of_bit(1:3, 1, n_bits) = trace_is(j_traces_1st)%s(1:3) CALL Dumb_s123 (i_element_1st, uvec1, s1, s2, s3) s123s_of_bit(1, 2, n_bits) = s1 s123s_of_bit(2, 2, n_bits) = s2 s123s_of_bit(3, 2, n_bits) = s3 n_sorted_bits = n_bits ! no need to sort this bit (created in order, in the positive direction!) !Note: fraction_of_step is not needed (to support sorting) !------------ end creation of bit ----------------------------- ELSE WRITE (*, "(' In SUBROUTINE Def_seg, increase PARAMETER maxBits, and recompile.')") CALL Pause() STOP END IF !create second bit in i_element_2nd: !(Note: If number = 2 (finite-length overlap with side), assume crossing occurs at uvec1.) n_bits = n_bits + 1 IF (n_bits <= maxBits) THEN !------------ create a bit ----------------------------------- element_of_bit(n_bits) = i_element_2nd uvecs_of_bit(1:3, 1, n_bits) = uvec1(1:3) uvecs_of_bit(1:3, 2, n_bits) = step_2nd_uvec(1:3) CALL Dumb_s123 (i_element_2nd, uvec1, s1, s2, s3) s123s_of_bit(1, 1, n_bits) = s1 s123s_of_bit(2, 1, n_bits) = s2 s123s_of_bit(3, 1, n_bits) = s3 s123s_of_bit(1:3, 2, n_bits) = trace_is(j_traces_2nd)%s(1:3) n_sorted_bits = n_bits ! no need to sort this bit (created in order, in the positive direction!) !Note: fraction_of_step is not needed (to support sorting) !------------ end creation of bit ----------------------------- ELSE WRITE (*, "(' In SUBROUTINE Def_seg, increase PARAMETER maxBits, and recompile.')") CALL Pause() STOP END IF ELSE ! General case; step may be VERY long, crossing MANY elements (or none)! ! It may also cross in and out of the model domain, perhaps repeatedly. ! Using a brute-force approach, checking for bits (of this step) in every element: CALL Cross(step_1st_uvec, step_2nd_uvec, tvec) CALL Make_Uvec(tvec, step_pole_uvec) step_dot = Double_dot(step_1st_uvec, step_pole_uvec) DO i_element = 1, num_ele side_intersections = 0 ! initialization; to be incremented below: DO side = 1, 3 j = 1 + MOD(side, 3) k = 1 + MOD(j, 3) nj = node(j, i_element) nk = node(k, i_element) side_1st_uvec(1:3) = xyz_nod(1:3, nj) side_2nd_uvec(1:3) = xyz_nod(1:3, nk) CALL Cross(side_1st_uvec, side_2nd_uvec, tvec) CALL Make_Uvec(tvec, side_pole_uvec) side_dot = Double_dot(side_1st_uvec, side_pole_uvec) CALL Circles_Intersect (pole_a_uvec = step_pole_uvec, dot_a = step_dot, & & first_a_uvec = step_1st_uvec, last_a_uvec = step_2nd_uvec, & & pole_b_uvec = side_pole_uvec, dot_b = side_dot, & & first_b_uvec = side_1st_uvec, last_b_uvec = side_2nd_uvec, & ! input & overlap = overlap, number = number, point1_uvec = uvec1, point2_uvec = uvec2) ! output !NOTE: In theory, number = 2 is an impossible result, because !it would mean that the element side and digitization step are colinear, !which is only legal in the two topologies already treated. !(That is, a digitization step shorter than the element side lies entirely between the two nodes that define the side. ! Then, it has to either remain in one element, or cross to a neighbor.) !In the current topology, number = 2 would have to mean that some node lies exactly on a fault, !which was supposed to be prevented by code external to this routine. IF (number > 0) THEN ! We will presume that it is 1 side_intersections = side_intersections + 1 ! may go up to 3 (crossings at a vertex may be double-counted) crossing_uvecs(1:3, side_intersections) = uvec1(1:3) END IF ! number == 1 for intersections with this side END DO ! side = 1, 3 !eliminate any double-counted points (possible at vertices): !-->compare #3 (if any) with #1: IF (side_intersections == 3) THEN IF ((crossing_uvecs(1, 3) == crossing_uvecs(1, 1)).AND. & (crossing_uvecs(2, 3) == crossing_uvecs(2, 1)).AND. & (crossing_uvecs(3, 3) == crossing_uvecs(3, 1))) THEN side_intersections = 2 ! deleting #3 END IF END IF ! side_intersections == 3 !-->compare #3 (if any) with #2: IF (side_intersections == 3) THEN IF ((crossing_uvecs(1, 3) == crossing_uvecs(1, 2)).AND. & (crossing_uvecs(2, 3) == crossing_uvecs(2, 2)).AND. & (crossing_uvecs(3, 3) == crossing_uvecs(3, 2))) THEN side_intersections = 2 ! deleting #3 END IF END IF ! side_intersections == 3 !-->compare #2 (if any) with #1: IF (side_intersections >= 2) THEN IF ((crossing_uvecs(1, 2) == crossing_uvecs(1, 1)).AND. & (crossing_uvecs(2, 2) == crossing_uvecs(2, 1)).AND. & (crossing_uvecs(3, 2) == crossing_uvecs(3, 1))) THEN side_intersections = side_intersections - 1 ! deleting former #2 !now copy former #3 (if valid) into position #2 IF (side_intersections == 2) THEN ! valid ones are now in positions 1 & 3: crossing_uvecs(1:3, 2) = crossing_uvecs(1:3, 3) END IF ! crossing must be moved END IF END IF ! side_intersections == 3 !(conclusion of the elimination of double-counted points) IF (side_intersections == 1) THEN !Usually this means that step just grazed a vertex, and there is no bit (or segment) !in this element. However, we have to check for the special case that there was !only one crossing because the start or end point of the step was in this element: IF (i_element == i_element_1st) THEN side_intersections = 2 ! (blurring the meaning of this variable name) crossing_uvecs(1:3, 2) = step_1st_uvec(1:3) ! (ditto) END IF IF (i_element == i_element_2nd) THEN side_intersections = 2 ! (blurring the meaning of this variable name) crossing_uvecs(1:3, 2) = step_2nd_uvec(1:3) ! (ditto) END IF END IF ! side_intersections == 1 IF (side_intersections >= 2) THEN ! > 2 should not happen; == 1 means just grazing a vertex (no action); n_bits = n_bits + 1 IF (n_bits <= maxBits) THEN !------------ create a bit ----------------------------------- element_of_bit(n_bits) = i_element uvecs_of_bit(1:3, 1, n_bits) = crossing_uvecs(1:3, 1) uvecs_of_bit(1:3, 2, n_bits) = crossing_uvecs(1:3, 2) uvec1(1:3) = crossing_uvecs(1:3, 1) CALL Dumb_s123 (i_element, uvec1, s1, s2, s3) s123s_of_bit(1, 1, n_bits) = s1 s123s_of_bit(2, 1, n_bits) = s2 s123s_of_bit(3, 1, n_bits) = s3 uvec2(1:3) = crossing_uvecs(1:3, 2) CALL Dumb_s123 (i_element, uvec2, s1, s2, s3) s123s_of_bit(1, 2, n_bits) = s1 s123s_of_bit(2, 2, n_bits) = s2 s123s_of_bit(3, 2, n_bits) = s3 !NOTE: n_sorted_bits is NOT incremented here, because bit order is random now fraction_of_step(1, n_bits) = Arc(step_1st_uvec, uvec1) / step_radians fraction_of_step(2, n_bits) = Arc(step_1st_uvec, uvec2) / step_radians !-------- (end creation of bit) ------------------------------- ELSE WRITE (*, "(' In SUBROUTINE Def_seg, increase PARAMETER maxBits, and recompile.')") CALL Pause() STOP END IF END IF ! a new bit is to be created END DO ! i_element = 1, num_ele IF (n_bits > n_sorted_bits) THEN ! new bits were created, and need to be sorted !First, reverse any bit that points the wrong way. DO j = (n_sorted_bits + 1), n_bits IF (fraction_of_step(2, j) < fraction_of_step(1, j)) THEN !reverse this bit: tvec(1:3) = uvecs_of_bit(1:3, 1, j) uvecs_of_bit(1:3, 1, j) = uvecs_of_bit(1:3, 2, j) uvecs_of_bit(1:3, 2, j) = tvec(1:3) s1 = s123s_of_bit(1, 1, j) s2 = s123s_of_bit(2, 1, j) s3 = s123s_of_bit(3, 1, j) s123s_of_bit(1, 1, j) = s123s_of_bit(1, 2, j) s123s_of_bit(2, 1, j) = s123s_of_bit(2, 2, j) s123s_of_bit(3, 1, j) = s123s_of_bit(3, 2, j) s123s_of_bit(1, 2, j) = s1 s123s_of_bit(2, 2, j) = s2 s123s_of_bit(3, 2, j) = s3 t = fraction_of_step(1, j) fraction_of_step(1, j) = fraction_of_step(2, j) fraction_of_step(2, j) = t END IF !this bit must be reversed END DO ! reversing any backward bits !bits are now all pointing forward; sort them by fraction_of_step(1, i) !using a pair-wise swapping algorithm: DO i = (n_sorted_bits + 1), (n_bits - 1) ! (won't execute unless there are at least 2 new bits) ! i points to the first of the unsorted bits favorite = i ! just initialization; probably replaced below low_fraction = fraction_of_step(1, i) ! just initialization; probably replaced below DO j = (i + 1), n_bits ! consider all possible comparisons among unsorted bits IF (fraction_of_step(1, j) < low_fraction) THEN favorite = j low_fraction = fraction_of_step(1, j) END IF ! new favorite found END DO ! j = (i + 1), n_bits ! considering all possible comparisons among unsorted bits IF (favorite /= i) THEN ! swap required between bits #i and #favorite: !swap element_of_bit(?): k = element_of_bit(i) element_of_bit(i) = element_of_bit(favorite) element_of_bit(favorite) = k !swap uvecs_of_bit(1:3, 1, ?): tvec(1:3) = uvecs_of_bit(1:3, 1, i) uvecs_of_bit(1:3, 1, i) = uvecs_of_bit(1:3, 1, favorite) uvecs_of_bit(1:3, 1, favorite) = tvec(1:3) !swap uvecs_of_bit(1:3, 2, ?): tvec(1:3) = uvecs_of_bit(1:3, 2, i) uvecs_of_bit(1:3, 2, i) = uvecs_of_bit(1:3, 2, favorite) uvecs_of_bit(1:3, 2, favorite) = tvec(1:3) !swap s123s_of_bit(1:3, 1, ?): s1 = s123s_of_bit(1, 1, i) s2 = s123s_of_bit(2, 1, i) s3 = s123s_of_bit(3, 1, i) s123s_of_bit(1:3, 1, i) = s123s_of_bit(1:3, 1, favorite) s123s_of_bit(1, 1, favorite) = s1 s123s_of_bit(2, 1, favorite) = s2 s123s_of_bit(3, 1, favorite) = s3 !swap s123s_of_bit(1:3, 2, ?): s1 = s123s_of_bit(1, 2, i) s2 = s123s_of_bit(2, 2, i) s3 = s123s_of_bit(3, 2, i) s123s_of_bit(1:3, 2, i) = s123s_of_bit(1:3, 2, favorite) s123s_of_bit(1, 2, favorite) = s1 s123s_of_bit(2, 2, favorite) = s2 s123s_of_bit(3, 2, favorite) = s3 !swap fraction_of_step(1:2, ?): tvec(1:2) = fraction_of_step(1:2, i) fraction_of_step(1:2, i) = fraction_of_step(1:2, favorite) fraction_of_step(1:2, favorite) = tvec(1:2) END IF ! swap required between bits #i and #favorite END DO ! i = (n_sorted_bits + 1), (n_bits - 1) ! pointing to first of bits that remain to be sorted END IF ! sorting of new bits is required n_sorted_bits = n_bits ! (sorting was either not-needed, or else completed) END IF ! easy, intermediate, or completely general case of step topology END IF ! step has positive length END DO ! stepping along this fault trace !==== (end step (1) Creation of sorted bit list) =========================================== !=== Begin step (2) Linking of adjacent bits to form segments ============================== IF (n_bits > 0) THEN last_used_bit = 0 ! initializing memory of bits used new_segments: DO first_bit = last_used_bit + 1 i_element = element_of_bit(first_bit) linking: DO j = first_bit, n_bits ! looking for last_bit end_of_list = (j == n_bits) end_of_chain = (element_of_bit(j + 1) /= i_element) IF (end_of_list .OR. end_of_chain) THEN last_bit = j EXIT linking END IF END DO linking ! j = first_bit, n_bits ! looking for last_bit !check that potential segment has postive length: uvec1(1:3) = uvecs_of_bit(1:3, 1, first_bit) uvec2(1:3) = uvecs_of_bit(1:3, 2, last_bit) segment_radians = Arc(uvec1, uvec2) IF (segment_radians > 0.0) THEN !**************** create new segment, from first_bit:last_bit ********************* seg_count = seg_count + 1 IF (savem) THEN !trace_loc was INTENT(INOUT) because (1:2, ?) are already known, but (3:4, ?) are still initialized as zeros: IF (trace_loc(3, i_trace) == 0) trace_loc(3, i_trace) = seg_count ! 1st segment for this trace trace_loc(4, i_trace) = seg_count ! last segment for this trace (so far; may be overwritten) !supply values for all INTENT(OUT) arrays: seg_def(1, seg_count) = i_trace seg_def(2, seg_count) = i_element seg_end(1:3, 1, seg_count) = uvec1(1:3) seg_end(1:3, 2, seg_count) = uvec2(1:3) seg_end_is(1, seg_count)%element = i_element seg_end_is(2, seg_count)%element = i_element seg_end_is(1, seg_count)%s(1:3) = s123s_of_bit(1:3, 1, first_bit) seg_end_is(2, seg_count)%s(1:3) = s123s_of_bit(1:3, 2, last_bit) IF ((first_bit > 1).AND.(last_bit < n_bits)) THEN !this segment is not at either end of this fault trace, so: seg_kappa_(seg_count) = 1.0 ! segment cuts all the way across this element ELSE ! kappa_ must be computed: !ds_dseg(1:3) is the partial derivative of s(1:3) with respect to stepping along this segment: !fraction_at_zero(1:3) is the fraction at which this s(1:3) --> 0.0 ! (0.0 <= fraction <= 1.0 corresponds to the segment) DO j = 1, 3 ds_dseg(j) = seg_end_is(2, seg_count)%s(j) - seg_end_is(1, seg_count)%s(j) IF (ds_dseg(j) == 0.0) THEN ! cannot divide by zero: fraction_at_zero(j) = HUGE(t) ELSE ! more typically: fraction_at_zero(j) = -seg_end_is(1, seg_count)%s(j) / ds_dseg(j) END IF END DO !find the two fractions which are closest to 0.5 (the center of the segment), ! AND which vary from 0.5 in OPPOSITE directions!!! IF (((fraction_at_zero(1) - 0.5) * (fraction_at_zero(2) - 0.5) < 0.0).AND. & & ((fraction_at_zero(1) - 0.5) * (fraction_at_zero(3) - 0.5) < 0.0)) THEN ! #1 is different in direction from the other two: j_critical_1st = 1 IF (ABS(fraction_at_zero(2) - 0.5) < ABS(fraction_at_zero(3))) THEN j_critical_2nd = 2 ELSE j_critical_2nd = 3 END IF ELSE IF (((fraction_at_zero(2) - 0.5) * (fraction_at_zero(1) - 0.5) < 0.0).AND. & & ((fraction_at_zero(2) - 0.5) * (fraction_at_zero(3) - 0.5) < 0.0)) THEN ! #2 is different in direction from the other two: j_critical_1st = 2 IF (ABS(fraction_at_zero(1) - 0.5) < ABS(fraction_at_zero(3))) THEN j_critical_2nd = 1 ELSE j_critical_2nd = 3 END IF ELSE ! #3 is different in direction from the other two: j_critical_1st = 3 IF (ABS(fraction_at_zero(1) - 0.5) < ABS(fraction_at_zero(2))) THEN j_critical_2nd = 1 ELSE j_critical_2nd = 2 END IF END IF IF (fraction_at_zero(j_critical_1st) /= fraction_at_zero(j_critical_2nd)) THEN seg_kappa_(seg_count) = 1.0 / ABS(fraction_at_zero(j_critical_1st) - fraction_at_zero(j_critical_2nd)) ELSE ! should not happen WRITE (*, "(' Error in Def_seg; could not compute seg_kappa_')") CALL Pause() STOP END IF seg_kappa_(seg_count) = MIN(1.0, MAX(0.0, seg_kappa_(seg_count) ) ) ! insurance END IF ! kappa_ known, or must be computed !to help determine seg_u_ and seg_eta_, form horizontal (non-unit) vectors ! tvec1 : points along segment ! tvec2 : points from beginning of segment to a node of this element; ! if testor = Dot(uvec1, Cross(tvec2, tvec1)) > 0, this node is on the right. tvec1(1:3) = uvec2(1:3) - uvec1(1:3) DO j = 1, 3 tvec2(1:3) = xyz_nod(1:3, node(j, i_element)) - uvec1(1:3) CALL Cross(tvec2, tvec1, tvec) testor(j) = Dot(uvec1, tvec) END DO IF ((testor(1)*testor(2) < 0.0).AND.(testor(1)*testor(3) < 0.0)) THEN !node 1 is isolated: seg_u_(seg_count) = 1 ELSE IF ((testor(2)*testor(1) < 0.0).AND.(testor(2)*testor(3) < 0.0)) THEN !node 2 is isolated: seg_u_(seg_count) = 2 ELSE !node 3 is isolated: seg_u_(seg_count) = 3 END IF IF (testor(seg_u_(seg_count)) > 0.0) THEN seg_eta_(seg_count) = +1.0 ELSE seg_eta_(seg_count) = -1.0 END IF END IF ! savem !*************** (end creation of new segment ) *********************************** END IF ! segment_radians > 0.0 last_used_bit = last_bit IF (last_used_bit >= n_bits) EXIT new_segments END DO new_segments END IF ! n_bits > 0 !==== (end step (2) Linking of adjacent bits to form segments) ============================ !==== (end of processing this real fault trace, #i_trace) ================================= END IF ! found a real fault trace (#i_trace) jtest = (20 * i_trace) / f_highest IF (jtest > jold) THEN bar_graph(jtest+leading_text_bytes:jtest+leading_text_bytes) = CHAR(219) PRINT "('+',A)", bar_graph(1:jtest+leading_text_bytes) jold = jtest END IF END DO ! i_trace = 1, f_highest; looking among potential fault traces for real ones END SUBROUTINE Def_seg DOUBLE PRECISION FUNCTION Double_dot(uvec1, uvec2) !Computes dot product of two REAL 3-D uvec's in DOUBLE PRECISION: IMPLICIT NONE REAL, DIMENSION(3), INTENT(IN) :: uvec1, uvec2 Double_dot = (1.D0 * uvec1(1)) * (1.D0 * uvec2(1)) + & & (1.D0 * uvec1(2)) * (1.D0 * uvec2(2)) + & & (1.D0 * uvec1(3)) * (1.D0 * uvec2(3)) END FUNCTION Double_dot SUBROUTINE Del_Gjxy_del_thetaphi (l_, r_, dG) IMPLICIT NONE INTEGER, INTENT(IN) :: l_ ! element number REAL, DIMENSION(3), INTENT(IN) :: r_ ! position vector DOUBLE PRECISION, 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_. INTEGER, SAVE :: l_last = 0 ! remembers l_ from previous invocation ! Subscripts of dG(j, x, y, m): 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? DOUBLE PRECISION, DIMENSION(3,2) :: del_r_ ! theta- and phi-derivitives of r_ (in 3-D) DOUBLE PRECISION, DIMENSION(3,2) :: local ! local Theta, Phi unit vectors at r_ (xyz, SE) DOUBLE PRECISION, DIMENSION(3,2,2) :: del_local ! theta-, phi- derivitives of local DOUBLE PRECISION, DIMENSION(3,3), SAVE :: corner ! positions vector of corner nodes (xyz, 123) DOUBLE PRECISION, DIMENSION(3,3,2), SAVE :: post ! unit coordinate vectors at corner nodes: ! (xyz, 123, SE) DOUBLE PRECISION, DIMENSION(3) :: tr_, tv, tvi, tvo, tvp, tv1, tv2, tv3, vfa, vfb ! temporary vector factors DOUBLE PRECISION :: cos_phi, cos_theta, factor, 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 tvi(1:3) = xyz_nod(1:3, node(j, l_)) ! promote to R8 CALL DMake_Uvec(tvi, tvo) ! and check length corner(1:3, j) = tvo(1:3) CALL DLocal_Theta(tvo, tvp) post(1:3, j, 1) = tvp(1:3) CALL DLocal_Phi(tvo, tvp) post(1:3, j, 2) = tvp(1:3) END DO END IF ! begin calculations which depend on r_ tvi(1:3) = r_(1:3) ! promote to R8 CALL DMake_Uvec(tvi, tr_) ! and check length CALL DLocal_Theta(tr_, tv) local(1:3, 1) = tv(1:3) CALL DLocal_Phi(tr_, tv) local(1:3, 2) = tv(1:3) ! Note: these functions will catch polar points; don't test again phi = DATAN2(tr_(2), tr_(1)) cos_phi = DCOS(phi) sin_phi = DSIN(phi) cos_theta = tr_(3) sin_theta = DSQRT(tr_(1)**2 + tr_(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) = -tr_(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(1:3) = corner(1:3, i1) tv2(1:3) = corner(1:3, i2) tv3(1:3) = corner(1:3, i3) CALL DCross(tv2, tv3, vfa) factor = 1.0D0 / DDot(tv1, vfa) vfb(1:3) = vfa(1:3) * factor DO x = 1, 2 ! unit velocity at node is S or E DO y = 1, 2 ! S- or E- component of nodal function tv1(1:3) = post(1:3, j, x) tvi(1:3) = local(1:3, y) DO m = 1, 2 ! theta- or phi-derivitive tv(1:3) = del_r_(1:3, m) tvo(1:3) = del_local(1:3, y, m) dG(j, x, y, m) = & & (DDot(tv, vfb) * DDot(tv1, tvi)) + & & (DDot(tr_, vfb) * DDot(tv1, tvo)) END DO END DO END DO END DO END SUBROUTINE Del_Gjxy_del_thetaphi DOUBLE PRECISION FUNCTION DLength(a_vec) ! DOUBLE PRECISION version of Length() IMPLICIT NONE DOUBLE PRECISION, 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 DLength = 0.0D0 ELSE DLength = DSQRT(t) END IF END FUNCTION DLength SUBROUTINE DLocal_Phi (b_, Phi) ! DOUBLE PRECISION version of Local_Phi(); ! returns local East-pointing unit vector in Cartesian coordinates ! for location b_; not intended to work at the poles! DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: b_ DOUBLE PRECISION, DIMENSION(3), INTENT(OUT) :: Phi DOUBLE PRECISION, DIMENSION(3) :: temp IF (b_(1) == 0.0D0) THEN IF (b_(2) == 0.0D0) THEN WRITE (*,"(' ERROR: DLocal_Phi was requested for N or S pole.')") CALL Traceback END IF END IF temp(1) = -b_(2) temp(2) = b_(1) temp(3) = 0. CALL DMake_Uvec(temp, Phi) END SUBROUTINE DLocal_Phi SUBROUTINE DLocal_Theta (b_, Theta) ! DOUBLE PRECISION version of Local_Theta(); ! returns local South-pointing unit vector in Cartesian coordinates ! for location b_; not intended to work at the poles! DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: b_ DOUBLE PRECISION, DIMENSION(3), INTENT(OUT) :: Theta DOUBLE PRECISION, DIMENSION(3) :: temp DOUBLE PRECISION :: equat, new_equat equat = DSQRT(b_(1)**2 + b_(2)**2) !equatorial component IF (equat == 0.0D0) THEN WRITE (*,"(' ERROR: DLocal_Theta was requested for N or S pole.')") CALL Traceback 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 DMake_Uvec (temp, Theta) END SUBROUTINE DLocal_Theta SUBROUTINE DMake_Uvec (vector, uvec) ! DOUBLE PRECISION version of Make_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 DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: vector DOUBLE PRECISION, DIMENSION(3), INTENT(OUT):: uvec DOUBLE PRECISION :: factor, size size = DLength(vector) IF (size > 0.0D0) THEN factor = 1.0D0 / size uvec = vector * factor DO i = 1, 3 IF (DABS(uvec(i)) < 1.0D-100) uvec(i) = 0.0D0 END DO ELSE WRITE (*,"(' ERROR: Cannot DMake_Uvec of (0.0D0, 0.0D0, 0.0D0).')") CALL Traceback END IF END SUBROUTINE DMake_Uvec SUBROUTINE Dumb_s123 (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). INTEGER, INTENT(IN) :: element REAL, DIMENSION(3), INTENT(IN) :: vector REAL, INTENT(OUT) :: s1, s2, s3 INTEGER :: i1, i2, i3 REAL, DIMENSION(3) :: tv, tvi, tvo, tv1, tv2, v1 REAL :: 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.) 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.00 - s1 - s2 END SUBROUTINE Dumb_s123 SUBROUTINE Dump_seg(limit, savem, punt) ! Called for debugging information: dump of segments list, ! when number becomes excessive. INTEGER, INTENT(IN) :: limit LOGICAL, INTENT(IN) :: savem LOGICAL, INTENT(OUT) :: punt INTEGER :: i IF (savem) THEN PRINT "(' Error: Number of fault segments exceeds plausible limit of ',I8)", limit PRINT "(' Probable infinite loop in Def_seg.')" PRINT "(' 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,"('Dump of segments follows')") WRITE (21,"(/'Trace Element I1 S1 S2 S3 I2 S1 S2 S3')") DO i = 1, MIN(seg_count, limit) WRITE (21, "(I5,I7,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 STOP ELSE punt = .TRUE. PRINT "(' Aborting search for fault segments at count of ',I8)", limit ENDIF END SUBROUTINE Dump_seg SUBROUTINE E_rate(l_, G, dG, theta_, vw, eps_dot) ! Evaluate strain-rate at one position in one spherical continuum element (# l_); ! note that exact position in l_ is determined by values in arrays G and dG; ! and the scalar colatitude theta_ (in radians) must be consistent with these. IMPLICIT NONE INTEGER, INTENT(IN) :: l_ ! element number DOUBLE PRECISION, DIMENSION(3,2,2), INTENT(IN) :: G ! nodal functions @ selected point DOUBLE PRECISION, DIMENSION(3,2,2,2), INTENT(IN):: dG ! derivitives of nodal functions REAL, INTENT(IN) :: theta_ ! colatitude, radians DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: vw REAL, DIMENSION(3), INTENT(OUT) :: eps_dot INTEGER :: iv, iw, j DOUBLE PRECISION :: cott, csct, prefix DOUBLE PRECISION, DIMENSION(3) :: sums sums(1:3) = 0.0D0 cott = 1.0D0 / DTAN(1.0D0 * theta_) csct = 1.0D0 / DSIN(1.0D0 * theta_) prefix = 1.0D0 / R ! 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 sums(1) = sums(1) + & & vw(iv) * prefix * dG(j,1,1,1) + & & vw(iw) * prefix * dG(j,2,1,1) ! epsilon_dot_sub_theta_phi sums(2) = sums(2) + & & vw(iv) * prefix * 0.5 * (csct * dG(j,1,1,2) + dG(j,1,2,1) - cott * G(j,1,2)) + & & vw(iw) * prefix * 0.5 * (csct * dG(j,2,1,2) + dG(j,2,2,1) - cott * G(j,2,2)) ! epsilon_dot_sub_phi_phi sums(3) = sums(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 eps_dot(1:3) = sums(1:3) ! truncating R4 <== R8 END SUBROUTINE E_rate LOGICAL FUNCTION Even(i) IMPLICIT NONE INTEGER, INTENT(IN) :: i Even = (MOD(i, 2) == 0) END FUNCTION Even ! SUBROUTINE File_List( file_type, & ! & suggested_file, & ! & using_path ) ! ! Reports a list (on default device) of filenames of the type requested. ! ! ! ! Usage of CHARACTER*(*), INTENT(INOUT) :: suggested_file ! ! depends on how many files (of specified type) are ! ! found in the current using_path directory: ! ! * If none are found, suggested_file is unchanged (it may ! ! be a correct file name in some other directory). ! ! * If one file is found, suggested_file is changed to its name. ! ! * If multiple files are found: ! ! -if suggested_file is one of them, it is unchanged. ! ! -if suggested_file is not one, it is changed to ' '. ! ! ! ! Uses GETFILEINFOQQ of module DFLIB.F90 ! ! (DIGITAL Visual Fortran 5.0). ! IMPLICIT NONE ! CHARACTER*(*), INTENT(IN) :: file_type ! CHARACTER*(*), INTENT(INOUT) :: suggested_file, using_path ! CHARACTER*1 :: first_letter ! CHARACTER*70 :: line = ' ', old_name ! CHARACTER*80 :: string0, string1, string2 ! CHARACTER*255 :: files ! INTEGER :: count, full_to, handle, old_result, result ! LOGICAL :: duplicate, matched !! TYPE file$info ! this type as defined in DFLIB.F90 !! INTEGER(4) creation !! INTEGER(4) lastwrite !! INTEGER(4) lastaccess !! INTEGER(4) length !! INTEGER(4) permit !! CHARACTER(255) name !! END TYPE file$info ! TYPE (FILE$INFO) info ! this type as defined in DFLIB.F90 ! !10 count = 0 ! matched = .FALSE. ! until we find a file == suggested_file ! IF (file_type == "*.*") THEN ! WRITE (*,"(/' Here are all the files in the input directory:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.*' ! ! ELSE IF (file_type == "*.dig") THEN ! WRITE (*,"(/' The following appear to be basemap (.dig) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.DIG' ! ! ELSE IF (file_type == "*.cat") THEN ! WRITE (*,"(/' The following appear to be seismic catalog (.cat) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.CAT' ! ! ELSE IF (file_type == "*.feg") THEN ! WRITE (*,"(/' The following appear to be FE grid (.feg) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.FEG' ! ELSE IF (file_type == ".grd") THEN ! WRITE (*,"(/' The following appear to be gridded data (.grd) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.GRD' ! ELSE IF (file_type == "p*.nki") THEN ! WRITE (*,"(/' The following appear to be Parameter input (p*.nki) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.NKI' ! ELSE IF (file_type == "s*.nki") THEN ! WRITE (*,"(/' The following appear to be Stress-direction input (s*.nki) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.NKI' ! ELSE IF (file_type == "s*.nko") THEN ! WRITE (*,"(/' The following appear to be interpolated Stress-direction output (s*.nko) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.NKO' ! ELSE IF (file_type == "v*.out") THEN ! WRITE (*,"(/' The following appear to be velocity output (v*.out) files:')") ! files = TRIM(using_path) // & ! defined in NeoKineMap above ! & '*.OUT' ! (must also filter below to exclude force "f*.out" and text "t*.out" files) ! ELSE ! WRITE (*, "(' ERROR: Unknown file_type (',A,') requested from FileList.')") TRIM(file_type) ! CALL Traceback ! END IF ! full_to = 0 ! keeps track of use of line ! handle = FILE$FIRST ! flag constant, defined in DFLIB as -1 ! old_result = -999 ! old_name = 'undefined' ! all_files: DO ! result = GETFILEINFOQQ (TRIM(files), info, handle) ! !check for duplicate return of last file (a bug in GETFILEINFOQQ): ! IF (result >= 1) THEN ! duplicate = (result == old_result) .AND. (info.name(1:result) == TRIM(old_name)) ! old_name = info.name(1:result) ! ELSE ! duplicate = .FALSE. ! old_name = ' ' ! END IF ! old_result = result ! !- - - - - - - - - - - - - - - - - - - ! IF (handle == FILE$ERROR) RETURN ! defined in DFLIB as -3 ! IF ((result == 0).OR.duplicate) THEN ! no (new) matching files found ! IF (full_to > 0) THEN ! WRITE (*,"(' ',A)") TRIM(line) ! GO TO 100 ! ELSE IF (count == 0) THEN ! WRITE (*,"(' No such files in directory ',A,';')") TRIM(using_path) ! CALL Prompt_for_String('Select new directory (for this file only)?',using_path,using_path) ! GO TO 10 ! ELSE ! count > 0, but line empty ! GO TO 100 ! END IF ! END IF ! first_letter = info.name(1:1) ! !If looking for p*.nki, reject "parameter" files that don't start with 'p' ! IF ((file_type == "p*.nki").AND.(.NOT.((first_letter == 'P').OR.(first_letter == 'p')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for s*.nki, reject "input" files that don't start with 's' ! IF ((file_type == "s*.nki").AND.(.NOT.((first_letter == 'S').OR.(first_letter == 's')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for s*.nko, reject "output" files that don't start with 's' ! IF ((file_type == "s*.nko").AND.(.NOT.((first_letter == 'S').OR.(first_letter == 's')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If looking for v*.out, reject "velocity" files that don't start with 'v' ! IF ((file_type == "v*.out").AND.(.NOT.((first_letter == 'V').OR.(first_letter == 'v')))) THEN ! IF (handle == FILE$LAST) THEN ! GO TO 100 ! ELSE ! CYCLE all_files ! END IF ! END IF ! !If we've gotten this far, we have a qualified file! ! count = count + 1 ! string0 = TRIM(suggested_file) ! CALL Upper_Case(string0) ! string1 = info.name(1:result) ! string2 = string1 ! CALL Upper_Case(string2) ! matched = matched .OR. (string0 == string2) ! IF ((full_to + 2 + result) > 70) THEN ! line would overflow ! WRITE (*,"(' ',A)") TRIM(line) ! full_to = 0 ! line = ' ' ! line = info.name(1:result) ! full_to = result ! ELSE ! line can accept this name ! IF (full_to == 0) THEN ! no leading spaces ! line = info.name(1:result) ! full_to = result ! ELSE ! use 2 leading spaces ! line = TRIM(line) // ' ' // info.name(1:result) ! full_to = full_to + 2 + result ! END IF ! END IF ! IF (handle == FILE$LAST) THEN ! IF (full_to > 0) WRITE (*,"(' ',A)") TRIM(line) ! GO TO 100 ! END IF ! END DO all_files ! 100 IF (count == 1) THEN ! collector point, replacing "RETURN" ! ! so that we can adjust suggested_file(?) ! suggested_file = TRIM(string1) ! ELSE IF (count > 1) THEN ! IF (.NOT.matched) THEN ! suggested_file = ' ' ! END IF ! END IF ! END SUBROUTINE File_List SUBROUTINE Find_s1s2s3 !determines internal coordinates of all integrated positions; ! for convenience, also turns off c_active, p_active if outside grid. REAL, DIMENSION(3) :: tv, v1 INTEGER :: a, b, back1, back2, element, lastel INTEGER :: i, j, jold, jtest, j1, j2, jt, k, l_, m, n REAL :: s1, s2, s3 CHARACTER(61) :: bar_graph INTEGER :: leading_text_bytes ! adjustable leading label of oft-repeated completion-bar code LOGICAL :: debug = .FALSE. ! find element center points DO l_ = 1, num_ele v1(1:3) = 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(1:3) 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 = ' ' ! to avoid printing undefined bytes leading_text_bytes = 32 ! no more than 41 !!! bar_graph(1:leading_text_bytes) = ' Finding fault traces (slow) ' IF (debug) WRITE (21, "('trace_is before correction:')") IF (debug) WRITE (21, "(' point element s1 s2 s3')") DO i = (leading_text_bytes + 1), (leading_text_bytes + 20) bar_graph(i:i) = CHAR(176) END DO PRINT "(' ',A)", bar_graph PRINT "('+',A)", bar_graph(1:leading_text_bytes) jold = 0 DO i = 1, f_dig_count tv = trace(1:3, i) 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) jtest = (20 * i) / f_dig_count IF (jtest > jold) THEN bar_graph(jtest+leading_text_bytes:jtest+leading_text_bytes) = CHAR(219) PRINT "('+',A)", bar_graph(1:jtest+leading_text_bytes) jold = jtest 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 j1 = trace_loc(1, i) j2 = trace_loc(2, i) IF ((j1 > 0) .AND. (j2 > j1+1)) THEN 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 back1 = lastel IF ((element == back2).AND.(element > 0)) THEN ! Problem ! jt = j - 1 fix_back: DO IF (trace_is(jt)%element == back1) THEN trace_is(jt)%element = back2 IF (back2 > 0) THEN tv = trace(1:3, jt) CALL Dumb_s123 (element = back2, vector = tv, s1 = s1, s2 = s2, s3 = s3) IF (debug) WRITE (21, 9921) i, jt, back1, trace_is(jt)%s(1), trace_is(jt)%s(2), & & trace_is(jt)%s(3), back2, s1, s2, s3 9921 FORMAT (I5,I6,I8,3F7.2,I8,3F7.2) trace_is(jt)%s(1) = s1 trace_is(jt)%s(2) = s2 trace_is(jt)%s(3) = s3 ELSE trace_is(jt)%s = (/ 0.0, 0.0, 0.0 /) END IF ELSE EXIT fix_back END IF jt = jt - 1 END DO fix_back END IF END IF ! prepare to loop lastel = element END DO END IF END DO ENDIF IF (external_benchmarks > 0) THEN PRINT "(' ',' Finding geodetic benchmarks')" WRITE (21,"(' Finding geodetic benchmarks')") DO i = 1, external_benchmarks tv = benchmark_uvec(1:3, i) CALL Internal (tv, l_, s1, s2, s3) benchmark_is(i)%element = l_ benchmark_is(i)%s(1) = s1 benchmark_is(i)%s(2) = s2 benchmark_is(i)%s(3) = s3 END DO ENDIF END SUBROUTINE Find_s1s2s3 REAL FUNCTION Get_azimuth (v1, v2) REAL, DIMENSION(3), INTENT(IN) :: v1, v2 REAL, DIMENSION(3) :: Phi, step, Theta REAL :: 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) PRINT "(' 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, ios LOGICAL :: past INTEGER, INTENT (IN) :: unit ! Fortran device number READ (unit,"(A)", IOSTAT = ios) buffer IF (ios /= 0) CALL Bad_Parameters() 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, DIMENSION(3), INTENT(IN) :: r_ ! position vector DOUBLE PRECISION, 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_. INTEGER, SAVE :: 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 DOUBLE PRECISION, DIMENSION(3,2) :: local ! local unit vectors at r_ (xyz, SE) DOUBLE PRECISION, DIMENSION(3,3), SAVE :: corner ! positions vector of corner nodes (xyz, 123) DOUBLE PRECISION, DIMENSION(3,3,2), SAVE :: post ! unit coordinate vectors at corner nodes: ! (xyz, 123, SE) DOUBLE PRECISION, DIMENSION(3) :: tr_, tvi, tvo, tvp, tv1, tv2, tv3, vf ! temporary vector factor DOUBLE PRECISION :: 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 tvi(1:3) = xyz_nod(1:3, node(j, l_)) CALL DMake_Uvec(tvi, tvo) corner(1:3, j) = tvo(1:3) CALL DLocal_Theta(tvo, tvp) post(1:3, j, 1) = tvp(1:3) CALL DLocal_Phi(tvo, tvp) post(1:3, j, 2) = tvp(1:3) END DO END IF ! begin computations which depend on r_ tvi(1:3) = r_(1:3) CALL DMake_Uvec(tvi, tr_) CALL DLocal_Theta(tr_, tvo) local(1:3,1) = tvo(1:3) CALL DLocal_Phi(tr_, tvo) local(1:3,2) = tvo(1:3) DO j = 1, 3 i1 = j i2 = 1 + MOD(j, 3) i3 = 1 + MOD(i2,3) tv1(1:3) = corner(1:3, i1) tv2(1:3) = corner(1:3, i2) tv3(1:3) = corner(1:3, i3) CALL DCross(tv2, tv3, vf) f_sup_j = DDot(tr_, vf) / DDot(tv1, vf) DO x = 1, 2 tv1(1:3) = post(1:3, j, x) DO y = 1, 2 tv2(1:3) = local(1:3, y) G(j, x, y) = f_sup_j * DDot(tv1, tv2) END DO END DO END DO END SUBROUTINE Gjxy INTEGER FUNCTION Int_Below (x) ! Returns integer equal to, or less than, x. ! (Note: INT() is different; always truncates toward zero.) IMPLICIT NONE REAL, INTENT(IN) :: x INTEGER :: i REAL :: y i = INT(x) IF (x >= 0.) THEN Int_Below = i ELSE ! x < 0. y = 1.*i IF (y <= x) THEN Int_Below = i ELSE ! most commonly Int_Below = i - 1 END IF END IF END FUNCTION Int_Below SUBROUTINE Internal (b_, iele, s1, s2, s3) REAL, DIMENSION(3), INTENT(IN) :: b_ INTEGER, INTENT(OUT) :: iele REAL, 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. ! Returns iele = 0 if no element contains the point b_. INTEGER :: back1, back2, i, iet, l_ REAL :: r2, r2min, s1t, s2t, s3t REAL, DIMENSION(3) :: s_temp, tv ! establish defaults (not found) in case of quick exit iele = 0 ! default s1 = 0.0; s2 = 0.0; s3 = 0.0 ! default !find closest element center to initialize search r2min = 4.01 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.540) RETURN ! initialize search memory (with impossible numbers) back1 = -1 back2 = -2 is_it_here: DO ! first, check for infinite loop between 2 elements! IF (iet == back2) THEN ! in loop; force location in one or the other! CALL Dumb_s123 (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 (iet, b_, s1t, s2t, s3t) IF ((s1t < s2t) .AND. (s1t < s3t)) THEN ! s1 is most negative; most critical IF (s1t >= 0.) THEN EXIT is_it_here ! success ELSE i = neighbor(1, iet) IF (i > 0) THEN back2 = back1 back1 = iet iet = i CYCLE is_it_here ELSE 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.) THEN EXIT is_it_here ! success ELSE i = neighbor(2, iet) IF (i > 0) THEN back2 = back1 back1 = iet iet = i CYCLE is_it_here ELSE RETURN ! fell off edge of grid ENDIF ENDIF ELSE ! s3 is most negative; most critical IF (s3t >= 0.) THEN EXIT is_it_here ! success ELSE i = neighbor(3, iet) IF (i > 0) THEN back2 = back1 back1 = iet iet = i CYCLE is_it_here ELSE 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 TYPE(is123), INTENT(IN) :: coordinates REAL, DIMENSION(3), INTENT(OUT) :: v INTEGER :: i1, i2, i3, iele REAL :: s1, s2, s3 REAL, 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(1:3) = 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 SUBROUTINE Lonlat_from_xyz (b_, lon, lat) REAL, DIMENSION(3), INTENT(IN) :: b_ ! Cartesian unit vector from center of planet REAL, INTENT(OUT) :: lon, lat REAL :: equat equat = b_(1)**2 + b_(2)**2 IF (equat == 0.) THEN ! N or S pole lon = 0. ! arbitrary convention IF (b_(3) > 0.) THEN lat = 90. ELSE lat = -90. END IF ELSE lat = ATAN2 (b_(3), SQRT(equat)) lon = ATAN2 (b_(2), b_(1)) lon = lon * deg_per_rad lat = lat * deg_per_rad END IF END SUBROUTINE Lonlat_from_xyz SUBROUTINE More_mem (array_name, bytes_added_I8) ! Keeps track of total array allocation CHARACTER(*) :: array_name ! literal text INTEGER*8 :: bytes_added_I8 REAL :: MB_added, MB_total CHARACTER(80) :: buffer memory_bytes_I8 = memory_bytes_I8 + bytes_added_I8 ! global INTEGER*8 variable MB_added = REAL(bytes_added_I8) / REAL(bytes_per_MB) MB_total = REAL(memory_bytes_I8) / REAL(bytes_per_MB) WRITE (buffer,"('Allocated ',A,' =',F12.3,' MB, total',F12.3,' MB')") & array_name, MB_added, MB_total !BUG: Formatted internal WRITE causes memory leak ! under Microsoft Fortran Powerstation 4.0, ! but it will be unimportant in this case. buffer = ADJUSTR(buffer) PRINT "(A)", buffer WRITE (21,"(A)") buffer END SUBROUTINE More_mem SUBROUTINE No_Fault_Elements_Allowed() ! Called if nfl > 0 in the .feg file: ! Prints explanatory messages and stops execution. IMPLICIT NONE 101 FORMAT (& &/' This .feg (finite element grid) file contains fault elements!'& &/' Fault elements are not allowed in NeoKinema grids, because:'& &/' I. NeoKinema does not require fault elements.'& &/' 1. NeoKinema has logic to add the compliance of any number of'& &/' faults to the continuum (triangle) elements that contain them.'& &/' 2. NeoKinema has logic to infer the heave-rate and slip-rate of'& &/' such implied fault(s) from the computed strain-rate of the'& &/' triangular continuum element(s).'& &/' 3. Graphics program NeoKineMap has logic to plot the heave-rates'& &/' of these faults, and also velocity fields with fault '& &/' disontinuities, without the use of fault elements.') 102 FORMAT (& &/' II. Fault elements cause bad grid topology.'& &/' 1. Fault elements are not read or stored by NeoKineMap.'& &/' 2. With fault elements ignored, the grids on the two sides of'& &/' each fault are not connected in any way.'& &/' 3. The solution process may fail due to a singular stiffness'& &/' matrix during solution of the linear system.'& &/' 4. Even if the solution does not fail, its physical interpretation'& &/' will be problematical.') 103 FORMAT (& &/' III. Fault elements should be eliminated from the .feg file.'& &/' 1. Re-load this .feg file into OrbWin, select command Faults,'& &/' and use the right mouse button to heal the fault cuts.'& &/' 2. Use command Adjust to move all nodes off of fault traces.'& &/' 3. Save the edited grid and re-number it with OrbNumber.'& &/' 4. Alternatively, use command Tile in OrbWin to create a'& &/' new .feg grid with no fault elements.') WRITE (*, 101) CALL Pause() WRITE (*, 102) CALL Pause() WRITE (*, 103) CALL Pause() WRITE (21, 101) WRITE (21, 102) WRITE (21, 103) STOP END SUBROUTINE No_Fault_Elements_Allowed LOGICAL FUNCTION Odd(i) IMPLICIT NONE INTEGER, INTENT(IN) :: i Odd = (MOD(i, 2) == 1) END FUNCTION Odd SUBROUTINE Pause() !The purpose of this routine is to give the user time to read an error message !before the program stops (and the operating system closes its window). !The programmer should WRITE the error, CALL Pause(), and then STOP. IMPLICIT NONE WRITE (*,"(' Press [Enter]...'\)") READ (*,*) END SUBROUTINE Pause SUBROUTINE Plane_area (folding) LOGICAL, INTENT(OUT) :: folding !puts areas of plane triangles (below surface) into array a_; !if any is zero or negative, reports folding INTEGER :: i1, i2, i3, l_ REAL, DIMENSION(3) :: a, b, c, t folding = .FALSE. 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.) THEN a_(l_) = Magnitude(c) * half_R2 ELSE folding = .TRUE. RETURN END IF END DO END SUBROUTINE Plane_area SUBROUTINE Plug_in_33_for_IMSL (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 ! augmented-matrix ABCDEF (which has a proprietary storage layout). INTEGER, INTENT(IN) :: l_ ! element number, to access nodes DOUBLE PRECISION, DIMENSION(3,3):: A, B, C, D ! submatrices of element matrix DOUBLE PRECISION, DIMENSION(3) :: E, F ! subvectors of element forcing vector INTEGER :: i, it, j, jt, m, n INTEGER :: ABCDrow, ABCDcol, EFrow, EFcol ! statement functions !======================================================================= ! IMSL version: ABCDrow(j) = j + nCoDa ! statement function; nCoDa is global ABCDcol(i, j) = (j - i) + 1 ! statement function EFrow(i) = i + nCoDa ! statement function; nCoDa is global EFcol = nCoDa + 2 ! These statement functions are for ! codiagonal band symmetric storage mode of matrices ABCD and EF, ! per Microsoft version of IMSL. Note that element (row #i, col #j) ! of the idealized square matrix square_ABCD, or ! square_ABCD(i, j) is stored as ABCDEF(ABCDrow(j),ABCDcol(i, j)); ! and that only elements with j >= i (upper right) can be stored. ! Element (row i) of the linear vector EF is stored in ! ABCDEF(EFrow(i), EFcol). !======================================================================= ! 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 IF (j >= i) THEN it = ABCDrow(j) ! actual row (sic; i not involved) jt = ABCDcol(i, j) ! actual column ABCDEF(it, jt) = ABCDEF(it, jt) + A(m, n) END IF 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_) IF (j >= i) THEN it = ABCDrow(j) ! actual row (sic; i not involved) jt = ABCDcol(i, j) ! actual column ABCDEF(it, jt) = ABCDEF(it, jt) + B(m, n) END IF 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 IF (j >= i) THEN it = ABCDrow(j) ! actual row (sic; i not involved) jt = ABCDcol(i, j) ! actual column ABCDEF(it, jt) = ABCDEF(it, jt) + C(m, n) END IF 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_) IF (j >= i) THEN it = ABCDrow(j) ! actual row (sic; i not involved) jt = ABCDcol(i, j) ! actual column ABCDEF(it, jt) = ABCDEF(it, jt) + D(m, n) END IF END DO END DO ! add element's forcing vectors to global system: DO m = 1, 3 i = 2 * node(m, l_) - 1 ! logical row ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + E(m) i = i + 1 ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + F(m) END DO END SUBROUTINE Plug_in_33_for_IMSL SUBROUTINE Plug_in_33_for_MKL (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 ! coefficient ABCD (in "band storage scheme for LU factorization"), ! and forcing vector EF (which has a second column index == 1). INTEGER, INTENT(IN) :: l_ ! element number, to access nodes DOUBLE PRECISION, DIMENSION(3,3), INTENT(INOUT):: A ! submatrices of element matrix DOUBLE PRECISION, DIMENSION(3,3), INTENT(OUT) :: B ! . DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN) :: C ! . DOUBLE PRECISION, DIMENSION(3,3), INTENT(INOUT):: D ! submatrices of element matrix DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: E, F ! subvectors of element forcing vector INTEGER :: i, it, j, jt, m, n !Note: Important INTEGER parameter MKLdRow is global, from MAIN. ! Arrays node, ABCD, EF are global and REAL*8, from MAIN. !INTEGER :: ABCDrow, ABCDcol, EFrow, EFcol ! statement functions !======================================================================== ! MKL version: !ABCDrow(i, j) = 2*nCoDa + 1 + i - j ! statement function; nCoDa is global !ABCDcol(j) = j ! statement function !EFrow(i) = i ! statement function; nCoDa is global !EFcol = 1 ! These statement functions are for ! MKL's "band storage scheme for LU factorization", in which column ! #s are unchanged, but row #s are flattened to produce a smaller, rectangular ! matrix with (nCoDa + (nCoDa+1+nCoDa)) rows. The diagonal becomes a row. ! Unfortunately, there does not seem to be any provision for ! designating the matrix symmetric, and thus storing only one side! !======================================================================== ! Postscript: After struggling with buggy compilations, I decided ! NOT to use these statement-functions for indirect addressing, ! but to make address computations explicit and checkable, ! with a temporary address variable: it = MKLdRow + i - j, ! so that logical ABCD(i, j) <==> stored at ABCD(it, j). ! Note that MKLdRow is a global INTEGER, precomputed. ! In a similar way, I now refer directly to EF(i, 1) ! instead of using the indirect EF(EFrow(i), EFcol) ! to refer to element #i in the right-hand side forcing vector EF. !======================================================================== ! 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 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 = MKLdRow + 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 = MKLdRow + 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 = MKLdRow + 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 = MKLdRow + 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_for_MKL SUBROUTINE Plug_in_66_for_IMSL (l_1,l_2,A,B,C,D,E,F) ! Completes upper triangle of a super-element ! (6-node x 6-node) matrix, then ! adds element matrix and element forcing vector to global system ! augmented-matrix ABCDEF (which has a proprietary storage layout). INTEGER, INTENT(IN) :: l_1, l_2 ! element numbers, to access nodes REAL, DIMENSION(6,6):: A, B, C, D ! submatrices of super-element matrix REAL, DIMENSION(6) :: E, F ! subvectors of super-element forcing vector INTEGER :: i, it, j, jt, m, n INTEGER :: ABCDrow, ABCDcol, EFrow, EFcol ! statement functions ABCDrow(j) = j + nCoDa ! statement function; nCoDa is global ABCDcol(i, j) = (j - i) + 1 ! statement function EFrow(i) = i + nCoDa ! statement function; nCoDa is global EFcol = nCoDa + 2 ! These statement functions are for ! codiagonal band symmetric storage mode of matrices ABCD and EF, ! per Microsoft version of IMSL. Note that element (row #i, col #j) ! of the idealized square matrix square_ABCD, or ! square_ABCD(i, j) is stored as ABCDEF(ABCDrow(j),ABCDcol(i, j)); ! and that only elements with j >= i (upper right) can be stored. ! Element (row i) of the linear vector EF is stored in ! ABCDEF(EFrow(i), EFcol). ! 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 IF (j >= i) THEN it = ABCDrow(j) ! actual row (sic; i not involved) jt = ABCDcol(i, j) ! actual column ABCDEF(it, jt) = ABCDEF(it, jt) + A(m, n) END IF 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 IF (j >= i) THEN it = ABCDrow(j) ! actual row (sic; i not involved) jt = ABCDcol(i, j) ! actual column ABCDEF(it, jt) = ABCDEF(it, jt) + B(m, n) END IF 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 IF (j >= i) THEN it = ABCDrow(j) ! actual row (sic; i not involved) jt = ABCDcol(i, j) ! actual column ABCDEF(it, jt) = ABCDEF(it, jt) + C(m, n) END IF 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 IF (j >= i) THEN it = ABCDrow(j) ! actual row (sic; i not involved) jt = ABCDcol(i, j) ! actual column ABCDEF(it, jt) = ABCDEF(it, jt) + D(m, n) END IF 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 ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + E(m) i = i + 1 ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + F(m) END DO END SUBROUTINE Plug_in_66_for_IMSL SUBROUTINE Prediction (vw, verbose, adjust_some_weights) ! Computes actual model predictions of rates (p_). ! Also computes 3 norms of errors !(N0 => XXX_err(0), N1 => XXX_err(1), N2 => XXX_err(2)) ! in non-dimensional sigma units, ! where XXX = "rate" for all input data types and a-priori constraints merged; ! = "mu" for a-priori stiffness alone, ! = "gps" for geodetic velocities alone, ! = "f" for fault offset-rates alone, ! = "potrate" for potency-rate-weighted non-dimensional errors in offset rate. ! and these final "reporting" variables are global. ! ! Input parameter "verbose" (not in Restore2, Restore3) ! was added for the NeoKinema version of this SUBR so ! that Prediction can also be called from within the refinement ! loop of Solve_for_vw, without producing output. ! This new call is to get updated estimates of all model ! heave-rates, which are stored in (new, global) type component ! local_crack()%p_ (for each crack) and in (new, global) array ! f_model_offset_rate for each (real and shadow) datum. IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: vw LOGICAL, INTENT(IN) :: verbose LOGICAL, INTENT(IN) :: adjust_some_weights DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: A DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: B, X !NOTE: Double precision is to prevent underflow/overflow ! during solution of linear system, not for great accuracy. CHARACTER*1 :: c1 CHARACTER*4 :: c4 CHARACTER*6 :: c6 REAL :: cott INTEGER, DIMENSION(3) :: corner_node REAL :: csct INTEGER :: datum REAL :: deg_p_Ma DOUBLE PRECISION :: determinant REAL, DIMENSION(:,:),ALLOCATABLE :: derivative REAL :: dipLength, dipLength_times_sliprate, dip_slip_rate_mps DOUBLE PRECISION, DIMENSION(3,2,2,2) :: dG REAL :: equat REAL, DIMENSION(3) :: eps_dot, eps_dot_c REAL :: error REAL :: extra_weight ! temporary, scalar version, used in local solution REAL, DIMENSION(3) :: Euler REAL :: f_N0_sum, f_N1_sum, f_N2_sum, f_error_count DOUBLE PRECISION, DIMENSION(3,2,2) :: G REAL, DIMENSION(:,:),ALLOCATABLE :: g_errors ! (1:3 = error_theta_mps, error_phi_mps, SQRT(e_N_e)) REAL :: gps_N0_sum, gps_N1_sum, gps_N2_sum, gps_error_count DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: GPS_misfit, N_x_GPS_misfit INTEGER :: i, i1, i2, i3 INTEGER :: info REAL, DIMENSION(:), ALLOCATABLE :: inverse_sigma2 INTEGER, DIMENSION(:), ALLOCATABLE :: ipiv INTEGER :: j, j1, j2 INTEGER :: k REAL, DIMENSION(3,3) :: K_matrix INTEGER :: l_, LDA, loc, lwork REAL :: lat1, lat2, lon1, lon2 REAL :: Lz REAL :: model_heave_rate_mmpa REAL :: mu_N0_sum, mu_N1_sum, mu_N2_sum, mu_error_count REAL :: mu_of_r_ INTEGER :: N REAL, DIMENSION(2, 2) :: N_local REAL, DIMENSION(2) :: N_e_column INTEGER :: next_loc, next_segment REAL :: p_ REAL :: potrate_N0_sum, potrate_N1_sum, potrate_N2_sum, potrate_error_count DOUBLE PRECISION :: prefix REAL :: product REAL :: rads_p_s REAL :: rate_N0_sum, rate_N1_sum, rate_N2_sum, rate_error_count REAL, DIMENSION(3) :: R_vector REAL :: rho_ REAL :: s_N0_sum, s_N1_sum, s_N2_sum INTEGER :: segment REAL :: slip_rate_mmpa ! information needed by Long_Term_Seismicity; for h_token_nko file. REAL :: strike_slip_rate_mps REAL :: theta_ REAL, DIMENSION(3) :: tv, tv1, tv2 REAL :: sint REAL :: tant, t_sigma CHARACTER*1 :: uplo REAL, DIMENSION(3) :: uvec, uvec1, uvec2 REAL, DIMENSION(3) :: vec, vec1, vec2 LOGICAL :: wagging_tail DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: work INTEGER :: z_, Z ! initialize 3 different numerators (for N0, N1, N2): rate_N0_sum = 0.; mu_N0_sum = 0.; f_N0_sum = 0.; potrate_N0_sum = 0.; gps_N0_sum = 0. rate_N1_sum = 0.; mu_N1_sum = 0.; f_N1_sum = 0.; potrate_N1_sum = 0.; gps_N1_sum = 0. rate_N2_sum = 0.; mu_N2_sum = 0.; f_N2_sum = 0.; potrate_N2_sum = 0.; gps_N2_sum = 0. ! initialize the common denominator for all measures: rate_error_count = 0.; mu_error_count = 0.; f_error_count = 0.; potrate_error_count = 0.; gps_error_count = 0. ! Note: s_error_count and s_err(0:2) are computed in SUBR Solve_for_vw. ! Prepare to write h*.nko as heave-rates of segments are discovered: IF (verbose) THEN IF (f_dat_count > 0) THEN h_token_nko_file = 'h' // TRIM(token) // ".nko" OPEN (UNIT = 24, FILE = h_token_nko_file) ! absolute; overwrites any pre-existing file END IF END IF ! Continuum strain-rate and active fault segments (cracks) IF (f_dat_count > 0) f_divide = 0. ! 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.) THEN PRINT "(' Error: center of element ',I5,' is N or S pole.')", l_ WRITE (21,"('Error: center of element ',I5,' is N or S pole.')") l_ STOP END IF theta_ = ATAN2(equat, tv(3)) sint = SIN(theta_) csct = 1. / sint tant = TAN(theta_) cott = 1. / tant CALL E_rate(l_, G, dG, theta_, vw, eps_dot) ! evaluate mu_ at center mu_of_r_ = (mu_nod(i1) + mu_nod(i2) + mu_nod(i3)) / 3. IF (f_dat_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 ( B(N) ) ALLOCATE ( X(N) ) LDA = N A = 0. ! whole matrix B = 0. ! whole vector !first term of derivitive of objective function: fault slip-rates: DO z_ = 1, Z loc = crack_index(2, l_) + z_ - 1 ! storage location in local_crack t_sigma = local_crack(loc)%sigma_ extra_weight = local_crack(loc)%extra_weight segment = local_crack(loc)%segment tv1 = seg_end(1:3, 1, segment) tv2 = seg_end(1:3, 2, segment) Lz = R * Arc_distance(tv1, tv2) ! length of segment in m; also known elsewhere as rho_ A(z_, z_) = 2. * Lz * extra_weight / (L0 * t_sigma**2) B(z_) = 2. * Lz * extra_weight * local_crack(loc)%s_ / (L0 * 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_of_r_ prefix = 2. * a_(l_) / (A0 * 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.5 * prefix !finish the third term: Lagrange constraint on total strain-rate: A(Z + 1, Z + 4) = 1. A(Z + 2, Z + 5) = 1. A(Z + 3, Z + 6) = 1. B(Z + 4) = eps_dot(1) B(Z + 5) = eps_dot(2) B(Z + 6) = eps_dot(3) !NOTE that this coefficient matrix is symmetric, but only the diagonal and upper triangle have been filled-in. !==================================================================================================================== ! IMSL version (see MKL version lower down): !! Solve a REAL*8 SYMMETRIC INDEFINITE system of linear equations, without iterative refinement. !! Usage !CALL DLSLSF (N, A, LDA, B, X) !! NOTE: Double-precision version will reduce underflow/overflow problems! !! Arguments !! N = Number of equations. (Input) !! A = N by N matrix containing the coefficient matrix of the symmetric linear system. (Input) !! Only the upper triangle of A is referenced. !! LDA = Leading dimension of A exactly as specified in the dimension statement of the calling program. (Input) !! B = Vector of length N containing the right-hand side of the linear system. (Input) !! X = Vector of length N containing the solution to the linear system. (Output) !==================================================================================================================== ! MKL version (see IMSL version above): uplo = 'U' ! consistent with source code above, which only filled-in the upper triangle. ! Use dsysv for this SYMMETRIC INDEFINITE linear system ALLOCATE ( ipiv(N) ) lwork = 64 * N ! large blocksize for better performance(?) ALLOCATE ( work(lwork) ) CALL dsysv(uplo, N, 1, A, N, ipiv, B, N, work, lwork, info) ! using Fortran77 CALL because F95 CALL is buggy. IF (info /= 0) THEN WRITE (*, "(' ERROR: info = ',I12,' in CALL to dsysv.')") info CALL Traceback() END IF DEALLOCATE ( work ) DEALLOCATE ( ipiv ) X = B ! copying solution to new vector !==================================================================================================================== DO z_ = 1, Z p_ = X(z_) ! PREDICTED HEAVE-RATE OF THIS CRACK (m/s; dextral +, sinistral -, extension +, shortening -) loc = crack_index(2, l_) + z_ - 1 ! storage location in local_crack local_crack(loc)%p_ = p_ ! statement, and new component %p_, added for NeoKinema 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_ !Note: these measures are heave-rates, not offset-rates. They are in m/s. !Find "factor" that will convert ABS(heave_rate) to an approximate slip-rate: !(N.B. "factor" is defined differently in other paragraphs of NeoKinema.) dip_degrees = local_crack(loc)%component_dip_degrees dipLength = (f_locking_depth_m_max(datum) - f_locking_depth_m_min(datum)) / & & SIN(dip_degrees * radians_per_degree) IF (local_crack(loc)%sense == 'T') THEN factor = 1.0 / COS(dip_degrees * radians_per_degree) ELSE IF (local_crack(loc)%sense == 'P') THEN factor = 1.0 / COS(dip_degrees * radians_per_degree) ELSE IF (local_crack(loc)%sense == 'S') THEN factor = 1.0 / COS(dip_degrees * radians_per_degree) ELSE IF (local_crack(loc)%sense == 'N') THEN factor = 1.0 / COS(dip_degrees * radians_per_degree) ELSE IF (local_crack(loc)%sense == 'D') THEN factor = 1.0 / COS(dip_degrees * radians_per_degree) ELSE IF (local_crack(loc)%sense == 'R') THEN factor = 1. ELSE IF (local_crack(loc)%sense == 'L') THEN factor = 1. ENDIF dipLength_times_slipRate = dipLength * (factor * MAX(ABS(p_), ABS(local_crack(loc)%s_))) !N.B. Using greater of datum heave-rate or current model heave-rate ! to compute the slipRate (as a component of the weight ! dipLength_times_slipRate for summation of Potency-rate errors), ! because in some models of seafloor orogens, the "datum" heave-rates ! may be uniformly zero (due to ignorance). On the other hand, ! in some models the faults may all be ~locked and model heave-rates ! could be very small. I want to avoid either potential problem, ! which could otherwise result in an unavailable or unreliable ! set of Potency-rate error measures. !Write_h_token_nko: !Output this crack/segment to h*.nko, where a few typical lines look like: !F9098T heave-rate = 0.017 mm/a in (-120.569, 34.848)-(-120.548, 34.834) = element 10348 creeping?: F, slip-rate = 0.019 mm/a !F9098R heave-rate = 0.000 mm/a in (-120.569, 34.848)-(-120.548, 34.834) = element 10348 creeping?: F, slip-rate = 0.000 mm/a !F9098T heave-rate = 0.017 mm/a in (-120.610, 34.868)-(-120.609, 34.868) = element 10350 creeping?: F, slip-rate = 0.019 mm/a !F9098R heave-rate = 0.000 mm/a in (-120.610, 34.868)-(-120.609, 34.868) = element 10350 creeping?: F, slip-rate = 0.000 mm/a !F9099T heave-rate = 0.479 mm/a in (-120.211, 34.730)-(-120.236, 34.737) = element 10356 creeping?: F, slip-rate = 0.530 mm/a !F9099L heave-rate = 0.040 mm/a in (-120.211, 34.730)-(-120.236, 34.737) = element 10356 creeping?: F, slip-rate = 0.000 mm/a !(Note that when a dip-slip is followed by a "shadow" strike-slip DOF, the slip rate in the first line ! is the Pythagorean hypotenuse or resultant in the fault plane, while the second slip rate is zero. ! This convention greatly simplifies the computations in PROGRAM Long_Term_Seismicity.) IF (verbose) THEN WRITE (c4, "(I4)") seg_def(1, segment) DO j = 1, 3 IF (c4(j:j) == ' ') c4(j:j) = '0' END DO c6 = 'F' // c4 // local_crack(loc)%sense model_heave_rate_mmpa = 1000.0 * s_per_year * p_ !At this point, dextral and extensional heave rates are defined as positive. !Now, adjust positive sense to be that of c6(6:6): IF ((c6(6:6) == 'L').OR.(c6(6:6) == 'T').OR.(c6(6:6) == 'P').OR.(c6(6:6) == 'S')) model_heave_rate_mmpa = -model_heave_rate_mmpa !Determine end points of segment: uvec1(1:3) = seg_end(1:3, 1, segment) CALL Lonlat_from_xyz (uvec1, lon1, lat1) uvec2(1:3) = seg_end(1:3, 2, segment) CALL Lonlat_from_xyz (uvec2, lon2, lat2) !If any shadow cracks have negative R rates, convert these to positive L rates IF (local_crack(loc)%shadow.AND.(model_heave_rate_mmpa < 0.0)) THEN IF (c6(6:6) == 'R') THEN c6(6:6) = 'L' ELSE IF (c6(6:6) == 'L') THEN ! note: ELSE IF prevents a complete back-flip c6(6:6) = 'R' ELSE IF (c6(6:6) == 'T') THEN c6(6:6) = 'N' ELSE IF (c6(6:6) == 'N') THEN c6(6:6) = 'T' ELSE IF (c6(6:6) == 'P') THEN c6(6:6) = 'D' ELSE IF (c6(6:6) == 'S') THEN c6(6:6) = 'D' END IF model_heave_rate_mmpa = -model_heave_rate_mmpa END IF IF (local_crack(loc)%shadow) THEN slip_rate_mmpa = 0.0 ! by convention; this component should be merged with previous dip-slip component by Pythagorean formula ELSE ! not a shadow datum, but could possibly have one following it c1 = local_crack(loc)%sense ! fault-type byte dip_degrees = local_crack(loc)%component_dip_degrees IF ((c1 == 'L').OR.(c1 == 'l').OR. & & (c1 == 'R').OR.(c1 == 'r')) THEN ! this is a strike-slip segment dip_slip_rate_mps = 0.0 strike_slip_rate_mps = ABS(p_) ELSE ! c1 == T, P, N, D, S, t, p, n, d, s: all dip-slip faults !determine dip-slip rate in m/s: dip_slip_rate_mps = ABS(p_) / COS(dip_degrees * radians_per_degree) !check for shadow strike-slip datum following after: IF (z_ < Z) THEN ! it's possible; do further tests next_loc = crack_index(2, l_) + z_ ! or, 1 more than loc next_segment = local_crack(next_loc)%segment IF (local_crack(next_loc)%shadow .AND. & &(seg_def(1, segment) == seg_def(1, next_segment))) THEN ! are F1234 #'s equal? wagging_tail = .TRUE. ! this fault has a shadow strike-slip contribution in the next p_ ELSE wagging_tail = .FALSE. END IF ELSE ! it's not possible wagging_tail = .FALSE. END IF ! we're not at the end of the list, or we are IF (wagging_tail) THEN ! obtained from next, shadow datum strike_slip_rate_mps = ABS(X(z_ + 1)) ELSE strike_slip_rate_mps = 0.0 END IF END IF ! strike-slip or dip-slip slip_rate_mmpa = 1000.0 * s_per_year * SQRT(dip_slip_rate_mps**2 + strike_slip_rate_mps**2) END IF ! shadow datum, or not WRITE (24,"(A6,' heave-rate =',F12.3,' mm/a in (',F8.3,',',F7.3,')-(',F8.3,',',F7.3,') = element',I7,' creeping?: ',L1,', slip-rate =',F12.3,' mm/a')") & & c6, model_heave_rate_mmpa, lon1, lat1, lon2, lat2, seg_def(2, segment), f_creeping(datum), slip_rate_mmpa END IF ! verbose !Add to f_err and rate_err accumulators: IF (ABS(error) > 2.) THEN f_N0_sum = f_N0_sum + rho_ / L0 potrate_N0_sum = potrate_N0_sum + dipLength_times_slipRate * rho_ rate_N0_sum = rate_N0_sum + rho_ / L0 END IF f_N1_sum = f_N1_sum + ABS(error) * rho_ / L0 potrate_N1_sum = potrate_N1_sum + ABS(error) * dipLength_times_sliprate * rho_ rate_N1_sum = rate_N1_sum + ABS(error) * rho_ / L0 f_N2_sum = f_N2_sum + error**2 * rho_ / L0 potrate_N2_sum = potrate_N2_sum + error**2 * dipLength_times_sliprate * rho_ rate_N2_sum = rate_N2_sum + error**2 * rho_ / L0 f_error_count = f_error_count + rho_ / L0 potrate_error_count = potrate_error_count + dipLength_times_slipRate * rho_ rate_error_count = rate_error_count + rho_ / L0 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) !these are the 3 components (NS, SE, EW) of the continuum strain-rate (not including faulting) ele_strainrate(1:3, l_) = eps_dot_c(1:3) ! saved for NeoKineMap 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.) THEN mu_N0_sum = mu_N0_sum + 1.5 * a_(l_) / A0 rate_N0_sum = rate_N0_sum + 1.5 * a_(l_) / A0 END IF mu_N1_sum = mu_N1_sum + ABS(error) * 1.5 * a_(l_) / A0 rate_N1_sum = rate_N1_sum + ABS(error) * 1.5 * a_(l_) / A0 mu_N2_sum = mu_N2_sum + error**2 * 1.5 * a_(l_) / A0 rate_N2_sum = rate_N2_sum + error**2 * 1.5 * a_(l_) / A0 mu_error_count = mu_error_count + 1.5 * a_(l_) / A0 rate_error_count = rate_error_count + 1.5 * a_(l_) / A0 DEALLOCATE ( A, B, X ) ELSE ! no active cracks in this element ele_strainrate(1:3, l_) = eps_dot(1:3) ! saved for NeoKineMap 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.) THEN mu_N0_sum = mu_N0_sum + a_(l_) / A0 rate_N0_sum = rate_N0_sum + a_(l_) / A0 END IF mu_N1_sum = mu_N1_sum + ABS(error) * a_(l_) / A0 rate_N1_sum = rate_N1_sum + ABS(error) * a_(l_) / A0 mu_N2_sum = mu_N2_sum + error**2 * a_(l_) / A0 rate_N2_sum = rate_N2_sum + error**2 * a_(l_) / A0 mu_error_count = mu_error_count + a_(l_) / A0 rate_error_count = rate_error_count + a_(l_) / A0 END IF ! active cracks / no active cracks END DO ! l_ = 1, num_ele ! nominal rate for each active fault is average over segments; check whether to apply bracketing n_brackets_tightened = 0 ! until we check... [global variable] IF (f_dat_count > 0) THEN DO i = 1, f_dat_count IF (f_divide(2, i) > 0.) THEN IF (f_sense(i) == 'T') THEN factor = -1.0 / TAN(f_dat_dip_degrees(i) * radians_per_degree) ELSE IF (f_sense(i) == 'P') THEN factor = -1. ELSE IF (f_sense(i) == 'S') THEN factor = -1. ELSE IF (f_sense(i) == 'N') THEN factor = 1.0 / TAN(f_dat_dip_degrees(i) * radians_per_degree) ELSE IF (f_sense(i) == 'D') THEN factor = 1. ELSE IF (f_sense(i) == 'R') THEN factor = 1. ELSE IF (f_sense(i) == 'L') THEN factor = -1. END IF f_model_offset_rate(i) = (f_divide(1, i) / f_divide(2, i)) / factor !Note: Write_f_token_nki will provide this information to the user. ! Users of NeoKineMap can choose to plot either this (faults) or h*.nko (segments). ELSE f_model_offset_rate(i) = 0.0 ! just so no undefined numbers get printed END IF IF (adjust_some_weights) THEN IF ((f_model_offset_rate(i) < f_offset_rate_floor(i)).OR. & & (f_model_offset_rate(i)>f_offset_rate_ceiling(i))) THEN ! offset rate is currently out of bounds !set flag on this datum (for output file) and count the number of brackets: f_offset_rate_bracketed(i) = .TRUE. ! (can never revert to FALSE) n_brackets_tightened = n_brackets_tightened + 1 !adjust local_crack (for use in future iterations): DO j = 1, crack_count IF (local_crack(j)%datum == i) THEN local_crack(j)%extra_weight = local_crack(j)%extra_weight * 2.0 !Note: In practical terms, there unlikely to be more than ~45 iterations, ! with (some) weights increasing in no more than 30 of these. ! Even if weight increased every time on the same datum (unlikely), ! extra_weight would not go beyond 2**30 = 1E9. So, it won't overflow. END IF END DO END IF ! offset rate is currently out of bounds END IF ! adjust_some_weights END DO ! i = 1, f_dat_count END IF ! f_dat_count > 0 ! Compute gps (geodetic) error measures IF (internal_benchmarks > 0) THEN ! compute model predictions of velocities at benchmarks benchmark_model_vw = 0.0 ! intialize before sums DO i = 1, internal_benchmarks l_ = benchmark_is(i)%element corner_node(1:3) = node(1:3, l_) DO k = 1, 3 ! corner nodes ! theta or S component: benchmark_model_vw(2 * i - 1) = benchmark_model_vw(2 * i - 1) + & & vw(2 * corner_node(k) - 1) * benchmark_G(k, 1, 1, i) + & & vw(2 * corner_node(k) ) * benchmark_G(k, 2, 1, i) ! phi or E component: benchmark_model_vw(2 * i ) = benchmark_model_vw(2 * i ) + & & vw(2 * corner_node(k) - 1) * benchmark_G(k, 1, 2, i) + & & vw(2 * corner_node(k) ) * benchmark_G(k, 2, 2, i) END DO ! k = 1, 3; corner nodes END DO ! i = 1, internal_benchmarks IF (floating_frame.AND.(loosening_degpMa > 0.0)) THEN !re-frame the geodetic data at benchmarks to minimize misfit ALLOCATE ( inverse_sigma2(geodetic_nDOF) ) ALLOCATE ( derivative(geodetic_nDOF, 3) ) DO i = 1, internal_benchmarks inverse_sigma2(2 * i - 1) = 1.0 / benchmark_covariance(1, 1, i) inverse_sigma2(2 * i ) = 1.0 / benchmark_covariance(2, 2, i) END DO ! i = 1, internal_benchmarks ! derivative(i, k) = partial derivative of velocity component i (at some benchmark) ! with respect to component rotation k = 1, 2, 3 = x, y, z ! (referring to the Cartesian axes from the center of Earth). ! As the component rotations are in radians/s, and the velocity ! components are in m/s, the units of derivative are m, and ! the magnitudes are of order R. DO k = 1, 3 ! 3 rotation axes: computing derivative(:,:) Euler = 0.0 Euler(k) = 1.0 ! radians/s DO i = 1, internal_benchmarks uvec(1:3) = benchmark_uvec(1:3, i) CALL Cross (Euler, uvec, vec1) ! vec1 is in radians/s vec1 = vec1 * R ! now, vec1 is in m/s CALL Local_Theta(uvec, vec2) derivative(2 * i - 1, k) = Dot_3D(vec1, vec2) ! vTheta produced by rotation, in m/s, per omega in /s: meters CALL Local_Phi (uvec, vec2) derivative(2 * i , k) = Dot_3D(vec1, vec2) ! vPhi produced by rotation, in m/s, per omega in /s: meters END DO END DO ! 3 rotations: computing derivative(:,:) K_matrix = 0.0 ! initialize before sum DO k = 1, 3 DO l_ = 1, 3 DO i = 1, geodetic_nDOF K_matrix(k, l_) = K_matrix(k, l_) + inverse_sigma2(i) * derivative(i, k) * derivative(i, l_) END DO ! i = 1, geodetic_nDOF END DO ! l_ = 1, 3 END DO ! k = 1, 3 R_vector = 0.0 ! initialize before sum DO k = 1, 3 DO i = 1, geodetic_nDOF R_vector(k) = R_vector(k) + inverse_sigma2(i) * derivative(i, k) * & & (benchmark_model_vw(i) - benchmark_unlocked_vw(i)) END DO ! i = 1, geodetic_nDOF END DO ! k = 1, 3 !==================================================================================================================== ! IMSL version (see MKL version lower down): ! Solve a real symmetric system of linear equations without iterative refinement. !CALL LSLSF (3, K_matrix, 3, R_vector, Euler) ! Arguments ! N = Number of equations. (Input) ! A = N by N matrix containing the coefficient matrix of the symmetric linear system. (Input) ! Only the upper triangle of A is referenced. ! LDA = Leading dimension of A exactly as specified in the dimension statement of the calling program. (Input) ! B = Vector of length N containing the right-hand side of the linear system. (Input) ! X = Vector of length N containing the solution to the linear system. (Output) !==================================================================================================================== ! MKL version (see IMSL version above): uplo = 'U' ! although it could equally well be 'L'. CALL dposv(uplo, 3, 1, K_matrix, 3, R_vector, 3, info) ! using Fortran77 CALL because F95 CALL is buggy. IF (info /= 0) THEN WRITE (*, "(' ERROR: info = ',I12,' in CALL to dposv.')") info CALL Traceback() END IF Euler = R_vector ! copying solution to new vector !==================================================================================================================== ! At this point, solution Euler should be in radians/s. rads_p_s = SQRT(Euler(1)**2 + Euler(2)**2 + Euler(3)**2) IF (rads_p_s > 0.0) THEN uvec(1:3) = Euler(1:3) / rads_p_s ELSE uvec(1:3) = (/ 1., 0., 0. /) END IF CALL Lonlat_from_xyz (uvec, lon1, lat1) deg_p_Ma = rads_p_s * deg_per_rad * 1E6 * s_per_year IF (verbose) THEN PRINT "(' ','Correcting geodetic velocities, to best-fit the current model, by')" WRITE (21,"('Correcting geodetic velocities, to best-fit the current model, by')") PRINT "(' ','adding rotation of ',F10.4,' deg/Ma about (',F7.3,'N, ',F8.3,'E)')", deg_p_Ma, lat1, lon1 WRITE (21,"('adding rotation of ',F10.4,' deg/Ma about (',F7.3,'N, ',F8.3,'E)')") deg_p_Ma, lat1, lon1 END IF ! actually APPLY the correction just determined, to the geodetic data DO i = 1, internal_benchmarks uvec(1:3) = benchmark_uvec(1:3, i) CALL Cross (Euler, uvec, vec1) ! vec1 is in radians/s vec1 = vec1 * R ! now, vec1 is in m/s CALL Local_Theta(uvec, vec2) benchmark_reframed_vw(2 * i - 1) = benchmark_unlocked_vw(2 * i - 1) + Dot_3D(vec1, vec2) ! vTheta produced by rotation, in m/s CALL Local_Phi (uvec, vec2) benchmark_reframed_vw(2 * i ) = benchmark_unlocked_vw(2 * i ) + Dot_3D(vec1, vec2) ! vPhi produced by rotation, in m/s END DO ! i = 1, internal_benchmarks DEALLOCATE ( derivative ) DEALLOCATE ( inverse_sigma2 ) ELSE ! floating_frame = F, or loosening_degpMa = 0.0 benchmark_reframed_vw = benchmark_unlocked_vw ! whole vector END IF ! velocity reference frame of geodetic data floats free, or not ALLOCATE ( g_errors(3, internal_benchmarks) ) ! (1:3 = error_theta_mps, error_phi_mps, SQRT(e_N_e)) DO i = 1, internal_benchmarks gps_error_count = gps_error_count + 2. ! 2 DOF at each benchmark rate_error_count = rate_error_count + 2. g_errors(1, i) = benchmark_model_vw(2 * i - 1) - benchmark_reframed_vw(2 * i - 1) g_errors(2, i) = benchmark_model_vw(2 * i) - benchmark_reframed_vw(2 * i) !Determine error using only block-diagonal parts of covariance and normal matrix: determinant = (1.0D0 * benchmark_covariance(1, 1, i)) * benchmark_covariance(2, 2, i) - & & (1.0D0 * benchmark_covariance(2, 1, i)) * benchmark_covariance(1, 2, i) N_local(1, 1) = +benchmark_covariance(2, 2, i) / determinant N_local(2, 2) = +benchmark_covariance(1, 1, i) / determinant N_local(1, 2) = -benchmark_covariance(1, 2, i) / determinant N_local(2, 1) = -benchmark_covariance(2, 1, i) / determinant N_e_column(1) = N_local(1, 1) * g_errors(1, i) + N_local(1, 2) * g_errors(2, i) N_e_column(2) = N_local(2, 1) * g_errors(1, i) + N_local(2, 2) * g_errors(2, i) g_errors(3, i) = SQRT(g_errors(1, i) * N_e_column(1) + g_errors(2, i) * N_e_column(2)) IF (g_errors(3, i) > 2.0) THEN gps_N0_sum = gps_N0_sum + 2. ! because we count each benchmark as 2 DOF in denominator rate_N0_sum = rate_N0_sum + 2. END IF gps_N1_sum = gps_N1_sum + 2. * g_errors(3, i) ! ditto rate_N1_sum = rate_N1_sum + 2. * g_errors(3, i) gps_N2_sum = gps_N2_sum + g_errors(3, i)**2 ! no factor of 2 is needed here because e_N_e is done in 2-D rate_N2_sum = rate_N2_sum + g_errors(3, i)**2 END DO ! i = 1, internal_benchmarks !NOTE: Method above is for block-diagonal covariance and normal matrices. ! The full-matrix method is below... IF (using_GPS_matrices) THEN ALLOCATE ( GPS_misfit(geodetic_NDOF) ) ! ~= g_error(1:2, 1:internal_benchmarks) ALLOCATE ( N_x_GPS_misfit(geodetic_NDOF) ) ! normal matrix N, multiplied by GPS_misfit DO i = 1, internal_benchmarks GPS_misfit(2*i-1) = g_errors(1, i) GPS_misfit(2*i) = g_errors(2, i) END DO N_x_GPS_misfit = 0.0D0 ! just initializing before sum DO i = 1, geodetic_NDOF DO j = 1, geodetic_NDOF N_x_GPS_misfit(i) = N_x_GPS_misfit(i) + GPS_misfit(j) * normal(i, j) END DO END DO gps_N0_sum = 0.0 ! just initializing, before sums gps_N1_sum = 0.0 gps_N2_sum = 0.0 DO i = 1, internal_benchmarks product = GPS_misfit(i) * N_x_GPS_misfit(i) IF (SQRT(ABS(product)) > 2.0) gps_N0_sum = gps_N0_sum + 1.0 gps_N1_sum = gps_N1_sum + SQRT(ABS(product)) gps_N2_sum = gps_N2_sum + product END DO DEALLOCATE ( GPS_misfit ) DEALLOCATE ( N_x_GPS_misfit ) END IF ! output file g*.nko, with re-framed geodetic velocities and/or geodetic misfits: IF (verbose) CALL Write_g_token_nko(g_errors) DEALLOCATE ( g_errors ) END IF ! internal_benchmarks > 0 ! Finish and report error measures: IF (verbose) THEN IF (f_dat_count > 0) CLOSE(24) ! h*.nko PRINT "(' ================================================================')" WRITE (21,"('================================================================')") END IF IF (mu_error_count > 0.) THEN mu_err(0) = mu_N0_sum / mu_error_count mu_err(1) = mu_N1_sum / mu_error_count mu_err(2) = SQRT( mu_N2_sum / mu_error_count ) IF (verbose) THEN PRINT "(' ','Continuum errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)", mu_err(0), mu_err(1), mu_err(2) WRITE (21,"('Continuum errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)") mu_err(0), mu_err(1), mu_err(2) END IF ELSE mu_err = 0. ! all 3 values END IF IF (any_stress) THEN !NOTE: These values were computed in SUBR Solve_for_vw IF (verbose) THEN PRINT "(' ','Stress errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)", s_err(0), s_err(1), s_err(2) WRITE (21,"('Stress errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)") s_err(0), s_err(1), s_err(2) END IF !Now, "reconstitute" the 3 stress error measures, and add them to the global total: s_N0_sum = s_err(0) * s_error_count s_N1_sum = s_err(1) * s_error_count s_N2_sum = s_err(2)**2 * s_error_count rate_N0_sum = rate_N0_sum + s_N0_sum rate_N1_sum = rate_N1_sum + s_N1_sum rate_N2_sum = rate_N2_sum + s_N2_sum rate_error_count = rate_error_count + s_error_count END IF IF (f_error_count > 0.) THEN f_err(0) = f_N0_sum / f_error_count f_err(1) = f_N1_sum / f_error_count f_err(2) = SQRT( f_N2_sum / f_error_count ) IF (verbose) THEN PRINT "(' ','Offset-rate errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)", f_err(0), f_err(1), f_err(2) WRITE (21,"('Offset-rate errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)") f_err(0), f_err(1), f_err(2) END IF ELSE f_err = 0. ! all 3 values END IF IF (potrate_error_count > 0.) THEN potrate_err(0) = potrate_N0_sum / potrate_error_count potrate_err(1) = potrate_N1_sum / potrate_error_count potrate_err(2) = SQRT( potrate_N2_sum / potrate_error_count ) IF (verbose) THEN PRINT "(' ','Potency-rate errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)", potrate_err(0), potrate_err(1), potrate_err(2) WRITE (21,"('Potency-rate errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)") potrate_err(0), potrate_err(1), potrate_err(2) END IF ELSE potrate_err = 0. ! all 3 values END IF IF (gps_error_count > 0.) THEN gps_err(0) = gps_N0_sum / gps_error_count gps_err(1) = gps_N1_sum / gps_error_count gps_err(2) = SQRT( gps_N2_sum / gps_error_count ) IF (verbose) THEN PRINT "(' ','Geodetic errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)", gps_err(0), gps_err(1), gps_err(2) WRITE (21,"('Geodetic errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)") gps_err(0), gps_err(1), gps_err(2) END IF ELSE gps_err = 0. ! all 3 values END IF IF (rate_error_count > 0.) THEN rate_err(0) = rate_N0_sum / rate_error_count rate_err(1) = rate_N1_sum / rate_error_count rate_err(2) = SQRT( rate_N2_sum / rate_error_count ) IF (verbose) THEN ! PRINT "(' ','Global errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)", rate_err(0), rate_err(1), rate_err(2) ! WRITE (21,"('Global errors: N0 =',F6.3,', N1 = ',F9.3,', N2 = ',F9.3)") rate_err(0), rate_err(1), rate_err(2) ! N.B. Suppressed printing of "global" errors beginning with version 2.2 of 2008.01.28, ! because move to replace misleading "Faults" errors with new "Potency" errors calls into ! serious question how a "global" error should be defined or measured. END IF ELSE rate_err = 0. ! all 3 values END IF IF (verbose) THEN PRINT "(' ================================================================')" WRITE (21,"('================================================================')") END IF END SUBROUTINE Prediction SUBROUTINE Prevent (bad_thing, line, filename) INTEGER, INTENT(IN) :: line CHARACTER(*), INTENT(IN) :: bad_thing, filename PRINT "(' 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 Pause() CALL Bad_Parameters() STOP END SUBROUTINE Prevent SUBROUTINE Prompt_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, ios, 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 Prompt_for_Logical SUBROUTINE Prompt_for_Real (prompt_text, default, answer) ! Writes a line to the default (*) unit, with: ! "prompt_text" ["default"]: ! and accepts an answer with a real 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 52 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 REAL, INTENT(IN) :: default REAL, INTENT(OUT) :: answer CHARACTER*11 :: instring, suggested INTEGER :: blank_at, bytes, ios, point, written LOGICAL :: finished REAL :: trial !------------------------------------------------------------------------------------ !This code worked (provided 4 significant digits), but left unecessary trailing zeros ("20.00"; "6.000E+07") !IF (((ABS(default) >= 0.1).AND.(ABS(default) < 1000.)).OR.(default == 0.0)) THEN ! ! Provide 4 significant digits by using Gxx.4 (the suffix shows significant digits, NOT digits after the decimal point!) ! WRITE (suggested,"(G11.4)") default !ELSE ! ! Use 1P,E because it avoids wasted and irritating leading 0 ("0.123E+4"). ! WRITE (suggested,"(1P,E11.3)") default !END IF !------------------------------------------------------------------------------------ !So I replaced it with the following: !(1) Use ASCII10 to get 4 significant digits (but no unecessary trailing zeroes): suggested = ASCII10(default) !(2) Be sure that the number contains some sign that it is floating-point, not integer: IF (INDEX(suggested, '.') == 0) THEN IF ((INDEX(suggested, 'E') == 0).AND.(INDEX(suggested, 'e') == 0).AND. & & (INDEX(suggested, 'D') == 0).AND.(INDEX(suggested, 'd') == 0)) THEN suggested = ADJUSTL(suggested) point = LEN_TRIM(suggested) + 1 suggested(point:point) = '.' END IF END IF !------------------------------------------------------------------------------------ suggested = ADJUSTL(suggested) bytes = LEN_TRIM(prompt_text) finished = .FALSE. DO WHILE (.NOT. finished) written = 0 DO WHILE ((bytes - written) > 52) blank_at = written + INDEX(prompt_text((written+1):(written+52)),' ',.TRUE.) ! searching L from end for ' ' IF (blank_at < (written + 2)) blank_at = written + 52 WRITE (*,"(' ',A)") prompt_text((written+1):blank_at) written = blank_at END DO WRITE (*,"(' ',A,' [',A']: '\)") prompt_text((written+1):bytes), TRIM(suggested) finished = .TRUE. ! unless changed below READ (*,"(A)") instring IF (LEN_TRIM(instring) == 0) THEN answer = default ELSE !The following lead to occoasional abends !under Digital Visual Fortran 5.0D !(memory violations caught by WinNT): !READ (instring, *, IOSTAT = ios) trial !The following fix leads to a compiler error: !BACKSPACE (*) !READ (*, *, IOSTAT = ios) trial !and the following fix lead to an immediate abend: !BACKSPACE (5) !READ (*, *, IOSTAT = ios) trial !So, I am creating and then reading a dummy file: OPEN (UNIT = 72, FILE = 'trash') WRITE (72, "(A)") instring CLOSE (72) OPEN (UNIT = 72, FILE = 'trash') READ (72, *, IOSTAT = ios) trial CLOSE (72, STATUS = 'DELETE') IF (ios /= 0) THEN ! bad string WRITE (*,"(' ERROR: Your response (',A,') was not recognized.')") TRIM(instring) WRITE (*,"(' Enter an real number using 11 characters (or less).')") WRITE (*,"(' Please try again:')") finished = .FALSE. ELSE answer = trial END IF ! problem with string, or not? END IF ! some bytes were entered END DO ! until finished END SUBROUTINE Prompt_for_Real SUBROUTINE Prompt_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 Prompt_for_String SUBROUTINE Pull_in(s) ! If necessary, adjusts internal coordinates s(1..3) so ! that none is negative. REAL, DIMENSION(3), INTENT(INOUT) :: s INTEGER, DIMENSION(1) :: array ! stupid, to satisfy MINLOC REAL factor, lowest, highest, medium INTEGER :: side, sidea, sideb lowest = MINVAL(s) IF (lowest < 0.) THEN highest = MAXVAL(s) medium = 1.00 - lowest - highest IF (medium > 0.) THEN ! correct to nearest edge array = MINLOC(s) side = array(1) s(side) = 0. sidea = 1 + MOD(side, 3) sideb = 1 + MOD(sidea, 3) factor = 1.00 / (1.00 - lowest) s(sidea) = factor * s(sidea) ! s(sideb) = factor * s(sideb) would be logical s(sideb) = 1.00 - s(sidea) ! is safer ELSE ! correct to nearest vertex array = MAXLOC(s) side = array(1) s(side) = 1.00 sidea = 1 + MOD(side, 3) sideb = 1 + MOD(sidea, 3) s(sidea) = 0. s(sideb) = 0. END IF END IF END SUBROUTINE Pull_in SUBROUTINE Interpolate_Sigma_1H_by_method1(mode, stress_count, data_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). !"Mode" (=1 or 2) selects from: ! 1: the simple "independent data method of ! 2: the more complex "clustered-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. (It is global to make it persistent.) ! The type "needle" is a global type defined in the main program. IMPLICIT NONE INTEGER, INTENT(IN) :: mode, & ! =1 for independent data; =2 for clustered data & stress_count ! count of data TYPE(needle),DIMENSION(:),INTENT(IN):: data_needles ! data table REAL, DIMENSION(3),INTENT(IN) :: x_ ! Cartesian unit vector ! from center of Earth ! to interpolation point REAL, INTENT(OUT) :: azimuth, del_az_for_90pc ! see text above INTEGER :: cluster_count, i, j, k, last_annulus, local_count, m, n, nn INTEGER, DIMENSION(:), ALLOCATABLE :: cluster_affinity, first_datum, n_in_cluster LOGICAL :: captured, neighbor REAL :: azimuth_a_, azimuth_b_, beta_, beta_kernel, & & cluster_azimuth, cluster_del_az_for_90pc, & & current_standard, epsy, gamma_a_, gamma_b_, & & initial_standard, test, theta_a_b_, theta_x_b_ REAL, DIMENSION(3) :: a_, b_, center_uvec, tvec TYPE(needle),DIMENSION(:),ALLOCATABLE :: cluster_needles, local_needles ! 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. IF (.NOT.ALLOCATED( ln_rel_prob )) THEN ALLOCATE ( ln_rel_prob(21, 0:29) ) ! Note: declared in main program as REAL, DIM(:,:), ALLOCATABLE :: ln_rel_prob ! In the parallel routine for method2, this array will have different ! limiting dimensions, and also different values. ln_rel_prob( 1,0:29) = & (/+0.790,+0.682,+0.639,+0.606,+0.553,+0.478,+0.449,+0.349,+0.318,+0.216,+0.179,+0.086,-0.006,-0.063,-0.192,& -0.261,-0.320,-0.401,-0.440,-0.546,-0.607,-0.644,-0.725,-0.727,-0.791,-0.791,-0.790,-0.781,-0.869,-0.843/) ln_rel_prob( 2,0:29) = & (/+0.522,+0.474,+0.449,+0.440,+0.378,+0.351,+0.317,+0.262,+0.252,+0.171,+0.110,+0.091,+0.015,-0.018,-0.088,& -0.134,-0.185,-0.244,-0.280,-0.309,-0.379,-0.408,-0.442,-0.394,-0.465,-0.447,-0.450,-0.456,-0.475,-0.462/) ln_rel_prob( 3,0:29) = & (/+0.416,+0.409,+0.379,+0.360,+0.357,+0.291,+0.276,+0.225,+0.191,+0.149,+0.123,+0.077,+0.021,-0.022,-0.045,& -0.109,-0.145,-0.180,-0.214,-0.256,-0.262,-0.295,-0.311,-0.331,-0.379,-0.381,-0.378,-0.387,-0.379,-0.433/) ln_rel_prob( 4,0:29) = & (/+0.361,+0.353,+0.312,+0.318,+0.296,+0.274,+0.256,+0.208,+0.191,+0.150,+0.112,+0.055,+0.031,-0.010,-0.046,& -0.067,-0.144,-0.143,-0.191,-0.262,-0.248,-0.311,-0.284,-0.342,-0.293,-0.270,-0.266,-0.309,-0.302,-0.347/) ln_rel_prob( 5,0:29) = & (/+0.273,+0.275,+0.267,+0.246,+0.239,+0.220,+0.210,+0.150,+0.126,+0.104,+0.094,+0.062,+0.051,-0.003,-0.028,& -0.054,-0.081,-0.109,-0.130,-0.158,-0.189,-0.217,-0.214,-0.263,-0.233,-0.225,-0.239,-0.254,-0.253,-0.210/) ln_rel_prob( 6,0:29) = & (/+0.343,+0.332,+0.346,+0.305,+0.270,+0.241,+0.213,+0.182,+0.186,+0.143,+0.117,+0.080,+0.038,+0.031,-0.025,& -0.056,-0.092,-0.127,-0.143,-0.200,-0.219,-0.289,-0.243,-0.303,-0.294,-0.315,-0.332,-0.343,-0.359,-0.358/) ln_rel_prob( 7,0:29) = & (/+0.327,+0.387,+0.314,+0.279,+0.294,+0.240,+0.236,+0.193,+0.173,+0.133,+0.103,+0.084,+0.060,+0.018,-0.047,& -0.075,-0.113,-0.123,-0.160,-0.223,-0.241,-0.295,-0.280,-0.289,-0.252,-0.313,-0.291,-0.341,-0.333,-0.329/) ln_rel_prob( 8,0:29) = & (/+0.290,+0.264,+0.282,+0.259,+0.279,+0.226,+0.203,+0.203,+0.163,+0.125,+0.092,+0.084,+0.062,+0.018,-0.009,& -0.020,-0.076,-0.118,-0.137,-0.143,-0.223,-0.212,-0.246,-0.267,-0.315,-0.276,-0.291,-0.277,-0.296,-0.333/) ln_rel_prob( 9,0:29) = & (/+0.259,+0.254,+0.252,+0.290,+0.223,+0.221,+0.215,+0.195,+0.172,+0.135,+0.098,+0.071,+0.053,-0.004,+0.007,& -0.062,-0.058,-0.078,-0.135,-0.157,-0.160,-0.205,-0.233,-0.259,-0.263,-0.263,-0.281,-0.265,-0.324,-0.323/) ln_rel_prob(10,0:29) = & (/+0.213,+0.208,+0.198,+0.190,+0.192,+0.195,+0.152,+0.158,+0.153,+0.121,+0.105,+0.106,+0.084,+0.048,+0.039,& +0.005,-0.040,-0.057,-0.109,-0.145,-0.158,-0.184,-0.215,-0.228,-0.237,-0.258,-0.230,-0.204,-0.266,-0.289/) ln_rel_prob(11,0:29) = & (/+0.179,+0.139,+0.164,+0.204,+0.183,+0.167,+0.164,+0.158,+0.157,+0.099,+0.071,+0.042,+0.086,+0.031,+0.000,& -0.001,-0.041,-0.069,-0.084,-0.118,-0.144,-0.170,-0.180,-0.192,-0.181,-0.181,-0.194,-0.193,-0.223,-0.201/) ln_rel_prob(12,0:29) = & (/+0.128,+0.192,+0.136,+0.158,+0.159,+0.132,+0.102,+0.118,+0.125,+0.139,+0.109,+0.038,+0.093,+0.033,-0.024,& +0.002,-0.056,-0.067,-0.091,-0.100,-0.178,-0.119,-0.147,-0.146,-0.164,-0.172,-0.156,-0.141,-0.196,-0.158/) ln_rel_prob(13,0:29) = & (/+0.078,+0.114,+0.085,+0.128,+0.090,+0.126,+0.089,+0.079,+0.046,+0.040,+0.037,+0.036,+0.010,-0.033,+0.019,& -0.072,-0.051,-0.071,-0.064,-0.087,-0.071,-0.065,-0.072,-0.077,-0.071,-0.067,-0.040,-0.056,-0.075,-0.085/) ln_rel_prob(14,0:29) = & (/+0.098,+0.069,+0.104,+0.106,+0.117,+0.099,+0.113,+0.130,+0.080,+0.047,+0.080,+0.042,+0.024,+0.021,-0.004,& -0.001,-0.049,-0.068,-0.032,-0.053,-0.060,-0.081,-0.110,-0.096,-0.080,-0.096,-0.115,-0.116,-0.139,-0.146/) ln_rel_prob(15,0:29) = & (/+0.187,+0.133,+0.181,+0.145,+0.138,+0.095,+0.140,+0.128,+0.083,+0.067,+0.085,+0.052,+0.051,+0.038,-0.010,& -0.066,+0.004,-0.021,-0.075,-0.098,-0.105,-0.150,-0.121,-0.106,-0.162,-0.149,-0.158,-0.174,-0.188,-0.160/) ln_rel_prob(16,0:29) = & (/+0.156,+0.172,+0.132,+0.139,+0.155,+0.117,+0.097,+0.087,+0.088,+0.107,+0.057,+0.056,+0.038,+0.026,+0.001,& -0.016,-0.038,-0.079,-0.077,-0.081,-0.105,-0.113,-0.077,-0.145,-0.143,-0.160,-0.157,-0.138,-0.139,-0.150/) ln_rel_prob(17,0:29) = & (/+0.130,+0.136,+0.131,+0.136,+0.107,+0.134,+0.119,+0.109,+0.123,+0.075,+0.027,+0.018,+0.046,+0.041,+0.029,& -0.036,-0.025,-0.028,-0.081,-0.054,-0.091,-0.070,-0.122,-0.113,-0.144,-0.117,-0.190,-0.162,-0.155,-0.145/) ln_rel_prob(18,0:29) = & (/+0.118,+0.097,+0.089,+0.092,+0.074,+0.089,+0.108,+0.122,+0.103,+0.104,+0.030,+0.053,+0.049,+0.055,-0.010,& +0.010,-0.051,-0.048,-0.056,-0.097,-0.077,-0.146,-0.086,-0.107,-0.098,-0.093,-0.107,-0.098,-0.122,-0.117/) ln_rel_prob(19,0:29) = & (/+0.135,+0.067,+0.070,+0.114,+0.110,+0.103,+0.084,+0.040,+0.102,+0.038,+0.011,+0.056,+0.013,+0.003,+0.005,& -0.024,+0.004,-0.059,-0.008,-0.022,-0.080,-0.064,-0.028,-0.144,-0.089,-0.083,-0.125,-0.123,-0.092,-0.108/) ln_rel_prob(20,0:29) = & (/+0.082,+0.047,+0.077,+0.054,+0.066,+0.051,+0.078,+0.049,+0.042,+0.010,+0.055,+0.015,+0.047,+0.049,+0.020,& +0.033,+0.020,-0.008,-0.002,-0.017,-0.044,-0.036,-0.081,-0.050,-0.070,-0.107,-0.091,-0.112,-0.098,-0.139/) ln_rel_prob(21,0:29) = & (/+0.051,+0.076,+0.037,+0.028,+0.037,+0.049,+0.027,+0.043,+0.031,+0.014,+0.022,+0.022,+0.023,+0.001,+0.005,& +0.020,-0.014,-0.001,-0.004,-0.006,-0.038,-0.036,-0.036,-0.067,-0.037,-0.034,-0.028,-0.042,-0.071,-0.096/) END IF IF (stress_count < 1) THEN WRITE (*, "(' ERROR: Positive stress_count required to CALL Interpolate_Sigma_1h')") CALL Pause() STOP END IF IF (mode == 1) THEN ! simple method; data assumed independent !----------------------------------------------------------------------------------------------- epsy = 0.4 last_annulus = 21 CALL Equation_6 (epsy, last_annulus, stress_count, data_needles, x_, azimuth, del_az_for_90pc) !----------------------------------------------------------------------------------------------- ELSE IF (mode == 2) THEN ! pre-cluster data, replacing data_needles with cluster_needles ALLOCATE ( cluster_needles(stress_count) ) ! actual value of cluster_count <= stress_count ALLOCATE ( local_needles(stress_count) ) ! used to interpolate within each cluster ALLOCATE ( cluster_affinity(stress_count) )! subscript refers to datum ALLOCATE ( first_datum(stress_count) ) ! subscript actually refers to cluster ALLOCATE ( n_in_cluster(stress_count) ) ! subscript actually refers to cluster !define all the clusters, but don't average yet: cluster_count = 0 ! initialize, before sum n_in_cluster = 0 ! initialize whole vector cluster_affinity = 0 ! initialize whole vector first_datum = 0 ! initialize whole vector DO k = 1, stress_count b_ = data_needles(k)%location theta_x_b_ = Arc_distance(x_, b_) !Note: In matrix ln_rel_prob(n,j), n (1:21) is the annulus number (which depends on the range theta_), ! and j (0:29) is the sector number (which depends on the discrepancy beta_). ! Each entry of the this matrix is the natural-log of the relative probability for that bin. n = 1.00001 + 150. * (0.5 - 0.5 * COS(theta_x_b_))**0.6 neighbor = (n <= 21) IF (neighbor) THEN ! assign stress datum k to to a new, or existing, cluster: initial_standard = ln_rel_prob(n, 0) IF (cluster_count == 0) THEN ! this will be true the first time through cluster_count = 1 n_in_cluster(1) = 1 cluster_affinity(k) = 1 first_datum(1) = k ELSE ! other clusters already exist; compare with these to see if datum k is "captured" i = 0 ! initializing; will be changed to ID of most-related cluster, if any current_standard = initial_standard ! initializing; may rise as clusters are found closeby DO m = 1, cluster_count a_ = data_needles(first_datum(m))%location ! location uvec of cluster m theta_a_b_ = Arc_distance(a_, b_) ! remember, b_ gives location of stress datum k IF (theta_a_b_ < theta_x_b_) THEN ! this minimal pre-qualification is not logically necessary, ! but it saves a bit of execution time, by preventing the ! computation of beta_ when it is not needed. IF (theta_a_b_ > 0.0) THEN ! normal case nn = 1.00001 + 150. * (0.5 - 0.5 * COS(theta_a_b_))**0.6 ELSE ! coincident points nn = 1 END IF IF (nn <= 21) THEN ! close enough to consider; now check discrepancy azimuth_a_ = data_needles(first_datum(m))%azimuth azimuth_b_ = data_needles(k)%azimuth IF (theta_a_b_ > 0.0) THEN ! normal case gamma_a_ = Get_azimuth(a_, b_) gamma_b_ = Get_azimuth(b_, a_) - 3.141593 beta_kernel = azimuth_a_ - azimuth_b_ - gamma_a_ + gamma_b_ ELSE ! coincident points; no correction for coordinate rotation is needed gamma_a_ = 0.0 ! (just in case these get written out by the error message below) gamma_b_ = 0.0 beta_kernel = azimuth_a_ - azimuth_b_ END IF !apply sawtooth function so that beta_ is between 0 and Pi/2: beta_ = MIN( ABS(beta_kernel), & & ABS(beta_kernel + 3.14159), & & ABS(beta_kernel - 3.14159), & & ABS(beta_kernel + 6.28319), & & ABS(beta_kernel - 6.28319), & & ABS(beta_kernel + 9.42478), & & ABS(beta_kernel - 9.42478), & & ABS(beta_kernel + 12.56637), & & ABS(beta_kernel - 12.56637), & & ABS(beta_kernel + 15.70796), & & ABS(beta_kernel - 15.70796), & & ABS(beta_kernel + 18.84956), & & ABS(beta_kernel - 18.84956) ) IF ((beta_ < 0.0).OR.(beta_ > 1.59)) THEN WRITE (*, "(' ERROR: Unreasonable number of windings in beta_kernel:', & & F12.3,' = ',F12.3,' - (',F12.3,') - (',F12.3,') + ',F12.3)") & & beta_kernel, azimuth_a_, azimuth_b_, gamma_a_, gamma_b_ WRITE (*, "(' a_ = ',3ES12.4)") a_(1), a_(2), a_(3) WRITE (*, "(' b_ = ',3ES12.4)") b_(1), b_(2), b_(3) WRITE (*, "(' current datum index = ',I8)") k WRITE (*, "(' Check that input azimuths are in range -360 to +360.')") CALL Pause() CALL TraceBack() STOP END IF j = INT(beta_ / 0.05236) ! divide by the 3-degree bin width j = MIN(MAX(j, 0), 29) ! just for insurance! test = ln_rel_prob(nn, j) IF (test > current_standard) THEN ! A New Winner! Replace current standard current_standard = test i = m ! remember the number of the closest cluster END IF END IF ! nn <= 21 END IF ! theta_a_b_ < theta_x_b_ END DO ! m = 1, cluster_count captured = (i > 0) IF (captured) THEN ! capturing cluster is number i; stress datum is number k n_in_cluster(i) = n_in_cluster(i) + 1 cluster_affinity(k) = i ELSE ! .NOT.captured; form an additional cluster cluster_count = cluster_count + 1 n_in_cluster(cluster_count) = 1 cluster_affinity(k) = cluster_count first_datum(cluster_count) = k END IF ! captured, or not END IF ! first, or latter neighbor of stress datum k? END IF ! neighbor END DO ! k = 1, stress_count !interpolate, within each cluster, to its center point: DO i = 1, cluster_count local_count = n_in_cluster(i) IF (local_count > 1) THEN ! build array local_needles: j = 0 ! initializing before incrementing; range will be 1:local_count tvec = 0.0 ! initializing, before sum to find central point DO k = 1, stress_count IF (cluster_affinity(k) == i) THEN ! found another datum belonging to this cluster j = j + 1 local_needles(j) = data_needles(k) ! copies all attributes tvec(1:3) = tvec(1:3) + data_needles(k)%location(1:3) END IF ! found another datum belonging to this cluster CALL Unitise(tvec, center_uvec) END DO ! k = 1, stress_count !----------------------------------------------------------------------------------------------------------------------- epsy = 0.4 last_annulus = 21 CALL Equation_6 (epsy, last_annulus, local_count, local_needles, center_uvec, cluster_azimuth, cluster_del_az_for_90pc) !------------------------------------------------------------------------------------------------------------------------ cluster_needles(i)%location(1:3) = center_uvec(1:3) cluster_needles(i)%azimuth = cluster_azimuth cluster_needles(i)%sigma = cluster_del_az_for_90pc * 0.6079 ! (assumes Gaussian shape!) ELSE ! local_count == 1; simply copy the datum cluster_needles(i) = data_needles(first_datum(i)) ! all attributes copied END IF END DO ! i = 1, cluster_count !final interpolation, to requested point x_, from the centers of the clusters: !-------------------------------------------------------------------------------------------------- epsy = 0.4 last_annulus = 21 CALL Equation_6 (epsy, last_annulus, cluster_count, cluster_needles, x_, azimuth, del_az_for_90pc) !-------------------------------------------------------------------------------------------------- DEALLOCATE ( first_datum ) DEALLOCATE ( cluster_affinity ) DEALLOCATE ( local_needles ) DEALLOCATE ( cluster_needles ) ELSE ! reject illegal mode WRITE (*, "(' ERROR: Illegal value of mode (',I3,') in CALL Interpolate_Sigma_1H_by_method1')") mode CALL Pause() STOP END IF END SUBROUTINE Interpolate_Sigma_1H_by_method1 SUBROUTINE Interpolate_Sigma_1H_by_method2(stress_count, data_needles, x_, azimuth_assigned, 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). ! ! New probabilities calculated by Carafa and Barba (2013), using World Stress Map 2008 (Heidbach et al., 2008) ! and a slightly annulus definition (to better weight data records in proximity of the interpoation point) ! There is only one main difference respect to Bird & Li (1996) interpolation scheme; ! to each interpolation point it is assigned its SHmax azimuth only if 3 conditions are met: ! (1) at least "cluster_number" clusters ! (2) in annulus "last_annulus" (maximum permissible annulus = 8) ! (3) with uncertainty lower than "sigma_max" ! ! The information about the present global stress field is ! in global array ln_rel_prob. (It is global to make it persistent.) ! The type "needle" is a global type defined in the main program. IMPLICIT NONE INTEGER, INTENT(IN) :: stress_count ! count of data TYPE(needle),DIMENSION(:),INTENT(IN):: data_needles ! data table REAL, DIMENSION(3),INTENT(IN) :: x_ ! Cartesian unit vector ! from center of Earth ! to interpolation point REAL, INTENT(OUT) :: azimuth, del_az_for_90pc ! see text above LOGICAL, INTENT(OUT) :: azimuth_assigned INTEGER :: cluster_count, cluster_number, i, j, k, last_annulus, local_count, m, n, nn INTEGER, DIMENSION(:), ALLOCATABLE :: cluster_affinity, first_datum, n_in_cluster LOGICAL :: captured, neighbor REAL :: azimuth_a_, azimuth_b_, beta_, beta_kernel, & & cluster_azimuth, cluster_del_az_for_90pc, & & current_standard, epsy, gamma_a_, gamma_b_, & & initial_standard, sigma_max, sigma_max_radians, test, theta_a_b_, theta_x_b_ REAL, DIMENSION(3) :: a_, b_, center_uvec, tvec TYPE(needle),DIMENSION(:),ALLOCATABLE :: cluster_needles, local_needles ! Initialize array of relative probabilities of angular discrepancies, ! as a function of angular (arc) distance between stress indicators. ! (Carafa & Barba, 2013, GJI, 193, 531548) ! We formed 8 annuli, using epsilon = 0.6 and 150 bins for the whole 180-degree range.. ! We used 30 3-degree sectors for beta, covering 0-90 degrees. IF (.NOT.ALLOCATED( ln_rel_prob )) THEN ALLOCATE ( ln_rel_prob(10, 0:29) ) ! Note: declared in main program as REAL, DIM(:,:), ALLOCATABLE :: ln_rel_prob ! In the parallel routine for method2, this array will have different ! limiting dimensions, and also different values. ln_rel_prob( 1,0:29) = & (/+1.7508147, +1.5216459, +1.2941595, +1.0687672, +0.8459710, +0.6263760, +0.4107032, +0.1997981, -0.0053672, -0.2037013,& & -0.3940162, -0.5750672, -0.7456130, -0.9044930, -1.0507162, -1.1835490, -1.3025870, -1.4077982, -1.4995258, -1.5784520,& & -1.6455302, -1.7018987, -1.7487911, -1.7874561, -1.8190948, -1.8448169, -1.8656155, -1.8823579, -1.8957853, -1.9065220/) ln_rel_prob( 2,0:29) = & (/+1.4382497, +1.2684475, +1.1003512, +0.9346460, +0.7717189, +0.6120013, +0.4559679, +0.3041324, +0.1570404, +0.0152572, & & -0.1206469, -0.2501165, -0.3726337, -0.4877423, -0.5950722, -0.6943600, -0.7854660, -0.8683825, -0.9432342, -1.0102708, & & -1.0698511, -1.1224225, -1.1684971, -1.2086270, -1.2433820, -1.2733288, -1.2990159, -1.3209612, -1.3396441, -1.3555013/) ln_rel_prob( 3,0:29) = & (/+1.2161373, +1.0680269, +0.9232758, +0.7824377, +0.6459727, +0.5143527, +0.3880486, +0.2675155, +0.1531755, +0.0454001, & & -0.0555074, -0.1493276, -0.2359366, -0.3153130, -0.3875391, -0.4527963, -0.5113553, -0.5635615, -0.6098184, -0.6505698, & & -0.6862819, -0.7174280, -0.7444742, -0.7678694, -0.7880370, -0.8053694, -0.8202259, -0.8329306, -0.8437734, -0.8530111/) ln_rel_prob( 4,0:29) = & (/+1.0326832, +0.9126169, +0.7961339, +0.6831131, +0.5738463, +0.4686197, +0.3677060, +0.2713571, +0.1797956, +0.0932074, & & +0.0117343, -0.0645309, -0.1355489, -0.2013348, -0.2619582, -0.3175396, -0.3682461, -0.4142851, -0.4558964, -0.4933446, & & -0.5269107, -0.5568850, -0.5835596, -0.6072230, -0.6281549, -0.6466226, -0.6628780, -0.6771562, -0.6896743, -0.7006312/) ln_rel_prob( 5,0:29) = & (/+0.9155696, +0.8185354, +0.7235157, +0.6309173, +0.5408715, +0.4535380, +0.3690711, +0.2876164, +0.2093079, +0.1342652, & & +0.0625902, -0.0056353, -0.0703518, -0.1315233, -0.1891393, -0.2432141, -0.2937868, -0.3409203, -0.3846996, -0.4252291, & & -0.4626307, -0.4970401, -0.5286046, -0.5574793, -0.5838245, -0.6078030, -0.6295776, -0.6493090, -0.6671536, -0.6832628/) ln_rel_prob( 6,0:29) = & (/+0.8532883, +0.7665789, +0.6825276, +0.5997206, +0.5191254, +0.4406706, +0.3644669, +0.2906200, +0.2192291, +0.1503847, & & +0.0841678, +0.0206472, -0.0401210, -0.0980951, -0.1532483, -0.2055700, -0.2550651, -0.3017547, -0.3456752, -0.3868775, & & -0.4254263, -0.4613981, -0.4948803, -0.5259692, -0.5547682, -0.5813866, -0.6059371, -0.6285350, -0.6492961, -0.6683359/) ln_rel_prob( 7,0:29) = & (/+0.7500998, +0.6778854, +0.6079135, +0.5388822, +0.4714622, +0.4056547, +0.3415267, +0.2791422, +0.2185614, +0.1598398, & & +0.1030274, +0.0481682, -0.0047005, -0.0555489, -0.1043550, -0.1511049, -0.1957930, -0.2384224, -0.2790045, -0.3175590, & & -0.3541134, -0.3887029, -0.4213695, -0.4521616, -0.4811331, -0.5083430, -0.5338541, -0.5577327, -0.5800475, -0.6008690/) ln_rel_prob( 8,0:29) = & (/+0.6862579, +0.6218856, +0.5578198, +0.4957286, +0.4349476, +0.3756914, +0.3180113, +0.2619550, +0.2075666, +0.1548852, & & +0.1039453, +0.0547756, +0.0073993, -0.0381670, -0.0819130, -0.1238348, -0.1639353, -0.2022241, -0.2387171, -0.2734366, & & -0.3064105, -0.3376727, -0.3672617, -0.3952210, -0.4215979, -0.4464432, -0.4698107, -0.4917564, -0.5123382, -0.5316150/) ln_rel_prob( 9,0:29) = & (/+0.6284929, +0.5712857, +0.5161928, +0.4608351, +0.4073416, +0.3548957, +0.3036719, +0.2537035, +0.2050218, +0.1576552, & & +0.1116295, +0.0669670, +0.0236869, -0.0181954, -0.0586682, -0.0977236, -0.1353578, -0.1715711, -0.2063676, -0.2397556, & & -0.2717473, -0.3023584, -0.3316084, -0.3595202, -0.3861196, -0.4114355, -0.4354993, -0.4583447, -0.4800074, -0.5005246/) ln_rel_prob( 10,0:29) = & (/+0.6035620, +0.5474248, +0.4925796, +0.4394362, +0.3877209, +0.3370642, +0.2877665, +0.2398570, +0.1933620, +0.1483039, & & +0.1047014, +0.0625692, +0.0219178, -0.0172467, -0.0549226, -0.0911127, -0.1258240, -0.1590678, -0.1908599, -0.2212199, & & -0.2501709, -0.2777400, -0.3039572, -0.3288556, -0.3524707, -0.3748404, -0.3960044, -0.4160040, -0.4348816, -0.4526805/) END IF IF (stress_count < 1) THEN WRITE (*, "(' ERROR: Positive stress_count required to CALL Interpolate_Sigma_1h')") CALL Pause() STOP END IF !define strategic parameters epsy=0.6 cluster_number=3 sigma_max= 45. ! degrees sigma_max_radians = sigma_max * radians_per_degree ALLOCATE ( cluster_needles(stress_count) ) ! actual value of cluster_count <= stress_count ALLOCATE ( local_needles(stress_count) ) ! used to interpolate within each cluster ALLOCATE ( cluster_affinity(stress_count) )! subscript refers to datum ALLOCATE ( first_datum(stress_count) ) ! subscript actually refers to cluster ALLOCATE ( n_in_cluster(stress_count) ) ! subscript actually refers to cluster !define all the clusters, but don't average yet: cluster_count = 0 ! initialize, before sum n_in_cluster = 0 ! initialize whole vector cluster_affinity = 0 ! initialize whole vector first_datum = 0 ! initialize whole vector DO last_annulus = 1, 8 DO k = 1, stress_count b_ = data_needles(k)%location theta_x_b_ = Arc_distance(x_, b_) n = 1.00001 + 150. * (0.5 - 0.5 * COS(theta_x_b_))**(1.0 - epsy) neighbor = (n <= last_annulus) IF (neighbor) THEN ! assign stress datum k to to a new, or existing, cluster: initial_standard = ln_rel_prob(n, 0) IF (cluster_count == 0) THEN ! this will be true the first time through cluster_count = 1 n_in_cluster(1) = 1 cluster_affinity(k) = 1 first_datum(1) = k ELSE ! other clusters already exist; compare with these to see if datum k is "captured" i = 0 ! initializing; will be changed to ID of most-related cluster, if any current_standard = initial_standard ! initializing; may rise as clusters are found closeby DO m = 1, cluster_count a_ = data_needles(first_datum(m))%location ! location uvec of cluster m theta_a_b_ = Arc_distance(a_, b_) ! remember, b_ gives location of stress datum k IF (theta_a_b_ < theta_x_b_) THEN ! this minimal pre-qualification is not logically necessary, ! but it saves a bit of execution time, by preventing the ! computation of beta_ when it is not needed. IF (theta_a_b_ > 0.0) THEN ! normal case nn = 1.00001 + 150. * (0.5 - 0.5 * COS(theta_a_b_))**(1.0 - epsy) ELSE ! coincident points nn = 1 END IF IF (nn <= last_annulus) THEN ! close enough to consider; now check discrepancy azimuth_a_ = data_needles(first_datum(m))%azimuth azimuth_b_ = data_needles(k)%azimuth IF (theta_a_b_ > 0.0) THEN ! normal case gamma_a_ = Get_azimuth(a_, b_) gamma_b_ = Get_azimuth(b_, a_) - 3.141593 beta_kernel = azimuth_a_ - azimuth_b_ - gamma_a_ + gamma_b_ ELSE ! coincident points; no correction for coordinate rotation is needed gamma_a_ = 0.0 ! (just in case these get written out by the error message below) gamma_b_ = 0.0 beta_kernel = azimuth_a_ - azimuth_b_ END IF !apply sawtooth function so that beta_ is between 0 and Pi/2: beta_ = MIN( ABS(beta_kernel), & & ABS(beta_kernel + 3.14159), & & ABS(beta_kernel - 3.14159), & & ABS(beta_kernel + 6.28319), & & ABS(beta_kernel - 6.28319), & & ABS(beta_kernel + 9.42478), & & ABS(beta_kernel - 9.42478), & & ABS(beta_kernel + 12.56637), & & ABS(beta_kernel - 12.56637), & & ABS(beta_kernel + 15.70796), & & ABS(beta_kernel - 15.70796), & & ABS(beta_kernel + 18.84956), & & ABS(beta_kernel - 18.84956) ) IF ((beta_ < 0.0).OR.(beta_ > 1.59)) THEN WRITE (*, "(' ERROR: Unreasonable number of windings in beta_kernel:', & & F12.3,' = ',F12.3,' - (',F12.3,') - (',F12.3,') + ',F12.3)") & & beta_kernel, azimuth_a_, azimuth_b_, gamma_a_, gamma_b_ WRITE (*, "(' a_ = ',3ES12.4)") a_(1), a_(2), a_(3) WRITE (*, "(' b_ = ',3ES12.4)") b_(1), b_(2), b_(3) WRITE (*, "(' current datum index = ',I8)") k WRITE (*, "(' Check that input azimuths are in range -360 to +360.')") CALL Pause() CALL TraceBack() STOP END IF j = INT(beta_ / 0.05236) ! divide by the 3-degree bin width j = MIN(MAX(j, 0), 29) ! just for insurance! test = ln_rel_prob(nn, j) IF (test > current_standard) THEN ! A New Winner! Replace current standard current_standard = test i = m ! remember the number of the closest cluster END IF END IF ! nn <= last_annulus END IF ! theta_a_b_ < theta_x_b_ END DO ! m = 1, cluster_count captured = (i > 0) IF (captured) THEN ! capturing cluster is number i; stress datum is number k n_in_cluster(i) = n_in_cluster(i) + 1 cluster_affinity(k) = i ELSE ! .NOT.captured; form an additional cluster cluster_count = cluster_count + 1 n_in_cluster(cluster_count) = 1 cluster_affinity(k) = cluster_count first_datum(cluster_count) = k END IF ! captured, or not END IF ! first, or latter neighbor of stress datum k? END IF ! neighbor END DO ! k = 1, stress_count ! if the cluster number is .lower. than parameter cluster_number set at the begin ! of the subroutine, then no other calculation is needed and you need to test ! the following annulus IF (cluster_count < cluster_number) CYCLE !interpolate, within each cluster, to its center point: DO i = 1, cluster_count local_count = n_in_cluster(i) IF (local_count > 1) THEN ! build array local_needles: j = 0 ! initializing before incrementing; range will be 1:local_count tvec = 0.0 ! initializing, before sum to find central point DO k = 1, stress_count IF (cluster_affinity(k) == i) THEN ! found another datum belonging to this cluster j = j + 1 local_needles(j) = data_needles(k) ! copies all attributes tvec(1:3) = tvec(1:3) + data_needles(k)%location(1:3) END IF ! found another datum belonging to this cluster CALL Unitise(tvec, center_uvec) END DO ! k = 1, stress_count !----------------------------------------------------------------------------------------------------------------------- CALL Equation_6 (epsy, last_annulus, local_count, local_needles, center_uvec, cluster_azimuth, cluster_del_az_for_90pc) !----------------------------------------------------------------------------------------------------------------------- cluster_needles(i)%location(1:3) = center_uvec(1:3) cluster_needles(i)%azimuth = cluster_azimuth cluster_needles(i)%sigma = cluster_del_az_for_90pc * 0.6079 ! (assumes Gaussian shape!) ELSE ! local_count == 1; simply copy the datum cluster_needles(i) = data_needles(first_datum(i)) ! all attributes copied END IF END DO ! i = 1, cluster_count !final interpolation, to requested point x_, from the centers of the clusters: !------------------------------------------------------------------------------ CALL Equation_6 (epsy, last_annulus, cluster_count, cluster_needles, x_, azimuth, del_az_for_90pc) !------------------------------------------------------------------------------ IF (del_az_for_90pc <= sigma_max_radians) THEN azimuth_assigned = .TRUE. RETURN ELSE azimuth_assigned = .FALSE. END IF !The algorithm will try again, adding one more annulus. END DO ! done with annulus last_annulus !Attempt using all available annuli did not succeed. azimuth_assigned = .FALSE. DEALLOCATE ( first_datum ) DEALLOCATE ( cluster_affinity ) DEALLOCATE ( local_needles ) DEALLOCATE ( cluster_needles ) END SUBROUTINE Interpolate_Sigma_1H_by_method2 SUBROUTINE Equation_6 (epsy, last_annulus, 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. (It is global to make it persistent.) ! The type "needle" is a global type defined in the main program. IMPLICIT NONE REAL, INTENT(IN) :: epsy ! 0.4 for method1; 0.6 for method2 INTEGER, INTENT(IN) :: last_annulus ! 21 for method1; variable in method2 INTEGER, INTENT(IN) :: stress_count ! count of data TYPE(needle),DIMENSION(:),INTENT(IN):: needles ! stress data table REAL, DIMENSION(3),INTENT(IN) :: x_ ! Cartesian unit vector ! from center of Earth ! to interpolation point REAL, INTENT(OUT) :: azimuth, del_az_for_90pc ! see text above INTEGER :: j, jl, jlo, jr, jro, left, n, neighbors, right INTEGER, DIMENSION(1) :: peak REAL, DIMENSION(3) :: a_ REAL :: fraction, gamma_a_, gamma_x_, oldsum, prediction, theta_ DOUBLE PRECISION :: sum DOUBLE PRECISION, DIMENSION(0:59) :: probability probability = 0.0D0 ! initialize array, before adding terms in extended sum !count available neighbors (within correlation horizon) and sum their contributions to ln(probability). neighbors = 0 DO i = 1, stress_count a_ = needles(i)%location theta_ = Arc_distance(x_, a_) IF (theta_ > 0.0) THEN n = 1.00001 + 150. * (0.5 - 0.5 * COS(theta_))**(1.0 - epsy) ELSE n = 1 END IF IF (n <= last_annulus) THEN neighbors = neighbors + 1 IF (theta_ > 0.0) THEN ! normal case gamma_x_ = Get_azimuth(x_, a_) gamma_a_ = Get_azimuth(a_, x_) + 3.141593 prediction = MOD((needles(i)%azimuth - gamma_a_ + gamma_x_ + 18.84955), 3.141593) ELSE ! special case of coincident points; no Delta_gamma_ correction needed: gamma_x_ = 0.0 gamma_a_ = 0.0 prediction = MOD((needles(i)%azimuth + 18.84955), 3.141593) END IF left = 19.0985 * prediction + 0.5 left = MOD(left,60) right = MOD(left + 1, 60) 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 END IF ! inside correlation horizon END DO ! i = 1, stress_count !convert "probability" vector from natural-log to real, normalize, and analyze IF (neighbors > 0) THEN sum = 0.0D0 DO j = 0, 59 probability(j) = DEXP(probability(j)) sum = sum + probability(j) END DO probability = probability / sum ! normalize array peak = MAXLOC(probability) - 1 ! to compensate for (0:59), not (60)! azimuth = (peak(1) + 0.5) * 0.05236 jlo = peak(1) jro = jlo oldsum = 0. DO j = 1, 29 jl = MOD(peak(1) - j + 60, 60) jr = MOD(peak(1) + j, 60) sum = oldsum + 0.5 *(probability(jl) + probability(jlo) + & & probability(jr) + probability(jro)) IF (sum >= 0.90) THEN fraction = (0.90 - oldsum) / (sum - oldsum) del_az_for_90pc = 0.05236 * (j - 1. + fraction) RETURN ! <============== normal return point from this subprogram END IF oldsum = sum jlo = jl jro = jr END DO ELSE ! no neighbors; no basis for assigning a stress azimuth azimuth = 0.0 ! so that we don't get a random (undefined) REAL in the output. END IF del_az_for_90pc = 1.41372 ! 81 degrees; worst possible result; stress direction unconstrained END SUBROUTINE Equation_6 SUBROUTINE Stress_Interpolation(stress_interpolation_method) !Interpolates most-compressive horizontal principal stress directions (sigma_1H) !from datum locations to element centers (if possible), using user-selected method IMPLICIT NONE INTEGER, INTENT(IN) :: stress_interpolation_method CHARACTER(61) :: bar_graph INTEGER :: i, jold, jtest, l_, leading_text_bytes, mode LOGICAL :: azimuth_assigned REAL :: azimuth, del_az_for_90pc ! results of interpolation, for a single element REAL, DIMENSION(3) :: r_ ! position on surface of Earth, as unit vector from Earth center WRITE (*, "(' Interpolation stress direction sigma_1H from data to element centers')") WRITE (21, "('Interpolation stress direction sigma_1H from data to element centers')") IF (stress_interpolation_method == 1) THEN WRITE (*, "(' using clustered-data method of Bird & Li [1996].')") WRITE (21, "('using clustered-data method of Bird & Li [1996].')") ELSE IF (stress_interpolation_method == 2) THEN WRITE (*, "(' using method of Carafa & Barba [2013].')") WRITE (21, "('using method of Carafa & Barba [2013].')") ELSE WRITE (*, "(' ERROR: INTEGER :: stress_interpolation_method in p_.nki has illegal value.')") CALL Pause() STOP END IF !set up bar-graph display of progress: bar_graph = ' ' ! to avoid printing any undefined bytes leading_text_bytes = 41 ! no more than 41 !!! bar_graph(1:leading_text_bytes) = 'Interpolating stress directions (slow!!) ' DO i = (leading_text_bytes + 1), (leading_text_bytes + 20) bar_graph(i:i) = CHAR(176) END DO PRINT "(' ',A)", bar_graph PRINT "('+',A)", bar_graph(1:leading_text_bytes) jold = 0 ! Interpolate to centers of elements DO l_ = 1, num_ele ! <--- global variable r_ = center(1:3, l_) ! <--- global array IF (stress_interpolation_method == 1) THEN ! Bird & Li [1996]: !---------------------------------------------------------------------------------------------- mode = 2 ! clustered-data variant of Bird & Li [1996] paper CALL Interpolate_Sigma_1H_by_method1(mode, stress_count, needles, r_, azimuth, del_az_for_90pc) !---------------------------------------------------------------------------------------------- ele_azim(l_) = azimuth ! filling 2 global arrays, previously allocated in main program ele_sigma(l_) = del_az_for_90pc * 0.6079 ! (assumes Gaussian shape!) IF (del_az_for_90pc <= 0.7854) THEN ! +- 45 degrees @ 90%-confidence is cutoff ele_stressed(l_) = .TRUE. ELSE ! too uncertain to bother with enforcing it! ele_stressed(l_) = .FALSE. END IF ELSE IF (stress_interpolation_method == 2) THEN ! Carafa & Barba [2013]: !---------------------------------------------------------------------------------------------- CALL Interpolate_Sigma_1H_by_method2(stress_count, needles, r_, azimuth_assigned, azimuth, del_az_for_90pc) !---------------------------------------------------------------------------------------------- ele_stressed(l_) = azimuth_assigned.AND.(del_az_for_90pc <= 0.7854) IF (ele_stressed(l_)) THEN ele_azim(l_) = azimuth ! filling 2 global arrays, previously allocated in main program ele_sigma(l_) = del_az_for_90pc * 0.6079 ! (assumes Gaussian shape!) ELSE ele_azim(l_) = 0.0 ! arbitrary; see below: ele_sigma(l_) = 54.711 * radians_per_degree ! sigma needed (54.711 degrees) to plot a complete-circle (0+-90 degrees) ! for 90%-confidence bounds in NeoKineMap (if plotting such points is demanded) END IF END IF !increment bar-graph display jtest = (20 * l_) / num_ele IF (jtest > jold) THEN bar_graph(jtest+leading_text_bytes:jtest+leading_text_bytes) = CHAR(219) PRINT "('+',A)", bar_graph(1:jtest+leading_text_bytes) jold = jtest END IF END DO ! l_ = 1, num_ele END SUBROUTINE Stress_Interpolation SUBROUTINE Solve_for_vw_with_IMSL (passes, vw) !NOTE: I am forced to have different codes here for the IMSL and MKL versions ! because these packages use different storage schemes for banded matrices, ! and the statement-functions to translate storage locations even ! have different numbers of arguments (see below). ! Also, these 2 versions call distinct flavors of Plug_in_33_for_xxx. INTEGER, INTENT(IN) :: passes DOUBLE PRECISION, DIMENSION(nDOF), INTENT(INOUT) :: vw ! NOTE: vw is used BEFORE it is computed in the first pass ! through the stress section, IF (any_stress), 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, DIMENSION(3,3) :: A, B, C, D DOUBLE PRECISION, DIMENSION(3) :: E, F REAL :: azimuth CHARACTER(61) :: bar_graph INTEGER :: benchmark_i, benchmark_j REAL :: big_diff, big_diff_mmpa INTEGER :: big_diff_node DOUBLE PRECISION :: big_one LOGICAL :: boost_some_weights REAL :: boxed_frac REAL :: cosg, cos2g REAL :: cott, csct DOUBLE PRECISION, DIMENSION(3,2,2,2) :: dG REAL :: del_az_for_90pc ! one-sided, in radians REAL :: del_s_, diff, difference, divisor REAL :: dV_frac REAL :: effective_sigma_perSecond !========================================================= ! IMSL version (see MKL version below): !COMPLEX, DIMENSION(3) :: eigenvalues !COMPLEX, DIMENSION(3,3) :: eigenvectors !========================================================= ! MKL version (see IMSL version above): REAL, DIMENSION(3) :: eigenvalues REAL, DIMENSION(3,3) :: eigenvectors !========================================================= REAL, DIMENSION(3) :: epsilon_dot REAL :: equat REAL :: error REAL :: eta_ REAL :: extra_weight REAL, DIMENSION(6) :: f_, g_ ! sometimes, only 1..3 are used DOUBLE PRECISION :: factor REAL, DIMENSION(3) :: fi, fj REAL :: floor = 2. * TINY(floor) REAL :: fraction DOUBLE PRECISION,DIMENSION(3,2,2) :: G REAL :: gamma_ TYPE(is123), DIMENSION(7) :: Gauss_point REAL, DIMENSION(7) :: Gauss_weight = (/ 0.225, & & 0.13239415, 0.13239415, 0.13239415, & & 0.12593918, 0.12593918, 0.12593918 /) REAL, DIMENSION(3) :: gi, gj DOUBLE PRECISION :: goal INTEGER :: h, h_alt1, h_alt2 REAL :: half_N INTEGER, PARAMETER :: ijob = 4 ! mode setting for LSLPB INTEGER :: i, i_geodetic, i1, i2, i3, ita, ite INTEGER, DIMENSION(3) :: i_node INTEGER, DIMENSION(:), ALLOCATABLE :: ipiv INTEGER :: info INTEGER, DIMENSION(18) :: iwork INTEGER :: j, j_geodetic, jold, jta, jte, jtest INTEGER, DIMENSION(3) :: j_node CHARACTER*1 :: jobz ! needed for ssyevd of MKL INTEGER :: k REAL :: kappa_ INTEGER :: l_, l_i, l_j INTEGER :: ldab, lwork, liwork REAL, DIMENSION(3) :: lambda_ REAL, DIMENSION(3,3) :: Lambda INTEGER :: leading_text_bytes ! adjustable leading label of oft-repeated completion-bar code INTEGER :: loc REAL :: lat, lon INTEGER :: m, method REAL :: mu_of_r_, mu_2 INTEGER :: n ! local copy REAL :: new_V, num_boxed, old_value LOGICAL :: OK_to_stop REAL :: one_over_A0R2 INTEGER :: pass DOUBLE PRECISION :: prefix REAL, DIMENSION(3) :: r_ REAL :: rho_ ! length of a fault segment, in m REAL :: radius INTEGER :: s REAL :: s_ REAL :: s_N0_sum, s_N1_sum, s_N2_sum ! Note: s_error_count is a global, ! so it will persist, and can be used at end of Prediction ! to reconstitute these 3 sums from s_err(0:2). INTEGER :: segment CHARACTER(1) :: sense REAL :: sigma_, sigma_perSecond, sigma_radians REAL, DIMENSION(3) :: sigma_list REAL :: sing, sin2g REAL :: sint INTEGER :: stress_count REAL :: stressed_frac REAL :: sum_base_n, sum_base_o, sum_diff REAL :: t_sigma, tant, theta REAL :: top_value INTEGER :: twoi, u_ CHARACTER*1 :: uplo REAL :: vn, vo, wn, wo REAL, DIMENSION(3,3) :: V DOUBLE PRECISION, DIMENSION(3,3) :: V8 REAL :: W, W_A, W_LL REAL, DIMENSION(37) :: work INTEGER :: Z, z_ INTEGER :: ABCDrow, ABCDcol, EFrow, EFcol ! statement functions !========================================================================= ! IMSL version: !{NOTE: Do NOT comment-this-out (or replace it) when using MKL, or the code below won't compile!} ABCDrow(j) = j + nCoDa ! statement function; nCoDa is global ABCDcol(i, j) = (j - i) + 1 ! statement function EFrow(i) = i + nCoDa ! statement function; nCoDa is global EFcol = nCoDa + 2 ! These statement functions are for ! codiagonal band symmetric storage mode of matrices ABCD and EF, ! per Microsoft version of IMSL. Note that element (row #i, col #j) ! of the idealized square matrix square_ABCD, or ! square_ABCD(i, j) is stored as ABCDEF(ABCDrow(j),ABCDcol(i, j)); ! and that only elements with j >= i (upper right) can be stored. ! Element (row i) of the linear vector EF is stored in ! ABCDEF(EFrow(i), EFcol). !========================================================================= Gauss_point(1)%s(1:3) = (/ 0.33333333, 0.33333333, 0.33333333 /) Gauss_point(2)%s(1:3) = (/ 0.05971587, 0.47014206, 0.47014206 /) Gauss_point(3)%s(1:3) = (/ 0.47014206, 0.05971587, 0.47014206 /) Gauss_point(4)%s(1:3) = (/ 0.47014206, 0.47014206, 0.05971587 /) Gauss_point(5)%s(1:3) = (/ 0.79742698, 0.10128650, 0.10128650 /) Gauss_point(6)%s(1:3) = (/ 0.10128650, 0.79742698, 0.10128650 /) Gauss_point(7)%s(1:3) = (/ 0.10128650, 0.10128650, 0.79742698 /) one_over_A0R2 = 1.0 / (A0 * R**2) !print header for table in report that follows the refinement process: PRINT "(' Solving for velocities:')" WRITE (21,"('Solving for velocities:')") IF (passes > 0) THEN ! selection criterion could be > 1 (0R, > 0 to always print) ! Write headers for convergence report IF (any_stress) THEN PRINT "(' ',4X,' Active Unfaulted& e1h_azim_error')" PRINT "(' ',4X,'Refinement dV/V RMS(V) brackets Stressed Boxed (N1; in sigmas)')" WRITE (21,"(4X,' Active Unfaulted& e1h_azim_error')") WRITE (21,"(4X,'Refinement dV/V RMS(V) brackets Stressed Boxed (N1; in sigmas)')") ELSE PRINT "(' ',4X,' Active ')" PRINT "(' ',4X,'Refinement dV/V RMS(V) brackets')" WRITE (21,"(4X,' Active ')") WRITE (21,"(4X,'Refinement dV/V RMS(V) brackets')") END IF END IF n_brackets_tightened = 0 ! initialized, because on 1st pass we do NOT CALL Prediction many_passes: DO pass = 1, passes boost_some_weights = ((3 * pass) > passes) ! consider local_crack()%extra_weight > 1.0 in latter 2/3 of iterations ! Update slip rates, for both geodetic targets, and strike-slip flexibility on dip-slip faults (if any). IF (pass > 1) THEN ! this is an iterative refinement pass CALL Prediction(vw = vw, verbose = .FALSE., adjust_some_weights = boost_some_weights) ! which returns current model heave-rates of cracks in (new, global) local_crack()%p_, ! and current model offset-rates of faults in f_model_offset_rate(). ! Note that both are in already in SI (m/s), but that conversions between ! heave-rate and offset-rate will be needed. DO i = 1, f_dat_count IF (f_dat_shadow(i)) THEN !NOTE: "factor" in this SUBR is the ABS(ratio of heave-rate to offset-rate) = ~2.7 for Thrust, ~0.7 for Normal, ==1 for R, L, P, S. IF ((f_sense(i) == 'R').OR.(f_sense(i) == 'L')) THEN !adjusting strike-slip flexibility (i) based on a dip-slip datum in (i - 1): IF (f_sense(i - 1) == 'T') THEN factor = 1.0 / TAN(f_dat_dip_degrees(i - 1) * radians_per_degree) ELSE IF (f_sense(i - 1) == 'P') THEN factor = 1. ELSE IF (f_sense(i - 1) == 'S') THEN factor = 1. ELSE IF (f_sense(i - 1) == 'N') THEN factor = 1.0 / TAN(f_dat_dip_degrees(i - 1) * radians_per_degree) ELSE IF (f_sense(i - 1) == 'D') THEN factor = 1. ELSE IF (f_sense(i - 1) == 'R') THEN factor = 1. WRITE (*, "(' ERROR: s-s shadow datum should not follow s-s real datum')") CALL Traceback ELSE IF (f_sense(i - 1) == 'L') THEN factor = 1. WRITE (*, "(' ERROR: s-s shadow datum should not follow s-s real datum')") CALL Traceback ENDIF IF (f_sense(i - 1) == 'S') THEN fraction = MAX(1.0, TAN(sigma_offnormal_degrees / 57.296)) ! ratio of allowed s-s heave rate to orthogonal heave rate ELSE fraction = TAN(sigma_offnormal_degrees / 57.296) ! ratio of allowed s-s heave rate to orthogonal heave rate END IF old_value = f_offset_rate_sigma_(i) !new value, if no damping were applied: f_offset_rate_sigma_(i) = fraction * ABS(f_model_offset_rate(i - 1)) * factor !apply modest damping for safety: f_offset_rate_sigma_(i) = 0.5 * old_value + 0.5 * f_offset_rate_sigma_(i) !do not allow value to vanish (what would happen?) f_offset_rate_sigma_(i) = MAX(f_offset_rate_sigma_(i), small_rate_in_mps) DO j = 1, crack_count IF (local_crack(j)%datum == i) THEN old_value = local_crack(j)%sigma_ !new value, if no damping were applied: local_crack(j)%sigma_ = fraction * ABS(f_model_offset_rate(i - 1)) * factor !apply modest damping for safety: local_crack(j)%sigma_ = 0.5 * old_value + 0.5 * local_crack(j)%sigma_ !do not allow value to vanish (what would happen?) local_crack(j)%sigma_ = MAX(local_crack(j)%sigma_, small_rate_in_mps) END IF ! local_crack(f) refers to this shadow datum END DO ! j = 1, crack_count END IF ! f_sense(i) == (R .OR. L) END IF ! f_dat_shadow(i) END DO ! i = 1, f_dat_count END IF ! pass > 1 !Begin building linear system by zeroing it out entirely: ABCDEF = 0.0D0 ! global coefficient matrix AND forcing vector ! <==== unique to IMSL version 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 (9) of Bird (1997?). E = 0.0D0; F = 0.0D0 ! forcing subvectors for element Z = crack_index(1, l_) IF (Z > 0) THEN ! active faulting! mu_of_r_ = mu_nod(i1) * Gauss_point(1)%s(1) + & & mu_nod(i2) * Gauss_point(1)%s(2) + & & mu_nod(i3) * Gauss_point(1)%s(3) t_sigma = mu_of_r_ mu_2 = t_sigma**2 V8(1,1) = mu_2 * 4./3. ! begin element covariance matrix (symmetric) V8(1,2) = 0.D0 V8(1,3) = mu_2 * (-2./3.) V8(2,1) = 0.D0 V8(2,2) = mu_2 V8(2,3) = 0.D0 V8(3,1) = V8(1,3) V8(3,2) = 0.D0 V8(3,3) = V8(1,1) epsilon_dot = 0. ! 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.) THEN PRINT "(' Error: center of element ',I5,' is N or S pole.')", l_ WRITE (21,"('Error: center of element ',I5,' is N or S pole.')") l_ STOP END IF theta = ATAN2(equat, tv(3)) sint = SIN(theta) csct = 1. / sint tant = TAN(theta) cott = 1. / tant W_LL = 0. ! just initializing, before sums (below) 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) rho_ = R * Arc_distance(tv1, tv2) W_LL = W_LL + rho_ / L0 ! N.B. This variable will not be used until after sum is complete. gamma_ = Get_azimuth (tv1, tv2) sense = local_crack(loc)%sense s_ =local_crack(loc)%s_ del_s_ = local_crack(loc)%sigma_ extra_weight = local_crack(loc)%extra_weight 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.5 * (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 == 'S') .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.5 * (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_vw') 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)/extra_weight) * local_crack(loc)%H(i) * & & local_crack(loc)%H(j) END DO END DO END DO ! z_ = 1, Z ! note that V8 should still be symmetric ! scale V matrix to prevent underflows V(1:3,1:3) = REAL(V8(1:3,1:3) * 1.D30) ! eigen-analysis of V: !========================================================================================================================= ! IMSL version (see MKL version below): !CALL EVCRG (3, V, 3, eigenvalues, eigenvectors, 3) !! Compute all of the eigenvalues and eigenvectors of a real matrix. !! Usage: !! CALL EVCRG (N, A, LDA, EVAL, EVEC, LDEVEC) !! Arguments: !! N = Order of the matrix. (Input) !! A = Floating-point array containing the matrix. (Input) !! LDA = Leading dimension of A exactly as specified in the dimension statement of the calling program. (Input) !! EVAL = Complex array of size N containing the eigenvalues of A in decreasing order of magnitude. (Output) !! EVEC = Complex array containing the matrix of eigenvectors. (Output) !! The #h eigenvector, corresponding to EVAL(h), is stored in the #h column. Each vector is normalized to have !! Euclidean length equal to the value one. !! LDEVEC = Leading dimension of EVEC exactly as specified in the dimension statement of the calling program. (Input) !========================================================================================================================= ! MKL version (see IMSL version above): jobz = 'V' ! required if you want to get eigenvectors back, too uplo = 'U' lwork = 37 ! matching dimension coded above liwork = 18 ! matching dimension coded above CALL ssyevd(jobz, uplo, 3, V, 3, eigenvalues, work, lwork, iwork, liwork, info) ! using Fortran77 call because F95 call is buggy. !Note: On return, each column of V is an eigenvector: DO h = 1, 3 eigenvectors(1:3, h) = V(1:3, h) END DO !========================================================================================================================= top_value = 0. ! just initializing, before search (below) DO h = 1, 3 ! the eigenvectors each define a new scalar datum ! undo the scaling applied previously to V lambda_(h) = 1.E-30 * REAL(eigenvalues(h)) ! Note that under MKL, the REAL() is redundant. top_value = MAX(top_value, lambda_(h)) END DO DO h = 1,3 sigma_list(h) = SQRT(lambda_(h)) END DO DO h = 1,3 h_alt1 = 1 + MOD(h, 3) h_alt2 = 1 + MOD(h_alt1, 3) IF (lambda_(h) <= 0.) THEN ! prevent needless halts due to loss-of-precision IF (ABS(lambda_(h)) <= (0.01 * 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_ = sigma_list(h) goal = 0. ! just initializing before sum (below) DO m = 1, 3 Lambda(h, m) = REAL(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./R) * (dG(j,1,1,1) * Lambda(h, 1) + & & 0.5 * (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./R) * (dG(j,2,1,1) * Lambda(h, 1) + & & 0.5 * (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) W_A = a_(l_) / A0 W = MAX(W_LL, W_A) !W_LL = SUM(rho_)/L0 was computed in a loop just above, z_ = 1, Z. !This selection will normally return W_LL. !However, if an element has only one infinitesimally-long fault segment, !W_LL could become very small. In that case, we would not want the !element to lose its continuum stiffness. prefix = W / sigma_**2 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 ! unfaulted element; use a-priori constraint ! Basic stiffness matrix of nonfaulting elements DO m = 1, 7 mu_of_r_ = mu_nod(i1) * Gauss_point(m)%s(1) + & & mu_nod(i2) * Gauss_point(m)%s(2) + & & mu_nod(i3) * Gauss_point(m)%s(3) t_sigma = mu_of_r_ prefix = a_(l_) * one_over_A0R2 * 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.) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP END IF theta = ATAN2(equat, r_(3)) csct = 1. / SIN(theta) tant = TAN(theta) cott = 1. / 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.*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.*(csct*dG(i,1,2,2)+G(i,1,1)*cott)*(csct*dG(j,1,2,2)+G(j,1,1)*cott)+ & & 0.5*(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.*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.*(csct*dG(i,2,2,2)+G(i,2,1)*cott)*(csct*dG(j,2,2,2)+G(j,2,1)*cott)+ & & 0.5*(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.*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.*(csct*dG(i,1,2,2)+G(i,1,1)*cott)*(csct*dG(j,2,2,2)+G(j,2,1)*cott)+ & ! & 0.5*(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.*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.*(csct*dG(i,2,2,2)+G(i,2,1)*cott)*(csct*dG(j,1,2,2)+G(j,1,1)*cott)+ & & 0.5*(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 CALL Plug_in_33_for_IMSL (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 ! initialize 3 different numerators (for N0, N1, N2): s_N0_sum = 0.0; s_N1_sum = 0.0; s_N2_sum = 0.0 ! initialize the common denominator for all 3 measures: s_error_count = 0.0 stressed_continuum_elements = 0 num_boxed = 0.0 IF (any_stress) THEN ! Insert stress constraints (different in each refinement) for NON-faulting elements DO l_ = 1, num_ele IF (ele_stressed(l_)) THEN ! Apply sigma_1h constraints only if element not faulting! ! Faulting elements are often anisotropic. ! Two examples from western USA: San Andreas has dextral slip even ! though it is almost orthogonal to sigma_1h in central California. ! Cascadia subduction zone has ENE-WSW shortening even though ! regional sigma_1h is N-S. (This is a case of layered stress guides.) ! When I once tried to apply boxing to faulting elements, ! the result was that the Cascadia subduction zone became locked, ! because then the E-W shortening was not allowed to exceed N-S shortening. IF (crack_index(1, l_) == 0) THEN stressed_continuum_elements = stressed_continuum_elements + 1 s_error_count = s_error_count + a_(l_) / A0 ! N.B. s_error_count is a REAL variable A = 0.; B = 0.; C = 0.; D = 0. E = 0.; F = 0. 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. / SIN(theta) tant = TAN(theta) cott = 1. / tant cos2g = COS(2. * ele_azim(l_)) sin2g = SIN(2. * ele_azim(l_)) prefix = 1. / (2. * 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 radius = SQRT(epsilon_dot(2)**2 + (0.5*(epsilon_dot(1)-epsilon_dot(3)))**2) ! units of /s sigma_perSecond = 2. * ele_sigma(l_) * radius ! desired value, ! without considering precision limits ! Guard against problems due to excessively small sigma_perSecond, ! to protect the condition number of the ABCD matrix, and the ! precision of the solution to the linear system. ! Since ABCDEF is REAL and has only 7 digits of precision, ! we must keep the condition number to under 10**(7-3) = 10**4 ! if we want to be sure the solution will have part-per-thousand precision !(e.g., 0.05 mm/a out of 50 mm/a in California). ! Now, a condition number of 10**4 means that (weight)/(sigma_perSecond**2) ! should not vary by more than 10**4, which means that when sigma_perSecond ! shrinks by more than 10**2 we may need to reduce the weight for these constraints. ! Since a very common sigma in the linear system is that of the stiff-continuum, ! with strain rates uncertainty of mu_ (around 1E-15 /s), ! effective sigma_perSecond should probably not be allowed to get smaller than ! about (1E-15 /s) / (10**2) = 1E-17 /s without decrease in weighting. ! This is in the neighborhood where xi_ is usually chosen (~ 3.2E-17 /s), so ! I will use xi_ as the lower limit on effective_sigma_perSecond, ! so as to give the user some limited control of this adjustment process: effective_sigma_perSecond = MAX(sigma_perSecond, xi_) ! limited on the low side prefix = (a_(l_) / A0) / (effective_sigma_perSecond**2) CALL Add_datum(prefix, f_, g_, 0.0D0, A, C, D, E, F) ! assess angular errors in sigma_1h azimuth = 0.5 * ATAN2F(epsilon_dot(2),0.5*(epsilon_dot(3)-epsilon_dot(1))) error = azimuth - ele_azim(l_) error = MIN(MOD(error + 6.2832, 3.1416), MOD(-error + 6.2832, 3.1416)) IF (radius > 0.0) THEN sigma_radians = sigma_perSecond / (2.0 * radius) ELSE sigma_radians = 1.0 END IF IF (ABS(error) > (2.0 * sigma_radians)) s_N0_sum = s_N0_sum + a_(l_) / A0 s_N1_sum = s_N1_sum + (a_(l_) / A0) * ABS(error) / sigma_radians s_N2_sum = s_N2_sum + (a_(l_) / A0) * (error / sigma_radians)**2 ! epsilon_alpha_alpha < epsilon_beta_beta IF ((3 * pass) > (2 * passes)) THEN ! don't allow boxing until last-3rd of run, when solution ~ stable. IF (((epsilon_dot(3) - epsilon_dot(1)) * cos2g + 2.0 * epsilon_dot(2) * sin2g) < 0.) boxed(l_) = .TRUE. END IF IF (boxed(l_)) THEN ! Needs constraint to enforce correct sense num_boxed = num_boxed + 1 prefix = 1. / 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 = (a_(l_) / A0) / (0.83 * xi_)**2 CALL Add_datum(prefix, f_, g_, (1.0D0 * xi_), A, C, D, E, F) END IF ! boxed(l_): sense constraint needed CALL Plug_in_33_for_IMSL (l_,A,B,C,D,E,F) ! add element matrix,vector to global END IF ! element is NOT faulting END IF ! ele_stressed(l_) END DO ! l_ = 1, num_ele END IF ! any_stress IF (internal_benchmarks > 0) THEN ! add geodetic constraints ! Correct from observed benchmark_vw --> (estimated) benchmark_unlocked_vw IF (f_dat_count > 0) THEN benchmark_unlocked_vw = benchmark_vw ! whole array; initialize before summing small corrections DO i = 1, f_dat_count !depths of top and bottom of the locked patch: ztop = 0.0 ! Was: "ztop = f_locking_depth_m_min(i)" in NeoKinema versions before 2.3 zbot = f_locking_depth_m_max(i) !Note that these were already converted from km-->m, and replaced with default values if negative, in the input section. IF ((.NOT.f_creeping(i)).AND.(zbot > ztop)) THEN ! compute correction only if locked area is positive!!! !Fault dip !Note: The forward direction is the digitizing direction, which is L-->R on the footwall side; ! thus dips measured from the RHS are all 90~175 degrees (but, converted to radians). dipf = 3.1415927 - (f_dat_dip_degrees(i) * radians_per_degree) !Slip-rate, in m/s, in the (x1, x2, x3) coordinate system of Aura, in which: ! x1 is along the trace, and the sliprate is positive if sinistral; ! x2 is horizontal and perpendicular to trace, sliprate is positive if divergent; ! x3 is down, and sliprate is positive when the RHS (looking in the forward direction) moves relatively down. IF (conservative_geodetic_adjustment) THEN ! !the fault slip rate used for coseismic adjustment is fixed at the geologic slip rate: rate_mps = f_offset_rate(i) ! in m/s; heave or throw depends on f_sense(i) ELSE ! use self-consistent method (less stable, but preferable if it converges): IF (pass == 1) THEN ! no model estimate available yet rate_mps = f_offset_rate(i) ! in m/s; heave or throw depends on f_sense(i) f_old_model_offset_rate(i) = rate_mps ! remember for damping next time ELSE ! subsequent iterations; use damped version of current model rate: rate_mps = 0.5 * f_model_offset_rate(i) + 0.5 * f_old_model_offset_rate(i) f_old_model_offset_rate(i) = rate_mps ! remember for damping next time END IF ! pass == 1, or later END IF ! conservative_geodetic_adjustment, or not IF (rate_mps /= 0.0) THEN ! contribution of this fault trace to geodetic adjustment is non-zero: IF (f_sense(i) == 'L') THEN sliprate_mps_x1x2x3(1) = rate_mps sliprate_mps_x1x2x3(2) = 0.0 sliprate_mps_x1x2x3(3) = 0.0 ELSE IF (f_sense(i) == 'R') THEN sliprate_mps_x1x2x3(1) = -rate_mps sliprate_mps_x1x2x3(2) = 0.0 sliprate_mps_x1x2x3(3) = 0.0 ELSE IF (f_sense(i) == 'D') THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = rate_mps sliprate_mps_x1x2x3(3) = rate_mps * TAN(dipf) ELSE IF (f_sense(i) == 'N') THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = rate_mps / ABS(TAN(dipf)) sliprate_mps_x1x2x3(3) = -rate_mps ELSE IF (f_sense(i) == 'T') THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = -rate_mps / ABS(TAN(dipf)) sliprate_mps_x1x2x3(3) = rate_mps ELSE IF ((f_sense(i) == 'P').OR.(f_sense(i) == 'S')) THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = -rate_mps sliprate_mps_x1x2x3(3) = -rate_mps * TAN(dipf) END IF k = which_trace(i) IF (trace_loc(3, k) > 0) THEN ! trace has at least one segment in the .feg area n1 = trace_loc(3, k) n2 = trace_loc(4, k) ! first and last segments associated with this trace DO n = n1, n2 ! segment index tv1(1:3) = seg_end(1:3, 1, n) ! Cartesian unit vector of initial point tv2(1:3) = seg_end(1:3, 2, n) ! and final point of this segment tv(1:3) = (tv1(1:3) + tv2(1:3)) / 2. ! location of midpoint fphi = ATAN2F(tv(2), tv(1)) ! phi, or longitude, in radians ftheta = ATAN2F(SQRT(tv(1)**2 + tv(2)**2), tv(3)) ! theta, or colatitude, in radians lf = 0.5D0 * R * SQRT((tv2(1)-tv1(1))**2 + (tv2(2)-tv1(2))**2 + (tv2(3)-tv1(3))**2) ! half-length, in m argume = 3.14159 - Get_Azimuth(tv1, tv2) ! radians counterclockwise from +theta (South) DO j = 1, internal_benchmarks !IF ((seg_def(1,n) == 430).AND.(seg_def(2,n) == 8953)) THEN ! IF (benchmark_name(j)(1:4) == "PICO") THEN ! WRITE (21, "(/'This segment is part of trace 0430 and lies in element 8953:')") ! WRITE (21, "('Inputs to CALL Change for benchmark PICO:')") ! WRITE (21, "('argume = ',ES12.4)") argume ! WRITE (21, "('btheta = ',ES12.4)") benchmark_theta(j) ! WRITE (21, "('bphi = ',ES12.4)") benchmark_phi(j) ! WRITE (21, "('dipf = ',ES12.4)") dipf ! WRITE (21, "('lf = ',ES12.4)") lf ! WRITE (21, "('ftheta = ',ES12.4)") ftheta ! WRITE (21, "('fphi = ',ES12.4)") fphi ! WRITE (21, "('radius = ',ES12.4)") R ! WRITE (21, "('slip(1)= ',ES12.4)") sliprate_mps_x1x2x3(1) ! WRITE (21, "('slip(2)= ',ES12.4)") sliprate_mps_x1x2x3(2) ! WRITE (21, "('slip(3)= ',ES12.4)") sliprate_mps_x1x2x3(3) ! WRITE (21, "('wedge = 0.2618')") ! WRITE (21, "('ztop = ',ES12.4)") ztop ! WRITE (21, "('zbot = ',ES12.4)") zbot ! END IF !END IF CALL Change (argume = argume, & & btheta = benchmark_theta(j), bphi = benchmark_phi(j), & & dipf = dipf, lf = lf, & & ftheta = ftheta, fphi = fphi, & & radius = R, & & slip = sliprate_mps_x1x2x3, & & wedge = 0.2618, & & ztop = ztop, zbot = zbot, & ! inputs & duthet = duthet, duphi = duphi) ! output !IF ((seg_def(1,n) == 430).AND.(seg_def(2,n) == 8953)) THEN ! IF (benchmark_name(j)(1:4) == "PICO") THEN ! WRITE (21, "('Output from CALL Change for benchmark PICO:')") ! WRITE (21, "('duthet = ',ES12.4)") duthet ! WRITE (21, "('duphi = ',ES12.4)") duphi ! END IF !END IF ! For a typical year with no earthquakes, ! correct the observed benchmark velocities ! by adding the (estimated) missing coseismic part: benchmark_unlocked_vw(2 * j - 1) = benchmark_unlocked_vw(2 * j - 1) + duthet benchmark_unlocked_vw(2 * j ) = benchmark_unlocked_vw(2 * j ) + duphi END DO ! j = 1, internal_benchmarks END DO ! n = n1, n2; segment index END IF ! trace_loc(3, k) > 0; trace has at least one segment in the .feg area END IF ! rate_mpa /= 0.0 for this trace END IF ! zbot > ztop, so locked area is positive END DO ! i = 1, f_dat_count ELSE ! no faults to correct for! benchmark_unlocked_vw = benchmark_vw ! whole array; no correction performed END IF ! f_dat_count > 0 (fault locking to correct for), or not ! Add geodetic information to odd (v) rows of the linear system, ! per notes of 2002.07.31, page 3 !(but only changing upper right of matrix: j >= i, and RHS vector) IF (using_GPS_matrices) THEN DO i_geodetic = 1, geodetic_nDOF ! equivalent to i of 2002.07.31 notes benchmark_i = (i_geodetic + 1) / 2 l_i = benchmark_is(benchmark_i)%element i_node(1:3) = node(1:3, l_i) ! equivalent to i1, i2, i3 of 2002.07.31 notes IF (Odd(i_geodetic)) THEN fi(1:3) = benchmark_G(1:3, 1, 1, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 1, benchmark_i) ELSE ! i_geodetic is even fi(1:3) = benchmark_G(1:3, 1, 2, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 2, benchmark_i) END IF ! i_geodetic is odd or even DO j_geodetic = 1, geodetic_nDOF ! equivalent to j of 2002.07.31 notes benchmark_j = (j_geodetic + 1) / 2 l_j = benchmark_is(benchmark_j)%element j_node(1:3) = node(1:3, l_j) ! equivalent to j1, j2, j3 of 2002.07.31 notes IF (Odd(j_geodetic)) THEN fj(1:3) = benchmark_G(1:3, 1, 1, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 1, benchmark_j) ELSE ! j_geodetic is even fj(1:3) = benchmark_G(1:3, 1, 2, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 2, benchmark_j) END IF ! j_geodetic is odd or even half_N = 0.5D0 * normal(i_geodetic, j_geodetic) DO k = 1, 3 ! (subscript of fi, gi, fj, gj, i_node, j_node) i = 2 * j_node(k) - 1 ! row of linear system (odd) ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + half_N * fj(k) * benchmark_unlocked_vw(i_geodetic) DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * i_node(m) - 1 ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * fj(k) * fi(m) j = 2 * i_node(m) ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * fj(k) * gi(m) END DO ! m = 1, 3 (subscript within horizontal group of 6) i = 2 * i_node(k) - 1 ! row of linear system (odd) ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + half_N * fi(k) * benchmark_unlocked_vw(j_geodetic) DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * j_node(m) - 1 ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * fi(k) * fj(m) j = 2 * j_node(m) ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * fi(k) * gj(m) END DO ! m = 1, 3 (subscript within horizontal group of 6) END DO ! k = 1, 3 (subscript of fi, gi, fj, gj, i_node, j_node) END DO ! j_geodetic = 1, geodetic_nDOF END DO ! i_geodetic = 1, geodetic_nDOF ! Add geodetic information to even (w) rows of the linear system, ! per notes of 2002.07.31, page 4 !(but only changing upper right of matrix: j >= i, and RHS vector) DO i_geodetic = 1, geodetic_nDOF ! equivalent to i of 2002.07.31 notes benchmark_i = (i_geodetic + 1) / 2 l_i = benchmark_is(benchmark_i)%element i_node(1:3) = node(1:3, l_i) ! equivalent to i1, i2, i3 of 2002.07.31 notes IF (Odd(i_geodetic)) THEN fi(1:3) = benchmark_G(1:3, 1, 1, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 1, benchmark_i) ELSE ! i_geodetic is even fi(1:3) = benchmark_G(1:3, 1, 2, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 2, benchmark_i) END IF ! i_geodetic is odd or even DO j_geodetic = 1, geodetic_nDOF ! equivalent to j of 2002.07.31 notes benchmark_j = (j_geodetic + 1) / 2 l_j = benchmark_is(benchmark_j)%element j_node(1:3) = node(1:3, l_j) ! equivalent to j1, j2, j3 of 2002.07.31 notes IF (Odd(j_geodetic)) THEN fj(1:3) = benchmark_G(1:3, 1, 1, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 1, benchmark_j) ELSE ! j_geodetic is even fj(1:3) = benchmark_G(1:3, 1, 2, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 2, benchmark_j) END IF ! j_geodetic is odd or even half_N = 0.5D0 * normal(i_geodetic, j_geodetic) DO k = 1, 3 ! (subscript of fi, gi, fj, gj, i_node, j_node) i = 2 * j_node(k) ! row of linear system (even) ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + half_N * gj(k) * benchmark_unlocked_vw(i_geodetic) DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * i_node(m) - 1 ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * gj(k) * fi(m) j = 2 * i_node(m) ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * gj(k) * gi(m) END DO ! m = 1, 3 (subscript within horizontal group of 6) i = 2 * i_node(k) ! row of linear system (even) ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + half_N * gi(k) * benchmark_unlocked_vw(j_geodetic) DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * j_node(m) - 1 ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * gi(k) * fj(m) j = 2 * j_node(m) ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * gi(k) * gj(m) END DO ! m = 1, 3 (subscript within horizontal group of 6) END DO ! k = 1, 3 (subscript of fi, gi, fj, gj, i_node, j_node) END DO ! j_geodetic = 1, geodetic_nDOF END DO ! i_geodetic = 1, geodetic_nDOF ELSE ! .NOT. using_GPS_matrices; using many benchmark_covariance's and benchmark_normal's instead: DO benchmark_i = 1, internal_benchmarks ! intentional half-indent (2 spaces), so copied lines within don't shift l_i = benchmark_is(benchmark_i)%element ! All statements in this group moved up (out of other loops). i_node(1:3) = node(1:3, l_i) ! equivalent to i1, i2, i3 of 2002.07.31 notes benchmark_j = benchmark_i l_j = benchmark_is(benchmark_j)%element j_node(1:3) = node(1:3, l_j) ! equivalent to j1, j2, j3 of 2002.07.31 notes DO i_geodetic = 1, 2 ! equivalent to i of 2002.07.31 notes IF (Odd(i_geodetic)) THEN fi(1:3) = benchmark_G(1:3, 1, 1, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 1, benchmark_i) ELSE ! i_geodetic is even fi(1:3) = benchmark_G(1:3, 1, 2, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 2, benchmark_i) END IF ! i_geodetic is odd or even DO j_geodetic = 1, 2 ! equivalent to j of 2002.07.31 notes IF (Odd(j_geodetic)) THEN fj(1:3) = benchmark_G(1:3, 1, 1, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 1, benchmark_j) ELSE ! j_geodetic is even fj(1:3) = benchmark_G(1:3, 1, 2, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 2, benchmark_j) END IF ! j_geodetic is odd or even !half_N = 0.5D0 * normal(i_geodetic, j_geodetic) half_N = 0.5D0 * benchmark_normal(i_geodetic, j_geodetic, benchmark_i) ! benchmark_j = benchmark_i DO k = 1, 3 ! (subscript of fi, gi, fj, gj, i_node, j_node) i = 2 * j_node(k) - 1 ! row of linear system (odd) ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + half_N * fj(k) * benchmark_unlocked_vw(2*(benchmark_i-1)+i_geodetic) DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * i_node(m) - 1 ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * fj(k) * fi(m) j = 2 * i_node(m) ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * fj(k) * gi(m) END DO ! m = 1, 3 (subscript within horizontal group of 6) i = 2 * i_node(k) - 1 ! row of linear system (odd) ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + half_N * fi(k) * benchmark_unlocked_vw(2*(benchmark_i-1)+j_geodetic) DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * j_node(m) - 1 ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * fi(k) * fj(m) j = 2 * j_node(m) ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * fi(k) * gj(m) END DO ! m = 1, 3 (subscript within horizontal group of 6) END DO ! k = 1, 3 (subscript of fi, gi, fj, gj, i_node, j_node) END DO ! j_geodetic = 1, 2 END DO ! i_geodetic = 1, 2 ! Add geodetic information to even (w) rows of the linear system, ! per notes of 2002.07.31, page 4 !(but only changing upper right of matrix: j >= i, and RHS vector) DO i_geodetic = 1, 2 ! equivalent to i of 2002.07.31 notes IF (Odd(i_geodetic)) THEN fi(1:3) = benchmark_G(1:3, 1, 1, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 1, benchmark_i) ELSE ! i_geodetic is even fi(1:3) = benchmark_G(1:3, 1, 2, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 2, benchmark_i) END IF ! i_geodetic is odd or even DO j_geodetic = 1, 2 ! equivalent to j of 2002.07.31 notes IF (Odd(j_geodetic)) THEN fj(1:3) = benchmark_G(1:3, 1, 1, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 1, benchmark_j) ELSE ! j_geodetic is even fj(1:3) = benchmark_G(1:3, 1, 2, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 2, benchmark_j) END IF ! j_geodetic is odd or even !half_N = 0.5D0 * normal(i_geodetic, j_geodetic) half_N = 0.5D0 * benchmark_normal(i_geodetic, j_geodetic, benchmark_i) ! benchmark_j = benchmark_i DO k = 1, 3 ! (subscript of fi, gi, fj, gj, i_node, j_node) i = 2 * j_node(k) ! row of linear system (even) ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + half_N * gj(k) * benchmark_unlocked_vw(2*(benchmark_i-1)+i_geodetic) DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * i_node(m) - 1 ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * gj(k) * fi(m) j = 2 * i_node(m) ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * gj(k) * gi(m) END DO ! m = 1, 3 (subscript within horizontal group of 6) i = 2 * i_node(k) ! row of linear system (even) ABCDEF(EFrow(i), EFcol) = ABCDEF(EFrow(i), EFcol) + half_N * gi(k) * benchmark_unlocked_vw(2*(benchmark_i-1)+j_geodetic) DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * j_node(m) - 1 ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * gi(k) * fj(m) j = 2 * j_node(m) ! column of linear system IF (j >= i) ABCDEF(ABCDrow(j),ABCDcol(i, j)) = ABCDEF(ABCDrow(j),ABCDcol(i, j)) + half_N * gi(k) * gj(m) END DO ! m = 1, 3 (subscript within horizontal group of 6) END DO ! k = 1, 3 (subscript of fi, gi, fj, gj, i_node, j_node) END DO ! j_geodetic = 1, 2 END DO ! i_geodetic = 1, 2 END DO ! benchmark_i[and _j] = 1, internal_benchmarks ! intentional half-indent (2 spaces), so copied lines within don't shift END IF ! using_GPS_matrices, or not (in which case, using benchmark_normal's intead). END IF ! internal_benchmarks > 0 (geodetic constraints) ! Scale linear system (to prevent overflow/underflow) big_one = MAXVAL(ABCDEF) ! biggest should be in ABCD part, not EF part factor = 1.0D0/big_one ABCDEF = factor * ABCDEF ! scales both coefficients and rhs ! Impose boundary conditions, maintaining symmetry, but only ! reading or changing upper right (j >= i). DO m = 1, bcs_count ! South (theta) component of velocity k = 2 * boundary_node(m) - 1 ! logical row/col to be replaced j = k ! work on the column DO i = MAX(1, k - nCoDa), k-1 ! upper part of column ! clear column, changing rhs ita = ABCDrow(j) jta = ABCDcol(i, j) ite = EFrow(i) jte = EFcol ABCDEF(ite, jte) = ABCDEF(ite, jte) - condition(1, m) * ABCDEF(ita, jta) ABCDEF(ita, jta) = 0.0D0 END DO i = k ! work on the row DO j = k+1, MIN(nDOF, k + nCoDa) ! right part of row ! clear row, changing rhs ita = ABCDrow(j) jta = ABCDcol(i, j) ite = EFrow(j) jte = EFcol ABCDEF(ite, jte) = ABCDEF(ite, jte) - condition(1, m) * ABCDEF(ita, jta) ABCDEF(ita, jta) = 0.0D0 END DO ABCDEF(ABCDrow(k), ABCDcol(k, k)) = 1.0D0 ! put 1 on diagonal ABCDEF(EFrow(k), EFcol) = condition(1, m) ! put BC velocity component in rhs ! East (phi) component of velocity k = 2 * boundary_node(m) ! logical row/col to be replaced j = k ! work on the column DO i = MAX(1, k - nCoDa), k-1 ! upper part of column ! clear column, changing rhs ita = ABCDrow(j) jta = ABCDcol(i, j) ite = EFrow(i) jte = EFcol ABCDEF(ite, jte) = ABCDEF(ite, jte) - condition(2, m) * ABCDEF(ita, jta) ABCDEF(ita, jta) = 0.0D0 END DO i = k ! work on the row DO j = k+1, MIN(nDOF, k + nCoDa) ! right part of row ! clear row, changing rhs ita = ABCDrow(j) jta = ABCDcol(i, j) ite = EFrow(j) jte = EFcol ABCDEF(ite, jte) = ABCDEF(ite, jte) - condition(2, m) * ABCDEF(ita, jta) ABCDEF(ita, jta) = 0.0D0 END DO ABCDEF(ABCDrow(k), ABCDcol(k, k)) = 1.0D0 ! put 1 on diagonal ABCDEF(EFrow(k), EFcol) = condition(2, m) ! put BC velocity component in rhs END DO ! on boundary node index m !solve banded linear system for node velocity (2-vectors): !============================================================================================= ! IMSL version (see MKL version below): !CALL DLSLPB (nDOF, ABCDEF, lda, nCoDa, ijob, u_flag) !! Usage: !! CALL DLSLPB (N, A, LDA, nCoDa, IJOB, U) !! Arguments: !! N = Order of the matrix. (Input) !! Must satisfy N > 0. !! A = Array containing the N by N positive definite band coefficient !! matrix and right hand side in MS-IMSL's !! codiagonal band symmetric storage mode. (Input/Output) !! The number of array columns must be at least nCoDa + 2. !! The number of columns is not an input to this subprogram. !! LDA = Leading dimension of A exactly as specified in the !! dimension statement of the calling program. (Input) !! Must satisfy LDA >= N + nCoDa. !! nCoDa = Number of upper codiagonals of matrix A. (Input) !! Must satisfy nCoDa >= 0 and nCoDa < N. !! IJOB = Flag to direct the desired factorization or solving step. (Input) !! IJOB Meaning: !! 1 factor the matrix A and solve the system Ax = b, where b is stored in column nCoDa + 2 of array A. !! The vector x overwrites b in storage. !! 2 solve step only. Use b as column nCoDa + 2 of A. (The factorization step has already been done.) !! The vector x overwrites b in storage. !! 3 factor the matrix A but do not solve a system. !! 4,5,6 same meaning as with the value IJOB - 3. For efficiency, no !! error checking is done on values LDA, N, nCoDa, and U(*). !! U = Array of flags that indicate any singularities of A, namely loss of positive-definiteness of a leading minor. (Output) !! A value U(I) = 0. means that the leading minor of dimension I is not positive-definite. Otherwise, U(I) = 1. !! Comments: !! Automatic workspace usage is: nCoDa real numbers. !IF (passes > 0) THEN ! ! Compare new with old solution ! sum_base_o = 0. ! sum_base_n = 0. ! sum_diff = 0. ! big_diff = 0. ! big_diff_node = 0 ! DO i = 1, num_nod ! twoi = 2 * i ! wo = vw(twoi) ! wn = ABCDEF(EFrow(twoi), EFcol) ! <==== unique to IMSL version ! twoi = twoi - 1 ! vo = vw(twoi) ! vn = ABCDEF(EFrow(twoi), EFcol) ! <==== unique to IMSL version ! 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 ! diff = SQRT((vn - vo)**2 + (wn - wo)**2) ! IF (diff > big_diff) THEN ! big_diff = diff ! big_diff_node = i ! END IF ! 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.) THEN ! dV_frac = difference / divisor ! ELSE ! dV_frac = 0. ! END IF ! IF (any_stress) THEN ! stressed_frac = (100. * stressed_continuum_elements) / num_ele ! boxed_frac = (100. * num_boxed) / num_ele ! IF (s_error_count > 0.) THEN ! s_err(0) = s_N0_sum / s_error_count ! s_err(1) = s_N1_sum / s_error_count ! s_err(2) = SQRT( s_N2_sum / s_error_count ) ! ELSE ! s_err = 0. ! all 3 values ! END IF ! PRINT "(' ',4X,I10,F8.5,1P,E11.4,I6,3X,0P,F8.2,'%',F7.2,'%',F11.3)", & ! & pass-1, dV_frac, new_V, n_brackets_tightened, stressed_frac, boxed_frac, s_err(1) ! WRITE (21,"(4X,I10,F8.5,1P,E11.4,I6,3X,0P,F8.2,'%',F7.2,'%',F11.3)") & ! & pass-1, dV_frac, new_V, n_brackets_tightened, stressed_frac, boxed_frac, s_err(1) ! ELSE ! PRINT "(' ',4X,I10,F8.5,1P,E11.4,I6)", & ! & pass-1, dV_frac, new_V, n_brackets_tightened ! WRITE (21,"(4X,I10,F8.5,1P,E11.4,I6)") & ! & pass-1, dV_frac, new_V, n_brackets_tightened ! END IF ! any_stress !END IF ! passes > 1 (or 0?) !! Transfer solution to velocity supervector !DO i = 1, nDOF ! vw(i) = ABCDEF(EFrow(i), EFcol) ! <=== unique to IMSL version !END DO !============================================================================================= ! MKL version (see IMSL version above): ldab = (nCoDa + (nCoDa + 1 + nCoDa)) ALLOCATE ( ipiv(nDOF) ) CALL dgbsv(nDOF, nCoDa, nCoDa, 1, ABCD, ldab, ipiv, EF, nDOF, info) ! using Fortran77 CALL because F95 CALL is buggy. IF (info /= 0) THEN WRITE (*, "(' ERROR: info = ',I12,' in call to dgbsv.')") info CALL Traceback() END IF IF (passes > 0) THEN ! Compare new with old solution sum_base_o = 0. sum_base_n = 0. sum_diff = 0. big_diff = 0. big_diff_node = 0 DO i = 1, num_nod twoi = 2 * i wo = vw(twoi) wn = EF(twoi, 1) ! <==== unique to MKL version twoi = twoi - 1 vo = vw(twoi) vn = EF(twoi, 1) ! <==== unique to MKL version 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 diff = SQRT((vn - vo)**2 + (wn - wo)**2) IF (diff > big_diff) THEN big_diff = diff big_diff_node = i END IF 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.) THEN dV_frac = difference / divisor ELSE dV_frac = 0. END IF IF (any_stress) THEN stressed_frac = (100. * stressed_continuum_elements) / num_ele boxed_frac = (100. * num_boxed) / num_ele IF (s_error_count > 0.) THEN s_err(0) = s_N0_sum / s_error_count s_err(1) = s_N1_sum / s_error_count s_err(2) = SQRT( s_N2_sum / s_error_count ) ELSE s_err = 0. ! all 3 values END IF PRINT "(' ',4X,I10,F8.5,1P,E11.4,I6,3X,0P,F8.2,'%',F7.2,'%',F11.3)", & & pass-1, dV_frac, new_V, n_brackets_tightened, stressed_frac, boxed_frac, s_err(1) WRITE (21,"(4X,I10,F8.5,1P,E11.4,I6,3X,0P,F8.2,'%',F7.2,'%',F11.3)") & & pass-1, dV_frac, new_V, n_brackets_tightened, stressed_frac, boxed_frac, s_err(1) ELSE PRINT "(' ',4X,I10,F8.5,1P,E11.4,I6)", & & pass-1, dV_frac, new_V, n_brackets_tightened WRITE (21,"(4X,I10,F8.5,1P,E11.4,I6)") & & pass-1, dV_frac, new_V, n_brackets_tightened END IF ! any_stress END IF ! passes > 1 (or 0?) ! Transfer solution to velocity supervector DO i = 1, nDOF vw(i) = EF(i, 1) ! <==== unique to MKL version END DO !============================================================================================= IF (dump_all_solutions) THEN WRITE (22, "('Pass ',I6)") pass DO i = 1, num_nod WRITE (22, "(i8,2ES12.4)") i, vw(2*i-1), vw(2*i) END DO END IF OK_to_stop = (passes > 1) .AND. (dV_frac < 0.00001) ! minimum condition for stopping iterations: stable velocity solution IF (f_dat_count > 0) OK_to_stop = OK_to_stop .AND. (pass > (passes/3)) ! must at least get to the 1st "bracketing" step IF (any_stress) OK_to_stop = OK_to_stop .AND. (pass > ((2*passes)/3)) ! must at least get to the 1st "boxing" step IF (OK_to_stop) EXIT many_passes END DO many_passes ! pass = 1, passes big_diff_mmpa = big_diff * 1000. * s_per_year ! using global parameter PRINT "(' ',4X,'Largest change is ',ES10.2,' = ',F10.3,' mm/a at node ',I8)", big_diff, big_diff_mmpa, big_diff_node WRITE (21,"(4X,'Largest change is ',ES10.2,' = ',F10.3,' mm/a at node ',I8)") big_diff, big_diff_mmpa, big_diff_node PRINT "(' ',4X,'If convergence is not satisfactory, even after 30~45 iterations,')" PRINT "(' ',4X,'then run program Analyze_Velocity_Evolution to get insight.')" WRITE (21,"(4X,'If convergence is not satisfactory, even after 30~45 iterations,')") WRITE (21,"(4X,'then run program Analyze_Velocity_Evolution to get insight.')") IF (.NOT.conservative_geodetic_adjustment) THEN PRINT "(' ',4X,'Also consider setting input parameter')" PRINT "(' ',4X,'conservative_geodetic_adjustment to TRUE.')" WRITE (21,"(4X,'Also consider setting input parameter')") WRITE (21,"(4X,'conservative_geodetic_adjustment to TRUE.')") END IF IF ((xi_ / 3.2E-17) < 0.5) THEN PRINT "(' ',4X,'Also consider setting input parameter xi_')" PRINT "(' ',4X,'to a larger value (but still below input parameter mu_).')" WRITE (21,"(4X,'Also consider setting input parameter xi_')") WRITE (21,"(4X,'to a larger value (but still below input parameter mu_).')") END IF PRINT "(' ','Finished computing velocities at nodes.')" WRITE (21,"('Finished computing velocities at nodes.')") END SUBROUTINE Solve_for_vw_with_IMSL SUBROUTINE Solve_for_vw_with_MKL (passes, vw) !NOTE: I am forced to have different codes here for the IMSL and MKL versions ! because these packages use different storage schemes for banded matrices, ! and the statement-functions to translate storage locations even ! have different numbers of arguments (see below). ! Also, these 2 versions call distinct flavors of Plug_in_33_for_xxx. INTEGER, INTENT(IN) :: passes DOUBLE PRECISION, DIMENSION(nDOF), INTENT(INOUT) :: vw ! NOTE: vw is used BEFORE it is computed in the first pass ! through the stress section, IF (any_stress), 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, DIMENSION(3,3) :: A, B, C, D DOUBLE PRECISION, DIMENSION(3) :: E, F REAL :: azimuth CHARACTER(61) :: bar_graph INTEGER :: benchmark_i, benchmark_j REAL :: big_diff, big_diff_mmpa INTEGER :: big_diff_node DOUBLE PRECISION :: big_one LOGICAL :: boost_some_weights REAL :: boxed_frac REAL :: cosg, cos2g REAL :: cott, csct DOUBLE PRECISION, DIMENSION(3,2,2,2) :: dG REAL :: del_az_for_90pc ! one-sided, in radians REAL :: del_s_, diff, difference, divisor LOGICAL :: dumping REAL :: dV_frac REAL :: effective_sigma_perSecond !========================================================= ! IMSL version (see MKL version below): !COMPLEX, DIMENSION(3) :: eigenvalues !COMPLEX, DIMENSION(3,3) :: eigenvectors !========================================================= ! MKL version (see IMSL version above): REAL, DIMENSION(3) :: eigenvalues REAL, DIMENSION(3,3) :: eigenvectors !========================================================= REAL, DIMENSION(3) :: epsilon_dot REAL :: equat REAL :: error REAL :: eta_ REAL :: extra_weight REAL, DIMENSION(6) :: f_, g_ ! sometimes, only 1..3 are used DOUBLE PRECISION :: factor REAL, DIMENSION(3) :: fi, fj REAL :: floor = 2. * TINY(floor) REAL :: force REAL :: fraction DOUBLE PRECISION, DIMENSION(3,2,2) :: G REAL :: gamma_ TYPE(is123), DIMENSION(7) :: Gauss_point REAL, DIMENSION(7) :: Gauss_weight = (/ 0.225, & & 0.13239415, 0.13239415, 0.13239415, & & 0.12593918, 0.12593918, 0.12593918 /) REAL, DIMENSION(3) :: gi, gj DOUBLE PRECISION :: goal INTEGER :: h, h_alt1, h_alt2 REAL :: half_N INTEGER, DIMENSION(2) :: ij_Infinity ! debugging aid INTEGER, PARAMETER :: ijob = 4 ! mode setting for LSLPB INTEGER :: i, i_geodetic, i_middle, i1, i2, i3, ii, ita, ite INTEGER, DIMENSION(3) :: i_node INTEGER :: info ! <=== unique to MKL version INTEGER :: ios INTEGER, DIMENSION(:), ALLOCATABLE :: ipiv INTEGER :: it ! logical element ABCD(i, j) <==> stored at ABCD(it, j); where it = MKLdRow + i - j INTEGER, DIMENSION(18) :: iwork INTEGER :: j, j_geodetic, j_middle, jj, jold, jta, jt, jte, jtest INTEGER, DIMENSION(3) :: j_node CHARACTER*1 :: jobz ! <=== unique to MKL version INTEGER :: k REAL :: kappa_ INTEGER :: l_, l_i, l_j REAL, DIMENSION(3) :: lambda_ REAL, DIMENSION(3,3) :: Lambda INTEGER :: ldab, liwork, lwork INTEGER :: leading_text_bytes ! adjustable leading label of oft-repeated completion-bar code INTEGER :: loc REAL :: lat, lon DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: matrix_UL ! for debugging INTEGER :: m, method REAL :: mu_of_r_, mu_2 INTEGER :: n ! local copy REAL :: new_V, num_boxed, old_value LOGICAL :: OK_to_stop REAL :: one_over_A0R2 INTEGER :: pass DOUBLE PRECISION :: prefix REAL, DIMENSION(3) :: r_ REAL :: rho_ ! length of a fault segment, in m REAL :: radius INTEGER :: s REAL :: s_ REAL :: s_N0_sum, s_N1_sum, s_N2_sum ! Note: s_error_count is a global, ! so it will persist, and can be used at end of Prediction ! to reconstitute these 3 sums from s_err(0:2). INTEGER :: segment CHARACTER(1) :: sense REAL :: sigma_, sigma_perSecond, sigma_radians REAL, DIMENSION(3) :: sigma_list REAL :: sing, sin2g REAL :: sint REAL :: stiff INTEGER :: stress_count REAL :: stressed_frac REAL :: sum_base_n, sum_base_o, sum_diff REAL :: t_sigma, tant, theta REAL :: top_value INTEGER :: twoi, u_ CHARACTER*1 :: uplo ! <=== unique to MKL version REAL :: vn, vo, wn, wo REAL, DIMENSION(3,3) :: V DOUBLE PRECISION, DIMENSION(3,3) :: V8 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: vector_U ! for debugging REAL :: W, W_A, W_LL REAL, DIMENSION(37) :: work INTEGER :: Z, z_ !INTEGER :: ABCDrow, ABCDcol, EFrow, EFcol ! statement functions !========================================================================= ! MKL version: !ABCDrow(i, j) = 2*nCoDa + 1 + i - j ! statement function; nCoDa is global !ABCDcol(j) = j ! statement function !EFrow(i) = i ! statement function !EFcol = 1 ! These statement functions are ! specific to MKL's "band storage scheme for LU factorization", in which column ! #s are unchanged, but row #s are flattened to produce a smaller, rectangular ! matrix with (nCoDa + (nCoDa+1+nCoDa)) rows. The diagonal becomes a row. ! Unfortunately, there does not seem to be any provision for ! designating the matrix symmetric, and thus storing only one side! !========================================================================= ! Postscript: After struggling with buggy compilations, I decided ! NOT to use these statement-functions for indirect addressing, ! but to make address computations explicit and checkable, ! with a temporary address variable: it = MKLdRow + i - j, ! so that logical ABCD(i, j) <==> stored at ABCD(it, j). ! Note that MKLdRow is a global INTEGER, precomputed. ! In a similar way, I now refer directly to EF(i, 1) ! instead of using the indirect EF(EFrow(i), EFcol) ! to refer to element #i in the right-hand side forcing vector EF. !======================================================================== Gauss_point(1)%s(1:3) = (/ 0.33333333, 0.33333333, 0.33333333 /) Gauss_point(2)%s(1:3) = (/ 0.05971587, 0.47014206, 0.47014206 /) Gauss_point(3)%s(1:3) = (/ 0.47014206, 0.05971587, 0.47014206 /) Gauss_point(4)%s(1:3) = (/ 0.47014206, 0.47014206, 0.05971587 /) Gauss_point(5)%s(1:3) = (/ 0.79742698, 0.10128650, 0.10128650 /) Gauss_point(6)%s(1:3) = (/ 0.10128650, 0.79742698, 0.10128650 /) Gauss_point(7)%s(1:3) = (/ 0.10128650, 0.10128650, 0.79742698 /) one_over_A0R2 = 1.0 / (A0 * R**2) !print header for table in report that follows the refinement process: PRINT "(' Solving for velocities:')" WRITE (21,"('Solving for velocities:')") IF (passes > 0) THEN ! selection criterion could be > 1 (0R, > 0 to always print) ! Write headers for convergence report IF (any_stress) THEN PRINT "(' ',4X,' Active Unfaulted& e1h_azim_error')" PRINT "(' ',4X,'Refinement dV/V RMS(V) brackets Stressed Boxed (N1; in sigmas)')" WRITE (21,"(4X,' Active Unfaulted& e1h_azim_error')") WRITE (21,"(4X,'Refinement dV/V RMS(V) brackets Stressed Boxed (N1; in sigmas)')") ELSE PRINT "(' ',4X,' Active ')" PRINT "(' ',4X,'Refinement dV/V RMS(V) brackets')" WRITE (21,"(4X,' Active ')") WRITE (21,"(4X,'Refinement dV/V RMS(V) brackets')") END IF END IF n_brackets_tightened = 0 ! initialized, because on 1st pass we do NOT CALL Prediction ALLOCATE ( ipiv(nDOF) ) ! used in MKL solver below many_passes: DO pass = 1, passes boost_some_weights = ((3 * pass) > passes) ! consider local_crack()%extra_weight > 1.0 in latter 2/3 of iterations ! Update slip rates, for both geodetic targets, and strike-slip flexibility on dip-slip faults (if any). IF (pass > 1) THEN ! this is an iterative refinement pass CALL Prediction(vw = vw, verbose = .FALSE., adjust_some_weights = boost_some_weights) ! which returns current model heave-rates of cracks in (new, global) local_crack()%p_, ! and current model offset-rates of faults in f_model_offset_rate(). ! Note that both are in already in SI (m/s), but that conversions between ! heave-rate and offset-rate will be needed. DO i = 1, f_dat_count IF (f_dat_shadow(i)) THEN !NOTE: "factor" in this SUBR is the ABS(ratio of heave-rate to offset-rate) = ~2.7 for Thrust, ~0.7 for Normal, ==1 for R, L, P, S. IF ((f_sense(i) == 'R').OR.(f_sense(i) == 'L')) THEN !adjusting strike-slip flexibility (i) based on a dip-slip datum in (i - 1): IF (f_sense(i - 1) == 'T') THEN factor = 1.0 / TAN(f_dat_dip_degrees(i - 1) * radians_per_degree) ELSE IF (f_sense(i - 1) == 'P') THEN factor = 1. ELSE IF (f_sense(i - 1) == 'S') THEN factor = 1. ELSE IF (f_sense(i - 1) == 'N') THEN factor = 1.0 / TAN(f_dat_dip_degrees(i - 1) * radians_per_degree) ELSE IF (f_sense(i - 1) == 'D') THEN factor = 1. ELSE IF (f_sense(i - 1) == 'R') THEN factor = 1. WRITE (*, "(' ERROR: s-s shadow datum should not follow s-s real datum')") CALL Traceback ELSE IF (f_sense(i - 1) == 'L') THEN factor = 1. WRITE (*, "(' ERROR: s-s shadow datum should not follow s-s real datum')") CALL Traceback ENDIF IF (f_sense(i - 1) == 'S') THEN fraction = MAX(1.0, TAN(sigma_offnormal_degrees / 57.296)) ! ratio of allowed s-s heave rate to orthogonal heave rate ELSE fraction = TAN(sigma_offnormal_degrees / 57.296) ! ratio of allowed s-s heave rate to orthogonal heave rate END IF old_value = f_offset_rate_sigma_(i) !new value, if no damping were applied: f_offset_rate_sigma_(i) = fraction * ABS(f_model_offset_rate(i - 1)) * factor !apply modest damping for safety: f_offset_rate_sigma_(i) = 0.5 * old_value + 0.5 * f_offset_rate_sigma_(i) !do not allow value to vanish (what would happen?) f_offset_rate_sigma_(i) = MAX(f_offset_rate_sigma_(i), small_rate_in_mps) DO j = 1, crack_count IF (local_crack(j)%datum == i) THEN old_value = local_crack(j)%sigma_ !new value, if no damping were applied: local_crack(j)%sigma_ = fraction * ABS(f_model_offset_rate(i - 1)) * factor !apply modest damping for safety: local_crack(j)%sigma_ = 0.5 * old_value + 0.5 * local_crack(j)%sigma_ !do not allow value to vanish (what would happen?) local_crack(j)%sigma_ = MAX(local_crack(j)%sigma_, small_rate_in_mps) END IF ! local_crack(f) refers to this shadow datum END DO ! j = 1, crack_count END IF ! f_sense(i) == (R .OR. L) END IF ! f_dat_shadow(i) END DO ! i = 1, f_dat_count END IF ! pass > 1 !Begin building linear system by zeroing it out entirely: ABCD = 0.0D0 ! global coefficient matrix ! <==== unique to MKL version EF = 0.0D0 ! global forcing vector (of 1 column) ! <==== unique to MKL version 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 (9) of Bird (1997?). E = 0.0D0; F = 0.0D0 ! forcing subvectors for element Z = crack_index(1, l_) IF (Z > 0) THEN ! active faulting! mu_of_r_ = mu_nod(i1) * Gauss_point(1)%s(1) + & & mu_nod(i2) * Gauss_point(1)%s(2) + & & mu_nod(i3) * Gauss_point(1)%s(3) t_sigma = mu_of_r_ mu_2 = t_sigma**2 V8(1,1) = mu_2 * 4./3. ! begin element covariance matrix (symmetric) V8(1,2) = 0.D0 V8(1,3) = mu_2 * (-2./3.) V8(2,1) = 0.D0 V8(2,2) = mu_2 V8(2,3) = 0.D0 V8(3,1) = V8(1,3) V8(3,2) = 0.D0 V8(3,3) = V8(1,1) epsilon_dot = 0. ! 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.) THEN PRINT "(' Error: center of element ',I5,' is N or S pole.')", l_ WRITE (21,"('Error: center of element ',I5,' is N or S pole.')") l_ STOP END IF theta = ATAN2(equat, tv(3)) sint = SIN(theta) csct = 1. / sint tant = TAN(theta) cott = 1. / tant W_LL = 0. ! just initializing, before sums (below) 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) rho_ = R * Arc_distance(tv1, tv2) W_LL = W_LL + rho_ / L0 ! N.B. This variable will not be used until after sum is complete. gamma_ = Get_azimuth (tv1, tv2) sense = local_crack(loc)%sense s_ =local_crack(loc)%s_ del_s_ = local_crack(loc)%sigma_ extra_weight = local_crack(loc)%extra_weight 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.5 * (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 == 'S') .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.5 * (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_vw') 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)/extra_weight) * local_crack(loc)%H(i) * & & local_crack(loc)%H(j) END DO END DO END DO ! z_ = 1, Z ! note that V8 should still be symmetric ! scale V matrix to prevent underflows V = V8 * 1.D30 ! eigen-analysis of V: !========================================================================================================================= ! IMSL version (see MKL version below): !CALL EVCRG (3, V, 3, eigenvalues, eigenvectors, 3) !! Compute all of the eigenvalues and eigenvectors of a real matrix. !! Usage: !! CALL EVCRG (N, A, LDA, EVAL, EVEC, LDEVEC) !! Arguments: !! N = Order of the matrix. (Input) !! A = Floating-point array containing the matrix. (Input) !! LDA = Leading dimension of A exactly as specified in the dimension statement of the calling program. (Input) !! EVAL = Complex array of size N containing the eigenvalues of A in decreasing order of magnitude. (Output) !! EVEC = Complex array containing the matrix of eigenvectors. (Output) !! The #h eigenvector, corresponding to EVAL(h), is stored in the #h column. Each vector is normalized to have !! Euclidean length equal to the value one. !! LDEVEC = Leading dimension of EVEC exactly as specified in the dimension statement of the calling program. (Input) !========================================================================================================================= ! MKL version (see IMSL version above): jobz = 'V' ! required when you want eigenvectors as well as eigenvalues uplo = 'U' ! although 'L' would also work lwork = 37 ! matching dimension coded above liwork = 18 ! matching dimension coded above CALL ssyevd(jobz, uplo, 3, V, 3, eigenvalues, work, lwork, iwork, liwork, info) ! using Fortran77 call because F95 call is buggy. IF (info /= 0) THEN WRITE (*, "(' ERROR: ssyevd of MKL could not solve eigenvalues/vectors of V'/' for element ',I6,'; info = ',I12)") l_, info CALL Traceback() END IF !Note: On return, each column of V is an eigenvector (h = 1, 2, 3): !DO h = 1, 3 ! eigenvectors(1:3, h) = V(1:3, h) !END DO eigenvectors = V ! NOTE: Since documentation is unclear, I also tried TRANSPOSE() here; but, it makes misfits larger. !========================================================================================================================= top_value = 0. ! just initializing, before search (below) DO h = 1, 3 ! the eigenvectors each define a new scalar datum ! undo the scaling applied previously to V lambda_(h) = 1.E-30 * eigenvalues(h) top_value = MAX(top_value, lambda_(h)) END DO DO h = 1,3 sigma_list(h) = SQRT(lambda_(h)) END DO DO h = 1,3 h_alt1 = 1 + MOD(h, 3) h_alt2 = 1 + MOD(h_alt1, 3) IF (lambda_(h) <= 0.) THEN ! prevent needless halts due to loss-of-precision IF (ABS(lambda_(h)) <= (0.01 * top_value)) THEN lambda_(h) = mu_2 ELSE CALL Prevent('nonpositive eigenvalue',185,'Solve for vw with MKL') END IF ! large or small negative eigenvalue END IF ! nonpositive eigenvalue (shouldn't happen) sigma_ = sigma_list(h) goal = 0. ! just initializing before sum (below) 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./R) * (dG(j,1,1,1) * Lambda(h, 1) + & & 0.5 * (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./R) * (dG(j,2,1,1) * Lambda(h, 1) + & & 0.5 * (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) W_A = a_(l_) / A0 W = MAX(W_LL, W_A) !W_LL = SUM(rho_)/L0 was computed in a loop just above, z_ = 1, Z. !This selection will normally return W_LL. !However, if an element has only one infinitesimally-long fault segment, !W_LL could become very small. In that case, we would not want the !element to lose its continuum stiffness. prefix = W / sigma_**2 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 mu_of_r_ = mu_nod(i1) * Gauss_point(m)%s(1) + & & mu_nod(i2) * Gauss_point(m)%s(2) + & & mu_nod(i3) * Gauss_point(m)%s(3) t_sigma = mu_of_r_ prefix = a_(l_) * one_over_A0R2 * 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.) THEN PRINT "(' Error: integration point ',I1,' of element ',I5,' is N or S pole.')", m, l_ WRITE (21,"('Error: integration point ',I1,' of element ',I5,' is N or S pole.')") m, l_ STOP END IF theta = ATAN2(equat, r_(3)) csct = 1. / SIN(theta) tant = TAN(theta) cott = 1. / 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; will be computed later ! 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 CALL Plug_in_33_for_MKL (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 ! initialize 3 different numerators (for N0, N1, N2): s_N0_sum = 0.0; s_N1_sum = 0.0; s_N2_sum = 0.0 ! initialize the common denominator for all 3 measures: s_error_count = 0.0 stressed_continuum_elements = 0 num_boxed = 0.0 IF (any_stress) THEN ! Insert stress constraints (different in each refinement) for NON-faulting elements DO l_ = 1, num_ele IF (ele_stressed(l_)) THEN ! Apply sigma_1h constraints only if element not faulting! ! Faulting elements are often anisotropic. ! Two examples from western USA: San Andreas has dextral slip even ! though it is almost orthogonal to sigma_1h in central California. ! Cascadia subduction zone has ENE-WSW shortening even though ! regional sigma_1h is N-S. (This is a case of layered stress guides.) ! When I once tried to apply boxing to faulting elements, ! the result was that the Cascadia subduction zone became locked, ! because then the E-W shortening was not allowed to exceed N-S shortening. IF (crack_index(1, l_) == 0) THEN stressed_continuum_elements = stressed_continuum_elements + 1 s_error_count = s_error_count + a_(l_) / A0 ! N.B. s_error_count is a REAL variable A = 0.; B = 0.; C = 0.; D = 0. E = 0.; F = 0. 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. / SIN(theta) tant = TAN(theta) cott = 1. / tant cos2g = COS(2. * ele_azim(l_)) sin2g = SIN(2. * ele_azim(l_)) prefix = 1. / (2. * 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 radius = SQRT(epsilon_dot(2)**2 + (0.5*(epsilon_dot(1)-epsilon_dot(3)))**2) ! units of /s sigma_perSecond = 2. * ele_sigma(l_) * radius ! desired value, ! without considering precision limits ! Guard against problems due to excessively small sigma_perSecond, ! to protect the condition number of the ABCD matrix, and the ! precision of the solution to the linear system. ! Since ABCD is REAL and has only 7 digits of precision, ! we must keep the condition number to under 10**(7-3) = 10**4 ! if we want to be sure the solution will have part-per-thousand precision !(e.g., 0.05 mm/a out of 50 mm/a in California). ! Now, a condition number of 10**4 means that (weight)/(sigma_perSecond**2) ! should not vary by more than 10**4, which means that when sigma_perSecond ! shrinks by more than 10**2 we may need to reduce the weight for these constraints. ! Since a very common sigma in the linear system is that of the stiff-continuum, ! with strain rates uncertainty of mu_ (around 1E-15 /s), ! effective sigma_perSecond should probably not be allowed to get smaller than ! about (1E-15 /s) / (10**2) = 1E-17 /s without decrease in weighting. ! This is in the neighborhood where xi_ is usually chosen (~ 3.2E-17 /s), so ! I will use xi_ as the lower limit on effective_sigma_perSecond, ! so as to give the user some limited control of this adjustment process: effective_sigma_perSecond = MAX(sigma_perSecond, xi_) ! limited on the low side prefix = (a_(l_) / A0) / (effective_sigma_perSecond**2) CALL Add_datum(prefix, f_, g_, 0.0D0, A, C, D, E, F) ! assess angular errors in sigma_1h azimuth = 0.5 * ATAN2F(epsilon_dot(2),0.5*(epsilon_dot(3)-epsilon_dot(1))) error = azimuth - ele_azim(l_) error = MIN(MOD(error + 6.2832, 3.1416), MOD(-error + 6.2832, 3.1416)) IF (radius > 0.0) THEN sigma_radians = sigma_perSecond / (2.0 * radius) ELSE sigma_radians = 1.0 END IF IF (ABS(error) > (2.0 * sigma_radians)) s_N0_sum = s_N0_sum + a_(l_) / A0 s_N1_sum = s_N1_sum + (a_(l_) / A0) * ABS(error) / sigma_radians s_N2_sum = s_N2_sum + (a_(l_) / A0) * (error / sigma_radians)**2 ! epsilon_alpha_alpha < epsilon_beta_beta IF ((3 * pass) > (2 * passes)) THEN ! don't allow boxing until last-3rd of run, when solution ~ stable. IF (((epsilon_dot(3) - epsilon_dot(1)) * cos2g + 2.0 * epsilon_dot(2) * sin2g) < 0.) boxed(l_) = .TRUE. END IF IF (boxed(l_)) THEN ! Needs constraint to enforce correct sense num_boxed = num_boxed + 1 prefix = 1. / 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 = (a_(l_) / A0) / (0.83 * xi_)**2 CALL Add_datum(prefix, f_, g_, (1.0D0 * xi_), A, C, D, E, F) END IF ! boxed(l_): sense constraint needed CALL Plug_in_33_for_MKL (l_, A, B, C, D, E, F) ! add element matrix,vector to global END IF ! element is NOT faulting END IF ! ele_stressed(l_) END DO ! l_ = 1, num_ele END IF ! any_stress IF (internal_benchmarks > 0) THEN ! add geodetic constraints ! Correct from observed benchmark_vw --> (estimated) benchmark_unlocked_vw IF (f_dat_count > 0) THEN benchmark_unlocked_vw = benchmark_vw ! whole array; initialize before summing small corrections DO i = 1, f_dat_count !depths of top and bottom of the locked patch: ztop = 0.0 ! Was: "ztop = f_locking_depth_m_min(i)" in NeoKinema versions before 2.3 zbot = f_locking_depth_m_max(i) !Note that these were already converted from km-->m, and replaced with default values if negative, in the input section. IF ((.NOT.f_creeping(i)).AND.(zbot > ztop)) THEN ! compute correction only if locked area is positive!!! !Fault dip !Note: The forward direction is the digitizing direction, which is L-->R on the footwall side; ! thus dips measured from the RHS are all 90~175 degrees (but, converted to radians). dipf = 3.1415927 - (f_dat_dip_degrees(i) * radians_per_degree) !Slip-rate, in m/s, in the (x1, x2, x3) coordinate system of Aura, in which: ! x1 is along the trace, and the sliprate is positive if sinistral; ! x2 is horizontal and perpendicular to trace, sliprate is positive if divergent; ! x3 is down, and sliprate is positive when the RHS (looking in the forward direction) moves relatively down. IF (conservative_geodetic_adjustment) THEN ! !the fault slip rate used for coseismic adjustment is fixed at the geologic slip rate: rate_mps = f_offset_rate(i) ! in m/s; heave or throw depends on f_sense(i) ELSE ! use self-consistent method (less stable, but preferable if it converges): IF (pass == 1) THEN ! no model estimate available yet rate_mps = f_offset_rate(i) ! in m/s; heave or throw depends on f_sense(i) f_old_model_offset_rate(i) = rate_mps ! remember for damping next time ELSE ! subsequent iterations; use damped version of current model rate: rate_mps = 0.5 * f_model_offset_rate(i) + 0.5 * f_old_model_offset_rate(i) f_old_model_offset_rate(i) = rate_mps ! remember for damping next time END IF ! pass == 1, or later END IF ! conservative_geodetic_adjustment, or not IF (rate_mps /= 0.0) THEN ! contribution of this fault trace to geodetic adjustment is non-zero: IF (f_sense(i) == 'L') THEN sliprate_mps_x1x2x3(1) = rate_mps sliprate_mps_x1x2x3(2) = 0.0 sliprate_mps_x1x2x3(3) = 0.0 ELSE IF (f_sense(i) == 'R') THEN sliprate_mps_x1x2x3(1) = -rate_mps sliprate_mps_x1x2x3(2) = 0.0 sliprate_mps_x1x2x3(3) = 0.0 ELSE IF (f_sense(i) == 'D') THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = rate_mps sliprate_mps_x1x2x3(3) = rate_mps * TAN(dipf) ELSE IF (f_sense(i) == 'N') THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = rate_mps / ABS(TAN(dipf)) sliprate_mps_x1x2x3(3) = -rate_mps ELSE IF (f_sense(i) == 'T') THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = -rate_mps / ABS(TAN(dipf)) sliprate_mps_x1x2x3(3) = rate_mps ELSE IF ((f_sense(i) == 'P').OR.(f_sense(i) == 'S')) THEN sliprate_mps_x1x2x3(1) = 0.0 sliprate_mps_x1x2x3(2) = -rate_mps sliprate_mps_x1x2x3(3) = -rate_mps * TAN(dipf) END IF k = which_trace(i) IF (trace_loc(3, k) > 0) THEN ! trace has at least one segment in the .feg area n1 = trace_loc(3, k) n2 = trace_loc(4, k) ! first and last segments associated with this trace DO n = n1, n2 ! segment index tv1(1:3) = seg_end(1:3, 1, n) ! Cartesian unit vector of initial point tv2(1:3) = seg_end(1:3, 2, n) ! and final point of this segment tv(1:3) = (tv1(1:3) + tv2(1:3)) / 2. ! location of midpoint fphi = ATAN2F(tv(2), tv(1)) ! phi, or longitude, in radians ftheta = ATAN2F(SQRT(tv(1)**2 + tv(2)**2), tv(3)) ! theta, or colatitude, in radians lf = 0.5D0 * R * SQRT((tv2(1)-tv1(1))**2 + (tv2(2)-tv1(2))**2 + (tv2(3)-tv1(3))**2) ! half-length, in m argume = 3.14159 - Get_Azimuth(tv1, tv2) ! radians counterclockwise from +theta (South) DO j = 1, internal_benchmarks !IF ((seg_def(1,n) == 430).AND.(seg_def(2,n) == 8953)) THEN ! IF (benchmark_name(j)(1:4) == "PICO") THEN ! WRITE (21, "(/'This segment is part of trace 0430 and lies in element 8953:')") ! WRITE (21, "('Inputs to CALL Change for benchmark PICO:')") ! WRITE (21, "('argume = ',ES12.4)") argume ! WRITE (21, "('btheta = ',ES12.4)") benchmark_theta(j) ! WRITE (21, "('bphi = ',ES12.4)") benchmark_phi(j) ! WRITE (21, "('dipf = ',ES12.4)") dipf ! WRITE (21, "('lf = ',ES12.4)") lf ! WRITE (21, "('ftheta = ',ES12.4)") ftheta ! WRITE (21, "('fphi = ',ES12.4)") fphi ! WRITE (21, "('radius = ',ES12.4)") R ! WRITE (21, "('slip(1)= ',ES12.4)") sliprate_mps_x1x2x3(1) ! WRITE (21, "('slip(2)= ',ES12.4)") sliprate_mps_x1x2x3(2) ! WRITE (21, "('slip(3)= ',ES12.4)") sliprate_mps_x1x2x3(3) ! WRITE (21, "('wedge = 0.2618')") ! WRITE (21, "('ztop = ',ES12.4)") ztop ! WRITE (21, "('zbot = ',ES12.4)") zbot ! END IF !END IF CALL Change (argume = argume, & & btheta = benchmark_theta(j), bphi = benchmark_phi(j), & & dipf = dipf, lf = lf, & & ftheta = ftheta, fphi = fphi, & & radius = R, & & slip = sliprate_mps_x1x2x3, & & wedge = 0.2618, & & ztop = ztop, zbot = zbot, & ! inputs & duthet = duthet, duphi = duphi) ! output !IF ((seg_def(1,n) == 430).AND.(seg_def(2,n) == 8953)) THEN ! IF (benchmark_name(j)(1:4) == "PICO") THEN ! WRITE (21, "('Output from CALL Change for benchmark PICO:')") ! WRITE (21, "('duthet = ',ES12.4)") duthet ! WRITE (21, "('duphi = ',ES12.4)") duphi ! END IF !END IF ! For a typical year with no earthquakes, ! correct the observed benchmark velocities ! by adding the (estimated) missing coseismic part: benchmark_unlocked_vw(2 * j - 1) = benchmark_unlocked_vw(2 * j - 1) + duthet benchmark_unlocked_vw(2 * j ) = benchmark_unlocked_vw(2 * j ) + duphi END DO ! j = 1, internal_benchmarks END DO ! n = n1, n2; segment index END IF ! trace_loc(3, k) > 0; trace has at least one segment in the .feg area END IF ! rate_mpa /= 0.0 for this trace END IF ! zbot > ztop, so locked area is positive END DO ! i = 1, f_dat_count ELSE ! no faults to correct for! benchmark_unlocked_vw = benchmark_vw ! whole array; no correction performed END IF ! f_dat_count > 0 (fault locking to correct for), or not ! Add geodetic information to odd (v) rows of the linear system, ! per notes of 2002.07.31, page 3 IF (using_GPS_matrices) THEN DO i_geodetic = 1, geodetic_nDOF ! equivalent to i of 2002.07.31 notes benchmark_i = (i_geodetic + 1) / 2 l_i = benchmark_is(benchmark_i)%element i_node(1:3) = node(1:3, l_i) ! equivalent to i1, i2, i3 of 2002.07.31 notes IF (Odd(i_geodetic)) THEN fi(1:3) = benchmark_G(1:3, 1, 1, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 1, benchmark_i) ELSE ! i_geodetic is even fi(1:3) = benchmark_G(1:3, 1, 2, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 2, benchmark_i) END IF ! i_geodetic is odd or even DO j_geodetic = 1, geodetic_nDOF ! equivalent to j of 2002.07.31 notes benchmark_j = (j_geodetic + 1) / 2 l_j = benchmark_is(benchmark_j)%element j_node(1:3) = node(1:3, l_j) ! equivalent to j1, j2, j3 of 2002.07.31 notes IF (Odd(j_geodetic)) THEN fj(1:3) = benchmark_G(1:3, 1, 1, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 1, benchmark_j) ELSE ! j_geodetic is even fj(1:3) = benchmark_G(1:3, 1, 2, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 2, benchmark_j) END IF ! j_geodetic is odd or even half_N = 0.5D0 * normal(i_geodetic, j_geodetic) DO k = 1, 3 ! (subscript of fi, gi, fj, gj, i_node, j_node) i = 2 * j_node(k) - 1 ! row of linear system (odd) EF(i, 1) = EF(i, 1) + half_N * fj(k) * benchmark_unlocked_vw(i_geodetic) ! <=== unique to MKL version DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * i_node(m) - 1 ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * fj(k) * fi(m) ! <=== unique to MKL version j = 2 * i_node(m) ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * fj(k) * gi(m) ! <=== unique to MKL version END DO ! m = 1, 3 (subscript within horizontal group of 6) i = 2 * i_node(k) - 1 ! row of linear system (odd) EF(i, 1) = EF(i, 1) + half_N * fi(k) * benchmark_unlocked_vw(j_geodetic) ! <=== unique to MKL version DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * j_node(m) - 1 ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * fi(k) * fj(m) ! <=== unique to MKL version j = 2 * j_node(m) ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * fi(k) * gj(m) ! <=== unique to MKL version END DO ! m = 1, 3 (subscript within horizontal group of 6) END DO ! k = 1, 3 (subscript of fi, gi, fj, gj, i_node, j_node) END DO ! j_geodetic = 1, geodetic_nDOF END DO ! i_geodetic = 1, geodetic_nDOF ! Add geodetic information to even (w) rows of the linear system, ! per notes of 2002.07.31, page 4 DO i_geodetic = 1, geodetic_nDOF ! equivalent to i of 2002.07.31 notes benchmark_i = (i_geodetic + 1) / 2 l_i = benchmark_is(benchmark_i)%element i_node(1:3) = node(1:3, l_i) ! equivalent to i1, i2, i3 of 2002.07.31 notes IF (Odd(i_geodetic)) THEN fi(1:3) = benchmark_G(1:3, 1, 1, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 1, benchmark_i) ELSE ! i_geodetic is even fi(1:3) = benchmark_G(1:3, 1, 2, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 2, benchmark_i) END IF ! i_geodetic is odd or even DO j_geodetic = 1, geodetic_nDOF ! equivalent to j of 2002.07.31 notes benchmark_j = (j_geodetic + 1) / 2 l_j = benchmark_is(benchmark_j)%element j_node(1:3) = node(1:3, l_j) ! equivalent to j1, j2, j3 of 2002.07.31 notes IF (Odd(j_geodetic)) THEN fj(1:3) = benchmark_G(1:3, 1, 1, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 1, benchmark_j) ELSE ! j_geodetic is even fj(1:3) = benchmark_G(1:3, 1, 2, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 2, benchmark_j) END IF ! j_geodetic is odd or even half_N = 0.5D0 * normal(i_geodetic, j_geodetic) DO k = 1, 3 ! (subscript of fi, gi, fj, gj, i_node, j_node) i = 2 * j_node(k) ! row of linear system (even) EF(i, 1) = EF(i, 1) + half_N * gj(k) * benchmark_unlocked_vw(i_geodetic) ! <=== unique to MKL version DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * i_node(m) - 1 ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * gj(k) * fi(m) ! <=== unique to MKL version j = 2 * i_node(m) ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * gj(k) * gi(m) ! <=== unique to MKL version END DO ! m = 1, 3 (subscript within horizontal group of 6) i = 2 * i_node(k) ! row of linear system (even) EF(i, 1) = EF(i, 1) + half_N * gi(k) * benchmark_unlocked_vw(j_geodetic) ! <=== unique to MKL version DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * j_node(m) - 1 ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * gi(k) * fj(m) ! <=== unique to MKL version j = 2 * j_node(m) ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * gi(k) * gj(m) ! <=== unique to MKL version END DO ! m = 1, 3 (subscript within horizontal group of 6) END DO ! k = 1, 3 (subscript of fi, gi, fj, gj, i_node, j_node) END DO ! j_geodetic = 1, geodetic_nDOF END DO ! i_geodetic = 1, geodetic_nDOF ELSE ! .NOT. using_GPS_matrices; using many benchmark_covariance's and benchmark_normal's instead: DO benchmark_i = 1, internal_benchmarks ! intentional half-indent (2 spaces), so copied lines within don't shift l_i = benchmark_is(benchmark_i)%element ! All statements in this group moved up (out of other loops). i_node(1:3) = node(1:3, l_i) ! equivalent to i1, i2, i3 of 2002.07.31 notes benchmark_j = benchmark_i l_j = benchmark_is(benchmark_j)%element j_node(1:3) = node(1:3, l_j) ! equivalent to j1, j2, j3 of 2002.07.31 notes DO i_geodetic = 1, 2 ! equivalent to i of 2002.07.31 notes IF (Odd(i_geodetic)) THEN fi(1:3) = benchmark_G(1:3, 1, 1, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 1, benchmark_i) ELSE ! i_geodetic is even fi(1:3) = benchmark_G(1:3, 1, 2, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 2, benchmark_i) END IF ! i_geodetic is odd or even DO j_geodetic = 1, 2 ! equivalent to j of 2002.07.31 notes IF (Odd(j_geodetic)) THEN fj(1:3) = benchmark_G(1:3, 1, 1, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 1, benchmark_j) ELSE ! j_geodetic is even fj(1:3) = benchmark_G(1:3, 1, 2, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 2, benchmark_j) END IF ! j_geodetic is odd or even !half_N = 0.5D0 * normal(i_geodetic, j_geodetic) half_N = 0.5D0 * benchmark_normal(i_geodetic, j_geodetic, benchmark_i) ! benchmark_j = benchmark_i DO k = 1, 3 ! (subscript of fi, gi, fj, gj, i_node, j_node) i = 2 * j_node(k) - 1 ! row of linear system (odd) EF(i, 1) = EF(i, 1) + half_N * fj(k) * benchmark_unlocked_vw(2*(benchmark_i-1)+i_geodetic) ! <=== unique to MKL version DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * i_node(m) - 1 ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * fj(k) * fi(m) ! <=== unique to MKL version j = 2 * i_node(m) ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * fj(k) * gi(m) ! <=== unique to MKL version END DO ! m = 1, 3 (subscript within horizontal group of 6) i = 2 * i_node(k) - 1 ! row of linear system (odd) EF(i, 1) = EF(i, 1) + half_N * fi(k) * benchmark_unlocked_vw(2*(benchmark_i-1)+j_geodetic) ! <=== unique to MKL version DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * j_node(m) - 1 ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * fi(k) * fj(m) ! <=== unique to MKL version j = 2 * j_node(m) ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * fi(k) * gj(m) ! <=== unique to MKL version END DO ! m = 1, 3 (subscript within horizontal group of 6) END DO ! k = 1, 3 (subscript of fi, gi, fj, gj, i_node, j_node) END DO ! j_geodetic = 1, 2 END DO ! i_geodetic = 1, 2 ! Add geodetic information to even (w) rows of the linear system, ! per notes of 2002.07.31, page 4 DO i_geodetic = 1, 2 ! equivalent to i of 2002.07.31 notes IF (Odd(i_geodetic)) THEN fi(1:3) = benchmark_G(1:3, 1, 1, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 1, benchmark_i) ELSE ! i_geodetic is even fi(1:3) = benchmark_G(1:3, 1, 2, benchmark_i) gi(1:3) = benchmark_G(1:3, 2, 2, benchmark_i) END IF ! i_geodetic is odd or even DO j_geodetic = 1, 2 ! equivalent to j of 2002.07.31 notes IF (Odd(j_geodetic)) THEN fj(1:3) = benchmark_G(1:3, 1, 1, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 1, benchmark_j) ELSE ! j_geodetic is even fj(1:3) = benchmark_G(1:3, 1, 2, benchmark_j) gj(1:3) = benchmark_G(1:3, 2, 2, benchmark_j) END IF ! j_geodetic is odd or even !half_N = 0.5D0 * normal(i_geodetic, j_geodetic) half_N = 0.5D0 * benchmark_normal(i_geodetic, j_geodetic, benchmark_i) ! benchmark_j = benchmark_i DO k = 1, 3 ! (subscript of fi, gi, fj, gj, i_node, j_node) i = 2 * j_node(k) ! row of linear system (even) EF(i, 1) = EF(i, 1) + half_N * gj(k) * benchmark_unlocked_vw(2*(benchmark_i-1)+i_geodetic) ! <=== unique to MKL version DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * i_node(m) - 1 ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * gj(k) * fi(m) ! <=== unique to MKL version j = 2 * i_node(m) ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * gj(k) * gi(m) ! <=== unique to MKL version END DO ! m = 1, 3 (subscript within horizontal group of 6) i = 2 * i_node(k) ! row of linear system (even) EF(i, 1) = EF(i, 1) + half_N * gi(k) * benchmark_unlocked_vw(2*(benchmark_i-1)+j_geodetic) ! <=== unique to MKL version DO m = 1, 3 ! (subscript within horizontal group of 6) j = 2 * j_node(m) - 1 ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * gi(k) * fj(m) ! <=== unique to MKL version j = 2 * j_node(m) ! column of linear system it = MKLdRow + i - j ABCD(it, j) = ABCD(it, j) + half_N * gi(k) * gj(m) ! <=== unique to MKL version END DO ! m = 1, 3 (subscript within horizontal group of 6) END DO ! k = 1, 3 (subscript of fi, gi, fj, gj, i_node, j_node) END DO ! j_geodetic = 1, 2 END DO ! i_geodetic = 1, 2 END DO ! benchmark_i[and _j] = 1, internal_benchmarks ! intentional half-indent (2 spaces), so copied lines within don't shift END IF ! using_GPS_matrices, or not (in which case, using benchmark_normal's intead). END IF ! internal_benchmarks > 0 (geodetic constraints) ! Scale linear system (to prevent overflow/underflow) big_one = MAXVAL(ABCD) ! <=== unique to MKL version factor = 1.0D0/big_one !WRITE (*, "(' Largest element in ABCD is ',ES12.3,'; scaling by factor = ',ES12.3)") big_one, factor IF ((factor == 0.0D0).OR.(big_one >= (0.001D0 * HUGE(big_one)))) THEN WRITE (*, "(' Largest element in ABCD is ',ES12.3,'; scaling by factor = ',ES12.3)") big_one, factor WRITE (*, "(' ERROR: Probable /0. during assembly of ABCD.')") ij_Infinity = MAXLOC(ABCD) it = ij_Infinity(1) j = ij_Infinity(2) i = it - MKLdRow + j WRITE (*, "(' Logical location of (1st) Infinity is at ABCD(',I7,', ',I7,') = ',ES12.3,',')") i, j, ABCD(it, j) i = (i + 1) / 2 j = (j + 1) / 2 WRITE (*, "(' corresponding to (node, node) pair (',I7,', ',I7,')')") i, j CALL Pause() STOP END IF ABCD = factor * ABCD ! <=== unique to MKL version EF = factor * EF ! <=== unique to MKL version ! Impose boundary conditions, NOT maintaining symmetry, and changing both lower and upper codiagonals: ! <=== unique to MKL version DO m = 1, bcs_count ! South (theta) component of velocity k = 2 * boundary_node(m) - 1 ! row to be replaced i = k ! work on this row DO j = MAX(1, i - nCoDa), MIN(nDOF, i + nCoDa) ! entire row ! <=== unique to MKL version it = MKLdRow + i - j ! <=== unique to MKL version ABCD(it, j) = 0.0D0 ! <=== unique to MKL version END DO ABCD(MKLdRow, k) = 1.0D0 ! put 1 on diagonal ! <=== unique to MKL version EF(k, 1) = condition(1, m) ! put BC velocity component in rhs ! <=== unique to MKL version ! East (phi) component of velocity k = 2 * boundary_node(m) ! row to be replaced i = k ! work on this row DO j = MAX(1, i - nCoDa), MIN(nDOF, i + nCoDa) ! entire row ! <=== unique to MKL version it = MKLdRow + i - j ! <=== unique to MKL version ABCD(it, j) = 0.0D0 ! <=== unique to MKL version END DO ABCD(MKLdRow, k) = 1.0D0 ! put 1 on diagonal ! <=== unique to MKL version EF(k, 1) = condition(2, m) ! put BC velocity component in rhs ! <=== unique to MKL version END DO ! on boundary node index m !solve banded linear system for node velocities (2-vectors): !============================================================================================= ! IMSL version (see MKL version below): !CALL DLSLPB (nDOF, ABCDEF, lda, nCoDa, ijob, u_flag) !! Usage: !! CALL DLSLPB (N, A, LDA, nCoDa, IJOB, U) !! Arguments: !! N = Order of the matrix. (Input) !! Must satisfy N > 0. !! A = Array containing the N by N positive definite band coefficient !! matrix and right hand side in MS-IMSL's !! codiagonal band symmetric storage mode. (Input/Output) !! The number of array columns must be at least nCoDa + 2. !! The number of columns is not an input to this subprogram. !! LDA = Leading dimension of A exactly as specified in the !! dimension statement of the calling program. (Input) !! Must satisfy LDA >= N + nCoDa. !! nCoDa = Number of upper codiagonals of matrix A. (Input) !! Must satisfy nCoDa >= 0 and nCoDa < N. !! IJOB = Flag to direct the desired factorization or solving step. (Input) !! IJOB Meaning: !! 1 factor the matrix A and solve the system Ax = b, where b is stored in column nCoDa + 2 of array A. !! The vector x overwrites b in storage. !! 2 solve step only. Use b as column nCoDa + 2 of A. (The factorization step has already been done.) !! The vector x overwrites b in storage. !! 3 factor the matrix A but do not solve a system. !! 4,5,6 same meaning as with the value IJOB - 3. For efficiency, no !! error checking is done on values LDA, N, nCoDa, and U(*). !! U = Array of flags that indicate any singularities of A, namely loss of positive-definiteness of a leading minor. (Output) !! A value U(I) = 0. means that the leading minor of dimension I is not positive-definite. Otherwise, U(I) = 1. !! Comments: !! Automatic workspace usage is: nCoDa real numbers. !IF (passes > 0) THEN ! ! Compare new with old solution ! sum_base_o = 0. ! sum_base_n = 0. ! sum_diff = 0. ! big_diff = 0. ! big_diff_node = 0 ! DO i = 1, num_nod ! twoi = 2 * i ! wo = vw(twoi) ! wn = ABCDEF(EFrow(twoi), EFcol) ! <==== unique to IMSL version ! twoi = twoi - 1 ! vo = vw(twoi) ! vn = ABCDEF(EFrow(twoi), EFcol) ! <==== unique to IMSL version ! 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 ! diff = SQRT((vn - vo)**2 + (wn - wo)**2) ! IF (diff > big_diff) THEN ! big_diff = diff ! big_diff_node = i ! END IF ! 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.) THEN ! dV_frac = difference / divisor ! ELSE ! dV_frac = 0. ! END IF ! IF (any_stress) THEN ! stressed_frac = (100. * stressed_continuum_elements) / num_ele ! boxed_frac = (100. * num_boxed) / num_ele ! IF (s_error_count > 0.) THEN ! s_err(0) = s_N0_sum / s_error_count ! s_err(1) = s_N1_sum / s_error_count ! s_err(2) = SQRT( s_N2_sum / s_error_count ) ! ELSE ! s_err = 0. ! all 3 values ! END IF ! PRINT "(' ',4X,I10,F8.5,1P,E11.4,I6,3X,0P,F8.2,'%',F7.2,'%',F11.3)", & ! & pass-1, dV_frac, new_V, n_brackets_tightened, stressed_frac, boxed_frac, s_err(1) ! WRITE (21,"(4X,I10,F8.5,1P,E11.4,I6,3X,0P,F8.2,'%',F7.2,'%',F11.3)") & ! & pass-1, dV_frac, new_V, n_brackets_tightened, stressed_frac, boxed_frac, s_err(1) ! ELSE ! PRINT "(' ',4X,I10,F8.5,1P,E11.4,I6)", & ! & pass-1, dV_frac, new_V, n_brackets_tightened ! WRITE (21,"(4X,I10,F8.5,1P,E11.4,I6)") & ! & pass-1, dV_frac, new_V, n_brackets_tightened ! END IF ! any_stress !END IF ! passes > 1 (or 0?) !! Transfer solution to velocity supervector !DO i = 1, nDOF ! vw(i) = ABCDEF(EFrow(i), EFcol) ! <=== unique to IMSL version !END DO !============================================================================================= ! MKL version (see IMSL version above): ldab = (nCoDa + (nCoDa + 1 + nCoDa)) CALL dgbsv(nDOF, nCoDa, nCoDa, 1, ABCD, ldab, ipiv, EF, nDOF, info) ! using Fortran77 CALL because F95 CALL is buggy. IF (info /= 0) THEN WRITE (*, "(' ERROR: info = ',I12,' in call to dgbsv.')") info CALL Traceback() END IF IF (passes > 0) THEN ! Compare new with old solution sum_base_o = 0. sum_base_n = 0. sum_diff = 0. big_diff = 0. big_diff_node = 0 DO i = 1, num_nod twoi = 2 * i wo = vw(twoi) wn = EF(twoi, 1) ! <==== unique to MKL version twoi = twoi - 1 vo = vw(twoi) vn = EF(twoi, 1) ! <==== unique to MKL version 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 diff = SQRT((vn - vo)**2 + (wn - wo)**2) IF (diff > big_diff) THEN big_diff = diff big_diff_node = i END IF 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.) THEN dV_frac = difference / divisor ELSE dV_frac = 0. END IF IF (any_stress) THEN stressed_frac = (100. * stressed_continuum_elements) / num_ele boxed_frac = (100. * num_boxed) / num_ele IF (s_error_count > 0.) THEN s_err(0) = s_N0_sum / s_error_count s_err(1) = s_N1_sum / s_error_count s_err(2) = SQRT( s_N2_sum / s_error_count ) ELSE s_err = 0. ! all 3 values END IF PRINT "(' ',4X,I10,F8.5,1P,E11.4,I6,3X,0P,F8.2,'%',F7.2,'%',F11.3)", & & pass-1, dV_frac, new_V, n_brackets_tightened, stressed_frac, boxed_frac, s_err(1) WRITE (21,"(4X,I10,F8.5,1P,E11.4,I6,3X,0P,F8.2,'%',F7.2,'%',F11.3)") & & pass-1, dV_frac, new_V, n_brackets_tightened, stressed_frac, boxed_frac, s_err(1) ELSE PRINT "(' ',4X,I10,F8.5,1P,E11.4,I6)", & & pass-1, dV_frac, new_V, n_brackets_tightened WRITE (21,"(4X,I10,F8.5,1P,E11.4,I6)") & & pass-1, dV_frac, new_V, n_brackets_tightened END IF ! any_stress END IF ! passes >= 1 (or 0?) ! Transfer solution to velocity supervector DO i = 1, nDOF vw(i) = EF(i, 1) ! <==== unique to MKL version END DO !============================================================================================= IF (dump_all_solutions) THEN WRITE (22, "('Pass ',I6)") pass DO i = 1, num_nod WRITE (22, "(i8,2ES12.4)") i, vw(2*i-1), vw(2*i) END DO END IF OK_to_stop = (passes > 1) .AND. (dV_frac < 0.00001) ! minimum condition for stopping iterations: stable velocity solution IF (f_dat_count > 0) OK_to_stop = OK_to_stop .AND. (pass > (passes/3)) ! must at least get to the 1st "bracketing" step IF (any_stress) OK_to_stop = OK_to_stop .AND. (pass > ((2*passes)/3)) ! must at least get to the 1st "boxing" step IF (OK_to_stop) EXIT many_passes END DO many_passes ! pass = 1, passes big_diff_mmpa = big_diff * 1000. * s_per_year ! using global parameter PRINT "(' ',4X,'Largest change is ',ES10.2,' = ',F10.3,' mm/a at node ',I8)", big_diff, big_diff_mmpa, big_diff_node WRITE (21,"(4X,'Largest change is ',ES10.2,' = ',F10.3,' mm/a at node ',I8)") big_diff, big_diff_mmpa, big_diff_node PRINT "(' ',4X,'If convergence is not satisfactory, even after 30~45 iterations,')" PRINT "(' ',4X,'then run program Analyze_Velocity_Evolution to get insight.')" WRITE (21,"(4X,'If convergence is not satisfactory, even after 30~45 iterations,')") WRITE (21,"(4X,'then run program Analyze_Velocity_Evolution to get insight.')") IF (.NOT.conservative_geodetic_adjustment) THEN PRINT "(' ',4X,'Also consider setting input parameter')" PRINT "(' ',4X,'conservative_geodetic_adjustment to TRUE.')" WRITE (21,"(4X,'Also consider setting input parameter')") WRITE (21,"(4X,'conservative_geodetic_adjustment to TRUE.')") END IF IF ((xi_ / 3.2E-17) < 0.5) THEN PRINT "(' ',4X,'Also consider setting input parameter xi_')" PRINT "(' ',4X,'to a larger value (but still below input parameter mu_).')" WRITE (21,"(4X,'Also consider setting input parameter xi_')") WRITE (21,"(4X,'to a larger value (but still below input parameter mu_).')") END IF PRINT "(' ','Finished computing velocities at nodes.')" WRITE (21,"('Finished computing velocities at nodes.')") END SUBROUTINE Solve_for_vw_with_MKL SUBROUTINE Unitise (b_, unit_vec) REAL, DIMENSION(3), INTENT(IN) :: b_ REAL, DIMENSION(3), INTENT(OUT) :: unit_vec REAL :: length length = Magnitude (b_) IF (length /= 0.) THEN unit_vec(1) = b_(1)/length unit_vec(2) = b_(2)/length unit_vec(3) = b_(3)/length ELSE unit_vec(1) = 1. unit_vec(2) = 0. unit_vec(3) = 0. END IF END SUBROUTINE Unitise SUBROUTINE Unsafe_Benchmarks (f_offset_rate, tabulate, & ! variable inputs & unsafe_GPS_count ) ! output to calling program !Tests for any internal benchmarks in the same finite-element with a fast-moving fault, !and counts the number of such unsafe benchmarks. !IF (tabulate), also produces a table of unsafe benchmarks, sent to both * (screen) and unit 21 (log file). !Note that almost all of the inputs to this routine are constant references to global variables and arrays; !only the variable inputs and the one output are listed in the argument list. !It is intended that this routine will be called 4 times per run of NeoKinema: ! (1) Preliminary prospective test, to see if a table is needed. ! (2) Recorded prospective test, producing a table. ! (3) Preliminary retrospective test, to see if a table is needed. ! (4) Recorded retrospective test, producing a table. IMPLICIT NONE REAL, DIMENSION(:), INTENT(IN) :: f_offset_rate ! changed to f_model_offset_rate for retrospective test LOGICAL, INTENT(IN) :: tabulate INTEGER, INTENT(OUT) :: unsafe_GPS_count CHARACTER(4) :: c4 CHARACTER(6) :: FF1_c6 ! e.g., "F0079R" INTEGER :: element, ib, jdate, k, kseg LOGICAL :: unsafe REAL :: bench_lat, bench_lon REAL :: one_mmpa_in_mps = 0.001/s_per_year REAL, DIMENSION(3) :: uvec IF (tabulate) THEN ! print header lines WRITE (*, *) WRITE (*, "(' CAUTION: Found unsafe benchmarks, defined as any located in')") WRITE (*, "(' the same finite-element with any fast-slipping ( >1 mm/a ) fault.')") WRITE (*, "(' E_longitude N_latitude Element FastFault1 Benchmark')") WRITE (*, "(' ----------- ---------- ------- ---------- -------------')") WRITE (21, *) WRITE (21, "('CAUTION: Found unsafe benchmarks, defined as any located in')") WRITE (21, "('the same finite-element with any fast-slipping ( >1 mm/a ) fault.')") WRITE (21, "('E_longitude N_latitude Element FastFault1 Benchmark')") WRITE (21, "('----------- ---------- ------- ---------- -------------')") END IF unsafe_GPS_count = 0 ! just initializing this sum DO ib = 1, internal_benchmarks unsafe = .FALSE. ! just initializing; may change uvec(1:3) = benchmark_uvec(1:3, ib) CALL Uvec_2_LonLat(uvec, bench_lon, bench_lat) ! precomputed to assist in debugging; may not be used element = benchmark_is(ib)%element dating: DO jdate = 1, f_dat_count IF (f_offset_rate(jdate) >= one_mmpa_in_mps) THEN WRITE (c4, "(I4)") which_trace(jdate) DO k = 1, 4 IF (c4(k:k) == ' ') c4(k:k) = '0' END DO FF1_c6 = 'F' // c4 // f_sense(jdate) ! precomputed to assist in debugging; may not be used DO kseg = 1, seg_count IF ((seg_def(1, kseg) == which_trace(jdate)).AND. & &(seg_def(2, kseg) == element)) THEN ! blowing the whistle unsafe = .TRUE. EXIT dating END IF ! blowing the whistle END DO ! kseg = 1, seg_count END IF ! this fault datum has offset rate > 1 mm/a END DO dating ! jdate = 1, f_dat_count IF (unsafe) THEN unsafe_GPS_count = unsafe_GPS_count + 1 IF (tabulate) THEN WRITE (*,"(' ',F11.3,2X,F10.3,2X,I7,4X,A6,4X,A)") & & bench_lon, bench_lat, element, FF1_c6, TRIM(benchmark_name(ib)) WRITE (21, "(F11.3,2X,F10.3,2X,I7,4X,A6,4X,A)") & & bench_lon, bench_lat, element, FF1_c6, TRIM(benchmark_name(ib)) END IF ! tabulate END IF ! unsafe END DO ! ib = 1, internal_benchmarks IF (tabulate) THEN WRITE (*, "(' ----------- ---------- ------- ---------- -------------')") WRITE (*, "(' Such coincidences may cause errors in the velocity solution')") WRITE (*, "(' (and fault heave-rate solution) which are comparable in size')") WRITE (*, "(' to the fault heave rate!')") WRITE (*, "(' I suggest that you stop now, and either:')") WRITE (*, "(' (1) edit the .FEG in OrbWin to shrink these elements,')") WRITE (*, "(' using utility program GPS_2_DIG to plot benchmarks; or')") WRITE (*, "(' (2) delete these benchmarks from the .GPS & .GP2 (if any),')") WRITE (*, "(' using utility program Delete_Cracked_Benchmarks; or')") WRITE (*, "(' (3) move these benchmarks outside these elements.')") WRITE (*, *) WRITE (21, "('----------- ---------- ------- ---------- -------------')") WRITE (21, "('Such coincidences may cause errors in the velocity solution')") WRITE (21, "('(and fault heave-rate solution) which are comparable in size')") WRITE (21, "('to the fault heave rate!')") WRITE (21, "('I suggest that you stop now, and either:')") WRITE (21, "(' (1) edit the .FEG in OrbWin to shrink these elements,')") WRITE (21, "(' using utility program GPS_2_DIG to plot benchmarks; or')") WRITE (21, "(' (2) delete these benchmarks from the .GPS & .GP2 (if any),')") WRITE (21, "(' using utility program Delete_Cracked_Benchmarks; or')") WRITE (21, "(' (3) move these benchmarks outside these elements.')") WRITE (21, *) END IF END SUBROUTINE Unsafe_Benchmarks SUBROUTINE Upper_Case (string) !Modifies its sole argument so that a..z --> A..Z !Useful* as a filter applied to filenames, before testing ! for a match (*at least, on Windows systems!) IMPLICIT NONE CHARACTER*(*), INTENT(INOUT) :: string INTEGER :: i, j, length length = LEN_TRIM(string) DO i = 1, length j = IACHAR(string(i:i)) IF ((j >= 97).AND.(j <= 122)) THEN ! a..z string(i:i) = ACHAR(j - 32) ! A..Z = 65..90 END IF END DO END SUBROUTINE Upper_Case SUBROUTINE Write_e_token_nko ! Writes e[token].nko output file, ! based on token, num_ele, crack_index, ele_strainrate (all global). IMPLICIT NONE CHARACTER(80) :: filename INTEGER :: unit = 26 ! see comment lines at top of file INTEGER :: j, l_, Z LOGICAL :: cracking filename = 'e' // TRIM(token) // ".nko" PRINT "(' Writing ',A)", TRIM(filename) WRITE (21,"('Writing ',A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') DO l_ = 1, num_ele Z = crack_index(1, l_) cracking = (Z > 0) WRITE (unit, "(I6,L3,3ES10.2)") l_, cracking, (ele_strainrate(j, l_), j = 1, 3) END DO CLOSE (unit) END SUBROUTINE Write_e_token_nko SUBROUTINE Write_f_token_nko ! Writes f[token].nko output file, ! based on: token, s_per_year, f_dat_count, f_dat_format, f_dat_titles, ! f_offset_rate, f_offset_rate_sigma_, f_creeping, f_model_offset_rate, ! f_sense, which_trace, trace_loc, f_dat_shadow, ! f_offset_rate_floor, f_offset_rate_ceiling, f_offset_rate_bracketed (all global). IMPLICIT NONE CHARACTER*3 :: c3 CHARACTER*4 :: c4 CHARACTER*6 :: c6 CHARACTER(148) :: filename, revised_format, revised_headers INTEGER :: unit = 23 ! see comment lines at top of file INTEGER :: first, i, ios, j, k, last, left, right, steps, terminus LOGICAL :: any_brackets_requested REAL :: error_in_sigmas, fraction, & & model_offset_rate_mmpa, & & offset_rate_mmpa, offset_rate_sigma_mmpa, offset_rate_floor_mmpa, offset_rate_ceiling_mmpa, & & real_F filename = 'f' // TRIM(token) // ".nko" PRINT "(' Writing ',A)", TRIM(filename) WRITE (21,"('Writing ',A)") TRIM(filename) !scan for any use of offset-rate brackets (in NeoKinema version 3+ only): any_brackets_requested = .FALSE. ! until we look... looking: DO i = 1, f_dat_count IF ((f_offset_rate_floor(i) > (-998.0 * 0.001/s_per_year)).OR. & & (f_offset_rate_ceiling(i) < (+998.0 * 0.001/s_per_year))) THEN any_brackets_requested = .TRUE. EXIT looking END IF END DO looking IF (any_brackets_requested) THEN revised_format = "(A6,1X,A50,F8.3,F8.3,L6,0P,F8.3,F8.3,F9.3,F8.3,L2)" revised_headers = "F0000X Descriptive text (50 bytes)....................... Input Sigma Creep? Output Err/Sig Floor Ceiling Active?" ELSE revised_format = "(A6,1X,A50,F12.3,F12.3,L8,0P,F13.3,F12.3)" revised_headers = "F0000X Descriptive text (50 bytes)....................... Input(mm/a) Sigma(mm/a) Creeps? Output(mm/a) Error/Sigma" END IF IF (f_dat_count >= 1) THEN OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') WRITE (unit, "(A)") TRIM(revised_format) WRITE (unit, "(A)") TRIM(revised_headers) i = 1 ! in place of DO i which will appear in parallel below k = which_trace(i) IF (trace_loc(3, k) > 0) THEN ! this trace has at least one segment in the .feg area WRITE (c4, "(I4)") which_trace(i) DO j = 1, 3 IF (c4(j:j) == ' ') c4(j:j) = '0' END DO c6 = 'F' // c4 // f_sense(i) offset_rate_mmpa = 1000.0 * s_per_year * f_offset_rate(i) offset_rate_sigma_mmpa = 1000.0 * s_per_year * f_offset_rate_sigma_(i) model_offset_rate_mmpa = 1000.0 * s_per_year * f_model_offset_rate(i) !if any shadow data resulted in negative R heave-rates, convert them to positive L rates: IF (f_dat_shadow(i).AND.(model_offset_rate_mmpa < 0.0)) THEN IF (c6(6:6) == 'R') THEN c6(6:6) = 'L' ELSE IF (c6(6:6) == 'L') THEN ! note: ELSE IF prevents a complete back-flip c6(6:6) = 'R' ELSE IF (c6(6:6) == 'T') THEN c6(6:6) = 'N' ELSE IF (c6(6:6) == 'N') THEN c6(6:6) = 'T' END IF model_offset_rate_mmpa = -model_offset_rate_mmpa END IF error_in_sigmas = ABS(model_offset_rate_mmpa - offset_rate_mmpa) / offset_rate_sigma_mmpa IF (any_brackets_requested) THEN offset_rate_floor_mmpa = f_offset_rate_floor(i) * 1000. * s_per_year offset_rate_ceiling_mmpa = f_offset_rate_ceiling(i) * 1000. * s_per_year WRITE (unit, revised_format, IOSTAT = ios) & & c6, fault_name(i), & & offset_rate_mmpa, offset_rate_sigma_mmpa, f_creeping(i), & & model_offset_rate_mmpa, error_in_sigmas, & & offset_rate_floor_mmpa, offset_rate_ceiling_mmpa, & & f_offset_rate_bracketed(i) ELSE WRITE (unit, revised_format, IOSTAT = ios) & & c6, fault_name(i), & & offset_rate_mmpa, offset_rate_sigma_mmpa, f_creeping(i), & & model_offset_rate_mmpa, error_in_sigmas END IF END IF ! (trace_loc(3, k) > 0); trace has at least one segment in the .feg area !(indented for parallelism with code below, even though there is no loop here) END IF ! f_dat_count >= 1; first pass through similar code !write the rest of the file IF (f_dat_count >= 2) THEN DO i = 2, f_dat_count k = which_trace(i) IF (trace_loc(3, k) > 0) THEN ! this trace has at least one segment in the .feg area WRITE (c4, "(I4)") which_trace(i) DO j = 1, 3 IF (c4(j:j) == ' ') c4(j:j) = '0' END DO c6 = 'F' // c4 // f_sense(i) offset_rate_mmpa = 1000.0 * s_per_year * f_offset_rate(i) offset_rate_sigma_mmpa = 1000.0 * s_per_year * f_offset_rate_sigma_(i) model_offset_rate_mmpa = 1000.0 * s_per_year * f_model_offset_rate(i) !if any shadow data resulted in negative R heave-rates, convert them to positive L rates: IF (f_dat_shadow(i).AND.(model_offset_rate_mmpa < 0.0)) THEN IF (c6(6:6) == 'R') THEN c6(6:6) = 'L' ELSE IF (c6(6:6) == 'L') THEN ! note: ELSE IF prevents a complete back-flip c6(6:6) = 'R' ELSE IF (c6(6:6) == 'T') THEN c6(6:6) = 'N' ELSE IF (c6(6:6) == 'N') THEN c6(6:6) = 'T' END IF model_offset_rate_mmpa = -model_offset_rate_mmpa END IF error_in_sigmas = ABS(model_offset_rate_mmpa - offset_rate_mmpa) / offset_rate_sigma_mmpa IF (any_brackets_requested) THEN offset_rate_floor_mmpa = f_offset_rate_floor(i) * 1000. * s_per_year offset_rate_ceiling_mmpa = f_offset_rate_ceiling(i) * 1000. * s_per_year WRITE (unit, revised_format, IOSTAT = ios) & & c6, fault_name(i), & & offset_rate_mmpa, offset_rate_sigma_mmpa, f_creeping(i), & & model_offset_rate_mmpa, error_in_sigmas, & & offset_rate_floor_mmpa, offset_rate_ceiling_mmpa, & & f_offset_rate_bracketed(i) ELSE WRITE (unit, revised_format, IOSTAT = ios) & & c6, fault_name(i), & & offset_rate_mmpa, offset_rate_sigma_mmpa, f_creeping(i), & & model_offset_rate_mmpa, error_in_sigmas END IF END IF ! (trace_loc(3, k) > 0); trace has at least one segment in the .feg area END DO ! i = 2, f_dat_count END IF ! f_dat_count >= 2; second pass through similar code CLOSE (unit, IOSTAT = ios) END SUBROUTINE Write_f_token_nko SUBROUTINE Write_g_token_nko (g_errors) ! Writes g[token].nko output file, ! based on: token, gps_file, internal_benchmarks, gps_format, gps_header, ! benchmark_uvec(:,:), benchmark_reframed_vw(:), benchmark_name(:) (all global). ! Only the array g_errors is an argument because it is temporary in Prediction. IMPLICIT NONE REAL, DIMENSION(:,:), INTENT(IN) :: g_errors ! (1:3 = error_theta_mps, error_phi_mps, SQRT(e_N_e)) CHARACTER(80) :: filename CHARACTER(200) :: expanded_gps_format ! augmented to include 2 error measures at end INTEGER :: unit = 27 ! see comment lines at top of file INTEGER :: i, i_last_A REAL :: correlation, E_error_mmpa, lat, lon, N_error_mmpa, & & vE_mmpa, vE_sigma, vN_mmpa, vN_sigma, v_error_mmpa, v_error_sigmas REAL, DIMENSION(3) :: uvec filename = 'g' // TRIM(token) // ".nko" PRINT "(' Writing ',A)", TRIM(filename) WRITE (21,"('Writing ',A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') IF ((floating_frame.AND.(loosening_degpMa > 0.)).AND.(f_dat_count == 0)) THEN WRITE (unit, "(A,': re-framed by NeoKinema from source ',A)") TRIM(filename), TRIM(gps_file) ELSE IF (f_dat_count > 0) THEN WRITE (unit, "(A,': fault-unlocked by NeoKinema from source ',A)") TRIM(filename), TRIM(gps_file) ELSE ! most typical case: WRITE (unit, "(A,': fault-unlocked and re-framed by NeoKinema from source ',A)") TRIM(filename), TRIM(gps_file) END IF i_last_A = INDEX(gps_format, 'A', .TRUE.) i_last_A = MAX(i_last_A, INDEX(gps_format, 'a', .TRUE.)) ! check for lower-case i_last_A = MAX(i_last_A, INDEX(gps_format, 'H', .TRUE.)) ! check for archaic Hollerith format entry i_last_A = MAX(i_last_A, INDEX(gps_format, 'h', .TRUE.)) ! check for archaic Hollerith format entry in lower-case expanded_gps_format = gps_format(1:i_last_A) // "20,0P,4F10.3)" ! converting "A" or "Ann" to "A20" and adding "4F10.3" WRITE (unit, "(A)") expanded_gps_format WRITE (unit, "(A)") gps_header DO i = 1, internal_benchmarks uvec(1:3) = benchmark_uvec(1:3, i) CALL LonLat_from_xyz(uvec, lon, lat) vE_mmpa = +benchmark_reframed_vw(2*i ) * 1000. * s_per_year vN_mmpa = -benchmark_reframed_vw(2*i-1) * 1000. * s_per_year vE_sigma = SQRT(benchmark_covariance(2, 2, i)) * 1000. * s_per_year vN_sigma = SQRT(benchmark_covariance(1, 1, i)) * 1000. * s_per_year correlation = -benchmark_covariance(1, 2, i) / & & (SQRT(benchmark_covariance(1,1,i)) * SQRT(benchmark_covariance(2,2,i))) E_error_mmpa = +g_errors(2, i) * 1000. * s_per_year ! phi -> E, m/s -> mm/a N_error_mmpa = -g_errors(1, i) * 1000. * s_per_year ! theta -> N, m/s -> mm/a v_error_mmpa = SQRT(E_error_mmpa**2 + N_error_mmpa**2) v_error_sigmas = g_errors(3, i) WRITE (unit, expanded_gps_format) lon, lat, vE_mmpa, vN_mmpa, vE_sigma, vN_sigma, correlation, & & "NeoKinema", TRIM(benchmark_name(i)), & & E_error_mmpa, N_error_mmpa, v_error_mmpa, v_error_sigmas END DO CLOSE (unit) END SUBROUTINE Write_g_token_nko SUBROUTINE Write_s_token_nko ! Writes s[token].nko output file, ! based on token, num_ele, ele_stressed, ele_azim, and ele_sigma (all global). IMPLICIT NONE CHARACTER(80) :: filename INTEGER :: unit = 22 ! see comment lines at top of file INTEGER :: l_ REAL :: azimuth_degrees, sigma_degrees filename = 's' // TRIM(token) // ".nko" PRINT "(' Writing ',A)", TRIM(filename) WRITE (21,"('Writing ',A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') DO l_ = 1, num_ele azimuth_degrees = ele_azim(l_) * deg_per_rad IF (azimuth_degrees < 0.) azimuth_degrees = azimuth_degrees + 180. IF (azimuth_degrees < 0.) azimuth_degrees = azimuth_degrees + 180. IF (azimuth_degrees < 0.) azimuth_degrees = azimuth_degrees + 180. IF (azimuth_degrees >= 180.) azimuth_degrees = azimuth_degrees - 180. IF (azimuth_degrees >= 180.) azimuth_degrees = azimuth_degrees - 180. IF (azimuth_degrees >= 180.) azimuth_degrees = azimuth_degrees - 180. sigma_degrees = ele_sigma(l_) * deg_per_rad WRITE (unit, "(I6,L3,F8.1,F8.1)") l_, ele_stressed(l_), azimuth_degrees, sigma_degrees END DO CLOSE (unit) END SUBROUTINE Write_s_token_nko SUBROUTINE Write_v_interseismic_token_out ! Writes v_interseismic[token].out output file, ! based on token, num_nod, and vw_interseismic (all global). IMPLICIT NONE CHARACTER(80) :: filename INTEGER :: unit = 25 ! see comment lines at top of file INTEGER :: i filename = 'v_interseismic' // TRIM(token) // ".out" PRINT "(' Writing ',A)", TRIM(filename) WRITE (21,"('Writing ',A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') WRITE (unit, "(A, ' (short-term, interseismic velocities)')") TRIM(filename) WRITE (unit, "('for use with ',A)") TRIM(x_feg) CALL DATE_AND_TIME (date, clock_time, zone, datetimenumber) WRITE (unit,"('computed with NeoKinema ',I4,'.',I2,'.',I2,' at ',I2,':',I2,':',I2)") & & datetimenumber(1), datetimenumber(2), datetimenumber(3), & & datetimenumber(5), datetimenumber(6), datetimenumber(7) DO i = 1, num_nod WRITE (unit, "(1P,E15.8,1X,E15.8)") vw_interseismic(2 * i - 1), vw_interseismic(2 * i) END DO CLOSE (unit) END SUBROUTINE Write_v_interseismic_token_out SUBROUTINE Write_v_token_out ! Writes v[token].out output file, ! based on token, num_nod, and vw (all global). IMPLICIT NONE CHARACTER(80) :: filename INTEGER :: unit = 25 ! see comment lines at top of file INTEGER :: i filename = 'v' // TRIM(token) // ".out" PRINT "(' Writing ',A)", TRIM(filename) WRITE (21,"('Writing ',A)") TRIM(filename) OPEN (unit, ACTION = 'WRITE', FILE = filename, STATUS = 'REPLACE') WRITE (unit, "(A)") TRIM(filename) WRITE (unit, "('for use with ',A)") TRIM(x_feg) CALL DATE_AND_TIME (date, clock_time, zone, datetimenumber) WRITE (unit,"('computed with NeoKinema ',I4,'.',I2,'.',I2,' at ',I2,':',I2,':',I2)") & & datetimenumber(1), datetimenumber(2), datetimenumber(3), & & datetimenumber(5), datetimenumber(6), datetimenumber(7) DO i = 1, num_nod WRITE (unit, "(1P,E15.8,1X,E15.8)") vw(2 * i - 1), vw(2 * i) END DO CLOSE (unit) END SUBROUTINE Write_v_token_out SUBROUTINE Xyz_from_lonlat (lon, lat, vector) REAL, INTENT(IN) :: lon, lat REAL, 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 :: theta_, phi_, equat theta_ = (90. - 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 NeoKinema