PROGRAM FAULTS C ======================== FAULTS =============================== C ========== (CALIFORNIA FINITE-ELEMENT PROGRAM #4) ============= C C BY C PETER BIRD, C DEPARTMENT OF EARTH AND SPACE SCIENCES, C UNIVERSITY OF CALIFORNIA, LOS ANGELES, CALIFORNIA 90095-1567 C (310) 825-1126 pbird@ess.ucla.edu C (WITH ASSISTANCE FROM JOHN BAUMGARDNER AND XIANGHONG KONG). C FOR VERSION DATE, SEE FORMAT OF FIRST "WRITE" BELOW. C C FEATURES/ADVANTAGES: C -------------------- C *USES THE "THIN PLATE" OR "2.5-DIMENSIONAL" METHOD TO MODEL C 3-DIMENSIONAL VARIATIONS IN CRUSTAL TEMPERATURE AND C RHEOLOGY AND STRESS, WITH THE LOW COST OF A 2-DIMENSIONAL GRID; C *EXACT TREATMENT OF MOHR-COULOMB-NAVIER FRICTION IN THE COOL UPPER C CRUST; 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 EITHER STRAIGHT OR CURVED FAULT C ELEMENTS. FAULTS MAY INTERSECT IN "TECTONIC KNOTS" OF GREAT C COMPLEXITY. FAULTS MAY HAVE A LOWER FRICTION THAN CRUSTAL BLOCKS, C IF DESIRED; 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 AND EARTHQUAKE RECURRENCE; C *ALL STRESSES ARE REDUCED (FOR CONVENIENCE AND PRECISION) BY C SUBTRACTION OF AN ISOTROPIC PRESSURE WHICH IS A FUNCTION OF C ELEVATION (*NOT* DEPTH BELOW THE SURFACE) ONLY. THIS PRESSURE C IS BASED ON THE STRUCTURE IN THE SYMMETRY PLANE OF MID-OCEAN C SPREADING RISES, WHERE THERE IS ALMOST ISOTROPIC, LITHOSTATIC C STRESS; C *INPUT ARRAYS AND PARAMETERS ARE ECHOED IN THE OUTPUT, TO PROVIDE C A COMPLETE RECORD OF THE NUMERICAL EXPERIMENTS PERFORMED; C *EXTENSIVE PRE-CHECKING OF THE GRID TOPOLOGY IS PERFORMED, AND WILL C AUTOMATICALLY CATCH MOST ERR0RS IN THE INPUT; C *RESIZING OF ALL ARRAYS CAN BE DONE BY CHANGING A FEW PARAMETER C STATEMENTS (ARRAY SIZES ARE AUTOMATICALLY CHECKED FOR OVERFLOW); C *CODE IS UNIT-FREE, AND WORKS EQUALLY WELL WITH SI, CGS, OR ENGLISH C INPUT DATA (AS LONG AS ALL INPUTS ARE SELF-CONSISTENT!). C C LIMITATIONS/DISADVANTAGES: C -------------------------- C *MODEL PLANE IS FLAT (THE CARTESIAN X,Y PLANE) AND DOES NOT REPRESENT C THE CURVATURE OF THE EARTH; 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 CRUST IS ZERO; 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 THIS C FIX-UP IS THAT IT IGNORES THE VARIATIONS IN ANELASTIC DISLOCATION C 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 FAULT ELEMENTS.) 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 THIS PROGRAM WAS DEVELOPED WITH SUPPORT FROM THE UNIVERSITY OF C CALIFORNIA, THE UNITED STATES GEOLOGIC SURVEY, AND THE NATIONAL C SCIENCE FOUNDATION. IT IS IN THE PUBLIC DOMAIN, AND MAY BE COPIED C AND USED WITHOUT RESTRICTION. HOWEVER, SCIENTIFIC ETHICS AND C COURTESY REQUIRE THE SOURCE OF THE PROGRAM TO BE STATED IN ANY C RESULTING PUBLICATIONS. (THE AUTHOR WOULD ALSO LIKE TO BE INFORMED C OF THESE PROJECTS.) C---------------------------------------------------------------------- C C OTHER SOFTWARE REQUIRED: C C * LINEAR SYSTEMS OF EQUATIONS ARE SOLVED BY "DGBF" & "DGBS" FROM C IBM'S E.S.S.L. (ENGINEERING SCIENCES SUBR0UTINE LIBRARY); C MY INTEGER FUNCTION "INDEXK" IS CUSTOMIZED TO WORK WITH C ESSL'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 THEN CHANGE. C C--------------------------------------------------------------------- C PARAMETER (ARRAY-SIZE) STATEMENTS C C SET THE FOLLOWING PARAMETERS AT LEAST AS LARGE AS YOUR PROBLEM: C C MAXNOD = MAXIMUM NUMBER OF NODES (INCLUDES BOTH "REAL"AND & "FAKE") PARAMETER (MAXNOD=994) C C MAXDOF = MAXIMUM NUMBER OF ENTRIES IN THE FORCING AND SOLUTION C VECTORS;SHOULD = 2 * MAXNOD AT ALL TIMES! PARAMETER (MAXDOF=1988) C C MAXBN = MAXIMUM NUMBER OF BOUNDARY NODES (BOTH "REAL" AND "FAKE"). PARAMETER (MAXBN=103) C C MAXEL = MAXIMUM NUMBER OF CONTINUUM ELEMENTS (TRIANGLES). PARAMETER (MAXEL=314) C C MAXFEL = MAXIMUM NUMBER OF FAULT ELEMENTS (LINE SEGMENTS); PARAMETER (MAXFEL=147) C C MAXATP = MAXIMUM NUMBER OF NODES WHICH MAY OVERLAP AT A FAULT- C INTERSECTION POINT. PARAMETER (MAXATP=20) C C MAXSIZ = MAXIMUM DIMENSION OF WORKSPACE FOR STIFFNESS MATRIX AND C SOLUTION OF LINEAR SYSTEMS. (NOTE: THIS DIMENSION IS C CHECKED DURING EVERY RUN. IF IN DOUBT, SET IT TO 1 AND C LET THE PROGRAM COMPUTE WHAT VALUE IS NECESSARY.) PARAMETER (MAXSIZ=677368) C C--------------------------------------------------------------------- C TYPE STATEMENTS C C (NOTE: THE IMPLICIT TYPING OF I-N = INTEGER, AND A-H,O-Z = REAL C IS OBSERVED IN THIS PROGRAM. NO TYPES ARE STATED FOR SUCH NAMES.) C CHARACTER*80 TITLE1,TITLE2,TITLE3 C DOUBLE PRECISION FBASE,FORCE,STIFF,V,VM C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD1: DOUBLE PRECISION PHI,POINTS,WEIGHT C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD2: DOUBLE PRECISION FPHI,FPOINT,FGAUSS C C NOTE: THE FOLLOWING CAN BE MADE "INTEGER*2" IN VS-FORTRAN: INTEGER NODTYP C LOGICAL BRIEF,EVERYP C C NOTE: THE FOLLOWING ARRAYS COULD BE COMPRESSED WITH "LOGICAL*1" C IN VS-FORTRAN: LOGICAL CHECKE,CHECKF,CHECKN,EDGETS,EDGEFS,FSLIPS,PULLED C C--------------------------------------------------------------------- C DIMENSION STATMENTS C C DIMENSIONS USING PARAMETER MAXNOD: DIMENSION ATNODE(MAXNOD), CHECKN(MAXNOD), DQDTDA(MAXNOD), + ELEV (MAXNOD), JCOL1 (MAXNOD), JCOL2 (MAXNOD), + NODTYP(MAXNOD), TAUZZN(MAXNOD), + V (2,MAXNOD), VM (2,MAXNOD), + XNODE (MAXNOD), YNODE (MAXNOD), ZMNODE(MAXNOD) C C DIMENSIONS USING PARAMETER MAXDOF: DIMENSION COMP (MAXDOF,4), FORCE (MAXDOF), FBASE (MAXDOF), + IPVT (MAXDOF) C C DIMENSIONS USING PARAMETER MAXBN: DIMENSION ICOND (MAXBN), NODCON (MAXBN), VBCAZ (MAXBN), + VBCMAG (MAXBN) C C DIMENSIONS USING PARAMETER MAXEL: DIMENSION ALPHA(3,3,7,MAXEL), AREA (MAXEL), CHECKE (MAXEL), + DETJ (7,MAXEL), DVB (7,MAXEL), + DXS (6,7,MAXEL), DYS (6,7,MAXEL), EDGETS(3,MAXEL), + ERATE (3,7,MAXEL), GEOTH(4,7,MAXEL), + GLUE (7,MAXEL), NODES (6,MAXEL), + OVB (2,7,MAXEL), + OUTVEC (2,7,MAXEL), PULLED (7,MAXEL), + SIGHB (2,7,MAXEL), SIGZZI (7,MAXEL), + TAUMAT (3,7,MAXEL), TAUZZI (7,MAXEL), + TOFSET (3,7,MAXEL), ZMOHO (7,MAXEL), + ZTRANC (7,MAXEL) C C DIMENSIONS USING PARAMETER MAXFEL: DIMENSION CHECKF (MAXFEL), EDGEFS (2,MAXFEL), + FAZ (2,MAXFEL), FC (2,2,7,MAXFEL), FDIP (3,MAXFEL), + FIMUDZ(7,MAXFEL), FLEN (MAXFEL), + FPEAKS (MAXFEL), FSLIPS (MAXFEL), + FTAN (7,MAXFEL), FTSTAR(2,7,MAXFEL), NODEF (6,MAXFEL), + OFFSET (MAXFEL), ZTRANF (MAXFEL) C C DIMENSIONS USING PARAMETER MAXATP: DIMENSION LIST (MAXATP) C C DIMENSIONS USING PARAMETER MAXSIZ: DIMENSION STIFF (MAXSIZ) C C DIMENSIONS OF FIXED SIZE: C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD1: DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD2: DIMENSION FPHI(6,7),FPOINT(7),FGAUSS(7) C C--------------------------------------------------------------------- C EQUIVALENCE STATEMENTS C (NOTE: ALL EQUIVALENCES ARE TO CONSERVE MEMORY, AND DO NOT IMPLY C LOGICAL EQUIVALENCE!) 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,MD 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, AND C FAULT ELEMENTS IN BLOCK DATA BD2). C ENTRIES CORRESPONDING TO BD1: COMMON /S1S2S3/ POINTS COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT C ENTRIES CORRESPONDING TO BD2: COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS C C-------------------------------------------------------------------- C DATA STATEMENTS 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 THE 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 DEVICE NUMBERS: C "IUNITG"= DEVICE NUMBER ASSOCIATED WITH THE GRID INPUT FILE. DATA IUNITG /1/ C "IUNITV"= DEVICE NUMBER ASSOCIATED WITH THE APPROXIMATE VELOCITY C SOLUTION, USED TO INITIALIZE. (NOTE: MAY EQUAL IUNITG.) DATA IUNITV /2/ C "IUNITB"= DEVICE NUMBER ASSOCIATED WITH THE BOUNDARY-CONDITION C INPUT FILE . (NOTE: MAY EQUAL IUNITV.) DATA IUNITB /3/ C "IUNITP"= DEVICE NUMBER ASSOCIATED WITH THE PARAMETER INPUT FILE. C (NOTE: MAY EQUAL IUNITB.) DATA IUNITP /4/ C "IUNITT"= DEVICE NUMBER ASSOCIATED WITH TEXT OUTPUT, INCLUDING C STATUS AND WARNING MESSAGES. C (NOTE! ON SOME SYSTEMS, SYSTEM ERR0R MESSAGES ARE ALWAYS C OUTPUT ON DEVICE 6. IF SO, THEN IUNITT SHOULD BE 6.) DATA IUNITT /6/ C "IUNITS"= DEVICE NUMBER ASSOCIATED WITH VELOCITY OUTPUT (SOLUTION). DATA IUNITS /7/ C C--------------------------------------------------------------------- C C GLOSSARY OF VARIABLES IN THE MAIN PROGRAM C C (A FEW NAMES MAY DIFFER WITHIN THE SUBPROGRAMS.) C (SPECIFICALLY, "STIFF" = "K" AND "FORCE" = "F".) C C ACREEP = PRE-EXPONENTIAL CONSTANT OF CREEP LAW, IN UNITS OF SHEAR C STRESS (EQUAL TO THE SHEAR STRESS FOR CREEP AT UNIT STRAIN- C 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 ALPHA(3,3,7,I) = THE 3 X 3 MATRIX OF TACTICAL EFFECTIVE VISCOSITIES 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 DEVIATORIC STRESS, 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 ATNODE(I)=TEMPORARY WORKING STORAGE WITH ONE ENTRY PER NODE. C BCREEP = CONSTANT IN DUCTILE CREEP LAW (SEE ACREEP ABOVE); EQUAL C TO ACTIVATION ENERGY FOR CREEP, MULTIPLIED BY ECREEP, C THEN DIVIDED BY THE GAS CONSTANT "R". 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 (FOR FIRST RUNS, SHOULD BE .FALSE.) 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 = CONSTANT IN THE DUCTILE CREEP LAW (SEE ACREEP ABOVE); C EQUAL TO THE DERIVITIVE OF BCREEP WITH RESPECT TO DEPTH. C (THIS SERVES AS A PROXY FOR AN ACTIVATION-VOLUME TERM.) C CFRIC = COEFFICIENT OF FRICTION IN CRUSTAL BLOCKS (OUTSIDE OF MAJOR C FAULTS). 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 CONDUC = THERMAL CONDUCTIVITY OF CRUST. UNITS OF ENERGY/DEGREE/ C 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 DCREEP = MAXIMUM SHEAR STRESS SUPPORTABLE BY ROCKS, AT WHICH THERE C WILL BE ARBITRARY AMOUNTS OF DEFORMATION REGARDLESS OF C TEMPERATURE OR PRESSURE. 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 IN INTERNAL C ELEMENT COORDINATES. (SHOULD REMAIN CLOSE 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 DVB(7,I)= DIFFERENCE (MAGNITUDE ONLY, NOT DIRECTION) OF VELOCITY C BELOW THE CRUST (AT THE TOP OF THE MANTLE) FROM CURRENT C VELOCITY OF THE CRUST, AT THE 7 INTEGRATION POINTS OF C EACH TRIANGULAR CONTINUUM ELEMENT #I. C DXS(J=1-6,M=1,7,I) = X-COMPONENT OF GRADIENT OF THE NODAL FUNCTION C ASSOCIATED WITH NODE #J (INTERNAL NUMBERING) OF C TRIANGULAR ELEMENT #I, EVALUATED AT INTEGRATION POINT #M. C UNITS ARE INVERSE DISTANCE; USUALLY A VERY SMALL NUMBER, C SIGN IS NEGATIVE FOR ABOUT HALF OF THE ENTRIES. C DYS(J=1-6,M=1,7,I) = Y-COMPONENT OF GRADIENT OF THE NODAL FUNCTION C ASSOCIATED WITH NODE #J (INTERNAL NUMBERING) OF C TRIANGULAR ELEMENT #I, EVALUATED AT INTEGRATION POINT #M. C UNITS ARE INVERSE DISTANCE; USUALLY A VERY SMALL NUMBER, C SIGN IS NEGATIVE FOR ABOUT HALF OF THE ENTRIES. C ECREEP = EXPONENT ON STRAIN-RATE IN CALULATION OF SHEAR-STRESES FOR C DUCTILE CREEP (SEE ACREEP ABOVE). THE INVERSE OF THE STRESS C EXPONENT "N" USED BY MANY OTHER AUTHORS. 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-N3; C SIDE 2 HAS NODES N4-N5-N6 AS RECORDED IN NODEF(N1-6,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-N5-N3; SIDE 2 HAS NODES N3-N6-N1; AND SIDE 3 HAS NODES C N1-N4-N2 AS RECORDED IN NODES(N1-6,I). C ELAPSE = CPU TIME REQUIRED TO INITIALIZE THE CALCULATION, BEFORE C ITERATION BEGINS. USED AS A GENEROUS ESTIMATE OF THE TIME C REQUIRED TO OUTPUT THE SOLUTION. UNITS ARE C SECONDS OF CPU TIME REMAINING. C ELEV(I) = ELEVATION AT NODE #I. NEGATIVE BELOW SEA LEVEL. 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 ETAMAX = MAXIMUM COUPLING COEFFICIENT FOR MANTLE DRAG, EQUAL TO C MAXIMUM RATIO OF SHEAR TRACTION TO VELOCITY DIFFERENCE. C FAZ(2,I)= ARGUMENT OF FAULT TRACE, IN RADIANS COUNTERCLOCKWISE FROM C THE X AXIS, AT THE NODEF(1,I) END, AND THE NODEF(3,I) END. 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 DIMENSIONALLY COMPARABLE TO THE VERTICAL C (NOT DOWN-DIP) INTEGRAL OF THE JACOBIAN MATRIX FOR THE C DERIVITIVE OF SHEAR TRACTION ON THE FAULT PLANE WITH C RESPECT TO CHANGES IN THE SLIP VECTOR. IN THIS JACOBIAN, 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-N3 SIDE RELATIVE C TO THE N6-N5-N4 SIDE. THE SHEAR TRACTION IS THAT EXERTED C ON THE N6-N5-N4 SIDE BY THE N1-N2-N3 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(3,I)=FAULT DIP, IN RADIANS, MEASURED FROM HORIZONTAL ON THE C SIDE WHICH HAS NODES NODEF(4-6,I). FIRST VALUE IS AT NODE C NODEF(1,I), 2ND IS AT NODEF(2,I), & 3RD IS AT NODEF(3,I). C FFRIC = COEFFICIENT OF FRICTION IN (COLD UPPER PARTS OF) FAULT C ELEMENTS. DIMENSIONLESS. USUALLY LESS THAN CFRIC. 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 CRUST 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 CRUST TIMES THE CRUSTAL 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 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 OR "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/DUCTILE C TRANSITION DEPTH (RELATIVE TO THE SURFACE) GIVEN BY C "ZTRANF". C FPHI(I=1-6,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 VALUE 1 AT NODE #NODEF(I,K), C WHERE K IS THE ELEMENT NUMBER, AND IS 0 AT OTHER NODES. 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 NODE3 END. C (NODE1 = NODEF(1,I), NODE3 = NODEF(3,I).) C FSLIPS(I) = LOGICAL VARIABLE, INDICATING WHETHER FAULT ELEMENT I C IS SLIPPING (AT ITS MIDPOINT). OTHERWISE, IT C LOCKED AND ASEISMIC, EVEN THOUGH ITS SLIP RATE WILL C NOT BE EXACTLY ZERO (FOR NUMERICAL REASONS). C FTAN(M=1-7,I) = ARGUMENT OF TANGENT TO THE TRACE OF FAULT ELEMENT C NUMBER I, EVALUATED AT INTEGRATION POINT M. C ARGUMENTS ARE MEASURED COUNTERCLOCKWISE FROM THE +X AXIS C AND EXPRESSED IN RADIANS. 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 IS UP-DIP. C (THE SHEAR TRACTION IS THAT EXERTED ON THE C N6-N5-N4 SIDE BY THE N1-N2-N3 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 GRADIENT, ETC. C GLUE(7,I)=STRENGTH OF COUPLING BETWEEN CRUST AND 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 SHEAR VELOCITY ACROSS THE L C THICKNESS OF THE LOWER CRUST. C GMEAN = MEAN VALUE OF GRAVITATIONAL ACCELERATION ON THE SURFACE OF C THE PLANET (LENGTH/SEC**2). C ICOND(I)= TYPE OF VELOCITY BOUNDARY CONDITION #I: C 0 = NO VELOCITY CONSTRAIN (DEFAULT LITHOSTATIC TRACTION). C 1 = ONE COMPONENT OF VELOCITY C (TOWARD SPECIFIED ARGUMENT) SET AT SPECIFIED C VALUE, WITH OTHER COMPONENT FREE. C 2 = VELOCITY FIXED AT SPECIFIED MAGNITUDE AND ARGUMENT. C 3 = VELOCITY FIXED AT MANTLE VALUES (FROM FUNCTION). C IFLOW = AN INTEGER IDENTIFYING DESIRED PATTERN OF MANTLE DRAG. AT C PRESENT, ONLY CHOICES ARE: 0 = NO DRAG, OR 1 = BIRD & C ROSENSTOCK(1984) PATTERN. C IPVT(NDOF)= AN INTEGER WORK ARRAY NEEDED BY SUBPROGRAM "SOLVER" C TO PERMIT RECORDING THE PIVOTING PERFORMED WHILE SOLVING C THE LINEAR SYSTEMS. C JCOL1(I)= A WORK ARRAY IN WHICH TO RECORD THE LOWEST NODE NUMBER WHICH C 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 AUGMENTED STIFFNESS MATRIX, ACCORDING TO THE STORAGE C CONVENTION FOR GENERAL BAND MATRICES IN IBM'S ESSL PACKAGE. C SEE IBM 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 STATMENT 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 "MD" PRECOMPUTED BY "KSIZE". C LIST = AN 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 MD = AN INTEGER CONSTANT COMPUTED BY "KSIZE" AND NEEDED BY C "INDEXK" WHEN USING IBM'S ESSL PACKAGE TO SOLVE LINEAR C SYSTEMS. SEE COMMENTS UNDER LDA ABOVE. C NCOND = NUMBER OF NODES WITH ANY KIND OF SIDE 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 * NREALN. C NFAKEN = THE NUMBER OF COMPLETELY CONSTRAINED NODES, NUMBERED C (N1000+1) TO (N1000 + NFAKEN) ON INPUT AND OUTPUT. 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. 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 SIDE BOUNDARY CONDITION #I. C THE NODE NUMBERS OF FAKE (CONSTRAINED BOUNDARY) NODES WILL C BEGIN WITH N1000+1 AND GO UP. HOWEVER, INTERNALLY, THE GAP C IN NODE NUMBERS IS REMOVED FOR PROGRAMMING CONVENIENCE. C NODEF(I=1-6,J=1,NFL) = NODE NUMBERS DEFINING A FAULT ELEMENT. C THE NODE NUMBERS OF FAKE (CONSTRAINED BOUNDARY) NODES WILL C BEGIN WITH N1000+1 AND GO UP. HOWEVER, INTERNALLY, THE GAP C IN NODE NUMBERS IS REMOVED FOR PROGRAMMING CONVENIENCE. C THE NODE NUMBERS ARE GIVEN IN COUNTERCLOCKWISE ORDER C AROUND THE FAULT ELEMENT, BEGINNING AT ONE END, THEN C NAMING THE MIDPOINT NODE ON THE SAME SIDE, ETC. C NODES(I=1-6,J=1,NUMEL) = NODE NUMBERS AT CORNERS (I=1-3) AND MIDPOINTS C OF SIDES (I=4-6) OF TRIANGULAR CONTINUUM ELEMENT #J. C NODES MUST BE NUMBERED IN COUNTERCLOCKWISE ORDER; FIRST ALL C CORNERS, THEN ALL MIDPOINTS (STARTING BETWEEN C CORNERS #1 & 2) C THE NODE NUMBERS OF FAKE (CONSTRAINED BOUNDARY) NODES WILL C BEGIN WITH N1000+1 AND GO UP. HOWEVER, INTERNALLY, THE GAP C IN NODE NUMBERS IS REMOVED FOR PROGRAMMING CONVENIENCE. C NODTYP(I)=A SHORT-INTEGER ARRAY DESCRIBING TYPE OF REAL NODES: C 0 = UNCONNECTED TO ANY ELEMENT (ILLEGAL); C 1 = A CORNER NODE OF TRIANGLES AND/OR END NODE OF FAULTS C 2 = A MIDPOINT NODE ALONG THE SIDES OF ELEMENTS OR FAULTS. C THE NODE NUMBERS OF FAKE (CONSTRAINED BOUNDARY) NODES WILL C BEGIN WITH N1000+1 AND GO UP. HOWEVER, INTERNALLY, THE GAP C IN NODE NUMBERS IS REMOVED FOR PROGRAMMING CONVENIENCE. C NREALN = NUMBER OF NODES WITH AT LEAST ONE DEGREE OF FREEDOM; C THESE ARE NUMBERED 1 - NREALN IN AN ORDER TO MINIMIZE THE C BANDWIDTH FACTOR NLINK. C NUB = WIDTH OF UPPER HALF-BAND IN STIFFNESS MATRIX, EQUAL TO THE C NUMBER OF UPPER CO-DIAGONALS. C NUMEL = NUMBER OF TRIANGULAR CONTINUUM ELEMENTS. C NUMNOD = NUMBER OF NODES (BOTH "REAL" AND "FAKE"). C N1000 = A CONVENIENT "ROUND-NUMBER" INTEGER THAT IS GREATER THAN C OR EQUAL TO NREALN. ON INPUT AND ON OUTPUT, C THE NODE NUMBERS OF FAKE (CONSTRAINED BOUNDARY) NODES WILL C BEGIN WITH N1000+1 AND GO UP. HOWEVER, INTERNALLY, THE GAP C IN NODE NUMBERS IS REMOVED FOR PROGRAMMING CONVENIENCE. 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 PARAMETER, NOT C A COMPUTED RESULT! C OKDELV = MAXIMUM PERMISSIBLE VELOCITY ERR0R DUE TO ARTIFICIAL UPPER C LIMITS ON STIFFNESSES OF DIFFERENT PARTS OF THE SYSTEM. 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". 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 USED ONLY IN SUBPROGRAM "SQUEEZ", WHICH CONTAINS A STANDARD C DENSITY MODEL EXPRESSED IN KILOMETER 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 MANTLE LAYER, BENEATH EACH OF THE 7 INTEGRATION C POINTS IN EACH TRIANGULAR CONTINUUM ELEMENT I. C PHI(I=1-6,J=1-7) = VALUE OF NODAL FUNCTION #I OF ANY TRIANGULAR C CONTINUUM ELEMENT, EVALUATED AT GAUSSIAN INTEGRATION POINT C #J. NODAL FUNCTION #I HAS VALUE 1 AT NODE #NODES(I,K), C WHERE K IS THE ELEMENT NUMBER, AND IS 0 AT OTHER NODES. C PRECOMPUTED AND STORED IN BLOCK DATA BD1. C POINTS(I=1-5,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 I=4:S1 VALUE. I=5:S2 VALUE. C (THE REDUNDANT VALUES IN I=4-5 ARE JUST FOR CONVENIENCE.) C PULLED(M,I) = LOGICAL FLAG, SHOWING THAT THE MANTLE DRAGS ON THE C BASE OF THE CRUST AT INTEGRATION POINT M (=1..7) OF C TRIANGULAR CONTINUUM ELEMENT I. IF FALSE, THIS IMPLIES C THAT THE UPPER MANTLE IS VERY WEAK, AND THE CRUST DETERMINES C THE VELOCITY ON THE TOP OF THE MANTLE. C RADIO = RADIOACTIVE HEAT PRODUCTION OF CRUST. UNITS OF ENERGY/ C VOLUME/SEC. (NOT ENERGY/MASS/SEC!) C REFSTR = REFERENCE STRESS, OR MEAN VALUE OF SHEAR STRESS IN THE C CRUST. USED FOR INITIALIZATION AND TO COMPUTE UPPER LIMITS C TO STIFFNESSES OF DIFFERENT PARTS OF THE SYSTEM. C RHOAST = DENSITY OF THE ASTHENOSPHERE BENEATH THE MANTLE LITHOSPHERE. C (NOTE: EFFECTS OF PRESSURE ARE UNIFORMLY OMITTED, SO THIS IS C A PRESSURE-FREE POTENTIAL DENSITY, AT AMBIENT TEMPERATURE.) C RHOBAR = MEAN DENSITY OF THE CRUST. (NOTE: EFFECTS OF PRESSURE ARE C UNIFORMLY OMITTED, BUT EFFECTS OF TEMPERATURE WILL BE ADDED, C SO THIS SHOULD BE A PRESSURE-FREE POTENTIAL DENSITY AT 0 K. C RHOH2O = DENSITY OF SEAWATER, PORE WATER, AND LAKES. C (NOTE: EFFECTS OF PRESSURE ARE UNIFORMLY OMITTED, SO THIS IS C A PRESSURE-FREE POTENTIAL DENSITY, AT AMBIENT TEMPERATURE.) C SIGHB(2,7,I) = 2-COMPONENT VECTOR OF HORIZONTAL TRACTION ON THE BASE C OF THE CRUST, 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 CRUST, RELATIVE TO THE STANDARD PRESSURE CURVE (SEE C SUBPROGRAM "SQUEEZ"). COMPRESSION IN 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 TAUMAT(3,M,I)= VERTICAL INTEGRALS OF 3 DEVIATORIC STRESS COMPONENTS C THROUGH THE CRUST, 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 DEVIATORIC STRESS IS THE C NEGATIVE OF THE LOCAL VALUE OF VERTICAL STRESS (SIGMA_ZZ). C TO GET THE ANOMALY INTEGRALS RELATIVE TO THE STANDARD CURVE OF C PRESSURE, IT IS NECESSARY TO ADD "TAUZZ" TO C COMPONENTS 1 & 2. C TAUZZI(M,I) = VERTICAL INTEGRAL OF THE VERTICAL STRESS ANOMALY C THROUGH THE CRUST, 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 RISE 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 TITLE1 = 80-CHARACTER IDENTIFIER FOR THE FINITE-ELEMENT GRID. C TITLE2 = 80-CHARACTER IDENTIFIER FOR THE SET OF BOUNDARY CONDITIONS. C TITLE3 = 80-CHARACTER IDENTIFIER FOR THE SET OF PARAMETERS. C TOFSET(3,M,I)= VERTICAL INTEGRAL OF 3 DEVIATORIC COMPONENTS OF C PRESTRESS THROUGH THE CRUST, 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 DEVIATORIC STRESS 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 "TAUZZ" TO C COMPONENTS 1 & 2. C TSTART = SECONDS OF CPU TIME STILL AVAILABLE ("TIME TO BURN") AT THE C BEGINNING OF SOME SECTION OF PROGRAM WE WISH TO TIME. C TSURF = SURFACE TEMPERATURE, IN DEGREES ABOVE ABSOLUTE ZERO. C VBCAZ(I)= ARGUMENT OF THE VELOCITY VECTOR IMPOSED AT BOUNDARY NODE C #I (WHOSE INDEX NUMBER IS NODCON(I)). MEASURED COUNTER- C CLOCKWISE FROM THE X AXIS. INPUT IN DEGREES, BUT STORED AS C RADIANS. C VBCMAG(I)=THE 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. (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 VISMAX = MAXIMUM VISCOSITY ALLOWED FOR ANY ELEMENT IN THE MODEL C (APPLIES TO THE WHOLE THICKNESS OF THE CRUST, NOT LOCALLY). C VM(1-2,I)= X AND Y COMPONENTS OF THE MANTLE VELOCITY UNDER NODE #I. 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(I)=WEIGHT ATTACHED TO GAUSSIAN INTEGRATION POINT #I (I=1,7) C IN AREA INTEGRATION OVER ANY TRIANGULAR CONTINUUM ELEMENT. C THE SUM OF THE 7 WEIGHTS IS 1. C XNODE(I)= X COORDINATE OF NODE #I. C YNODE(I)= Y COORDINATE OF NODE #I. 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. SEE COMMENTS UNDER "ZMNODE". C ZTRANC(M,I)=DEPTH TO THE BRITTLE/DUCTILE TRANSITION AT INTEGRATION C POINT M OF TRIANGULAR CONTINUUM ELEMENT I, MEASURED FROM C THE EARTH'S SURFACE. C ZTRANF(I)=DEPTH TO THE BRITTLE/DUCTILE TRANSITION AT THE MIDPOINT C OF FAULT ELEMENT I,MEASURED FROM THE EARTH'S SURFACE. 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 + MXBN,MXEL,MXFEL,MXNODE, CCCC + MXSTAR,NFL,NODEF,NODES,NREALN, CCCC + NUMEL,NUMNOD,N1000,WEDGE, CCCC + MODIFY,FAZ,XNODE,YNODE, CCCC + OUTPUT,AREA,DETJ,DXS,DYS,EDGEFS,EDGETS, CCCC + FLEN,FTAN,NCOND,NODCON, CCCC + WORK,CHECKN,LIST,NODTYP) 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 "MODIFY" GROUP = VALUE MUST BE DEFINED BEFORE CALL, BUT MAY BE C ADJUSTED BY SUBPROGRAM. C "OUTPUT" GROUP = VALUE NEED NOT BE DEFINED BEFORE CALL, AND WILL C BE DEFINED BY THE SUBPROGRAM. 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 C NOTE THAT THE DISTINCTIONS BETWEEN "INPUT", "MODIFY", AND C "OUTPUT" ARE VERY SHARP, AND CAN BE DETERMINED BY THE STRUCTURE C OF THE SUBPROGRAM ALONE. (COMPILERS SHOULD BE WRITTEN TO IMPOSE C AND ENFORCE THESE DISTINCTIONS!) C HOWEVER, THE DISTINCTION BETWEEN "OUTPUT" AND "WORK" IS BASED C SOLELY ON WHETHER THE RESULTS WILL BE USED BY THE CALLING C PROGRAM, WHICH CANNOT BE DETERMINED BY LOOKING AT THE SUBPROGRAM C CODE! STILL, I MAKE THIS DISTINCTION TO REDUCE CONFUSION, C BY FOCUSING ATTENTION ON THE "OUTPUT" ARRAYS WHICH ARE THE C PRIMARY REASONS FOR THE CALL. C C-------------------------------------------------------------------- C C BEGINNING OF EXECUTABLE CODE C C *** KLUDGE ALERT ************************************************* C CONVERSION OF PARAMETERS (CONSTANTS) TO VARIABLES SHOULD LOGICALLY C HAVE NO EFFECT, BUT IN FACT HELPS TO SUPPRESS SOME SPURIOUS C MESSAGES FROM THE IBM VS-FORTRAN COMPILER. MXNODE=MAXNOD MXDOF =MAXDOF MXBN =MAXBN MXEL =MAXEL MXFEL =MAXFEL MXSTAR=MAXATP MXWORK=MAXSIZ C ****************************************************************** C C WRITE HEADER ON OUTPUT FILE C WRITE (IUNITT,1) 1 FORMAT ( +' =============================================================='/ +' I Program -FAULTS- I'/ +' I A flat-Earth, thin-plate program for computing I'/ +' I time-averaged (anelastic) deformation of a crust I'/ +' I with realistic frictional/dislocation-creep rheology. I'/ +' I Faults may be included, with specified dip and friction. I'/ +' I The velocity on the top of the mantle may be specified, I'/ +' I or left free. I'/ +' I by I'/ +' I Peter Bird I'/ +' I Department of Earth and Space Sciences I'/ +' I University of California I'/ +' I Los Angeles, CA 90095-1567 I'/ +' I Version of 20 April 2000 I'/ +' ==============================================================') C WEDGE=ABS(90.-ABS(DIPMAX))*0.017453293 C C INPUT FINITE ELEMENT GRID AND DATA VALUES AT NODE POINTS C CALL GETNET (INPUT,IUNITG,IUNITT, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF,DQDTDA,ELEV,FAZ,FDIP, + NFAKEN,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,OFFMAX,OFFSET, + TITLE1,XNODE,YNODE,ZMNODE, + WORK,CHECKE,CHECKF,CHECKN) C C CHECK GRID TOPOLOGY AND COMPUTE GEOMETRIC PROPERTIES C CALL SQUARE (INPUT,BRIEF,FDIP,IUNITT, + MXBN,MXEL,MXFEL,MXNODE, + MXSTAR,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,WEDGE, + MODIFY,FAZ,XNODE,YNODE, + OUTPUT,AREA,DETJ,DXS,DYS,EDGEFS,EDGETS, + FLEN,FTAN,NCOND,NODCON, + WORK,CHECKN,LIST,NODTYP) C C ATTEMPT TO READ OLD VELOCITY SOLUTION FOR INITIALIZATION; C IF THIS FAILS, SET VELOCITIES TO ZERO. C CALL OLDVEL (INPUT,IUNITT,IUNITV,MXNODE,NUMNOD, + OUTPUT,V) C C READ BOUNDARY CONDITIONS ON SIDES, IN ORDER DETERMINED BY "SQUARE", C (AND PERHAPS USING CORRECTED NODE POSITIONS DETERMINED BY "SQUARE"). C CALL READBC (INPUT,BRIEF, + IUNITB,IUNITT,MXBN,MXNODE,NCOND, + NODCON,NREALN,NUMNOD,N1000, + XNODE,YNODE, + OUTPUT,ICOND,TITLE2,VBCAZ,VBCMAG) C C READ SCALAR PARAMETERS C CALL READPM (INPUT,IUNITP, IUNITT, OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT, + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , + IFLOW , GMEAN , + MAXITR, OKDELV, OKTOQT, ONEKM, RADIO , + REFSTR, RHOAST, RHOBAR, RHOH2O, + TEMLIM, TITLE3, TSURF) C C DETERMINE BANDWIDTH OF LINEAR SYSTEMS AND COMPUTE STORAGE NEEDED C CALL KSIZE (INPUT,BRIEF,IUNITT,MXEL,MXFEL,MXNODE, + MXWORK,NFL,NODEF,NODES,NREALN,NUMEL, + OUTPUT,LDA,MD,NDOF,NKSIZE,NLB,NUB, + WORK,JCOL1,JCOL2) C C INTERPOLATE AND INITIALIZE ALL "CONVENIENCE ARRAYS": C CALL FILLIN (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,CFRIC,CONDUC,DQDTDA, + ECREEP,ELEV,ERATE,GMEAN,IFLOW,IUNITT, + MXEL,MXNODE,NODES,NUMEL,NUMNOD,ONEKM, + RADIO,RHOAST,RHOBAR,RHOH2O,TEMLIM, + TSURF,XNODE,YNODE,V,ZMNODE, + OUTPUT,GEOTH,GLUE,PULLED,SIGZZI,TAUZZI, + TAUZZN,VM,ZMOHO, + WORK,ATNODE) 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,REFSTR,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) C C PRECOMPUTE THE FIXED PART OF THE FORCING VECTOR OF THE LINEAR C SYSTEMS OF EQUATIONS C CALL FIXED (INPUT,ALPHAT,AREA,CONDUC,DETJ,DQDTDA,DXS,DYS, + EDGETS,ELEV,FDIP,FLEN,FTAN,GMEAN,IUNITT, + MXDOF,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES,NUMEL, + ONEKM,RADIO,RHOAST,RHOBAR,RHOH2O,SIGZZI, + TAUZZI,TAUZZN,TEMLIM,TSURF,WEDGE, + XNODE,YNODE,ZMNODE, + OUTPUT,FBASE) C C -CREATE AND SOLVE THIN-PLATE VERSION OF EQUILIBRIUM TO CORRECT THE C HORIZONTAL VELOCITY COMPONENTS (USING ITERATION TO HANDLE C NONLINEARITIES). C -HOWEVER, CUT OFF ATTEMPTS TO CONVERGE WHEN CPU TIME REMAINING C BECOMES LESS THAN "ELAPSE" SECONDS. C CALL PURE (INPUT,ACREEP,ALPHAT,AREA,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DETJ, + DQDTDA,DXS,DYS,ECREEP,ELAPSE,ETAMAX, + EVERYP,FBASE, + FDIP,FFRIC,FLEN,FMUMAX,FTAN,GEOTH,GLUE, + GMEAN,ICOND,IFLOW,IUNITS,IUNITT, + MAXITR,MXBN,MXDOF,MXEL, + MXFEL,MXNODE,MXWORK,NCOND,NDOF,NFL,NLB,NODCON, + NODEF,NODES,NREALN,NUB,NUMEL,NUMNOD, + OFFMAX,OFFSET,OKTOQT, + ONEKM,PULLED,RADIO,RHOBAR,RHOH2O, + TEMLIM,TITLE1,TITLE2,TITLE3, + TSURF,VBCAZ,VBCMAG,VISMAX,VM,WEDGE, + XNODE,YNODE,ZMNODE,ZMOHO,999, + MODIFY,V, + OUTPUT,ERATE,FIMUDZ,FPEAKS,FSLIPS,SIGHB,TAUMAT, + ZTRANC,ZTRANF, + WORK,ALPHA,DVB,FORCE,FC,FTSTAR,IPVT,STIFF, + OUTVEC,OVB,TOFSET) C C TEST AND DISPLAY THE EQUILIBRIUM FOUND C C CALL BALANC (INPUT,AREA,DETJ,DXS,DYS,FBASE,FLEN,ICOND, C + IUNITT,MXBN,MXDOF,MXEL,MXFEL, C + NCOND,NFL,NODCON,NODEF,NODES, C + NREALN,NUMEL,NUMNOD,N1000, C + SIGHB,TAUMAT,VBCAZ, C + WORK,COMP) C C OUTPUT THE SOLUTION C CALL RESULT (INPUT,ALPHAT,ELEV,ERATE,EVERYP, + FDIP,FIMUDZ,FPEAKS,FSLIPS, + FTAN,GEOTH,IUNITS,IUNITT,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES,NREALN,NUMEL,NUMNOD,N1000, + RHOAST,RHOBAR,RHOH2O,SIGHB,TAUMAT,TAUZZI, + TITLE1,TITLE2,TITLE3, + V,WEDGE,ZMOHO,ZTRANC,ZTRANF) C STOP END C C C SUBROUTINE ADDFST (INPUT,CONSTR,FC,FDIP,FIMUDZ,FLEN,FTAN, + MXDOF,MXFEL,MXNODE,MXWORK, + NFL,NODEF,NREALN, + V,WEDGE, + MODIFY,K,F) 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-6. 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 BECAUSE FAKE NODES ARE CONDENSED OUT OF THE LINEAR SYSTEM, C TERMS CONNECTING REMAINING REAL NODES TO FAKE NODES ARE USED C TO MODIFY THE RIGHT-SIDE VECTOR "F" INSTEAD OF THE STIFFNESS C MATRIX "K". FOR THIS REASON, THE VECTOR "V" WHICH INCLUDES C THE VELOCITIES OF THE FAKE NODES IS NECESSARY INPUT DATA. 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 "FMUMAX"*THICKNESS_OF_ C CRUST. C DOUBLE PRECISION ELK,F,K,V DOUBLE PRECISION FPHI,FPOINT,FGAUSS DIMENSION FPHI(6,7),FPOINT(7),FGAUSS(7) DIMENSION F(MXDOF),FC(2,2,7,MXFEL),FDIP(3,MXFEL),FLEN(MXFEL), + FIMUDZ(7,MXFEL),FTAN(7,MXFEL),K(MXWORK), + NODEF(6,MXFEL),V(2,MXNODE) DIMENSION ELK(2,2,6,6) COMMON LDA,MD COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS C C STATEMENT FUNCTION REPLACING INTEGER FUNCTION SUBPROGRAM "INDEXK": INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + MD + IROW - JCOLUM C C NOTE: CONVENTION IS THAT ROW NUMBERS IDENTIFY THE FORCE BALANCE C EQUATION, WHILE COLUMN NUMBERS IDENTIFY THE DEGREE C OF FREEDOM INFLUENCING THE FORCE BALANCE. C DO 500 IFE=1,NFL C C ZERO AND THEN BUILD UP THE ELEMENT STIFFNESS MATRIX: C DO 10 I=1,6 DO 9 J=1,6 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 C C DO 60 M=1,7 ANGLE=FTAN(M,IFE) SINA=SIN(ANGLE) COSA=COS(ANGLE) DS=FLEN(IFE)*FGAUSS(M) DIP=FPHI(1,M)*FDIP(1,IFE)+FPHI(2,M)*FDIP(2,IFE)+ + FPHI(3,M)*FDIP(3,IFE) IF (ABS(DIP-1.570796).LE.WEDGE) THEN C C VERTICAL STRIKE-SLIP FAULT C DO 30 I=1,6 DO 20 J=1,6 TERM=FPHI(I,M)*FPHI(J,M)*DS ELK(1,1,I,J)=ELK(1,1,I,J)+TERM* + (FIMUDZ(M,IFE)*COSA**2+ + CONSTR*SINA**2) ELK(1,2,I,J)=ELK(1,2,I,J)+TERM* + (FIMUDZ(M,IFE)-CONSTR)*SINA*COSA ELK(2,1,I,J)=ELK(2,1,I,J)+TERM* + (FIMUDZ(M,IFE)-CONSTR)*SINA*COSA ELK(2,2,I,J)=ELK(2,2,I,J)+TERM* + (FIMUDZ(M,IFE)*SINA**2+ + CONSTR*COSA**2) 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,6 DO 40 J=1,6 FIFIDS=FPHI(I,M)*FPHI(J,M)*DS ELK(1,1,I,J)=ELK(1,1,I,J)+FIFIDS* + (COSA*OSIND*(COSA* FC(1,1,M,IFE)- + SINA*OCOSD* FC(1,2,M,IFE))- + 2.*SINA*OSIN2D*(COSA* FC(2,1,M,IFE)- + SINA*OCOSD*FC(2,2,M,IFE))) ELK(1,2,I,J)=ELK(1,2,I,J)+FIFIDS* + (COSA*OSIND*(SINA* FC(1,1,M,IFE)+ + COSA*OCOSD* FC(1,2,M,IFE))- + 2.*SINA*OSIN2D*(SINA* FC(2,1,M,IFE)+ + COSA*OCOSD*FC(2,2,M,IFE))) ELK(2,1,I,J)=ELK(2,1,I,J)+FIFIDS* + (SINA*OSIND*(COSA* FC(1,1,M,IFE)- + SINA*OCOSD* FC(1,2,M,IFE))+ + 2.*COSA*OSIN2D*(COSA* FC(2,1,M,IFE)- + SINA*OCOSD*FC(2,2,M,IFE))) ELK(2,2,I,J)=ELK(2,2,I,J)+FIFIDS* + (SINA*OSIND*(SINA* FC(1,1,M,IFE)+ + COSA*OCOSD* FC(1,2,M,IFE))+ + 2.*COSA*OSIN2D*(SINA* FC(2,1,M,IFE)+ + COSA*OCOSD*FC(2,2,M,IFE))) 40 CONTINUE 50 CONTINUE ENDIF 60 CONTINUE C C APPLY ELEMENT MATRIX TO AUGMENT GLOBAL STIFFNESS MATRIX "K" C OR LOAD VECTOR "F" (IF THE COLUMN J REFERS TO A FAKE NODE). C DO 400 I6=1,6 NODEI=NODEF(I6,IFE) IF (NODEI.LE.NREALN) THEN IRY=2*NODEI IRX=IRY-1 DO 300 J6=1,6 NODEJ=NODEF(J6,IFE) IF (NODEJ.LE.NREALN) THEN C CASE OF TWO REAL NODES: JCY=2*NODEJ JCX=JCY-1 IKXX=INDEXK(IRX,JCX) K(IKXX)=K(IKXX)+ELK(1,1,I6,J6) IKXY=INDEXK(IRX,JCY) K(IKXY)=K(IKXY)+ELK(1,2,I6,J6) IKYX=INDEXK(IRY,JCX) K(IKYX)=K(IKYX)+ELK(2,1,I6,J6) IKYY=INDEXK(IRY,JCY) K(IKYY)=K(IKYY)+ELK(2,2,I6,J6) ELSE C CASE WHERE I IS A REAL NODE BUT J IS NOT: F(IRX)=F(IRX)-ELK(1,1,I6,J6)*V(1,NODEJ) + -ELK(1,2,I6,J6)*V(2,NODEJ) F(IRY)=F(IRY)-ELK(2,1,I6,J6)*V(1,NODEJ) + -ELK(2,2,I6,J6)*V(2,NODEJ) ENDIF 300 CONTINUE ENDIF 400 CONTINUE 500 CONTINUE RETURN END C C C SUBROUTINE AREAS (INPUT,NODES,NUMEL,NUMNOD,XNODE,YNODE, 1 OUTPUT,AREA) C C COMPUTE AREAS OF ELEMENTS IN GRID AS IF THEY HAD STRAIGHT C SIDES. EFFECT OF SIDE CURVATURE WILL BE HANDLED LATER BY C MULTIPLYING BY DETERMINANT OF JACOBIAN MATRIX FOR THE SIDE- C BENDING MAPPING. NOTE THAT AREA MAY BE NEGATIVE, BUT ELEMENT C IS OK IF DETERMINANT IN DERIV IS ALSO NEGATIVE. C DIMENSION AREA(NUMEL),NODES(6,NUMEL),XNODE(NUMNOD),YNODE(NUMNOD) DO 100 I=1,NUMEL I1=NODES(1,I) I2=NODES(2,I) I3=NODES(3,I) AREA(I)= 0.5*(XNODE(I1)*YNODE(I2)-XNODE(I2)*YNODE(I1) + +XNODE(I2)*YNODE(I3)-XNODE(I3)*YNODE(I2) + +XNODE(I3)*YNODE(I1)-XNODE(I1)*YNODE(I3)) 100 CONTINUE RETURN END C C C REAL FUNCTION ATAN2F (Y,X) C C CORRECTS FOR PROBLEM OF TWO ZERO ARGUMENTS 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,AREA,DETJ,DXS,DYS,FBASE,FLEN,ICOND, + IUNITT,MXBN,MXDOF,MXEL,MXFEL, + NCOND,NFL,NODCON,NODEF,NODES, + NREALN,NUMEL,NUMNOD,N1000, + SIGHB,TAUMAT,VBCAZ, + WORK,COMP) C C CHECK THE BALANCE OF FORCES ON EACH NODE BY COMPUTING THE C APPARENT FORCE (FROM OUTSIDE THE MODELED SYSTEM) NECESSARY C TO CANCEL THE KNOWN FORCES WITHIN THE SYSTEM. C C IF THE PROGRAM IS WORKING CORRECTLY, THEN THE APPARENT FORCES C ON INTERNAL NODES SHOULD BE "SMALL" (COMPARED TO THE AREA C INTEGRAL OF TYPICAL STRESS ANOMALIES OVER THE SURFACE C WHICH PROJECTS VERTICALLY THROUGH THE CRUST FROM A TYPICAL C ELEMENT SIDE ON THE SURFACE). FOR EXAMPLE, IN SI UNITS, IF THE C LAYER THICKNESS IS 30,000 M, THE TYPICAL ELEMENT SIDE IS C 100,000 M, AND THE TYPICAL STRESS ANOMALY IS 3.E7 PA, THEN C AN APPARENT FORCE OF 5.E16 N WOULD BE "LARGE" (100% ERR0R), C BUT AN APPARENT FORCE OF 5.E13 WOULD BE "SMALL" (EQUILIBRIUM C WITHIN 0.1%). C C AT ANY NODE WHICH HAS AN IMPOSED BOUNDARY CONDITION, THE C APPARENT FORCES MAY BE LARGE. THEY REPRESENT THE EQUIVALENT C NODAL FORCES WHICH THE BOUNDARY CONDITION MUST EXERT TO C GIVE THE REQUESTED VELOCITY AT THAT NODE. C CHARACTER*2 CX, CY, CZ CHARACTER*15 LARGE, SMALL, SIZE LOGICAL HASBC DOUBLE PRECISION FBASE DOUBLE PRECISION PHI,POINTS,WEIGHT DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS COMMON /S1S2S3/ POINTS COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) DIMENSION FPHI(6,7),FPOINT(7),FGAUSS(7) DIMENSION AREA(MXEL), + COMP(MXDOF,4),DETJ(7,MXEL), + DXS(6,7,NUMEL),DYS(6,7,NUMEL),FBASE(MXDOF), + FLEN(MXFEL),ICOND(MXBN), + NODCON(MXBN),NODEF(6,MXFEL),NODES(6,MXEL), + SIGHB(2,7,MXEL),TAUMAT(3,7,MXEL),VBCAZ(MXBN) DATA CX /'+X'/, CY /'+Y'/ DATA LARGE /'MAY BE LARGE '/, SMALL /'SHOULD BE SMALL'/ C C WRITE TEXT EXPLAINING PURPOSE OF TABLE C WRITE (IUNITT,10) 10 FORMAT (' -----------------------------------', + '-----------------------------------') WRITE (IUNITT,1) 1 FORMAT (/ / +' APPARENT FORCE (FROM OUTSIDE THE MODELED SYSTEM) NECESSARY'/ +' TO CANCEL THE KNOWN FORCES WITHIN THE SYSTEM.'/ / +' IF THE PROGRAM IS WORKING CORRECTLY, THEN THE APPARENT FORCES'/ +' ON INTERNAL NODES SHOULD BE SMALL (COMPARED TO THE AREA'/ +' INTEGRAL OF TYPICAL STRESS ANOMALIES OVER THE SURFACE'/ +' WHICH PROJECTS VERTICALLY THROUGH THE CRUST FROM A TYPICAL'/ +' ELEMENT SIDE ON THE SURFACE). FOR EXAMPLE (IN SI) IF THE'/ +' LAYER THICKNESS IS 30,000 M, THE TYPICAL ELEMENT SIDE IS'/ +' 100,000 M, AND THE TYPICAL STRESS ANOMALY IS 3.E7 PA, THEN'/ +' AN APPARENT FORCE OF 5.E16 N WOULD BE LARGE (100% ERR0R),'/ +' BUT AN APPARENT FORCE OF 5.E13 WOULD BE SMALL (EQUILIBRIUM'/ +' ACHIEVED WITHIN 0.1%).'/ / +' AT ANY NODE WHICH HAS AN IMPOSED BOUNDARY CONDITION, THE'/ +' APPARENT FORCES MAY BE LARGE. THEY REPRESENT THE EQUIVALENT'/ +' NODAL FORCES WHICH THE BOUNDARY CONDITION MUST EXERT TO'/ +' GIVE THE REQUESTED VELOCITY AT THAT NODE.'/ /) WRITE (IUNITT,2) 2 FORMAT (' EXPLANATION OF THE TABLE:'/ / +' EACH ROW CORREPONDS TO ONE DEGREE OF FREEDOM, SO ROW 1'/ +' GIVES APPARENT FORCE ON NODE 1 IN THE X DIRECTION,'/ +' ROW 2 GIVES APPARENT FORCE ON NODE 1 IN Y DIRECTION,'/ +' ROW 3 GIVES APPARENT FORCE ON NODE 2 IN X DIRECTION,'/ +' ET CET.'/ / +' THE *STRENGTH* COLUMN GIVES APPARENT FORCE THAT WOULD BE'/ +' NEEDED TO BALANCE THE NON-ISOSTATIC STRESS FIELD;'/ +' THIS STRESS FIELD IS DEFINED BY SUBTRACTING THE VERTICAL'/ +' STRESS FROM BOTH HORIZONTAL NORMAL STRESS COMPONENTS.'/ +' THE *GRAVITY* COLUMN GIVES APPARENT FORCE THAT WOULD BE'/ +' NEEDED TO BALANCE ANY HORIZONTAL GRADIENTS OF VERTICAL'/ +' STRESS.'/ +' THE *DRAG* COLUMN GIVES APPARENT FORCE NEEDED TO BALANCE'/ +' ANY BASAL SHEAR TRACTIONS COMING FROM THE MANTLE.'/ +' THE *TOTAL* COLUMN IS THE SUM OF THE OTHERS, AND SHOWS THE'/ +' NET FORCE FROM OUTSIDE THE MODEL.'/ +' THE *COMMENT* COLUMN INDICATES WHETHER THE TOTAL IS EXPECTED'/ +' TO BE SMALL OR NOT.'/ /) WRITE (IUNITT,3) 3 FORMAT (' NODE COMPONENT STRENGTH GRAVITY', + ' DRAG TOTAL COMMENT'/) 4 FORMAT (' ',I10,8X,A2,1P,4E10.2,1X,A15) C C STRENGTH COLUMN C NENTRY=2*NUMNOD DO 110 I=1,NENTRY COMP(I,1)=0. 110 CONTINUE C C TRIANGULAR ELEMENT AREAS: DO 150 M=1,7 DO 140 I=1,NUMEL DA=AREA(I)*WEIGHT(M)*DETJ(M,I) DO 130 J=1,6 DBDX=DXS(J,M,I) DBDY=DYS(J,M,I) NODE=NODES(J,I) IX=2*NODE-1 IY=IX+1 COMP(IX,1)=COMP(IX,1)+DA* + (TAUMAT(1,M,I)*DBDX+TAUMAT(3,M,I)*DBDY) COMP(IY,1)=COMP(IY,1)+DA* + (TAUMAT(2,M,I)*DBDY+TAUMAT(3,M,I)*DBDX) 130 CONTINUE 140 CONTINUE 150 CONTINUE C C FAULT-TRACTION CONTRIBUTION (CONVERTED TO (SIGMA_H - SIGMA_Z)) DO 190 M=1,7 DO 180 I=1,NFL DS=FLEN(I)*FGAUSS(M) DO 170 J=1,6 NODE=NODEF(J,I) IX=2*NODE-1 IY=IX+1 C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C $ C CODE IS NOT FINISHED IN THIS SECTION $ C $ C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 170 CONTINUE 180 CONTINUE 190 CONTINUE C C GRAVITY COLUMN C DO 210 I=1,NENTRY COMP(I,2)= -FBASE(I) 210 CONTINUE C C DRAG COLUMN C DO 310 I=1,NENTRY COMP(I,3)=0. 310 CONTINUE DO 350 M=1,7 DO 340 I=1,NUMEL DA=AREA(I)*WEIGHT(M)*DETJ(M,I) DO 330 J=1,6 NODE=NODES(J,I) IX=2*NODE-1 IY=IX+1 COMP(IX,3)=COMP(IX,3)-DA*PHI(J,M)*SIGHB(1,M,I) COMP(IY,3)=COMP(IY,3)-DA*PHI(J,M)*SIGHB(2,M,I) 330 CONTINUE 340 CONTINUE 350 CONTINUE C C TOTAL COLUMN C DO 400 I=1,NENTRY COMP(I,4)=COMP(I,1)+COMP(I,2)+COMP(I,3) 400 CONTINUE C C WRITE OUT MATRIX, WITH ANNOTATIONS C 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 HASBC=NODE.GT.NREALN IC=2 IF (.NOT.HASBC) THEN DO 910 K=1,NCOND IF (NODCON(K).EQ.NODE) THEN HASBC=.TRUE. IC=ICOND(K) VBCA=VBCAZ(K) GO TO 911 ENDIF 910 CONTINUE ENDIF 911 IF (HASBC) THEN IF (IC.GE.2) THEN SIZE=LARGE ELSE IF (IC.EQ.1) THEN IF (CZ.EQ.CX) THEN IF (ABS(COS(VBCA)).LT.0.01) THEN SIZE=SMALL ELSE SIZE=LARGE ENDIF ELSE IF (ABS(SIN(VBCA)).LT.0.01) THEN SIZE=SMALL ELSE SIZE=LARGE ENDIF ENDIF ELSE SIZE=SMALL ENDIF ELSE SIZE=SMALL ENDIF C IF (NODE.GT.NREALN) NODE=N1000+(NODE-NREALN) WRITE (IUNITT,4) NODE, CZ, (COMP(I,J),J=1,4), SIZE C 1000 CONTINUE C WRITE (IUNITT,10) RETURN END C C C SUBROUTINE BUILDF (INPUT,AREA,DETJ,DVB,DXS,DYS,ETAMAX, + FBASE,FDIP,FLEN,FTAN,FTSTAR, + IFLOW,MXDOF,MXEL,MXFEL, + NDOF,NFL,NODEF,NODES, + NREALN,NUMEL,OVB,PULLED,SIGHB,TOFSET, + 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 OF 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 12-COMPONENT ELEMENT VECTOR IS FORMED FIRST, C WITH LOCAL NODE NUMBERS, AND THEN TRANSFERRED TO THE GLOBAL C FORCING VECTOR; THIS SIMPLIFIES ADRESSING. C C C NOTE: FOLLOWING TYPE CAN BE COMPRESSED TO LOGICAL*1 IN VS-FORTRAN: LOGICAL PULLED C DOUBLE PRECISION ELF,FBASE,FORCE DOUBLE PRECISION PHI,WEIGHT DOUBLE PRECISION FPHI,FGAUSS COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT DIMENSION PHI(6,7),WEIGHT(7) DIMENSION FPHI(6,7),FGAUSS(7) DIMENSION AREA(MXEL),DETJ(7,MXEL),DVB(7,MXEL), + DXS(6,7,MXEL),DYS(6,7,MXEL),ELF(12),ETAB(7), + FBASE(MXDOF),FDIP(3,MXFEL),FLEN(MXFEL), + FORCE(MXDOF),FTAN(7,MXFEL),FTSTAR(2,7,MXFEL), + NODEF(6,MXFEL),NODES(6,MXEL),OVB(2,7,MXEL), + PULLED(7,MXEL),SIGHB(2,7,MXEL),TOFSET(3,7,MXEL) DATA TINY/1.E-36/ 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,12 ELF(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) TOXX=TOFSET(1,M,I) TOYY=TOFSET(2,M,I) TOXY=TOFSET(3,M,I) DO 90 J=1,6 JU=2*J-1 JV=2*J ELF(JU)=ELF(JU)+DA*(-TOXX*DXS(J,M,I) + -TOXY*DYS(J,M,I)) ELF(JV)=ELF(JV)+DA*(-TOXY*DXS(J,M,I) + -TOYY*DYS(J,M,I)) 90 CONTINUE 100 CONTINUE C C BASAL SHEAR STRESSES (IF ANY) C IF (IFLOW.GT.0) THEN ETAHIB=0. DO 150 M=1,7 IF (PULLED(M,I)) THEN SIG=SQRT((1.D0*SIGHB(1,M,I))**2+ + (1.D0*SIGHB(2,M,I))**2) ETAB(M)=SIG/MAX(DVB(M,I),TINY) ETAB(M)=MIN(ETAB(M),ETAMAX) ETAHIB=MAX(ETAHIB,ETAB(M)) ENDIF 150 CONTINUE ETALOB=ETAHIB*0.01 DO 200 M=1,7 IF (PULLED(M,I)) THEN DA=AREA(I)*WEIGHT(M)*DETJ(M,I) ETAB(M)=MAX(ETAB(M),ETALOB) SHX=OVB(1,M,I)*ETAB(M) SHY=OVB(2,M,I)*ETAB(M) DO 190 J=1,6 JU=2*J-1 JV=2*J ELF(JU)=ELF(JU)+DA*SHX*PHI(J,M) ELF(JV)=ELF(JV)+DA*SHY*PHI(J,M) 190 CONTINUE ENDIF 200 CONTINUE ENDIF C C MOVE ENTRIES OF CONTINUUM-ELEMENT FORCE VECTOR INTO GLOBAL VECTOR C DO 900 J=1,6 IF(NODES(J,I).LE.NREALN) THEN JV=2*NODES(J,I) JU=JV-1 FORCE(JU)=FORCE(JU)+ELF(2*J-1) FORCE(JV)=FORCE(JV)+ELF(2*J) ENDIF 900 CONTINUE 1000 CONTINUE C C CONTRIBUTION FROM DIPPING, OBLIQUE-SLIP FAULT ELEMENTS: C DO 2000 I=1,NFL DO 1020 J=1,12 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)+ + FPHI(3,M)*FDIP(3,I) IF (ABS(DIP-1.570796).GT.WEDGE) THEN OSIND=1./SIN(DIP) OSIN2D=1./SIN(2.*DIP) ANGLE=FTAN(M,I) SINA=SIN(ANGLE) COSA=COS(ANGLE) DS=FLEN(I)*FGAUSS(M) DO 1090 J=1,6 JU=2*J-1 JV=2*J ELF(JU)=ELF(JU)+DS*FPHI(J,M)* + ( -COSA*OSIND*FTSTAR(1,M,I)+ + 2.*SINA*OSIN2D*FTSTAR(2,M,I)) ELF(JV)=ELF(JV)+DS*FPHI(J,M)* + ( -SINA*OSIND*FTSTAR(1,M,I)- + 2.*COSA*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,6 IF (NODEF(J,I).LE.NREALN) THEN JV=2*NODEF(J,I) JU=JV-1 FORCE(JU)=FORCE(JU)+ELF(2*J-1) FORCE(JV)=FORCE(JV)+ELF(2*J) ENDIF 1900 CONTINUE 2000 CONTINUE RETURN END C C C SUBROUTINE BUILDK (INPUT,ALPHA,AREA,DETJ,DVB,DXS,DYS,ETAMAX, + IFLOW,MXDOF,MXEL,MXNODE,MXWORK,NDOF,NLB, + NODES,NREALN,NUB,NUMEL,PULLED,SIGHB,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-6. 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 BECAUSE FAKE NODES ARE CONDENSED OUT OF THE LINEAR C SYSTEM, TERMS INVOLVING INTERACTIONS OF THESE NODES WITH REAL C NODES ARE NOT INCLUDED IN "STIFF", BUT INSTEAD ARE MULTIPLIED BY C THE KNOWN FAKE-NODE VELOCITIES, AND SUBTRACTED FROM "FORCE". C C C NOTE: FOLLOWING TYPE CAN BE COMPRESSED TO LOGICAL*1 IN VS-FORTRAN: LOGICAL PULLED C DOUBLE PRECISION ELK,FORCE,PHI,STIFF,SUM,V,WEIGHT DIMENSION ALPHA(3,3,7,MXEL),AREA(MXEL),DETJ(7,MXEL), + DVB(7,MXEL),DXS(6,7,MXEL),DYS(6,7,MXEL), + FORCE(MXDOF),NODES(6,MXEL),PULLED(7,MXEL), + SIGHB(2,7,MXEL),STIFF(MXWORK),V(2,MXNODE) DIMENSION ELK(2,2,6,6),ETA(7),PHI(6,7),WEIGHT(7) COMMON LDA,MD COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT C C STATEMENT FUNCTION REPLACING INTEGER FUNCTION SUBPROGRAM "INDEXK": INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + MD + IROW - JCOLUM C C BEGIN BY ZEROING THE MATRIX; ALL OTHER LOGIC WILL ADD TO IT. C CALL ZEROK (INPUT,MXWORK,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 I6=1,6 DO 9 J6=1,6 ELK(1,1,I6,J6)=0.0D0 ELK(1,2,I6,J6)=0.0D0 ELK(2,1,I6,J6)=0.0D0 ELK(2,2,I6,J6)=0.0D0 9 CONTINUE 10 CONTINUE C C INCORPORATE STIFFNESS TENSORS "ALPHA" C DO 90 I6=1,6 DO 80 J6=1,6 C C UPPER LEFT ELEMENTS: X-COEFFICIENTS IN X-BALANCE SUM=0.D0 DO 40 M=1,7 SUM=SUM+WEIGHT(M)*DETJ(M,I)* + (ALPHA(1,1,M,I)*DXS(J6,M,I)*DXS(I6,M,I) + +0.5*ALPHA(1,3,M,I)*DYS(J6,M,I)*DXS(I6,M,I) + +ALPHA(3,1,M,I)*DXS(J6,M,I)*DYS(I6,M,I) + +0.5*ALPHA(3,3,M,I)*DYS(J6,M,I)*DYS(I6,M,I)) 40 CONTINUE ELK(1,1,I6,J6)=ELK(1,1,I6,J6)+SUM*AREA(I) C C LOWER RIGHT ELEMENTS: Y-COEFFICIENTS IN Y-BALANCE SUM=0.D0 DO 50 M=1,7 SUM=SUM+WEIGHT(M)*DETJ(M,I)* + (ALPHA(3,2,M,I)*DYS(J6,M,I)*DXS(I6,M,I) + +0.5*ALPHA(3,3,M,I)*DXS(J6,M,I)*DXS(I6,M,I) + +ALPHA(2,2,M,I)*DYS(J6,M,I)*DYS(I6,M,I) + +0.5*ALPHA(2,3,M,I)*DXS(J6,M,I)*DYS(I6,M,I)) 50 CONTINUE ELK(2,2,I6,J6)=ELK(2,2,I6,J6)+SUM*AREA(I) C C UPPER RIGHT ELEMENTS: Y-COEFFICIENTS IN X-BALANCE SUM=0.0D0 DO 60 M=1,7 SUM=SUM+WEIGHT(M)*DETJ(M,I)* + (ALPHA(1,2,M,I)*DYS(J6,M,I)*DXS(I6,M,I) + +0.5*ALPHA(1,3,M,I)*DXS(J6,M,I)*DXS(I6,M,I) + +ALPHA(3,2,M,I)*DYS(J6,M,I)*DYS(I6,M,I) + +0.5*ALPHA(3,3,M,I)*DXS(J6,M,I)*DYS(I6,M,I)) 60 CONTINUE ELK(1,2,I6,J6)=ELK(1,2,I6,J6)+SUM*AREA(I) C C LOWER LEFT ELEMENTS: X-COEFFICIENTS IN Y-BALANCE SUM=0.0D0 DO 70 M=1,7 SUM=SUM+WEIGHT(M)*DETJ(M,I)* + (ALPHA(3,1,M,I)*DXS(J6,M,I)*DXS(I6,M,I) + +0.5*ALPHA(3,3,M,I)*DYS(J6,M,I)*DXS(I6,M,I) + +ALPHA(2,1,M,I)*DXS(J6,M,I)*DYS(I6,M,I) + +0.5*ALPHA(2,3,M,I)*DYS(J6,M,I)*DYS(I6,M,I)) 70 CONTINUE ELK(2,1,I6,J6)=ELK(2,1,I6,J6)+SUM*AREA(I) C 80 CONTINUE 90 CONTINUE C C ADD ANY DIAGONAL STIFFNESS ASSOCIATED WITH VISCOUS BASAL DRAG C IF (IFLOW.GT.0) THEN ETAHI=0. DO 110 M=1,7 IF (PULLED(M,I)) THEN SIGB=SQRT((1.D0*SIGHB(1,M,I))**2+ + (1.D0*SIGHB(2,M,I))**2) ETA(M)=SIGB/MAX(DVB(M,I),1.E-30) ETA(M)=MIN(ETA(M),ETAMAX) ETAHI=MAX(ETAHI,ETA(M)) ENDIF 110 CONTINUE ETALOW=ETAHI*0.01 DO 200 M=1,7 IF (PULLED(M,I)) THEN ETAUSE=MAX(ETA(M),ETALOW) ETADA=ETAUSE*WEIGHT(M)*AREA(I)*DETJ(M,I) DO 190 I6=1,6 DO 180 J6=1,6 SPRING=ETADA*PHI(I6,M)*PHI(J6,M) ELK(1,1,I6,J6)=ELK(1,1,I6,J6)+ + SPRING ELK(2,2,I6,J6)=ELK(2,2,I6,J6)+ + SPRING 180 CONTINUE 190 CONTINUE ENDIF 200 CONTINUE ENDIF C C APPLY ELEMENT MATRIX TO AUGMENT GLOBAL STIFFNESS MATRIX C OR LOAD VECTOR (IF THE COLUMN REFERS TO A FAKE NODE). C DO 400 I6=1,6 NODEI=NODES(I6,I) IF (NODEI.LE.NREALN) THEN IRY=2*NODEI IRX=IRY-1 DO 300 J6=1,6 NODEJ=NODES(J6,I) IF (NODEJ.LE.NREALN) THEN C CASE OF TWO REAL NODES: JCY=2*NODEJ JCX=JCY-1 IKXX=INDEXK(IRX,JCX) STIFF(IKXX)=STIFF(IKXX)+ELK(1,1,I6,J6) IKXY=INDEXK(IRX,JCY) STIFF(IKXY)=STIFF(IKXY)+ELK(1,2,I6,J6) IKYX=INDEXK(IRY,JCX) STIFF(IKYX)=STIFF(IKYX)+ELK(2,1,I6,J6) IKYY=INDEXK(IRY,JCY) STIFF(IKYY)=STIFF(IKYY)+ELK(2,2,I6,J6) ELSE C CASE WHERE I IS A REAL NODE BUT J IS NOT: FORCE(IRX)=FORCE(IRX)-ELK(1,1,I6,J6)*V(1,NODEJ) + -ELK(1,2,I6,J6)*V(2,NODEJ) FORCE(IRY)=FORCE(IRY)-ELK(2,1,I6,J6)*V(1,NODEJ) + -ELK(2,2,I6,J6)*V(2,NODEJ) ENDIF 300 CONTINUE ENDIF 400 CONTINUE 500 CONTINUE RETURN END C C C SUBROUTINE DERIV (INPUT,AREA,NODES,NUMEL,NUMNOD,XNODE,YNODE, + OUTPUT,DETJ,DXS,DYS) C C CALCULATES DXS AND DYS, THE X-DERIVITIVE AND Y-DERIVITIVE C OF EACH OF THE 6 NODAL FUNCTIONS OF A DEFORMED-TRIANGLE C FINITE ELEMENT, AT EACH OF THE 7 INTEGRATION POINTS IN C THAT ELEMENT. ALSO PROVIDES DETJ, THE DETERMINANT OF THE C JACOBIAN MATRIX FOR THE TRANSFORMATION IN WHICH INTERNAL C POINTS OF A TRIANGLE WITH STRAIGHT SIDES ARE MAPPED INTO C NEW LOCATIONS AS SIDES BEND (BUT CORNERS STAY FIXED). C DOUBLE PRECISION POINTS DIMENSION AREA(NUMEL),DETJ(7,NUMEL), + DXS(6,7,NUMEL),DYS(6,7,NUMEL), + NODES(6,NUMEL), + XNODE(NUMNOD),YNODE(NUMNOD) DIMENSION B(4),C(4),DN(6,2),POINTS(5,7),X(6),Y(6) COMMON /S1S2S3/ POINTS DO 500 I=1,NUMEL DO 100 J=1,6 NODE=NODES(J,I) X(J)=XNODE(NODE) Y(J)=YNODE(NODE) 100 CONTINUE B(1)=Y(2)-Y(3) B(2)=Y(3)-Y(1) B(3)=Y(1)-Y(2) B(4)=B(1) C(1)=X(3)-X(2) C(2)=X(1)-X(3) C(3)=X(2)-X(1) C(4)=C(1) AI2=1./(2.*AREA(I)) DO 400 M=1,7 DO 200 J=1,3 DN(J,1)=AI2*B(J)*(4.*POINTS(J,M)-1.) DN(J+3,1)=AI2*4.*(B(J)*POINTS(J+1,M) + +B(J+1)*POINTS(J,M)) DN(J,2)=AI2*C(J)*(4.*POINTS(J,M)-1.) DN(J+3,2)=AI2*4.*(C(J)*POINTS(J+1,M) + +C(J+1)*POINTS(J,M)) 200 CONTINUE AJ11=0. AJ12=0. AJ21=0. AJ22=0. DO 300 J=1,6 AJ11=AJ11+DN(J,1)*X(J) AJ12=AJ12+DN(J,1)*Y(J) AJ21=AJ21+DN(J,2)*X(J) AJ22=AJ22+DN(J,2)*Y(J) 300 CONTINUE DETJAC=AJ11*AJ22-AJ12*AJ21 DETJ(M,I)=DETJAC AJ11S=AJ11 AJ11=AJ22/DETJAC AJ12=-AJ12/DETJAC AJ21=-AJ21/DETJAC AJ22=AJ11S/DETJAC DO 350 J=1,6 DXS(J,M,I)=AJ11*DN(J,1)+AJ12*DN(J,2) DYS(J,M,I)=AJ21*DN(J,1)+AJ22*DN(J,2) 350 CONTINUE 400 CONTINUE 500 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(*,"(/' Error: E1:',1P,E10.2,' > E2:', + E10.2)") E1,E2 STOP 'DIAMND detected incorrect INPUTs.' 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) SC0=2.*VISINF*EXP((BCREEP+CCREEP*ZOFTOP)/T0)*ESCRIT 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) SC1=2.*VISINF*EXP((BCREEP+CCREEP*(ZOFTOP+Z1))/T1)*ESCRIT 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 error 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) SCH=2.*VISINF*EXP((BCREEP+CCREEP*(ZOFTOP+ZH))/TH) + *ESCRIT 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 (surface, or Moho) and may not be absolute depth. T=GEOTH1+GEOTH2*Z+GEOTH3*Z**2+GEOTH4*Z**3 T=MIN(T,TEMLIM) VIS=VISINF*EXP((BCREEP+CCREEP*(ZOFTOP+Z))/T) 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 EDOT (INPUT,DXS,DYS,MXEL,MXNODE,NODES,NUMEL,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 V DIMENSION DXS(6,7,MXEL),DYS(6,7,MXEL), + ERATE(3,7,MXEL),NODES(6,MXEL), + V(2,MXNODE) C DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=0. EYY=0. EXY=0. DO 800 J=1,6 NODE=NODES(J,I) VX=V(1,NODE) VY=V(2,NODE) DX=DXS(J,M,I) DY=DYS(J,M,I) EXX=EXX+VX*DX EYY=EYY+VY*DY EXY=EXY+(VX*DY+VY*DX)*0.5 800 CONTINUE ERATE(1,M,I)=EXX ERATE(2,M,I)=EYY ERATE(3,M,I)=EXY 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE FEM (INPUT,ALPHA,AREA,CONSTR,DETJ,DVB,DXS,DYS, + ETAMAX,EVERYP,FBASE,FC,FDIP, + FIMUDZ,FLEN,FTAN, + FTSTAR,ICOND,IFLOW,IUNITS,IUNITT, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + MXWORK,NCOND,NDOF,NFL,NLB,NODCON,NODEF, + NODES,NREALN,NUB,NUMEL,NUMNOD, + OVB,PULLED,SIGHB, + TITLE1,TITLE2,TITLE3,TOFSET, + VBCAZ,VBCMAG,WEDGE,XNODE, + YNODE,LASTPM, + MODIFY,ERATE, + OUTPUT,SCOREA,SCOREB,TAUMAT,V, + WORK,F,IPVT,K) C C COMPUTES HORIZONTAL VELOCITY OF NODES IN A SINGLE LAYER 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 FOUR SCORES (A-D)=MAX DV, RMS DV/RMS V, C MAX DT, RMS DT/RMS T. 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), + DVB(7,MXEL),DXS(6,7,MXEL),DYS(6,7,MXEL), + ERATE(3,7,MXEL),F(MXDOF),FBASE(MXDOF),FC(2,2,7,MXFEL), + FDIP(3,MXFEL),FIMUDZ(7,MXFEL),FLEN(MXFEL), + FTAN(7,MXFEL),FTSTAR(2,7,MXFEL), + ICOND(MXBN),IPVT(MXDOF), + K(MXWORK),NODCON(MXBN),NODEF(6,MXFEL),NODES(6,MXEL), + OVB(2,7,MXEL),PULLED(7,MXEL), + SIGHB(2,7,MXEL),TAUMAT(3,7,MXEL), + TOFSET(3,7,MXEL),V(2,MXNODE),VBCAZ(MXBN), + VBCMAG(MXBN),XNODE(MXNODE),YNODE(MXNODE) C IF(LASTPM.NE.999) THEN WRITE (IUNITT,1) 1 FORMAT(' WRONG NUMBER OF ARGUMENTS IN CALL TO FEM!') STOP ENDIF C CALL BUILDF (INPUT,AREA,DETJ,DVB,DXS,DYS,ETAMAX, + FBASE,FDIP,FLEN,FTAN,FTSTAR, + IFLOW,MXDOF,MXEL,MXFEL, + NDOF,NFL,NODEF,NODES, + NREALN,NUMEL,OVB,PULLED,SIGHB,TOFSET, + WEDGE, + OUTPUT,F) CALL BUILDK (INPUT,ALPHA,AREA,DETJ,DVB,DXS,DYS,ETAMAX,IFLOW, + MXDOF,MXEL,MXNODE,MXWORK,NDOF,NLB, + NODES,NREALN,NUB,NUMEL,PULLED,SIGHB,V, + MODIFY,F, + OUTPUT,K) CALL ADDFST (INPUT,CONSTR,FC,FDIP,FIMUDZ,FLEN,FTAN, + MXDOF,MXFEL,MXNODE,MXWORK, + NFL,NODEF,NREALN, + V,WEDGE, + MODIFY,K,F) CALL VBCS (INPUT,ICOND,MXBN,MXDOF,MXNODE,MXWORK, + NCOND,NDOF,NLB,NODCON,NREALN,NUB, + VBCAZ,VBCMAG, + MODIFY,K,V,F) C C NOTE: FOLLOWING STATEMENT 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,K,MXDOF,MXWORK,NDOF,NLB,NUB) C CALL SOLVER (INPUT,MXDOF,MXWORK,NDOF,NLB,NUB, + MODIFY,K,F, + WORK,IPVT) C C AT THIS POINT, OLD SOLUTION IS IN V, AND NEW ONE IN F. COMPARE: C BDENOM=0. BDENON=0. SCOREA=0. SCOREB=0. DO 90 I=1,NREALN BDENOM=BDENOM+SQRT(F(2*I-1)**2+F(2*I)**2) BDENON=BDENON+SQRT(V(1,I)**2+V(2,I)**2) DV=SQRT( (V(1,I)-F(2*I-1))**2 + + (V(2,I)-F(2*I))**2 ) SCOREA=MAX(SCOREA,DV) SCOREB=SCOREB+DV 90 CONTINUE IF (NUMNOD.GT.NREALN) THEN DO 91 I=NREALN+1,NUMNOD VS=SQRT(V(1,I)**2+V(2,I)**2) BDENOM=BDENOM+VS BDENON=BDENON+VS 91 CONTINUE ENDIF BDEN=MAX(BDENOM,BDENON) IF (BDEN.GT.0.) THEN SCOREB=(SCOREB-SCOREA)/BDEN ELSE SCOREB=1.0 ENDIF C C TRANSFER NEW SOLUTION TO V, WHERE IT WILL BE 'OLD' NEXT TIME C DO 100 I=1,NREALN 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,MXEL,MXNODE,NODES,NUMEL,V, + OUTPUT,ERATE) CALL TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) C RETURN END C C C SUBROUTINE FILLIN (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,CFRIC,CONDUC,DQDTDA, + ECREEP,ELEV,ERATE,GMEAN,IFLOW,IUNITT, + MXEL,MXNODE,NODES,NUMEL,NUMNOD,ONEKM, + RADIO,RHOAST,RHOBAR,RHOH2O,TEMLIM, + TSURF,XNODE,YNODE,V,ZMNODE, + OUTPUT,GEOTH,GLUE,PULLED,SIGZZI,TAUZZI, + TAUZZN,VM,ZMOHO, + WORK,ATNODE) C C PRECOMPUTE AND INTERPOLATE ALL "CONVENIENCE ARRAYS": C LOGICAL PULLED,RESIST DOUBLE PRECISION V,VM DOUBLE PRECISION PHI COMMON /PHITAB/ PHI DIMENSION PHI(6,7) DIMENSION ATNODE(MXNODE),DQDTDA(MXNODE),ELEV(MXNODE), + ERATE(3,7,MXEL),GEOTH(4,7,MXEL),GLUE(7,MXEL), + NODES(6,MXEL),PULLED(7,MXEL), + SIGZZI(7,MXEL),TAUZZI(7,MXEL),TAUZZN(MXNODE), + V(2,MXNODE),VM(2,MXNODE),XNODE(MXNODE),YNODE(MXNODE), + ZMNODE(MXNODE),ZMOHO(7,MXEL) C C GEOTHERM (STEADY-STATE): C GEOTH1=TSURF GEOTH3= -0.5*RADIO/CONDUC GEOTH4=0.0 DO 20 M=1,7 DO 10 I=1,NUMEL GEOTH(1,M,I)=GEOTH1 Q=DQDTDA(NODES(1,I))*PHI(1,M)+ + DQDTDA(NODES(2,I))*PHI(2,M)+ + DQDTDA(NODES(3,I))*PHI(3,M)+ + DQDTDA(NODES(4,I))*PHI(4,M)+ + DQDTDA(NODES(5,I))*PHI(5,M)+ + DQDTDA(NODES(6,I))*PHI(6,M) GEOTH(2,M,I)=Q/CONDUC GEOTH(3,M,I)=GEOTH3 GEOTH(4,M,I)=GEOTH4 10 CONTINUE 20 CONTINUE C C THICKNESS OF CRUST (DEPTH OF MOHO, RELATIVE TO SURFACE): C CALL INTERP (INPUT,ZMNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,ZMOHO) 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 CALL SQUEEZ (INPUT,ALPHAT,ELEV(I),GEOTH1,GEOTH2, + GEOTH3,GEOTH4,GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, + TEMLIM,ZMNODE(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 DUCTILE LOWER CRUST: C CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP, + ECREEP,ERATE,CFRIC,GMEAN,GEOTH, + NODES,NUMEL,RHOH2O,RHOBAR, + TEMLIM,ZMOHO, + OUTPUT,GLUE) C C PRECOMPUTE VELOCITY OF THE TOP OF THE MANTLE C (AT NODES, SO THAT INTERPOLATION WILL BE IDENTICAL TO THAT C OCCURRING IN THE CRUSTAL LAYER). C DO 400 I=1,NUMNOD C (NOTE: V, VM ARE DOUBLE PRECISION; BUT MANTLE ISN'T. C THUS, IMPLICIT TYPE CONVERSIONS OCCUR BEFORE AND AFTER CALL.) TCX=V(1,I) TCY=V(2,I) CALL MANTLE (INPUT,IFLOW,TCX,TCY,XNODE(I),YNODE(I), + OUTPUT,RESIST,TMX,TMY) VM(1,I)=TMX VM(2,I)=TMY 400 CONTINUE C C NOW, DETERMINE FOR EACH INTEGRATION POINT WHETHER IT IS ACTUALLY C PULLED BY A STRONG UPPER MANTLE LITHOSPHERE C DO 500 M=1,7 DO 490 I=1,NUMEL X=XNODE(NODES(1,I))*PHI(1,M)+ + XNODE(NODES(2,I))*PHI(2,M)+ + XNODE(NODES(3,I))*PHI(3,M)+ + XNODE(NODES(4,I))*PHI(4,M)+ + XNODE(NODES(5,I))*PHI(5,M)+ + XNODE(NODES(6,I))*PHI(6,M) Y=YNODE(NODES(1,I))*PHI(1,M)+ + YNODE(NODES(2,I))*PHI(2,M)+ + YNODE(NODES(3,I))*PHI(3,M)+ + YNODE(NODES(4,I))*PHI(4,M)+ + YNODE(NODES(5,I))*PHI(5,M)+ + YNODE(NODES(6,I))*PHI(6,M) TCX=0. TCY=0. CALL MANTLE (INPUT,IFLOW,TCX,TCY,X,Y, + OUTPUT,RESIST,TMX,TMY) PULLED(M,I)=RESIST 490 CONTINUE 500 CONTINUE RETURN END C C C SUBROUTINE FIXED (INPUT,ALPHAT,AREA,CONDUC,DETJ,DQDTDA,DXS,DYS, + EDGETS,ELEV,FDIP,FLEN,FTAN,GMEAN,IUNITT, + MXDOF,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES,NUMEL, + ONEKM,RADIO,RHOAST,RHOBAR,RHOH2O,SIGZZI, + TAUZZI,TAUZZN,TEMLIM,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 C NOTE THAT THE CALCULATION INCLUDES THE LOWER PARTITION OF THE C VECTOR, CORREPONDING TO THE "FAKE" DEGREES OF FREEDOM OF C THE "FAKE" NODES NUMBER N1000+1 AND UP. THIS IS NECESSARY C TO PROVIDE INFORMATION NEEDED BY SUBPROGRAM -BALANC- IN THE C POST-PROCESSING STEP. C C NUMBER OF STEPS TO USE IN VERTICAL INTEGRATIONS: PARAMETER (NSTEP=50) C LOGICAL ATSEA,EDGETS DOUBLE PRECISION FBASE DOUBLE PRECISION PHI,POINTS,WEIGHT DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS COMMON /S1S2S3/ POINTS COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT DIMENSION FPHI(6,7),FPOINT(7),FGAUSS(7) DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) DIMENSION AREA(MXEL),DETJ(7,MXEL),DQDTDA(MXNODE), + DXS(6,7,MXEL),DYS(6,7,MXEL),EDGETS(3,MXEL), + ELEV(MXNODE),FBASE(MXDOF),FDIP(3,MXFEL), + FLEN(MXFEL),FTAN(7,MXFEL), + NODEF(6,MXFEL),NODES(6,MXEL),SIGZZI(7,MXEL), + TAUZZI(7,MXEL),TAUZZN(MXNODE), + XNODE(MXNODE),YNODE(MXNODE),ZMNODE(MXNODE) C C STATEMENT FUNCTION: C PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) C DO 10 I=1,MXDOF FBASE(I)=0.0D0 10 CONTINUE C C EFFECT OF VERTICALLY-INTEGRATED TOPOGRAPHIC STRESS C ANOMALY (TAUZZ), AND C HORIZONTAL COMPONENTS OF BASAL TRACTION ANOMALY 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) SLOPEX=0. SLOPEY=0. DO 20 J=1,6 ZM=ZMNODE(NODES(J,I)) SLOPEX=SLOPEX+ZM*DXS(J,M,I) SLOPEY=SLOPEY+ZM*DYS(J,M,I) 20 CONTINUE DO 80 J=1,6 NODE=NODES(J,I) KROWX=2*NODE-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+DAREA* + (-SIGZZI(M,I)*SLOPEX*PHI(J,M) + -TAUZZI(M,I)*DXS(J,M,I)) FBASE(KROWY)=FBASE(KROWY)+DAREA* + (-SIGZZI(M,I)*SLOPEY*PHI(J,M) + -TAUZZI(M,I)*DYS(J,M,I)) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C EFFECT OF NORMAL TRACTION (ASSUMED EQUAL TO VERTICAL COMPRESSION, C INCLUDING TOPOGRAPHIC STRESS) ON SIDE BOUNDARIES OF TRIANGULAR C CONTINUUM ELEMENTS: C (NOTE: THESE FORCES WILL USUALLY BE OVERWRITTEN BY VELOCITY C BOUNDARY CONDITIONS, BUT ARE PROVIDED JUST IN 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, 3)+4,I) N3=NODES(MOD(J+1,3)+1,I) X1=XNODE(N1) X2=XNODE(N2) X3=XNODE(N3) Y1=YNODE(N1) Y2=YNODE(N2) Y3=YNODE(N3) SLONG=0. OLDX=X1 OLDY=Y1 DO 110 K=1,20 S=K/20. F1=1.-3.*S+2.*S**2 F2=4.*S*(1.-S) F3= -S+2.*S**2 X=X1*F1+X2*F2+X3*F3 Y=Y1*F1+Y2*F2+Y3*F3 SLONG=SLONG+SQRT((X-OLDX)**2+(Y-OLDY)**2) OLDX=X OLDY=Y 110 CONTINUE DO 180 M=1,7 TZZ=TAUZZN(N1)*FPHI(1,M)+TAUZZN(N2)*FPHI(2,M) + +TAUZZN(N3)*FPHI(3,M) DS=FGAUSS(M)*SLONG S=FPOINT(M) DF1DS= -3.+4.*S DF2DS=4.-8.*S DF3DS= -1.+4.*S DXDS=X1*DF1DS+X2*DF2DS+X3*DF3DS DYDS=Y1*DF1DS+Y2*DF2DS+Y3*DF3DS ANGLE=ATAN2(DYDS,DXDS) XOUT=COS(ANGLE-1.570796) YOUT=SIN(ANGLE-1.570796) KROWX=2*N1-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+DS*FPHI(1,M)* + TZZ*XOUT FBASE(KROWY)=FBASE(KROWY)+DS*FPHI(1,M)* + TZZ*YOUT KROWX=2*N2-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+DS*FPHI(2,M)* + TZZ*XOUT FBASE(KROWY)=FBASE(KROWY)+DS*FPHI(2,M)* + TZZ*YOUT KROWX=2*N3-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+DS*FPHI(3,M)* + TZZ*XOUT FBASE(KROWY)=FBASE(KROWY)+DS*FPHI(3,M)* + TZZ*YOUT 180 CONTINUE ENDIF 190 CONTINUE 200 CONTINUE 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) N5=NODEF(5,I) N6=NODEF(6,I) X1=XNODE(N1) X2=XNODE(N2) X3=XNODE(N3) Y1=YNODE(N1) Y2=YNODE(N2) Y3=YNODE(N3) C C FIND NEIGHBORING TRIANGULAR ELEMENTS, IF ANY: C KELE2=0 KELE5=0 DO 210 J=1,NUMEL IF ((NODES(4,J).EQ.N2).OR.(NODES(5,J).EQ.N2).OR. + (NODES(6,J).EQ.N2)) KELE2=J IF ((NODES(4,J).EQ.N5).OR.(NODES(5,J).EQ.N5).OR. + (NODES(6,J).EQ.N5)) KELE5=J 210 CONTINUE DO 290 M=1,7 X0=X1*FPHI(1,M)+X2*FPHI(2,M)+X3*FPHI(3,M) Y0=Y1*FPHI(1,M)+Y2*FPHI(2,M)+Y3*FPHI(3,M) DS=FGAUSS(M)*FLEN(I) ANGLE=FTAN(M,I) XOUT=COS(ANGLE+1.570796) YOUT=SIN(ANGLE+1.570796) DIP=FDIP(1,I)*FPHI(1,M)+FDIP(2,I)*FPHI(2,M)+ + FDIP(3,I)*FPHI(3,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)+ + TAUZZN(N3)*FPHI(3,M) ELSE C CASE OF SHALLOW DIP: IF (DIP.GT.1.570796) THEN C DIP IS TOWARD N5 SIDE: KELE=KELE5 ELSE C DIP IS TOWARD N2 SIDE: KELE=KELE2 ENDIF IF (KELE.EQ.0) THEN C NO NEIGHBORING ELEMENT (AT GRID EDGE): TZZ=TAUZZN(N1)*FPHI(1,M)+ + TAUZZN(N2)*FPHI(2,M)+ + TAUZZN(N3)*FPHI(3,M) ELSE C INTEGRATE ON A SLANT BELOW NEIGHBOR ELEMENTS. C (1) FIND INTERSECTION OF FAULT WITH MOHO: ZM=ZMNODE(N1)*FPHI(1,M)+ + ZMNODE(N2)*FPHI(2,M)+ + ZMNODE(N3)*FPHI(3,M) TOSIDE=ZM/TAN(DIP) SIDEAZ=ANGLE-1.570796 XM=X0+TOSIDE*COS(SIDEAZ) YM=Y0+TOSIDE*SIN(SIDEAZ) C (2) SUBDIVIDE SLANT PATH INTO STEPS DX=(XM-X0)/NSTEP DY=(YM-Y0)/NSTEP DZ=ZM/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,DETJ, + IUNITT,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES,NUMEL, + X,XNODE,Y,YNODE, + MODIFY,KELE,S1,S2,S3, + OUTPUT,ATSEA) DTDZ=PHIVAL(S1,S2,S3, + DQDTDA(NODES(1,KELE)), + DQDTDA(NODES(2,KELE)), + DQDTDA(NODES(3,KELE)), + DQDTDA(NODES(4,KELE)), + DQDTDA(NODES(5,KELE)), + DQDTDA(NODES(6,KELE))) + /CONDUC ELEVAT=PHIVAL(S1,S2,S3, + ELEV(NODES(1,KELE)),ELEV(NODES(2,KELE)), + ELEV(NODES(3,KELE)),ELEV(NODES(4,KELE)), + ELEV(NODES(5,KELE)),ELEV(NODES(6,KELE))) CALL SQUEEZ ( + INPUT,ALPHAT,ELEVAT,TSURF,DTDZ, + -RADIO/(2.*CONDUC),0.0,GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR, + RHOH2O,TEMLIM,Z, + OUTPUT,TAUZZ,SIGZZ) IF (.NOT.ATSEA) THEN TZZ=TZZ+SIGZZ*DZ ELSE TZZ=TAUZZN(N1)*FPHI(1,M)+ + TAUZZN(N2)*FPHI(2,M)+ + TAUZZN(N3)*FPHI(3,M) GO TO 251 ENDIF 250 CONTINUE 251 CONTINUE ENDIF ENDIF KROWX=2*N1-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+DS*FPHI(1,M)* + TZZ*XOUT FBASE(KROWY)=FBASE(KROWY)+DS*FPHI(1,M)* + TZZ*YOUT KROWX=2*N2-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+DS*FPHI(2,M)* + TZZ*XOUT FBASE(KROWY)=FBASE(KROWY)+DS*FPHI(2,M)* + TZZ*YOUT KROWX=2*N3-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+DS*FPHI(3,M)* + TZZ*XOUT FBASE(KROWY)=FBASE(KROWY)+DS*FPHI(3,M)* + TZZ*YOUT KROWX=2*N4-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+DS*FPHI(4,M)* + TZZ*XOUT FBASE(KROWY)=FBASE(KROWY)+DS*FPHI(4,M)* + TZZ*YOUT KROWX=2*N5-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+DS*FPHI(5,M)* + TZZ*XOUT FBASE(KROWY)=FBASE(KROWY)+DS*FPHI(5,M)* + TZZ*YOUT KROWX=2*N6-1 KROWY=KROWX+1 FBASE(KROWX)=FBASE(KROWX)+DS*FPHI(6,M)* + TZZ*XOUT FBASE(KROWY)=FBASE(KROWY)+DS*FPHI(6,M)* + TZZ*YOUT 290 CONTINUE 300 CONTINUE RETURN END C C C SUBROUTINE FLOW (INPUT,NODES,NUMEL,NUMNOD,V, + OUTPUT,OUTVEC) C C CALCULATES VELOCITY VECTORS AT INTEGRATION POINTS, FROM NODAL VALUES C DOUBLE PRECISION PHI,V DIMENSION NODES(6,NUMEL),OUTVEC(2,7,NUMEL), + PHI(6,7),V(2,NUMNOD) COMMON /PHITAB/ PHI 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,6 DO 90 M=1,7 DO 80 I=1,NUMEL OUTVEC(1,M,I)=OUTVEC(1,M,I)+V(1,NODES(J,I)) + *PHI(J,M) OUTVEC(2,M,I)=OUTVEC(2,M,I)+V(2,NODES(J,I)) + *PHI(J,M) 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE GETNET (INPUT,IUNIT7,IUNIT8, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF,DQDTDA,ELEV,FAZ,FDIP, + NFAKEN,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,OFFMAX,OFFSET, + TITLE1,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), + DQDTDA(MXNODE),ELEV(MXNODE), + FAZ(2,MXFEL),FDIP(3,MXFEL), + NODEF(6,MXFEL),NODES(6,MXEL),OFFSET(MXFEL), + XNODE(MXNODE),YNODE(MXNODE),ZMNODE(MXNODE) DIMENSION DIPS(3),IFN(6) C WRITE (IUNIT8,1) IUNIT7 1 FORMAT (/' ATTEMPTING TO READ FINITE ELEMENT GRID FROM UNIT',I3) 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, AND HOW MANY ARE "REAL" VERSUS "FAKE". C INPUT NODAL LOCATIONS (X,Y), ELEVATIONS, HEAT-FLOW, AND ISOSTATIC C GRAVITY ANOMALIES (ONE RECORD PER NODE). C (OPTION "BRIEF" SUPPRESSES MOST OUTPUT) C READ (IUNIT7,*) NUMNOD,NREALN,NFAKEN,N1000,BRIEF C IF (NUMNOD.NE.(NREALN+NFAKEN)) THEN WRITE (IUNIT8,5) 5 FORMAT (/' INCONSISTENT DATA:'/ + ' NUMBER OF NODES SHOULD EQUAL TOTAL OF REAL', + ' NODES AND FAKE NODES.') STOP ENDIF 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.') STOP ENDIF N2=2*NUMNOD IF (N2.GT.MXDOF) THEN WRITE (IUNIT8,15) N2 15 FORMAT(/' INCREASE PARAMETER MAXDOF TO BE AT LEAST' + /' TWICE THE NUMBER OF NODES (',I6,')' + /' AND RECOMPILE.') STOP ENDIF IF (NREALN.GT.N1000) THEN WRITE (IUNIT8,20) NREALN 20 FORMAT (/' INCREASE THE DATA VALUE N1000 TO BE GREATER' + /' OR EQUAL TO NREALN (',I6,') AND RECOMPILE.') STOP ENDIF IF (NFAKEN.GT.MXBN) THEN WRITE (IUNIT8,30) NFAKEN 30 FORMAT(/' INCREASE THE PARAMETER MAXBN TO BE GREATER' + /' OR EQUAL TO NFAKEN (',I6,') AND RECOMPILE.') STOP ENDIF C NBASE=N1000+1 NTOP=N1000+NFAKEN IF (BRIEF) THEN WRITE (IUNIT8,35) 35 FORMAT(/' (SINCE OPTION BRIEF=.TRUE., GRID WILL NOT BE ', + 'ECHOED HERE. BE CAREFUL!!!)') ELSE WRITE (IUNIT8,40) NUMNOD,NREALN,NREALN 40 FORMAT (/' THERE ARE',I5,' NODES IN THE GRID:'/ ' ',I5, + ' OF THESE ARE NUMBERED 1-',I4,' AND THESE REAL NODES', + ' HAVE TWO VELOCITY VARIABLES UNLESS CONSTRAINED.') IF (NFAKEN.GT.0) WRITE (IUNIT8,42) NFAKEN,NBASE,NTOP 42 FORMAT(' ',I5, + ' OF THESE ARE NUMBERED ',I6,'-',I6,' AND THESE ARE', + ' ARTIFICIAL;'/' THEIR VELOCITIES MUST BE', + ' COMPLETELY SPECIFIED.') WRITE (IUNIT8,49) 49 FORMAT(/ + ' (NOTE: X AND Y COORDINATES MAY BE ZERO FOR NODES WHICH' + ,' WILL BE AT MIDPOINTS OF ELEMENT SIDES AND/OR FAULTS.'/ + ' THE PROGRAM WILL INTERPOLATE VALUES FOR THESE.)') WRITE (IUNIT8,50) 50 FORMAT (/' ', + ' CRUSTAL'/ + ' NODE X Y ELEVATION ', + 'HEAT-FLOW THICKNESS'/) ENDIF DO 90 K=1,NUMNOD CHECKN(K)=.FALSE. 90 CONTINUE DO 100 K=1,NUMNOD READ (IUNIT7,*) INDEX,XI,YI,ELEVI,QI,ZMI C (NODES NEED NOT BE INPUT IN ORDER, BUT MUST ALL BE PRESENT.) IF (INDEX.LE.NREALN) THEN I=INDEX ELSE I=INDEX-N1000+NREALN ENDIF CHECKN(I)=.TRUE. ELEV(I)=ELEVI DQDTDA(I)=QI IF (QI.LT.0.) THEN WRITE (IUNIT8,91) 91 FORMAT (' NEGATIVE HEAT-FLOW IS NON-PHYSICAL.') STOP ENDIF XNODE(I)=XI YNODE(I)=YI IF (ZMI.LT.0.) THEN WRITE (IUNIT8,92) 92 FORMAT(' NEGATIVE CRUSTAL THICKNESS IS NON-PHYSICAL.') STOP ENDIF ZMNODE(I)=ZMI IF (.NOT.BRIEF) THEN WRITE (IUNIT8,95) INDEX,XI,YI,ELEVI,QI,ZMI 95 FORMAT (' ',I10,1P,2E11.3,3E10.2) ENDIF 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 (.NOT.CHECKN(I)) WRITE(IUNIT8,103)I 103 FORMAT (' ',36X,I6) 104 CONTINUE 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.') 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 CORNERS-FIRST, COUNTER', + 'CLOCKWISE; THEN'/' MIDPOINTS, COUNTERCLOCKWISE, BEGINNING' + ,' WITH THE MIDPOINT BETWEEN CORNER #1 AND CORNER #2)'/ / + ' ELEMENT C1 C2 C3 M1 M2', + ' M3') DO 200 K=1,NUMEL C (ELEMENTS NEED NOT BE INPUT IN ORDER, BUT MUST ALL BE PRESENT.) READ (IUNIT7,*) I,(IFN(J),J=1,6) CHECKE(I)=.TRUE. IF (.NOT.BRIEF) WRITE (IUNIT8,120) I,(IFN(J),J=1,6) 120 FORMAT (' ',I6,':',6I10) DO 130 J=1,6 N=IFN(J) IF ((N.LE.0).OR.(N.GT.NTOP).OR. + ((N.GT.NREALN).AND.(N.LE.N1000))) THEN WRITE (IUNIT8,125) N 125 FORMAT (' NODE NUMBER ',I6,' IS ILLEGAL.') STOP ENDIF IF (N.GT.NREALN) N=N-N1000+NREALN 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 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.') 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,' CURVILINEAR FAULT ELEMENTS.') IF ((.NOT.BRIEF).AND.(NFL.GT.0)) WRITE(IUNIT8,231) 231 FORMAT (/' (THE 6 NODE NUMBERS DEFINING EACH ELEMENT MUST BE', + ' IN A COUNTERCLOCKWISE ORDER:'/ + ' N1, N2, AND N3 ARE IN LEFT-TO-RIGHT SEQUENCE ON THE', + ' NEAR SIDE,'/ + ' THEN N4 IS OPPOSITE N3, N5 IS OPPOSITE N2, AND ', + 'N6 IS OPPOSITE N1.)'/' (FAULT DIPS ARE GIVEN AT N1, N2, ', + 'AND N3, IN DEGREES FROM HORIZONTAL;'/ + ' POSITIVE DIPS ARE TOWARD N1, N2, AND N3, RESPECTIVELY, '/ + ' WHILE NEGATIVE DIPS ARE TOWARD N6, N5, AND N4.)'/ + ' (THE ARGUMENT OF THE FAULT TRACE IS GIVEN AT N1 AND N3,'/ + ' IN DEGREES COUNTERCLOCKWISE FROM THE X AXIS.)'/ + ' OFFSET IS THE TOTAL PAST SLIP OF THE FAULT.'/ / + ' ELEMENT N1 N2 N3 N4 N5 N6 DIP1 DIP2 DIP3', + ' ARG1 ARG3 OFFSET'/) 240 FORMAT (' ',I6,':',6I5,1X,3F6.1,1X,2F5.0,F9.0) DO 300 K=1,NFL OFF=0. READ (IUNIT7,*,ERR=242) I,(IFN(J),J=1,6),(DIPS(L),L=1,3), + AZ1,AZ3,OFF 242 CHECKF(I)=.TRUE. IF (.NOT.BRIEF) WRITE (IUNIT8,240) I,(IFN(J),J=1,6), + (DIPS(L),L=1,3),AZ1,AZ3,OFF DO 250 J=1,6 N=IFN(J) IF ((N.LE.0).OR.(N.GT.NTOP).OR. + ((N.GT.NREALN).AND.(N.LE.N1000))) THEN WRITE (IUNIT8,125) N STOP ENDIF IF (N.GT.NREALN) N=N-N1000+NREALN NODEF(J,I)=N 250 CONTINUE DO 260 L=1,3 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-N3 SIDE;'/ + ' A - PREFIX INDICATES A DIP TOWARD', + ' THE N6-N5-N4 SIDE.)') STOP ENDIF IF (DIPS(L).LT.0.) DIPS(L)=180.+DIPS(L) FDIP(L,I)=DIPS(L)*0.017453293 260 CONTINUE IF ((ABS(AZ1).GT.361.).OR.(ABS(AZ3).GT.361.)) THEN WRITE (IUNIT8,272) AZ1,AZ3 272 FORMAT (' ILLEGAL ARGUMENT OF ',F10.4,' OR ',F10.4, + '; SHOULD BE IN RANGE -360. TO +360. DEGREES.') STOP ENDIF FAZ(1,I)=AZ1*0.017453293 FAZ(2,I)=AZ3*0.017453293 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.') 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 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 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 USE "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 BLANK COMMON FROM THE MAIN PROGRAM: CCC COMMON LDA,MD CCC CCC INDEXK = (JCOLUM-1)*LDA + MD + IROW - JCOLUM 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 PHI COMMON /PHITAB/ PHI DIMENSION PHI(6,7) DIMENSION FATNOD(MXNODE),FATIP(7,MXEL),NODES(6,MXEL) C DO 100 M=1,7 DO 90 I=1,NUMEL FATIP(M,I)=PHI(1,M)*FATNOD(NODES(1,I))+ + PHI(2,M)*FATNOD(NODES(2,I))+ + PHI(3,M)*FATNOD(NODES(3,I))+ + PHI(4,M)*FATNOD(NODES(4,I))+ + PHI(5,M)*FATNOD(NODES(5,I))+ + PHI(6,M)*FATNOD(NODES(6,I)) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE KSIZE (INPUT,BRIEF,IUNITT,MXEL,MXFEL,MXNODE, + MXWORK,NFL,NODEF,NODES,NREALN,NUMEL, + OUTPUT,LDA,MD,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 COMPARED TO PARAMETER "MAXSIZ" OF THE C MAIN PROGRAM. C CHARACTER*1 BLANK,STAR,ASC1,ASC2,ASCR LOGICAL BRIEF,WORST1,WORST2,WORSTR DIMENSION JCOL1(MXNODE),JCOL2(MXNODE), + NODEF(6,MXFEL),NODES(6,MXEL) DATA BLANK/' '/, STAR/'*'/ C C INITIALIZE BANDWIDTH TO 1 NODE: DO 10 I=1,NREALN JCOL1(I)=I JCOL2(I)=I 10 CONTINUE C BAND WIDENING BY TRIANGULAR CONTINUUM ELEMENTS: DO 50 I=1,NUMEL DO 40 J=1,6 NR=NODES(J,I) IF (NR.LE.NREALN) THEN DO 30 K=1,6 NC=NODES(K,I) IF (NC.LE.NREALN) THEN JCOL1(NR)=MIN(JCOL1(NR),NC) JCOL2(NR)=MAX(JCOL2(NR),NC) ENDIF 30 CONTINUE ENDIF 40 CONTINUE 50 CONTINUE C BAND WIDENING BY LINEAR FAULT ELEMENTS: DO 80 I=1,NFL DO 70 J=1,6 NR=NODEF(J,I) IF (NR.LE.NREALN) THEN DO 60 K=1,6 NC=NODEF(K,I) IF (NC.LE.NREALN) THEN JCOL1(NR)=MIN(JCOL1(NR),NC) JCOL2(NR)=MAX(JCOL2(NR),NC) ENDIF 60 CONTINUE ENDIF 70 CONTINUE 80 CONTINUE C NLB=0 NUB=0 DO 190 I=1,NREALN 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,NREALN 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*NREALN 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 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, AND THE LOWER', + ' BANDWIDTH IS ',I6,' AND THE UPPER BANDWIDTH IS ',I6) C C ADJUST FOR INEFFICIENCIES OF ACTUAL LINEAR-SYSTEM SOLVER USED: C SUBPROGRAMS DGBF DGBS OF IBM'S ESSL SOFTWARE. C MD=NLB+NUB+1 LDA=2*NLB+NUB+16 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.') IF(NKSIZE.GT.MXWORK) THEN WRITE (IUNITT,330) NKSIZE 330 FORMAT(/ /' INCREASE PARAMETER MAXSIZ IN THE MAIN PROGRAM', + ' TO AT LEAST ',I10) STOP ENDIF RETURN END C C C SUBROUTINE LIMITS (INPUT,AREA,DETJ,IUNITT,MXEL, + NUMEL,OKDELV,REFSTR,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) C C COMPUTE AREA, MEAN THICKNESS, AND OTHER DIMENSIONAL PARAMETERS C OF THE CRUST, THEN DETERMINE VALUES OF STIFFNESS LIMITS NEEDED C TO KEEP VELOCITY ERR0RS DOWN TO ORDER "OKDELV" AT SHEAR STRESS C LEVEL "REFSTR". C DOUBLE PRECISION WEIGHT COMMON /WGTVEC/ WEIGHT DIMENSION WEIGHT(7) DIMENSION AREA(MXEL),DETJ(7,MXEL),ZMOHO(7,MXEL) C C DATA ITEM "NFAULT" GIVES THE TYPICAL NUMBER OF FAULTS WHICH ARE C CROSSED BY ANY STRAIGHT LINE RUNNING ACROSS THE MODEL. IT DOES C NOT NEED TO BE ACCURATE! DATA NFAULT /5/ 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) 10 CONTINUE 20 CONTINUE THICK=TOTALV/TOTALA SIDE=SQRT(TOTALA) CONSTR=NFAULT*REFSTR*THICK/OKDELV ETAMAX=0.5*REFSTR*THICK/(SIDE*OKDELV) FMUMAX=NFAULT*REFSTR/OKDELV VISMAX=REFSTR*SIDE/OKDELV 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 CRUST = ',E10.3,' LENGTH**3'/ + ' TYPICAL THICKNESS = ',E10.3,' LENGTH'/ + ' TYPICAL WIDTH = ',E10.3,' LENGTH'/ + ' CONSTR (CONSTRAINT WEIGHT) = ',E10.3,' FORCE-SEC/LENGTH**2'/ + ' ETAMAX (MAX. BASAL COUPLING) = ',E10.3,' FORCE-SEC/LENGTH**3'/ + ' FMUMAX (MAX. FAULT STIFFNESS) = ',E10.3,' FORCE-SEC/LENGTH**3'/ + ' VISMAX (MAX. BLOCK VISCOSITY) = ',E10.3,' FORCE-SEC/LENGTH**2') RETURN END C C C SUBROUTINE LOOKUP (INPUT,DETJ,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 A RETURNED VALUE OF ATSEA INDICATES THAT POINT FELL OFF EDGE C OF THE GRID. C PARAMETER (NTOTRY=50) LOGICAL ATSEA,ISTRAP,TRUBBL REAL M11,M12,M13,M21,M22,M23 DIMENSION DETJ(7,MXEL), + NODEF(6,MXFEL),NODES(6,MXEL), + XNODE(MXNODE),YNODE(MXNODE) DIMENSION IEHIST(NTOTRY),SHIST(3,NTOTRY) C C STATEMENT FUNCTION: C PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) C C NTRIED=0 C C LOOP AS MANY TIMES AS NEEDED: C 100 NTRIED=NTRIED+1 IEHIST(NTRIED)=IE TRUBBL=(NTRIED.GE.NTOTRY).OR. + ((NTRIED.GE.(NTOTRY-10)).AND.(IEHIST(NTRIED).EQ. + IEHIST(MAX(NTRIED-2,1)))) IF (TRUBBL) THEN ATSEA=.TRUE. RETURN ENDIF I1=NODES(1,IE) I2=NODES(2,IE) I3=NODES(3,IE) I4=NODES(4,IE) I5=NODES(5,IE) I6=NODES(6,IE) X1=XNODE(I1) X2=XNODE(I2) X3=XNODE(I3) Y1=YNODE(I1) Y2=YNODE(I2) Y3=YNODE(I3) ISTRAP=(DETJ(1,IE).LE.0.2).OR. + (DETJ(2,IE).LE.0.2).OR. + (DETJ(3,IE).LE.0.2).OR. + (DETJ(4,IE).LE.0.2).OR. + (DETJ(5,IE).LE.0.2).OR. + (DETJ(6,IE).LE.0.2).OR. + (DETJ(7,IE).LE.0.2) IF (ISTRAP) THEN X4=0.5*(X1+X2) X5=0.5*(X2+X3) X6=0.5*(X3+X1) Y4=0.5*(Y1+Y2) Y5=0.5*(Y2+Y3) Y6=0.5*(Y3+Y1) ELSE X4=XNODE(I4) X5=XNODE(I5) X6=XNODE(I6) Y4=YNODE(I4) Y5=YNODE(I5) Y6=YNODE(I6) ENDIF 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,X4,X5,X6) YT=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) C C COEF:=MAT((DXDS1,DXDS2,DXDS3), C (DYDS1,DYDS2,DYDS3),(1,1,1)); C COEF11=4.*S2*X4+4.*S1*X1+4.*X6*S3-X1 COEF12=4.*S2*X2+4.*S1*X4+4.*X5*S3-X2 COEF13=4.*S2*X5+4.*S1*X6+4.*X3*S3-X3 COEF21=4.*S2*Y4+4.*S1*Y1+4.*Y6*S3-Y1 COEF22=4.*S2*Y2+4.*S1*Y4+4.*Y5*S3-Y2 COEF23=4.*S2*Y5+4.*S1*Y6+4.*Y3*S3-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. 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,6), + (XNODE(NODES(J,IEHIST(NTRIED-1))),J=1,6), + (YNODE(NODES(J,IEHIST(NTRIED-1))),J=1,6) WRITE(IUNITT,204) IEHIST(NTRIED), + (NODES(J,IEHIST(NTRIED)),J=1,6), + (XNODE(NODES(J,IEHIST(NTRIED))),J=1,6), + (YNODE(NODES(J,IEHIST(NTRIED))),J=1,6) 204 FORMAT(' ELEMENT',I3,' NODES:',I3,5I10/ + 9X,'X:',1P,6E10.2/9X,'Y:',6E10.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 MANTLE (INPUT,IFLOW,VCX,VCY,X,Y, + OUTPUT,RESIST,VMX,VMY) C C COMPUTES HORIZONTAL COMPONENTS OF FLOW AT TOP OF MANTLE. C UPDATED 3/13/84 TO CHOICE OF NO DRAG (IFLOW=0) OR BIRD AND C ROSENSTOCK (1984) BOUNDARY (IFLOW=1), WITH NORTH AMERICA ENDING C AT THE CIMA RIFT, AND NO DRAG APPLIED TO SUBPLATES (E.G. SIERRA). C C**************************************************************** C CAVEAT HACKER !!! C UNLIKE OTHER SUBPROGRAMS IN THIS PACKAGE, "MANTLE" IS VERY C SPECIFIC TO A PARTICULAR PROBLEM: C -IT ONLY DESCRIBES THE PACIFIC/NORTH AMERICAN BOUNDARY IN THE C REGION OF CALIFORNIA. C -IT ASSUMES A PARTICULAR ORIGIN AND ORIENTATION OF THE X-AXIS. C (ORIGIN AT 34.371 N, 122.650 W, WITH +X POINTING S41.5E) C -IT ASSUMES A PARTICULAR MAP PROJECTION OF CALIFORNIA. C (LAMBERT CONFORMAL CONIC, 33/45 DEGREES; LIKE 1:750,000 C GEOLOGIC MAP OF CALIFORNIA) C -IT ASSUMES THAT INPUT COORDINATES ARE IN METERS. C -IT IS BASED ON A PARTICULAR PLATE MODEL (ROTATION POLE): C THAT OF DEMETS ET. AL. (1990): NUVEL-1. C C YOU WILL PROBABLY NEED TO REPLACE THE CODE GIVEN HERE WITH C NEW CODE OF YOUR OWN !!! C**************************************************************** C LOGICAL NOAM,PACIF,RESIST,SIERRA DATA VXC/-1.57707E-9/, VXX/ 0.0 /, VXY/3.5455E-16/, + VYC/+0.14242E-9/, VYX/-3.5455E-16/, VYY/ 0.0 / C IF (IFLOW.EQ.0) THEN C NO-DRAG OPTION: RESIST=.FALSE. VMX=VCX VMY=VCY ELSE IF (IFLOW.EQ.1) THEN C BIRD AND ROSENSTOCK (1984) OPTION: C V NORTHERN AND CENTRAL CALIFORNIA TRANSFORM SEGMENT YBOUND =175.5E3-0.036* X C V TRANPRESSIVE BOUNDARY BENEATH TRANSVERSE RANGES IF (X.GE.326.6E3) YBOUND=163.0E3+2.028*(X-326.6E3) C V SEGMENT APPROXIMATELY PARALLEL TO LITTLE SAN BERNARDINO C V MOUNTAINS FRONT IF (X.GE.420.8E3) YBOUND=355.4E3-0.029*(X-420.8E3) C V OBLIQUE SPREADING SEGMENT, NODES 44-39 IF (X.GE.597.0E3) YBOUND=349.5E3-0.675*(X-597.0E3) C V CRYPTIC PLATE BOUNDARY SEGMENT, NODES 39-9 IF (X.GE.649.5E3) YBOUND=312.7E3+0.032*(X-649.5E3) PACIF=Y.LE.YBOUND NOAM=(.NOT.PACIF).AND.(X.GE.(448.7E3-Y*0.0787)) SIERRA=(.NOT.PACIF).AND.(.NOT.NOAM) IF (NOAM) THEN RESIST=.TRUE. VMX=0. VMY=0. ELSE IF (PACIF) THEN RESIST=.TRUE. VMX=VXC+VXX*X+VXY*Y VMY=VYC+VYX*X+VYY*Y ELSE IF (SIERRA) THEN RESIST=.FALSE. VMX=VCX VMY=VCY ENDIF ENDIF RETURN END C C C SUBROUTINE MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DQDTDA, + ECREEP,FDIP,FFRIC,FMUMAX,FTAN,GMEAN, + MXFEL,MXNODE,NFL,NODEF, + OFFMAX,OFFSET, + ONEKM,RADIO,RHOH2O, + RHOBAR,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 FAULT 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 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 BYERLY'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 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=20) 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 ERR0R WHICH CAN PUT A FLOOR ON CONVERGENCE. C C NOTE: IN VS-FORTRAN, FOLLOWING TYPE COULD BE LOGICAL*1: LOGICAL FSLIPS C LOGICAL LOCKED,PURESS,SLOPED DOUBLE PRECISION V DOUBLE PRECISION FPHI COMMON /FPHIS/ FPHI REAL NORMAL DIMENSION FPHI(6,7) DIMENSION DQDTDA(MXNODE), + FC(2,2,7,MXFEL),FDIP(3,MXFEL), + FIMUDZ(7,MXFEL),FPEAKS(MXFEL),FSLIPS(MXFEL), + FTAN(7,MXFEL),FTSTAR(2,7,MXFEL),NODEF(6,MXFEL), + OFFSET(MXFEL),V(2,MXNODE),ZMNODE(MXNODE),ZTRANF(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 BEING USED. DATA TINY /1.E-36/ DATA HUGE /1.E+36/ 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) N5=NODEF(5,I) N6=NODEF(6,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).AND. + (ABS(FDIP(3,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 NODES N2 AND N5 (IN SPITE OF CONSTRAINT EQUATION): IF (PURESS) THEN ANGLE=FTAN(4,I) UNITBX=SIN(ANGLE) UNITBY= -COS(ANGLE) DELVX=V(1,N2)-V(1,N5) DELVY=V(2,N2)-V(2,N5) SPREAD=DELVX*UNITBX+DELVY*UNITBY DELTAU=CONSTR*SPREAD DPMAX= -2.*DELTAU/ZTRANF(I) DDPNDZ=DPMAX/ZTRANF(I) 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.5*(DQDTDA(N2)+DQDTDA(N5)) TTRANS=TSURF+ZTRANF(I)*Q/CONDUC- + ZTRANF(I)**2*RADIO/(2.*CONDUC) TMEAN=(TSURF+TTRANS)/2. RHO=RHOBAR*(1.-ALPHAT*TMEAN) DLEPDZ=GMEAN*(RHO-RHOH2O*BIOT) THRUST=DLEPDZ*CGAMMA NORMAL=DLEPDZ/CGAMMA DDPNDZ=MAX(DDPNDZ,NORMAL-DLEPDZ) DDPNDZ=MIN(DDPNDZ,THRUST-DLEPDZ) C ELSE C SITUATION TOO COMPLEX TO ANALYZE, SO JUST SET NORMAL C STRESS ON THE VERTICAL PART OF THIS FAULT ELEMENT C EQUAL TO VERTICAL STRESS: DDPNDZ=0. ENDIF C DO 90 M=1,7 C HEAT-FLOW: Q=DQDTDA(N1)*FPHI(1,M)+DQDTDA(N2)*FPHI(2,M)+ + DQDTDA(N3)*FPHI(3,M) C C CRUSTAL THICKNESS: THICK=ZMNODE(N1)*FPHI(1,M)+ZMNODE(N2)*FPHI(2,M)+ + ZMNODE(N3)*FPHI(3,M) C C MOHO TEMPERATURE: TMOHO=TSURF+THICK*Q/CONDUC-THICK**2*RADIO/(2.*CONDUC) C C MEAN TEMPERATURE: TMEAN=(TSURF+TMOHO)/2. C C MEAN DENSITY: RHO=RHOBAR*(1.-ALPHAT*TMEAN) C C DERIVITIVE OF LITHOSTATIC EFFECTIVE PRESSURE WITH DEPTH DLEPDZ=GMEAN*(RHO-RHOH2O*BIOT) C C ANGLE IS THE FAULT STRIKE, IN RADIANS CCLKWS FROM +X. ANGLE=FTAN(M,I) C C UNITA IS A UNIT VECTOR ALONG THE FAULT, FROM N1 TO N3. UNITAX=COS(ANGLE) UNITAY=SIN(ANGLE) C C UNITB IS A PERPENDICULAR UNIT VECTOR, POINTING OUT C TOWARD THE N6-N4 SIDE. UNITBX= -UNITAY UNITBY= +UNITAX C C RELATIVE VELOCITIES ARE FOR N1-3 SIDE RELATIVE TO C THE N6-4 SIDE: DELVX=V(1,N1)*FPHI(1,M)+V(1,N2)*FPHI(2,M)+ + V(1,N3)*FPHI(3,M)+V(1,N4)*FPHI(4,M)+ + V(1,N5)*FPHI(5,M)+V(1,N6)*FPHI(6,M) DELVY=V(2,N1)*FPHI(1,M)+V(2,N2)*FPHI(2,M)+ + V(2,N3)*FPHI(3,M)+V(2,N4)*FPHI(4,M)+ + V(2,N5)*FPHI(5,M)+V(2,N6)*FPHI(6,M) 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-3 SIDE): DIP=FDIP(1,I)*FPHI(1,M)+FDIP(2,I)*FPHI(2,M)+ + FDIP(3,I)*FPHI(3,M) SLOPED=ABS(DIP-1.570796).GT.WEDGE C IF (.NOT.SLOPED) THEN C CASE OF A NEAR-VERTICAL FAULT: DSFDZ=(DLEPDZ+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 C FAULT IS LOCKED. LOCKED=(FRIC*DEPDST).GE.1.00 IF (LOCKED) THEN DSFDZ=HUGE ELSE DSFDZ=FRIC*DLEPDZ/(1.00-FRIC*DEPDST) ENDIF C SLIP=SQRT(SINIST**2+VUPDIP**2) ENDIF SLIP=MAX(SLIP,TINY*50.*ONEKM) C C LOCATE PLASTIC/CREEP TRANSITION C BY ITERATED HALVING OF DOMAIN: C TOPZ=0. BASEZ=THICK DO 50 KITER=1,15 Z=0.5*(TOPZ+BASEZ) SHEARF=Z*DSFDZ SHEARP=MIN(SHEARF,DCREEP) T=TSURF+Q*Z/CONDUC-(RADIO/(2.*CONDUC))*Z**2 IF (Z.LE.17.*ONEKM) THEN T90PC=0.5*Z ELSE T90PC=25.*ONEKM-2.83*Z+ + 0.11111*ONEKM*(Z/ONEKM)**2 ENDIF C SEE TURCOTTE ET AL (1980) JGR, 85, B11, 6224-6230 STRAIN=SLIP/T90PC SHEARC=ACREEP*(STRAIN**ECREEP)* + EXP((BCREEP+CCREEP*Z)/T) IF (SHEARC.LT.SHEARP) THEN BASEZ=Z ELSE TOPZ=Z ENDIF 50 CONTINUE ZTRANS=0.5*(TOPZ+BASEZ) SHEARF=ZTRANS*DSFDZ C C PLASTIC PART OF VERTICAL INTEGRAL OF TRACTION: C IF (SHEARF.LT.DCREEP) THEN VITDZ=0.5*SHEARF*ZTRANS ELSE ZP=ZTRANS*DCREEP/SHEARF VITDZ=DCREEP*(ZTRANS-0.5*ZP) ENDIF C C ADD CREEP PART OF INTEGRAL, USING PARABOLIC RULE C DZ=(THICK-ZTRANS)/NSTEP OLDSC=SHEARC Z0=ZTRANS SUM=0. DO 80 J=1,NSTEP ZHALF=Z0+0.5*DZ ZFULL=Z0+DZ THALF=TSURF+Q*ZHALF/CONDUC- + (RADIO/(2.*CONDUC))*ZHALF**2 TFULL=TSURF+Q*ZFULL/CONDUC- + (RADIO/(2.*CONDUC))*ZFULL**2 IF (ZHALF.LE.17.*ONEKM) THEN WHALF=0.5*ZHALF ELSE WHALF=25.*ONEKM-2.83*ZHALF+ + 0.11111*ONEKM*(ZHALF/ONEKM)**2 ENDIF IF (ZFULL.LE.17.*ONEKM) THEN WFULL=0.5*ZFULL ELSE WFULL=25.*ONEKM-2.83*ZFULL+ + 0.11111*ONEKM*(ZFULL/ONEKM)**2 ENDIF C SEE TURCOTTE ET AL (1980) JGR, 85, B11, 6224-6230 EHALF=SLIP/WHALF EFULL=SLIP/WFULL SCHALF=ACREEP*(EHALF**ECREEP)* + EXP((BCREEP+CCREEP*ZHALF)/THALF) SCFULL=ACREEP*(EFULL**ECREEP)* + EXP((BCREEP+CCREEP*ZFULL)/TFULL) SUM=SUM+DZ*(0.1666667*OLDSC+ + 0.6666667*SCHALF+ + 0.1666666*SCFULL) Z0=ZFULL OLDSC=SCFULL 80 CONTINUE VITDZ=VITDZ+SUM C VIMUDZ=VITDZ/SLIP C FIMUDZ(M,I)=MIN(VIMUDZ,FMUMAX*THICK) 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 NOT 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*THICK)) ZTRANF(I)=ZTRANS FPEAKS(I)=SHEARP 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 OPPOSITE 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 FAULT ELEMENT KFAULT!) THEN ITS NUMBER IS KELE; OTHERWISE, KELE = 0. C LOGICAL FOUNDE,FOUNDF DIMENSION NODEF(6,MXFEL),NODES(6,MXEL) C C THREE NODE NUMBERS ALONG THE SIDE OF INTEREST, COUNTERCLOCKWISE: N1=NODES(MOD(J, 3)+1,I) N2=NODES(MOD(J, 3)+4,I) N3=NODES(MOD(J+1,3)+1,I) C CHECK FOR ADJACENT FAULT ELEMENT FIRST: FOUNDF=.FALSE. DO 10 K=1,NFL M1=NODEF(1,K) M2=NODEF(2,K) M3=NODEF(3,K) M4=NODEF(4,K) M5=NODEF(5,K) M6=NODEF(6,K) IF (((M1.EQ.N3).AND.(M2.EQ.N2).AND.(M3.EQ.N1)).OR. + ((M4.EQ.N3).AND.(M5.EQ.N2).AND.(M6.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 3 NODE NUMBERS THAT WE SEARCH FOR: IF (FOUNDF) THEN IF (M2.EQ.N2) THEN N1=M4 N2=M5 N3=M6 ELSE N1=M1 N2=M2 N3=M3 ENDIF ENDIF C SEARCH FOR ADJACENT TRIANGULAR CONTINUUM ELEMENT: FOUNDE=.FALSE. DO 20 K=1,NUMEL IF (K.NE.I) THEN DO 15 L=1,3 M1=NODES(MOD(L, 3)+1,K) M2=NODES(MOD(L, 3)+4,K) M3=NODES(MOD(L+1,3)+1,K) IF ((M3.EQ.N1).AND.(M2.EQ.N2).AND.(M1.EQ.N3)) THEN FOUNDE=.TRUE. KELE=K GO TO 21 ENDIF 15 CONTINUE ENDIF 20 CONTINUE 21 IF (.NOT.FOUNDE) KELE=0 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 (INITAL 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,BIOT,CCREEP, + ECREEP,ERATE,FRIC,GMEAN,GEOTH, + NODES,NUMEL,RHOH2O,RHOBAR, + TEMLIM,ZMOHO, + OUTPUT,GLUE) C C CALCULATES "GLUE" (SHEAR STRESS REQUIRED TO CREATE UNIT RELATIVE C HORIZONTAL VELOCITY ACROSS A LAYER) C C PARAMETER "NINT" SETS NUMBER OF STEPS IN VERTICAL INTEGRALS: PARAMETER (NINT=100) C DIMENSION ERATE(3,7,NUMEL), + GEOTH(4,7,NUMEL), + GLUE(7,NUMEL), + NODES(6,NUMEL), + ZMOHO(7,NUMEL) C C C INITIALIZE SUMS TO ZERO C (NOTE THAT THESE SUMS DO NOT YET HAVE THE MEANING DESCRIBED ABOVE, C AND THE ARRAYS ARE ONLY BEING USED FOR WORKING STORAGE. C UNTIL THE FINAL LOOP, GLUE WILL HOLD THE VELOCITY AND FLUX WILL C HOLD THE FLUX AT/ABOVE THE CURRENT DEPTH.) C STFRIC=SIN(ATAN(FRIC)) DPEDZ=GMEAN*(RHOBAR-RHOH2O*BIOT) C DO 7 M=1,7 DO 6 I=1,NUMEL GLUE(M,I)=0. 6 CONTINUE 7 CONTINUE C C BEGIN CRITICAL TRIPLY-NESTED LOOP C DO 100 M=1,7 DO 60 J=1,NINT DO 50 I=1,NUMEL C C INTEGRATION OF "GLUE" (VELOCITY) IS PERFORMED BY MIDPOINT RULE, C SO ALL QUANTITIES ARE EVALUATED AT MIDDLE OF DEPTH STEP: C Z=(J-0.5)*ZMOHO(M,I)/NINT T=GEOTH(1,M,I) + +GEOTH(2,M,I)*Z + +GEOTH(3,M,I)*Z*Z + +GEOTH(4,M,I)*Z*Z*Z TH=MAX(T,200.) TL=MIN(TH,TEMLIM) ECINI= -1.0/ECREEP AILOG=LOG(ACREEP)*ECINI BI=(BCREEP+CCREEP*Z)*ECINI ARG=MAX(AILOG+BI/TL,-89.9) GLUE(M,I)=GLUE(M,I)+EXP(ARG) 50 CONTINUE 60 CONTINUE C C MULTIPLY SUMS BY COMMON FACTORS AND TRANSFORM DIMENSIONS C DO 90 I=1,NUMEL GLUE(M,I)=(GLUE(M,I)*ZMOHO(M,I)/NINT)**(-ECREEP) 90 CONTINUE 100 CONTINUE 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,K,MXDOF,MXWORK,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),K(MXWORK) DIMENSION TEXT(NCOL) COMMON LDA,MD C C STATEMENT FUNCTION REPLACING INTEGER FUNCTION SUBPROGRAM "INDEXK": INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + MD + IROW - JCOLUM 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 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,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DETJ, + DQDTDA,DXS,DYS,ECREEP,ELAPSE,ETAMAX, + EVERYP,FBASE,FDIP, + FFRIC,FLEN,FMUMAX,FTAN,GEOTH,GLUE, + GMEAN,ICOND,IFLOW,IUNITS,IUNITT, + MAXITR,MXBN,MXDOF,MXEL,MXFEL, + MXNODE,MXWORK,NCOND,NDOF,NFL,NLB,NODCON, + NODEF,NODES,NREALN,NUB,NUMEL,NUMNOD, + OFFMAX,OFFSET, + OKTOQT,ONEKM,PULLED,RADIO,RHOBAR,RHOH2O, + TEMLIM,TITLE1,TITLE2,TITLE3, + TSURF,VBCAZ,VBCMAG,VISMAX,VM,WEDGE, + XNODE,YNODE,ZMNODE,ZMOHO,LASTPM, + MODIFY,V, + OUTPUT,ERATE,FIMUDZ,FPEAKS,FSLIPS, + SIGHB,TAUMAT,ZTRANC,ZTRANF, + WORK,ALPHA,DVB,F,FC,FTSTAR,IPVT,K, + OUTVEC,OVB,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 F,FBASE,K,V,VM CHARACTER*80 TITLE1,TITLE2,TITLE3 C C NOTE: IN VS-FORTRAN, FOLLOWING TYPE COULD BE LOGICAL*1: LOGICAL FSLIPS,PULLED C LOGICAL EVERYP DIMENSION ALPHA(3,3,7,MXEL),AREA(MXEL), + DETJ(7,MXEL),DQDTDA(MXNODE),DXS(6,7,MXEL), + DVB(7,MXEL),DYS(6,7,MXEL),ERATE(3,7,MXEL), + F(MXDOF),FBASE(MXDOF),FC(2,2,7,MXFEL), + FDIP(3,MXFEL),FIMUDZ(7,MXFEL), + FLEN(MXFEL),FPEAKS(MXFEL),FSLIPS(MXFEL), + FTAN(7,MXFEL),FTSTAR(2,7,MXFEL), + GEOTH(4,7,MXEL),GLUE(7,MXEL), + ICOND(MXBN),IPVT(MXDOF),K(MXWORK),NODCON(MXBN), + NODEF(6,MXFEL),NODES(6,MXEL),OFFSET(MXFEL), + OUTVEC(2,7,MXEL),OVB(2,7,MXEL),PULLED(7,MXEL), + SIGHB(2,7,MXEL),TAUMAT(3,7,MXEL), + TOFSET(3,7,MXEL),VBCAZ(MXBN), + VBCMAG(MXBN),V(2,MXNODE),VM(2,MXNODE),XNODE(MXNODE), + YNODE(MXNODE),ZMNODE(MXNODE),ZMOHO(7,MXEL), + ZTRANC(7,MXEL),ZTRANF(MXFEL) C IF (LASTPM.NE.999) THEN WRITE(IUNITT,1) 1 FORMAT(' WRONG NUMBER OF ARGUMENTS IN CALL TO PURE!') 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,MXEL,MXNODE,NODES,NUMEL,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 CALL VISCOS (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,DCREEP,ECREEP, + ERATE,CFRIC,GMEAN,GEOTH, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,VISMAX,ZMOHO, + OUTPUT,ALPHA,SCOREC,SCORED,TOFSET,ZTRANC) 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(I)=ZMNODE(NODEF(2,I))/2. 30 CONTINUE CALL MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DQDTDA, + ECREEP,FDIP,FFRIC,FMUMAX,FTAN,GMEAN,MXFEL, + MXNODE,NFL,NODEF, + OFFMAX,OFFSET, + ONEKM,RADIO,RHOH2O, + RHOBAR,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) C C CALL VBCS EARLY (BEFORE BUILDF) IN ORDER TO LOAD VELOCITY C BOUNDARY CONDITIONS OF FAKE NODES INTO V VECTOR, SO BUILDF C CAN REFERENCE THEM, FOR GREATER EFFICIENCY. C (THE COST IS THAT WE HAVE TO DO SOME WASTED OPERATIONS ON K C IN THIS CALL, BUT THAT INEFFICIENCY ONLY OCCURS ONCE.) C IF (NUMNOD.GT.NREALN) THEN CALL VBCS (INPUT,ICOND,MXBN,MXDOF,MXNODE,MXWORK, + NCOND,NDOF,NLB,NODCON,NREALN,NUB, + VBCAZ,VBCMAG, + MODIFY,K,V,F) ENDIF C C MAJOR ITERATION LOOP OF THE ENTIRE PROGRAM !!!!! C WRITE (IUNITT,50) 50 FORMAT (/ /' ITERATION HISTORY:'/ / +' RELATIVE'/ +' MAXIMUM MEAN'/ +' RELATIVE VERTICALLY VERTICALLY'/ +' MAXIMUM MEAN INTEGRATED INTEGRATED'/ +' ITERATION VELOCITY VELOCITY STRESS STRESS'/ +' NUMBER CHANGE CHANGE ERR0R ERR0R'/) C DO 1000 ITER=1,MAXITR IF (IFLOW.GT.0) THEN CALL THONC (INPUT,ECREEP,ETAMAX,GLUE, + MXEL,MXNODE,NODES,NUMEL,NUMNOD, + PULLED,V,VM,ZMOHO, + OUTPUT,DVB,OVB,SIGHB, + WORK,OUTVEC) ELSE IF (ITER.EQ.1) THEN DO 100 M=1,7 DO 90 I=1,NUMEL SIGHB(1,M,I)=0. SIGHB(2,M,I)=0. 90 CONTINUE 100 CONTINUE ENDIF CALL VISCOS (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,DCREEP,ECREEP, + ERATE,CFRIC,GMEAN,GEOTH, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,VISMAX,ZMOHO, + OUTPUT,ALPHA,SCOREC,SCORED,TOFSET,ZTRANC) CALL MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DQDTDA, + ECREEP,FDIP,FFRIC,FMUMAX,FTAN,GMEAN,MXFEL, + MXNODE,NFL,NODEF, + OFFMAX,OFFSET, + ONEKM,RADIO,RHOH2O, + RHOBAR,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) IF (ITER.GT.1) THEN IPRINT=ITER-1 WRITE(IUNITT,102)IPRINT,SCOREA,SCOREB,SCOREC,SCORED 102 FORMAT(' ',I9,1X,2(1P,E13.4,0P,F12.6,1X)) ENDIF CALL FEM (INPUT,ALPHA,AREA,CONSTR,DETJ,DVB,DXS,DYS, + ETAMAX,EVERYP,FBASE,FC,FDIP, + FIMUDZ,FLEN,FTAN, + FTSTAR,ICOND,IFLOW,IUNITS,IUNITT, + MXBN,MXDOF,MXEL,MXFEL,MXNODE, + MXWORK,NCOND,NDOF,NFL,NLB,NODCON,NODEF, + NODES,NREALN,NUB,NUMEL,NUMNOD, + OVB,PULLED,SIGHB,TITLE1,TITLE2,TITLE3, + TOFSET,VBCAZ,VBCMAG,WEDGE,XNODE, + YNODE,999, + MODIFY,ERATE, + OUTPUT,SCOREA,SCOREB,TAUMAT,V, + WORK,F,IPVT,K) IF (SCOREB.LE.OKTOQT) THEN WRITE(IUNITT,109) ITER,SCOREA,SCOREB 109 FORMAT(' ',I9,1X,1P,E13.4,0P,F12.6,1X) WRITE (IUNITT,998) 998 FORMAT (' CONVERGED !!!!!!!!!!!!!!!!!!!!!!!!!', + '!!!!!!!!!!!!!!!!!!!!!!!!!!') RETURN ENDIF 1000 CONTINUE WRITE(IUNITT,109) MAXITR,SCOREA,SCOREB WRITE(IUNITT,1001) 1001 FORMAT(' ITERATION LIMIT REACHED BEFORE CONVERGENCE.') RETURN END C C C SUBROUTINE READBC (INPUT,BRIEF, + IUNIT7,IUNIT8,MXBN,MXNODE,NCOND, + NODCON,NREALN,NUMNOD,N1000, + XNODE,YNODE, + OUTPUT,ICOND,TITLE2,VBCAZ,VBCMAG) C C READ IN VELOCITY BOUNDARY CONDITIONS FROM UNIT IUNIT7, C WITH COMMENTS OUPUT TO DEVICE IUNIT8. C ONE OPTION IS TO HAVE THE VELOCITY BOUNDARY CONDITIONS SET BY C SUBPROGRAM "MANTLE". C CHARACTER*80 TITLE2 LOGICAL ALLOK,BRIEF,RESIST DIMENSION ICOND(MXBN),NODCON(MXBN), + VBCAZ(MXBN),VBCMAG(MXBN), + XNODE(MXNODE),YNODE(MXNODE) C IF (.NOT.BRIEF) WRITE (IUNIT8,10) IUNIT7 10 FORMAT(/ /' ATTEMPTING TO READ BOUNDARY CONDITIONS FROM UNIT', + I3) TITLE2=' '// + ' ' READ (IUNIT7,12) TITLE2 12 FORMAT (A80) IF (.NOT.BRIEF) WRITE (IUNIT8,15) TITLE2 15 FORMAT (/' TITLE FOR SET OF BOUNDARY CONDITIONS ='/' ',A80) IF (.NOT.BRIEF) WRITE (IUNIT8,20) NCOND 20 FORMAT(/' THERE ARE ',I6,' SIDE BOUNDARY NODES.'/ + ' NODES MUST BE LISTED IN THE SAME COUNTERCLOCKWISE ORDER'/ + ' AS IN THE LIST PRODUCED BY SUBPROGRAM SQUARE.'/ / + ' WHEN DESCRIBING THE KIND OF VELOCITY BOUNDARY CONDITION,'/ + ' THE CODE IS: 0 = NO VELOCITY CONSTRAINT.'/ + ' 1 = FIX VELOCITY IN SPECIFIED DIRECTION;'/ + ' PERPENDICULAR COMPONENT REMAINS FREE.'/ + ' 2 = FIX VELOCITY IN SPECIFIED DIRECTION;'/ + ' PERPENDICULAR COMPONENT SET TO ZERO.'/ + ' 3 = BOTH VELOCITY COMPONENTS FIXED AT'/ + ' MANTLE VELOCITY (FROM SUBPROGRAM).'/ / +' BC# NODE CODE VELOCITY DIRECTION (DEGREES COUNTERCLO', +'CKWISE FROM X-AXIS)') C (' ', I6, I6, I6, 1P,E12.3, 0P,F12.1) IF (NUMNOD.GT.NREALN) THEN NTOP=N1000+NUMNOD-NREALN ELSE NTOP=NUMNOD ENDIF ALLOK=.TRUE. NFIXED=0 DO 100 I=1,NCOND NODEXP=NODCON(I) IF (NODEXP.GT.NREALN) NODEXP=N1000+NODEXP-NREALN READ (IUNIT7,*) NUMBER,NODE,ICOND(I) IF (NUMBER.NE.I) THEN WRITE (IUNIT8,40) NUMBER, I 40 FORMAT (' ILLEGAL ORDERING OF BOUNDARY CONDITIONS:'/ + ' READ CONDITION #',I6,' WHEN EXPECTING #',I6,'.'/ + ' SUGGESTION: EDIT OUTPUT ABOVE TO MAKE B.C. FILE.') ALLOK=.FALSE. ENDIF IF ((NODE.LE.0).OR.(NODE.GT.NTOP)) THEN WRITE(IUNIT8,45) NODE 45 FORMAT(' ILLEGAL NODE NUMBER IN BOUNDARY', + ' CONDITIONS:',I6) ALLOK=.FALSE. ENDIF IF (NODE.NE.NODEXP) THEN WRITE(IUNIT8,47) NODE, NODEXP 47 FORMAT(/' BOUNDARY CONDITIONS INPUT IN WRONG ORDER;'/ + ' NODES SHOULD GO IN SEQUENCE AROUND BOUNDARY' + ,' FROM THE LOWEST-NUMBERED BOUNDARY NODE.'/ + ' (SEE LIST PREVIOUSLY WRITTEN BY SUBPROGRAM SQUARE' + ,')'/' ',I6,' WAS READ WHEN EXPECTING ',I6) ALLOK=.FALSE. ENDIF IF (NODE.GT.NREALN) THEN IF (.NOT.((ICOND(I).EQ.2).OR.(ICOND(I).EQ.3))) THEN WRITE(IUNIT8,50) NREALN,ICOND(I) 50 FORMAT(' FOR FAKE NODES, WITH # > ',I6,' THE ONLY' + ,' LEGAL CODES ARE 2 AND 3.'/' ',I6,' IS ILLEGAL.') ALLOK=.FALSE. ENDIF ENDIF IF (ICOND(I).EQ.0) THEN IF (.NOT.BRIEF) WRITE (IUNIT8,60)I,NODE,ICOND(I) 60 FORMAT(' ',3I6,' FREE',' FREE') ELSE IF (ICOND(I).EQ.1) THEN BACKSPACE IUNIT7 READ (IUNIT7,*) NUMBER,NODE,ICOND(I),VMAG,VAZ NFIXED=NFIXED+1 VBCMAG(I)=VMAG VBCAZ(I)=VAZ*0.017453293 IF(.NOT.BRIEF)WRITE (IUNIT8,61)I,NODE,ICOND(I),VMAG,VAZ 61 FORMAT(' ',3I6,1P,E12.3,0P,F12.1,' (PERPENDIC' + ,'ULAR COMPONENT FREE)') ELSE IF (ICOND(I).EQ.2) THEN BACKSPACE IUNIT7 READ (IUNIT7,*) NUMBER,NODE,ICOND(I),VMAG,VAZ NFIXED=NFIXED+2 VBCMAG(I)=VMAG VBCAZ(I)=VAZ*0.017453293 IF(.NOT.BRIEF)WRITE (IUNIT8,62)I,NODE,ICOND(I),VMAG,VAZ 62 FORMAT(' ',3I6,1P,E12.3,0P,F12.1,' (NO PERPEN' + ,'DICULAR COMPONENT)') ELSE IF (ICOND(I).EQ.3) THEN NFIXED=NFIXED+2 IF (NODE.LE.NREALN) THEN INNER=NODE ELSE INNER=NREALN+(NODE-N1000) ENDIF CALL MANTLE (INPUT,1,0.,0.,XNODE(INNER),YNODE(INNER), + OUTPUT,RESIST,VMX,VMY) VMAG=SQRT(VMX**2+VMY**2) VAZ=ATAN2F(VMY,VMX)*57.2957795 VBCMAG(I)=VMAG VBCAZ(I)=VAZ*0.017453293 IF (.NOT. BRIEF) THEN WRITE (IUNIT8,63) I,NODE,ICOND(I),VMAG,VAZ 63 FORMAT(' ',3I6,1P,E12.3,0P,F12.1,' (EQUALS MA' + ,'NTLE FLOW)') IF (.NOT. RESIST) WRITE (IUNIT8,64) 64 FORMAT (' CAUTION: UNDER CURRENT IFLOW OPTION,'/ + ' THERE IS NO STRONG MANTLE LITHOSPHERE UNDER', + ' THIS NODE;'/' VELOCITY WILL DEFAULT TO ZERO.') ENDIF ELSE WRITE(IUNIT8,95) ICOND(I) 95 FORMAT(' ILLEGAL TYPE OF BOUNDARY', + ' CONDITION:',I6) ALLOK=.FALSE. ENDIF 100 CONTINUE IF (NFIXED.LT.3) THEN ALLOK=.FALSE. WRITE (IUNIT8,110) NFIXED 110 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) STOP C IF (.NOT. BRIEF) WRITE (IUNIT8,999) 999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE READPM (INPUT,IUNIT7, IUNIT8, OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT , + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , + IFLOW , GMEAN , + MAXITR, OKDELV, OKTOQT, ONEKM, RADIO , + REFSTR, RHOAST, RHOBAR, RHOH2O, + TEMLIM, TITLE3, TSURF) C C READS STRATEGIC AND TACTICAL INPUT PARAMETERS FROM DEVICE IUNIT7, C AND ECHOES THEM ON DEVICE IUNIT8 WITH ANNOTATIONS. C CHARACTER*80 TITLE3 LOGICAL EVERYP C WRITE (IUNIT8,1) IUNIT7 1 FORMAT (/ /' ATTEMPTING TO READ PARAMETERS FROM UNIT',I3) TITLE3=' '// + ' ' READ (IUNIT7,2,IOSTAT=IOS) TITLE3 2 FORMAT (A80) WRITE (IUNIT8,3) TITLE3 3 FORMAT (/' TITLE OF PARAMETER SET ='/' ',A80) WRITE (IUNIT8,4) 4 FORMAT (/' **************************************************'/ + ' IT IS THE USERS RESPONSIBILITY TO INPUT ALL OF THE'/ + ' FOLLOWING NUMERICAL QUANTITIES IN CONSISTENT UNITS,'/ + ' SUCH AS SYSTEM-INTERNATIONAL (SI) OR CM-G-S (CGS).'/ + ' NOTE THAT TIME UNIT MUST BE THE SECOND (HARD-CODED).'/ + ' **************************************************'/ + /' ========== STRATEGIC PARAMETERS (DEFINE THE REAL', + '-EARTH PROBLEM) ======'/) READ (IUNIT7,*) FFRIC WRITE (IUNIT8,20) FFRIC 20 FORMAT (' ', F10.3,' COEFFICIENT OF FRICTION ON FAULTS') READ (IUNIT7,*) CFRIC WRITE (IUNIT8,30) CFRIC 30 FORMAT (' ', F10.3,' COEFFICIENT OF FRICTION WITHIN BLOCKS') READ (IUNIT7,*) BIOT BIOT = MAX(0.0,MIN(1.0,BIOT)) WRITE (IUNIT8,40) BIOT 40 FORMAT (' ',F10.4,' EFFECTIVE-PRESSURE (BIOT) COEFFICIENT,', + ' 0.0 TO 1.0') READ (IUNIT7,*) BYERLY BYERLY = MAX(0.0,MIN(0.99,BYERLY)) IF (OFFMAX.GT.0.) THEN WRITE (IUNIT8,41) BYERLY 41 FORMAT (' ',F10.4,' BYERLY COEFFICIENT (0. TO 0.99) ='/ + 11X,' FRACTIONAL FRICTION REDUCTION ON MASTER', + ' FAULT'/ + 11X,' (OTHER FAULTS HAVE LESS REDUCTION, IN', + ' PROPORTION TO'/ + 11X,' THEIR TOTAL PAST OFFSETS)') ELSE WRITE (IUNIT8,42) BYERLY 42 FORMAT (' ',F10.4,' BYERLY COEFFICIENT (NOT USED IN', + ' THIS RUN,'/ + 11X,' AS ALL OFFSETS ARE ZERO)') ENDIF READ (IUNIT7,*) ACREEP WRITE (IUNIT8,50) ACREEP 50 FORMAT (' ',1P, E10.2,' A FOR CREEP = PRE-EXPONENTIAL SHEAR', + ' STRESS CONSTANT FOR CREEP') READ (IUNIT7,*) BCREEP WRITE (IUNIT8,60) BCREEP 60 FORMAT (' ', F10.0,' B FOR CREEP =(ACTIVATION ENERGY)/R/N', + ' (IN K)') READ (IUNIT7,*) CCREEP WRITE (IUNIT8,70) CCREEP 70 FORMAT (' ',1P, E10.2,' C FOR CREEP = DERIVATIVE OF B WITH', + ' RESPECT TO DEPTH') READ (IUNIT7,*) DCREEP WRITE (IUNIT8,80) DCREEP 80 FORMAT (' ',1P, E10.2,' D FOR CREEP = MAXIMUM SHEAR STRESS', + ' UNDER ANY CONDITIONS') READ (IUNIT7,*) ECREEP WRITE (IUNIT8,90) ECREEP 90 FORMAT (' ', F10.6,' E FOR CREEP = STRAIN-RATE EXPONENT FOR', + ' CREEP (1/N)') READ (IUNIT7,*) IFLOW WRITE (IUNIT8,100) 100 FORMAT(12X,'VELOCITY BOUNDARY CONDITION AT BASE OF CRUST IS:') IF (IFLOW.EQ.0) THEN WRITE (IUNIT8,101) IFLOW 101 FORMAT (' ',I10,' PARALLEL TO CRUST, CREATING NO', + ' DRAG ANYWHERE.') ELSE IF (IFLOW.EQ.1) THEN WRITE (IUNIT8,102) IFLOW 102 FORMAT (' ',I10,' PER BIRD AND ROSENSTOCK (1984),', + ' WITH RIFT BELOW CIMA'/11X, + ' AND NO DRAG APPLIED BENEATH SUBPLATES', + ' (SIERRA, MOJAVE, B/R)') ELSE WRITE (IUNIT8,103) IFLOW 103 FORMAT (11X, + ' NOT UNDERSTOOD. WHAT DOES IFLOW=',I6,' MEAN ?') STOP ENDIF READ (IUNIT7,*) RHOH2O WRITE (IUNIT8,110) RHOH2O 110 FORMAT (' ',1P,E10.3,' DENSITY OF GROUNDWATER, LAKES, & OCEANS') READ (IUNIT7,*) RHOBAR WRITE (IUNIT8,120) RHOBAR 120 FORMAT (' ',1P,E10.3,' MEAN DENSITY OF CRUST,', + ' CORRECTED TO 0 DEGREES KELVIN') READ (IUNIT7,*) RHOAST WRITE (IUNIT8,130) RHOAST 130 FORMAT (' ',1P,E10.3,' DENSITY OF ASTHENOSPHERE') READ (IUNIT7,*) GMEAN WRITE (IUNIT8,140) GMEAN 140 FORMAT (' ',1P,E10.3,' MEAN GRAVITATIONAL ACCELERATION', + ' (LENGTH/SEC**2)') READ (IUNIT7,*) ONEKM WRITE (IUNIT8,150) ONEKM 150 FORMAT (' ',1P,E10.3,' NUMBER OF LENGTH UNITS NEEDED TO', + ' MAKE 1 KILOMETER'/11X, + ' (E.G., 1000. IN SI, 1.E5 IN CGS)') READ (IUNIT7,*) ALPHAT WRITE (IUNIT8,160) ALPHAT 160 FORMAT (' ',1P,E10.2,' VOLUMETERIC THERMAL EXPANSION OF CRUST', + ' (1/VOL)*(D.VOL/D.T)') READ (IUNIT7,*) CONDUC WRITE (IUNIT8,170) CONDUC 170 FORMAT (' ',1P,E10.2,' THERMAL CONDUCTIVITY OF CRUST (ENERGY/', + 'LENGTH/SEC/DEG)') READ (IUNIT7,*) RADIO WRITE (IUNIT8,180) RADIO 180 FORMAT (' ',1P,E10.2,' RADIOACTIVE HEAT PRODUCTION OF CRUST', + ' (ENERGY/VOLUME/SEC)') READ (IUNIT7,*) TSURF WRITE (IUNIT8,185) TSURF 185 FORMAT (' ', F10.0,' SURFACE TEMPERATURE, ON', + ' ABSOLUTE SCALE') READ (IUNIT7,*) TEMLIM WRITE (IUNIT8,190) TEMLIM 190 FORMAT (' ', F10.0,' CONVECTING TEMPERATURE (TMAX), ON', + ' ABSOLUTE SCALE') WRITE (IUNIT8,199) 199 FORMAT (/' ========== TACTICAL PARAMETERS (HOW TO REACH ', + 'THE SOLUTION) =========='/) READ (IUNIT7,*) MAXITR WRITE (IUNIT8,200) MAXITR 200 FORMAT (' ',I10,' MAXIMUM ITERATIONS WITHIN VELOCITY SOLUTION') READ (IUNIT7,*) OKTOQT WRITE (IUNIT8,210) OKTOQT 210 FORMAT (' ',F10.6,' ACCEPTABLE FRACTIONAL CHANGE IN VELOCITY ', + '(STOPS ITERATION EARLY)') READ (IUNIT7,*) REFSTR WRITE (IUNIT8,220) REFSTR 220 FORMAT (' ',1P,E10.2,' EXPECTED MEAN VALUE OF SHEAR STRESS IN', + ' CRUST'/' ',10X, + ' (USED TO INITIALIZE AND SET STIFFNESS LIMITS)') READ (IUNIT7,*) OKDELV WRITE (IUNIT8,230) OKDELV 230 FORMAT (' ',1P,E10.2,' MAGNITUDE OF VELOCITY ERR0RS ALLOWED', + ' DUE TO FINITE STIFFNESS'/11X, + '(SUCH ERR0RS MAY APPEAR IN SUCH FORMS AS:'/11X, + ' 1. FICTICIOUS BASAL SLIP OF CRUST OVER MANTLE'/11X, + ' 2. ERRONEOUS CONVERGENCE/DIVERGENCE AT VERTICAL FAULTS'/ + 11X, + ' 3. VELOCITY EFFECT OF FICTICIOUS VISCOUS COMPLIANCES'/11X, + ' HOWEVER, VALUES WHICH ARE TOO SMALL WILL CAUSE ILL-CONDITIONED' + /11X, + ' LINEAR SYSTEMS AND STRESS ERR0RS, ', + 'AND MAY PREVENT CONVERGENCE!)') READ (IUNIT7,*) EVERYP WRITE (IUNIT8,240) EVERYP 240 FORMAT (' ',L10,' SHOULD NODAL VELOCITIES BE OUTPUT EVERY STE', + 'P? (FOR CONVERGENCE STUDIES)') WRITE (IUNIT8,999) 999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE RESULT (INPUT,ALPHAT,ELEV,ERATE,EVERYP, + FDIP,FIMUDZ, + FPEAKS,FSLIPS,FTAN,GEOTH,IUNITS,IUNITT, + MXEL,MXFEL,MXNODE,NFL, + NODEF,NODES,NREALN,NUMEL,NUMNOD,N1000, + RHOAST,RHOBAR,RHOH2O,SIGHB, + TAUMAT,TAUZZI,TITLE1,TITLE2,TITLE3, + V,WEDGE,ZMOHO,ZTRANC,ZTRANF) C C OUTPUT THE SOLUTION: C -NODE VELOCITIES ONLY TO UNIT "IUNITS", C -DESCRIPTIVE TABLES TO UNIT "IUNITT". C CHARACTER*80 TITLE1,TITLE2,TITLE3 LOGICAL EVERYP C C NOTE: IN VS-FORTRAN, FOLLOWING TYPE COULD BE LOGICAL*1: LOGICAL FSLIPS C DOUBLE PRECISION V DOUBLE PRECISION PHI,POINTS,WEIGHT COMMON /S1S2S3/ POINTS COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) DIMENSION ELEV(MXNODE), ERATE(3,7,MXEL), + FDIP(3,MXFEL), FIMUDZ(7,MXFEL),FPEAKS(MXFEL), + FSLIPS(MXFEL),FTAN(7,MXFEL),GEOTH(4,7,MXEL), + NODEF(6,MXFEL),NODES(6,MXEL), SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL),TAUZZI(7,MXEL),V(2,MXNODE), + ZMOHO(7,MXEL), + ZTRANC(7,MXEL),ZTRANF(MXFEL) 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 WRITE (IUNITT,30) 30 FORMAT(/ /' VELOCITIES OF THE NODES:'/ + ' ', + ' ARGUMENT'/ + ' ', + ' (DEGREES'/ + ' NODE X-COMPONENT Y-COMPONENT MAGNI', + 'TUDE FROM +X)'/) DO 100 I=1,NUMNOD IF (I.LE.NREALN) THEN IP=I ELSE IP=N1000+I-NREALN ENDIF VX=V(1,I) VY=V(2,I) AZIMUT=ATAN2F(VY,VX)*57.2957795 VMAG=SQRT(V(1,I)**2+V(2,I)**2) WRITE (IUNITT,40) IP,V(1,I),V(2,I),VMAG,AZIMUT 40 FORMAT(' ',I5,1P,2D20.12,E10.2,0P,F8.2) 100 CONTINUE C C TRIANGULAR CONTINUUM ELEMENT PROPERTIES AT THEIR CENTERS: C WRITE (IUNITT,110) 110 FORMAT (/ /' CONTINUUM ELEMENT PROPERTIES (AT CENTER POINTS):'/ + /' E1=MOST E2=MOST ISOSTATIC VERTIC', + 'AL VERTICAL VERTICAL DEPTH OF BASAL BASAL' + /' ELEMENT ARGUMENT COMPRESS. EXTENS. UPLIFT INTEGR', + 'AL INTEGRAL INTEGRAL SEISMIC SHEAR SHEAR' + /' NUMBER OF E1 RATE RATE RATE OF(SZ+', + 'P0) OF(S1+P0) OF(S2+P0) ZONE STRESS ARGUMENT'/) 120 FORMAT (' ',I7,F10.2,1P,8E10.2,0P,F10.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) ANGLE=ATAN2F(U1Y,U1X)*57.2957795 EZZ= -(EXX+EYY) TMID=GEOTH(1,M,I)+GEOTH(2,M,I)*ZMOHO(M,I)/2.+ + GEOTH(3,M,I)*(ZMOHO(M,I)/2.)**2 RHOC=RHOBAR*(1.-ALPHAT*TMID) HEIGHT=0. DO 150 N=1,6 HEIGHT=HEIGHT+ELEV(NODES(N,I))*PHI(N,M) 150 CONTINUE 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(M,I) SIGHX=SIGHB(1,M,I) SIGHY=SIGHB(2,M,I) STHETA=57.2958*ATAN2F(SIGHY,SIGHX) SHEAR=SQRT(SIGHX**2+SIGHY**2) WRITE (IUNITT,120) I,ANGLE,E1,E2,VZ, + TZZ,T1,T2,ZTRANS,SHEAR,STHETA 200 CONTINUE WRITE (IUNITT,210) 210 FORMAT ( + /' THE FIGURES ABOVE INCLUDE VERTICAL INTEGRALS OF', + ' NORMAL STRESSES THROUGH THE CRUSTAL LAYER. 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 (NFL.GT.0) WRITE (IUNITT,300) 300 FORMAT (/ / /' FAULT ELEMENT PROPERTIES (AT MID-POINTS):'/ + ' ', + ' ', + ' DOWN-DIP '/ + ' FAULT NODES#2,5 HORIZ. ARGUMENT', + ' PLUNGE TOTAL RIGHT PERPEN. RELATIVE', + ' INTEGRAL PEAK DEPTH OF IS THIS'/ + ' ELEMENT (N2 MOVES SLIP OF', + ' OF SLIP LATERAL SHORTNING VERTICAL', + ' OF SHEAR SHEAR SEISMIC FAULT'/ + ' NUMBER REL.TO N5) RATE SLIP', + ' SLIP RATE RATE RATE RATE', + ' TRACTION TRACTION ZONE ACTIVE?'/) 310 FORMAT (' ',I7,I5,',',I5,1P,E10.2,0P,2F10.2,1P,7E10.2,L5,I8) M=4 DO 400 I=1,NFL DIP=FDIP(2,I) JM=NODEF(2,I) JB=NODEF(5,I) DU=V(1,JM)-V(1,JB) DV=V(2,JM)-V(2,JB) IF (JM.GT.NREALN) JM=N1000+(JM-NREALN) IF (JB.GT.NREALN) JB=N1000+(JB-NREALN) AZIMHS=ATAN2F(DV,DU) HORS=SQRT(DU**2+DV**2) C C ANGLE IS THE FAULT STRIKE, IN RADIANS CCLKWS FROM +X. ANGLE=FTAN(M,I) UNITX=COS(ANGLE) UNITY=SIN(ANGLE) CROSSX= -UNITY CROSSY= +UNITX SINIST=DU*UNITX+DV*UNITY IF (ABS(FDIP(2,I)-1.570796).LT.WEDGE) THEN CLOSE=0. VUPDIP=0. ELSE CLOSE=DU*CROSSX+DV*CROSSY VUPDIP=CLOSE/COS(DIP) ENDIF RELV=VUPDIP*SIN(DIP) SNET=SQRT(HORS**2+VUPDIP**2) PLUNGE= -ASIN(RELV/SNET) RLT= -SINIST SHEAR=FIMUDZ(4,I)*SNET/SIN(DIP) AZIMHS=AZIMHS*57.2957795 PLUNGE=PLUNGE*57.2957795 WRITE (IUNITT,310) I,JM,JB,HORS,AZIMHS,PLUNGE,SNET, + RLT,CLOSE,RELV,SHEAR,FPEAKS(I),ZTRANF(I),FSLIPS(I),I 400 CONTINUE WRITE (IUNITT,401) 401 FORMAT(' -----------------------------------', + '-----------------------------------') RETURN END C C C SUBROUTINE ROTOR (INPUT,MXWORK,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,MD C C STATEMENT FUNCTION REPLACING INTEGER FUNCTION SUBPROGRAM "INDEXK": INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + MD + IROW - JCOLUM 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 SOLVER (INPUT,MXDOF,MXWORK,NDOF,NLB,NUB, + MODIFY,ABD,BX, + WORK,IPVT) C C SETS UP FOR CALL TO THE LIBRARY ROUTINE WHICH ACTUALLY C SOLVES THE LINEAR SYSTEM C C ]ABD] ]X] = ]BX] C C THE LEFT-HAND COEFFICIENT MATRIX ]ABD] IS DESTROYED. C THE ANSWER VECTOR ]X] IS WRITTEN OVER THE FORCING VECTOR ]BX]. C C CURRENT VERSION IS PER CONVENTIONS OF IBM'S ESSL LIBRARY, C DOUBLE PRECISION VERSION. C DOUBLE PRECISION ABD,BX DIMENSION ABD(MXWORK),BX(MXDOF),IPVT(MXDOF) 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,MD C N=NDOF ML=NLB MU=NUB C---------------------------------------- CALL DGBF(ABD,LDA,N,ML,MU,IPVT) CALL DGBS(ABD,LDA,N,ML,MU,IPVT,BX) C---------------------------------------- RETURN END C C C SUBROUTINE SQUARE (INPUT,BRIEF,FDIP,IUNIT8, + MXBN,MXEL,MXFEL,MXNODE, + MXSTAR,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,WEDGE, + MODIFY,FAZ,XNODE,YNODE, + OUTPUT,AREA,DETJ,DXS,DYS,EDGEFS,EDGETS, + FLEN,FTAN,NCOND,NODCON, + WORK,CHECKN,LIST,NODTYP) C C CHECK, CORRECT, AND COMPLETE THE GEOMETRY OF THE GRID C LOGICAL ALLOK,BRIEF,FOUND,MATCH,SWITCH,VERT1,VERT2,VERT3 C C NOTE: THE FOLLOWING TYPE COULD BE "LOGICAL*1" IN IBM VS-FORTRAN: LOGICAL CHECKN,EDGEFS,EDGETS C C NOTE: THE FOLLOWING COULD BE MADE "INTEGER*2" IN VS-FORTRAN: INTEGER NODTYP C CHARACTER*21 OBLIQU,TAG1,TAG2,TAG3,VERTIC DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS DIMENSION FPHI(6,7),FPOINT(7),FGAUSS(7) DIMENSION AREA(MXEL),CHECKN(MXNODE), + DETJ(7,MXEL),DXS(6,7,MXEL),DYS(6,7,MXEL), + EDGEFS(2,MXFEL),EDGETS(3,MXEL),FDIP(3,MXFEL), + FAZ(2,MXFEL),FLEN(MXFEL),FTAN(7,MXFEL), + LIST(MXSTAR),NODCON(MXBN), + NODEF(6,MXFEL),NODES(6,MXEL),NODTYP(MXNODE), + XNODE(MXNODE),YNODE(MXNODE) DATA OBLIQU /'(DIP SLIP IS ALLOWED)'/ DATA VERTIC /'(STRIKE-SLIP ONLY) '/ C C (1) CHECK THAT ALL REAL NODES ARE CONNECTED TO AT LEAST ONE C CONTINUUM (TRIANGULAR) ELEMENT; C DO 110 I=1,NREALN CHECKN(I)=.FALSE. 110 CONTINUE DO 130 I=1,NUMEL DO 120 J=1,6 CHECKN(NODES(J,I))=.TRUE. 120 CONTINUE 130 CONTINUE DO 132 I=1,NFL DO 131 J=1,6 CHECKN(NODEF(J,I))=.TRUE. 131 CONTINUE 132 CONTINUE ALLOK=.TRUE. DO 140 I=1,NREALN ALLOK=ALLOK.AND.CHECKN(I) 140 CONTINUE IF (.NOT.ALLOK) THEN WRITE(IUNIT8,150) 150 FORMAT(' BAD GRID TOPOLOGY: FOLLOWING REAL NODES DO NOT'/ 1 ' BELONG TO ANY CONTINUUM ELEMENT OR FAULT:') DO 160 I=1,NREALN IF (.NOT.CHECKN(I)) WRITE (IUNIT8,155) I 155 FORMAT (' ',43X,I6) 160 CONTINUE STOP ENDIF C C (2) CHECK THAT EVERY NODE IS EITHER A CORNER OR A MIDPOINT NODE, C BUT NOT BOTH. C DO 210 I=1,NUMNOD NODTYP(I)=0 210 CONTINUE NTOFIX=0 ALLOK=.TRUE. DO 250 I=1,NUMEL DO 240 J=1,6 IF (J.LE.3) THEN ITYPE=1 ELSE ITYPE=2 ENDIF N=NODES(J,I) IF (NODTYP(N).EQ.0) THEN NODTYP(N)=ITYPE IF (ITYPE.EQ.2) THEN IF ((XNODE(N).EQ.0.).AND.(YNODE(N).EQ.0.)) + NTOFIX=NTOFIX+1 ENDIF ELSE IF (NODTYP(N).NE.ITYPE) THEN ALLOK=.FALSE. WRITE (IUNIT8,220) N 220 FORMAT(' BAD GRID TOPOLOGY: NODE ',I6, + ' CANNOT BE AN ELEMENT CORNER AND AN', + ' ELEMENT SIDE-MIDPOINT AT THE SAME', + ' TIME.') ENDIF ENDIF 240 CONTINUE 250 CONTINUE DO 290 I=1,NFL DO 280 J=1,6 IF ((J.EQ.2).OR.(J.EQ.5)) THEN ITYPE=2 ELSE ITYPE=1 ENDIF N=NODEF(J,I) IF (NODTYP(N).EQ.0) THEN NODTYP(N)=ITYPE ELSE IF (NODTYP(N).NE.ITYPE) THEN ALLOK=.FALSE. WRITE (IUNIT8,220) N ENDIF ENDIF 280 CONTINUE 290 CONTINUE IF (.NOT.ALLOK) STOP C C (3) CHECK THAT EACH FAULT SIDE WITH REAL NODES ALONG IT SHARES C THOSE SAME 3 NODES WITH A TRIANGULAR CONTINUUM ELEMENT. C ALLOK=.TRUE. DO 390 I=1,NFL DO 380 J=2,5,3 N=NODEF(J,I) IF (N.LE.NREALN) THEN DO 320 K=1,NUMEL DO 310 L=4,6 IF (NODES(L,K).EQ.N) THEN LP=L-2 IF (LP.EQ.4) LP=1 LM=L-3 MATCH=((NODEF(J-1,I).EQ.NODES(LP,K)) + .OR.(NODEF(J-1,I).GT.NREALN)) + .AND.((NODEF(J+1,I).EQ.NODES(LM,K)) + .OR.(NODEF(J+1,I).GT.NREALN)) IF (.NOT.MATCH) THEN ALLOK=.FALSE. WRITE(IUNIT8,305) I,K 305 FORMAT(' BAD GRID TOPOLOGY:', + ' FAULT ',I6,' IS NOT PROPERL' + ,'Y CONNECTED TO ELEMENT ',I6) ELSE GO TO 380 ENDIF ENDIF 310 CONTINUE 320 CONTINUE ENDIF 380 CONTINUE 390 CONTINUE IF (.NOT.ALLOK) STOP C C (4) AVERAGE TOGETHER THE COORDINATES OF ALL NODES AT ONE "POINT" C DO 410 I=1,NUMNOD CHECKN(I)=.FALSE. 410 CONTINUE DO 490 I=1,NFL DO 480 J1=1,3,2 NJ1=NODEF(J1,I) IF (.NOT.CHECKN(NJ1)) THEN LIST(1)=NJ1 CHECKN(NJ1)=.TRUE. J2=7-J1 NJ2=NODEF(J2,I) LIST(2)=NJ2 CHECKN(NJ2)=.TRUE. NINSUM=2 DO 470 K=I,NFL DO 460 L1=1,3,2 NL1=NODEF(L1,K) IF (.NOT.CHECKN(NL1)) THEN MATCH=.FALSE. DO 420 M=1,NINSUM MATCH=MATCH.OR.(NL1.EQ.LIST(M)) 420 CONTINUE IF (MATCH) THEN NINSUM=NINSUM+1 IF (NINSUM.GT.MXSTAR) THEN WRITE(IUNIT8,421) 421 FORMAT(/' INCREASE VALUE' + ,' OF PARAMETER MAXATP.') STOP ENDIF LIST(NINSUM)=NL1 CHECKN(NL1)=.TRUE. ENDIF L2=7-L1 NL2=NODEF(L2,K) MATCH=.FALSE. DO 430 M=1,NINSUM MATCH=MATCH.OR.(NL2.EQ.LIST(M)) 430 CONTINUE IF (MATCH) THEN NINSUM=NINSUM+1 IF (NINSUM.GT.MXSTAR) THEN WRITE(IUNIT8,421) STOP ENDIF LIST(NINSUM)=NL2 CHECKN(NL2)=.TRUE. ENDIF ENDIF 460 CONTINUE 470 CONTINUE 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(IUNIT8,472) NINSUM, + (LIST(N),N=1,NINSUM) 472 FORMAT(/ + ' AVERAGING TOGETHER THE POSITIONS OF', + ' THESE ',I6,' NODES:',(/' ',12I6)) WRITE (IUNIT8,476) RMAX 476 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 (5) SURVEY STRIKE-SLIP (VERTICAL) FAULTS TO CHECK FOR CONFLICTS IN C ARGUMENT THAT WOULD LOCK THE FAULT. C C LOOP ON ALL FAULT ELEMENTS (I): DO 2000 I=1,NFL C LOOP ON 2 TERMINAL NODE PAIRS, 1-6, 4-3 (J = 1 OR 4): DO 1900 J=1,4,3 C DIP MUST BE WITHIN "WEDGE" OF VERTICAL FOR CONSTRAINT: NDIP=1+J/2 IF (ABS(FDIP(NDIP,I)-1.570796).LE.WEDGE) THEN NAZI=1+J/4 N1=J N6=7-J NODE1=NODEF(N1,I) NODE6=NODEF(N6,I) C NO CONSTRAINT APPLIED WHERE A FAULT ENDS: IF (NODE1.NE.NODE6) 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. + (NODE6.EQ.NODEF(6,L))).OR. + ((NODE1.EQ.NODEF(6,L)).AND. + (NODE6.EQ.NODEF(1,L)))) THEN FOUND=.TRUE. NUMBER=L NAZL=1 GO TO 1601 ENDIF ENDIF IF (ABS(FDIP(3,L)-1.5708).LE.WEDGE) THEN IF (((NODE1.EQ.NODEF(3,L)).AND. + (NODE6.EQ.NODEF(4,L))).OR. + ((NODE1.EQ.NODEF(4,L)).AND. + (NODE6.EQ.NODEF(3,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): AZI=MOD(FAZ(NAZI,I)+1.570796,3.14159265) + -1.570796 AZL=MOD(FAZ(NAZL,NUMBER)+1.570796,3.14159265) + -1.570796 AZIMUT=0.5*(AZI+AZL) FAZ(NAZI,I)=AZIMUT FAZ(NAZL,NUMBER)=AZIMUT IF (ABS(AZI-AZL).GT.0.02) THEN DAZI=AZI*57.2957795 DAZL=AZL*57.2957795 DAZ=AZIMUT*57.2957795 IF (NODE1.LE.NREALN) THEN NP1=NODE1 ELSE NP1=N1000+NODE1-NREALN ENDIF IF (NODE6.LE.NREALN) THEN NP6=NODE6 ELSE NP6=N1000+NODE6-NREALN ENDIF WRITE (IUNIT8,1610) I,NUMBER,NP1,NP6, + DAZI,DAZL,DAZ 1610 FORMAT(/' WARNING: STRIKE-SLIP FAULT ELEMENTS' + ,I7,' AND',I7/' SHARE NODES',I7,' AND', + I7/' BUT THEIR ARGUMENTS OF ',F6.1, + ' AND ',F6.1,' DEGREES DIFFER SUBSTAN', + 'TIALLY.'/' THE ARGUMENTS WILL BE AVERAGED,' + ,' AND A VALUE OF ',F6.1,' WILL BE USED.' + /' THIS IS NECESSARY TO PREVENT FAULT', + ' LOCKING;'/' IF YOU -WANT- THE FAULT LOCKED' + ,', THEN USE A SINGLE NODE AT THIS POINT.') ENDIF ENDIF C ^END BLOCK WHICH LOOKS FOR CONSTRAINTS ON REAL NODES 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 ^END LOOP ON FAULT ELEMENTS C C (6) COMPUTE COORDINATES OF MIDPOINT NODES THAT WERE NOT INPUT. C C FIRST, FAULTS: IF ((.NOT.BRIEF).AND.(NFL.GT.0)) WRITE (IUNIT8,540) 540 FORMAT(/ /' FOLLOWING FAULT MID-POINT POSITIONS WERE COMPUTED:'/ + /' FAULT NODE2 NODE5 X Y'/) DO 550 I=1,NFL I1=NODEF(1,I) I2=NODEF(2,I) I3=NODEF(3,I) I5=NODEF(5,I) DX= XNODE(I3)- XNODE(I1) DY= YNODE(I3)- YNODE(I1) AZ=ATAN2(DY,DX) PHI1=FAZ(1,I)-AZ PHI1=MOD(PHI1+1.570796,3.14159265)-1.570796 PHI2=AZ-FAZ(2,I) PHI2=MOD(PHI2+1.570796,3.14159265)-1.570796 IF ((ABS(PHI1).GT.0.001).OR.(ABS(PHI2).GT.0.001)) THEN T1=TAN(PHI1) T2=TAN(PHI2) IF (ABS(T2-T1).GE.ABS(T1+T2)) THEN FACTOR=0.99*ABS(T1+T2)/ABS(T2-T1) IF (ABS(T1).GT.ABS(T2)) THEN T2=T1+FACTOR*(T2-T1) ELSE T1=T2+FACTOR*(T1-T2) ENDIF ENDIF PARRAL=(T2-T1)/(4.*(T1+T2)) PERPEN= T1*T2 /(2.*(T1+T2)) XNODE(I2)=XNODE(I1)+DX/2.+PARRAL*DX-PERPEN*DY YNODE(I2)=YNODE(I1)+DY/2.+PERPEN*DX+PARRAL*DY ELSE XNODE(I2)=(XNODE(I1)+XNODE(I3))/2. YNODE(I2)=(YNODE(I1)+YNODE(I3))/2. ENDIF XNODE(I5)= XNODE(I2) YNODE(I5)= YNODE(I2) NTOFIX=NTOFIX-1 IF (.NOT.BRIEF) WRITE (IUNIT8,549) I,I2,I5,XNODE(I2), 1 YNODE(I2) 549 FORMAT(' ',I6,2I10,1P,2E12.4) 550 CONTINUE C C NEXT, OTHER ELEMENT SIDES, IF NEEDED: IF ((.NOT.BRIEF).AND.(NTOFIX.GT.0)) WRITE (IUNIT8,551) 551 FORMAT(/ /' FOLLOWING MID-POINTS OF CONTINUUM ELEMENT SIDES', + ' THAT WERE 0.0 IN THE' + / ' INPUT DATASET ARE NOW COMPUTED, AS FOLLOWS:' + / / ' ELEMENT NODE X Y'/) DO 590 I=1,NUMEL DO 580 J=4,6 N=NODES(J,I) IF ((XNODE(N).EQ.0.).AND.(YNODE(N).EQ.0.)) THEN JP=J-2 IF (J.EQ.6) JP=1 JM=J-3 XNODE(N)=0.5* + (XNODE(NODES(JP,I))+XNODE(NODES(JM,I))) YNODE(N)=0.5* + (YNODE(NODES(JP,I))+YNODE(NODES(JM,I))) IF (.NOT.BRIEF) + WRITE (IUNIT8,579) I,N,XNODE(N),YNODE(N) 579 FORMAT(' ',I6,I10,1P,2E12.4) ENDIF 580 CONTINUE 590 CONTINUE C C (7) COMPUTE AREAS OF ELEMENTS AND COMPUTE DERIVITIVES OF NODAL C FUNCTIONS AT INTEGRATION POINTS; C THEN CHECK FOR NEGATIVE AREAS C CALL AREAS (INPUT,NODES,NUMEL,NUMNOD,XNODE,YNODE, + OUTPUT,AREA) CALL DERIV (INPUT,AREA,NODES,NUMEL,NUMNOD,XNODE,YNODE, + OUTPUT,DETJ,DXS,DYS) ALLOK=.TRUE. DO 620 M=1,7 DO 610 I=1,NUMEL TEST=AREA(I)*DETJ(M,I) IF (TEST.LE.0.) THEN WRITE(IUNIT8,605) M,I 605 FORMAT(/' EXCESSIVELY DISTORTED ELEMENT LEADS TO ' + ,'NEGATIVE AREA AT POINT ',I1,' IN ELEMENT ', + I5) ALLOK=.FALSE. ENDIF 610 CONTINUE 620 CONTINUE IF (.NOT.ALLOK) STOP C C (8) COMPUTE LENGTHS OF FAULT ELEMENTS. C DO 750 I=1,NFL FLEN(I)=0. X1=XNODE(NODEF(1,I)) X2=XNODE(NODEF(2,I)) X3=XNODE(NODEF(3,I)) Y1=YNODE(NODEF(1,I)) Y2=YNODE(NODEF(2,I)) Y3=YNODE(NODEF(3,I)) OLDX=X1 OLDY=Y1 DO 740 J=1,20 S=J/20. F1=1.-3.*S+2.*S**2 F2=4.*S*(1.-S) F3= -S+2.*S**2 X=X1*F1+X2*F2+X3*F3 Y=Y1*F1+Y2*F2+Y3*F3 FLEN(I)=FLEN(I)+SQRT((X-OLDX)**2+(Y-OLDY)**2) OLDX=X OLDY=Y 740 CONTINUE 750 CONTINUE C C (9) MAKE A LIST OF NODES THAT ARE ON THE BOUNDARY AND REQUIRE C BOUNDARY CONDITIONS (NODCON); THESE ARE IN COUNTERCLOCKWISE C ORDER. ALSO MAKE A 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, 3)+4,I) N3=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 IF (.NOT.CHECKN(N3)) THEN NCOND=NCOND+1 CHECKN(N3)=.TRUE. ENDIF ELSE C (TRIANGULAR ELEMENT HAS AN EXTERIOR FAULT ELEMENT C ADJACENT TO IT) EDGETS(J,I)=.FALSE. N2=NODES(MOD(J, 3)+4,I) IF (NODEF(2,KFAULT).EQ.N2) THEN EDGEFS(2,KFAULT)=.TRUE. DO 806 K=4,6 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,3 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(IUNIT8,820) NCOND 820 FORMAT(/' INCREASE PARAMETER MAXBN TO',I6,' AND RECOMPILE.') STOP ENDIF IF (NUMNOD.GT.NREALN) THEN DO 824 I=NREALN+1,NUMNOD IF (.NOT.CHECKN(I)) THEN IO=N1000+I-NREALN WRITE(IUNIT8,822) IO 822 FORMAT(' BAD GRID TOPOLOGY; FAKE NODES ARE NOT', + ' PERMITTED IN THE INTERIOR.'/' CHECK NODE ',I6) STOP ENDIF 824 CONTINUE ENDIF 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 -2 NODES AT A TIME ALONG A TRIANGLE SIDE, OR C -2 NODES AT A TIME ALONG A FAULT ELEMENT SIDE, OR C -BY FINDING ANOTHER (CORNER) NODE WHICH SHARES THE SAME LOCATION. C FIRST, BE SURE THAT WE ARE NOT STARTING ON A MIDPOINT: IF (NODTYP(I).EQ.2) THEN DO 833 K=1,NUMEL DO 832 L=1,3 IF (EDGETS(L,K)) THEN N2=NODES(MOD(L, 3)+4,K) IF (N2.EQ.I) THEN J=NODES(MOD(L+1,3)+1,K) GO TO 839 ENDIF ENDIF 832 CONTINUE 833 CONTINUE DO 835 K=1,NFL IF (EDGEFS(1,K)) THEN IF (NODEF(2,K).EQ.I) THEN J=NODEF(3,K) GO TO 839 ENDIF ELSE IF (EDGEFS(2,K)) THEN IF (NODEF(5,K).EQ.I) THEN J=NODEF(6,K) GO TO 839 ENDIF ENDIF 835 CONTINUE 839 NDONE=2 NODCON(2)=J NLEFT=NCOND-1 ENDIF C BEGINNING OF MAIN INDEFINATE LOOP: 840 NODE=NODCON(NDONE) X=XNODE(NODE) Y=YNODE(NODE) C LOOK FOR AN ADJACENT TRIANGULAR ELEMENT USING 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,3)+4,I) NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N2 CHECKN(N2)=.FALSE. N3=NODES(MOD(J+1,3)+1,I) NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N3 CHECKN(N3)=.FALSE. NLEFT=NLEFT-2 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) N3=NODEF(3,I) GO TO 856 ENDIF ELSE IF (EDGEFS(2,I)) THEN IF (NODEF(4,I).EQ.NODE) THEN N2=NODEF(5,I) N3=NODEF(6,I) GO TO 856 ENDIF ENDIF 854 CONTINUE GO TO 860 856 NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N2 CHECKN(N2)=.FALSE. NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N3 CHECKN(N3)=.FALSE. NLEFT=NLEFT-2 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 ((NODTYP(I).EQ.1).AND. + ((XNODE(I).EQ.X).AND.(YNODE(I).EQ.Y)))GO TO 867 ENDIF 865 CONTINUE WRITE(IUNIT8,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.') STOP 867 NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=I CHECKN(I)=.FALSE. NLEFT=NLEFT-1 IF (NLEFT.GT.0) GO TO 840 C END OF INDEFINATE LOOP WHICH TRACES AROUND PERIMETER. 870 WRITE(IUNIT8,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') DO 890 I=1,NCOND N=NODCON(I) IF (N.GT.NREALN) N=N1000+N-NREALN WRITE(IUNIT8,882) I, N 882 FORMAT(' ',2I6) 890 CONTINUE N=NODCON(1) IF (N.GT.NREALN) N=N1000+N-NREALN WRITE (IUNIT8,892) N 892 FORMAT(' (NOTE: NODE ',I6,' COMPLETES THE LOOP, BUT WILL', + ' NOT BE LISTED TWICE.)') C C (10) 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 DELD3=FDIP(3,I)-1.570796 VERT1=ABS(DELD1).LE.WEDGE VERT2=ABS(DELD2).LE.WEDGE VERT3=ABS(DELD3).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 IF (VERT3) THEN NVPART=NVPART+1 TAG3=VERTIC ELSE TAG3=OBLIQU ENDIF SWITCH=((NVPART.GT.0).AND.(NVPART.LT.3)) 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. DIP3=FDIP(3,I)*57.2957795 IF (DIP3.GT.90.) DIP3=DIP3-180. WRITE (IUNIT8,905) I,DIP1,TAG1,DIP2,TAG2,DIP3,TAG3 905 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES ',A21/ + ' ',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)+ + DELD3*FPHI(3,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 (IUNIT8,912) I,DIP1,DIP2,DIP3 912 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES,'/ + ' ',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 (IUNIT8,914) I,DIP1,DIP2,DIP3 914 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES,'/ + ' ',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 (11) CALCULATE FAULT ARGUMENT (IN RADIANS, MEASURED COUNTERCLOCKWISE C FROM +X) FOR EACH INTEGRATION POINT IN EACH FAULT ELEMENT. C DO 1000 M=1,7 S=FPOINT(M) DF1DS= -3.+4.*S DF2DS=4.-8.*S DF3DS= -1.+4.*S DO 900 I=1,NFL N1=NODEF(1,I) N2=NODEF(2,I) N3=NODEF(3,I) X1=XNODE(N1) X2=XNODE(N2) X3=XNODE(N3) Y1=YNODE(N1) Y2=YNODE(N2) Y3=YNODE(N3) DXDS=X1*DF1DS+X2*DF2DS+X3*DF3DS DYDS=Y1*DF1DS+Y2*DF2DS+Y3*DF3DS FTAN(M,I)=ATAN2(DYDS,DXDS) 900 CONTINUE 1000 CONTINUE C IF (.NOT. BRIEF) WRITE (IUNIT8,9999) 9999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE SQUEEZ (INPUT,ALPHAT,ELEVAT,GEOTH1,GEOTH2, + GEOTH3,GEOTH4,GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, + TEMLIM,THICK, + OUTPUT,TAUZZ,SIGZZB) C C CALCULATES "TAUZZ", THE VERTICAL INTEGRAL THROUGH THE CRUST C OF THE VERTICAL STRESS ANOMALY, WHICH IS C RELATIVE TO A COLUMN OF MANTLE AT ASTHENOSPHERE TEMPERATURE C WITH A 5 KM CRUST AND A 2.7 KM OCEAN ON TOP, LIKE A MID-OCEAN C RISE. THE INTEGRAL IS FROM EITHER THE LAND SURFACE OR THE C SURFACE, DOWN TO A DEPTH OF "THICK" INTO THE CRUST. C ALSO RETURNS "SIGZZB", THE VERTICAL STRESS ANOMALY C AT DEPTH "THICK" 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 THE MANTLE-LITHOSPHERE WEIGHT INDIRECTLY FROM C THE GIVEN TOPOGRAPHY, INSTEAD OF FROM ITS INTERNAL STRUCTURE. C PARAMETER (NDREF=100) LOGICAL CALLED DIMENSION DREF(NDREF),PREF(0:NDREF) SAVE CALLED,DREF,PREF DATA CALLED /.FALSE./ C C STATEMENT FUNCTION: TEMP(H)=MIN(TEMLIM,GEOTH1+GEOTH2*H+GEOTH3*H**2 + +GEOTH4*H**3) C C CREATE REFERENCE TEMPERATURE & DENSITY PROFILES TO DEPTH OF NDREF KM C IF (.NOT.CALLED) THEN RHOTOP=RHOBAR*(1.-ALPHAT*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 CALLED=.TRUE. ENDIF C C ROUTINE PROCESSING (ON EVERY CALL): C IF (ELEVAT.GT.0.) THEN ZTOP= -ELEVAT ZBASE=THICK-ELEVAT DENSE1=RHOBAR*(1.-GEOTH1*ALPHAT) H=0. ELSE ZTOP=0. ZBASE=THICK+(-ELEVAT) DENSE1=RHOH2O H=ELEVAT 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) 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 T=TEMP(H) DENSE2=RHOBAR*(1.-T*ALPHAT) ELSE DENSE2=RHOH2O 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 SIGZZ=SIGZZ-DENSE*GMEAN*ONEKM+(PR-OLDPR) TAUZZ=TAUZZ+0.5*(SIGZZ+OLDSZZ)*ONEKM DENSE1=DENSE2 OLDSZZ=SIGZZ OLDPR=PR 200 CONTINUE RESID=ZBASE-Z H=THICK Z=ZBASE T=TEMP(H) DENSE2=RHOBAR*(1.-T*ALPHAT) 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 RETURN END C C C SUBROUTINE TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) C C COMPUTES VERTICAL INTEGRALS OF RELATIVE OR DEVIATORIC C 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 THONC (INPUT,ECREEP,ETAMAX,GLUE, + MXEL,MXNODE,NODES,NUMEL,NUMNOD, + PULLED,V,VM,ZMOHO, + OUTPUT,DVB,OVB,SIGHB, + WORK,OUTVEC) C C CALCULATES SHEAR STRESSES ON BASE OF CRUST (SIGHB), AND C THE VECTOR VELOCITY OF THE LAYER BELOW (OVB), AND C THE SCALAR VELOCITY DIFFERENCE OF THE LAYER BELOW (DVB). C C NOTE: FOLLOWING TYPE CAN BE COMPRESSED TO LOGICAL*1 IN VS-FORTRAN: LOGICAL PULLED C DOUBLE PRECISION V,VM DIMENSION DVB(7,MXEL), + GLUE(7,MXEL), + NODES(6,MXEL),OUTVEC(2,7,MXEL), + OVB(2,7,MXEL),PULLED(7,MXEL), + SIGHB(2,7,MXEL), + V(2,MXNODE),VM(2,MXNODE),ZMOHO(7,MXEL) C CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,V, + OUTPUT,OUTVEC) CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,VM, + OUTPUT,OVB) DO 1000 M=1,7 DO 900 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) DVB(M,I)=VMAG IF (PULLED(M,I).AND.(VMAG.GT.0.)) THEN DVX=VRX/VMAG DVY=VRY/VMAG SHEAR1=GLUE(M,I)*VMAG**ECREEP SHEAR2=ETAMAX*VMAG SHEAR=MIN(SHEAR1,SHEAR2) SIGHB(1,M,I)=SHEAR*DVX SIGHB(2,M,I)=SHEAR*DVY ELSE SIGHB(1,M,I)=0. SIGHB(2,M,I)=0. ENDIF 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE VBCS (INPUT,ICOND,MXBN,MXDOF,MXNODE,MXWORK, + NCOND,NDOF,NLB,NODCON,NREALN,NUB, + VBCAZ,VBCMAG, + MODIFY,K,V,F) C C IMPOSE VELOCITY BOUNDARY CONDITIONS. C -IF THE NODE IS REAL, REPLACE THE EQUILIBRIUM EQUATION(S) FOR C THAT NODE WITH TRIVIAL EQUATION(S) SAYING THAT THE VELOCITY C IS EQUAL TO THAT DESIRED. IN THE CASE OF ICOND(I)=1, 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 UNCHANGED) AND REPLACING ONLY THE REDUNDANT C EQUATION, THEN ROTATING BACK. IN ANY CASE, THE WEIGTH 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 -IF THE NODE IS FAKE, THEN IT IS NOT TREATED IN THE SYSTEM OF C LINEAR EQUATIONS; INSTEAD, THE DESIRED VALUES ARE PLACED DIRECTLY C INTO THE V (SOLUTION) VECTOR, AT THE END. C DOUBLE PRECISION F,K,TOPONE,V DIMENSION ICOND(MXBN),K(MXWORK),F(MXDOF),NODCON(MXBN), + V(2,MXNODE),VBCAZ(MXBN),VBCMAG(MXBN) COMMON LDA,MD C C STATEMENT FUNCTION REPLACING INTEGER FUNCTION SUBPROGRAM "INDEXK": INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + MD + IROW - JCOLUM 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) IF (NODE.LE.NREALN) THEN C C REAL NODES ARE TREATED BY MODIFYING THE LINEAR SYSTEM: C IF (ICOND(I).EQ.1) THEN C IMPOSE COMPONENT IN THE DIRECTION "VBCAZ", C BUT LEAVE THE PERPENDICULAR COMPONENT FREE: CALL ROTOR (INPUT,MXWORK,MXDOF,NDOF,NLB,NODE, + NUB,VBCAZ(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(VBCAZ(I)) K(INDEXK(IRCON,IRCON+1))=TOPONE*SIN(VBCAZ(I)) CALL ROTOR (INPUT,MXWORK,MXDOF,NDOF,NLB,NODE, + NUB,-VBCAZ(I), + MODIFY,F,K) ELSE IF (ICOND(I).GE.2) THEN C IMPOSE BOTH COMPONENTS OF VELOCITY: VBCX=VBCMAG(I)*COS(VBCAZ(I)) VBCY=VBCMAG(I)*SIN(VBCAZ(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 ELSE C C FAKE NODES ARE TREATED BY MODIFYING V DIRECTLY C V(1,NODCON(I))=VBCMAG(I)*COS(VBCAZ(I)) V(2,NODCON(I))=VBCMAG(I)*SIN(VBCAZ(I)) ENDIF 100 CONTINUE C RETURN END C C C SUBROUTINE VISCOS (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,DCREEP,ECREEP, + ERATE,FRIC,G,GEOTH, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM, + 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(7,NUMEL) is the depth into the crust 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). C SCOREC and SCORED are measures of mismatch between current C linearized and actual nonlinear rheologies: C SCOREC is the maximum (absolute value) error in tau [N/m]; C SCORED is the mean-error/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 This new version is specific to FAULTS: C *expects parameters ACREEP, ALPHAT, BCREEP, CCREEP, DCREEP, C RHOBAR, TEMLIM to be scalars, not 2- C component (crust/mantle) vectors; C *expects one input array GEOTH instead of GEOTHC and GEOTHM; C *does not expect an input array TLINT of mantle lithosphere; C *internal variables THICKM, TMEAN, RHOUSE are eliminated; C *calls DIAMND only once per integration point (Note: DIAMND C is the same in all programs now!) C *reports results as ZTRANC(7,NUMEL), not ZTRANC(2,7,NUMEL). C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C External variables and arrays INTEGER I, INPUT, M, MXEL, NUMEL REAL BIOT, ECREEP, FRIC, G, + OUTPUT, RHOH2O, SCOREC, SCORED, VISMAX REAL ACREEP, ALPHA(3,3,7,MXEL), + ALPHAT, BCREEP, + CCREEP, DCREEP, + ERATE(3,7,MXEL), + GEOTH(4,7,MXEL), + RHOBAR, SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL), TEMLIM, + TOFSET(3,7,MXEL), + ZMOHO(7,MXEL), ZTRANC(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, TMEAN, TXX, TXY, TYY, + ZOFTOP, ZTRAN 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) 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 ALPHA(1,2,M,I)=2.*VISMAX*THICKC ALPHA(1,3,M,I)=0. ALPHA(2,1,M,I)=2.*VISMAX*THICKC ALPHA(2,2,M,I)=4.*VISMAX*THICKC 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 TOFSET(1,M,I)=0. TOFSET(2,M,I)=0. TOFSET(3,M,I)=0. ZTRANC(M,I)=0. C Note: "C" is for Continuum, not for Crust! 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. CALL DIAMND (INPUT,ACREEP,ALPHAT, + BCREEP,BIOT, + CCREEP,DCREEP, + ECREEP, + E1,E2,FRIC,G, + GEOTH(1,M,I), + GEOTH(2,M,I), + GEOTH(3,M,I), + GEOTH(4,M,I), + PL0,PW0, + RHOBAR,RHOH2O,SIGHBI, + THICKC,TEMLIM, + VISMAX,ZOFTOP, + OUTPUT,PT1DE1,PT1DE2, + PT2DE1,PT2DE2, + PT1,PT2,ZTRAN) 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(M,I)=ZTRAN ELSE ZTRANC(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 BLOCK DATA BD1 C C DEFINE "PHI" (NODAL FUNCTIONS) AND "WEIGHT" (GAUSSIAN INTEGRATION C WEIGHTS) OF THE 6-NODE TRIANGULAR FINITE ELEMENT FOR THE C SEVEN INTEGRATION POINTS IN EACH ELEMENT, DEFINED BY INTERNAL C COORDINATES "POINTS(5,7)", WHERE POINTS(1-3,M)=S1-S3 OF C INTEGRATION POINT NUMBER M. (NOTE: POINTS(4,M)=POINTS(1,M) AND C POINTS(5,M)=POINTS(2,M), FOR PROGRAMMING CONVENIENCE, AS IN C SUBPROGRAM "DERIV".) C BECAUSE ALL OF THESE ARRAYS ARE FUNCTIONS OF INTERNAL C COORDINATES, THEY ARE NOT AFFECTED BY SCALING OR DEFORMATION OF C THE ELEMENTS. C DOUBLE PRECISION PHI,POINTS,WEIGHT COMMON /S1S2S3/ POINTS COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) C C "PHI" CONTAINS THE VALUES OF THE 6 NODAL FUNCTIONS AT THE 7 C GAUSSIAN INTEGRATION POINTS (FOR AREA INTEGRALS) OF THE C TRIANGULAR ELEMENTS. DATA PHI / +-0.1111111111111111D0,-0.1111111111111111D0,-0.1111111111111111D0, + 0.4444444444444444D0, 0.4444444444444444D0, 0.4444444444444444D0, +-0.0525839022774079D0,-0.0280749439026853D0,-0.0280749439026853D0, + 0.1122997756107412D0, 0.8841342388612960D0, 0.1122997756107412D0, +-0.0280749439026853D0,-0.0525839022774079D0,-0.0280749439026853D0, + 0.1122997756107412D0, 0.1122997756107412D0, 0.8841342388612960D0, +-0.0280749439026853D0,-0.0280749439026853D0,-0.0525839022774079D0, + 0.8841342388612960D0, 0.1122997756107412D0, 0.1122997756107412D0, + 0.4743526114618935D0,-0.0807685938011933D0,-0.0807685938011933D0, + 0.3230743752047730D0, 0.0410358257309469D0, 0.3230743752047730D0, +-0.0807685938011933D0, 0.4743526114618935D0,-0.0807685938011933D0, + 0.3230743752047730D0, 0.3230743752047730D0, 0.0410358257309469D0, +-0.0807685938011933D0,-0.0807685938011933D0, 0.4743526114618935D0, + 0.0410358257309469D0, 0.3230743752047730D0, 0.3230743752047730D0/ 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. DATA POINTS / + 0.3333333333333333D0, 0.3333333333333333D0, 0.3333333333333333D0, + 0.3333333333333333D0, 0.3333333333333333D0, + 0.0597158733333333D0, 0.4701420633333333D0, 0.4701420633333333D0, + 0.0597158733333333D0, 0.4701420633333333D0, + 0.4701420633333333D0, 0.0597158733333333D0, 0.4701420633333333D0, + 0.4701420633333333D0, 0.0597158733333333D0, + 0.4701420633333333D0, 0.4701420633333333D0, 0.0597158733333333D0, + 0.4701420633333333D0, 0.4701420633333333D0, + 0.7974269866666667D0, 0.1012865066666667D0, 0.1012865066666667D0, + 0.7974269866666667D0, 0.1012865066666667D0, + 0.1012865066666667D0, 0.7974269866666667D0, 0.1012865066666667D0, + 0.1012865066666667D0, 0.7974269866666667D0, + 0.1012865066666667D0, 0.1012865066666667D0, 0.7974269866666667D0, + 0.1012865066666667D0, 0.1012865066666667D0/ 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) OF THE 6-NODE LINEAR FAULT ELEMENT FOR THE SEVEN C INTEGRATION POINTS IN EACH ELEMENT, DEFINED BY INTERNAL C COORDINATE "FPOINT(M=1-7)", 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 SCALING OR DEFORMATION OF C THE ELEMENTS. C DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS DIMENSION FPHI(6,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 NODE3 (OF 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 6 NODAL FUNCTIONS (ONE PER NODE) C AT EACH OF THESE 7 INTEGRATION POINTS IN THE FAULT ELEMENT. DATA FPHI/ + .92495670801042D0, .09919438397916D0,-.02415109198958D0, + .02415109198958D0,-.09919438397916D0,-.92495670801042D0, + .64569986028672D0, .45013147942656D0,-.09583133971328D0, + .09583133971328D0,-.45013147942656D0,-.64569986028672D0, + .28527776318152D0, .83528967363696D0,-.12056743681848D0, + .12056743681848D0,-.83528967363696D0,-.28527776318152D0, + 0.0D0, 1.0D0, 0.0D0, + 0.0D0, -1.0D0, 0.0D0, + -.12056743681848D0, .83528967363696D0, .28527776318152D0, + -.28527776318152D0,-.83528967363696D0, .12056743681848D0, + -.09583133971328D0, .45013147942656D0, .64569986028672D0, + -.64569986028672D0,-.45013147942656D0, .09583133971328D0, + -.02415109198958D0, .09919438397916D0, .92495670801042D0, + -.92495670801042D0,-.09919438397916D0, .02415109198958D0/ C END C C C SUBROUTINE ZEROK (INPUT,MXWORK,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,MD C C STATEMENT FUNCTION REPLACING INTEGER FUNCTION SUBPROGRAM "INDEXK": INDEXK(IROW,JCOLUM) = (JCOLUM-1)*LDA + MD + IROW - JCOLUM 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