PROGRAM Shells_for_CSM C C An expansion of program SHELLS, by Peter Bird 2012.09.04, to C add post-processing that reports model stress tensors at C requested lat/lon/elevation points specified by the template C CSM_grid.txt provided by Dr. Jeanne Hardebeck (USGS), leader of C the Community Stress Model project of the Southern California C Earthquake Center. C C Most of the new code is in MODULE CSM_Report, C which is in Fortran 90 free-format syntax, and reuses much code C from FiniteMap. C C ========================== Shells =============================== C =========== (spherical shell finite-element program) ============ C =========== For version date, search for "1 FORMAT" below. ===== C C by C Peter Bird and Xianghong Kong, C Department of Earth and Space Sciences, C University of California, Los AngeleAs, CA 90095-1567 C C Features/advantages: C -------------------- C *Models one plate, several plates, or the entire global C lithosphere in spherical geometry. C *Uses the "thin-shell" OR "2.5-dimensional" method to model C 3-dimensional variations in temperature, rheology, and C stress, with the low cost of a 2-dimensional grid. C *Exact treatment of Mohr-Coulomb-Navier friction in the cool upper C lithosphere; C *Transition to power-law, thermally-activated dislocation creep C occurs at variable depth below each map point, as a function of C the geotherm, the rheologic constants, and the strain rate. C *Fault networks may be input using arc-of-great-circle fault C elements. Faults may intersect in "tectonic knots" of great C complexity. C *Faults have the same type of rheology as the blocks C between them, but in most experiments the user will choose C to assign them a lower coefficient of friction. C *Model predicts whether each fault will slip or lock. If it slips, C the calculated average slip rate can be used for estimation of C long-term seismic hazard. C *All stresses are reduced (for convenience and precision) by C subtraction of an isotropic pressure which is only a function of C elevation (*not* "depth" below the bumpy surface). This pressure C is based on the structure in the symmetry plane of mid-ocean C spreading rises (of high spreading rate), where there is almost C isotropic, lithostatic stress. C *Input parameters are echoed in the output, to provide a record of C the numerical experiment. C *Echoing of the finite-element grid, and other long tables of C computed quantities (like velocities, stresses, strain rates, and C fault slip rates) can be switched on or off. C *Extensive pre-checking of the grid topology is performed, and will C automatically catch many types of common errors in the input. C *Code is unit-free, and works equally well with SI, cgs, or other C input data (as long as all inputs are self-consistent). C C Limitations/disadvantages: C -------------------------- C *The vertical component of the equilibrium (momentum-conservation) C equation is represented by the isostatic approximation; hence the C effective flexural rigidity of the lithosphere is zero. This C means that the program cannot be used to predict or understand C isostatic gravity anomaly fields. C *Elastic strain is neglected, hence the code does not represent the C earthquake cycle on each fault. (However, this omission can be C repaired, to first order, by adding analytic elastic-dislocation C solutions to the output. Positive dislocations at discrete times C can represent earthquakes. Anti-dislocations growing at steady C rates can represent temporary fault locking. The only flaw in C this fix-up is that it ignores the variations in anelastic C dislocation creep deformation associated with the time-dependent C component of the stress field.) C *Program only computes velocities, strain rates, and stresses, but C does not extrapolate forward in time to find finite strains and C displacements. (While such a program would clearly be desirable, C there are difficult problems to solve at the points of C intersection between faults. Also, it would be necessary C to know the physics behind the creation of new faults and their C weakening with slip.) C C Therefore: C ---------- C *The stresses output should be considered to be averaged over the C entire earthquake cycle, or longer. C *The velocities output should be considered to be averaged over C the entire earthquake cycle, or longer. C *The strain rates output are only the permanent (anelastic) part, C and should be considered as averages over the entire earthquake C cycle, or longer. C *Nothing in this program can be used to predict individual C earthquakes, or even to determine whether a particular active C fault will slip seismically or aseismically. C C Copyright (c) 1995, 2005, 2006 by Peter Bird and the C Regents of the University of California. C C This program was developed with support from the University of C California, the Unites States Geological Survey, the National C Science Foundation, and the National Aeronautics and Space C Administration. C It is freeware, and may be copied and used without charge. C It may not be modified in a way which hides its origin C or removes this message or the copyright message. C It may not be resold for more than the actual cost of C serving/reproduction and distribution. C Furthermore, scientific ethics and courtesy require C the source of the program to be stated in any C resulting publications C C As the program is freeware, support will be provided at the C discretion of the authors. For questions, suggestions, C or reports of potential bugs, please contact: C Peter Bird C Department of Earth and Space Sciences C University of California C Los Angeles, CA 90095-1567 C pbird@ess.ucla.edu C C An on-line user's guide, and many examples of completed projects, C may be seen at this URL: C http://element.ess.ucla.edu C---------------------------------------------------------------------- C C ***************************************************************** C * History of changes to Shells (since 1999) * C * * C * Switch from mainframe to PC (1999.09.24); #1-6 below: * C * ---------------------------------------------------- * C * 1. Linear systems are solved with DLSLRB of the IMSL library,* C * instead of DGBF/DGBS of the ESSL library. This required * C * changes to statement function INDEXK (wherever it occurs) * C * and also changes to subprogram KSIZE. With this method, * C * array IPVT is no longer needed, and has been eliminated. * C * 2. Detailed output on device IUNITT goes to a logfile; only * C * occasional short messages to show progress are sent to * C * the default output device (screen). * C * 3. Interactive mode is assumed, and the user is prompted to * C * enter a (new) name for the logfile, and also to * C * enter the names of all input and output files. * C * In order to accomplish this prompting, all file-opening * C * messages that go to device IUNITT now also go to * C * the standard output device (* = 6). * C * (However, user intervention will not be needed if the * C * environment variables FORT1, FORT2, ... are predefined * C * to equal the names of the desired files. Another option * C * is to rename the files as FORT.1, FORT.2, etc. See your * C * compiler documentation to see how switches can be set to * C * control program behavior when a file with no name is * C * opened implicitly.) * C * 4. Dynamic memory allocation is used to create all large * C * arrays, eliminating the need to recompile. Because of * C * this one feature, the program is no longer in FORTRAN 77; * C * it is now in Fortran 90. (However, it is still in fixed * C * format, and no other Fortran 90 innovations are used.) * C * 5. The large coefficient matrix STIFF (or its alias, K) is * C * now passed as an argument, and no longer placed in COMMON.* C * 6. After any ERR0R message, but before STOP, I call PAUSE() * C * to allow time for the message to be read. * C * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * C * 7. ICONVE = 5 option (basal drag only on subduction forearc) * C * added 2000.04.14. * C * 8. Labels V1,V2->VE,VN in output table 2000.10.03. * C * 9. A temporary file "iteration permit.txt" is created during * C * each run. If this file is deleted, Shells will stop * C * at the end of the next iteration and report the current * C * unconverged solution (as if it had hit the MAXITR limit). * C * 2001.07.31. * C * 10. Improved initiation of iteration 2001.08.29. * C * 11. Increased MXBN boundary nodes limit 2001.09.24. * C * (See also note of 2005.08.10 below.) * C * 12. Added single-plate (no-slab) torque report 2002.02.07. * C * 13. Plate model (used to determine lateral and basal boundary * C * conditions when appropriate switches are set) switched * C * from old: PB1999 (essentially NUVEL-1A) * C * to new: PB2002 [Bird, 2003, G**3] * C * on 2005.03.03. * C * 14. Added boundary-condition code ICOND = 5, in which case * C * the user specifies the two-letter code of any plate, * C * and subprogram EULER computes the velocity and azimuth * C * of that plate (in the velocity reference frame requested * C * by parameter PLTREF, which is the 2-letter name of the * C * plate defining the reference frame; #IPVREF). 2005.03.04 * C * 15. Boundary between subduction zones and ordinary thrust * C * faults moved to SUBDIP = 19.0 degrees (per Bird & Kagan, * C * 2004, BSSA, Table 5; agrees with OrbWin & FiniteMap * C * conventions). Now suggesting 14 degrees for SUB faults. * C * 2005.04.11. * C * 16. Silently reads and uses 2 additional nodal data values, * C * if present in .feg file. (Otherwise, they are set to * C * zero for backward compatibility.) These are: * C * density_anomaly_kgpm3 (applying to whole lithosphere); & * C * cooling_curvature_Cpm2 (ditto). * C * These 2 new degrees of freedom allow new OrbData5 to * C * create .feg files with crustal thickness from CRUST2, * C * and with lithosphere thickness from global seismic * C * tomography. We do this by permitting lateral density * C * variations (of chemical origin) in crust and/or mantle, * C * and also by allowing geotherms to be out of steady-state. * C * Note that supporting programs OrbWin, OrbNumber, and * C * FiniteMap were also upgraded to support this, 2005.05.31. * C * 17. Added boundary-condition code ICOND = 4, for cut-slab * C * nodes in global models. Shells will read file * C * PB2002_boundaries.dig (or equivalent) to infer which * C * plate is subducting at this location. The velocity and * C * azimuth of the subducting plate (relative to plate * C * PLTREF/IPVREF) are computed and imposed. Therefore, this * C * is just a more convenient form of a type-2 BC, which does * C * not require the user to compute the velocity and azimuth. * C * (It is also more convenient than type-5, which would * C * require the user to name the subducting plate.) * C * Note that this type-4 BC does *not* have the effect of * C * destroying velocity-reference-frame-independence, as the * C * "bad old" type-3 BC does! 2005.06.24. * C * 18. Modified FORMATs to lower-case for all routine messages; * C * upper-case is now reserved for varaible names and for * C * warning messages. 2005.06.28 * C * 19. Added LOGICAL :: log_{table type} = .FALSE. switches to * C * suppress logging of lengthy tables, and shrink log file * C * sizes. User can always set these .TRUE. and recompile * C * if more detail is needed (or to test graphics & scoring * C * post-processor programs). 2005.06.28. * C * 20. Added date-and-time stamping of log file at beginning and * C * end of each run, using subprogram DATE_AND_TIME which * C * was provided with the Compaq Visual Fortran compiler. * C * (If this routine is not available on another system, just * C * comment-out these lines; they are not essential.) * C * 2005.06.28. * C * 21. Allowed for additional, non-physical "boundary" condition * C * constraints on the solution at interior nodes. (These * C * are appended to the .bcs input file after the required * C * boundary nodes.) This allows forcing plate motion to be * C * correct, in order to evaluate reaction forces. * C * 2005.08.10 * C * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * C * 22. Moved code that classifies each node by plate affiliation * C * from conditional execution in main (CALL GETPBX) and in * C * CONVEC (old CALL FINDPV) to routine execution in main * C * (CALL ASSIGN), storing results in new INTEGER * C * array WHICHP. This will now be available for assigning * C * component (COMP) forces and torques to sums by plate. * C * 2006.08.02 * C * 23. Modified code of BALANC to separate *Fault* into 2 * C * components *Fault_P* and *Fault_S*, and *Base* into 2 * C * components *Base_P* and *Base_S*, changing COMP(4,NDOF) * C * to COMP(6,NDOF). 2006.08.03-08 * C * 24. Changed torque reporting to add individual plate totals, * C * using plate-associations of each node stored in new INT * C * WHICHP(node#). TORQLP(3) became TORQLP(3,NPLATE). TORQFS,* C * TORQSS, TORQCL, & TORQBS also expand to same dimensions, * C * and are now allocated in main and passed to -RESULT-, * C * which uses array COMP(6,NDOF) from -BALANC- to compute * C * them. Changed last section of subprogram -RESULT- to * C * report torque balances per plate. 2006.08.03-08 * C * 25. Inferred new TORQCL ("Continuum Links") as negative of * C * any non-zero sum of TORQLP+TORQFS+TORQBS. * C * Also defined TORQSS=TORQFS+TORQCL, and this is used in * C * final 3-term balance of TORQLP+TORQSS+TORQBS=0. * C * 2006.08.08 * C * 26. Added parallel torque (and point-force) balance report * C * for each plate, as a separate text file on IUNITQ. * C * 2006.08.08 * C * 27. Added subprogram -TWIST- to compute traction pole vector * C * for each plate-wide basal-strength torque computed in * C * -RESULT-, adding this to the torque-report file. * C * 2006.08.10 * C * 28. Added option for ICONVE == 6 (traction sense and amount * C * from traction pole vectors in a previous torque report). * C * These basal shear tractions are computed by new suprogram * C * -TRACT- and stored in new array BASAL. * C * Since SHELLS was not designed for a fixed-shear-traction * C * basal BC, this is done with a kludge: Subprogram -FILLIN- * C * computes PB2002 lower mantle velocities (as an estimate * C * of desired and likely surface velocities), then adds * C * a differential component that is different by 100 mm/a, * C * in the direction predicted by the BASAL vectors; * C * the total vector is stored as OVB. * C * Then, subprogram -THONB- also makes * C * use of BASAL traction vectors to regulate the * C * magnitude of shear traction, and keeps this constant * C * during iteration, allowing small adjustments of ETA. * C * 2006.08.14-15 * C ***************************************************************** C C Other software required: C C * Linear systems of equations are solved by DLSLRB from C I.M.S.L. (International Mathematics Subroutine Library); C my INTEGER FUNCTION INDEXK is customized to work with C IMSL's storage convention for banded nonsymmetric real matrices. C (If a different solver is substituted then INDEXK will need to be C modified! Also, subprogram KSIZE, which checks whether the C size of PARAMETER MAXSIZ is adequate, would also change. C USE Numerical_Libraries C * (Under Compaq/Digital Visual Fortran, Professional Edition, C * the preceding line causes library IMSL to be linked.) C USE CSM_Report C Free-format Fortran90 code added to report stresses in CSM format C--------------------------------------------------------------------- C Array-size statement(s): C C Set the following PARAMETER(s) to match the size of arrays C defined by DATA statements further down in this program: C C PARAMETER giving the exact number of PB2002 plates [Bird, 2003, G**3]: PARAMETER (NPLATE=52) C C--------------------------------------------------------------------- C C TYPE statements C for scalar variables and fixed arrays (not ALLOCATABLE arrays): C C (Note: The IMPLICIT typing of I-N = INTEGER, and A-H,O-Z = REAL C is assumed in this program. No TYPEs are stated for such names.) C CHARACTER*2 NAMES CHARACTER*8 :: date CHARACTER*10 :: clock_time CHARACTER*5 :: zone CHARACTER*80 LOGFIL,TITLE1,TITLE2,TITLE3 C C Following statement must agree with BLOCK DATA BD1: DOUBLE PRECISION POINTS,WEIGHT C Following statement must agree with BLOCK DATA BD2: DOUBLE PRECISION FPHI,FPOINT,FGAUSS C Following 3-vectors accumulate components of net torque: DOUBLE PRECISION TORQBS,TORQCL,TORQFS,TORQLP,TORQMD,TORQSS,TORQVB C INTEGER, DIMENSION(8) :: datetimenumber C C The following switches control the size of the log file; C set them .TRUE. for maximum detail, or .FALSE. for brevity: LOGICAL :: log_strike_adjustments = .FALSE. LOGICAL :: log_force_balance = .TRUE. LOGICAL :: log_node_velocities = .FALSE. LOGICAL :: log_element_dynamics = .TRUE. LOGICAL :: log_fault_dynamics = .TRUE. C LOGICAL BRIEF,DOFB1,DOFB2,DOFB3,DOFB4,EVERYP, + SKIPBC,SLAB_Q,SPHERE C C--------------------------------------------------------------------- C DIMENSION statements: C C DIMENSIONs that will be ALLOCATEd based on variable MXNODE: INTEGER, DIMENSION(:), ALLOCATABLE :: JCOL1,JCOL2,WHICHP LOGICAL, DIMENSION(:), ALLOCATABLE :: CHECKN REAL, DIMENSION(:), ALLOCATABLE :: ATNODE,DQDTDA,ELEV,TAUZZN, + TLNODE,XNODE,YNODE,ZMNODE REAL, DIMENSION(:), ALLOCATABLE :: density_anomaly, + cooling_curvature REAL, DIMENSION(:,:), ALLOCATABLE:: DV,DVLAST DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: BASAL,V,VM C C DIMENSIONs that will be ALLOCATEd based on variable MXDOF: REAL, DIMENSION(:,:), ALLOCATABLE :: COMP DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: FBASE,FORCE C C DIMENSIONs that will be ALLOCATEd based on variable MXBN C (which on 2005.08.10 was made equal to NUMNOD): CHARACTER(2), DIMENSION(:), ALLOCATABLE :: SAVTAG INTEGER, DIMENSION(:), ALLOCATABLE :: ICOND,IEDGE,NODCON REAL, DIMENSION(:), ALLOCATABLE :: R2EDGE,VBCARG,VBCMAG, + XEDGE,YEDGE C C DIMENSIONs that will be ALLOCATEd based on variable MXEL: INTEGER, DIMENSION(:,:), ALLOCATABLE :: NODES LOGICAL, DIMENSION(:), ALLOCATABLE :: CHECKE LOGICAL, DIMENSION(:,:), ALLOCATABLE :: CONTIN,EDGETS,PULLED REAL, DIMENSION(:), ALLOCATABLE :: AREA REAL, DIMENSION(:,:), ALLOCATABLE :: DETJ,ETA,GLUE,SIGZZI, + SITA,TAUZZI,TLINT,ZMOHO REAL, DIMENSION(:,:), ALLOCATABLE :: curviness, delta_rho REAL, DIMENSION(:,:,:), ALLOCATABLE :: DXSP,DYSP,ERATE, + GEOTHC,GEOTHM, + OVB,OUTVEC,SIGHB, + TAUMAT,TOFSET,ZTRANC REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ALPHA REAL, DIMENSION(:,:,:,:,:), ALLOCATABLE :: DXS,DYS,FPSFER C C DIMENSIONs that will be ALLOCATEd based on variable MXFEL: C INTEGER, DIMENSION(:,:), ALLOCATABLE :: NODEF LOGICAL, DIMENSION(:), ALLOCATABLE :: CHECKF,FSLIPS LOGICAL, DIMENSION(:,:), ALLOCATABLE :: EDGEFS REAL, DIMENSION(:), ALLOCATABLE :: FLEN,OFFSET REAL, DIMENSION(:,:), ALLOCATABLE :: FARG,FDIP,FIMUDZ,FPEAKS, + ZTRANF REAL, DIMENSION(:,:,:), ALLOCATABLE :: FTSTAR REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: FC REAL, DIMENSION(:,:,:,:,:), ALLOCATABLE :: FPFLT C C DIMENSIONs that will be ALLOCATEd based on variable MXSTAR: INTEGER, DIMENSION(:), ALLOCATABLE :: LIST C C DIMENSIONs that will be ALLOCATEd based on variables NPLATE and NPBND INTEGER, DIMENSION(:), ALLOCATABLE :: NDPLAT REAL, DIMENSION(:,:), ALLOCATABLE :: PLAT,PLON C C DIMENSIONs that will be ALLOCATEd based on variable MXWORK: DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: STIFF C C DIMENSIONs fixed by a PARAMETER (not adjustable at run-time): DIMENSION NAMES(NPLATE),OMEGA(3,NPLATE),SLAB_Q(NPLATE) C Following vectors collect sums of torque components: DIMENSION TORQBS(3,NPLATE),TORQCL(3,NPLATE),TORQFS(3,NPLATE), + TORQLP(3,NPLATE),TORQMD(3,NPLATE),TORQSS(3,NPLATE), + TORQVB(3,NPLATE) C C DIMENSIONs of fixed size: C DIMENSIONs of (2) refer to crust/mantle lithosphere: DIMENSION ACREEP(2), ALPHAT(2), BCREEP(2), CCREEP(2), CONDUC(2), + DCREEP(2), RADIO(2), RHOBAR(2), TAUMAX(2), TEMLIM(2) C Following statement must agree with BLOCK DATA BD1: DIMENSION POINTS(3,7),WEIGHT(7) C Following statement must agree with BLOCK DATA BD2: DIMENSION FPHI(4,7),FPOINT(7),FGAUSS(7) C C--------------------------------------------------------------------- C COMMON statements C C Note: Un-named COMMON passes INTEGER variables used in the C INTEGER FUNCTION INDEXK, to avoid passing these same C through long sequences of subprograms. COMMON LDA,NUCA,MXWORK C C Named COMMON blocks hold the fixed values of the positions, C weights, and nodal function values at the integration points C in the elements (triangular elements in BLOCK DATA BD1, C and fault elements in BLOCK DATA BD2). C Entries corresponding to BD1: COMMON /S1S2S3/ POINTS COMMON /WGTVEC/ WEIGHT C Entries corresponding to BD2: COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS C C-------------------------------------------------------------------- C DATA statements C C SUBDIP is the maximum dip (from horizontal, in degrees) for a C fault in a whole-Earth model (SPHERE=.TRUE.) to be treated as C a subduction zone (in which case, the footwall nodes require C boundary conditions). C In all models, faults with less than this dip have the down-dip C integral of traction limited to TAUMAX. TAUMAX is an array C of two values, for oceanic and continental subduction zones, C respectively. If such limits are not wanted, then C the TAUMAX vaules can be set to very large numbers (e.g.,9.99E29). DATA SUBDIP /19.0/ C C DIPMAX is the maximum dip (from horizontal, in degrees) for a C fault element to be treated as a dip-slip fault, with two degrees C of freedom per node-pair. At steeper dips, the degree of freedom C corresponding to opening or convergence of the opposite sides is C eliminated by a constraint equation, and the fault is treated as C a vertical strike-slip fault. This arbitrary limit is necessary C because the equations for dip-slip faults become singular as the C dip approaches 90 degrees. In practice, it is best to specify dips C as either (1) vertical, or (2) clearly less than DIPMAX, within C each fault element. If the dip varies within an element in such a C way that it passes through this limit within one element, then C the representation of that fault element in the equations may C be inaccurate. DATA DIPMAX /75./ C C The following are the FORTRAN input and output devide numbers: C (avoid 5,6 which are STDIN and STDOUT on UNIX and AIX systems!) C IUNITG = device number associated with the grid input file: DATA IUNITG /1/ C IUNITV = device number associated with the approximate velocity C solution (optionally used to initialize): DATA IUNITV /2/ C IUNITB = device number associated with the boundary-condition C input file: DATA IUNITB /3/ C IUNITP = device number assoicated with the parameter input file: DATA IUNITP /4/ C IUNITT = device number associated with the logfile (ASCII text): DATA IUNITT /50/ C IUNITI = device number associated with the temporary file C "iteration permit.txt" which is used as a flag to C let the user interrupt an long job without crashing it: DATA IUNITI /51/ C IUNITD = device number associated with the digitised plate-pair C boundaries, if required by subprogram EDGEVS; C (for example, "PB2002_boundaries.dig"). C (Caution: This is *not* the same file as the digitised plate C outline file that is read in on IUNITM; C the two have different formats, and may both be C needed if plate velocity boundary C conditions are imposed.) DATA IUNITD /7/ C IUNITM = device number associated with mantle flow vectors C or plate outlines (e.g., PB2002_boundaries.dig): DATA IUNITM /8/ C IUNITS = device number associated with velocity output (solution): DATA IUNITS /9/ C IUNITF = device number associated with force output (reactions). DATA IUNITF /10/ C IUNITQ = device number associated with NEW torque- and force-balance C report for each plate. Always used. See also IUNITR below. DATA IUNITQ /11/ C IUNITR = device number associated with OLD torque- and force-balance C report for each plate. Only used for input if ICONVE.EQ.6. C See also IUNITQ above. DATA IUNITR /12/ C C C PB2002 plate names [Bird, 2003, G**3, Table 1]: DATA NAMES / 1 'AF', 'AM', 'AN', 'AP', 'AR', 'AS', 'AT', 'AU', 'BH', 'BR', 2 'BS', 'BU', 'CA', 'CL', 'CO', 'CR', 'EA', 'EU', 'FT', 'GP', 3 'IN', 'JF', 'JZ', 'KE', 'MA', 'MN', 'MO', 'MS', 'NA', 'NB', 4 'ND', 'NH', 'NI', 'NZ', 'OK', 'ON', 'PA', 'PM', 'PS', 'RI', 5 'SA', 'SB', 'SC', 'SL', 'SO', 'SS', 'SU', 'SW', 'TI', 'TO', 6 'WL', 'YA' / C INTEGER, PARAMETER :: IPAFRI = 1 C Index number of Africa plate in this model. C C Following rotation vectors in Cartesian (x,y,z) components, C with units of radians per million years: C [Bird, 2003, G**3, Table 1] C DATA ((OMEGA(I,J),I=1,3),J=1,NPLATE) / 1 0.002401, -0.007939, 0.013892, 2 0.000949, -0.008643, 0.013725, 3 0.000689, -0.006541, 0.013676, 4 0.002042, -0.013153, 0.008856, 5 0.008570, -0.005607, 0.017497, 6 0.000148, -0.003070, 0.010915, 7 0.015696, 0.002467, 0.023809, 8 0.009349, 0.000284, 0.016252, 9 0.000184, 0.005157, 0.001150, A -0.000871, -0.002268, 0.002507, 1 -0.019124, 0.030087, 0.010227, 2 0.011506, -0.044526, 0.007197, 3 0.001688, -0.009048, 0.012815, 4 0.003716, -0.003791, 0.000949, 5 -0.008915, -0.026445, 0.020895, 6 -0.061175, 0.005216, -0.013755, 7 0.070136, 0.160534, 0.094328, 8 0.000529, -0.007235, 0.013123, 9 -0.083251, -0.002464, -0.014923, B 0.016256, 0.089364, 0.015035, 1 0.008180, -0.004800, 0.016760, 2 0.006512, 0.003176, 0.005073, 3 0.108013, 0.299461, 0.230528, 4 0.033318, -0.001813, 0.036441, 5 -0.013835, 0.008245, 0.015432, 6 -0.777844, 0.440872, -0.047437, 7 0.001521, 0.007739, 0.013437, 8 0.038223, -0.058291, 0.013679, 9 0.001768, -0.008439, 0.009817, C -0.004336, 0.003769, -0.000402, 1 0.000111, -0.006361, 0.010449, 2 0.044913, -0.009546, 0.010601, 3 -0.055342, -0.010890, 0.006794, 4 -0.000022, -0.013417, 0.019579, 5 0.001041, -0.008305, 0.012143, 6 -0.026223, 0.020184, 0.037208, 7 0.000000, 0.000000, 0.000000, 8 -0.000040, -0.009291, 0.012815, 9 0.012165, -0.012510, -0.000366, D -0.019183, -0.070604, 0.036798, 1 0.000472, -0.006355, 0.009100, 2 0.121443, -0.078836, 0.027122, 3 0.001117, -0.007434, 0.008534, 4 -0.000833, -0.006701, 0.013323, 5 0.001287, -0.008754, 0.014603, 6 -0.017196, 0.017186, 0.008623, 7 0.003201, -0.010440, 0.015854, 8 0.023380, -0.019369, -0.010465, 9 -0.009400, 0.023063, 0.008831, E 0.142118, 0.005616, 0.078214, 1 -0.016831, 0.018478, 0.010166, 2 -0.000836, -0.006169, 0.016274/ C C--------------------------------------------------------------------- C C Glossary of variables in the main program: C C (A few names may differ within the subprograms.) C (Specifically, arrays STIFF = K and FORCE = F.) C C ---------------------------------------------------------- C General note on coordinate system: The surface of the C sphere is described by two angular coordinates C (expressed internally in radians, but externally in degrees): C THETA points horizontally South from any point; C PHI points horizontally East from any point. C When multiplied by RADIUS to give units of length, these C are generally called X (South) and Y (East). C The vertical or radial coordinate is generally called R C when measured outward from the center of the planet, or C Z when measured downward from the surface or the geoid. C (There may be a few inconsistencies for historical reasons.) C ---------------------------------------------------------- C C ACREEP(1-2) = pre-exponential constant of creep law, in units of C shear stress (equal to the shear stress for creep at unit C strain rate and infinite temperature). C The complete creep law is: C (shear stress) = ACREEP*(strain rate)**ECREEP C *EXP((BCREEP+CCREEP*depth)/(absolute temperature)). C Subscript: 1 = crust; 2 = mantle lithosphere/asthenosphere. C ALPHA(3,3,7,I) = the 3 x 3 matrix of tactical effective viccosities C at the 7 integration points in each triangular continuum C element. The 3 rows correspond to Txx, Tyy, AND Txy C (the vertical integrals of the stress anomaly, relative to C vertical stress). C The 3 columns correspond to strain rates Exx, Eyy, and Exy. C ALPHAT = volumetric thermal expansion coefficient, in units of C inverse degrees. C AREA(I) = area of triangular element I, based on corner node C positions only (ignoring curvature of sides). See DETJ. C In length**2 units (not steradians). C ATNODE(I)=temporary working storage with one entry per node. C BASAL(2,I) = horizontal vector (components +theta = S, +phi = E) C of basal shear tractions based on traction pole vectors C that are read from a previous torque report when/if C ICONVE.EQ.6. Otherwise, filled with zeros. C Note that BASAL is DOUBLE PRECISION by analogy with C V, so that it can be processed by -INTERP-. C BCREEP(1-2) = constant in ductile creep law. (See ACREEP above.) C Equal to activation energy for creep, multiplied by ECREEP, C then divided by the gas constant "R". C Subscript: 1 = crust; 2 = mantle lithosphere/asthenosphere. C BIOT = coefficient of pore-pressure in the computation of effective C normal stresses. Range 0 (for impermeable rocks) to 1 (for C very porous rocks). (Note: Most theorists assume 1.) C BRIEF = LOGICAL variable, requesting that grid details not C be included in output (to economize size of the log file). C BYERLY = a dimensionless coefficient (0. to 0.99) describing the C fractional reduction of effective friction on major faults, C in proportion to their offsets. If BYERLY>0 and C MAX(OFFSET(I);I=1...NFL)>0, then the effective friction C coefficient of each fault element is reduced to C FFRIC*(1.-BYERLY*OFFSET(I)/OFFMAX). C The hypothesis behind this is that major faults have C thick gouge layers which support static, non-Darcy, C pore pressure gradients. C CCREEP(1-2) = constant in the ductile creep law (see ACREEP above); C equal to (activation volume)*(density)*(gravity)/ C ((stress exponent)*(gas constant, "R")); C therefore in SI units it is about 0.02 degree/meter. C Subscript: 1 = crust; 2 = mantle lithosphere/asthenosphere. C [Documentation corrected 2004.03.11, but program unchanged.] C CFRIC = coefficient of friction in blocks (outside of fault C elements). Dimensionless. Approximately 0.85. C CHECKE(I)=a LOGICAL array in which we note that element I was C included in the input data. C CHECKF(I)=a LOGICAL array in which we note that fault I was C included in the input data. C CHECKN(I)=a LOGICAL array in which we note that node I was C included in the input data. C COMP(1..6,1..NDOF) = consistent nodal force components C (i.e., convolutions of nodal functions with distributed C traction anomalies) of 6 different types, for each C degree of freedom in the grid (2 DOF per node). C See comments in subprogram -BALANC- for identification C of these 6 components. C CONDUC(I=1..2) = thermal conductivity of layer (1=crust, C 2=mantle lithosphere). C Units of energy/degree/length. C CONSTR = coefficient used to determine the weights applied to the C constraint equations preventing relative velocity C across the plane of strike-slip faults. CONSTR is in units C of force-sec/length**2, So it must be multiplied by the C integral of nodal function products along an element side to C arrive at a diagonal stiffness element in force-sec//length C units. C CONTIN(M,I) = LOGICAL value, indicating that the lithosphere C structure at integration point M of element I is C 'continental', based on limiting values of elevation C and heat-flow. C Used only if ICONVE=4, to decide which points have basal C drag applied to them. C cooling_curvature(I) = additional (non-steady-state) curvature of C the geotherm, in both crust and mantle lithosphere, C beyond that caused by local radioactivity, at node #I. C Units are degrees C (or degrees K) per m**2. The change C that cooling_curvature creates in the quadratic coefficient C of the geotherm [GEOTH3 or GEOTH7, or GEOTHC/M(3,M,I)] C is exactly -0.5*cooling_curvature. Positive C values indicate that lithosphere is cooling, and negative C values indicate that lithosphere is warming. All models C prior to June 2005 had this field implicitly set to C zero, giving exactly steady-state geotherms for all nodes. C curviness(M=1,7;I) = cooling_curvature values [see above] interpolated C to integration point #M of element #I. C DCREEP = maximum shear stress supportable by rocks, at which there C will be arbitrary amounts of deformation regardless of C temperature or pressure. C Subscript: 1 = crust; 2 = mantle lithosphere/asthenosphere. C delta_rho(M=1,7;I) = density anomaly (of chemical origin) at C integration point #M in element #I. Applies to both C crust and mantle lithosphere. Note that models before C June 2005 had this field implicitly set to zero. C density_anomaly(I) = density anomaly (of chemical origin) at node C #I, in kg/m**3. Applies to both crust and mantle C lithosphere. Note that models prior to June 2005 C had this field implicitly set to zero. C DETJ(M=1,7,I) = determinant of Jacobian matrix for distortion of C triangular element #I by side-bending, evaluated at C integration point #M. When multiplied by AREA(I), the C product gives the actual area per unit area of internal C element coordinates. (Should remain clost to 1.0.) C DIPMAX = maximum dip (in degrees) at which fault elements retain C 2 DOF for relative slip; at steeper angles they become C purely strike-slip. (This is to avoid singularities.) C DQDTDA(I)= heat flow at node #I (energy/length**2/sec) C DV(1-2,I) = x and y components of the velocity change at node #I, C relative to the previous iteration. (Note: C includes both real and fake nodes. However, index numbers C I of the fake nodes have been reduced by a constant so C that they follow immediately after the real nodes.) C DVLAST(1-2,I) = x and y components of the velocity change at node #I C that was determined (as DV) in the previous iteration. C (Includes both real and fake nodes. However, index numbers C I of the fake nodes have been reduced by a constant so C that they follow immediately after the real nodes.) C DXS (J=1..2, K=1..2, L=1..3, M=1..7, I=1..MAXEL) = C theta-partial-derivitive of each vector nodal function C on the sphere. C K:(1=theta,2=phi) identifies the component of the C result, which is itself a vector. C J:(1=theta,2=phi) identifies which of the 2 nodal C degrees of freedom C associated with node #L (internal numbering) of C triangular element #I, evaluated at integration point #M. C Units are 1/length; usually a very small number; C sign is negative for about half of the entries. C DXSP (J=1..3, M=1..7, I=1..MAXEL) = C theta-partial-derivitive on the sphere of the scalar nodal C function on the plane triangle (suM:=1..3 = 1) C associated with a scalar value of 1 at node #J C (internal numbering) of triangular element #I, C evaluated at integration point #M (internal numbering). C DYS (J=1..2, K=1..2, L=1..3, M=1..7, I=1..MAXEL) = C phi-partial-derivitive of each vector nodal function C on the sphere. C K:(1=theta,2=phi) identifies the component of the C result, which is itself a vector. C J:(1=theta,2=phi) identifies which of the 2 nodal C degrees of freedom C associated with node #L (internal numbering) of C triangular element #I, evaluated at integration point #M. C Units are 1/length; usually a very small number; C sign is negative for about half of the entries. C DYSP (J=1..3, M=1..7, I=1..MAXEL) = C phi-derivitive on the sphere of the scalar nodal C function on the plane triangle (sum:J=1..3 = 1) C associated with a scalar value of 1 at node #J C (internal numbering) of triangular element #I, C evaluated at integration point #M (internal numbering). C ECREEP = exponent on strain rate in calculation of shear stresses for C ductile creep (see ACREEP above). The inverse of the stress C exponent "n" used by many other authors. C (No subscript; value applies to both crust and mantle.) C EDGEFS(1-2,I) = .TRUE. if side 1 or 2 of fault element #I is part of C the perimeter of the model. Side 1 has nodes N1-N2; C side 2 has nodes N3-N4 as recorded in NODEF(N1-4,I). C EDGETS(1-3,I) = .TRUE. if side 1, 2, or 3 of triangular element #I is C part of the perimeter of the model. Side 1 has nodes C N2-N3; side 2 has nodes N3-N1; and side 3 has nodes C N1-N2 as recorded in NODES(1-3,I). C ELEV(I) = elevation at node #I. Negative below sea level. C Relative to a geoid from which mid-ocean spreading ridges C (the reference structure for defining stress anomalies) C have mean depth of 2700 m. C ERATE(3,M,I) = set of 3 components of strain rate at integration point C M in triangular continuum element I. First component Exx, C second Eyy, third Exy. (This shear component is according to C the tensor definition, and is equal to C (1/2) * ((dVx/dy)+(dVy/dx)). ) C ETA(M,I)= ratio of basal shear traction to velocity difference, C used in linearization of basal traction (and updated C each iteration), at integration point M in element I. C ETAMAX = maximum coupling coefficient for mantle drag, equal to C maximum ratio of shear traction to velocity difference. C FARG (J=1..2, I=1..MAXFEL) = C argument of tangent ray to the trace of fault element C number I, evaluated at node J (internal numbering). C The sense of the ray is from node NODEF(1,I)->NODEF(2,I). C Arguments are measured counterclockwise from the +theta C axis and expressed in radians. Because of the use of C REAL FUNCTION CHORD to interpolate, it is not essential C that FARG values at the two ends of the fault are on the C same cycle. C FBASE(I)= nonvarying parts of vector FORCE. (See below.) C FC(2,2,M,I) = 2 x 2 matrix of stiffness of dipping fault element I, C evaluated at integration point M = 1...7. C The stiffness is the derivitive of the C vertical (not down-dip) integral of the matrix for the C derivitive of shear traction on the fault plane with C respect to changes in the slip vector. In this matrix, C The two components are (1) horizontal and parallel to C the fault trace, and (2) up-dip. The slip vector is C defined as the velocity of the N1-N2 side relative C to the N4-N3 side. The shear traction is that exerted C on the N4-N3 side by the N1-N2 side, so the slip C vector and traction are strictly parallel at all times. C However, as a tactical device, the values placed in the C matrix will typically be larger than the actual C derivitives, to promote stability. C In any particular iteration, the linearized model of the C vertical integral of the shear traction on the fault plane C is that it is = FC*(slip vector) + FTSTAR, C in the fault-plane (2 x 2) coordinate system. C FDIP(2,I)= fault dip, in radians, measured from horizontal on the C side which has nodes NODEF(1-2,I). First value is at node C NODEF(1,I), 2nd is at NODEF(2,I). C (Note: In input .feg files, and output, a negative dip C indicates a dip toward the other side of the fault. C However, internally dips are stored as positive numbers C between 0 and 3.14159, with no discontinuity.) C FFRIC = coefficient of friction in (cold upper parts of) fault C elements. Dimensionless. Usually less than CFRIC, C or else most fault elements will not slip, and so they C might as well be eliminated from the grid. C FGAUSS(I)= weight attached to Gaussian integration point #I (I=1,7) C in line integration over any linear fault element. C The sum of the 7 weights IS 1. C FIMUDZ(M=1-7,I) = vertical integral through the plate of MU, at C Gauss integration point #M in linear fault element I. C MU is the (artificially linearized) ratio of shear C traction (on the fault plane) to slip rate (in the fault C plane). Note that the length step in the integration is C dZ (vertical), not dS (on a slant). Thus, FIMUDZ is the C mean value of MU in the plate times the plate thickness, C not the mean value of MU times the downdip length of the C fault. See also FMUMAX. C FLEN(I) = length of fault element #I, including effect of curvature. C In length units, not radians or degrees. C FMUMAX = maximum value of fault stiffness after linearization, equal C to maximum ratio of shear traction to velocity difference. C FORCE(I)= right-hand-side of "forcing" vector of the linear systems C which are solved to determine nodal velocities. Some values C are physical forces, while others are weighted boundary C conditions or constraints. The vector is different in each C iteration; however, the constant parts are saved in FBASE C so they do not need to be recomputed. C I = 2*(node number)-1 for X-components, and C I = 2*(node number) for Y-components. C FPEAKS(I) = peak value of shear stress at the midpoint of fault C element I. This value will occur at the brittle/ductive C transition depth (relative to the surface) given by C ZTRANF. C FPFLT (J=1..2, K=1..2, L=1..2, M=1..7, I=1..MAXFEL)= C vector nodal functions of a fault element. C K:(1=theta,2=phi) identifies the component of the C vector nodal function. C J:(1=theta,2=phi) identifies which of the 2 nodal C degrees of freedom C associated with node #L (internal numbering) of C fault element #I, evaluated at integration point #M. C Note: L=3 nodal function should be negative of L=2. C L=4 nodal function should be negative of L=1. C DIMENSIONLESS; ORDER(1). C FPHI(I=1-4,J=1-7) = value of nodal function #I of any linear C fault element, evaluated at Gaussian integration point C #J. Nodal function #I has magnitude 1 at node NODEF(I,K), C where K is the element number, and is 0 at other end. C For convenience, nodal functions are positive for I=1,2 C but negative for I=3,4. This simplifies the computations C of fault slip and fault stiffness by including the C changing sign of the outward normal vector. C Precomputed and stored in BLOCK DATA BD2. C FPOINT(J=1,7) = location of the Gaussian integration point #J C in any linear fault element. Expressed in relative C or fractional length from the NODE1 end to the NODE2 end. C (NODE1 = NODEF(1,I), NODE2 = NODEF(2,I).) C FPSFER (J=1..2, K=1..2, L=1..3, M=1..7, I=1..MAXEL) = C vector nodal functions on the sphere. C K:(1=theta,2=phi) identifies the component of the C vector nodal function. C J:(1=theta,2=phi) identifies which of the 2 nodal C degrees of freedom C associated with node #L (internal numbering) of C triangular element #I, evaluated at integration point #M. C Dimensionless. C FSLIPS(I) = LOGICAL variable, indicating whether fault element I C is slipping (at its midpoint). Otherwise, it is C locked and aseismic, even though its slip rate will C not be exactly zero for numerical reasons (see OKDELV). C FTSTAR(2,M,I) = 2-component vector of the vertically-integrated C "initial" traction on dipping fault element I, C evaluated at integration point M = 1...7. C In any particular iteration, the linearized model of the C vertical integral of the shear traction on the fault plane C is that it is = FC*(slip vector) + FTSTAR, C in the fault-plane (2 x 2) coordinate system where the C first component is horizontal and parallel to fault C trace, and the second component in up-dip. C (The shear traction is that exerted on the C N3-N4 side by the N1-N2 side.) C Note that FTSTAR has no physical meaning, but is used in C conjunction with the FC matrix to provide a linearized C model for faults that will always be stiffer than the C real nonlinear rheology (to allow convergence). C GEOTH(4,7,I) = coefficients of the cubic polynomial geotherm C beneath the 7 integration points of triangular continuum C element #I. The first term is surface temperature, the C second term is the surface gradient, etc. C GLUE(7,I)= strength of coupling between plate and lower mantle at each C of the 7 integration points in triangular continuum C element #I. Expressed as the shear traction that would C be needed to create a unit of shear velocity across the C thickness of the asthenosphere. C (Note: If (ICONVE.EQ.5), GLUE is not used; it is set to C very large values so that they will never be relevant.) C GMEAN = mean value of gravitational acceleration on the surface of C the planet (length/sec**2). C GRADIE = (positive) gradient of temperature with respect to depth C on the adiabat in the asthenosphere. SI units C would be degrees K per meter, or degrees C per meter. C ICOND(I)= type of boundary condition #I: C -1 = no velocity constraint (spreading ridge adjacent). C 0 = no velocity constraint (local lithostatic pressure). C 1 = one component of velocity C (toward specified azimuth) set at specified C value, with other component subject to lithostatic C pressure based on local structure. C 2 = velocity fixed at specified magnitude and azimuth. C 3 = velocity component in the direction of subduction C (which is the absolute velocity of the subducting plate, C based on model PB2002, in the current reference frame) C is fixed at the PB2002 value. The orthogonal component C of velocity is left free. See subprogram EDGEVS. C *CAUTION*: This option gives results which are *NOT* C independent of the velocity reference frame (defined C by input parameter PLTREF and related INTEGER index C IPVREF)! C 4 = velocity fixed at the magnitude and azimuth of the C plate which is known to be subducting at a trench in C this vicinity (per file PB2002_boundaries.dig). C A more convenient form of type-2, with automated C identification of the subducting plate and computation C of its velocity (in the current velocity reference C frame, set by input parameter PLTREF). C Unlike type-3 above, does *NOT* destroy the C velocity-reference-frame-independence of solution! C 5 = both components fixed at the velocity of the plate C whose 2-letter name code is given on the same line. C Computed according to model PB2002 of Bird [2003], C in the current velocity reference frame (which was C defined by input parameter PLTREF and related INTEGER C index IPVREF). C (For all: See array NODCON to find which node is affected.) C ICONVE = INTEGER code selecting model of lower mantle flow: C 0 = static (with respect to AF = Africa plate). C 1 = Hager and O'Connell (1979) Model II. C 2 = Baumgardner (1988) Figure 7A-F, *10. C 3 = Bird (2003) PB2002 plate model. C 4 = PB2002 drag under continents; none under oceans. C 5 = drag on base of subduction-zone forearc only C (used when the subduction shear zone is the bottom\side C boundary of the model along one part of perimeter). C 6 = mantle drag traction from traction pole vectors, C read from the torque report produced by a previous C SHELLS model with velocity boundary conditions on C all plates (and, usually, with TRHMAX = 0.). C IPVREF = index (= 1, 2, .., NUMPLT) of the plate whose name is input C parameter PLTREF (CHARACTER*2). This is the plate which C defines the velocity reference frame for this experiment. C Important in processing type-3 and type-4 and type-5 boundary C conditions and in computing lower mantle flow (see ICONVE). C See array NAMES for CHARACTER*2 mnemonics for each plate. C JCOL1(I)= a WORK array in which to record the lowest node number C which will be linked to node #I during the assembly of the C stiffness matrix and the imposition of constraints at C strike-slip node pairs. C JCOL2(I)= a WORK array in which to record the highest node number C which will be linked to node #I during the assembly of the C stiffness matrix and the imposition of constraints at C strike-slip node pairs. C LDA = an INTEGER constant giving the number of rows in the C stiffness matrix, according to the storage convention C for general real band matrices in the IMSL package. C See IMSL manual for definition. Generically, it indicates C the "Leading Dimension of A", where the authors presume that C the stiffness matrix (A) appears in a Fortran statement C "DIMENSION A(LDA,NDOF)" in this program. To preserve C flexibility, however, we have stored STIFF (=A) as a C one-subscript vector, and the details of the translation are C accomplished by INTEGER FUNCTION INDEXK, which uses C INTEGER values LDA and NUCA precomputed by KSIZE. C LIST = in INTEGER work array needed by subprogram SQUARE, to C collect the numbers of all the nodes that are nominally C at the same point. C MAXITR = maximum number of iterations permitted in attempt to C converge on a solution. C NCOND = number of nodes with any kind of boundary condition. C NDOF = number of degrees of freedom before imposition of boundary C conditions, = number of rows and columns in stiffness C matrix = 2 * NUMNOD. C NFL = number of fault elements. C NKSIZE = actual number of entries needed to store central band of C stiffness matrix. While NKSIZE is of order NDOF*(NLB+1+NUB), C the actual formula will vary with the linear-system-solver C which is called from subprogram SOLVER. Computed in C subprogram KSIZE, which may need adjustment if the solver C is ever replaced. (Also, modify INTEGER FUNCTION INDEXK.) C NLB = width of lower half-band in stiffness matrix, equal to the C number of lower co-diagonals. C NLINK = maximum difference in indices of connected real nodes. C NODCON(I)= number of the node affected by boundary condition #I. C NODEF(I=1-4,J=1,NFL) = node numbers defining the fault elements. C The node numbers are given in counterclockwise order C around each fault element, beginning at one end, and C ending on the other side of the same end. C NODES(I=1-3,J=1,NUMEL) = node numbers at corners C of triangular continuum element #J. C Nodes must be entered in counterclockwise order C NUB = width of upper half-band in stiffness matrix, equal to the C number of upper co-diagonals. C NUCA = an INTEGER constant computed by KSIZE and needed by C INDEXK when using the IMSL package to solve linear C systems. See communts under LDA above. C NUMEL = number of triangular continuum elements. C NUMNOD = number of nodes. C OFFMAX = largest total past slip on any fault element; see OFFSET C below. C OFFSET(I) = offset, or total past slip, on fault element I. C Used in one model of fault rheology to estimate the C thickness of the gouge zone (about 1% of offset) and C therefore the thickness of the zone in which static C non-Darcy pore pressure gradients can be supported, C reducing effective friction. An input variable, NOT C a computed result! C OKDELV = magnitude of velocity errors allowed due to finite stiffness C of the linear system(s) approximating the real planet. C (SI units would be m/s; cgs units would be cm/s.) C Note: Velocity errors may appear in such forms as: C 1. fictitious basal slip of plate over asthenosphere; C 2. erroneous convergence/divergence at vertical faults; or C 3. velocity error due to fictitious viscous compliances. C HOWEVER, VALUES WHICH ARE TOO SMALL WILL CAUSE ILL-CONDITIONED C LINEAR SYSTEMS AND STRESS ERR0RS, AND MAY PREVENT CONVERGENCE!) C OKTOQT = dimensionless (small) number used for testing whether C velocity solution has converged. The mean value (over all C nodes) of the velocity change from the last iteration, C divided by the mean value of the velocity, must be less C than this value for "convergence". I suggest 0.0001. C ONEKM = conversion factor, expressing a length of 1 kilometer in C the current measurement units (e.g., 1000. in SI units, C 1.0E+5 in cgs units). C OUTVEC(2,7,I) = a 2-component vector WORK array, with one vector C entry at each of the 7 integration points in each triangular C continuum element I. C OVB(2,7,I) = 2-component vector field of horizontal velocities C of the lower-mantle layer, beneath each of the 7 integration C points in each triangular continuum element I. C PLTREF = name (CHARACTER*2) of the plate which defines the velocity C reference frame. Abbreviated names follow the PB2002 model, C as in Table 1 of BIRD [2003]. For internal use, this is C quickly converted to INTEGER parameter IPVREF, which is the C index number of this plate in the table of Euler vectors. C POINTS(I=1-3,J=1,7) = location of the Gaussian integration point #J C in any triangular continuum element. Expressed in relative C internal coordinates (S1,S2,S3) which satisfy S1+S2+S3=1. C I=1:S1 value. I=2:S2 value. I=3:S3 value. C PULLED(M,I) = LOGICAL flag, showing that there is shear traction on C the base of the plate at integration point M (=1..7) of C triangular continuum element I. If .FALSE., there is no C shear (horizontal) traction. C RADIO(1-2) = radioactive heat production of layer. Units of energy/ C volume/sec. (*NOT* energy/mass/sec !) 1:crust; 2:mantle. C RADIUS = radius of the planet. C REFSTR = reference stress, or mean value of shear stress in the C plate. Used for initialization and to compute upper limits C to stiffnesses of different parts of the linear system. C RHOAST = density of the asthenosphere beneath the mantle lithosphere. C (Notes: Effects of pressure on density are uniformly omitted C in every part of Shells, so this is a pressure-free C potential density, at ambient temperature. The value should C be consistent with RHOBAR(2)*(1.-ALPHAT(2)*TASTH), C but may be slightly different to take account of phase C differences (partial melting??) or chemical differences C between lithosphere and asthenosphere. C RHOBAR(1-2) = mean density of each layer. Note: Effects of pressure C on density are uniformly omitted from every part of Shells, C but effects of temperature (thermal expansion) will be C added later. So, this should be a pressure-free potential C density at O K. Subscript: 1 = crust; 2 = mantle. C RHOH2O = density of seawater, pore water, and lakes. C (Note: Effects of pressure on density are uniformly omitted C in every part of Shells, so this is a pressure-free C potential density, at ambient temperature.) C SIGHB(2,7,I) = 2-component vector of horizontal traction on the base C of the plate, at each of 7 integration points in triangular C continuum element I. C SIGZZI(M,I) = vertical normal stress anomaly at the base of the C plate, relative to the standard pressure curve (See C subprogram SQUEEZ.) Compression is negative. Values are C given at integration point M of triangular element I. C SIGZZN(I) = same as SIGZZI above, except value is given at node I. C SITA(M,I) = colatitude of integration point "M" in C spherical triangle finite element I. C In radians from the North pole. C SLIDE = maximum dip antle (in radians) for faults to be considered C "subduction zones". Faults of greater dip are treated C as ordinary thrust (or normal or strike-slip) faults. C The special meaning of subduction zone faults is that: C 1. In all models, their shear traction can be limited C by input parameter(s) TAUMAX, if desired. C 2. In global models, the nodes on the footwall C (downgoing slab) plate will require boundary conditions. C 3. Boundary condition codes 3 and 4 are provided to C help compute velocity boundary conditions for such C nodes, if desired. (N.B. Type 4 is preferred to 3.) C SPHERE = a LOGICAL variable, indicating a problem in which the C finite element grid covers the whole sphere. In this C case, low-angle thrust faults are considered to be C "subduction zones" (see SLIDE above) and the nodes on C the footwall or downgoing-plate side will require C boundary conditions. If SPHERE = .FALSE., the problem C is a local problem involving only part of the sphere. C TADIAB = intercept temperature (at Z =0 =P) of upper mantle adiabat, C on an absolute (Kelvin) scale. Used only in computing C asthenosphere creep strength for basal drag estimation. C TAUMAT(3,M,I)= vertical integral of 3 stress anomaly components C through the plate, evaluated at integration point M in C triangular continuum element I. Compression is negative. C First component is Txx, the second Tyy, and the third Txy. C The reference pressure for defining stress anomaly is the C negative of the local value of vertical stress (sigma_zz). C To get the integrals relative to the standard curve of C pressure, it is necessary to add TAUZZI(M,I) to C components Txx and Tyy. C TAUMAX(2) = maximum of the down-dip integral of the interplate shear C traction in "subduction zones". C A subduction zone fault will be one with dip less than C SUBDIP (degrees) or SLIDE (radians). C The first value is for oceanic subduction zones, and the C second is for continental subduction. C The limit applies in both local and global models. C (If you don't want such a limit, enter a large number.) C TAUZZI(M,I) = vertical integral of the vertical stress anomaly C through the plate, evaluated at integration point M in C triangular continuum element I. Compression is negative. C The reference pressure for defining stress anomaly is the C pressure in a standard density model of a mid-ocean C spreading ridge with high spreading rate. C (See subprogram SQUEEZ.) C TAUZZN(I) = same as TAUZZI above, except value is given at node I. C TEMLIM = maximum temperature permitted (measured from absolute zero). C At points of very high heat flow, a conductive geotherm is C unreasonable because there must be convection at depth. C Set TEMLIM to the value at which convection is expected. C This could be the partial-melting temperature, or a C bit lower. C TITLE1 = CHARACTER*80 identifier for the finite element grid. C TITLE2 = CHARACTER*80 identifier for the set of boundary conditions. C TITLE3 = CHARACTER*80 identifier for the set of input parameters. C TLINT(M,I) = thickness of the mantle lithosphere (the part below the C crust or Moho) at integration point M of element I. C TLNODE(I) = thickness of the mantle lithosphere (the part below the C crust or Moho) at node I. C TOFSET(3,M,I)= vertical integral of 3 components of prestress C anomaly through the plate, evaluated at integration point C #M = 1,2,...,7 C in triangular continuum element I. Compression is negative. C Prestress is an artifact of linearising the rheology, and C represents the intercept of this linear function at zero C values of all components of the strain rate tensor. C First component is Txx, the second Tyy, and the third Txy. C The reference pressure for defining stress anomaly is the C negative of the local value of vertical stress (sigma_zz). C To get the integrals relative to the standard curve of C pressure, it is necessary to add TAUZZI(M,I) to C components Txx and Tyy. C TORQBS(3,NPLATE) = Cartesian vectors of net torque on each plate due C basal strength, both in the form of asthenosphere viscosity C (distributed basal shear stresses; TORQMD) and in the form C point forces from velocity boundary condtions (TORQVB), C which usually represent cut-off slabs and/or plate-interior C control points. C See report at end of text output C file for definition of coordinate system. C TORQCL(3,NPLATE) = Cartesian vectors of net torque on each plate due C continuum links (unfaulted boundary) with other plates, C if any. See report at end of text output C file for definition of coordinate system. C TORQFS(3,NPLATE) = Cartesian vectors of net torque on each plate due C to deviatoric stress in faults. C See report at end of text output C file for definition of coordinate system. C TORQLP(3,NPLATE) = Cartesian vectors of net torque on each plate due C lithostatic pressure, both on (sloping) base of lithosphere, C and in bounding faults. C See report at end of text output C file for definition of coordinate system. C TORQMD(3,NPLATE) = Cartesian vectors of net torque on each plate due C mantle drag in the form of asthenosphere viscosity C (distributed basal shear stresses). C One component of TORQBS (see also TORQVB). C control points. C See report at end of text output C file for definition of coordinate system. C TORQSS(3,NPLATE) = Cartesian vectors of net torque on each plate due C to side strength; equal to TORQFS+TORQCL. C See report at end of text output C file for definition of coordinate system. C TORQVB(3,NPLATE) = Cartesian vectors of net torque on each plate due C to point forces from velocity boundary condtions, C which usually represent cut-off slabs and/or plate-interior C control points. One component of TORQBS (see also TORQMD). C See report at end of text output C file for definition of coordinate system. C TRHMAX = upper limit on magnitude of shear tractions on the base C of the model. When ICONVE = 5, this parameter is used C to control the shear traction in a bounding subduction zhear C zone, which is one tapered edge of the model domain. C (This is not the same as using fault elements to represent C subduction shear zones-- in that case, see TAUMAX above.) C Another use of TRHMAX is to set it to zero, in which case C the model will have no basal shear tractions, regardless C of the value of ICONVE chosen. C TSURF = surface temperature, in degrees above absolute zero. C VBCARG(I) = argument of the velocity vector imposed at boundary node C #I (whose index number is NODCON(I)). Measured counter- C clockwise from the southward +Theta (+X) axis. (Input in C degrees of azimuth, but stored as radians of argument.) C As always, velocity reference frame is that of plate C #IPVREF (specified by CHARACTER*2 PLTREF in the input file). C VBCMAG(I)= magnitude (speed) of the velocity vector imposed at C boundary node #I (whose index number is NODCON(I)). C V(1-2,I) = X and Y components of the velocity of node #I. C (Axis X points Southward, and axis Y points Eastward.) C VISMAX = maximum viscosity allowed for any element in the model C (applies to the whole thickness of the plate, not locally). C VM(1-2,I)= X and Y components of the lower mantle velocity C (below the asthenosphere) under node #I. C *IMPORTANT NOTE*: Because the Earth is round, the C zero-strain case is not dV/dR = 0, but V(R) = k*R. C This means that for piggyback transport, Vm should C really be less than surface velocity V by the factor C (RADIUS-ZBASTH)/RADIUS. However, our convention is C merely to ignore this conversion factor, as if C ZBASTH were much smaller than RADIUS. (In fact, it C may be as much as 0.106*RADIUS in the Earth.) C This means that whenever lower mantle velocity is C quoted in the programs, the values are equivalent to C those projected to the surface of the planet by C rotation around the point at the center of the planet. C WEDGE = angle (in radians) on either side of vertical at which C a fault is first permitted to have a dip-slip degree of C freedom. This limit is needed to avoid singularities. C WEIGHT(M) = weight attached to Gaussian integration point #M (M=1,7) C in area-integration over any triangular continuum element. C The sum of the 7 weights is 1. C XEDGE(I)= theta (colatitude) coordinate of the point at or near C boundary node I where the plate-boundary file is C read to determine the boundary velocity. In radians. C WHICHP(I)=integer index (1..NPLATE) identifying which plate each of C the NUMNOD nodes is part of. C XNODE(I)= theta (colatitude) coordinate of node #I. C Measured in radians Southward from the North pole. C YEDGE(I)= phi (Eastward) coordinate of the point at or near C boundary node I where the plate-boundary file is C read to determine the boundary velocity. In radians. C YNODE(I)= phi (Eastward) coordinate of node #I. C Measured in radians Eastward from the prime meridian. C ZBASTH = depth of the bottom of the asthenosphere layer; C used in computing coupling between the plates and the C lower mantle for basal drag boundary conditions. C (Note: Should exceed greatest thickness of plates!) C ZMNODE(I) = depth of Moho beneath node #I, relative to Earth surface C (that is, measured from rock surface, not from sea level). C ZMOHO(M,I) = depth of Moho beneath integration point M of triangular C continuum element I. Measured from the upper rock surface C (land surface or sea floor), not from sea level. C ZTRANC(M,I) = depth to the brittle/ductile transition at integration C point M of triangular continuum element I, measured from C upper rock surface (land surface or sea floor), C not from sea level. C ZTRANF(I) = depth to the brittle/ductile transition at the midpoint C of fault element I. Measured from the upper rock surface C (land surface or sea floor), not from sea level. C--------------------------------------------------------------------- C C A Note on Argument Lists of Subprograms C C The argument list in each "CALL" and "SUBR0UTINE" statement C is divided into up to 4 groups by dummy (place-holding) C arguments "INPUT", "MODIFY", "OUTPUT", and "WORK". C For example: C CCCC CALL SQUARE (INPUT,BRIEF,FDIP,IUNITT, CCCC + log_strike_adjustments, CCCC + MXBN,MXEL,MXFEL,MXNODE, CCCC + MXSTAR,NFL,NODEF,NODES,NREALN, CCCC + NUMEL,NUMNOD,SKIPBC,RADIUS,WEDGE, CCCC + MODIFY,FAZ,XNODE,YNODE, CCCC + OUTPUT,AREA,DETJ,DXS,DYS,EDGEFS,EDGETS, CCCC + FLEN,FARG,NCOND,NODCON, CCCC + WORK,CHECKN,LIST) CCCC C The meaning of these groups is as follows: C "INPUT" group = Value must be defined before CALL, and is not C changed by the subprogram. C Equivalent to INTENT(IN) of Fortran 90. C "MODIFY" group = Value must be defined before CALL, but may be C adjusted by subprogram. C Equivalent to INTENT(INOUT) of Fortran 90. C "OUTPUT" group = Value need not be defined before CALL, and will C be defined by the subprogram. C Equivalent to INTENT(OUT) of Fortran 90. C "WORK" group = Arrays provided as working space needed by the C subprogram (so that all parameter statements C can be in the main program). Values will be C set before reading, so any predefined values C are irrelevant. Final values are not used C by calling program. C (No Fortran 90 equivalent, because meta-analysis C of the whole computational context is needed C to distinguish "WORK" from "OUTPUT".) C C-------------------------------------------------------------------- C C Beginning of Executable Code (!) C SLIDE=SUBDIP*0.017453293 C Mark most plates as LACKING extensive attached slabs... DO 10 I=1,NPLATE SLAB_Q(I) = .FALSE. 10 CONTINUE C ...except for these particular cases: SLAB_Q( 8) = .TRUE. ! 8 = AU = Australia SLAB_Q(14) = .TRUE. ! 14 = CL = Caroline SLAB_Q(15) = .TRUE. ! 15 = CO = Cocos SLAB_Q(21) = .TRUE. ! 21 = IN = India SLAB_Q(22) = .TRUE. ! 22 = JF = Juan de Fuca SLAB_Q(34) = .TRUE. ! 34 = NZ = Nazca SLAB_Q(37) = .TRUE. ! 37 = PA = Pacific SLAB_Q(39) = .TRUE. ! 39 = PS = Philippine Sea SLAB_Q(40) = .TRUE. ! 40 = RI = Rivera SLAB_Q(46) = .TRUE. ! 46 = SS = Solomon Sea C C Write header on output log file: C WRITE (*,"(' Enter [Drive:][\path\]filename for', + ' output logfile: ')") READ (*,"(A)") LOGFIL OPEN (UNIT = IUNITT, FILE = LOGFIL) WRITE (IUNITT,1) WRITE (*,1) 1 FORMAT ( +' =============================================================='/ +' I Output from program Shells, I'/ +' I a spherical-Earth, thin-shell program for computing I'/ +' I time-averaged (anelastic) deformation of plates I'/ +' I with realistic frictional/dislocation-creep rheology. I'/ +' I Distinct thicknesses and thermal and mechanical I'/ +' I properties are read for the crust and mantle layers. I'/ +' I Faults may be included, with specified dip and friction. I'/ +' I The velocity below the base of the model may be fixed, I'/ +' I (to represent subduction and other convection), I'/ +' I or shear traction on the base of the lithosphere may I'/ +' I be set to zero. I'/ +' I by I'/ +' I Xianghong Kong and Peter Bird I'/ +' I Department of Earth and Space Sciences I'/ +' I University of California I'/ +' I Los Angeles, CA 90095-1567 I'/ +" I Peter Bird's version of 29 August 2006 I"/ +' ==============================================================') C WRITE (IUNITT,"('----------------------------------------------', + '-------------')") CALL DATE_AND_TIME (date, clock_time, zone, datetimenumber) WRITE ( *,"(' Run began on ',I4,'.',I2,'.',I2,' at ',I2,':', + I2,':',I2)") + datetimenumber(1), datetimenumber(2), datetimenumber(3), + datetimenumber(5), datetimenumber(6), datetimenumber(7) WRITE (IUNITT,"('Run began on ',I4,'.',I2,'.',I2,' at ',I2,':', + I2,':',I2)") + datetimenumber(1), datetimenumber(2), datetimenumber(3), + datetimenumber(5), datetimenumber(6), datetimenumber(7) WRITE (IUNITT,"('----------------------------------------------', + '-------------')") C WEDGE=ABS(90.-ABS(DIPMAX))*0.017453293 C C Preview .feg file to determine array sizes: C WRITE (*,101) IUNITG 101 FORMAT (/' Attempting to read finite element grid from unit',I3/) READ (IUNITG,*,IOSTAT=IOS) IF (IOS.NE.0) THEN WRITE(*,"(' ERR','OR: File not found, or file is empty,' + /' or file is too short.')") CALL PAUSE() STOP END IF READ (IUNITG,*,IOSTAT=IOS) NUMNOD IF (IOS.NE.0) THEN WRITE(*,"(' ERR','OR: File not found, or file is empty,' + /' or file is too short.')") CALL PAUSE() STOP END IF MXNODE=NUMNOD MXDOF=2*MXNODE CCCC MXBN=16*SQRT(1.0*MXNODE) MXBN=NUMNOD C Which permits any/all nodes to have boundary conditions! C (This is unphysical, but useful for computing reaction forces.) DO 102 I=1,NUMNOD READ (IUNITG,*,IOSTAT=IOS) IF (IOS.NE.0) THEN WRITE(*,"(' ERR','OR:File not found, or file is empty,' + /' or file is too short.')") CALL PAUSE() STOP END IF 102 CONTINUE READ (IUNITG,*,IOSTAT=IOS)NUMEL IF (IOS.NE.0) THEN WRITE(*,"(' ERR','OR: File not found, or file is empty,' + /' or file is too short.')") CALL PAUSE() STOP END IF MXEL=NUMEL DO 103 I=1,NUMEL READ (IUNITG,*,IOSTAT=IOS) IF (IOS.NE.0) THEN WRITE(*,"(' ERR','OR:File not found, or file is empty,' + /' or file is too short.')") CALL PAUSE() STOP END IF 103 CONTINUE NFL=0 READ (IUNITG,*,IOSTAT=IOS) N IF (IOS.EQ.0) NFL=N NFL=MAX(NFL,0) IF (NFL.EQ.0) log_fault_dynamics = .FALSE. MXFEL=NFL MXSTAR=20 NPBND=1250 REWIND (UNIT=IUNITG) C C Allocate adjustable arrays (except those whose sizes C are based on MXWORK): C C DIMENSIONs using size variable MXNODE: ALLOCATE (ATNODE(MXNODE), + BASAL(2,MXNODE), + CHECKN (MXNODE), + cooling_curvature(MXNODE), + density_anomaly(MXNODE), + DQDTDA(MXNODE), + DV (2,MXNODE), DVLAST(2,MXNODE), + ELEV (MXNODE), JCOL1 (MXNODE), JCOL2 (MXNODE), + TAUZZN(MXNODE), TLNODE (MXNODE), + V (2,MXNODE), VM (2,MXNODE), + WHICHP(MXNODE), + XNODE (MXNODE), YNODE (MXNODE), ZMNODE(MXNODE)) C C DIMENSIONs using size variable MXDOF: ALLOCATE (COMP (6,MXDOF), + FORCE (MXDOF), FBASE (MXDOF)) C C DIMENSIONs using size variable MXBN: ALLOCATE (ICOND (MXBN), IEDGE (MXBN), + NODCON (MXBN), R2EDGE (MXBN), + SAVTAG (MXBN), + VBCARG (MXBN), VBCMAG (MXBN), + XEDGE (MXBN), YEDGE (MXBN)) C C DIMENSIONs using size variable MXEL: ALLOCATE (ALPHA(3,3,7,MXEL), AREA (MXEL), + CHECKE (MXEL), CONTIN (7,MXEL), + curviness(7,MXEL), + delta_rho(7,MXEL), DETJ (7,MXEL), + DXS(2,2,3,7,MXEL), DYS(2,2,3,7,MXEL), + DXSP (3,7,MXEL), DYSP (3,7,MXEL), EDGETS(3,MXEL), + ERATE (3,7,MXEL), ETA (7,MXEL), + FPSFER(2,2,3,7,MXEL), + GEOTHC(4,7,MXEL), GEOTHM(4,7,MXEL), + GLUE (7,MXEL), NODES (3,MXEL), + OVB (2,7,MXEL), + OUTVEC (2,7,MXEL), PULLED (7,MXEL), + SIGHB (2,7,MXEL), SIGZZI (7,MXEL), SITA (7,MXEL), + TAUMAT (3,7,MXEL), TAUZZI (7,MXEL), TLINT (7,MXEL), + TOFSET (3,7,MXEL), ZMOHO (7,MXEL), + ZTRANC (2,7,MXEL)) C C DIMENSIONs using size variable MXFEL: ALLOCATE (CHECKF (MXFEL), EDGEFS (2,MXFEL), + FC(2,2,7,MXFEL), FDIP (2,MXFEL), + FIMUDZ(7,MXFEL), FLEN (MXFEL), FPEAKS(2,MXFEL), + FPFLT(2,2,2,7,MXFEL), FSLIPS (MXFEL), + FARG (2,MXFEL), FTSTAR(2,7,MXFEL), NODEF (4,MXFEL), + OFFSET (MXFEL), ZTRANF (2,MXFEL)) C C DIMENSIONs using size variable MXSTAR: ALLOCATE (LIST (MXSTAR)) C C DIMENSIONs using size variables NPLATE and NPBND: ALLOCATE (NDPLAT(NPLATE), + PLAT(NPLATE,NPBND), PLON(NPLATE,NPBND)) C C Input finite element grid and nodal data (up to 6 fields): C CALL GETNET (INPUT,IUNITG,IUNITT, + MXDOF,MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF, cooling_curvature, + density_anomaly, + DQDTDA,ELEV,FDIP, + NFAKEN,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,OFFMAX,OFFSET, + TITLE1,TLNODE,XNODE,YNODE,ZMNODE, + WORK,CHECKE,CHECKF,CHECKN) WRITE (*,"(' Finite element grid file has been read.')") C C Read scalar parameters: C CALL READPM (INPUT,IUNITP, IUNITT, NAMES, NPLATE, OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT , + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , GMEAN , + GRADIE, ICONVE, IPVREF, + MAXITR, OKDELV, OKTOQT, ONEKM, RADIO , + RADIUS, REFSTR, RHOAST, RHOBAR, RHOH2O, + TADIAB, TAUMAX, TEMLIM, TITLE3, + TRHMAX, TSURF , VTIMES, ZBASTH) WRITE (*,"(' Parameter input file has been read.')") C C Check grid topology and compute geometric properties: C WRITE (*,"(/' Analyzing grid topology for defects...')") CALL SQUARE (INPUT,BRIEF,FDIP,IUNITT, + log_strike_adjustments, + MXBN,MXEL,MXFEL,MXNODE, + MXSTAR,NFL,NODEF,NODES, + NUMEL,NUMNOD,SKIPBC,RADIUS,WEDGE, + MODIFY,XNODE,YNODE, + OUTPUT,AREA,DETJ, + DXS,DYS,DXSP,DYSP,EDGEFS, + EDGETS,FLEN,FPFLT,FPSFER, + FARG,NCOND,NODCON,SITA, + WORK,CHECKN,LIST) WRITE (*,"(' Grid topology has been verified.')") C C Read plate outlines, for assigning each node to a plate: WRITE (*,2) IUNITM 2 FORMAT (/' Attempting to read outlines of PLATES from unit' + ,I3/) CALL GETPBX (INPUT,IUNITM,IUNITT,NAMES,NPBND,NPLATE, + OUTPUT,NDPLAT,PLAT,PLON) C C Assign each node of grid to a plate: WRITE (*,"(/' Assigning each node to a plate...')") CALL ASSIGN (INPUT,IUNITT, + NAMES,NPBND,NDPLAT,NFL,NODEF,NODES, + NPLATE,NUMEL,NUMNOD, + OMEGA,PLAT,PLON, + XNODE,YNODE, + OUTPUT,WHICHP, + WORK,CHECKN) WRITE (*,"(' Nodes have all been assigned.')") C C If (ICONVE.EQ.6) compute basal shear tractions: IF (ICONVE.EQ.6) THEN C Note that -TRACT- will request name of torque report file, C read it in, and compute values for BASAL: CALL TRACT(INPUT,IUNITR,IUNITT,NPLATE,NUMNOD, + SLAB_Q,WHICHP,XNODE,YNODE, + OUTPUT,BASAL) ELSE DO 3 I=1,NUMNOD BASAL(1,I)=0.0D0 BASAL(2,I)=0.0D0 3 CONTINUE ENDIF C C Determine if grid covers whole sphere; if so, boundary C conditions will be required for footwalls of thrusts C (because they represent truncated subducting slabs): C IF (NCOND.EQ.0) THEN SPHERE=.TRUE. SKIPBC=.FALSE. CALL DOWNER (INPUT,SKIPBC,FDIP,IUNITT,MXBN,MXFEL,MXNODE, + NFL,NODEF,NUMNOD,SLIDE, + XNODE,YNODE, + OUTPUT,NCOND,NODCON, + WORK,CHECKN) ELSE SPHERE=.FALSE. ENDIF C C Attempt to read old velocity solution for initialization; C if this fails, set velocities to zero: C WRITE (*,4) IUNITV 4 FORMAT (/ /' Attempting to read old velocity solution', + ' from unit ',I3 + /' (If none is available, give a', + ' non-existent filename, like X.)' + /) CALL OLDVEL (INPUT,IUNITT,IUNITV,MXNODE,NUMNOD, + OUTPUT,V) C C Read boundary conditions, in order determined by SQUARE, C or by DOWNER C (and perhaps using corrected node positions determined by SQUARE). C SKIPBC=.FALSE. CALL READBC (INPUT,SKIPBC,FDIP,IPVREF,IUNITB,IUNITD,IUNITT, + MXBN,MXFEL,MXNODE,NAMES,NCOND,NFL,NODCON, + NODEF,NPLATE,NREALN,NUMNOD,N1000,OMEGA, + RADIUS,SAVTAG,SLIDE,SPHERE,TRHMAX,XNODE, + YNODE, + OUTPUT,ICOND,TITLE2,VBCARG,VBCMAG, + WORK,IEDGE,R2EDGE,XEDGE,YEDGE) WRITE (*,"(' Boundary-conditions file has been read...')") C C -Predefine names of output files for nodal velocity, boundary- C condition reaction forces, and torque-balances for plates: C WRITE (*,"(/' Please supply output file names in advance:')") WRITE (*,"(/' Attempting to create file for nodal velocities'/)") WRITE (IUNITS,"('Dummy line to force implicit OPEN')") BACKSPACE (IUNITS) WRITE (*,"(/' Attempting to create file for nodal forces'/)") WRITE (IUNITF,"('Dummy line to force implicit OPEN')") BACKSPACE (IUNITF) WRITE (*,"(/' Attempting to create file for torque balances'/)") WRITE (IUNITQ,"('Dummy line to force implicit OPEN')") BACKSPACE (IUNITQ) C C If necessary, average arguments of model-bounding strike-slip C fault elements: C IF (.NOT.SPHERE) THEN CALL SANDER (INPUT,FDIP,ICOND,IUNITT, + log_strike_adjustments, + MXBN,MXFEL,MXNODE,NCOND,NFL, + NODCON,NODEF,VBCARG,VBCMAG, + WEDGE,XNODE,YNODE, + MODIFY,FARG) END IF C C Determine bandwidth of linear systems and compute storage needed: C CALL KSIZE (INPUT,BRIEF,IUNITT,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES,NUMEL,NUMNOD, + OUTPUT,LDA,NUCA,NDOF,NKSIZE,NLB,NUB, + WORK,JCOL1,JCOL2) MXWORK=NKSIZE ALLOCATE (STIFF(MXWORK)) C C Interpolate and initialize all "convenience arrays": C WRITE (*,"(/' Constant arrays are being computed.')") CALL FILLIN (INPUT,ACREEP,ALPHAT,BASAL,BCREEP, + CCREEP,CONDUC, + cooling_curvature, curviness, + delta_rho, density_anomaly, + DQDTDA,ECREEP,ELEV, + ERATE,FPSFER,GMEAN,GRADIE, + ICONVE,IPAFRI,IPVREF,IUNITM,IUNITT, + MXEL,MXFEL,MXNODE,NAMES,NDPLAT,NFL,NODEF, + NODES,NPBND,NPLATE,NUMEL,NUMNOD,OMEGA,ONEKM, + PLAT,PLON, + RADIO,RADIUS,RHOAST,RHOBAR,RHOH2O, + TADIAB,TEMLIM,TLNODE,TRHMAX,TSURF, + VTIMES,WHICHP,XNODE,YNODE,V,ZBASTH,ZMNODE, + OUTPUT,CONTIN,GEOTHC,GEOTHM,GLUE,OVB,PULLED,SIGZZI, + TAUZZI,TAUZZN,TLINT,VM,ZMOHO, + WORK,ATNODE,CHECKN) WRITE (*,"(' Constant arrays have been computed.')") C C Compute tactical values of limits on viscosity, and weights for C imposition of constraints in linear systems: C CALL LIMITS (INPUT,AREA,DETJ,IUNITT,MXEL,NUMEL, + OKDELV,RADIUS,REFSTR,SPHERE,TLINT, + TRHMAX,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) C C Precompute the fixed part of the forcing vector of the linear C systems of equations: C DOFB1=.TRUE. DOFB2=.TRUE. DOFB3=.TRUE. DOFB4=.TRUE. CALL FIXED (INPUT,ALPHAT,AREA,CONDUC, + density_anomaly,DETJ, + DOFB1,DOFB2,DOFB3,DOFB4, + DQDTDA,DXS,DYS, + DXSP,DYSP,EDGETS,ELEV,FDIP,FLEN,FPFLT, + FPSFER,FARG,GMEAN, + ICOND,IUNITT, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + NCOND,NFL,NODCON,NODEF,NODES,NUMEL, + ONEKM,RADIO,RADIUS, + RHOAST,RHOBAR,RHOH2O,SIGZZI, + SITA,TAUZZI,TAUZZN,TEMLIM,TLNODE,TSURF,WEDGE, + XNODE,YNODE,ZMNODE, + OUTPUT,FBASE) C C -Create and solve thin-plate version of equilibrium to determine the C horizontal velocity components (using iteration to handle C nonlinearities): C WRITE (*,"(/' Beginning the iterative solution for velocity.')") CALL PURE (INPUT,ACREEP,ALPHAT,AREA, + BASAL,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,CONTIN,DCREEP, + delta_rho,DETJ,DQDTDA,DXS,DYS, + ECREEP,ELEV,ETAMAX, + EVERYP,FBASE,FDIP,FFRIC,FLEN,FMUMAX, + FPFLT,FPSFER,FARG,GEOTHC,GEOTHM,GLUE, + GMEAN,ICOND,ICONVE,IUNITI,IUNITS,IUNITT, + MAXITR,MXBN,MXDOF,MXEL,MXFEL, + MXNODE,NCOND,NDOF,NFL,NLB,NODCON, + NODEF,NODES,NUB,NUMEL,NUMNOD,OFFMAX, + OFFSET,OKTOQT,ONEKM,OVB,PULLED,RADIO, + RADIUS,RHOBAR,RHOH2O,SITA,SLIDE,SPHERE, + TAUMAX,TEMLIM,TITLE1, + TITLE2,TITLE3,TLINT,TLNODE,TRHMAX, + TSURF,VBCARG,VBCMAG,VISMAX, + WEDGE,XNODE,YNODE,ZMNODE,ZMOHO,999, + MODIFY,V, + OUTPUT,ERATE,ETA,FIMUDZ,FPEAKS,FSLIPS, + SIGHB,TAUMAT,ZTRANC,ZTRANF, + WORK,ALPHA,DV,DVLAST,FORCE,FC,FTSTAR, + OUTVEC,STIFF,TOFSET) C C Test and display the equilibrium found: C CALL BALANC (INPUT,ALPHAT,AREA,CONDUC,CONSTR, + density_anomaly,DETJ,DQDTDA,DXS, + DXSP,DYS,DYSP,EDGETS,ELEV,ETA, + FARG,FC,FDIP, + FIMUDZ,FLEN,FPFLT,FPSFER,FTSTAR, + GMEAN,ICOND,IUNITF, + IUNITT,log_force_balance, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + NCOND,NFL,NODCON,NODEF,NODES, + NUMEL,NUMNOD,ONEKM,OVB,RADIO,RADIUS, + RHOAST,RHOBAR,RHOH2O, + SIGZZI,SITA, + TAUMAT,TAUZZI,TAUZZN,TEMLIM, + TITLE1,TITLE2,TITLE3,TLNODE, + TSURF,V,WEDGE,VBCARG,XNODE,YNODE, + ZMNODE, + MODIFY,SIGHB, + OUTPUT,COMP, + WORK,FBASE,OUTVEC) C C Output the solution: C CALL RESULT (INPUT,ALPHAT,AREA,COMP,DETJ,ELEV,ERATE,EVERYP, + FDIP,FFRIC,FIMUDZ,FPFLT,FPEAKS,FPSFER,FSLIPS, + FARG,GEOTHC,GEOTHM,IUNITQ,IUNITS,IUNITT, + log_node_velocities, + log_element_dynamics, + log_fault_dynamics, + MXDOF,MXEL,MXFEL,MXNODE,NAMES, + NFL,NODEF,NODES,NPLATE,NREALN,NUMEL,NUMNOD, + N1000,ONEKM, + RADIUS,RHOAST,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TAUMAX, + TAUZZI,TITLE1,TITLE2,TITLE3,TLINT,TLNODE, + V,WEDGE,WHICHP,XNODE,YNODE, + ZMNODE,ZMOHO,ZTRANC,ZTRANF, + OUTPUT,TORQBS,TORQCL,TORQFS,TORQLP,TORQMD,TORQSS, + TORQVB) C WRITE (IUNITT,"('----------------------------------------------', + '-------------')") CALL DATE_AND_TIME (date, clock_time, zone, datetimenumber) WRITE ( *,"(' Run ended on ',I4,'.',I2,'.',I2,' at ',I2,':', + I2,':',I2)") + datetimenumber(1), datetimenumber(2), datetimenumber(3), + datetimenumber(5), datetimenumber(6), datetimenumber(7) WRITE (IUNITT,"('Run ended on ',I4,'.',I2,'.',I2,' at ',I2,':', + I2,':',I2)") + datetimenumber(1), datetimenumber(2), datetimenumber(3), + datetimenumber(5), datetimenumber(6), datetimenumber(7) WRITE (IUNITT,"('----------------------------------------------', + '-------------')") C CLOSE (UNIT = IUNITT) WRITE (*,"(' See the logfile for detailed output:')") WRITE (*,"(' ',A)") TRIM(LOGFIL) C DEALLOCATE (STIFF) C WRITE (*,*) WRITE (*,"(' Final step: ', + 'Preparing report of stresses in CSM format...')") CALL CSM_Reporter(INPUT,ACREEP,ALPHAT, + BCREEP,BIOT, + CCREEP,CFRIC,CONDUC,cooling_curvature, + DCREEP,density_anomaly,DQDTDA, + ECREEP,ELEV, + GMEAN,GRADIE, + MXDOF,MXEL,MXFEL,MXNODE, + NDOF,NFL,NODEF,NODES,NUMEL,NUMNOD, + ONEKM, + PULLED, + RADIO,RADIUS,RHOAST,RHOBAR,RHOH2O, + SIGHB,SIGZZN, + TADIAB,TEMLIM,TLNODE,TRHMAX,TSURF, + V,VISMAX, + XNODE, + YNODE, + ZMNODE) C (new free-format code in MODULE CSM_Report) C N.B. These variables contain everything needed to compute C strain-rates and stresses at any point in the continuum C elements, which make up "100% of the volume" of any C SHELLS domain. C Most values are scalars (BIOT,CFRIC,GMEAN,ONEKM,RADIUS,...) C two-vectors (crust/mantle: ACREEP, BCREEP, ...) C or lists of values at nodes (ELEV,DQDTDA,V,...); C the only quantities provided at integration points are C PULLED (logical, T/F) and SIGHB (a horizontal 2-vector) C for each integration point of each continuum element). C The new code will be responsible for C reading in the desired grid points, interpolating, C and writing the new output file SHELLS_for_CSM.txt. WRITE (*,*) WRITE (*,"(' Report done. See file SHELLS_for_CSM.txt.')") CALL PAUSE() STOP C C END PROGRAM Shells_for_CSM {not required in Fortran 70 syntax}. C END C C C SUBROUTINE ADDFST (INPUT,CONSTR,FC,FDIP,FIMUDZ,FLEN,FPFLT,FARG, + MXDOF,MXFEL,MXNODE, + NFL,NODEF, + V,WEDGE, + MODIFY,F,K) C C Add fault stiffness to linear system. C C A two-step process is used: C -A stiffness matrix for the fault element is formed, using C generic node numbering, 1-4. Each entry in this matrix is C a 2 x 2 submatrix because node velocities have two components. C -The element stiffness matrix terms are added to the global C stiffness matrix. (This step involves complex indirect C addressing, and is very difficult to optimize.) C C The constant CONSTR is the weight used in enforcing C strike-slip constraint equations. It has the same units as C FIMUDZ and has a value comparable to C FMUMAX*(thickness of the plate). C DOUBLE PRECISION ELK,F,K,V DOUBLE PRECISION FPHI,FPOINT,FGAUSS DIMENSION FPHI(4,7),FPOINT(7),FGAUSS(7),FPFLT(2,2,2,7,MXFEL) DIMENSION F(MXDOF),FC(2,2,7,MXFEL),FDIP(2,MXFEL),FLEN(MXFEL), + FIMUDZ(7,MXFEL),FARG(2,MXFEL), + NODEF(4,MXFEL),V(2,MXNODE) DIMENSION ELK(2,2,4,4),FP(2,2,4),K(MXWORK),FSTIF(8,8) COMMON LDA,NUCA,MXWORK COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS C C Statement function replacing INTEGER FUNCTION subprogram INDEXK: INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + NUCA + IROW - JCOLUM + 1 C C Note: Convention is that row numbers identify the force balance C equation, while column numbers identify the degree C of freedom influencing that force balance. C DO 500 IFE=1,NFL C C Zero and then build up the element stiffness matrix: C DO 10 I=1,4 DO 9 J=1,4 ELK(1,1,I,J)=0.0D0 ELK(1,2,I,J)=0.0D0 ELK(2,1,I,J)=0.0D0 ELK(2,2,I,J)=0.0D0 9 CONTINUE 10 CONTINUE DO 12 I=1,8 DO 11 J=1,8 FSTIF(I,J)=0.0 11 CONTINUE 12 CONTINUE C C DO 60 M=1,7 CCCCC ANGLE=FARG(1,IFE)*FPHI(1,M)+FARG(2,IFE)*FPHI(2,M) CCCCC Line above was replaced because of cycle-shift problem! C ANGLE=CHORD(FARG(1,IFE),FPHI(2,M),FARG(2,IFE)) C SINA=SIN(ANGLE) COSA=COS(ANGLE) DS=FLEN(IFE)*FGAUSS(M) DIP=FPHI(1,M)*FDIP(1,IFE)+FPHI(2,M)*FDIP(2,IFE) DO 15 J=1,2 JJ=4 IF(J.EQ.2) JJ=3 FP(1,1,J)=FPFLT(1,1,J,M,IFE) FP(2,1,J)=FPFLT(2,1,J,M,IFE) FP(1,2,J)=FPFLT(1,2,J,M,IFE) FP(2,2,J)=FPFLT(2,2,J,M,IFE) FP(1,1,JJ)=-FP(1,1,J) FP(2,1,JJ)=-FP(2,1,J) FP(1,2,JJ)=-FP(1,2,J) FP(2,2,JJ)=-FP(2,2,J) 15 CONTINUE IF (ABS(DIP-1.570796).LE.WEDGE) THEN C C Vertical strike-slip fault C DO 30 I=1,4 DO 20 J=1,4 TM1111= (FP(1,1,J)*COSA+FP(1,2,J)*SINA) + *(FP(1,1,I)*COSA+FP(1,2,I)*SINA) + *DS*FIMUDZ(M,IFE) TM1112= (FP(1,1,J)*COSA+FP(1,2,J)*SINA) + *(FP(2,1,I)*COSA+FP(2,2,I)*SINA) + *DS*FIMUDZ(M,IFE) TM1211= (FP(2,1,J)*COSA+FP(2,2,J)*SINA) + *(FP(1,1,I)*COSA+FP(1,2,I)*SINA) + *DS*FIMUDZ(M,IFE) TM1212= (FP(2,1,J)*COSA+FP(2,2,J)*SINA) + *(FP(2,1,I)*COSA+FP(2,2,I)*SINA) + *DS*FIMUDZ(M,IFE) TM2121= (-FP(1,1,J)*SINA+FP(1,2,J)*COSA) + *(-FP(1,1,I)*SINA+FP(1,2,I)*COSA) + *DS*CONSTR TM2122= (-FP(1,1,J)*SINA+FP(1,2,J)*COSA) + *(-FP(2,1,I)*SINA+FP(2,2,I)*COSA) + *DS*CONSTR TM2221= (-FP(2,1,J)*SINA+FP(2,2,J)*COSA) + *(-FP(1,1,I)*SINA+FP(1,2,I)*COSA) + *DS*CONSTR TM2222= (-FP(2,1,J)*SINA+FP(2,2,J)*COSA) + *(-FP(2,1,I)*SINA+FP(2,2,I)*COSA) + *DS*CONSTR ELK(1,1,I,J)=ELK(1,1,I,J)+TM1111 + +TM2121 ELK(1,2,I,J)=ELK(1,2,I,J)+TM1211 + +TM2221 ELK(2,1,I,J)=ELK(2,1,I,J)+TM1112 + +TM2122 ELK(2,2,I,J)=ELK(2,2,I,J)+TM1212 + +TM2222 20 CONTINUE 30 CONTINUE ELSE C C Dipping oblique-slip fault C OSIND=1./SIN(DIP) OCOSD=1./COS(DIP) OSIN2D=1./SIN(2.*DIP) DO 50 I=1,4 DO 40 J=1,4 ADS11=(FC(1,1,M,IFE)*( FP(1,1,J)*COSA+ + FP(1,2,J)*SINA) + +FC(1,2,M,IFE)*OCOSD*(-FP(1,1,J)*SINA+ + FP(1,2,J)*COSA))*DS ADS12=(FC(1,1,M,IFE)*( FP(2,1,J)*COSA+ + FP(2,2,J)*SINA) + +FC(1,2,M,IFE)*OCOSD*(-FP(2,1,J)*SINA+ + FP(2,2,J)*COSA))*DS ADS21=(FC(2,1,M,IFE)*( FP(1,1,J)*COSA+ + FP(1,2,J)*SINA) + +FC(2,2,M,IFE)*OCOSD*(-FP(1,1,J)*SINA+ + FP(1,2,J)*COSA))*DS ADS22=(FC(2,1,M,IFE)*( FP(2,1,J)*COSA+ + FP(2,2,J)*SINA) + +FC(2,2,M,IFE)*OCOSD*(-FP(2,1,J)*SINA+ + FP(2,2,J)*COSA))*DS B11=FP(1,1,I)*COSA+FP(1,2,I)*SINA B12=FP(2,1,I)*COSA+FP(2,2,I)*SINA B21=-FP(1,1,I)*SINA+FP(1,2,I)*COSA B22=-FP(2,1,I)*SINA+FP(2,2,I)*COSA ELK(1,1,I,J)=ELK(1,1,I,J)+ADS11*B11*OSIND + +2.*ADS21*B21*OSIN2D ELK(1,2,I,J)=ELK(1,2,I,J)+ADS12*B11*OSIND + +2.*ADS22*B21*OSIN2D ELK(2,1,I,J)=ELK(2,1,I,J)+ADS11*B12*OSIND + +2.*ADS21*B22*OSIN2D ELK(2,2,I,J)=ELK(2,2,I,J)+ADS12*B12*OSIND + +2.*ADS22*B22*OSIN2D 40 CONTINUE 50 CONTINUE ENDIF 60 CONTINUE C C Apply element matrix to augment global stiffness matrix K: C DO 400 I4=1,4 NODEI=NODEF(I4,IFE) IRY=2*NODEI IRX=IRY-1 IFY=2*I4 IFX=IFY-1 DO 300 J4=1,4 NODEJ=NODEF(J4,IFE) JCY=2*NODEJ JCX=JCY-1 JFY=2*J4 JFX=JFY-1 IKXX=INDEXK(IRX,JCX) K(IKXX)=K(IKXX)+ELK(1,1,I4,J4) IKXY=INDEXK(IRX,JCY) K(IKXY)=K(IKXY)+ELK(1,2,I4,J4) IKYX=INDEXK(IRY,JCX) K(IKYX)=K(IKYX)+ELK(2,1,I4,J4) IKYY=INDEXK(IRY,JCY) K(IKYY)=K(IKYY)+ELK(2,2,I4,J4) C IF (ABS(DIP-1.570796).GT.WEDGE) THEN C FSTIF(IFX,JFX)=ELK(1,1,I4,J4) C FSTIF(IFX,JFY)=ELK(1,2,I4,J4) C FSTIF(IFY,JFX)=ELK(2,1,I4,J4) C FSTIF(IFY,JFY)=ELK(2,2,I4,J4) C ENDIF 300 CONTINUE 400 CONTINUE 500 CONTINUE RETURN END C C C SUBROUTINE ASSIGN (INPUT,IUNITT, + NAMES,NPBND,NDPLAT,NFL,NODEF,NODES, + NPLATE,NUMEL,NUMNOD, + OMEGA,PLAT,PLON, + XNODE,YNODE, + OUTPUT,WHICHP, + WORK,CHECKN) C C Assigns an integer plate ID# to each node of the grid. C CHARACTER*2, DIMENSION(NPLATE) :: NAMES INTEGER :: NPBND INTEGER, DIMENSION(NPLATE) :: NDPLAT INTEGER :: NFL INTEGER, DIMENSION(4,NFL) :: NODEF INTEGER, DIMENSION(3,NUMEL) :: NODES INTEGER :: NPLATE INTEGER :: NUMEL INTEGER :: NUMNOD REAL, DIMENSION(3,NPLATE) :: OMEGA REAL, DIMENSION(NPLATE,NPBND):: PLAT, PLON REAL, DIMENSION(NUMNOD) :: XNODE, YNODE INTEGER, DIMENSION(NUMNOD) :: WHICHP LOGICAL, DIMENSION(NUMNOD) :: CHECKN C INTEGER :: OLDIP LOGICAL :: GOTOUT REAL, DIMENSION(3) :: ALONGV,CROSSV C C PB2002 model of Bird [2003; G**3]; C Already has plate NAMES and OMEGA vectors in C main program (DATA statements); C must also have digitised plate C outlines in arrays PLAT and PLON, C presumably read from file "PB2002_plates.dig". C That is, this routine will not read any file. C C Check which nodes are on faults: DO 10 I=1,NUMNOD CHECKN(I)=.FALSE. 10 CONTINUE DO 30 I=1,NFL DO 20 K=1,4 CHECKN(NODEF(K,I))=.TRUE. 20 CONTINUE 30 CONTINUE C C For nodes on faults, attempt to offset test position C which is used to determine plate membership C (but not position used in V = OMEGA x R ) DO 999 I=1,NUMNOD XVEL=XNODE(I) YVEL=YNODE(I) IF (CHECKN(I)) THEN C C Node is on fault; seek offset position C for determination of plate affiliation... C GOTOUT=.FALSE. C C 1st strategy: C Is there a continuum element including this node C which has some other node NOT on a fault? C If so, use that other node's position. C DO 100 J=1,NUMEL N1=NODES(1,J) N2=NODES(2,J) N3=NODES(3,J) IF ((N1.EQ.I).OR.(N2.EQ.I).OR.(N3.EQ.I)) THEN IF ((N1.NE.I).AND.(.NOT.CHECKN(N1)))THEN GOTOUT=.TRUE. XINPL=XNODE(N1) YINPL=YNODE(N1) GO TO 101 ENDIF IF ((N2.NE.I).AND.(.NOT.CHECKN(N2)))THEN GOTOUT=.TRUE. XINPL=XNODE(N2) YINPL=YNODE(N2) GO TO 101 ENDIF IF ((N3.NE.I).AND.(.NOT.CHECKN(N3)))THEN GOTOUT=.TRUE. XINPL=XNODE(N3) YINPL=YNODE(N3) GO TO 101 ENDIF ENDIF 100 CONTINUE C C If there is still a problem, try C 2nd strategy: C If any continuum element includes this node C (even though its other nodes are all on faults), C we can use the midpoint of the continuum element... C 101 IF (.NOT.GOTOUT) THEN DO 200 J=1,NUMEL N1=NODES(1,J) N2=NODES(2,J) N3=NODES(3,J) IF ((N1.EQ.I).OR.(N2.EQ.I).OR. + (N3.EQ.I)) THEN GOTOUT=.TRUE. A1=SIN(XNODE(N1))*COS(YNODE(N1)) B1=SIN(XNODE(N1))*SIN(YNODE(N1)) G1=COS(XNODE(N1)) A2=SIN(XNODE(N2))*COS(YNODE(N2)) B2=SIN(XNODE(N2))*SIN(YNODE(N2)) G2=COS(XNODE(N2)) A3=SIN(XNODE(N3))*COS(YNODE(N3)) B3=SIN(XNODE(N3))*SIN(YNODE(N3)) G3=COS(XNODE(N3)) AC=(A1+A2+A3)/3. BC=(B1+B2+B3)/3. GC=(G1+G2+G3)/3. SIZE=SQRT(AC**2+BC**2+GC**2) AC=AC/SIZE BC=BC/SIZE GC=GC/SIZE EQUAT=SQRT(AC**2+BC**2) XINPL=ATAN2(EQUAT,GC) YINPL=ATAN2(BC,AC) GO TO 201 ENDIF 200 CONTINUE ENDIF C C If there is still a problem, then this fault C node does not belong to any continuum element. C It must be on the outer perimeter of the model. C Try a small offset toward the outside... C 201 IF (.NOT.GOTOUT) THEN C Find where node I is on the fault... DO 220 J=1,NFL DO 210 K=1,4 IF (NODEF(K,J).EQ.I) THEN C N.B. K & J are what we are seeking. GOTO 221 ENDIF 210 CONTINUE 220 CONTINUE 221 IF (K.LE.2) THEN C Node is on N1-N2 side of fault. N1=NODEF(1,J) N2=NODEF(2,J) ELSE C Node is on N3-N4 side of fault. N1=NODEF(3,J) N2=NODEF(4,J) END IF C X1=COS(YNODE(N1))*SIN(XNODE(N1)) Y1=SIN(YNODE(N1))*SIN(XNODE(N1)) Z1=COS(XNODE(N1)) X2=COS(YNODE(N2))*SIN(XNODE(N2)) Y2=SIN(YNODE(N2))*SIN(XNODE(N2)) Z2=COS(XNODE(N2)) ALONGV(1)=X2-X1 ALONGV(2)=Y2-Y1 ALONGV(3)=Z2-Z1 XOFF=X1+0.5*ALONGV(1) YOFF=Y1+0.5*ALONGV(2) ZOFF=Z1+0.5*ALONGV(3) CROSSV(1)=ALONGV(2)*ZOFF-ALONGV(3)*YOFF CROSSV(2)=ALONGV(3)*XOFF-ALONGV(1)*ZOFF CROSSV(3)=ALONGV(1)*YOFF-ALONGV(2)*XOFF C Crossv has same length as ALONGV, C and points out of fault (to right, C when looking from N1 toward N2). XOFF=XOFF+0.25*CROSSV(1) YOFF=YOFF+0.25*CROSSV(2) ZOFF=ZOFF+0.25*CROSSV(3) EQUAT=SQRT(XOFF**2+YOFF**2) XINPL=ATAN2(EQUAT,ZOFF) YINPL=ATAN2(YOFF,XOFF) ENDIF ELSE C C Node is not on any fault; C no offset of position is needed: C XINPL=XVEL YINPL=YVEL ENDIF XO=COS(YINPL)*SIN(XINPL) YO=SIN(YINPL)*SIN(XINPL) ZO=COS(XINPL) OXYZ=XO*XO+YO*YO+ZO*ZO OXYZ=SQRT(OXYZ) XO=XO/OXYZ YO=YO/OXYZ ZO=ZO/OXYZ NPOINT=0 ANGLE=0.0 IPLATE=0 DO 500 IP=1,NPLATE TANGL=0.0 NEND=NDPLAT(IP) DO 300 J=1,NEND J2=J+1 IF(J.EQ.NEND) THEN J2=1 ENDIF A1=COS(PLON(IP,J))*COS(PLAT(IP,J)) A2=SIN(PLON(IP,J))*COS(PLAT(IP,J)) A3=SIN(PLAT(IP,J)) B1=COS(PLON(IP,J2))*COS(PLAT(IP,J2)) B2=SIN(PLON(IP,J2))*COS(PLAT(IP,J2)) B3=SIN(PLAT(IP,J2)) AO=XO*A1+YO*A2+ZO*A3 BO=XO*B1+YO*B2+ZO*B3 A1=A1/AO A2=A2/AO A3=A3/AO B1=B1/BO B2=B2/BO B3=B3/BO A1=A1-XO A2=A2-YO A3=A3-ZO B1=B1-XO B2=B2-YO B3=B3-ZO AA=SQRT(A1*A1+A2*A2+A3*A3) BB=SQRT(B1*B1+B2*B2+B3*B3) AB1=A2*B3-A3*B2 AB2=A3*B1-A1*B3 AB3=A1*B2-A2*B1 STHETA=(AB1*XO+AB2*YO+AB3*ZO)/(AA*BB) C prevent stupid abends due to imprecision: STHETA=MAX(-1.,MIN(1.,STHETA)) TANGL=TANGL+ASIN(STHETA) 300 CONTINUE DANGLE=TANGL-3.1416 IF(DANGLE.GE.0.0001) THEN NPOINT=NPOINT+1 IPLATE=IP ENDIF 500 CONTINUE IF(NPOINT.GE.3) THEN XPOINT=90.0-XINPL*57.29577951 YPOINT=YINPL*57.29577951 WRITE(IUNITT,505) XPOINT,YPOINT 505 FORMAT(' POINT ',2F10.3,' WAS FOUND IN MORE THAN TWO' + ,'PLATES; SOMETHING IS WRONG !!!!') CALL PAUSE() STOP ENDIF IF (IPLATE.EQ.0) THEN XPOINT=90.0-XINPL*57.29577951 YPOINT=YINPL*57.29577951 WRITE(IUNITT,600) XPOINT,YPOINT WRITE(*,600) XPOINT,YPOINT 600 FORMAT(' THE POINT ', 2F13.5,' DOES NOT BELONG TO' + ,' ANY PLATE !!!!' + /' Arbitrarily assigning to last previous plate.') CALL PAUSE() IPLATE=OLDIP ENDIF C WHICHP(I)=IPLATE OLDIP=IPLATE C 999 CONTINUE END C C C REAL FUNCTION ATAN2F (Y,X) C C Corrects for problem of abend due to ATAN2(0.,0.): C IF ((Y.NE.0.).OR.(X.NE.0.)) THEN ATAN2F=ATAN2(Y,X) ELSE ATAN2F=0. ENDIF RETURN END C C C SUBROUTINE BALANC (INPUT,ALPHAT,AREA,CONDUC,CONSTR, + density_anomaly,DETJ,DQDTDA,DXS, + DXSP,DYS,DYSP,EDGETS,ELEV,ETA, + FARG,FC,FDIP, + FIMUDZ,FLEN,FPFLT,FPSFER,FTSTAR, + GMEAN,ICOND,IUNITF, + IUNITT,log_force_balance, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + NCOND,NFL,NODCON,NODEF,NODES, + NUMEL,NUMNOD,ONEKM,OVB,RADIO,RADIUS, + RHOAST,RHOBAR,RHOH2O, + SIGZZI,SITA, + TAUMAT,TAUZZI,TAUZZN,TEMLIM, + TITLE1,TITLE2,TITLE3,TLNODE, + TSURF,V,WEDGE,VBCARG,XNODE,YNODE, + ZMNODE, + MODIFY,SIGHB, + OUTPUT,COMP, + WORK,FBASE,OUTVEC) C C============= C Test #1: C============= C Checks the balance of forces on each node by computing the C convolutions of all nodal functions with the standardised C traction anomalies over the surface of artificial fixed-V C boundaries. For any degree of freedom that has been removed by C the imposition of a velocity boundary condition, this gives the C consistent nodal force required to impose that velocity. C For boundary nodes which are free (except for lithostatic C pressure), gives the horizontal force due to this pressure. C If Shells is working properly, then the convolutions C for internal nodes should be "small" (compared to the area C integral of the dot product of a nodal function (of order 1) C with typical traction anomalies over the surface C which projects vertically through the plate from a typical C element side on the surface). For example, in SI units, if the C layer thickness is 1E5 m, the typical element side is C 6E5 m, and the typical stress anomaly is 5.E7 Pa, then C an apparent force of 3.E18 N would be "large" (100% error), C but an apparent force OF 3.E15 N would be "small" (equilibrium C within 0.1%). C C============= C Test #2: C============= C Checks the global balance of forces by computing the net C torque on the model passed through all boundaries C (basal pressure and drag, faults, side boundary conditions) C which should, of course, be zero (except for numeric error). C C Note: For this purpose, the array SIGHB is modified from C the nonlinear flow-law value (of -THONB-) to the linearized C value, based on the ETA of the last iteration. If the C solution is well converged, this should be a small change. C CHARACTER*2 CX, CY, CZ CHARACTER*15 LARGE, SIZE, SMALL CHARACTER*80 TITLE1,TITLE2,TITLE3 INTEGER WHICHP LOGICAL DOFB1,DOFB2,DOFB3,DOFB4,EDGETS,HASBC,SLOPED LOGICAL :: log_force_balance DOUBLE PRECISION ABSVDA,ABSWDA,ARE,FBASE, + TQXX,TQYY,TQZZ,V,VTDA,WTDA DOUBLE PRECISION POINTS,WEIGHT DOUBLE PRECISION FPHI,FPOINT,FGAUSS DOUBLE PRECISION DUMMYT C COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS COMMON /S1S2S3/ POINTS COMMON /WGTVEC/ WEIGHT DIMENSION POINTS(3,7),WEIGHT(7) DIMENSION FPHI(4,7),FPOINT(7),FGAUSS(7) DIMENSION AREA(MXEL),ALPHAT(2), + COMP(6,MXDOF),CONDUC(2),density_anomaly(MXNODE), + DETJ(7,MXEL),DQDTDA(MXNODE),DUMMYT(3), + DXS(2,2,3,7,MXEL),DXSP(3,7,MXEL), + DYS(2,2,3,7,MXEL),DYSP(3,7,MXEL), + EDGETS(3,MXEL),ELEV(MXNODE),ETA(7,MXEL), + FARG(2,MXFEL),FBASE(MXDOF),FC(2,2,7,MXFEL), + FDIP(2,MXFEL),FIMUDZ(7,MXFEL), + FLEN(MXFEL),FPFLT(2,2,2,7,MXFEL), + FPSFER(2,2,3,7,MXEL),FTSTAR(2,7,MXFEL),ICOND(MXBN), + NODCON(MXBN),NODEF(4,MXFEL),NODES(3,MXEL), + OUTVEC(2,7,MXEL),OVB(2,7,MXEL),RADIO(2),RHOBAR(2), + SIGHB(2,7,MXEL),SIGZZI(7,MXEL),SITA(7,MXEL), + TAUMAT(3,7,MXEL),TAUZZI(7,MXEL),TAUZZN(MXNODE), + TEMLIM(2),TLNODE(MXNODE), + V(2,MXNODE),VBCARG(MXBN), + XNODE(MXNODE),YNODE(MXNODE),ZMNODE(MXNODE) DATA CX /'+S'/, CY /'+E'/ DATA LARGE /'MAY BE LARGE '/, SMALL /'should be small'/ C C Write text explaining purpose of table: C IF (log_force_balance) WRITE (IUNITT,10) 10 FORMAT (' ===================================', + '===================================') IF (log_force_balance) WRITE (IUNITT,1) 1 FORMAT (/ +/' Check the balance of forces on each node by computing the' +/' convolutions of all nodal functions with the standardised' +/' traction anomalies over the surface of artificial fixed-V' +/' boundaries. For degrees of freedom that have been removed by' +/' the imposition of velocity boundary conditions, this gives the' +/' consistent nodal forces required to impose those velocities.' +/' For boundary nodes which are free (except for lithostatic' +/' pressure), gives the horizontal force due to this pressure.') IF (log_force_balance) WRITE (IUNITT,2) 2 FORMAT (/ +/' If the program is working correctly, then the convolutions' +/' for internal nodes should be "small" (compared to the area' +/' integral of the dot product of a nodal function (order 1)' +/' with typical traction anomalies over the surface' +/' which projects vertically through the plate from a typical' +/' element side on the surface). For example, in SI units, if' +/' the layer thickness is 1E5 m, the typical element side is' +/' 6E5 m, and the typical stress anomaly is 5.E7 Pa, then' +/' an apparent force of 3.E18 N would be "large" (100% error),' +/' but an apparent force of 3.E15 would be "small" (equilibrium' +/' within 0.1%).') IF (log_force_balance) WRITE (IUNITT,3) 3 FORMAT (/' Explanation of the table:'/ / +' Each row corresponds to one degree of freedom, so'/ +' row 1 gives apparent force on node 1 in the South direction,'/ +' row 2 gives apparent force on node 1 in the East direction,'/ +' row 3 gives apparent force on node 2 in the South direction,'/ +' et cetera.'/ / +' The *Total* column gives the convolution of nodal functions'/ +' with all traction anomalies on all surfaces of the model'/ +' (external top, bottom, and sides, plus internal faults).'/ +' The *Fault_P* column gives the convolution of nodal functions'/ +' with pressure-anomalies on internal fault surfaces.'/ +' The *Fault_S* column gives the convolution of nodal functions'/ +' with deviatoric tractions on internal fault surfaces.'/ +' The *Base_P* column gives the convolution of nodal functions'/ +' with pressure-anomaly*grad(depth of base of lithosphere).'/ +' The *Base_S* column gives the convolution of nodal functions'/ +' with shear tractions on the base of the lithosphere.'/ +' The *Bounds* column = *Total* - *Fault* - *Base_P* - *Base_S*,' +/' and gives the convolution of nodal functions with'/ +' traction anomalies on artificial fixed-V nodes.'/ +' The *Comment* column indicates whether *Bounds* is expected'/ +' to be small or not.'/ /) IF (log_force_balance) WRITE (IUNITT,4) 4 FORMAT (' Node Component *Total* *Fault_P*', + ' *Fault_S* *Base_P* *Base_S* *Bounds* *Comment*') 5 FORMAT (' ',I10,8X,A2,6ES10.2,1X,A15) C NENTRY=2*NUMNOD DO 110 I=1,NENTRY COMP(1,I)=0. COMP(2,I)=0. COMP(3,I)=0. COMP(4,I)=0. COMP(5,I)=0. C (no need to zero COMP(6,I), as it is not an accumulated sum) 110 CONTINUE C C *Total* column is convolution of nodal functions with C total inhomogeneous term(s) in horizontal C stress-equilibrium equation for the plate shell(s): C DO 150 M=1,7 DO 140 I=1,NUMEL TAUXX=TAUMAT(1,M,I)+TAUZZI(M,I) TAUYY=TAUMAT(2,M,I)+TAUZZI(M,I) TAUXY=TAUMAT(3,M,I) SINS=1.0/SIN(SITA(M,I)) TANS=1.0/TAN(SITA(M,I)) DAOR=AREA(I)*WEIGHT(M)*DETJ(M,I)/RADIUS DO 130 J=1,3 NODE=NODES(J,I) IX=2*NODE-1 IY=IX+1 DUXX=TAUXX*DXS(1,1,J,M,I) DUXY=TAUXY*(DXS(1,2,J,M,I) + +DYS(1,1,J,M,I)*SINS + -FPSFER(1,2,J,M,I)*TANS) DUYY=TAUYY*(DYS(1,2,J,M,I)*SINS + +FPSFER(1,1,J,M,I)*TANS) COMP(1,IX)=COMP(1,IX)+DAOR*(DUXX+DUXY+DUYY) DUXX=TAUXX*DXS(2,1,J,M,I) DUXY=TAUXY*(DXS(2,2,J,M,I) + +DYS(2,1,J,M,I)*SINS + -FPSFER(2,2,J,M,I)*TANS) DUYY=TAUYY*(DYS(2,2,J,M,I)*SINS + +FPSFER(2,1,J,M,I)*TANS) COMP(1,IY)=COMP(1,IY)+DAOR*(DUXX+DUXY+DUYY) 130 CONTINUE 140 CONTINUE 150 CONTINUE C C *Fault_P* column is convolution of nodal functions with C lithostatic pressures on fault surfaces: C Anomaly in lithostatic vertical compressive stress C (relative to standard weak-ridge structure) C integrated down the dip of the fault: C DOFB1=.FALSE. DOFB2=.FALSE. DOFB3=.FALSE. DOFB4=.TRUE. CALL FIXED (INPUT,ALPHAT,AREA,CONDUC, + density_anomaly,DETJ, + DOFB1,DOFB2,DOFB3,DOFB4, + DQDTDA,DXS,DYS, + DXSP,DYSP,EDGETS,ELEV,FDIP,FLEN,FPFLT, + FPSFER,FARG,GMEAN, + ICOND,IUNITT, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + NCOND,NFL,NODCON,NODEF,NODES,NUMEL, + ONEKM,RADIO,RADIUS, + RHOAST,RHOBAR,RHOH2O,SIGZZI, + SITA,TAUZZI,TAUZZN,TEMLIM,TLNODE,TSURF,WEDGE, + XNODE,YNODE,ZMNODE, + OUTPUT,FBASE) DO 210 I=1,NENTRY COMP(2,I)=FBASE(I) 210 CONTINUE C C *Fault_S* column: C C tractions caused by departures of stress from the local C lithostatic pressure, due to strength (deviatoric stress), C integrated down the dip of faults: C DO 290 I=1,NFL N1=NODEF(1,I) N2=NODEF(2,I) N3=NODEF(3,I) N4=NODEF(4,I) DO 280 M=1,7 C C ANGLE is the fault strike, in radians cclkws from +X. CCCCC ANGLE=FARG(1,I)*FPHI(1,M)+FARG(2,I)*FPHI(2,M) CCCCC Line above was replaced due to cycle-shift problem! C ANGLE=CHORD(FARG(1,I),FPHI(2,M),FARG(2,I)) C ANGLE is the argument of the forward ray from N1-->N2, C measured counterclockwise from +theta = +X = South. C C UNITA is a unit vector along the fault, from N1-->N2. UNITAX=COS(ANGLE) UNITAY=SIN(ANGLE) C C UNITB is a perpendicular unit vector, pointing in C (toward the N4-N3 side). UNITBX= -UNITAY UNITBY= +UNITAX C C Relative velocities are for N1-N2 side relative to C the N4-N3 side: DELVX=V(1,N1)*FPFLT(1,1,1,M,I)+V(2,N1)*FPFLT(2,1,1,M,I) + +V(1,N2)*FPFLT(1,1,2,M,I)+V(2,N2)*FPFLT(2,1,2,M,I) + -V(1,N3)*FPFLT(1,1,2,M,I)-V(2,N3)*FPFLT(2,1,2,M,I) + -V(1,N4)*FPFLT(1,1,1,M,I)-V(2,N4)*FPFLT(2,1,1,M,I) DELVY=V(1,N1)*FPFLT(1,2,1,M,I)+V(2,N1)*FPFLT(2,2,1,M,I) + +V(1,N2)*FPFLT(1,2,2,M,I)+V(2,N2)*FPFLT(2,2,2,M,I) + -V(1,N3)*FPFLT(1,2,2,M,I)-V(2,N3)*FPFLT(2,2,2,M,I) + -V(1,N4)*FPFLT(1,2,1,M,I)-V(2,N4)*FPFLT(2,2,1,M,I) C C Sinistral strike-slip rate component: SINIST=DELVX*UNITAX+DELVY*UNITAY C C Convergence rate component (in horizontal plane): CLOSE =DELVX*UNITBX+DELVY*UNITBY C C Dip of the fault (from horizontal on the N1-N2 side): DIP=FDIP(1,I)*FPHI(1,M)+FDIP(2,I)*FPHI(2,M) SLOPED=ABS(DIP-1.570796).GT.WEDGE C C Find traction on N3-N4 side in alpha, gamma coordinates IF (SLOPED) THEN VUPDIP=CLOSE/COS(DIP) C positive for thrusting with dip.LT.Pi/2 TAIDZ=FC(1,1,M,I)*SINIST+FC(1,2,M,I)*VUPDIP+ + FTSTAR(1,M,I) TBIDZ=FC(2,1,M,I)*SINIST+FC(2,2,M,I)*VUPDIP+ + FTSTAR(2,M,I) TGIDZ=TBIDZ/COS(DIP) TAIDB=TAIDZ/SIN(DIP) TGIDB=TGIDZ/SIN(DIP) ELSE TAIDB=FIMUDZ(M,I)*SINIST TGIDB=CONSTR*CLOSE ENDIF C C Reverse for tractions on N1-N2 side: TAIDB= -TAIDB TGIDB= -TGIDB C Now, positive TGIDB is associated with divergence C and positive TAIDB is associated with dextral slip. C C Express traction on N1-N2 side in X,Y coordinates: TXIDB=TAIDB*COS(ANGLE)-TGIDB*SIN(ANGLE) TYIDB=TGIDB*COS(ANGLE)+TAIDB*SIN(ANGLE) C DS=FLEN(I)*FGAUSS(M) C DO 270 J=1,2 NODE=NODEF(J,I) IX=2*NODE-1 IY=IX+1 COMP(3,IX)=COMP(3,IX)+DS* + (TXIDB*FPFLT(1,1,J,M,I)+TYIDB*FPFLT(1,2,J,M,I)) COMP(3,IY)=COMP(3,IY)+DS* + (TXIDB*FPFLT(2,1,J,M,I)+TYIDB*FPFLT(2,2,J,M,I)) JJ=5-J NODE=NODEF(JJ,I) IX=2*NODE-1 IY=IX+1 COMP(3,IX)=COMP(3,IX)-DS* + (TXIDB*FPFLT(1,1,J,M,I)+TYIDB*FPFLT(1,2,J,M,I)) COMP(3,IY)=COMP(3,IY)-DS* + (TXIDB*FPFLT(2,1,J,M,I)+TYIDB*FPFLT(2,2,J,M,I)) 270 CONTINUE 280 CONTINUE 290 CONTINUE C C *Base_P* column is convolution of nodal functions with C basal pressure-anomaly * grad(bottom depth): C DOFB1=.FALSE. DOFB2=.TRUE. DOFB3=.FALSE. DOFB4=.FALSE. CALL FIXED (INPUT,ALPHAT,AREA,CONDUC, + density_anomaly,DETJ, + DOFB1,DOFB2,DOFB3,DOFB4, + DQDTDA,DXS,DYS, + DXSP,DYSP,EDGETS,ELEV,FDIP,FLEN,FPFLT, + FPSFER,FARG,GMEAN, + ICOND,IUNITT, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + NCOND,NFL,NODCON,NODEF,NODES,NUMEL, + ONEKM,RADIO,RADIUS, + RHOAST,RHOBAR,RHOH2O,SIGZZI, + SITA,TAUZZI,TAUZZN,TEMLIM,TLNODE,TSURF,WEDGE, + XNODE,YNODE,ZMNODE, + OUTPUT,FBASE) DO 310 I=1,NENTRY COMP(4,I)=FBASE(I) 310 CONTINUE C C *Base_S* column is convolution of nodal functions with C shear tractions on base of lithosphere C (based on linearized form, not flow-law form; C should be similar if solution is converged): C CALL FLOW (INPUT,FPSFER,MXEL,MXNODE,NODES,NUMEL,V, + OUTPUT,OUTVEC) DO 350 M=1,7 DO 340 I=1,NUMEL DA=AREA(I)*WEIGHT(M)*DETJ(M,I) SIGHB(1,M,I)=ETA(M,I)*(OVB(1,M,I)-OUTVEC(1,M,I)) SIGHB(2,M,I)=ETA(M,I)*(OVB(2,M,I)-OUTVEC(2,M,I)) DO 330 J=1,3 NODE=NODES(J,I) IX=2*NODE-1 IY=IX+1 COMP(5,IX)=COMP(5,IX)+DA* + (SIGHB(1,M,I)*FPSFER(1,1,J,M,I)+ + SIGHB(2,M,I)*FPSFER(1,2,J,M,I)) COMP(5,IY)=COMP(5,IY)+DA* + (SIGHB(1,M,I)*FPSFER(2,1,J,M,I)+ + SIGHB(2,M,I)*FPSFER(2,2,J,M,I)) 330 CONTINUE 340 CONTINUE 350 CONTINUE C C *Bounds* column is inferred from preceding five columns, C and should represent the either: C (1) consistent nodal forces due to velocity boundary conditions; C OR (2) consistent nodal forces due to pressure anomalies on any C "free" lateral boundaries [not applicable in global models]. C DO 400 I=1,NENTRY COMP(6,I)=COMP(1,I)-COMP(2,I)-COMP(3,I)-COMP(4,I)-COMP(5,I) 400 CONTINUE C C Write out matrix, with annotations: C (Also, sum forces times velocities over boundary nodes.) C SUMVDF=0. DO 1000 I=1,NENTRY C NODE=(I+1)/2 C IF (MOD(I,2).EQ.1) THEN CZ=CX ELSE CZ=CY ENDIF C C Are we expecting large *Bounds* forces, or not? C IC=0 HASBC=.FALSE. VBCA=0. DO 910 K=1,NCOND IF (NODCON(K).EQ.NODE) THEN HASBC=.TRUE. GO TO 911 ENDIF 910 CONTINUE 911 IF (HASBC) THEN SIZE=LARGE ELSE SIZE=SMALL ENDIF C IF (log_force_balance) WRITE (IUNITT,5) + NODE, CZ, (COMP(J,I),J=1,6), SIZE IF (SIZE.EQ.LARGE) THEN IF (MOD(I,2).EQ.1) THEN SUMVDF=SUMVDF+V(1,NODE)*COMP(6,I) ELSE SUMVDF=SUMVDF+V(2,NODE)*COMP(6,I) ENDIF ENDIF C 1000 CONTINUE C C Write *Bounds* forces to file in same format as velocities: C WRITE (IUNITF,1010) TITLE1 WRITE (IUNITF,1010) TITLE2 WRITE (IUNITF,1010) TITLE3 1010 FORMAT (A80) WRITE (IUNITF,1020) (COMP(6,I),I=1,NENTRY) 1020 FORMAT (1P,5E16.8) C C Calculate the sum of torques, which should be zero: C TQXX=0.0D0 TQYY=0.0D0 TQZZ=0.0D0 TFXX=0.0 TFYY=0.0 TFZZ=0.0 DO 2000 I=1,NUMNOD IX=2*I-1 IY=IX+1 THETA=XNODE(I) PHAI =YNODE(I) FX= COS(THETA)*COS(PHAI)*COMP(1,IX) + -SIN(PHAI)*COMP(1,IY) FY= COS(THETA)*SIN(PHAI)*COMP(1,IX) + +COS(PHAI)*COMP(1,IY) FZ=-SIN(THETA)*COMP(1,IX) TQXX=TQXX+RADIUS*(SIN(THETA)*SIN(PHAI)*FZ- + COS(THETA)*FY) TQYY=TQYY+RADIUS*(COS(THETA)*FX- + SIN(THETA)*COS(PHAI)*FZ) TQZZ=TQZZ+RADIUS*(SIN(THETA)*COS(PHAI)*FY- + SIN(THETA)*SIN(PHAI)*FX) TFXX=TFXX+RADIUS*ABS(SIN(THETA)*SIN(PHAI)*FZ- + COS(THETA)*FY) TFYY=TFYY+RADIUS*ABS(COS(THETA)*FX- + SIN(THETA)*COS(PHAI)*FZ) TFZZ=TFZZ+RADIUS*ABS(SIN(THETA)*COS(PHAI)*FY- + SIN(THETA)*SIN(PHAI)*FX) 2000 CONTINUE IF (TFXX.GT.0.) THEN RQXX=ABS(TQXX/TFXX) ELSE RQXX=0. ENDIF IF (TFYY.GT.0.) THEN RQYY=ABS(TQYY/TFYY) ELSE RQYY=0. ENDIF IF (TFZZ.GT.0.) THEN RQZZ=ABS(TQZZ/TFZZ) ELSE RQZZ=0. ENDIF WRITE(IUNITT,2001) TQXX,TQYY,TQZZ, + TFXX,TFYY,TFZZ, + RQXX,RQYY,RQZZ 2001 FORMAT(/' Net torque from all standardized surface' + ,' traction anomalies:' + /' X=0N,0E Y=0N,90E Z=90N <- axes' + ,' (through center of planet)' + /' ',1P,3D10.2,' <- sum of torque' + /' ', 3E10.2,' <- sum of ABS(torque)' + /' ', 3E10.2,' <- quotient (fractional' + ,' error)') WRITE (IUNITT,10) RETURN END C C C BLOCK DATA BD1 C C Define WEIGHT (Gaussian integration weights) of the C seven integration points in each element, defined by internal C coordinates POINTS(3,7), where points(1-3,M) holds the S1-S3 of C integration point number M. C Because all of these arrays are functions of internal C coordinates, they are not affected by scaling or shape of C particular elements. C DOUBLE PRECISION POINTS,WEIGHT COMMON /S1S2S3/ POINTS COMMON /WGTVEC/ WEIGHT DIMENSION POINTS(3,7),WEIGHT(7) C C POINTS contains the internal coordinates (S1,S2,S3) of the 7 C Gaussian integration points (for area integrals) of the C triangular elements. POINTS is also the set of nodal functions C for unprojected scalar quantities within an element: DATA POINTS / + 0.3333333333333333D0, 0.3333333333333333D0, 0.3333333333333333D0, + 0.0597158733333333D0, 0.4701420633333333D0, 0.4701420633333333D0, + 0.4701420633333333D0, 0.0597158733333333D0, 0.4701420633333333D0, + 0.4701420633333333D0, 0.4701420633333333D0, 0.0597158733333333D0, + 0.7974269866666667D0, 0.1012865066666667D0, 0.1012865066666667D0, + 0.1012865066666667D0, 0.7974269866666667D0, 0.1012865066666667D0, + 0.1012865066666667D0, 0.1012865066666667D0, 0.7974269866666667D0/ C C WEIGHT is the Gaussian weight (for area integrals) of the 7 C integration points in each triangular element: DATA WEIGHT / 0.2250000000000000D0, + 0.1323941500000000D0, 0.1323941500000000D0, 0.1323941500000000D0, + 0.1259391833333333D0, 0.1259391833333333D0, 0.1259391833333333D0/ C END C C C BLOCK DATA BD2 C C Define FPHI (nodal functions) and FGAUSS (Gaussian integration C weights) at the 7 integration points in each fault element, C defined by internal coordinate FPOINT(M=1,...,7), C which contains the relative position C (fractional length) of the integration points. C Because all of these arrays are functions of internal C coordinates, they are not affected by length or orientation of C particular fault elements. C DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS DIMENSION FPHI(4,7),FPOINT(7),FGAUSS(7) C C FPOINT contains the seven integration point locations for the fault C elements. Each value gives a position as a fraction of total length C measured from NODE1 to NODE2 (or array NODEF): DATA FPOINT/ 1 0.0254461D0, 2 0.1292344D0, 3 0.2970774D0, 4 0.5000000D0, 5 0.7029226D0, 6 0.8707656D0, 7 0.9745539D0 / C C FGAUSS contains the seven corresponding weight factors for use in C line integrals: DATA FGAUSS/ 1 0.0647425D0, 2 0.1398527D0, 3 0.1909150D0, 4 0.2089796D0, 5 0.1909150D0, 6 0.1398527D0, 7 0.0647425D0/ C C FPHI contains the values of the 4 nodal functions (one per node) C at each of these 7 integration points in the fault element. C A special convention is that the nodal function of node 3 C is the negative of that for node 2, while the nodal function C for node 4 is the negative of that for node 1. This simplifies C many expressions in which we would otherwise have to have C a separate factor of +1 or -1 for the two sides of the fault. DATA FPHI/ + 0.9745539D0, 0.0254461D0, -0.0254461D0, -0.9745539D0, + 0.8707656D0, 0.1292344D0, -0.1292344D0, -0.8707656D0, + 0.7029226D0, 0.2970774D0, -0.2970774D0, -0.7029226D0, + 0.5000000D0, 0.5000000D0, -0.5000000D0, -0.5000000D0, + 0.2970774D0, 0.7029226D0, -0.7029226D0, -0.2970774D0, + 0.1292344D0, 0.8707656D0, -0.8707656D0, -0.1292344D0, + 0.0254461D0, 0.9745539D0, -0.9745539D0, -0.0254461D0/ C END C C C SUBROUTINE BUILDF (INPUT,AREA,DETJ,DXS,DYS,ETA, + FBASE,FDIP,FLEN, + FPFLT,FPSFER,FARG,FTSTAR, + MXDOF,MXEL,MXFEL, + NDOF,NFL,NODEF,NODES, + NUMEL,OVB,PULLED,RADIUS, + SITA,TOFSET,TRHMAX, + WEDGE, + OUTPUT,FORCE) C C Compute forcing vector: Includes fixed terms from FBASE C (mostly gravitational spreading), plus variable terms: C *From triangular continuum elements: C 'pre-stress' or intercept-stress on linearized flow-laws, C and basal shear stress forces. C *From dipping, oblique-slip fault elements: C 'initial traction' used in linearization of rheology. C C In both cases, a small element vector is formed first, C with local node numbers, and then transferred to the global C forcing vector; this simplifies addressing. C C C Note: Following type can be compressed to LOGICAL*1 in VS-Fortran: LOGICAL PULLED C DOUBLE PRECISION DUXX,DUXY,DUYY,ELE,ELF,FBASE,FORCE,SINS,TANS DOUBLE PRECISION WEIGHT DOUBLE PRECISION FPHI,FGAUSS COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS COMMON /WGTVEC/ WEIGHT DIMENSION WEIGHT(7) DIMENSION FPHI(4,7),FGAUSS(7) DIMENSION AREA(MXEL),DETJ(7,MXEL), + DXS(2,2,3,7,MXEL),DYS(2,2,3,7,MXEL), + ELE(6),ELF(8),ETA(7,MXEL), + FBASE(MXDOF),FDIP(2,MXFEL),FLEN(MXFEL),FP(2,2,4), + FORCE(MXDOF),FPFLT(2,2,2,7,MXFEL),FARG(2,MXFEL), + FPSFER(2,2,3,7,MXEL),FTSTAR(2,7,MXFEL), + NODEF(4,MXFEL),NODES(3,MXEL),OVB(2,7,MXEL), + PULLED(7,MXEL), + SITA(7,MXEL),TOFSET(3,7,MXEL) DATA TINY/2.E-38/ C C Begin with constant terms (the same in each iteration): C DO 10 I=1,NDOF FORCE(I)=FBASE(I) 10 CONTINUE C C Contributions of triangular continuum elements: C DO 1000 I=1,NUMEL DO 20 J=1,6 ELE(J)=0.0D0 20 CONTINUE C C Effects of pre-stress: C DO 100 M=1,7 DA=AREA(I)*WEIGHT(M)*DETJ(M,I)/RADIUS SINS=1.0/SIN(SITA(M,I)) TANS=1.0/TAN(SITA(M,I)) TOXX=TOFSET(1,M,I) TOYY=TOFSET(2,M,I) TOXY=TOFSET(3,M,I) DO 90 J=1,3 JU=2*J-1 JV=2*J DUXX=TOXX*DXS(1,1,J,M,I) DUXY=TOXY*(DXS(1,2,J,M,I)+DYS(1,1,J,M,I)*SINS + -FPSFER(1,2,J,M,I)*TANS) DUYY=TOYY*(DYS(1,2,J,M,I)*SINS + +FPSFER(1,1,J,M,I)*TANS) ELE(JU)=ELE(JU)-DA*(DUXX+DUXY+DUYY) DUXX=TOXX*DXS(2,1,J,M,I) DUXY=TOXY*(DXS(2,2,J,M,I)+DYS(2,1,J,M,I)*SINS + -FPSFER(2,2,J,M,I)*TANS) DUYY=TOYY*(DYS(2,2,J,M,I)*SINS + +FPSFER(2,1,J,M,I)*TANS) ELE(JV)=ELE(JV)-DA*(DUXX+DUXY+DUYY) 90 CONTINUE 100 CONTINUE C C Basal shear stresses (if any), in case where grid doesn't move: C IF (TRHMAX.GT.0.) THEN DO 200 M=1,7 IF (PULLED(M,I)) THEN DA=AREA(I)*WEIGHT(M)*DETJ(M,I) SHX=OVB(1,M,I)*ETA(M,I) SHY=OVB(2,M,I)*ETA(M,I) DO 190 J=1,3 JU=2*J-1 JV=2*J ELE(JU)=ELE(JU) + +DA*(SHX*FPSFER(1,1,J,M,I) + +SHY*FPSFER(1,2,J,M,I)) ELE(JV)=ELE(JV) + +DA*(SHX*FPSFER(2,1,J,M,I) + +SHY*FPSFER(2,2,J,M,I)) 190 CONTINUE ENDIF 200 CONTINUE ENDIF C C Move entries of continuum-element force vector into global vector C DO 900 J=1,3 JV=2*NODES(J,I) JU=JV-1 FORCE(JU)=FORCE(JU)+ELE(2*J-1) FORCE(JV)=FORCE(JV)+ELE(2*J) 900 CONTINUE 1000 CONTINUE C C Contributions from dipping, oblique-slip fault elements: C DO 2000 I=1,NFL DO 1020 J=1,8 ELF(J)=0.0D0 1020 CONTINUE C C Effects of artificial 'initial traction' (FTSTAR): C DO 1100 M=1,7 DIP=FPHI(1,M)*FDIP(1,I)+FPHI(2,M)*FDIP(2,I) IF (ABS(DIP-1.570796).GT.WEDGE) THEN OSIND=1./SIN(DIP) OSIN2D=1./SIN(2.*DIP) C CCCCC ANGLE=FARG(1,I)*FPHI(1,M)+FARG(2,I)*FPHI(2,M) CCCCC Line above was replaced due to cycle-shift problem C ANGLE=CHORD(FARG(1,I),FPHI(2,M),FARG(2,I)) C SINA=SIN(ANGLE) COSA=COS(ANGLE) DS=FLEN(I)*FGAUSS(M) DO 1030 J=1,2 JJ=4 IF(J.EQ.2) JJ=3 FP(1,1,J)=FPFLT(1,1,J,M,I) FP(2,1,J)=FPFLT(2,1,J,M,I) FP(1,2,J)=FPFLT(1,2,J,M,I) FP(2,2,J)=FPFLT(2,2,J,M,I) FP(1,1,JJ)=-FP(1,1,J) FP(2,1,JJ)=-FP(2,1,J) FP(1,2,JJ)=-FP(1,2,J) FP(2,2,JJ)=-FP(2,2,J) 1030 CONTINUE DO 1090 J=1,4 JU=2*J-1 JV=2*J ADS11=FP(1,1,J)*COSA+FP(1,2,J)*SINA ADS12=FP(1,1,J)*SINA-FP(1,2,J)*COSA ADS21=FP(2,1,J)*COSA+FP(2,2,J)*SINA ADS22=FP(2,1,J)*SINA-FP(2,2,J)*COSA ELF(JU)=ELF(JU)-DS*(ADS11*FTSTAR(1,M,I)*OSIND + -2.0*ADS12*OSIN2D*FTSTAR(2,M,I)) ELF(JV)=ELF(JV)-DS*(ADS21*FTSTAR(1,M,I)*OSIND + -2.0*ADS22*OSIN2D*FTSTAR(2,M,I)) 1090 CONTINUE ENDIF 1100 CONTINUE C C Move entries of fault-element force vector into global vector: C DO 1900 J=1,4 JV=2*NODEF(J,I) JU=JV-1 FORCE(JU)=FORCE(JU)+ELF(2*J-1) FORCE(JV)=FORCE(JV)+ELF(2*J) 1900 CONTINUE 2000 CONTINUE RETURN END C C C SUBROUTINE BUILDK (INPUT,ALPHA,AREA,DETJ,DXS,DYS, + ETA,FPSFER, + MXDOF,MXEL,MXNODE,NDOF,NLB, + NODES,NUB,NUMEL,PULLED, + RADIUS,SITA,TRHMAX,V, + MODIFY,FORCE, + OUTPUT,STIFF) C C Computes stiffness matrix STIFF (alias K in other subprograms) C which represents stiffness of triangular continuum elements, C from tensor ALPHA and derivitives of nodal functions C of the element grid. C C Also adds diagonal stiffening associated with shear coupling to C the mantle beneath, if any. C C Note that the stiffness associated with fault elements is not C included here (for historical reasons). See subprogram -ADDFST-. C C A two-step process is used: C -A stiffness matrix for each element is formed, using C generic node numbering, 1-3. Each entry in this matrix is C a 2 x 2 submatrix, because node velocities have two components. C -The element stiffness matrix terms are added to the global C stiffness matrix. (This step involves complex indirect C addressing, and is very difficult to optimize). C C Note: Following type can be compressed to LOGICAL*1 in VS-Fortran: LOGICAL PULLED C DOUBLE PRECISION ELK,FORCE,STIFF,V,WEIGHT DOUBLE PRECISION DA,FL11J,FL12I,FL12J,FL22I,FL22J,SINS,SUM,TANS DIMENSION ALPHA(3,3,7,MXEL),AREA(MXEL),DETJ(7,MXEL), + DXS(2,2,3,7,MXEL),DYS(2,2,3,7,MXEL), + ETA(7,MXEL),FORCE(MXDOF),FPSFER(2,2,3,7,MXEL), + NODES(3,MXEL),PULLED(7,MXEL), + SITA(7,MXEL),V(2,MXNODE) DIMENSION ELK(2,2,3,3),WEIGHT(7),STIFF(MXWORK) COMMON LDA,NUCA,MXWORK COMMON /WGTVEC/ WEIGHT C C Statement function replacing INTEGER FUNCTION subprogram -INDEXK-: INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + NUCA + IROW - JCOLUM + 1 C C Begin by zeroing the matrix; all other logic will add to it. C CALL ZEROK (INPUT,NDOF,NLB,NUB, + OUTPUT,STIFF) C C Major loop is on triangular continuum elements: C DO 500 I=1,NUMEL C C Zero and then build up the element stiffness matrix: C DO 10 I3=1,3 DO 9 J3=1,3 ELK(1,1,I3,J3)=0.0D0 ELK(1,2,I3,J3)=0.0D0 ELK(2,1,I3,J3)=0.0D0 ELK(2,2,I3,J3)=0.0D0 9 CONTINUE 10 CONTINUE C C Incorporate stiffness tensors ALPHA: C DO 90 I3=1,3 DO 80 J3=1,3 C C upper left terms: X-coefficients in X-balance: SUM=0.D0 DO 40 M=1,7 DA =WEIGHT(M)*DETJ(M,I) SINS=1.0/SIN(SITA(M,I)) TANS=1.0/TAN(SITA(M,I)) FL11J=ALPHA(1,1,M,I)*DXS(1,1,J3,M,I) + +0.5*ALPHA(1,3,M,I)*(DYS(1,1,J3,M,I)*SINS + +DXS(1,2,J3,M,I)-FPSFER(1,2,J3,M,I)*TANS) + +ALPHA(1,2,M,I)*(DYS(1,2,J3,M,I)*SINS + +FPSFER(1,1,J3,M,I)*TANS) FL12J=ALPHA(3,1,M,I)*DXS(1,1,J3,M,I) + +0.5*ALPHA(3,3,M,I)*(DYS(1,1,J3,M,I)*SINS + +DXS(1,2,J3,M,I)-FPSFER(1,2,J3,M,I)*TANS) + +ALPHA(3,2,M,I)*(DYS(1,2,J3,M,I)*SINS + +FPSFER(1,1,J3,M,I)*TANS) FL12I=DXS(1,2,I3,M,I)+DYS(1,1,I3,M,I)*SINS + -FPSFER(1,2,I3,M,I)*TANS FL22J=ALPHA(2,1,M,I)*DXS(1,1,J3,M,I) + +0.5*ALPHA(2,3,M,I)*(DYS(1,1,J3,M,I)*SINS + +DXS(1,2,J3,M,I)-FPSFER(1,2,J3,M,I)*TANS) + +ALPHA(2,2,M,I)*(DYS(1,2,J3,M,I)*SINS + +FPSFER(1,1,J3,M,I)*TANS) FL22I=DYS(1,2,I3,M,I)*SINS + +FPSFER(1,1,I3,M,I)*TANS SUM=SUM+DA* + (FL11J*DXS(1,1,I3,M,I)+FL12J*FL12I + +FL22J*FL22I) 40 CONTINUE ELK(1,1,I3,J3)=ELK(1,1,I3,J3)+ + SUM*AREA(I)/(RADIUS*RADIUS) C C lower right terms: Y-coefficients in Y-balance: SUM=0.D0 DO 50 M=1,7 DA =WEIGHT(M)*DETJ(M,I) SINS=1.0/SIN(SITA(M,I)) TANS=1.0/TAN(SITA(M,I)) FL11J=ALPHA(1,1,M,I)*DXS(2,1,J3,M,I) + +0.5*ALPHA(1,3,M,I)*(DYS(2,1,J3,M,I)*SINS + +DXS(2,2,J3,M,I)-FPSFER(2,2,J3,M,I)*TANS) + +ALPHA(1,2,M,I)*(DYS(2,2,J3,M,I)*SINS + +FPSFER(2,1,J3,M,I)*TANS) FL12J=ALPHA(3,1,M,I)*DXS(2,1,J3,M,I) + +0.5*ALPHA(3,3,M,I)*(DYS(2,1,J3,M,I)*SINS + +DXS(2,2,J3,M,I)-FPSFER(2,2,J3,M,I)*TANS) + +ALPHA(3,2,M,I)*(DYS(2,2,J3,M,I)*SINS + +FPSFER(2,1,J3,M,I)*TANS) FL12I=DXS(2,2,I3,M,I)+DYS(2,1,I3,M,I)*SINS + -FPSFER(2,2,I3,M,I)*TANS FL22J=ALPHA(2,1,M,I)*DXS(2,1,J3,M,I) + +0.5*ALPHA(2,3,M,I)*(DYS(2,1,J3,M,I)*SINS + +DXS(2,2,J3,M,I)-FPSFER(2,2,J3,M,I)*TANS) + +ALPHA(2,2,M,I)*(DYS(2,2,J3,M,I)*SINS + +FPSFER(2,1,J3,M,I)*TANS) FL22I=DYS(2,2,I3,M,I)*SINS + +FPSFER(2,1,I3,M,I)*TANS SUM=SUM+DA*(FL11J*DXS(2,1,I3,M,I) + +FL12J*FL12I+FL22J*FL22I) 50 CONTINUE ELK(2,2,I3,J3)=ELK(2,2,I3,J3)+ + SUM*AREA(I)/(RADIUS*RADIUS) C C upper right terms: Y-coefficients in X-balance: SUM=0.0D0 DO 60 M=1,7 DA =WEIGHT(M)*DETJ(M,I) TANS=1.0/TAN(SITA(M,I)) SINS=1.0/SIN(SITA(M,I)) FL11J=ALPHA(1,1,M,I)*DXS(2,1,J3,M,I) + +0.5*ALPHA(1,3,M,I)*(DYS(2,1,J3,M,I)*SINS + +DXS(2,2,J3,M,I)-FPSFER(2,2,J3,M,I)*TANS) + +ALPHA(1,2,M,I)*(DYS(2,2,J3,M,I)*SINS + +FPSFER(2,1,J3,M,I)*TANS) FL12J=ALPHA(3,1,M,I)*DXS(2,1,J3,M,I) + +0.5*ALPHA(3,3,M,I)*(DYS(2,1,J3,M,I)*SINS + +DXS(2,2,J3,M,I)-FPSFER(2,2,J3,M,I)*TANS) + +ALPHA(3,2,M,I)*(DYS(2,2,J3,M,I)*SINS + +FPSFER(2,1,J3,M,I)*TANS) FL12I=DXS(1,2,I3,M,I)+DYS(1,1,I3,M,I)*SINS + -FPSFER(1,2,I3,M,I)*TANS FL22J=ALPHA(2,1,M,I)*DXS(2,1,J3,M,I) + +0.5*ALPHA(2,3,M,I)*(DYS(2,1,J3,M,I)*SINS + +DXS(2,2,J3,M,I)-FPSFER(2,2,J3,M,I)*TANS) + +ALPHA(2,2,M,I)*(DYS(2,2,J3,M,I)*SINS + +FPSFER(2,1,J3,M,I)*TANS) FL22I=DYS(1,2,I3,M,I)*SINS + +FPSFER(1,1,I3,M,I)*TANS SUM=SUM+DA*(FL11J*DXS(1,1,I3,M,I) + +FL12J*FL12I+FL22J*FL22I) 60 CONTINUE ELK(1,2,I3,J3)=ELK(1,2,I3,J3)+ + SUM*AREA(I)/(RADIUS*RADIUS) C C lower left terms: X-coefficients in Y-balance: SUM=0.0D0 DO 70 M=1,7 DA =WEIGHT(M)*DETJ(M,I) SINS=1.0/SIN(SITA(M,I)) TANS=1.0/TAN(SITA(M,I)) FL11J=ALPHA(1,1,M,I)*DXS(1,1,J3,M,I) + +0.5*ALPHA(1,3,M,I)*(DYS(1,1,J3,M,I)*SINS + +DXS(1,2,J3,M,I)-FPSFER(1,2,J3,M,I)*TANS) + +ALPHA(1,2,M,I)*(DYS(1,2,J3,M,I)*SINS + +FPSFER(1,1,J3,M,I)*TANS) FL12J=ALPHA(3,1,M,I)*DXS(1,1,J3,M,I) + +0.5*ALPHA(3,3,M,I)*(DYS(1,1,J3,M,I)*SINS + +DXS(1,2,J3,M,I)-FPSFER(1,2,J3,M,I)*TANS) + +ALPHA(3,2,M,I)*(DYS(1,2,J3,M,I)*SINS + +FPSFER(1,1,J3,M,I)*TANS) FL12I=DXS(2,2,I3,M,I)+DYS(2,1,I3,M,I)*SINS + -FPSFER(2,2,I3,M,I)*TANS FL22J=ALPHA(2,1,M,I)*DXS(1,1,J3,M,I) + +0.5*ALPHA(2,3,M,I)*(DYS(1,1,J3,M,I)*SINS + +DXS(1,2,J3,M,I)-FPSFER(1,2,J3,M,I)*TANS) + +ALPHA(2,2,M,I)*(DYS(1,2,J3,M,I)*SINS + +FPSFER(1,1,J3,M,I)*TANS) FL22I=DYS(2,2,I3,M,I)*SINS + +FPSFER(2,1,I3,M,I)*TANS SUM=SUM+DA* + (FL11J*DXS(2,1,I3,M,I)+FL12J*FL12I + +FL22J*FL22I) 70 CONTINUE ELK(2,1,I3,J3)=ELK(2,1,I3,J3)+ + SUM*AREA(I)/(RADIUS*RADIUS) C 80 CONTINUE 90 CONTINUE C C Add any diagonal stiffness associated with viscous basal drag C IF (TRHMAX.GT.0.) THEN DO 200 M=1,7 IF (PULLED(M,I)) THEN ETADA=ETA(M,I)*WEIGHT(M)*AREA(I)*DETJ(M,I) DO 190 I3=1,3 DO 180 J3=1,3 ELK(1,1,I3,J3)=ELK(1,1,I3,J3)+ + ETADA*(FPSFER(1,1,I3,M,I)* + FPSFER(1,1,J3,M,I)+ + FPSFER(1,2,I3,M,I)* + FPSFER(1,2,J3,M,I)) ELK(1,2,I3,J3)=ELK(1,2,I3,J3)+ + ETADA*(FPSFER(1,1,I3,M,I)* + FPSFER(2,1,J3,M,I)+ + FPSFER(1,2,I3,M,I)* + FPSFER(2,2,J3,M,I)) ELK(2,1,I3,J3)=ELK(2,1,I3,J3)+ + ETADA*(FPSFER(2,1,I3,M,I)* + FPSFER(1,1,J3,M,I)+ + FPSFER(2,2,I3,M,I)* + FPSFER(1,2,J3,M,I)) ELK(2,2,I3,J3)=ELK(2,2,I3,J3)+ + ETADA*(FPSFER(2,1,I3,M,I)* + FPSFER(2,1,J3,M,I)+ + FPSFER(2,2,I3,M,I)* + FPSFER(2,2,J3,M,I)) 180 CONTINUE 190 CONTINUE ENDIF 200 CONTINUE ENDIF C C Apply element matrix to augment global stiffness matrix: C DO 400 I3=1,3 NODEI=NODES(I3,I) IRY=2*NODEI IRX=IRY-1 DO 300 J3=1,3 NODEJ=NODES(J3,I) JCY=2*NODEJ JCX=JCY-1 IKXX=INDEXK(IRX,JCX) STIFF(IKXX)=STIFF(IKXX)+ELK(1,1,I3,J3) IKXY=INDEXK(IRX,JCY) STIFF(IKXY)=STIFF(IKXY)+ELK(1,2,I3,J3) IKYX=INDEXK(IRY,JCX) STIFF(IKYX)=STIFF(IKYX)+ELK(2,1,I3,J3) IKYY=INDEXK(IRY,JCY) STIFF(IKYY)=STIFF(IKYY)+ELK(2,2,I3,J3) 300 CONTINUE 400 CONTINUE 500 CONTINUE RETURN END C C C REAL FUNCTION CHORD (ANGLE1,S,ANGLE2) C C Returns an angle obtained by interpolation between ANGLE1 C and ANGLE2. The interpolation method is not sensitive to C possible cycle shifts (of 2*n*Pi) between ANGLE1 and ANGLE2. C C Unit vectors are constructed for ANGLE1 and ANGLE2, and a C linear chord is drawn between their tips. C C DOUBLE PRECISION S is the internal coordinate along the chord; C it is dimensionless, with value 0.0D0 at ANGLE1 and 1.0D0 at C ANGLE2. (The user may input S values outside this range C to get results outside the (smaller) angle between ANGLE1 and C ANGLE2, if desired.) The angle returned is that from the C origin to this chord point. C C This algorithm should work equally well for angles measured C either clockwise or counterclockwise from any reference, as C long as the usage is consistent. C C Both the input ANGLEs and the result CHORD are in radians. C DOUBLE PRECISION S REAL ANGLE1,ANGLE2,UVEC1,UVEC2,UVECS DIMENSION UVEC1(2),UVEC2(2),VECS(2) UVEC1(1)=COS(ANGLE1) UVEC1(2)=SIN(ANGLE1) UVEC2(1)=COS(ANGLE2) UVEC2(2)=SIN(ANGLE2) VECS(1)=(1.0D0-S)*UVEC1(1)+S*UVEC2(1) VECS(2)=(1.0D0-S)*UVEC1(2)+S*UVEC2(2) CHORD=ATAN2F(VECS(2),VECS(1)) RETURN END C C C SUBROUTINE CONVEC (INPUT,ICONVE,IPAFRI,IPVREF,IUNITM,IUNITT, + MXEL,MXFEL,MXNODE, + NAMES,NDPLAT, + NFL,NODEF,NODES, + NPBND,NPLATE,NUMEL,NUMNOD, + OMEGA,PLAT,PLON,RADIUS,VTIMES, + WHICHP,XNODE,YNODE, + OUTPUT,VM, + WORK,CHECKN) C C Computes lower-mantle flow velocity below asthenosphere; C or, if ICONVE.EQ.5, computes velocity of subducting plate(s). C Note that no code is provided here for case of ICONVE.EQ.6; C that is handled externally. C C Computation strategy varies by model. For many, data files C must be read from unit IUNITM. C C For all models except #5, the factor VTIMES is applied. C C Velocities are initially computed in the Africa-fixed C reference frame (for historical reasons); then they are C transformed to appear in the reference frame of plate C #IPVREF; this is done by a common transformation at the end of C this routine. C REAL LAT1,LAT2,LON1,LON2,NLAT,NLAT1,NLAT2 INTEGER WHICHP LOGICAL CHECKN,GOTOUT DOUBLE PRECISION VM CHARACTER*27 ENDSEG CHARACTER*2 c2, NAMES DIMENSION NODES(3,MXEL) DIMENSION NODEF(4,MXFEL) DIMENSION CHECKN(MXNODE),XNODE(MXNODE),YNODE(MXNODE),VM(2,MXNODE) DIMENSION HOC792(2,-8:8,1:36) DIMENSION BAUM88(5,1000) DIMENSION NAMES(NPLATE),OMEGA(3,NPLATE),PLAT(NPLATE,NPBND), + PLON(NPLATE,NPBND),NDPLAT(NPLATE) DIMENSION WHICHP(MXNODE) C - - - - - - - - - -- - - - - - - - - - - - - - - - - - - - - C C Data specific to the ICONVE == 5 case. C (Fortran 90 code added 2000.04.14): C C ID code of subducting plate (or, in case of several subducting C plates, ID code of the largest plate (applied in any areas NOT C outlined by .dig outlines): CHARACTER(2) :: underplate, otherplate INTEGER :: iunderplate C Number (may be 0) of additional plates, each to be represented C with a digitised outline: INTEGER ::n_others C ID codes of other subducting plates: INTEGER, DIMENSION(:), ALLOCATABLE :: iotherplate C Counts of points in each of the "other" digitized outlines: INTEGER, DIMENSION(:), ALLOCATABLE :: other_counts C Largest value found in other_counts: INTEGER :: max_count C Storage for digitized outlines, in (lon, lat) format, in C decimal degrees (+ = N, E; - = S, W). REAL, DIMENSION(:,:,:), ALLOCATABLE :: other_shapes C C - - - - - - - - - -- - - - - - - - - - - - - - - - - - - - - C C Statement functions: COSDEG(DEG)=COS(DEG*0.017453293D0) SINDEG(DEG)=SIN(DEG*0.017453293D0) C IF (ICONVE.EQ.0) THEN C DO 99 I=1,NUMNOD VM(1,I)=0.0D0 VM(2,I)=0.0D0 C Note: This is in Africa-fixed reference frame; C see below at end of routine for transformation. 99 CONTINUE C ELSE IF (ICONVE.EQ.1) THEN C C Hager and O'Connell (1979) viscosity model II C C Read from file "HOC79II.DIG" C Vectors are every 10 degrees in latitude and longitude C Columns march East from 10E to 360E. C Within each column, travel is S from 80N to 80S. C Units of input data are degrees East and North. C 2nd end of line segment shows where the grid point C will be displaced to after 50 m.y. of flow. C WRITE (*,100) IUNITM WRITE (IUNITT,100) IUNITM 100 FORMAT (' Attempting to read plate OUTLINES from unit ',I3/) DO 140 JEAST=1,36 DO 130 ISOUTH=-8,8 READ (IUNITM,*,END=101,ERR=101) ELON1,NLAT1 GO TO 103 C -------------------- ERR0R HANDLER ---------- 101 WRITE (IUNITT,102) IUNITM,JEAST,ISOUTH 102 FORMAT (/' ERR0R IN -CONVEC-:' + /' WHILE READING MANTLE VELOCITIES FROM' + ,' UNIT ',I3 + /' TO FILL IN COLUMN ',I2,', ROW ',I2 + /' ENCOUNTERED A RECORD WHICH DOES NOT' + ,' HOLD TWO RECOGNIZABLE NUMBERS.') CALL PAUSE() STOP C --------------------------------------------- 103 JC=(ELON1/10.)+0.5 IF (NLAT1.GE.0.) THEN IR=(NLAT1/10.)+0.5 IR= -IR ELSE IR=(-NLAT1/10.)+0.5 ENDIF IF ((JC.NE.JEAST).OR.(IR.NE.ISOUTH)) THEN WRITE (IUNITT,104) IUNITM,ISOUTH,JEAST,IR,JC, + ELON1,NLAT1 104 FORMAT (/' ERR0R: WHILE READING LOWER-MANTLE' + ,' FLOW VECTORS FROM UNIT ',I3 + /' AND LOOKING FOR ROW ',I2,', COLUMN ',I2 + /' ENCOUNTERED ROW ',I2,', COLUMN ',I2 + /' (LONGITUDE ',F7.2,', LATITUDE ',F6.2,') + ') CALL PAUSE() STOP ENDIF READ (IUNITM,*,ERR=101,END=101) ELON2,NLAT2 READ (IUNITM,'(A)') ENDSEG TX=COSDEG(NLAT1)*COSDEG(ELON1) TY=COSDEG(NLAT1)*SINDEG(ELON1) TZ=SINDEG(NLAT1) HX=COSDEG(NLAT2)*COSDEG(ELON2) HY=COSDEG(NLAT2)*SINDEG(ELON2) HZ=SINDEG(NLAT2) VX=(HX-TX)*RADIUS/(50.E6*3.15576E7) VY=(HY-TY)*RADIUS/(50.E6*3.15576E7) VZ=(HZ-TZ)*RADIUS/(50.E6*3.15576E7) THETAX=SINDEG(NLAT1)*COSDEG(ELON1) THETAY=SINDEG(NLAT1)*SINDEG(ELON1) THETAZ= -COSDEG(NLAT1) VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ PHIX= -SINDEG(ELON1) PHIY=COSDEG(ELON1) PHIZ=0. VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ HOC792(1,IR,JC)=VTHETA HOC792(2,IR,JC)=VPHI 130 CONTINUE 140 CONTINUE DO 190 I=1,NUMNOD NLAT1=90.-XNODE(I)*57.2958 NLAT1=MIN(NLAT1,+80.) NLAT1=MAX(NLAT1,-80.) ELON1=YNODE(I)*57.2958 IF (ELON1.LT.0.) ELON1=ELON1+360. IF (ELON1.LT.0.) ELON1=ELON1+360. IF (ELON1.GT.360.) ELON1=ELON1-360. IF (NLAT1.GE.0.) THEN IRTOP=(NLAT1/10.)+1. IRTOP= -IRTOP ELSE IRTOP=(-NLAT1/10.) ENDIF IF (IRTOP.LT.8) THEN IRBOT=IRTOP+1 FS=(-IRTOP*10.-NLAT1)/10. ELSE IRBOT=IRTOP FS=0. ENDIF JCRIGH=ELON1/10.+1. JCRIGH=MIN(JCRIGH,36) IF (JCRIGH.GT.1) THEN JCLEFT=JCRIGH-1 FE=(ELON1-10.*JCLEFT)/10. ELSE JCLEFT=36 FE=ELON1/10. ENDIF VTOP=HOC792(1,IRTOP,JCLEFT)+ + (HOC792(1,IRTOP,JCRIGH)-HOC792(1,IRTOP,JCLEFT))*FE VBOT=HOC792(1,IRBOT,JCLEFT)+ + (HOC792(1,IRBOT,JCRIGH)-HOC792(1,IRBOT,JCLEFT))*FE VM(1,I)=VTOP+(VBOT-VTOP)*FS VTOP=HOC792(2,IRTOP,JCLEFT)+ + (HOC792(2,IRTOP,JCRIGH)-HOC792(2,IRTOP,JCLEFT))*FE VBOT=HOC792(2,IRBOT,JCLEFT)+ + (HOC792(2,IRBOT,JCRIGH)-HOC792(2,IRBOT,JCLEFT))*FE VM(2,I)=VTOP+(VBOT-VTOP)*FS VM(1,I)=VM(1,I)*VTIMES VM(2,I)=VM(2,I)*VTIMES 190 CONTINUE C ELSE IF (ICONVE.EQ.2) THEN C C Baumgardner (1988) Figure 7, parts A-F C C Read from file "BAUM887.DIG" C Vectors are in random order, about 729 in all. C Units of input data are degrees East and North. C 2nd end of line segment shows where the grid point C will be displaced to after 11 m.y. of flow. C (Time would be 110 m.y., but he says to scale V up C *10 because Earth's Rayleigh number is higher that C that of the model.) C WRITE (*,200) IUNITM WRITE (IUNITT,200) IUNITM 200 FORMAT (' Attempting to read Baumgardner [1988] mantle', + ' flow from unit ',I3/) NUMVEC=0 DO 220 JVEC=1,1000 READ (IUNITM,*,END=221,ERR=201) ELON1,NLAT1 GO TO 203 C -------------------- ERR0R HANDLER ---------- 201 WRITE (IUNITT,202) IUNITM,JVEC 202 FORMAT (/' ERR0R IN -CONVEC-:' + /' WHILE READING MANTLE VELOCITIES FROM' + ,' UNIT ',I3 + /' TO FILL IN VECTOR ',I2, + /' ENCOUNTERED A RECORD WHICH DOES NOT' + ,' HOLD TWO RECOGNIZABLE NUMBERS.') CALL PAUSE() STOP C --------------------------------------------- 203 READ (IUNITM,*,ERR=201,END=221) ELON2,NLAT2 READ (IUNITM,'(A)') ENDSEG TX=COSDEG(NLAT1)*COSDEG(ELON1) TY=COSDEG(NLAT1)*SINDEG(ELON1) TZ=SINDEG(NLAT1) HX=COSDEG(NLAT2)*COSDEG(ELON2) HY=COSDEG(NLAT2)*SINDEG(ELON2) HZ=SINDEG(NLAT2) VX=(HX-TX)*RADIUS/(11.E6*3.15576E7) VY=(HY-TY)*RADIUS/(11.E6*3.15576E7) VZ=(HZ-TZ)*RADIUS/(11.E6*3.15576E7) THETAX=SINDEG(NLAT1)*COSDEG(ELON1) THETAY=SINDEG(NLAT1)*SINDEG(ELON1) THETAZ= -COSDEG(NLAT1) VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ PHIX= -SINDEG(ELON1) PHIY=COSDEG(ELON1) PHIZ=0. VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ BAUM88(1,JVEC)=VTHETA BAUM88(2,JVEC)=VPHI BAUM88(3,JVEC)=TX BAUM88(4,JVEC)=TY BAUM88(5,JVEC)=TZ NUMVEC=NUMVEC+1 220 CONTINUE 221 DO 290 I=1,NUMNOD TX=SIN(XNODE(I))*COS(YNODE(I)) TY=SIN(XNODE(I))*SIN(YNODE(I)) TZ=COS(XNODE(I)) R2MIN=999. DO 280 J=1,NUMVEC R2=(TX-BAUM88(3,J))**2+ + (TY-BAUM88(4,J))**2+ + (TZ-BAUM88(5,J))**2 IF (R2.LT.R2MIN) THEN R2MIN=R2 VM(1,I)=BAUM88(1,J) VM(2,I)=BAUM88(2,J) VM(1,I)=VM(1,I)*VTIMES VM(2,I)=VM(2,I)*VTIMES ENDIF 280 CONTINUE 290 CONTINUE C ELSE IF ((ICONVE.EQ.3).OR.(ICONVE.EQ.4)) THEN C C PB2002 model of Bird [2003; G**3]; C Already has plate NAMES and OMEGA vectors in C main program (DATA statements); C also, plate ID's for each node are already C computed (CALL ASSIGN) and stored in WHICHP. C DO 390 I=1,NUMNOD IPLATE=WHICHP(I) C Convert to AFrica-fixed, and radians/second: OMEGAX=(OMEGA(1,IPLATE)-OMEGA(1,IPAFRI))*3.168809E-14 OMEGAY=(OMEGA(2,IPLATE)-OMEGA(2,IPAFRI))*3.168809E-14 OMEGAZ=(OMEGA(3,IPLATE)-OMEGA(3,IPAFRI))*3.168809E-14 C Convert to length/second: OMEGAX=OMEGAX*RADIUS OMEGAY=OMEGAY*RADIUS OMEGAZ=OMEGAZ*RADIUS C Velocity = OMEGA x position: THETA=XNODE(I) PHI=YNODE(I) XN=SIN(THETA)*COS(PHI) YN=SIN(THETA)*SIN(PHI) ZN=COS(THETA) VX=OMEGAY*ZN-OMEGAZ*YN VY=OMEGAZ*XN-OMEGAX*ZN VZ=OMEGAX*YN-OMEGAY*XN C Create unit +Theta and +Phi vectors in Cartesian: THETAX=COS(THETA)*COS(PHI) THETAY=COS(THETA)*SIN(PHI) THETAZ= -SIN(THETA) PHIX= -SIN(PHI) PHIY=COS(PHI) PHIZ=0. C Find argument from dot products: VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ VM(1,I)=VTHETA*VTIMES VM(2,I)=VPHI*VTIMES 390 CONTINUE C ELSE IF (ICONVE.EQ.5) THEN C Code added for Japan models, 2000.04; written generally so as C work in any case of subduction under one margin of the model, C where the subduction shear zone is one model boundary, which C is NOT represented with fault elements. This code determines C which plate is subducting underneath each node, and returns C its velocity. The decision about whether the subducting C plate is touching the model (PULLED(M,I)) is made elsewhere. C WRITE (*,501) IUNITM WRITE (IUNITT,501) IUNITM 501 FORMAT ( +/' Attempting to read subducting plate identification code' +/' (and plate outlines if there is more than one subducting' +/' plate) from unit ',I3/) C C Read file once for first line, and just count lengths C and number of digitised outlines, without saving them: C READ(IUNITM,"(A2)",IOSTAT=ios) underplate IF (ios.NE.0) THEN WRITE(*,502) WRITE(IUNITT,502) 502 FORMAT( +/' File not found, or file empty.' +/' This file MUST be supplied when ICONVE = 5.' +/' First line must begin with plate code (e.g., PA).' +/' Second line should be "*** END OF SEGMENT ***".' +/' Then, if more than one plate is subducting, follow this' +/' with other plate ID codes (e.g., PH), each followed by' +/' a CLOSED outline in (lon,lat) format with decimal degrees.') CALL PAUSE() STOP END IF iunderplate=0 DO 510 I=1,NPLATE IF (underplate.EQ.NAMES(I)) THEN iunderplate=I GO TO 511 END IF 510 CONTINUE 511 IF (iunderplate.EQ.0) THEN WRITE(*,515) underplate,IUNITM WRITE(IUNITT,515) underplate,IUNITM 515 FORMAT(/' ERR0R: Illegal plate code "',A2, + '" was read from unit ',I3) CALL PAUSE() STOP END IF n_others = 0 max_count = 0 ALLOCATE ( other_counts(NPLATE - 1) ) ALLOCATE ( iotherplate(NPLATE - 1) ) C (clear the next line, which should be *** END...) READ (IUNITM, *, END=549) DO 540 I =1, NPLATE - 1 C Scan file for outlines, and count lengths: READ (IUNITM,"(A)", END = 549) otherplate n_others = n_others + 1 iotherplate(n_others) = 0 DO 520 J=1,NPLATE IF (otherplate.EQ.NAMES(J)) THEN iotherplate(n_others) = J GO TO 521 END IF 520 CONTINUE 521 IF (iotherplate(n_others).EQ.0) THEN WRITE(*,515) underplate,IUNITM WRITE(IUNITT,515) underplate,IUNITM CALL PAUSE() STOP END IF other_counts(n_others) = 0 530 READ (IUNITM, "(A)", END = 549) c2 IF ((c2.EQ." +").OR.(c2.EQ." -")) THEN other_counts(n_others) = other_counts(n_others)+1 max_count = MAX(max_count, other_counts(n_others)) GO TO 530 END IF 540 CONTINUE 549 REWIND (IUNITM) C C Read file again, and store digitised outlines: C IF (n_others > 0) THEN ALLOCATE ( other_shapes(n_others, 2, max_count) ) READ (IUNITM, *) READ (IUNITM, *) DO 560 I = 1, n_others READ (IUNITM, *) DO 555 J = 1, other_counts(I) READ (IUNITM, *) other_shapes(I, 1, J), + other_shapes(I, 2, J) 555 CONTINUE READ (IUNITM, *) 560 CONTINUE END IF CLOSE (IUNITM) C C Now, apply the plate information for each node: C DO 590 I=1,NUMNOD THETA=XNODE(I) PHI=YNODE(I) NLAT=90.0-THETA*57.29577951 ELON=PHI*57.29577951 IF (ELON.LT.-180.0) ELON=ELON+360.0 IF (ELON.GT.+180.0) ELON=ELON-360.0 C C Decide IPLATE for this node, C by counting crossings of a line extending to South C IPLATE = iunderplate IF (n_others > 0) THEN DO 585 J = 1, n_others NCROSS=0 DO 580 K = 2, other_counts(J) LON1 = other_shapes(J,1,K-1) LON2 = other_shapes(J,1,K) LAT1 = other_shapes(J,2,K-1) LAT2 = other_shapes(J,2,K) IF (LON2.NE.LON1) THEN FRAC=(ELON-LON1)/(LON2-LON1) IF ((FRAC.GE.0.0).AND. + (FRAC.LT.1.0)) THEN TEST=LAT1+FRAC*(LAT2-LAT1) IF (NLAT.GT.TEST) THEN NCROSS=NCROSS+1 END IF END IF END IF 580 CONTINUE IF (MOD(NCROSS,2).EQ.1) THEN C odd number of crossings: inside IPLATE = iotherplate(J) GO TO 586 END IF 585 CONTINUE 586 CONTINUE END IF C Convert OMEGA(IPLATE) to AFrica-fixed, and radians/second: OMEGAX=(OMEGA(1,IPLATE)-OMEGA(1,IPAFRI))*3.168809E-14 OMEGAY=(OMEGA(2,IPLATE)-OMEGA(2,IPAFRI))*3.168809E-14 OMEGAZ=(OMEGA(3,IPLATE)-OMEGA(3,IPAFRI))*3.168809E-14 C Convert to length/second: OMEGAX=OMEGAX*RADIUS OMEGAY=OMEGAY*RADIUS OMEGAZ=OMEGAZ*RADIUS C Velocity = OMEGA x position: XN=SIN(THETA)*COS(PHI) YN=SIN(THETA)*SIN(PHI) ZN=COS(THETA) VX=OMEGAY*ZN-OMEGAZ*YN VY=OMEGAZ*XN-OMEGAX*ZN VZ=OMEGAX*YN-OMEGAY*XN C Create unit +Theta and +Phi vectors in Cartesian: THETAX=COS(THETA)*COS(PHI) THETAY=COS(THETA)*SIN(PHI) THETAZ= -SIN(THETA) PHIX= -SIN(PHI) PHIY=COS(PHI) PHIZ=0. C Find argument from dot products: VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ VM(1,I)=VTHETA VM(2,I)=VPHI 590 CONTINUE C ELSE C WRITE (IUNITT,999) ICONVE 999 FORMAT (/' ILLEGAL INTEGER CODE FOR LOWER-MANTLE' + /' CONVECTION PATTERN (ICONVE): ',I6) CALL PAUSE() STOP C ENDIF C C End of selection based on ICONVE; C Now apply velocity reference frame transformation from C AFrica-fixed to plate #IPVREF fixed: C C Rotation of plate IPVREF wrt AFrica, in radians/second: OMEGAX=(OMEGA(1,IPVREF)-OMEGA(1,IPAFRI))*3.168809E-14 OMEGAY=(OMEGA(2,IPVREF)-OMEGA(2,IPAFRI))*3.168809E-14 OMEGAZ=(OMEGA(3,IPVREF)-OMEGA(3,IPAFRI))*3.168809E-14 C Convert to length/second: OMEGAX=OMEGAX*RADIUS OMEGAY=OMEGAY*RADIUS OMEGAZ=OMEGAZ*RADIUS C DO 2000 I=1,NUMNOD C Velocity of IPVREF wrt AFrica = OMEGA x position: THETA=XNODE(I) PHI=YNODE(I) XN=SIN(THETA)*COS(PHI) YN=SIN(THETA)*SIN(PHI) ZN=COS(THETA) VX=OMEGAY*ZN-OMEGAZ*YN VY=OMEGAZ*XN-OMEGAX*ZN VZ=OMEGAX*YN-OMEGAY*XN C Create unit +Theta and +Phi vectors in Cartesian: THETAX=COS(THETA)*COS(PHI) THETAY=COS(THETA)*SIN(PHI) THETAZ= -SIN(THETA) PHIX= -SIN(PHI) PHIY=COS(PHI) PHIZ=0. C Find argument from dot products: VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ C C Transform the velocity previously found in the C AFrica-fixed reference frame to one in the C IPVREF-fixed reference frame: VM(1,I)=VM(1,I)-VTHETA VM(2,I)=VM(2,I)-VPHI C 2000 CONTINUE C RETURN END C C C SUBROUTINE DERIV (INPUT,IUNITT,MXEL,MXNODE, + NODES,NUMEL, + RADIUS,XNODE,YNODE, + OUTPUT,AREA,DETJ, + DXS,DYS,DXSP,DYSP,FPSFER,SITA) C C Sets up 6 vector nodal functions (FPSFER) of each spherical C triangle finite element, at each of its 7 integration points. C Calculates DXS and DYS, the Theta-derivitive and Phi-derivitive C of each of these 6 vector nodal functions. C Also computes AREA, the areas of the plane triangles. C Also computes DETJ, the local ratio of areas on the sphere C to areas on the plane triangles. C DOUBLE PRECISION POINTS DOUBLE PRECISION FFF,SKKC,SKKE,SNCSNE,SNCCSE,CSCCSE,CSCSNE DOUBLE PRECISION XA,XB,XC,YA,YB,YC,ZA,ZB,ZC,XYZP DIMENSION XNODE(MXNODE),YNODE(MXNODE),NODES(3,MXEL),AREA(MXEL) DIMENSION DETJ(7,MXEL) DIMENSION DXS(2,2,3,7,MXEL),DYS(2,2,3,7,MXEL) DIMENSION DXSP(3,7,MXEL),DYSP(3,7,MXEL),POINTS(3,7) DIMENSION PHI(3),THETA(3),SKKC(3),SKKE(3),FFF(3), + SITA(7,MXEL),FPSFER(2,2,3,7,MXEL) COMMON /S1S2S3/ POINTS C C DO 900 I=1,NUMEL DO 100 J=1,3 THETA(J)=XNODE(NODES(J,I)) PHI(J) =YNODE(NODES(J,I)) 100 CONTINUE X21=SIN(THETA(2))*COS(PHI(2))-SIN(THETA(1))*COS(PHI(1)) X31=SIN(THETA(3))*COS(PHI(3))-SIN(THETA(1))*COS(PHI(1)) Y21=SIN(THETA(2))*SIN(PHI(2))-SIN(THETA(1))*SIN(PHI(1)) Y31=SIN(THETA(3))*SIN(PHI(3))-SIN(THETA(1))*SIN(PHI(1)) Z21=COS(THETA(2))-COS(THETA(1)) Z31=COS(THETA(3))-COS(THETA(1)) A=Y21*Z31-Y31*Z21 B=Z21*X31-Z31*X21 C=X21*Y31-X31*Y21 AREAP=SQRT(A*A+B*B+C*C) AREA(I)=RADIUS*RADIUS*(0.5*AREAP) PNX=A/AREAP PNY=B/AREAP PNZ=C/AREAP DD1=SIN(THETA(1))*COS(PHI(1))*PNX DD2=SIN(THETA(1))*SIN(PHI(1))*PNY DD3=COS(THETA(1))*PNZ DD=DD1+DD2+DD3 C C This part is to test if Kong's method and Bird's method give the same C results for the derivitive: C XA=SIN(THETA(1))*COS(PHI(1)) XB=SIN(THETA(2))*COS(PHI(2)) XC=SIN(THETA(3))*COS(PHI(3)) YA=SIN(THETA(1))*SIN(PHI(1)) YB=SIN(THETA(2))*SIN(PHI(2)) YC=SIN(THETA(3))*SIN(PHI(3)) ZA=COS(THETA(1)) ZB=COS(THETA(2)) ZC=COS(THETA(3)) CKA=(YB*ZC-ZB*YC)*XA+(ZB*XC-XB*ZC)*YA+(XB*YC-YB*XC)*ZA C C C DO 800 M=1,7 SNCCSE=0.0 SNCSNE=0.0 COSM=0.0 DO 200 J=1,3 SNCCSE=SNCCSE+POINTS(J,M)*SIN(THETA(J))*COS(PHI(J)) SNCSNE=SNCSNE+POINTS(J,M)*SIN(THETA(J))*SIN(PHI(J)) COSM=COSM+POINTS(J,M)*COS(THETA(J)) 200 CONTINUE XYZP=SQRT(SNCCSE*SNCCSE+SNCSNE*SNCSNE+COSM*COSM) SNCCSE=SNCCSE/XYZP SNCSNE=SNCSNE/XYZP COSM=COSM/XYZP SITAJ=ACOS(COSM) TY=SNCSNE TX=SNCCSE PHAIJ=ATAN2F(TY,TX) CSCCSE=COS(SITAJ)*COS(PHAIJ) CSCSNE=COS(SITAJ)*SIN(PHAIJ) C C Bird's method: C FFF(1)=((YB*ZC-ZB*YC)*SNCCSE+(ZB*XC-XB*ZC)*SNCSNE + +(XB*YC-YB*XC)*COSM)/CKA FFF(2)=((YC*ZA-ZC*YA)*SNCCSE+(ZC*XA-XC*ZA)*SNCSNE + +(XC*YA-YC*XA)*COSM)/CKA FFF(3)=((YA*ZB-ZA*YB)*SNCCSE+(ZA*XB-XA*ZB)*SNCSNE + +(XA*YB-YA*XB)*COSM)/CKA SKKC(1)=((YB*ZC-ZB*YC)*CSCCSE + +(ZB*XC-XB*ZC)*CSCSNE + -(XB*YC-YB*XC)*SIN(SITAJ))/CKA SKKC(2)=((YC*ZA-ZC*YA)*CSCCSE + +(ZC*XA-XC*ZA)*CSCSNE + -(XC*YA-YC*XA)*SIN(SITAJ))/CKA SKKC(3)=((YA*ZB-ZA*YB)*CSCCSE + +(ZA*XB-XA*ZB)*CSCSNE + -(XA*YB-YA*XB)*SIN(SITAJ))/CKA SKKE(1)=(-(YB*ZC-ZB*YC)*SNCSNE + +(ZB*XC-XB*ZC)*SNCCSE)/CKA SKKE(2)=(-(YC*ZA-ZC*YA)*SNCSNE + +(ZC*XA-XC*ZA)*SNCCSE)/CKA SKKE(3)=(-(YA*ZB-ZA*YB)*SNCSNE + +(ZA*XB-XA*ZB)*SNCCSE)/CKA C C C SITA(M,I)=SITAJ RR1=SIN(SITAJ)*COS(PHAIJ) RR2=SIN(SITAJ)*SIN(PHAIJ) RR3=COS(SITAJ) RN=RR1*PNX+RR2*PNY+RR3*PNZ PP=DD/RN DPDC=(COS(SITAJ)*COS(PHAIJ)*PNX+COS(SITAJ)*SIN(PHAIJ)*PNY + -SIN(SITAJ)*PNZ) DPDE=(-SIN(SITAJ)*SIN(PHAIJ)*PNX+ + SIN(SITAJ)*COS(PHAIJ)*PNY) DDPN=PP/RN DPDC=-DDPN*DPDC DPDE=-DDPN*DPDE IF(SITA(M,I).LE.0.0.OR.SITA(M,I).GE.3.141592654) THEN SITAMI=SITA(M,I)*57.29577951 WRITE(IUNITT,220) M,I,SITAMI 220 FORMAT(' COLATITUDE OF INTEGRATION POINT',I5, + ' OF ELEMENT', + I5,' IS OUT RANGE', + E14.4) CALL PAUSE() STOP ENDIF DO 500 J=1,3 DXSP(J,M,I)= DPDC*FFF(J)+PP*SKKC(J) DYSP(J,M,I)= DPDE*FFF(J)+PP*SKKE(J) CSCS=COS(THETA(J))*COS(PHI(J)) CSSN=COS(THETA(J))*SIN(PHI(J)) SNC=SIN(THETA(J)) SNE=SIN(PHI(J)) CSE=COS(PHI(J)) FPSFER(1,1,J,M,I)= CSCS*CSCCSE+CSSN*CSCSNE + +SNC*SIN(SITAJ) FPSFER(2,1,J,M,I)=-SNE*CSCCSE+CSE*CSCSNE FPSFER(1,2,J,M,I)=-CSCS*SIN(PHAIJ)+CSSN*COS(PHAIJ) FPSFER(2,2,J,M,I)=SNE*SIN(PHAIJ)+CSE*COS(PHAIJ) DXS(1,1,J,M,I)=(-CSCS*SNCCSE-CSSN*SNCSNE + +SNC*COS(SITAJ))*FFF(J) + +FPSFER(1,1,J,M,I)*SKKC(J) DXS(2,1,J,M,I)=(SNE*SNCCSE-CSE*SNCSNE)*FFF(J) + +FPSFER(2,1,J,M,I)*SKKC(J) DYS(1,1,J,M,I)=(-CSCS*CSCSNE+CSSN*CSCCSE)*FFF(J) + +FPSFER(1,1,J,M,I)*SKKE(J) DYS(2,1,J,M,I)=(SNE*CSCSNE+CSE*CSCCSE)*FFF(J) + +FPSFER(2,1,J,M,I)*SKKE(J) DXS(1,2,J,M,I)=FPSFER(1,2,J,M,I)*SKKC(J) DXS(2,2,J,M,I)=FPSFER(2,2,J,M,I)*SKKC(J) DYS(1,2,J,M,I)=(-CSCS*COS(PHAIJ)-CSSN*SIN(PHAIJ)) + *FFF(J) + +FPSFER(1,2,J,M,I)*SKKE(J) DYS(2,2,J,M,I)=(SNE*COS(PHAIJ)-CSE*SIN(PHAIJ)) + *FFF(J) + +FPSFER(2,2,J,M,I)*SKKE(J) FPSFER(1,1,J,M,I)=FPSFER(1,1,J,M,I)*FFF(J) FPSFER(2,1,J,M,I)=FPSFER(2,1,J,M,I)*FFF(J) FPSFER(1,2,J,M,I)=FPSFER(1,2,J,M,I)*FFF(J) FPSFER(2,2,J,M,I)=FPSFER(2,2,J,M,I)*FFF(J) 500 CONTINUE PFQ=FFF(1)+FFF(2)+FFF(3) DETJ(M,I)=RN**3/(DD*DD) 800 CONTINUE 900 CONTINUE RETURN END C C C SUBROUTINE DIAMND (INPUT,ACREEP,ALPHAT,BCREEP, + BIOT,CCREEP,DCREEP, + ECREEP, + E1,E2,FRIC,G, + GEOTH1, + GEOTH2, + GEOTH3, + GEOTH4, + PL0,PW0, + RHOBAR,RHOH2O,SIGHBI, + THICK,TEMLIM, + VISMAX,ZOFTOP, + OUTPUT,PT1DE1,PT1DE2, + PT2DE1,PT2DE2, + PT1,PT2,ZTRAN) C C For one homogeneous layer (crust, *or* mantle lithosphere), C computes the vertical integral through the layer of C horizontal principal stresses (relative to the vertical stress); C reports these as PT1 (more negative) and PT2 (more positive). C C Also reports ZTRAN, the depth into the layer of the brittle/ C ductile transition (greatest depth of earthquakes). C C Finally, recommends layer partial derivitives C PT1DE1, PT1DE2, PT2DE1, PT2DE2 C to be used in constructing ALPHA and TOFSET (in VISCOS), C according to strategy in pages 3973-3977 of Bird (1989). C In computing these, as in computing PT1 and PT2, the viscosity C limit VISMAX is applied to the average behavior of the whole C frictional layer, and again to the average behavior of the C whole creeping layer; it is not applied locally at each depth. C C Necessary conditions when calling DIAMND: C -> horizontal principal strain-rates E1 and E2 not both zero; C -> E2 >= E1; C -> layer thickness THICK is positive. C C Note special kludge: if friction FRIC is >2., then this is C taken to be a signal that no frictional layer is desired, C and that the whole layer should be power-law (or plastic, or C viscous-- whichever gives the least shear stress). C C New version, May 5, 1998, by Peter Bird; intended to improve C the convergence behavior of all F-E programs which use it. C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C External variables (*** all are scalars, even though C these same names may be arrays in other programs! ***): INTEGER INPUT REAL ACREEP, ALPHAT, BCREEP, BIOT, CCREEP, DCREEP, + ECREEP, E1, E2, FRIC, G, + GEOTH1, GEOTH2, GEOTH3, GEOTH4, + OUTPUT, PL0, PW0, + PT1, PT2, PT1DE1, PT1DE2, PT2DE1, PT2DE2, + RHOBAR, RHOH2O, SIGHBI, + THICK, TEMLIM, VISMAX, ZOFTOP, ZTRAN C External function: REAL ATAN2F C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C Internal variables: INTEGER N, NVSTEP DOUBLE PRECISION SECINV REAL ANGAT2, ANGAT3, ANGLE, + DELNEG, DELPOS, DSFDEV, + DS1DE1, DS1DE2, DS2DE1, DS2DE2, + DT1DE1, DT1DE2, DT2DE1, DT2DE2, DZ, + E1AT1, E1AT2, E1AT3, E1AT4, + E2AT1, E2AT2, E2AT3, E2AT4, + ESCRIT, EZ, + FRAC, + GAMMA, GREAT, + PH2O, + R, RHOUSE, + SIGMA1, SIGMA2, S1EFF, S2EFF, S1REL, S2REL, + SC0, SCH, SC1, SF0, SFH, SF1, STFRIC, SZ, SZEFF, + TAU1, TAU2, TECN, TECS, TECT, TMEAN, TSFN, TSFS, TSFT, + T, T0, TH, T1, + VIS, VISDCR, VISINF, VISINT, VISMIN, VISSHB, + Z, Z0, ZH, Z1 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C C CHARACTERIZE THE STRAIN-RATE TENSOR: EZ= -(E1+E2) C (Formula for vertical strain-rate EZ comes from the C incompressibility of all permanent, anelastic strain types.) SECINV= -((1.D0*E1)*E2 + (1.D0*E1)*EZ + (1.D0*E2)*EZ) C (One possible form for the second invariant of the matrix.) C Note that the double-precision is just to prevent underflows C from squaring small strain rates, not for precision. VISINF=0.5*ACREEP*(2.*SQRT(SECINV))**(ECREEP-1.) C VISINF is the viscosity for dislocation creep, lacking only C the exponential term; therefore, as a mathematical abstraction, C we can say that it is the viscosity at infinite temperature. C C CHARACTERIZE THE CONTINUUM FRICTION: C STFRIC=SIN(ATAN(FRIC)) GAMMA=(1+STFRIC)/(1-STFRIC) C Note: For thrusting, effective-sigma1h is effective-sigma1z C times GAMMA. For normal faulting, effective-sigma2h C is effective-sigmaz/GAMMA. For small FRIC, GAMMA C is approximately equal to 1.+2.*FRIC C C FIND THE BRITTLE/DUCTILE TRANSITION (ZTRAN, measured from C the top of the layer): C C In the thrusting quadrant (E1<0, E2<0) and in the normal- C faulting quadrant (E1>0, E2>0) the brittle/ductile transtion C is clear: it the greatest depth of frictional behavior C (possibly including earthquakes) on any fault, which is also C the greatest depth of frictional behavior on the most active C fault set. C C However, in the strike-slip quadrant (E1<0, E2>0) the C transition is less clear. I do not know of any empirical C field study which has determined how the transition depth C depends on (E1+E2) within the transtensional and transpressional C wedges of the strain-rate field. Therefore, we have to choose C some simple rule. The rule that the transition is at the C greatest depth of frictional behavior on any fault would C create two discontinuities (at the E1=0 line, where normal C faulting appears/dissapears; and at the E2=0 line, where C strike-slip faulting appears/dissapears). Furthermore, the C transition depth near to these lines (on the deeper side) would C be defined by the less-active fault set, which asymptotically C becomes totally inactive as the line is approached! If we C chose the alternate rule of taking the deepest frictional C behavior on the most active fault set, we would still have C two discontinuities, although at different places, both within C the strike-slip quadrant. My F-E programs cannot converge well C when there is any discontinuity; therefore, I have chosen an C arbitrary rule which smooths the transition depth across each C of the transpressional and transtensional wedges, giving the C correct (unambiguous) depths on the lines E1=0, E1=-E2, and C E2=0. In order to do this, I apply SIN(2*theta) smoothing to C both the frictional parameter DSFDEV and also to the creep C parameter ESCRIT, and then compute the transition depth from C the combination of values. (I do this instead of smoothing C the depth itself because I have no formula for the transition C depth on any of these three lines, and would have to locate C it by additional numerical searches.) C C ESCRIT is the shear strain rate (tensor type, = C 0.5*(larger principal rate - smaller principal rate) C of the shear system which defines the transition C from the creep side (from below); C DSFDEV is the partial derivitive of the maximum shear C stress (on any plane) in the frictional domain C with respect to effective vertical stress C (vertical stress plus BIOT times water pressure). C IF (E1.GE.0.) THEN IF (E2.GE.0.) THEN C Normal-normal; faster E2 dominates. ESCRIT=0.5*(E2-EZ) DSFDEV=0.5*(1.-1./GAMMA) ELSE C (E1 >=0, E2 < 0) C E2 < E1? Should not happen! WRITE(*,"(/' ERR','OR in DIAMND: E1:',1P,E10.2,' > E2:', + E10.2)") E1,E2 CALL PAUSE() STOP END IF ELSE C (E1 < 0) IF (E2.GE.0.) THEN C (E1 < 0, E2 >= 0) IF (EZ.GE.0.) THEN C Transpression (T/S). C Enforce smooth transition in DSFDEV C as the pure strike-slip line is approached. C (This smoothing cannot be with VISMAX because C ZTRAN is not yet known; instead, use a smooth C function of angle from origin of the C strain-rate plane, varying over 45 degrees C from the pure-strike-slip line E1=-E2 C to the pure-thrust line E2=0.) TSFT=0.5*(GAMMA-1.) TSFS=STFRIC C Note: One might expect TSFS=FRIC, but check on C a Mohr-circle diagram, remembering that the C pure strike-slip condition is EZ==0 -> C SZZEFF=0.5*(S1EFF+S2EFF). C Also remember that the "SF" in DSFDEV is not the C shear stress on the fault, but the maximum shear C stress, because this is what creep will attack and C lower first, at the brittle/ductile transition. ANGLE=ATAN2F(E2,E1) DSFDEV=TSFS+(TSFT-TSFS)*SIN(2.*(ANGLE-2.3561945)) C R=SQRT((1.D0*E1)**2+(1.D0*E2)**2) TECT=1. TECS=0.7071067 ESCRIT=R* + (TECS+(TECT-TECS)*SIN(2.*(ANGLE-2.3561945))) ELSE C (E1 < 0, E2 >= 0, EZ < 0) C Transtension (N/S). C Enforce smooth transition in DSFDEV C as the pure strike-slip line is approached. C (This smoothing cannot be with VISMAX because C ZTRAN is not yet known; instead, use a smooth C function of angle from origin of the C strain-rate plane, varying over 45 degrees C from the pure-strike-slip line E1=-E2 to the C pure-normal faulting line E1=0.) TSFN=0.5*(1.-1./GAMMA) TSFS=STFRIC C Note: One might expect TSFS=FRIC, but check on C a Mohr-circle diagram, remembering that the C pure strike-slip condition is EZ==0 -> C SZZEFF=0.5*(S1EFF+S2EFF). C Also remember that the "SF" in DSFDEV is not the C shear stress on the fault, but the maximum shear C stress, because this is what creep will attack and C lower first, at the brittle/ductile transition. ANGLE=ATAN2F(E2,E1) DSFDEV=TSFS+(TSFN-TSFS)*SIN(2.*(2.3561945-ANGLE)) C R=SQRT((1.D0*E1)**2+(1.D0*E2)**2) TECN=1. TECS=0.7071067 ESCRIT=R* + (TECS+(TECN-TECS)*SIN(2.*(2.3561945-ANGLE))) END IF ELSE C (E1 < 0, E2 < 0) C Thrust-thrust; faster (more negative) E1 dominates. ESCRIT=0.5*(EZ-E1) DSFDEV=0.5*(GAMMA-1.) END IF END IF C C Use ESCRIT and DSFDEV to locate ZTRAN (brittle/ductile trans.): C IF (FRIC.GT.2.) THEN C Special kludge; no frictional layer is wanted C (for models with a purely power-law or linear-viscous C rheology, you specify an unrealistically high friction. C This makes the transition occur at the surface, and C below the surface, the friction value is irrelevant.) ZTRAN=0. ELSE C Normal case; compute friction and creep at top and bottom: C Z0=0. SF0=DSFDEV*(PL0-BIOT*PW0) T0=MIN(TEMLIM,GEOTH1) ARGUME=(BCREEP+CCREEP*ZOFTOP)/T0 ARGUME=MAX(MIN(ARGUME,87.),-87.) SC0=2.*(VISINF*ESCRIT)*EXP(ARGUME) SC0=MIN(SC0,DCREEP) C Z1=THICK TMEAN=GEOTH1+ + 0.5*GEOTH2*Z1+ + 0.333*GEOTH3*Z1**2+ + 0.25*GEOTH4*Z1**3 RHOUSE=RHOBAR*(1.-ALPHAT*TMEAN) SF1=SF0+DSFDEV*(RHOUSE-BIOT*RHOH2O)*G*THICK T1=MIN(TEMLIM,GEOTH1+GEOTH2*Z1+GEOTH3*Z1**2+GEOTH4*Z1**3) ARGUME=(BCREEP+CCREEP*(ZOFTOP+Z1))/T1 ARGUME=MAX(MIN(ARGUME,87.),-87.) SC1=2.*(VISINF*ESCRIT)*EXP(ARGUME) SC1=MIN(SC1,DCREEP) SC1=MAX(SC1,SIGHBI) C C Check if whole layer is frictional: IF (SC1.GE.SF1) THEN ZTRAN=THICK C C Check if none of layer is frictional: ELSE IF (SC0.LE.SF0) THEN ZTRAN=0. C ELSE C Transition is within layer, between Z0 and Z1. C Use a binary-division search to bracket within C the nearest 1/128 of the layer (usually, within C 0.5 km); then, finish with linear interpolation. C Note ASSUMPTION: T increases montonically with z!!! C Also note that linearity may fail if the C power-law/DCREEP-limit transition falls into the C remaining interval; however, the err0r will be small. DO 100 N=1,7 ZH=0.5*(Z0+Z1) TMEAN=0.5*(T0+T1) RHOUSE=RHOBAR*(1.-ALPHAT*TMEAN) SFH=SF0+DSFDEV*(RHOUSE-BIOT*RHOH2O)*G*(ZH-Z0) TH=MIN(TEMLIM,GEOTH1+GEOTH2*ZH+GEOTH3*ZH**2+ + GEOTH4*ZH**3) ARGUME=(BCREEP+CCREEP*(ZOFTOP+ZH))/TH ARGUME=MAX(MIN(ARGUME,87.),-87.) SCH=2.*(VISINF*ESCRIT)*EXP(ARGUME) SCH=MIN(SCH,DCREEP) SCH=MAX(SCH,SIGHBI) IF (SCH.GT.SFH) THEN C Transition is between ZH and Z1. Z0=ZH SF0=SFH T0=TH SC0=SCH ELSE C Transition is between Z0 and ZH. Z1=ZH SF1=SFH T1=TH SC1=SCH END IF 100 CONTINUE DELNEG=SF0-SC0 DELPOS=SF1-SC1 FRAC= -DELNEG/(DELPOS-DELNEG) IF ((FRAC.LT.-0.01).OR.(FRAC.GT.1.01)) THEN WRITE(*,"(' WARNING: Failure to bracket ZTRAN', + ' within DIAMND')") END IF FRAC=MIN(1.,MAX(0.,FRAC)) ZTRAN=Z0+FRAC*(Z1-Z0) END IF END IF C C SUM TAU (AND DERIVITIVES) OVER FRICTIONAL AND CREEP LAYERS: C C Initialize sums over (up to) two layers: C -brittle layer at <= ZTRAN from the top; C -creeping layer at > ZTRAN from the top. PT1=0. PT2=0. PT1DE1=0. PT1DE2=0. PT2DE1=0. PT2DE2=0. C C COMPUTE AND ADD STRENGTH OF FRICTIONAL PART OF LAYER: C IF (ZTRAN.GT.0.) THEN C Compute the effective vertical stress at the midpoint C of the frictional layer: TMEAN=GEOTH1+ + 0.5*GEOTH2*(ZTRAN/2.)+ + 0.333*GEOTH3*(ZTRAN/2.)**2+ + 0.25*GEOTH4*(ZTRAN/2.)**3 RHOUSE=RHOBAR*(1.-ALPHAT*TMEAN) SZ= -PL0-RHOUSE*G*ZTRAN/2. PH2O=PW0+RHOH2O*G*ZTRAN/2. SZEFF=SZ+BIOT*PH2O C C Compute effective horizontal principal stresses, C and their derivitives with respect to E1 and E2, C at the midpoint of the frictional layer, according C to the methods in Bird (1989), pages 3973-3977 C (except, correcting the typos in the caption for C Figure 4): C C Define the corner points of the diamond in the C ordered principal strain-rate plane: E1AT1=((1./GAMMA)-1.)*SZEFF/(6.*VISMAX) E2AT1=E1AT1 E1AT2=(1.-(1./GAMMA))*SZEFF/(6.*VISMAX) E2AT2=((2./GAMMA)-2.)*SZEFF/(6.*VISMAX) E1AT3=(2.*GAMMA-2.)*SZEFF/(6.*VISMAX) E2AT3=(1.-GAMMA)*SZEFF/(6.*VISMAX) E1AT4=(GAMMA-1.)*SZEFF/(6.*VISMAX) E2AT4=E1AT4 ANGAT2=ATAN2F((E2-E2AT2),(E1-E1AT2)) ANGAT3=ATAN2F((E2-E2AT3),(E1-E1AT3)) C C Select proper segment of diagram and assign effective C principal stresses. C Also, begin definition of strategic stiffnesses C DS1DE1, DS1DE2, DS2DE1, and DS2DE2, by computing C stiffness required to give warning of local cliffs. C Afterward, basic minimum stiffness required to avoid C singularity of stiffness matrix will be imposed with C a formula common to all regions. IF (E1.GT.E1AT1) THEN C Region N/N: two conjugate sets of normal faults S1EFF=SZEFF/GAMMA S2EFF=S1EFF C DS1DE1=(0.5*((1/GAMMA)-1.)*SZEFF)/E1 DS1DE2=0. DS2DE1=0. DS2DE2=(0.5*((1/GAMMA)-1.)*SZEFF)/E2 ELSE IF ((E1.GE.E1AT2).AND. + (ANGAT2.GT.ATAN2F((E2AT1-E2AT2),(E1AT1-E1AT2)))) THEN C Region N: single conjugate set of normal faults S2EFF=SZEFF/GAMMA FRAC=(E1-E1AT1)/(E1AT2-E1AT1) C fraction increases in -E1 direction, from point 1 -> 2 S1EFF=SZEFF*((1/GAMMA)+FRAC*(1.-(1./GAMMA))) C DS1DE1=4.*VISMAX DS1DE2=0. DS2DE1=0. DS2DE2=0. ELSE IF ((ANGAT2.LE.1.9635).AND.(ANGAT2.GE.1.5707)) THEN C Region N/S: transtension, dominantly normal. S1EFF=SZEFF S2EFF=SZEFF/GAMMA C DS1DE1=(0.5*((1.-1/GAMMA))*SZEFF)/E1 DS1DE2=0. DS2DE1=0. DS2DE2=0. ELSE IF ((ANGAT2.LE.2.3562).AND.(ANGAT2.GE.1.9635)) THEN C Region S/N: transtension, dominantly strike-slip. S1EFF=SZEFF S2EFF=SZEFF/GAMMA C C GREAT is the value of DS1DE1 in region S: GREAT=6.*VISMAX*(GAMMA-1.)/(GAMMA-(1./GAMMA)) C FRAC is also defined exactly as in S, so here it C will be negative: FRAC=((E1+E2)-(E1AT2+E2AT2))/ + ((E1AT3+E2AT3)-(E1AT2+E2AT2)) C Reduce all derivitives according to distance: GREAT=GREAT*(-0.5)/(FRAC-0.5) C Pattern of derivitives is the same as in S: DS1DE1=GREAT DS1DE2=DS1DE1 DS2DE1=DS1DE1/GAMMA DS2DE2=DS2DE1 ELSE IF ((ANGAT3.LE.2.3562).AND. + (ANGAT3.GE.ATAN2F((E2AT2-E2AT3),(E1AT2-E1AT3)))) THEN C Region S: single set of conjugate strike-slip faults FRAC=((E1+E2)-(E1AT2+E2AT2))/ + ((E1AT3+E2AT3)-(E1AT2+E2AT2)) C FRAC increases across band from the S/N (point 2) side C toward the S/T (point 3) side; contours of FRAC are C parallel to the band sides, not normal to the diamond. S1EFF=SZEFF*(1.+FRAC*(GAMMA-1.)) S2EFF=SZEFF*((1./GAMMA)+FRAC*(1.-(1./GAMMA))) C Notes: The equation of this line is S2EFF=S1EFF/GAMMA. C I used algebra to check (98.4.21) that the C pure strike-slip stress (S1EFF,S2EFF)= C SZZEFF*(1.+STFRIC,1.-STFRIC) correctly falls on C this line, at the correct point (E1= -E2). C DS1DE1=6.*VISMAX*(GAMMA-1.)/(GAMMA-(1./GAMMA)) DS1DE2=DS1DE1 DS2DE1=DS1DE1/GAMMA DS2DE2=DS2DE1 ELSE IF ((ANGAT3.LE.2.7489).AND.(ANGAT3.GE.2.3562)) THEN C Region S/T: transpression; strike-slip dominant. S1EFF=SZEFF*GAMMA S2EFF=SZEFF C C GREAT is the value of DS1DE1 in region S: GREAT=6.*VISMAX*(GAMMA-1.)/(GAMMA-(1./GAMMA)) C FRAC is also defined exactly as in S, so here it C will be greater than one: FRAC=((E1+E2)-(E1AT2+E2AT2))/ + ((E1AT3+E2AT3)-(E1AT2+E2AT2)) C Reduce all derivitives according to distance: GREAT=GREAT*(0.5)/(FRAC-0.5) C Pattern of derivitives is the same as in S: DS1DE1=GREAT DS1DE2=DS1DE1 DS2DE1=DS1DE1/GAMMA DS2DE2=DS2DE1 ELSE IF ((E2.GE.E2AT3).AND.(ANGAT3.GE.2.7489)) THEN C Region T/S: transpression; thrusting dominant. S1EFF=SZEFF*GAMMA S2EFF=SZEFF C DS1DE1=0. DS1DE2=0. DS2DE1=0. DS2DE2=(0.5*(1.-GAMMA)*SZEFF)/E2 ELSE IF ((E2.GE.E2AT4).AND. + (ANGAT3.LE.ATAN2F((E2AT4-E2AT3),(E1AT4-E1AT3)))) THEN C Region T: single conjugate thrust fault set. S1EFF=SZEFF*GAMMA FRAC=(E2-E2AT3)/(E2AT4-E2AT3) C FRAC increases in the -E2 direction across the band. S2EFF=SZEFF*(1.+FRAC*(GAMMA-1.)) C DS1DE1=0. DS1DE2=0. DS2DE1=0. DS2DE2=4.*VISMAX ELSE IF (E2.LE.E2AT4) THEN C Region T/T: Two set of conjugate thrust faults. S1EFF=SZEFF*GAMMA S2EFF=S1EFF C DS1DE1=(0.5*(GAMMA-1.)*SZEFF)/E1 DS1DE2=0. DS2DE1=0. DS2DE2=(0.5*(GAMMA-1.)*SZEFF)/E2 ELSE C Region V: linear viscosity C Note that equations are now for SIGMA1,2 and no C longer for S1EFF and S2EFF. However, we can C easily compute both: SIGMA1=SZ+VISMAX*(4.*E1+2.*E2) SIGMA2=SZ+VISMAX*(2.*E1+4.*E2) S1EFF=SIGMA1+BIOT*PH2O S2EFF=SIGMA2+BIOT*PH2O C DS1DE1=0. DS1DE2=0. DS2DE1=0. DS2DE2=0. END IF C C Regardless of region, be sure that stiffnesses do C not fall below those which represent a minimum C effective viscosity-- one based on the weakest of C the active fault sets. This is to guaruntee that C the linear system will not have any zero eigenvalues, C even if a creeping layer does not exist. VISMIN=VISMAX IF ((E1.LT.0.).AND.(E2.GT.0.)) THEN C strike-slip faults are active VISMIN=MIN(VISMIN,0.5*(S2EFF-S1EFF)/(E2-E1)) END IF IF ((E1.LT.0.).AND.(EZ.GT.0.)) THEN C thrust faults are active VISMIN=MIN(VISMIN,0.5*(SZEFF-S1EFF)/(EZ-E1)) END IF IF ((E2.GT.0.).AND.(EZ.LT.0.)) THEN C normal faults are active VISMIN=MIN(VISMIN,0.5*(S2EFF-SZEFF)/(E2-EZ)) END IF DS1DE1=DS1DE1+4.*VISMIN DS1DE2=DS1DE2+2.*VISMIN DS2DE1=DS2DE1+2.*VISMIN DS2DE2=DS2DE2+4.*VISMIN C C Convert effective principal stresses at the midpoint C of the frictional layer into total principal stresses: SIGMA1=S1EFF-BIOT*PH2O SIGMA2=S2EFF-BIOT*PH2O C (Note that correcting S1 and S2 by a constant does not C affect the values of the derivitives DS1DE1...DS2DE2.) C C Convert total principal stresses at the midpoint of C the frictional layer into relative principal stresses C (relative to the total vertical stress, that is): S1REL=SIGMA1-SZ S2REL=SIGMA2-SZ C (Note that correcting S1 and S2 by a constant does not C affect the values of the derivitives DS1DE1...DS2DE2.) C C Convert values at midpoint of frictional layer to C integrals over the frictional layer: TAU1=S1REL*ZTRAN TAU2=S2REL*ZTRAN DT1DE1=DS1DE1*ZTRAN DT1DE2=DS1DE2*ZTRAN DT2DE1=DS2DE1*ZTRAN DT2DE2=DS2DE2*ZTRAN C C Add integrals over frictional layer to layer totals: PT1=PT1+TAU1 PT2=PT2+TAU2 PT1DE1=PT1DE1+DT1DE1 PT1DE2=PT1DE2+DT1DE2 PT2DE1=PT2DE1+DT2DE1 PT2DE2=PT2DE2+DT2DE2 END IF C (IF the frictional layer thickness ZTRAN > 0) C C COMPUTE AND ADD STRENGTH OF CREEPING PART OF LAYER: C IF (ZTRAN.LT.THICK) THEN C C Precompute the maximum viscosity limit imposed by the C requirement that creep shear stress never exceeds C DCREEP on any plane: VISDCR=DCREEP/(MAX(E1,E2,EZ)-MIN(E1,E2,EZ)) C C Precompute the lower viscosity limit imposed by the C requirement that creep shear stress does not C fall below SIGHBI: VISSHB=SIGHBI/(MAX(E1,E2,EZ)-MIN(E1,E2,EZ)) C C Compute the vertical integral of viscosity, C observing the local limit VISDCR, and terminating C the integral if creep shear stress falls below C SIGHBI (because then we are in a horizontally- C sheared boundary layer which does not contribute C anything to plate strength): C NVSTEP=50 DZ=(THICK-ZTRAN)/NVSTEP C VISINT=0. DO 200 N=0,NVSTEP Z=ZTRAN+N*DZ C Note that Z is measured from top of layer C (upper surface of hard crust, or Moho) and C may not be absolute depth. T=GEOTH1+GEOTH2*Z+GEOTH3*Z**2+GEOTH4*Z**3 T=MIN(T,TEMLIM) ARGUME=(BCREEP+CCREEP*(ZOFTOP+Z))/T ARGUME=MAX(MIN(ARGUME,87.),-87.) VIS=VISINF*EXP(ARGUME) VIS=MIN(VIS,VISDCR) IF ((N.EQ.0).OR.(N.EQ.NVSTEP)) THEN FRAC=0.5 ELSE FRAC=1. END IF IF (VIS.LT.VISSHB) GO TO 201 VISINT=VISINT+FRAC*VIS*DZ 200 CONTINUE 201 CONTINUE C C Limit the mean viscosity of the creeping layer to C be no more than VISMAX: VISINT=MIN(VISINT,VISMAX*(THICK-ZTRAN)) C TAU1=4.*VISINT*E1+2.*VISINT*E2 TAU2=2.*VISINT*E1+4.*VISINT*E2 C Note that these principal values of TAU (the two C horizontal principal values, contributed by the C creeping layer only) are relative to TAUZZ, which C is the vertical integral of the vertical stress C anomaly through the creeping layer. C DT1DE1=4.*VISINT DT1DE2=2.*VISINT DT2DE1=2.*VISINT DT2DE2=4.*VISINT C C Add integrals over creeping layer to layer totals: PT1=PT1+TAU1 PT2=PT2+TAU2 PT1DE1=PT1DE1+DT1DE1 PT1DE2=PT1DE2+DT1DE2 PT2DE1=PT2DE1+DT2DE1 PT2DE2=PT2DE2+DT2DE2 END IF C (IF the creeping layer thickness (THICK-ZTRAN) > 0) C RETURN END C C C SUBROUTINE DOWNER (INPUT,BRIEF,FDIP,IUNITT,MXBN,MXFEL,MXNODE, + NFL,NODEF,NUMNOD,SLIDE, + XNODE,YNODE, + OUTPUT,NCOND,NODCON, + WORK,CHECKN) C C Surveys faults for dips less than SLIDE (radians), and C lists the footwall nodes as needing boundary conditions. C (This routine is only called for whole-Earth models.) C LOGICAL BRIEF,CHECKN DIMENSION CHECKN(MXNODE),FDIP(2,MXFEL),NODCON(MXBN), + NODEF(4,MXFEL),XNODE(MXNODE),YNODE(MXNODE) C TOPS=3.141592654-SLIDE C DO 10 I=1,NUMNOD CHECKN(I)=.FALSE. 10 CONTINUE C DO 100 I=1,NFL IF (NODEF(1,I).NE.NODEF(4,I)) THEN IF (FDIP(1,I).LE.SLIDE) THEN CHECKN(NODEF(4,I))=.TRUE. ELSE IF (FDIP(1,I).GE.TOPS) THEN CHECKN(NODEF(1,I))=.TRUE. ENDIF ENDIF IF (NODEF(2,I).NE.NODEF(3,I)) THEN IF (FDIP(2,I).LE.SLIDE) THEN CHECKN(NODEF(3,I))=.TRUE. ELSE IF (FDIP(2,I).GE.TOPS) THEN CHECKN(NODEF(2,I))=.TRUE. ENDIF ENDIF 100 CONTINUE C NCOND=0 DO 200 I=1,NUMNOD IF (CHECKN(I)) THEN IF (NCOND.LT.MXBN) THEN NCOND=NCOND+1 NODCON(NCOND)=I ELSE WRITE (IUNITT,199) 199 FORMAT (/' Increase the constant in the formula', + ' for MXBN, and recompile.') CALL PAUSE() STOP ENDIF ENDIF 200 CONTINUE C IF (.NOT.BRIEF) THEN WRITE(IUNITT,880) 880 FORMAT(/ /' Here follows a list, in consecutive order,'/ + ' of the nodes in the footwalls of '/ + ' SUBduction zones; these nodes require boundary', + ' conditions:'/' BC# Node Latitude', + ' Longitude') DO 890 I=1,NCOND N=NODCON(I) THELAT=90.-57.2958*XNODE(N) THELON=57.2958*YNODE(N) WRITE(IUNITT,882) I, N, THELAT, THELON 882 FORMAT(' ',2I6,2F10.2) 890 CONTINUE ENDIF RETURN END C C C SUBROUTINE EDGEVS (INPUT,FDIP,IPVREF,IUNITD,IUNITT,MXBN,MXNODE, + MXFEL,NAMES,NCOND,NFL,NODCON,NODEF, + OMEGA,RADIUS,SLIDE,SPHERE,XNODE,YNODE, + MODIFY,ICOND,VBCARG,VBCMAG, + WORK,IEDGE,R2EDGE,XEDGE,YEDGE) C C Supplies velocities (VBCMAG) and arguments (VBCARG) C (measured counterclockwise in radians from +X = +Theta) C for all the boundary nodes listed in NODCON C which have ICOND = 3 or 4. C C It does this by consulting a data table of C rotation-rate poles with respect to the PAcific plate, from: C C Bird, P., An updated digital model of plate boundaries, C Geochemistry Geophysics Geosystems, 4(3), 1027, C doi:10.1029/2001GC000252, 2003. C C The output reference frame is one where plate #IPVREF is fixed. C C To figure out which plate applies, a dataset of digitized C plate boundary lines (*.dig) is read on device IUNITD. C (As of 2005.07, the file to use is "PB2002_boundaries.dig".) C C Thest line segments must be labeled with 2-letter plate C names and an intervening boundary symbol, e.g. C Column 1 ---->PA\NA [or] PA)NA C so that the first plate named is on the left as one C proceeds along the digitised boundary. C Boundary symbols "/" [or "("] versus "\" [or ")"] must be used C for subduction boundaries to show polarity. Ridges and/or C transforms are marked by "-" or any other boundary symbol. C C If no digitized boundary is found near the node (within C 0.1 radians) or if the closest digitised boundary has a plate C name which is not found in this table, C then ICOND is modified to make the node free. C CCC IF (SPHERE; a global model) THEN CCC look-up position is that of a fault midpoint. CCC boundary V is that of the subducting plate. CCC ELSE (a local model) CCC look-up position is the node position. CCC Boundary V is that of the plate on the right, looking along CCC digitised line (i.e., If we assume that the edge CCC of the model is surrounded with fault elements, CCC then it should be digitised counterclockwise. CCC (If model is not surrounded by faults, then using CCC boundary conditons of type 5 would be more appropriate.) CCC ENDIF C------------------------------------------------------- PARAMETER (NPLATE=52) CHARACTER*1 LEFT1,LEFT2,RIGHT1,RIGHT2,WHICH CHARACTER*2 FIRST,SECOND,NAMES CHARACTER*3 STARS LOGICAL READIT,SPHERE DIMENSION FDIP(2,MXFEL), ICOND (MXBN), IEDGE (MXBN), + NODCON (MXBN), NODEF(4,MXFEL),R2EDGE (MXBN), + VBCARG (MXBN), VBCMAG (MXBN), + XEDGE (MXBN), YEDGE (MXBN), + XNODE (MXNODE),YNODE (MXNODE) DIMENSION NAMES (NPLATE), OMEGA (3,NPLATE) DATA LEFT1/'\'/,LEFT2/')'/, RIGHT1/'/'/,RIGHT2/'('/ C---------------------------------------------------------------- C READIT=.FALSE. DO 90 I=1,NCOND N=NODCON(I) IF ((ICOND(I).EQ.3).OR.(ICOND(I).EQ.4)) THEN READIT=.TRUE. IEDGE(I)=0 R2EDGE(I)=9.99E29 IF (SPHERE) THEN DO 50 K=1,NFL N1=NODEF(1,K) N2=NODEF(2,K) N3=NODEF(3,K) N4=NODEF(4,K) IF ( + ((N.EQ.N1).AND.(FDIP(1,K).GE.(3.14159-SLIDE))) .OR. + ((N.EQ.N2).AND.(FDIP(2,K).GE.(3.14159-SLIDE))) .OR. + ((N.EQ.N3).AND.(FDIP(2,K).LE.SLIDE)) .OR. + ((N.EQ.N4).AND.(FDIP(1,K).LE.SLIDE)) + ) THEN X1=XNODE(N1) X2=XNODE(N2) Y1=YNODE(N1) Y2=YNODE(N2) A1=COS(Y1)*SIN(X1) A2=COS(Y2)*SIN(X2) B1=SIN(Y1)*SIN(X1) B2=SIN(Y2)*SIN(X2) G1=COS(X1) G2=COS(X2) AM=0.5*(A1+A2) BM=0.5*(B1+B2) GM=0.5*(G1+G2) SIZE=SQRT(AM*AM+BM*BM+GM*GM) AM=AM/SIZE BM=BM/SIZE GM=GM/SIZE EQUPAR=SQRT(AM*AM+BM*BM) THETA=ATAN2F(EQUPAR,GM) PHI=ATAN2F(BM,AM) XEDGE(I)=THETA YEDGE(I)=PHI GO TO 55 ENDIF 50 CONTINUE WRITE (IUNITT,51) N 51 FORMAT (/' ERR','OR IN SUBPROGRAM -EDGEVS-:' + /' SUBPROGRAM -DOWNER- PLACED NODE ',I6 + /' ON LIST OF SUBDUCTING-SLAB NODES,' + /' BUT NO SUCH FAULT ELEMENT FOUND.') CALL PAUSE() STOP 55 CONTINUE ELSE XEDGE(I)=XNODE(NODCON(I)) YEDGE(I)=YNODE(NODCON(I)) ENDIF ENDIF 90 CONTINUE IF (.NOT.READIT) RETURN C WRITE (*,2) IUNITD WRITE (IUNITT,2) IUNITD 2 FORMAT (/' Attempting to read plate BOUNDARIES from unit ',I3/) NREAD=0 100 READ (IUNITD,101,END=201,IOSTAT=IOS) FIRST,WHICH,SECOND 101 FORMAT (A2,A1,A2) IF ((NREAD.EQ.0).AND.(IOS.NE.0)) THEN WRITE(*,"(' ERR','OR:File not found, or file empty.')") CALL PAUSE() STOP END IF NREAD=NREAD+1 IF (SPHERE) THEN C Use plate which is subducting, if any: IF ((WHICH.EQ.LEFT1).OR.(WHICH.EQ.LEFT2)) THEN IPLATE=0 DO 110 K=1,NPLATE IF (FIRST.EQ.NAMES(K)) IPLATE=K 110 CONTINUE ELSE IF ((WHICH.EQ.RIGHT1).OR. + (WHICH.EQ.RIGHT2)) THEN IPLATE=0 DO 120 K=1,NPLATE IF (SECOND.EQ.NAMES(K)) IPLATE=K 120 CONTINUE ELSE IPLATE=0 ENDIF ELSE C Local model; use plate on right IPLATE=0 DO 130 K=1,NPLATE IF (SECOND.EQ.NAMES(K)) IPLATE=K 130 CONTINUE ENDIF 140 READ (IUNITD,141,END=201) STARS 141 FORMAT (A3) IF (STARS.EQ.'***') GO TO 100 BACKSPACE IUNITD READ (IUNITD, * ) PLON, PLAT CC142 FORMAT (1X,F12.5,1X,F12.5) IF (IPLATE.GT.0) THEN PLON=PLON*0.017453293 PLAT=PLAT*0.017453293 X=COS(PLON)*COS(PLAT) Y=SIN(PLON)*COS(PLAT) Z=SIN(PLAT) DO 150 I=1,NCOND IF ((ICOND(I).EQ.3).OR.(ICOND(I).EQ.4)) THEN THETA=XEDGE(I) PHI=YEDGE(I) XP=COS(PHI)*SIN(THETA) YP=SIN(PHI)*SIN(THETA) ZP=COS(THETA) R2=(X-XP)**2+(Y-YP)**2+(Z-ZP)**2 IF (R2.LE.R2EDGE(I)) THEN R2EDGE(I)=R2 IEDGE(I)=IPLATE ENDIF ENDIF 150 CONTINUE ENDIF GO TO 140 C 201 DO 300 I=1,NCOND IF ((ICOND(I).EQ.3).OR.(ICOND(I).EQ.4)) THEN IPLATE=IEDGE(I) IF ((IPLATE.EQ.IPVREF).AND.(ICOND(I).EQ.3)) THEN C problem: subduction direction is undefined! ICOND(I)=4 VBCMAG(I)=0.0 VBCARG(I)=0.0 C N.B. A plate never moves in its own reference frame! WRITE (IUNITT,205) N, PLON, PLAT 205 FORMAT (/' SUBDUCTION DIRECTION IS UNDEFINED', + ' FOR BOUNDARY NODE ',I6/ + ' AT ',F8.3,' EAST, ',F7.3,' NORTH: ', + 'NODE WILL BE GIVEN A TYPE-4 BC.') ELSE IF ((IPLATE.EQ.0).OR.(R2EDGE(I).GT.0.01)) THEN C plate not identified, or trench very far away: ICOND(I)=0 N=NODCON(I) THETA=XNODE(N) PHI=YNODE(N) PLON=57.29578*PHI PLAT=90.-57.29578*THETA WRITE (IUNITT,209) N, PLON, PLAT 209 FORMAT (/' NO RECOGNIZABLE DIGITISED SUBDUCTION', + ' ZONE PASSES BOUNDARY NODE ',I6/ + ' AT ',F8.3,' EAST, ',F7.3,' NORTH: ', + 'NODE WILL BE FREE.') ELSE C normal cases: IF (IPLATE.EQ.IPVREF) THEN VBCMAG(I)=0.0 VBCARG(I)=0.0 ELSE C Convert to IPVREF-fixed, and radians/second: OMEGAX=(OMEGA(1,IPLATE)- + OMEGA(1,IPVREF))*3.168809E-14 OMEGAY=(OMEGA(2,IPLATE)- + OMEGA(2,IPVREF))*3.168809E-14 OMEGAZ=(OMEGA(3,IPLATE)- + OMEGA(3,IPVREF))*3.168809E-14 C Convert to length/second: OMEGAX=OMEGAX*RADIUS OMEGAY=OMEGAY*RADIUS OMEGAZ=OMEGAZ*RADIUS N=NODCON(I) THETA=XNODE(N) PHI=YNODE(N) XN=COS(PHI)*SIN(THETA) YN=SIN(PHI)*SIN(THETA) ZN=COS(THETA) C Velocity = OMEGA x position: VX=OMEGAY*ZN-OMEGAZ*YN VY=OMEGAZ*XN-OMEGAX*ZN VZ=OMEGAX*YN-OMEGAY*XN VBCMAG(I)=SQRT(VX**2+VY**2+VZ**2) C Create unit +Theta and +Phi vectors in Cartesian: THETAX=COS(THETA)*COS(PHI) THETAY=COS(THETA)*SIN(PHI) THETAZ= -SIN(THETA) PHIX= -SIN(PHI) PHIY=COS(PHI) PHIZ=0. C Find argument from dot products: VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ VBCARG(I)=ATAN2F(VPHI,VTHETA) ENDIF ENDIF ENDIF 300 CONTINUE RETURN END C C C SUBROUTINE EDOT (INPUT,DXS,DYS, + FPSFER,MXEL, + MXNODE,NODES,NUMEL,RADIUS,SITA,V, + OUTPUT,ERATE) C C Compute strain rate components EDOTXX, EDOTYY, and C EDOTXY (tensor form; equal to C (1/2) * ((dVx/dY)+(dVy/dX)) C at the integration points of triangular continuum elements. C DOUBLE PRECISION POINTS,V DIMENSION DXS(2,2,3,7,MXEL),DYS(2,2,3,7,MXEL), + ERATE(3,7,MXEL), + FPSFER(2,2,3,7,MXEL), + NODES(3,MXEL), POINTS(3,7), + SITA(7,MXEL),V(2,MXNODE) COMMON /S1S2S3/ POINTS C DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=0. EYY=0. EXY=0. DO 800 J=1,3 NODE=NODES(J,I) VX=V(1,NODE) VY=V(2,NODE) DY11=DYS(1,1,J,M,I)/SIN(SITA(M,I)) DY21=DYS(2,1,J,M,I)/SIN(SITA(M,I)) DY12=DYS(1,2,J,M,I)/SIN(SITA(M,I)) DY22=DYS(2,2,J,M,I)/SIN(SITA(M,I)) FP11=FPSFER(1,1,J,M,I)/TAN(SITA(M,I)) FP21=FPSFER(2,1,J,M,I)/TAN(SITA(M,I)) FP12=FPSFER(1,2,J,M,I)/TAN(SITA(M,I)) FP22=FPSFER(2,2,J,M,I)/TAN(SITA(M,I)) EXX=EXX+VX*DXS(1,1,J,M,I)+VY*DXS(2,1,J,M,I) EYY=EYY+VX*DY12+VY*DY22+VX*FP11+VY*FP21 EXY=EXY+VX*DY11+VY*DY21 + +VX*DXS(1,2,J,M,I)+VY*DXS(2,2,J,M,I) + -VX*FP12-VY*FP22 800 CONTINUE ERATE(1,M,I)=EXX/RADIUS ERATE(2,M,I)=EYY/RADIUS ERATE(3,M,I)=0.5*EXY/RADIUS 900 CONTINUE 1000 CONTINUE RETURN END C C SUBROUTINE ELUVEC (INPUT,N1,N2,N3,NUMNOD,XNODE,YNODE, + OUTPUT,PHIM,THETAM,UVECM) C C Computes all necessary unit vectors at the integration points C within one triangular continuum element: C UVECM = position vector C THETAM= +theta unit vector at that site C PHIM = +phi unit vector at that site C REAL, DIMENSION(NUMNOD) :: XNODE, YNODE REAL, DIMENSION(3,7) :: PHIM, THETAM, UVECM C REAL :: LENGTH REAL, DIMENSION(3,3) :: UVECN C C Named COMMON blocks hold the fixed values of the positions, C weights, and nodal function values at the integration points C in the elements (triangular elements in BLOCK DATA BD1, C and fault elements in BLOCK DATA BD2). C Entries corresponding to BD1: DOUBLE PRECISION POINTS COMMON /S1S2S3/ POINTS DIMENSION POINTS(3,7) C C Find UVECN = uvec's of corner nodes: C DO 10 J=1,3 IF (J.EQ.1) THEN N=N1 ELSE IF (J.EQ.2) THEN N=N2 ELSE N=N3 ENDIF X=XNODE(N) Y=YNODE(N) UVECN(1,J)=SIN(X)*COS(Y) UVECN(2,J)=SIN(X)*SIN(Y) UVECN(3,J)=COS(X) 10 CONTINUE C C Create each of 7 integration points: C DO 100 M=1,7 C Rough linear interpolation: UVECM(1,M)=POINTS(1,M)*UVECN(1,1)+POINTS(2,M)*UVECN(1,2)+ + POINTS(3,M)*UVECN(1,3) UVECM(2,M)=POINTS(1,M)*UVECN(2,1)+POINTS(2,M)*UVECN(2,2)+ + POINTS(3,M)*UVECN(2,3) UVECM(3,M)=POINTS(1,M)*UVECN(3,1)+POINTS(2,M)*UVECN(3,2)+ + POINTS(3,M)*UVECN(3,3) C Normalization: LENGTH=SQRT(UVECM(1,M)**2+UVECM(2,M)**2+UVECM(3,M)**2) UVECM(1,M)=UVECM(1,M)/LENGTH UVECM(2,M)=UVECM(2,M)/LENGTH UVECM(3,M)=UVECM(3,M)/LENGTH C C Unit vectors at this site (NOT a pole): C PHIM(1,M)= -UVECM(2,M) PHIM(2,M)=UVECM(1,M) EQUAT=SQRT(PHIM(1,M)**2+PHIM(2,M)**2) PHIM(1,M)=PHIM(1,M)/EQUAT PHIM(2,M)=PHIM(2,M)/EQUAT PHIM(3,M)=0.0 TEQUAT=UVECM(3,M) THETAM(3,M)= -EQUAT THETAM(1,M)=TEQUAT*UVECM(1,M)/EQUAT THETAM(2,M)=TEQUAT*UVECM(2,M)/EQUAT LENGTH=SQRT(THETAM(1,M)**2+THETAM(2,M)**2+ + THETAM(3,M)**2) THETAM(1,M)=THETAM(1,M)/LENGTH THETAM(2,M)=THETAM(2,M)/LENGTH THETAM(3,M)=THETAM(3,M)/LENGTH 100 CONTINUE RETURN END C C C SUBROUTINE EULER (INPUT,NAMTAG,NODE, + IPVREF,NAMES,NPLATE,OMEGA, + IUNITT,RADIUS, + MXNODE,XNODE,YNODE, + OUTPUT,VAZ,VMAG) C C Given a 2-letter plate identifier (NAMTAG), C finds this plate in the table NAMES(NPLATE) and C looks up its Euler rotation vector in OMEGA(3,NPLATE). C Then converts the rotation to the reference frame of C plate # IPVREF (in the same tables). C Finally, computes the velocity vector C (using the theta and phi of node #NODE in the lists C XNODE(MXNODE) and YNODE(MXNODE)) C and expresses it as: C VAZ = azimuth clockwise from North, in degrees; C VMAG = magnitude in SI (m/s). C IMPLICIT NONE INTEGER :: INPUT CHARACTER(2), INTENT(IN) :: NAMTAG INTEGER, INTENT(IN) :: NODE INTEGER, INTENT(IN) :: IPVREF INTEGER, INTENT(IN) :: NPLATE CHARACTER(2), DIMENSION(NPLATE), INTENT(IN) :: NAMES REAL, DIMENSION(3,NPLATE), INTENT(IN) :: OMEGA INTEGER, INTENT(IN) :: IUNITT REAL, INTENT(IN) :: RADIUS INTEGER, INTENT(IN) :: MXNODE REAL, DIMENSION(MXNODE), INTENT(IN) :: XNODE REAL, DIMENSION(MXNODE), INTENT(IN) :: YNODE REAL :: OUTPUT REAL, INTENT(OUT):: VAZ, VMAG C INTEGER :: I, JPLATE REAL :: VTHETA, VPHI REAL, DIMENSION(3) :: PHI, ROTATE, RVEC, THETA, VMPS REAL, EXTERNAL :: ATAN2F C JPLATE=0 DO 10 I=1,NPLATE IF (NAMTAG.EQ.NAMES(I)) THEN JPLATE=I GO TO 11 END IF 10 CONTINUE 11 IF (JPLATE.EQ.0) THEN WRITE (IUNITT,12) NAMTAG WRITE (*,12) NAMTAG 12 FORMAT(' ERROR: Plate name {',A2,'} not found in lists.' + /' Please correct the boundary conditions file.') STOP END IF C relative Euler vector in radians/second: DO 20 I=1,3 ROTATE(I)=(OMEGA(I,JPLATE)-OMEGA(I,IPVREF))*3.168809E-14 20 CONTINUE C radius vector to location: RVEC(1)=RADIUS*SIN(XNODE(NODE))*COS(YNODE(NODE)) RVEC(2)=RADIUS*SIN(XNODE(NODE))*SIN(YNODE(NODE)) RVEC(3)=RADIUS*COS(XNODE(NODE)) C cross product gives velocity in m/s in Cartesian: VMPS(1)=ROTATE(2)*RVEC(3)-ROTATE(3)*RVEC(2) VMPS(2)=ROTATE(3)*RVEC(1)-ROTATE(1)*RVEC(3) VMPS(3)=ROTATE(1)*RVEC(2)-ROTATE(2)*RVEC(1) VMAG=SQRT(VMPS(1)**2+VMPS(2)**2+VMPS(3)**2) C create unit +Theta and +Phi vectors in Cartesian: THETA(1)=COS(XNODE(NODE))*COS(YNODE(NODE)) THETA(2)=COS(XNODE(NODE))*SIN(YNODE(NODE)) THETA(3)= -SIN(XNODE(NODE)) PHI(1)= -SIN(YNODE(NODE)) PHI(2)=COS(YNODE(NODE)) PHI(3)=0.0 C find azimuth from dot products: VTHETA=VMPS(1)*THETA(1)+VMPS(2)*THETA(2)+VMPS(3)*THETA(3) VPHI=VMPS(1)*PHI(1)+VMPS(2)*PHI(2)+VMPS(3)*PHI(3) VAZ=57.2957795*ATAN2F(VPHI, -VTHETA) END C C C SUBROUTINE FANGLS (INPUT,PHI,THETA, + OUTPUT,FANGLE) C C Calculate the arguments (angles counterclockwise from +Theta) C at both ends of an arc of a great circle. Results in radians. C DOUBLE PRECISION FPOINT COMMON /SFAULT/ FPOINT DIMENSION FANGLE(2),FPOINT(7),PHI(2),THETA(2) DG180=3.141592654 A1=SIN(THETA(1))*COS(PHI(1)) A2=SIN(THETA(1))*SIN(PHI(1)) A3=COS(THETA(1)) B1=SIN(THETA(2))*COS(PHI(2)) B2=SIN(THETA(2))*SIN(PHI(2)) B3=COS(THETA(2)) C S=0.99 XX=S*A1+(1.0-S)*B1 YY=S*A2+(1.0-S)*B2 ZZ=S*A3+(1.0-S)*B3 XVAL=SQRT(XX*XX+YY*YY+ZZ*ZZ) XX=XX/XVAL YY=YY/XVAL ZZ=ZZ/XVAL DX=XX-A1 DY=YY-A2 DZ=ZZ-A3 SITA=THETA(1) PHAI=PHI(1) S1=COS(SITA)*COS(PHAI) S2=COS(SITA)*SIN(PHAI) S3=-SIN(SITA) P1=-SIN(PHAI) P2=COS(PHAI) DXX=DX*S1+DY*S2+DZ*S3 DYY=DX*P1+DY*P2 FANGLE(1)=ATAN2F(DYY,DXX) C S=0.01 XX=S*A1+(1.0-S)*B1 YY=S*A2+(1.0-S)*B2 ZZ=S*A3+(1.0-S)*B3 XVAL=SQRT(XX*XX+YY*YY+ZZ*ZZ) XX=XX/XVAL YY=YY/XVAL ZZ=ZZ/XVAL DX=B1-XX DY=B2-YY DZ=B3-ZZ SITA=ACOS(ZZ) PHAI=ATAN2F(YY,XX) IF(PHAI.LT.0.0) PHAI=2.0*DG180+PHAI S1=COS(SITA)*COS(PHAI) S2=COS(SITA)*SIN(PHAI) S3=-SIN(SITA) P1=-SIN(PHAI) P2=COS(PHAI) DXX=DX*S1+DY*S2+DZ*S3 DYY=DX*P1+DY*P2 FANGLE(2)=ATAN2F(DYY,DXX) C RETURN END C C C SUBROUTINE FEM (INPUT,ALPHA,AREA,CONSTR,DETJ, + DXS,DYS,ETA, + EVERYP,FBASE,FC,FDIP, + FIMUDZ,FLEN,FPFLT,FPSFER,FARG, + FTSTAR,ICOND,ITER,IUNITS,IUNITT, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + NCOND,NDOF,NFL,NLB,NODCON,NODEF, + NODES,NUB,NUMEL,NUMNOD, + OVB,PULLED,RADIUS,SITA, + TITLE1,TITLE2,TITLE3,TOFSET,TRHMAX, + VBCARG,VBCMAG,WEDGE,XNODE, + YNODE,LASTPM, + MODIFY,ERATE,V, + OUTPUT,DV,SCOREA,SCOREB,TAUMAT, + WORK,F,K) C C Computes horizontal velocity of nodes in a thin-shell lithosphere, C based on applied forces and boundary conditions. C Uses the current strain rate (ERATE must be input) as a basis C for linearizing the equations by the secant method. C C Also returns two scores: max_dV, RMS_dV/RMS_V C DOUBLE PRECISION F,FBASE,K,V CHARACTER*80 TITLE1,TITLE2,TITLE3 LOGICAL EVERYP C C Note: Following type can be compressed to LOGICAL*1 in VS-Fortran: LOGICAL PULLED C DIMENSION ALPHA(3,3,7,MXEL),AREA(MXEL),DETJ(7,MXEL), + DXS(2,2,3,7,MXEL),DYS(2,2,3,7,MXEL), + DV(2,MXNODE), + ERATE(3,7,MXEL),ETA(7,MXEL), + F(MXDOF),FBASE(MXDOF),FC(2,2,7,MXFEL), + FDIP(2,MXFEL),FIMUDZ(7,MXFEL),FLEN(MXFEL), + FPFLT(2,2,2,7,MXFEL), + FPSFER(2,2,3,7,MXEL), + FARG(2,MXFEL),FTSTAR(2,7,MXFEL), + ICOND(MXBN), + NODCON(MXBN),NODEF(4,MXFEL),NODES(3,MXEL), + OVB(2,7,MXEL),PULLED(7,MXEL), + SITA(7,MXEL),TAUMAT(3,7,MXEL), + TOFSET(3,7,MXEL),V(2,MXNODE),VBCARG(MXBN), + VBCMAG(MXBN),XNODE(MXNODE),YNODE(MXNODE),K(MXWORK) COMMON LDA,NUCA,MXWORK C IF(LASTPM.NE.999) THEN WRITE (IUNITT,1) 1 FORMAT(' WRONG NUMBER OF ARGUMENTS IN CALL TO FEM!') CALL PAUSE() STOP ENDIF CALL BUILDF (INPUT,AREA,DETJ,DXS,DYS,ETA, + FBASE,FDIP,FLEN,FPFLT, + FPSFER,FARG,FTSTAR, + MXDOF,MXEL,MXFEL, + NDOF,NFL,NODEF,NODES, + NUMEL,OVB,PULLED, + RADIUS,SITA,TOFSET,TRHMAX, + WEDGE, + OUTPUT,F) CALL BUILDK (INPUT,ALPHA,AREA,DETJ,DXS,DYS, + ETA,FPSFER, + MXDOF,MXEL,MXNODE,NDOF,NLB, + NODES,NUB,NUMEL, + PULLED,RADIUS,SITA,TRHMAX,V, + MODIFY,F, + OUTPUT,K) CALL ADDFST (INPUT,CONSTR,FC,FDIP,FIMUDZ,FLEN,FPFLT,FARG, + MXDOF,MXFEL,MXNODE, + NFL,NODEF, + V,WEDGE, + MODIFY,F,K) CALL VBCS (INPUT,ICOND,MXBN,MXDOF,MXNODE, + NCOND,NDOF,NLB,NODCON,NUB, + VBCARG,VBCMAG, + MODIFY,F,K,V) C C Note: Following statemetn is commented-out for routine runs. C It can be restored for debugging purposes -IF- the C size of the problem is small (e.g., NDOF <= 68). C CALL PRINTK (INPUT,F,IUNITT,ITER,K,MXDOF,NDOF,NLB,NUB) C Following line prevents "UNREFERENCD" error when C the "CALL PRINTK" line is commented out: ITER=1*ITER C CALL SOLVER (INPUT,K,MXDOF,NDOF,NLB,NUB, + MODIFY,F) C C At this point, old solution is in V, and new one in F. Compare, C and compute difference dV (SINGLE-PRECISION) and two scores: C BDENOM=0. BDENON=0. SCOREA=0. SCOREB=0. DO 90 I=1,NUMNOD BDENOM=BDENOM+SQRT(F(2*I-1)**2+F(2*I)**2) BDENON=BDENON+SQRT(V(1,I)**2+V(2,I)**2) DV(1,I)=V(1,I)-F(2*I-1) DV(2,I)=V(2,I)-F(2*I) DVSIZE=SQRT(DV(1,I)**2+DV(2,I)**2) SCOREA=MAX(SCOREA,DVSIZE) SCOREB=SCOREB+DVSIZE 90 CONTINUE BDEN=MAX(BDENOM,BDENON) IF (BDEN.GT.0.) THEN SCOREB=SCOREB/BDEN ELSE SCOREB=1.0 ENDIF C C Transfer new solution to V, where it will be "old" during next call: C DO 100 I=1,NUMNOD V(1,I)=F(2*I-1) V(2,I)=F(2*I) 100 CONTINUE IF (EVERYP) THEN WRITE (IUNITS,10) TITLE1 WRITE (IUNITS,10) TITLE2 WRITE (IUNITS,10) TITLE3 10 FORMAT (A80) WRITE (IUNITS,20) ((V(J,I),J=1,2),I=1,NUMNOD) 20 FORMAT (1P,4D20.12) ENDIF C C Compute strain rate and stress (the latter according to the C current tentative linearization): C CALL EDOT (INPUT,DXS,DYS, + FPSFER,MXEL, + MXNODE,NODES,NUMEL,RADIUS,SITA,V, + OUTPUT,ERATE) CALL TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) C RETURN END C C C SUBROUTINE FILLIN (INPUT,ACREEP,ALPHAT,BASAL,BCREEP, + CCREEP,CONDUC, + cooling_curvature,curviness, + delta_rho, density_anomaly, + DQDTDA,ECREEP,ELEV, + ERATE,FPSFER,GMEAN,GRADIE, + ICONVE,IPAFRI,IPVREF,IUNITM,IUNITT, + MXEL,MXFEL,MXNODE, + NAMES,NDPLAT,NFL,NODEF,NODES, + NPBND,NPLATE,NUMEL,NUMNOD,OMEGA,ONEKM, + PLAT,PLON, + RADIO,RADIUS,RHOAST,RHOBAR,RHOH2O, + TADIAB,TEMLIM,TLNODE,TRHMAX,TSURF, + VTIMES,WHICHP,XNODE,YNODE,V,ZBASTH, + ZMNODE, + OUTPUT,CONTIN,GEOTHC,GEOTHM,GLUE, + OVB,PULLED,SIGZZI, + TAUZZI,TAUZZN,TLINT,VM,ZMOHO, + WORK,ATNODE,CHECKN) C C Precompute and interpolate all "convenience arrays": C INTEGER WHICHP LOGICAL CHECKN,CONTIN,PULLED CHARACTER*2 NAMES DOUBLE PRECISION BASAL,V,VM DOUBLE PRECISION POINTS COMMON /S1S2S3/ POINTS DIMENSION POINTS(3,7) DIMENSION ACREEP(2),ALPHAT(2),ATNODE(MXNODE), + BASAL(2,MXNODE),BCREEP(2), + CCREEP(2),CONDUC(2),CONTIN(7,MXEL), + cooling_curvature(MXNODE), + curviness(7,MXEL), + delta_rho(7,MXEL), + density_anomaly(MXNODE), + DQDTDA(MXNODE), + ELEV(MXNODE),ERATE(3,7,MXEL), + FPSFER(2,2,3,7,MXEL), + GEOTHC(4,7,MXEL),GEOTHM(4,7,MXEL), + GLUE(7,MXEL),NODEF(4,MXFEL),NODES(3,MXEL), + OVB(2,7,MXEL), + PULLED(7,MXEL),RADIO(2),RHOBAR(2), + SIGZZI(7,MXEL),TAUZZI(7,MXEL),TAUZZN(MXNODE), + TEMLIM(2),TLNODE(MXNODE), + TLINT(7,MXEL),V(2,MXNODE),WHICHP(MXNODE), + VM(2,MXNODE),XNODE(MXNODE),YNODE(MXNODE), + ZMNODE(MXNODE),ZMOHO(7,MXEL) DIMENSION PLAT (NPLATE,NPBND), PLON (NPLATE,NPBND) DIMENSION NAMES (NPLATE) DIMENSION NDPLAT (NPLATE), OMEGA (3,NPLATE) DIMENSION CHECKN(MXNODE) C DATA HUGE /1.0E+30/ C C Lower-mantle flow at nodes (for computing basal drag) C (Notes: If ICONVE=4, mantle velocity is the same under C continents and oceans; however, it is only used C for drag computation under continents. C If ICONVE=6, a virtual mantle velocity is created, C which differs from velocity model PB2002 (ICONVE==3~4) C by a large differential (or shear) velocity DIFMAG C in the direction given by BASAL vectors.) C IF (ICONVE.NE.6) THEN CALL CONVEC (INPUT,ICONVE,IPAFRI,IPVREF,IUNITM,IUNITT, + MXEL,MXFEL,MXNODE, + NAMES,NDPLAT, + NFL,NODEF,NODES, + NPBND,NPLATE,NUMEL,NUMNOD, + OMEGA,PLAT,PLON,RADIUS,VTIMES, + WHICHP,XNODE,YNODE, + OUTPUT,VM, + WORK,CHECKN) ELSE C The new case of ICONVE.EQ.6... ICONV2=3 VTIME2=1.0 C Note that use of these parameters will give the PB2002 C surface velocity model in VM... CALL CONVEC (INPUT,ICONV2,IPAFRI,IPVREF,IUNITM,IUNITT, + MXEL,MXFEL,MXNODE, + NAMES,NDPLAT, + NFL,NODEF,NODES, + NPBND,NPLATE,NUMEL,NUMNOD, + OMEGA,PLAT,PLON,RADIUS,VTIME2, + WHICHP,XNODE,YNODE, + OUTPUT,VM, + WORK,CHECKN) C Differential or shear velocity of 100 mm/a: DIFMAG=0.1/3.1536E7 DO 610 I=1,NUMNOD SHRMAG=SQRT(BASAL(1,I)**2+BASAL(2,I)**2) IF (SHRMAG.GT.0.) THEN VM(1,I)=VM(1,I)+(DIFMAG/SHRMAG)*BASAL(1,I) VM(2,I)=VM(2,I)+(DIFMAG/SHRMAG)*BASAL(2,I) END IF 610 CONTINUE ENDIF C C Same field expressed as values at integration points: C CALL FLOW (INPUT,FPSFER,MXEL,MXNODE,NODES,NUMEL,VM, + OUTPUT,OVB) C C Decide which points are "continental" C (a distinction that matters only if ICONVE=4), C using ZMOHO as temporary storage for interpolated elevation, C and TLINT as temporary storage for interpolated heatflow: C CALL INTERP (INPUT,ELEV,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,ZMOHO) CALL INTERP (INPUT,DQDTDA,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,TLINT) DO 2 M=1,7 DO 1 I=1,NUMEL CONTIN(M,I)=(ZMOHO(M,I).GT.-2500.).AND. + (TLINT(M,I).LT.0.150) C Note: Heat-flow limit excludes Iceland, Afar. 1 CONTINUE 2 CONTINUE C C Thickness of layers: C CALL INTERP (INPUT,ZMNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,ZMOHO) CALL INTERP (INPUT,TLNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,TLINT) DO 4 M=1,7 DO 3 I=1,NUMEL TLINT(M,I)=MAX(TLINT(M,I),0.) 3 CONTINUE 4 CONTINUE C C Density anomaly of chemical origin (applies to whole lithosphere): C CALL INTERP (INPUT,density_anomaly,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,delta_rho) C C Geotherm: C C -------------- The following method is easy but WRONG!----------- CCCC CALL INTERP (INPUT,cooling_curvature,MXEL,MXNODE,NODES,NUMEL, CCCC + OUTPUT,curviness) C ----------The nonlinearities are too great for this approach,---- C especially when one node of the element is on a C spreading ridge. C The correct way is to set curviness(M,I) to make the C geotherm of each integration point arrive at C temperature TASTHK=TADIAB+GRADIE*100.E3 C at depth (in lithosphere) of C (ZMOHO(M,I)+TLINT(M,I)). C ----------------------------------------------------------------- C TASTHK = TADIAB + GRADIE * 100.E3 GEOTH1=TSURF GEOTH3= -0.5*RADIO(1)/CONDUC(1) GEOTH4=0. GEOTH7= -0.5*RADIO(2)/CONDUC(2) GEOTH8=0. DO 90 M=1,7 DO 80 I=1,NUMEL C C N.B. On first pass, omit curviness: C GEOTHC(1,M,I)=GEOTH1 Q=DQDTDA(NODES(1,I))*POINTS(1,M)+ + DQDTDA(NODES(2,I))*POINTS(2,M)+ + DQDTDA(NODES(3,I))*POINTS(3,M) GEOTHC(2,M,I)=Q/CONDUC(1) GEOTHC(3,M,I)=GEOTH3 GEOTHC(4,M,I)=GEOTH4 Z=ZMOHO(M,I) GEOTHM(1,M,I)=GEOTHC(1,M,I)+ + GEOTHC(2,M,I)*Z+ + GEOTHC(3,M,I)*Z**2+ + GEOTHC(4,M,I)*Z**3 DTDZC= GEOTHC(2,M,I)+ + 2.*GEOTHC(3,M,I)*Z+ + 3.*GEOTHC(4,M,I)*Z**2 DTDZM=DTDZC*CONDUC(1)/CONDUC(2) GEOTHM(2,M,I)=DTDZM GEOTHM(3,M,I)=GEOTH7 GEOTHM(4,M,I)=GEOTH8 C C Now, correct geotherm to hit TASTHK: C IF (TLINT(M,I).GT.0.) THEN TEST=GEOTHM(1,M,I)+ + GEOTHM(2,M,I)*TLINT(M,I)+ + GEOTHM(3,M,I)*TLINT(M,I)**2+ + GEOTHM(4,M,I)*TLINT(M,I)**3 ELSE TEST=GEOTHC(1,M,I)+ + GEOTHC(2,M,I)*ZMOHO(M,I)+ + GEOTHC(3,M,I)*ZMOHO(M,I)**2+ + GEOTHC(4,M,I)*ZMOHO(M,I)**3 END IF TERR0R=TEST-TASTHK delta_quadratic= -TERR0R/(ZMOHO(M,I)+TLINT(M,I))**2 curviness(M,I) = -2. * delta_quadratic GEOTHC(3,M,I)=GEOTH3 + delta_quadratic GEOTHM(3,M,I)=GEOTH7 + delta_quadratic GEOTHM(1,M,I)=GEOTHC(1,M,I)+ + GEOTHC(2,M,I)*ZMOHO(M,I)+ + GEOTHC(3,M,I)*ZMOHO(M,I)**2+ + GEOTHC(4,M,I)*ZMOHO(M,I)**3 DTDZC= GEOTHC(2,M,I)+ + 2.*GEOTHC(3,M,I)*ZMOHO(M,I)+ + 3.*GEOTHC(4,M,I)*ZMOHO(M,I)**2 DTDZM=DTDZC*CONDUC(1)/CONDUC(2) GEOTHM(2,M,I)=DTDZM 80 CONTINUE 90 CONTINUE C C Vertical integrals of vertical stress anomaly C (relative to a standard pressure curve, in -SQUEEZ-): C DO 100 I=1,NUMNOD GEOTH2=DQDTDA(I)/CONDUC(1) GEOTH3= -0.5*RADIO(1)/CONDUC(1) -0.5 * cooling_curvature(I) GEOTH5=GEOTH1+ + GEOTH2*ZMNODE(I)+ + GEOTH3*ZMNODE(I)**2+ + GEOTH4*ZMNODE(I)**3 DTDZC= GEOTH2+ + 2.*GEOTH3*ZMNODE(I)+ + 3.*GEOTH4*ZMNODE(I)**2 GEOTH6=DTDZC*CONDUC(1)/CONDUC(2) GEOTH7= -0.5*RADIO(2)/CONDUC(2) -0.5 * cooling_curvature(I) CALL SQUEEZ (INPUT,ALPHAT,density_anomaly(I),ELEV(I), + GEOTH1,GEOTH2,GEOTH3,GEOTH4, + GEOTH5,GEOTH6,GEOTH7,GEOTH8, + GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, + TEMLIM,ZMNODE(I),ZMNODE(I)+TLNODE(I), + OUTPUT,TAUZZN(I),ATNODE(I)) 100 CONTINUE CALL INTERP (INPUT,ATNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,SIGZZI) CALL INTERP (INPUT,TAUZZN,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,TAUZZI) C C Compute strength of shearing layer in asthenosphere: C CALL ONEBAR (INPUT,ACREEP,BCREEP,CCREEP, + ECREEP,GEOTHC,GEOTHM,GRADIE, + IUNITT,MXEL,NUMEL,ONEKM,TADIAB, + ZBASTH,ZMOHO, + OUTPUT,GLUE) C C However, asthenosphere strength is not considered when C ICONVE = 5; in this case, GLUE is not used; it is set C to very large values so that shear tractions will be C based on parameters ETAMAX or TRHMAX, instead of GLUE: C IF (ICONVE.EQ.5) THEN DO 180 M=1,7 DO 170 I=1,NUMEL GLUE(M,I)=HUGE 170 CONTINUE 180 CONTINUE END IF C C Determine which points have horizontal shear tractions: C DO 200 M=1,7 DO 190 I=1,NUMEL IF (ICONVE.LE.3) THEN PULLED(M,I)=(TRHMAX.GT.0.0) ELSE IF (ICONVE.EQ.4) THEN PULLED(M,I)=(TRHMAX.GT.0.0).AND.CONTIN(M,I) ELSE IF (ICONVE.EQ.5) THEN C FOREARC IS DEFINED WHERE BASE OF PLATE IS AT LESS C THAN 1000 C = 1273 K. BASET=GEOTHM(1,M,I)+ + GEOTHM(2,M,I)*TLINT(M,I)+ + GEOTHM(3,M,I)*TLINT(M,I)**2+ + GEOTHM(4,M,I)*TLINT(M,I)**3 PULLED(M,I)=(BASET.LT.1273.0) ELSE IF (ICONVE.EQ.6) THEN PULLED(M,I)=(TRHMAX.GT.0.0) C (However, even when PULLED = T for all C integration points, some will still have C zero traction because nodal shear-traction C vectors BASAL are zero for all nodes around C the element. This happens within plates that C have SLAB_Q = T, where inferred basal traction C is not needed or wanted.) END IF 190 CONTINUE 200 CONTINUE C RETURN END C C C SUBROUTINE FINDPV (INPUT, IPAFRI, IUNITT, NDPLAT, NPBND, NPLATE, + OMEGA, PLAT, PLON, RADIUS, + XINPL, XVEL, YINPL, YVEL, + OUTPUT, VPHI, VTHETA) C C Finds out in which plate (XINPL,YINPL) is located, C and calculates the velocity of the point from the C PB2002 model of Bird [2003; G**3]. C C Requires that NAMES and OMEGA be pre-filled with names and C rotation vectors. C C Requires that -GETPBX- has already been called to fill in the C arrays with digitized plate outlines. C C Returns VPHI (Southward velocity) and VTHETA (Eastward velocity) C in a reference frame where the AFrica plate is fixed. C C DIMENSION PLAT (NPLATE,NPBND), PLON (NPLATE,NPBND) DIMENSION NDPLAT (NPLATE), OMEGA (3,NPLATE) C XO=COS(YINPL)*SIN(XINPL) YO=SIN(YINPL)*SIN(XINPL) ZO=COS(XINPL) OXYZ=XO*XO+YO*YO+ZO*ZO OXYZ=SQRT(OXYZ) XO=XO/OXYZ YO=YO/OXYZ ZO=ZO/OXYZ NPOINT=0 ANGLE=0.0 IPLATE=0 DO 500 I=1,NPLATE TANGL=0.0 NEND=NDPLAT(I) DO 300 J=1,NEND J2=J+1 IF(J.EQ.NEND) THEN J2=1 ENDIF A1=COS(PLON(I,J))*COS(PLAT(I,J)) A2=SIN(PLON(I,J))*COS(PLAT(I,J)) A3=SIN(PLAT(I,J)) B1=COS(PLON(I,J2))*COS(PLAT(I,J2)) B2=SIN(PLON(I,J2))*COS(PLAT(I,J2)) B3=SIN(PLAT(I,J2)) AO=XO*A1+YO*A2+ZO*A3 BO=XO*B1+YO*B2+ZO*B3 A1=A1/AO A2=A2/AO A3=A3/AO B1=B1/BO B2=B2/BO B3=B3/BO A1=A1-XO A2=A2-YO A3=A3-ZO B1=B1-XO B2=B2-YO B3=B3-ZO AA=SQRT(A1*A1+A2*A2+A3*A3) BB=SQRT(B1*B1+B2*B2+B3*B3) AB1=A2*B3-A3*B2 AB2=A3*B1-A1*B3 AB3=A1*B2-A2*B1 STHETA=(AB1*XO+AB2*YO+AB3*ZO)/(AA*BB) C prevent stupid abends due to imprecision: STHETA=MAX(-1.,MIN(1.,STHETA)) TANGL=TANGL+ASIN(STHETA) 300 CONTINUE DANGLE=TANGL-3.1416 IF(DANGLE.GE.0.0001) THEN NPOINT=NPOINT+1 IPLATE=I ENDIF 500 CONTINUE IF(NPOINT.GE.3) THEN XPOINT=90.0-XINPL*57.29577951 YPOINT=YINPL*57.29577951 WRITE(IUNITT,505) XPOINT,YPOINT 505 FORMAT(' POINT ',2F10.3,' WAS FOUND IN MORE THAN TWO PLATES' + ,' SOMETHING IS WRONG') ENDIF IF(IPLATE.GT.0) THEN C Convert to AFrica-fixed, and radians/second: OMEGAX=(OMEGA(1,IPLATE)-OMEGA(1,IPAFRI))*3.168809E-14 OMEGAY=(OMEGA(2,IPLATE)-OMEGA(2,IPAFRI))*3.168809E-14 OMEGAZ=(OMEGA(3,IPLATE)-OMEGA(3,IPAFRI))*3.168809E-14 C Convert to length/second: OMEGAX=OMEGAX*RADIUS OMEGAY=OMEGAY*RADIUS OMEGAZ=OMEGAZ*RADIUS C Velocity = OMEGA x position: THETA=XVEL PHI=YVEL XN=SIN(THETA)*COS(PHI) YN=SIN(THETA)*SIN(PHI) ZN=COS(THETA) VX=OMEGAY*ZN-OMEGAZ*YN VY=OMEGAZ*XN-OMEGAX*ZN VZ=OMEGAX*YN-OMEGAY*XN C Create unit +Theta and +Phi vectors in Cartesian: THETAX=COS(THETA)*COS(PHI) THETAY=COS(THETA)*SIN(PHI) THETAZ= -SIN(THETA) PHIX= -SIN(PHI) PHIY=COS(PHI) PHIZ=0. C Find argument from dot products: VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ ELSE XPOINT=90.0-XINPL*57.29577951 YPOINT=YINPL*57.29577951 WRITE(IUNITT,600) XPOINT,YPOINT WRITE(*,600) XPOINT,YPOINT 600 FORMAT(' THE POINT ', 2F13.5,' DOES NOT BELONG ANY PLATE !!!' + /' Therefore plate velocity is undefined.') CALL PAUSE() STOP ENDIF RETURN END C C C SUBROUTINE FIXED (INPUT,ALPHAT,AREA,CONDUC, + density_anomaly,DETJ, + DOFB1,DOFB2,DOFB3,DOFB4, + DQDTDA,DXS,DYS, + DXSP,DYSP,EDGETS,ELEV,FDIP,FLEN, + FPFLT,FPSFER,FARG,GMEAN, + ICOND,IUNITT, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + NCOND,NFL,NODCON,NODEF,NODES,NUMEL, + ONEKM,RADIO,RADIUS,RHOAST, + RHOBAR,RHOH2O,SIGZZI, SITA, + TAUZZI,TAUZZN,TEMLIM,TLNODE,TSURF,WEDGE, + XNODE,YNODE,ZMNODE, + OUTPUT,FBASE) C C Precompute the fixed part of the forcing vector of the linear C systems of equations. C LOGICAL switches DOFB1, ..., DOFB4 allow individual terms to C be computed (for example, in subprogram -BALANC-). C C Number of steps to use in vertical integrations: PARAMETER (NSTEP=100) C LOGICAL ATSEA,DOFB1,DOFB2,DOFB3,DOFB4,EDGETS,RIDGE DOUBLE PRECISION FBASE DOUBLE PRECISION POINTS,WEIGHT DOUBLE PRECISION FPHI,FPOINT,FP1,FP2,FGAUSS REAL LENGTH COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS COMMON /S1S2S3/ POINTS COMMON /WGTVEC/ WEIGHT DIMENSION FPHI(4,7),FPOINT(7),FGAUSS(7),FPP(2,2,2,7) DIMENSION ALPHAT(2), CONDUC(2), + RADIO(2), RHOBAR(2), TEMLIM(2) DIMENSION PHI(2),POINTS(3,7),THETA(2),WEIGHT(7) DIMENSION DTORQ(3),FORCE(3),TVEC(3), + UPHI(3),UTHETA(3),UVEC(3) DIMENSION AREA(MXEL),density_anomaly(MXNODE), + DETJ(7,MXEL),DQDTDA(MXNODE), + DXS(2,2,3,7,MXEL),DYS(2,2,3,7,MXEL), + DXSP(3,7,MXEL),DYSP(3,7,MXEL),EDGETS(3,MXEL), + ELEV(MXNODE),FANGLE(2),FBASE(MXDOF),FDIP(2,MXFEL), + FLEN(MXFEL),FPFLT(2,2,2,7,MXFEL), + FPSFER(2,2,3,7,MXEL),FARG(2,MXFEL), + ICOND(MXBN),NODCON(MXBN), + NODEF(4,MXFEL),NODES(3,MXEL), + SIGZZI(7,MXEL), SITA(7,MXEL), + TAUZZI(7,MXEL),TAUZZN(MXNODE),TLNODE(MXNODE), + XNODE(MXNODE),YNODE(MXNODE),ZMNODE(MXNODE) C C Statement function: PHIVAL (S1,S2,S3, F1,F2,F3) = S1*F1 + S2*F2 + S3*F3 C C C Initialize accumulator (to be incremented by loops below): DO 10 I=1,MXDOF FBASE(I)=0.0D0 10 CONTINUE C C Effects of: C IF (DOFB1): vertically-integrated topographic stress (TAUZZ), and C IF (DOFB2): horizontal components of basal traction anomalies C on areas of the triangular continuum elements: C DO 100 M=1,7 DO 90 I=1,NUMEL DAREA=AREA(I)*DETJ(M,I)*WEIGHT(M)/RADIUS SLOPEX=0. SLOPEY=0. SINA=SIN(SITA(M,I)) DO 20 J=1,3 ND=NODES(J,I) ZA=ZMNODE(ND)+TLNODE(ND)-ELEV(ND) SLOPEX=SLOPEX+ZA*DXSP(J,M,I) SLOPEY=SLOPEY+ZA*DYSP(J,M,I) C Note: These are not dimensionless; divide by RADIUS C to get dimensionless slopes. 20 CONTINUE DO 80 J=1,3 NODE=NODES(J,I) KROWX=2*NODE-1 KROWY=KROWX+1 FT1=-TAUZZI(M,I)*(DXS(1,1,J,M,I)+ + DYS(1,2,J,M,I)/SIN(SITA(M,I))+ + FPSFER(1,1,J,M,I)/TAN(SITA(M,I))) FT2=-TAUZZI(M,I)*(DXS(2,1,J,M,I)+ + DYS(2,2,J,M,I)/SIN(SITA(M,I))+ + FPSFER(2,1,J,M,I)/TAN(SITA(M,I))) FP1=-SIGZZI(M,I)*( FPSFER(1,1,J,M,I)*SLOPEX + +FPSFER(1,2,J,M,I)*SLOPEY) FP2=-SIGZZI(M,I)*( FPSFER(2,1,J,M,I)*SLOPEX + +FPSFER(2,2,J,M,I)*SLOPEY) IF (DOFB1) THEN FBASE(KROWX)=FBASE(KROWX)+DAREA*FT1 FBASE(KROWY)=FBASE(KROWY)+DAREA*FT2 ENDIF IF (DOFB2) THEN FBASE(KROWX)=FBASE(KROWX)+DAREA*FP1 FBASE(KROWY)=FBASE(KROWY)+DAREA*FP2 ENDIF 80 CONTINUE 90 CONTINUE 100 CONTINUE C IF (DOFB3) THEN C C Effect of anomalous normal traction on exterior C side boundaries of triangular continuum elements: C since the standard for normal traction anomalies is the C pressure under a spreading ridge, boundaries with a ridge C (ICOND = -1) boundary condition have none. C However, boundaries with a "free" (ICOND = 0) boundary C condition have normal traction equal to vertical, C as if the adjacent material had the same crustal thickness C and geotherm, but no strength. C (Note: These forces will often be overwritten by velocity C boundary conditions, but are provided just is case this is not so.) C DO 200 I=1,NUMEL DO 190 J=1,3 IF (EDGETS(J,I)) THEN N1=NODES(MOD(J, 3)+1,I) N2=NODES(MOD(J+1,3)+1,I) RIDGE=.FALSE. DO 110 N=1,NCOND IF (NODCON(N).EQ.N1) RIDGE=RIDGE.OR. + (ICOND(N).EQ.-1) IF (NODCON(N).EQ.N2) RIDGE=RIDGE.OR. + (ICOND(N).EQ.-1) 110 CONTINUE IF (.NOT.RIDGE) THEN THETA(1)=XNODE(N1) THETA(2)=XNODE(N2) PHI(1) =YNODE(N1) PHI(2) =YNODE(N2) ELONG=FLTLEN (PHI(1),PHI(2),RADIUS, + THETA(1),THETA(2)) CALL SNODAL (INPUT,PHI,THETA, + OUTPUT,FPP) CALL FANGLS (INPUT,PHI,THETA, + OUTPUT,FANGLE) DO 180 M=1,7 S=FPOINT(M) TZZ=TAUZZN(N1)*FPHI(1,M)+TAUZZN(N2)*FPHI(2,M) DS=FGAUSS(M)*ELONG COSS=COS(FANGLE(1))*FPHI(1,M) + +COS(FANGLE(2))*FPHI(2,M) SINN=SIN(FANGLE(1))*FPHI(1,M) + +SIN(FANGLE(2))*FPHI(2,M) ANGLE=ATAN2F(SINN,COSS) XOUT=COS(ANGLE-1.570796) YOUT=SIN(ANGLE-1.570796) KROWX=2*N1-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+ + DS*(FPP(1,1,1,M)*XOUT+ + FPP(1,2,1,M)*YOUT)*TZZ FBASE(KROWY)=FBASE(KROWY)+ + DS*(FPP(2,1,1,M)*XOUT+ + FPP(2,2,1,M)*YOUT)*TZZ KROWX=2*N2-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+ + DS*(FPP(1,1,2,M)*XOUT+ + FPP(1,2,2,M)*YOUT)*TZZ FBASE(KROWY)=FBASE(KROWY)+ + DS*(FPP(2,1,2,M)*XOUT+ + FPP(2,2,2,M)*YOUT)*TZZ 180 CONTINUE END IF END IF 190 CONTINUE 200 CONTINUE END IF C C Effect of vertical-stress (SIGZZ) component of normal traction on C fault planes is obtained by integrating down dip of each C fault at each of the seven integration points along its length: C DO 300 I=1,NFL N1=NODEF(1,I) N2=NODEF(2,I) N3=NODEF(3,I) N4=NODEF(4,I) X1=XNODE(N1) X2=XNODE(N2) Y1=YNODE(N1) Y2=YNODE(N2) C C Find neighboring triangular elements, if any: C KELE12=0 DO 210 J=1,NUMEL IF (((NODES(1,J).EQ.N2).AND. + (NODES(2,J).EQ.N1) ) .OR. + ((NODES(3,J).EQ.N2).AND. + (NODES(1,J).EQ.N1) ) .OR. + ((NODES(2,J).EQ.N2).AND. + (NODES(3,J).EQ.N1) ) ) THEN KELE12=J GO TO 211 ENDIF 210 CONTINUE 211 KELE34=0 DO 220 J=1,NUMEL IF (((NODES(1,J).EQ.N3).AND. + (NODES(3,J).EQ.N4) ) .OR. + ((NODES(3,J).EQ.N3).AND. + (NODES(2,J).EQ.N4) ) .OR. + ((NODES(2,J).EQ.N3).AND. + (NODES(1,J).EQ.N4) ) ) THEN KELE34=J GO TO 221 ENDIF 220 CONTINUE 221 DO 290 M=1,7 S=FPOINT(M) X0=X1*FPHI(1,M)+X2*FPHI(2,M) Y0=Y1*FPHI(1,M)+Y2*FPHI(2,M) C CCCCC ANGLE=FARG(1,I)*FPHI(1,M)+FARG(2,I)*FPHI(2,M) CCCCC Line above was replaced due to cycle-shift problem! C ANGLE=CHORD(FARG(1,I),FPHI(2,M),FARG(2,I)) C XOUT=COS(ANGLE-1.570796) YOUT=SIN(ANGLE-1.570796) DIP=FDIP(1,I)*FPHI(1,M)+FDIP(2,I)*FPHI(2,M) IF (ABS(DIP-1.570796).LT.WEDGE) THEN C Case of vertical dip (within WEDGE radians): TZZ=TAUZZN(N1)*FPHI(1,M)+TAUZZN(N2)*FPHI(2,M) ELSE C Case of shallow dip: IF (DIP.GT.1.570796) THEN C dip is toward N3,N4 side: KELE=KELE34 ELSE C dip is toward N1,N2 side: KELE=KELE12 ENDIF IF (KELE.EQ.0) THEN C no neighboring element (at grid edge): TZZ=TAUZZN(N1)*FPHI(1,M)+ + TAUZZN(N2)*FPHI(2,M) ELSE C Integrate on a slant below neighbor elements. C (1) Find intersection of fault with C asthenosphere (plate base): ZTA1=ZMNODE(N1)+TLNODE(N1) ZTA2=ZMNODE(N2)+TLNODE(N2) ZTA=ZTA1*FPHI(1,M)+ZTA2*FPHI(2,M) TOSIDE=ZTA/TAN(DIP) C Note: TOSIDE is <0 for DIP > Pi/2. SIDEAZ=ANGLE-1.570796 XTA=X0+TOSIDE*COS(SIDEAZ)/RADIUS YTA=Y0+TOSIDE*SIN(SIDEAZ)/(RADIUS*SIN(X0)) C (2) Subdivide slant path into steps DX=(XTA-X0)/NSTEP DY=(YTA-Y0)/NSTEP DZ=ZTA/NSTEP C (3) Actual integration on slant path: S1=0.3333 S2=0.3333 S3=0.3334 TZZ=0. DO 250 K=1,NSTEP SMID=K-0.5 X=X0+SMID*DX Y=Y0+SMID*DY Z=SMID*DZ CALL LOOKUP (INPUT,IUNITT,MXEL,MXFEL, + MXNODE,NFL,NODEF, + NODES,NUMEL, + X,XNODE,Y,YNODE, + MODIFY,KELE,S1,S2,S3, + OUTPUT,ATSEA) IF (ATSEA) THEN TZZ=TAUZZN(N1)*FPHI(1,M)+ + TAUZZN(N2)*FPHI(2,M) GO TO 251 ELSE ELEVAT=PHIVAL(S1,S2,S3, + ELEV(NODES(1,KELE)), + ELEV(NODES(2,KELE)), + ELEV(NODES(3,KELE))) delta_rho=PHIVAL(S1,S2,S3, + density_anomaly(NODES(1,KELE)), + density_anomaly(NODES(2,KELE)), + density_anomaly(NODES(3,KELE))) Q=PHIVAL(S1,S2,S3, + DQDTDA(NODES(1,KELE)), + DQDTDA(NODES(2,KELE)), + DQDTDA(NODES(3,KELE))) ZM=PHIVAL(S1,S2,S3, + ZMNODE(NODES(1,KELE)), + ZMNODE(NODES(2,KELE)), + ZMNODE(NODES(3,KELE))) TL=PHIVAL(S1,S2,S3, + TLNODE(NODES(1,KELE)), + TLNODE(NODES(2,KELE)), + TLNODE(NODES(3,KELE))) C (4) Terminate integral if it C emerges into asthenosphere C anywhere along slant path: IF (Z.GT.(ZM+TL)) GO TO 251 GEOTH1=TSURF GEOTH2=Q/CONDUC(1) GEOTH3= -0.5*RADIO(1)/CONDUC(1) GEOTH4=0. GEOTH5=GEOTH1+GEOTH2*ZM+ + GEOTH3*ZM**2 GEOTH6=(Q-ZM*RADIO(1))/CONDUC(2) GEOTH7= -0.5*RADIO(2)/CONDUC(2) GEOTH8=0. CALL SQUEEZ (INPUT,ALPHAT, + delta_rho, + ELEVAT, + GEOTH1,GEOTH2, + GEOTH3,GEOTH4, + GEOTH5,GEOTH6, + GEOTH7,GEOTH8, + GMEAN,IUNITT, + ONEKM,RHOAST, + RHOBAR,RHOH2O, + TEMLIM,ZM,Z, + OUTPUT,TAUZZ,SIGZZB) TZZ=TZZ+SIGZZB*DZ ENDIF 250 CONTINUE 251 CONTINUE ENDIF ENDIF DS=FGAUSS(M)*FLEN(I)*TZZ IF (DOFB4) THEN KROWX=2*N1-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)- + DS*(FPFLT(1,1,1,M,I)*XOUT+ + FPFLT(1,2,1,M,I)*YOUT) FBASE(KROWY)=FBASE(KROWY)- + DS*(FPFLT(2,1,1,M,I)*XOUT+ + FPFLT(2,2,1,M,I)*YOUT) KROWX=2*N2-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)- + DS*(FPFLT(1,1,2,M,I)*XOUT+ + FPFLT(1,2,2,M,I)*YOUT) FBASE(KROWY)=FBASE(KROWY)- + DS*(FPFLT(2,1,2,M,I)*XOUT+ + FPFLT(2,2,2,M,I)*YOUT) KROWX=2*N3-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+ + DS*(FPFLT(1,1,2,M,I)*XOUT+ + FPFLT(1,2,2,M,I)*YOUT) FBASE(KROWY)=FBASE(KROWY)+ + DS*(FPFLT(2,1,2,M,I)*XOUT+ + FPFLT(2,2,2,M,I)*YOUT) KROWX=2*N4-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+ + DS*(FPFLT(1,1,1,M,I)*XOUT+ + FPFLT(1,2,1,M,I)*YOUT) FBASE(KROWY)=FBASE(KROWY)+ + DS*(FPFLT(2,1,1,M,I)*XOUT+ + FPFLT(2,2,1,M,I)*YOUT) END IF C C Add torques due to lithostatic pressure anom. in fault. C Make use of integration pnt position (X0=theta,Y0=phi), C and DS (incorporating TZZ * fault length step), C and horizontal (d_theta,d_phi) unit vector C (XOUT,YOUT) in the fault-normal direction, on the N1-N2 C side,computed above. C C Position of integration point: TVEC(1)=SIN(X0)*COS(Y0) TVEC(2)=SIN(X0)*SIN(Y0) TVEC(3)=COS(X0) C Unit vectors at this site (NOT a pole): EQUAT=SQRT(TVEC(1)**2+TVEC(2)**2) UPHI(1)= -TVEC(2) UPHI(2)=TVEC(1) UPHI(1)=UPHI(1)/EQUAT UPHI(2)=UPHI(2)/EQUAT UPHI(3)=0.0 TEQUAT=TVEC(3) UTHETA(3)= -EQUAT UTHETA(1)=TEQUAT*TVEC(1)/EQUAT UTHETA(2)=TEQUAT*TVEC(2)/EQUAT LENGTH=SQRT(UTHETA(1)**2+UTHETA(2)**2+ + UTHETA(3)**2) UTHETA(1)=UTHETA(1)/LENGTH UTHETA(2)=UTHETA(2)/LENGTH UTHETA(3)=UTHETA(3)/LENGTH DO 261 L=1,3 TVEC(L)=TVEC(L)*RADIUS 261 CONTINUE C Horizontal force due to LP in fault is 2-sided; C first, the nodef12 side: FORCE(1)=DS*(XOUT*UTHETA(1)+YOUT*UPHI(1)) FORCE(2)=DS*(XOUT*UTHETA(2)+YOUT*UPHI(2)) FORCE(3)=DS*(XOUT*UTHETA(3)+YOUT*UPHI(3)) C second, the nodef34 side: FORCE(1)= -DS*(XOUT*UTHETA(1)+YOUT*UPHI(1)) FORCE(2)= -DS*(XOUT*UTHETA(2)+YOUT*UPHI(2)) FORCE(3)= -DS*(XOUT*UTHETA(3)+YOUT*UPHI(3)) C 290 CONTINUE C ending loop on integration points M=1,7 300 CONTINUE C ending loop on fault elements I=1,NFL RETURN END C C C SUBROUTINE FLOW (INPUT,FPSFER,MXEL,MXNODE,NODES,NUMEL,V, + OUTPUT,OUTVEC) C C Calculates velocity vectors at integration points, from nodal values C DOUBLE PRECISION POINTS,V DIMENSION FPSFER(2,2,3,7,MXEL),NODES(3,MXEL),OUTVEC(2,7,MXEL), + POINTS(3,7),V(2,MXNODE) DO 50 M=1,7 DO 40 I=1,NUMEL OUTVEC(1,M,I)=0. OUTVEC(2,M,I)=0. 40 CONTINUE 50 CONTINUE DO 100 J=1,3 DO 90 M=1,7 DO 80 I=1,NUMEL NJI=NODES(J,I) OUTVEC(1,M,I)=OUTVEC(1,M,I) + +V(1,NJI)*FPSFER(1,1,J,M,I) + +V(2,NJI)*FPSFER(2,1,J,M,I) OUTVEC(2,M,I)=OUTVEC(2,M,I) + +V(1,NJI)*FPSFER(1,2,J,M,I) + +V(2,NJI)*FPSFER(2,2,J,M,I) 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END C C C REAL FUNCTION FLTLEN (PHI1,PHI2,RADIUS,THETA1,THETA2) C C Calculates length of great circle segment between C point (THETA1,PHI1) and point (THETA2,PHI2), C in physical length units (radians*RADIUS). C Note that Theta is colatitude (from North pole), C and Phi is East longitude; both in radians. C DOUBLE PRECISION AB AB =SIN(THETA1)*SIN(THETA2)*COS(PHI1)*COS(PHI2)+ + SIN(THETA1)*SIN(THETA2)*SIN(PHI1)*SIN(PHI2)+ + COS(THETA1)*COS(THETA2) AB=ACOS(AB) FLTLEN=AB*RADIUS RETURN END C C C SUBROUTINE FNODAL (INPUT,IUNITT,MXFEL,MXNODE,NFL,NODEF, + XNODE,YNODE, + OUTPUT,FPFLT) C C Calculates vector nodal functions at all integration points C on all arc-of-great-circle fault elements. C DOUBLE PRECISION FPHI DIMENSION FPHI(4,7),FPFLT(2,2,2,7,MXFEL),FPP(2,2,2,7), + NODEF(4,MXFEL),PHI(2),THETA(2), + XNODE(MXNODE),YNODE(MXNODE) COMMON /FPHIS/ FPHI C DO 900 I=1,NFL N1=NODEF(1,I) N2=NODEF(2,I) THETA(1)=XNODE(N1) THETA(2)=XNODE(N2) PHI(1)=YNODE(N1) PHI(2)=YNODE(N2) CALL SNODAL (INPUT,PHI,THETA, + OUTPUT,FPP) DO 800 M=1,7 DO 500 J=1,2 DO 400 K=1,2 DO 300 L=1,2 FPFLT(L,K,J,M,I)=FPP(L,K,J,M) 300 CONTINUE 400 CONTINUE 500 CONTINUE C C Note: C SNCCOP: SIN(SITA)*COS(PHAI) at integration point C SNCSNP: SIN(SITA)*SIN(PHAI) at integration point SNCCOP=FPHI(1,M)*SIN(THETA(1))*COS(PHI(1))+ + FPHI(2,M)*SIN(THETA(2))*COS(PHI(2)) SNCSNP=FPHI(1,M)*SIN(THETA(1))*SIN(PHI(1))+ + FPHI(2,M)*SIN(THETA(2))*SIN(PHI(2)) COSM =FPHI(1,M)*COS(THETA(1))+FPHI(2,M)*COS(THETA(2)) PP=SQRT(SNCCOP*SNCCOP+SNCSNP*SNCSNP+COSM*COSM) COSM=COSM/PP SITA=ACOS(COSM) IF(SITA.LE.0.0.OR.SITA.GE.3.141592654) THEN SITA=SITA*57.29577951 WRITE(IUNITT,220) M,I,SITA 220 FORMAT('LATITUDE OF INTEGRATION POINT',I5, + ' OF FAULT ELEMENT', + I5,' IS OUT RANGE', + E14.4) ENDIF 800 CONTINUE 900 CONTINUE RETURN END C C C SUBROUTINE GETNET (INPUT,IUNIT7,IUNIT8, + MXDOF,MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF, cooling_curvature, + density_anomaly, + DQDTDA,ELEV,FDIP, + NFAKEN,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,OFFMAX,OFFSET, + TITLE1,TLNODE,XNODE,YNODE,ZMNODE, + WORK,CHECKE,CHECKF,CHECKN) C C Read finite element grid from unit IUNIT7. C Echo the important values to a print dataset on unit IUNIT8. C CHARACTER*80 TITLE1 LOGICAL ALLOK,BRIEF C C Note: Following type could be LOGICAL*1 in IBM VS-Fortran: LOGICAL CHECKE,CHECKF,CHECKN C DIMENSION CHECKE(MXEL),CHECKF(MXFEL),CHECKN(MXNODE), + cooling_curvature(MXNODE), + density_anomaly(MXNODE), + DQDTDA(MXNODE),ELEV(MXNODE), + FDIP(2,MXFEL), NODEF(4,MXFEL), + NODES(3,MXEL),OFFSET(MXFEL), TLNODE(MXNODE), + XNODE(MXNODE),YNODE(MXNODE),ZMNODE(MXNODE) DIMENSION DIPS(3),VECTOR(9) C TITLE1=' '// + ' ' READ (IUNIT7,2) TITLE1 2 FORMAT (A80) WRITE (IUNIT8,3) TITLE1 3 FORMAT(/' Title of finite-element grid ='/' ',A80) C C READ NUMBER OF NODES, plus out-dated parameters that once C permitted boundary nodes to be specially numbered as C "fake" nodes with numbers from N1000+1 ... N1000+NFAKEN. C This option is no longer supported by my programs! C (OPTION "BRIEF" SUPPRESSES MOST OUTPUT) C READ (IUNIT7,*) NUMNOD,NREALN,NFAKEN,N1000,BRIEF BRIEF=.TRUE. C IF (NUMNOD.NE.(NREALN+NFAKEN)) THEN WRITE (IUNIT8,4) NUMNOD,NREALN,NFAKEN 4 FORMAT (/' ERR0R: NUMNOD (',I6,') IS NOT EQUAL TO SUM' + /' OF NREALN (',I6,') AND NFAKEN (',I6,').') CALL PAUSE() STOP ENDIF C IF (NREALN.GT.N1000) THEN WRITE (IUNIT8,5) NREALN,N1000 5 FORMAT (/' ERR0R: NREALN (',I6,') IS GREATER THAN' + /' N1000 (',I6,').') CALL PAUSE() STOP ENDIF C IF (NUMNOD.GT.MXNODE) THEN WRITE (IUNIT8,10) NUMNOD 10 FORMAT(/' INCREASE PARAMETER MAXNOD TO BE AT LEAST' + /' THE NUMBER OF NODES (',I6,') AND RECOMPILE.') CALL PAUSE() STOP ENDIF C NRT2=NREALN*2 IF (NRT2.GT.MXDOF) THEN WRITE (IUNIT8,12) NRT2 12 FORMAT (/' INCREASE PARAMETER MAXDOF TO ',I6, + ' AND RECOMPILE.') CALL PAUSE() STOP ENDIF C IF (BRIEF) THEN WRITE (IUNIT8,35) 35 FORMAT(/' (Since option BRIEF=.TRUE., grid will not be ', + 'echoed here.)') ELSE WRITE (IUNIT8,40) NUMNOD 40 FORMAT (/' There are',I5,' nodes in the grid') WRITE (IUNIT8,50) 50 FORMAT (/ + 77X,' mantle'/ + 77X,' crustal lithosphere'/ + ' node E-longitude N-latitude', + ' theta phi elevation', + ' heat-flow thickness thickness'/) ENDIF DO 90 K=1,NUMNOD CHECKN(K)=.FALSE. 90 CONTINUE DO 100 K=1,NUMNOD CALL READN (INPUT,IUNIT7,IUNIT8,9, + OUTPUT,VECTOR) INDEX=VECTOR(1)+0.5 IF (INDEX.GT.NREALN) THEN IF ((INDEX.LE.N1000).OR. + (INDEX.GT.(N1000+NFAKEN))) THEN WRITE (IUNIT8,91) INDEX 91 FORMAT (/' ERR0R: ILLEGAL NODE NUMBER: ',I6) CALL PAUSE() STOP ENDIF ENDIF PLON=VECTOR(2) PLAT=VECTOR(3) IF (ABS(PLAT).GT.90.01) THEN WRITE (IUNIT8,92) INDEX 92 FORMAT (/' ERR0R: ABS(LATITUDE) > 90 AT NODE ',I6) CALL PAUSE() STOP ENDIF IF (ABS(PLAT).GT.89.99) THEN WRITE (IUNIT8,93) INDEX 93 FORMAT (/' ERR0R: NODE ',I6,' LIES ON A POLE.' + /' THIS IS A SINGULAR POINT OF THE' + ,' SPHERICAL COORDINATE SYSTEM.' + /' MOVE THIS NODE, AT LEAST SLIGHTLY.') CALL PAUSE() STOP ENDIF XI=(90.0-PLAT)*0.017453292 YI=PLON*0.017453292 ELEVI=VECTOR(4) QI=VECTOR(5) ZMI=VECTOR(6) TLI=VECTOR(7) density_anomaly_kgpm3 = VECTOR(8) cooling_curvature_Cpm2 = VECTOR(9) IF (INDEX.LE.NREALN) THEN I=INDEX ELSE I=NREALN+INDEX-N1000 ENDIF CHECKN(I)=.TRUE. XNODE(I)=XI YNODE(I)=YI ELEV(I)=ELEVI DQDTDA(I)=QI IF (QI.LT.0.) THEN WRITE (IUNIT8,96) 96 FORMAT (' NEGATIVE HEAT-FLOW IS NON-PHYSICAL.') CALL PAUSE() STOP ENDIF IF (ZMI.LT.0.) THEN WRITE (IUNIT8,97) 97 FORMAT(' NEGATIVE CRUSTAL THICKNESS IS NON-PHYSICAL.') CALL PAUSE() STOP ENDIF ZMNODE(I)=ZMI IF (TLI.LT.0.) THEN WRITE (IUNIT8,98) 98 FORMAT(' NEGATIVE MANTLE LITHOSPHERE THICKNESS IS', + ' NON-PHYSICAL.') CALL PAUSE() STOP ENDIF TLNODE(I)=TLI IF (.NOT.BRIEF) THEN WRITE (IUNIT8,99) INDEX,PLON,PLAT,XI,YI,ELEVI, + QI,ZMI,TLI 99 FORMAT (' ',I10,0P,2F12.3,2F11.5,1P,3E10.2,E12.2) ENDIF density_anomaly(I) = density_anomaly_kgpm3 cooling_curvature(I) = cooling_curvature_Cpm2 100 CONTINUE ALLOK=.TRUE. DO 101 I=1,NUMNOD ALLOK=ALLOK.AND.CHECKN(I) 101 CONTINUE IF (.NOT.ALLOK) THEN WRITE (IUNIT8,102) 102 FORMAT(' THE FOLLOWING NODES WERE NEVER READ:') DO 104 I=1,NUMNOD IF (I.LE.NREALN) THEN INDEX=I ELSE INDEX=N1000+I-NREALN ENDIF IF (.NOT.CHECKN(I)) WRITE(IUNIT8,103)INDEX 103 FORMAT (' ',36X,I6) 104 CONTINUE CALL PAUSE() STOP ENDIF C C Read triangular elements: C READ (IUNIT7,*) NUMEL IF (NUMEL.GT.MXEL) THEN WRITE (IUNIT8,108) NUMEL 108 FORMAT(/' INCREASE PARAMETER MAXEL TO BE AT LEAST EQUAL' + /' TO THE NUMBER OF ELEMENTS (',I6,') AND RECOMPILE.') CALL PAUSE() STOP ENDIF DO 109 K=1,NUMEL CHECKE(K)=.FALSE. 109 CONTINUE IF (.NOT.BRIEF) WRITE (IUNIT8,110) NUMEL 110 FORMAT(/' There are ',I6,' triangular continuum elements.'/ + ' (Node numbers for each are given at corners, counter', + 'clockwise'/ / + ' element C1 C2 C3') DO 200 K=1,NUMEL C (Elements need not be input in order, but must all be present.) READ (IUNIT7,*) I,(NODES(J,I),J=1,3) IF ((I.LT.1).OR.(I.GT.NUMEL)) THEN WRITE (IUNIT8,111) I 111 FORMAT (/' ERR0R: ILLEGAL ELEMENT NUMBER: ',I6) CALL PAUSE() STOP ENDIF CHECKE(I)=.TRUE. IF (.NOT.BRIEF) WRITE (IUNIT8,120) I,(NODES(J,I),J=1,3) 120 FORMAT (' ',I6,':',3I10) DO 130 J=1,3 N=NODES(J,I) IF (N.GT.NREALN) N=NREALN+(N-N1000) IF ((N.LE.0).OR.(N.GT.NUMNOD)) THEN WRITE (IUNIT8,125) NODES(J,I) 125 FORMAT (' NODE NUMBER ',I6,' IS ILLEGAL.') CALL PAUSE() STOP ENDIF NODES(J,I)=N 130 CONTINUE 200 CONTINUE ALLOK=.TRUE. DO 201 I=1,NUMEL ALLOK=ALLOK.AND.CHECKE(I) 201 CONTINUE IF (.NOT.ALLOK) THEN WRITE (IUNIT8,202) 202 FORMAT (' THE FOLLOWING ELEMENTS WERE NEVER READ:') DO 204 I=1,NUMEL IF (.NOT.CHECKE(I)) WRITE(IUNIT8,203)I 203 FORMAT (' ',39X,I6) 204 CONTINUE CALL PAUSE() STOP ENDIF C C Read fault elements: C READ (IUNIT7,*) NFL IF (NFL.GT.MXFEL) THEN WRITE (IUNIT8,220)NFL 220 FORMAT (/' INCREASE PARAMETER MAXFEL TO BE AT LEAST EQUAL' + /' TO THE NUMBER OF FAULTS (',I6,') AND RECOMPILE.') CALL PAUSE() STOP ENDIF OFFMAX=0. DO 222 I=1,NFL CHECKF(I)=.FALSE. 222 CONTINUE IF (.NOT.BRIEF) WRITE(IUNIT8,230) NFL 230 FORMAT(/ /' There are ',I6,' great-circle fault elements.') IF ((.NOT.BRIEF).AND.(NFL.GT.0)) WRITE(IUNIT8,231) 231 FORMAT (/' (The 4 node numbers defining each element must be', + ' in a counterclockwise order:'/ + ' N1, and N2 are in left-to-right seguence on the', + ' near side,'/ + ' then N3 is opposite N2, and N4 is opposite N1.'/, + ' (Fault dips are given at N1, N2,', + ' in degrees from horizontal;'/ + ' positive dips are toward N1 and N2, respectively, '/ + ' while negative dips are toward N4 and N3.)'/ + ' Offset is the total past slip of the fault.'/ / + ' Element N1 N2 N3 N4 Dip1 Dip2', + ' Offset'/) 240 FORMAT (' ',I6,':',4I5,1X,2F6.1,1X,F9.0) DO 300 K=1,NFL OFF=0. READ(IUNIT7,*) I,(NODEF(J,K),J=1,4),(DIPS(L),L=1,2),OFF IF ((I.LT.1).OR.(I.GT.NFL)) THEN WRITE (IUNIT8,241) I 241 FORMAT (/' ERR0R: ILLEGAL FAULT NUMBER: ',I6) CALL PAUSE() STOP ENDIF CHECKF(I)=.TRUE. IF (.NOT.BRIEF) WRITE (IUNIT8,240) I,(NODEF(J,I),J=1,4), + (DIPS(L),L=1,2),OFF DO 250 J=1,4 N=NODEF(J,I) IF (N.GT.NREALN) N=NREALN+(N-N1000) IF ((N.LE.0).OR.(N.GT.NUMNOD)) THEN WRITE (IUNIT8,243) NODEF(J,I),I 243 FORMAT (/' ERR0R: ILLEGAL NODE NUMBER (',I6, + ') IN FAULT ',I6) CALL PAUSE() STOP ENDIF NODEF(J,I)=N 250 CONTINUE DO 260 L=1,2 IF (ABS(DIPS(L)).GT.90.) THEN WRITE(IUNIT8,252) DIPS(L) 252 FORMAT(' ILLEGAL DIP OF ',F10.4,'; SHOULD BE IN', + ' RANGE OF -90. TO +90. DEGREES.'/ + ' (NOTE: ALL DIPS ARE IN DEGREES FROM THE', + ' HORIZONAL;'/ + ' A + PREFIX (OR NONE) INDICATES A DIP', + ' TOWARD THE N1-N2 SIDE;'/ + ' A - PREFIX INDICATES A DIP TOWARD', + ' THE N4-N3 SIDE.)') CALL PAUSE() STOP ENDIF IF (DIPS(L).LT.0.) DIPS(L)=180.+DIPS(L) FDIP(L,I)=DIPS(L)*0.017453293 260 CONTINUE IF (OFF.LT.0.) THEN WRITE (IUNIT8,280) OFF 280 FORMAT (' ILLEGAL FAULT OFFSET OF ',1P,E10.2, + ' FOR FAULT ELEMENT',I6/ + ' OFFSETS MAY NOT BE NEGATIVE.') CALL PAUSE() STOP ENDIF OFFSET(I)=OFF OFFMAX=MAX(OFFMAX,OFF) 300 CONTINUE ALLOK=.TRUE. DO 301 I=1,NFL ALLOK=ALLOK.AND.CHECKF(I) 301 CONTINUE IF (.NOT.ALLOK) THEN WRITE(IUNIT8,302) 302 FORMAT(' THE FOLLOWING FAULTS WERE NEVER READ:') DO 304 I=1,NFL IF (.NOT.CHECKF(I)) WRITE(IUNIT8,303)I 303 FORMAT(' ',36X,I6) 304 CONTINUE CALL PAUSE() STOP ELSE IF (OFFMAX.GT.0.) THEN WRITE (IUNIT8,400) OFFMAX 400 FORMAT (/' Greatest fault offset read was ',1P,E10.2) ELSE WRITE (IUNIT8,401) 401 FORMAT (/' Since fault offsets are all zero,', + ' input parameter BYERLY will have no effect.') ENDIF ENDIF IF (.NOT. BRIEF) WRITE (IUNIT8,999) 999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE GETPBX (INPUT,IUNITM,IUNITT,NAMES,NPBND,NPLATE, + OUTPUT,NDPLAT,PLAT,PLON) C C Sets up arrays defining the plates in the PB2002 model of: C Bird [2003; G**3]. C C (The rotation vectors of the plates are contained in DATA C statements in the main PROGRAM.) C C The digitized boundaries of the plates (continuous closed curves, C always circling counterclockwise, and redundantly descriging C each plate boundary *twice*, from each side) C are read here, from an input file such as 'PB2002_plates.dig', C on Fortran input device IUNITM. C C The convention for identifying the plates is a 2-character symbol. C See array NAMES in the main PROGRAM. C C------------------------------------------------------- CHARACTER*2 NAMES, SYMBOL CHARACTER*3 STARS DIMENSION NAMES (NPLATE) , NDPLAT(NPLATE) DIMENSION PLAT (NPLATE,NPBND), PLON (NPLATE,NPBND) C------------------------------------------------------ C C NREAD=0 100 READ (IUNITM,101,END=201,IOSTAT=IOS) SYMBOL IF((NREAD.EQ.0).AND.(IOS.NE.0)) THEN WRITE(*,"(' ERR','OR:File not found, or file empty.')") CALL PAUSE() STOP END IF 101 FORMAT (A2) DO 120 L=1,NPLATE IF(SYMBOL.EQ.NAMES(L)) THEN IP=L GO TO 140 ENDIF 120 CONTINUE WRITE (IUNITT,121) IUNITM 121 FORMAT (/' ERR0R: BAD PLATE NAME ON INPUT DEVICE ',I3) CALL PAUSE() STOP C 140 NREAD=NREAD+1 IF (NREAD.GT.NPLATE) THEN WRITE (IUNITT,141) WRITE (*,141) 141 FORMAT(/' Increase NPLATE and recompile.') CALL PAUSE() STOP END IF I=0 142 READ (IUNITM,145,END=201) STARS 145 FORMAT (A3) IF (STARS.EQ.'***') THEN NDPLAT(IP)=I GO TO 100 ENDIF BACKSPACE IUNITM I=I+1 IF (I.GT.NPBND) THEN WRITE (IUNITT, 146) WRITE (*, 146) 146 FORMAT(/' Increase NPBND and recompile.') CALL PAUSE() STOP END IF READ (IUNITM, * ) PLON(IP,I), PLAT(IP,I) PLON(IP,I)=PLON(IP,I)*0.017453293 PLAT(IP,I)=PLAT(IP,I)*0.017453293 GO TO 142 201 IF(NREAD.LT.NPLATE) THEN WRITE(IUNITT,"(' ERR','OR: Expecting ',I3,' plates but' + /' read outlines of only ',I3)")NPLATE,NREAD WRITE(*,"(' ERR','OR: Expecting ',I3,' plates but' + /' read outlines of only ',I3)")NPLATE,NREAD CALL PAUSE() STOP END IF C RETURN END C C C C Note: The following FUNCTION subprogram was used during debugging C of this package. Then, it was replaced by C faster (identical) statement functions in each of the C other subprograms that usedd INDEXK. Each of those C subprograms now also includes the COMMON statement. C CCC INTEGER FUNCTION INDEXK (IROW,JCOLUM) CCC CCC Returns subscript necessary to locate a term in the stiffness CCC matrix which resides at logical row IROW and logical column CCC JCOLUM. The value can be read from (or written to) CCC STIFF(INDEXK(IROW,JCOLUMN)), where the stiffness matrix is CCC dimensioned as a vector (single-subscript array). CCC CCC Necessary information from subprogram -KSIZE- is passed by way of CCC blnak COMMON from the main PROGRAM: CCC COMMON LDA,NUCA,MXWORK CCC CCC INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + NUCA + IROW - JCOLUM + 1 CCC RETURN CCC END C C C SUBROUTINE INTERP (INPUT,FATNOD,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,FATIP) C C Interpolate a scalar function known at the nodes (FATNOD) C to values at the 7 integration points in each triangular C continuum element. C DOUBLE PRECISION POINTS COMMON /S1S2S3/ POINTS DIMENSION POINTS(3,7) DIMENSION FATNOD(MXNODE),FATIP(7,MXEL),NODES(3,MXEL) C DO 100 M=1,7 DO 90 I=1,NUMEL FATIP(M,I)=POINTS(1,M)*FATNOD(NODES(1,I))+ + POINTS(2,M)*FATNOD(NODES(2,I))+ + POINTS(3,M)*FATNOD(NODES(3,I)) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE KSIZE (INPUT,BRIEF,IUNITT,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES,NUMEL,NUMNOD, + OUTPUT,LDA,NUCA,NDOF,NKSIZE,NLB,NUB, + WORK,JCOL1,JCOL2) C C Determine the lower and upper half-bandwidths of the stiffness C matrix by proceeding through the same loops as will be used to C create it. C The calculation is done in terms of node numbers first, and then C the results are (almost) doubled to account for two degrees of C freedom per node. The necessary size of the stiffness matrix C workspace is computed and reported as NKSIZE. C CHARACTER*1 BLANK,STAR,ASC1,ASC2,ASCR LOGICAL BRIEF,WORST1,WORST2,WORSTR DIMENSION JCOL1(MXNODE),JCOL2(MXNODE), + NODEF(4,MXFEL),NODES(3,MXEL) DATA BLANK/' '/, STAR/'*'/ C C Initialize bandwidth to 1 node: DO 10 I=1,NUMNOD JCOL1(I)=I JCOL2(I)=I 10 CONTINUE C Band widening by triangular continuum elements: DO 50 I=1,NUMEL DO 40 J=1,3 NR=NODES(J,I) DO 30 K=1,3 NC=NODES(K,I) JCOL1(NR)=MIN(JCOL1(NR),NC) JCOL2(NR)=MAX(JCOL2(NR),NC) 30 CONTINUE 40 CONTINUE 50 CONTINUE C Band widening by linear fault elements: DO 80 I=1,NFL DO 70 J=1,4 NR=NODEF(J,I) DO 60 K=1,4 NC=NODEF(K,I) JCOL1(NR)=MIN(JCOL1(NR),NC) JCOL2(NR)=MAX(JCOL2(NR),NC) 60 CONTINUE 70 CONTINUE 80 CONTINUE C NLB=0 NUB=0 DO 190 I=1,NUMNOD NLB=MAX(NLB,I-JCOL1(I)) NUB=MAX(NUB,JCOL2(I)-I) 190 CONTINUE IF (.NOT.BRIEF) THEN WRITE(IUNITT,200) 200 FORMAT(/ /' Table of most distant connections between', + ' nodes'/ + ' (* marks the cases which determine the bandwidth)'/ / + ' Lowest-connection Node Highest-connection') DO 220 I=1,NUMNOD WORST1=(I-JCOL1(I)).EQ.NLB WORST2=(JCOL2(I)-I).EQ.NUB WORSTR=WORST1.OR.WORST2 ASC1=BLANK ASC2=BLANK ASCR=BLANK IF (WORST1) ASC1=STAR IF (WORST2) ASC2=STAR IF (WORSTR) ASCR=STAR WRITE (IUNITT,210) JCOL1(I),ASC1,I,ASCR,JCOL2(I),ASC2 210 FORMAT(' ',I12,A1,I11,A1,I11,A1) 220 CONTINUE ENDIF C C Correct numbers for presence of two degrees of freedom per node: C NDOF=2*NUMNOD NLB=2*NLB+1 NUB=2*NUB+1 NKSIZE=0 DO 300 IR=1,NDOF JC1=MAX(1,IR-NLB) JC2=MIN(NDOF,IR+NUB) NKSIZE=NKSIZE+(JC2-JC1+1) 300 CONTINUE WRITE (*,310) NKSIZE,NDOF,NLB,NUB IF (.NOT.BRIEF) WRITE (IUNITT,310) NKSIZE,NDOF,NLB,NUB 310 FORMAT (/' If no space were wasted, stiffness matrix would have', + I10,' entries.'/' It has ',I6,' rows;'/' the lower', + ' bandwidth is ',I6,';'/' the upper bandwidth is ',I6, + '.') C C Adjust for inefficiencies of actual linear-system solver used: C currently, subprogram DLSLRB of the IMSL package. C NUCA=NUB LDA=NLB+1+NUB NKSIZE=NDOF*LDA IF (.NOT.BRIEF) WRITE (IUNITT,320) NKSIZE,NDOF,LDA 320 FORMAT (/' Actual storage needed for stiffness matrix is', + I10,' entries;'/' It has ',I6,' columns, each of ', + I6,' rows.') RETURN END C C C SUBROUTINE LIMITS (INPUT,AREA,DETJ,IUNITT,MXEL,NUMEL, + OKDELV,RADIUS,REFSTR,SPHERE,TLINT, + TRHMAX,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) C C Compute area, mean thickness, and other dimensional parameters C of the plate, then determine values of stiffness limits needed C to keep velocity errors down to order OKDELV at shear stress C level REFSTR. C LOGICAL SPHERE DOUBLE PRECISION WEIGHT COMMON /WGTVEC/ WEIGHT DIMENSION WEIGHT(7) DIMENSION AREA(MXEL),DETJ(7,MXEL),TLINT(7,MXEL),ZMOHO(7,MXEL) C TOTALA=0. TOTALV=0. DO 20 M=1,7 DO 10 I=1,NUMEL DA=AREA(I)*DETJ(M,I)*WEIGHT(M) TOTALA=TOTALA+DA TOTALV=TOTALV+DA*(ZMOHO(M,I)+TLINT(M,I)) 10 CONTINUE 20 CONTINUE WHOLE=4.*3.14159*RADIUS**2 IF (TOTALA.GT.(1.02*WHOLE)) THEN WRITE (IUNITT,21) TOTALA, WHOLE 21 FORMAT (/' AREA OF GRID (',1P,E12.4,') EXCEEDS' + /' AREA OF PLANET (',E12.4,'), WHICH MAKES' + ,' NO SENSE.' + /' CHECK GRID FOR ABS(LATITUDE) > 90.' + /' AND FOR OVERLAPPING ELEMENTS.') CALL PAUSE() STOP ENDIF THICK=TOTALV/TOTALA IF (SPHERE) THEN SIDE=RADIUS NFAULT=1 ELSE SIDE=SQRT(TOTALA) NFAULT=4 ENDIF CONSTR=NFAULT*REFSTR*THICK/OKDELV ETAMAX=REFSTR*THICK/(SIDE*OKDELV) ETAMAX=MIN(ETAMAX,TRHMAX/OKDELV) FMUMAX=NFAULT*REFSTR/OKDELV VISMAX=0.25*REFSTR*SIDE/OKDELV WRITE (*,50) TOTALA,TOTALV,THICK,SIDE,CONSTR,ETAMAX, + FMUMAX,VISMAX WRITE (IUNITT,50) TOTALA,TOTALV,THICK,SIDE,CONSTR,ETAMAX, + FMUMAX,VISMAX 50 FORMAT (/ /' Subprogram -LIMITS- performs dimensional analysis'/ + ' and estimates necessary stiffness limits to balance'/1P, + ' the conflicting objectives of accuracy and precision:'/ / + ' area of model = ',E10.3,' length**2'/ + ' volume of model = ',E10.3,' length**3'/ + ' typical thickness = ',E10.3,' length'/ + ' typical width = ',E10.3,' length'/ + ' CONSTR (constraint weight) = ',E10.3,' force s/length**2'/ + ' ETAMAX (max. basal coupling) = ',E10.3,' force s/length**3'/ + ' FMUMAX (max. fault stiffness) = ',E10.3,' force s/length**3'/ + ' VISMAX (max. block viscosity) = ',E10.3,' force s/length**2') RETURN END C C C SUBROUTINE LOOKUP (INPUT,IUNITT,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES,NUMEL, + X,XNODE,Y,YNODE, + MODIFY,IE,S1,S2,S3, + OUTPUT,ATSEA) C C Finds element and internal coordinates in grid matching location C of a particular point (X,Y) and reports them as IE and S1,S2,S3. C C Note that X is colatitude (from North pole) and Y is C East longitude. Both are in radians. C C A returned value of ATSEA indicates that point fell off edge C of the grid. C PARAMETER (NTOTRY=50) LOGICAL ATSEA,TRUBBL REAL M11,M12,M13,M21,M22,M23 DIMENSION NODEF(4,MXFEL),NODES(3,MXEL), + XNODE(MXNODE),YNODE(MXNODE) DIMENSION IEHIST(NTOTRY),SHIST(3,NTOTRY) C C Statement function: PHIVAL(S1,S2,S3,F1,F2,F3)=S1*F1+S2*F2+S3*F3 C C NTRIED=0 C C Loop as many times as needed: C 100 NTRIED=NTRIED+1 IEHIST(NTRIED)=IE IF (NTRIED.GE.(NTOTRY-10)) THEN TRUBBL=(IEHIST(NTRIED).EQ.IEHIST(NTRIED-2)) ELSE TRUBBL=.FALSE. END IF IF (TRUBBL) THEN ATSEA=.TRUE. RETURN ENDIF I1=NODES(1,IE) I2=NODES(2,IE) I3=NODES(3,IE) X1=XNODE(I1) X2=XNODE(I2) X3=XNODE(I3) Y1=YNODE(I1) Y2=YNODE(I2) Y3=YNODE(I3) S3=1.-S1-S2 LIMIT=3 NREFIN=0 C C Loop to refine estimate of internal coordinates: C 150 NREFIN=NREFIN+1 XT=PHIVAL(S1,S2,S3,X1,X2,X3) YT=PHIVAL(S1,S2,S3,Y1,Y2,Y3) C C COEF:=MAT((DXDS1,DXDS2,DXDS3), C (DYDS1,DYDS2,DYDS3),(1,1,1)); C COEF11=X1 COEF12=X2 COEF13=X3 COEF21=Y1 COEF22=Y2 COEF23=Y3 M11=COEF22-COEF23 M12=COEF21-COEF23 M13=COEF21-COEF22 M21=COEF12-COEF13 M22=COEF11-COEF13 M23=COEF11-COEF12 CF11=+M11 CF12=-M12 CF13=+M13 CF21=-M21 CF22=+M22 CF23=-M23 DET=COEF11*CF11+COEF12*CF12+COEF13*CF13 IF (DET.EQ.0.0) THEN ATSEA=.TRUE. WRITE (IUNITT,151) 151 FORMAT (' LOOKUP IS ATSEA.') RETURN ENDIF DETI= 1./DET STEP11=CF11 STEP12=CF21 STEP21=CF12 STEP22=CF22 STEP31=CF13 STEP32=CF23 DELX=X-XT DELY=Y-YT DS1=(STEP11*DELX+STEP12*DELY)*DETI DS2=(STEP21*DELX+STEP22*DELY)*DETI DS3=(STEP31*DELX+STEP32*DELY)*DETI ERR=(DS1+DS2+DS3)/3. DS1=DS1-ERR DS2=DS2-ERR DS3=DS3-ERR DSTEP=MAX(ABS(DS1),ABS(DS2),ABS(DS3)) IF (DSTEP.GT. 0.10) THEN LIMIT=LIMIT+1 DS1=DS1*0.1/DSTEP DS2=DS2*0.1/DSTEP DS3=DS3*0.1/DSTEP ENDIF S1=S1+DS1 S2=S2+DS2 S3=S3+DS3 C C Loop-back (with some conditions): C IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.(NTOTRY-10)).AND. + (S1.GE.-0.1.AND.S1.LE.1.1).AND. + (S2.GE.-0.1.AND.S2.LE.1.1).AND. + (S3.GE.-0.1.AND.S3.LE.1.1)) GO TO 150 C C Point is now as well-located as possible "in" the current element; C however, the internal coordinates may not all be positive, so C point may be outside, and we may need to shift to a new element. C SHIST(1,NTRIED)=S1 SHIST(2,NTRIED)=S2 SHIST(3,NTRIED)=S3 IF (TRUBBL.OR.NTRIED.GE.NTOTRY) THEN WRITE(IUNITT,201) X,Y 201 FORMAT(' REQUEST FOR VALUE AT LOCATION', + ' (',1P,E10.2,',',E10.2,') CAUSES ', + 'INFINITE LOOP IN LOOKUP.'/ + ' HISTORY OF SEARCH: ELEMENT S1 S2', + ' S3') DO 203 N=1,NTRIED-1 WRITE(IUNITT,202) IEHIST(N),(SHIST(K,N),K=1,3) 202 FORMAT(22X,I3,2X,3F12.4) 203 CONTINUE WRITE(IUNITT,204) IEHIST(NTRIED-1), + (NODES(J,IEHIST(NTRIED-1)),J=1,3), + (XNODE(NODES(J,IEHIST(NTRIED-1))),J=1,3), + (YNODE(NODES(J,IEHIST(NTRIED-1))),J=1,3) WRITE(IUNITT,204) IEHIST(NTRIED), + (NODES(J,IEHIST(NTRIED)),J=1,3), + (XNODE(NODES(J,IEHIST(NTRIED))),J=1,3), + (YNODE(NODES(J,IEHIST(NTRIED))),J=1,3) 204 FORMAT(' ELEMENT',I3,' NODES:',I3,2I10/ + 9X,'X:',1P,3E10.2/9X,'Y:',3E10.2) RETURN ENDIF IF (S1.GT.-0.03) THEN IF (S2.GT.-0.03) THEN IF (S3.GT.-0.03) THEN C Point has been successfully found! ATSEA=.FALSE. RETURN ELSE CALL NEXT (INPUT,IE,3,MXEL,MXFEL,NFL, + NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) ENDIF ELSE CALL NEXT (INPUT,IE,2,MXEL,MXFEL,NFL, + NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) ENDIF ELSE CALL NEXT (INPUT,IE,1,MXEL,MXFEL,NFL, + NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) ENDIF IF (KELE.GT.0) THEN IE=KELE S1=0.3333 S2=0.3333 S3=0.3334 GO TO 100 ELSE ATSEA=.TRUE. RETURN ENDIF C C Note: Indentation reflects indefinite loop on trial element IE. C END C C C SUBROUTINE MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DQDTDA, + ECREEP,ELEV,FDIP,FFRIC,FMUMAX, + FPFLT,FARG,GMEAN, + MXFEL,MXNODE,NFL,NODEF, + OFFMAX,OFFSET, + ONEKM,RADIO,RHOH2O,RHOBAR, + SLIDE,SPHERE,TAUMAX, + TLNODE,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) C C This subprogram contains the nonlinear rheology of the faults. C For each of 7 integration points along the length of each fault C element, it: C C (1) Computes the slip-rate vector on the fault surface; C (2) Determines the shear stress on the fault surface by Mohr/ C Coulomb/Navier theory; (This stress is proportional to depth, C so the calculation is actually done at unit depth and then C scaled.) C (3) Proceeds down the dip of the fault, checking temperature, C strain rate, and pressure to see if frictional or creep C shear stress is lower; C (4) Reports the vertical integral of MU (the ratio of shear C stress to slip rate) down the fault as FIMUDZ; C (Note that the integral is vertical, not on a slant, even though C conditions are evaluated along a slant path.) C (5) For dipping, oblique-slip faults only, also reports recommended C tactical values for the matrix FC and the vector FTSTAR C which jointly describe a linearized rheology stiffer than C the actual nonlinear rheology; C (6) ZTRANF is the latest estimate of the depth C to the brittle/ductile transition, at the fault midpoint; C (7) LOGICAL variable FSLIPS indicates whether the fault is C slipping at its midpoint; (Otherwise, it is in the artificial C linearized regime, with stiffness FMUMAX.) C (8) FPEAKS gives the peak shear stress at the midpoint of each C fault, evaluated at the brittle/ductile transition; C (9) Faults with dip less than SLIDE (radians) are limited C to a maximum down-dip integral shear traction of TAUMAX. C C Note that pore pressures are considered in the calculation of C frictional strength: C *Normal pore pressures reduce the effective normal stress on the C fault surface by the amount C -BIOT*GMEAN*RHOH20*Z C *IF (OFFMAX.GT.0.) THEN the remaining effective frictional strength C of the fault is multiplied by the reducing factor C *(1.-BYERLY*OFFSET(I)/OFFMAX). C This is also a pore pressure effect, because Byerlee's model is C that gouge layers have thickness in proportion to OFFSET, and C that they support non-Darcy static pore pressure gradients which C allow elevated pore pressures in the core of the gouge, which C reduce the effective friction of the fault. C C Following PARAMETER gives number of steps in vertical integral C of creep shear stress on ductile parts of faults: PARAMETER (NSTEP=30) C Higher values obviously cost more. On the other hand, small values C do not merely approximate the creep law; they also introduce C some random error which can put a floor on convergence C of the whole global velocity field. C C Note: In VS-Fortran, following type could be LOGICAL*1: LOGICAL FSLIPS C LOGICAL LOCKED,PURESS,SLOPED,SPHERE DOUBLE PRECISION DPT1,V DOUBLE PRECISION FPHI COMMON /FPHIS/ FPHI REAL MANTLE,NORMAL C DIMENSIONs per COMMON block: DIMENSION FPHI(4,7) C DIMENSIONs of internal convenience arrays: DIMENSION DLEPDZ(2),DSFDZ(2),RHO(2),SHEART(2),TMEAN(2),ZTRANS(2) C DIMENSIONs of external argument arrays: DIMENSION ACREEP(2),ALPHAT(2),BCREEP(2),CCREEP(2),CONDUC(2), + DCREEP(2),DQDTDA(MXNODE),ELEV(MXNODE), + FC(2,2,7,MXFEL),FDIP(2,MXFEL), + FIMUDZ(7,MXFEL),FPEAKS(2,MXFEL), + FPFLT(2,2,2,7,MXFEL), FSLIPS(MXFEL), + FARG(2,MXFEL),FTSTAR(2,7,MXFEL),NODEF(4,MXFEL), + OFFSET(MXFEL),RADIO(2),RHOBAR(2), + TAUMAX(2),TLNODE(MXNODE), + V(2,MXNODE),ZMNODE(MXNODE),ZTRANF(2,MXFEL) C C Following two numbers are "very small" and "very large", but not C so extreme as to cause underflow or overflow. They may need to C be adjusted, depending on the computer and compiler you use: DATA TINY /2.E-38/ DATA HUGE /1.E+38/ C CGAMMA=(1.+SIN(ATAN(CFRIC)))/(1.-SIN(ATAN(CFRIC))) DO 100 I=1,NFL IF (OFFMAX.LE.0.) THEN FRIC=FFRIC ELSE FRIC=FFRIC*(1.-BYERLY*OFFSET(I)/OFFMAX) ENDIF N1=NODEF(1,I) N2=NODEF(2,I) N3=NODEF(3,I) N4=NODEF(4,I) C C Is this a purely strike-slip fault element? PURESS=(ABS(FDIP(1,I)-1.570796).LE.WEDGE).AND. + (ABS(FDIP(2,I)-1.570796).LE.WEDGE) C C If so, compute estimate of relative normal stress C (relative to vertical stress) by using amount of divergence C between average of node N1 and N2 and average of node N3 C and node N4 (in spite on constraint equation): IF (PURESS) THEN C CCCCC ANGLE=0.5*(FARG(1,I)+FARG(2,I)) CCCCC Line above was replaced due to cycle-shift problem! C ANGLE=CHORD(FARG(1,I),0.5D0,FARG(2,I)) C UNITBX=SIN(ANGLE) UNITBY= -COS(ANGLE) C UNITB points outward on the N1-N2 side (away from C the N3-N4 side). DELVX=V(1,N1)*FPFLT(1,1,1,4,I)+V(2,N1)*FPFLT(2,1,1,4,I) + +V(1,N2)*FPFLT(1,1,2,4,I)+V(2,N2)*FPFLT(2,1,2,4,I) + -V(1,N3)*FPFLT(1,1,2,4,I)-V(2,N3)*FPFLT(2,1,2,4,I) + -V(1,N4)*FPFLT(1,1,1,4,I)-V(2,N4)*FPFLT(2,1,1,4,I) DELVY=V(1,N1)*FPFLT(1,2,1,4,I)+V(2,N1)*FPFLT(2,2,1,4,I) + +V(1,N2)*FPFLT(1,2,2,4,I)+V(2,N2)*FPFLT(2,2,2,4,I) + -V(1,N3)*FPFLT(1,2,2,4,I)-V(2,N3)*FPFLT(2,2,2,4,I) + -V(1,N4)*FPFLT(1,2,1,4,I)-V(2,N4)*FPFLT(2,2,1,4,I) C DELVX and DELVY are the velocities of the N1-N2 side C relative to the N3-N4 side. SPREAD=DELVX*UNITBX+DELVY*UNITBY DELTAU=CONSTR*SPREAD TLAN=0.5*(TLNODE(N1)+TLNODE(N2)) ZMAN=0.5*(ZMNODE(N1)+ZMNODE(N2)) IF ((TLAN.LE.0.).OR.(ZTRANF(2,I).LE.0.)) THEN C Crust along resists convergence: DPMAX= -2.*DELTAU/ZTRANF(1,I) DDPNDZ=DPMAX/ZTRANF(1,I) ELSE C Mantle lithosphere helps to resist convergence: DDPNDZ= -DELTAU/ + (0.5*ZTRANF(1,I)**2+ZTRANF(2,I)*ZMAN+ + 0.5*ZTRANF(2,I)**2) ENDIF C DDPNDZ is the gradient of excess normal pressure (in C excess of vertical pressure) with depth on this fault; C check that it lies within frictional limits of blocks: Q=0.25*(DQDTDA(N1)+DQDTDA(N2)+ + DQDTDA(N3)+DQDTDA(N4)) TTRANS=TSURF+ZTRANF(1,I)*Q/CONDUC(1)- + ZTRANF(1,I)**2*RADIO(1)/(2.*CONDUC(1)) TMEANC=(TSURF+TTRANS)/2. RHOC=RHOBAR(1)*(1.-ALPHAT(1)*TMEANC) DLEPDC=GMEAN*(RHOC-RHOH2O*BIOT) THRUST=DLEPDC*CGAMMA NORMAL=DLEPDC/CGAMMA DDPNDZ=MAX(DDPNDZ,NORMAL-DLEPDC) DDPNDZ=MIN(DDPNDZ,THRUST-DLEPDC) C ELSE C Different logic will be used; this parameter is not C really needed. Zero it just to be careful. DDPNDZ=0. ENDIF C DO 90 M=1,7 C C elevation: ELEVAT=ELEV(N1)*FPHI(1,M)+ELEV(N2)*FPHI(2,M) C C heat flow: Q=DQDTDA(N1)*FPHI(1,M)+DQDTDA(N2)*FPHI(2,M) C C crustal thickness: CRUST=ZMNODE(N1)*FPHI(1,M)+ZMNODE(N2)*FPHI(2,M) C C mantle lithosphere thickness: MANTLE=TLNODE(N1)*FPHI(1,M)+TLNODE(N2)*FPHI(2,M) MANTLE=MAX(MANTLE,0.) C C Moho temperature: TMOHO=TSURF+CRUST*Q/CONDUC(1)- + CRUST**2*RADIO(1)/(2.*CONDUC(1)) C C Temperature at base of plate: TASTH=TMOHO+MANTLE*(Q-CRUST*RADIO(1))/CONDUC(2)- + MANTLE**2*RADIO(2)/(2.*CONDUC(2)) C C mean temperatures: TMEAN(1)=(TSURF+TMOHO)/2. TMEAN(2)=(TMOHO+TASTH)/2. C C mean densities: RHO(1)=RHOBAR(1)*(1.-ALPHAT(1)*TMEAN(1)) RHO(2)=RHOBAR(2)*(1.-ALPHAT(2)*TMEAN(2)) C C derivitives of lithostatic effective pressure wrt depth DLEPDZ(1)=GMEAN*(RHO(1)-RHOH2O*BIOT) EPMOHO=DLEPDZ(1)*CRUST DLEPDZ(2)=GMEAN*(RHO(2)-RHOH2O*BIOT) C C ANGLE is the fault strike, in radians cclkws from +X. C CCCCC ANGLE=FARG(1,I)*FPHI(1,M)+FARG(2,I)*FPHI(2,M) CCCCC Line above was replaced due to cycle-shift problem! C ANGLE=CHORD(FARG(1,I),FPHI(2,M),FARG(2,I)) C C UNITA is a unit vector along the fault, from N1 to N2. UNITAX=COS(ANGLE) UNITAY=SIN(ANGLE) C C UNITB is a perpendicular unit vector, pointing out C toward the N4-N3 side. UNITBX= -UNITAY UNITBY= +UNITAX C C relative velocities are for N1-2 side relative to C the N4-3 side: DELVX=V(1,N1)*FPFLT(1,1,1,M,I)+V(2,N1)*FPFLT(2,1,1,M,I) + +V(1,N2)*FPFLT(1,1,2,M,I)+V(2,N2)*FPFLT(2,1,2,M,I) + -V(1,N3)*FPFLT(1,1,2,M,I)-V(2,N3)*FPFLT(2,1,2,M,I) + -V(1,N4)*FPFLT(1,1,1,M,I)-V(2,N4)*FPFLT(2,1,1,M,I) DELVY=V(1,N1)*FPFLT(1,2,1,M,I)+V(2,N1)*FPFLT(2,2,1,M,I) + +V(1,N2)*FPFLT(1,2,2,M,I)+V(2,N2)*FPFLT(2,2,2,M,I) + -V(1,N3)*FPFLT(1,2,2,M,I)-V(2,N3)*FPFLT(2,2,2,M,I) + -V(1,N4)*FPFLT(1,2,1,M,I)-V(2,N4)*FPFLT(2,2,1,M,I) C C sinistral strike-slip rate component: SINIST=DELVX*UNITAX+DELVY*UNITAY C C convergence rate component (in horizontal plane): CLOSE =DELVX*UNITBX+DELVY*UNITBY C C dip of the fault (from horizontal on the N1-N2 side): DIP=FDIP(1,I)*FPHI(1,M)+FDIP(2,I)*FPHI(2,M) SLOPED=ABS(DIP-1.570796).GT.WEDGE C IF (.NOT.SLOPED) THEN C case of a near-vertical fault: DSFDZ(1)=(DLEPDZ(1)+DDPNDZ)*FRIC SFMOHO=DSFDZ(1)*CRUST DSFDZ(2)=(DLEPDZ(2)+DDPNDZ)*FRIC SLIP=ABS(SINIST) LOCKED=.FALSE. ELSE C case of a shallow-dipping fault: C C VUPDIP is the up-dip velocity component, in the C fault plane, of the block on the N1-N3 side: VUPDIP=CLOSE/COS(DIP) C C RAKE angle is measured counterclockwise in C fault plane from horizontal & parallel to ANGLE: RAKE=ATAN2F(VUPDIP,SINIST) C C derivitive of effective normal pressure C with respect to shear traction on fault: DEPDST=TAN(DIP)*SIN(RAKE) C (Notice that when sense of dip reverses, sign C change caused by TAN(DIP) is cancelled by sign C change caused by SIN(RAKE).) C C According to theory, the equation to solve is: C d(shear traction)/dZ = C FRIC*(DLEPDZ+DEPDST*d(shear traction)/dZ) C This may have a physical solution (one with C positive shear traction). If not, the fault C is locked. LOCKED=(FRIC*DEPDST).GE.1.00 IF (LOCKED) THEN DSFDZ(1)=HUGE DSFDZ(2)=HUGE ELSE DSFDZ(1)=FRIC*DLEPDZ(1)/(1.00-FRIC*DEPDST) SFMOHO=DSFDZ(1)*CRUST DSFDZ(2)=FRIC*DLEPDZ(2)/(1.00-FRIC*DEPDST) ENDIF C SLIP=SQRT(SINIST**2+VUPDIP**2) ENDIF SLIP=MAX(SLIP,1.E8*TINY) C C Locate plastic/creep transition(s) C by iterated halving of domain: C IF (MANTLE.GT.0.) THEN LIMIT=2 ELSE LIMIT=1 ZTRANS(2)=0. SHEART(2)=0. ENDIF DO 60 LAYER=1,LIMIT TOPZ=0. IF (LAYER.EQ.1) THEN BASEZ=CRUST SF0=0. T0=TSURF Q0=Q Z0=0. ELSE BASEZ=MANTLE SF0=SFMOHO T0=TMOHO Q0=Q-CRUST*RADIO(1) Z0=CRUST ENDIF DO 50 KITER=1,15 Z=0.5*(TOPZ+BASEZ) ZABS=Z+Z0 SHEARF=Z*DSFDZ(LAYER)+SF0 SHEARP=MIN(SHEARF,DCREEP(LAYER)) T=T0+Q0*Z/CONDUC(LAYER)-(RADIO(LAYER)/ + (2.*CONDUC(LAYER)))*Z**2 IF (ZABS.LE.(15.*ONEKM)) THEN T90PC=0.5*ZABS ELSE IF (ZABS.LT.(45.*ONEKM)) THEN T90PC=(405./8.)*ONEKM+ + (-7.)*ZABS+ + (13./40.)*ONEKM*(ZABS/ONEKM)**2+ + (-1./300.)*ONEKM*(ZABS/ONEKM)**3 ELSE T90PC=2.*ZABS ENDIF C see Turcotte et al (1980) JGR, 85, B11, 6224-6230 STRAIN=SLIP/T90PC SHEARC=ACREEP(LAYER)*(STRAIN**ECREEP)* + EXP((BCREEP(LAYER)+CCREEP(LAYER)*Z)/T) IF (SHEARC.LT.SHEARP) THEN BASEZ=Z ELSE TOPZ=Z ENDIF 50 CONTINUE ZTRANS(LAYER)=0.5*(TOPZ+BASEZ) SHEART(LAYER)=ZTRANS(LAYER)*DSFDZ(LAYER)+SF0 60 CONTINUE C C plastic part of vertical integral(s) of traction: C (A) crust: IF (SHEART(1).LE.DCREEP(1)) THEN VITDZ=0.5*SHEART(1)*ZTRANS(1) ELSE ZP=ZTRANS(1)*DCREEP(1)/SHEART(1) VITDZ=DCREEP(1)*(ZTRANS(1)-0.5*ZP) ENDIF C (B) mantle lithosphere: IF ((MANTLE.GT.0.).AND.(SHEART(2).GT.SFMOHO)) THEN IF (SHEART(2).LE.DCREEP(2)) THEN VITDZ=VITDZ+0.5*(SFMOHO+SHEART(2))*ZTRANS(2) ELSE ZP=ZTRANS(2)*(DCREEP(2)-SFMOHO)/ + (SHEART(2)-SFMOHO) ZP=MAX(ZP,0.) VITDZ=VITDZ+0.5*(SFMOHO+SHEART(2))*ZP+ + DCREEP(2)*(ZTRANS(2)-ZP) ENDIF ENDIF C C Add creep part(s) of integral, using parabolic rule: C SUM=0. DO 80 LAYER=1,LIMIT IF (LAYER.EQ.1) THEN THICK=CRUST T0=TSURF Q0=Q ZABS=0. ELSE THICK=MANTLE T0=TMOHO Q0=Q-CRUST*RADIO(1) ZABS=CRUST ENDIF DZ=(THICK-ZTRANS(LAYER))/NSTEP OLDSC=SHEART(LAYER) OLDSC=MIN(OLDSC,DCREEP(LAYER)) Z0=ZTRANS(LAYER) DO 70 J=1,NSTEP ZHALF=Z0+0.5*DZ ZFULL=Z0+DZ AZHALF=ZHALF+ZABS AZFULL=ZFULL+ZABS THALF=T0+Q0*ZHALF/CONDUC(LAYER)- + (RADIO(LAYER)/ + (2.*CONDUC(LAYER)))*ZHALF**2 TFULL=T0+Q0*ZFULL/CONDUC(LAYER)- + (RADIO(LAYER)/ + (2.*CONDUC(LAYER)))*ZFULL**2 IF (AZHALF.LE.(15.*ONEKM)) THEN WHALF=0.5*AZHALF ELSE IF (AZHALF.LT.(45.*ONEKM)) THEN WHALF=(405./8.)*ONEKM+ + (-7.)*AZHALF+ + (13./40.)*ONEKM*(AZHALF/ONEKM)**2+ + (-1./300.)*ONEKM*(AZHALF/ONEKM)**3 ELSE WHALF=2.*AZHALF ENDIF IF (AZFULL.LE.(15.*ONEKM)) THEN WFULL=0.5*AZFULL ELSE IF (AZFULL.LT.(45.*ONEKM)) THEN WFULL=(405./8.)*ONEKM+ + (-7.)*AZFULL+ + (13./40.)*ONEKM*(AZFULL/ONEKM)**2+ + (-1./300.)*ONEKM*(AZFULL/ONEKM)**3 ELSE WFULL=2.*AZHALF ENDIF C see Turcotte et al (1980) JGR, 85, B11, 6224-6230 EHALF=SLIP/WHALF EFULL=SLIP/WFULL SCHALF=ACREEP(LAYER)*(EHALF**ECREEP)* + EXP((BCREEP(LAYER)+CCREEP(LAYER)*ZHALF) + /THALF) SCHALF=MIN(SCHALF,DCREEP(LAYER)) SCFULL=ACREEP(LAYER)*(EFULL**ECREEP)* + EXP((BCREEP(LAYER)+CCREEP(LAYER)*ZFULL) + /TFULL) SCFULL=MIN(SCFULL,DCREEP(LAYER)) SUM=SUM+DZ*(0.1666667*OLDSC+ + 0.6666667*SCHALF+ + 0.1666666*SCFULL) Z0=ZFULL OLDSC=SCFULL 70 CONTINUE 80 CONTINUE C VITDZ=VITDZ+SUM C C Limit shear traction on subduction zones only: C DIPPY=MIN(DIP,3.141592654-DIP) IF (DIPPY.LE.SLIDE) THEN IF (ELEVAT.LT.0.0) THEN C apply oceanic subduction zone limit: VITDZ=MIN(VITDZ,TAUMAX(1)*SIN(DIP)) ELSE C apply continental subduction zone limit: VITDZ=MIN(VITDZ,TAUMAX(2)*SIN(DIP)) END IF ENDIF C DPT1=(1.D0*VITDZ)/SLIP VIMUDZ=MIN(DPT1,1.D38) C FIMUDZ(M,I)=MIN(VIMUDZ,FMUMAX*(CRUST+MANTLE)) C C Dipping, oblique-slip integration C points are also characterized C by FC and FTSTAR: C IF (SLOPED) THEN TS=SINIST*FIMUDZ(M,I) TU=VUPDIP*FIMUDZ(M,I) IF (LOCKED) THEN FC(1,1,M,I)=FIMUDZ(M,I) FC(1,2,M,I)=0. FC(2,1,M,I)=0. FC(2,2,M,I)=FIMUDZ(M,I) ELSE SINR=SIN(RAKE) COSR=COS(RAKE) TAND=TAN(DIP) C C *** IMPORTANT NOTE: *** C The following 7 statements are *not* the C result of theory, but a tactical choice C which attempts to compromise between C stability of the linear system, stability C of the iteration, and efficiency. C They may be changed if the program does C no converge satisfactorily! C TUNE=2. FC(1,1,M,I)=FIMUDZ(M,I)* + (1.-TUNE*SINR*COSR**2*TAND) FC(1,2,M,I)=FIMUDZ(M,I)* + (TUNE*COSR**3*TAND) FC(2,1,M,I)=FIMUDZ(M,I)* + (-TUNE*SINR**2*COSR*TAND) FC(2,2,M,I)=FIMUDZ(M,I)* + (1.+TUNE*SINR*COSR**2*TAND) C (OFTEN, FC(1,2) IS THE BIGGEST TERM. C IN SOME CASES, DIAGONALS BECOME NEGATIVE. C FOR STABILITY, BE SURE THAT THE FC C MATRIX REMAINS POSITIVE DEFINITE: FC(1,1,M,I)=MAX(FC(1,1,M,I),ABS(FC(1,2,M,I))) FC(2,2,M,I)=MAX(FC(2,2,M,I),ABS(FC(1,2,M,I))) ENDIF FTSTAR(1,M,I)=TS-FC(1,1,M,I)*SINIST- + FC(1,2,M,I)*VUPDIP FTSTAR(2,M,I)=TU-FC(2,1,M,I)*SINIST- + FC(2,2,M,I)*VUPDIP ENDIF C C Provide interesting diagnostic data at midpoints only: C IF (M.EQ.4) THEN FSLIPS(I)=(.NOT.LOCKED).AND. + (FIMUDZ(M,I).LT.(0.99*FMUMAX*(CRUST+MANTLE))) ZTRANF(1,I)=ZTRANS(1) FPEAKS(1,I)=MIN(SHEART(1),DCREEP(1)) ZTRANF(2,I)=ZTRANS(2) FPEAKS(2,I)=MIN(SHEART(2),DCREEP(2)) ENDIF C 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE NEXT (INPUT,I,J,MXEL,MXFEL,NFL,NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) C C Determine whether there are more elements adjacent to side J of C triangular continuum element #I. C J = 1 means the side oppoiste node # NODES(1,I). C J = 2 means the side opposite node # NODES(2,I). C J = 3 means the side opposite node # NODES(3,I). C If a fault element is adjacent, its number is KFAULT; otherwise, C KFAULT is set to zero. C If another triangular continuum element is adjacent (even across C fautl element KFAULT!) then its number is KELE; otherwise, KELE = 0. C LOGICAL FOUNDF DIMENSION NODEF(4,MXFEL),NODES(3,MXEL) C C Two node numbers along the side of interest, counterclockwise: N1=NODES(MOD(J, 3)+1,I) N2=NODES(MOD(J+1,3)+1,I) C Check for adjacent fault element first: FOUNDF=.FALSE. KFAULT=0 IF (NFL.GT.0) THEN DO 10 K=1,NFL M1=NODEF(1,K) M2=NODEF(2,K) M3=NODEF(3,K) M4=NODEF(4,K) IF (((M1.EQ.N2).AND.(M2.EQ.N1)).OR. + ((M3.EQ.N2).AND.(M4.EQ.N1))) THEN FOUNDF=.TRUE. KFAULT=K GO TO 11 ENDIF 10 CONTINUE 11 IF (.NOT.FOUNDF) KFAULT=0 C If there was a fault, replace 2 node numbers that we search for: IF (FOUNDF) THEN IF (M2.EQ.N1) THEN N1=M3 N2=M4 ELSE N1=M1 N2=M2 ENDIF ENDIF ENDIF C Search for adjacent triangular continuum element: KELE=0 KLOW=I KHIGH=I C --- Begin irregular loop, to search out nearest elements first --- 100 KLOW=KLOW-1 IF (KLOW.GE.1) THEN DO 110 L=1,3 M1=NODES(MOD(L, 3)+1,KLOW) M2=NODES(MOD(L+1,3)+1,KLOW) IF ((M2.EQ.N1).AND.(M1.EQ.N2)) THEN KELE=KLOW RETURN ENDIF 110 CONTINUE ENDIF KHIGH=KHIGH+1 IF (KHIGH.LE.NUMEL) THEN DO 120 L=1,3 M1=NODES(MOD(L, 3)+1,KHIGH) M2=NODES(MOD(L+1,3)+1,KHIGH) IF ((M2.EQ.N1).AND.(M1.EQ.N2)) THEN KELE=KHIGH RETURN ENDIF 120 CONTINUE ENDIF IF ((KLOW.GT.1).OR.(KHIGH.LT.NUMEL)) GO TO 100 RETURN END C C C SUBROUTINE OLDVEL (INPUT,IUNITT,IUNITV,MXNODE,NUMNOD, + OUTPUT,V) C C Read old velocity solution from unit IUNITV, or else fill array C with zeros. Comments are output to unit IUNITT. C CHARACTER*80 TITLE1,TITLE2,TITLE3 DOUBLE PRECISION V DIMENSION V(2,MXNODE) C TITLE1=' '// + ' ' READ (IUNITV,'(A80)',END=100,ERR=100) TITLE1 TITLE2=' '// + ' ' READ (IUNITV,'(A80)',END=100,ERR=100) TITLE2 TITLE3=' '// + ' ' READ (IUNITV,'(A80)',END=100,ERR=100) TITLE3 READ (IUNITV,*,END=100,ERR=100) ((V(J,I),J=1,2),I=1,NUMNOD) WRITE (IUNITT,50) IUNITV,TITLE1,TITLE2,TITLE3 50 FORMAT (/ /' Old velocity solution (initial estimate) was', + ' read from unit',I3,'; titles were:'/3(/' ',A80)) GO TO 900 C ------------------(This section executed only if READ fails)--------- 100 WRITE (IUNITT,110) IUNITV 110 FORMAT (/ /' UNABLE TO READ OLD VELOCITY SOLUTION FROM UNIT', + I3/ /' VELOCITIES WILL BE INITIALIZED TO ZERO.') DO 150 I=1,NUMNOD V(1,I)=0.D0 V(2,I)=0.D0 150 CONTINUE C --------------------------------------------------------------------- 900 WRITE (IUNITT,999) 999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE ONEBAR (INPUT,ACREEP,BCREEP,CCREEP, + ECREEP,GEOTHC,GEOTHM,GRADIE, + IUNITT,MXEL,NUMEL,ONEKM,TADIAB, + ZBASTH,ZMOHO, + OUTPUT,GLUE) C C Calculates GLUE (shear stress required to create unit relative C horizontal velocity across the lithosphere+asthenosphere) C C External argument arrays: DIMENSION ACREEP(2),BCREEP(2),CCREEP(2), + GEOTHC(4,7,MXEL),GEOTHM(4,7,MXEL), + GLUE(7,MXEL), + ZMOHO(7,MXEL) C Internal arrays: DIMENSION AILOG(2),GT(4) C C DZ=ONEKM LIMIT=ZBASTH/DZ+0.5 ECINI= -1.0/ECREEP AILOG(1)=LOG(ACREEP(1))*ECINI AILOG(2)=LOG(ACREEP(2))*ECINI DO 100 M=1,7 DO 90 I=1,NUMEL V=0. DO 20 LEVEL=1,LIMIT Z=(LEVEL-0.5)*DZ IF (Z.LT.ZMOHO(M,I)) THEN LAYER=1 GT(1)=GEOTHC(1,M,I) GT(2)=GEOTHC(2,M,I) GT(3)=GEOTHC(3,M,I) GT(4)=GEOTHC(4,M,I) ELSE LAYER=2 GT(1)=GEOTHM(1,M,I) GT(2)=GEOTHM(2,M,I) C Note: Quadratic and cubic terms could C cause lithospheric geotherm to have C multiple (nonphysical) intersections C with the adiabat! GT(3)=0. GT(4)=0. ENDIF TG=GT(1) + +GT(2)*Z + +GT(3)*Z*Z + +GT(4)*Z*Z*Z TA=TADIAB+Z*GRADIE T=MIN(TG,TA) T=MAX(T,200.) BI=(BCREEP(LAYER)+CCREEP(LAYER)*Z)*ECINI ARG=MAX(AILOG(LAYER)+BI/T,-87.) V=V+DZ*EXP(ARG) 20 CONTINUE GLUE(M,I)=1./(V**ECREEP) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE PAUSE() IMPLICIT NONE WRITE(*,"(' Press [Enter]...'\)") READ(*,*) RETURN END C C C SUBROUTINE PRINCE (INPUT,E11,E22,E12, + OUTPUT,E1,E2,U1X,U1Y,U2X,U2Y) C C Find principal values (E1,E2) of the symmetric 2x2 tensor E11 E12 C E12 E22 C and also the associated eigenvectors #1=(U1X,U1Y),#2=(U2X,U2Y). C The convention is that E1 <= E2. C R=SQRT(((E11-E22)/2.)**2+E12**2) C=(E11+E22)/2. E1=C-R E2=C+R SCALE=MAX(ABS(E1),ABS(E2)) TEST=0.01*SCALE IF ((ABS(E12).GT.TEST).OR.(ABS(E11-E1).GT.TEST)) THEN THETA=ATAN2F(E11-E1, -E12) ELSE THETA=ATAN2F(E12, E1-E22) ENDIF U1X=COS(THETA) U1Y=SIN(THETA) U2X=U1Y U2Y= -U1X RETURN END C C C SUBROUTINE PRINTK (INPUT,F,IUNITT,ITER,K, + MXDOF,NDOF,NLB,NUB) C C Prints out the K matrix and F vector for debugging purposes. C Typically, it must be printed in blocks and pasted together. C C Note: This debugging routine is the *only* one which is not C standard Fortran77. It uses internal WRITEs (to text variables) C to FORMAT INTEGERs and DOUBLE-PRECISION numbers into text output. C PARAMETER (NCOL=14) LOGICAL DOIT CHARACTER*4 CNODE4 CHARACTER*7 CNODE7 CHARACTER*9 TEXT DOUBLE PRECISION F,K DIMENSION F(MXDOF) DIMENSION TEXT(NCOL),K(MXWORK) COMMON LDA,NUCA,MXWORK C C Statement function replacing INTEGER FUNCTION subprogram -INDEXK-: INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + NUCA + IROW - JCOLUM + 1 C C Note: 1 CCC + I4 + 'X:' + 14D9.2 = 133 columns. 1 FORMAT( '1',' Block Row',I2,', Block Column',I2/) 10 FORMAT( ' ',4X,2X, 14A9) C 11 FORMAT(/ / / /' ',I4,'X:',1P,14D9.2) C 12 FORMAT( ' ',I4,'Y:',1P,14D9.2) 21 FORMAT(/ / / /' ',I4,'X:', 14A9) 22 FORMAT( ' ',I4,'Y:', 14A9) C WRITE(6,23) ITER 23 FORMAT(' ITERATION ',I5) NBLOCK=(NDOF+2)/NCOL IF ((NDOF+2).GT.NCOL*NBLOCK) NBLOCK=NBLOCK+1 DO 100 IRB=1,NBLOCK DO 90 JCB=1,NBLOCK I2=NCOL*IRB I1=I2-NCOL+1 J2=NCOL*JCB J1=J2-NCOL+1 DOIT=(I1.LE.NDOF) .AND. + ( (J2.GT.NDOF) .OR. + ((J2.GE.(I1-NLB)).AND.(J1.LE.(I2+NUB))) ) IF (.NOT. DOIT) GO TO 90 C C Write header for each block (page): C WRITE (IUNITT,1) IRB,JCB C C Prepare and write headers over the columns C DO 60 J=J1,J2 M=J-J1+1 IF (J.LE.NDOF) THEN MODE=(J+1)/2 WRITE (CNODE7,'(I7)') MODE IF (MOD(J,2).EQ.1) THEN TEXT(M)=CNODE7//'X:' ELSE TEXT(M)=CNODE7//'Y:' ENDIF ELSE TEXT(M)=' ' ENDIF 60 CONTINUE WRITE (IUNITT,10) (TEXT(L),L=1,NCOL) DO 80 I=I1,I2 C C Prepare text of a line within the system of equations C NODE=(I+1)/2 IF (I.LE.NDOF) THEN DO 70 J=J1,J2 M=J-J1+1 IF (J.LE.NDOF) THEN IF ((J.GE.(I-NLB)).AND.(J.LE.(I+NUB))) THEN WRITE(TEXT(M),'(1P,D9.2)') K(INDEXK(I,J)) ELSE TEXT(M)=' ------- ' ENDIF ELSE IF (J.EQ.(NDOF+1)) THEN WRITE (CNODE4,'(I4)') NODE IF (MOD(I,2).EQ.1) THEN TEXT(M)=' *'//CNODE4//'X =' ELSE TEXT(M)=' *'//CNODE4//'Y =' ENDIF ELSE IF (J.EQ.(NDOF+2)) THEN WRITE(TEXT(M),'(1P,D9.2)') F(I) ELSE TEXT(M)=' ' ENDIF 70 CONTINUE C C Actually print the line: C IF (MOD(I,2).EQ.1) THEN WRITE (IUNITT,21) NODE,(TEXT(L),L=1,NCOL) ELSE WRITE (IUNITT,22) NODE,(TEXT(L),L=1,NCOL) ENDIF ENDIF 80 CONTINUE 90 CONTINUE 100 CONTINUE WRITE (IUNITT,101) 101 FORMAT('1----------------------------------------------------', + '---------------------------') RETURN END C C C SUBROUTINE PURE (INPUT,ACREEP,ALPHAT,AREA, + BASAL,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,CONTIN,DCREEP, + delta_rho,DETJ,DQDTDA,DXS,DYS, + ECREEP,ELEV,ETAMAX, + EVERYP,FBASE,FDIP,FFRIC,FLEN,FMUMAX, + FPFLT,FPSFER,FARG,GEOTHC,GEOTHM,GLUE, + GMEAN,ICOND,ICONVE,IUNITI,IUNITS,IUNITT, + MAXITR,MXBN,MXDOF,MXEL,MXFEL, + MXNODE,NCOND,NDOF,NFL,NLB,NODCON, + NODEF,NODES,NUB,NUMEL,NUMNOD,OFFMAX, + OFFSET,OKTOQT,ONEKM,OVB,PULLED, + RADIO,RADIUS,RHOBAR,RHOH2O,SITA,SLIDE, + SPHERE,TAUMAX,TEMLIM,TITLE1, + TITLE2,TITLE3,TLINT,TLNODE,TRHMAX, + TSURF,VBCARG,VBCMAG,VISMAX,WEDGE, + XNODE,YNODE,ZMNODE,ZMOHO,LASTPM, + MODIFY,V, + OUTPUT,ERATE,ETA,FIMUDZ,FPEAKS,FSLIPS, + SIGHB,TAUMAT,ZTRANC,ZTRANF, + WORK,ALPHA,DV,DVLAST,F,FC,FTSTAR, + OUTVEC,K,TOFSET) C C Create and solve thin-plate version of equilibrium to determine C horizontal velocity components (using iteration to handle C nonlinearities). C DOUBLE PRECISION BASAL,F,FBASE,K,V CHARACTER*80 TITLE1,TITLE2,TITLE3 C C Note: In VS-Fortran, following type could be LOGICAL*1: LOGICAL FSLIPS,PULLED C LOGICAL CONTIN,EVERYP,SPHERE,VALID DIMENSION ALPHA(3,3,7,MXEL),AREA(MXEL), + BASAL(2,MXNODE), + CONTIN(7,MXEL), + delta_rho(7,MXEL),DETJ(7,MXEL), + DQDTDA(MXNODE), + DXS(2,2,3,7,MXEL),DYS(2,2,3,7,MXEL), + DV(2,MXNODE),DVLAST(2,MXNODE), + ELEV(MXNODE),ERATE(3,7,MXEL), + ETA(7,MXEL),F(MXDOF),FBASE(MXDOF),FC(2,2,7,MXFEL), + FDIP(2,MXFEL),FIMUDZ(7,MXFEL), + FLEN(MXFEL),FPEAKS(2,MXFEL), + FPFLT(2,2,2,7,MXFEL), + FPSFER(2,2,3,7,MXEL),FSLIPS(MXFEL), + FARG(2,MXFEL),FTSTAR(2,7,MXFEL), + GEOTHC(4,7,MXEL),GEOTHM(4,7,MXEL),GLUE(7,MXEL), + ICOND(MXBN),K(MXWORK),NODCON(MXBN), + NODEF(4,MXFEL),NODES(3,MXEL),OFFSET(MXFEL), + OUTVEC(2,7,MXEL),OVB(2,7,MXEL),PULLED(7,MXEL), + SIGHB(2,7,MXEL),SITA(7,MXEL),TAUMAT(3,7,MXEL), + TAUMAX(2),TOFSET(3,7,MXEL),TLINT(7,MXEL), + TLNODE(MXNODE),VBCARG(MXBN), + VBCMAG(MXBN),V(2,MXNODE),XNODE(MXNODE), + YNODE(MXNODE),ZMNODE(MXNODE),ZMOHO(7,MXEL), + ZTRANC(2,7,MXEL),ZTRANF(2,MXFEL) DIMENSION ACREEP(2), ALPHAT(2), BCREEP(2), CCREEP(2), CONDUC(2), + DCREEP(2), RADIO(2), RHOBAR(2), TEMLIM(2) COMMON LDA,NUCA,MXWORK C IF (LASTPM.NE.999) THEN WRITE(IUNITT,1) 1 FORMAT(' WRONG NUMBER OF ARGUMENTS IN CALL TO PURE!') CALL PAUSE() STOP ENDIF C C Initialize strain rate and vertical integrals of relative stress C for the triangular continuum elements: C CALL EDOT (INPUT,DXS,DYS, + FPSFER,MXEL, + MXNODE,NODES,NUMEL,RADIUS,SITA,V, + OUTPUT,ERATE) DO 20 M=1,7 DO 10 I=1,NUMEL SIGHB(1,M,I)=0. SIGHB(2,M,I)=0. TAUMAT(1,M,I)=0. TAUMAT(2,M,I)=0. TAUMAT(3,M,I)=0. 10 CONTINUE 20 CONTINUE C CALL VISCOS (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,DCREEP,delta_rho,ECREEP, + ERATE,CFRIC,GMEAN,GEOTHC,GEOTHM, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,TLINT, + VISMAX,ZMOHO, + OUTPUT,ALPHA,SCOREC,SCORED,TOFSET,ZTRANC) C CALL TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) C C Initialize slip rate and vertical integrals of relative stress C for the linear fault elements C DO 30 I=1,NFL ZTRANF(1,I)=(ZMNODE(NODEF(1,I))+ + ZMNODE(NODEF(2,I)))/6. ZTRANF(2,I)=(TLNODE(NODEF(1,I))+ + TLNODE(NODEF(2,I)))/6. 30 CONTINUE CALL MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DQDTDA, + ECREEP,ELEV,FDIP,FFRIC,FMUMAX, + FPFLT,FARG,GMEAN, + MXFEL,MXNODE,NFL,NODEF, + OFFMAX,OFFSET, + ONEKM,RADIO,RHOH2O,RHOBAR, + SLIDE,SPHERE,TAUMAX, + TLNODE,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) C C Create "iteration permit" file C OPEN (UNIT=IUNITI,FILE='iteration permit.txt') WRITE (IUNITI,98) 98 FORMAT('If you delete this file, Shells will' + /'stop at the end of the next iteration' + /'and report the current unconverged solution.') CLOSE (UNIT=IUNITI) C C Major Iteration Loop of the Entire Program !!!!! C WRITE (*,99) WRITE (IUNITT,99) 99 FORMAT (/ /' Iteration history:'/ +' ', +' Relative'/ +' ', +' Corre- Maximum mean'/ +' ', +' Relative lation vertically vertically'/ +' ', +' Maximum mean with integrated integrated'/ +' Iter- ', +' RMS velocity velocity last stress stress'/ +' ation ve', +'locity change change change error error'/) C DO 1000 ITER=1,MAXITR MEMORY=ITER CALL THONB (INPUT,BASAL,ECREEP,ETAMAX, + FPSFER,GLUE,ICONVE, + MXEL,MXNODE,NODES,NUMEL, + OVB,PULLED,TRHMAX,V, + OUTPUT,ETA,SIGHB, + WORK,OUTVEC) CALL VISCOS (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,DCREEP,delta_rho,ECREEP, + ERATE,CFRIC,GMEAN,GEOTHC,GEOTHM, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,TLINT, + VISMAX,ZMOHO, + OUTPUT,ALPHA,SCOREC,SCORED,TOFSET,ZTRANC) CALL MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DQDTDA, + ECREEP,ELEV,FDIP,FFRIC,FMUMAX, + FPFLT,FARG,GMEAN, + MXFEL,MXNODE,NFL,NODEF, + OFFMAX,OFFSET, + ONEKM,RADIO,RHOH2O,RHOBAR, + SLIDE,SPHERE,TAUMAX, + TLNODE,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) IF (ITER.GT.1) THEN IPRINT=ITER-1 IF (IPRINT.EQ.1) THEN WRITE(*,101)IPRINT,VRMS, + SCOREA,SCOREB,SCOREC,SCORED WRITE(IUNITT,101)IPRINT,VRMS, + SCOREA,SCOREB,SCOREC,SCORED 101 FORMAT(' ',I5,1P,E14.6,E12.4,0P,F9.6,' ----', + 1P,E12.4,0P,F11.6) ELSE WRITE(*,102)IPRINT,VRMS, + SCOREA,SCOREB,DVCORR,SCOREC,SCORED WRITE(IUNITT,102)IPRINT,VRMS, + SCOREA,SCOREB,DVCORR,SCOREC,SCORED 102 FORMAT(' ',I5,1P,E14.6,E12.4,0P,F9.6,F7.2, + 1P,E12.4,0P,F11.6) END IF ENDIF DO 110 I=1,NUMNOD DVLAST(1,I)=DV(1,I) DVLAST(2,I)=DV(2,I) 110 CONTINUE CALL FEM (INPUT,ALPHA,AREA,CONSTR,DETJ, + DXS,DYS,ETA, + EVERYP,FBASE,FC,FDIP, + FIMUDZ,FLEN,FPFLT,FPSFER,FARG, + FTSTAR,ICOND,ITER,IUNITS,IUNITT, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + NCOND,NDOF,NFL,NLB,NODCON,NODEF, + NODES,NUB,NUMEL,NUMNOD, + OVB,PULLED,RADIUS,SITA, + TITLE1,TITLE2,TITLE3,TOFSET,TRHMAX, + VBCARG,VBCMAG,WEDGE,XNODE, + YNODE,999, + MODIFY,ERATE,V, + OUTPUT,DV,SCOREA,SCOREB,TAUMAT, + WORK,F,K) VRMS=0. DO 105 I=1,NUMNOD VRMS=VRMS+V(1,I)**2+V(2,I)**2 105 CONTINUE VRMS=SQRT(VRMS/(1.*NUMNOD)) IF (ITER.GE.2) THEN SUMN=0. SUMD=0. DO 107 I=1,NUMNOD SIZE1=SQRT(DV(1,I)**2+DV(2,I)**2) SIZE2=SQRT(DVLAST(1,I)**2+DVLAST(2,I)**2) SUMN=SUMN+DV(1,I)*DVLAST(1,I)+ + DV(2,I)*DVLAST(2,I) SUMD=SUMD+SIZE1*SIZE2 107 CONTINUE IF (SUMD.GT.0.) THEN DVCORR=SUMN/SUMD ELSE DVCORR=0. END IF END IF IF (SCOREB.LE.OKTOQT) THEN WRITE(*,109) ITER,VRMS,SCOREA,SCOREB,DVCORR WRITE(IUNITT,109) ITER,VRMS,SCOREA,SCOREB,DVCORR 109 FORMAT(' ',I5,1P,E14.6,E12.4,0P,F9.6,F7.2) WRITE (*,998) WRITE (IUNITT,998) 998 FORMAT (' CONVERGED !!!!!!!!!!!!!!!!!!!!!!!!!', + '!!!!!!!!!!!!!!!!!!!!!!!!!!') C open file again just in order to delete it: OPEN (UNIT=IUNITI,FILE='iteration permit.txt', + STATUS='OLD',IOSTAT=IOS) CLOSE (UNIT=IUNITI,STATUS='DELETE') RETURN ENDIF C C Check whether iteration permit still exists: C OPEN (UNIT=IUNITI,FILE='iteration permit.txt',STATUS='OLD', + IOSTAT=IOS) VALID=(IOS.EQ.0) IF (VALID) CLOSE (UNIT=IUNITI) IF (.NOT.VALID) GO TO 1001 C 1000 CONTINUE 1001 WRITE(*,109) MEMORY,VRMS,SCOREA,SCOREB,DVCORR WRITE(IUNITT,109) MEMORY,VRMS,SCOREA,SCOREB,DVCORR IF (VALID) THEN WRITE(*,1002) WRITE(IUNITT,1002) 1002 FORMAT(' ITERATION LIMIT REACHED BEFORE CONVERGENCE.') C open file again just in order to delete it: OPEN (UNIT=IUNITI,FILE='iteration permit.txt',STATUS='OLD', + IOSTAT=IOS) CLOSE (UNIT=IUNITI,STATUS='DELETE') ELSE WRITE(*,1003) WRITE(IUNITT,1003) 1003 FORMAT(' ITERATION WAS STOPPED BY OPERATOR.') END IF RETURN END C C C SUBROUTINE READBC(INPUT,BRIEF,FDIP,IPVREF,IUNITB,IUNITD,IUNITT, + MXBN,MXFEL,MXNODE,NAMES,NCOND,NFL,NODCON, + NODEF,NPLATE,NREALN,NUMNOD,N1000,OMEGA, + RADIUS,SAVTAG,SLIDE,SPHERE,TRHMAX,XNODE, + YNODE, + OUTPUT,ICOND,TITLE2,VBCARG,VBCMAG, + WORK,IEDGE,R2EDGE,XEDGE,YEDGE) C C Read in velocity boundary conditions from unit IUNITB, C with comments output to device IUNITT. C One option is to have the velocity boundary conditions set by C subprogram -EDGEVS-, which would read unit IUNITD. C CHARACTER*80 TITLE2 CHARACTER*2 NAMES, NAMTAG, SAVTAG INTEGER IOS, IOTHER LOGICAL ALLOK,BRIEF,READIT,SPHERE DIMENSION FDIP(2,MXFEL),ICOND(MXBN),IEDGE(MXBN),NODCON(MXBN), + NODEF(4,MXFEL),R2EDGE(MXBN),SAVTAG(MXBN), + VBCARG(MXBN),VBCMAG(MXBN), + XEDGE (MXBN),YEDGE (MXBN), + XNODE(MXNODE),YNODE(MXNODE) DIMENSION NAMES (NPLATE), OMEGA (3,NPLATE) C WRITE (*,10) IUNITB IF (.NOT.BRIEF) WRITE (IUNITT,10) IUNITB 10 FORMAT(/ /' Attempting to read boundary conditions from unit', + I3/) TITLE2=' '// + ' ' READ (IUNITB,12,IOSTAT=IOS) TITLE2 IF (IOS.NE.0) THEN WRITE(*,11) 11 FORMAT(' ERR','OR in READBC: File is empty, too short, or' + /' defective in its format.') CALL PAUSE() STOP END IF 12 FORMAT (A80) IF (.NOT.BRIEF) WRITE (IUNITT,15) TITLE2 15 FORMAT (/' Title for set of boundary conditions ='/' ',A80) C ALLOK=.TRUE. NFIXED=0 READIT=.FALSE. C C During first pass, don't print table entries (incomplete) C C Begin indefinate loop (at least NCOND entries required, but up to C NUMNOD entries might appear! C I=0 30 I=I+1 IF (I.LE.NCOND) THEN NODEXP=NODCON(I) ELSE NODEXP=0 END IF READ (IUNITB,*,IOSTAT=IOS,END=100) NUMBER,NODE,ICOND(I) IF (IOS.EQ.24) GO TO 100 C (jumping out of loop due to EOF condition) IF (IOS.NE.0) THEN WRITE(*,11) CALL PAUSE() STOP END IF IF (NUMBER.NE.I) THEN WRITE (IUNITT,40) NUMBER, I 40 FORMAT (' ILLEGAL ORDERING OF BOUNDARY CONDITIONS:'/ + ' READ CONDITION #',I6,' WHEN EXPECTING #',I6,'.'/ + ' SUGGESTION: EDIT LOG FILE TABLE TO MAKE B.C. FILE.') ALLOK=.FALSE. ENDIF IF (NODE.GT.NREALN) NODE=NREALN+(NODE-N1000) IF ((NODE.LE.0).OR.(NODE.GT.NUMNOD)) THEN IF (NODE.GT.NREALN) NODE=N1000+(NODE-NREALN) WRITE(IUNITT,45) NODE 45 FORMAT(' ILLEGAL NODE NUMBER IN BOUNDARY', + ' CONDITIONS:',I6) ALLOK=.FALSE. ENDIF IF ((NODEXP.GT.0).AND.(NODE.NE.NODEXP)) THEN IF (NODE.GT.NREALN) NODE=N1000+(NODE-NREALN) IF (NODEXP.GT.NREALN) NODEXP=N1000+(NODEXP-NREALN) WRITE(IUNITT,47) NODE, NODEXP 47 FORMAT(/' BOUNDARY CONDITIONS INPUT IN WRONG ORDER;'/ + ' (SEE LIST PREVIOUSLY WRITTEN IN OUTPUT ABOVE)', + /' ',I6,' WAS READ WHEN EXPECTING ',I6) ALLOK=.FALSE. ENDIF IF (NODEXP.EQ.0) NODCON(I)=NODE IF ((ICOND(I).EQ.0).OR.(ICOND(I).EQ.-1)) THEN C No action needed for free nodes (of either type) ELSE IF (ICOND(I).EQ.1) THEN BACKSPACE IUNITB READ (IUNITB,*) NUMBER,NODE,ICOND(I),VMAG,VAZ NFIXED=NFIXED+1 VBCMAG(I)=VMAG VBCARG(I)=(180.-VAZ)*0.017453293 ELSE IF (ICOND(I).EQ.2) THEN BACKSPACE IUNITB READ (IUNITB,*) NUMBER,NODE,ICOND(I),VMAG,VAZ NFIXED=NFIXED+2 VBCMAG(I)=VMAG VBCARG(I)=(180.-VAZ)*0.017453293 ELSE IF (ICOND(I).EQ.3) THEN READIT=.TRUE. NFIXED=NFIXED+1 ELSE IF (ICOND(I).EQ.4) THEN READIT=.TRUE. NFIXED=NFIXED+2 ELSE IF (ICOND(I).EQ.5) THEN BACKSPACE IUNITB READ (IUNITB,*) NUMBER,NODE,ICOND(I),NAMTAG SAVTAG(I)= NAMTAG CALL EULER (INPUT,NAMTAG,NODE, + IPVREF,NAMES,NPLATE,OMEGA, + IUNITT,RADIUS, + MXNODE,XNODE,YNODE, + OUTPUT,VAZ,VMAG) VBCMAG(I)=VMAG VBCARG(I)=(180.-VAZ)*0.017453293 NFIXED=NFIXED+2 ELSE WRITE(IUNITT,95) ICOND(I) 95 FORMAT(' ILLEGAL TYPE OF BOUNDARY', + ' CONDITION:',I6) ALLOK=.FALSE. ENDIF C C end of indefinate loop: IF (I.LT.NUMNOD) GO TO 30 100 CONTINUE NREAD=I-1 IF (NREAD.LT.NCOND) THEN WRITE(*,11) CALL PAUSE() STOP ELSE IF (NREAD.GT.NCOND) THEN NCOND=MIN(NREAD,NUMNOD) END IF C C Do we need to complete table (by filling in ICOND=3/4 nodes)? C IF (READIT) THEN CALL EDGEVS (INPUT,FDIP,IPVREF,IUNITD,IUNITT,MXBN,MXNODE, + MXFEL,NAMES,NCOND,NFL,NODCON,NODEF, + OMEGA,RADIUS,SLIDE,SPHERE,XNODE,YNODE, + MODIFY,ICOND,VBCARG,VBCMAG, + WORK,IEDGE,R2EDGE,XEDGE,YEDGE) ENDIF C C Now, it's OK to print the table: C IF (.NOT.BRIEF) WRITE (IUNITT,101) NCOND 101 FORMAT(/' There are ',I6,' nodes with boundary conditions.'/ + ' When describing the kind of boundary condition,', + ' the code is:'/ + ' -1 = no velocity constraint (ridge adjacent).'/ + ' 0 = no velocity constraint (weak margin).'/ + ' 1 = fix velocity in specified direction;'/ + ' perpendicular component remains free.'/ + ' 2 = fix velocity in specified direction;'/ + ' perpendicular component set to zero.'/ + ' 3 = fix PB2002 component at PB2002'/ + ' velocity value.'/ + ' 4 = fix both components at PB2002'/ + ' velocity value.'/ + ' 5 = fix velocity to that of named plate;'/ + ' azimuth is also fixed.'// +' BC# Node (E.lon) (N.lat) Code Velocity Azimuth (deg' +,'rees clockwise from North)') C (' ', I6, I6, F8.2, F8.2, I6, 1P,E12.3, 0P,F12.1) DO 200 I=1,NCOND N=NODCON(I) IF (N.LE.NREALN) THEN NODE=N ELSE NODE=N1000+N-NREALN ENDIF THETA=XNODE(N) PHI=YNODE(N) PLON=57.29578*PHI PLAT=90.-THETA*57.29578 IF (ICOND(I).EQ.-1) THEN IF (.NOT.BRIEF) WRITE (IUNITT,159) I, NODE, + PLON, PLAT, ICOND(I) 159 FORMAT(' ',2I6,2F8.2,I6,' FREE',' FREE' + ,' (RIDGE ADJACENT)') ELSE IF (ICOND(I).EQ.0) THEN IF (.NOT.BRIEF) WRITE (IUNITT,160) I, NODE, + PLON, PLAT, ICOND(I) 160 FORMAT(' ',2I6,2F8.2,I6,' FREE',' FREE' + ,' (WEAK MATERIAL ADJACENT)') ELSE IF (ICOND(I).EQ.1) THEN VAZ=180.-VBCARG(I)*57.29578 IF (VAZ.LT.0.) VAZ=VAZ+360. IF (.NOT.BRIEF) WRITE (IUNITT,161) I, NODE, + PLON, PLAT, ICOND(I), VBCMAG(I), VAZ 161 FORMAT(' ',2I6,2F8.2,I6,1P,E12.3,0P,F12.1,' (PERPEN' + ,'DICULAR COMPONENT FREE)') ELSE IF (ICOND(I).EQ.2) THEN VAZ=180.-VBCARG(I)*57.29578 IF (VAZ.LT.0.) VAZ=VAZ+360. IF (.NOT.BRIEF) WRITE (IUNITT,162) I, NODE, + PLON, PLAT, ICOND(I), VBCMAG(I), VAZ 162 FORMAT(' ',2I6,2F8.2,I6,1P,E12.3,0P,F12.1,' (NO ' + ,'PERPENDICULAR COMPONENT)') ELSE IF (ICOND(I).EQ.3) THEN VAZ=180.-VBCARG(I)*57.29578 IF (VAZ.LT.0.) VAZ=VAZ+360. IF (.NOT.BRIEF) WRITE (IUNITT,161) I, NODE, + PLON, PLAT, ICOND(I), VBCMAG(I), VAZ ELSE IF (ICOND(I).EQ.4) THEN VAZ=180.-VBCARG(I)*57.29578 IF (VAZ.LT.0.) VAZ=VAZ+360. IF (.NOT.BRIEF) WRITE (IUNITT,162) I, NODE, + PLON, PLAT, ICOND(I), VBCMAG(I), VAZ ELSE IF (ICOND(I).EQ.5) THEN VAZ=180.-VBCARG(I)*57.29578 IF (VAZ.LT.0.) VAZ=VAZ+360. IF (.NOT.BRIEF) WRITE (IUNITT,165) I, NODE, + PLON, PLAT, ICOND(I), SAVTAG(I), VBCMAG(I), VAZ 165 FORMAT(' ',2I6,2F8.2,I3,':',A2,1P,E12.3,0P,F12.1, + ' (NO PERPENDICULAR COMPONENT)') ENDIF 200 CONTINUE C IF ((NFIXED.LT.3).AND.(.NOT.SPHERE).AND.(TRHMAX.LE.0.0)) THEN ALLOK=.FALSE. WRITE (IUNITT,901) NFIXED 901 FORMAT (/' INSUFFICIENT BOUNDARY CONDITIONS.'/ + ' EVERY PROBLEM REQUIRES THAT AT LEAST 3 DEGREES', + ' OF FREEDOM BE CONSTRAINED,'/ + ' TO PREVENT NONUNIQUENESS OF THE SOLUTION WITH'/ + ' RESPECT TO TRANSLATION AND/OR ROTATION.'/ + ' YOU HAVE CONSTRAINED ONLY',I2,' DEGREES OF', + ' FREEDOM;'/' ADD MORE CONSTRAINED NODES.') ENDIF IF (.NOT. ALLOK) THEN CALL PAUSE() STOP END IF C IF (.NOT. BRIEF) WRITE (IUNITT,999) 999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE READN (INPUT,IUNITP,IUNITT,N, + OUTPUT,VECTOR) C C A utility routine designed to permis -Faults- input files C to also be used by -Plates-, which expects more numbers C in some records. C This routine attempts to READ N floating-point values C (using * FORMAT) from the next record on devide IUNITP. C If anything goes wrong, the missing values are set to zero. C Since June 2005, this feature also allows the reading of C both old-format (OrbData) .feg files (with 4 nodal data), C and new-format (OrbData5) .feg files (with 6 nodal data), C by program -Shells-. C CHARACTER*1 C CHARACTER*132 LINE LOGICAL ANYIN,DOTTED,EXPON,SIGNED DIMENSION VECTOR(N) C LINE=' '// + ' ' READ (IUNITP,1) LINE 1 FORMAT (A) C NUMBER=0 ANYIN=.FALSE. EXPON=.FALSE. SIGNED=.FALSE. DOTTED=.FALSE. DO 10 I=1,132 C=LINE(I:I) IF ((C.EQ.' ').OR.(C.EQ.',').OR.(C.EQ.'/')) THEN SIGNED=.FALSE. EXPON=.FALSE. DOTTED=.FALSE. IF (ANYIN) THEN NUMBER=NUMBER+1 ANYIN=.FALSE. ENDIF ELSE IF ((C.EQ.'+').OR.(C.EQ.'-')) THEN IF (SIGNED) THEN GO TO 50 ELSE SIGNED=.TRUE. ENDIF ELSE IF ((C.EQ.'E').OR.(C.EQ.'D').OR. + (C.EQ.'e').OR.(C.EQ.'d')) THEN IF (EXPON) THEN GO TO 50 ELSE EXPON=.TRUE. SIGNED=.FALSE. DOTTED=.TRUE. ENDIF ELSE IF (C.EQ.'.') THEN IF (DOTTED) THEN GO TO 50 ELSE DOTTED=.TRUE. ENDIF ELSE IF ((C.EQ.'0').OR.(C.EQ.'1').OR.(C.EQ.'2').OR. + (C.EQ.'3').OR.(C.EQ.'4').OR.(C.EQ.'5').OR. + (C.EQ.'6').OR.(C.EQ.'7').OR.(C.EQ.'8').OR. + (C.EQ.'9')) THEN SIGNED=.TRUE. ANYIN=.TRUE. ELSE GO TO 50 ENDIF 10 CONTINUE IF (ANYIN) NUMBER=NUMBER+1 C 50 IF (NUMBER.EQ.0) THEN WRITE (IUNITT,91) N,LINE 91 FORMAT (/' ERR0R: A LINE OF PARAMETER INPUT WHICH', + ' WAS SUPPOSED TO CONTAIN 1-',I2,' NUMBERS'/ + ' COULD NOT BE INTERPRETED. LINE FOLLOWS:'/ + ' ',A80) CALL PAUSE() STOP ELSE NUMBER=MIN(NUMBER,N) BACKSPACE IUNITP READ (IUNITP,*) (VECTOR(I),I=1,NUMBER) IF (NUMBER.LT.N) THEN DO 99 I=NUMBER+1,N VECTOR(I)=0. 99 CONTINUE ENDIF ENDIF RETURN END C C C SUBROUTINE READPM (INPUT,IUNIT7, IUNIT8, NAMES , NUMPLT, OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT , + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , GMEAN , + GRADIE, ICONVE, IPVREF, + MAXITR, OKDELV, OKTOQT, ONEKM, RADIO , + RADIUS, REFSTR, RHOAST, RHOBAR, RHOH2O, + TADIAB, TAUMAX, TEMLIM, TITLE3, + TRHMAX, TSURF, VTIMES, ZBASTH) C C Reads strategic and tactical input parameters from device IUNIT7, C and echoes them on device IUNIT8 with annotations. C CHARACTER*2 NAMES,PLTREF CHARACTER*80 TITLE3 LOGICAL EVERYP DIMENSION ACREEP(2),ALPHAT(2),BCREEP(2),CCREEP(2),CONDUC(2), + DCREEP(2),NAMES(NUMPLT),RADIO(2), + RHOBAR(2),TAUMAX(2),TEMLIM(2),TEMPV(2),VECTOR(2) C WRITE (*,1) IUNIT7 1 FORMAT(//' Attempting to read input parameter file', + ' from unit ',I3/) TITLE3=' '// + ' ' READ (IUNIT7,2,IOSTAT=IOS) TITLE3 IF (IOS.NE.0) THEN WRITE(*,"(' ERR','OR: File not found, or file is empty,' + /' or file is too short.')") CALL PAUSE() STOP END IF 2 FORMAT (A80) WRITE (IUNIT8,3) TITLE3 3 FORMAT (/' [OMIT from iXXX.in] Title of parameter set ='/' ',A80) C WRITE (IUNIT8,4) 4 FORMAT (' [OMIT from iXXX.in]' + /' [OMIT from iXXX.in]', + ' **************************************************' + /' [OMIT from iXXX.in]', + ' It is the user''s responsibility to input all of the' + /' [OMIT from iXXX.in]', + ' following numerical quantities in consistent units,' + /' [OMIT from iXXX.in]', + ' such as Systeme International (SI) or cm-g-s (cgs).' + /' [OMIT from iXXX.in]', + ' Note that time unit must be the second (hard-coded).' + /' [OMIT from iXXX.in]', + ' **************************************************' + /' [OMIT from iXXX.in]' + /' [OMIT from iXXX.in]', + ' ========== Strategic parameters (define the real', + '-Earth problem) ======' + /' [OMIT from iXXX.in]') C READ (IUNIT7,*,IOSTAT=IOS) FFRIC IF (IOS.NE.0) THEN WRITE(*,"(' ERR','OR: File not found, or file is empty,' + /' or file is too short.')") CALL PAUSE() STOP END IF WRITE (IUNIT8,20) FFRIC 20 FORMAT (' ',11X,F10.3,' FFRIC = coefficient of friction on', + ' faults') IF (FFRIC.LT.0.) THEN WRITE (*,21) WRITE (IUNIT8,21) 21 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' negative fault friction FFRIC is not physical.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) CFRIC WRITE (IUNIT8,30) CFRIC 30 FORMAT (' ',11X,F10.3,' CFRIC = coefficient of friction within', +' blocks') IF (CFRIC.LE.0.) THEN WRITE (*,31) WRITE (IUNIT8,31) 31 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' continuum friction CFRIC must be positive.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) BIOT WRITE (IUNIT8,40) BIOT 40 FORMAT (' ',11X,F10.4,' BIOT = effective-pressure coefficient', + ' of Biot: 0. (dry) to 1. (wet)') IF ((BIOT.LT.0.).OR.(BIOT.GT.1.)) THEN WRITE (*,41) WRITE (IUNIT8,41) 41 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' BIOT coefficient must be in range 0.0 to 1.0.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) BYERLY IF (OFFMAX.GT.0.) THEN WRITE (IUNIT8,43) BYERLY 43 FORMAT (' ',11X,F10.4,' BYERLY coefficient (0. to 0.999) ='/ + 11X,' fractional friction reduction on master', + ' fault'/ + 11X,' (Other faults have less reduction, in', + ' proportion to'/ + 11X,' their total past offsets)') IF ((BYERLY.LT.0.).OR.(BYERLY.GT.1.)) THEN WRITE (*,44) WRITE (IUNIT8,44) 44 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' BYERLY coefficient must be in range 0.0 to' + ,' 1.0.') CALL PAUSE() STOP END IF ELSE WRITE (IUNIT8,46) BYERLY 46 FORMAT (' ',11X,F10.4,' BYERLY coefficient (not used in', + ' this run, as all fault offsets are zero).') ENDIF C CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,ACREEP) WRITE (IUNIT8,50) ACREEP(1),ACREEP(2) 50 FORMAT (' ',1P, E10.2,' ',E10.2,' ACREEP = A for creep = ', + 'pre-exponential shear', + ' stress constant for creep. (crust/mantle)') IF ((ACREEP(1).LE.0.).OR.(ACREEP(2).LE.0.)) THEN WRITE (*,51) WRITE (IUNIT8,51) 51 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' ACREEP must be positive in each layer.') CALL PAUSE() STOP END IF C CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,BCREEP) WRITE (IUNIT8,60) BCREEP(1),BCREEP(2) 60 FORMAT (' ',F10.0,' ',F10.0,' BCREEP = B for creep =', + ' activation_energy/R/n', + ' (in K). (crust/mantle)') IF ((BCREEP(1).LT.0.).OR.(BCREEP(2).LT.0.)) THEN WRITE (*,61) WRITE (IUNIT8,61) 61 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' Negative BCREEP in either layer is unphysical.') CALL PAUSE() STOP END IF C CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,CCREEP) WRITE (IUNIT8,70) CCREEP(1),CCREEP(2) 70 FORMAT (' ',1P, E10.2,' ',E10.2,' CCREEP = C for creep = rho*', + 'g*V_star*ECREEP/R (in K/m). (crust/mantle)') IF ((CCREEP(1).LT.0.).OR.(CCREEP(2).LT.0.)) THEN WRITE (*,71) WRITE (IUNIT8,71) 71 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' Negative CCREEP in either layer is unphysical.') CALL PAUSE() STOP END IF C CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,DCREEP) WRITE (IUNIT8,80) DCREEP(1),DCREEP(2) 80 FORMAT (' ',1P,E10.2,' ',E10.2,' DCREEP = D for creep = max', + 'imum shear stress under any conditions. (crust/mantle)') IF ((DCREEP(1).LE.0.).OR.(DCREEP(2).LE.0.)) THEN WRITE (*,81) WRITE (IUNIT8,81) 81 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' DCREEP must be positive in each layer.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) ECREEP WRITE (IUNIT8,90) ECREEP 90 FORMAT (' ',11X,F10.6,' ECREEP = E for creep = strain-rate expo', + 'nent for creep (1/n). (Same for crust and mantle!)') IF (ECREEP.LE.0.) THEN WRITE (*,91) WRITE (IUNIT8,91) 91 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' ECREEP must be positive.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) TADIAB, GRADIE WRITE (IUNIT8,92) TADIAB, GRADIE 92 FORMAT (' ',F10.0,' ',1P,E10.2,' TADIAB, GRADIE = intercept and ' + ,'slope of upper mantle adiabat below plate (K, K/m)') IF ((TADIAB.LT.0.).OR.(GRADIE.LT.0.)) THEN WRITE (*,93) WRITE (IUNIT8,93) 93 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' Negative Kelvin temperature and/or' + /' negative adiabatic gradient is/are unphysical.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) ZBASTH WRITE (IUNIT8,94) ZBASTH 94 FORMAT (' ',11X,1P,E10.2,' ZBASTH = depth of base of', + ' asthenosphere') IF (ZBASTH.LE.0.) THEN WRITE (*,95) WRITE (IUNIT8,95) 95 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' ZBASTH must be positive.') CALL PAUSE() STOP END IF C READ (IUNIT7,952) PLTREF 952 FORMAT(A2) WRITE (IUNIT8,954) PLTREF 954 FORMAT(' ',A2,'<==================', + ' PLTREF = plate defining velocity ', + 'reference frame (AF, NA, EU, ...)') IPVREF=0 DO 956 I=1,NUMPLT IF (NAMES(I).EQ.PLTREF) IPVREF=I 956 CONTINUE IF (IPVREF.EQ.0) THEN WRITE (*,958) (NAMES(I),I=1,NUMPLT) WRITE (IUNIT8,958) (NAMES(I),I=1,NUMPLT) 958 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' In line 13 (after ZBASTH, before ICONVE),' + /' in the first two columns of the line,' + /' define the velocity reference frame by' + /' entering one of the following plate names:' + /' ',26(A2,1X)) CALL PAUSE() STOP END IF C READ (IUNIT7,*) ICONVE WRITE (IUNIT8,96) ICONVE 96 FORMAT (' ',11X,I10,' ICONVE = code for mantle flow below the ', + 'asthenosphere:' +/' ','[OMIT from iXXX.in] ',' 0 = static (with respect to AF)' +/' ','[OMIT from iXXX.in] ',' 1 = Hager and O''Connell (1979)', + ' Model II' +/' ','[OMIT from iXXX.in] ',' 2 = Baumgardner (1988) Figure', + ' 7A-F, *10.' +/' ','[OMIT from iXXX.in] ',' 3 = PB2002 (Bird, 2003)' +/' ','[OMIT from iXXX.in] ',' 4 = PB2002 drags continents;', + ' no ocean drag' +/' ','[OMIT from iXXX.in] ',' 5 = drag on base of subduction', + ' forearc only' +/' ','[OMIT from iXXX.in] ',' 6 = sense & traction from trac', + 'tion pole vectors' + ) IF ((ICONVE.LT.0).OR.(ICONVE.GT.6)) THEN WRITE (*,97) WRITE (IUNIT8,97) 97 FORMAT (/' *** ERR','OR in input parameter file: ***' + /' ICONVE is not one of the values listed.') CALL PAUSE() STOP END IF IF (ICONVE.GT.0) THEN BACKSPACE IUNIT7 CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,TEMPV) IF (TEMPV(2).GE.0) THEN VTIMES=TEMPV(2) WRITE (IUNIT8,98) VTIMES 98 FORMAT (' ',11X,F10.4,' VTIMES = speed factor for con', + 'vection model identified above') ELSE WRITE (*,99) WRITE (IUNIT8,99) 99 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' Uninterpretable value for VTIMES.') CALL PAUSE() STOP ENDIF ELSE VTIMES=1.0 ENDIF C READ (IUNIT7,*) TRHMAX WRITE (IUNIT8,101) TRHMAX 101 FORMAT (' ',11X,1P,E10.2,' TRHMAX = limit on horizontal', + ' tractions applied to base of plate') IF (TRHMAX.LT.0.) THEN WRITE (*,102) WRITE (IUNIT8,102) 102 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' TRHMAX may not be negative.') CALL PAUSE() STOP END IF C CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,VECTOR) TAUMAX(1)=VECTOR(1) TAUMAX(2)=VECTOR(2) C PROVIDE FOR OLD PARAMETER FILES WITH ONLY ONE TAUMAX: IF (TAUMAX(2).LE.0.0) TAUMAX(2)=TAUMAX(1) WRITE (IUNIT8,106) TAUMAX(1),TAUMAX(2) 106 FORMAT (' ',1P, E10.2,' ',E10.2, + ' TAUMAX = upper limit(s) on subduction zone shear', + ' coupling, integrated down-dip (N/m). One value:', + ' universal. Two values: sea, land.') IF ((TAUMAX(1).LT.0.).OR.(TAUMAX(2).LT.0.)) THEN WRITE (*,107) WRITE (IUNIT8,107) 107 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' TAUMAX may not be negative.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) RHOH2O WRITE (IUNIT8,110) RHOH2O 110 FORMAT (' ',11X,1P,E10.3,' RHOH2O = density of groundwater,', + ' lakes, & oceans') IF (RHOH2O.LT.0.) THEN WRITE (*,111) WRITE (IUNIT8,111) 111 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' RHOH2O may not be negative.') CALL PAUSE() STOP END IF C CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,RHOBAR) WRITE (IUNIT8,120) RHOBAR(1),RHOBAR(2) 120 FORMAT (' ',1P,E10.3,' ',E10.3,' RHOBAR = mean density,', + ' corrected to 0 degrees Kelvin. (crust/mantle)') IF ((RHOBAR(1).LE.0.).OR.(RHOBAR(2).LE.0.)) THEN WRITE (*,121) WRITE (IUNIT8,121) 121 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' RHOBAR must be positive in each layer.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) RHOAST WRITE (IUNIT8,130) RHOAST 130 FORMAT (' ',11X,1P,E10.3,' RHOAST = density of asthenosphere') IF (RHOAST.LE.0.) THEN WRITE (*,131) WRITE (IUNIT8,131) 131 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' RHOAST must be positive.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) GMEAN WRITE (IUNIT8,140) GMEAN 140 FORMAT (' ',11X,1P,E10.3,' GMEAN = mean gravitational', + ' acceleration', + ' (length/s**2)') IF (GMEAN.LE.0.) THEN WRITE (*,141) WRITE (IUNIT8,141) 141 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' GMEAN must be positive.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) ONEKM WRITE (IUNIT8,150) ONEKM 150 FORMAT (' ',11X,1P,E10.3,' ONEKM = number of length units', + ' needed to make 1 kilometer (e.g., 1000. in SI, 1.E5 in cgs)') IF (ONEKM.LE.0.) THEN WRITE (*,151) WRITE (IUNIT8,151) 151 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' ONEKM must be positive.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) RADIUS WRITE (IUNIT8,155) RADIUS 155 FORMAT (' ',11X,1P,E10.3,' RADIUS = radius of the planet') IF (RADIUS.LE.0.) THEN WRITE (*,156) WRITE (IUNIT8,156) 156 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' RADIUS must be positive.') CALL PAUSE() STOP END IF C CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,ALPHAT) WRITE (IUNIT8,160) ALPHAT(1),ALPHAT(2) 160 FORMAT (' ',1P,E10.2,' ',E10.2,' ALPHAT = volumetric thermal', + ' expansion', + ' (1/V)*(dV/dT). (crust/mantle)') IF ((ALPHAT(1).LT.0.).OR.(ALPHAT(2).LT.0.)) THEN WRITE (*,161) WRITE (IUNIT8,161) 161 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' Negative ALPHAT in either layer is unphysical.') CALL PAUSE() STOP END IF C CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,CONDUC) WRITE (IUNIT8,170) CONDUC(1),CONDUC(2) 170 FORMAT (' ',1P,E10.2,' ',E10.2,' CONDUC = thermal conductivity,', + ' energy/length/s/deg. (crust/mantle)') IF ((CONDUC(1).LE.0.).OR.(CONDUC(2).LE.0.)) THEN WRITE (*,171) WRITE (IUNIT8,171) 171 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' CONDUC must be positive in each layer.') CALL PAUSE() STOP END IF C CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,RADIO) WRITE (IUNIT8,180) RADIO(1),RADIO(2) 180 FORMAT (' ',1P,E10.2,' ',E10.2,' RADIO = radioactive heat ', + 'production, energy/volume/s. (crust/mantle)') IF ((RADIO(1).LT.0.).OR.(RADIO(2).LT.0.)) THEN WRITE (*,181) WRITE (IUNIT8,181) 181 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' Negative RADIO in either layer is unphysical.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) TSURF WRITE (IUNIT8,185) TSURF 185 FORMAT (' ',11X,F10.0,' TSURF = surface temperature, on', + ' absolute scale (deg. K)') IF (TSURF.LE.0.) THEN WRITE (*,186) WRITE (IUNIT8,186) 186 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' TSURF must be positive.') CALL PAUSE() STOP END IF C CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,TEMLIM) WRITE (IUNIT8,190) TEMLIM(1),TEMLIM(2) 190 FORMAT (' ',F10.0,' ',F10.0,' TEMLIM = convecting', + ' temperature (Tmax), on absolute scale. (crust/mantle)') IF ((TEMLIM(1).LE.0.).OR.(TEMLIM(2).LE.0.)) THEN WRITE (*,191) WRITE (IUNIT8,191) 191 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' TEMLIM must be positive in each layer.') CALL PAUSE() STOP END IF C WRITE (IUNIT8,199) 199 FORMAT (' [OMIT from iXXX.in]' + /' [OMIT from iXXX.in]', + ' ========== Tactical parameters (How to reach ', + 'the solution?) ==========' + /' [OMIT from iXXX.in]') C READ (IUNIT7,*) MAXITR WRITE (IUNIT8,200) MAXITR 200 FORMAT (' ',11X,I10,' MAXITR = maximum iterations within', + ' velocity solution') IF (MAXITR.LT.1) THEN WRITE (*,201) WRITE (IUNIT8,201) 201 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' MAXITR must be positive.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) OKTOQT WRITE (IUNIT8,210) OKTOQT 210 FORMAT (' ',11X,F10.6,' OKTOQT = acceptable fractional change', + ' in velocity (stops iteration early)') IF (OKTOQT.LT.0.) THEN WRITE (*,211) WRITE (IUNIT8,211) 211 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' OKTOQT may not be negative.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) REFSTR WRITE (IUNIT8,220) REFSTR 220 FORMAT (' ',11X,1P,E10.2,' REFSTR = expected mean value of', + ' shear stress in plate (used to set stiffness limits)') IF (REFSTR.LE.0.) THEN WRITE (*,221) WRITE (IUNIT8,221) 221 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' REFSTR must be positive.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) OKDELV WRITE (IUNIT8,230) OKDELV 230 FORMAT (' ',11X,1P,E10.2,' OKDELV = magnitude of velocity', + ' errors allowed due to finite stiffness' + /' [OMIT from iXXX.in] ', + ' (Such errors may appear in such forms as:' + /' [OMIT from iXXX.in] ', + ' 1. fictitious basal slip of plate over asthenosphere' + /' [OMIT from iXXX.in] ', + ' 2. erroneous convergence/divergence at vertical faults' + /' [OMIT from iXXX.in] ', + ' 3. velocity effect of fictitious viscous compliances' + /' [OMIT from iXXX.in] ', + ' HOWEVER, VALUES WHICH ARE TOO SMALL WILL CAUSE ILL-CONDITIONED' + /' [OMIT from iXXX.in] ', + ' LINEAR SYSTEMS AND STRESS ERR0RS, ', + 'AND MAY PREVENT CONVERGENCE!)' +) IF (OKDELV.LE.0.) THEN WRITE (*,231) WRITE (IUNIT8,231) 231 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' OKDELV must be positive.') CALL PAUSE() STOP END IF C READ (IUNIT7,*) EVERYP WRITE (IUNIT8,240) EVERYP 240 FORMAT (' ',11X,L10,' EVERYP = should nodal velocities be', + ' output in every iteration? (for convergence studies)') C WRITE (IUNIT8,999) 999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE RESULT (INPUT,ALPHAT,AREA,COMP,DETJ,ELEV,ERATE,EVERYP, + FDIP,FFRIC,FIMUDZ,FPFLT, + FPEAKS,FPSFER,FSLIPS,FARG, + GEOTHC,GEOTHM,IUNITQ,IUNITS,IUNITT, + log_node_velocities, + log_element_dynamics, + log_fault_dynamics, + MXDOF,MXEL,MXFEL,MXNODE,NAMES,NFL, + NODEF,NODES,NPLATE,NREALN,NUMEL,NUMNOD, + N1000,ONEKM, + RADIUS,RHOAST,RHOBAR,RHOH2O,SIGHB, + TAUMAT,TAUMAX,TAUZZI,TITLE1,TITLE2, + TITLE3,TLINT,TLNODE, + V,WEDGE,WHICHP,XNODE,YNODE, + ZMNODE,ZMOHO,ZTRANC,ZTRANF, + OUTPUT,TORQBS,TORQCL,TORQFS,TORQLP,TORQMD, + TORQSS,TORQVB) C C Output the solution: C -Node velocities to unit IUNITS, C -Descriptive tables to unit IUNITT: C * nodal velocities table C * element properties table C * fault properties table C * single-plate torque-balance report C CHARACTER*80 TITLE1,TITLE2,TITLE3 LOGICAL EVERYP C C Note: In VS-Fortran, following type could be LOGICAL*1: LOGICAL FSLIPS C CHARACTER*2 :: NAMES INTEGER :: WHICHP LOGICAL :: log_node_velocities LOGICAL :: log_element_dynamics LOGICAL :: log_fault_dynamics DOUBLE PRECISION V DOUBLE PRECISION POINTS,WEIGHT DOUBLE PRECISION TORQBS,TORQCL,TORQFS,TORQLP,TORQMD,TORQSS,TORQVB DOUBLE PRECISION TBSMAG,TCLMAG,TFSMAG,TLPMAG,TSSMAG DOUBLE PRECISION DDOT,DEQUAT,DVEC,LENGTH,SUMNOD REAL LATITU,LONGIT COMMON /S1S2S3/ POINTS COMMON /WGTVEC/ WEIGHT DIMENSION POINTS(3,7),WEIGHT(7) DIMENSION ALPHAT(2),RHOBAR(2),TAUMAX(2) DIMENSION AREA(MXEL), + COMP(6,MXDOF), + DETJ(7,MXEL),DTORQ(3), + ELEV(MXNODE), ERATE(3,7,MXEL),FPFLT(2,2,2,7,MXFEL), + FDIP(2,MXFEL), FIMUDZ(7,MXFEL),FPEAKS(2,MXFEL), + FPSFER(2,2,3,7,MXEL), + FORCE(3),FSLIPS(MXFEL),FARG(2,MXFEL), + GEOTHC(4,7,MXEL), GEOTHM(4,7,MXEL), + NAMES(NPLATE),NODEF(4,MXFEL),NODES(3,MXEL), + SIGHB(2,7,MXEL),SUMNOD(3), + TAUMAT(3,7,MXEL),TAUZZI(7,MXEL), + TLINT(7,MXEL),TLNODE(MXNODE), + TORQBS(3,NPLATE),TORQCL(3,NPLATE),TORQFS(3,NPLATE), + TORQLP(3,NPLATE),TORQMD(3,NPLATE),TORQSS(3,NPLATE), + TORQVB(3,NPLATE), + V(2,MXNODE), + WHICHP(MXNODE), + XNODE(MXNODE),YNODE(MXNODE), + ZMNODE(MXNODE),ZMOHO(7,MXEL), + ZTRANC(2,7,MXEL),ZTRANF(2,MXFEL) C DIMENSIONs of (3) for Cartesian vectors: DIMENSION force_BS(3), force_FS(3), force_LP(3),force_MD(3), + force_SS(3), force_VB(3), + DVEC(3),RVEC(3),TVEC(3),TWISTV(3),UPHI(3),UTHETA(3), + UVEC(3) C IF (.NOT.EVERYP) THEN WRITE (IUNITS,10) TITLE1 WRITE (IUNITS,10) TITLE2 WRITE (IUNITS,10) TITLE3 10 FORMAT (A80) WRITE (IUNITS,20) ((V(K,I),K=1,2),I=1,NUMNOD) 20 FORMAT (1P,4D20.12) ENDIF C------------------------End of report on unit IUNITS--------------- C------------------------Begin writing to unit IUNITT--------------- C C Velocities at nodes: C IF (log_node_velocities) WRITE (IUNITT,30) 30 FORMAT(/ /' Velocities of the nodes:'/ + ' ', + ' Azimuth East North'/ + ' ', + ' (degrees long. lat.'/ + ' Node East-component North-component Magni', + 'tude from North)'/) SUMNOD(1)=0.0D0 SUMNOD(2)=0.0D0 SUMNOD(3)=0.0D0 DO 100 I=1,NUMNOD IP=I IF (I.GT.NREALN) IP=N1000+(I-NREALN) THETA=XNODE(I) PHI=YNODE(I) SUMNOD(1)=SUMNOD(1)+SIN(THETA)*COS(PHI) SUMNOD(2)=SUMNOD(2)+SIN(THETA)*SIN(PHI) SUMNOD(3)=SUMNOD(3)+COS(THETA) PLON=PHI*57.29578 PLAT=90.-THETA*57.29578 VE=V(2,I) VN= -V(1,I) AZIMUT=ATAN2F(VE,VN)*57.2957795 IF (AZIMUT.LT.0.) AZIMUT=AZIMUT+360. VMAG=SQRT(V(1,I)**2+V(2,I)**2) IF (log_node_velocities) WRITE (IUNITT,40) + IP,VE,VN,VMAG,AZIMUT,PLON,PLAT 40 FORMAT(' ',I5,1P,2D20.12,E10.2,0P,3F8.2) 100 CONTINUE C C Triangular continuum element properties at their centers: C IF (log_element_dynamics) WRITE (IUNITT,110) 110 FORMAT (/ /' Continuum element properties (at center points):'/ + /' E1=most E2=most Isostatic Vertic', +'al Vertical Vertical Brittle/ Brittle/ Basal Basal' + /' Element Azimuth compress. extens. uplift integr', +'al integral integral ductile ductile shear shear', + ' East North' + /' number of E1 rate rate rate of(Sz+', +'P0) of(S1+P0) of(S2+P0) in crust in mantle stress azimuth', + ' long. lat.'/) 120 FORMAT (' ',I7,F10.2,1P,8E10.2,E9.1,0P,F9.2,2F8.2) 121 FORMAT (' ',I7,F10.2,1P,7E10.2,' --------',E9.1,0P,F9.2,2F8.2) 122 FORMAT (' ',I7,F10.2,1P,6E10.2,' --------',E10.2,E9.1,0P,F9.2, + 2F8.2) M=1 DO 200 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) CALL PRINCE (INPUT,EXX,EYY,EXY, + OUTPUT,E1,E2,U1X,U1Y,U2X,U2Y) AZIM=180.-ATAN2F(U1Y,U1X)*57.2957795 IF (AZIM.LT.0.) AZIM=AZIM+360. EZZ= -(EXX+EYY) TMID=GEOTHC(1,M,I)+GEOTHC(2,M,I)*ZMOHO(M,I)/2.+ + GEOTHC(3,M,I)*(ZMOHO(M,I)/2.)**2 RHOC=RHOBAR(1)*(1.-ALPHAT(1)*TMID) C C Interpolate height, position to element center: HEIGHT=0. DO 140 L=1,3 TVEC(L)=0. 140 CONTINUE DO 150 K=1,3 N=NODES(K,I) HEIGHT=HEIGHT+ELEV(N)/3. THETA=XNODE(N) PHI=YNODE(N) EQUAT=SIN(THETA) UVEC(1)=EQUAT*COS(PHI) UVEC(2)=EQUAT*SIN(PHI) UVEC(3)=COS(THETA) DO 149 L=1,3 TVEC(L)=TVEC(L)+UVEC(L) 149 CONTINUE 150 CONTINUE EQUAT2=TVEC(1)**2+TVEC(2)**2 IF (EQUAT2.EQ.0.0) THEN PLON=0. IF (TVEC(3).GT.0.) THEN PLAT=90. ELSE PLAT= -90. END IF ELSE EQUAT=SQRT(EQUAT2) PLAT=57.29578*ATAN2F(TVEC(3),EQUAT) PLON=57.29578*ATAN2F(TVEC(2),TVEC(1)) END IF C IF (HEIGHT.GT.0.) THEN FACTOR=(RHOAST-RHOC)/RHOAST ELSE FACTOR=(RHOAST-RHOC)/(RHOAST-RHOH2O) ENDIF VZ=EZZ*ZMOHO(M,I)*FACTOR TXX=TAUMAT(1,M,I)+TAUZZI(M,I) TYY=TAUMAT(2,M,I)+TAUZZI(M,I) TXY=TAUMAT(3,M,I) TZZ=TAUZZI(M,I) CALL PRINCE (INPUT,TXX,TYY,TXY, + OUTPUT,T1,T2,U1X,U1Y,U2X,U2Y) ZTRANS=ZTRANC(1,M,I) SIGHX=SIGHB(1,M,I) SIGHY=SIGHB(2,M,I) STHETA=180.-57.2958*ATAN2F(SIGHY,SIGHX) IF (STHETA.GE.360.) STHETA=STHETA-360. IF (STHETA.LT.0.) STHETA=STHETA+360. SHEAR=SQRT(SIGHX**2+SIGHY**2) IF ((TLINT(M,I).GT.0.).AND. + (ZTRANC(2,M,I).GT.(0.1*ONEKM))) THEN ZTRANM=ZMOHO(M,I)+ZTRANC(2,M,I) IF ((ZTRANS/ZMOHO(M,I)).GT.0.97) THEN IF (log_element_dynamics) + WRITE (IUNITT,122) I,AZIM,E1,E2,VZ, + TZZ,T1,T2, ZTRANM,SHEAR,STHETA, + PLON,PLAT ELSE IF (log_element_dynamics) + WRITE (IUNITT,120) I,AZIM,E1,E2,VZ, + TZZ,T1,T2,ZTRANS,ZTRANM,SHEAR,STHETA, + PLON,PLAT ENDIF ELSE IF (log_element_dynamics) + WRITE (IUNITT,121) I,AZIM,E1,E2,VZ, + TZZ,T1,T2,ZTRANS, SHEAR,STHETA, + PLON,PLAT ENDIF 200 CONTINUE IF (log_element_dynamics) WRITE (IUNITT,210) 210 FORMAT ( + /' The figures above include vertical integrals of', + ' normal stresses through the plate. Compressive' + /' stresses are negative. For convenience, normal stresses are', + ' first corrected using a standard pressure curve' + /' P0(z), based on the structure of mid-ocean spreading', + ' rises (see subprogram -SQUEEZ-).') C C Fault element properties, also at midpoints: C IF (log_fault_dynamics) WRITE (IUNITT,300) 300 FORMAT (/ / /' Fault element properties (at mid-points):'/ + ' ', + ' ', + ' Down-dip Brittle/ Mantle '/ + ' Fault Nodes#1,4 Horiz. Azimuth', + ' Plunge Total Right Perpen. Relative', + ' integral Peak ductile brittle/ Is this '/ + ' element (N1 moves slip of', + ' of slip lateral shortning vertical', + ' of shear shear depth ductile fault '/ + ' number rel.to N4) rate slip', + ' slip rate rate rate rate', + ' traction traction in crust depth plastic?'/) 310 FORMAT (' ',I6,1X,I5,',',I5,1P,E9.2,0P,F10.2,F7.2, + 1P,E9.2,3E10.2,4E9.2,L3,I6) 311 FORMAT (' ',I6,1X,I5,',',I5,1P,E9.2,0P,F10.2,F7.2, + 1P,E9.2,3E10.2,3E9.2,' --------',L3,I6) 312 FORMAT (' ',I6,1X,I5,',',I5,1P,E9.2,0P,F10.2,F7.2, + 1P,E9.2,3E10.2,2E9.2,' --------',E9.2,L3,I6) M=4 DO 400 I=1,NFL DIP=0.5*(FDIP(1,I)+FDIP(2,I)) J1=NODEF(1,I) J2=NODEF(2,I) J3=NODEF(3,I) J4=NODEF(4,I) JM=J1 IF (JM.GT.NREALN) JM=N1000+(JM-NREALN) JB=J4 IF (JB.GT.NREALN) JB=N1000+(JB-NREALN) DU=V(1,J1)*FPFLT(1,1,1,4,I)+V(2,J1)*FPFLT(2,1,1,4,I) + +V(1,J2)*FPFLT(1,1,2,4,I)+V(2,J2)*FPFLT(2,1,2,4,I) + -V(1,J3)*FPFLT(1,1,2,4,I)-V(2,J3)*FPFLT(2,1,2,4,I) + -V(1,J4)*FPFLT(1,1,1,4,I)-V(2,J4)*FPFLT(2,1,1,4,I) DV=V(1,J1)*FPFLT(1,2,1,4,I)+V(2,J1)*FPFLT(2,2,1,4,I) + +V(1,J2)*FPFLT(1,2,2,4,I)+V(2,J2)*FPFLT(2,2,2,4,I) + -V(1,J3)*FPFLT(1,2,2,4,I)-V(2,J3)*FPFLT(2,2,2,4,I) + -V(1,J4)*FPFLT(1,2,1,4,I)-V(2,J4)*FPFLT(2,2,1,4,I) AZIMHS=3.141593-ATAN2F(DV,DU) HORS=SQRT(DU**2+DV**2) C C ANGLE IS THE FAULT STRIKE, IN RADIANS CCLKWS FROM +SITA. C CCCCC ANGLE=0.5*(FARG(1,I)+FARG(2,I)) CCCCC Line above was replaced due to cycle-shift problem C ANGLE=CHORD(FARG(1,I),0.5D0,FARG(2,I)) UNITX=COS(ANGLE) UNITY=SIN(ANGLE) CROSSX= -UNITY CROSSY= +UNITX SINIST=DU*UNITX+DV*UNITY CLOSE=DU*CROSSX+DV*CROSSY IF (ABS(DIP-1.570796).LT.WEDGE) THEN VUPDIP=0. RELV=0. SNET=HORS PLUNGE=0. ELSE VUPDIP=CLOSE/COS(DIP) RELV=VUPDIP*SIN(DIP) SNET=SQRT(HORS**2+RELV**2) PLUNGE= -ASIN(RELV/SNET) ENDIF RLT= -SINIST IF (ABS(DIP-1.570796).LT.WEDGE) THEN SHEAR=FIMUDZ(4,I)*ABS(RLT) ELSE SHEAR=FIMUDZ(4,I)*SNET/SIN(DIP) ENDIF AZIMHS=AZIMHS*57.2957795 IF (AZIMHS.GE.360.) AZIMHS=AZIMHS-360. IF (AZIMHS.LE.-360.) AZIMHS=AZIMHS+360. PLUNGE=PLUNGE*57.2957795 TLAV=0.5*(TLNODE(J1)+TLNODE(J2)) ZMAV=0.5*(ZMNODE(J1)+ZMNODE(J2)) IF ((TLAV.GT.0.).AND. + (ZTRANF(2,I).GT.(0.1*ONEKM))) THEN FPMAX=MAX(FPEAKS(1,I),FPEAKS(2,I)) ZTRANM=ZMAV+ZTRANF(2,I) IF ((ZTRANF(1,I)/ZMAV).GT.0.97) THEN IF (log_fault_dynamics) + WRITE (IUNITT,312) I,JM,JB,HORS,AZIMHS,PLUNGE, + SNET,RLT,CLOSE,RELV,SHEAR,FPMAX, + ZTRANM,FSLIPS(I),I ELSE IF (log_fault_dynamics) + WRITE (IUNITT,310) I,JM,JB,HORS,AZIMHS,PLUNGE, + SNET,RLT,CLOSE,RELV,SHEAR,FPMAX, + ZTRANF(1,I),ZTRANM,FSLIPS(I),I ENDIF ELSE IF (log_fault_dynamics) + WRITE (IUNITT,311) I,JM,JB,HORS,AZIMHS,PLUNGE,SNET, + RLT,CLOSE,RELV,SHEAR,FPEAKS(1,I), + ZTRANF(1,I), FSLIPS(I),I ENDIF 400 CONTINUE IF (log_fault_dynamics) WRITE (IUNITT,401) 401 FORMAT(' ===========================================', + '===========================================') C C----------------Begin writing to units IUNITT & IUNITQ--------------- C C Single-plate torque-balance reports: C C Zero out all torque components, prior to accumulating them: C DO 502 I=1,3 DO 501 J=1,NPLATE TORQBS(I,J)=0.0D0 TORQCL(I,J)=0.0D0 TORQFS(I,J)=0.0D0 TORQLP(I,J)=0.0D0 TORQMD(I,J)=0.0D0 TORQSS(I,J)=0.0D0 TORQVB(I,J)=0.0D0 501 CONTINUE 502 CONTINUE C C Build torque components from info in COMP: C DO 510 I=1,NUMNOD C C Subscript accounting: C IPLATE=WHICHP(I) IX=2*I-1 IY=2*I C C Consistent nodal forces in (theta,phi) coordinates: C C Basal Strength (2 components, and sum): FMDX=COMP(5,IX) FMDY=COMP(5,IY) FVBX=COMP(6,IX) FVBY=COMP(6,IY) FBSX=COMP(5,IX)+COMP(6,IX) FBSY=COMP(5,IY)+COMP(6,IY) C C Fault Strength FFSX=COMP(3,IX) FFSY=COMP(3,IY) C C Lithostatic Pressure (sum of fault and basal): FLPX=COMP(2,IX)+COMP(4,IX) FLPY=COMP(2,IY)+COMP(4,IY) C C (N.B. Sum of these consistent nodal forces C should be equal to COMP(1).) C C Uvec of the node: C TTHETA=XNODE(I) PPHI=YNODE(I) EQUAT=SIN(TTHETA) UVEC(1)=EQUAT*COS(PPHI) UVEC(2)=EQUAT*SIN(PPHI) UVEC(3)=COS(TTHETA) C C Unit vectors at this site (NOT a pole): UPHI(1)= -UVEC(2) UPHI(2)=UVEC(1) UPHI(1)=UPHI(1)/EQUAT UPHI(2)=UPHI(2)/EQUAT UPHI(3)=0.0 TEQUAT=UVEC(3) UTHETA(3)= -EQUAT UTHETA(1)=TEQUAT*UVEC(1)/EQUAT UTHETA(2)=TEQUAT*UVEC(2)/EQUAT LENGTH=SQRT(UTHETA(1)**2+UTHETA(2)**2+UTHETA(3)**2) UTHETA(1)=UTHETA(1)/LENGTH UTHETA(2)=UTHETA(2)/LENGTH UTHETA(3)=UTHETA(3)/LENGTH C C Consistent nodal forces in (x,y,z): C force_MD(1)=FMDX*UTHETA(1)+FMDY*UPHI(1) force_MD(2)=FMDX*UTHETA(2)+FMDY*UPHI(2) force_MD(3)=FMDX*UTHETA(3)+FMDY*UPHI(3) C force_VB(1)=FVBX*UTHETA(1)+FVBY*UPHI(1) force_VB(2)=FVBX*UTHETA(2)+FVBY*UPHI(2) force_VB(3)=FVBX*UTHETA(3)+FVBY*UPHI(3) C force_BS(1)=FBSX*UTHETA(1)+FBSY*UPHI(1) force_BS(2)=FBSX*UTHETA(2)+FBSY*UPHI(2) force_BS(3)=FBSX*UTHETA(3)+FBSY*UPHI(3) C force_FS(1)=FFSX*UTHETA(1)+FFSY*UPHI(1) force_FS(2)=FFSX*UTHETA(2)+FFSY*UPHI(2) force_FS(3)=FFSX*UTHETA(3)+FFSY*UPHI(3) C force_LP(1)=FLPX*UTHETA(1)+FLPY*UPHI(1) force_LP(2)=FLPX*UTHETA(2)+FLPY*UPHI(2) force_LP(3)=FLPX*UTHETA(3)+FLPY*UPHI(3) C C Nodal forces x moment arms: C RVEC(1)=RADIUS*UVEC(1) RVEC(2)=RADIUS*UVEC(2) RVEC(3)=RADIUS*UVEC(3) C TORQMD(1,IPLATE)=TORQMD(1,IPLATE)+ + RVEC(2)*force_MD(3)-RVEC(3)*force_MD(2) TORQMD(2,IPLATE)=TORQMD(2,IPLATE)+ + RVEC(3)*force_MD(1)-RVEC(1)*force_MD(3) TORQMD(3,IPLATE)=TORQMD(3,IPLATE)+ + RVEC(1)*force_MD(2)-RVEC(2)*force_MD(1) C TORQVB(1,IPLATE)=TORQVB(1,IPLATE)+ + RVEC(2)*force_VB(3)-RVEC(3)*force_VB(2) TORQVB(2,IPLATE)=TORQVB(2,IPLATE)+ + RVEC(3)*force_VB(1)-RVEC(1)*force_VB(3) TORQVB(3,IPLATE)=TORQVB(3,IPLATE)+ + RVEC(1)*force_VB(2)-RVEC(2)*force_VB(1) C TORQBS(1,IPLATE)=TORQBS(1,IPLATE)+ + RVEC(2)*force_BS(3)-RVEC(3)*force_BS(2) TORQBS(2,IPLATE)=TORQBS(2,IPLATE)+ + RVEC(3)*force_BS(1)-RVEC(1)*force_BS(3) TORQBS(3,IPLATE)=TORQBS(3,IPLATE)+ + RVEC(1)*force_BS(2)-RVEC(2)*force_BS(1) C TORQFS(1,IPLATE)=TORQFS(1,IPLATE)+ + RVEC(2)*force_FS(3)-RVEC(3)*force_FS(2) TORQFS(2,IPLATE)=TORQFS(2,IPLATE)+ + RVEC(3)*force_FS(1)-RVEC(1)*force_FS(3) TORQFS(3,IPLATE)=TORQFS(3,IPLATE)+ + RVEC(1)*force_FS(2)-RVEC(2)*force_FS(1) C TORQLP(1,IPLATE)=TORQLP(1,IPLATE)+ + RVEC(2)*force_LP(3)-RVEC(3)*force_LP(2) TORQLP(2,IPLATE)=TORQLP(2,IPLATE)+ + RVEC(3)*force_LP(1)-RVEC(1)*force_LP(3) TORQLP(3,IPLATE)=TORQLP(3,IPLATE)+ + RVEC(1)*force_LP(2)-RVEC(2)*force_LP(1) 510 CONTINUE C WRITE (IUNITQ,"(' ',A)") TRIM(TITLE1) WRITE (IUNITQ,"(' ',A)") TRIM(TITLE2) WRITE (IUNITQ,"(' ',A)") TRIM(TITLE3) WRITE (IUNITQ,*) WRITE (IUNITT,511) NPLATE, FFRIC, TAUMAX(1), TAUMAX(2) WRITE (IUNITQ,511) NPLATE, FFRIC, TAUMAX(1), TAUMAX(2) 511 FORMAT(/' Torque-balance reports for each of ', + I3,' plates (FFRIC ',F5.3, + ', TAUMAX ',ES7.1,'\',ES7.1,'):') DO 600 N=1,NPLATE C C Find rough center point for this plate, C defined by mean uvec of all nodes associated with it. C (If no nodes are associated with plate, skip to next.) C NINSUM=0 SUMNOD(1)=0.0D0 SUMNOD(2)=0.0D0 SUMNOD(3)=0.0D0 DO 515 I=1,NUMNOD IF (WHICHP(I).EQ.N) THEN TTHETA=XNODE(I) PPHI=YNODE(I) EQUAT=SIN(TTHETA) UVEC(1)=EQUAT*COS(PPHI) UVEC(2)=EQUAT*SIN(PPHI) UVEC(3)=COS(TTHETA) SUMNOD(1)=SUMNOD(1)+UVEC(1) SUMNOD(2)=SUMNOD(2)+UVEC(2) SUMNOD(3)=SUMNOD(3)+UVEC(3) NINSUM=NINSUM+1 END IF 515 CONTINUE IF (NINSUM.EQ.0) GO TO 600 C WRITE(IUNITT,516) N, NAMES(N), NINSUM WRITE(IUNITQ,516) N, NAMES(N), NINSUM 516 FORMAT(/' Plate #',I6,' =',A2,': ',I6,' nodes.') C C C ************************************************************ C *CRITICAL LOGIC* C C N.B. TORQBS = TORQMD + TORQVB (by definition), C but not computed here because each was computed C separately above. C TORQSS(1,N)= -TORQBS(1,N)-TORQLP(1,N) TORQSS(2,N)= -TORQBS(2,N)-TORQLP(2,N) TORQSS(3,N)= -TORQBS(3,N)-TORQLP(3,N) C so that these 3 will always add to zero (by definition). C TORQCL(1,N)=TORQSS(1,N)-TORQFS(1,N) TORQCL(2,N)=TORQSS(2,N)-TORQFS(2,N) TORQCL(3,N)=TORQSS(3,N)-TORQFS(3,N) C inferring continuum-link torque (if any) from residual. C CALL TWIST(INPUT,AREA,DETJ,FPSFER, + N,NODES,NPLATE,NUMEL,NUMNOD, + RADIUS,TORQBS,WHICHP,XNODE,YNODE, + OUTPUT,TWISTV) C C (everything below is just reformatting and reporting) C ************************************************************ C C reformat Basal-Strength torque for this plate: C TBSMAG=SQRT(TORQBS(1,N)**2+TORQBS(2,N)**2+TORQBS(3,N)**2) IF (TBSMAG.EQ.0.0D0) THEN TBSLON=0.0 TBSLAT=0.0 ELSE DEQUAT=SQRT(TORQBS(1,N)**2+TORQBS(2,N)**2) IF (DEQUAT.EQ.0.0D0) THEN IF (TORQBS(3,N).GT.0.0D0) THEN TBSLAT=90.0 ELSE TBSLAT= -90.0 END IF TBSLON=0.0 ELSE TBSLAT=57.2958*ATAN2(TORQBS(3,N),DEQUAT) TBSLON=57.2958*ATAN2(TORQBS(2,N),TORQBS(1,N)) END IF END IF C C reformat Continuum-Link torque for this plate: C TCLMAG=SQRT(TORQCL(1,N)**2+TORQCL(2,N)**2+TORQCL(3,N)**2) IF (TCLMAG.EQ.0.0D0) THEN TCLLON=0.0 TCLLAT=0.0 ELSE DEQUAT=SQRT(TORQCL(1,N)**2+TORQCL(2,N)**2) IF (DEQUAT.EQ.0.0D0) THEN IF (TORQCL(3,N).GT.0.0D0) THEN TCLLAT=90.0 ELSE TCLLAT= -90.0 END IF TCLLON=0.0 ELSE TCLLAT=57.2958*ATAN2(TORQCL(3,N),DEQUAT) TCLLON=57.2958*ATAN2(TORQCL(2,N),TORQCL(1,N)) END IF END IF C C reformat Fault-Strength torque for this plate: C TFSMAG=SQRT(TORQFS(1,N)**2+TORQFS(2,N)**2+TORQFS(3,N)**2) IF (TFSMAG.EQ.0.0D0) THEN TFSLON=0.0 TFSLAT=0.0 ELSE DEQUAT=SQRT(TORQFS(1,N)**2+TORQFS(2,N)**2) IF (DEQUAT.EQ.0.0D0) THEN IF (TORQFS(3,N).GT.0.0D0) THEN TFSLAT=90.0 ELSE TFSLAT= -90.0 END IF TFSLON=0.0 ELSE TFSLAT=57.2958*ATAN2(TORQFS(3,N),DEQUAT) TFSLON=57.2958*ATAN2(TORQFS(2,N),TORQFS(1,N)) END IF END IF C C reformat Lithostatic Pressure torque for this plate: C TLPMAG=SQRT(TORQLP(1,N)**2+TORQLP(2,N)**2+TORQLP(3,N)**2) IF (TLPMAG.EQ.0.0D0) THEN TLPLON=0.0 TLPLAT=0.0 ELSE DEQUAT=SQRT(TORQLP(1,N)**2+TORQLP(2,N)**2) IF (DEQUAT.EQ.0.0D0) THEN IF (TORQLP(3,N).GT.0.0D0) THEN TLPLAT=90.0 ELSE TLPLAT= -90.0 END IF TLPLON=0.0 ELSE TLPLAT=57.2958*ATAN2(TORQLP(3,N),DEQUAT) TLPLON=57.2958*ATAN2(TORQLP(2,N),TORQLP(1,N)) END IF END IF C C reformat Mantle-Drag torque for this plate: C TMDMAG=SQRT(TORQMD(1,N)**2+TORQMD(2,N)**2+TORQMD(3,N)**2) IF (TMDMAG.EQ.0.0D0) THEN TMDLON=0.0 TMDLAT=0.0 ELSE DEQUAT=SQRT(TORQMD(1,N)**2+TORQMD(2,N)**2) IF (DEQUAT.EQ.0.0D0) THEN IF (TORQMD(3,N).GT.0.0D0) THEN TMDLAT=90.0 ELSE TMDLAT= -90.0 END IF TMDLON=0.0 ELSE TMDLAT=57.2958*ATAN2(TORQMD(3,N),DEQUAT) TMDLON=57.2958*ATAN2(TORQMD(2,N),TORQMD(1,N)) END IF END IF C C reformat Side-Strength torque for this plate: C TSSMAG=SQRT(TORQSS(1,N)**2+TORQSS(2,N)**2+TORQSS(3,N)**2) IF (TSSMAG.EQ.0.0D0) THEN TSSLON=0.0 TSSLAT=0.0 ELSE DEQUAT=SQRT(TORQSS(1,N)**2+TORQSS(2,N)**2) IF (DEQUAT.EQ.0.0D0) THEN IF (TORQSS(3,N).GT.0.0D0) THEN TSSLAT=90.0 ELSE TSSLAT= -90.0 END IF TSSLON=0.0 ELSE TSSLAT=57.2958*ATAN2(TORQSS(3,N),DEQUAT) TSSLON=57.2958*ATAN2(TORQSS(2,N),TORQSS(1,N)) END IF END IF C C reformat Velocity-Boundary-Condition torque for this plate: C TVBMAG=SQRT(TORQVB(1,N)**2+TORQVB(2,N)**2+TORQVB(3,N)**2) IF (TVBMAG.EQ.0.0D0) THEN TVBLON=0.0 TVBLAT=0.0 ELSE DEQUAT=SQRT(TORQVB(1,N)**2+TORQVB(2,N)**2) IF (DEQUAT.EQ.0.0D0) THEN IF (TORQVB(3,N).GT.0.0D0) THEN TVBLAT=90.0 ELSE TVBLAT= -90.0 END IF TVBLON=0.0 ELSE TVBLAT=57.2958*ATAN2(TORQVB(3,N),DEQUAT) TVBLON=57.2958*ATAN2(TORQVB(2,N),TORQVB(1,N)) END IF END IF C C reformat traction pole vector for this plate: C TWIMAG=SQRT(TWISTV(1)**2+TWISTV(2)**2+TWISTV(3)**2) IF (TWIMAG.EQ.0.0D0) THEN TWILON=0.0 TWILAT=0.0 ELSE DEQUAT=SQRT(TWISTV(1)**2+TWISTV(2)**2) IF (DEQUAT.EQ.0.0D0) THEN IF (TWISTV(3).GT.0.0D0) THEN TWILAT=90.0 ELSE TWILAT= -90.0 END IF TWILON=0.0 ELSE TWILAT=57.2958*ATAN2(TWISTV(3),DEQUAT) TWILON=57.2958*ATAN2(TWISTV(2),TWISTV(1)) END IF END IF C WRITE(IUNITT,520) WRITE(IUNITQ,520) 520 FORMAT(/' Torques on plate bottoms: X=0N,0E Y=0N,90E' + ,' Z=90N Magnitude Longitude Latitude' + /' ------------------------- --------- ---------' + ,' --------- --------- --------- ---------') WRITE (IUNITT,521)(TORQMD(I,N),I=1,3),TMDMAG,TMDLON,TMDLAT WRITE (IUNITQ,521)(TORQMD(I,N),I=1,3),TMDMAG,TMDLON,TMDLAT 521 FORMAT(' Mantle-Drag: ',3ES10.2,ES10.3,2F10.2) WRITE (IUNITT,522)(TORQVB(I,N),I=1,3),TVBMAG,TVBLON,TVBLAT WRITE (IUNITQ,522)(TORQVB(I,N),I=1,3),TVBMAG,TVBLON,TVBLAT 522 FORMAT(' Velocity-Boundary-C.''s ',3ES10.2,ES10.3,2F10.2) WRITE(IUNITT,523) WRITE(IUNITQ,523) 523 FORMAT(' ---------------------------------------------' + ,'----------------------------------------') WRITE (IUNITT,524)(TORQBS(I,N),I=1,3),TBSMAG,TBSLON,TBSLAT WRITE (IUNITQ,524)(TORQBS(I,N),I=1,3),TBSMAG,TBSLON,TBSLAT 524 FORMAT(' Basal-Strength: ',3ES10.2,ES10.3,2F10.2) C WRITE(IUNITT,530) WRITE(IUNITQ,530) 530 FORMAT(/' Torques on plate sides: X=0N,0E Y=0N,90E' + ,' Z=90N Magnitude Longitude Latitude' + /' ------------------------- --------- ---------' + ,' --------- --------- --------- ---------') WRITE (IUNITT,531)(TORQFS(I,N),I=1,3),TFSMAG,TFSLON,TFSLAT WRITE (IUNITQ,531)(TORQFS(I,N),I=1,3),TFSMAG,TFSLON,TFSLAT 531 FORMAT(' Fault-Strength: ',3ES10.2,ES10.3,2F10.2) WRITE (IUNITT,532)(TORQCL(I,N),I=1,3),TCLMAG,TCLLON,TCLLAT WRITE (IUNITQ,532)(TORQCL(I,N),I=1,3),TCLMAG,TCLLON,TCLLAT 532 FORMAT(' Continuum-Link [PLUG]: ',3ES10.2,ES10.3,2F10.2) WRITE(IUNITT,533) WRITE(IUNITQ,533) 533 FORMAT(' ---------------------------------------------' + ,'----------------------------------------') WRITE (IUNITT,534)(TORQSS(I,N),I=1,3),TSSMAG,TSSLON,TSSLAT WRITE (IUNITQ,534)(TORQSS(I,N),I=1,3),TSSMAG,TSSLON,TSSLAT 534 FORMAT(' Side-Strength: ',3ES10.2,ES10.3,2F10.2) C WRITE(IUNITT,540) WRITE(IUNITQ,540) 540 FORMAT(/' Kind of torque: X=0N,0E Y=0N,90E' + ,' Z=90N Magnitude Longitude Latitude' + /' ------------------------- --------- ---------' + ,' --------- --------- --------- ---------') WRITE (IUNITT,541)(TORQLP(I,N),I=1,3),TLPMAG,TLPLON,TLPLAT WRITE (IUNITQ,541)(TORQLP(I,N),I=1,3),TLPMAG,TLPLON,TLPLAT 541 FORMAT(' Lithostatic-Pressure: ',3ES10.2,ES10.3,2F10.2) WRITE (IUNITT,542)(TORQSS(I,N),I=1,3),TSSMAG,TSSLON,TSSLAT WRITE (IUNITQ,542)(TORQSS(I,N),I=1,3),TSSMAG,TSSLON,TSSLAT 542 FORMAT(' Side-Strength: ',3ES10.2,ES10.3,2F10.2) WRITE (IUNITT,543)(TORQBS(I,N),I=1,3),TBSMAG,TBSLON,TBSLAT WRITE (IUNITQ,543)(TORQBS(I,N),I=1,3),TBSMAG,TBSLON,TBSLAT 543 FORMAT(' Basal-Strength: ',3ES10.2,ES10.3,2F10.2) C WRITE (IUNITT,550) WRITE (IUNITQ,550) 550 FORMAT(/' Traction pole vector: X=0N,0E Y=0N,90E' + ,' Z=90N Magnitude Longitude Latitude' + /' ------------------------- --------- ---------' + ,' --------- --------- --------- ---------') WRITE (IUNITT,551)(TWISTV(I),I=1,3),TWIMAG,TWILON,TWILAT WRITE (IUNITQ,551)(TWISTV(I),I=1,3),TWIMAG,TWILON,TWILAT 551 FORMAT(' Basal-strength: ',3ES10.2,ES10.3,2F10.2) C C Find viewpoint orthogonal to all 3 (BS,LP,SS) torque vectors: DVEC(1)=TORQSS(2,N)*TORQBS(3,N)-TORQSS(3,N)*TORQBS(2,N) DVEC(2)=TORQSS(3,N)*TORQBS(1,N)-TORQSS(1,N)*TORQBS(3,N) DVEC(3)=TORQSS(1,N)*TORQBS(2,N)-TORQSS(2,N)*TORQBS(1,N) C C Check that viewpoint is on same side of planet as plate: C DDOT=DVEC(1)*SUMNOD(1)+DVEC(2)*SUMNOD(2)+DVEC(3)*SUMNOD(3) IF (DDOT.LT.0.0D0) THEN DVEC(1)= -DVEC(1) DVEC(2)= -DVEC(2) DVEC(3)= -DVEC(3) END IF LENGTH=SQRT(DVEC(1)**2+DVEC(2)**2+DVEC(3)**2) IF (LENGTH.EQ.0.0) THEN LONGIT=0.0 LATITU=0.0 UVEC(1)=1. UVEC(2)=0. UVEC(3)=0. ELSE UVEC(1)=DVEC(1)/LENGTH UVEC(2)=DVEC(2)/LENGTH UVEC(3)=DVEC(3)/LENGTH DEQUAT=SQRT(UVEC(1)**2+UVEC(2)**2) IF (DEQUAT.EQ.0.0D0) THEN IF (UVEC(3).GT.0.0D0) THEN LATITU=90.0 ELSE LATITU= -90.0 END IF LONGIT=0.0 ELSE LATITU=57.2958*ATAN2(UVEC(3),DEQUAT) LONGIT=57.2958*ATAN2(UVEC(2),UVEC(1)) END IF END IF WRITE (IUNITT,560) LONGIT,LATITU WRITE (IUNITQ,560) LONGIT,LATITU 560 FORMAT(/' Suggested viewpoint for orthographic projection' + ,' of torques on this plate is: (',F7.2,'E,',F6.2,'N)' + /' from which direction all 3 torque vectors will be' + ,' in the plane of the figure.') C WRITE (IUNITT,570) WRITE (IUNITQ,570) 570 FORMAT(/' Equivalent horizontal forces at this point:' + /' Kind of force: X=0N,0E Y=0N,90E' + ,' Z=90N Magnitude Azimuth' + /' ------------------------- --------- ---------' + ,' --------- --------- ---------') C EQUAT=SQRT(UVEC(1)**2+UVEC(2)**2) UPHI(1)= -UVEC(2) UPHI(2)=UVEC(1) UPHI(1)=UPHI(1)/EQUAT UPHI(2)=UPHI(2)/EQUAT UPHI(3)=0.0 TEQUAT=UVEC(3) UTHETA(3)= -EQUAT UTHETA(1)=TEQUAT*UVEC(1)/EQUAT UTHETA(2)=TEQUAT*UVEC(2)/EQUAT LENGTH=SQRT(UTHETA(1)**2+UTHETA(2)**2+UTHETA(3)**2) UTHETA(1)=UTHETA(1)/LENGTH UTHETA(2)=UTHETA(2)/LENGTH UTHETA(3)=UTHETA(3)/LENGTH C C Lithostatic pressure force: C force_LP(1)=(TORQLP(2,N)*UVEC(3)-TORQLP(3,N)*UVEC(2))/RADIUS force_LP(2)=(TORQLP(3,N)*UVEC(1)-TORQLP(1,N)*UVEC(3))/RADIUS force_LP(3)=(TORQLP(1,N)*UVEC(2)-TORQLP(2,N)*UVEC(1))/RADIUS LENGTH=SQRT(TORQLP(1,N)**2+TORQLP(2,N)**2+TORQLP(3,N)**2)/ + RADIUS DOT_S=force_LP(1)*UTHETA(1)+force_LP(2)*UTHETA(2)+ + force_LP(3)*UTHETA(3) DOT_E=force_LP(1)*UPHI(1)+force_LP(2)*UPHI(2)+ + force_LP(3)*UPHI(3) DOT_N= -DOT_S AZIMUT=57.296*ATAN2(DOT_E,DOT_N) IF (AZIMUT.LT.0.) AZIMUT=AZIMUT+360. WRITE (IUNITT,571)(force_LP(I),I=1,3),LENGTH,AZIMUT WRITE (IUNITQ,571)(force_LP(I),I=1,3),LENGTH,AZIMUT 571 FORMAT(' Lithostatic pressure: ',3ES10.2,ES10.3,F10.1) C C Side-strength force: C force_SS(1)=(TORQSS(2,N)*UVEC(3)-TORQSS(3,N)*UVEC(2))/RADIUS force_SS(2)=(TORQSS(3,N)*UVEC(1)-TORQSS(1,N)*UVEC(3))/RADIUS force_SS(3)=(TORQSS(1,N)*UVEC(2)-TORQSS(2,N)*UVEC(1))/RADIUS LENGTH=SQRT(TORQSS(1,N)**2+TORQSS(2,N)**2+TORQSS(3,N)**2)/ + RADIUS DOT_S=force_SS(1)*UTHETA(1)+force_SS(2)*UTHETA(2)+ + force_SS(3)*UTHETA(3) DOT_E=force_SS(1)*UPHI(1)+force_SS(2)*UPHI(2)+ + force_SS(3)*UPHI(3) DOT_N= -DOT_S AZIMUT=57.296*ATAN2(DOT_E,DOT_N) IF (AZIMUT.LT.0.) AZIMUT=AZIMUT+360. WRITE (IUNITT,572)(force_SS(I),I=1,3),LENGTH,AZIMUT WRITE (IUNITQ,572)(force_SS(I),I=1,3),LENGTH,AZIMUT 572 FORMAT(' Side-strength: ',3ES10.2,ES10.3,F10.1) C C Basal-strength force: C force_BS(1)=(TORQBS(2,N)*UVEC(3)-TORQBS(3,N)*UVEC(2))/RADIUS force_BS(2)=(TORQBS(3,N)*UVEC(1)-TORQBS(1,N)*UVEC(3))/RADIUS force_BS(3)=(TORQBS(1,N)*UVEC(2)-TORQBS(2,N)*UVEC(1))/RADIUS LENGTH=SQRT(TORQBS(1,N)**2+TORQBS(2,N)**2+TORQBS(3,N)**2)/ + RADIUS DOT_S=force_BS(1)*UTHETA(1)+force_BS(2)*UTHETA(2)+ + force_BS(3)*UTHETA(3) DOT_E=force_BS(1)*UPHI(1)+force_BS(2)*UPHI(2)+ + force_BS(3)*UPHI(3) DOT_N= -DOT_S AZIMUT=57.296*ATAN2(DOT_E,DOT_N) IF (AZIMUT.LT.0.) AZIMUT=AZIMUT+360. WRITE (IUNITT,573)(force_BS(I),I=1,3),LENGTH,AZIMUT WRITE (IUNITQ,573)(force_BS(I),I=1,3),LENGTH,AZIMUT 573 FORMAT(' Basal-strength: ',3ES10.2,ES10.3,F10.1) C DEQUAT=SQRT(SUMNOD(1)**2+SUMNOD(2)**2) LATITU=57.2958*ATAN2(SUMNOD(3),DEQUAT) LONGIT=57.2958*ATAN2(SUMNOD(2),SUMNOD(1)) WRITE (IUNITT,580) LONGIT,LATITU WRITE (IUNITQ,580) LONGIT,LATITU 580 FORMAT(/' and this cluster of forces should be connected' + ,' by a leader line' + /' to the plate center at approximately:' + ,' (',F7.2,'E, ',F6.2,'N).') C WRITE (IUNITT,401) WRITE (IUNITQ,401) 600 CONTINUE CLOSE (IUNITQ) RETURN END C C C SUBROUTINE ROTOR (INPUT,MXDOF,NDOF,NLB,NODE,NUB,THETA, + MODIFY,FORCE,STIFF) C C Operate on two adjacent row equations of the linear system C (coefficient matrix STIFF and right-side vector FORCE) C which represent the balance of forces on one node in the C X and Y directions, respectively. C Rotate these equations to a new coordinate system (ALPHA,BETA) C where ALPHA is THETA radians counterclockwise from X, and C BETA is THETA radians counterclockwise from Y. C C Note: This transformation has ***no effect*** on the definitions C of the unknown velocities, which remain in the (X,Y) system. C C The rows operated on are #(2*NODE-1) and #(2*NODE). C After rotation, the ALPHA equation will replace the X equation, C and the BETA equation will replace the Y equation. C DOUBLE PRECISION COST,DTHETA,FORCE,SINT,STIFF,XTEMP,YTEMP DIMENSION FORCE(MXDOF),STIFF(MXWORK) COMMON LDA,NUCA,MXWORK C C Statement function replacing INTEGER FUNCTION subprogram -INDEXK-: INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + NUCA + IROW - JCOLUM + 1 C DTHETA=THETA COST=COS(DTHETA) SINT=SIN(DTHETA) IXROW=2*NODE-1 IYROW=2*NODE IAROW=IXROW IBROW=IYROW XTEMP=FORCE(IXROW) YTEMP=FORCE(IYROW) FORCE(IAROW)=COST*XTEMP+SINT*YTEMP FORCE(IBROW)=COST*YTEMP-SINT*XTEMP J1=MAX(IYROW-NLB,1) J2=MIN(IXROW+NUB,NDOF) DO 10 JCOLUM=J1,J2 IKX=INDEXK(IXROW,JCOLUM) IKY=INDEXK(IYROW,JCOLUM) IKA=IKX IKB=IKY XTEMP=STIFF(IKX) YTEMP=STIFF(IKY) STIFF(IKA)=COST*XTEMP+SINT*YTEMP STIFF(IKB)=COST*YTEMP-SINT*XTEMP 10 CONTINUE RETURN END C C C SUBROUTINE SANDER (INPUT,FDIP,ICOND,IUNITT, + log_strike_adjustments, + MXBN,MXFEL,MXNODE,NCOND,NFL, + NODCON,NODEF,VBCARG,VBCMAG, + WEDGE,XNODE,YNODE, + MODIFY,FARG) C C "Rounds the angular corners" of any model edges which are C multi-element strike-slip fault systems, by averaging the C arguments at matched ends of the adjacent s-s fault elements. C C This is only done where boundary conditions for the external C nodes are identical, creating one rigid plate outside the C model domain. C C This correction is necessary to prevent two artifacts: C -Extremely large equal-but-opposite boundary force C vectors plotted at the same location (for the two C external nodes that are co-located). C -Artificial resistance to strike-slip, since the C resistance added by mismatched arguments is proportional C to FMUMAX, but not dependent on fault or plate rheology!!! C INTEGER B1,B2,END1,END2,F1,F2,ON1,ON2 LOGICAL DIDONE LOGICAL :: log_strike_adjustments DIMENSION ICOND(MXBN),NODCON(MXBN),NODEF(4,MXFEL) DIMENSION FARG(2,MXFEL),FDIP(2,MXFEL),VBCARG(MXBN),VBCMAG(MXBN), + XNODE(MXNODE),YNODE(MXNODE) C IF (log_strike_adjustments) WRITE(IUNITT,1) 1 FORMAT(/ /' The following pairs of model-bounding strike-slip' + /' fault elements had their azimuths averaged at the' + /' connection point for purposes of computing the' + /' constraint on the directino of strike-slip:' + / /' Fault#1 Fault#2 Node#A Node#B ', + ' Latitude Longitude Azim#1 Azim#2 Azimuth' + /' ----------------------------------------', + '--------------------------------------------------') DIDONE=.FALSE. C loop on all boundary nodes (referring backwards for neighbors) B1=NCOND DO 1000 B2=1,NCOND N1=NODCON(B1) N2=NODCON(B2) C C consider only if 2 consecutive boundary nodes are colocated IF ((XNODE(N1).EQ.XNODE(N2)).AND. + (YNODE(N1).EQ.YNODE(N2))) THEN C C consider only if both boundary nodes are type-2, 4, 5: IF (((ICOND(B1).EQ.2).AND.(ICOND(B2).EQ.2)).OR. + ((ICOND(B1).EQ.4).AND.(ICOND(B2).EQ.4)).OR. + ((ICOND(B1).EQ.5).AND.(ICOND(B2).EQ.5))) THEN C C consider only if both type-2/4/5 BC's are same velocity IF ((VBCARG(B1).EQ.VBCARG(B2)).AND. + (VBCMAG(B1).EQ.VBCMAG(B2))) THEN C C <<<<<<<<<<<<<<<<<<<<<<<< shift <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< C C find fault element F1 containing node N1 (and remember the end C END1 and opposing inner node ON1) F1=0 DO 110 I=1,NFL IF (N1.EQ.NODEF(1,I)) THEN F1=I END1=1 ON1=NODEF(4,I) GO TO 111 END IF IF (N1.EQ.NODEF(4,I)) THEN F1=I END1=1 ON1=NODEF(1,I) GO TO 111 END IF IF (N1.EQ.NODEF(2,I)) THEN F1=I END1=2 ON1=NODEF(3,I) GO TO 111 END IF IF (N1.EQ.NODEF(3,I)) THEN F1=I END1=2 ON1=NODEF(2,I) GO TO 111 END IF 110 CONTINUE C find fault element F2 containing node N2 (and remember the end C END2 and opposing inner node ON2) 111 F2=0 DO 120 I=1,NFL IF (N2.EQ.NODEF(1,I)) THEN F2=I END2=1 ON2=NODEF(4,I) GO TO 121 END IF IF (N2.EQ.NODEF(4,I)) THEN F2=I END2=1 ON2=NODEF(1,I) GO TO 121 END IF IF (N2.EQ.NODEF(2,I)) THEN F2=I END2=2 ON2=NODEF(3,I) GO TO 121 END IF IF (N2.EQ.NODEF(3,I)) THEN F2=I END2=2 ON2=NODEF(2,I) GO TO 121 END IF 120 CONTINUE C consider only if 2 distinct faults were found 121 IF ((F1.GT.0).AND.(F2.GT.0).AND.(F1.NE.F2)) THEN C C consider only if both faults are vertical IF ((ABS(FDIP(END1,F1)-1.570796).LE.WEDGE).AND. + (ABS(FDIP(END2,F2)-1.570796).LE.WEDGE)) THEN C C consider only if opposite/inner nodes are the same C (no internal fault creates a triple-junction) IF (ON1.EQ.ON2) THEN C ARGMID=CHORD(FARG(END1,F1),0.50D0,FARG(END2,F2)) DEG1=180. - 57.2957795*FARG(END1,F1) DEG2=180. - 57.2957795*FARG(END2,F2) DEGM=180. - 57.2957795*ARGMID C =================== modify! ===================== FARG(END1,F1)=ARGMID FARG(END2,F2)=ARGMID DIDONE=.TRUE. C =================== modify! ===================== C write a line for the output table DELON=57.2957795*YNODE(N1) DNLAT=90.-57.2957795*XNODE(N1) IF (log_strike_adjustments) WRITE (IUNITT,900) + F1,F2,N1,N2, + DNLAT,DELON,DEG1,DEG2,DEGM 900 FORMAT(' ',I7,3X,I7,3X, + I7,3X,I7,3X, + 2X,F8.3,1X,F9.3, + 4X,F6.1,4X,F6.1,4X,F6.1) C END IF C ^end of test that opposite/inner nodes are the same C END IF C ^end of test that both faults are vertical C END IF C ^end of test that 2 distinct faults were found C C >>>>>>>>>>>>>>>>>>>>>>>> shift >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> C END IF C ^end of test that 2 type-2 VBC's are same vector C END IF C ^end of test that both nodes are type-2 C END IF C ^end of test that two consecutive boundary nodes are colocated C C prepare to loop: current lead node becomes new following node B1=B2 1000 CONTINUE C ^end loop on all boundary nodes (referring backwards to neighbor B1) C IF (.NOT.DIDONE) THEN WRITE (IUNITT,1001) 1001 FORMAT(' (No fault pairs were found which needed ' + ,'this correction.)') END IF END C C C SUBROUTINE SNODAL (INPUT,PHI,THETA, + OUTPUT,FPP) C C Calculates vector nodal function at integration point along an C arc-of-great-circle side of a finite element. C DOUBLE PRECISION FPHI,PP DIMENSION FPHI(4,7),FPP(2,2,2,7),PHI(2),THETA(2) COMMON /FPHIS/ FPHI C X1=SIN(THETA(1))*COS(PHI(1)) Y1=SIN(THETA(1))*SIN(PHI(1)) Z1=COS(THETA(1)) X2=SIN(THETA(2))*COS(PHI(2)) Y2=SIN(THETA(2))*SIN(PHI(2)) Z2=COS(THETA(2)) XN=X1+X2 YN=Y1+Y2 ZN=Z1+Z2 XYZN=SQRT(XN*XN+YN*YN+ZN*ZN) XN=XN/XYZN YN=YN/XYZN ZN=ZN/XYZN DD=X1*XN+Y1*YN+Z1*ZN DO 800 M=1,7 XX=FPHI(1,M)*X1+FPHI(2,M)*X2 YY=FPHI(1,M)*Y1+FPHI(2,M)*Y2 ZZ=FPHI(1,M)*Z1+FPHI(2,M)*Z2 PP=SQRT(XX*XX+YY*YY+ZZ*ZZ) XX=XX/PP YY=YY/PP ZZ=ZZ/PP SITAJ=ACOS(ZZ) PHAIJ=ATAN2F(YY,XX) RN=XX*XN+YY*YN+ZZ*ZN PPM=RN/DD CSCS=COS(SITAJ)*COS(PHAIJ) CSSN=COS(SITAJ)*SIN(PHAIJ) SNSN=SIN(SITAJ)*SIN(PHAIJ) SNC=SIN(SITAJ) SNP=SIN(PHAIJ) CSP=COS(PHAIJ) DO 500 J=1,2 FP=FPHI(J,M)*PPM FPP(1,1,J,M)=( COS(THETA(J))*COS(PHI(J))*CSCS + +COS(THETA(J))*SIN(PHI(J))*CSSN + +SIN(THETA(J))*SNC)*FP FPP(2,1,J,M)=(-SIN(PHI(J))*CSCS+COS(PHI(J))*CSSN)*FP FPP(1,2,J,M)=(-COS(THETA(J))*COS(PHI(J))*SNP + +COS(THETA(J))*SIN(PHI(J))*CSP)*FP FPP(2,2,J,M)=( SIN(PHI(J))*SNP + +COS(PHI(J))*CSP)*FP 500 CONTINUE 800 CONTINUE RETURN END C C C SUBROUTINE SOLVER (INPUT,A,MXDOF,NDOF,NLB,NUB, + MODIFY,B) C C Sets up for CALL to the library routine which actually C solves the linear system C C |A| |X| = |B|. C C The left-hand coefficient matrix |A| is destroyed. C The answer vector |X| is written over the forcing vector |B|. C C Current version is per conventions of the IMSL Library, C DOUBLE PRECISION version. C DOUBLE PRECISION A,B INTEGER INPUT,IPATH,LDA,MODIFY,MXDOF,N,NDOF,NLB,NLCA,NUB,NUCA DIMENSION A(MXWORK),B(MXDOF) C C Note: Un-named COMMON passes INTEGER variables used in C INTEGER FUNCTION -INDEXK-, to avoid passing these same C through long sequences of subprograms: COMMON LDA,NUCA,MXWORK C C ----- Name conversions ----------------------------------- C Coefficient matrix: STIFF or K in -Shells-; here called A. C Right-hand forcing vector: F in -Shells-; here called B. C Note that last argument below is the solution vector; C here it is overwritten onto B to save storage. (The C IMSL manual says that this is permitted.) N=NDOF NLCA=NLB IPATH=1 C------------------------------------------------------ CALL DLSLRB (N, A, LDA, NLCA, NUCA, B, IPATH, B) C------------------------------------------------------ RETURN END C C C SUBROUTINE SQUARE (INPUT,BRIEF,FDIP,IUNITT, + log_strike_adjustments, + MXBN,MXEL,MXFEL,MXNODE, + MXSTAR,NFL,NODEF,NODES, + NUMEL,NUMNOD,SKIPBC,RADIUS,WEDGE, + MODIFY,XNODE,YNODE, + OUTPUT,AREA,DETJ, + DXS,DYS,DXSP,DYSP,EDGEFS, + EDGETS,FLEN,FPFLT,FPSFER, + FARG,NCOND,NODCON,SITA, + WORK,CHECKN,LIST) C C Check, correct, and complete the geometry of the finite element grid. C LOGICAL AGREED,ALLOK,BRIEF,FOUND,SKIPBC,SWITCH,VERT1,VERT2 C C Note: The following type could be LOGICAL*1 in IBM VS-Fortran: LOGICAL CHECKN,EDGEFS,EDGETS C CHARACTER*21 OBLIQU,TAG1,TAG2,VERTIC DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS LOGICAL :: log_strike_adjustments DIMENSION FANGLE(2),FPHI(4,7),FPOINT(7),FGAUSS(7),PHI(2),THETA(2) DIMENSION AREA(MXEL),CHECKN(MXNODE), + DETJ(7,MXEL), + DXS(2,2,3,7,MXEL),DYS(2,2,3,7,MXEL), + DXSP(3,7,MXEL),DYSP(3,7,MXEL), + EDGEFS(2,MXFEL),EDGETS(3,MXEL),FDIP(2,MXFEL), + FLEN(MXFEL), + FPFLT(2,2,2,7,MXFEL), + FPSFER(2,2,3,7,MXEL),FARG(2,MXFEL), + LIST(MXSTAR),NODCON(MXBN), + NODEF(4,MXFEL),NODES(3,MXEL), + SITA(7,MXEL),XNODE(MXNODE),YNODE(MXNODE) DATA OBLIQU /'(DIP SLIP IS ALLOWED)'/ DATA VERTIC /'(STRIKE-SLIP ONLY) '/ C C (1) Check that all nodes are connected to at least one C continuum (triangular) element or fault element: C DO 110 I=1,NUMNOD CHECKN(I)=.FALSE. 110 CONTINUE DO 130 I=1,NUMEL DO 120 J=1,3 CHECKN(NODES(J,I))=.TRUE. 120 CONTINUE 130 CONTINUE DO 136 I=1,NFL DO 134 J=1,4 CHECKN(NODEF(J,I))=.TRUE. 134 CONTINUE 136 CONTINUE ALLOK=.TRUE. DO 140 I=1,NUMNOD ALLOK=ALLOK.AND.CHECKN(I) 140 CONTINUE IF (.NOT.ALLOK) THEN WRITE(IUNITT,150) 150 FORMAT(' BAD GRID TOPOLOGY: FOLLOWING REAL NODES DO NOT'/ 1 ' BELONG TO ANY TRIANGULAR CONTINUUM ELEMENT'/ 2 ' OR FAULT ELEMENT:') DO 160 I=1,NUMNOD IF (.NOT.CHECKN(I)) WRITE (IUNITT,155) I 155 FORMAT (' ',43X,I6) 160 CONTINUE CALL PAUSE() STOP ENDIF C C (2) Average together the coordinates of all nodes at one "point": C DO 410 I=1,NUMNOD CHECKN(I)=.FALSE. C (MEANS "NOT YET INVOLVED IN AVERAGING') 410 CONTINUE DO 490 I=1,NFL DO 480 J1=1,2 NJ1=NODEF(J1,I) C (Fault ends are the only places that can have problems.) IF (.NOT.CHECKN(NJ1)) THEN LIST(1)=NJ1 CHECKN(NJ1)=.TRUE. C Begin list of neighbors with paired node: J2=5-J1 NJ2=NODEF(J2,I) LIST(2)=NJ2 CHECKN(NJ2)=.TRUE. NINSUM=2 C Find shortest fault connected to either one: DX=XNODE(NJ1)-XNODE(NJ2) DY=YNODE(NJ1)-YNODE(NJ2) IF (DY.GT.3.14) DY=DY-6.28318 IF (DY.LT.-3.14) DY=DY+6.28318 DY=DY*SIN(XNODE(NJ1)) SHORT=SQRT(DX**2+DY**2) DO 470 K=1,NFL NL1=NODEF(1,K) NL2=NODEF(2,K) NL3=NODEF(3,K) NL4=NODEF(4,K) IF ((NJ1.EQ.NL1).OR.(NJ2.EQ.NL1).OR. + (NJ1.EQ.NL2).OR.(NJ2.EQ.NL2).OR. + (NJ1.EQ.NL3).OR.(NJ2.EQ.NL3).OR. + (NJ1.EQ.NL4).OR.(NJ2.EQ.NL4)) THEN DX=XNODE(NL1)-XNODE(NL2) DY=YNODE(NL1)-YNODE(NL2) IF (DY.GT.3.14) DY=DY-6.28318 IF (DY.LT.-3.14) DY=DY+6.28318 DY=DY*SIN(XNODE(NL1)) TEST=SQRT(DX**2+DY**2) SHORT=MIN(SHORT,TEST) ENDIF 470 CONTINUE C Collect all corner nodes within 10% of this: TOLER=SHORT/10. T2=TOLER**2 DO 471 K=1,NUMNOD IF (.NOT.CHECKN(K)) THEN DX=XNODE(NJ1)-XNODE(K) DY=YNODE(NJ1)-YNODE(K) IF (DY.GT.3.14) DY=DY-6.28318 IF (DY.LT.-3.14) DY=DY+6.28318 DY=DY*SIN(XNODE(NJ1)) R2=DX**2+DY**2 IF (R2.LT.T2) THEN NINSUM=NINSUM+1 IF (NINSUM.GT.MXSTAR) THEN WRITE(IUNITT,421) 421 FORMAT(/' INCREASE VALUE' + ,' OF PARAMETER MAXATP.') CALL PAUSE() STOP ENDIF LIST(NINSUM)=K CHECKN(K)=.TRUE. ENDIF ENDIF 471 CONTINUE C (Quick EXIT if all nodes in same place) AGREED=.TRUE. DO 472 K=2,NINSUM AGREED=AGREED.AND. + (XNODE(LIST(K)).EQ.XNODE(LIST(1))).AND. + (YNODE(LIST(K)).EQ.YNODE(LIST(1))) 472 CONTINUE IF (AGREED) GO TO 480 XSUM=0. YSUM=0. DO 473 K=1,NINSUM XSUM=XSUM+XNODE(LIST(K)) YSUM=YSUM+YNODE(LIST(K)) 473 CONTINUE XMEAN=XSUM/NINSUM YMEAN=YSUM/NINSUM RMAX=0. DO 474 K=1,NINSUM R=SQRT((XNODE(LIST(K))-XMEAN)**2+ + (YNODE(LIST(K))-YMEAN)**2) RMAX=MAX(RMAX,R) 474 CONTINUE DO 475 K=1,NINSUM XNODE(LIST(K))=XMEAN YNODE(LIST(K))=YMEAN 475 CONTINUE IF (.NOT.BRIEF) THEN IF (RMAX.GT.0.) THEN WRITE(IUNITT,476) NINSUM, + (LIST(N),N=1,NINSUM) 476 FORMAT(/ + ' AVERAGING TOGETHER THE POSITIONS OF', + ' THESE ',I6,' NODES:',(/' ',12I6)) WRITE (IUNITT,477) RMAX 477 FORMAT (' MAXIMUM CORRECTION TO ', + 'ANY POSITION IS',1P,E10.2/ + ' YOU ARE RESPONSIBLE FOR ', + ' DECIDING WHETHER THIS IS A', + ' SERIOUS ERR0R!') ENDIF ENDIF ENDIF 480 CONTINUE 490 CONTINUE C C (3) Compute derivitives of nodal C functions at integration points; C then check for negative areas: C CALL DERIV (INPUT,IUNITT,MXEL,MXNODE,NODES,NUMEL, + RADIUS,XNODE,YNODE, + OUTPUT,AREA,DETJ, + DXS,DYS,DXSP,DYSP,FPSFER,SITA) ALLOK=.TRUE. DO 620 I=1,NUMEL DO 610 M=1,7 TEST=AREA(I)*DETJ(M,I) IF (TEST.LE.0.) THEN WRITE(IUNITT,605) M,I 605 FORMAT(/' EXCESSIVELY DISTORTED ELEMENT LEADS TO ' + ,'NEGATIVE AREA AT POINT ',I1,' IN ELEMENT ', + I5) WRITE(IUNITT,606) AREA(I),DETJ(M,I) 606 FORMAT('AREA = ',1P,E12.4,' DETJ: ',0P,F12.6) ALLOK=.FALSE. ENDIF 610 CONTINUE 620 CONTINUE IF (.NOT.ALLOK) THEN CALL PAUSE() STOP END IF C C (4) Compute lengths of fault elements: C DO 750 I=1,NFL N1=NODEF(1,I) N2=NODEF(2,I) THETA1=XNODE(N1) THETA2=XNODE(N2) PHI1 =YNODE(N1) PHI2 =YNODE(N2) FLEN(I)=FLTLEN (PHI1,PHI2,RADIUS,THETA1,THETA2) 750 CONTINUE C C (5) Make a list of nodes that are on the boundary and require C boundary conditions (NODCON); these are in counterclockwise C order. Also make lists of element sides which contain these C nodes: EDGETS and EDGEFS. C NCOND=0 DO 801 I=1,NUMNOD CHECKN(I)=.FALSE. 801 CONTINUE DO 802 I=1,NFL EDGEFS(1,I)=.FALSE. EDGEFS(2,I)=.FALSE. 802 CONTINUE DO 810 I=1,NUMEL DO 809 J=1,3 CALL NEXT (INPUT,I,J,MXEL,MXFEL,NFL,NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) IF (KELE.GT.0) THEN C (ordinary interior side) EDGETS(J,I)=.FALSE. ELSE IF (KFAULT.EQ.0) THEN C (exterior side) EDGETS(J,I)=.TRUE. N1=NODES(MOD(J, 3)+1,I) N2=NODES(MOD(J+1,3)+1,I) IF (.NOT.CHECKN(N1)) THEN NCOND=NCOND+1 CHECKN(N1)=.TRUE. ENDIF IF (.NOT.CHECKN(N2)) THEN NCOND=NCOND+1 CHECKN(N2)=.TRUE. ENDIF ELSE C (triangular element has an exterior fault element C adjacent to it) EDGETS(J,I)=.FALSE. N1=NODES(MOD(J, 3)+1,I) IF (NODEF(2,KFAULT).EQ.N1) THEN EDGEFS(2,KFAULT)=.TRUE. DO 806 K=3,4 N=NODEF(K,KFAULT) IF (.NOT.CHECKN(N)) THEN NCOND=NCOND+1 CHECKN(N)=.TRUE. ENDIF 806 CONTINUE ELSE EDGEFS(1,KFAULT)=.TRUE. DO 808 K=1,2 N=NODEF(K,KFAULT) IF (.NOT.CHECKN(N)) THEN NCOND=NCOND+1 CHECKN(N)=.TRUE. ENDIF 808 CONTINUE ENDIF ENDIF 809 CONTINUE 810 CONTINUE IF (NCOND.GT.MXBN) THEN WRITE(IUNITT,820) NCOND 820 FORMAT(/' Increase parameter MXBN to at least ',I6, + /' (by adjusting formula) and recompile.') CALL PAUSE() STOP ENDIF C C Stop work if no boundary nodes found (global grid): C IF (NCOND.EQ.0) GO TO 899 C C Begin circuit with lowest-numbered boundary node DO 830 I=1,NUMNOD IF (CHECKN(I)) GO TO 831 830 CONTINUE 831 NODCON(1)=I NDONE=1 NLEFT=NCOND C Beginning of indefinate loop which traces around the perimeter. C Each time, it progresses by one of 3 steps: C -1 node at a time along a triangle side, OR C -1 node at a time along a fault element side, or C -by finding another node which shares the same location. C Beginning of main indefinate loop: 840 NODE=NODCON(NDONE) C C Important: Check that we are not revisiting a node! C This would mean that there are too many boundary nodes C to fit in the simply-connected loop, and that there C are excess boundary nodes somewhere, unconnected! IF (.NOT.CHECKN(NODE)) THEN NGOOD=NDONE-2 WRITE (IUNITT,841) NGOOD, NCOND 841 FORMAT(/' ERR','OR IN GRID, reported by -SQUARE-:' + /' BOUNDARY IS NOT SIMPLY-CONNECTED.' + /' Closed loop of ',I6,' nodes does not' + /' include all ',I6,' boundary nodes.' + /' Run command Perimeter in OrbWin' + /' for a map of the bad nodes.'/) CALL PAUSE() STOP END IF IF (NDONE.GT.1) CHECKN(NODE)=.FALSE. C X=XNODE(NODE) Y=YNODE(NODE) C Look for a triangular element with an external C side that begins with this node: DO 844 I=1,NUMEL DO 842 J=1,3 IF (EDGETS(J,I)) THEN N1=NODES(MOD(J,3)+1,I) IF (N1.EQ.NODE) GO TO 846 ENDIF 842 CONTINUE 844 CONTINUE GO TO 850 846 N2=NODES(MOD(J+1,3)+1,I) C Success by element method: N2 is next boundary node NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N2 NLEFT=NLEFT-1 IF (NLEFT.GT.0) THEN GO TO 840 ELSE GO TO 870 ENDIF C Else, look for an adjacent fault element using this node: 850 DO 854 I=1,NFL IF (EDGEFS(1,I)) THEN IF (NODEF(1,I).EQ.NODE) THEN N2=NODEF(2,I) GO TO 856 ENDIF ELSE IF (EDGEFS(2,I)) THEN IF (NODEF(3,I).EQ.NODE) THEN N2=NODEF(4,I) GO TO 856 ENDIF ENDIF 854 CONTINUE GO TO 860 856 NDONE=NDONE+1 C Success by fault method: N2 is next boundary node: IF (NDONE.LE.NCOND) NODCON(NDONE)=N2 NLEFT=NLEFT-1 IF (NLEFT.GT.0) THEN GO TO 840 ELSE GO TO 870 ENDIF C Else, look for another exterior corner node at same location 860 DO 865 I=1,NUMNOD IF ((I.NE.NODE).AND.CHECKN(I)) THEN IF ( (ABS(XNODE(I)-X).LT.1.E-6) .AND. + (ABS(YNODE(I)-Y).LT.1.E-6) ) GO TO 867 ENDIF 865 CONTINUE WRITE(IUNITT,866) NODE 866 FORMAT(' BAD GRID TOPOLOGY: WHILE TRACING PERIMETER,'/ + ' COULD NOT FIND ANY WAY TO CONTINUE FROM NODE ',I6/ + ' EITHER THROUGH SHARED BOUNDARY ELEMENTS, OR'/ + ' THROUGH OTHER BOUNDARY NODES SHARING THE SAME ', + 'POSITION.') CALL PAUSE() STOP 867 NDONE=NDONE+1 C Success by location method: I is the next boundary node IF (NDONE.LE.NCOND) NODCON(NDONE)=I NLEFT=NLEFT-1 IF (NLEFT.GT.0) GO TO 840 C End of indefinate loop which traces around perimeter. 870 IF (.NOT.SKIPBC) THEN WRITE(IUNITT,880) 880 FORMAT(/ /' Here follows a list, in consecutive order,'/ + ' of the nodes which define the perimeter'/ + ' of the model; these nodes require boundary', + ' conditions:'/' BC# Node ', + ' Latitude Longitude') DO 890 I=1,NCOND N=NODCON(I) THELON=YNODE(N)*57.296 THELAT=90.-XNODE(N)*57.296 WRITE(IUNITT,882) I, N, THELAT, THELON 882 FORMAT(' ',2I6,10X,2F10.3) 890 CONTINUE N=NODCON(1) WRITE (IUNITT,892) N 892 FORMAT(' (Note: Initial node ',I6,' completes the loop,', + ' but is not listed again.)') ENDIF 899 CONTINUE C C (6) Survey fault elements and issue warning if any element is of C mixed type (part strike-slip, and part shallow-dipping: C DO 920 I=1,NFL DELD1=FDIP(1,I)-1.570796 DELD2=FDIP(2,I)-1.570796 VERT1=ABS(DELD1).LE.WEDGE VERT2=ABS(DELD2).LE.WEDGE NVPART=0 IF (VERT1) THEN NVPART=NVPART+1 TAG1=VERTIC ELSE TAG1=OBLIQU ENDIF IF (VERT2) THEN NVPART=NVPART+1 TAG2=VERTIC ELSE TAG2=OBLIQU ENDIF SWITCH=((NVPART.GT.0).AND.(NVPART.LT.2)) IF (SWITCH) THEN DIP1=FDIP(1,I)*57.2957795 IF (DIP1.GT.90.) DIP1=DIP1-180. DIP2=FDIP(2,I)*57.2957795 IF (DIP2.GT.90.) DIP2=DIP2-180. WRITE (IUNITT,905) I,DIP1,TAG1,DIP2,TAG2 905 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES ',A21/ + ' ',F7.2,' DEGREES ',A21/ + ' WHICH MAKES IT MIXED-MODE.'/ + ' SUCH ELEMENTS ARE INACCURATE AND NOT RECOMMENDED.'/ + ' PREFERABLY EACH ELEMENT SHOULD BE OF A SINGLE TYPE.'/ + ' (REMEMBER, DIP NEED NOT BE CONTINUOUS FROM ONE', + ' FAULT ELEMENT TO THE NEXT.)') ELSE NVPART=0 DO 910 M=1,7 DELD=DELD1*FPHI(1,M)+DELD2*FPHI(2,M) IF (ABS(DELD).LE.WEDGE) NVPART=NVPART+1 910 CONTINUE IF ((NVPART.GT.0).AND.(NVPART.LT.7)) THEN IF (NVPART.GE.4) THEN WRITE (IUNITT,912) I,DIP1,DIP2 912 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES, AND'/ + ' ',F7.2,' DEGREES'/ + ' WHICH APPEAR TO MAKE IT STRIKE-SLIP.'/ + ' HOWEVER, THESE VALUES ARE SUCH THAT DIP-SLIP'/ + ' IS PERMITTED AT ONE OR MORE INTEGRATION POINTS.'/ + ' SUCH ELEMENTS ARE INACCURATE AND NOT RECOMMENDED.'/ + ' PREFERABLY EACH ELEMENT SHOULD BE OF A SINGLE TYPE.'/ + ' (REMEMBER, DIP NEED NOT BE CONTINUOUS FROM ONE', + ' FAULT ELEMENT TO THE NEXT.)') ELSE WRITE (IUNITT,914) I,DIP1,DIP2 914 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES, AND'/ + ' ',F7.2,' DEGREES'/ + ' WHICH APPEAR TO MAKE IT FREE-SLIPPING.'/ + ' HOWEVER, THESE VALUES ARE SUCH THAT DIP-SLIP'/ + ' IS PROHIBITED AT ONE OR MORE INTEGRATION POINTS.'/ + ' SUCH ELEMENTS ARE INACCURATE AND NOT RECOMMENDED.'/ + ' PREFERABLY EACH ELEMENT SHOULD BE OF A SINGLE TYPE.'/ + ' (REMEMBER, DIP NEED NOT BE CONTINUOUS FROM ONE', + ' FAULT ELEMENT TO THE NEXT.)') ENDIF ENDIF ENDIF 920 CONTINUE C C (7) Calculate fault argument (in radians, measured counterclockwise C from +Theta = South) at each end of each fault element. C DO 1000 I=1,NFL N1=NODEF(1,I) N2=NODEF(2,I) THETA(1)=XNODE(N1) THETA(2)=XNODE(N2) PHI(1) =YNODE(N1) PHI(2) =YNODE(N2) CALL FANGLS(INPUT, PHI,THETA, + OUTPUT, FANGLE) DO 900 J=1,2 FARG(J,I)=FANGLE(J) 900 CONTINUE 1000 CONTINUE C C (8) Survey strike-slip (vertical) faults to check for conflicts in C argument that would lock the fault: C IF (log_strike_adjustments) WRITE(IUNITT,1001) 1001 FORMAT(/ /' The following tightly-connected pairs of strike-slip' + /' fault elements had their azimuths averaged at the' + /' connection point for purposes of computing the' + /' constraint on the direction of strike-slip:' + / /' Fault#1 Fault#2 Node#A Node#B ', + ' Latitude Longitude Azim#1 Azim#2 Azimuth' + /' ----------------------------------------', + '--------------------------------------------------') C Loop on all fault elements (I): DO 2000 I=1,NFL C Loop on 2 terminal node pairs, 1-4, 2-3 (J = 1 or 2): DO 1900 J=1,2 C Dip must be within WEDGE of vertical for constraint: IF (ABS(FDIP(J,I)-1.570796).LE.WEDGE) THEN NAZI=J N1=J IF(J.EQ.1) THEN N4=4 ELSE N4=3 ENDIF NODE1=NODEF(N1,I) NODE4=NODEF(N4,I) C No constraint applied where a fault ends: IF (NODE1.NE.NODE4) THEN C Endpoint pairs must be checked for duplication: C Look for other strike-slip faults sharing this C pair of nodes, at either end: FOUND=.FALSE. DO 1600 L=1,NFL IF (L.NE.I) THEN IF (ABS(FDIP(1,L)-1.5708).LE.WEDGE) THEN IF (((NODE1.EQ.NODEF(1,L)).AND. + (NODE4.EQ.NODEF(4,L))).OR. + ((NODE1.EQ.NODEF(4,L)).AND. + (NODE4.EQ.NODEF(1,L)))) THEN FOUND=.TRUE. NUMBER=L NAZL=1 GO TO 1601 ENDIF ENDIF IF (ABS(FDIP(2,L)-1.5708).LE.WEDGE) THEN IF (((NODE1.EQ.NODEF(2,L)).AND. + (NODE4.EQ.NODEF(3,L))).OR. + ((NODE1.EQ.NODEF(3,L)).AND. + (NODE4.EQ.NODEF(2,L)))) THEN FOUND=.TRUE. NUMBER=L NAZL=2 GO TO 1601 ENDIF ENDIF ENDIF 1600 CONTINUE C Don't worry if this pair already checked! 1601 IF (FOUND.AND.(NUMBER.GT.I)) THEN C Average arguments together (avoid cycle shifts): IF(NAZI.EQ.NAZL) THEN AZL=FARG(NAZL,NUMBER)+3.141592654 ELSE AZL=FARG(NAZL,NUMBER) ENDIF AZI=FARG(NAZI,I) COSZ=0.5*(COS(AZI)+COS(AZL)) SINZ=0.5*(SIN(AZI)+SIN(AZL)) AZIMUT=ATAN2F(SINZ,COSZ) FARG(NAZI,I)=AZIMUT IF(NAZL.EQ.NAZI) THEN FARG(NAZL,NUMBER)=AZIMUT-3.141592654 ELSE FARG(NAZL,NUMBER)=AZIMUT ENDIF C Print a warning: DAZI=AZI*57.2957795 DAZL=AZL*57.2957795 DAZ=AZIMUT*57.2957795 NP1=NODE1 NP4=NODE4 DELON=57.2957795*YNODE(NODE1) DNLAT=90.-57.2957795*XNODE(NODE1) IF (log_strike_adjustments) WRITE (IUNITT,1610) + I,NUMBER,NP1,NP4, + DNLAT,DELON,DAZI,DAZL,DAZ 1610 FORMAT(' ',I7,3X,I7,3X, + I7,3X,I7,3X, + 2X,F8.3,1X,F9.3, + 4X,F6.1,4X,F6.1,4X,F6.1) ENDIF C ^End block which looks for constraints ENDIF C ^End block which checks for distinct node numbers ENDIF C ^End block which checks for dip of over 75 degrees 1900 CONTINUE C ^End loop on 2 node pairs in fault element 2000 CONTINUE C C (9) Calculate nodal functions at integration points on faults: C CALL FNODAL (INPUT,IUNITT,MXFEL, + MXNODE,NFL,NODEF,XNODE,YNODE, + OUTPUT,FPFLT) C IF (.NOT. BRIEF) WRITE (IUNITT,9999) 9999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE SQUEEZ (INPUT,ALPHAT,density_anomaly_kgpm3,ELEVAT, + GEOTH1,GEOTH2,GEOTH3,GEOTH4, + GEOTH5,GEOTH6,GEOTH7,GEOTH8, + GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, + TEMLIM,ZM,ZSTOP, + OUTPUT,TAUZZ,SIGZZB) C C Calculates TAUZZ, the vertical integral through the plate C of the vertical standardized stress anomaly, which is C relative to a column of mantle with asthenosphere density C with a 5 km crust and a 2.7 km ocean on top, like a mid-ocean C spreading rise of high spreading velocity. C The integral is from either the land surface or the C sea surface, down to a depth of ZSTOP below the top of C the crust. C If ZSTOP exceeds Moho depth ZM, then properties of the mantle C will be used in the lower part of the integral. C Also returns SIGZZB, the standardized vertical stress anomaly C at depth ZSTOP below the solid rock surface. C Note: This version is different from the version found in the LARAMY C program package. First, it acts on only a single point. C Second, it infers sub-plate normal-stress anomalies from C the given topography, instead of from model structure. C Finally, it was modified (in 2005, for Earth5) to accept C the additional input parameter density_anomaly_kgpm3, C which is a density anomaly of chemical origin (applying to C both crust and mantle lithosphere) in addition to the C crust/mantle density difference, and density variations C of thermal origin. C PARAMETER (NDREF=300) LOGICAL CALLED C Internal arrays: DIMENSION DREF(NDREF),PREF(0:NDREF) C Argument arrays: DIMENSION ALPHAT(2),RHOBAR(2),TEMLIM(2) SAVE CALLED,DREF,PREF DATA CALLED /.FALSE./ C C Statement functions: TEMPC(H)=MIN(TEMLIM(1),GEOTH1+GEOTH2*H+GEOTH3*H**2 + +GEOTH4*H**3) TEMPM(H)=MIN(TEMLIM(2),GEOTH5+GEOTH6*H+GEOTH7*H**2 + +GEOTH8*H**3) C C Create reference temperature & density profiles to depth of NDREF km C IF (.NOT.CALLED) THEN RHOTOP=RHOBAR(1)*(1.-ALPHAT(1)*GEOTH1) DREF(1)=RHOH2O DREF(2)=RHOH2O DREF(3)=0.7*RHOH2O+0.3*RHOTOP DREF(4)=RHOTOP DREF(5)=RHOTOP DREF(6)=RHOTOP DREF(7)=RHOTOP DREF(8)=0.7*RHOTOP+0.3*RHOAST DO 50 J=9,NDREF DREF(J)=RHOAST 50 CONTINUE PREF(0)=0. DO 100 I=1,NDREF PREF(I)=PREF(I-1)+DREF(I)*GMEAN*ONEKM 100 CONTINUE ENDIF C C Routine processing (in every CALL): C IF (ELEVAT.GT.0.) THEN C land: ZTOP= -ELEVAT ZBASE=ZSTOP-ELEVAT DENSE1=RHOBAR(1)*(1.-GEOTH1*ALPHAT(1))+ + density_anomaly_kgpm3 H=0. LAYER1=1 ELSE C ocean: ZTOP=0. ZBASE=ZSTOP+(-ELEVAT) DENSE1=RHOH2O H=ELEVAT LAYER1=0 ENDIF LASTDR=ZBASE/ONEKM IF (ZBASE.GT.ONEKM*LASTDR) LASTDR=LASTDR+1 IF (LASTDR.GT.NDREF) THEN WRITE(IUNITT,110) LASTDR 110 FORMAT(' IN SUBPROGRAM SQUEEZ, PARAMETER NDREF '/ + ' MUST BE INCREASED TO AT LEAST ',I10) CALL PAUSE() STOP ENDIF NSTEP=(ZBASE-ZTOP)/ONEKM OLDSZZ=0. OLDPR=0. SIGZZ=0. TAUZZ=0. Z=ZTOP DO 200 I=1,NSTEP Z=Z+ONEKM H=H+ONEKM IF (H.GT.0.) THEN IF (H.LE.ZM) THEN T=TEMPC(H) DENSE2=RHOBAR(1)*(1.-T*ALPHAT(1))+ + density_anomaly_kgpm3 LAYER2=1 ELSE T=TEMPM(H-ZM) DENSE2=RHOBAR(2)*(1.-T*ALPHAT(2))+ + density_anomaly_kgpm3 LAYER2=2 ENDIF ELSE DENSE2=RHOH2O LAYER2=0 ENDIF IF ((LAYER1.EQ.0).AND.(LAYER2.EQ.1)) THEN FRAC2=H/ONEKM FRAC1=1.-FRAC2 ELSE IF ((LAYER1.EQ.1).AND.(LAYER2.EQ.2)) THEN FRAC2=(H-ZM)/ONEKM FRAC1=1.-FRAC2 ELSE FRAC1=0.5 FRAC2=0.5 ENDIF DENSE=FRAC1*DENSE1+FRAC2*DENSE2 IF (Z.GT.0.) THEN N1=Z/ONEKM N2=N1+1 FRAC=Z/ONEKM-N1 PR=PREF(N1)+FRAC*(PREF(N2)-PREF(N1)) ELSE PR=0. ENDIF SIGZZ=SIGZZ-DENSE*GMEAN*ONEKM+(PR-OLDPR) TAUZZ=TAUZZ+0.5*(SIGZZ+OLDSZZ)*ONEKM DENSE1=DENSE2 OLDSZZ=SIGZZ OLDPR=PR LAYER1=LAYER2 200 CONTINUE RESID=ZBASE-Z H=ZSTOP Z=ZBASE IF (ZSTOP.LE.ZM) THEN T=TEMPC(H) DENSE2=RHOBAR(1)*(1.-T*ALPHAT(1))+ + density_anomaly_kgpm3 ELSE T=TEMPM(H-ZM) DENSE2=RHOBAR(2)*(1.-T*ALPHAT(2))+ + density_anomaly_kgpm3 ENDIF DENSE=0.5*(DENSE1+DENSE2) IF (Z.GT.0.) THEN N1=Z/ONEKM N2=N1+1 FRAC=Z/ONEKM-N1 PR=PREF(N1)+FRAC*(PREF(N2)-PREF(N1)) ELSE PR=0. ENDIF SIGZZB=SIGZZ-DENSE*GMEAN*RESID+(PR-OLDPR) TAUZZ=TAUZZ+0.5*(SIGZZB+OLDSZZ)*RESID CALLED=.TRUE. RETURN END C C C SUBROUTINE TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) C C Computes vertical integrals of C stress anomaly relative to vertical stress (TAUMAT). C C The components are: C TAUMAT(1) = vertical integral of (Sxx-Szz) C TAUMAT(2) = vertical integral of (Syy-Szz) C TAUMAT(3) = vertical integral of Sxy. C DIMENSION ALPHA(3,3,7,MXEL),ERATE(3,7,MXEL), + TAUMAT(3,7,MXEL),TOFSET(3,7,MXEL) C DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) TAUMAT(1,M,I)=TOFSET(1,M,I)+EXX*ALPHA(1,1,M,I)+ + EYY*ALPHA(1,2,M,I)+EXY*ALPHA(1,3,M,I) TAUMAT(2,M,I)=TOFSET(2,M,I)+EXX*ALPHA(2,1,M,I)+ + EYY*ALPHA(2,2,M,I)+EXY*ALPHA(2,3,M,I) TAUMAT(3,M,I)=TOFSET(3,M,I)+EXX*ALPHA(3,1,M,I)+ + EYY*ALPHA(3,2,M,I)+EXY*ALPHA(3,3,M,I) 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE THONB (INPUT,BASAL,ECREEP,ETAMAX,FPSFER,GLUE, + ICONVE,MXEL,MXNODE,NODES,NUMEL, + OVB,PULLED,TRHMAX,V, + OUTPUT,ETA,SIGHB, + WORK,OUTVEC) C C Calculates shear stresses on base of plate (SIGHB), using C the vector velocity of the layer below (OVB), and also reports C the linearized coupling coefficient for next iteration (ETA). C DOUBLE PRECISION BASAL,V LOGICAL PULLED DIMENSION BASAL(2,MXNODE), + ETA(7,MXEL),FPSFER(2,2,3,7,MXEL), + GLUE(7,MXEL), + NODES(3,MXEL),OUTVEC(2,7,MXEL), + OVB(2,7,MXEL),PULLED(7,MXEL), + SIGHB(2,7,MXEL), + V(2,MXNODE) C C Small number to prevent division by zero: DATA TINY /2.E-38/ C IF (ICONVE.NE.6) THEN C older code, for defined lower-mantle velocity field. C First, interpolate surface flow to integration points: CALL FLOW (INPUT,FPSFER,MXEL,MXNODE,NODES,NUMEL,V, + OUTPUT,OUTVEC) DO 1000 M=1,7 DO 900 I=1,NUMEL IF (PULLED(M,I)) THEN VCX=OUTVEC(1,M,I) VCY=OUTVEC(2,M,I) VMX=OVB(1,M,I) VMY=OVB(2,M,I) VRX=VMX-VCX VRY=VMY-VCY VMAG=SQRT((1.D0*VRX)**2+(1.D0*VRY)**2) IF (VMAG.GT.0.) THEN SHEAR1=GLUE(M,I)*VMAG**ECREEP ELSE SHEAR1=0. END IF SHEAR2=TRHMAX SHEAR3=ETAMAX*VMAG SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3) ETA(M,I)=SHEAR/MAX(TINY,VMAG) ETA(M,I)=MIN(ETA(M,I),ETAMAX) SIGHB(1,M,I)=ETA(M,I)*VRX SIGHB(2,M,I)=ETA(M,I)*VRY ELSE ETA(M,I)=0.0 SIGHB(1,M,I)=0.0 SIGHB(2,M,I)=0.0 END IF 900 CONTINUE 1000 CONTINUE ELSE C new code for ICONVE.EQ.6: use nodal values of shear traction C vectors contained in BASAL, and interpolate: CALL FLOW (INPUT,FPSFER,MXEL,MXNODE,NODES,NUMEL,BASAL, + OUTPUT,SIGHB) C next, interpolate surface velocity (as above) to compare C to values in OVB, for computation of ETA: CALL FLOW (INPUT,FPSFER,MXEL,MXNODE,NODES,NUMEL,V, + OUTPUT,OUTVEC) DO 2000 M=1,7 DO 1900 I=1,NUMEL VCX=OUTVEC(1,M,I) VCY=OUTVEC(2,M,I) VMX=OVB(1,M,I) VMY=OVB(2,M,I) VRX=VMX-VCX VRY=VMY-VCY VMAG=SQRT((1.D0*VRX)**2+(1.D0*VRY)**2) IF (VMAG.GT.0.) THEN SHEAR1=SQRT(SIGHB(1,M,I)**2+SIGHB(2,M,I)**2) ELSE SHEAR1=0. END IF SHEAR2=TRHMAX SHEAR3=ETAMAX*VMAG SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3) ETA(M,I)=SHEAR/MAX(TINY,VMAG) ETA(M,I)=MIN(ETA(M,I),ETAMAX) 1900 CONTINUE 2000 CONTINUE ENDIF RETURN END C C C SUBROUTINE TRACT(INPUT,IUNITR,IUNITT,NPLATE,NUMNOD, + SLAB_Q,WHICHP,XNODE,YNODE, + OUTPUT,BASAL) C C Requests file name of an existing torque report C (including traction pole vectors for each plate, C created by a previous experiment with SHELLS, C usually one that had TRHMAX = 0. and extra internal C velocity boundary conditions for each slabless plate). C Reads this file, extracts the traction pole vectors, C and uses them to precompute basal shear tractions C on each node. C For further clarification of "traction pole vectors" C see subprogram -TWIST- below. C IMPLICIT NONE DOUBLE PRECISION BASAL INTEGER INPUT,IUNITR,IUNITT,NPLATE,NUMNOD,WHICHP LOGICAL SLAB_Q REAL OUTPUT,XNODE,YNODE DIMENSION SLAB_Q(NPLATE),WHICHP(NUMNOD), + XNODE(NUMNOD),YNODE(NUMNOD) DIMENSION BASAL(2,NUMNOD) C CHARACTER*132 LINE,TRQFIL INTEGER I,IOS,IPLATE,J LOGICAL, DIMENSION(:), ALLOCATABLE :: TPREAD REAL EQUAT,LAT,LENGTH,LON,T,TEQUAT REAL, DIMENSION(3) :: TVEC,UPHI,UTHETA,UVEC REAL, DIMENSION(:,:), ALLOCATABLE :: TPVECS C 10 WRITE(*,"(/' A torque report file with traction pole vectors ' + /' is needed to compute basal shear tractions.' + /' Please enter name of an existing q*.out file:')") READ(*,"(A)") TRQFIL OPEN(UNIT=IUNITR,FILE=TRIM(TRQFIL),STATUS="OLD",IOSTAT=IOS) IF (IOS.NE.0) THEN WRITE(*,"(' ERROR. File not found (in current directory).')") CALL PAUSE() GOTO 10 ENDIF WRITE(IUNITT,"(/' Reading existing torque report: ',A + /' for traction pole vectors' + ,' (because ICONVE == 6).')") TRIM(TRQFIL) ALLOCATE (TPVECS(3,NPLATE)) ALLOCATE (TPREAD(NPLATE)) C Zero whole array; advisable because some plates may not C appear in report. DO 30 J=1,NPLATE DO 20 I=1,3 TPVECS(I,J)=0. 20 CONTINUE TPREAD(J)=.FALSE. 30 CONTINUE C Waste first 6 lines (titles & 2 blanks & header) of torque file. DO 40 I=1,6 READ (IUNITR,"(A)") line 40 CONTINUE C Loop on plates in report (up to NPLATE for whole-Earth model): DO 100 J=1,NPLATE READ(IUNITR,*,IOSTAT=IOS) IF (IOS.EQ.-1) GOTO 101 READ(IUNITR,"(8X,I6)",IOSTAT=IOS) IPLATE IF (IOS.EQ.-1) GOTO 101 C Waste 23 more lines of each plate report DO 50 I=1,23 READ(IUNITR,*,IOSTAT=IOS) IF (IOS.EQ.-1) GOTO 101 50 CONTINUE READ(IUNITR,"(56X,ES10.3,2F10.2)") T,LON,LAT C T is magnitude, in Pa, at location 90 deg. from (LON, LAT). TPVECS(1,IPLATE)=T*COS(LAT/57.296)*COS(LON/57.296) TPVECS(2,IPLATE)=T*COS(LAT/57.296)*SIN(LON/57.296) TPVECS(3,IPLATE)=T*SIN(LAT/57.296) TPREAD(IPLATE)=.TRUE. C Waste 14 lines to get past the "=======" at the bottom of C each torque report: DO 60 I=1,14 READ(IUNITR,*,IOSTAT=IOS) IF (IOS.EQ.-1) GOTO 101 60 CONTINUE 100 CONTINUE 101 CLOSE(IUNITR) C DO 200 I=1,NUMNOD IPLATE=WHICHP(I) IF (SLAB_Q(IPLATE)) THEN C no need for inferred basal-strength traction: BASAL(1,I)=0.0D0 BASAL(2,I)=0.0D0 ELSE IF (TPREAD(IPLATE)) THEN C C Uvec is unit vector to node location: UVEC(1)=SIN(XNODE(I))*COS(YNODE(I)) UVEC(2)=SIN(XNODE(I))*SIN(YNODE(I)) UVEC(3)=COS(XNODE(I)) C C Tvec is cross-product with traction pole vector: TVEC(1)=TPVECS(2,IPLATE)*UVEC(3)- + TPVECS(3,IPLATE)*UVEC(2) TVEC(2)=TPVECS(3,IPLATE)*UVEC(1)- + TPVECS(1,IPLATE)*UVEC(3) TVEC(3)=TPVECS(1,IPLATE)*UVEC(2)- + TPVECS(2,IPLATE)*UVEC(1) T=SQRT(TVEC(1)**2+TVEC(2)**2+TVEC(3)**2) C C Unit vectors at this site (NOT a pole): UPHI(1)= -UVEC(2) UPHI(2)=UVEC(1) EQUAT=SIN(XNODE(I)) UPHI(1)=UPHI(1)/EQUAT UPHI(2)=UPHI(2)/EQUAT UPHI(3)=0.0 C TEQUAT=UVEC(3) UTHETA(3)= -EQUAT UTHETA(1)=TEQUAT*UVEC(1)/EQUAT UTHETA(2)=TEQUAT*UVEC(2)/EQUAT LENGTH=SQRT(UTHETA(1)**2+UTHETA(2)**2+ + UTHETA(3)**2) UTHETA(1)=UTHETA(1)/LENGTH UTHETA(2)=UTHETA(2)/LENGTH UTHETA(3)=UTHETA(3)/LENGTH C C Horizontal components of shear traction: BASAL(1,I)=TVEC(1)*UTHETA(1)+TVEC(2)*UTHETA(2)+ + TVEC(3)*UTHETA(3) BASAL(2,I)=TVEC(1)*UPHI(1)+TVEC(2)*UPHI(2)+ + TVEC(3)*UPHI(3) ELSE BASAL(1,I)=0.0D0 BASAL(2,I)=0.0D0 ENDIF ENDIF 200 CONTINUE C DEALLOCATE (TPREAD) DEALLOCATE (TPVECS) C RETURN END C C C SUBROUTINE TWIST(INPUT,AREA,DETJ,FPSFER, + N,NODES,NPLATE,NUMEL,NUMNOD, + RADIUS,TORQBS,WHICHP,XNODE,YNODE, + OUTPUT,TWISTV) C C Computes the twist pole vector TWISTV(3) that will apply basal- C strength torque TORQBS(1:3,N) to plate N, if used in a CONVEC=6 C basal boundary condition in the next run of SHELLS. C C The area, shape, and position of plate N are represented by C information in NODES and WHICHP. C C A twist pole vector has units of shear traction (Pa), C and can be used to compute basal shear traction according to: C C basal_shear_traction = TWISTV x UVEC {vector cross product}, C C where UVEC is a dimensionless unit vector giving position. C Thus the magnitude (length) of TWISTV represents the largest C basal traction, applying to points 90 degrees from the pole. C The 3 components of TWISTV are Cartesian (x,y,z) measured C from the center of the planet, as with UVECs. C C The solution is achieved by setting up a 3 x 3 linear system: C C For further clarification, read subprogram -TRACT- above. C C TORQBS(1,N) C11 C12 C13 TWISTV(1) C TORQBS(2,N) = C21 C22 C23 TWISTV(2) C TORQBS(3,N) C31 C32 C33 TWISTV(3) C C which is then inverted to get TWISTV(1:3). C C Each column of the C matrix is computed by integrating a C hypothetical case: for example, column 1, transposed as C (C11, C21, C31) gives the (x, y, z) components of the C basal torque on plate N that would be produced if C TWISTV(1:3) = (1., 0., 0.). C C Linear system of equations is solved by LSLRG from C I.M.S.L. (International Mathematics Subroutine Library). USE Numerical_Libraries C REAL, DIMENSION(NUMEL) :: AREA REAL, DIMENSION(7,NUMEL) :: DETJ REAL, DIMENSION(2,2,3,7,NUMEL) :: FPSFER INTEGER, DIMENSION(3,NUMEL) :: NODES DOUBLE PRECISION, DIMENSION(3,NPLATE) :: TORQBS REAL, DIMENSION(3) :: TWISTV INTEGER, DIMENSION(NUMNOD) :: WHICHP REAL, DIMENSION(NUMNOD) :: XNODE, YNODE C REAL :: LENGTH REAL, DIMENSION(3,3) :: C REAL, DIMENSION(3) :: FXYZ, RVEC, TQBS, UPHI, UTHETA, UVEC REAL, DIMENSION(3,7) :: PHIM, THETAM, UVECM C C Named COMMON blocks hold the fixed values of the positions, C weights, and nodal function values at the integration points C in the elements (triangular elements in BLOCK DATA BD1, C and fault elements in BLOCK DATA BD2). C Entries corresponding to BD1: DOUBLE PRECISION POINTS,WEIGHT COMMON /S1S2S3/ POINTS COMMON /WGTVEC/ WEIGHT DIMENSION POINTS(3,7),WEIGHT(7) C C Compute the 3 hypothetical cases: DO 100 J=1,3 DO 5 I=1,3 C(I,J)=0. TWISTV(I)=0. 5 CONTINUE TWISTV(J)=1. C C Integrate over elements belonging ENTIRELY to plate N: DO 90 L=1,NUMEL N1=NODES(1,L) N2=NODES(2,L) N3=NODES(3,L) IP1=WHICHP(N1) IP2=WHICHP(N2) IP3=WHICHP(N3) IF ((IP1.EQ.N).AND.(IP2.EQ.N).AND.(IP3.EQ.N)) THEN CALL ELUVEC(INPUT,N1,N2,N3,NUMNOD,XNODE,YNODE, + OUTPUT,PHIM,THETAM,UVECM) C Numerical integration over area, with 7 Gauss C integration points: DO 80 M=1,7 DAREA=AREA(L)*DETJ(M,L)*WEIGHT(M) C Basal shear tractions for this case C ...in 3-D (x, y, z): FXYZ(1)=TWISTV(2)*UVECM(3,M)- + TWISTV(3)*UVECM(2,M) FXYZ(2)=TWISTV(3)*UVECM(1,M)- + TWISTV(1)*UVECM(3,M) FXYZ(3)=TWISTV(1)*UVECM(2,M)- + TWISTV(2)*UVECM(1,M) C ...in 2-D (X = +theta = S; Y = +phi = E): SHX=FXYZ(1)*THETAM(1,M)+FXYZ(2)*THETAM(2,M)+ + FXYZ(3)*THETAM(3,M) SHY=FXYZ(1)*PHIM(1,M)+FXYZ(2)*PHIM(2,M)+ + FXYZ(3)*PHIM(3,M) C Three nodal functions: DO 70 K=1,3 NODE=NODES(K,L) C C Contribution to consistent nodal forces: C FORCEX=DAREA*(SHX*FPSFER(1,1,K,M,L) + +SHY*FPSFER(1,2,K,M,L)) FORCEY=DAREA*(SHX*FPSFER(2,1,K,M,L) + +SHY*FPSFER(2,2,K,M,L)) C C Uvec of this node: C TTHETA=XNODE(NODE) PPHI=YNODE(NODE) EQUAT=SIN(TTHETA) UVEC(1)=EQUAT*COS(PPHI) UVEC(2)=EQUAT*SIN(PPHI) UVEC(3)=COS(TTHETA) C C Unit vectors at this site (NOT a pole): C UPHI(1)= -UVEC(2) UPHI(2)=UVEC(1) UPHI(1)=UPHI(1)/EQUAT UPHI(2)=UPHI(2)/EQUAT UPHI(3)=0.0 TEQUAT=UVEC(3) UTHETA(3)= -EQUAT UTHETA(1)=TEQUAT*UVEC(1)/EQUAT UTHETA(2)=TEQUAT*UVEC(2)/EQUAT LENGTH=SQRT(UTHETA(1)**2+UTHETA(2)**2+ + UTHETA(3)**2) UTHETA(1)=UTHETA(1)/LENGTH UTHETA(2)=UTHETA(2)/LENGTH UTHETA(3)=UTHETA(3)/LENGTH C C Consistent nodal force in (x,y,z): C FXYZ(1)=FORCEX*UTHETA(1)+FORCEY*UPHI(1) FXYZ(2)=FORCEX*UTHETA(2)+FORCEY*UPHI(2) FXYZ(3)=FORCEX*UTHETA(3)+FORCEY*UPHI(3) C C Nodal forces x moment arms: C RVEC(1)=RADIUS*UVEC(1) RVEC(2)=RADIUS*UVEC(2) RVEC(3)=RADIUS*UVEC(3) C C Sum up the torque for this hypothetical: C C(1,J)=C(1,J)+ + RVEC(2)*FXYZ(3)-RVEC(3)*FXYZ(2) C(2,J)=C(2,J)+ + RVEC(3)*FXYZ(1)-RVEC(1)*FXYZ(3) C(3,J)=C(3,J)+ + RVEC(1)*FXYZ(2)-RVEC(2)*FXYZ(1) 70 CONTINUE 80 CONTINUE END IF 90 CONTINUE 100 CONTINUE C C Now the C matrix is finished. C Set up the inverse problem and solve it. C TQBS(1)=TORQBS(1,N) TQBS(2)=TORQBS(2,N) TQBS(3)=TORQBS(3,N) CALL LSLRG (3,C,3,TQBS,1,TWISTV) C RETURN END C C C SUBROUTINE VBCS (INPUT,ICOND,MXBN,MXDOF,MXNODE, + NCOND,NDOF,NLB,NODCON,NUB, + VBCARG,VBCMAG, + MODIFY,F,K,V) C C Impose velocity boundary conditions. C Replace the equilibrium equation(s) for any fixed-velocity node C with trivial equation(s) saying that the velocity C is equal to that desired. In the case of ICOND(I)=1 or 3, only C one component is to be specified; this is done by rotating the C equilibrium equations to new directions (while keeping the C velocity variables unchagned) and replacing only the redundant C equation, then rotating back. In any case, the weight used for C such constraint equations is equal to the largest diagonal element C already in the K matrix (to preserve its condition number). C DOUBLE PRECISION F,K,TOPONE,V DIMENSION ICOND(MXBN),F(MXDOF),NODCON(MXBN), + V(2,MXNODE),VBCARG(MXBN),VBCMAG(MXBN),K(MXWORK) COMMON LDA,NUCA,MXWORK C C Statement function replacing INTEGER FUNCTION subprogram -INDEXK-: INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + NUCA + IROW - JCOLUM + 1 C TOPONE=0.D0 DO 10 I=1,NDOF TOPONE=MAX(TOPONE,K(INDEXK(I,I))) 10 CONTINUE C DO 100 I=1,NCOND NODE=NODCON(I) C C Nodes are constrained by modifying the linear system: C IF ((ICOND(I).EQ.1).OR.(ICOND(I).EQ.3)) THEN C Impose component in the direction VBCARG, C but leave the perpendicular component free: CALL ROTOR (INPUT,MXDOF,NDOF,NLB,NODE, + NUB,VBCARG(I), + MODIFY,F,K) IRCON=2*NODE-1 F(IRCON)=VBCMAG(I)*TOPONE J1=MAX(1,IRCON-NLB) J2=MIN(NDOF,IRCON+NUB) DO 20 JCOLUM=J1,J2 K(INDEXK(IRCON,JCOLUM))=0.0D0 20 CONTINUE K(INDEXK(IRCON,IRCON ))=TOPONE*COS(VBCARG(I)) K(INDEXK(IRCON,IRCON+1))=TOPONE*SIN(VBCARG(I)) C CALL ROTOR (INPUT,MXDOF,NDOF,NLB,NODE, C + NUB,-VBCARG(I), C + MODIFY,F,K) ELSE IF ((ICOND(I).EQ.2).OR.(ICOND(I).EQ.4).OR. + (ICOND(I).EQ.5)) THEN C Impose both components of velocity: VBCX=VBCMAG(I)*COS(VBCARG(I)) VBCY=VBCMAG(I)*SIN(VBCARG(I)) IROWX=2*NODE-1 IROWY=2*NODE F(IROWX)=VBCX*TOPONE F(IROWY)=VBCY*TOPONE J1=MAX(1,IROWX-NLB) J2=MIN(NDOF,IROWX+NUB) DO 50 JCOLUM=J1,J2 K(INDEXK(IROWX,JCOLUM))=0.0D0 50 CONTINUE K(INDEXK(IROWX,IROWX))=TOPONE J1=MAX(1,IROWY-NLB) J2=MIN(NDOF,IROWY+NUB) DO 60 JCOLUM=J1,J2 K(INDEXK(IROWY,JCOLUM))=0.0D0 60 CONTINUE K(INDEXK(IROWY,IROWY))=TOPONE ENDIF 100 CONTINUE C RETURN END C C C SUBROUTINE VISCOS (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,DCREEP,delta_rho,ECREEP, + ERATE,FRIC,G,GEOTHC,GEOTHM, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,TLINT, + VISMAX,ZMOHO, + OUTPUT,ALPHA,SCOREC,SCORED,TOFSET,ZTRANC) C C Computes tactical partial-derivitive tensor ALPHA(3,3,7,NUMEL) C (partial derivitives of vertically-integrated stresses C tau.ij [where normal components are relative to vertical stress] C with respect to strain-rates e.kl) C in 3 x 3 component form, from 2 x 2 principal-axis form C provided by DIAMND, at each integration point of each element. C Also records intercept values (TOFSET(3,7,NUMEL)) for next iteration C Calculation of TAUMAT = TOFSET + ALPHA*E will give model C relative stress integrals (relative to vertical stress integral). C ZTRANC(2,7,NUMEL) is the depth into the (1:crust, 2:mantle) where C the brittle/ductile transition occurs, for each integration point C of each element. Note: "C" in the name stands for "Continuum" C (as opposed to Fault), not for "Crust". C SCOREC and SCORED are measures of mismatch between current C linearized and actual nonlinear rheologies: C SCOREC is the maximum (absolute value) err0r in tau [N/m]; C SCORED is the mean-err0r/mean-value [dimensionless; <=1?]. C C New version, May 5, 1998, by Peter Bird; intended to improve C the convergence behavior of all F-E programs which use it. C For an elementary (not comprehensive) test of VISCOS, C see test program ISOTROPY.for, 1998.4.18, which shows that C it preserves linear-viscous behavior in all 3 branches C of its code (when linear-viscous behavior is reported by DIAMND). C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C External variables and arrays INTEGER I, INPUT, M, MXEL, NUMEL REAL BIOT, ECREEP, FRIC, G, + OUTPUT, RHOH2O, SCOREC, SCORED, VISMAX REAL ACREEP(2), ALPHA(3,3,7,MXEL), + ALPHAT(2), BCREEP(2), + CCREEP(2), DCREEP(2), + delta_rho(7,MXEL), + ERATE(3,7,MXEL), + GEOTHC(4,7,MXEL), GEOTHM(4,7,MXEL), + RHOBAR(2), SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL), TEMLIM(2), + TLINT(7,MXEL), TOFSET(3,7,MXEL), + ZMOHO(7,MXEL), ZTRANC(2,7,MXEL) C External function: REAL ATAN2F C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C Internal variables and arrays: REAL CENTER, DELP2, DENOM, DENOM0, DENOM1, DIVER, + DANDEX, DANDEY, DANDES, + DE1DEX, DE1DEY, DE1DES, + DE2DEX, DE2DEY, DE2DES, + DTSDE1, DTSDE2, + DTSDT1, DTSDT2, DTSDAN, + DTXDE1, DTXDE2, + DTXDT1, DTXDT2, DTXDAN, + DTYDE1, DTYDE2, + DTYDT1, DTYDT2, DTYDAN, + DT1DE1, DT1DE2, DT2DE1, DT2DE2, + DXX, DXY, DYY, + EXX, EXY, EYY, E1, E2, PL0, PW0, + PT1DE1, PT1DE2, PT2DE1, PT2DE2, + PT1, PT2, PTXX, PTXY, PTYY, + R, RHOUSE, + SHEAR, SHEAR2, SIGHBI, + THETA, THICKC, THICKM, TMEAN, TXX, TXY, TYY, + ZOFTOP, ZTRAN(2) C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C C Initialize sums to be used in computation of scores: SCOREC=0. SCORED=0. DENOM0=0. DENOM1=0. C DO 1000 M=1,7 DO 900 I=1,NUMEL C C ----------- rheology (& ZTRANC) section ------------ C C Extract data for this integration point, as scalars: SIGHBI=SQRT((1.D0*SIGHB(1,M,I))**2+ + (1.D0*SIGHB(2,M,I))**2) THICKC=ZMOHO(M,I) THICKM=TLINT(M,I) EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) C C Guard against special case of zero strain-rate: IF ((EXX.EQ.0.).AND.(EXY.EQ.0.).AND.(EYY.EQ.0.)) THEN TXX=0. TXY=0. TYY=0. C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) ALPHA(1,1,M,I)=4.*VISMAX*(THICKC+THICKM) ALPHA(1,2,M,I)=2.*VISMAX*(THICKC+THICKM) ALPHA(1,3,M,I)=0. ALPHA(2,1,M,I)=2.*VISMAX*(THICKC+THICKM) ALPHA(2,2,M,I)=4.*VISMAX*(THICKC+THICKM) ALPHA(2,3,M,I)=0. ALPHA(3,1,M,I)=0. ALPHA(3,2,M,I)=0. ALPHA(3,3,M,I)=2.*VISMAX*(THICKC+THICKM) TOFSET(1,M,I)=0. TOFSET(2,M,I)=0. TOFSET(3,M,I)=0. ZTRANC(1,M,I)=0. C Note: "C" is for Continuum, not for Crust! C 1st subscript is: (1:crust; 2:mantle). ZTRANC(2,M,I)=0. ELSE C (strain-rate tensor is not zero) C Find principal strain-rates (E1 <= E2) C in the horizontal plane: DIVER=EXX+EYY R=SQRT((1.D0*EXY)**2+(0.5D0*(EXX-EYY))**2) E1=0.5*DIVER-R E2=0.5*DIVER+R THETA=ATAN2F(2.*EXY,EXX-EYY) C see (29) of Bird (1989); C THETA is like angular coordinate of Mohr's circles C of strain-rate and also of stress; C THETA = 0 when EXX > EYY and EXY =0; C THETA = small, + when EXY > 0, EXX > EYY; C THETA = Pi when EXY = 0, EYY > EXX. C C Prepare to sum tau (and derivitives) over layers: TXX=0. TXY=0. TYY=0. DT1DE1=0. DT1DE2=0. DT2DE1=0. DT2DE2=0. C IF (THICKC.GT.0) THEN ZOFTOP=0. PL0=0. PW0=0. rho_use = RHOBAR(1) + delta_rho(M,I) CALL DIAMND (INPUT,ACREEP(1),ALPHAT(1), + BCREEP(1),BIOT, + CCREEP(1),DCREEP(1), + ECREEP, + E1,E2,FRIC,G, + GEOTHC(1,M,I), + GEOTHC(2,M,I), + GEOTHC(3,M,I), + GEOTHC(4,M,I), + PL0,PW0, + rho_use,RHOH2O,SIGHBI, + THICKC,TEMLIM(1), + VISMAX,ZOFTOP, + OUTPUT,PT1DE1,PT1DE2, + PT2DE1,PT2DE2, + PT1,PT2,ZTRAN(1)) CENTER=0.5*(PT1+PT2) SHEAR=0.5*(PT2-PT1) PTXX=CENTER+SHEAR*COS(THETA) PTYY=CENTER-SHEAR*COS(THETA) PTXY=SHEAR*SIN(THETA) C Add contribution of crust to total: TXX=TXX+PTXX TXY=TXY+PTXY TYY=TYY+PTYY DT1DE1=DT1DE1+PT1DE1 DT1DE2=DT1DE2+PT1DE2 DT2DE1=DT2DE1+PT2DE1 DT2DE2=DT2DE2+PT2DE2 ZTRANC(1,M,I)=ZTRAN(1) ELSE ZTRANC(1,M,I)=0. END IF C IF (THICKM.GT.0) THEN ZOFTOP=THICKC PW0=RHOH2O*G*THICKC TMEAN=GEOTHC(1,M,I)+ + 0.5*GEOTHC(2,M,I)*THICKC+ + 0.333*GEOTHC(3,M,I)*THICKC**2+ + 0.25*GEOTHC(4,M,I)*THICKC**3 RHOUSE=RHOBAR(1)*(1.-ALPHAT(1)*TMEAN) PL0=RHOUSE*G*THICKC rho_use = RHOBAR(2) + delta_rho(M,I) CALL DIAMND (INPUT,ACREEP(2),ALPHAT(2), + BCREEP(2),BIOT, + CCREEP(2),DCREEP(2), + ECREEP, + E1,E2,FRIC,G, + GEOTHM(1,M,I), + GEOTHM(2,M,I), + GEOTHM(3,M,I), + GEOTHM(4,M,I), + PL0,PW0, + rho_use,RHOH2O,SIGHBI, + THICKM,TEMLIM(2), + VISMAX,ZOFTOP, + OUTPUT,PT1DE1,PT1DE2, + PT2DE1,PT2DE2, + PT1,PT2,ZTRAN(2)) CENTER=0.5*(PT1+PT2) SHEAR=0.5*(PT2-PT1) PTXX=CENTER+SHEAR*COS(THETA) PTYY=CENTER-SHEAR*COS(THETA) PTXY=SHEAR*SIN(THETA) TXX=TXX+PTXX TXY=TXY+PTXY TYY=TYY+PTYY DT1DE1=DT1DE1+PT1DE1 DT1DE2=DT1DE2+PT1DE2 DT2DE1=DT2DE1+PT2DE1 DT2DE2=DT2DE2+PT2DE2 ZTRANC(2,M,I)=ZTRAN(2) ELSE ZTRANC(2,M,I)=0. END IF C C ---------- ALPHA and TOFSET section ------------- C (cases of non-zero strain-rate) C IF (R.LE.0.) THEN C Pathological case: EXY = 0, EXX = EYY /= 0. C See notes from derivations of 18 April 1998; C based on (28) of Bird(1989), but not using C (29) because r = 0 and alpha is undefined. C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) ALPHA(1,1,M,I)=DT2DE2 ALPHA(1,2,M,I)=DT1DE2 ALPHA(1,3,M,I)=0. ALPHA(2,1,M,I)=DT1DE2 ALPHA(2,2,M,I)=DT2DE2 ALPHA(2,3,M,I)=0. ALPHA(3,1,M,I)=0. ALPHA(3,2,M,I)=0. ALPHA(3,3,M,I)=0.5*(DT1DE1-DT2DE1- + DT1DE2+DT2DE2) ELSE C typical case, r > 0: see p. 3976 in Bird (1989). DE1DEX=0.5-((EXX-EYY)/(4.*R)) DE1DEY=0.5+((EXX-EYY)/(4.*R)) DE1DES= -EXY/R DE2DEX=DE1DEY DE2DEY=DE1DEX DE2DES= -DE1DES DANDEX= -SIN(THETA)/(2.*R) C Note: Formula above is equivalent to (29) of C Bird (1989), but less likely to be singular. DANDEY= -DANDEX DANDES=COS(THETA)/R C Note: Formula above is equivalent to (29) of C Bird (1989), but less likely to be singular. DTXDT1=0.5*(1.-COS(THETA)) DTXDT2=0.5*(1.+COS(THETA)) DTXDAN= -TXY DTYDT1=DTXDT2 DTYDT2=DTXDT1 DTYDAN=TXY DTSDT1= -0.5*SIN(THETA) DTSDT2= -DTSDT1 SHEAR=SQRT(TXY**2+(0.5*(TXX-TYY))**2) DTSDAN=SHEAR*COS(THETA) C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) DTXDE1=DTXDT1*DT1DE1+DTXDT2*DT2DE1 DTXDE2=DTXDT1*DT1DE2+DTXDT2*DT2DE2 ALPHA(1,1,M,I)= + DTXDE1*DE1DEX+DTXDE2*DE2DEX+DTXDAN*DANDEX ALPHA(1,2,M,I)= + DTXDE1*DE1DEY+DTXDE2*DE2DEY+DTXDAN*DANDEY ALPHA(1,3,M,I)= + DTXDE1*DE1DES+DTXDE2*DE2DES+DTXDAN*DANDES DTYDE1=DTYDT1*DT1DE1+DTYDT2*DT2DE1 DTYDE2=DTYDT1*DT1DE2+DTYDT2*DT2DE2 ALPHA(2,1,M,I)= + DTYDE1*DE1DEX+DTYDE2*DE2DEX+DTYDAN*DANDEX ALPHA(2,2,M,I)= + DTYDE1*DE1DEY+DTYDE2*DE2DEY+DTYDAN*DANDEY ALPHA(2,3,M,I)= + DTYDE1*DE1DES+DTYDE2*DE2DES+DTYDAN*DANDES DTSDE1=DTSDT1*DT1DE1+DTSDT2*DT2DE1 DTSDE2=DTSDT1*DT1DE2+DTSDT2*DT2DE2 ALPHA(3,1,M,I)= + DTSDE1*DE1DEX+DTSDE2*DE2DEX+DTSDAN*DANDEX ALPHA(3,2,M,I)= + DTSDE1*DE1DEY+DTSDE2*DE2DEY+DTSDAN*DANDEY ALPHA(3,3,M,I)= + DTSDE1*DE1DES+DTSDE2*DE2DES+DTSDAN*DANDES END IF C ----------- TOFSET section ------------------ C (case of non-zero strain rate) TOFSET(1,M,I)=TXX-ALPHA(1,1,M,I)*EXX + -ALPHA(1,2,M,I)*EYY + -ALPHA(1,3,M,I)*EXY TOFSET(2,M,I)=TYY-ALPHA(2,1,M,I)*EXX + -ALPHA(2,2,M,I)*EYY + -ALPHA(2,3,M,I)*EXY TOFSET(3,M,I)=TXY-ALPHA(3,1,M,I)*EXX + -ALPHA(3,2,M,I)*EYY + -ALPHA(3,3,M,I)*EXY END IF CC C ---------- SCORE section ----------------- C C Build tentative denominator for score, based C on old values of TAUMAT (tau relative to vertical). DELP2=(0.5*(TAUMAT(1,M,I)+TAUMAT(2,M,I)))**2 SHEAR2=TAUMAT(3,M,I)**2+ + (0.5*(TAUMAT(1,M,I)-TAUMAT(2,M,I)))**2 DENOM0=DENOM0+SQRT(MAX(DELP2,SHEAR2)) C C Build alternative denominator for score, based C on new values of TXX,TXY,TYY (tau relative to vertical). DELP2=(0.5*(TXX+TYY))**2 SHEAR2=TXY**2+(0.5*(TXX-TYY))**2 DENOM1=DENOM1+SQRT(MAX(DELP2,SHEAR2)) C C Evaluate difference between old and new tau: DXX=TAUMAT(1,M,I)-TXX DYY=TAUMAT(2,M,I)-TYY DXY=TAUMAT(3,M,I)-TXY DELP2=(0.5*(DXX+DYY))**2 SHEAR2=(0.5*(DXX-DYY))**2+DXY**2 SCOREC=MAX(SCOREC,SQRT(DELP2),SQRT(SHEAR2)) SCORED=SCORED+SQRT(MAX(DELP2,SHEAR2)) C 900 CONTINUE 1000 CONTINUE C C In computing SCORED, use larger of (old, new) denominators: DENOM=MAX(DENOM0,DENOM1) IF (DENOM.GT.0.) THEN SCORED=SCORED/DENOM ELSE SCORED=0.0 END IF C C NOTE: SCOREC is already computed in loop above. C RETURN END C C C SUBROUTINE ZEROK (INPUT,NDOF,NLB,NUB, + OUTPUT,STIFF) C C Zero the parts of the stiffness matrix with physical meaning. C (Other parts will be used for temporary storage; need not be 0.) C DOUBLE PRECISION STIFF DIMENSION STIFF(MXWORK) COMMON LDA,NUCA,MXWORK C C Statement function replacing INTEGER FUNCTION subprogram -INDEXK-: INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + NUCA + IROW - JCOLUM + 1 C DO 100 IROW=1,NDOF DO 90 JCOLUM=MAX(1,IROW-NLB),MIN(NDOF,IROW+NUB) STIFF(INDEXK(IROW,JCOLUM))=0.0D0 90 CONTINUE 100 CONTINUE RETURN END