C PROGRAM OLD_LARAMY C (FOR VERSION DATE SEE 1ST WRITE BELOW). C CALCULATES TIME-HISTORY OF THREE-DIMENSIONAL DEFORMATION OF C CONTINENTAL CRUST AND MANTLE LITHOSPHERE CAUSED BY BASAL DRAG C AND WEIGHT OF HORIZONTALLY-SUBDUCTING OCEANIC PLATES C (AND/OR VELOCITY AND/OR STRESS BOUNDARY CONDITIONS ON EDGES). C NOTE: "OLD_" IN NAME REFERS TO THE USE OF THE ORIGINAL VERSIONS C OF -VISCOS- AND -DIAMND- TO COMPUTE THE STRENGTH OF THE ELEMENTS. C-- INPUT: ------------ C *USES STRATEGIC AND TACTICAL INPUT PARAMETERS READ FROM DEVICE 1. C *OPTIONALLY READS POSITIONS OF NODES FROM DEVICE 8; OR C READS ALL OLD ARRAY VALUES FOR RESTARTING, ON DEVICE 8. C-- OUTPUT: ----------- C *SENDS INFORMATIVE TEXT, TABLES, AND GRAPHIC OUTPUT C (FORMATTED FOR LINE PRINTER) TO DEVICE 6. C *SENDS DETAILED CONTENTS OF ALL ARRAYS TO DEVICE 9. C (YOU CAN CHOOSE TO HAVE THIS OUTPUT AT ALL TIME STEPS, C OR ONLY AT SELECTED TIME STEPS, OR ONLY AT THE END.) C------------------------------------------------------------------ C C NOTICE: THIS PROGRAM AND ASSOCIATED SUBPROGRAMS WERE CREATED BY C PETER BIRD, DEPARTMENT OF EARTH & SPACE SCIENCES, C UNIVERSITY OF CALIFORNIA, LOS ANGELES. C FIVE YEARS OF SUPPORT FROM THE CRUSTAL STRUCTURE AND TECTONICS C PROGRAM OF THE NATIONAL SCIENCE FOUNDATION ARE GRATEFULLY C ACKNOWLEDGED. C THIS PROGRAM IS FREEWARE AND MAY BE REPRODUCED AND RUN C WITHOUT WRITTEN PERMISSION. HOWEVER, PROPER CREDIT SHOULD C BE GIVEN TO THE AUTHOR IN ANY RESULTING PUBLICATIONS. C USERS ARE ENCOURAGED TO CONTACT THE AUTHOR FOR ADVICE, UPDATES, C AND TECHNICAL SUPPORT, AT (310) 825-1126, or: pbird@ess.ucla.edu C A PAPER DESCRIBING THE NUMERICAL METHODS APPEARED IN THE C JOURNAL OF GEOPHYSICAL RESEARCH, VOL. 94, NO. B4, C PAGES 3967-3990, APRIL 10, 1989. (HOWEVER, MAJOR SUBPROGRAMS C HEATER, DRAGIT, AND PANCAK ARE NEWER THAN THAT PAPER). C C EXTERNAL ROUTINES USED: C -ENGINEERING & SCIENTIFIC SUBROUTINE LIBRARY C (AN IBM PRODUCT) ROUTINES: C SGEF AND SGES (SINGLE PRECISION FACTOR AND C SOLVE A GENERAL LINEAR SYSTEM) C DGBF AND DGBS (DOUBLE PRECISION FACTOR AND C SOLVE A GENERAL BANDED LINEAR SYSTEM) C (NOTE THAT STATEMENT FUNCTION 'INDEXK' APPEARING C IN A NUMBER OF SUBPROGRAMS MUST BE REDEFINED C IF A DIFFERENT PROCEDURE WITH A DIFFERENT C ARRAY-STORAGE SCHEME IS SUBSTITUTED.) C SGEEV (EIGENVALUES AND EIGENVECTORS OF A REAL GENERAL MATRIX) C -FORTRAN INTRINSIC FUNCTIONS CALLED BY GENERIC NAMES: C ABS,ASIN,ATAN2,COS,EXP,LOG,MAX,MIN,MOD,SIN,SQRT,TAN C C MAX.# OF: ELEMENTS, NODES, 2*NODES, K DIMENSION, WORKSPACE PARAMETER (N200=280,N441=609,N882=1218,I50822=330078,N75852=1218) C CURRENTLY DIMENSIONED FOR UP TO 14 ROWS OF QUADRILATERALS, BY C 10 COLUMNS OF QUADRILATERALS, WITH C 2 TRIANGLES PER QUADRILATERAL, AND C 2 LAYERS OF FINITE-ELEMENT GRID; C THIS REQUIRES 5 MBYTES ON IBM. C SUBPROGRAM SETDIM CHECKS WHETHER THESE ARE ADEQUATE EACH RUN. C PARAMETER (NRD=29,NRDP1=30) C DESCRIBES MAXIMUM NUMBER OF ROWS (N TO S) OF NODES IN GRID. C NRDP1 IS 1 GREATER TO ALLOW FOR OVERLAP ON ALL SIDES. C CHARACTER*80 TITLE REAL N,NS DOUBLE PRECISION CODE,FLOWIN,FORCE,STIFF LOGICAL ALLREP,BOXIT,COLAPS,DIMERR,DOREP, + FAILUR,LISTOP,OLDGRD,RESTRT,TAPE9,TERSE C VARIABLE DIMENSIONS CONTAINING VALUE OF N200: DIMENSION ALPHAC(3,3,7,N200),ALPHAM(3,3,7,N200), 2 AREAC(N200),AREAM(N200),CONINT(7,N200), 3 DELVC(2,7,N200),DELVM(2,7,N200),DETJC(7,N200), 4 DETJM(7,N200),DGDT1C(4,7,N200),DGDT1M(4,7,N200), 5 DGDT2C(4,7,N200),DGDT2M(4,7,N200),DNLINK(3,7,N200), 6 DVB(7,N200),DVT(7,N200),DXSC(6,7,N200), 7 DXSM(6,7,N200),DYSC(6,7,N200),DYSM(6,7,N200), 8 EDOTC(4,7,N200),EDOTM(4,7,N200), 9 ERATEC(4,7,N200),ERATEM(4,7,N200), A ESUMC(2,2,7,N200),ESUMM(2,2,7,N200), 1 FLUXC(7,N200),FLUXM(7,N200),FLUXUC(7,N200), 2 FROMWC(7,N200),FROMWM(7,N200) DIMENSION GEOTHA(4,7,N200),GEOTHC(4,7,N200),GEOTHM(4,7,N200), 2 GLUEC(7,N200),GLUEM(7,N200), 3 INTVEC(N200),LISTOP(N200), 4 NODES(6,0:N200),OUTSCA(7,N200),OUTVEC(2,7,N200), 5 OUTV2(2,7,N200),OVA(2,7,N200),OVB(2,7,N200), 6 PRHOCP(7,N200),PTSC(2,7,N200), 7 PTSM(2,7,N200),QFRICC(4,7,N200),QFRICM(4,7,N200), 8 QWORK(4,7,N200),SIGHC(2,7,N200),SIGHBM(2,7,N200), 9 SIGHTM(2,7,N200),SIGZZC(7,N200),SIGZZM(7,N200), A SZZBC(7,N200),SZZBM(7,N200),TAUMTC(3,7,N200), 1 TAUMTM(3,7,N200),TAUZZC(7,N200),TAUZZM(7,N200), 2 THIKC(7,N200),THIKM(7,N200), 3 TOFSTC(3,7,N200),TOFSTM(3,7,N200), 4 TOUCHC(7,N200),TOUCHM(7,N200),UPLINK(3,7,N200), 5 VSLABC(2,7,N200),VSLABM(2,7,N200), 6 XIPC(7,N200),XIPM(7,N200),YIPC(7,N200),YIPM(7,N200) C VARIABLE DIMENSIONS CONTAINING VALUE OF N441: DIMENSION CONDNS(N441), + CONNOD(N441),CONSAV(N441), + PHINOD(N441), + THNKC(N441),THNKM(N441),THNSAV(N441), + VNODE(2,N441), + V1C(2,N441),V1M(2,N441), + V2C(2,N441),V2M(2,N441), + W1C(N441),W1M(N441),W2C(N441),W2M(N441), + XNODC(N441),XNODM(N441),YNODC(N441), + YNODM(N441) C VARIABLE DIMENSIONS CONTAINING VALUE OF N882: DIMENSION FLOWIN(N882),FORCE(N882) C VARIABLE DIMENSIONS CONTAINING VALUE OF I50822: DIMENSION CODE(I50822),STIFF(I50822) C VARIABLE DIMENSION CONTAINING VALUE OF N75852: DIMENSION LWORK(N75852) C VARIABLE DIMENSIONS CONTAINING VALUES OF NRD AND NRDP1: DIMENSION C(NRD,NRD), + DRAGN(2,NRD,NRD), + E(NRD,NRD),ES(NRD,NRD), + GEONOD(4,NRD,NRD), + GRADXC(NRD,NRD),GRADXE(NRD,NRD),GRADXW(NRD,NRD), + GRADYC(NRD,NRD),GRADYN(NRD,NRD),GRADYS(NRD,NRD), + N(NRD,NRD),NS(NRD,NRD), + PK(2,5,0:NRDP1,0:NRDP1), + PRCFD(NRD,NRD), + P0(0:NRDP1,0:NRDP1), + P1(0:NRDP1,0:NRDP1), + P2(0:NRDP1,0:NRDP1), + SHEARN(2,NRD,NRD), + S(NRD,NRD),SS(NRD,NRD), + W(NRD,NRD),WS(NRD,NRD), + XFD(NRD,NRD),YFD(NRD,NRD) C____________________________________________________________________ C Glossary of Arrays C passed between LARAMY and subroutines C (Arrays in block-data programs are defined there. C Arrays used to assemble and solve linear systems C are not discussed, as conventions are software-dependent.) C ALPHA{C/M}(j k,m,i) C Secant "derivitive" of the vertical-integral of deformational- C (deviatoric-) stress component j : C j=1-3: Txx, Tyy, Txy C evaluated from the nonlinear rheology at the current strain- C rate with respect to the strain-rate component k at the layer top: C k=1-3: Exx, Eyy, Exy (note: "tensor" definition of Exy). C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitude 1.E30 dyne sec/cm. C AREA{C/M}(i) C Area of the element computed without regard for curvature of the C sides, using only the coordinates of the three vertices. C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crusta1 or mantle values. C Typical magnitude 5.E14 cm**2. C C(i,j) C Array used only in the finite-difference solution of the C diffusion of crustal thickness under the force of gravity. C Gives the coefficient to be applied to the Central point C (at row i, from the North, and column j, from the West) C when computing the new matrix of topographic pressures. C Equal to 1.00-N-E-S-W. C CONDNS(i) C Temporary storage of scalar floating-point variables defined at C nodes. C Subscript i =1-NUMNOD is the node number (defined in GRIDDR). C CONINT(m,i) C Depth of Conrad discontinuity (in crustal creep properties) C at each integration point in crust. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C Typical magnitude 3.E6 cm. C CONNOD(i) C Depth of Conrad discontinuity (in crustal creep properties) C at each node in crust. C Subscript i =1-NUMNOD is the node number (defined in GRIDDR). C Typical magnitude 3.E6 cm. C CONSAV(i) C Depth of Conrad discontinuity (in crustal creep properties) C at each node in crust. An extra copy of info. in CONNOD. C Subscript i =1-NUMNOD is the node number (defined in GRIDDR). C Typical magnitude 3.E6 cm. C DELV{C/M}(k,m,i) C Relative velocity of the layer bottom with respect to its top. C Subscript k=1-2: x-component, y-component. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitude 3.E-8 cm/sec. C DETJ{C/M}(m,i) C Determinant of the Jacobian matrix of the mapping that bends the C sides of an isoparametric element. Equal to the ratio of C areas after mapping to areas before mapping. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitude 1.00 (dimensionless). C DGDT{1/2}{C/M}(k,m,i) C Rate of change of coefficients of the geotherm. C Subscript k=1-4 for constant, linear, quadratic, and cubic C coefficients of the geotherm polynomial. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {1/2} indicates beginning or end of a time step. C {C/M} indicates crustal or mantle values. C Typical magnitudes O., 7.E-2O, 2.E-29, 5.E-37 K cm**(1-k)/sec. C DNLINK(k,m,i) C Information necessary to locate the point in the mantle grid C which is beneath one of the integration points in the C crustal grid. C Value at k=1 is either: 0. if no mantle layer beneath; or C : # of mantle element +0.10). C Value at k=2 is internal coordinate S2 in the mantle element. C Value at k=3 is internal coordinate S3 in the mantle element. C Internal coordinate S1 is not stored: S1 = 1.00 - S2 - S3. C Subscript m =1-7 is the integration point number in the crustal C element (defined by coordinates in BD1). C Subscript i =1-NUMEL is the crustal element number. C Typical magnitudes 27.1, 0.2785, 0.1354 for k=1,3. C DRAGN(k,i,j) C Relative velocity of the layer bottom with respect to its top. C Subscript k=1-2: x-component, y-component. C Subscript i=1,NROWN is the row number of the node in a C rectangular grid (N to S). C Subscript j=1,NCOLN is the column number of the node in a C rectangular grid (W to E). C Typical magnitude 3.E-8 cm/sec. C DV{B/T}(m,i) C Magnitude of the difference in vector horizontal velocity C between the tops of the crust and mantle, or between top C of mantle layer and top of subducting plate. C {B/T} indicates bottom/top of the layer whose force balance is C in question at the time. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C Typical magnitude 1.E-7 cm/sec. C D{X/Y}S{C/M}(k,m,i) C Spatial partial derivitives of nodal functions. C Subscript k=1-6: number of nodal function in internal ordering C scheme of generic element (defined in GRIDDR and BD1). C Note that all nodal functions are 1. at node k and 0. at others. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {X/Y} indicates direction of spatial derivitive. C {C/M} indicates crustal or mantle values. C Typical magnitude 1.E-7 /cm. C E(i,j) C Array used only in finite-difference solutions of lateral C diffusion. C Gives the coefficient to be applied to the next point East C (from row i, from the North, and column j, from the West) C when computing the new matrix of topographic pressures. C EDOT{C/M}(k,m,i) C Strain-rate components at the top of a layer. C Subscript k=1-4 for Exx, Eyy, Exy ("tensor" definition), and C counterclockwise rotation rate of hard inclusions. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitude 1.E-14 /sec (radians/sec for k=4). C ERATE{C/M}(k,m,i) C Extra copies of information in EDOT{C/M)(k,m,i); see above. C (Spare copies are needed to save old rates from overwriting C so that corrector step of predictor/corrector time C integration can proceed.) C ES(i,j) C Array used only in the finite-difference solution of the C diffusion of crustal thickness under the force of gravity. C Gives part of the coefficient to be applied to the next point C E (from row i, from the North, and column j, from the West) C when computing the new matrix of topographic pressures. C To obtain the whole coefficient E, it must be multiplied by the C timestep and flux/gradient coefficient. C ESUM{C/M}(j,k,m,i) C Time-integrated finite strain (Green's tensor) at the top of a C layer. C Subscripts j=1,2 and k=1,2 define a 2 x 2 matrix for the mapping C of small vectors in the x-y plane from undeformed to C deformed states. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BDI). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitude: approx. identity matrix (dimensionless). C FLUX{C/M/UC}(m,i) C Vertical integral through the layer of the scalar horizontal C velocity, relative to the strongest part of the layer, which C is caused by a unit of relative velocity imposed as a lower C boundary condition, DIVIDED BY relative horizontal velocity. C Equal to effective thickness of boundary layer transported C along with the layer below. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C {UC} indicates integral is only down to Conrad discontinuity. C Typical magnitude 3.E5 cm. C FROMW{C/M}(m,i) C Distance from west edge of grid. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitude 2.E8 cm. C GEONOD(k,i,j) C Coefficients of the geotherm polynomial for a layer. C Subscript k=1-4 for constant, linear, quadratic, and cubic C coefficients of the geotherm polynomial. C Subscript i=1,NROWN is the row number of the node in a C rectangular grid (N to S). C Subscript j=1,NCOLN is the column number of the node in a C rectangular grid (W to E). C Typical magnitudes 283., 2.E-4,-1.E-11, 1.E-18 K cm**(1-k). C GEOTH{A/C/M}(k,m,i) C Coefficients of the geotherm polynomial for the layer. C Subscript k=1-4 for constant, linear, quadratic, and cubic C coefficients of the geotherm polynomial. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {A/C/M} indicates asthenosphere or crustal or mantle-lithosphere C layer. C Typical magnitudes 283., 2.E-4,-1.E-11, 1.E-18 K cm**(1-k). C GLUE{C/M}(m,i) C Scalar shear stress on base of layer necessary to cause a unit C of horizontal velocity at the layer bottom relative to the C top. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitude 1.E1O dyne/cm**2. C GRAD{X/Y}{C/N/E/S/W}(i,j) C Coefficients (with dimension 1/distance) to be multiplied by C any set of nodal values to obtain the approximate C derivitive values at the nodes. C {X/Y} indicates whether d/dX or d/dY will result. C {C/N/E/S/W} indicates whether coefficient is to be multiplied C by point (i,j)=Center, (i-1,j)=North, (i,j+1)=East, C (i+1,j)=South, or (i,j-1)=West. C Subscript i=1,NROWN is the row number of the node in a C rectangular grid (N to S). C Subscript j=1,NCOLN is the column number of the node in a C rectangular grid (W to E). C Typical magnitudes 1.E-7 /cm. C LISTOP(i) C Logical array which is TRUE. if an element requires correction C of shape to avoid folding", defined as locally C negative area due to a negative determinant of the Jacobian C matrix of the side-bending transformation, or as a failure C of functional mapping from external to bent internal C coordinates. C Subscript i =1-NUMEL is the element number, defined in GRIDDR. C Typical value .FALSE. C N(i,j) C Array used only in finite-difference solutions of lateral C diffusion. C Gives the coefficient to be applied to the next point North C (from row i, from the North, and column j, from the West) C when computing the new matrix of topographic pressures. C NODES(k,i) C Integer array of node numbers associated with an element. C Subscript k=1,6 are the 6 node numbers in this order: C first the three vertices in counterclockwise direction, C beginning with the node which is at the right angle; C then the three side nodes in counterc1ockwise direction C beginning with the node between node k=1 and node k=2. C Subscript i =1-NUMEL is the element number, defined in GRIDDR. C Same array serves for both crust and mantle layers. C Typical values: integer, range 1-NUMNOD. C NS(i,j) C Array used only in the finite-difference solution of the C diffusion of crustal thickness under the force of gravity. C Gives part of the coefficient to be applied to the next point C N (from row i, from the North, and column j, from the West) C when computing the new matrix of topographic pressures. C To obtain the whole coefficient N, it must be multiplied by the C timestep and flux/gradient coefficient. C OUTSCA(m,i) C Scratch array for temporary storage of real floating-point C scalar variables defined at integration points. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C OUTVEC(k,m,i) C Scratch array for temporary storage of real floating-point C vector variables defined at integration points. C Subscript k=1,2 indicates x and y components of vectors. C Subscript m =1-7 is the integration p,int number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C OUTV2(k,m,i) C Scratch array for temporary storage of real floating-point C vector variables defined at integration points. C Subscript k=1,2 indicates x and y components of vectors. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C OV{A/B}(k,m,i) C Horizontal velocity vector of the layer adjacent to the one in C question. C A/B indicates above or below the layer in question. C Subscript k=1,2 indicates x and y components of velocity. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C Typical magnitude 3.E-7 cm/sec. C PHINOD(i) C Temporary storage of scalar floating-point variables defined at C nodes. C Subscript i =1-NUMNOD is the node number (defined in GRIDDR). C PK(m,k,i,j) C Set of coefficients needed to compute the approximate C ratio of flux of crustal material driven by lateral C pressure gradients to the size of the pressure gradient. C (This ratio plays a role in the diffusion of crustal thickness C which is analogous to the role of conductivity in heat C diffusion.) C m = 1 indicates whole-crust values. C m = 2 indicates upper-crust values (above the Conrad disc.) C k = 1 indicates the current flux/grad-p ratio. C k = 2 indicates the pre-exponential coefficient needed to C compute the value in k = 1. C k = 3 indicates the exponent to be applied to the square of C the pressure gradient when computing the k = 1 value. C k = 4 indicates the factor by which the k=1 value will increase C for each additional kilometer of Moho depth. C k = 5 indicates the factor by which the k=1 value will increase C for each additional kilometer of upper crust. C Subscript i=1,NROWN is the row number of the node in a C rectangular grid (N to S). C Subscript j=1,NCOLN is the column number of the node in a C rectangular grid (W to E). C PRCFD(i,j) C Array used only in the finite-difference solution of the C diffusion of crustal thickness under the force of gravity. C Inverse of (gravity * (mantle density - crustal density) ). C This factor plays a role in the diffusion of crustal thickness C which is analogous to the heat capacity per unit volume C in 2-dimensional heat conduction. C Subscript i is the row number (North to South). C Subscript j is the column number (West to East). C PRHOCP(m,i) C Inverse of (gravity * (mantle density - crustal density) ). C This factor plays a role in the diffusion of crustal thickness C which is analogous to the heat capacity per unit volume C in 2-dimensional heat conduction. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C PTS{C/M}(k,m,i) C Deviatoric pressure times slope of bottom or bottom & top of C layer; equals an effective horizontal force per unit area C exerted on the layer by deviatoric pressures. C Subscript k=1,2 indicates x and y components of force/area. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C C/M indicates crust or mantle layer: value differs: C for crust, PTSC = (delta P) x (grad thickness); C for mantle PTSM = (delta P at base) x (grad lithosphere C thickness) C -(delta P at top) x (grad crustal C thickness). C Typical magnitude: 5.E7 dyne/cm**2. C P{0/1/2}(i,j) C Array used only in the finite-difference solution of the C diffusion of crustal thickness under the force of gravity. C Gives the topographic pressure at row i (from North to South) C and column j (from West to East). C 0/1 indicates before/after a diffusion timestep; 2 indicates C and extra copy of the P0 array, for convenience. C Typical magnitude 1.E9 dyne/cm**2. C S(i,j) C Array used only in the finite-difference solution of the C diffusion of crustal thickness under the force of gravity. C Gives the coefficient to be applied to the next point South C (from row i, from the North, and column j, from the West) C when computing the new matrix of topographic pressures. C SHEARN(k,i,j) C Horizontal shear stress on the top or bottom of a layer. C Subscript k=1,2 indicates x and y components of force/area. C Subscript i=1,NROWN is the row number of the node in a C rectangular grid (N to S). C Subscript j=1,NCOLN is the column number of the node in a C rectangular grid (W to E). C Typical magnitude 1.E8 dyne/cm**2. C SIGH{C/TM/BM}(k,m,i) C Horizontal shear stress on the top or bottom of a layer. C C indicates crustal 1ayer; shear stress is on base only. C BM indicates bottom of the mantle layer. C TM indicates top of the mantle layer. C Subscript k=1,2 indicates x and y components of force/area. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C Typical magnitude 1.E8 dyne/cm**2. C SIGZZ{C/M}(m,i) C Vertical normal stress anomaly (tension positive) at the top C of a layer, relative to the mid-ocean rise standard. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C SubscriPt i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitudes 1.E9 dyne/cm**2. C SS(i,j) C Array used only in the finite-difference solution of the C diffusion of crustal thickness under the force of gravity. C Gives part of the coefficient to be applied to the next point C S (from row i, from the North, and column j, from the West) C when computing the new matrix of topographic pressures. C To obtain the whole coefficient S, it must be multiplied by the C timestep and flux/gradient coefficient. C SZZB{C/M}(m,i) C Vertical normal stress anomaly (tension positive) that would C be exerted by subducted slabs if there were mechanical C coupling. Relative to the mid-ocean rise standard. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitudes 1.E9 dyne/cm**2. C TAUMT{C/M}(k,m,i) C Vertically integrated deviatoric stress in a layer. C Subscript k=1-3 indicates Txx, Tyy, or Txy component C respectively. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitudes 4.E15 dyne/cm. C Note: Values are obtained from current ALPHA and TOFST arrays, C not from nonlinear rheology. At convergence, these agree. C TAUZZ{C/M}(m,i) C Vertical integral through the layer of vertical normal C stress anomaly (tension positive). C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitudes 4.E15 dyne/cm**2. C THIK{C/M}(m,i) C Thickness of the layer, defined at integration points. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitudes 4.E6 cm. C THNK{C/M}(i) C Thickness of the layer, defined at nodes. C Subscript i =1-NUMNOD is the node number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitudes 4.E6 cm. C THNSAV(i) C Thickness of the layer, defined at nodes. Extra copy. C Subscript i =1-NUMNOD is the node number (defined in GRIDDR). C Typical magnitudes 4.E6 cm. C TOFST{C/M}(k,m,i) C Vertically-integrated deviatoric stress in the layer (tension C positive) at zero strain-rate, according to the current C tactical choice of linearized rheology. C Subscript k=1-3 indicates Txx, Tyy, or Txy component C respectively. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitudes 4.E15 dyne/cm. C TOUCHLC/M}(m,i) C Indicator of mechanical/isostatic/thermal coupling of a layer C to the subducted slabs. Value 1.00 indicates full coupling, C value 0. indicates no coupling; intermediate values occur C if parameter RAMP.gt.0. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Note: In case of crust, coupling is recorded without regard for C possibly intervening layer of mantle lithosphere. To check C for this, see DNLINK(I,m,i). C Typical magnitudes 0. to 1. C UPLINK(k,m,i) C Information necessary to locate the point in the crustal grid C which is above one of the integration points in the C mantle grid. C Value at k=1 is either: 0. if no crustal layer above; or C : # of crustal element +0.10. C Value at k=2 is internal coordinate S2 in the crustal element. C Value at k=3 is internal coordinate S3 in the crustal element. C Internal coordinate S1 is not stored: S1 = 1.00 - S2 - S3. C Subscript m =1-7 is the integration point number; in the mantle C element (defined by coordinates in BD1). C Subscript i =1-NUMEL is the mantle element number. C Typical magnitudes 27.1, 0.2785, 0.1354 for k=1,3. C VNODE(k,m,i) C Array used for temporary storage of (horizontal) vector C variables defined at the nodes. C Subscript k =1,2 indicates x and y components. C Subscript i =1-NUMNOD is the node number (defined in GRIDDR). C VSLAB{C/M}(k,m,i) C Horizontal velocity vector of subducted slabs beneath the layer. C Subscript k=1,2 indicates x and y components of velocity. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitude 3.E-7 cm/sec. C V{1/2}{C/M}(k,i) C Horizontal velocity vectors at nodes. C 1 indicates beginning of time step; the "predictor." C 2 indicates end of timestep; the "corrector." C {C/M} indicates crustal or mantle values. C Subscript k =1,2 indicates x and y components. C Subscript i =1-NUMNOD is the node number (defined in GRIDDR). C Typical magnitude 1.E-7 cm/sec. C W(i,j) C Array used only in the finite-difference solution of the C diffusion of crustal thickness under the force of gravity. C Gives the coefficient to be applied to the next point West C (from row i, from the North, and column j, from the West) C when computing the new matrix of topographic pressures. C WS(i,j) C Array used only in the finite-difference solution of the C diffusion of crustal thickness under the force of gravity. C Gives part of the coefficient to be applied to the next point C W (from row i, from the North, and column j, from the West) C when computing the new matrix of topographic pressures. C To obtain the whole coefficient W, it must be multiplied by the C timestep and flux/gradient coefficient. C W{1/2}{C/M}(k,i) C Rate of thickening (positive) or thinning of layer. C Note: Includes only thickening/thinning due to pure shear of C layer; effects due to basal drag or gravity-spreading are C added later. C 1 indicates beginning of time step; the "predictor." C 2 indicates end of timestep; the "corrector." C {C/M} INDICATES CRUSTAL OR MANTLE VALUES. C Subscript i =1-NUMNOD is the node number (defined in GRIDDR). C Typical magnitude 3.E-9 cm/sec. C {X/Y}FD(i,j) C Arrays used only in the finite-difference solution of the C diffusion of crustal thickness under the force of gravity. C Gives one Cartesian coordinate at row i (from North to South) C and column j (from West to East). C X or Y indicates which component. C Typical magnitude 1.E8 cm. C {X/Y}IP{C/M}(m,i) C X or Y coordinate of integration points. C System is Cartesian in the plane of a conic projection with C specified tangent. At longitude of Denver, X is locally C East, and Y is locally North, but this is not true C elsewhere. C Subscript m =1-7 is the integration point number in each element C (defined by coordinates in BD1). C Subscript i =1-NUMEL is the element number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitude 9.E7 cm. C {X/Y}NOD{C/M}(i) C X or Y coordinate of nodes. C System is Cartesian in the plane of a conic projection with C East, and Y is locally North, but this is not true e1sewhere. C Subscript i =1-NUMNOD is the node number (defined in GRIDDR). C {C/M} indicates crustal or mantle values. C Typical magnitude 9.E7 cm. C__________________________________________________________________ C FOLLOWING EQUIVALENCES ARE TO COMPRESS STORAGE BY TIME-SHARING C AND DO NOT IMPLY LOGICAL EQUIVALENCE. EQUIVALENCE (STIFF,CODE), + (FORCE,FLOWIN) C- - - - - - - - - - - - - - - - - - - - - - - - - - - CCC EQUIVALENCE (STIFF( 1),C ), CCC 2 (STIFF( 1001),CONSAV), CCC 3 (STIFF( 2001),DRAGN ), CCC 4 (STIFF( 4001),E ), CCC 5 (STIFF( 5001),ES ), CCC 6 (STIFF( 6001),GEONOD), CCC 7 (STIFF(10001),GRADXC), CCC 8 (STIFF(11001),GRADXE), CCC 9 (STIFF(12001),GRADXW), CCC A (STIFF(13001),GRADYC), CCC 1 (STIFF(14001),GRADYN), CCC 2 (STIFF(15001),GRADYS), CCC 3 (STIFF(16001),N ), CCC 4 (STIFF(17001),NS ), CCC 5 (STIFF(18001),PK ), CCC 6 (STIFF(28001),PRHOCP), CCC 7 (STIFF(31001),PRCFD ), CCC 8 (STIFF(32001),P0 ), CCC 9 (STIFF(33001),P1 ), CCC B (STIFF(34001),P2 ) CCC EQUIVALENCE (STIFF(35001),S ), CCC 2 (STIFF(36001),SHEARN), CCC 3 (STIFF(38001),SS ), CCC 4 (STIFF(39001),THNSAV), CCC 5 (STIFF(40001),W ), CCC 6 (STIFF(41001),WS ), CCC 7 (STIFF(42001),XFD ), CCC 8 (STIFF(43001),YFD ) C Note added 18 March 2004: C I have commented out the EQUIVALENCE statements above C because they could cause very serious trouble if a user C changed array-size values such as N200 and N441 and N882, C without also adjusting the alignments in these statements. C I now think it is better to waste some memory than C to return wrong answers! C- - - - - - - - - - - - - - - - - - - - - - - - - - - C FIXED-DIMENSION ARRAYS OF GENERAL USE AND VARIABLE VALUE: DIMENSION ACREEP(3),ALPHAT(2),BCREEP(3),CCREEP(3),CONDUC(2), + DCREEP(3),DIFFUS(2),DVPBYE(2,2),DVPDT(2),ECREEP(3), + FRIC(2),HMAX(2),HMIN(2),RADIO(2),RHOBAR(2),TEMLIM(2), + THICKN(2),VPMEAN(2) C (FIXED-DIMENSION ARRAYS OF LOCAL USE ARE BUILT INTO SUBPROGRAMS; C FIXED-DIMENSION ARRAYS OF GENERAL USE BUT CONSTANT VALUE ARE C CONTAINED IN COMMON BLOCKS.) C DATA (NODES(J,0),J=1,6)/1,1,1,1,1,1/ DATA RINKM /6371./ DATA COLAPS /.FALSE./, FAILUR /.FALSE./ C WRITE (6,10) 10 FORMAT(/ / +' ==================== Program OLD_LARAMY ======================'/ +' H A finite-element program in FORTRAN 77 for modeling H'/ +' H continuum (no-fault) isostatic deformation histories of H'/ +' H continents, employing the flat-Earth approximation. H'/ +' H Note: "Old_" refers to use of the original -VISCOS- and H'/ +' H -DIAMND- to compute the strength of the elements. H'/ +' H by Peter Bird H'/ +' H Department of Earth and Space Sciences H'/ +' H University of California H'/ +' H Los Angeles, CA 90095-1567 H'/ +' ================== Version of 18 March 2004 ================'/ + / /) CALL READIN (TITLE ,FRIC ,ACREEP,ECREEP,BCREEP, + CCREEP,DCREEP,CONDUC,DIFFUS, + RADIO ,THICKN,TEMLIM,RHOBAR, + ALPHAT,VPMEAN,DVPDT ,DVPBYE, + RHOAST,RHOH2O,BIOT ,G ,RADIUS, + X0ELON,Y0NLAT,CPNLAT,IBELOW, + TSLAB0,SIGBOT,PUSHHO,ECLOG , + SLABSZ,PUSHUP,NELROW,NELCOL, + BEGAGE,DELTAT,ENDAGE,DXMAX ,DTHMAX, + RAMP ,NDIFUS,MAXITR,OKTOQT, + VISMAX,ETAMAX,HMIN ,HMAX , + ALLREP,MIDREP,TAPE9 ,RESTRT, + KTIME ,CONRAD,DQDTDA,TSURF , + APLANO,WANDES,VDECOL,OLDGRD, + GWIDE ,GHIGH ,GANGLE) ONEKM=RADIUS/RINKM CALL SETDIM (N200,N441,N882,I50822,N75852,NKDIM,NBAND,NCDIM, + NXL,NDIFF,NELROW,NELCOL,NUMNOD,NUMEL, + DIMERR,NTNM) IF (DIMERR) STOP CALL GRIDDR (INPUT,GANGLE,GHIGH,GWIDE, + NELCOL,NELROW,NUMEL,NUMNOD, + OLDGRD,RESTRT,WANDES, + OUTPUT,AREAC,AREAM, + DETJC,DETJM, + DXSC,DXSM,DYSC,DYSM, + DNLINK,UPLINK, + FROMWC,FROMWM,LISTOP, + NCOLN,NODES, + XIPC,XIPM,XNODC,XNODM, + YIPC,YIPM,YNODC,YNODM) CALL PAST (RESTRT,OLDGRD,NCOLN,XNODC,XNODM,YNODC,YNODM, 2 NUMNOD,THNKC,THNKM,ALPHAT,TEMLIM, 3 THIKC,THIKM,NUMEL,GEOTHA,GEOTHC,GEOTHM,ERATEC, 4 ERATEM,V2C,V2M,W2C,W2M, 5 KTIME,THICKN,NODES,NELROW, 6 CONDUC,RADIO,DQDTDA,TASTH,TSURF, 7 BEGAGE,ONEKM,VISMAX, 8 DNLINK,UPLINK,SIGHC,SIGHBM,SIGZZC,SIGZZM, 9 TAUZZC,TAUZZM,ESUMC,WANDES, A ESUMM,APLANO,RHOBAR,VDECOL, 1 XIPC,XIPM,YIPC,YIPM,FROMWC,FROMWM, 2 ECLOG,RADIUS,SLABSZ,CPNLAT,IBELOW, 3 X0ELON,Y0NLAT,SZZBC,SZZBM,TOUCHC, 4 TOUCHM,VSLABC,VSLABM,OUTVEC,OUTV2, 5 G,CONDNS,DXSC,DXSM,DYSC,DYSM,RHOH2O,RHOAST, 6 PTSC,PTSM,AREAC,AREAM,CODE,NCDIM,DETJC,DETJM, 7 FLOWIN,NDIFF,LWORK,NXL,RAMP,TAUMTC,TAUMTM, 8 OUTSCA,ALPHAC,ALPHAM,TOFSTC,TOFSTM,LISTOP, 9 DGDT1C,DGDT1M,DGDT2C,DGDT2M,DIFFUS,TSLAB0, B CONINT,CONNOD,CONRAD,PUSHUP,HMAX,HMIN,NELCOL) TIME2=BEGAGE ISTEP=0 NPLAST=0 101 CONTINUE ISTEP=ISTEP+1 TIME1=TIME2 DELTAT=MIN(DELTAT,TIME1-ENDAGE) CALL STEP (ACREEP,ALPHAC,ALPHAM,ALPHAT,AREAC,AREAM,BCREEP, 2 BIOT,BOXIT,C,CCREEP,CODE,CONDNS,CONDUC,CONINT,CONNOD,CONRAD, 3 CONSAV,CPNLAT,DCREEP,DELTAT,DELVC,DELVM,DETJC,DETJM, 4 DGDT1C,DGDT1M,DGDT2C,DGDT2M,DIFFUS,DNLINK,DRAGN,DTHMAX,DVB,DVT, 5 DXMAX,DXSC,DXSM,DYSC,DYSM,E,ECLOG,ECREEP,EDOTC,EDOTM, 6 ERATEC,ERATEM,ES,ESUMC,ESUMM,ETAMAX,FAILUR,FLOWIN,FLUXC,FLUXM, 7 FLUXUC,FORCE,FRIC,FROMWC,FROMWM,G,GEONOD,GEOTHA,GEOTHC,GEOTHM, 8 GLUEC,GLUEM,GRADXC,GRADXE,GRADXW,GRADYC,GRADYN,GRADYS, 9 HMAX,HMIN,IBELOW,INTVEC,ISTEP,LISTOP,LWORK,MAXITR,N,NBAND,NCDIM, A NDIFF,NDIFUS,NELROW,NKDIM,NELCOL,NODES,NRD,NRDP1, 1 NS,NTNM,NUMEL,NUMNOD,NXL,OKTOQT,ONEKM,OUTSCA,OUTVEC,OUTV2, 2 OVA,OVB,PHINOD,PK,PRCFD,PRHOCP,PTSC,PTSM,PUSHHO,PUSHUP,P0,P1,P2, 3 QFRICC,QFRICM,QWORK,RADIO,RADIUS,RAMP,RHOAST,RHOH2O,RHOBAR,S, 4 SHEARN,SIGBOT,SIGHBM,SIGHC,SIGHTM,SIGZZC,SIGZZM,SLABSZ,SS,STIFF, 5 SZZBC,SZZBM,TASTH,TAUMTC,TAUMTM,TAUZZC,TAUZZM,TEMLIM,THIKC, 6 THIKM,THNKC,THNKM,THNSAV,TIME1,TIME2,TOFSTC,TOFSTM,TOUCHC, 7 TOUCHM,TSLAB0,TSURF,UPLINK,VISMAX,VNODE,VSLABC,VSLABM, 8 V1C,V1M,V2C,V2M,W,WANDES,WS,W1C,W1M,W2C,W2M, 9 XFD,XIPC,XIPM,XNODC,XNODM,X0ELON,YFD, B YIPC,YIPM,YNODC,YNODM,Y0NLAT,999) NPDONE=(MIDREP+1.)*(BEGAGE-TIME2)/ + MAX((BEGAGE-ENDAGE),1.) +0.001 DOREP=ALLREP .OR. + ((ISTEP.EQ.1).AND.(.NOT.RESTRT)).OR. + (TIME2.LE.ENDAGE) .OR. + (NPDONE.GT.NPLAST) .OR. + FAILUR NPLAST=NPDONE IF (FAILUR.AND.BOXIT) WRITE(6,998) IF (DOREP.AND.TAPE9) CALL TAPE (TITLE,TIME2, + XNODC,XNODM,YNODC,YNODM,THNKC,CONNOD,THNKM, + GEOTHC,GEOTHM,GEOTHA,V2C,V2M,W2C,W2M,ESUMC,ESUMM, + NUMNOD,NUMEL) TERSE=.NOT.((TIME2.LE.ENDAGE).OR.FAILUR) IF (DOREP) CALL REPORT (XIPC,XIPM,YIPC,YIPM, 2 XNODC,XNODM,YNODC,YNODM,TITLE,V2M,NODES, 3 OUTSCA,OUTVEC,V2C,ERATEM,ERATEC, 4 THIKM,THIKC,GEOTHA,GEOTHC,CONDUC, 5 GEOTHM,DNLINK,VPMEAN,DVPBYE,DVPDT, 6 TIME2,NUMNOD,NUMEL, 7 G,HMAX,HMIN,RHOAST,RHOH2O,SIGHC,SIGHBM,SIGZZC, 8 SIGZZM,TAUMTC,TAUMTM,TAUZZC,TAUZZM, 9 TEMLIM,ONEKM,ESUMC,ESUMM,AREAC,AREAM, A CODE,CONDNS,DETJC,DETJM,COLAPS,FLOWIN, 1 NCDIM,NDIFF,NXL,LWORK,W2C,W2M, 2 SZZBC,SZZBM,TOUCHC,TOUCHM, 3 ECLOG,RADIUS,SLABSZ,CPNLAT,IBELOW, 4 X0ELON,Y0NLAT,VSLABC,VSLABM,OUTV2,RAMP, 5 THNKC,UPLINK,TASTH,TSLAB0,FROMWC,FROMWM, 6 WANDES,CONINT,TSURF,PUSHUP,TERSE, 7 NELCOL) IF (TIME2.GT.ENDAGE.AND.(.NOT.FAILUR)) GO TO 101 IF (FAILUR.AND.BOXIT) WRITE(6,999) STOP C C 998 FORMAT('0*****************************************************' + /' *** ***' + /' *** VELOCITY SOLUTION HAS FAILED TO CONVERGE ***' + /' *** OR SUFFERED FROM UNRECOVERABLE ERR0R IN ***' + /' *** SOLUTION OF LINEAR EQUATIONS. ***' + /' *** FOLLOWING REPORT ON TAPE AND PRINTOUT IS ***' + /' *** ISSUED FOR DEBUGGING PURPOSES. ***' + /' *** ONLY THE FOLLOWING QUANTITIES REFLECT THE ***' + /' *** BAD SOLUTION: -BASAL SHEAR STRESSES ***' + /' *** -VELOCITY VECTORS ***' + /' *** -PRINCIPAL STRAIN-RATES ***' + /' *** -PRINCIPAL STRESS ANOMALIES. ***' + /' *** OTHER QUANTITIES RETAIN VALUES FROM BEFORE ***' + /' *** THE BAD VELOCITY SOLUTION. ***' + /' *** ***' + /' *****************************************************') 999 FORMAT('0*****************************************************' + /' *** ***' + /' *** THIS VELOCITY SOLUTION FAILED TO CONVERGE ***' + /' *** OR SUFFERED FROM UNRECOVERABLE ERR0R IN ***' + /' *** SOLUTION OF LINEAR EQUATIONS. ***' + /' *** PREVIOUS REPORT ON PRINTOUT WAS ***' + /' *** ISSUED FOR DEBUGGING PURPOSES. ***' + /' *** ONLY THE FOLLOWING QUANTITIES REFLECT THE ***' + /' *** BAD SOLUTION: -BASAL SHEAR STRESSES ***' + /' *** -VELOCITY VECTORS ***' + /' *** -PRINCIPAL STRAIN-RATES ***' + /' *** -PRINCIPAL STRESS ANOMALIES. ***' + /' *** OTHER QUANTITIES RETAINED VALUES FROM ***' + /' *** BEFORE THE BAD VELOCITY SOLUTION. ***' + /' *** ***' + /' *****************************************************') END C C C SUBROUTINE READIN(TITLE ,FRIC ,ACREEP,ECREEP,BCREEP, + CCREEP,DCREEP,CONDUC,DIFFUS, + RADIO ,THICKN,TEMLIM,RHOBAR, + ALPHAT,VPMEAN,DVPDT ,DVPBYE, + RHOAST,RHOH2O,BIOT ,G ,RADIUS, + X0ELON,Y0NLAT,CPNLAT,IBELOW, + TSLAB0,SIGBOT,PUSHHO,ECLOG , + SLABSZ,PUSHUP,NELROW,NELCOL, + BEGAGE,DELTAT,ENDAGE,DXMAX ,DTHMAX, + RAMP ,NDIFUS,MAXITR,OKTOQT, + VISMAX,ETAMAX,HMIN ,HMAX , + ALLREP,MIDREP,TAPE9 ,RESTRT, + KTIME ,CONRAD,DQDTDA,TSURF , + APLANO,WANDES,VDECOL,OLDGRD, + GWIDE ,GHIGH ,GANGLE) C C READS STRATEGIC AND TACTICAL INPUT PARAMETERS FROM DEVICE 1, C AND ECHOES THEM ON DEVICE 6 WITH ANNOTATIONS. C CHARACTER*80 TITLE LOGICAL ALLREP,OLDGRD,RESTRT,TAPE9 DIMENSION ACREEP(3),ALPHAT(2),BCREEP(3),CCREEP(3), + CONDUC(2),DCREEP(3),DIFFUS(2),DVPBYE(2,2), + DVPDT(2),ECREEP(3),FRIC(2),HMAX(2),HMIN(2), + RADIO(2),RHOBAR(2),TEMLIM(2),THICKN(2),VPMEAN(2) 1 FORMAT(A80) WRITE(6,10) 10 FORMAT(' ****************************************************'/ + ' IT IS THE USERS RESPONSIBILITY TO INPUT ALL OF THE'/ + ' FOLLOWING NUMERICAL QUANTITIES IN CONSISTENT UNITS,'/ + ' SUCH AS Systeme-Internationale (SI) OR cm-g-s (cgs).'/ + ' NOTE THAT TIME UNIT MUST BE THE SECOND (HARD-CODED).'/ + ' ****************************************************') READ(1,*) WRITE(6,11) 11 FORMAT(/ / /' ========== STRATEGIC PARAMETERS (DEFINE THE REAL-', + 'EARTH PROBLEM) ======') TITLE=' '// + ' ' READ(1,1,IOSTAT=IOS) TITLE WRITE(6,101) TITLE 101 FORMAT(/ / /' ',A80/ + ' CRUST MANTLE PARAMETER (LINE ABOVE IS TITLE)') READ(1,*) READ(1,*) FRIC(1),FRIC(2) WRITE(6,102) FRIC(1),FRIC(2) 102 FORMAT(' ',2F10.3,' COEFFICIENT OF FRICTION') READ(1,*) ACREEP(1),ACREEP(3) WRITE(6,103) ACREEP(1),ACREEP(3) 103 FORMAT(' ',1P,2E10.2,' PRE-EXPONENTIAL SHEAR STRESS CONSTANT', + ' FOR CREEP') READ(1,*) ACREEP(2) WRITE(6,104) ACREEP(2) 104 FORMAT(' ',1P,E10.2,' N/A PRE-EXPONENTIAL FOR LOWER', + ' CRUST, BELOW CONRAD') READ(1,*) ECREEP(1),ECREEP(3) WRITE(6,105) ECREEP(1),ECREEP(3) 105 FORMAT(' ',2F10.6,' STRAIN-RATE EXPONENT FOR CREEP (1/N)') READ(1,*) ECREEP(2) IF (ECREEP(2).NE.ECREEP(1)) THEN ECREEP(2)=ECREEP(1) WRITE(6,1059) 1059 FORMAT(' ',' WARNING! ALGEBRA IN -PWAZUL- REQUIRES A', + ' UNIFORM CREEP EXPONENT IN CRUST.' + /' YOUR INPUT VALUE FOR THE LOWER CRUST HAS ', + ' BEEN CHANGED TO MAKE THIS TRUE.') ENDIF WRITE(6,106) ECREEP(2) 106 FORMAT(' ',F10.6,' N/A STRAIN-RATE EXPONENT FOR ', + 'LOWER CRUST, BELOW CONRAD') READ(1,*) BCREEP(1),BCREEP(3) WRITE(6,107) BCREEP(1),BCREEP(3) 107 FORMAT(' ',2F10.0,' B FOR CREEP =(ACTIVATION ENERGY)/R/N (IN K)') READ(1,*) BCREEP(2) WRITE(6,108) BCREEP(2) 108 FORMAT(' ',F10.0,' N/A B FOR CREEP OF LOWER CRUST,', + ' BELOW CONRAD') READ(1,*) CCREEP(1),CCREEP(3) WRITE(6,109) CCREEP(1),CCREEP(3) 109 FORMAT(' ',1P,2E10.2,' C FOR CREEP = DERIVATIVE OF B WITH', + ' RESPECT TO DEPTH') READ(1,*) CCREEP(2) WRITE(6,110) CCREEP(2) 110 FORMAT(' ',1P,E10.2,' N/A C FOR CREEP OF LOWER CRUST,', + ' BELOW CONRAD') READ(1,*) DCREEP(1),DCREEP(3) WRITE(6,111) DCREEP(1),DCREEP(3) 111 FORMAT(' ',1P,2E10.2,' MAXIMUM SHEAR STRESS UNDER ANY', + ' CONDITIONS') READ(1,*) DCREEP(2) WRITE(6,112) DCREEP(2) 112 FORMAT(' ',1P,E10.2,' N/A MAXIMUM SHEAR FOR LOWER CRUST,', + ' BELOW CONRAD') READ(1,*) CONDUC(1),CONDUC(2) WRITE(6,113) CONDUC(1),CONDUC(2) 113 FORMAT(' ',1P,2E10.2,' THERMAL CONDUCTIVITY (ENERGY/', + 'LENGTH/SEC/DEG)') READ(1,*) DIFFUS(1),DIFFUS(2) WRITE(6,114) DIFFUS(1),DIFFUS(2) 114 FORMAT(' ',1P,2E10.2,' THERMAL DIFFUSIVITY (LENGTH**2/', + 'SEC)') READ(1,*) RADIO(1),RADIO(2) WRITE(6,115) RADIO(1),RADIO(2) 115 FORMAT(' ',1P,2E10.2,' RADIOACTIVE HEAT PRODUCTION', + ' (ENERGY/VOLUME/SEC)') READ(1,*) THICKN(1),THICKN(2) WRITE(6,116) THICKN(1),THICKN(2) 116 FORMAT(' ',1P,2E10.2,' THICKNESS OF LAYER IN NORMAL', + ' CONTINENT') READ(1,*) TEMLIM(1),TEMLIM(2) WRITE(6,117) TEMLIM(1),TEMLIM(2) 117 FORMAT(' ',2F10.0,' CONVECTING TEMPERATURE (TMAX) IN', + ' DEGREES KELVIN') READ(1,*)(RHOBAR(I),I=1,2) WRITE(6,118) RHOBAR(1),RHOBAR(2) 118 FORMAT(' ',1P,2E10.2,' DENSITY,', + ' CORRECTED TO 0 DEGREES KELVIN') READ(1,*) ALPHAT(1),ALPHAT(2) WRITE(6,119) ALPHAT(1),ALPHAT(2) 119 FORMAT(' ',1P,2E10.2,' VOLUMETRIC THERMAL EXPANSION', + ' (1/VOL)*(D.VOL/D.T)') READ(1,*) VPMEAN(1),VPMEAN(2) WRITE(6,120) VPMEAN(1),VPMEAN(2) 120 FORMAT(' ',1P,2E10.2,' MEAN P-WAVE VELOCITY (VP) AT 0 K', + ' AND HIGH PRESSURE') READ(1,*) DVPDT(1),DVPDT(2) WRITE(6,121) DVPDT(1),DVPDT(2) 121 FORMAT(' ',1P,2E10.2,' (1/VP)*(D.VP/D.T): TEMPERATURE', + ' SENSITIVITY OF VP') READ(1,*) DVPBYE(1,1),DVPBYE(1,2) WRITE(6,122) DVPBYE(1,1),DVPBYE(1,2) 122 FORMAT(' ',1P,2E10.2,' (DELTA.VP/VP): STRAIN(EZZ)-INDU', + 'CED ANISOTROPY IN VP') READ(1,*) DVPBYE(2,1),DVPBYE(2,2) WRITE(6,123) DVPBYE(2,1),DVPBYE(2,2) 123 FORMAT(' ',1P,2E10.2,' CHARACTERISTIC STRAIN TO DEVELOP A', + 'NISOTROPY') READ(1,*) RHOAST WRITE(6,124) RHOAST 124 FORMAT(' ',1P,E10.3,' DENSITY OF ASTHENOSPHERE', + ' (ADJUST TO CORRECT ALL ELEVATION)') READ(1,*) RHOH2O WRITE(6,125) RHOH2O 125 FORMAT(' ',1P,E10.2,' DENSITY OF GROUNDWATER, LAKES, AND OCEANS') READ(1,*) BIOT WRITE(6,126) BIOT 126 FORMAT(' ',F10.4,' EFFECTIVE-PRESSURE (BIOT) COEFFICIENT,', + ' 0.0 TO 1.0') BIOT=MAX(0.0,MIN(1.0,BIOT)) READ(1,*) G WRITE(6,127) G 127 FORMAT(' ',1P,E10.2,' GRAVITATIONAL ACCELERATION', + ' (LENGTH/SEC/SEC)') READ(1,*) RADIUS WRITE(6,128) RADIUS 128 FORMAT(' ',1P,E10.2,' RADIUS OF EARTH', + ' (EFFECTIVELY DEFINES YOUR LENGTH UNIT)') READ(1,*) X0ELON WRITE(6,129) X0ELON 129 FORMAT(' ',F10.2,' LONGITUDE OF X/Y ORIGIN IN DEGREES', + ' (EAST = +, WEST = -)') READ(1,*) Y0NLAT WRITE(6,130) Y0NLAT 130 FORMAT(' ',F10.2,' LATITUDE OF X/Y ORIGIN IN DEGREES', + ' (NORTH = +, SOUTH = -)') READ(1,*) CPNLAT WRITE(6,131) CPNLAT 131 FORMAT(' ',F10.2,' LATITUDE OF BASE-MAP CONIC PROJECTION', + ' TANGENT IN DEGREES (NORTH = +)') IF (ABS(CPNLAT).LT.0.01) CPNLAT=0.01 READ(1,*) IBELOW WRITE(6,132) IBELOW 132 FORMAT(' ',I10,' BELOW-INDEX: SELECTS PLATE MODEL USED', + ' FOR BASAL BOUNDARY'/ + ' CONDITIONS: 0=NONE,1=N.AMER./NORTH,', + '2=N.AMER./SOUTH,3=S.AMER.,4=ASIA') READ(1,*) READ(1,*) TSURF WRITE(6,305) TSURF 305 FORMAT(' ',F10.1,' SURFACE TEMPERATURE IN DEGREES KELVIN') READ(1,*) TSLAB0 WRITE(6,133) TSLAB0 133 FORMAT(' ',F10.1,' TEMPERATURE OF SLAB-TOP SHEAR ZONE', + ' AT 1000 KM INLAND, IN KELVIN') READ(1,*) SIGBOT WRITE(6,134) SIGBOT 134 FORMAT(' ',1P,E10.2,' SHEAR STRESS LIMIT ON BASE OF', + ' CONTINENT (MELANGE STRENGTH)') READ(1,*) WANDES WRITE(6,307) WANDES 307 FORMAT(' ',1P,E10.2,' INITIAL WIDTH OF CORDILLERA,', + ' MEASURED TRENCH-TO-PLAINS', + ' (OR 0.0 FOR NONE)') READ(1,*) PUSHHO WRITE(6,135) PUSHHO 135 FORMAT(' ',1P,E10.2,' EXTRA SHEAR STRESS APPLIED TO', + ' "LEFT" MARGIN FOREARC ONLY') READ(1,*) ECLOG WRITE(6,136) ECLOG 136 FORMAT(' ',1P,E10.2,' EXCESS-WEIGHT/UNIT-AREA OF NEW LITHOSPHER', + 'E WITH RESPECT TO ASTHENOSPHERE') READ(1,*) SLABSZ WRITE(6,137) SLABSZ 137 FORMAT(' ',1P,E10.2,' THERMAL EXCESS-WEIGHT/UNIT-AREA', + ' AT 100 MA WITH REPECT TO NEW LITHOSPHERE') READ(1,*) PUSHUP WRITE(6,138) PUSHUP 138 FORMAT(' ',1P,E10.2,' NON-ISOSTATIC FLEXURAL UPLIFT BY SLAB,', + ' (IN THE FOREARC REGION ONLY)') READ(1,*) WRITE(6,12) 12 FORMAT(/ / /' ============== TACTICAL PARAMETERS', + ' (HOW TO FIND THE SOLUTION) ============') READ(1,*) NELROW WRITE(6,201) NELROW 201 FORMAT(/ / /' ',I10,' NUMBER OF ROWS OF 2-ELEMENT', + ' QUADRILATERALS (ROWS ARE PERPENDICULAR TO TRENCH)') READ(1,*) NELCOL WRITE(6,202) NELCOL 202 FORMAT(' ',I10,' NUMBER OF COLUMNS OF 2-ELEMENT', + ' QUADRILATERALS (COLUMNS ARE PARALLEL TO TRENCH)') READ(1,*) BEGAGE WRITE(6,203) BEGAGE 203 FORMAT(' ',1P,E10.4,' BEGINNING OF CALCULATION', + ' (POSITIVE SECONDS BEFORE PRESENT)') READ(1,*) DELTAT WRITE(6,204) DELTAT 204 FORMAT(' ',1P,E10.4,' SIZE OF TIME STEPS (POSITIVE', + ' SECONDS); MAY BE REDUCED BY PROGRAM') READ(1,*) ENDAGE WRITE(6,205) ENDAGE 205 FORMAT(' ',1P,E10.4,' ENDING OF CALCULATION', + ' (POSITIVE SECONDS BEFORE PRESENT)') READ(1,*) DXMAX WRITE(6,206) DXMAX 206 FORMAT(' ',1P,E10.2,' MAXIMUM HORIZONTAL DISPLACEMENT OF ANY' + ,' NODE IN ONE TIME STEP') READ(1,*) DTHMAX WRITE(6,207) DTHMAX 207 FORMAT(' ',1P,E10.2,' MAXIMUM CHANGE IN LAYER THICKNESS BY PURE' + ,' SHEAR ALLOWED IN ONE TIME STEP') READ(1,*) RAMP WRITE(6,208) RAMP 208 FORMAT(' ',1P,E10.2,' WIDTH OF LINEAR RAMP SMOOTHING OF SLAB', + ' WEIGHT') READ(1,*) NDIFUS WRITE(6,209) NDIFUS 209 FORMAT(' ',I10,' MAXIMUM NUMBER OF CRUSTAL-THICKNESS', + ' SMOOTHINGS EACH TIMESTEP (ABOUT 1000)') READ(1,*) MAXITR WRITE(6,210) MAXITR 210 FORMAT(' ',I10,' MAXIMUM ITERATIONS WITHIN VELOCITY SOLUTION', + ' IN EACH TIMESTEP') READ(1,*) OKTOQT WRITE(6,211) OKTOQT 211 FORMAT(' ',F10.6,' ACCEPTABLE RMS FRACTIONAL ERR0R (STOPS', + ' ITERATION EARLY)') READ(1,*) VISMAX WRITE(6,212) VISMAX 212 FORMAT(' ',1P,E10.2,' MAXIMUM AVERAGE VISCOSITY ALLOWED FOR ANY', + ' LAYER (APPLIES TO WHOLE THICKNESS, NOT LOCALLY)') READ(1,*) ETAMAX WRITE(6,213) ETAMAX 213 FORMAT(' ',1P,E10.2,' MAXIMUM LAYER/LAYER COUPLING ALLOWED', + ' (STRESS/VELOCITY-DIFFERENCE)') READ(1,*) READ(1,*) HMIN(1),HMIN(2) WRITE(6,214) HMIN(1),HMIN(2) 214 FORMAT(/' CRUST MANTLE LIMITS ON LAYER THICKNESSES:'/ + ' ',1P,2E10.2,' MINIMUM THICKNESS', + ' (TRIGGERS VOLUME ADDITION)') READ(1,*) HMAX(1),HMAX(2) WRITE(6,215) HMAX(1),HMAX(2) 215 FORMAT(' ',1P,2E10.2,' MAXIMUM THICKNESS', + ' (TRIGGERS VOLUME REDUCTION)') READ(1,*) ALLREP WRITE(6,216) ALLREP 216 FORMAT(' ',L10,' ALLREP: SHOULD REPORTS BE PRODUCED', + ' AT EVERY TIMESTEP ? (USE ONLY FOR DEBUGGING)') READ(1,*) MIDREP WRITE(6,217) MIDREP 217 FORMAT(' ',I10,' NUMBER OF INTERMEDIATE REPORTS (WHEN ALLREP=F)') READ(1,*) TAPE9 WRITE(6,218) TAPE9 218 FORMAT(' ',L10,' THAT DETAILED REPORTS ARE OUTPUT ON DEVICE 9', + ' (USUALLY T)') READ(1,*) WRITE(6,13) 13 FORMAT(/ / /' ================== INITIALIZATION PARAMETERS', + ' (INITIAL CONDITIONS) ========') READ(1,*) RESTRT WRITE(6,301) RESTRT 301 FORMAT(/ / /' ',L10,' RESTART: IF = T, THEN RESTART FROM OLD', + ' REPORT; READ FROM DEVICE 8') READ(1,*) KTIME WRITE(6,302) KTIME 302 FORMAT(' ',I10,' IF (RESTART): ORDINAL NUMBER OF OLD REPORT', + ' IN DEVICE 8 FILE') READ(1,*) WRITE(6,14) 14 FORMAT(' ------- NEXT LINES ARE USED ONLY IF RESTRT = F', + '--------------------------') READ(1,*) CONRAD WRITE(6,303) CONRAD 303 FORMAT(' ',1P,E10.2,' INITIAL DEPTH OF CONRAD DISCONTINUITY', + ' IN THE CRUST OF THE PLAINS') READ(1,*) DQDTDA WRITE(6,304) DQDTDA 304 FORMAT(' ',1P,E10.2,' INITIAL HEAT-FLOW OF PLAINS', + ' (ENERGY/LENGTH**2/SEC)') READ(1,*) APLANO WRITE(6,306) APLANO 306 FORMAT(' ',1P,E10.2,' INITIAL HEIGHT OF ALTIPLANO IN CORDILLERA', + ' (OR 0.0 FOR NONE)') IF ((APLANO.LE.0.0).AND.(.NOT.RESTRT)) WANDES=0.0 READ(1,*) VDECOL WRITE(6,308) VDECOL 308 FORMAT(' ',1P,E10.2,' GROSS ESTIMATE OF DETACHMENT', + ' VELOCITY BETWEEN CRUST AND MANTLE') READ(1,*) OLDGRD IF (RESTRT) OLDGRD=.FALSE. WRITE(6,309) OLDGRD 309 FORMAT(' ',L10,' OLDGRD : SHALL EXISTING GRID OF NODES', + ' BE READ (FROM DEVICE 8, IN TRUNCATED REPORT FORMAT)?') READ(1,*) READ(1,*) WRITE(6,15) 15 FORMAT(' -------- FOLLOWING LINES DEFINE AN AUTOMATICALLY-', + 'GENERATED GRID, AND -----'/ + ' ----------- ARE USED ONLY IF RESTRT = F AND ', + 'OLDGRD = F -----------------') READ(1,*) GWIDE WRITE(6,310) GWIDE 310 FORMAT(' ',1P,E10.3,' "WIDTH" OF GRID FROM "LEFT"', + ' (TRENCH SIDE) TO "RIGHT" (INLAND SIDE)') READ(1,*) GHIGH WRITE(6,311) GHIGH 311 FORMAT(' ',1P,E10.3,' "HEIGHT" OF GRID FROM "TOP"', + ' (NODE ROW 1) TO "BOTTOM" (LAST ROW)') READ(1,*) GANGLE WRITE(6,312) GANGLE 312 FORMAT(' ',F10.2,' ANGLE GRID IS ROTATED FROM', + ' ("RIGHT"= +X, "TOP" = +Y), IN DEGREES COUNTERCLOCKWISE') READ(1,*,END=3129) 3129 WRITE(6,16) 16 FORMAT(/ / /' ===== POST-PROCESSING PLOT CONTROL PARAMETERS', + ' (NOT USED BY LARAMY) ====='/ + ' ( OMITTED )') RETURN END C C C SUBROUTINE SETDIM (N200,N441,N882,I50822,N75852,NKDIM,NBAND, + NCDIM,NXL,NDIFF,NELROW,NELCOL,NUMNOD, + NUMEL,DIMERR,NTNM) C C CALCULATES AMOUNTS OF VARIABLE STORAGE SPACE NEEDED VS. AVAILABLE C LOGICAL DIMERR DATA NXEL/1173/,NXNOD/23/,NX2NOD/2/,NXKDIM/2/,NXNXL/1/ NUMEL=2*NELROW*NELCOL NUMNOD=(2*NELROW+1)*(2*NELCOL+1) NTNM=2*NUMNOD NDIFF=2*(2*NELCOL+1) NBAND=2*NDIFF+1 C NBAND IS ONE-SIDED AND DOES NOT COUNT THE CENTRAL DIAGONAL NKDIM=(3*NBAND+16)*NTNM C NKDIM IS PER INSTRUCTIONS FOR GENERAL BAND MATRIX IN DGBF WRITEUP NCDIM=(3*NDIFF+16)*NUMNOD C NCDIM IS ALSO, BUT ONLY ONE D.O.F. PER NODE NXL=NTNM I11=NUMEL*NXEL I12=N200*NXEL I21=NUMNOD*NXNOD I22=N441*NXNOD I31=NTNM*NX2NOD I32=N882*NX2NOD I41=NKDIM*NXKDIM I42=I50822*NXKDIM I51=NXL*NXNXL I52=N75852*NXNXL NSUM1=I11+I21+I31+I41+I51 NSUM2=I12+I22+I32+I42+I52 WRITE(6,1)NUMEL,N200,NXEL,I11,I12, + NUMNOD,N441,NXNOD,I21,I22, + NTNM,N882,NX2NOD,I31,I32, + NKDIM,I50822,NXKDIM,I41,I42, + NXL,N75852,NXNXL,I51,I52, + NSUM1,NSUM2 1 FORMAT(/ / / 2 ' VARIABLE STORAGE REPORT FROM SUBPROGRAM SETDIM:'/ / 3 ' VARIABLE = FORMULA',29X,' = VALUE VS.ALLOWED', 4 ' MULTIPLIER WORDS-USED WORDS-ALLOWED'/ / 5 '0NUMEL = 2*NELROW*NELCOL ',10X,'=', 6 I7,I12,I12,I12,I15/ 7 '0NUMNOD = (2*NELROW+1)*(2*NELCOL+1) ','=', 8 I7,I12,I12,I12,I15/ 9 '0NTNM = 2*NUMNOD',26X,'=', A I7,I12,I12,I12,I15/ 1 '0NKDIM = NTNM*(6*NDIFF+19)',17X,'=', 2 I7,I12,I12,I12,I15/ 3 ' NDIFF=2*(2*NELCOL+1) '/ 4 '0NXL = NTNM ',18X,'=', 5 I7,I12,I12,I12,I15/ 6 78X,' _______ _______'/ 7 78X,I12,I15) DIMERR=(NUMEL.GT.N200).OR. + (NUMNOD.GT.N441).OR. + (NTNM.GT.N882).OR. + (NKDIM.GT.I50822).OR. + (NXL.GT.N75852) IF(DIMERR) WRITE(6,2) 2 FORMAT('0ONE OR MORE VARIABLES ABOVE ARE TOO LARGE.'/ + '0ALL OF THEM MUST BE WITHIN LIMITS BEFORE EXECUTION', + ' CAN PROCEED.'/ + '0INCREASE VALUES OF N200, N441, N882, I50822,', + ' AND/OR N75852', + ' IN PROGRAM LARAMY PARAMETER STATEMENT.') RETURN END C C C SUBROUTINE GRIDDR (INPUT,GANGLE,GHIGH,GWIDE, + NELCOL,NELROW,NUMEL,NUMNOD, + OLDGRD,RESTRT,WANDES, + OUTPUT,AREAC,AREAM, + DETJC,DETJM, + DXSC,DXSM,DYSC,DYSM, + DNLINK,UPLINK, + FROMWC,FROMWM,LISTOP, + NCOLN,NODES, + XIPC,XIPM,XNODC,XNODM, + YIPC,YIPM,YNODC,YNODM) C C INITIALIZES TOPOLOGY OF THE FINITE ELEMENT GRIDS. C IF (.NOT.RESTRT) THEN C IF (OLDGRD) THEN C READS IN OLD GRID C ELSE C BUILDS A REGUALAR GRID C IF (WANDES.GT.0.0) THEN C ADJUSTS NODE POSITIONS TO SIGNIFICANT POINTS C ENDIF C ENDIF C COMPUTES AREAS, DERIVITIVES, LOCATES INTEGRATION POINTS, C LINKS GRIDS, AND FINDS DISTANCES FROM COAST C ENDIF C LOGICAL FAILUR,LISTOP,OLDGRD,RESTRT COMMON /GROBOW/ HANDES,XANDES,NPOINT,NALT1,NALT2 DIMENSION HANDES(5),XANDES(5) DIMENSION AREAC(NUMEL),AREAM(NUMEL), + DETJC(7,NUMEL),DETJM(7,NUMEL), + DXSC(6,7,NUMEL),DXSM(6,7,NUMEL), + DYSC(6,7,NUMEL),DYSM(6,7,NUMEL), + DNLINK(3,7,NUMEL),UPLINK(3,7,NUMEL), + FROMWC(7,NUMEL),FROMWM(7,NUMEL), + LISTOP(NUMEL),NODES(6,0:NUMEL), + XIPC(7,NUMEL),XIPM(7,NUMEL), + XNODC(NUMNOD),XNODM(NUMNOD), + YIPC(7,NUMEL),YIPM(7,NUMEL), + YNODC(NUMNOD),YNODM(NUMNOD) C C NUMEL=2*NELROW*NELCOL NROWN=2*NELROW+1 NCOLN=2*NELCOL+1 C NUMNOD=NROWN*NCOLN C C TOPOLOGY OF GRID IS ALWAYS THE SAME: C DO 20 I=1,NELROW DO 10 J=1,NELCOL K1=2*NELCOL*(I-1)+2*(J-1)+1 NODES(1,K1)=2*NCOLN*(I-1)+2*(J-1)+1 NODES(2,K1)=NODES(1,K1)+2*NCOLN NODES(3,K1)=NODES(1,K1)+2 NODES(4,K1)=NODES(1,K1)+NCOLN NODES(5,K1)=NODES(4,K1)+1 NODES(6,K1)=NODES(1,K1)+1 K2=K1+1 NODES(1,K2)=NODES(2,K1)+2 NODES(2,K2)=NODES(3,K1) NODES(3,K2)=NODES(2,K1) NODES(4,K2)=NODES(5,K1)+1 NODES(5,K2)=NODES(5,K1) NODES(6,K2)=NODES(2,K1)+1 10 CONTINUE 20 CONTINUE C IF (RESTRT) RETURN C IF (OLDGRD) THEN C C READ IN AN EXISTING GRID C KTIME=1 CALL GOON (KTIME,OLDGRD, + XNODC,XNODM,YNODC,YNODM,NUMNOD) ELSE C C BUILD GRID IN UPRIGHT ORIENTATION ("TOP" TOWARD +Y) C DX=GWIDE/(2*NELCOL) DY=GHIGH/(2*NELROW) DO 40 I=1,NROWN Y=GHIGH-(I-1)*DY DO 30 J=1,NCOLN K=(I-1)*NCOLN+J YNODC(K)=Y XNODC(K)=(J-1)*DX XNODM(K)=XNODC(K) YNODM(K)=YNODC(K) 30 CONTINUE 40 CONTINUE C C IF CORDILLERA IS DESIRED, NODES MUST BE FUDGED TO LIE ON ITS C BREAKS IN SLOPE. C ALSO, MANTLE GRID MUST BE COMPRESSED TO BEGIN AT INLAND EDGE C OF ALTIPLANO. C IF (WANDES.GT.0.0) THEN XALT1=WANDES*XANDES(NALT1) XALT2=WANDES*XANDES(NALT2) JALT1=XALT1/DX+0.5 JALT1=MAX(JALT1,2) JALT2=XALT2/DX+0.5 JALT2=MAX(JALT2,JALT1+1) DO 60 J=1,NCOLN IF (J.LT.JALT1) THEN X=XALT1*(J-1.)/(JALT1-1.) ELSE IF (J.LT.JALT2) THEN X=XALT1+((XALT2-XALT1)*(J-JALT1))/(JALT2-JALT1) ELSE X=XALT2+((GWIDE-XALT2)*(J-JALT2))/(NCOLN-JALT2) ENDIF DO 50 I=1,NROWN K=(I-1)*NCOLN+J XNODC(K)=X 50 CONTINUE 60 CONTINUE DO 80 J=1,NCOLN X=XALT2+(J-1.)*(GWIDE-XALT2)/(NCOLN-1.) DO 70 I=1,NROWN K=(I-1)*NCOLN+J XNODM(K)=X 70 CONTINUE 80 CONTINUE ENDIF C C ROTATE TO DESIRED ANGLE C DO 100 I=1,NUMNOD X=XNODC(I) Y=YNODC(I) R=SQRT(X**2+Y**2) ANGLE=ATAN2F(Y,X) ANGLE=ANGLE+GANGLE/57.298 XNODC(I)=R*COS(ANGLE) YNODC(I)=R*SIN(ANGLE) X=XNODM(I) Y=YNODM(I) R=SQRT(X**2+Y**2) ANGLE=ATAN2F(Y,X) ANGLE=ANGLE+GANGLE/57.298 XNODM(I)=R*COS(ANGLE) YNODM(I)=R*SIN(ANGLE) 100 CONTINUE C C ADJUST ORIGIN TO CENTER C XSUM=0. YSUM=0. DO 110 I=1,NUMNOD XSUM=XSUM+XNODC(I) YSUM=YSUM+YNODC(I) 110 CONTINUE XMEAN=XSUM/NUMNOD YMEAN=YSUM/NUMNOD DO 120 I=1,NUMNOD XNODC(I)=XNODC(I)-XMEAN YNODC(I)=YNODC(I)-YMEAN XNODM(I)=XNODM(I)-XMEAN YNODM(I)=YNODM(I)-YMEAN 120 CONTINUE ENDIF CALL AREAS (NODES,AREAC,XNODC,YNODC,NUMNOD,NUMEL) CALL AREAS (NODES,AREAM,XNODM,YNODM,NUMNOD,NUMEL) CALL INTERP (XNODC,NODES,NUMEL,NUMNOD,XIPC) CALL INTERP (YNODC,NODES,NUMEL,NUMNOD,YIPC) CALL INTERP (XNODM,NODES,NUMEL,NUMNOD,XIPM) CALL INTERP (YNODM,NODES,NUMEL,NUMNOD,YIPM) CALL INLAND (INPUT,XIPC,YIPC,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMWC) CALL INLAND (INPUT,XIPM,YIPM,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMWM) CALL DERIV (NUMEL,NUMNOD,NODES,XNODC,YNODC,AREAC, + DETJC,DXSC,DYSC,NUMBAD,LISTOP) CALL DERIV (NUMEL,NUMNOD,NODES,XNODM,YNODM,AREAM, + DETJM,DXSM,DYSM,NUMBAD,LISTOP) CALL LINKER (NELCOL,NUMEL,XIPM,YIPM, + DETJC,XIPC,YIPC,XNODC,YNODC, + NUMNOD,NODES,AREAC,UPLINK,FAILUR) CALL LINKER (NELCOL,NUMEL,XIPC,YIPC, + DETJM,XIPM,YIPM,XNODM,YNODM, + NUMNOD,NODES,AREAM,DNLINK,FAILUR) RETURN END C C C SUBROUTINE PAST(RESTRT,OLDGRD,NCOLN,XNODC,XNODM,YNODC,YNODM, 2 NUMNOD,THNKC,THNKM,ALPHAT,TEMLIM, 3 THIKC,THIKM,NUMEL,GEOTHA,GEOTHC,GEOTHM,ERATEC, 4 ERATEM,VC,VM,WC,WM,KTIME,THICKN,NODES,NELROW, 5 CONDUC,RADIO,DQDTDA,TASTH,TSURF, 6 BEGAGE,ONEKM,VISMAX, 7 DNLINK,UPLINK,SIGHC,SIGHBM,SIGZZC,SIGZZM, 8 TAUZZC,TAUZZM,ESUMC,WANDES, 9 ESUMM,APLANO,RHOBAR,VDECOL, A XIPC,XIPM,YIPC,YIPM,FROMWC,FROMWM, 1 ECLOG,RADIUS,SLABSZ,CPNLAT,IBELOW, 2 X0ELON,Y0NLAT,SZZBC,SZZBM,TOUCHC, 3 TOUCHM,VSLABC,VSLABM,OUTVEC,OUTV2, 4 G,CONDNS,DXSC,DXSM,DYSC,DYSM,RHOH2O,RHOAST, 5 PTSC,PTSM,AREAC,AREAM,CODE,NCDIM,DETJC,DETJM, 6 FLOWIN,NDIFF,LWORK,NXL,RAMP,TAUMTC,TAUMTM, 7 OUTSCA,ALPHAC,ALPHAM,TOFSTC,TOFSTM,LISTOP, 8 DGDT1C,DGDT1M,DGDT2C,DGDT2M,DIFFUS,TSLAB0, 9 CONINT,CONNOD,CONRAD,PUSHUP,HMAX,HMIN, B NELCOL) C C ESTABLISHES INITIAL CONDITIONS IN ARRAYS FOR BEGINNING OF LARAMIDE C OROGENY (OR ANY MIDPOINT CONTAINED ON TAPE, IF RESTRT) C DOUBLE PRECISION CODE,FLOWIN LOGICAL FAILUR,LISTOP,LOCKIN,LOCKWC,OLDGRD,RESTRT,STRTUP DIMENSION ALPHAC(3,3,7,NUMEL),ALPHAM(3,3,7,NUMEL), 2 ALPHAT(2),AREAC(NUMEL),AREAM(NUMEL),CODE(NCDIM), 3 CONDNS(NUMNOD),CONDUC(2),CONINT(7,NUMEL), 4 CONNOD(NUMNOD),DETJC(7,NUMEL),DETJM(7,NUMEL), 5 DGDT1C(4,7,NUMEL),DGDT1M(4,7,NUMEL), 6 DGDT2C(4,7,NUMEL),DGDT2M(4,7,NUMEL),DIFFUS(2), 7 DXSC(6,7,NUMEL),DXSM(6,7,50),DYSC(6,7,50),DYSM(6,7,50), 8 ERATEC(4,7,NUMEL),ERATEM(4,7,NUMEL), 9 ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL),FLOWIN(NUMNOD), A FROMWC(7,NUMEL),FROMWM(7,NUMEL),GEOTHA(4,7,NUMEL), 1 GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL),HMAX(2),HMIN(2) DIMENSION DNLINK(3,7,NUMEL),UPLINK(3,7,NUMEL),LISTOP(NUMEL), 2 LWORK(NXL),NODES(6,0:NUMEL),OUTSCA(7,NUMEL), 3 OUTVEC(2,7,NUMEL),OUTV2(2,7,NUMEL), 4 PTSC(2,7,NUMEL),PTSM(2,7,50), 5 RADIO(2),RHOBAR(2), 6 SIGHC(2,7,NUMEL),SIGHBM(2,7,NUMEL), 7 SIGZZC(7,NUMEL),SIGZZM(7,NUMEL), 8 SZZBC(7,NUMEL),SZZBM(7,NUMEL), 9 TAUMTC(3,7,NUMEL),TAUMTM(3,7,NUMEL), A TAUZZC(7,NUMEL),TAUZZM(7,NUMEL),TEMLIM(2) DIMENSION THIKC(7,NUMEL),THIKM(7,NUMEL),THICKN(2), 2 THNKC(NUMNOD),THNKM(NUMNOD), 3 TOFSTC(3,7,NUMEL),TOFSTM(3,7,NUMEL), 4 TOUCHC(7,NUMEL),TOUCHM(7,NUMEL), 5 VC(2,NUMNOD),VM(2,NUMNOD), 6 VSLABC(2,7,NUMEL),VSLABM(2,7,NUMEL), 7 WC(NUMNOD),WM(NUMNOD), 8 XIPC(7,NUMEL),XIPM(7,NUMEL), 9 XNODC(NUMNOD),XNODM(NUMNOD), A YIPC(7,NUMEL),YIPM(7,NUMEL), 1 YNODC(NUMNOD),YNODM(NUMNOD) DATA LOCKIN/.FALSE./, LOCKWC/.FALSE./ TEMPC(Z,M,I)=MIN(TEMLIM(1),GEOTHC(1,M,I) + +GEOTHC(2,M,I)*Z + +GEOTHC(3,M,I)*Z**2 + +GEOTHC(4,M,I)*Z**3) TEMPM(Z,M,I)=MIN(TEMLIM(2),GEOTHM(1,M,I) + +GEOTHM(2,M,I)*Z + +GEOTHM(3,M,I)*Z**2 + +GEOTHM(4,M,I)*Z**3) DO 60 K=1,3 DO 59 M=1,7 DO 58 I=1,NUMEL TOFSTC(K,M,I)=0. TOFSTM(K,M,I)=0. ALPHAC(1,K,M,I)=0. ALPHAM(1,K,M,I)=0. ALPHAC(2,K,M,I)=0. ALPHAM(2,K,M,I)=0. ALPHAC(3,K,M,I)=0. ALPHAM(3,K,M,I)=0. 58 CONTINUE 59 CONTINUE 60 CONTINUE IF (RESTRT) THEN CALL GOON (KTIME,OLDGRD, + XNODC,XNODM,YNODC,YNODM,NUMNOD, + THNKC,CONNOD,THNKM, + GEOTHC,GEOTHM,GEOTHA,VC,VM,WC,WM,ESUMC,ESUMM, + NUMEL) CALL INTERP (XNODC,NODES,NUMEL,NUMNOD,XIPC) CALL INTERP (YNODC,NODES,NUMEL,NUMNOD,YIPC) CALL INTERP (XNODM,NODES,NUMEL,NUMNOD,XIPM) CALL INTERP (YNODM,NODES,NUMEL,NUMNOD,YIPM) CALL INTERP (THNKC,NODES,NUMEL,NUMNOD,THIKC) CALL INTERP (THNKM,NODES,NUMEL,NUMNOD,THIKM) DO 100 M=1,7 DO 90 I=1,NUMEL THIKC(M,I)=MAX(THIKC(M,I),HMIN(1)) THIKM(M,I)=MAX(THIKM(M,I),HMIN(2)) THIKC(M,I)=MIN(THIKC(M,I),HMAX(1)) THIKM(M,I)=MIN(THIKM(M,I),HMAX(2)) 90 CONTINUE 100 CONTINUE CALL AREAS (NODES,AREAC,XNODC,YNODC,NUMNOD,NUMEL) CALL AREAS (NODES,AREAM,XNODM,YNODM,NUMNOD,NUMEL) CALL DERIV (NUMEL,NUMNOD,NODES,XNODC,YNODC,AREAC, + DETJC,DXSC,DYSC,NUMBAD,LISTOP) CALL DERIV (NUMEL,NUMNOD,NODES,XNODM,YNODM,AREAM, + DETJM,DXSM,DYSM,NUMBAD,LISTOP) CALL EDOT (NUMEL,NODES,VC,NUMNOD,DXSC,DYSC,ERATEC, + ALPHAC,TOFSTC,TAUMTC) CALL EDOT (NUMEL,NODES,VM,NUMNOD,DXSM,DYSM,ERATEM, + ALPHAM,TOFSTM,TAUMTM) CALL INTERP (CONNOD,NODES,NUMEL,NUMNOD,CONINT) TASTH=TEMPM(THIKM(5,NUMEL),5,NUMEL) ELSE STRTUP=.TRUE. CALL SCULPT (THICKN,XNODC,XNODM,YNODC,YNODM, + NUMNOD,APLANO,HMAX,HMIN, + RHOBAR,THNKC,THNKM,WANDES,STRTUP,XIPC,YIPC, + THIKC,THIKM,NUMEL,NODES,NCOLN,NELROW,ONEKM, + G,CONDNS,RHOAST,RHOH2O) CALL GEOTHR (INPUT, AREAC,AREAM, + CONDUC,DETJC,DETJM, + DIFFUS,DNLINK,DQDTDA, + FROMWC,FROMWM,HMAX,HMIN, + NCDIM,NDIFF,NODES,NUMEL, + NUMNOD,NXL,ONEKM,RADIO,STRTUP, + THICKN,THIKC,THIKM,THNKC,THNKM, + TOUCHC,TOUCHM,TSLAB0, + TSURF,UPLINK, + OUTPUT,GEOTHA,GEOTHC,GEOTHM,TASTH, + WORK, CODE,CONDNS, + DGDT1C,DGDT1M,DGDT2C,DGDT2M, + FLOWIN,LWORK,OUTSCA) IF (WANDES*APLANO.GT.0.) THEN CALL BELOW (INPUT,CPNLAT,ECLOG,FROMWC,IBELOW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ, + BEGAGE,WANDES, + XIPC,YIPC,X0ELON,Y0NLAT, + OUTPUT,SZZBC,TOUCHC,VSLABC) CALL BELOW (INPUT,CPNLAT,ECLOG,FROMWM,IBELOW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ, + BEGAGE,WANDES, + XIPM,YIPM,X0ELON,Y0NLAT, + OUTPUT,SZZBM,TOUCHM,VSLABM) STRTUP=.FALSE. DO 300 KITER=1,10 CALL SQUEZE (G,CONDNS,TOUCHC,TOUCHM,SZZBC,SZZBM, + GEOTHA,GEOTHC,GEOTHM,NUMEL,THIKC,THIKM,TEMLIM, + ALPHAT,RHOBAR,DNLINK,UPLINK,SIGZZC,SIGZZM, + OUTSCA,THNKC,THNKM,DXSC,DXSM,DYSC,DYSM, + TAUZZC,TAUZZM,ONEKM,RHOH2O,RHOAST, + NODES,NUMNOD,PTSC,PTSM, + AREAC,AREAM,CODE,DETJC,DETJM,FAILUR,FLOWIN, + NCDIM,NDIFF,NXL,LWORK,ECLOG,HMAX,HMIN) CALL SCULPT (THICKN,XNODC,XNODM,YNODC,YNODM, + NUMNOD,APLANO,HMAX,HMIN, + RHOBAR,THNKC,THNKM,WANDES, + STRTUP,XIPC,YIPC, + THIKC,THIKM,NUMEL,NODES,NCOLN,NELROW, + ONEKM,G,CONDNS,RHOAST,RHOH2O) CALL GEOTHR (INPUT, AREAC,AREAM, + CONDUC,DETJC,DETJM, + DIFFUS,DNLINK,DQDTDA, + FROMWC,FROMWM,HMAX,HMIN, + NCDIM,NDIFF,NODES,NUMEL, + NUMNOD,NXL,ONEKM,RADIO,STRTUP, + THICKN,THIKC,THIKM,THNKC, + THNKM,TOUCHC,TOUCHM,TSLAB0, + TSURF,UPLINK, + OUTPUT,GEOTHA,GEOTHC,GEOTHM,TASTH, + WORK, CODE,CONDNS, + DGDT1C,DGDT1M,DGDT2C,DGDT2M, + FLOWIN,LWORK,OUTSCA) 300 CONTINUE ENDIF CALL SETEDT (NUMNOD,VM,VDECOL, + NUMEL,ERATEC,ERATEM,ESUMC,ESUMM, + XIPC,XIPM,YIPC,YIPM, + XNODC,XNODM,YNODC,YNODM) DO 500 I=1,NUMNOD VC(1,I)=0. VC(2,I)=0. WC(I)=0. WM(I)=0. CONNOD(I)=CONRAD 500 CONTINUE CALL INTERP (CONNOD,NODES,NUMEL,NUMNOD,CONINT) ENDIF WRITE(6,510) 510 FORMAT('0INITIAL VALUE OF CRUSTAL') CALL VOLUME (INPUT,AREAC,DETJC,NUMEL,.TRUE.,THIKC, + OUTPUT,VOLC) RETURN END C C C SUBROUTINE GOON (KTIME,OLDGRD, + XNODC,XNODM,YNODC,YNODM,NUMNOD, + THNKC,CONNOD,THNKM, + GEOTHC,GEOTHM,GEOTHA,VC,VM,WC,WM,ESUMC,ESUMM, + NUMEL) C C READS FILE WITH THE ARRAYS NEEDED IN ORDER TO C A) REUSE OLD GRID OF NODAL LOCATIONS, OR C B) RESTART PROGRAM AND CONTINUE IN TIME; C ONLY ESSENTIAL (INTEGRATED) VARIABLES ARE READ; C PARAMETERS MUST BE RE-INPUT BY "INPUT", AND ALL C RECONSTRUCTABLE ARRAYS MUST BE RECOMPUTED. C C BECAUSE THERE WAS A CHANGE IN THE PRECISION OF ARRAY FILES C DURING THE COURSE OF THE LARAMIDE-OROGENY PROJECT C (MORE SIGNIFICANT DIGITS IN LATER FILES), THIS SUBPROGRAM C FIRST ATTEMPTS TO READ WITH THE NEWER (2000-SERIES) FORMATS; C IF THIS FAILS THEN IT TRIES TO READ WITH THE OLDER C (1000-SERIES) FORMATS. C LOGICAL OLDGRD CHARACTER*80 TITLE,TIME DIMENSION CONNOD(NUMNOD),ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL), + GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), + THNKC(NUMNOD),THNKM(NUMNOD), + VC(2,NUMNOD),VM(2,NUMNOD), + WC(NUMNOD),WM(NUMNOD), + XNODC(NUMNOD),XNODM(NUMNOD), + YNODC(NUMNOD),YNODM(NUMNOD) C OLDER FORMAT SERIES: 1001 FORMAT(A80) 1002 FORMAT(1P,8E9.2) 1003 FORMAT(0P,8F9.5) 1004 FORMAT(' ',A80) 1005 FORMAT(1P,8E9.2) 1006 FORMAT(1P,8E9.2) 1007 FORMAT(1P,8E9.2) C C NEWER FORMAT SERIES 2001 FORMAT(A80) 2002 FORMAT(1P,8E9.2) 2003 FORMAT(0P,8F9.5) 2004 FORMAT(' ',A80) 2005 FORMAT(1P,6E13.6) 2006 FORMAT(1P,8E10.3) 2007 FORMAT(0P,F10.3,1P,3E10.3,0P,F10.3,1P,3E10.3) C C UNCHANGED FORMAT SERIES 3003 FORMAT('0FOLLOWING DATASET WAS READ FOR INITIAL CONDITIONS:'/ + '0',A80) 3004 FORMAT('0FOLLOWING DATASET WAS READ FOR NODE LOCATIONS ONLY:'/ + '0',A80) C TITLE=' '// + ' ' READ (8,2001,IOSTAT=IOS) TITLE IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1001,IOSTAT=IOS) TITLE C NOTE: IOSTAT USED 2ND TIME ALSO, IN CASE C TITLE HAS FEWER BYTES THAN MAXIMUM. END IF IF (OLDGRD) THEN WRITE(6,3004) TITLE ELSE WRITE(6,3003) TITLE ENDIF DO 1000 ITIME=1,KTIME IF (ITIME.GT.1) THEN TITLE=' '// + ' ' READ (8,2001,IOSTAT=IOS) TITLE IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1001,IOSTAT=IOS) TITLE C NOTE: IOSTAT USED 2ND TIME ALSO, IN CASE C TITLE HAS FEWER BYTES THAN MAXIMUM. END IF END IF READ (8,2001,IOSTAT=IOS) TIME IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1001) TIME END IF IF (ITIME.EQ.KTIME) WRITE(6,2004) TIME READ (8,2001) READ (8,2005,IOSTAT=IOS) (XNODC(I),I=1,NUMNOD) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1005) (XNODC(I),I=1,NUMNOD) END IF READ (8,2001) READ (8,2005,IOSTAT=IOS) (XNODM(I),I=1,NUMNOD) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1005) (XNODM(I),I=1,NUMNOD) END IF READ (8,2001) READ (8,2005,IOSTAT=IOS) (YNODC(I),I=1,NUMNOD) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1005) (YNODC(I),I=1,NUMNOD) END IF READ (8,2001) READ (8,2005,IOSTAT=IOS) (YNODM(I),I=1,NUMNOD) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1005) (YNODM(I),I=1,NUMNOD) END IF IF (OLDGRD) GO TO 1000 READ (8,2001) READ (8,*,IOSTAT=IOS) (THNKC(I),I=1,NUMNOD) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1006) (THNKC(I),I=1,NUMNOD) END IF READ (8,2001) READ (8,*,IOSTAT=IOS) (CONNOD(I),I=1,NUMNOD) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1006) (CONNOD(I),I=1,NUMNOD) END IF READ (8,2001) READ (8,*,IOSTAT=IOS) (THNKM(I),I=1,NUMNOD) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1006) (THNKM(I),I=1,NUMNOD) END IF READ (8,2001) READ (8,2007,IOSTAT=IOS) + (((GEOTHC(I,J,K),I=1,4),J=1,7),K=1,NUMEL) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1007) + (((GEOTHC(I,J,K),I=1,4),J=1,7),K=1,NUMEL) END IF READ (8,2001) READ (8,2007,IOSTAT=IOS) + (((GEOTHM(I,J,K),I=1,4),J=1,7),K=1,NUMEL) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1007) + (((GEOTHM(I,J,K),I=1,4),J=1,7),K=1,NUMEL) END IF READ (8,2001) READ (8,2007,IOSTAT=IOS) + (((GEOTHA(I,J,K),I=1,4),J=1,7),K=1,NUMEL) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1007) + (((GEOTHA(I,J,K),I=1,4),J=1,7),K=1,NUMEL) END IF READ (8,2001) READ (8,2005,IOSTAT=IOS) ((VC(I,J),I=1,2),J=1,NUMNOD) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1005) ((VC(I,J),I=1,2),J=1,NUMNOD) END IF READ (8,2001) READ (8,2005,IOSTAT=IOS) ((VM(I,J),I=1,2),J=1,NUMNOD) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1005) ((VM(I,J),I=1,2),J=1,NUMNOD) END IF READ (8,2001) READ (8,2002,IOSTAT=IOS) (WC(I),I=1,NUMNOD) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1002) (WC(I),I=1,NUMNOD) END IF READ (8,2001) READ (8,2002,IOSTAT=IOS) (WM(I),I=1,NUMNOD) IF (IOS.NE.0) THEN BACKSPACE 8 READ (8,1002) (WM(I),I=1,NUMNOD) END IF READ (8,2001) READ (8,2003) ((ESUMC(1,1,J,K),ESUMC(1,2,J,K), + ESUMC(2,1,J,K),ESUMC(2,2,J,K),J=1,7), + K=1,NUMEL) READ (8,2001) READ (8,2003,END=9001) ((ESUMM(1,1,J,K),ESUMM(1,2,J,K), + ESUMM(2,1,J,K),ESUMM(2,2,J,K),J=1,7), + K=1,NUMEL) 1000 CONTINUE RETURN 9001 IF (ITIME.EQ.KTIME) THEN DO 9003 J=1,7 DO 9002 K=1,NUMEL ESUMM(1,1,J,K)=1. ESUMM(1,2,J,K)=0. ESUMM(2,1,J,K)=0. ESUMM(2,2,J,K)=1. 9002 CONTINUE 9003 CONTINUE WRITE(6,9005) 9005 FORMAT('0INPUT TAPE WAS TRUNCATED WITHIN ARRAY ESUMM;'/ + '0THIS ARRAY HAS BEEN SET TO ZERO;'/ + '0PREDICTIONS OF TELESEISMIC TRAVEL-TIME WILL NOT', + ' BE ACCURATE UNLESS DVPBYE(1,I) = 0.') ELSE WRITE(6,9006) ITIME,KTIME 9006 FORMAT('0ONLY ',I3,' DATASETS FOUND ON TAPE; ',I3,'NEEDED.') STOP ENDIF END C C C SUBROUTINE SCULPT (THICKN,XNODC,XNODM,YNODC,YNODM, + NUMNOD,APLANO,HMAX,HMIN,RHOBAR, + THNKC,THNKM,WANDES,STRTUP,XIPC,YIPC, + THIKC,THIKM,NUMEL,NODES,NCOLN,NELROW,ONEKM, + G,CONDNS,RHOAST,RHOH2O) C C ESTABLISHES INITIAL THICKNESSES OF CRUST AND MANTLE LAYERS C LOGICAL STRTUP COMMON /GROBOW/ HANDES,X,NPOINT,NALT1,NALT2 DIMENSION HANDES(5),X(5) DIMENSION CONDNS(NUMNOD),HMAX(2),HMIN(2), + NODES(6,0:NUMEL),RHOBAR(2), + THICKN(2),THIKC(7,NUMEL),THIKM(7,NUMEL), + THNKC(NUMNOD),THNKM(NUMNOD), + XIPC(7,NUMEL),YIPC(7,NUMEL), + XNODC(NUMNOD),XNODM(NUMNOD), + YNODC(NUMNOD),YNODM(NUMNOD) NLL=NUMNOD-NCOLN+1 IF (STRTUP) THEN C C SETUP UNIFORM THICKNESSES, ON FIRST AND/OR ONLY CALL C DO 10 I=1,NUMNOD THNKC(I)=THICKN(1) THNKM(I)=THICKN(2) 10 CONTINUE CALL INTERP (THNKC,NODES,NUMEL,NUMNOD,THIKC) CALL INTERP (THNKM,NODES,NUMEL,NUMNOD,THIKM) ELSE C C REVISE CRUSTAL THICKNESSES ON ANY SUBSEQUENT CALLS C DO 100 I=1,NUMNOD XIP=XNODC(I) YIP=YNODC(I) XP=HOWFAR(XIP,YIP,NELROW,NCOLN,NLL,XNODC,YNODC)/ + MAX(WANDES,1.) IF (XP.LT.X(NPOINT)) THEN IF (XP.LT.X(1)) THEN HEIGHT=HANDES(1)*APLANO ELSE J1=1 J2=2 DO 50 L=3,NPOINT LM1=L-1 IF(X(L).GE.XP.AND.XP.GE.X(LM1)) THEN J2=L J1=LM1 ENDIF 50 CONTINUE FRAC=(XP-X(J1))/(X(J2)-X(J1)) HEIGHT=APLANO* + (HANDES(J1)+FRAC*(HANDES(J2)-HANDES(J1))) ENDIF IF (HEIGHT.LT.0.) HEIGHT= + HEIGHT*(RHOAST-RHOH2O)/RHOAST DSZCOR= -HEIGHT*G*RHOAST DSZNOW=CONDNS(I)-CONDNS(NUMNOD) CORREC=(DSZNOW-DSZCOR)/(G*(RHOBAR(2)-RHOBAR(1))) C C NOTE: CORRECTION IS DAMPED BY 0.5 FOR STABILITY. C ITERATION IS PERFORMED (EXTERNALLY) BY PAST, C SO FULL CORRECTION WILL ULTIMATELY BE APPLIED. C THNKC(I)=THNKC(I)+0.5*CORREC THNKC(I)=MAX(THNKC(I),HMIN(1)) THNKC(I)=MIN(THNKC(I),HMAX(1)) ENDIF 100 CONTINUE C C TAPER EDGE OF MANTLE LITHOSPHERE C DO 200 I=1,NUMNOD XIP=XNODM(I) YIP=YNODM(I) XP=HOWFAR(XIP,YIP,NELROW,NCOLN,NLL,XNODC,YNODC)/ + MAX(WANDES,1.) IF (XP.LT.X(NPOINT)) THEN FRAC=(XP-X(NALT2))/(X(NPOINT)-X(NALT2)) THNKM(I)=FRAC*THICKN(2)+(1.-FRAC)*HMIN(2) THNKM(I)=MAX(THNKM(I),HMIN(2)) THNKM(I)=MIN(THNKM(I),HMAX(2)) ENDIF 200 CONTINUE ENDIF CALL INTERP (THNKC,NODES,NUMEL,NUMNOD,THIKC) CALL INTERP (THNKM,NODES,NUMEL,NUMNOD,THIKM) DO 400 M=1,7 DO 390 I=1,NUMEL THIKC(M,I)=MAX(THIKC(M,I),HMIN(1)) THIKM(M,I)=MAX(THIKM(M,I),HMIN(2)) THIKC(M,I)=MIN(THIKC(M,I),HMAX(1)) THIKM(M,I)=MIN(THIKM(M,I),HMAX(2)) 390 CONTINUE 400 CONTINUE RETURN END C C C SUBROUTINE INLAND (INPUT,XIP,YIP,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMW) C C COMPUTE DISTANCE INLAND FROM "LEFT" EDGE OF CRUSTAL GRID C FOR A WHOLE SET OF INTEGRATION POINTS AT ONCE. C DIMENSION FROMW(7,NUMEL),XIP(7,NUMEL),XNODC(NUMNOD), + YIP(7,NUMEL),YNODC(NUMNOD) NELCOL=NUMEL/(2*NELROW) NCOLN=2*NELCOL+1 NLL=NUMNOD-NCOLN+1 DO 100 M=1,7 DO 90 I=1,NUMEL X=XIP(M,I) Y=YIP(M,I) FROMW(M,I)= + HOWFAR(X,Y,NELROW,NCOLN,NLL,XNODC,YNODC) 90 CONTINUE 100 CONTINUE RETURN END C C C REAL FUNCTION HOWFAR (X,Y, + NELROW,NCOLN,NLL,XNODC,YNODC) C C COMPUTES ORTHOGONAL DISTANCE FROM "LEFT" EDGE OF CRUSTAL GRID, C FOR A SINGLE POINT. C THIS FUNCTION USES A METHOD OF TRIANGLE-AREA, WHICH IS NOT C SENSITIVE TO THE ORIENTATION OF THE GRID IN THE X/Y PLANE. C FOR STABILITY, IT DOES NOT CONSIDER THE CURVATURE OF THE C LEFT SIDE, BUT REPLACES IT WITH A PIECEWISE-LINEAR CURVE C CONNECTING ALL THE LEFT SIDE NODES. C DIMENSION XNODC(NLL),YNODC(NLL) C D2M=9.99E37 NMID=1 DO 10 N=1,NELROW NM=NCOLN*(2*N-1)+1 R2=(X-XNODC(NM))**2+(Y-YNODC(NM))**2 IF (R2.LT.D2M) THEN D2M=R2 NMID=NM ENDIF 10 CONTINUE NTOP=NMID-NCOLN NBOT=NMID+NCOLN R2TOP=(X-XNODC(NTOP))**2+(Y-YNODC(NTOP))**2 R2BOT=(X-XNODC(NBOT))**2+(Y-YNODC(NBOT))**2 X1=X Y1=Y IF (R2TOP.LE.R2BOT) THEN X2=XNODC(NTOP) Y2=YNODC(NTOP) X3=XNODC(NMID) Y3=YNODC(NMID) ELSE X2=XNODC(NMID) Y2=YNODC(NMID) X3=XNODC(NBOT) Y3=YNODC(NBOT) ENDIF BASE=((X2-X3)**2+(Y2-Y3)**2)**0.5 AREA=0.5*(X1*Y2-X2*Y1 + +X2*Y3-X3*Y2 + +X3*Y1-X1*Y3) HOWFAR=MAX(0.,2.*AREA/BASE) RETURN END C C C SUBROUTINE GEOTHR (INPUT, AREAC,AREAM, + CONDUC,DETJC,DETJM, + DIFFUS,DNLINK,DQDTDA, + FROMWC,FROMWM,HMAX,HMIN, + NCDIM,NDIFF,NODES,NUMEL, + NUMNOD,NXL,ONEKM,RADIO,STRTUP, + THICKN,THIKC,THIKM,THNKC,THNKM, + TOUCHC,TOUCHM,TSLAB0, + TSURF,UPLINK, + OUTPUT,GEOTHA,GEOTHC,GEOTHM,TASTH, + WORK, CODE,CONDNS, + DGDT1C,DGDT1M,DGDT2C,DGDT2M, + FLOWIN,LWORK,OUTSCA) C C INITIALIZES GEOTHERM PARAMETERS TO STEADY-STATE CONDUCTION SOLUTION C LOGICAL STRTUP DOUBLE PRECISION CODE,FLOWIN DIMENSION AREAC(NUMEL),AREAM(NUMEL),CODE(NCDIM), 2 CONDNS(NUMNOD),CONDUC(2), 3 DETJC(7,NUMEL),DETJM(7,NUMEL), 4 DGDT1C(4,7,NUMEL),DGDT2C(4,7,NUMEL), 5 DGDT1M(4,7,NUMEL),DGDT2M(4,7,NUMEL), 6 DIFFUS(2),DNLINK(3,7,NUMEL), 7 FLOWIN(NUMNOD), 8 FROMWC(7,NUMEL),FROMWM(7,NUMEL), 9 GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), A HMAX(2),HMIN(2),LWORK(NXL),NODES(6,0:NUMEL), 1 OUTSCA(7,NUMEL),RADIO(2), 2 THIKC(7,NUMEL),THIKM(7,NUMEL),THICKN(2), 3 THNKC(NUMNOD),THNKM(NUMNOD), 4 TOUCHC(7,NUMEL),TOUCHM(7,NUMEL), 5 UPLINK(3,7,NUMEL) DIMENSION A(0:3),G(0:3),H(0:3) DATA BIGNUM /3.E38/ C IF (STRTUP) THEN QMANTL=DQDTDA-RADIO(1)*THICKN(1) QASTH=QMANTL-RADIO(2)*THICKN(2) D=THIKC(5,NUMEL) E=THIKM(5,NUMEL) G(0)=TSURF G(1)=DQDTDA/CONDUC(1) G(2)= -RADIO(1)/(2.*CONDUC(1)) G(3)=0. H(0)=G(0)+G(1)*D+G(2)*D**2 H(1)=QMANTL/CONDUC(2) H(2)= -RADIO(2)/(2.*CONDUC(2)) H(3)=0. TASTH=H(0)+H(1)*E+H(2)*E**2 A(0)=TASTH A(1)=0. A(2)=0. A(3)=0. DO 100 M=1,7 DO 90 I=1,NUMEL DO 80 K=0,3 GEOTHA(K+1,M,I)=A(K) GEOTHC(K+1,M,I)=G(K) GEOTHM(K+1,M,I)=H(K) 80 CONTINUE 90 CONTINUE 100 CONTINUE ELSE CALL SETCUB (THIKM,NUMEL,GEOTHM,GEOTHA,OUTSCA,TASTH, + THIKC,GEOTHC,DNLINK,TOUCHC,TOUCHM,TSLAB0, + AREAM,CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NODES,NUMNOD,NXL,LWORK, + TSURF,FROMWC,FROMWM,ONEKM) DO 200 M=1,7 DO 190 I=1,NUMEL IF (DNLINK(1,M,I).LE.0.) THEN TOUCHC(M,I)=MAX(TOUCHC(M,I),0.01) ENDIF 190 CONTINUE 200 CONTINUE CALL COOLER (INPUT, AREAC,AREAM, + CONDUC,DIFFUS,BIGNUM, + DETJC,DETJM,DNLINK,HMAX,HMIN, + NCDIM,NDIFF,NODES, + NUMEL,NUMNOD,NXL,RADIO,TASTH, + THIKC,THIKM,THNKC,THNKM, + TOUCHC,UPLINK, + MODIFY,GEOTHA,GEOTHC,GEOTHM, + WORK, CODE,CONDNS,FLOWIN, + DGDT1C,DGDT1M,DGDT2C,DGDT2M, + LWORK,OUTSCA) ENDIF RETURN END C C C SUBROUTINE SETEDT (NUMNOD,VM,VDECOL, + NUMEL,ERATEC,ERATEM,ESUMC,ESUMM, + XIPC,XIPM,YIPC,YIPM, + XNODC,XNODM,YNODC,YNODM) C C INITIALIZE STRAIN-RATE AND TOTAL-STRAIN TENSORS. C ALL MOTION IS HERE ASSUMED C TO BE IN THE X DIRECTION FOR SIMPLICITY, WITH THE FORM: C VX=(MAX. VEL.)*COS(X')**2 * SIN(Y')**2 C WHERE 0.LE.X'.LE.PI/2 AND 0.LE.Y'.LE.PI C DIMENSION ERATEC(4,7,NUMEL),ERATEM(4,7,NUMEL), + ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL), + VM(2,NUMNOD), + XIPC(7,NUMEL),XIPM(7,NUMEL), + XNODC(NUMNOD),XNODM(NUMNOD), + YIPC(7,NUMEL),YIPM(7,NUMEL), + YNODC(NUMNOD),YNODM(NUMNOD) DATA E1MAXC/8.0E-17/, E1MAXM/1.6E-15/ XMIN= +3.E38 YMIN= +3.E38 XMAX= -3.E38 YMAX= -3.E38 DO 10 I=1,NUMNOD XMIN=MIN(XMIN,XNODC(I)) YMIN=MIN(YMIN,YNODC(I)) XMAX=MAX(XMAX,XNODC(I)) YMAX=MAX(YMAX,YNODC(I)) 10 CONTINUE XFACT=3.1415927/(2.*(XMAX-XMIN)) XCON= -XMIN*XFACT YFACT=3.1415927/(YMAX-YMIN) YCON= -YMIN*YFACT DO 50 I=1,NUMNOD XPM=XFACT*XNODM(I)+XCON YPM=YFACT*YNODM(I)+YCON VM(1,I)=VDECOL*COS(XPM)**2 * SIN(YPM)**2 VM(2,I)=0. 50 CONTINUE DO 100 M=1,7 DO 90 I=1,NUMEL XPC=XCON+XIPC(M,I)*XFACT YPC=YCON+YIPC(M,I)*YFACT ERATEC(1,M,I)= -2.*E1MAXC*SIN(YPC)**2*COS(XPC)*SIN(XPC) ERATEC(2,M,I)=0.0 ERATEC(3,M,I)=E1MAXC*COS(XPC)*SIN(YPC)*COS(YPC) XPM=XCON+XIPM(M,I)*XFACT YPM=YCON+YIPM(M,I)*YFACT ERATEM(1,M,I)= -2.*E1MAXM*SIN(YPM)**2*COS(XPM)*SIN(XPM) ERATEM(2,M,I)=0.0 ERATEM(3,M,I)=E1MAXM*COS(XPM)*SIN(YPM)*COS(YPM) ESUMC(1,1,M,I)=1. ESUMC(1,2,M,I)=0. ESUMC(2,1,M,I)=0. ESUMC(2,2,M,I)=1. ESUMM(1,1,M,I)=1. ESUMM(1,2,M,I)=0. ESUMM(2,1,M,I)=0. ESUMM(2,2,M,I)=1. 90 CONTINUE 100 CONTINUE RETURN END C C C C SUBROUTINE STEP (ACREEP,ALPHAC,ALPHAM,ALPHAT,AREAC,AREAM,BCREEP, 2 BIOT,BOXIT,C,CCREEP,CODE,CONDNS,CONDUC,CONINT,CONNOD,CONRAD, 3 CONSAV,CPNLAT,DCREEP,DELTAT,DELVC,DELVM,DETJC,DETJM, 4 DGDT1C,DGDT1M,DGDT2C,DGDT2M,DIFFUS,DNLINK,DRAGN,DTHMAX,DVB,DVT, 5 DXMAX,DXSC,DXSM,DYSC,DYSM,E,ECLOG,ECREEP,EDOTC,EDOTM, 6 ERATEC,ERATEM,ES,ESUMC,ESUMM,ETAMAX,FAILUR,FLOWIN,FLUXC,FLUXM, 7 FLUXUC,FORCE,FRIC,FROMWC,FROMWM,G,GEONOD,GEOTHA,GEOTHC,GEOTHM, 8 GLUEC,GLUEM,GRADXC,GRADXE,GRADXW,GRADYC,GRADYN,GRADYS, 9 HMAX,HMIN,IBELOW,INTVEC,ISTEP,LISTOP,LWORK,MAXITR,N,NBAND,NCDIM, A NDIFF,NDIFUS,NELROW,NKDIM,NELCOL,NODES,NRD,NRDP1, 1 NS,NTNM,NUMEL,NUMNOD,NXL,OKTOQT,ONEKM,OUTSCA,OUTVEC,OUTV2, 2 OVA,OVB,PHINOD,PK,PRCFD,PRHOCP,PTSC,PTSM,PUSHHO,PUSHUP,P0,P1,P2, 3 QFRICC,QFRICM,QWORK,RADIO,RADIUS,RAMP,RHOAST,RHOH2O,RHOBAR,S, 4 SHEARN,SIGBOT,SIGHBM,SIGHC,SIGHTM,SIGZZC,SIGZZM,SLABSZ,SS,STIFF, 5 SZZBC,SZZBM,TASTH,TAUMTC,TAUMTM,TAUZZC,TAUZZM,TEMLIM,THIKC, 6 THIKM,THNKC,THNKM,THNSAV,TIME1,TIME2,TOFSTC,TOFSTM,TOUCHC, 7 TOUCHM,TSLAB0,TSURF,UPLINK,VISMAX,VNODE,VSLABC,VSLABM, 8 V1C,V1M,V2C,V2M,W,WANDES,WS,W1C,W1M,W2C,W2M, 9 XFD,XIPC,XIPM,XNODC,XNODM,X0ELON,YFD, B YIPC,YIPM,YNODC,YNODM,Y0NLAT,LAST) C C CARRIES CALCULATION FORWARD BY ONE TIME STEP BY METHOD OF C PREDICTOR-CORRECTOR TRAPEZOIDAL INTEGRATION (TWICE THE COST C OF EXPLICIT INTEGRATION, BUT MORE STABLE AND ACCURATE). C DOUBLE PRECISION CODE,FLOWIN,FORCE,STIFF,TWICE,VMAX2,WMAX2 LOGICAL BOXIT,CRUST,FAILUR,LISTOP,LOCKIN,LOCKWC REAL N,NS DIMENSION ACREEP(3), 2 ALPHAC(3,3,7,NUMEL),ALPHAM(3,3,7,NUMEL),ALPHAT(2), 3 AREAC(NUMEL),AREAM(NUMEL),BASIS(4),BCREEP(3), 4 C(NRD,NRD),CCREEP(3),CODE(NKDIM),CONDNS(NUMNOD), 5 CONDUC(2),CONINT(7,NUMEL),CONNOD(NUMNOD), 6 CONSAV(NUMNOD),DCREEP(3),DELVC(2,7,NUMEL), 7 DELVM(2,7,NUMEL),DETJC(7,NUMEL),DETJM(7,NUMEL), 8 DGDT1C(4,7,NUMEL),DGDT1M(4,7,NUMEL), 9 DGDT2C(4,7,NUMEL),DGDT2M(4,7,NUMEL), A DIFFUS(2),DRAGN(2,NRD,NRD),DVB(7,NUMEL),DVT(7,NUMEL), 1 DXSC(6,7,NUMEL),DXSM(6,7,NUMEL), 2 DYSC(6,7,NUMEL),DYSM(6,7,NUMEL),E(NRD,NRD), 3 ECREEP(3),EDOTC(4,7,NUMEL),EDOTM(4,7,NUMEL), 4 ERATEC(4,7,NUMEL),ERATEM(4,7,NUMEL),ES(NRD,NRD), 5 ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL), 6 FLOWIN(NTNM) DIMENSION FLUXC(7,NUMEL),FLUXM(7,NUMEL),FLUXUC(7,NUMEL), 2 FORCE(NTNM),FRIC(2),FROMWC(7,NUMEL),FROMWM(7,NUMEL), 3 GEONOD(4,NRD,NRD),GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL), 4 GEOTHM(4,7,NUMEL),GLUEC(7,NUMEL),GLUEM(7,NUMEL), 5 GRADXC(NRD,NRD),GRADXE(NRD,NRD),GRADXW(NRD,NRD), 6 GRADYC(NRD,NRD),GRADYN(NRD,NRD),GRADYS(NRD,NRD), 7 HMAX(2),HMIN(2),INTVEC(NUMEL), 8 DNLINK(3,7,NUMEL),UPLINK(3,7,NUMEL), 9 LISTOP(NUMEL),LWORK(NXL),N(NRD,NRD),NS(NRD,NRD), A NODES(6,0:NUMEL),OUTSCA(7,NUMEL), 1 OUTVEC(2,7,NUMEL),OUTV2(2,7,NUMEL), 2 OVA(2,7,NUMEL),OVB(2,7,NUMEL),PERCEN(4), 3 PHINOD(NUMNOD),PK(2,5,0:NRDP1,0:NRDP1), 4 PRHOCP(7,NUMEL),PRCFD(NRD,NRD),PTSC(2,7,NUMEL), 5 PTSM(2,7,NUMEL),P0(0:NRDP1,0:NRDP1), 6 P1(0:NRDP1,0:NRDP1),P2(0:NRDP1,0:NRDP1), 7 QFRICC(4,7,NUMEL),QFRICM(4,7,NUMEL),QWORK(4,7,NUMEL), 8 RADIO(2),RHOBAR(2),S(NRD,NRD),SHEARN(2,NRD,NRD), 9 SIGHBM(2,7,NUMEL),SIGHC(2,7,NUMEL),SIGHTM(2,7,NUMEL), B SIGZZC(7,NUMEL),SIGZZM(7,NUMEL),SS(NRD,NRD) DIMENSION STIFF(NKDIM),SZZBC(7,NUMEL),SZZBM(7,NUMEL), 2 TAUMTC(3,7,NUMEL),TAUMTM(3,7,NUMEL), 3 TAUZZC(7,NUMEL),TAUZZM(7,NUMEL), 4 TEMLIM(2),THIKC(7,NUMEL), 5 THIKM(7,NUMEL),THNKC(NUMNOD),THNKM(NUMNOD), 6 THNSAV(NUMNOD),TOFSTC(3,7,NUMEL),TOFSTM(3,7,NUMEL), 7 TOUCHC(7,NUMEL),TOUCHM(7,NUMEL),VNODE(2,NUMNOD), 8 VSLABC(2,7,NUMEL),VSLABM(2,7,NUMEL), 6 V1C(2,NUMNOD),V1M(2,NUMNOD),V2C(2,NUMNOD), 7 V2M(2,NUMNOD), 9 W(NRD,NRD),WS(NRD,NRD), A W1C(NUMNOD),W1M(NUMNOD),W2C(NUMNOD),W2M(NUMNOD), 1 XFD(NRD,NRD), 2 XIPC(7,NUMEL),XIPM(7,NUMEL), 3 XNODC(NUMNOD),XNODM(NUMNOD),YFD(NRD,NRD), 4 YIPC(7,NUMEL),YIPM(7,NUMEL), 5 YNODC(NUMNOD),YNODM(NUMNOD) DATA LOCKIN /.FALSE./, LOCKWC /.FALSE./ C IF (LAST.NE.999) THEN WRITE(6,10) 10 FORMAT(' MISALIGNMENT OF ARGUMENTS IN CALL TO STEP!') STOP ENDIF C WRITE(6,99) 99 FORMAT(' ========================================', + '========================================', + '========================================', + '====') WRITE(6,100) 100 FORMAT(' BEFORE PREDICTOR STEP, CRUSTAL') CALL VOLUME (INPUT,AREAC,DETJC,NUMEL,.TRUE.,THIKC, + OUTPUT,VOLC) C C COMPUTE HORIZONTAL VELOCITIES AND LAYER THICKNESS RATES AT C BEGINNING OF TIMESTEP WITH GRID FROM END OF LAST STEP C C CALL AREAS (NODES,AREAC,XNODC,YNODC,NUMNOD,NUMEL) CALL DERIV (NUMEL,NUMNOD,NODES,XNODC,YNODC,AREAC, + DETJC,DXSC,DYSC,NUMBAD,LISTOP) NPASS=0 IF (NUMBAD.GT.0) THEN 1001 NPASS=NPASS+1 WRITE(6,1002) NUMBAD 1002 FORMAT(' WARNING: ',I3,' CRUSTAL ELEMENTS REQUIRE', + ' ORTHOPEDIC CORECTION AT BEGINNING OF TIMESTEP') CALL ORTHO (NODES,XNODC,YNODC,LISTOP,NUMEL,NUMNOD, + NELCOL,XIPC,YIPC) CALL AREAS (NODES,AREAC,XNODC,YNODC,NUMNOD,NUMEL) CALL DERIV (NUMEL,NUMNOD,NODES,XNODC,YNODC,AREAC, + DETJC,DXSC,DYSC,NUMBAD,LISTOP) IF (NUMBAD.GT.0.AND.NPASS.LT.10) GO TO 1001 ENDIF IF (NPASS.GE.10.AND.NUMBAD.GT.0) THEN WRITE(6,1003) NUMBAD 1003 FORMAT(' DISASTER: NEGATIVE AREAS AT ',I5,' POINTS CANNOT', + ' BE FIXED BY ORTHO IN 10 PASSES. CALCULATION STOPS') FAILUR=.TRUE. BOXIT=.FALSE. RETURN ENDIF CALL AREAS (NODES,AREAM,XNODM,YNODM,NUMNOD,NUMEL) CALL DERIV (NUMEL,NUMNOD,NODES,XNODM,YNODM,AREAM, + DETJM,DXSM,DYSM,NUMBAD,LISTOP) NPASS=0 IF (NUMBAD.GT.0) THEN 1011 NPASS=NPASS+1 WRITE(6,1012) NUMBAD 1012 FORMAT(' WARNING: ',I3,' MANTLE ELEMENTS REQUIRE', + ' ORTHOPEDIC CORECTION AT BEGINNING OF TIMESTEP') CALL ORTHO (NODES,XNODM,YNODM,LISTOP,NUMEL,NUMNOD, + NELCOL,XIPM,YIPM) CALL AREAS (NODES,AREAM,XNODM,YNODM,NUMNOD,NUMEL) CALL DERIV (NUMEL,NUMNOD,NODES,XNODM,YNODM,AREAM, + DETJM,DXSM,DYSM,NUMBAD,LISTOP) IF (NUMBAD.GT.0.AND.NPASS.LT.10) GO TO 1011 ENDIF IF (NPASS.GE.10.AND.NUMBAD.GT.0) THEN WRITE(6,1003) NUMBAD FAILUR=.TRUE. BOXIT=.FALSE. RETURN ENDIF CALL LINKER (NELCOL,NUMEL,XIPM,YIPM, + DETJC,XIPC,YIPC,XNODC,YNODC, + NUMNOD,NODES,AREAC,UPLINK,FAILUR) IF (FAILUR) RETURN CALL LINKER (NELCOL,NUMEL,XIPC,YIPC, + DETJM,XIPM,YIPM,XNODM,YNODM, + NUMNOD,NODES,AREAM,DNLINK,FAILUR) IF (FAILUR) RETURN CALL BELOW (INPUT,CPNLAT,ECLOG,FROMWC,IBELOW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME1,WANDES, + XIPC,YIPC,X0ELON,Y0NLAT, + OUTPUT,SZZBC,TOUCHC,VSLABC) CALL BELOW (INPUT,CPNLAT,ECLOG,FROMWM,IBELOW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME1,WANDES, + XIPM,YIPM,X0ELON,Y0NLAT, + OUTPUT,SZZBM,TOUCHM,VSLABM) CALL SETCUB (THIKM,NUMEL,GEOTHM,GEOTHA,OUTSCA,TASTH, + THIKC,GEOTHC,DNLINK,TOUCHC,TOUCHM,TSLAB0, + AREAM,CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NODES,NUMNOD,NXL,LWORK, + TSURF,FROMWC,FROMWM,ONEKM) CRUST=.FALSE. CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATEM,FRIC,G,GEOTHM, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIKM,THNKC,UPLINK, + OUTPUT,FLUXM,FLUXUC,GLUEM,QFRICM, + WORK,INTVEC,OUTSCA,OUTV2) CRUST=.TRUE. CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATEC,FRIC,G,GEOTHC, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIKC,THNKC,UPLINK, + OUTPUT,FLUXC,FLUXUC,GLUEC,QFRICC, + WORK,INTVEC,OUTSCA,OUTV2) CALL SQUEZE (G,CONDNS,TOUCHC,TOUCHM,SZZBC,SZZBM, + GEOTHA,GEOTHC,GEOTHM,NUMEL,THIKC,THIKM,TEMLIM, + ALPHAT,RHOBAR,DNLINK,UPLINK,SIGZZC,SIGZZM, + OUTSCA,THNKC,THNKM,DXSC,DXSM,DYSC,DYSM, + TAUZZC,TAUZZM,ONEKM,RHOH2O,RHOAST, + NODES,NUMNOD,PTSC,PTSM, + AREAC,AREAM,CODE,DETJC,DETJM,FAILUR,FLOWIN, + NCDIM,NDIFF,NXL,LWORK,ECLOG,HMAX,HMIN) T1MA=TIME1/(1.E6*365.25*24.*60.*60.) WRITE(6,1102) TIME1,T1MA 1102 FORMAT(' VELOCITY SOLUTION AT BEGINNING OF TIME STEP:', + ' AGE = ',1P,E10.3,' (',0P,F8.3,')') WRITE(6,1103) 1103 FORMAT(11X,'ITERATION MANTLE: MANTLE: MANTLE: MANTLE: ', + ' CRUST: CRUST: CRUST: CRUST:'/ + 11X,'NUMBER MAXIMUM RMS.DV MAXIMUM RMS.DTAU', + ' MAXIMUM RMS.DV MAXIMUM RMS.DTAU'/ + 11X,' D.VELOC WRT LAST/ D.TAU WRT F-L/', + ' D.VELOC WRT LAST/ D.TAU WRT F-L/'/ + 11X,' WRT LAST RMS.VEL WRT F-L RMS.TAU', + ' WRT LAST RMS.VEL WRT F-L RMS.TAU') DO 1200 I=1,NUMNOD V1C(1,I)=V2C(1,I) V1C(2,I)=V2C(2,I) V1M(1,I)=V2M(1,I) V1M(2,I)=V2M(2,I) W1C(I)=W2C(I) W1M(I)=W2M(I) 1200 CONTINUE CALL PURE (ACREEP,ALPHAC,ALPHAM, + AREAC,AREAM,BCREEP,BIOT,CCREEP,CONINT,DCREEP, + DELTAT,DELVC,DELVM,DETJC,DETJM,DXSC,DXSM, + DYSC,DYSM,ECREEP,ERATEC,ERATEM,ETAMAX, + FORCE,FRIC,FROMWC,G,GEOTHC,GEOTHM, + GLUEC,GLUEM,HMAX,HMIN,DNLINK,UPLINK, + IBELOW,MAXITR,NBAND,NKDIM,NELCOL, + NODES,NTNM,NUMEL,NUMNOD,NXL,OKTOQT,ONEKM,OUTVEC, + OUTV2,OUTSCA,PUSHHO,PTSC,PTSM, + QFRICC,QFRICM,RHOH2O,RHOBAR,STIFF, + SIGBOT,SIGHC,SIGHBM,SIGHTM, + TAUMTC,TAUMTM, + TAUZZC,TAUZZM,TEMLIM, + THIKC,THIKM,THNKC,THNKM,TOFSTC,TOFSTM, + TOUCHC,TOUCHM,LWORK,WANDES,XNODC,XNODM, + YNODC,YNODM,V1C,V1M,VISMAX,VSLABC,VSLABM, + FAILUR,DVB,DVT,OVA,OVB, + CODE,FLOWIN,CONDNS,NCDIM,NDIFF) IF (FAILUR) THEN BOXIT=.TRUE. DO 1300 I=1,NUMNOD V2C(1,I)=V1C(1,I) V2C(2,I)=V1C(2,I) V2M(1,I)=V1M(1,I) V2M(2,I)=V1M(2,I) W2C(I)=W1C(I) W2M(I)=W1M(I) 1300 CONTINUE RETURN ENDIF DELT=DELTAT VMAX2=0.D0 DO 1310 I=1,NUMNOD VMAX2=MAX(VMAX2,(1.D0*V1C(1,I))**2+(1.D0*V1C(2,I))**2, + (1.D0*V1M(1,I))**2+(1.D0*V1M(2,I))**2) 1310 CONTINUE SAFEDT=DXMAX/SQRT(VMAX2) IF (SAFEDT.LT.DELTAT) THEN DELT=SAFEDT WRITE(6,1320) DELT,ISTEP,DXMAX 1320 FORMAT(' SUBPROGRAM STEP USING REDUCED TIMESTEP OF ',1P, + E10.3,' IN STEP ',I3, + ' TO KEEP DISPLACEMENT DOWN TO SPECIFIED ' + ,E10.3) ENDIF NCOLN=2*NELCOL+1 NROWN=NUMNOD/NCOLN CALL UNFOLD (INPUT,DELT,DXSM,DYSM,NDIFUS,NCOLN,NODES, + NROWN,NUMEL,NUMNOD,XNODM,YNODM, + MODIFY,V1M, + WORK,C,CONDNS,E,N,NRD,NRDP1,PHINOD, + PK,PRCFD,P0,P1,S,W,XFD,YFD) CALL EDOT (NUMEL,NODES,V1M,NUMNOD,DXSM,DYSM,ERATEM, + ALPHAM,TOFSTM,TAUMTM) CALL EZZDOT (INPUT,AREAM,DETJM,ERATEM, + NCDIM,NDIFF,NODES, + NUMEL,NUMNOD,NXL,THIKM, + OUTPUT,W1M, + WORK,CODE,FLOWIN,LWORK) CALL EZZDOT (INPUT,AREAC,DETJC,ERATEC, + NCDIM,NDIFF,NODES, + NUMEL,NUMNOD,NXL,THIKC, + OUTPUT,W1C, + WORK,CODE,FLOWIN,LWORK) IF (DELTAT.GT.0.) THEN WMAX2=0.D0 DO 1380 I=1,NUMNOD WMAX2=MAX(WMAX2,(1.D0*W1C(I))**2,(1.D0*W1M(I))**2) 1380 CONTINUE SAFEDT=DTHMAX/SQRT(WMAX2) IF (SAFEDT.LT.DELT) THEN DELT=SAFEDT WRITE(6,1390) DELT,ISTEP,DTHMAX 1390 FORMAT(' SUBPROGRAM STEP USING REDUCED TIMESTEP OF ', + 1P,E10.3,' IN STEP ',I3, + ' TO KEEP THICKNESS CHANGE DOWN TO SPECIFIED ' + ,E10.3) ENDIF IF (DELT/DELTAT.LT.0.10) THEN WRITE(6,1391) 1391 FORMAT(/ + ' NECESSARY TIMESTEP UNDER IMPOSED CONTRAINTS', + ' IS FOUND TO BE LESS THAN 0.10 X REQUESTED', + ' TIMESTEP.'/' PROGRAM IS BECOMING VERY SLOW', + ' AND EXPENSIVE AND MAY TIME-OUT.'/ + ' INSTEAD, STOPPING FOR OPERATOR DECISION:'/ + ' -DECREASE REQUESTED TIMESTEP; OR'/ + ' -RELEASE CONSTRAINTS ON NODE MOVEMENT', + ' AND/OR THICKNESS CHANGES; OR'/ + ' -ABANDON CALCULATION AS UNPHYSICAL.'/ /) FAILUR=.TRUE. BOXIT=.FALSE. DO 1392 I=1,NUMNOD V2C(1,I)=V1C(1,I) V2C(2,I)=V1C(2,I) V2M(1,I)=V1M(1,I) V2M(2,I)=V1M(2,I) W2C(I)=W1C(I) W2M(I)=W1M(I) 1392 CONTINUE RETURN ENDIF ELSE FAILUR=.TRUE. BOXIT=.FALSE. DO 1393 I=1,NUMNOD V2C(1,I)=V1C(1,I) V2C(2,I)=V1C(2,I) V2M(1,I)=V1M(1,I) V2M(2,I)=V1M(2,I) W2C(I)=W1C(I) W2M(I)=W1M(I) 1393 CONTINUE RETURN ENDIF C C C APPLY RATES TO DEFORM GRID AND CHANGE THICKNESS AND STRAIN C C DO 1400 I=1,NUMNOD XNODC(I)=XNODC(I)+DELT*V1C(1,I) YNODC(I)=YNODC(I)+DELT*V1C(2,I) XNODM(I)=XNODM(I)+DELT*V1M(1,I) YNODM(I)=YNODM(I)+DELT*V1M(2,I) 1400 CONTINUE CALL INTERP (XNODC,NODES,NUMEL,NUMNOD,XIPC) CALL INTERP (YNODC,NODES,NUMEL,NUMNOD,YIPC) CALL INTERP (XNODM,NODES,NUMEL,NUMNOD,XIPM) CALL INTERP (YNODM,NODES,NUMEL,NUMNOD,YIPM) CALL INLAND (INPUT,XIPC,YIPC,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMWC) CALL INLAND (INPUT,XIPM,YIPM,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMWM) DO 1500 I=1,NUMNOD THNKC(I)=THNKC(I)+W1C(I)*DELT THNKC(I)=MAX(THNKC(I),HMIN(1)) THNKC(I)=MIN(THNKC(I),HMAX(1)) THNKM(I)=THNKM(I)+W1M(I)*DELT THNKM(I)=MAX(THNKM(I),HMIN(2)) THNKM(I)=MIN(THNKM(I),HMAX(2)) 1500 CONTINUE CALL INTERP (THNKC,NODES,NUMEL,NUMNOD,THIKC) CALL INTERP (THNKM,NODES,NUMEL,NUMNOD,THIKM) DO 1600 M=1,7 DO 1590 I=1,NUMEL THIKC(M,I)=MAX(THIKC(M,I),HMIN(1)) THIKM(M,I)=MAX(THIKM(M,I),HMIN(2)) THIKC(M,I)=MIN(THIKC(M,I),HMAX(1)) THIKM(M,I)=MIN(THIKM(M,I),HMAX(2)) 1590 CONTINUE 1600 CONTINUE DO 1700 M=1,7 DO 1690 I=1,NUMEL ARATE=ERATEC(1,M,I)+ERATEC(2,M,I) DGDT1C(1,M,I)=0. DGDT1C(2,M,I)=GEOTHC(2,M,I)*ARATE DGDT1C(3,M,I)=2.*GEOTHC(3,M,I)*ARATE C COMPUTE AS DOUBLE; SAVE AS SINGLE PRECISION: TWICE=3.D0*GEOTHC(4,M,I)*ARATE IF (ABS(TWICE).GT.5.D-43) THEN DGDT1C(4,M,I)=TWICE ELSE DGDT1C(4,M,I)=0.0 ENDIF ARATE=ERATEM(1,M,I)+ERATEM(2,M,I) DGDT1M(1,M,I)=0. DGDT1M(2,M,I)=GEOTHM(2,M,I)*ARATE DGDT1M(3,M,I)=2.*GEOTHM(3,M,I)*ARATE C COMPUTE AS DOUBLE; SAVE AS SINGLE PRECISION: TWICE=3.D0*GEOTHM(4,M,I)*ARATE IF (ABS(TWICE).GT.5.D-43) THEN DGDT1M(4,M,I)=TWICE ELSE DGDT1M(4,M,I)=0.0 ENDIF 1690 CONTINUE 1700 CONTINUE CALL HEATER (INPUT,AREAC,AREAM, + CONDUC,DIFFUS, + DETJC,DETJM,DNLINK, + NCDIM,NDIFF,NODES,NUMEL,NUMNOD, + NXL,QFRICC,QFRICM, + THIKC,THIKM,THNKC,THNKM, + UPLINK, + MODIFY,DGDT1C,DGDT1M, + WORK,CODE,CONDNS,FLOWIN,LWORK,OUTSCA,QWORK) DO 1800 I=1,NUMEL DO 1790 M=1,7 DO 1780 K=1,4 GEOTHC(K,M,I)=GEOTHC(K,M,I)+DELT*DGDT1C(K,M,I) GEOTHM(K,M,I)=GEOTHM(K,M,I)+DELT*DGDT1M(K,M,I) EDOTC(K,M,I)=ERATEC(K,M,I) EDOTM(K,M,I)=ERATEM(K,M,I) 1780 CONTINUE 1790 CONTINUE 1800 CONTINUE CALL EPLUSE (ERATEC,DELT,ESUMC,NUMEL) CALL EPLUSE (ERATEM,DELT,ESUMM,NUMEL) CALL CRUSTS (INPUT,AREAC,DELT,DETJC,ERATEC,HMAX,HMIN, + NCDIM,NDIFF,NODES,NUMEL,NUMNOD, + NXL,THIKC,THNKC, + MODIFY,CONNOD, + OUTPUT,CONINT, + WORK,CODE,CONDNS,FLOWIN,LWORK,OUTSCA) C C C COMPARE RATES WITH THOSE FROM END OF PREVIOUS TIMESTEP C C DO 1810 I=1,4 BASIS(I)=0. PERCEN(I)=0. 1810 CONTINUE DO 1900 I=1,NUMNOD PERCEN(1)=PERCEN(1)+(V1C(1,I)-V2C(1,I))**2+ + (V1C(2,I)-V2C(2,I))**2 PERCEN(2)=PERCEN(2)+(V1M(1,I)-V2M(1,I))**2+ + (V1M(2,I)-V2M(2,I))**2 BASIS(1)=BASIS(1)+V1C(1,I)**2+V1C(2,I)**2+ + V2C(1,I)**2+V2C(2,I)**2 BASIS(2)=BASIS(2)+V1M(1,I)**2+V1M(2,I)**2+ + V2M(1,I)**2+V2M(2,I)**2 PERCEN(3)=PERCEN(3)+(W1C(I)-W2C(I))**2 PERCEN(4)=PERCEN(4)+(W1M(I)-W2M(I))**2 BASIS(3)=BASIS(3)+W1C(I)**2+W2C(I)**2 BASIS(4)=BASIS(4)+W1M(I)**2+W2M(I)**2 1900 CONTINUE DO 1950 I=1,4 BASIS(I)=SQRT(BASIS(I)/(2*NUMNOD)) PERCEN(I)=SQRT(PERCEN(I)/NUMNOD) PERCEN(I)=PERCEN(I)/BASIS(I) 1950 CONTINUE WRITE(6,1999) (PERCEN(I),I=1,4),(BASIS(I),I=1,4) 1999 FORMAT(' SUBPROGRAM STEP REPORTS FOLLOWING CORRECTIONS TO ', + 'VELOCITY AT END OF PREVIOUS TIMESTEP:'/ + 33X,'V.OF.CRUST V.OF.MNTLE W.OF.CRUST W.OF.MANTLE'/ + 11X,'RMS CHANGE/RMS BASIS:',0P,4F11.7/ + 11X,' RMS BASIS:',1P,4E11.2) C C C RECOMPUTE ALL RATES AT END OF TIMESTEP WITH DEFORMED GRID C C TIME2=TIME1-DELT CALL AREAS (NODES,AREAC,XNODC,YNODC,NUMNOD,NUMEL) CALL DERIV (NUMEL,NUMNOD,NODES,XNODC,YNODC,AREAC, + DETJC,DXSC,DYSC,NUMBAD,LISTOP) NPASS=0 IF (NUMBAD.GT.0) THEN 2001 NPASS=NPASS+1 WRITE(6,2002) NUMBAD 2002 FORMAT(' WARNING: ',I3,' CRUSTAL ELEMENTS REQUIRE', + ' ORTHOPEDIC CORECTION AT END OF TIMESTEP') CALL ORTHO (NODES,XNODC,YNODC,LISTOP,NUMEL,NUMNOD, + NELCOL,XIPC,YIPC) CALL AREAS (NODES,AREAC,XNODC,YNODC,NUMNOD,NUMEL) CALL DERIV (NUMEL,NUMNOD,NODES,XNODC,YNODC,AREAC, + DETJC,DXSC,DYSC,NUMBAD,LISTOP) IF (NUMBAD.GT.0.AND.NPASS.LT.10) GO TO 2001 ENDIF IF (NPASS.GE.10.AND.NUMBAD.GT.0) THEN WRITE(6,1003) NUMBAD FAILUR=.TRUE. BOXIT=.FALSE. RETURN ENDIF CALL AREAS (NODES,AREAM,XNODM,YNODM,NUMNOD,NUMEL) CALL DERIV (NUMEL,NUMNOD,NODES,XNODM,YNODM,AREAM, + DETJM,DXSM,DYSM,NUMBAD,LISTOP) NPASS=0 IF (NUMBAD.GT.0) THEN 2011 NPASS=NPASS+1 WRITE(6,2012) NUMBAD 2012 FORMAT(' WARNING: ',I3,' MANTLE ELEMENTS REQUIRE', + ' ORTHOPEDIC CORECTION AT END OF TIMESTEP') CALL ORTHO (NODES,XNODM,YNODM,LISTOP,NUMEL,NUMNOD, + NELCOL,XIPM,YIPM) CALL AREAS (NODES,AREAM,XNODM,YNODM,NUMNOD,NUMEL) CALL DERIV (NUMEL,NUMNOD,NODES,XNODM,YNODM,AREAM, + DETJM,DXSM,DYSM,NUMBAD,LISTOP) IF (NUMBAD.GT.0.AND.NPASS.LT.10) GO TO 2011 ENDIF IF (NPASS.GE.10.AND.NUMBAD.GT.0) THEN WRITE(6,1003) NUMBAD FAILUR=.TRUE. BOXIT=.FALSE. RETURN ENDIF CALL LINKER (NELCOL,NUMEL,XIPM,YIPM, + DETJC,XIPC,YIPC,XNODC,YNODC, + NUMNOD,NODES,AREAC,UPLINK,FAILUR) IF (FAILUR) RETURN CALL LINKER (NELCOL,NUMEL,XIPC,YIPC, + DETJM,XIPM,YIPM,XNODM,YNODM, + NUMNOD,NODES,AREAM,DNLINK,FAILUR) IF (FAILUR) RETURN CALL BELOW (INPUT,CPNLAT,ECLOG,FROMWC,IBELOW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME2,WANDES, + XIPC,YIPC,X0ELON,Y0NLAT, + OUTPUT,SZZBC,TOUCHC,VSLABC) CALL BELOW (INPUT,CPNLAT,ECLOG,FROMWM,IBELOW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME2,WANDES, + XIPM,YIPM,X0ELON,Y0NLAT, + OUTPUT,SZZBM,TOUCHM,VSLABM) CALL SETCUB (THIKM,NUMEL,GEOTHM,GEOTHA,OUTSCA,TASTH, + THIKC,GEOTHC,DNLINK,TOUCHC,TOUCHM,TSLAB0, + AREAM,CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NODES,NUMNOD,NXL,LWORK, + TSURF,FROMWC,FROMWM,ONEKM) CRUST=.FALSE. CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATEM,FRIC,G,GEOTHM, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIKM,THNKC,UPLINK, + OUTPUT,FLUXM,FLUXUC,GLUEM,QFRICM, + WORK,INTVEC,OUTSCA,OUTV2) CRUST=.TRUE. CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATEC,FRIC,G,GEOTHC, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIKC,THNKC,UPLINK, + OUTPUT,FLUXC,FLUXUC,GLUEC,QFRICC, + WORK,INTVEC,OUTSCA,OUTV2) C C IMPLICIT CALCULATIONS OF 1: SIMPLE SHEAR OF BOTH LAYERS C 2: CRUSTAL DIFFUSION C 3: VERTICAL HEAT DIFFUSION C INTERVENE BETWEEN THE TWO VELOCITY SOLUTIONS. C WRITE(6,2020) 2020 FORMAT(' AFTER PREDICTOR BUT BEFORE DRAGIT, CRUSTAL') CALL VOLUME (INPUT,AREAC,DETJC,NUMEL,.TRUE.,THIKC, + OUTPUT,VOLC) CRUST=.FALSE. CALL DRAGIT (INPUT, AREAM,CRUST,DELT,DELVM,DETJM,DXSM,DYSM, + FLUXM,HMAX,HMIN,NCDIM,NDIFF, + NELCOL,NODES,NUMEL,NUMNOD,NXL, + XIPM,XNODM,YIPM,YNODM, + MODIFY,THIKM,THNKM, + WORK, CODE,CONDNS,FLOWIN,LWORK, + OUTSCA,PHINOD,VNODE) CRUST=.TRUE. CALL DRAGIT (INPUT, AREAC,CRUST,DELT,DELVC,DETJC,DXSC,DYSC, + FLUXC,HMAX,HMIN,NCDIM,NDIFF, + NELCOL,NODES,NUMEL,NUMNOD,NXL, + XIPC,XNODC,YIPC,YNODC, + MODIFY,THIKC,THNKC, + WORK, CODE,CONDNS,FLOWIN,LWORK, + OUTSCA,PHINOD,VNODE) CALL DRAGIT (INPUT, AREAC,CRUST,DELT,DELVC,DETJC,DXSC,DYSC, + FLUXUC,HMAX,HMIN,NCDIM,NDIFF, + NELCOL,NODES,NUMEL,NUMNOD,NXL, + XIPC,XNODC,YIPC,YNODC, + MODIFY,CONINT,CONNOD, + WORK, CODE,CONDNS,FLOWIN,LWORK, + OUTSCA,PHINOD,VNODE) DO 2021 I=1,NUMNOD CONNOD(I)=MIN(CONNOD(I),THNKC(I)) 2021 CONTINUE CALL INTERP (CONNOD,NODES,NUMEL,NUMNOD,CONINT) DO 2023 M=1,7 DO 2022 I=1,NUMEL CONINT(M,I)=MIN(CONINT(M,I),THIKC(M,I)) CONINT(M,I)=MAX(CONINT(M,I),HMIN(1)) 2022 CONTINUE 2023 CONTINUE CALL SETCUB (THIKM,NUMEL,GEOTHM,GEOTHA,OUTSCA,TASTH, + THIKC,GEOTHC,DNLINK,TOUCHC,TOUCHM,TSLAB0, + AREAM,CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NODES,NUMNOD,NXL,LWORK, + TSURF,FROMWC,FROMWM,ONEKM) CRUST=.TRUE. CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATEC,FRIC,G,GEOTHC, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIKC,THNKC,UPLINK, + OUTPUT,FLUXC,FLUXUC,GLUEC,QFRICC, + WORK,INTVEC,OUTSCA,OUTV2) CALL THONC (INPUT,DNLINK,ECREEP,ETAMAX, + FRIC,FROMWC,G,GLUEC, + NODES,NUMEL,NUMNOD,PUSHHO, + RHOBAR,SIGBOT,THIKC,TOUCHC, + V1C,VISMAX,V1M,VSLABC,WANDES, + OUTPUT,DELVC,DVB,OVB,QFRICC,SIGHC, + WORK,OUTVEC) CALL SQUEZE (G,CONDNS,TOUCHC,TOUCHM,SZZBC,SZZBM, + GEOTHA,GEOTHC,GEOTHM,NUMEL,THIKC,THIKM,TEMLIM, + ALPHAT,RHOBAR,DNLINK,UPLINK,SIGZZC,SIGZZM, + OUTSCA,THNKC,THNKM,DXSC,DXSM,DYSC,DYSM, + TAUZZC,TAUZZM,ONEKM,RHOH2O,RHOAST, + NODES,NUMNOD,PTSC,PTSM, + AREAC,AREAM,CODE,DETJC,DETJM,FAILUR,FLOWIN, + NCDIM,NDIFF,NXL,LWORK,ECLOG,HMAX,HMIN) WRITE(6,2025) 2025 FORMAT(' AFTER DRAGIT BUT BEFORE PANCAK, CRUSTAL') CALL VOLUME (INPUT,AREAC,DETJC,NUMEL,.TRUE.,THIKC, + OUTPUT,VOLC) CALL PANCAK (INPUT, ACREEP,ALPHAT,AREAC,BCREEP,CCREEP, + DCREEP,DELVC,DETJC, + ECREEP,G,GEOTHC,HMAX,HMIN, + NDIFUS,NCOLN,NDIFF,NODES, + NROWN,NUMEL,NUMNOD, + ONEKM,RHOAST,RHOBAR,SIGHC,SIGZZC, + DELT,TEMLIM,XNODC,YNODC, + MODIFY,CONINT,CONNOD,THIKC,THNKC, + WORK, C,CODE,CONDNS,CONSAV,DRAGN,E,ES,FLOWIN, + GEONOD,GRADXC,GRADXE,GRADXW,GRADYC, + GRADYN,GRADYS,LWORK, + N,NCDIM,NRD,NRDP1,NS,NXL,OUTSCA, + PK,PRHOCP,PRCFD,P0,P1,P2, + S,SHEARN,SS,THNSAV,W,WS,XFD,YFD) WRITE(6,2030) 2030 FORMAT(' AFTER PANCAK BUT BEFORE CORRECTOR, CRUSTAL') CALL VOLUME (INPUT,AREAC,DETJC,NUMEL,.TRUE.,THIKC, + OUTPUT,VOLC) CALL SETCUB (THIKM,NUMEL,GEOTHM,GEOTHA,OUTSCA,TASTH, + THIKC,GEOTHC,DNLINK,TOUCHC,TOUCHM,TSLAB0, + AREAM,CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NODES,NUMNOD,NXL,LWORK, + TSURF,FROMWC,FROMWM,ONEKM) CALL COOLER (INPUT, AREAC,AREAM, + CONDUC,DIFFUS,DELT, + DETJC,DETJM,DNLINK,HMAX,HMIN, + NCDIM,NDIFF,NODES, + NUMEL,NUMNOD,NXL,RADIO,TASTH, + THIKC,THIKM,THNKC,THNKM,TOUCHC,UPLINK, + MODIFY,GEOTHA,GEOTHC,GEOTHM, + WORK, CODE,CONDNS,FLOWIN, + QFRICC,QFRICM,DGDT2C,DGDT2M, + LWORK,OUTSCA) CRUST=.FALSE. CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATEM,FRIC,G,GEOTHM, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIKM,THNKC,UPLINK, + OUTPUT,FLUXM,FLUXUC,GLUEM,QFRICM, + WORK,INTVEC,OUTSCA,OUTV2) CRUST=.TRUE. CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATEC,FRIC,G,GEOTHC, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIKC,THNKC,UPLINK, + OUTPUT,FLUXC,FLUXUC,GLUEC,QFRICC, + WORK,INTVEC,OUTSCA,OUTV2) CALL SQUEZE (G,CONDNS,TOUCHC,TOUCHM,SZZBC,SZZBM, + GEOTHA,GEOTHC,GEOTHM,NUMEL,THIKC,THIKM,TEMLIM, + ALPHAT,RHOBAR,DNLINK,UPLINK,SIGZZC,SIGZZM, + OUTSCA,THNKC,THNKM,DXSC,DXSM,DYSC,DYSM, + TAUZZC,TAUZZM,ONEKM,RHOH2O,RHOAST, + NODES,NUMNOD,PTSC,PTSM, + AREAC,AREAM,CODE,DETJC,DETJM,FAILUR,FLOWIN, + NCDIM,NDIFF,NXL,LWORK,ECLOG,HMAX,HMIN) T2MA=TIME2/(1.E6*365.25*24.*60.*60.) WRITE(6,2102) TIME2,T2MA 2102 FORMAT(' VELOCITY SOLUTION AT END OF TIME STEP:', + ' AGE = ',1P,E10.3,' (',0P,F8.3,')') WRITE(6,1103) DO 2200 I=1,NUMNOD V2C(1,I)=V1C(1,I) V2C(2,I)=V1C(2,I) V2M(1,I)=V1M(1,I) V2M(2,I)=V1M(2,I) 2200 CONTINUE CALL PURE (ACREEP,ALPHAC,ALPHAM, + AREAC,AREAM,BCREEP,BIOT,CCREEP,CONINT,DCREEP, + DELT,DELVC,DELVM,DETJC,DETJM,DXSC,DXSM, + DYSC,DYSM,ECREEP,ERATEC,ERATEM,ETAMAX, + FORCE,FRIC,FROMWC,G,GEOTHC,GEOTHM, + GLUEC,GLUEM,HMAX,HMIN,DNLINK,UPLINK, + IBELOW,MAXITR,NBAND,NKDIM,NELCOL, + NODES,NTNM,NUMEL,NUMNOD,NXL,OKTOQT,ONEKM,OUTVEC, + OUTV2,OUTSCA,PUSHHO,PTSC,PTSM, + QFRICC,QFRICM,RHOH2O,RHOBAR,STIFF, + SIGBOT,SIGHC,SIGHBM,SIGHTM, + TAUMTC,TAUMTM, + TAUZZC,TAUZZM,TEMLIM, + THIKC,THIKM,THNKC,THNKM,TOFSTC,TOFSTM, + TOUCHC,TOUCHM,LWORK,WANDES,XNODC,XNODM, + YNODC,YNODM,V2C,V2M,VISMAX,VSLABC,VSLABM, + FAILUR,DVB,DVT,OVA,OVB, + CODE,FLOWIN,CONDNS,NCDIM,NDIFF) IF (FAILUR) THEN BOXIT=.TRUE. RETURN ENDIF CALL UNFOLD (INPUT,DELT,DXSM,DYSM,NDIFUS,NCOLN,NODES, + NROWN,NUMEL,NUMNOD,XNODM,YNODM, + MODIFY,V2M, + WORK,C,CONDNS,E,N,NRD,NRDP1,PHINOD, + PK,PRCFD,P0,P1,S,W,XFD,YFD) CALL EDOT (NUMEL,NODES,V2M,NUMNOD,DXSM,DYSM,ERATEM, + ALPHAM,TOFSTM,TAUMTM) CALL EZZDOT (INPUT,AREAM,DETJM,ERATEM, + NCDIM,NDIFF,NODES, + NUMEL,NUMNOD,NXL,THIKM, + OUTPUT,W2M, + WORK,CODE,FLOWIN,LWORK) CALL EZZDOT (INPUT,AREAC,DETJC,ERATEC, + NCDIM,NDIFF,NODES, + NUMEL,NUMNOD,NXL,THIKC, + OUTPUT,W2C, + WORK,CODE,FLOWIN,LWORK) C C C ADJUST RESULTS FOR DRIFT IN RATES OVER TIMESTEP C C DO 2400 I=1,NUMNOD XNODC(I)=XNODC(I)+DELT*0.5*(V2C(1,I)-V1C(1,I)) YNODC(I)=YNODC(I)+DELT*0.5*(V2C(2,I)-V1C(2,I)) XNODM(I)=XNODM(I)+DELT*0.5*(V2M(1,I)-V1M(1,I)) YNODM(I)=YNODM(I)+DELT*0.5*(V2M(2,I)-V1M(2,I)) 2400 CONTINUE CALL INTERP (XNODC,NODES,NUMEL,NUMNOD,XIPC) CALL INTERP (YNODC,NODES,NUMEL,NUMNOD,YIPC) CALL INTERP (XNODM,NODES,NUMEL,NUMNOD,XIPM) CALL INTERP (YNODM,NODES,NUMEL,NUMNOD,YIPM) CALL INLAND (INPUT,XIPC,YIPC,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMWC) CALL INLAND (INPUT,XIPM,YIPM,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMWM) DO 2500 I=1,NUMNOD THNKC(I)=THNKC(I)+0.5*DELT*(W2C(I)-W1C(I)) THNKC(I)=MAX(THNKC(I),HMIN(1)) THNKC(I)=MIN(THNKC(I),HMAX(1)) THNKM(I)=THNKM(I)+0.5*DELT*(W2M(I)-W1M(I)) THNKM(I)=MAX(THNKM(I),HMIN(2)) THNKM(I)=MIN(THNKM(I),HMAX(2)) 2500 CONTINUE CALL INTERP (THNKC,NODES,NUMEL,NUMNOD,THIKC) CALL INTERP (THNKM,NODES,NUMEL,NUMNOD,THIKM) DO 2600 M=1,7 DO 2590 I=1,NUMEL THIKC(M,I)=MAX(THIKC(M,I),HMIN(1)) THIKM(M,I)=MAX(THIKM(M,I),HMIN(2)) THIKC(M,I)=MIN(THIKC(M,I),HMAX(1)) THIKM(M,I)=MIN(THIKM(M,I),HMAX(2)) 2590 CONTINUE 2600 CONTINUE DO 2700 M=1,7 DO 2690 I=1,NUMEL ARATE=ERATEC(1,M,I)+ERATEC(2,M,I) DGDT2C(1,M,I)=0. DGDT2C(2,M,I)=GEOTHC(2,M,I)*ARATE DGDT2C(3,M,I)=2.*GEOTHC(3,M,I)*ARATE C COMPUTE AS DOUBLE; SAVE AS SINGLE PRECISION: TWICE=3.D0*GEOTHC(4,M,I)*ARATE IF (ABS(TWICE).GT.5.D-43) THEN DGDT2C(4,M,I)=TWICE ELSE DGDT2C(4,M,I)=0.0 ENDIF ARATE=ERATEM(1,M,I)+ERATEM(2,M,I) DGDT2M(1,M,I)=0. DGDT2M(2,M,I)=GEOTHM(2,M,I)*ARATE DGDT2M(3,M,I)=2.*GEOTHM(3,M,I)*ARATE C COMPUTE AS DOUBLE; SAVE AS SINGLE PRECISION: TWICE=3.D0*GEOTHM(4,M,I)*ARATE IF (ABS(TWICE).GT.5.D-43) THEN DGDT2M(4,M,I)=TWICE ELSE DGDT2M(4,M,I)=0.0 ENDIF 2690 CONTINUE 2700 CONTINUE CALL HEATER (INPUT,AREAC,AREAM, + CONDUC,DIFFUS, + DETJC,DETJM,DNLINK, + NCDIM,NDIFF,NODES,NUMEL,NUMNOD, + NXL,QFRICC,QFRICM, + THIKC,THIKM,THNKC,THNKM, + UPLINK, + MODIFY,DGDT2C,DGDT2M, + WORK,CODE,CONDNS,FLOWIN,LWORK,OUTSCA,QWORK) DO 2800 M=1,7 DO 2790 I=1,NUMEL DO 2780 K=1,4 GEOTHC(K,M,I)=GEOTHC(K,M,I)+DELT*0.5* + (DGDT2C(K,M,I)- DGDT1C(K,M,I)) GEOTHM(K,M,I)=GEOTHM(K,M,I)+DELT*0.5* + (DGDT2M(K,M,I)-DGDT1M(K,M,I)) EDOTC(K,M,I)=0.5*(ERATEC(K,M,I)-EDOTC(K,M,I)) EDOTM(K,M,I)=0.5*(ERATEM(K,M,I)-EDOTM(K,M,I)) 2780 CONTINUE 2790 CONTINUE 2800 CONTINUE CALL EPLUSE (EDOTC,DELT,ESUMC,NUMEL) CALL EPLUSE (EDOTM,DELT,ESUMM,NUMEL) CALL CRUSTS (INPUT,AREAC,DELT,DETJC,EDOTC,HMAX,HMIN, + NCDIM,NDIFF,NODES,NUMEL,NUMNOD, + NXL,THIKC,THNKC, + MODIFY,CONNOD, + OUTPUT,CONINT, + WORK,CODE,CONDNS,FLOWIN,LWORK,OUTSCA) C C C COMPARE RATES TO THOSE AT BEGINNING OF TIMESTEP C C DO 2810 I=1,4 BASIS(I)=0. PERCEN(I)=0. 2810 CONTINUE DO 2900 I=1,NUMNOD PERCEN(1)=PERCEN(1)+(V1C(1,I)-V2C(1,I))**2+ + (V1C(2,I)-V2C(2,I))**2 PERCEN(2)=PERCEN(2)+(V1M(1,I)-V2M(1,I))**2+ + (V1M(2,I)-V2M(2,I))**2 BASIS(1)=BASIS(1)+V1C(1,I)**2+V1C(2,I)**2+ + V2C(1,I)**2+V2C(2,I)**2 BASIS(2)=BASIS(2)+V1M(1,I)**2+V1M(2,I)**2+ + V2M(1,I)**2+V2M(2,I)**2 PERCEN(3)=PERCEN(3)+(W1C(I)-W2C(I))**2 PERCEN(4)=PERCEN(4)+(W1M(I)-W2M(I))**2 BASIS(3)=BASIS(3)+W1C(I)**2+W2C(I)**2 BASIS(4)=BASIS(4)+W1M(I)**2+W2M(I)**2 2900 CONTINUE DO 2950 I=1,4 BASIS(I)=SQRT(BASIS(I)/(2*NUMNOD)) PERCEN(I)=SQRT(PERCEN(I)/NUMNOD) PERCEN(I)=PERCEN(I)/BASIS(I) 2950 CONTINUE WRITE(6,2999) (PERCEN(I),I=1,4),(BASIS(I),I=1,4) 2999 FORMAT(' SUBPROGRAM STEP REPORTS FOLLOWING CHANGES DURING ', + 'TIMESTEP:'/ + 33X,'V.OF.CRUST V.OF.MNTLE W.OF.CRUST W.OF.MANTLE'/ + 11X,'RMS CHANGE/RMS BASIS:',0P,4F11.7/ + 11X,' RMS BASIS:',1P,4E11.2) RETURN END C C C SUBROUTINE AREAS (NODES,AREA,XNOD,YNOD,NUMNOD,NUMEL) 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,0:NUMEL),XNOD(NUMNOD),YNOD(NUMNOD) DO 100 INDEX=1,NUMEL I1=NODES(1,INDEX) I2=NODES(2,INDEX) I3=NODES(3,INDEX) AREA(INDEX)= 0.5*(XNOD(I1)*YNOD(I2)-XNOD(I2)*YNOD(I1) + +XNOD(I2)*YNOD(I3)-XNOD(I3)*YNOD(I2) + +XNOD(I3)*YNOD(I1)-XNOD(I1)*YNOD(I3)) 100 CONTINUE RETURN END C C C SUBROUTINE DERIV (NUMEL,NUMNOD,NODES,XNOD,YNOD,AREA, + DETJ,DXS,DYS,NUMBAD,LISTOP) 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 LOGICAL LISTOP DIMENSION AREA(NUMEL),B(4),C(4),DETJ(7,NUMEL),DN(6,2), + DXS(6,7,NUMEL),DYS(6,7,NUMEL), + LISTOP(NUMEL),NODES(6,0:NUMEL),POINTS(5,7), + X(6),XNOD(NUMNOD),Y(6),YNOD(NUMNOD) COMMON /L1L2L3/ POINTS NUMBAD=0 DO 500 I=1,NUMEL LISTOP(I)=.FALSE. DO 100 J=1,6 NODE=NODES(J,I) X(J)=XNOD(NODE) Y(J)=YNOD(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 IF (DETJAC.LT.0.) LISTOP(I)=.TRUE. 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 IF (LISTOP(I)) NUMBAD=NUMBAD+1 500 CONTINUE RETURN END C C C SUBROUTINE ORTHO (NODES,XNOD,YNOD,LISTOP,NUMEL,NUMNOD, + NELCOL,XIP,YIP) C C STRAIGHTENS SIDES OF ELEMENTS WITH NEGATIVE AREAS C AT ANY OF THEIR INTEGRATION POINTS (AS INDICATED BY LISTOP=T) C BY BACKING-OFF 10% OF TOTAL BENDING OF THE SIDES. C TEN APPLICATIONS CAN REMOVE UP TO 65% OF BENDING IF SAME C ELEMENT IS OPERATED ON EACH TIME. C SLOW AND CAUTIOUS PACE IS NECESSARY BECAUSE OF POSSIBLE ADVERSE C EFFECTS ON OTHER ELEMENTS, WHICH MAY REQUIRE PROPAGATION OF A C WAVE OF CORRECTIONS. C LOGICAL FIXED,LISTOP DIMENSION LISTOP(NUMEL),NODES(6,0:NUMEL), + XIP(7,NUMEL),XNOD(NUMNOD),YIP(7,NUMEL),YNOD(NUMNOD) FIXED(J)=J.LT.NCOLN.OR.(MOD(J,NCOLN).EQ.0).OR. + ((NUMNOD-J).LT.NCOLN) NCOLN=2*NELCOL+1 DO 1000 I=1,NUMEL IF (LISTOP(I)) THEN J1=NODES(1,I) J2=NODES(2,I) J3=NODES(3,I) J4=NODES(4,I) J5=NODES(5,I) J6=NODES(6,I) IF (.NOT.FIXED(J4)) THEN DX4=XNOD(J4)-0.5*(XNOD(J1)+XNOD(J2)) DY4=YNOD(J4)-0.5*(YNOD(J1)+YNOD(J2)) XNOD(J4)=XNOD(J4)-0.1*DX4 YNOD(J4)=YNOD(J4)-0.1*DY4 ENDIF IF (.NOT.FIXED(J5)) THEN DX5=XNOD(J5)-0.5*(XNOD(J2)+XNOD(J3)) DY5=YNOD(J5)-0.5*(YNOD(J2)+YNOD(J3)) XNOD(J5)=XNOD(J5)-0.1*DX5 YNOD(J5)=YNOD(J5)-0.1*DY5 ENDIF IF(.NOT.FIXED(J6)) THEN DX6=XNOD(J6)-0.5*(XNOD(J3)+XNOD(J1)) DY6=YNOD(J6)-0.5*(YNOD(J3)+YNOD(J1)) XNOD(J6)=XNOD(J6)-0.1*DX6 YNOD(J6)=YNOD(J6)-0.1*DY6 ENDIF ENDIF 1000 CONTINUE CALL INTERP(XNOD,NODES,NUMEL,NUMNOD,XIP) CALL INTERP(YNOD,NODES,NUMEL,NUMNOD,YIP) RETURN END C C C SUBROUTINE LINKER (NELCOL,NUMEL,XIP1,YIP1, + DETJ2,XIP2,YIP2,XNOD2,YNOD2, + NUMNOD,NODES,AREA,UDLINK,INLOOP) C C FINDS ELEMENT AND INTERNAL COORDINATES IN OPPOSITE GRID MATCHING C LOCATION OF EACH INTEGRATION POINT IN THE FIRST GRID, AND STORES C THEM IN UDLINK(1-3,M,I); WHERE M AND I ARE THE INTEGRATION POINT C AND ELEMENT IN THE FIRST GRID. C UDLINK(1,M,I) HOLDS THE ELEMENT NUMBER (+0.10) FROM THE OTHER; C UDLINK(2,M,I) HOLDS THE S2 INTERNAL COORDINATE; C UDLINK(3,M,I) HOLDS THE S3 INTERNAL COORDINATE. C THE S1 COORDINATE IS NOT STORED: S1=1.00-S2-S3 C LOGICAL INLOOP,ISTRAP,LEFTY,ODD,RIGHT,TRUBBL REAL M11,M12,M13,M21,M22,M23,M31,M32,M33 DIMENSION AREA(NUMEL),DETJ2(7,NUMEL),ITHIST(50), + NODES(6,0:NUMEL),SHIST(3,50),UDLINK(3,7,NUMEL), + XIP1(7,NUMEL),XIP2(7,NUMEL), + XNOD2(NUMNOD), + YIP1(7,NUMEL),YIP2(7,NUMEL), + YNOD2(NUMNOD) C C STATEMENT FUNCTIONS: ODD(I)=MOD(I,2).EQ.1 RIGHT(I)=MOD(I,NELWID).EQ.0 LEFTY(I)=MOD(I,NELWID).EQ.1 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 NELWID=2*NELCOL INLOOP=.FALSE. IT=NUMEL C C LOOP ON POINTS WHOSE COORDINATES ARE TO BE FOUND: DO 1000 I=NUMEL,1,-1 IF(RIGHT(I)) IT=I DO 900 M=1,7 X=XIP1(M,I) Y=YIP1(M,I) NTRIED=0 C C BEGIN LOOP ON ELEMENTS WHICH MIGHT CONTAIN THE POINT: 100 NTRIED=NTRIED+1 ITHIST(NTRIED)=IT TRUBBL=(NTRIED.GE.3).AND.(ITHIST(NTRIED).EQ. + ITHIST(NTRIED-2)) IF (TRUBBL) THEN I1=I M1=M CALL SURVEY (INPUT,I1,M1,NUMEL, + X,XIP2,Y,YIP2, + OUTPUT,UDLINK) GO TO 898 ENDIF I1=NODES(1,IT) I2=NODES(2,IT) I3=NODES(3,IT) I4=NODES(4,IT) I5=NODES(5,IT) I6=NODES(6,IT) X1=XNOD2(I1) X2=XNOD2(I2) X3=XNOD2(I3) Y1=YNOD2(I1) Y2=YNOD2(I2) Y3=YNOD2(I3) ISTRAP=(DETJ2(1,IT).LE.0.2).OR. + (DETJ2(2,IT).LE.0.2).OR. + (DETJ2(3,IT).LE.0.2).OR. + (DETJ2(4,IT).LE.0.2).OR. + (DETJ2(5,IT).LE.0.2).OR. + (DETJ2(6,IT).LE.0.2).OR. + (DETJ2(7,IT).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=XNOD2(I4) X5=XNOD2(I5) X6=XNOD2(I6) Y4=YNOD2(I4) Y5=YNOD2(I5) Y6=YNOD2(I6) ENDIF S1=1./3. S2=S1 S3=1.-S1-S2 LIMIT=3 NREFIN=0 C C C LOOP TO REFINE ESTIMATE OF INTERNAL COORDINATES 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),(DYDS1,DYDS2,DYDS3),(1,1,1)); 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 UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 898 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 200 IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.40).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 SHIST(1,NTRIED)=S1 SHIST(2,NTRIED)=S2 SHIST(3,NTRIED)=S3 IF (NTRIED.GE.50) THEN INLOOP=.TRUE. WRITE(6,201) M,I,X,Y 201 FORMAT(' INTEGRATION POINT ',I1,' IN ELEMENT ', + I3,' AT (',1P,E10.2,',',E10.2,') CAUSES ', + 'INFINITE LOOP IN LINKER.'/ + ' HISTORY OF SEARCH: ELEMENT S1 S2', + ' S3') 202 FORMAT(22X,I3,2X,3F12.4) DO 203 N=1,50 WRITE(6,202) ITHIST(N),(SHIST(K,N),K=1,3) 203 CONTINUE WRITE(6,204) ITHIST(49),(NODES(J,ITHIST(49)), + J=1,6),(XNOD2(NODES(J,ITHIST(49))),J=1,6), + (YNOD2(NODES(J,ITHIST(49))),J=1,6) WRITE(6,204) ITHIST(50),(NODES(J,ITHIST(50)), + J=1,6),(XNOD2(NODES(J,ITHIST(50))),J=1,6), + (YNOD2(NODES(J,ITHIST(50))),J=1,6) 204 FORMAT(' ELEMENT',I3,' NODES:',I3,5I10/ + 9X,'X:',1P,6E10.2/9X,'Y:',6E10.2) RETURN ENDIF IF (ODD(IT)) THEN IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF (LEFTY(IT)) THEN UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 898 ELSE IT=IT-1 GO TO 100 ENDIF ELSE IF(IT.GT.NELWID) THEN IT=IT-NELWID+1 GO TO 100 ELSE GO TO 500 ENDIF ELSE IT=IT+1 GO TO 100 ENDIF ELSE IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF(MOD(IT,NELWID).NE.0) THEN IT=IT+1 GO TO 100 ELSE GO TO 500 ENDIF ELSE IF ((NUMEL-IT).GE.NELWID) THEN IT=IT+NELWID-1 GO TO 100 ELSE GO TO 500 ENDIF ELSE IT=IT-1 GO TO 100 ENDIF ENDIF 500 UDLINK(1,M,I)=IT+0.10 UDLINK(2,M,I)=S2 UDLINK(3,M,I)=S3 898 CONTINUE 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE SURVEY (INPUT,I1,M1,NUMEL, + X,XIP,Y,YIP, + OUTPUT,UDLINK) C C FINDS THE CLOSEST INTEGRATION POINT IN GRID (XIP,YIP) C TO THE GIVEN POINT (X,Y), AND STORES THE COORDINATES C IN UDLINK(1-3,M1,I1); WHERE M1 AND I1 ARE THE INTEGRATION POINT C AND ELEMENT IN THE FIRST GRID. C UDLINK(1,M1,I1) HOLDS THE ELEMENT NUMBER (+0.10); C UDLINK(2,M1,I1) HOLDS THE S2 INTERNAL COORDINATE; C UDLINK(3,M1,I1) HOLDS THE S3 INTERNAL COORDINATE. C THE S1 COORDINATE IS NOT STORED: S1=1.00-S2-S3 C THIS ROUTINE IS A ROUGH REPLACEMENT FOR "LINKER" IN CASES WHERE C IT FAILS DUE TO VERY DISTORTED ELEMENTS. C LOGICAL INSIDE DOUBLE PRECISION POINTS COMMON /L1L2L3/ POINTS DIMENSION POINTS(5,7),UDLINK(3,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) DATA BIGNUM/3.E38/ C R2MIN=BIGNUM IS=1 MS=1 DO 100 M=1,7 DO 90 I=1,NUMEL R2=(X-XIP(M,I))**2+(Y-YIP(M,I))**2 IF (R2.LT.R2MIN) THEN R2MIN=R2 IS=I MS=M ENDIF 90 CONTINUE 100 CONTINUE R2C=(X-XIP(1,IS))**2+(Y-YIP(1,IS))**2 DXA=XIP(1,IS)-XIP(5,IS) DXB=XIP(1,IS)-XIP(6,IS) DXC=XIP(1,IS)-XIP(7,IS) DYA=YIP(1,IS)-YIP(5,IS) DYB=YIP(1,IS)-YIP(6,IS) DYC=YIP(1,IS)-YIP(7,IS) RA2=DXA**2+DYA**2 RB2=DXB**2+DYB**2 RC2=DXC**2+DYC**2 R2CRIT=1.5*MAX(RA2,RB2,RC2) INSIDE=R2C.LE.R2CRIT IF (INSIDE) THEN UDLINK(1,M1,I1)=IS+0.1 UDLINK(2,M1,I1)=POINTS(2,MS) UDLINK(3,M1,I1)=POINTS(3,MS) ELSE UDLINK(1,M1,I1)=0. UDLINK(2,M1,I1)=0. UDLINK(3,M1,I1)=0. ENDIF RETURN END C C C SUBROUTINE LOOKUP (INPUT,AREA,DETJ, + NELCOL,NODES,NUMEL,NUMNOD, + X,XIP,XNODE,Y,YIP,YNODE, + MODIFY,IE,S1,S2,S3, + OUTPUT,ATSEA) C C FINDS ELEMENT AND INTERNAL COORDINATES IN OPPOSITE GRID MATCHING C LOCATION OF A PARTICULAR POINT, AND REPORTS THEM AS IE AND S1,S2,S3. C C NOTE THAT THE LOGIC OF LOOKUP IS ALMOST THE SAME AS IN LINKER, C BUT THAT LOOKUP OPERATES ON ONE POINT AT A TIME. C C A RETURNED VALUE OF ATSEA INDICATES THAT POINT FELL OFF "LEFT" EDGE C OF THE GRID; OTHERWISE ALL SEARCHES ARE LIMITED WITHIN GRID BOUNDS. C THAT IS, THIS ROUTINE WILL NOT REPORT A FAILURE IF THE POINT FALLS C OFF ANY OTHER SIDE OF THE GRID, BECAUSE WE ASSUME THAT IS JUST A C TINY BIT OFF BECAUSE OF SOME MINOR MISALIGNMENT. C LOGICAL ATSEA,ISTRAP,LEFTY,ODD,RIGHT,TRUBBL REAL M11,M12,M13,M21,M22,M23,M31,M32,M33 DIMENSION AREA(NUMEL),DETJ(7,NUMEL),IEHIST(50), + NODES(6,0:NUMEL),SHIST(3,50), + XIP(7,NUMEL),YIP(7,NUMEL), + XNODE(NUMNOD),YNODE(NUMNOD) DIMENSION DUMMY(3,1,1) C C STATEMENT FUNCTIONS: C ODD(I)=MOD(I,2).EQ.1 RIGHT(I)=MOD(I,NELWID).EQ.0 LEFTY(I)=MOD(I,NELWID).EQ.1 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 NELWID=2*NELCOL NTRIED=0 C C LOOP AS MANY TIMES AS NEEDED: C 100 NTRIED=NTRIED+1 IEHIST(NTRIED)=IE TRUBBL=(NTRIED.GE.9).AND.(IEHIST(NTRIED).EQ. + IEHIST(NTRIED-2)) IF (TRUBBL) THEN CALL SURVEY (INPUT,1,1,NUMEL, + X,XIP,Y,YIP, + OUTPUT,DUMMY) IF (DUMMY(1,1,1).GT.0.0) THEN IE=DUMMY(1,1,1) S2=DUMMY(2,1,1) S3=DUMMY(3,1,1) S1=1.00-S2-S3 ATSEA=.FALSE. ELSE ATSEA=.TRUE. ENDIF 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 IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.40).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 SHIST(1,NTRIED)=S1 SHIST(2,NTRIED)=S2 SHIST(3,NTRIED)=S3 IF (TRUBBL.OR.NTRIED.GE.50) THEN WRITE(6,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(6,202) IEHIST(N),(SHIST(K,N),K=1,3) 202 FORMAT(22X,I3,2X,3F12.4) 203 CONTINUE WRITE(6,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(6,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 (ODD(IE)) THEN IF (S1.GT.-0.03) THEN IF (S2.GT.-0.03) THEN IF (S3.GT.-0.03) THEN ATSEA=.FALSE. RETURN ELSE IF (LEFTY(IE)) THEN ATSEA=.TRUE. RETURN ELSE IE=IE-1 S1=0.3333 S2=0.3333 S3=0.3334 GO TO 100 ENDIF ELSE IF(IE.GT.NELWID) THEN IE=IE-NELWID+1 S1=0.3333 S2=0.3333 S3=0.3334 GO TO 100 ELSE ATSEA=.FALSE. RETURN ENDIF ELSE IE=IE+1 S1=0.3333 S2=0.3333 S3=0.3334 GO TO 100 ENDIF ELSE IF (S1.GT.-0.03) THEN IF (S2.GT.-0.03) THEN IF (S3.GT.-0.03) THEN ATSEA=.FALSE. RETURN ELSE IF(MOD(IE,NELWID).NE.0) THEN IE=IE+1 S1=0.3333 S2=0.3333 S3=0.3334 GO TO 100 ELSE ATSEA=.FALSE. RETURN ENDIF ELSE IF ((NUMEL-IE).GE.NELWID) THEN IE=IE+NELWID-1 S1=0.3333 S2=0.3333 S3=0.3334 GO TO 100 ELSE ATSEA=.FALSE. RETURN ENDIF ELSE IE=IE-1 S1=0.3333 S2=0.3333 S3=0.3334 GO TO 100 ENDIF ENDIF END C C C SUBROUTINE SETCUB (THIKM,NUMEL,GEOTHM,GEOTHA,OUTSCA,TASTH, + THIKC,GEOTHC,DNLINK,TOUCHC,TOUCHM,TSLAB0, + AREAM,CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NODES,NUMNOD,NXL,LWORK, + TSURF,FROMWC,FROMWM,ONEKM) C C ADJUSTS LOWER PART OF GEOTHERMS TO BOTTOM BOUNDARY CONDITION C AFTER AN INCREMENT OF SIMPLE SHEAR (NO NEED AFTER PURE SHEAR), C OR WHEN DIFFERENT MATERIAL SHIFTS BENEATH THE LAYER. C LOGICAL FAILUR,LOCKIN,LOCKWC DOUBLE PRECISION CODE,FLOWIN DIMENSION GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), + DNLINK(3,7,NUMEL),OUTSCA(7,NUMEL), + THIKC(7,NUMEL),THIKM(7,NUMEL), + TOUCHC(7,NUMEL),TOUCHM(7,NUMEL), + AREAM(NUMEL),CODE(NCDIM),DETJM(7,NUMEL), + FLOWIN(NUMNOD),CONDNS(NUMNOD), + NODES(6,0:NUMEL),LWORK(NXL), + FROMWC(7,NUMEL),FROMWM(7,NUMEL) DATA BIGNUM /3.E38/, LOCKIN /.FALSE./, LOCKWC /.FALSE./ C C ASTHENOSPHERE LAYER, WITH POTENTIAL THERMAL BOUNDARY LAYER C DO 100 M=1,7 DO 90 I=1,NUMEL IF ((TOUCHC(M,I).LE.0.).AND. + (DNLINK(1,M,I).LE.0.)) THEN C C RESET BASE, BUT ALLOW THERMAL EVOLUTION C Z=THIKM(5,NUMEL) TBOT=GEOTHA(1,M,I)+ GEOTHA(2,M,I)*Z+ + GEOTHA(3,M,I)*Z**2+GEOTHA(4,M,I)*Z**3 CORREC=TASTH-TBOT GEOTHA(4,M,I)=GEOTHA(4,M,I)+CORREC/Z**3 ELSE C C RESET WHOLE BOUNDARY LAYER C GEOTHA(1,M,I)=TASTH GEOTHA(2,M,I)=0. GEOTHA(3,M,I)=0. GEOTHA(4,M,I)=0. ENDIF 90 CONTINUE 100 CONTINUE C C MANTLE LITHOSPHERE LAYER C CALL TMOHO (THIKM,NUMEL,GEOTHM,BIGNUM,OUTSCA) DO 200 M=1,7 DO 190 I=1,NUMEL TBOT=OUTSCA(M,I) XLEFT=FROMWM(M,I) IF (TOUCHM(M,I).GE.0.99) THEN TBOTC=TSLAB(TSURF,TSLAB0,XLEFT,ONEKM) ELSE TBOTC=TASTH ENDIF CORREC=TBOTC-TBOT GEOTHM(4,M,I)=GEOTHM(4,M,I)+CORREC/THIKM(M,I)**3 190 CONTINUE 200 CONTINUE C C CRUSTAL LAYER C DO 220 M=1,7 DO 210 I=1,NUMEL OUTSCA(M,I)=GEOTHM(1,M,I) 210 CONTINUE 220 CONTINUE CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 300 M=1,7 DO 290 I=1,NUMEL D=THIKC(M,I) TBASE=GEOTHC(1,M,I)+ + GEOTHC(2,M,I)*D+ + GEOTHC(3,M,I)*D**2+ + GEOTHC(4,M,I)*D**3 I2=DNLINK(1,M,I) IF (I2.GT.0) THEN TBOT=OUTSCA(M,I) ELSE IF (TOUCHC(M,I).GE.0.99) THEN XLEFT=FROMWC(M,I) TBOT=TSLAB(TSURF,TSLAB0,XLEFT,ONEKM) ELSE TBOT=GEOTHA(1,M,I) ENDIF ENDIF CORREC=TBOT-TBASE GEOTHC(4,M,I)=GEOTHC(4,M,I)+CORREC/THIKC(M,I)**3 290 CONTINUE 300 CONTINUE RETURN END C C C REAL FUNCTION TSLAB(TSURF,TSLAB0,XLEFT,ONEKM) C C COMPUTES SLAB-SURFACE TEMPERATURE BASED ON X**1/3 INCREASE C X=MAX(XLEFT,1.) TSLAB=TSURF+(TSLAB0-TSURF)*(X/(1000.*ONEKM))**0.333 RETURN END C C C SUBROUTINE ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATE,FRIC,G,GEOTH, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIK,THNKC,UPLINK, + OUTPUT,FLUX,FLUXUC,GLUE,QFRIC, + WORK,ILAYER,OUTSCA,ZBEAM) C C CALCULATES: C *GLUE (SHEAR STRESS REQUIRED TO CREATE UNIT RELATIVE C HORIZONTAL VELOCITY ACROSS A LAYER), AND C *FLUX (VERTICAL INTEGRAL OF HORIZONTAL VELOCITY CAUSED BY A C UNIT OF RELATIVE HORIZONTAL VELOCITY ACROSS A LAYER) C *FLUXUC (FOR CRUST ONLY, VERTICAL INTEGRAL DOWN TO THE CONRAD OF C HORIZONTAL VELOCITY CAUSED BY A UNIT OF RELATIVE HORIZONTAL C VELOCITY IMPOSED ON THE MOHO) C *QFRIC(4,M,I) IS THE DEPTH (FROM THE LAYER TOP) OF THE CENTER C OF THE DETACHMENT SHEAR ZONE, AT INT. POINT I IN ELEMENT I. C C NOTE: UNTIL THE REVISION (9/07/1988) THIS ROUTINE USED C TO CONSUME 30% OF THE TOTAL TIME IN SOME RUNS. C THIS REVISION VECTORIZES WELL WITH IBM FORTVS. C PARAMETER (NINT=100) DOUBLE PRECISION SECINV LOGICAL CRUST,MANTLE DIMENSION ACREEP(3),BCREEP(3),CCREEP(3),DCREEP(3),ECREEP(3), + CONINT(7,NUMEL), + ERATE(4,7,NUMEL), + FLUX(7,NUMEL),FLUXUC(7,NUMEL), + FRIC(2), + GEOTH(4,7,NUMEL), + GLUE(7,NUMEL), + ILAYER(NUMEL), + NODES(6,0:NUMEL), + OUTSCA(7,NUMEL), + QFRIC(4,7,NUMEL), + RHOBAR(2), + TEMLIM(2), + THIK(7,NUMEL), + THNKC(NUMNOD), + UPLINK(3,7,NUMEL), + ZBEAM(7,NUMEL) C MANTLE=.NOT.CRUST 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 DO 7 M=1,7 C*VDIR: ASSUME COUNT(280) DO 6 I=1,NUMEL FLUX(M,I)=0. GLUE(M,I)=0. 6 CONTINUE 7 CONTINUE C IF (CRUST) THEN DO 9 M=1,7 C*VDIR: ASSUME COUNT(280) DO 8 I=1,NUMEL FLUXUC(M,I)=0. 8 CONTINUE 9 CONTINUE ILE=1 STFRIC=SIN(ATAN(FRIC(1))) TLIM=TEMLIM(1) DPEDZ=G*(RHOBAR(1)-RHOH2O*BIOT) DO 20 M=1,7 C*VDIR: ASSUME COUNT(280) DO 10 I=1,NUMEL OUTSCA(M,I)=0. 10 CONTINUE 20 CONTINUE ELSE ILE=3 STFRIC=SIN(ATAN(FRIC(2))) TLIM=TEMLIM(2) CALL GETSCA(INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DPEDZ=G*(RHOBAR(2)-RHOH2O*BIOT) C*VDIR: ASSUME COUNT(280) DO 25 I=1,NUMEL ILAYER(I)=3 25 CONTINUE ENDIF C C FIND REFERENCE LEVEL, TO WHICH NODAL VELOCITIES REFER: C IN CRUST, THIS IS ALWAYS THE SURFACE; C IN MANTLE, IT IS THE STRONGEST LEVEL: C DO 28 M=1,7 C*VDIR: ASSUME COUNT(280) DO 27 I=1,NUMEL IF (CRUST) THEN ZBEAM(M,I)=0.0 ELSE PE0=G*OUTSCA(M,I)*(RHOBAR(1)-RHOH2O*BIOT) EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) DIVER=EXX+EYY SHEAR=SQRT((1.D0*EXY)**2+ + 0.25D0*(1.D0*EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR EZZ=-DIVER SECINV=(1.D0*E1)*E2+(1.D0*E1)*EZZ+(1.D0*E2)*EZZ DEFORM=2.*SQRT(ABS(SECINV)) EN=DEFORM**ECREEP(3) ANGLE=ATAN2F(E2,E1)-0.7854 FACTOR=1./(1.+STFRIC*COS(ANGLE)) ZBEAM(M,I)=THIK(M,I) STRMAX=0.0 DO 26 K=0,10,1 Z=(THIK(M,I)*K)/10 ZABS=Z+OUTSCA(M,I) 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,TLIM) ARG=(BCREEP(3)+CCREEP(3)*ZABS)/TL ARG=MAX(MIN(ARG,88.),-97.) SCP=ACREEP(3)*EN*EXP(ARG) SF=STFRIC*(PE0+DPEDZ*Z)*FACTOR SCP=MIN(SCP,DCREEP(3),SF) IF (SCP.GE.STRMAX) THEN ZBEAM(M,I)=Z STRMAX=SCP ENDIF 26 CONTINUE ENDIF 27 CONTINUE 28 CONTINUE C C BEGIN CRITICAL TRIPLY-NESTED LOOPS C DO 100 M=1,7 DO 60 J=1,NINT C C SEPARATE OUT CHOICE OF MATERIAL ,IN CASE IT BLOCKS VECTORIZATION C IF (CRUST) THEN C*VDIR: ASSUME COUNT(280) DO 30 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=ZBEAM(M,I)+(J-0.5)/NINT* + (THIK(M,I)-ZBEAM(M,I)) IF (Z.GT.CONINT(M,I)) THEN ILAYER(I)=2 ELSE ILAYER(I)=1 ENDIF 30 CONTINUE ENDIF C C CRITICAL, TRIPLY-NESTED LOOP; MUST BE VECTORIZED: C C*VDIR: ASSUME COUNT(280) DO 50 I=1,NUMEL Z=ZBEAM(M,I)+(J-0.5)/NINT* + (THIK(M,I)-ZBEAM(M,I)) 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,TLIM) ACI=ACREEP(ILAYER(I)) BCI=BCREEP(ILAYER(I)) CCI=CCREEP(ILAYER(I)) ECINI= -1.0/ECREEP(ILAYER(I)) AILOG=LOG(ACI)*ECINI BI=(BCI+CCI*(Z+OUTSCA(M,I)))*ECINI ARG=MAX(AILOG+BI/TL,-97.) GLUE(M,I)=GLUE(M,I)+EXP(ARG) FLUX(M,I)=FLUX(M,I)+GLUE(M,I) FLUXUC(M,I)=FLUXUC(M,I)+GLUE(M,I)*(2-ILAYER(I)) 50 CONTINUE 60 CONTINUE C C CORRECT FOR EXCESSIVE WEIGHT ON LAST VALUE OF "GLUE" (VELOCITY) C IN INTEGRATION OF FLUX (I.E., APPLY TRAPEZOIDAL RULE): C C*VDIR: ASSUME COUNT(280) DO 70 I=1,NUMEL FLUX(M,I)=FLUX(M,I)-0.5*GLUE(M,I) 70 CONTINUE C C MULTIPLY SUMS BY COMMON FACTORS AND TRANSFORM DIMENSIONS C C*VDIR: ASSUME COUNT(280) DO 80 I=1,NUMEL FLUX(M,I)=FLUX(M,I)*(THIK(M,I)-ZBEAM(M,I))/ + (GLUE(M,I)*NINT) 80 CONTINUE IF (CRUST) THEN C*VDIR: ASSUME COUNT(280) DO 85 I=1,NUMEL FLUXUC(M,I)=FLUXUC(M,I)*THIK(M,I)/ + (GLUE(M,I)*NINT) 85 CONTINUE ENDIF C*VDIR: ASSUME COUNT(280) DO 90 I=1,NUMEL GLUE(M,I)=(GLUE(M,I)*MAX(1.,(THIK(M,I)-ZBEAM(M,I)))/ + NINT)**(-ECREEP(ILE)) QFRIC(4,M,I)=THIK(M,I)-FLUX(M,I) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE BELOW (INPUT,CPNLAT,ECLOG,FROMW,IBELOW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C SELECTS ONE OF THE POSSIBLE SLAB MODEL FOR THE BOTTOM BC. C 0 = NO CONTACT OF SLABS WITH BASE OF MODEL (NULL B.C.) C 1 = NORTH AMERICA (NORTHERN OPTION) C 2 = NORTH AMERICA (SOUTHERN OPTION) C 3 = ROUGH VERSION OF SOUTH AMERICAN (SIERRA DE PAMPEANAS) C 4 = ROUGH VERSION OF CHINA (SHORT 200 KM UNDERTHRUST) C 5 = ? C C IF (IBELOW.LE.0) THEN CALL BELOW0(INPUT,NUMEL, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOW.EQ.1) THEN CALL BELOW1(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOW.EQ.2) THEN CALL BELOW2(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOW.EQ.3) THEN CALL BELOW3(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOW.EQ.4) THEN CALL BELOW4(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C ELSE IF (IBELOW.EQ.5) THEN C CALL BELOW5(INPUT,CPNLAT,ECLOG,FROMW, C + NELCOL,NUMEL, C + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, C + WANDES,XIP,YIP,X0ELON,Y0NLAT, C + OUTPUT,SZZ,TOUCH,VSLAB) ENDIF RETURN END C C C SUBROUTINE BELOW0(INPUT,NUMEL, + OUTPUT,SZZ,TOUCH,VSLAB) C C NULL BOUNDARY CONDITIONS (NO CONTACT) C DIMENSION SZZ(7,NUMEL),TOUCH(7,NUMEL),VSLAB(2,7,NUMEL) C DO 20 M=1,7 DO 10 I=1,NUMEL SZZ(M,I)=0. TOUCH(M,I)=0. VSLAB(1,M,I)=0. VSLAB(2,M,I)=0. 10 CONTINUE 20 CONTINUE RETURN END C C C SUBROUTINE BELOW1(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C "BELOW1", LINKED TO /NORTH1/,/NORTH2/, AND /NORTH3/, C REPRESENTS THE NORTHERN OPTION FOR NORTH AMERICA C C NOTE: THESE DIMENSION PARAMETERS MUST AGREE C IN ALL PROGRAMS !!!!!! C C MAXIMUM NUMBER OF DIGITISED SLAB HINGELINES: PARAMETER (MAXHL=20) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED HINGELINE: PARAMETER (MAXHNG=40) C MAXIMUM NUMBER OF FINITE ROTATIONS FOR EACH PLATE: PARAMETER (MAXROT=21) C MAXIMUM NUMBER OF RELATIVE ROTATION-AXIS VECTORS FOR EACH PLATE: PARAMETER (MAXVEL=20) C MAXIMUM NUMBER OF AGES WHEN KULA/VANCOUVER TRIPLE-JUNCTION IS GIVEN: PARAMETER (MXKV3J =50) C MAXIM.NUMBER OF AGES WHEN VANCOUVER/FARALLON TRIPLE-JUNCTION IS GIVEN PARAMETER (MXVF3J =50) C MAXIMUM NUMBER OF STRIPS OF SEAFLOOR (BETWEEN FRACTURE ZONES) ON MAP: PARAMETER (MTAPES =40,MTAPP1=41) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED FRACTURE ZONE: PARAMETER (MAXFZP=100) C MAXIMUM NUMBER OF MAGNETIC ANOMALIES IN ANY ONE STRIP: PARAMETER (MAXMAG=100) C********************************************************************* CHARACTER*1 TAGFZ,TAGMAG C-------------------------------------------------------------------- COMMON /NORTH1/ + NKV3J, + NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, + TUMAP COMMON /NORTH2/ + AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, + FRACZN,NMAG,NPFZ,NPHING, + OMEGAF,OMEGAK,OMEGAP,OMEGAV, + REHING,REKV3J,REMAG,REVF3J, + ROMATF,ROMATK,ROMATP,ROMATV COMMON /NORTH3/ + TAGFZ,TAGMAG C-------------------------------------------------------------------- DIMENSION AGEFZ(MAXFZP,MTAPP1), 2 AGEHNG(MAXHL), 3 AGEKV(MXKV3J), 4 AGEMAG(MAXMAG,MTAPES), 5 AGEROT(MAXROT), 6 AGEVEL(MAXVEL), 7 AGEVF(MXVF3J), 8 FRACZN(2,MAXFZP,MTAPP1), 9 NPFZ(MTAPP1), A NPHING(MAXHNG) DIMENSION NMAG(MTAPES), 2 OMEGAF(3,MAXVEL), 3 OMEGAK(3,MAXVEL), 4 OMEGAP(3,MAXVEL), 5 OMEGAV(3,MAXVEL), 6 REHING(2,MAXHNG,MAXHL), 7 REKV3J(3,MXKV3J), 8 REMAG(2,2,MAXMAG,MTAPES), 9 REVF3J(3,MXVF3J), A ROMATF(3,3,MAXROT), 1 ROMATK(3,3,MAXROT), 2 ROMATP(3,3,MAXROT), 3 ROMATV(3,3,MAXROT), 4 TAGFZ(MAXFZP,MTAPP1), 5 TAGMAG(MAXMAG,MTAPES) C C C CALL BELOWY(INPUT,CPNLAT,ECLOG,FROMW, 1 NELCOL,NUMEL, 2 PUSHUP,RADIUS,RAMP,SLABSZ,TIME, 3 WANDES,XIP,YIP,X0ELON,Y0NLAT, 4 MAXHL,MAXHNG,MAXROT,MAXVEL,MXKV3J,MXVF3J, 5 MTAPES,MTAPP1,MAXFZP,MAXMAG, 6 NKV3J, 7 NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, 8 TUMAP, 9 AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, A FRACZN,NMAG,NPFZ,NPHING, 1 OMEGAF,OMEGAK,OMEGAP,OMEGAV, 2 REHING,REKV3J,REMAG,REVF3J, 3 ROMATF,ROMATK,ROMATP,ROMATV, 4 TAGFZ,TAGMAG, 5 OUTPUT,SZZ,TOUCH,VSLAB) RETURN END C C C SUBROUTINE BELOW2(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C "BELOW2", LINKED TO /SOUTH1/,/SOUTH2/, AND /SOUTH3/, C REPRESENTS THE SOUTHERN OPTION FOR NORTH AMERICA. C C NOTE: THESE DIMENSION PARAMETERS MUST AGREE C IN ALL PROGRAMS !!!!!! C C MAXIMUM NUMBER OF DIGITISED SLAB HINGELINES: PARAMETER (MAXHL=20) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED HINGELINE: PARAMETER (MAXHNG=40) C MAXIMUM NUMBER OF FINITE ROTATIONS FOR EACH PLATE: PARAMETER (MAXROT=21) C MAXIMUM NUMBER OF RELATIVE ROTATION-AXIS VECTORS FOR EACH PLATE: PARAMETER (MAXVEL=20) C MAXIMUM NUMBER OF AGES WHEN KULA/VANCOUVER TRIPLE-JUNCTION IS GIVEN: PARAMETER (MXKV3J =50) C MAXIM.NUMBER OF AGES WHEN VANCOUVER/FARALLON TRIPLE-JUNCTION IS GIVEN PARAMETER (MXVF3J =50) C MAXIMUM NUMBER OF STRIPS OF SEAFLOOR (BETWEEN FRACTURE ZONES) ON MAP: PARAMETER (MTAPES =40,MTAPP1=41) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED FRACTURE ZONE: PARAMETER (MAXFZP=100) C MAXIMUM NUMBER OF MAGNETIC ANOMALIES IN ANY ONE STRIP: PARAMETER (MAXMAG=100) C********************************************************************* CHARACTER*1 TAGFZ,TAGMAG C-------------------------------------------------------------------- COMMON /SOUTH1/ + NKV3J, + NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, + TUMAP COMMON /SOUTH2/ + AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, + FRACZN,NMAG,NPFZ,NPHING, + OMEGAF,OMEGAK,OMEGAP,OMEGAV, + REHING,REKV3J,REMAG,REVF3J, + ROMATF,ROMATK,ROMATP,ROMATV COMMON /SOUTH3/ + TAGFZ,TAGMAG C-------------------------------------------------------------------- DIMENSION AGEFZ(MAXFZP,MTAPP1), 2 AGEHNG(MAXHL), 3 AGEKV(MXKV3J), 4 AGEMAG(MAXMAG,MTAPES), 5 AGEROT(MAXROT), 6 AGEVEL(MAXVEL), 7 AGEVF(MXVF3J), 8 FRACZN(2,MAXFZP,MTAPP1), 9 NPFZ(MTAPP1), A NPHING(MAXHNG) DIMENSION NMAG(MTAPES), 2 OMEGAF(3,MAXVEL), 3 OMEGAK(3,MAXVEL), 4 OMEGAP(3,MAXVEL), 5 OMEGAV(3,MAXVEL), 6 REHING(2,MAXHNG,MAXHL), 7 REKV3J(3,MXKV3J), 8 REMAG(2,2,MAXMAG,MTAPES), 9 REVF3J(3,MXVF3J), A ROMATF(3,3,MAXROT), 1 ROMATK(3,3,MAXROT), 2 ROMATP(3,3,MAXROT), 3 ROMATV(3,3,MAXROT), 4 TAGFZ(MAXFZP,MTAPP1), 5 TAGMAG(MAXMAG,MTAPES) C C C CALL BELOWY(INPUT,CPNLAT,ECLOG,FROMW, 1 NELCOL,NUMEL, 2 PUSHUP,RADIUS,RAMP,SLABSZ,TIME, 3 WANDES,XIP,YIP,X0ELON,Y0NLAT, 4 MAXHL,MAXHNG,MAXROT,MAXVEL,MXKV3J,MXVF3J, 5 MTAPES,MTAPP1,MAXFZP,MAXMAG, 6 NKV3J, 7 NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, 8 TUMAP, 9 AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, A FRACZN,NMAG,NPFZ,NPHING, 1 OMEGAF,OMEGAK,OMEGAP,OMEGAV, 2 REHING,REKV3J,REMAG,REVF3J, 3 ROMATF,ROMATK,ROMATP,ROMATV, 4 TAGFZ,TAGMAG, 5 OUTPUT,SZZ,TOUCH,VSLAB) RETURN END C C C SUBROUTINE BELOWY(INPUT,CPNLAT,ECLOG,FROMW, 1 NELCOL,NUMEL, 2 PUSHUP,RADIUS,RAMP,SLABSZ,TIME, 3 WANDES,XIP,YIP,X0ELON,Y0NLAT, 4 MAXHL,MAXHNG,MAXROT,MAXVEL,MXKV3J,MXVF3J, 5 MTAPES,MTAPP1,MAXFZP,MAXMAG, 6 NKV3J, 7 NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, 8 TUMAP, 9 AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, A FRACZN,NMAG,NPFZ,NPHING, 1 OMEGAF,OMEGAK,OMEGAP,OMEGAV, 2 REHING,REKV3J,REMAG,REVF3J, 3 ROMATF,ROMATK,ROMATP,ROMATV, 4 TAGFZ,TAGMAG, 5 OUTPUT,SZZ,TOUCH,VSLAB) C C CUSTOM ROUTINE TO DESCRIBE THE MOTIONS OF THE FOUR OCEANIC C PLATES (FARALLON, KULA, PACIFIC, AND VANCOUVER) IN CONTACT C WITH NORTH AMERICA. C ACCEPTS LOCATIONS OF INTEGRATION POINTS OF EITHER GRID IN C (CONIC-PROJECTION-PLANE) CARTESIAN UNITS, PLUS C POSITION OF X/Y ORIGIN ON EARTH TO DEFINE CARTESIAN SYSTEM, PLUS C EARTH RADIUS AND LATITUDE OF PROJECTION TANGENT TO DEFINE MAP, C TIME BEFORE PRESENT, AND 2 PARAMETERS GOVERNING SLAB WEIGHTS. C OUTPUTS SLAB VERTICAL LOAD, CONTACT INDICATOR, AND SLAB VELOCITY. C ALL NECESSARY DATA ARE PASSED BY PARENT PROGRAM "BELOW1" OR C "BELOW2"-ONLY ONE OF WHICH WILL BE ACTIVE IN CALLING THIS C CODE (FOR NORTHERN OR SOUTHERN OPTIONS, RESPECTIVELY). C C CHARACTER*1 TAGFZ,TAGMAG,TAGLIN LOGICAL ABOVE,BELOW,FARALL,KULA,PACIFI,VANCOU C COMMON /GROBOW/ HANDES,XANDES,NPOINT,NALT1,NALT2 C DIMENSION HANDES(5),XANDES(5) DIMENSION AGEFZ(MAXFZP,MTAPP1), 2 AGEHNG(MAXHL), 3 AGEKV(MXKV3J), 4 AGEMAG(MAXMAG,MTAPES), 5 AGEROT(MAXROT), 6 AGEVEL(MAXVEL), 7 AGEVF(MXVF3J), 8 FRACZN(2,MAXFZP,MTAPP1), 9 NPFZ(MTAPP1), A NPHING(MAXHNG) DIMENSION NMAG(MTAPES), 2 OMEGAF(3,MAXVEL), 3 OMEGAK(3,MAXVEL), 4 OMEGAP(3,MAXVEL), 5 OMEGAV(3,MAXVEL), 6 REHING(2,MAXHNG,MAXHL), 7 REKV3J(3,MXKV3J), 8 REMAG(2,2,MAXMAG,MTAPES), 9 REVF3J(3,MXVF3J), A ROMATF(3,3,MAXROT), 1 ROMATK(3,3,MAXROT), 2 ROMATP(3,3,MAXROT), 3 ROMATV(3,3,MAXROT), 4 TAGFZ(MAXFZP,MTAPP1), 5 TAGMAG(MAXMAG,MTAPES) DIMENSION FROMW(7,NUMEL), + SZZ(7,NUMEL),TAGLIN(100), + TOUCH(7,NUMEL),VSLAB(2,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) C SAVE ICALL,NEWIDE, + RTAN,TAGLIN,YPOLE C DATA BIGNUM/3.E38/ DATA ICALL/0/ C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C ICALL=ICALL+1 C C===================================================================== C SETUP WORK IS PERFORMED ONLY ON THE FIRST CALL: IF (ICALL.EQ.1) THEN C C (1) ALGEBRA C NEWIDE=2*NELCOL RTAN=RADIUS*TANDEG(90.-CPNLAT) YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) UNITE1= -SINDEG(X0ELON) UNITE2= COSDEG(X0ELON) UNITE3=0. UNITN1= -COSDEG(X0ELON)*SINDEG(Y0NLAT) UNITN2= -SINDEG(X0ELON)*SINDEG(Y0NLAT) UNITN3=COSDEG(Y0NLAT) R1=COSDEG(X0ELON)*COSDEG(Y0NLAT) R2=SINDEG(X0ELON)*COSDEG(Y0NLAT) R3=SINDEG(Y0NLAT) A11= -R3*UNITE2+R2*UNITE3 A12= R3*UNITE1-R1*UNITE3 A13= -R2*UNITE1+R1*UNITE2 A21= -R3*UNITN2+R2*UNITN3 A22= R3*UNITN1-R1*UNITN3 A23= -R2*UNITN1+R1*UNITN2 A31=R1 A32=R2 A33=R3 C C (2) CHARACTERIZE FRACTURE ZONES, AS TO WHICH PLATE THEY BELONG TO C DO 20 I=1,NTAPP1 NP=0 NF=0 NV=0 NK=0 DO 10 J=1,NPFZ(I) IF (TAGFZ(J,I).EQ.'p'.OR.TAGFZ(J,I).EQ.'P') THEN NP=NP+1 ELSE IF (TAGFZ(J,I).EQ.'f'.OR.TAGFZ(J,I).EQ.'F') THEN NF=NF+1 ELSE IF (TAGFZ(J,I).EQ.'v'.OR.TAGFZ(J,I).EQ.'V') THEN NV=NV+1 ELSE IF (TAGFZ(J,I).EQ.'k'.OR.TAGFZ(J,I).EQ.'K') THEN NK=NK+1 ENDIF 10 CONTINUE IF ((NP.GT.NF).AND.(NP.GT.NV).AND.(NP.GT.NK)) THEN TAGLIN(I)='P' ELSE IF ((NF.GT.NP).AND.(NF.GT.NV).AND.(NF.GT.NK)) THEN TAGLIN(I)='F' ELSE IF ((NK.GT.NV).AND.(NK.GT.NF).AND.(NK.GT.NP)) THEN TAGLIN(I)='K' ELSE IF ((NV.GT.NF).AND.(NV.GT.NP).AND.(NV.GT.NK)) THEN TAGLIN(I)='V' ENDIF 20 CONTINUE C C (3) CONVERT (LAT,LON) POSITIONS IN DATA ARRAYS TO (X,Y) C DO 40 J=1,NUMHNG DO 30 I=1,NPHING(J) PLAT=REHING(1,I,J) PLON=REHING(2,I,J) CALL LLTOXY (INPUT,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X,Y) REHING(1,I,J)=X REHING(2,I,J)=Y 30 CONTINUE 40 CONTINUE DO 60 J=1,NTAPP1 DO 50 I=1,NPFZ(J) PLAT=FRACZN(1,I,J) PLON=FRACZN(2,I,J) CALL LLTOXY (INPUT,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X,Y) FRACZN(1,I,J)=X FRACZN(2,I,J)=Y 50 CONTINUE 60 CONTINUE DO 90 J=1,NTAPES DO 80 I=1,NMAG(J) DO 70 K=1,2 PLAT=REMAG(1,K,I,J) PLON=REMAG(2,K,I,J) CALL LLTOXY (INPUT,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X,Y) REMAG(1,K,I,J)=X REMAG(2,K,I,J)=Y 70 CONTINUE 80 CONTINUE 90 CONTINUE DO 100 I=1,NKV3J PLAT=REKV3J(1,I) PLON=REKV3J(2,I) DPLON=PLON-X0ELON IF (DPLON.LT.-180.) DPLON=DPLON+360. IF (DPLON.GT. 180.) DPLON=DPLON-360. ANGLE=DPLON*SINDEG(CPNLAT) REKV3J(3,I)=REKV3J(3,I)+ANGLE CALL LLTOXY (INPUT,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X,Y) REKV3J(1,I)=X REKV3J(2,I)=Y 100 CONTINUE DO 110 I=1,NKV3J PLAT=REVF3J(1,I) PLON=REVF3J(2,I) DPLON=PLON-X0ELON IF (DPLON.LT.-180.) DPLON=DPLON+360. IF (DPLON.GT. 180.) DPLON=DPLON-360. ANGLE=DPLON*SINDEG(CPNLAT) REVF3J(3,I)=REVF3J(3,I)+ANGLE CALL LLTOXY (INPUT,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X,Y) REVF3J(1,I)=X REVF3J(2,I)=Y 110 CONTINUE C C (4) CONVERT ROTATION-AXIS VECTORS FROM (X,Y,Z) CARTESIAN SYSTEM C AND RADIANS/SEC UNITS TO LOCAL VX = VEAST, VY=VNORTH, C AND SPIN RATE AT ORIGIN OF CONIC-PROJECTION (X,Y) SYSTEM. C NEW UNITS WILL BE (PROGRAM LENGTH UNITS)/SEC AND RADS/SEC. C DO 120 I=1,NUMVEL O1=OMEGAF(1,I) O2=OMEGAF(2,I) O3=OMEGAF(3,I) VX=A11*O1+A12*O2+A13*O3 VY=A21*O1+A22*O2+A23*O3 SP=A31*O1+A32*O2+A33*O3 OMEGAF(1,I)=VX*RADIUS OMEGAF(2,I)=VY*RADIUS OMEGAF(3,I)=SP 120 CONTINUE DO 130 I=1,NUMVEL O1=OMEGAK(1,I) O2=OMEGAK(2,I) O3=OMEGAK(3,I) VX=A11*O1+A12*O2+A13*O3 VY=A21*O1+A22*O2+A23*O3 SP=A31*O1+A32*O2+A33*O3 OMEGAK(1,I)=VX*RADIUS OMEGAK(2,I)=VY*RADIUS OMEGAK(3,I)=SP 130 CONTINUE DO 140 I=1,NUMVEL O1=OMEGAP(1,I) O2=OMEGAP(2,I) O3=OMEGAP(3,I) VX=A11*O1+A12*O2+A13*O3 VY=A21*O1+A22*O2+A23*O3 SP=A31*O1+A32*O2+A33*O3 OMEGAP(1,I)=VX*RADIUS OMEGAP(2,I)=VY*RADIUS OMEGAP(3,I)=SP 140 CONTINUE DO 150 I=1,NUMVEL O1=OMEGAV(1,I) O2=OMEGAV(2,I) O3=OMEGAV(3,I) VX=A11*O1+A12*O2+A13*O3 VY=A21*O1+A22*O2+A23*O3 SP=A31*O1+A32*O2+A33*O3 OMEGAV(1,I)=VX*RADIUS OMEGAV(2,I)=VY*RADIUS OMEGAV(3,I)=SP 150 CONTINUE ENDIF C==================================================================== C C SELECT TIME WINDOWS FOR RELATIVE VELOCITY, FINITE ROTATION, 3-J C LOCATION, AND HINGE LOCATION C TMY=TIME/TUMAP C C (1) BOUNDING INDECES AND FRACTION FOR RELATIVE VELOCITY C IT1=1 IT2=NUMVEL DO 210 I=2,NUMVEL IF (AGEVEL(I).LE.TMY) IT1=I J=NUMVEL+1-I IF (AGEVEL(J).GT.TMY) IT2=J 210 CONTINUE FT2=(TMY-AGEVEL(IT1))/MAX(1.,(AGEVEL(IT2)-AGEVEL(IT1))) FT1=1.00-FT2 VXFD= FT1*OMEGAF(1,IT1)+FT2*OMEGAF(1,IT2) VYFD= FT1*OMEGAF(2,IT1)+FT2*OMEGAF(2,IT2) SPINF=FT1*OMEGAF(3,IT1)+FT2*OMEGAF(3,IT2) VXKD= FT1*OMEGAK(1,IT1)+FT2*OMEGAK(1,IT2) VYKD= FT1*OMEGAK(2,IT1)+FT2*OMEGAK(2,IT2) SPINK=FT1*OMEGAK(3,IT1)+FT2*OMEGAK(3,IT2) VXPD= FT1*OMEGAP(1,IT1)+FT2*OMEGAP(1,IT2) VYPD= FT1*OMEGAP(2,IT1)+FT2*OMEGAP(2,IT2) SPINP=FT1*OMEGAP(3,IT1)+FT2*OMEGAP(3,IT2) VXVD= FT1*OMEGAV(1,IT1)+FT2*OMEGAV(1,IT2) VYVD= FT1*OMEGAV(2,IT1)+FT2*OMEGAV(2,IT2) SPINV=FT1*OMEGAV(3,IT1)+FT2*OMEGAV(3,IT2) C C (2) BOUNDING INDECES AND FRACTION FOR FINITE ROTATIONS C IROT1=1 IROT2=NROMAT DO 220 I=2,NROMAT IF (AGEROT(I).LE.TMY) IROT1=I J=NROMAT+1-I IF (AGEROT(J).GT.TMY) IROT2=J 220 CONTINUE TFRAC=(TMY-AGEROT(IROT1))/MAX((AGEROT(IROT2)-AGEROT(IROT1)),1.) C C (3A) BOUNDING INDECES FOR KULA/VANCOUVER TRIPLE-JUNCTION LOCATION C IKV3J1=1 IKV3J2=NKV3J DO 230 I=2,NKV3J IF (AGEKV(I).LE.TMY) IKV3J1=I J=NKV3J+1-I IF (AGEKV(J).GT.TMY) IKV3J2=J 230 CONTINUE FKV3J2=(TMY-AGEKV(IKV3J1))/MAX(1.,(AGEKV(IKV3J2)-AGEKV(IKV3J1))) FKV3J1=1.00-FKV3J2 XKV=FKV3J1*REKV3J(1,IKV3J1)+FKV3J2*REKV3J(1,IKV3J2) YKV=FKV3J1*REKV3J(2,IKV3J1)+FKV3J2*REKV3J(2,IKV3J2) AKV=FKV3J1*REKV3J(3,IKV3J1)+FKV3J2*REKV3J(3,IKV3J2) C C (3B) BOUNDING INDECES FOR VANCOUVER/FARALLON 3-JUNCTION LOCATION C IVF3J1=1 IVF3J2=NVF3J DO 240 I=2,NVF3J IF (AGEVF(I).LE.TMY) IVF3J1=I J=NVF3J+1-I IF (AGEVF(J).GT.TMY) IVF3J2=J 240 CONTINUE FVF3J2=(TMY-AGEVF(IVF3J1))/MAX(1.,(AGEVF(IVF3J2)-AGEVF(IVF3J1))) FVF3J1=1.00-FVF3J2 XVF=FVF3J1*REVF3J(1,IVF3J1)+FVF3J2*REVF3J(1,IVF3J2) YVF=FVF3J1*REVF3J(2,IVF3J1)+FVF3J2*REVF3J(2,IVF3J2) AVF=FVF3J1*REVF3J(3,IVF3J1)+FVF3J2*REVF3J(3,IVF3J2) C C (4) BOUNDING INDECES AND FRACTION FOR HINGE LOCATION C IH1=1 IH2=NUMHNG DO 250 I=2,NUMHNG IF (TMY.LE.AGEHNG(I)) IH1=I IP=NUMHNG+1-I IF (TMY.GT.AGEHNG(IP)) IH2=IP 250 CONTINUE FH1=(TMY-AGEHNG(IH2))/MAX(1.,(AGEHNG(IH1)-AGEHNG(IH2))) FH2=1.00-FH1 C C MAIN (DOUBLE) LOOP ON ALL INTEGRATION POINTS IN FINITE ELEMENT GRID C DO 1000 I=1,NUMEL DO 900 M=1,7 X=XIP(M,I) Y=YIP(M,I) C C TEST FOR CONTACT OF SLABS WITH THE CONTINENT C J1M=1 J1N=2 D1=RADIUS D2=D1*1.1 DO 300 J=1,NPHING(IH1) D=SQRT((X-REHING(1,J,IH1))**2+ + (Y-REHING(2,J,IH1))**2) IF (D.LT.D1) THEN D2=D1 J1N=J1M D1=D J1M=J ELSE IF (D.LT.D2) THEN D2=D J1N=J ENDIF 300 CONTINUE IF (J1N.LT.J1M) THEN J=J1N J1N=J1M J1M=J ENDIF J2M=1 J2N=2 D1=RADIUS D2=D1*1.1 DO 350 J=1,NPHING(IH2) D=SQRT((X-REHING(1,J,IH2))**2+ + (Y-REHING(2,J,IH2))**2) IF (D.LT.D1) THEN D2=D1 J2N=J2M D1=D J2M=J ELSE IF (D.LT.D2) THEN D2=D J2N=J ENDIF 350 CONTINUE IF (J2N.LT.J2M) THEN J=J2N J2N=J2M J2M=J ENDIF X1=REHING(1,J1M,IH1) X2=REHING(1,J1N,IH1) X3=X Y1=REHING(2,J1M,IH1) Y2=REHING(2,J1N,IH1) Y3=Y AREA1=0.5*(X1*Y2-X2*Y1 + +X2*Y3-X3*Y2 + +X3*Y1-X1*Y3) SIDE1=SQRT((X1-X2)**2+(Y1-Y2)**2) DIST1=2.*AREA1/SIDE1 X1=REHING(1,J2M,IH2) X2=REHING(1,J2N,IH2) X3=X Y1=REHING(2,J2M,IH2) Y2=REHING(2,J2N,IH2) Y3=Y AREA2=0.5*(X1*Y2-X2*Y1 + +X2*Y3-X3*Y2 + +X3*Y1-X1*Y3) SIDE2=SQRT((X1-X2)**2+(Y1-Y2)**2) DIST2=2.*AREA2/SIDE2 DIST=FH1*DIST1+FH2*DIST2 TOUCH(M,I)=MIN(1.,MAX(0.,1.-(DIST/RAMP))) C C DETERMINE WHICH SLAB IS BENEATH POINT C DIVN=YKV+(X-XKV)*TANDEG(AKV) DIVS=YVF+(X-XVF)*TANDEG(AVF) KULA= Y.GT.DIVN VANCOU=(Y.LE.DIVN).AND.(Y.GT.DIVS) FARALL= Y.LE.DIVS C C COMPUTE VELOCITY OF SLAB C IF (FARALL) THEN VSLAB(1,M,I)=VXFD-Y*SPINF VSLAB(2,M,I)=VYFD+X*SPINF ELSE IF (KULA) THEN VSLAB(1,M,I)=VXKD-Y*SPINK VSLAB(2,M,I)=VYKD+X*SPINK ELSE IF (VANCOU) THEN VSLAB(1,M,I)=VXVD-Y*SPINV VSLAB(2,M,I)=VYVD+X*SPINV ENDIF C C CONVERT TO CARTESIAN 3-D COORDINATES IN RANGE -1 TO +1 C CALL XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) CX=COSDEG(PLAT)*COSDEG(PLON) CY=COSDEG(PLAT)*SINDEG(PLON) CZ=SINDEG(PLAT) C C ROTATE TO TWO NEW (LAT,LON) POINTS WITH BOUNDING ROTATIONS C IF (FARALL) THEN CX1=ROMATF(1,1,IROT1)*CX+ROMATF(1,2,IROT1)*CY + +ROMATF(1,3,IROT1)*CZ CY1=ROMATF(2,1,IROT1)*CX+ROMATF(2,2,IROT1)*CY + +ROMATF(2,3,IROT1)*CZ CZ1=ROMATF(3,1,IROT1)*CX+ROMATF(3,2,IROT1)*CY + +ROMATF(3,3,IROT1)*CZ CX2=ROMATF(1,1,IROT2)*CX+ROMATF(1,2,IROT2)*CY + +ROMATF(1,3,IROT2)*CZ CY2=ROMATF(2,1,IROT2)*CX+ROMATF(2,2,IROT2)*CY + +ROMATF(2,3,IROT2)*CZ CZ2=ROMATF(3,1,IROT2)*CX+ROMATF(3,2,IROT2)*CY + +ROMATF(3,3,IROT2)*CZ ELSE IF (KULA) THEN CX1=ROMATK(1,1,IROT1)*CX+ROMATK(1,2,IROT1)*CY + +ROMATK(1,3,IROT1)*CZ CY1=ROMATK(2,1,IROT1)*CX+ROMATK(2,2,IROT1)*CY + +ROMATK(2,3,IROT1)*CZ CZ1=ROMATK(3,1,IROT1)*CX+ROMATK(3,2,IROT1)*CY + +ROMATK(3,3,IROT1)*CZ CX2=ROMATK(1,1,IROT2)*CX+ROMATK(1,2,IROT2)*CY + +ROMATK(1,3,IROT2)*CZ CY2=ROMATK(2,1,IROT2)*CX+ROMATK(2,2,IROT2)*CY + +ROMATK(2,3,IROT2)*CZ CZ2=ROMATK(3,1,IROT2)*CX+ROMATK(3,2,IROT2)*CY + +ROMATK(3,3,IROT2)*CZ ELSE IF (VANCOU) THEN CX1=ROMATV(1,1,IROT1)*CX+ROMATV(1,2,IROT1)*CY + +ROMATV(1,3,IROT1)*CZ CY1=ROMATV(2,1,IROT1)*CX+ROMATV(2,2,IROT1)*CY + +ROMATV(2,3,IROT1)*CZ CZ1=ROMATV(3,1,IROT1)*CX+ROMATV(3,2,IROT1)*CY + +ROMATV(3,3,IROT1)*CZ CX2=ROMATV(1,1,IROT2)*CX+ROMATV(1,2,IROT2)*CY + +ROMATV(1,3,IROT2)*CZ CY2=ROMATV(2,1,IROT2)*CX+ROMATV(2,2,IROT2)*CY + +ROMATV(2,3,IROT2)*CZ CZ2=ROMATV(3,1,IROT2)*CX+ROMATV(3,2,IROT2)*CY + +ROMATV(3,3,IROT2)*CZ ELSE CX1=CX CX2=CX CY1=CY CY2=CY CZ1=CZ CZ2=CZ ENDIF C C RECONVERT TO (LAT,LON) COORDINATES IN DEGREES C PLAT1=57.29578*ASIN(CZ1) PLON1=57.29578*ATAN2F(CY1,CX1) PLAT2=57.29578*ASIN(CZ2) PLON2=57.29578*ATAN2F(CY2,CX2) C C CONVERT TO CONIC PROJECTION AND AVERAGE C CALL LLTOXY (INPUT,CPNLAT, + PLAT1,PLON1, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X1,Y1) CALL LLTOXY (INPUT,CPNLAT, + PLAT2,PLON2, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X2,Y2) XM=X2*TFRAC+X1*(1.-TFRAC) YM=Y2*TFRAC+Y1*(1.-TFRAC) C C FIND FRACTURE-ZONE LINES ENCLOSING POINT C KROW= -1 DO 500 K=1,NTAPES IF (KULA) THEN IF ((TAGLIN(K ).NE.'K').OR. + (TAGLIN(K+1).NE.'K')) GO TO 500 ELSE IF (VANCOU.OR.FARALL) THEN IF (TMY.GE.59.) THEN IF (.NOT.(TAGLIN(K ).EQ.'V'.OR. + TAGLIN(K ).EQ.'F' ) .OR. + .NOT.(TAGLIN(K+1).EQ.'V'.OR. + TAGLIN(K+1).EQ.'F')) GO TO 500 ELSE IF (VANCOU) THEN IF ((TAGLIN(K ).NE.'V').OR. + (TAGLIN(K+1).NE.'V')) GO TO 500 ELSE IF (FARALL) THEN IF ((TAGLIN(K ).NE.'F').OR. + (TAGLIN(K+1).NE.'F')) GO TO 500 ENDIF ENDIF ENDIF RMIN2=BIGNUM DO 400 J=1,NPFZ(K) R2=(XM-FRACZN(1,J,K))**2+ + (YM-FRACZN(2,J,K))**2 IF (R2.LT.RMIN2) THEN JSAVE=J RMIN2=R2 ENDIF 400 CONTINUE XP=FRACZN(1,JSAVE,K) YP=FRACZN(2,JSAVE,K) IF (JSAVE.EQ.1) THEN XE=FRACZN(1,2,K) YE=FRACZN(2,2,K) XW=2.*XP-FRACZN(1,NPFZ(K),K) YW=2.*YP-FRACZN(2,NPFZ(K),K) ELSE IF (JSAVE.EQ.NPFZ(K)) THEN XE=2.*XP-FRACZN(1,1,K) YE=2.*YP-FRACZN(2,1,K) XW=FRACZN(1,JSAVE-1,K) YW=FRACZN(2,JSAVE-1,K) ELSE XE=FRACZN(1,JSAVE+1,K) YE=FRACZN(2,JSAVE+1,K) XW=FRACZN(1,JSAVE-1,K) YW=FRACZN(2,JSAVE-1,K) ENDIF ANGLEE=ATAN2F(YE-YP,XE-XP) ANGLEW=ATAN2F(YW-YP,XW-XP) IF (ANGLEW.LT.ANGLEE) ANGLEW=ANGLEW+6.283 ANGLEM=ATAN2F(YM-YP,XM-XP) IF (ANGLEM.LT.ANGLEE) ANGLEM=ANGLEM+6.283 ABOVE=ANGLEM.LE.ANGLEW IF (.NOT.ABOVE) GO TO 500 RMIN2=BIGNUM DO 450 J=1,NPFZ(K+1) R2=(XM-FRACZN(1,J,K+1))**2+ + (YM-FRACZN(2,J,K+1))**2 IF (R2.LT.RMIN2) THEN JSAVE=J RMIN2=R2 ENDIF 450 CONTINUE XP=FRACZN(1,JSAVE,K+1) YP=FRACZN(2,JSAVE,K+1) IF (JSAVE.EQ.1) THEN XE=FRACZN(1,2,K+1) YE=FRACZN(2,2,K+1) XW=2.*XP-FRACZN(1,NPFZ(K+1),K+1) YW=2.*YP-FRACZN(2,NPFZ(K+1),K+1) ELSE IF (JSAVE.EQ.NPFZ(K+1)) THEN XE=2.*XP-FRACZN(1,1,K+1) YE=2.*YP-FRACZN(2,1,K+1) XW=FRACZN(1,JSAVE-1,K+1) YW=FRACZN(2,JSAVE-1,K+1) ELSE XE=FRACZN(1,JSAVE+1,K+1) YE=FRACZN(2,JSAVE+1,K+1) XW=FRACZN(1,JSAVE-1,K+1) YW=FRACZN(2,JSAVE-1,K+1) ENDIF ANGLEE=ATAN2F(YE-YP,XE-XP) ANGLEW=ATAN2F(YW-YP,XW-XP) IF (ANGLEW.LT.ANGLEE) ANGLEW=ANGLEW+6.283 ANGLEM=ATAN2F(YM-YP,XM-XP) IF (ANGLEM.LT.ANGLEE) ANGLEM=ANGLEM+6.283 BELOW=ANGLEM.GE.ANGLEW IF (BELOW) THEN KROW=K GO TO 501 ENDIF 500 CONTINUE 501 CONTINUE IF (KROW.GE.1) THEN AGENOW=0. C C FIND MAGNETIC ANOMALIES SURROUNDING POINT AND FIX AGE C DO 600 J=1,NMAG(KROW)-1 XL1=REMAG(1,1,J,KROW) XL2=REMAG(1,2,J,KROW) YL1=REMAG(2,1,J,KROW) YL2=REMAG(2,2,J,KROW) XR1=REMAG(1,1,J+1,KROW) XR2=REMAG(1,2,J+1,KROW) YR1=REMAG(2,1,J+1,KROW) YR2=REMAG(2,2,J+1,KROW) DOT=(XL2-XL1)*(XR2-XR1)+(YL2-YL1)*(YR2-YR1) IF (DOT.LT.0.) THEN XS=XR1 YS=YR1 XR1=XR2 YR1=YR2 XR2=XS YR2=YS ENDIF AREAL=0.5*(XL1*YL2-XL2*YL1 + +XL2*YM-XM*YL2 + +XM*YL1-XL1*YM) SIDEL=SQRT((XL1-XL2)**2+(YL1-YL2)**2) DISTL=2.*AREAL/MAX(SIDEL,1.) AREAR=0.5*(XR1*YR2-XR2*YR1 + +XR2*YM-XM*YR2 + +XM*YR1-XR1*YM) SIDER=SQRT((XR1-XR2)**2+(YR1-YR2)**2) DISTR=2.*AREAR/MAX(SIDER,1.) IF ((DISTL*DISTR).LE.0.) THEN IF (ABS(DISTL-DISTR).GT.0.) THEN FRAC=ABS(DISTL)/ABS(DISTL-DISTR) ELSE FRAC=0. ENDIF AGENOW=MAX(AGENOW, + FRAC *AGEMAG(J+1,KROW)+ + (1.-FRAC)*AGEMAG(J,KROW) ) ENDIF 600 CONTINUE ELSE AGENOW=0. TOUCH(M,I)=0. SZZ(M,I)=0. ENDIF AGETHN=AGENOW-TMY IF (AGETHN.GT.0.) THEN SZZ(M,I)=ECLOG+SLABSZ*SQRT(MIN(AGETHN,100.)/100.) ELSE TOUCH(M,I)=0. SZZ(M,I)=0. ENDIF C C WITHIN FOREARC, NON-ISOSTATIC UPLIFT FROM SLAB IS ADDED C XREL=FROMW(M,I)/MAX(WANDES,1.) IF (XREL.LT.XANDES(NALT1)) THEN SZZ(M,I)=SZZ(M,I)-PUSHUP*TOUCH(M,I) ENDIF C C SPECIAL CASE OF PACIFIC PLATE IN CONTACT WITH COASTAL STRIP C PACIFI=(TOUCH(M,I).EQ.0.0).AND. + (MOD(I,NEWIDE).EQ.1).AND. + ((M.EQ.4).OR.(M.EQ.5).OR.(M.EQ.6)) IF (PACIFI) THEN VSLAB(1,M,I)=VXPD-Y*SPINP VSLAB(2,M,I)=VYPD+X*SPINP ENDIF C************************* KLUDGE **************************** C PREVENT FICTICIOUS "CONTINENTAL COLLISION EVENTS" CAUSED C BY SMALL BUGS IN MAP DATA THAT MAY CAUSE A POINT TO HAVE C TOUCH=0 (AND PACIFI) BEFORE THE PROPER TIME, ESPECIALLY C NEAR THE KULA/FARALLON-VANCOUVER/NORTH AMERICA TRIPLE C JUNCTION C IF (PACIFI.AND.(TMY.GT.43.8)) TOUCH(M,I)=0.1 C C THIS STATEMENT GUARUNTEES THAT PACIFI WILL BE .FALSE. IN C OTHER ROUTINES LIKE SLIPBC (IN LARAMY) AND ARROW (IN MAP). C************************************************************* 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE LLTOXY (INPUT,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X,Y) C C CONVERT A (NORTH LATITUDE=PLAT, EAST LONGITUDE=PLON) POSITION C INTO AN (X,Y) POSITION ON A CONIC PROJECTION WITH TANGENT C LATITUDE CPNLAT, WHEN THE (X,Y) ORIGIN IS AT C (NORTH LATITUDE=Y0NLAT, EAST LONGITUDE=X0ELON). C THE CUT NECESSARY IN THIS PROJECTION IS FROM THE POLE NEAREST C TO THE TANGENT LATITUDE (CPNLAT), ALONG A MERIDIAN WHICH C IS ON THE OPPOSITE SIDE OF THE EARTH FROM X0ELON. C IF PLAT IS MORE THAN 90 DEGREES DIFFERENT FROM CPNLAT, THE C POINT DOES NOT FALL ONTO THE PROJECTION AT ALL. TO PREVENT C CRASHES, WE MERELY PLACE IT VERY FAR OUT ON THE PROJECTION. C C NOTE: FOLLOWING TWO LINES ARE PRECOMPUTED AND PASSED TO SAVE TIME: C RTAN=RADIUS*TANDEG(90.-CPNLAT) C YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C IF (ABS(PLAT-CPNLAT).GE.90.) PLAT=CPNLAT+89.*(PLAT-CPNLAT)/ + ABS(PLAT-CPNLAT) R=RTAN-RADIUS*TANDEG(PLAT-CPNLAT) DPLON=PLON-X0ELON IF (DPLON.LT.-180.) DPLON=DPLON+360. IF (DPLON.GT. 180.) DPLON=DPLON-360. ANGLE=DPLON*SINDEG(CPNLAT) X=R*SINDEG(ANGLE) Y=YPOLE-R*COSDEG(ANGLE) RETURN END C C C SUBROUTINE XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) C C CONVERT POINTS EXPRESSED AS (X,Y) ON A CONIC PROJECTION PLANE C WITH TANGENT LATITUDE CPNLAT AND ORIGIN AT (Y0NLAT,X0ELON) C TO (PLAT = NORTH_LATITUDE, PLON = EAST_LONGITUDE) C IN DEGREES C C NOTE: FOLLOWING TWO VARIABLES ARE PRECOMPUTED TO SAVE TIME: C RTAN=RADIUS*TANDEG(90.-CPNLAT) C YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C YRP=Y-YPOLE R=SQRT(X**2+YRP**2) ANGLE=57.29578*ATAN2F(X,-YRP) PLON=X0ELON+ANGLE/SINDEG(CPNLAT) PLAT=CPNLAT+57.29578*ATAN((RTAN-R)/RADIUS) PLAT=MIN(90.,MAX(PLAT,-90.)) IF (PLON.GT. 180.) PLON=PLON-360. IF (PLON.LT.-180.) PLON=PLON+360. RETURN END C C C SUBROUTINE BELOW3(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C VERY ROUGH VERSION OF ANDEAN (SIERRA DE PAMPEANAS), 1987? C DIMENSION SZZ(7,NUMEL),TOUCH(7,NUMEL),VSLAB(2,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL), + BETAL(7),COEFF(3,6,2) C DATA NUMHR /6/ DATA BETAL /1.E+20,2185.,1738.,1419.,993.,463.,-1.E+20/ DATA RINKM/6371./ DATA ((COEFF(I,J,1),I=1,3),J=1,6)/ + 1.256000E+3, 0.000000 , 0.000000, + 5.130022E+2, 3.400447E-1, 0.000000, + -2.122960E+3, 4.330471 , -1.423388E-3, + -2.631799E+3, 5.698898 , -2.134993E-3, + 5.504894E+2, -8.305952E-1, 1.213217E-3, + 4.260000E+2, 0.000000 , 0.000000/ C ONEKM=RADIUS/RINKM DO 20 J=1,NUMEL DO 10 I=1,7 VSLAB(1,I,J)=0.3234E-06 VSLAB(2,I,J)=-0.8666E-07 SZZ(I,J)=ECLOG+SLABSZ*SQRT(50./100.) 10 CONTINUE 20 CONTINUE C RAMPKM=RAMP/ONEKM C DO 200 M=1,7 DO 100 I=1,NUMEL X=XIP(M,I) Y=YIP(M,I) ALPHA=(X-2.5831E+08)/ONEKM BETA=(Y+1.9218E+09)/ONEKM C DO 105 J=1,NUMHR IF(BETA.LE.BETAL(J).AND.BETA.GE.BETAL(J+1))THEN ALIM=COEFF(1,J,1)+BETA*COEFF(2,J,1)+BETA**2*COEFF(3,J,1) TOUCHI=AMAX1(0.,AMIN1(1.,(0.5-2.*(ALPHA-ALIM)/RAMPKM))) TOUCH(M,I)=TOUCHI ENDIF 105 CONTINUE 100 CONTINUE 200 CONTINUE RETURN END C C C SUBROUTINE BELOW4(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C VERY ROUGH VERSION OF CHINESE SHORT-UNDERTHRUST FOR C NOV. 1989 CALCULATIONS FOR NSF PROPOSAL 4. C LOGICAL MANTLE DIMENSION FROMW(7,NUMEL),SZZ(7,NUMEL),TOUCH(7,NUMEL), + VSLAB(2,7,NUMEL),XIP(7,NUMEL),YIP(7,NUMEL) C NTOUCH=9 C ABOVE DEFINES HOW MANY ROWS (FROM WEST) OF ELEMENTS C WILL TOUCH THE INDIAN PLATE. C CONTACT WILL ONLY BE WITH THE FIRST COLUMN, AND ONLY WITH CRUST. C C C DETECT AND REJECT MANTLE LAYER (NO CONTACT) C FSUM=0. DO 20 IROW=1,NTOUCH I=(IROW-1)*2*NELCOL+1 DO 10 M=1,7 FSUM=FSUM+FROMW(M,I) 10 CONTINUE 20 CONTINUE FMEAN=FSUM/(7.*NTOUCH) MANTLE=FMEAN.GT.100.E+05 IF (MANTLE) THEN DO 40 M=1,7 DO 30 I=1,NUMEL SZZ(M,I)=0. TOUCH(M,I)=0. VSLAB(1,M,I)=0. VSLAB(2,M,I)=0. 30 CONTINUE 40 CONTINUE ELSE DO 100 I=1,NUMEL JCOL=MOD((I-1),(2*NELCOL))+1 IROW=(I-1)/(2*NELCOL)+1 IF (JCOL.LE.2.AND.IROW.LE.NTOUCH) THEN DO 80 M=1,7 SZZ(M,I)=ECLOG TOUCH(M,I)=1. VSLAB(1,M,I)=1.089E-8+1.906E-16*XIP(M,I) VSLAB(2,M,I)=8.869E-8+2.680E-16*XIP(M,I) C THESE ARE MINSTER + JORDAN (1978) RM2* VELOCITIES FOR C WEST INDIA (SEPARATE FROM AUSTRALIA) WITH RESPECT TO C EURASIA. C 80 CONTINUE ELSE DO 90 M=1,7 SZZ(M,I)=0. TOUCH(M,I)=0. VSLAB(1,M,I)=0. VSLAB(2,M,I)=0. 90 CONTINUE ENDIF 100 CONTINUE ENDIF RETURN END C C C SUBROUTINE SQUEZE (G,CONDNS,TOUCHC,TOUCHM,SZZBC,SZZBM, + GEOTHA,GEOTHC,GEOTHM,NUMEL,THIKC,THIKM, + TEMLIM, + ALPHAT,RHOBAR,DNLINK,UPLINK,SIGZZC,SIGZZM, + OUTSCA,THNKC,THNKM, + DXSC,DXSM,DYSC,DYSM, + TAUZZC,TAUZZM,ONEKM,RHOH2O,RHOAST, + NODES,NUMNOD,PTSC,PTSM, + AREAC,AREAM,CODE,DETJC,DETJM,FAILUR,FLOWIN, + NCDIM,NDIFF,NXL,LWORK,ECLOG,HMAX,HMIN) C C CALCULATES LAYER-TOP VALUE (SIGZZ) AND THE LAYER INTEGRAL C (TAUZZ) OF VERTICAL STRESS ANOMALY C (RELATIVE TO A COLUMN OF MANTLE AT ASTHENOSPHERE TEMPERATURE C WITH A 2.7 KM OCEAN ON TOP AND A 5 KM CRUST, LIKE A MID-OCEAN C RIDGE) IN BOTH LAYERS AT ONCE. C ALSO PROVIDES PRESSURE ANOMALY TIMES SLOPE OF LAYER TOP (& BOT). C NOTE THAT ALL DENSITIES IN THIS PROGRAM ARE POTENTIAL C DENSITIES AT ZERO PRESSURE. C PARAMETER(NDREF=500) LOGICAL FAILUR,LOCKIN,LOCKWC DOUBLE PRECISION CODE,FLOWIN DIMENSION DREF(NDREF) DIMENSION ALPHAT(2),AREAC(NUMEL),AREAM(NUMEL), + CODE(NCDIM),CONDNS(NUMNOD), + DETJC(7,NUMEL),DETJM(7,NUMEL), + DXSC(6,7,NUMEL),DXSM(6,7,NUMEL), + DYSC(6,7,NUMEL),DYSM(6,7,NUMEL), + FLOWIN(NUMNOD),GEOTHA(4,7,NUMEL), + GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), + HMAX(2),HMIN(2), + DNLINK(3,7,NUMEL),UPLINK(3,7,NUMEL),NODES(6,0:NUMEL), + OUTSCA(7,NUMEL), + PTSC(2,7,NUMEL),PTSM(2,7,NUMEL), + RHOBAR(2),SIGZZC(7,NUMEL),SIGZZM(7,NUMEL), + SZZBC(7,NUMEL),SZZBM(7,NUMEL), + TAUZZC(7,NUMEL),TAUZZM(7,NUMEL),TEMLIM(2), + THIKC(7,NUMEL),THIKM(7,NUMEL), + THNKC(NUMNOD),THNKM(NUMNOD), + TOUCHC(7,NUMEL),TOUCHM(7,NUMEL), + LWORK(NXL) SAVE ICALL,DREF DATA ICALL /0/, LOCKIN /.FALSE./, LOCKWC /.FALSE./ C C STATEMENT FUNCTIONS: TEMPC(Z,M,I)=MIN(TEMLIM(1),GEOTHC(1,M,I) + +GEOTHC(2,M,I)*Z + +GEOTHC(3,M,I)*Z**2 + +GEOTHC(4,M,I)*Z**3) TEMPM(Z,M,I)=MIN(TEMLIM(2),GEOTHM(1,M,I) + +GEOTHM(2,M,I)*Z + +GEOTHM(3,M,I)*Z**2 + +GEOTHM(4,M,I)*Z**3) TEMPA(Z,M,I)=MIN(TEMLIM(2),GEOTHA(1,M,I) + +GEOTHA(2,M,I)*Z + +GEOTHA(3,M,I)*Z**2 + +GEOTHA(4,M,I)*Z**3) C TASTH=TEMPM(THIKM(5,NUMEL),5,NUMEL) C C CREATE REFERENCE TEMPERATURE & DENSITY PROFILES TO DEPTH OF NDREF KM C ICALL=ICALL+1 IF (ICALL.EQ.1) THEN ITEST=(HMAX(1)+HMAX(2))/ONEKM IF (ITEST.GT.NDREF) THEN WRITE(6,1)ITEST 1 FORMAT(' IN SUBPROGRAM SQUEZE, PARAMETER NDREF '/ + ' MUST BE INCREASED TO AT LEAST ',I10) STOP ENDIF DREF(1)=RHOH2O DREF(2)=RHOH2O DREF(3)=0.7*RHOH2O+0.3*RHOBAR(1) DREF(4)=RHOBAR(1) DREF(5)=RHOBAR(1) DREF(6)=RHOBAR(1) DREF(7)=RHOBAR(1) DREF(8)=0.7*RHOBAR(1)+0.3*RHOAST DO 58 J=9,58 DREF(J)=RHOAST+ECLOG/(G*50.*ONEKM) 58 CONTINUE DO 100 J=59,NDREF DREF(J)=RHOAST 100 CONTINUE ENDIF C C CALCULATION FOR MANTLE C CALL GETSCA(INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) DO 200 M=1,7 DO 190 I=1,NUMEL SLTOPX=0. SLTOPY=0. DO 110 J=1,6 SLTOPX=SLTOPX+CONDNS(NODES(J,I))*DXSM(J,M,I) SLTOPY=SLTOPY+CONDNS(NODES(J,I))*DYSM(J,M,I) 110 CONTINUE SLOPEX=SLTOPX SLOPEY=SLTOPY DO 120 J=1,6 SLOPEX=SLOPEX+THNKM(NODES(J,I))*DXSM(J,M,I) SLOPEY=SLOPEY+THNKM(NODES(J,I))*DYSM(J,M,I) 120 CONTINUE NLNROW=(NDIFF/2)-1 IF (MOD((I-1),NLNROW).GT.1) THEN T=TOUCHM(M,I) ELSE IF (TOUCHM(M,I).GT.0.99) THEN T=1.00 ELSE T=0.0 ENDIF ENDIF SZZ=T*SZZBM(M,I) SZZBOT=SZZ SZZLST=SZZ TZZ=0. ZMOHO=OUTSCA(M,I) ZASTH=ZMOHO+THIKM(M,I) NTOP=ZMOHO/ONEKM+0.5 NBOT=ZASTH/ONEKM+0.5 NTOP=MIN(NDREF,NTOP) NBOT=MIN(NDREF,NBOT) TRES=ZMOHO-NTOP*ONEKM BRES=ZASTH-NBOT*ONEKM DO 180 J=NBOT,NTOP+1,-1 Z=ONEKM*(J-0.5) ZP=Z-ZMOHO T=TEMPM(ZP,M,I) DENSE=RHOBAR(2)*(1.-ALPHAT(2)*T) IF (J.EQ.NBOT) DSAVE=DENSE SZZ=SZZ+G*ONEKM*(DENSE-DREF(J)) SZZM=0.5*(SZZ+SZZLST) SZZLST=SZZ TZZ=TZZ+ONEKM*SZZM 180 CONTINUE SIGZZM(M,I)=SZZ+G*(BRES*(DSAVE-DREF(NBOT))- + TRES*(DENSE-DREF(NTOP))) TAUZZM(M,I)=TZZ+BRES*SZZBOT-TRES*SZZ PTSM(1,M,I)= -SZZBOT*SLOPEX+SZZ*SLTOPX PTSM(2,M,I)= -SZZBOT*SLOPEY+SZZ*SLTOPY 190 CONTINUE 200 CONTINUE C C CALCULATION FOR CRUST C CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,SIGZZM,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 300 M=1,7 DO 290 I=1,NUMEL SLOPEX=0. SLOPEY=0. DO 220 J=1,6 SLOPEX=SLOPEX+THNKC(NODES(J,I))*DXSC(J,M,I) SLOPEY=SLOPEY+THNKC(NODES(J,I))*DYSC(J,M,I) 220 CONTINUE ZMOHO=THIKC(M,I) TMOHO=TEMPC(ZMOHO,M,I) IF (DNLINK(1,M,I).GT.0.) THEN SZZ=OUTSCA(M,I) ELSE IF (TOUCHC(M,I).GT.0.) THEN SZZ=TOUCHC(M,I)*SZZBC(M,I) ELSE SZZ=0. ZMOHO=THIKC(M,I) ZASTH=ZMOHO+THIKM(5,NUMEL) NTOP=ZMOHO/ONEKM+0.5 NBOT=ZASTH/ONEKM+0.5 NTOP=MIN(NDREF,NTOP) NBOT=MIN(NDREF,NBOT) TRES=ZMOHO-NTOP*ONEKM BRES=ZASTH-NBOT*ONEKM DO 250 J=NBOT,NTOP+1,-1 Z=ONEKM*(J-0.5) ZP=Z-ZMOHO T=TEMPA(ZP,M,I) DENSE=RHOBAR(2)*(1.-ALPHAT(2)*T) IF (J.EQ.NBOT) DSAVE=DENSE SZZ=SZZ+G*ONEKM*(DENSE-DREF(J)) 250 CONTINUE SZZ=SZZ+G*(BRES*(DSAVE-DREF(NBOT))- + TRES*(DENSE-DREF(NTOP))) ENDIF ENDIF SZZBOT=SZZ PTSC(1,M,I)= -SZZBOT*SLOPEX PTSC(2,M,I)= -SZZBOT*SLOPEY SZZLST=SZZ TZZ=0. NINT=ZMOHO/ONEKM+0.5 NINT=MIN(NINT,NDREF) RESIDU=ZMOHO-NINT*ONEKM DO 280 J=NINT,1,-1 Z=ONEKM*(J-0.5) T=TEMPC(Z,M,I) DENSE=RHOBAR(1)*(1.-ALPHAT(1)*T) IF (J.EQ.NINT) DSAVE=DENSE SZZ=SZZ+G*ONEKM*(DENSE-DREF(J)) SZZM=0.5*(SZZ+SZZLST) SZZLST=SZZ TZZ=TZZ+ONEKM*SZZM 280 CONTINUE SIGZZC(M,I)=SZZ+RESIDU*G*(DSAVE-DREF(NINT)) TAUZZC(M,I)=TZZ+RESIDU*SZZBOT 290 CONTINUE 300 CONTINUE CALL EXTRAP (AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,SIGZZC,LWORK, + LOCKIN,LOCKWC) CALL INTERP (CONDNS,NODES,NUMEL,NUMNOD,SIGZZC) RETURN END C C C SUBROUTINE EXTRAP (AREA,CODE,DETJ,FAILUR, + FLOWIN,FPOLES,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,VALUES,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) C C SMOOTHS VALUES OF A SCALAR FIELD KNOWN AT THE INTEGRATION C POINTS (VALUES) TO PRODUCE VALUES AT THE NODES (FPOLES). C INCLUDES OPTION (LOCKIN) TO SET VALUES TO ZERO AT INLAND EDGES, C AND AN OPTION (LOCKWC) TO SET NODE VALUES TO PHINOD(I) AT WEST EDGE C LOGICAL FAILUR,LOCKIN,LOCKWC DOUBLE PRECISION CODE,FLOWIN,PHI,WEIGHT DIMENSION AREA(NUMEL),CODE(NCDIM),DETJ(7,NUMEL), + FLOWIN(NUMNOD),FPOLES(NUMNOD),NODES(6,0:NUMEL), + PHI(6,7),PHINOD(NUMNOD), + WEIGHT(7),VALUES(7,NUMEL),LWORK(NXL) COMMON /WGTVEC/ WEIGHT COMMON /PHITAB/ PHI CALL BUILDC (AREA,CODE,DETJ, + NCDIM,NDIFF,NODES,NUMEL,NUMNOD) DO 200 I=1,NUMNOD FLOWIN(I)=0. 200 CONTINUE DO 800 M=1,7 WT=WEIGHT(M) DO 700 I=1,NUMEL VALDA=VALUES(M,I)*AREA(I)*DETJ(M,I)*WT DO 600 J=1,6 K=NODES(J,I) FLOWIN(K)=FLOWIN(K)+PHI(J,M)*VALDA 600 CONTINUE 700 CONTINUE 800 CONTINUE IF (LOCKIN) CALL EBCS (NELCOL,FLOWIN,NUMNOD,NDIFF, + CODE,NCDIM) IF (LOCKWC) THEN NACROS=2*NELCOL+1 NROW=NUMNOD/NACROS DO 850 IR=1,NROW IN=(IR-1)*NACROS+1 VALUE=PHINOD(IN) CALL FIXVAL (IN,FLOWIN,NUMNOD,NDIFF,CODE,NCDIM,VALUE) 850 CONTINUE ENDIF CALL SOLVER (CODE,NCDIM,FLOWIN,NUMNOD,NDIFF,LWORK,NXL,FAILUR) DO 900 I=1,NUMNOD FPOLES(I)=FLOWIN(I) 900 CONTINUE RETURN END C C C SUBROUTINE INTERP (FPOLES,NODES,NUMEL,NUMNOD,VALUES) + C C INTERPOLATES SCALAR FROM NODES TO INTEGRATION POINTS C DOUBLE PRECISION PHI DIMENSION FPOLES(NUMNOD),NODES(6,0:NUMEL), + PHI(6,7),VALUES(7,NUMEL) COMMON /PHITAB/ PHI DO 100 M=1,7 DO 10 I=1,NUMEL VALUES(M,I)=0. 10 CONTINUE 100 CONTINUE DO 200 K=1,6 DO 190 M=1,7 DO 180 I=1,NUMEL VALUES(M,I)=VALUES(M,I)+FPOLES(NODES(K,I))* + PHI(K,M) 180 CONTINUE 190 CONTINUE 200 CONTINUE RETURN END C C C SUBROUTINE GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,UDLINK, + OUTPUT,OUTSCA) C C INTERPOLATES SCALAR FROM NODES TO POSITIONS GIVEN IN UDLINK C (ONE VALUE PER INTEGRATION POINT) C DIMENSION CONDNS(NUMNOD),NODES(6,0:NUMEL),OUTSCA(7,NUMEL), + UDLINK(3,7,NUMEL) 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) DO 1000 M=1,7 DO 900 I=1,NUMEL IE=UDLINK(1,M,I) S2=UDLINK(2,M,I) S3=UDLINK(3,M,I) S1=1.00-S2-S3 F1=CONDNS(NODES(1,IE)) F2=CONDNS(NODES(2,IE)) F3=CONDNS(NODES(3,IE)) F4=CONDNS(NODES(4,IE)) F5=CONDNS(NODES(5,IE)) F6=CONDNS(NODES(6,IE)) OUTSCA(M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE GETVEC (INPUT,VECNOD,NODES,NUMEL,NUMNOD,UDLINK, + OUTPUT,OUTVEC) C C INTERPOLATES VECTOR FROM NODES TO POSITIONS GIVEN IN UDLINK C (ONE VECTOR PER INTEGRATION POINT) C DIMENSION VECNOD(2,NUMNOD),NODES(6,0:NUMEL),OUTVEC(2,7,NUMEL), + UDLINK(3,7,NUMEL) 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) DO 1000 M=1,7 DO 900 I=1,NUMEL IE=UDLINK(1,M,I) I1=NODES(1,IE) I2=NODES(2,IE) I3=NODES(3,IE) I4=NODES(4,IE) I5=NODES(5,IE) I6=NODES(6,IE) S2=UDLINK(2,M,I) S3=UDLINK(3,M,I) S1=1.00-S2-S3 F1=VECNOD(1,I1) F2=VECNOD(1,I2) F3=VECNOD(1,I3) F4=VECNOD(1,I4) F5=VECNOD(1,I5) F6=VECNOD(1,I6) OUTVEC(1,M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) F1=VECNOD(2,I1) F2=VECNOD(2,I2) F3=VECNOD(2,I3) F4=VECNOD(2,I4) F5=VECNOD(2,I5) F6=VECNOD(2,I6) OUTVEC(2,M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE BUILDC (AREA,CODE,DETJ, + NCDIM,NDIFF,NODES,NUMEL,NUMNOD) C C WARNING!!! A "@PROCESS NOVECTOR" STATEMENT C IS NEEDED BEFORE "SUBROUTINE BUILDC" UNDER VS FORTRAN 2.4.0 C BECAUSE OF A COMPILER BUG. IF THIS ROUTINE IS COMPILED C WITH THE VECTOR (DEFAULT) OPTION, IT WILL BE INCORRECT C AND WILL GIVE VERY ODD RESULTS THAT ARE HARD TO TRACE. C C CREATES SMOOTHING MATRIX CODE (CROSS-PRODUCTS OF PHI) C DOUBLE PRECISION CODE,PHI,WEIGHT DIMENSION AREA(NUMEL),CODE(NCDIM),DETJ(7,NUMEL), + NODES(6,0:NUMEL),PHI(6,7),WEIGHT(7) COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT C C ****************** IMPORTANT ************************************ C ALL INDEXK DEFINITION STATEMENTS IN PACKAGE MUST AGREE ! INDEXK(IR,JC,NBAND)=2*NBAND+1+IR-JC+(JC-1)*(3*NBAND+16) C****************************************************************** C USAGE IN THIS ROUTINE: INDEXK(IR,JC,NDIFF) C BECAUSE THESE TENSORS HAVE HALF THE RANK OF STIFF C DO 10 I=1,NCDIM CODE(I)=0. 10 CONTINUE C DO 100 I=1,NUMEL DO 90 I6=1,6 DO 80 J6=1,6 IR=NODES(I6,I) JC=NODES(J6,I) SUM=0. DO 70 M=1,7 SUM=SUM+WEIGHT(M)*DETJ(M,I)* + PHI(I6,M)*PHI(J6,M) 70 CONTINUE K=INDEXK(IR,JC,NDIFF) CODE(K)=CODE(K)+SUM*AREA(I) 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE PURE (ACREEP,ALPHAC,ALPHAM, + AREAC,AREAM,BCREEP,BIOT,CCREEP,CONINT,DCREEP, + DELTAT,DELVC,DELVM,DETJC,DETJM,DXSC,DXSM, + DYSC,DYSM,ECREEP,ERATEC,ERATEM,ETAMAX, + FORCE,FRIC,FROMWC,G,GEOTHC,GEOTHM, + GLUEC,GLUEM,HMAX,HMIN,DNLINK,UPLINK, + IBELOW,MAXITR,NBAND,NKDIM,NELCOL, + NODES,NTNM,NUMEL,NUMNOD,NXL,OKTOQT,ONEKM,OUTVEC, + OUTV2,OUTSCA,PUSHHO,PTSC,PTSM, + QFRICC,QFRICM,RHOH2O,RHOBAR,STIFF, + SIGBOT,SIGHC,SIGHBM,SIGHTM, + TAUMTC,TAUMTM, + TAUZZC,TAUZZM,TEMLIM, + THIKC,THIKM,THNKC,THNKM,TOFSTC,TOFSTM, + TOUCHC,TOUCHM,LWORK,WANDES,XNODC,XNODM, + YNODC,YNODM,VC,VM,VISMAX,VSLABC,VSLABM, + FAILUR,DVB,DVT,OVA,OVB, + CODE,FLOWIN,CONDNS,NCDIM,NDIFF) C C CALCULATES VELOCITIES OF UPPER SURFACES (GRID PLANES) C OF BOTH LAYERS DUE TO PURE-SHEAR DEFORMATION CAUSED BY C BASAL SHEAR STRESSES AND PRESSURE ANOMALIES AND C GRAVITATIONAL SPREADING C DOUBLE PRECISION CODE,FLOWIN,FORCE,STIFF LOGICAL FAILUR,LOCKIN,LOCKWC,MANTLE DIMENSION ACREEP(3),ALPHAC(3,3,7,NUMEL),ALPHAM(3,3,7,NUMEL), + AREAC(NUMEL),AREAM(NUMEL),BCREEP(3),CCREEP(3), + CODE(NCDIM),CONDNS(NUMNOD),CONINT(7,NUMEL),DCREEP(3), + DELVC(2,7,NUMEL), + DELVM(2,7,NUMEL),DETJC(7,NUMEL),DETJM(7,NUMEL), + DNLINK(3,7,NUMEL),DVB(7,NUMEL),DVT(7,NUMEL), + DXSC(6,7,NUMEL),DXSM(6,7,NUMEL),DYSC(6,7,NUMEL), + DYSM(6,7,NUMEL),ECREEP(3),ERATEC(4,7,NUMEL), + ERATEM(4,7,NUMEL),FLOWIN(NUMNOD),FORCE(NTNM),FRIC(2), + FROMWC(7,NUMEL), + GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL),GLUEC(7,NUMEL), + GLUEM(7,NUMEL),HMAX(2),HMIN(2), + NODES(6,0:NUMEL),OVA(2,7,NUMEL),OVB(2,7,NUMEL) DIMENSION OUTSCA(7,NUMEL), + OUTVEC(2,7,NUMEL),OUTV2(2,7,NUMEL), + PTSC(2,7,NUMEL),PTSM(2,7,NUMEL),RHOBAR(2), + QFRICC(4,7,NUMEL),QFRICM(4,7,NUMEL), + SIGHBM(2,7,NUMEL),SIGHC(2,7,NUMEL),SIGHTM(2,7,NUMEL), + STIFF(NKDIM), + TAUMTC(3,7,NUMEL),TAUMTM(3,7,NUMEL), + TAUZZC(7,NUMEL),TAUZZM(7,NUMEL), + TEMLIM(2),THIKC(7,NUMEL),THIKM(7,NUMEL), + THNKC(NUMNOD),THNKM(NUMNOD), + TOFSTC(3,7,NUMEL),TOFSTM(3,7,NUMEL), + TOUCHC(7,NUMEL),TOUCHM(7,NUMEL), + UPLINK(3,7,NUMEL), + VSLABC(2,7,NUMEL),VSLABM(2,7,NUMEL), + LWORK(NXL), + XNODC(NUMNOD),XNODM(NUMNOD), + YNODC(NUMNOD),YNODM(NUMNOD), + VC(2,NUMNOD),VM(2,NUMNOD) DATA LOCKIN /.FALSE./, LOCKWC /.FALSE./ C C FIRST, COMPUTE CONSTANT ARRAYS DESCRIBING CRUST THAT THONM C WILL NEED DURING EACH ITERATION. C C --GLUEC-- DO 4 M=1,7 DO 2 I=1,NUMEL IF (DNLINK(1,M,I).GT.0.0) THEN OUTSCA(M,I)=GLUEC(M,I) ELSE OUTSCA(M,I)=0.0 ENDIF 2 CONTINUE 4 CONTINUE CALL EXTRAP (AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DO 20 M=1,7 DO 10 I=1,NUMEL OUTV2(1,M,I)=MAX(OUTSCA(M,I),0.) 10 CONTINUE 20 CONTINUE C OUTV2(1,M,I) HOLDS GLUEC VALUE AT MANTLE INTEGRATION POINTS C C --CRUSTAL THICKNESS-- CALL GETSCA (INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DO 40 M=1,7 DO 30 I=1,NUMEL OUTSCA(M,I)=MAX(OUTSCA(M,I),HMIN(1)) OUTSCA(M,I)=MIN(OUTSCA(M,I),HMAX(1)) 30 CONTINUE 40 CONTINUE C OUTSCA HOLDS CRUSTAL THICKNESSES AT MANTLE INTEGRATION POINTS C -- DONE -- C DO 1000 ITER=1,MAXITR IF ((ITER.LE.3).OR.(SCORE2.GT.OKTOQT).OR. + (SCORE4.GT.OKTOQT)) THEN CALL THONM (INPUT,OUTSCA,ECREEP,ETAMAX, + FRIC,G,OUTV2,GLUEM, + NODES,NUMEL,NUMNOD, + RHOBAR,SIGBOT,THIKM,TOUCHM,UPLINK, + VC,VISMAX,VM,VSLABM, + OUTPUT,DELVM,DVB,DVT,OVA,OVB, + QFRICM,SIGHBM,SIGHTM, + WORK,OUTVEC) MANTLE=.TRUE. CALL FEM (ACREEP,ALPHAM,AREAM,BCREEP, + BIOT,CCREEP,CONINT,DCREEP,DELTAT, + DETJM,DXSM,DYSM,ECREEP,TEMLIM, + ERATEM,FORCE,FRIC,G,GEOTHM,UPLINK, + IBELOW,ITER,MANTLE,NBAND,NKDIM,NELCOL,NODES, + NUMEL,NUMNOD,NTNM,NXL,ONEKM,PTSM,QFRICM, + RHOBAR,RHOH2O,SCORE1,SCORE2,SCORE3,SCORE4,SIGBOT, + STIFF,SIGHBM,SIGHTM,DVB,DVT,OVB,OVA,TAUMTM, + TAUZZM,THIKM,THIKC,THNKM,TOFSTM,TOUCHM, + VM,VISMAX,VSLABM,ETAMAX,FAILUR, + LWORK,XNODM,YNODM,OUTSCA) IF (FAILUR) RETURN ENDIF IF ((ITER.LE.3).OR.(SCORE6.GT.OKTOQT).OR. + (SCORE8.GT.OKTOQT)) THEN CALL THONC (INPUT,DNLINK,ECREEP,ETAMAX, + FRIC,FROMWC,G,GLUEC, + NODES,NUMEL,NUMNOD,PUSHHO, + RHOBAR,SIGBOT,THIKC,TOUCHC, + VC,VISMAX,VM,VSLABC,WANDES, + OUTPUT,DELVC,DVB,OVB,QFRICC,SIGHC, + WORK,OUTVEC) MANTLE=.FALSE. CALL FEM (ACREEP,ALPHAC,AREAC,BCREEP, + BIOT,CCREEP,CONINT,DCREEP,DELTAT, + DETJC,DXSC,DYSC,ECREEP,TEMLIM, + ERATEC,FORCE,FRIC,G,GEOTHC,UPLINK, + IBELOW,ITER,MANTLE,NBAND,NKDIM,NELCOL,NODES, + NUMEL,NUMNOD,NTNM,NXL,ONEKM,PTSC,QFRICC, + RHOBAR,RHOH2O,SCORE5,SCORE6,SCORE7,SCORE8,SIGBOT, + STIFF,SIGHC,SIGHC,DVB,DVB,OVB,OVB,TAUMTC, + TAUZZC,THIKC,THIKC,THNKC,TOFSTC,TOUCHC, + VC,VISMAX,VSLABC,ETAMAX,FAILUR, + LWORK,XNODC,YNODC,OUTSCA) IF (FAILUR) RETURN ENDIF WRITE(6,102) ITER,SCORE1,SCORE2,SCORE3,SCORE4, + SCORE5,SCORE6,SCORE7,SCORE8 102 FORMAT(11X,I6,4X,4(1P,E10.2,0P,F9.4,1X)) WSCORE=MAX(SCORE2,SCORE4,SCORE6,SCORE8) IF (WSCORE.LE.OKTOQT) THEN WRITE(6,999) 999 FORMAT('+',100X,' CONVERGED') GO TO 1001 ENDIF 1000 CONTINUE 1001 IF(WSCORE.GT.OKTOQT) THEN WRITE(6,1002) 1002 FORMAT('+',100X,' ITERATION LIMIT REACHED') ENDIF FAILUR=FAILUR.OR.WSCORE.GT.0.50 RETURN END C C C SUBROUTINE THONM (INPUT,CRUSTM,ECREEP,ETAMAX, + FRIC,G,GLUECM,GLUEM, + NODES,NUMEL,NUMNOD, + RHOBAR,SIGBOT,THIKM,TOUCHM,UPLINK, + VC,VISMAX,VM,VSLABM, + OUTPUT,DELVM,DVB,DVT,OVA,OVB, + QFRICM,SIGHBM,SIGHTM, + WORK,OUTVEC) C C CALCULATES VECTOR SHEAR STRESSES ON BASE OF MANTLE (SIGHBM), C VECTOR SHEAR STRESSES ON TOP OF MANTLE (SIGHTM), C RELATIVE VELOCITY WITHIN MANTLE DUE TO SIMPLE SHEAR (DELVM), C THE VECTOR VELOCITY OF THE LAYER BELOW (OVB), C THE SCALAR VELOCITY DIFFERENCE OF THE LAYER BELOW (DVB), C THE VECTOR VELOCITY OF THE LAYER ABOVE (OVA), C THE SCALAR VELOCITY DIFFERENCE OF THE LAYER ABOVE (DVA), C ALSO SUPPLIES QFRICM(3,M,I), THE FRICTIONAL HEATING FLUX FROM C THE DETACHMENT LAYER. C C NOTE THAT INPUT ARRAY CRUSTM(M,I) GIVES CRUSTAL THICKNESS ABOVE C THE MANTLE INTEGRATION POINTS. C THE INPUT ARRAY GLUECM(1,M,I) GIVES GLUEC VALUES ABOVE C THE MANTLE INTEGRATION POINTS; GLUECM(2,M,I) IS NOT USED. C DIMENSION CRUSTM(7,NUMEL), + DELVM(2,7,NUMEL),DVB(7,NUMEL),DVT(7,NUMEL), + ECREEP(3),FRIC(2),GLUECM(2,7,NUMEL),GLUEM(7,NUMEL), + UPLINK(3,7,NUMEL),NODES(6,0:NUMEL), + OUTVEC(2,7,NUMEL), + OVA(2,7,NUMEL),OVB(2,7,NUMEL),QFRICM(4,7,NUMEL), + RHOBAR(2),SIGHBM(2,7,NUMEL),SIGHTM(2,7,NUMEL), + THIKM(7,NUMEL), + TOUCHM(7,NUMEL),VSLABM(2,7,NUMEL), + VC(2,NUMNOD),VM(2,NUMNOD) C CALL FLOW (VM,NUMNOD,NODES,NUMEL,OUTVEC) CALL GETVEC (INPUT,VC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OVA) DO 1000 M=1,7 DO 900 I=1,NUMEL CRUST=CRUSTM(M,I) GLUEC=GLUECM(1,M,I) VMX=OUTVEC(1,M,I) VMY=OUTVEC(2,M,I) VFX=VSLABM(1,M,I) VFY=VSLABM(2,M,I) IF (TOUCHM(M,I).GE.0.99) THEN OVB(1,M,I)=VFX OVB(2,M,I)=VFY VRX=VFX-VMX VRY=VFY-VMY V=SQRT((1.D0*VRX)**2+(1.D0*VRY)**2) DVB(M,I)=V IF (V.GT.0.0) THEN DVX=VRX/V DVY=VRY/V SHEAR1=GLUEM(M,I)*V**ECREEP(3) ELSE DVX=0. DVY=0. SHEAR1=0. END IF SHEAR2=G*FRIC(2)* + (CRUST*RHOBAR(1)+THIKM(M,I)*RHOBAR(2)) SHEAR3=VISMAX*V/THIKM(M,I) SHEAR4=ETAMAX*V SHEAR5=SIGBOT SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4,SHEAR5) DECOLL=(SHEAR/GLUEM(M,I))**(1./ECREEP(3)) SIGHBM(1,M,I)=SHEAR*DVX SIGHBM(2,M,I)=SHEAR*DVY DELVM(1,M,I)=DVX*DECOLL DELVM(2,M,I)=DVY*DECOLL QFRICM(3,M,I)=SHEAR*DECOLL ELSE OVB(1,M,I)=0. OVB(2,M,I)=0. DVB(M,I)=0. SIGHBM(1,M,I)=0. SIGHBM(2,M,I)=0. DELVM(1,M,I)=0. DELVM(2,M,I)=0. QFRICM(3,M,I)=0. ENDIF VCX=OVA(1,M,I) VCY=OVA(2,M,I) VRX=VCX-VMX VRY=VCY-VMY V=SQRT((1.D0*VRX)**2+(1.D0*VRY)**2) DVT(M,I)=V IF (V.GT.0.0) THEN DVX=VRX/V DVY=VRY/V SHEAR1=MAX(GLUEC,0.)*V**ECREEP(2) ELSE DVX=0. DVY=0. SHEAR1=0. END IF SHEAR2=RHOBAR(1)*G*CRUST*FRIC(1) SHEAR3=VISMAX*V/CRUST SHEAR4=ETAMAX*V SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4) SIGHTM(1,M,I)=SHEAR*DVX SIGHTM(2,M,I)=SHEAR*DVY 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE THONC (INPUT,DNLINK,ECREEP,ETAMAX, + FRIC,FROMWC,G,GLUEC, + NODES,NUMEL,NUMNOD,PUSHHO, + RHOBAR,SIGBOT,THIKC,TOUCHC, + VC,VISMAX,VM,VSLABC,WANDES, + OUTPUT,DELVC,DVB,OVB,QFRICC,SIGHC, + WORK,OUTVEC) C C CALCULATES SHEAR STRESSES ON BASE OF CRUST (SIGHC), AND C RELATIVE VELOCITY WITHIN CRUST DUE TO SIMPLE SHEAR (DELVC), C THE VECTOR VELOCITY OF THE LAYER BELOW (OVB), AND C THE SCALAR VELOCITY DIFFERENCE OF THE LAYER BELOW (DVB). C ALSO SUPPLIES QFRICC(3,M,I), THE FRICTIONAL HEATING FLUX FROM C THE DETACHMENT LAYER. C COMMON /GROBOW/ HANDES,XANDES,NPOINT,NALT1,NALT2 DIMENSION HANDES(5),XANDES(5) DIMENSION DELVC(2,7,NUMEL),DVB(7,NUMEL),ECREEP(3),FRIC(2), + FROMWC(7,NUMEL),GLUEC(7,NUMEL),DNLINK(3,7,NUMEL), + NODES(6,0:NUMEL),OUTVEC(2,7,NUMEL), + OVB(2,7,NUMEL),QFRICC(4,7,NUMEL),RHOBAR(2), + SIGHC(2,7,NUMEL),THIKC(7,NUMEL), + TOUCHC(7,NUMEL),VSLABC(2,7,NUMEL), + VC(2,NUMNOD),VM(2,NUMNOD) C CALL FLOW (VC,NUMNOD,NODES,NUMEL,OUTVEC) CALL GETVEC (INPUT,VM,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OVB) DO 1000 M=1,7 DO 900 I=1,NUMEL VCX=OUTVEC(1,M,I) VCY=OUTVEC(2,M,I) XREL=FROMWC(M,I)/MAX(WANDES,1.) IF (XREL.LT.XANDES(NALT1)) THEN SLIMIT=SIGBOT+PUSHHO ELSE SLIMIT=SIGBOT ENDIF I2=DNLINK(1,M,I) IF (I2.NE.0) THEN VMX=OVB(1,M,I) VMY=OVB(2,M,I) VRX=VMX-VCX VRY=VMY-VCY V=SQRT((1.D0*VRX)**2+(1.D0*VRY)**2) DVB(M,I)=V IF (V.GT.0.0) THEN DVX=VRX/V DVY=VRY/V SHEAR1=GLUEC(M,I)*V**ECREEP(2) ELSE DVX=0. DVY=0. SHEAR1=0. END IF SHEAR2=RHOBAR(1)*G*THIKC(M,I)*FRIC(1) SHEAR3=VISMAX*V/THIKC(M,I) SHEAR4=ETAMAX*V SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4) DECOLL=(SHEAR/GLUEC(M,I))**(1./ECREEP(2)) SIGHC(1,M,I)=SHEAR*DVX SIGHC(2,M,I)=SHEAR*DVY DELVC(1,M,I)=DVX*DECOLL DELVC(2,M,I)=DVY*DECOLL QFRICC(3,M,I)=SHEAR*DECOLL ELSE VFX=VSLABC(1,M,I) VFY=VSLABC(2,M,I) IF (TOUCHC(M,I).GE.0.99) THEN OVB(1,M,I)=VFX OVB(2,M,I)=VFY VRX=VFX-VCX VRY=VFY-VCY V=SQRT((1.D0*VRX)**2+(1.D0*VRY)**2) DVB(M,I)=V IF (V.GT.0.0) THEN DVX=VRX/V DVY=VRY/V SHEAR1=GLUEC(M,I)*V**ECREEP(2) ELSE DVX=0. DVY=0. SHEAR1=0. END IF SHEAR2=RHOBAR(1)*G*THIKC(M,I)*FRIC(1) SHEAR3=VISMAX*V/THIKC(M,I) SHEAR4=ETAMAX*V SHEAR5=SLIMIT SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4,SHEAR5) DECOLL=(SHEAR/GLUEC(M,I))**(1./ECREEP(2)) SIGHC(1,M,I)=SHEAR*DVX SIGHC(2,M,I)=SHEAR*DVY DELVC(1,M,I)=DVX*DECOLL DELVC(2,M,I)=DVY*DECOLL QFRICC(3,M,I)=SHEAR*DECOLL ELSE OVB(1,M,I)=0. OVB(2,M,I)=0. DVB(M,I)=0. DELVC(1,M,I)=0. DELVC(2,M,I)=0. SIGHC(1,M,I)=0. SIGHC(2,M,I)=0. QFRICC(3,M,I)=0. ENDIF ENDIF 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE FEM (ACREEP,ALPHA,AREA,BCREEP,BIOT,CCREEP, + CONINT,DCREEP,DELTAT,DETJ,DXS,DYS, + ECREEP,TEMLIM,ERATE,FORCE,FRIC,G,GEOTH, + UPLINK,IBELOW,ITER,MANTLE,NBAND,NKDIM,NELCOL, + NODES,NUMEL,NUMNOD,NTNM,NXL,ONEKM,PTS,QFRIC, + RHOBAR,RHOH2O,SCOREA,SCOREB,SCOREC,SCORED,SIGBOT, + STIFF,SIGHB,SIGHT,DVB,DVT,OVB,OVA,TAUMAT,TAUZZ, + THIK,THIKC,THNK,TOFSET,TOUCH,V,VISMAX,VSLAB, + ETAMAX,FAILUR,LWORK,XNOD,YNOD,CRUSTM) 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 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 DS, RMS DS/RMS S. C C NOTE THAT INPUT ARRAY CRUSTM(M,I) GIVES CRUSTAL THICKNESS ABOVE C THE MANTLE INTEGRATION POINTS. C LOGICAL FAILUR,MANTLE DOUBLE PRECISION FORCE,STIFF DIMENSION ACREEP(3),ALPHA(3,3,7,NUMEL),AREA(NUMEL), + BCREEP(3),CCREEP(3),CONINT(7,NUMEL), + CRUSTM(7,NUMEL),DCREEP(3),DETJ(7,NUMEL), + DVB(7,NUMEL),DVT(7,NUMEL),DXS(6,7,NUMEL), + DYS(6,7,NUMEL),ECREEP(3),ERATE(4,7,NUMEL), + FORCE(NTNM),FRIC(2),GEOTH(4,7,NUMEL), + UPLINK(3,7,NUMEL), + NODES(6,0:NUMEL),OVA(2,7,NUMEL),OVB(2,7,NUMEL), + PTS(2,7,NUMEL),QFRIC(4,7,NUMEL),RHOBAR(2), + SIGHB(2,7,NUMEL),SIGHT(2,7,NUMEL),STIFF(NKDIM), + TAUMAT(3,7,NUMEL),TAUZZ(7,NUMEL), + TEMLIM(2),THIK(7,NUMEL),THIKC(7,NUMEL), + THNK(NUMNOD),TOFSET(3,7,NUMEL),TOUCH(7,NUMEL), + V(2,NUMNOD),LWORK(NXL),VSLAB(2,7,NUMEL), + XNOD(NUMNOD),YNOD(NUMNOD) C CALL VISCOS (INPUT,ACREEP,BCREEP,BIOT,CCREEP, + CONINT,CRUSTM,DCREEP,ECREEP, + ERATE,FRIC,G,GEOTH, + MANTLE,NUMEL,ONEKM,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,THIK,VISMAX, + OUTPUT,ALPHA,QFRIC, + SCOREC,SCORED,TOFSET) CALL BUILDK (STIFF,NKDIM,NBAND,NUMEL,NODES,ALPHA, + DXS,DYS,DETJ,AREA,NTNM, + MANTLE,SIGHB,SIGHT,DVB,DVT,ETAMAX) CALL BUILDF (FORCE,NTNM,NUMEL,TAUZZ,AREA,DETJ, + MANTLE,SIGHB,SIGHT,DVB,DVT,OVB,OVA,DXS,DYS,NODES, + ETAMAX,TOFSET,PTS,NELCOL,NUMNOD,XNOD,YNOD) CALL BCS (NELCOL,FORCE,NTNM,NBAND, + STIFF,NKDIM,NUMNOD) IF ((IBELOW.EQ.1).OR.(IBELOW.EQ.2)) + CALL SLIPBC (INPUT,DELTAT,ETAMAX,MANTLE, + NBAND,NKDIM,NELCOL, + NTNM,NUMEL,NUMNOD, + SIGBOT,THNK,TOUCH, + V,VSLAB,XNOD,YNOD, + MODIFY,FORCE,STIFF) CALL SOLVER (STIFF,NKDIM,FORCE,NTNM,NBAND,LWORK,NXL,FAILUR) BDENOM=0. BDENON=0. SCOREA=0. SCOREB=0. DO 10 I=1,NUMNOD BDENOM=BDENOM+FORCE(2*I-1)**2+FORCE(2*I)**2 BDENON=BDENON+V(1,I)**2+V(2,I)**2 DV2=(V(1,I)-FORCE(2*I-1))**2 + + (V(2,I)-FORCE(2*I))**2 SCOREA=MAX(SCOREA,DV2) SCOREB=SCOREB+DV2 10 CONTINUE IF (SCOREA.GT.0.) SCOREA=SQRT(SCOREA) IF (SCOREB.GT.0.) + SCOREB=SQRT(SCOREB)/SQRT(MAX(BDENOM,BDENON)) DO 100 I=1,NUMNOD V(1,I)=FORCE(2*I-1) V(2,I)=FORCE(2*I) 100 CONTINUE CALL EDOT (NUMEL,NODES,V,NUMNOD,DXS,DYS,ERATE, + ALPHA,TOFSET,TAUMAT) RETURN END C C C SUBROUTINE VISCOS (INPUT,ACREEP,BCREEP,BIOT,CCREEP, + CONINT,CRUSTM,DCREEP,ECREEP, + ERATE,FRIC,G,GEOTH, + MANTLE,NUMEL,ONEKM,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,THIK,VISMAX, + OUTPUT,ALPHA,QFRIC, + SCOREC,SCORED,TOFSET) C C COMPUTES SECANT EFFECTIVE VISCOSITY MATRIX ALPHA C IN 3 X 3 COMPONENT FORM, FROM 2 X 2 PRINCIPAL AXIS FORM, C AT EACH INTEGRATION POINT OF A LAYER. C (NOTE THAT ALPHA HAS DIMENSION OF VISCOSITY * THICKNESS). C ALSO RECORDS OFFSET VALUES (TOFSET(3,7,NUMEL)) FOR NEXT ITERATION; C CALCULATION OF TOFSET + ALPHA*E WILL GIVE MODEL C DEVIATORIC STRESS INTEGRALS (RELATIVE TO VERTICAL STRESS). C QFRIC(1,M,I) IS THE VERTICALLY-INTEGRATED SHEAR-STRAIN HEATING C IN THE LAYER; QFRIC(2,M,I) GIVES THE DEPTH OF ITS CENTER. C SCOREC AND SCORED ARE MEASURES OF MISMATCH BETWEEN CURRENT C LINEARIZED AND ACTUAL NONLINEAR RHEOLOGIES. C C NOTE THAT INPUT ARRAY CRUSTM(M,I) GIVES CRUSTAL THICKNESS ABOVE C THE MANTLE INTEGRATION POINTS. C DOUBLE PRECISION DELP2,DENOMF,DENOMV,SHEAR2,TOTALC,TOTALD LOGICAL MANTLE DIMENSION ACREEP(3),ALPHA(3,3,7,NUMEL),BCREEP(3),CCREEP(3), + CONINT(7,NUMEL),CRUSTM(7,NUMEL),DCREEP(3),ECREEP(3), + ERATE(4,7,NUMEL),FRIC(2),GEOTH(4,7,NUMEL), + QFRIC(4,7,NUMEL),RHOBAR(2), + SIGHB(2,7,NUMEL),TAUMAT(3,7,NUMEL), + TEMLIM(2),THIK(7,NUMEL),TOFSET(3,7,NUMEL) C IF (MANTLE) THEN FR=FRIC(2) RHO=RHOBAR(2) ELSE FR=FRIC(1) RHO=RHOBAR(1) ENDIF TOTALC=0.0D0 TOTALD=0.0D0 DENOMV=0.0D0 DENOMF=0.0D0 EBASE=(RHO*G*ONEKM*0.001)/VISMAX STFRIC=SIN(ATAN(FR)) DO 1000 M=1,7 DO 900 I=1,NUMEL CTAMIP=MAX(CRUSTM(M,I),0.) SIGHBI=SQRT((1.D0*SIGHB(1,M,I))**2+ + (1.D0*SIGHB(2,M,I))**2) DELP2=0.25D0*(1.D0*TAUMAT(1,M,I)+TAUMAT(2,M,I))**2 SHEAR2=(1.D0*TAUMAT(3,M,I))**2+0.25D0* + (1.D0*TAUMAT(1,M,I)-TAUMAT(2,M,I))**2 DENOMV=DENOMV+MAX(DELP2,SHEAR2) THICK=THIK(M,I) EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) IF(ABS(EXX-EYY).LT.EBASE) EXX=EYY-EBASE DIVER=EXX+EYY SHEAR=SQRT((1.D0*EXY)**2+ + 0.25D0*(1.D0*EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR ANGLE=ATAN2F(EXY,0.5*(EXX-EYY)) CALL DIAMND (INPUT,ACREEP,BCREEP,BIOT, + CCREEP,CONINT,CTAMIP, + DCREEP,ECREEP,EXX,EXY,EYY,E1,E2, + G,GEOTH,I,M,MANTLE,NUMEL,ONEKM, + RHOBAR,RHOH2O,SIGHBI,STFRIC, + THICK,TEMLIM,VISMAX, + OUTPUT,DT1DE1,DT1DE2,DT2DE1,DT2DE2, + QFRIC,RADT,TXX,TXY,TYY) DENOMF=DENOMF+MAX((1.D0*RADT)**2, + 0.25D0*(1.D0*TXX+TYY)**2) DXX=TAUMAT(1,M,I)-TXX DYY=TAUMAT(2,M,I)-TYY DXY=TAUMAT(3,M,I)-TXY DELP2=0.25D0*(1.D0*DXX+DYY)**2 SHEAR2=.25D0*(1.D0*DXX-DYY)**2+(1.D0*DXY)**2 TOTALC=MAX(TOTALC,DELP2,SHEAR2) TOTALD=TOTALD+MAX(DELP2,SHEAR2) DE1DEX=0.5-(EXX-EYY)/(4.*SHEAR) DE1DEY=0.5+(EXX-EYY)/(4.*SHEAR) DE1DES= -EXY/SHEAR DE2DEX=DE1DEY DE2DEY=DE1DEX DE2DES= -DE1DES U=2.*EXY/(EXX-EYY) TERM=1./(1.+U**2) DANDEX= -TERM*U/(EXX-EYY) DANDEY= -DANDEX DANDES=TERM*2./(EXX-EYY) DTXDT1=0.5*(1.-COS(ANGLE)) DTXDT2=0.5*(1.+COS(ANGLE)) DTXDAN= -TXY DTYDT1=DTXDT2 DTYDT2=DTXDT1 DTYDAN=TXY DTSDT1= -0.5*SIN(ANGLE) DTSDT2= -DTSDT1 DTSDAN=RADT*COS(ANGLE) C FIRST SUBSCRIPT OF ALPHA REFERS TO STRESS (1:TXX,2:TYY,3:TXY) C SECOND SUBSCRIPT OF ALPHA REFERS TO STRAIN (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 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 900 CONTINUE 1000 CONTINUE SCOREC=SQRT(TOTALC) SCORED=SQRT(TOTALD/MAX(DENOMV,DENOMF)) RETURN END C C C SUBROUTINE DIAMND (INPUT,ACREEP,BCREEP,BIOT, + CCREEP,CONINT,CTAMIP, + DCREEP,ECREEP,EXX,EXY,EYY,E1,E2, + G,GEOTH,I,M,MANTLE,NUMEL,ONEKM, + RHOBAR,RHOH2O,SIGHBI,STFRIC, + THICK,TEMLIM,VISMAX, + OUTPUT,DT1DE1,DT1DE2,DT2DE1,DT2DE2, + QFRIC,RADT,TXX,TXY,TYY) C C CALCULATES VERTICAL INTEGRAL OF C STRESS COMPONENTS (SXX-SZZ), (SYY-SZZ), AND SXY C AT A SINGLE INTEGRATION POINT (M,I) AND REPORTS THEM AS C TXX, TYY, AND TXY. C ALSO RECOMMENDS TACTICAL PARTIAL DERIVITIVES C DT1DE1, DT1DE2, DT2DE1, AND DT2DE2 C IN PRINCIPAL-AXIS FORM. C QFRIC(1,M,I) REPORTS THE VERTICAL INTEGRAL OF THE SHEAR-STRAIN C HEATING RATE; QFRIC(2,M,I) HOLDS THE DEPTH INTO THE LAYER C WHERE THIS IS CONCENTRATED. C DOUBLE PRECISION SECINV LOGICAL FAULT,GLIDE,MANTLE DIMENSION ACREEP(3),BCREEP(3),CCREEP(3),CONINT(7,NUMEL), + DCREEP(3),DTF1(4),DTF2(4),DT1(4),DT2(4), + ECREEP(3),ETALPH(4),ETBETA(4),ET1(4),ET2(4), + GEOTH(4,7,NUMEL),QFRIC(4,7,NUMEL),RHOBAR(2),TEMLIM(2) C C STATEMENT FUNCTION: TEMP(Z,L,J)=MAX(200.,MIN(TLIM,GEOTH(1,L,J) + +GEOTH(2,L,J)*Z + +GEOTH(3,L,J)*Z**2 + +GEOTH(4,L,J)*Z**3)) C C SELECT PROPERTIES RELEVANT TO BRITTLE/DUCTILE TRANSITION C IF (MANTLE) THEN CRUST=CTAMIP PE0=G*CRUST*(RHOBAR(1)-RHOH2O*BIOT) DPEDZ=G*(RHOBAR(2)-RHOH2O*BIOT) TLIM=TEMLIM(2) ILAYER=3 ELSE CRUST=0. PE0=0. DPEDZ=G*(RHOBAR(1)-RHOH2O*BIOT) TLIM=TEMLIM(1) ILAYER=1 ENDIF C C CHARACTERIZE THE STRAIN RATE C EZZ= -EXX-EYY SECINV=(1.D0*E1)*E2+(1.D0*E1)*EZZ+(1.D0*E2)*EZZ DEFORM=2.*SQRT(ABS(SECINV)) EN=DEFORM**ECREEP(ILAYER) ANGLE=ATAN2F(E2,E1)-0.7854 FACTOR=1./(1.+STFRIC*COS(ANGLE)) C C FIND BRITTLE/DUCTILE TRANSITION DEPTH INTO THE LAYER (Z), C USING BRUTE-FORCE SEARCH FROM THE TOP DOWN. C (I TRIED NEWTON'S METHOD, BUT IT WAS OCCASIONALLY UNSTABLE.) C NOTICE THAT MATERIAL WHOSE STRENGTH IS LIMITED BY DCREEP C IS CONSIDERED TO BE ABOVE THE BRITTLE/DUCTILE TRANSITION(?). C NSTEP=50 DO 100 J=0,NSTEP ZT=(THICK*J)/NSTEP T=TEMP(ZT,M,I) SF=STFRIC*(PE0+DPEDZ*ZT)*FACTOR SF=MIN(SF,DCREEP(ILAYER)) ARG=(BCREEP(ILAYER)+CCREEP(ILAYER)*(ZT+CRUST))/T ARG=MIN(MAX(ARG,-97.),97.) SC=ACREEP(ILAYER)*EN*EXP(ARG) IF (J.GT.0) THEN IF (SC.LE.SF) THEN DENOM=SF-OLDSF+OLDSC-SC IF (DENOM.NE.0.) THEN FRAC=(OLDSC-OLDSF)/DENOM ELSE FRAC=1. END IF FRAC=MAX(MIN(FRAC,1.),0.) Z=OLDZT+FRAC*(ZT-OLDZT) GO TO 101 END IF END IF OLDZT=ZT OLDSF=SF OLDSC=SC 100 CONTINUE Z=THICK 101 Z=MAX(Z,0.) Z=MIN(Z,THICK) C C DETERMINE FRICTIONAL AND PLASTIC RESISTANCES AND HEATING CENTER C SFMIN=PE0*STFRIC*FACTOR SFMAX=(PE0+Z*DPEDZ)*STFRIC*FACTOR IF (SFMAX.LE.DCREEP(ILAYER).OR.Z.EQ.0.) THEN CONST=Z*(SFMAX+SFMIN)/2. PLAST=0. QFRIC(2,M,I)=Z ELSE IF (SFMIN.GE.DCREEP(ILAYER)) THEN PLAST=Z*DCREEP(ILAYER) CONST=0. QFRIC(2,M,I)=Z/2. ELSE ZT=Z*(DCREEP(ILAYER)-SFMIN)/(SFMAX-SFMIN) CONST=0.5*ZT*(SFMIN+DCREEP(ILAYER)) PLAST=(Z-ZT)*DCREEP(ILAYER) QFRIC(2,M,I)=(Z+ZT)/2. ENDIF ENDIF C C FIND REFERENCE LEVEL TO WHICH NODAL VELOCITIES REFER: C IN CRUST, THIS IS ALWAYS THE SURFACE, C IN MANTLE, IT IS THE STRONGEST LEVEL. C IF (MANTLE) THEN ZBEAM=THICK STRMAX=0.0 DO 110 K=0,10,1 ZP=(THICK*K)/10 ZPABS=ZP+CRUST TP=TEMP(ZP,M,I) ARG=(BCREEP(3)+CCREEP(3)*ZPABS)/TP ARG=MAX(MIN(ARG,88.),-97.) SCP=ACREEP(3)*EN*EXP(ARG) SF=STFRIC*(PE0+DPEDZ*ZP)*FACTOR SCP=MIN(SCP,DCREEP(3),SF) IF (SCP.GE.STRMAX) THEN ZBEAM=ZP STRMAX=SCP ENDIF 110 CONTINUE ELSE ZBEAM=0.0 ENDIF C C INTEGRATE RESISTANCE OF CREEPING LAYER C VAR=0. IF (Z.LT.THICK) THEN T=TEMP(Z,M,I) ZABS=Z IF (MANTLE) ZABS=Z+CRUST ARG=(BCREEP(ILAYER)+CCREEP(ILAYER)*ZABS)/T ARG=MAX(MIN(ARG,88.),-97.) TOPSC=ACREEP(ILAYER)*EN*EXP(ARG) TOPSC=MIN(TOPSC,DCREEP(ILAYER)) OLDSC=TOPSC NSTEP=THICK/ONEKM DO 120 JITER=1,NSTEP ZP=Z+ONEKM ZPABS=ZABS+ONEKM IF (MANTLE) THEN IL=3 ELSE IF (ZPABS.GT.CONINT(M,I)) THEN IL=2 ELSE IL=1 ENDIF ENDIF TP=TEMP(ZP,M,I) ARG=(BCREEP(IL)+CCREEP(IL)*ZPABS)/TP ARG=MAX(MIN(ARG,88.),-97.) SCP=ACREEP(IL)*EN*EXP(ARG) SF=STFRIC*(PE0+DPEDZ*ZP)*FACTOR SCP=MIN(SCP,DCREEP(IL),SF) C NOTE: TERMINATE INTEGRAL IF IT ENCOUNTERS A DETACHED BOUNDARY C LAYER (WITH STRAIN-RATES DIFFERENT FROM STRONG LAYER ABOVE) IF (ZP.GT.ZBEAM.AND.SCP.LT.SIGHBI) GO TO 122 VAR=VAR+ONEKM*0.5*(OLDSC+SCP) IF (ZP.GE.THICK) GO TO 121 Z=ZP ZABS=ZPABS OLDSC=SCP 120 CONTINUE 121 VAR=VAR+(THICK-ZP)*SCP 122 CONTINUE ENDIF VIST=VAR/DEFORM C C MORE PRECISE TREATMENT OF FRICTIONAL RESISTANCE C IF ((CONST+PLAST).GT.0.) THEN CONST=CONST/(STFRIC*FACTOR) RATIO=(1.+STFRIC)/(1.-STFRIC) DTFEXT=CONST*(1.-1./RATIO) DTFCOM=CONST*(1.-RATIO) DT1(1)=DTFEXT+2.*PLAST DT2(1)=DTFEXT+2.*PLAST DT1(2)=0. DT2(2)=DTFEXT+2.*PLAST DT1(3)=DTFCOM-2.*PLAST DT2(3)=0. DT1(4)=DTFCOM-2.*PLAST DT2(4)=DTFCOM-2.*PLAST DO 220 K=1,4 DTF1(K)=DT1(K) DTF2(K)=DT2(K) DO 210 NITER=1,3 ETALPH(K)=DT1(K)/(2.*VISMAX*THICK) ETBETA(K)=DT2(K)/(2.*VISMAX*THICK) ET2(K)=(2.*ETBETA(K)-ETALPH(K))/3. ET1(K)=ETBETA(K)-2.*ET2(K) ETZ= -ET1(K) -ET2(K) SINK=ET1(K)*ET2(K) + ET1(K)*ETZ + ET2(K)*ETZ DEFNK=2.*SQRT(ABS(SINK)) VISP=VIST*(DEFNK/DEFORM)**(ECREEP(ILAYER)-1.) DT1(K)=DTF1(K)+2.*VISP*ETALPH(K) DT2(K)=DTF2(K)+2.*VISP*ETBETA(K) 210 CONTINUE ETALPH(K)=DT1(K)/(2.*VISMAX*THICK) ETBETA(K)=DT2(K)/(2.*VISMAX*THICK) ET2(K)=(2.*ETBETA(K)-ETALPH(K))/3. ET1(K)=ETBETA(K)-2.*ET2(K) 220 CONTINUE FRACZ=(ET1(2)+ET2(2))/((ET1(2)+ET2(2))-(ET1(3)+ET2(3))) SSERR=FRACZ*(DTF1(3)+DTF2(3))+(1.-FRACZ)*(DTF1(2)+DTF2(2)) SLOPE=(DTF1(2)+DTF2(2)-DTF1(3)-DTF2(3)) / + (ET1(2) +ET2(2) -ET1(3) -ET2(3) ) EMOVE=0.5*SSERR/SLOPE ET1(2)=ET1(2)+EMOVE ET2(2)=ET2(2)+EMOVE ET1(3)=ET1(3)+EMOVE ET2(3)=ET2(3)+EMOVE IF(E1.LT.ET1(1)) GO TO 230 IREGON=1 C DOUBLE NORMAL-FAULT CONJUGATE SETS T1=DTF1(1) + +2.*VIST*(2.*E1+E2) T2=DTF2(1) + +2.*VIST*(2.*E2+E1) DT1DE1=DTF1(1)/(2.*E1)+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=DTF2(1)/(2.*E2)+4.*VIST GO TO 290 230 IF(E1.LT.ET1(2)) GO TO 240 FRAC=(ET1(1)-E1)/(ET1(1)-ET1(2)) E2LIM=ET2(1)+(ET2(2)-ET2(1))*FRAC IF(E2.LT.E2LIM) GO TO 235 IREGON=2 C SINGLE NORMAL FAULT SET T1=FRAC*DTF1(2)+(1.-FRAC)*DTF1(1) + +2.*VIST*(2.*E1+E2) T2=FRAC*DTF2(2)+(1.-FRAC)*DTF2(1) + +2.*VIST*(2.*E2+E1) DT1DE1=4.*VISMAX*THICK DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=T2/E2 GO TO 290 235 IREGON=0 C PURELY VISCOUS RANGE T1=2.*VISMAX*(2.*E1+E2)*THICK T2=2.*VISMAX*(2.*E2+E1)*THICK DT1DE1=4.*VISMAX*THICK DT1DE2=2.*VISMAX*THICK DT2DE1=DT1DE2 DT2DE2=DT1DE1 GO TO 290 240 FRAC=((ET1(2)+ET2(2))-(E1+E2))/((ET1(2)+ET2(2))- 1 (ET1(3)+ET2(3))) IF(FRAC.GT.0.) GO TO 250 IREGON=3 C NORMAL + STRIKE-SLIP SETS T1=DTF1(2) + +2.*VIST*(2.*E1+E2) T2=DTF2(2) + +2.*VIST*(2.*E2+E1) IF (E1.LE.-0.5*E2) THEN ESUM=E1+E2 EDIF=E1-E2 TSUM=T1+T2 TDIF=T1-T2 DT1DE1=0.5*(TSUM/ESUM+TDIF/EDIF) DT1DE2=0.5*(TSUM/ESUM-TDIF/EDIF) DT2DE1=DT1DE2 DT2DE2=DT1DE1 ELSE DT1DE1=-0.5*DTF1(1)/E1+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=T2/E2 ENDIF GO TO 290 250 IF(FRAC.GT.1.) GO TO 260 E2LIM=ET2(2)+(ET2(3)-ET2(2))*FRAC IF(E2.LT.E2LIM) GO TO 235 IREGON=4 C CONJUGATE STRIKE-SLIP SET TF1=FRAC*DTF1(3)+(1.-FRAC)*DTF1(2) T1=TF1+2.*VIST*(2.*E1+E2) TF2=FRAC*DTF2(3)+(1.-FRAC)*DTF2(2) T2=TF2+2.*VIST*(2.*E2+E1) Q=((DTF1(2)-DTF2(2))-(DTF1(3)-DTF2(3))) / + ((ET1 (2)+ET2 (2))-(ET1 (3)+ET2 (3))) DT1DE1=3.*VISMAX*THICK+0.5*(T1-T2)/(E1-E2)+0.5*Q DT1DE2=3.*VISMAX*THICK-0.5*(T1-T2)/(E1-E2)+0.5*Q DT2DE1=DT1DE2-Q DT2DE2=DT1DE1-Q GO TO 290 260 IF(E2.LT.ET2(3)) GO TO 270 IREGON=5 C STRIKE-SLIP + THRUST SETS T1=DTF1(3) + +2.*VIST*(2.*E1+E2) T2=DTF2(3) + +2.*VIST*(2.*E2+E1) IF (E2.GE.-0.5*E1) THEN ESUM=E1+E2 EDIF=E1-E2 TSUM=T1+T2 TDIF=T1-T2 DT1DE1=0.5*(TSUM/ESUM+TDIF/EDIF) DT1DE2=0.5*(TSUM/ESUM-TDIF/EDIF) DT2DE1=DT1DE2 DT2DE2=DT1DE1 ELSE DT1DE1=T1/E1 DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=-0.5*DTF2(4)/E2+4.*VIST ENDIF GO TO 290 270 IF(E2.LT.ET2(4)) GO TO 275 FRAC=(ET2(3)-E2)/(ET2(3)-ET2(4)) E1LIM=ET1(3)+(ET1(4)-ET1(3))*FRAC IF(E1.GT.E1LIM) GO TO 235 IREGON=6 C ONE CONJUGATE THRUST SET T1=FRAC*DTF1(4)+(1.-FRAC)*DTF1(3) + +2.*VIST*(2.*E1+E2) T2=FRAC*DTF2(4)+(1.-FRAC)*DTF2(3) + +2.*VIST*(2.*E2+E1) DT1DE1=T1/E1 DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=4.*VISMAX*THICK GO TO 290 275 IREGON=7 C DOUBLE THRUST SETS T1=DTF1(4) + +2.*VIST*(2.*E1+E2) T2=DTF2(4) + +2.*VIST*(2.*E2+E1) DT1DE1=DTF1(4)/(2.*E1)+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=DTF2(4)/(2.*E2)+4.*VIST 290 CONTINUE ELSE VISLIM=VISMAX*THICK VIS=MIN(VIST,VISLIM) IREGON=8 IF (VIS.LT.VIST) IREGON=0 T1=2.*VIS*(2.*E1+E2) T2=2.*VIS*(2.*E2+E1) DT1DE1=4.*VIS DT1DE2=2.*VIS DT2DE1=DT1DE2 DT2DE2=DT1DE1 ENDIF RADT=0.5*(T2-T1) IF((E1-E2).NE.0.) THEN C=(T2-T1)/(E2-E1) ELSE C=0. ENDIF TXX=.5*(C*(EXX-EYY)+T1+T2) TYY=T1+T2-TXX TXY=C*EXY QFRIC(1,M,I)=T1*E1+T2*E2 RETURN END C C C SUBROUTINE BUILDK (STIFF,NKDIM,NBAND,NUMEL,NODES,ALPHA, + DXS,DYS,DETJ,AREA,NTNM, + MANTLE,SIGHB,SIGHT,DVB,DVT,ETAMAX) C C COMPUTES STIFFNESS MATRIX STIFF (OR K) FROM ALPHA C AND DERIVITIVES OF NODAL FUNCTIONS OF THE ELEMENT GRID, C THEN ADDS DIAGONAL STIFFENING ASSOCIATED WITH SHEAR COUPLING. C DOUBLE PRECISION PHI,STIFF,SUM,TWICE,WEIGHT LOGICAL MANTLE DIMENSION ALPHA(3,3,7,NUMEL),AREA(NUMEL),DETJ(7,NUMEL), + DVB(7,NUMEL),DVT(7,NUMEL), + DXS(6,7,NUMEL),DYS(6,7,NUMEL), + ETA(7),NODES(6,0:NUMEL),PHI(6,7), + SIGHB(2,7,NUMEL),SIGHT(2,7,NUMEL), + STIFF(NKDIM),WEIGHT(7) COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT C C ****************** IMPORTANT ************************************ C ALL INDEXK DEFINITION STATEMENTS IN PACKAGE MUST AGREE ! INDEXK(IR,JC,NBAND)=2*NBAND+1+IR-JC+(JC-1)*(3*NBAND+16) C****************************************************************** C DO 10 K=1,NKDIM STIFF(K)=0. 10 CONTINUE C DO 100 I=1,NUMEL DO 90 I6=1,6 DO 80 J6=1,6 C UPPER LEFT ELEMENTS: X-COEFFICIENTS IN X-BALANCE IR=2*NODES(I6,I)-1 JC=2*NODES(J6,I)-1 SUM=0. 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 K=INDEXK(IR,JC,NBAND) STIFF(K)=STIFF(K)+SUM*AREA(I) C LOWER RIGHT ELEMENTS: Y-COEFFICIENTS IN Y-BALANCE IR=2*NODES(I6,I) JC=2*NODES(J6,I) SUM=0. 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 K=INDEXK(IR,JC,NBAND) STIFF(K)=STIFF(K)+SUM*AREA(I) C UPPER RIGHT ELEMENTS: Y-COEFFICIENTS IN X-BALANCE IR=2*NODES(I6,I)-1 JC=2*NODES(J6,I) SUM=0. 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 K=INDEXK(IR,JC,NBAND) STIFF(K)=STIFF(K)+SUM*AREA(I) C LOWER LEFT ELEMENTS: X-COEFFICIENTS IN Y-BALANCE IR=2*NODES(I6,I) JC=2*NODES(J6,I)-1 SUM=0. 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 K=INDEXK(IR,JC,NBAND) STIFF(K)=STIFF(K)+SUM*AREA(I) 80 CONTINUE 90 CONTINUE 100 CONTINUE DO 2000 N=1,NUMEL DO 820 M=1,7 SIGB=SQRT((1.D0*SIGHB(1,M,N))**2+ + (1.D0*SIGHB(2,M,N))**2) TWICE=(1.D0*SIGB)/MAX(DVB(M,N),5.E-43) ETA(M)=MIN(TWICE,(1.D0*ETAMAX)) 820 CONTINUE ETAHI=MAX(ETA(1),ETA(2),ETA(3),ETA(4),ETA(5), + ETA(6),ETA(7)) ETALOW=ETAHI*0.01 DO 1000 M=1,7 ETA(M)=MAX(ETA(M),ETALOW) ETADA=ETA(M)*WEIGHT(M)*AREA(N)*DETJ(M,N) DO 900 IDUM=1,6 I=NODES(IDUM,N) IRU=2*I-1 IRV=IRU+1 DO 850 JDUM=1,6 SPRING=ETADA*PHI(IDUM,M)*PHI(JDUM,M) J=NODES(JDUM,N) JCU=2*J-1 JCV=JCU+1 K=INDEXK(IRU,JCU,NBAND) STIFF(K)=STIFF(K)+SPRING K=INDEXK(IRV,JCV,NBAND) STIFF(K)=STIFF(K)+SPRING 850 CONTINUE 900 CONTINUE 1000 CONTINUE 2000 CONTINUE IF (.NOT.MANTLE) RETURN DO 4000 N=1,NUMEL DO 2820 M=1,7 SIGT=SQRT((1.D0*SIGHT(1,M,N))**2+ + (1.D0*SIGHT(2,M,N))**2) TWICE=(1.D0*SIGT)/MAX(DVT(M,N),5.E-43) ETA(M)=MIN(TWICE,(1.D0*ETAMAX)) 2820 CONTINUE ETAHI=MAX(ETA(1),ETA(2),ETA(3),ETA(4),ETA(5), + ETA(6),ETA(7)) ETALOW=ETAHI*0.01 DO 3000 M=1,7 ETA(M)=MAX(ETA(M),ETALOW) ETADA=ETA(M)*WEIGHT(M)*AREA(N)*DETJ(M,N) DO 2900 IDUM=1,6 I=NODES(IDUM,N) IRU=2*I-1 IRV=IRU+1 DO 2850 JDUM=1,6 SPRING=ETADA*PHI(IDUM,M)*PHI(JDUM,M) J=NODES(JDUM,N) JCU=2*J-1 JCV=JCU+1 K=INDEXK(IRU,JCU,NBAND) STIFF(K)=STIFF(K)+SPRING K=INDEXK(IRV,JCV,NBAND) STIFF(K)=STIFF(K)+SPRING 2850 CONTINUE 2900 CONTINUE 3000 CONTINUE 4000 CONTINUE RETURN END C C C SUBROUTINE BUILDF (FORCE,NTNM,NUMEL,TAUZZ,AREA,DETJ, + MANTLE,SIGHB,SIGHT,DVB,DVT,OVB,OVA,DXS,DYS,NODES, + ETAMAX,TOFSET,PTS,NELCOL,NUMNOD,XNOD,YNOD) C C COMPUTE FORCING VECTOR: INCLUDES GRAVITATIONAL SPREADING, C 'PRE-STRESS' OR INTERCEPT-STRESS OF LINEARIZED FLOW-LAWS, C SURFACE SHEAR STRESS FORCES, AND PRODUCTS OF PRESSURE ANOMALIES C WITH SLOPE OF LAYER INTERFACES. C C ON VERTICAL BOUNDARIES (WHICH ARE ALWAYS ARTIFICIAL) A C LITHOSTATIC PRESSURE BOUNDARY CONDITION IS ADDED, WITH THE C PRESSURE COMPUTED FROM THE DENSITY STRUCTURE JUST INSIDE C THE BOUNDARY. C NOTE THAT IF VELOCITY BOUNDARY CONDITIONS C ARE APPLIED, THEY WILL OVERRIDE THESE PRESSURES. C HOWEVER, THE PRESSURES ARE ADDED ON ALL SIDES IN CASE THEY C MIGHT BE FREE OF VELOCITY B.C'S IN SOME FUTURE MODEL. C DOUBLE PRECISION DA,ELF,FORCE,PHI,TWICE,WEIGHT LOGICAL LEFTY,LOWER,RIGHTY,UPPER,MANTLE DIMENSION AREA(NUMEL),DETJ(7,NUMEL),DVB(7,NUMEL),DVT(7,NUMEL), + DXS(6,7,NUMEL),DYS(6,7,NUMEL), + FORCE(NTNM), + NODES(6,0:NUMEL),OVA(2,7,NUMEL),OVB(2,7,NUMEL), + PHI(6,7),PTS(2,7,NUMEL), + SIGHB(2,7,NUMEL),SIGHT(2,7,NUMEL), + TAUZZ(7,NUMEL),TOFSET(3,7,NUMEL), + WEIGHT(7),XNOD(NUMNOD),YNOD(NUMNOD) DIMENSION ELF(12),ETAB(7),ETAT(7) COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT DO 10 I=1,NTNM FORCE(I)=0. 10 CONTINUE NELWID=2*NELCOL DO 900 I=1,NUMEL DO 40 J=1,12 ELF(J)=0. 40 CONTINUE DO 50 M=1,7 SIG=SQRT((1.D0*SIGHB(1,M,I))**2+ + (1.D0*SIGHB(2,M,I))**2) TWICE=(1.D0*SIG)/MAX(DVB(M,I),5.E-43) ETAB(M)=MIN(TWICE,(1.D0*ETAMAX)) SIG=SQRT((1.D0*SIGHT(1,M,I))**2+ + (1.D0*SIGHT(2,M,I))**2) TWICE=(1.D0*SIG)/MAX(DVT(M,I),5.E-43) ETAT(M)=MIN(TWICE,(1.D0*ETAMAX)) 50 CONTINUE ETAHIB=MAX(ETAB(1),ETAB(2),ETAB(3),ETAB(4),ETAB(5), + ETAB(6),ETAB(7)) ETALOB=ETAHIB*0.01 ETAHIT=MAX(ETAT(1),ETAT(2),ETAT(3),ETAT(4),ETAT(5), + ETAT(6),ETAT(7)) ETALOT=ETAHIT*0.01 DO 100 M=1,7 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) IF (MANTLE) THEN ETAT(M)=MAX(ETAT(M),ETALOT) SHX=SHX+OVA(1,M,I)*ETAT(M) SHY=SHY+OVA(2,M,I)*ETAT(M) ENDIF DO 90 J=1,6 JU=2*J-1 JV=2*J ELF(JU)=ELF(JU)+DA*( + (SHX+PTS(1,M,I))*PHI(J,M) + +(-TAUZZ(M,I)-TOFSET(1,M,I))*DXS(J,M,I) + +(-TOFSET(3,M,I))*DYS(J,M,I)) ELF(JV)=ELF(JV)+DA*( + (SHY+PTS(2,M,I))*PHI(J,M) + +(-TOFSET(3,M,I))*DXS(J,M,I) + +(-TAUZZ(M,I)-TOFSET(2,M,I))*DYS(J,M,I)) 90 CONTINUE 100 CONTINUE LEFTY=MOD(I,NELWID).EQ.1 RIGHTY=MOD(I,NELWID).EQ.0 UPPER=(I.LE.NELWID).AND.(MOD(I,2).EQ.1) LOWER=((NUMEL-I).LT.NELWID).AND.(MOD(I,2).EQ.0) IF (LEFTY.OR.RIGHTY) THEN NODE1=NODES(1,I) NODE2=NODES(2,I) TAUZZ1=TAUZZ(5,I) TAUZZ2=TAUZZ(6,I) TAUZZ4=TAUZZ(4,I) DX=XNOD(NODE2)-XNOD(NODE1) DY=YNOD(NODE2)-YNOD(NODE1) ELF(1)=ELF(1)+DY* + (-0.0333333*TAUZZ2+0.0666666*TAUZZ4+0.1333333*TAUZZ1) ELF(2)=ELF(2)-DX* + (-0.0333333*TAUZZ2+0.0666666*TAUZZ4+0.1333333*TAUZZ1) ELF(3)=ELF(3)+DY* + (0.1333333*TAUZZ2+0.0666666*TAUZZ4-0.0333333*TAUZZ1) ELF(4)=ELF(4)-DX* + (0.1333333*TAUZZ2+0.0666666*TAUZZ4-0.0333333*TAUZZ1) ELF(7)=ELF(7)+DY* + (0.0666666*TAUZZ2+0.5333333*TAUZZ4+0.0666666*TAUZZ1) ELF(8)=ELF(8)-DX* + (0.0666666*TAUZZ2+0.5333333*TAUZZ4+0.0666666*TAUZZ1) ENDIF IF (UPPER.OR.LOWER) THEN NODE1=NODES(1,I) NODE3=NODES(3,I) TAUZZ1=TAUZZ(5,I) TAUZZ3=TAUZZ(7,I) TAUZZ6=TAUZZ(3,I) DX=XNOD(NODE1)-XNOD(NODE3) DY=YNOD(NODE1)-YNOD(NODE3) ELF(1)=ELF(1)+DY* + (-0.0333333*TAUZZ3+0.0666666*TAUZZ6+0.1333333*TAUZZ1) ELF(2)=ELF(2)-DX* + (-0.0333333*TAUZZ3+0.0666666*TAUZZ6+0.1333333*TAUZZ1) ELF(5)=ELF(5)+DY* + (0.1333333*TAUZZ3+0.0666666*TAUZZ6-0.0333333*TAUZZ1) ELF(6)=ELF(6)-DX* + (0.1333333*TAUZZ3+0.0666666*TAUZZ6-0.0333333*TAUZZ1) ELF(11)=ELF(11)+DY* + (0.0666666*TAUZZ1+0.5333333*TAUZZ6+0.0666666*TAUZZ3) ELF(12)=ELF(12)-DX* + (0.0666666*TAUZZ1+0.5333333*TAUZZ6+0.0666666*TAUZZ3) ENDIF DO 800 J=1,6 JU=2*NODES(J,I)-1 JV=JU+1 FORCE(JU)=FORCE(JU)+ELF(2*J-1) FORCE(JV)=FORCE(JV)+ELF(2*J) 800 CONTINUE 900 CONTINUE RETURN END C C C SUBROUTINE BCS (NELCOL,FORCE,NTNM,NBAND, + STIFF,NKDIM,NUMNOD) C C ADDS VELOCITY BOUNDARY CONDITIONS C BY OPERATIONS ON MATRIX STIFF C AND VECTOR FORCE C LOGICAL FIXVX,FIXVY DOUBLE PRECISION FORCE,STIFF DIMENSION FORCE(NTNM),STIFF(NKDIM) C C ****************** IMPORTANT ************************************ C ALL INDEXK DEFINITION STATEMENTS IN PACKAGE MUST AGREE ! INDEXK(IR,JC,NBAND)=2*NBAND+1+IR-JC+(JC-1)*(3*NBAND+16) C****************************************************************** C C SEARCH FOR LARGEST DIAGONAL OF STIFFNESS MATRIX TO USE AS WEIGHT. C BIGD=0. DO 5 I=1,NTNM K=INDEXK(I,I,NBAND) DIAG=STIFF(K) BIGD=MAX(BIGD,DIAG) 5 CONTINUE C C SET BOUNDARY CONDITIONS ALONG "TOP" SIDE OF GRID. C NACROS=NELCOL*2+1 FIXVX=.TRUE. FIXVY=.TRUE. VX=0.0 VY=0.0 DO 10 J=1,NACROS CALL FIXNOD (J,FORCE,NTNM,NBAND,STIFF,NKDIM,BIGD, + FIXVX,FIXVY,VX,VY) 10 CONTINUE C C SET BOUNDARY CONDITIONS ALONG "BOTTOM" SIDE OF GRID. C JL=NUMNOD JF=NUMNOD-NACROS+1 FIXVX=.TRUE. FIXVY=.TRUE. VX=0.0 VY=0.0 DO 20 J=JF,JL CALL FIXNOD (J,FORCE,NTNM,NBAND,STIFF,NKDIM,BIGD, + FIXVX,FIXVY,VX,VY) 20 CONTINUE C C SET BOUNDARY CONDITIONS ALONG "RIGHT" SIDE OF GRID C (THE SIDE OPPOSITE TO THE TRENCH, IF ANY) C IL=NUMNOD/NACROS FIXVX=.TRUE. FIXVY=.TRUE. VX=0.0 VY=0.0 DO 30 I=1,IL J=NACROS*I CALL FIXNOD (J,FORCE,NTNM,NBAND,STIFF,NKDIM,BIGD, + FIXVX,FIXVY,VX,VY) 30 CONTINUE RETURN END C C C SUBROUTINE FIXNOD (I,FORCE,NTNM,NBAND,STIFF,NKDIM,BIGD, + FIXVX,FIXVY,VX,VY) C C SET ONE OR BOTH COMPONENTS OF VELOCITY AT NODE NUMBER I C LOGICAL FIXVX,FIXVY DOUBLE PRECISION FORCE,STIFF DIMENSION FORCE(NTNM),STIFF(NKDIM) C C ****************** IMPORTANT ************************************ C ALL INDEXK DEFINITION STATEMENTS IN PACKAGE MUST AGREE ! INDEXK(IR,JC,NBAND)=2*NBAND+1+IR-JC+(JC-1)*(3*NBAND+16) C****************************************************************** C IU=2*I-1 IV=IU+1 IF (FIXVX) THEN FORCE(IU)=BIGD*VX JF=MAX(1,IU-NBAND) JL=MIN(NTNM,IU+NBAND) DO 10 J=JF,JL K=INDEXK(IU,J,NBAND) STIFF(K)=0. 10 CONTINUE KU=INDEXK(IU,IU,NBAND) STIFF(KU)=BIGD ENDIF IF (FIXVY) THEN FORCE(IV)=BIGD*VY JF=MAX(1,IV-NBAND) JL=MIN(NTNM,IV+NBAND) DO 20 J=JF,JL K=INDEXK(IV,J,NBAND) STIFF(K)=0. 20 CONTINUE KV=INDEXK(IV,IV,NBAND) STIFF(KV)=BIGD ENDIF RETURN END C C C SUBROUTINE SLIPBC (INPUT,DELTAT,ETAMAX,MANTLE, + NBAND,NKDIM,NELCOL, + NTNM,NUMEL,NUMNOD, + SIGBOT,THNK,TOUCH, + V,VSLAB,XNOD,YNOD, + MODIFY,FORCE,STIFF) C C CHANGES STIFFNESS MATRIX AND FORCE VECTOR TO ADD A C STRIKE-SLIP BOUNDARY CONDITION TO CERTAIN NODES ON C THE WEST (LOW-X) SIDE OF THE GRID, WHERE THEY C WOULD OTHERWISE BE FREE. C PARAMETER (NSPACE=100) DOUBLE PRECISION FORCE,PIVOT,STIFF,TWICE LOGICAL MANTLE,ODD,PACIFI DIMENSION FORCE(NTNM), + STIFF(NKDIM), + THNK(NUMNOD), + TOUCH(7,NUMEL), + V(2,NUMNOD), + VSLAB(2,7,NUMEL), + XNOD(NUMNOD), + YNOD(NUMNOD) DIMENSION DSTIF1(2,NSPACE),DSTIF2(2,NSPACE), + FLIST1(NSPACE),FLIST2(NSPACE) C C ****************** IMPORTANT ************************************ C ALL INDEXK DEFINITION STATEMENTS IN PACKAGE MUST AGREE ! INDEXK(IR,JC,NBAND)=2*NBAND+1+IR-JC+(JC-1)*(3*NBAND+16) C****************************************************************** C IF (MANTLE) RETURN NCOLN=2*NELCOL+1 NROWN=NUMNOD/NCOLN IF (NROWN.GT.NSPACE) THEN WRITE(6,1)NSPACE,NROWN 1 FORMAT(/ /' INCREASE PARAMETER NSPACE FROM ',I5, + ' TO ',I5, ' IN SUBPROGRAM SLIPBC.') STOP ENDIF DO 5 I=1,NROWN DSTIF1(1,I)=0.0 DSTIF2(1,I)=0.0 DSTIF1(2,I)=0.0 DSTIF2(2,I)=0.0 FLIST1(I)=0.0 FLIST2(I)=0.0 5 CONTINUE NELROW=NUMEL/(2*NELCOL) NLL=NUMNOD-NCOLN+1 PIVOT=0.0 DO 10 I=1,NTNM K=INDEXK(I,I,NBAND) PIVOT=MAX(PIVOT,STIFF(K)) 10 CONTINUE DO 1000 IROW=2,NROWN-1 INODE=NCOLN*(IROW-1)+1 ODD=MOD(IROW,2).EQ.1 IF (ODD) THEN IEA=2*NELCOL*((IROW-1)/2-1)+1 IEB=IEA+2*NELCOL MA=6 MB=5 PACIFI=(TOUCH(MA,IEA).EQ.0.0).AND. + (TOUCH(MB,IEB).EQ.0.0) VPACX=0.5*(VSLAB(1,MA,IEA)+VSLAB(1,MB,IEB)) VPACY=0.5*(VSLAB(2,MA,IEA)+VSLAB(2,MB,IEB)) ELSE IE=2*NELCOL*((IROW/2)-1)+1 M=4 PACIFI=TOUCH(M,IE).EQ.0.0 VPACX=VSLAB(1,M,IE) VPACY=VSLAB(2,M,IE) ENDIF IF (PACIFI) THEN DY=VPACY*DELTAT XT=XNOD(INODE) YT=YNOD(INODE)-DY YT=MAX(MIN(YT,YNOD(1)),YNOD(NLL)) DO 100 N=1,NELROW NLLT=NCOLN*N*2+1 NULT=NLLT-2*NCOLN IF(YT.LE.YNOD(NULT).AND.YT.GE.YNOD(NLLT)) THEN J1=NULT J3=NLLT J2=J1+NCOLN X1=XNOD(J1) X2=XNOD(J2) X3=XNOD(J3) Y1=YNOD(J1) Y2=YNOD(J2) Y3=YNOD(J3) FRAC=(Y1-YT)/(Y1-Y3) XLEFT=X1+ + FRAC*(X3-X1)+ + (FRAC-FRAC**2)*4.*(X2-(X1+X3)/2.) DX=XLEFT-XT C DXDYAV=(X1-X3)/(Y1-Y3) C QUAD=(X2-0.5*(X1+X3))/(Y1-Y3) C DXDY=DXDYAV+QUAD*(-4.+8.*FRAC) C AZIM=ATAN(DXDY) GO TO 101 ENDIF 100 CONTINUE 101 CONTINUE ANGLEC=ATAN(DX/DY)+1.5709 ANGLEV=ATAN2F(VPACY,VPACX) THETA=ANGLEV-ANGLEC VPAC=SQRT(VPACX**2+VPACY**2) VPULL=VPAC*SIN(THETA) COSA=COS(ANGLEC) SINA=SIN(ANGLEC) IFLOAD=2*INODE-1 IFBC =2*INODE FORCE(IFLOAD)=FORCE(IFLOAD)*COSA+ + FORCE(IFBC )*SINA JF=MAX(1 ,IFLOAD-NBAND+1) JL=MIN(NTNM,IFLOAD+NBAND ) DO 20 J=JF,JL KA=INDEXK(IFLOAD,J,NBAND) KB=INDEXK(IFBC ,J,NBAND) STIFF(KA)=STIFF(KA)*COSA+STIFF(KB)*SINA 20 CONTINUE JF=MAX(1 ,IFBC-NBAND) JL=MIN(NTNM,IFBC+NBAND) DO 30 J=JF,JL K=INDEXK(IFBC,J,NBAND) STIFF(K)=0.0 30 CONTINUE KX=INDEXK(IFBC,IFLOAD,NBAND) KY=INDEXK(IFBC,IFBC ,NBAND) STIFF(KX)=PIVOT*(-SINA) STIFF(KY)=PIVOT*COSA FORCE(IFBC)=PIVOT*VPULL SLOAD=SIGBOT*SIGN(1.,COS(THETA)) VNAX=V(1,INODE) VNAY=V(2,INODE) VNAC=VNAX*COSA+VNAY*SINA VPACC=VPACX*COSA+VPACY*SINA TWICE=ABS((1.D0*SLOAD)/MAX(ABS(VPACC-VNAC),5.E-43)) ETA=MIN(TWICE,(1.D0*ETAMAX)) THICK=THNK(INODE) FLIST1(IROW)=THICK*ETA*VPACC DSTIF1(1,IROW)=THICK*ETA*COSA DSTIF1(2,IROW)=THICK*ETA*SINA ELSE FLIST1(IROW)=0.0 DSTIF1(1,IROW)=0.0 DSTIF1(2,IROW)=0.0 ENDIF 1000 CONTINUE DO 2000 I=1,NELROW J2=NCOLN*(2*I-1)+1 J3=J2+NCOLN J1=J2-NCOLN SIDE=0.5*SQRT((XNOD(J1)-XNOD(J3))**2+ + (YNOD(J1)-YNOD(J3))**2) K2=2*I K3=K2+1 K1=K2-1 FLIST2(K1)=FLIST2(K1)+SIDE* + (0.1333*FLIST1(K1)+0.0666*FLIST1(K2)-0.0333*FLIST1(K3)) FLIST2(K2)=FLIST2(K2)+SIDE* + (0.0666*FLIST1(K1)+0.5333*FLIST1(K2)+0.0666*FLIST1(K3)) FLIST2(K3)=FLIST2(K3)+SIDE* + (-.0333*FLIST1(K1)+0.0666*FLIST1(K2)+0.1333*FLIST1(K3)) DSTIF2(1,K1)=DSTIF2(1,K1)+SIDE* + (0.1333*DSTIF1(1,K1)+0.0666*DSTIF1(1,K2)-0.0333*DSTIF1(1,K3)) DSTIF2(1,K2)=DSTIF2(1,K2)+SIDE* + (0.0666*DSTIF1(1,K1)+0.5333*DSTIF1(1,K2)+0.0666*DSTIF1(1,K3)) DSTIF2(1,K3)=DSTIF2(1,K3)+SIDE* + (-.0333*DSTIF1(1,K1)+0.0666*DSTIF1(1,K2)+0.1333*DSTIF1(1,K3)) DSTIF2(2,K1)=DSTIF2(2,K1)+SIDE* + (0.1333*DSTIF1(2,K1)+0.0666*DSTIF1(2,K2)-0.0333*DSTIF1(2,K3)) DSTIF2(2,K2)=DSTIF2(2,K2)+SIDE* + (0.0666*DSTIF1(2,K1)+0.5333*DSTIF1(2,K2)+0.0666*DSTIF1(2,K3)) DSTIF2(2,K3)=DSTIF2(2,K3)+SIDE* + (-.0333*DSTIF1(2,K1)+0.0666*DSTIF1(2,K2)+0.1333*DSTIF1(2,K3)) 2000 CONTINUE DO 3000 IROW=2,NROWN-1 IF (FLIST1(IROW).NE.0.) THEN INODE=NCOLN*(IROW-1)+1 IFLOAD=2*INODE-1 IFBC =2*INODE FORCE(IFLOAD)=FORCE(IFLOAD)+FLIST2(IROW) KX=INDEXK(IFLOAD,IFLOAD,NBAND) KY=INDEXK(IFLOAD,IFBC ,NBAND) STIFF(KX)=STIFF(KX)+DSTIF2(1,IROW) STIFF(KY)=STIFF(KY)+DSTIF2(2,IROW) ENDIF 3000 CONTINUE RETURN END C C C SUBROUTINE SOLVER (ABD,NKDIM,BX,NTNM,NBAND,IPVT,NXL,FAILUR) C C SETS UP FOR CALL TO THE LIBRARY ROUTINE WHICH ACTUALLY C SOLVES THE LINEAR EQUATION SYSTEM C C CURRENT VERSION IS PER CONVENTIONS OF IBM'S ESSL LIBRARY, C DOUBLE PRECISION VERSION. C DOUBLE PRECISION ABD,BX,SIZE LOGICAL FAILUR DIMENSION ABD(NKDIM),BX(NTNM),IPVT(NXL) C C ****************** IMPORTANT ************************************ C ALL INDEXK DEFINITION STATEMENTS IN PACKAGE MUST AGREE ! INDEXK(IR,JC,NBAND)=2*NBAND+1+IR-JC+(JC-1)*(3*NBAND+16) C****************************************************************** C N=NTNM ML=NBAND MU=NBAND LDA=2*ML+MU+16 CALL DGBF(ABD,LDA,N,ML,MU,IPVT) CALL DGBS(ABD,LDA,N,ML,MU,IPVT,BX) C C PREVENT LATER UNDERFLOWS (DUE TO SLOPPY ENFORCEMENT OF 0 VALUES), C BY TRUNCATING TO ZERO NUMBERS THAT HAVE NO SINGLE-PRECISION C EQUIVALENT. C DO 10 I=1,N SIZE=ABS(BX(I)) IF (SIZE.LE.5.D-43) BX(I)=0.0D0 10 CONTINUE RETURN END C C C SUBROUTINE EDOT (NUMEL,NODES,V,NUMNOD,DXS,DYS,ERATE, + ALPHA,TOFSET,TAUMAT) C C COMPUTE STRAIN-RATE COMPONENTS EDOTXX, EDOTYY, AND C EDOTXY (TENSOR FORM) AND THE "FOURTH COMPONENT" C (ROTATION RATE OF STIFF INCLUSIONS) AT INTEGRATION POINTS C C ALSO COMPUTES VERTICAL INTEGRALS OF DEFORMATIONAL DEVIATORIC C STRESS: TAUMAT C DIMENSION ALPHA(3,3,7,NUMEL),DXS(6,7,NUMEL),DYS(6,7,NUMEL), + ERATE(4,7,NUMEL),NODES(6,0:NUMEL), + TAUMAT(3,7,NUMEL),TOFSET(3,7,NUMEL),V(2,NUMNOD) DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=0. EYY=0. EXY=0. ROT=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 ROT=ROT+(VY*DX-VX*DY)*0.5 800 CONTINUE ERATE(1,M,I)=EXX ERATE(2,M,I)=EYY ERATE(3,M,I)=EXY ERATE(4,M,I)=ROT 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 UNFOLD (INPUT,DELTAT,DXS,DYS,MAXTEP,NCOLN,NODES, + NROWN,NUMEL,NUMNOD,XNOD,YNOD, + MODIFY,V, + WORK,C,CONDNS,E,N,NRD,NRDP1,PHINOD, + PKFD,PRCFD,P0,P1,S,W,XFD,YFD) C C MODIFIES VECTOR VELOCITY FIELD "V" BY LATERAL DIFFUSION UNTIL C IT IS SMOOTH ENOUGH SO THAT NO INTEGRATION POINT OF THE C GRID WILL BE SHRUNK BY MORE THAN 50% IN THE TIME STEP "DELTAT". C REAL N DIMENSION C(NRD,NRD), + CONDNS(NUMNOD), + DXS(6,7,NUMEL), + DYS(6,7,NUMEL), + E(NRD,NRD), + N(NRD,NRD), + NODES(6,0:NUMEL), + PHINOD(NUMNOD), + PKFD(2,NRD,NRD), + PRCFD(NRD,NRD), + P0(0:NRDP1,0:NRDP1), + P1(0:NRDP1,0:NRDP1), + S(NRD,NRD), + V(2,NUMNOD), + W(NRD,NRD), + XFD(NRD,NRD), + XNOD(NUMNOD), + YFD(NRD,NRD), + YNOD(NUMNOD) C DX=MIN(((XNOD(NCOLN)-XNOD(1))/(NCOLN-1)), + ((YNOD(NCOLN)-YNOD(NUMNOD))/(NROWN-1))) TIME=DX**2 NDONE=0 C C FIND WORST-CASE OF NEGATIVE DILATATION RATE C 10 WORST=0.0 DO 30 M=1,7 DO 20 I=1,NUMEL NODE1=NODES(1,I) NODE2=NODES(2,I) NODE3=NODES(3,I) NODE4=NODES(4,I) NODE5=NODES(5,I) NODE6=NODES(6,I) EXX=V(1,NODE1)*DXS(1,M,I)+ + V(1,NODE2)*DXS(2,M,I)+ + V(1,NODE3)*DXS(3,M,I)+ + V(1,NODE4)*DXS(4,M,I)+ + V(1,NODE5)*DXS(5,M,I)+ + V(1,NODE6)*DXS(6,M,I) EYY=V(2,NODE1)*DYS(1,M,I)+ + V(2,NODE2)*DYS(2,M,I)+ + V(2,NODE3)*DYS(3,M,I)+ + V(2,NODE4)*DYS(4,M,I)+ + V(2,NODE5)*DYS(5,M,I)+ + V(2,NODE6)*DYS(6,M,I) DILAT=EXX+EYY WORST=MIN(WORST,DILAT) 20 CONTINUE 30 CONTINUE C C DECIDE WHETHER DILATATION RATES ARE ACCEPTABLE (IF SO, RETURN): C IF ((WORST*DELTAT).GT.-0.5) THEN IF (NDONE.GT.0) THEN WIDE=DX*SQRT(1.0*NDONE) WRITE(6,32) WIDE 32 FORMAT(' SUBPROGRAM UNFOLD SMOOTHED VELOCITIES OVER', + ' SMOOTHING DISTANCE ',1P,E10.2) ENDIF RETURN ENDIF C C SMOOTH BOTH COMPONENTS OF VELOCITY, ONE AT A TIME C DO 100 K=1,2 DO 40 I=1,NUMNOD PHINOD(I)=V(K,I) 40 CONTINUE CALL SMOOTH (INPUT, MAXTEP,NCOLN, + NROWN,NUMEL,NUMNOD, + TIME,XNOD,YNOD, + MODIFY,PHINOD, + WORK, C,CONDNS,E, + N,NRD,NRDP1,PKFD, + PRCFD,P0,P1,S,W,XFD,YFD) DO 50 I=1,NROWN PHINOD(NCOLN*I)=0.0 50 CONTINUE DO 60 I=1,NCOLN PHINOD(I)=0.0 PHINOD(NUMNOD-I+1)=0.0 60 CONTINUE DO 70 I=1,NUMNOD V(K,I)=PHINOD(I) 70 CONTINUE 100 CONTINUE NDONE=NDONE+1 IF (NDONE.LT.25) GO TO 10 RETURN END C C SUBROUTINE SMOOTH (INPUT, MAXTEP,NCOLN, + NROWN,NUMEL,NUMNOD, + TIME,XNOD,YNOD, + MODIFY,THNK, + WORK, C,CONDNS,E, + N,NRD,NRDP1,PKFD, + PRCFD,P0,P1,S,W,XFD,YFD) C C THIS ROUTINE MAY BE USED FOR SMOOTHING ANY SCALAR FIELD C ("THNK") DEFINED ON THE NODES. C REAL N DOUBLE PRECISION DROP,FLIST,FNEWS,MINSTP,PKLIM,PKLIST,PKNEWS, + TEST,TMPBOT,TMPLIM,WORST LOGICAL FAILUR,LOCKIN,LOCKWC DIMENSION C(NRD,NRD), 2 CONDNS(NUMNOD), 4 E(NRD,NRD), 6 N(NRD,NRD), 7 PKFD(2,NRD,NRD), 8 PRCFD(NRD,NRD), 9 P0(0:NRDP1,0:NRDP1),P1(0:NRDP1,0:NRDP1), A S(NRD,NRD), 1 THNK(NUMNOD), 2 W(NRD,NRD), 3 XFD(NRD,NRD),XNOD(NUMNOD), 4 YFD(NRD,NRD),YNOD(NUMNOD) DIMENSION FLIST(4),FNEWS(4),PKLIST(4),PKNEWS(4) DATA ACCURA/0.02/,BIGNUM/3.E38/ C MAXTEP=MAX(MAXTEP,2) NPREF=0.25/ACCURA DO 20 IROW=1,NROWN DO 10 JCOL=1,NCOLN PKFD(1,IROW,JCOL)=1.00 PKFD(2,IROW,JCOL)=1.00 PRCFD(IROW,JCOL)=1.00 K=NCOLN*(IROW-1)+JCOL CONDNS(K)= -THNK(K) P0(IROW,JCOL)=THNK(K) XFD(IROW,JCOL)=XNOD(K) YFD(IROW,JCOL)=YNOD(K) 10 CONTINUE 20 CONTINUE DELTAT=1. CALL STENCL (INPUT,XFD,YFD,PKFD,PRCFD,NRD,NCOLN,NROWN, + DELTAT, + OUTPUT,C,N,S,E,W) WORST=0.0 DO 630 IR=1,NROWN DO 620 JC=1,NCOLN TEST=N(IR,JC)+E(IR,JC)+W(IR,JC)+S(IR,JC) WORST=MAX(WORST,TEST) 620 CONTINUE 630 CONTINUE DTMAX=0.5/WORST MINSTP=TIME/DTMAX IF (MINSTP.GT.DBLE(MAXTEP)) THEN NSTEP=MAXTEP WORST=NSTEP/(2.*TIME) C C POLL NODES TO ESTABLISH THE LIMIT PKLIM C PKLIM=BIGNUM DO 800 IR=1,NROWN DO 790 JC=1,NCOLN TEST=N(IR,JC)+E(IR,JC)+W(IR,JC)+S(IR,JC) IF (TEST.GT.WORST) THEN DROP=TEST-WORST IF (JC.LT.NCOLN) THEN PKNEWS(1)=PKFD(2,IR,JC) IF (PKNEWS(1).GT.0.0D0) THEN FNEWS(1)=E(IR,JC)/PKNEWS(1) ELSE FNEWS(1)=0.D0 ENDIF ELSE PKNEWS(1)=0.D0 FNEWS(1)=0.D0 ENDIF IF (IR.GT.1) THEN PKNEWS(2)=PKFD(1,IR-1,JC) IF (PKNEWS(2).GT.0.0D0) THEN FNEWS(2)=N(IR,JC)/PKNEWS(2) ELSE FNEWS(2)=0.D0 ENDIF ELSE PKNEWS(2)=0.D0 FNEWS(2)=0.D0 ENDIF IF (IR.LT.NROWN) THEN PKNEWS(3)=PKFD(1,IR,JC) IF (PKNEWS(3).GT.0.0D0) THEN FNEWS(3)=S(IR,JC)/PKNEWS(3) ELSE FNEWS(3)=0.D0 ENDIF ELSE PKNEWS(3)=0.D0 FNEWS(3)=0.D0 ENDIF IF (JC.GT.1) THEN PKNEWS(4)=PKFD(2,IR,JC-1) IF (PKNEWS(4).GT.0.0D0) THEN FNEWS(4)=W(IR,JC)/PKNEWS(4) ELSE FNEWS(4)=0.D0 ENDIF ELSE PKNEWS(4)=0.D0 FNEWS(4)=0.D0 ENDIF DO 700 K=1,4 DO 650 L=1,4 IF (PKNEWS(L).EQ. + MAX(PKNEWS(1),PKNEWS(2), + PKNEWS(3),PKNEWS(4))) KP=L 650 CONTINUE PKLIST(K)=PKNEWS(KP) FLIST(K)=FNEWS(KP) PKNEWS(KP)= -BIGNUM 700 CONTINUE TMPLIM=PKLIST(1)-DROP/FLIST(1) IF (TMPLIM.LT.PKLIST(2)) THEN DROP=DROP-(PKLIST(1)-PKLIST(2))*FLIST(1) TMPLIM=PKLIST(2)-DROP/(FLIST(1)+FLIST(2)) ENDIF IF (TMPLIM.LT.PKLIST(3)) THEN DROP=DROP-(PKLIST(2)-PKLIST(3))* + (FLIST(1)+FLIST(2)) TMPLIM=PKLIST(3)-DROP/ + (FLIST(1)+FLIST(2)+FLIST(3)) ENDIF IF (TMPLIM.LT.PKLIST(4)) THEN DROP=DROP-(PKLIST(3)-PKLIST(4))* + (FLIST(1)+FLIST(2)+FLIST(3)) TMPLIM=PKLIST(4)-DROP/ + (FLIST(1)+FLIST(2)+FLIST(3)+FLIST(4)) ENDIF TMPBOT=WORST/(FLIST(1)+FLIST(2)+ + FLIST(3)+FLIST(4)) TMPLIM=MAX(TMPLIM,TMPBOT) PKLIM=MIN(PKLIM,TMPLIM) ENDIF 790 CONTINUE 800 CONTINUE C C APPLY THE LIMIT C PKL=PKLIM NLIMIT=0 HOWLIM=1.00 DO 1000 K=1,2 DO 950 JC=1,NCOLN DO 900 IR=1,NROWN IF (PKFD(K,IR,JC).GT.PKL) THEN NLIMIT=NLIMIT+1 HOWLIM=MIN(HOWLIM,(PKL/PKFD(K,IR,JC))) PKFD(K,IR,JC)=PKL ENDIF 900 CONTINUE 950 CONTINUE 1000 CONTINUE ELSE IF ((NPREF*MINSTP).GT.DBLE(MAXTEP)) THEN NSTEP=MAXTEP ACC=ACCURA*(NPREF*MINSTP)/MAXTEP ELSE NSTEP=MAX(2 .01D0,(NPREF*MINSTP)+0.5D0) ENDIF NITER=NSTEP/2 NSTEP=NITER*2 DELTAT=TIME/NSTEP CALL STENCL (INPUT,XFD,YFD,PKFD,PRCFD,NRD,NCOLN,NROWN, + DELTAT, + OUTPUT,C,N,S,E,W) DO 1510 I=0,NCOLN+1 P0(0 ,I)=0. P0(NROWN+1,I)=0. P1(0 ,I)=0. P1(NROWN+1,I)=0. 1510 CONTINUE DO 1520 I=0,NROWN+1 P0(I,0 )=0. P0(I,NCOLN+1)=0. P1(I,0 )=0. P1(I,NCOLN+1)=0. 1520 CONTINUE DO 2000 ITER=1,NITER CALL TWOTIM (INPUT, C,N,S,E,W,NRD,NRDP1,NCOLN,NROWN, + MODIFY,P0, + WORK, P1) 2000 CONTINUE DO 3000 I=1,NUMNOD JC=MOD((I-1),NCOLN)+1 IR=(I-1)/NCOLN+1 PCHANG=P0(IR,JC)-(-CONDNS(I)) TCHANG=PCHANG*PRCFD(IR,JC) THNK(I)=THNK(I)+TCHANG 3000 CONTINUE RETURN END C C C SUBROUTINE STENCL (INPUT,X,Y,K,RHOCP,NRD,NX,NY,DELTAT, + OUTPUT,C,N,S,E,W) C C CREATES COEFFICIENT MATRICES USED BY TWOTIM TO SOLVE THE DIFFUSION C PROBLEM EXPLICITLY. C C X AND Y ARE ARRAYS OF NODE LOCATIONS IN CARTESIAN PLANAR COORDINATES C C K AND RHOCP ARE CONDUCTIVITY AND (DENSITY*HEAT-CAPACITY) ARRAYS C IN THE CASE OF TEMPERATURE-DIFFUSION, OR CORRESPONDING QUANTITIES C IN OTHER PROBLEMS. K HAS AN ADDITIONAL SUBSCRIPT WITH VALUES 1,2: C 1 = CONDUCTIVITY 1/2 ROW (SOUTH) FROM POINT INDICATED BY (I,J); C 2 = CONDUCTIVITY 1/2 COLUMN (EAST) FROM SAME POINT. C C DELTAT IS THE TIME STEP (THIS ROUTINE DOES NOT CHECK FOR STABILITY!) C C SUBSCRIPTS ARE (ROW,COLUMN), WITH ROWS INCREASING SOUTHWARD AND C COLUMNS INCREASING EASTWARD. NX AND NY DEFINE THE GRID SIZE. C REAL K,N DIMENSION C(NRD,NX),E(NRD,NX),K(2,NRD,NX),N(NRD,NX),RHOCP(NRD,NX), + S(NRD,NX),W(NRD,NX),X(NRD,NX),Y(NRD,NX) C C DO INTERIOR POINTS FIRST C NXM1=NX-1 NYM1=NY-1 DO 20 I=2,NYM1 DO 10 J=2,NXM1 DXP=SQRT((X(I,J+1)-X(I,J))**2+(Y(I,J+1)-Y(I,J))**2) DXM=SQRT((X(I,J)-X(I,J-1))**2+(Y(I,J)-Y(I,J-1))**2) DYP=SQRT((Y(I-1,J)-Y(I,J))**2+(X(I-1,J)-X(I,J))**2) DYM=SQRT((Y(I,J)-Y(I+1,J))**2+(X(I,J)-X(I+1,J))**2) N(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(1,I-1,J)/DYP)/(DYP+DYM)) E(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(2,I,J)/DXP)/(DXP+DXM)) S(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(1,I,J)/DYM)/(DYP+DYM)) W(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(2,I,J-1)/DXM)/(DXP+DXM)) C(I,J)=1.00-N(I,J)-E(I,J)-S(I,J)-W(I,J) 10 CONTINUE 20 CONTINUE C C DO TOP (NORTH) ROW, IMPOSING NO-FLUX B.C. C I=1 DO 30 J=2,NXM1 DXP=SQRT((X(I,J+1)-X(I,J))**2+(Y(I,J+1)-Y(I,J))**2) DXM=SQRT((X(I,J)-X(I,J-1))**2+(Y(I,J)-Y(I,J-1))**2) DYM=SQRT((Y(I,J)-Y(I+1,J))**2+(X(I,J)-X(I+1,J))**2) N(I,J)=0.0 E(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(2,I,J)/DXP)/(DXP+DXM)) S(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(1,I,J)/DYM**2 W(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(2,I,J-1)/DXM)/(DXP+DXM)) C(I,J)=1.00-N(I,J)-E(I,J)-S(I,J)-W(I,J) 30 CONTINUE C C DO LAST (SOUTH) ROW, IMPOSING NO-FLUX B.C. C I=NY DO 40 J=2,NXM1 DXP=SQRT((X(I,J+1)-X(I,J))**2+(Y(I,J+1)-Y(I,J))**2) DXM=SQRT((X(I,J)-X(I,J-1))**2+(Y(I,J)-Y(I,J-1))**2) DYP=SQRT((Y(I-1,J)-Y(I,J))**2+(X(I-1,J)-X(I,J))**2) N(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(1,I-1,J)/DYP**2 E(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(2,I,J)/DXP)/(DXP+DXM)) S(I,J)=0.0 W(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(2,I,J-1)/DXM)/(DXP+DXM)) C(I,J)=1.00-N(I,J)-E(I,J)-S(I,J)-W(I,J) 40 CONTINUE C C DO LEFT (WEST) COLUMN IMPOSING NO-FLUX B.C. C J=1 DO 50 I=2,NYM1 DXP=SQRT((X(I,J+1)-X(I,J))**2+(Y(I,J+1)-Y(I,J))**2) DYP=SQRT((Y(I-1,J)-Y(I,J))**2+(X(I-1,J)-X(I,J))**2) DYM=SQRT((Y(I,J)-Y(I+1,J))**2+(X(I,J)-X(I+1,J))**2) N(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(1,I-1,J)/DYP)/(DYP+DYM)) E(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(2,I,J)/DXP**2 S(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(1,I,J)/DYM)/(DYP+DYM)) W(I,J)=0.0 C(I,J)=1.00-N(I,J)-E(I,J)-S(I,J)-W(I,J) 50 CONTINUE C C DO LAST (EAST) COLUMN, IMPOSING NO-FLUX B.C. C J=NX DO 60 I=2,NYM1 DXM=SQRT((X(I,J)-X(I,J-1))**2+(Y(I,J)-Y(I,J-1))**2) DYP=SQRT((Y(I-1,J)-Y(I,J))**2+(X(I-1,J)-X(I,J))**2) DYM=SQRT((Y(I,J)-Y(I+1,J))**2+(X(I,J)-X(I+1,J))**2) N(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(1,I-1,J)/DYP)/(DYP+DYM)) E(I,J)=0.0 S(I,J)=(2.0*DELTAT/RHOCP(I,J))* + ((K(1,I,J)/DYM)/(DYP+DYM)) W(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(2,I,J-1)/DXM**2 C(I,J)=1.00-N(I,J)-E(I,J)-S(I,J)-W(I,J) 60 CONTINUE C C DO CORNER (1,1) = NW, CONTINUING NO-FLUX B.C.'S C I=1 J=1 DXP=SQRT((X(I,J+1)-X(I,J))**2+(Y(I,J+1)-Y(I,J))**2) DYM=SQRT((Y(I,J)-Y(I+1,J))**2+(X(I,J)-X(I+1,J))**2) N(I,J)=0.0 E(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(2,I,J)/DXP**2 S(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(1,I,J)/DYM**2 W(I,J)=0.0 C(I,J)=1.00-N(I,J)-E(I,J)-S(I,J)-W(I,J) C C DO CORNER (NY,1) = SW, CONTINUING NO-FLUX B.C.'S C I=NY J=1 DXP=SQRT((X(I,J+1)-X(I,J))**2+(Y(I,J+1)-Y(I,J))**2) DYP=SQRT((Y(I-1,J)-Y(I,J))**2+(X(I-1,J)-X(I,J))**2) N(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(1,I-1,J)/DYP**2 E(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(2,I,J)/DXP**2 S(I,J)=0.0 W(I,J)=0.0 C(I,J)=1.00-N(I,J)-E(I,J)-S(I,J)-W(I,J) C C DO CORNER (NY,NX) = SE, CONTINUING NO-FLUX B.C.'S C I=NY J=NX DXM=SQRT((X(I,J)-X(I,J-1))**2+(Y(I,J)-Y(I,J-1))**2) DYP=SQRT((Y(I-1,J)-Y(I,J))**2+(X(I-1,J)-X(I,J))**2) N(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(1,I-1,J)/DYP**2 E(I,J)=0.0 S(I,J)=0.0 W(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(2,I,J-1)/DXM**2 C(I,J)=1.00-N(I,J)-E(I,J)-S(I,J)-W(I,J) C C DO CORNER (1,NX) = NE, CONTINUING NO-FLUX B.C.'S C I=1 J=NX DXM=SQRT((X(I,J)-X(I,J-1))**2+(Y(I,J)-Y(I,J-1))**2) DYM=SQRT((Y(I,J)-Y(I+1,J))**2+(X(I,J)-X(I+1,J))**2) N(I,J)=0.0 E(I,J)=0.0 S(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(1,I,J)/DYM**2 W(I,J)=(2.0*DELTAT/RHOCP(I,J))* + K(2,I,J-1)/DXM**2 C(I,J)=1.00-N(I,J)-E(I,J)-S(I,J)-W(I,J) C RETURN END C C C SUBROUTINE EPLUSE (ERATE,DT,ESUM,NUMEL) C C UPDATE TOTAL STRAIN OF SURFACE INTEGRATION POINTS BY C CREATING A MAPPING MATRIX OUT OF STRAIN-RATES AND DT C AND LEFT-MULTIPLYING IT ONTO THE EXISTING MAPPING MATRIX. C DIMENSION ESUM(2,2,7,NUMEL),EM(2,2),ER(2,2), & ERATE(4,7,NUMEL),TWIST(2,2) C DO 100 M=1,7 DO 90 I=1,NUMEL ANGLE=ERATE(4,M,I)*DT/2. C TWIST(1,1)=COS(ANGLE) TWIST(1,2)= -SIN(ANGLE) TWIST(2,1)= -TWIST(1,2) TWIST(2,2)=TWIST(1,1) C ER(1,1)=1.00+ERATE(1,M,I)*DT ER(1,2)=ERATE(3,M,I)*DT ER(2,1)=ER(1,2) ER(2,2)=1.00+ERATE(2,M,I)*DT C EM(1,1)=ER(1,1)*TWIST(1,1)+ER(1,2)*TWIST(2,1) EM(1,2)=ER(1,1)*TWIST(1,2)+ER(1,2)*TWIST(2,2) EM(2,1)=ER(2,1)*TWIST(1,1)+ER(2,2)*TWIST(2,1) EM(2,2)=ER(2,1)*TWIST(1,2)+ER(2,2)*TWIST(2,2) C ER(1,1)=TWIST(1,1)*EM(1,1)+TWIST(1,2)*EM(2,1) ER(1,2)=TWIST(1,1)*EM(1,2)+TWIST(1,2)*EM(2,2) ER(2,1)=TWIST(2,1)*EM(1,1)+TWIST(2,2)*EM(2,1) ER(2,2)=TWIST(2,1)*EM(1,2)+TWIST(2,2)*EM(2,2) C ESUM(1,1,M,I)=ER(1,1)*ESUM(1,1,M,I)+ & ER(1,2)*ESUM(2,1,M,I) ESUM(1,2,M,I)=ER(1,1)*ESUM(1,2,M,I)+ & ER(1,2)*ESUM(2,2,M,I) ESUM(2,1,M,I)=ER(2,1)*ESUM(1,1,M,I)+ & ER(2,2)*ESUM(2,1,M,I) ESUM(2,2,M,I)=ER(2,1)*ESUM(1,2,M,I)+ & ER(2,2)*ESUM(2,2,M,I) ESUM(1,1,M,I)=MIN(MAX(ESUM(1,1,M,I),-99.999),999.999) ESUM(1,2,M,I)=MIN(MAX(ESUM(1,2,M,I),-99.999),999.999) ESUM(2,1,M,I)=MIN(MAX(ESUM(2,1,M,I),-99.999),999.999) ESUM(2,2,M,I)=MIN(MAX(ESUM(2,2,M,I),-99.999),999.999) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE CRUSTS (INPUT,AREAC,DELT,DETJC,ERATEC,HMAX,HMIN, + NCDIM,NDIFF,NODES,NUMEL,NUMNOD, + NXL,THIKC,THNKC, + MODIFY,CONNOD, + OUTPUT,CONINT, + WORK,CODE,CONDNS,FLOWIN,LWORK,OUTSCA) C C MODIFIES DEPTH OF CONRAD DISCONTINUITY C (WHERE CRUSTAL CREEP PROPERTIES CHANGE) C BASED ON SURFACE STRAIN-RATE AND TIMESTEP, ASSUMPTION OF VOLUME C CONSERVATION ABOVE CONRAD, AND PREVIOUS DEPTH. C NOTE THAT STRAIN-RATE IS FIRST SMOOTHED BY EXTRAPOLATION C TO THE NODES. C DOUBLE PRECISION CODE,FLOWIN LOGICAL FAILUR,LOCKIN,LOCKWC DIMENSION AREAC(NUMEL),CODE(NCDIM),CONDNS(NUMNOD), + CONINT(7,NUMEL),CONNOD(NUMNOD),DETJC(7,NUMEL), + ERATEC(4,7,NUMEL),FLOWIN(NUMNOD), + HMAX(2),HMIN(2),LWORK(NXL),NODES(6,0:NUMEL), + OUTSCA(7,NUMEL), + THIKC(7,NUMEL),THNKC(NUMNOD) DATA LOCKIN/.FALSE./,LOCKWC/.FALSE./ C DO 100 M=1,7 DO 90 I=1,NUMEL OUTSCA(M,I)=ERATEC(1,M,I)+ERATEC(2,M,I) 90 CONTINUE 100 CONTINUE CALL EXTRAP (AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) DO 200 I=1,NUMNOD CONNOD(I)=CONNOD(I)*(1.00-DELT*CONDNS(I)) CONNOD(I)=MIN(CONNOD(I),HMAX(1),THNKC(I)) CONNOD(I)=MAX(CONNOD(I),HMIN(1)) 200 CONTINUE CALL INTERP (CONNOD,NODES,NUMEL,NUMNOD,CONINT) DO 300 M=1,7 DO 290 I=1,NUMEL CONINT(M,I)=MAX(CONINT(M,I),HMIN(1)) CONINT(M,I)=MIN(CONINT(M,I),HMAX(1),THIKC(M,I)) 290 CONTINUE 300 CONTINUE RETURN END C C C SUBROUTINE EZZDOT (INPUT,AREA,DETJ,ERATE, + NCDIM,NDIFF,NODES, + NUMEL,NUMNOD,NXL,THIK, + OUTPUT,W, + WORK,CODE,FLOWIN,LWORK) C C CALCULATES W, THE RATE OF CHANGE OF LAYER THICKNESSES THNK, C CONSIDERING ONLY PURE SHEAR OF THE LAYER, AND ASSUMING C STRAIN-RATES AT LAYER TOP ARE REPRESENTATIVE. C DOES NOT DO SIMPLE SHEAR TERMS, WHICH ARE IN 'DRAGIT.' C DOES NOT DO DIFFUSION OF CRUSTAL THICKNESS, WHICH IS IN 'SMOOTH.' C DOUBLE PRECISION CODE,FLOWIN,PHI,WEIGHT LOGICAL FAILUR DIMENSION AREA(NUMEL), + CODE(NCDIM), + DETJ(7,NUMEL), + ERATE(4,7,NUMEL), + FLOWIN(NUMNOD),LWORK(NXL), + NODES(6,0:NUMEL), + PHI(6,7), + THIK(7,NUMEL), + W(NUMNOD),WEIGHT(7) COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT C CALL BUILDC (AREA,CODE,DETJ, + NCDIM,NDIFF,NODES,NUMEL,NUMNOD) DO 1500 I=1,NUMNOD FLOWIN(I)=0. 1500 CONTINUE DO 1800 M=1,7 DO 1700 I=1,NUMEL DA=AREA(I)*DETJ(M,I)*WEIGHT(M) HEZZDT= -THIK(M,I)*(ERATE(1,M,I)+ERATE(2,M,I)) DO 1600 J=1,6 K=NODES(J,I) FLOWIN(K)=FLOWIN(K)+HEZZDT*PHI(J,M)*DA 1600 CONTINUE 1700 CONTINUE 1800 CONTINUE CALL SOLVER (CODE,NCDIM,FLOWIN,NUMNOD,NDIFF,LWORK,NXL,FAILUR) DO 1900 I=1,NUMNOD W(I)=FLOWIN(I) 1900 CONTINUE RETURN END C C C SUBROUTINE HEATER (INPUT,AREAC,AREAM, + CONDUC,DIFFUS, + DETJC,DETJM,DNLINK, + NCDIM,NDIFF,NODES,NUMEL,NUMNOD, + NXL,QFRICC,QFRICM, + THIKC,THIKM,THNKC,THNKM, + UPLINK, + MODIFY,DGDTC,DGDTM, + WORK,CODE,CONDNS,FLOWIN,LWORK,OUTSCA,QWORK) C C CALCULATES RATES-OF-CHANGE OF GEOTHERM COEFFICIENTS ARISING C FROM THE SHEAR-STRAIN-HEATING EFFECT (ONLY) AND RECORDS C THEM BY INCREMENTING THE VALUES OF DGDTC AND DGDTM. C PRIMARY INPUT ARRAYS ARE QFRICC AND QFRICM(K,M,I), IN WHICH: C K=1 GIVES THE SHEAR-HEATING HEAT-FLUX FROM PURE SHEAR, C K=2 GIVES THE DEPTH OF ITS CREATION IN THE LAYER, C K=3 GIVES THE SHEAR-HEATING HEAT-FLUX FROM SIMPLE SHEAR, C K=4 GIVES THE DEPTH OF THE DETACHMENT IN THE LAYER. C DOUBLE PRECISION CODE,FLOWIN LOGICAL FAILUR,LOCKIN,LOCKWC REAL INVERS DIMENSION INVERS(5,5),PDOT(5),RHS(5) DIMENSION AREAC(NUMEL),AREAM(NUMEL),CODE(NCDIM), + CONDNS(NUMNOD), + CONDUC(2),DETJC(7,NUMEL),DETJM(7,NUMEL), + DIFFUS(2),DNLINK(3,7,NUMEL), + DGDTC(4,7,NUMEL),DGDTM(4,7,NUMEL), + FLOWIN(NUMNOD),LWORK(NXL), + NODES(6,0:NUMEL),OUTSCA(7,NUMEL), + QFRICC(4,7,NUMEL),QFRICM(4,7,NUMEL), + QWORK(4,7,NUMEL), + THIKC(7,NUMEL),THIKM(7,NUMEL), + THNKC(NUMNOD),THNKM(NUMNOD), + UPLINK(3,7,NUMEL) DATA LOCKIN/.FALSE./,LOCKWC/.FALSE./ C FACTRC=DIFFUS(1)/CONDUC(1) FACTRM=DIFFUS(2)/CONDUC(2) C C CALCULATION FOR CRUSTAL INTEGRATION POINTS C C PUT VALUES FROM ADJACENT QFRICM (IF ANY) INTO QWORK C DO 100 K=1,4 DO 20 M=1,7 DO 10 I=1,NUMEL OUTSCA(M,I)=QFRICM(K,M,I) 10 CONTINUE 20 CONTINUE CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 90 M=1,7 DO 80 I=1,NUMEL QWORK(K,M,I)=MAX(OUTSCA(M,I),0.) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C PUT THICKNESSES OF ADJACENT MANTLE (IF ANY) INTO OUTSCA C CALL GETSCA (INPUT,THNKM,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 200 M=1,7 DO 190 I=1,NUMEL QWORK(2,M,I)=MIN(QWORK(2,M,I),OUTSCA(M,I)) QWORK(4,M,I)=MIN(QWORK(4,M,I),OUTSCA(M,I)) 190 CONTINUE 200 CONTINUE C DO 1000 M=1,7 DO 900 I=1,NUMEL IF (DNLINK(1,M,I).GE.1.) THEN C C POINTS OVERLYING MANTLE LITHOSPHERE C TC=THIKC(M,I) TM=OUTSCA(M,I) Z2=QFRICC(2,M,I) Z4=QFRICC(4,M,I) ZP2=QWORK(2,M,I) ZP4=QWORK(4,M,I) RHS(1)=FACTRC*(QFRICC(1,M,I)* + (2.*Z2/TC) + +QFRICC(3,M,I)* + (2.*Z4/TC)) + +FACTRM*(QWORK(1,M,I)* + (2.*(1.-ZP2/TM)) + +QWORK(3,M,I)* + (2.*(1.-ZP4/TM))) RHS(2)=FACTRC*(QFRICC(1,M,I)* + (6.*(Z2/TC-Z2**2/TC**2)) + +QFRICC(3,M,I)* + (6.*(Z4/TC-Z4**2/TC**2))) RHS(3)=FACTRM*(QWORK(1,M,I)* + (6.*(ZP2/TM-ZP2**2/TM**2)) + +QWORK(3,M,I)* + (6.*(ZP4/TM-ZP4**2/TM**2))) RHS(4)=FACTRC*(QFRICC(1,M,I)* + (Z2/TC-3.*Z2**2/TC**2+2.*Z2**3/TC**3) + +QFRICC(3,M,I)* + (Z4/TC-3.*Z4**2/TC**2+2.*Z4**3/TC**3)) RHS(5)=FACTRM*(QWORK(1,M,I)* + (ZP2/TM-3.*ZP2**2/TM**2+2.*ZP2**3/TM**3) + +QWORK(3,M,I)* + (ZP4/TM-3.*ZP4**2/TM**2+2.*ZP4**3/TM**3)) INVERS(1,1)=15./(4.*(TM+TC)) INVERS(1,2)=(-25.)/(8.*(TM+TC)) INVERS(1,3)=(-25.)/(8.*(TM+TC)) INVERS(1,4)=105./(4.*(TM+TC)) INVERS(1,5)=(-105.)/(4.*(TM+TC)) INVERS(2,1)=(-25.)/(8.*(TM+TC)) INVERS(2,2)=(5.*(8.*TM+33.*TC))/(48.*TC*(TM+TC)) INVERS(2,3)=125./(48.*(TM+TC)) INVERS(2,4)=(-175.)/(8.*(TM+TC)) INVERS(2,5)=175./(8.*(TM+TC)) INVERS(4,1)=105./(4.*(TM+TC)) INVERS(4,2)=(-175.)/(8.*(TM+TC)) INVERS(4,3)=(-175.)/(8.*(TM+TC)) INVERS(4,4)=(105.*(8.*TM+15.*TC))/(4.*TC*(TM+TC)) INVERS(4,5)=(-735.)/(4.*(TM+TC)) PDOT(1)=INVERS(1,1)*RHS(1)+INVERS(1,2)*RHS(2)+ + INVERS(1,3)*RHS(3)+INVERS(1,4)*RHS(4)+ + INVERS(1,5)*RHS(5) PDOT(2)=INVERS(2,1)*RHS(1)+INVERS(2,2)*RHS(2)+ + INVERS(2,3)*RHS(3)+INVERS(2,4)*RHS(4)+ + INVERS(2,5)*RHS(5) PDOT(4)=INVERS(4,1)*RHS(1)+INVERS(4,2)*RHS(2)+ + INVERS(4,3)*RHS(3)+INVERS(4,4)*RHS(4)+ + INVERS(4,5)*RHS(5) DGDTC(2,M,I)=DGDTC(2,M,I)+ + (2.*PDOT(1)+6.*PDOT(2)+PDOT(4))/TC DGDTC(3,M,I)=DGDTC(3,M,I)+ + (-6.*PDOT(2)-3.*PDOT(4))/TC**2 DGDTC(4,M,I)=DGDTC(4,M,I)+ + (2.*PDOT(4))/TC**3 ELSE C C POINTS OVERLYING ASTHENOSPHERE OR SLAB C FIXED-T LOWER B.C. LEAVES ONLY 2 D.O.F.: C C1(Z) = Z/T - Z**2/T**2 (PEAK 1/4 AT T/2) C C2(Z) =-Z/T +3Z**2/T**2 -2Z**3/T**3 C (PEAK 0.096 AT .7887T) C INTEGRATED PRODUCT MATRIX = (T/30 , 0 ) C (0 , T/210) C INVERSE MATRIX = (30/T , 0) C (0, 210/T) C T=THIKC(M,I) Z2=QFRICC(2,M,I) Z4=QFRICC(4,M,I) RHS1=FACTRC*(QFRICC(1,M,I)* + (Z2/T-Z2**2/T**2) + +QFRICC(3,M,I)* + (Z4/T-Z4**2/T**2)) RHS2=FACTRC*(QFRICC(1,M,I)* + (-Z2/T+3.*Z2**2/T**2-2.*Z2**3/T**3) + +QFRICC(3,M,I)* + (-Z4/T+3.*Z4**2/T**2-2.*Z4**3/T**3)) P1DOT=(30./T)*RHS1 P2DOT=(210./T)*RHS2 DGDTC(2,M,I)=DGDTC(2,M,I)+ + (P1DOT-P2DOT)/T DGDTC(3,M,I)=DGDTC(3,M,I)+ + (-P1DOT+3.*P2DOT)/T**2 DGDTC(4,M,I)=DGDTC(4,M,I)+ + (-2.*P2DOT)/T**3 ENDIF 900 CONTINUE 1000 CONTINUE C C CALCULATION FOR MANTLE INTEGRATION POINTS C C PUT VALUES FROM ADJACENT QFRICC (IF ANY) INTO QWORK C DO 1100 K=1,4 DO 1020 M=1,7 DO 1010 I=1,NUMEL OUTSCA(M,I)=QFRICC(K,M,I) 1010 CONTINUE 1020 CONTINUE CALL EXTRAP (AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DO 1090 M=1,7 DO 1080 I=1,NUMEL QWORK(K,M,I)=MAX(OUTSCA(M,I),0.) 1080 CONTINUE 1090 CONTINUE 1100 CONTINUE C C PUT THICKNESSES OF ADJACENT CRUST INTO OUTSCA C CALL GETSCA (INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DO 1200 M=1,7 DO 1190 I=1,NUMEL QWORK(2,M,I)=MIN(QWORK(2,M,I),OUTSCA(M,I)) QWORK(4,M,I)=MIN(QWORK(4,M,I),OUTSCA(M,I)) 1190 CONTINUE 1200 CONTINUE C DO 2000 M=1,7 DO 1900 I=1,NUMEL TM=THIKM(M,I) TC=OUTSCA(M,I) Z2=QWORK(2,M,I) Z4=QWORK(4,M,I) ZP2=QFRICM(2,M,I) ZP4=QFRICM(4,M,I) RHS(1)=FACTRC*(QWORK(1,M,I)* + (2.*Z2/TC) + +QWORK(3,M,I)* + (2.*Z4/TC)) + +FACTRM*(QFRICM(1,M,I)* + (2.*(1.-ZP2/TM)) + +QFRICM(3,M,I)* + (2.*(1.-ZP4/TM))) RHS(2)=FACTRC*(QWORK(1,M,I)* + (6.*(Z2/TC-Z2**2/TC**2)) + +QWORK(3,M,I)* + (6.*(Z4/TC-Z4**2/TC**2))) RHS(3)=FACTRM*(QFRICM(1,M,I)* + (6.*(ZP2/TM-ZP2**2/TM**2)) + +QFRICM(3,M,I)* + (6.*(ZP4/TM-ZP4**2/TM**2))) RHS(4)=FACTRC*(QWORK(1,M,I)* + (Z2/TC-3.*Z2**2/TC**2+2.*Z2**3/TC**3) + +QWORK(3,M,I)* + (Z4/TC-3.*Z4**2/TC**2+2.*Z4**3/TC**3)) RHS(5)=FACTRM*(QFRICM(1,M,I)* + (ZP2/TM-3.*ZP2**2/TM**2+2.*ZP2**3/TM**3) + +QFRICM(3,M,I)* + (ZP4/TM-3.*ZP4**2/TM**2+2.*ZP4**3/TM**3)) INVERS(1,1)=15./(4.*(TM+TC)) INVERS(1,2)=(-25.)/(8.*(TM+TC)) INVERS(1,3)=(-25.)/(8.*(TM+TC)) INVERS(1,4)=105./(4.*(TM+TC)) INVERS(1,5)=(-105.)/(4.*(TM+TC)) INVERS(3,1)=(-25.)/(8.*(TM+TC)) INVERS(3,2)=125./(48.*(TM+TC)) INVERS(3,3)=(5.*(33.*TM+8.*TC))/(48.*TM*(TM+TC)) INVERS(3,4)=(-175.)/(8.*(TM+TC)) INVERS(3,5)=175./(8.*(TM+TC)) INVERS(5,1)=(-105.)/(4.*(TM+TC)) INVERS(5,2)=175./(8.*(TM+TC)) INVERS(5,3)=175./(8.*(TM+TC)) INVERS(5,4)=(-735.)/(4.*(TM+TC)) INVERS(5,5)=(105.*(15.*TM+8.*TC))/(4.*TM*(TM+TC)) PDOT(1)=INVERS(1,1)*RHS(1)+INVERS(1,2)*RHS(2)+ + INVERS(1,3)*RHS(3)+INVERS(1,4)*RHS(4)+ + INVERS(1,5)*RHS(5) PDOT(3)=INVERS(3,1)*RHS(1)+INVERS(3,2)*RHS(2)+ + INVERS(3,3)*RHS(3)+INVERS(3,4)*RHS(4)+ + INVERS(3,5)*RHS(5) PDOT(5)=INVERS(5,1)*RHS(1)+INVERS(5,2)*RHS(2)+ + INVERS(5,3)*RHS(3)+INVERS(5,4)*RHS(4)+ + INVERS(5,5)*RHS(5) DGDTM(1,M,I)=DGDTM(1,M,I)+2.*PDOT(1) DGDTM(2,M,I)=DGDTM(2,M,I)+ + (-2.*PDOT(1)+6.*PDOT(3)+PDOT(5))/TM DGDTM(3,M,I)=DGDTM(3,M,I)+ + (-6.*PDOT(3)-3.*PDOT(5))/TM**2 DGDTM(4,M,I)=DGDTM(4,M,I)+ + 2.*PDOT(5)/TM**3 1900 CONTINUE 2000 CONTINUE RETURN END C C C SUBROUTINE DRAGIT (INPUT, AREA,CRUST,DELTAT,DELV,DETJ,DXS,DYS, + FLUX,HMAX,HMIN,NCDIM,NDIFF, + NELCOL,NODES,NUMEL,NUMNOD,NXL, + XIP,XNODE,YIP,YNODE, + MODIFY,THIK,THNK, + WORK, CODE,CONDNS,FLOWIN,LWORK, + OUTSCA,PHINOD,VNODE) C C MODIFIES LAYER THICKNESSES AT INTEGRATION POINTS (THIK) AND C NODES (THNK), CONSIDERING ONLY FORCED SIMPLE SHEAR. C METHOD IS FULLY-IMPLICIT, AND HAS THESE STEPS: C (1) CONTINOUS FIELD OF DRAGGED-ALONG THICKNESSES IS FOUND; C (2) CONTINOUS FIELD OF DRAGGING RELATIVE VELOCITIES IS FOUND; C (3) CONTINOUS FIELD OF THE DIVERGENCE OF THE ABOVE IS FOUND; C (4) NEW THICKNESS IS FOUND BY LOOKING UPSTREAM; C (5) THICKNESS IS STRAINED BASED ON DIVERGENCE OF VELOCITY FIELD. C DOES NOT DO PURE-SHEAR THICKENING, WHICH IS IN 'EZZDOT.' C DOES NOT DO DIFFUSION OF CRUSTAL THICKNESS, WHICH IS IN 'SMOOTH.' C PARAMETER (NPIECE=10) DOUBLE PRECISION CODE,FLOWIN,PHI,POINTS,WEIGHT LOGICAL ATSEA,CRUST,FAILUR,LOCKIN,LOCKWC,STUCK DIMENSION DELT(NPIECE),DILRAT(NPIECE),VMAG(NPIECE) DIMENSION AREA(NUMEL), + CODE(NCDIM),CONDNS(NUMNOD), + DELV(2,7,NUMEL),DETJ(7,NUMEL), + DXS(6,7,NUMEL),DYS(6,7,NUMEL), + FLOWIN(NUMNOD),FLUX(7,NUMEL), + HMAX(2),HMIN(2), + LWORK(NXL),NODES(6,0:NUMEL), + OUTSCA(7,NUMEL), + PHI(6,7),PHINOD(NUMNOD),POINTS(5,7), + THIK(7,NUMEL),THNK(NUMNOD), + VNODE(2,NUMNOD),WEIGHT(7), + XIP(7,NUMEL),YIP(7,NUMEL), + XNODE(NUMNOD),YNODE(NUMNOD) COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT COMMON /L1L2L3/ POINTS C C STATEMENT FUNCTIONS: C PHIVAL(IE,S1,S2,S3)= + PHINOD(NODES(1,IE))*(-S1+2.*S1**2)+ + PHINOD(NODES(2,IE))*(-S2+2.*S2**2)+ + PHINOD(NODES(3,IE))*(-S3+2.*S3**2)+ + PHINOD(NODES(4,IE))*(4.*S1*S2)+ + PHINOD(NODES(5,IE))*(4.*S2*S3)+ + PHINOD(NODES(6,IE))*(4.*S3*S1) CONVAL(IE,S1,S2,S3)= + CONDNS(NODES(1,IE))*(-S1+2.*S1**2)+ + CONDNS(NODES(2,IE))*(-S2+2.*S2**2)+ + CONDNS(NODES(3,IE))*(-S3+2.*S3**2)+ + CONDNS(NODES(4,IE))*(4.*S1*S2)+ + CONDNS(NODES(5,IE))*(4.*S2*S3)+ + CONDNS(NODES(6,IE))*(4.*S3*S1) VECVAL(K,IE,S1,S2,S3)= + VNODE(K,NODES(1,IE))*(-S1+2.*S1**2)+ + VNODE(K,NODES(2,IE))*(-S2+2.*S2**2)+ + VNODE(K,NODES(3,IE))*(-S3+2.*S3**2)+ + VNODE(K,NODES(4,IE))*(4.*S1*S2)+ + VNODE(K,NODES(5,IE))*(4.*S2*S3)+ + VNODE(K,NODES(6,IE))*(4.*S3*S1) C IF (CRUST) THEN HMX=HMAX(1) HMN=HMIN(1) ELSE HMX=HMAX(2) HMN=HMIN(2) ENDIF C C TRANSFER DRAGGED-ALONG THICKNESSES FROM INTEGRATION POINTS(FLUX) C TO NODES (CONDNS): C LOCKIN=.FALSE. LOCKWC=.FALSE. CALL EXTRAP (AREA,CODE,DETJ,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,FLUX,LWORK, + LOCKIN,LOCKWC) DO 110 I=1,NUMNOD CONDNS(I)=MAX(CONDNS(I),0.0) 110 CONTINUE C C SMOOTH RELATIVE VELOCITIES (DELV) AND TRANFER FROM INTEGRATION C POINT VALUES TO NODAL VALUES (VNODE): C C FIRST, THE X-COMPONENT: C LOCKIN=.FALSE. LOCKWC=.FALSE. DO 900 M=1,7 DO 850 I=1,NUMEL OUTSCA(M,I)=DELV(1,M,I) 850 CONTINUE 900 CONTINUE CALL EXTRAP (AREA,CODE,DETJ,FAILUR, + FLOWIN,PHINOD,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) DO 1000 I=1,NUMNOD VNODE(1,I)=PHINOD(I) 1000 CONTINUE C C SECOND, THE Y-COMPONENT: C DO 1100 M=1,7 DO 1050 I=1,NUMEL OUTSCA(M,I)=DELV(2,M,I) 1050 CONTINUE 1100 CONTINUE CALL EXTRAP (AREA,CODE,DETJ,FAILUR, + FLOWIN,PHINOD,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) DO 1200 I=1,NUMNOD VNODE(2,I)=PHINOD(I) 1200 CONTINUE C C FIND AVERAGE FLOW DIRECTION AND SUPPRESS ANY NEGATIVE SIDE LOBES C VXS=0. VYS=0. DO 1220 I=1,NUMNOD VXS=VXS+VNODE(1,I) VYS=VYS+VNODE(2,I) 1220 CONTINUE SIZE=SQRT((1.D0*VXS)**2+(1.D0*VYS)**2) IF (SIZE.GT.0.0) THEN VXS=VXS/SIZE VYS=VYS/SIZE ELSE VXS=0.0 VYS=0.0 END IF DO 1240 I=1,NUMNOD DOT=VXS*VNODE(1,I)+VYS*VNODE(2,I) IF (DOT.LT.0.0) THEN VNODE(1,I)=0.0 VNODE(2,I)=0.0 DOT=0.0 ENDIF PHINOD(I)=DOT 1240 CONTINUE CALL INTERP (PHINOD,NODES,NUMEL,NUMNOD,OUTSCA) DO 1250 I=1,NUMEL DMIN=MIN(OUTSCA(1,I),OUTSCA(2,I),OUTSCA(3,I), + OUTSCA(4,I),OUTSCA(5,I),OUTSCA(6,I), + OUTSCA(7,I)) IF (DMIN.LT.0.0) THEN I1=NODES(1,I) I2=NODES(2,I) I3=NODES(3,I) I4=NODES(4,I) I5=NODES(5,I) I6=NODES(6,I) TOP=MAX(PHINOD(I1),PHINOD(I2)) BOT=MIN(PHINOD(I1),PHINOD(I2)) RAISE=MAX(0.0,((BOT+0.25*(TOP-BOT))-PHINOD(I4))) VNODE(1,I4)=VNODE(1,I4)+RAISE*VXS VNODE(2,I4)=VNODE(2,I4)+RAISE*VYS TOP=MAX(PHINOD(I2),PHINOD(I3)) BOT=MIN(PHINOD(I2),PHINOD(I3)) RAISE=MAX(0.0,((BOT+0.25*(TOP-BOT))-PHINOD(I5))) VNODE(1,I5)=VNODE(1,I5)+RAISE*VXS VNODE(2,I5)=VNODE(2,I5)+RAISE*VYS TOP=MAX(PHINOD(I3),PHINOD(I1)) BOT=MIN(PHINOD(I3),PHINOD(I1)) RAISE=MAX(0.0,((BOT+0.25*(TOP-BOT))-PHINOD(I6))) VNODE(1,I6)=VNODE(1,I6)+RAISE*VXS VNODE(2,I6)=VNODE(2,I6)+RAISE*VYS ENDIF 1250 CONTINUE C C COMPUTE DIVERGENCE-RATE (D.X-VEL/DX + D.Y-VEL/DY) C AND EXTRAPOLATE TO NODE POSITIONS (PHINOD): C DO 1400 M=1,7 DO 1300 I=1,NUMEL OUTSCA(M,I)=VNODE(1,NODES(1,I))*DXS(1,M,I)+ + VNODE(1,NODES(2,I))*DXS(2,M,I)+ + VNODE(1,NODES(3,I))*DXS(3,M,I)+ + VNODE(1,NODES(4,I))*DXS(4,M,I)+ + VNODE(1,NODES(5,I))*DXS(5,M,I)+ + VNODE(1,NODES(6,I))*DXS(6,M,I)+ + VNODE(2,NODES(1,I))*DYS(1,M,I)+ + VNODE(2,NODES(2,I))*DYS(2,M,I)+ + VNODE(2,NODES(3,I))*DYS(3,M,I)+ + VNODE(2,NODES(4,I))*DYS(4,M,I)+ + VNODE(2,NODES(5,I))*DYS(5,M,I)+ + VNODE(2,NODES(6,I))*DYS(6,M,I) 1300 CONTINUE 1400 CONTINUE LOCKIN=.FALSE. LOCKWC=.FALSE. CALL EXTRAP (AREA,CODE,DETJ,FAILUR, + FLOWIN,PHINOD,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) C C FIND NEW THICKNESS TO PLACE BENEATH EACH NODE, STRAIN IT, C AND ADJUST TOTAL LAYER THICKNESS ACCORDINGLY: C DO 2001 M=1,7 DO 2000 I=1,NUMEL IE=I S1=POINTS(1,M) S2=POINTS(2,M) S3=POINTS(3,M) FOLD=CONVAL(IE,S1,S2,S3) V0X=VECVAL(1,IE,S1,S2,S3) V0Y=VECVAL(2,IE,S1,S2,S3) C C DETERMINE INITIAL POSITION BY 4TH-ORDER RUNGA-KUTTA: C C -EULER PREDICTOR FOR HALF-STEP: XSTAR=XIP(M,I)-V0X*DELTAT/2. YSTAR=YIP(M,I)-V0Y*DELTAT/2. C C -BACKWARD EULER CORRECTOR FOR HALF-STEP: CALL LOOKUP (INPUT,AREA,DETJ,NELCOL,NODES,NUMEL, + NUMNOD,XSTAR,XIP,XNODE, + YSTAR,YIP,YNODE, + MODIFY,IE,S1,S2,S3, + OUTPUT,ATSEA) IF (ATSEA) THEN VXSTAR=V0X VYSTAR=V0Y ELSE VXSTAR=VECVAL(1,IE,S1,S2,S3) VYSTAR=VECVAL(2,IE,S1,S2,S3) ENDIF DOT=VXS*VXSTAR+VYS*VYSTAR IF (DOT.LT.0.0) THEN VXSTAR=0.0 VYSTAR=0.0 ENDIF XSTAR2=XIP(M,I)-DELTAT*VXSTAR/2. YSTAR2=YIP(M,I)-DELTAT*VYSTAR/2. C C -MIDPOINT RULE PREDICTOR FOR FULL STEP: CALL LOOKUP (INPUT,AREA,DETJ,NELCOL,NODES,NUMEL, + NUMNOD,XSTAR2,XIP,XNODE, + YSTAR2,YIP,YNODE, + MODIFY,IE,S1,S2,S3, + OUTPUT,ATSEA) IF (ATSEA) THEN VX2STR=V0X VY2STR=V0Y ELSE VX2STR=VECVAL(1,IE,S1,S2,S3) VY2STR=VECVAL(2,IE,S1,S2,S3) ENDIF DOT=VXS*VX2STR+VYS*VY2STR IF (DOT.LT.0.0) THEN VX2STR=0.0 VY2STR=0.0 ENDIF XSTAR3=XIP(M,I)-DELTAT*VX2STR YSTAR3=YIP(M,I)-DELTAT*VY2STR C C -SIMPSON'S RULE CORRECTOR FOR FULL STEP: CALL LOOKUP (INPUT,AREA,DETJ,NELCOL,NODES,NUMEL, + NUMNOD,XSTAR3,XIP,XNODE, + YSTAR3,YIP,YNODE, + MODIFY,IE,S1,S2,S3, + OUTPUT,ATSEA) IF (ATSEA) THEN VX3STR=V0X VY3STR=V0Y ELSE VX3STR=VECVAL(1,IE,S1,S2,S3) VY3STR=VECVAL(2,IE,S1,S2,S3) ENDIF DOT=VXS*VX3STR+VYS*VY3STR IF (DOT.LT.0.0) THEN VX3STR=0.0 VY3STR=0.0 ENDIF X0=XIP(M,I)-DELTAT*(V0X+2.*VXSTAR+ + 2.*VX2STR+VX3STR)/6. Y0=YIP(M,I)-DELTAT*(V0Y+2.*VYSTAR+ + 2.*VY2STR+VY3STR)/6. CALL LOOKUP (INPUT,AREA,DETJ,NELCOL,NODES,NUMEL, + NUMNOD,X0,XIP,XNODE, + Y0,YIP,YNODE, + MODIFY,IE,S1,S2,S3, + OUTPUT,ATSEA) IF (ATSEA) THEN FTEMP=0.0 ELSE FTEMP=MAX(CONVAL(IE,S1,S2,S3),0.0) ENDIF C C PREPARE TABLES FOR NUMER. INTEGRATION OF DILATATION: C DO 1800 J=1,NPIECE S=(J-0.5)/NPIECE X=S*XIP(M,I)+(1.-S)*X0 Y=S*YIP(M,I)+(1.-S)*Y0 CALL LOOKUP (INPUT,AREA,DETJ, + NELCOL,NODES,NUMEL, + NUMNOD,X,XIP,XNODE, + Y,YIP,YNODE, + MODIFY,IE,S1,S2,S3, + OUTPUT,ATSEA) IF (ATSEA) THEN DILRAT(J)=0.0 VMAG(J)=SQRT((1.D0*V0X)**2+(1.D0*V0Y)**2) ELSE DILRAT(J)=PHIVAL(IE,S1,S2,S3) VX=VECVAL(1,IE,S1,S2,S3) VY=VECVAL(2,IE,S1,S2,S3) VMAG(J)=SQRT((1.D0*VX)**2+(1.D0*VY)**2) ENDIF 1800 CONTINUE DIST=SQRT((X0-XIP(M,I))**2+(Y0-YIP(M,I))**2) DX=DIST/NPIECE IF (DX.EQ.0.0) THEN CORREC=0.0 GO TO 1999 ENDIF TSUM=0. STUCK=.FALSE. DO 1850 J=1,NPIECE IF (VMAG(J).GT.0.0) THEN TSUM=TSUM+DX/VMAG(J) ELSE STUCK=.TRUE. ENDIF 1850 CONTINUE IF (STUCK) THEN DO 1860 J=1,NPIECE DELT(J)=DELTAT/NPIECE 1860 CONTINUE ELSE DO 1870 J=1,NPIECE DELT(J)=DELTAT*DX/(VMAG(J)*TSUM) 1870 CONTINUE ENDIF C C PERFORM INTEGRATION OF RELATIVE AREA C DILATE=1.00 DO 1900 J=1,NPIECE DILATE=DILATE*EXP(DILRAT(J)*DELT(J)) 1900 CONTINUE DILATE=MAX(DILATE,0.25) FNEW=FTEMP/DILATE CORREC=FNEW-FOLD C C NOTE: ONLY CRUSTAL LAYER CAN BE THICKENED BY SIMPLE C SHEAR, BECAUSE MANTLE LAYER IS SHEARED ONLY BY SLAB, C AND ANY MANTLE MATERIAL ATTACHED TO SLAB WILL STAY C STUCK AND SUBDUCT, BUT ANY CRUSTAL MATERIAL WILL FLOAT. C 1999 IF (.NOT.CRUST) CORREC=MIN(CORREC,0.0) THIK(M,I)=CORREC 2000 CONTINUE 2001 CONTINUE LOCKIN=.FALSE. LOCKWC=.FALSE. CALL EXTRAP (AREA,CODE,DETJ,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,THIK,LWORK, + LOCKIN,LOCKWC) IF (CRUST) THEN C C SCALE CHANGES IF NECESSARY TO CONSERVE TOTAL QUANTITY C (NOTE: ONLY APPROPRIATE WITH NO-FLUX BOUNDARY CONDITIONS) C CALL INTERP (CONDNS,NODES,NUMEL,NUMNOD,THIK) CALL VOLUME (INPUT,AREA,DETJ,NUMEL,.FALSE.,THIK, + OUTPUT,VOLALL) DO 5000 I=1,NUMNOD PHINOD(I)=MAX(CONDNS(I),0.0) 5000 CONTINUE CALL INTERP (PHINOD,NODES,NUMEL,NUMNOD,OUTSCA) CALL VOLUME (INPUT,AREA,DETJ,NUMEL,.FALSE.,OUTSCA, + OUTPUT,VOLPOS) VOLNEG=VOLALL-VOLPOS IF (VOLPOS.GT.ABS(VOLNEG)) THEN FACPOS=ABS(VOLNEG)/MAX(VOLPOS,1.) FACNEG=1. ELSE FACNEG=VOLPOS/MAX(ABS(VOLNEG),1.) FACPOS=1. ENDIF DO 5500 I=1,NUMNOD IF (CONDNS(I).GE.0.0) THEN CONDNS(I)=CONDNS(I)*FACPOS ELSE CONDNS(I)=CONDNS(I)*FACNEG ENDIF 5500 CONTINUE ENDIF C C FINALLY APPLY CHANGES C DO 6000 I=1,NUMNOD THNK(I)=THNK(I)+CONDNS(I) THNK(I)=MIN(THNK(I),HMX) THNK(I)=MAX(THNK(I),HMN) 6000 CONTINUE CALL INTERP (THNK,NODES,NUMEL,NUMNOD,THIK) DO 6200 M=1,7 DO 6100 I=1,NUMEL THIK(M,I)=MIN(THIK(M,I),HMX) THIK(M,I)=MAX(THIK(M,I),HMN) 6100 CONTINUE 6200 CONTINUE RETURN END C C C SUBROUTINE PANCAK (INPUT, ACREEP,ALPHAT,AREA,BCREEP,CCREEP, + DCREEP,DELV,DETJ, + ECREEP,G,GEOTH,HMAX,HMIN, + MAXTEP,NCOLN,NDIFF,NODES, + NROWN,NUMEL,NUMNOD, + ONEKM,RHOAST,RHOBAR,SIGHC,SIGZZ, + TIME,TEMLIM,XNOD,YNOD, + MODIFY,CONINT,CONNOD,THIK,THNK, + WORK, C,CODE,CONDNS,CONSAV,DRAGN,E,ES,FLOWIN, + GEONOD,GRADXC,GRADXE,GRADXW,GRADYC, + GRADYN,GRADYS,LWORK, + N,NCDIM,NRD,NRDP1,NS,NXL,OUTSCA, + PK,PRHOCP,PRCFD,P0,P1,P2, + S,SHEARN,SS,THNSAV,W,WS,XFD,YFD) C C SMOOTH THE THICKNESS OF THE CRUST BY DETERMINING COEFFICIENTS C FOR POISEUILLE EXTRUSION FLOW, AND APPLYING THEM IN AN C EXPLICIT FINITE-DIFFERENCE SCHEME. C SUBPROGRAM PWAZUL, CALLED TO DETERMINE THE FLUX COEFFICIENTS, C IS SLOW. THUS IT IS CALLED ONLY 4 TIMES PER NODE, AND C APPROXIMATE SCALING LAWS ARE USED TO ESTIMATE THE NEW C COEFFICIENTS AS DIFFUSION PROCEEDS. C REAL MINSTP,N,NS DOUBLE PRECISION CODE,FLOWIN, + FLPMAG,FLPMUC,FLXMAG,FLXMUC LOGICAL DONE,FAILUR,LOCKIN,LOCKWC DIMENSION ACREEP(3),ALPHAT(2),AREA(NUMEL),BCREEP(3),C(NRD,NRD), 2 CCREEP(3),CODE(NCDIM),CONDNS(NUMNOD),CONINT(7,NUMEL), 3 CONNOD(NUMNOD),CONSAV(NUMNOD), 4 DCREEP(3),DELV(2,7,NUMEL),DETJ(7,NUMEL), 5 DRAGN(2,NRD,NRD),E(NRD,NRD),ECREEP(3),ES(NRD,NRD), 6 FLOWIN(NUMNOD),GEONOD(4,NRD,NRD),GEOTH(4,7,NUMEL), 7 GRADXC(NRD,NRD),GRADXE(NRD,NRD),GRADXW(NRD,NRD), 8 GRADYC(NRD,NRD),GRADYN(NRD,NRD),GRADYS(NRD,NRD), 9 HMAX(2),HMIN(2), A LWORK(NXL),N(NRD,NRD),NS(NRD,NRD),NODES(6,0:NUMEL), 1 OUTSCA(7,NUMEL),PK(2,5,0:NRDP1,0:NRDP1), 2 PRHOCP(7,NUMEL),PRCFD(NRD,NRD), 3 P0(0:NRDP1,0:NRDP1),P1(0:NRDP1,0:NRDP1), 4 P2(0:NRDP1,0:NRDP1), 5 RHOBAR(2),S(NRD,NRD),SHEARN(2,NRD,NRD), 6 SIGHC(2,7,NUMEL),SIGZZ(7,NUMEL),SS(NRD,NRD), 7 TEMLIM(2),THIK(7,NUMEL),THNK(NUMNOD),THNSAV(NUMNOD), 8 W(NRD,NRD),WS(NRD,NRD), 9 XFD(NRD,NRD),XNOD(NUMNOD), B YFD(NRD,NRD),YNOD(NUMNOD) DIMENSION FLIST(5),FNEWS(5),PKLIST(5),PKNEWS(5) DATA ACCURA/0.02/,BIGNUM/3.E38/ C TEMP(Z,M,I)=MAX(200.,MIN(TEMLIM(1),GEOTH(1,M,I) + +GEOTH(2,M,I)*Z + +GEOTH(3,M,I)*Z**2 + +GEOTH(4,M,I)*Z**3)) C NPREF=0.25/ACCURA C DH=0.01*ONEKM DX=SQRT((XNOD(NUMNOD)-XNOD(NUMNOD-1))**2+ + (YNOD(NUMNOD)-YNOD(NUMNOD-1))**2) GPMIN=RHOBAR(1)*G*DH/DX GP2MIN=GPMIN**2 C LOCKIN=.FALSE. LOCKWC=.FALSE. C NOTE: THIS CALL MUST BE FIRST, ELSE IT WIPES OUT VALUES IN WORK C ARRAYS THAT ARE EQUIVALENCED TO CODE IN THE MAIN PROGRAM! CALL EXTRAP (AREA,CODE,DETJ,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,SIGZZ,LWORK, + LOCKIN,LOCKWC) C C DO 100 K=1,NUMNOD CONSAV(K)=CONNOD(K) THNSAV(K)=THNK(K) 100 CONTINUE C C DO 200 K=1,2 DO 170 M=1,7 DO 160 I=1,NUMEL PRHOCP(M,I)=DELV(K,M,I) 160 CONTINUE 170 CONTINUE CALL FETOFD (INPUT,NCOLN,NODES,NRD,NRDP1, + NROWN,NUMEL,NUMNOD, + PRHOCP,CONDNS,XNOD,YNOD, + OUTPUT,PRCFD,P0,XFD,YFD) DO 190 I=1,NROWN DO 180 J=1,NCOLN DRAGN(K,I,J)=PRCFD(I,J) 180 CONTINUE 190 CONTINUE 200 CONTINUE C C DO 300 K=1,2 DO 270 M=1,7 DO 260 I=1,NUMEL PRHOCP(M,I)=SIGHC(K,M,I) 260 CONTINUE 270 CONTINUE CALL FETOFD (INPUT,NCOLN,NODES,NRD,NRDP1, + NROWN,NUMEL,NUMNOD, + PRHOCP,CONDNS,XNOD,YNOD, + OUTPUT,PRCFD,P0,XFD,YFD) DO 290 I=1,NROWN DO 280 J=1,NCOLN SHEARN(K,I,J)=PRCFD(I,J) 280 CONTINUE 290 CONTINUE 300 CONTINUE C C DO 400 K=1,4 DO 370 M=1,7 DO 360 I=1,NUMEL PRHOCP(M,I)=GEOTH(K,M,I) 360 CONTINUE 370 CONTINUE CALL FETOFD (INPUT,NCOLN,NODES,NRD,NRDP1, + NROWN,NUMEL,NUMNOD, + PRHOCP,CONDNS,XNOD,YNOD, + OUTPUT,PRCFD,P0,XFD,YFD) DO 390 I=1,NROWN DO 380 J=1,NCOLN GEONOD(K,I,J)=PRCFD(I,J) 380 CONTINUE 390 CONTINUE 400 CONTINUE C C DO 500 M=1,7 DO 490 I=1,NUMEL TMOHO=TEMP(THIK(M,I),M,I) RHOMOH=RHOBAR(1)*(1.-ALPHAT(1)*TMOHO) RHOMOH=MIN(RHOMOH,0.9*RHOAST) PRHOCP(M,I)=1.00/(G*(RHOAST-RHOMOH)) 490 CONTINUE 500 CONTINUE CALL FETOFD (INPUT,NCOLN,NODES,NRD,NRDP1,NROWN,NUMEL,NUMNOD, + PRHOCP,CONDNS,XNOD,YNOD, + OUTPUT,PRCFD,P0,XFD,YFD) C C DO 560 I=2,NROWN-1 DO 550 J=2,NCOLN-1 DXP=SQRT((XFD(I,J+1)-XFD(I,J))**2+ + (YFD(I,J+1)-YFD(I,J))**2) DXM=SQRT((XFD(I,J)-XFD(I,J-1))**2+ + (YFD(I,J)-YFD(I,J-1))**2) DYP=SQRT((YFD(I-1,J)-YFD(I,J))**2+ + (XFD(I-1,J)-XFD(I,J))**2) DYM=SQRT((YFD(I,J)-YFD(I+1,J))**2+ + (XFD(I,J)-XFD(I+1,J))**2) GRADXW(I,J)=-1./(DXP+DXM) GRADXC(I,J)=0. GRADXE(I,J)=+1./(DXP+DXM) GRADYN(I,J)=+1./(DYP+DYM) GRADYC(I,J)=0. GRADYS(I,J)=-1./(DYP+DYM) NS(I,J)=(2.0/PRCFD(I,J))* + ((1./DYP)/(DYP+DYM)) ES(I,J)=(2.0/PRCFD(I,J))* + ((1./DXP)/(DXP+DXM)) SS(I,J)=(2.0/PRCFD(I,J))* + ((1./DYM)/(DYP+DYM)) WS(I,J)=(2.0/PRCFD(I,J))* + ((1./DXM)/(DXP+DXM)) 550 CONTINUE 560 CONTINUE I=1 DO 570 J=2,NCOLN-1 DXP=SQRT((XFD(I,J+1)-XFD(I,J))**2+ + (YFD(I,J+1)-YFD(I,J))**2) DXM=SQRT((XFD(I,J)-XFD(I,J-1))**2+ + (YFD(I,J)-YFD(I,J-1))**2) DYM=SQRT((YFD(I,J)-YFD(I+1,J))**2+ + (XFD(I,J)-XFD(I+1,J))**2) GRADXW(I,J)=-1./(DXP+DXM) GRADXC(I,J)=0. GRADXE(I,J)=+1./(DXP+DXM) GRADYN(I,J)=0. GRADYC(I,J)=+1./DYM GRADYS(I,J)=-1./DYM NS(I,J)=0.0 ES(I,J)=(2.0/PRCFD(I,J))* + ((1./DXP)/(DXP+DXM)) SS(I,J)=(2.0/PRCFD(I,J))* + 1./DYM**2 WS(I,J)=(2.0/PRCFD(I,J))* + ((1./DXM)/(DXP+DXM)) 570 CONTINUE I=NROWN DO 580 J=2,NCOLN-1 DXP=SQRT((XFD(I,J+1)-XFD(I,J))**2+ + (YFD(I,J+1)-YFD(I,J))**2) DXM=SQRT((XFD(I,J)-XFD(I,J-1))**2+ + (YFD(I,J)-YFD(I,J-1))**2) DYP=SQRT((YFD(I-1,J)-YFD(I,J))**2+ + (XFD(I-1,J)-XFD(I,J))**2) GRADXW(I,J)=-1./(DXP+DXM) GRADXC(I,J)=0. GRADXE(I,J)=+1./(DXP+DXM) GRADYN(I,J)=+1./DYP GRADYC(I,J)=-1./DYP GRADYS(I,J)=0. NS(I,J)=(2.0/PRCFD(I,J))* + 1./DYP**2 ES(I,J)=(2.0/PRCFD(I,J))* + ((1./DXP)/(DXP+DXM)) SS(I,J)=0.0 WS(I,J)=(2.0/PRCFD(I,J))* + ((1./DXM)/(DXP+DXM)) 580 CONTINUE J=1 DO 590 I=2,NROWN-1 DXP=SQRT((XFD(I,J+1)-XFD(I,J))**2+ + (YFD(I,J+1)-YFD(I,J))**2) DYP=SQRT((YFD(I-1,J)-YFD(I,J))**2+ + (XFD(I-1,J)-XFD(I,J))**2) DYM=SQRT((YFD(I,J)-YFD(I+1,J))**2+ + (XFD(I,J)-XFD(I+1,J))**2) GRADXW(I,J)=0. GRADXC(I,J)=-1./DXP GRADXE(I,J)=+1./DXP GRADYN(I,J)=+1./(DYP+DYM) GRADYC(I,J)=0. GRADYS(I,J)=-1./(DYP+DYM) NS(I,J)=(2.0/PRCFD(I,J))* + ((1./DYP)/(DYP+DYM)) ES(I,J)=(2.0/PRCFD(I,J))* + 1./DXP**2 SS(I,J)=(2.0/PRCFD(I,J))* + ((1./DYM)/(DYP+DYM)) WS(I,J)=0.0 590 CONTINUE J=NCOLN DO 600 I=2,NROWN-1 DXM=SQRT((XFD(I,J)-XFD(I,J-1))**2+ + (YFD(I,J)-YFD(I,J-1))**2) DYP=SQRT((YFD(I-1,J)-YFD(I,J))**2+ + (XFD(I-1,J)-XFD(I,J))**2) DYM=SQRT((YFD(I,J)-YFD(I+1,J))**2+ + (XFD(I,J)-XFD(I+1,J))**2) GRADXW(I,J)=-1./DXM GRADXC(I,J)=+1./DXM GRADXE(I,J)=0. GRADYN(I,J)=+1./(DYP+DYM) GRADYC(I,J)=0. GRADYS(I,J)=-1./(DYP+DYM) NS(I,J)=(2.0/PRCFD(I,J))* + ((1./DYP)/(DYP+DYM)) ES(I,J)=0.0 SS(I,J)=(2.0/PRCFD(I,J))* + ((1./DYM)/(DYP+DYM)) WS(I,J)=(2.0/PRCFD(I,J))* + 1./DXM**2 600 CONTINUE I=1 J=1 DXP=SQRT((XFD(I,J+1)-XFD(I,J))**2+ + (YFD(I,J+1)-YFD(I,J))**2) DYM=SQRT((YFD(I,J)-YFD(I+1,J))**2+ + (XFD(I,J)-XFD(I+1,J))**2) GRADXW(I,J)=0. GRADXC(I,J)=-1./DXP GRADXE(I,J)=+1./DXP GRADYN(I,J)=0. GRADYC(I,J)=+1./DYM GRADYS(I,J)=-1./DYM NS(I,J)=0.0 ES(I,J)=(2.0/PRCFD(I,J))* + 1./DXP**2 SS(I,J)=(2.0/PRCFD(I,J))* + 1./DYM**2 WS(I,J)=0.0 I=NROWN J=1 DXP=SQRT((XFD(I,J+1)-XFD(I,J))**2+ + (YFD(I,J+1)-YFD(I,J))**2) DYP=SQRT((YFD(I-1,J)-YFD(I,J))**2+ + (XFD(I-1,J)-XFD(I,J))**2) GRADXW(I,J)=0. GRADXC(I,J)=-1./DXP GRADXE(I,J)=+1./DXP GRADYN(I,J)=+1./DYP GRADYC(I,J)=-1./DYP GRADYS(I,J)=0. NS(I,J)=(2.0/PRCFD(I,J))* + 1./DYP**2 ES(I,J)=(2.0/PRCFD(I,J))* + 1./DXP**2 SS(I,J)=0.0 WS(I,J)=0.0 I=NROWN J=NCOLN DXM=SQRT((XFD(I,J)-XFD(I,J-1))**2+ + (YFD(I,J)-YFD(I,J-1))**2) DYP=SQRT((YFD(I-1,J)-YFD(I,J))**2+ + (XFD(I-1,J)-XFD(I,J))**2) GRADXW(I,J)=-1./DXM GRADXC(I,J)=+1./DXM GRADXE(I,J)=0. GRADYN(I,J)=+1./DYP GRADYC(I,J)=-1./DYP GRADYS(I,J)=0. NS(I,J)=(2.0/PRCFD(I,J))* + 1./DYP**2 ES(I,J)=0.0 SS(I,J)=0.0 WS(I,J)=(2.0/PRCFD(I,J))* + 1./DXM**2 I=1 J=NCOLN DXM=SQRT((XFD(I,J)-XFD(I,J-1))**2+ + (YFD(I,J)-YFD(I,J-1))**2) DYM=SQRT((YFD(I,J)-YFD(I+1,J))**2+ + (XFD(I,J)-XFD(I+1,J))**2) GRADXW(I,J)=-1./DXM GRADXC(I,J)=+1./DXM GRADXE(I,J)=0. GRADYN(I,J)=0. GRADYC(I,J)=+1./DYM GRADYS(I,J)=-1./DYM NS(I,J)=0.0 ES(I,J)=0.0 SS(I,J)=(2.0/PRCFD(I,J))* + 1./DYM**2 WS(I,J)=(2.0/PRCFD(I,J))* + 1./DXM**2 C C DO 650 J=0,NCOLN+1 P0(0 ,J)=0. P0(NROWN+1,J)=0. P1(0 ,J)=0. P1(NROWN+1,J)=0. P2(0 ,J)=0. P2(NROWN+1,J)=0. PK(1,1,0 ,J)=0. PK(1,1,NROWN+1,J)=0. PK(2,1,0 ,J)=0. PK(2,1,NROWN+1,J)=0. 650 CONTINUE DO 700 I=0,NROWN+1 P0(I,0 )=0. P0(I,NCOLN+1)=0. P1(I,0 )=0. P1(I,NCOLN+1)=0. P2(I,0 )=0. P2(I,NCOLN+1)=0. PK(1,1,I,0 )=0. PK(1,1,I,NCOLN+1)=0. PK(2,1,I,0 )=0. PK(2,1,I,NCOLN+1)=0. 700 CONTINUE C C DO 1000 I=1,NROWN DO 900 J=1,NCOLN K=(I-1)*NCOLN+J CONRAD=CONNOD(K) DVX=DRAGN(1,I,J) DVY=DRAGN(2,I,J) GEOTH1=GEONOD(1,I,J) GEOTH2=GEONOD(2,I,J) GEOTH3=GEONOD(3,I,J) GEOTH4=GEONOD(4,I,J) GRADPX=GRADXW(I,J)*P0(I,J-1)+GRADXC(I,J)*P0(I,J)+ + GRADXE(I,J)*P0(I,J+1) GRADPY=GRADYN(I,J)*P0(I-1,J)+GRADYC(I,J)*P0(I,J)+ + GRADYS(I,J)*P0(I+1,J) GRADP=SQRT(GRADPX**2+GRADPY**2) IF (GRADP.LT.GPMIN) THEN GRADPX=GPMIN GRADPY=0. GRADP=GRADPX ENDIF SIGHX=SHEARN(1,I,J) SIGHY=SHEARN(2,I,J) THICK=THNK(K) CALL PWAZUL (INPUT,ACREEP,BCREEP,CCREEP,CONRAD,DCREEP, + DVX,DVY,ECREEP,GEOTH1,GEOTH2,GEOTH3, + GEOTH4,GRADPX,GRADPY, + TEMLIM(1),THICK, + MODIFY,SIGHX,SIGHY, + OUTPUT,FLXMAG,FLXMUC) PRADPX=0.5*GRADPX PRADPY=0.5*GRADPY SIGHX=SHEARN(1,I,J) SIGHY=SHEARN(2,I,J) CALL PWAZUL (INPUT,ACREEP,BCREEP,CCREEP,CONRAD,DCREEP, + DVX,DVY,ECREEP,GEOTH1,GEOTH2,GEOTH3, + GEOTH4,PRADPX,PRADPY, + TEMLIM(1),THICK, + MODIFY,SIGHX,SIGHY, + OUTPUT,FLPMAG,FLPMUC) FLPMAG=MAX(FLPMAG,1.D-70) FLPMUC=MAX(FLPMUC,1.D-70) PEXP=LOG(FLPMAG/MAX(FLXMAG,1.D-70))/LOG(0.5) PEXPUC=LOG(FLPMUC/MAX(FLXMUC,1.D-70))/LOG(0.5) PEXP=MAX(PEXP,1.0) PEXPUC=MAX(PEXPUC,1.0) PEXP=MIN(PEXP,1./ECREEP(1)) PEXPUC=MIN(PEXPUC,1./ECREEP(1)) IF (THICK.GT.CONRAD.AND.CONRAD.GT.0.) THEN SIGHX=SHEARN(1,I,J) SIGHY=SHEARN(2,I,J) IF (THICK.GT.(CONRAD+5.*ONEKM)) THEN CONRDP=CONRAD+ONEKM CALL PWAZUL (INPUT,ACREEP,BCREEP, + CCREEP,CONRDP,DCREEP, + DVX,DVY,ECREEP, + GEOTH1,GEOTH2,GEOTH3, + GEOTH4,GRADPX,GRADPY, + TEMLIM(1),THICK, + MODIFY,SIGHX,SIGHY, + OUTPUT,FLPMAG,FLPMUC) FCOWC=FLPMAG/MAX(FLXMAG,1.D-70) FCOUC=FLPMUC/MAX(FLXMUC,1.D-70) ELSE CONRDP=CONRAD-ONEKM CALL PWAZUL (INPUT,ACREEP,BCREEP, + CCREEP,CONRDP,DCREEP, + DVX,DVY,ECREEP, + GEOTH1,GEOTH2,GEOTH3, + GEOTH4,GRADPX,GRADPY, + TEMLIM(1),THICK, + MODIFY,SIGHX,SIGHY, + OUTPUT,FLPMAG,FLPMUC) FCOWC=FLXMAG/MAX(FLPMAG,1.D-70) FCOUC=FLXMUC/MAX(FLPMUC,1.D-70) END IF FCOWC=MAX(0.50,MIN(2.0,FCOWC)) FCOUC=MAX(0.50,MIN(2.0,FCOUC)) ELSE FCOWC=1.00 FCOUC=1.00 ENDIF THICKP=THICK+ONEKM TMOHO=GEOTH1+GEOTH2*THICK+GEOTH3*THICK**2+ + GEOTH4*THICK**3 TMOHP=GEOTH1+GEOTH2*THICKP+GEOTH3*THICKP**2+ + GEOTH4*THICKP**3 PEOTH4=GEOTH4+(TMOHO-TMOHP)/THICKP**3 SIGHX=SHEARN(1,I,J) SIGHY=SHEARN(2,I,J) CALL PWAZUL (INPUT,ACREEP,BCREEP,CCREEP,CONRAD,DCREEP, + DVX,DVY,ECREEP,GEOTH1,GEOTH2,GEOTH3, + PEOTH4,GRADPX,GRADPY, + TEMLIM(1),THICKP, + MODIFY,SIGHX,SIGHY, + OUTPUT,FLPMAG,FLPMUC) FMOWC=FLPMAG/MAX(FLXMAG,1.D-70) FMOUC=FLPMUC/MAX(FLXMUC,1.D-70) FMOWC=MAX(0.50,MIN(2.0,FMOWC)) FMOUC=MAX(0.50,MIN(2.0,FMOUC)) PK(1,2,I,J)=MIN(1.D30,FLXMAG/GRADP**PEXP) PK(2,2,I,J)=MIN(1.D30,FLXMUC/GRADP**PEXPUC) PK(1,3,I,J)=0.5*(PEXP-1.) PK(2,3,I,J)=0.5*(PEXPUC-1.) PK(1,4,I,J)=FMOWC PK(2,4,I,J)=FMOUC PK(1,5,I,J)=FCOWC PK(2,5,I,J)=FCOUC 900 CONTINUE 1000 CONTINUE C C TLEFT=TIME MOSTLM=0 BIGLIM=1.00 BADACC=ACCURA C C BEGIN LOOP ON SMALL INTERNAL TIMESTEPS C DO 4000 ISTEP=0,MAXTEP-2,2 C C DETERMINE GRAD-P AND BOTH SETS OF FLUX COEFFICIENTS C DO 1200 I=1,NROWN DO 1100 J=1,NCOLN K=(I-1)*NCOLN+J GRADPX=GRADXW(I,J)*P0(I,J-1)+GRADXC(I,J)*P0(I,J)+ + GRADXE(I,J)*P0(I,J+1) GRADPY=GRADYN(I,J)*P0(I-1,J)+GRADYC(I,J)*P0(I,J)+ + GRADYS(I,J)*P0(I+1,J) GRADP2=GRADPX**2+GRADPY**2 GRADP2=MAX(GRADP2,GP2MIN) PK(1,1,I,J)=PK(1,2,I,J)*GRADP2**PK(1,3,I,J)* + PK(1,4,I,J)**((THNK(K)-THNSAV(K))/ONEKM)* + PK(1,5,I,J)**((CONNOD(K)-CONSAV(K))/ONEKM) PK(2,1,I,J)=PK(2,2,I,J)*GRADP2**PK(2,3,I,J)* + PK(2,4,I,J)**((THNK(K)-THNSAV(K))/ONEKM)* + PK(2,5,I,J)**((CONNOD(K)-CONSAV(K))/ONEKM) PK(2,1,I,J)=MIN(PK(2,1,I,J),PK(1,1,I,J)) 1100 CONTINUE 1200 CONTINUE C C COMPUTE THE WHOLE-CRUST COEFFICIENTS, AND LIMIT IF NESC. C DO 1300 I=1,NROWN DO 1290 J=1,NCOLN N(I,J)=NS(I,J)*0.5*(PK(1,1,I,J)+PK(1,1,I-1,J)) E(I,J)=ES(I,J)*0.5*(PK(1,1,I,J)+PK(1,1,I,J+1)) S(I,J)=SS(I,J)*0.5*(PK(1,1,I,J)+PK(1,1,I+1,J)) W(I,J)=WS(I,J)*0.5*(PK(1,1,I,J)+PK(1,1,I,J-1)) 1290 CONTINUE 1300 CONTINUE C C WORST=0.0 DO 1400 I=1,NROWN DO 1390 J=1,NCOLN TEST=N(I,J)+E(I,J)+W(I,J)+S(I,J) WORST=MAX(WORST,TEST) 1390 CONTINUE 1400 CONTINUE DTMAX=0.5/WORST MINSTP=TLEFT/DTMAX IF (MINSTP.GT.REAL(MAXTEP-ISTEP)) THEN NSTEP=MAXTEP-ISTEP WORST=NSTEP/(2.*TLEFT) PKLIM=BIGNUM DO 1500 IR=1,NROWN DO 1490 JC=1,NCOLN TEST=N(IR,JC)+E(IR,JC)+W(IR,JC)+S(IR,JC) IF (TEST.GT.WORST) THEN PKNEWS(1)=PK(1,1,IR,JC) FNEWS(1)=0.5*(NS(IR,JC)+ES(IR,JC)+ + WS(IR,JC)+SS(IR,JC)) PKNEWS(2)=PK(1,1,IR-1,JC) FNEWS(2)=0.5*NS(IR,JC) PKNEWS(3)=PK(1,1,IR,JC+1) FNEWS(3)=0.5*ES(IR,JC) PKNEWS(4)=PK(1,1,IR,JC-1) FNEWS(4)=0.5*WS(IR,JC) PKNEWS(5)=PK(1,1,IR+1,JC) FNEWS(5)=0.5*SS(IR,JC) DO 1450 K=1,5 BIGGES=MAX(PKNEWS(1),PKNEWS(2), + PKNEWS(3),PKNEWS(4), + PKNEWS(5)) APART=BIGNUM DO 1430 L=1,5 TEST=ABS(PKNEWS(L)-BIGGES) IF (TEST.LT.APART) THEN KP=L APART=TEST ENDIF 1430 CONTINUE PKLIST(K)=PKNEWS(KP) FLIST(K)=FNEWS(KP) PKNEWS(KP)= -BIGNUM 1450 CONTINUE BUDGET=WORST TMPLIM=BUDGET/(NS(IR,JC)+ES(IR,JC)+ + WS(IR,JC)+SS(IR,JC)) IF (TMPLIM.GT.PKLIST(5)) THEN BUDGET=BUDGET-PKLIST(5)* + (NS(IR,JC)+ES(IR,JC)+ + WS(IR,JC)+SS(IR,JC)) TMPLIM=PKLIST(5)+BUDGET/ + (FLIST(1)+FLIST(2)+ + FLIST(3)+FLIST(4)) ENDIF IF (TMPLIM.GT.PKLIST(4)) THEN BUDGET=BUDGET-(PKLIST(4)-PKLIST(5))* + (FLIST(1)+FLIST(2)+ + FLIST(3)+FLIST(4)) TMPLIM=PKLIST(4)+BUDGET/ + (FLIST(1)+FLIST(2)+ + FLIST(3)) ENDIF IF (TMPLIM.GT.PKLIST(3)) THEN BUDGET=BUDGET-(PKLIST(3)-PKLIST(4))* + (FLIST(1)+FLIST(2)+ + FLIST(3)) TMPLIM=PKLIST(3)+BUDGET/ + (FLIST(1)+FLIST(2)) ENDIF IF (TMPLIM.GT.PKLIST(2)) THEN BUDGET=BUDGET-(PKLIST(2)-PKLIST(3))* + (FLIST(1)+FLIST(2)) TMPLIM=PKLIST(2)+BUDGET/FLIST(1) ENDIF PKLIM=MIN(PKLIM,TMPLIM) ENDIF 1490 CONTINUE 1500 CONTINUE C C APPLY THE LIMIT C NLIMIT=0 HOWLIM=1.00 DO 1600 JC=1,NCOLN DO 1590 IR=1,NROWN IF (PK(1,1,IR,JC).GT.PKLIM) THEN NLIMIT=NLIMIT+1 HOWLIM=MIN(HOWLIM,(PKLIM/PK(1,1,IR,JC))) PK(1,1,IR,JC)=PKLIM ENDIF PK(2,1,IR,JC)=MIN(PK(2,1,IR,JC),PKLIM) 1590 CONTINUE 1600 CONTINUE MOSTLM=MAX(MOSTLM,NLIMIT) BIGLIM=MIN(BIGLIM,HOWLIM) ELSE IF ((NPREF*MINSTP).GT.DBLE(MAXTEP-ISTEP)) THEN NSTEP=MAXTEP-ISTEP ACC=ACCURA*(NPREF*MINSTP)/NSTEP BADACC=MAX(BADACC,ACC) ELSE NSTEP=MAX(2.01,(NPREF*MINSTP)+0.5) ENDIF NITER=NSTEP/2 NSTEP=NITER*2 DELTAT=TLEFT/NSTEP DONE=NITER.LE.1 C C CALCULATION WITH UPPER-CRUST FLUXES TO MODIFY CONRAD C DO 1700 I=1,NROWN DO 1690 J=1,NCOLN N(I,J)=NS(I,J)*0.5*(PK(2,1,I,J)+PK(2,1,I-1,J))* + DELTAT E(I,J)=ES(I,J)*0.5*(PK(2,1,I,J)+PK(2,1,I,J+1))* + DELTAT S(I,J)=SS(I,J)*0.5*(PK(2,1,I,J)+PK(2,1,I+1,J))* + DELTAT W(I,J)=WS(I,J)*0.5*(PK(2,1,I,J)+PK(2,1,I,J-1))* + DELTAT N(I,J)=MIN(N(I,J),0.49) E(I,J)=MIN(E(I,J),0.49) S(I,J)=MIN(S(I,J),0.49) W(I,J)=MIN(W(I,J),0.49) 1690 CONTINUE 1700 CONTINUE DO 1800 I=1,NROWN DO 1790 J=1,NCOLN C(I,J)=1.00-N(I,J)-E(I,J)-S(I,J)-W(I,J) 1790 CONTINUE 1800 CONTINUE C C DO 1900 I=1,NROWN DO 1890 J=1,NCOLN P2(I,J)=P0(I,J) 1890 CONTINUE 1900 CONTINUE C C CALL TWOTIM (INPUT, C,N,S,E,W,NRD,NRDP1,NCOLN,NROWN, + MODIFY,P0, + WORK, P1) C C DO 2000 I=1,NROWN DO 1990 J=1,NCOLN K=(I-1)*NCOLN+J CONNOD(K)=CONNOD(K)+(P0(I,J)-P2(I,J))*PRCFD(I,J) 1990 CONTINUE 2000 CONTINUE C C CALCULATION WITH WHOLE-CRUST COEFFICIENTS TO MODIFY MOHO C DO 2700 I=1,NROWN DO 2690 J=1,NCOLN N(I,J)=NS(I,J)*0.5*(PK(1,1,I,J)+PK(1,1,I-1,J))* + DELTAT E(I,J)=ES(I,J)*0.5*(PK(1,1,I,J)+PK(1,1,I,J+1))* + DELTAT S(I,J)=SS(I,J)*0.5*(PK(1,1,I,J)+PK(1,1,I+1,J))* + DELTAT W(I,J)=WS(I,J)*0.5*(PK(1,1,I,J)+PK(1,1,I,J-1))* + DELTAT N(I,J)=MIN(N(I,J),0.49) E(I,J)=MIN(E(I,J),0.49) S(I,J)=MIN(S(I,J),0.49) W(I,J)=MIN(W(I,J),0.49) 2690 CONTINUE 2700 CONTINUE DO 2800 I=1,NROWN DO 2790 J=1,NCOLN C(I,J)=1.00-N(I,J)-E(I,J)-S(I,J)-W(I,J) 2790 CONTINUE 2800 CONTINUE C C DO 2900 I=1,NROWN DO 2890 J=1,NCOLN P0(I,J)=P2(I,J) 2890 CONTINUE 2900 CONTINUE C C CALL TWOTIM (INPUT, C,N,S,E,W,NRD,NRDP1,NCOLN,NROWN, + MODIFY,P0, + WORK, P1) C C DO 3000 I=1,NROWN DO 2990 J=1,NCOLN K=(I-1)*NCOLN+J THNK(K)=THNK(K)+(P0(I,J)-P2(I,J))*PRCFD(I,J) 2990 CONTINUE 3000 CONTINUE C C IF (DONE) GO TO 4001 TLEFT=TLEFT-DELTAT-DELTAT IF (TLEFT.LE.0.) GO TO 4001 4000 CONTINUE 4001 CONTINUE C C SCALE MOHO CHANGES IF NECESSARY TO CONSERVE TOTAL QUANTITY C (NOTE: ONLY APPROPRIATE WITH NO-FLUX BOUNDARY CONDITIONS) C DO 4100 I=1,NUMNOD CONDNS(I)=MAX(THNK(I)-THNSAV(I),0.0) 4100 CONTINUE CALL INTERP (CONDNS,NODES,NUMEL,NUMNOD,OUTSCA) CALL VOLUME (INPUT,AREA,DETJ,NUMEL,.FALSE.,OUTSCA, + OUTPUT,VOLPOS) DO 4200 I=1,NUMNOD CONDNS(I)=THNK(I)-THNSAV(I) 4200 CONTINUE CALL INTERP (CONDNS,NODES,NUMEL,NUMNOD,OUTSCA) CALL VOLUME (INPUT,AREA,DETJ,NUMEL,.FALSE.,OUTSCA, + OUTPUT,VOLALL) VOLNEG=VOLALL-VOLPOS IF (VOLPOS.GT.ABS(VOLNEG)) THEN FACPOS=ABS(VOLNEG)/MAX(VOLPOS,1.) FACNEG=1. ELSE FACNEG=VOLPOS/MAX(ABS(VOLNEG),1.) FACPOS=1. ENDIF C C FINALLY APPLY CHANGES TO MOHO C DO 4500 I=1,NUMNOD DELTAM=THNK(I)-THNSAV(I) IF (DELTAM.GT.0.) THEN THNK(I)=THNSAV(I)+DELTAM*FACPOS ELSE THNK(I)=THNSAV(I)+DELTAM*FACNEG ENDIF THNK(I)=MAX(THNK(I),HMIN(1)) THNK(I)=MIN(THNK(I),HMAX(1)) 4500 CONTINUE CALL INTERP (THNK,NODES,NUMEL,NUMNOD,THIK) DO 5000 M=1,7 DO 4900 I=1,NUMEL THIK(M,I)=MAX(THIK(M,I),HMIN(1)) THIK(M,I)=MIN(THIK(M,I),HMAX(1)) 4900 CONTINUE 5000 CONTINUE C C SCALE CONRAD CHANGES IF NECESSARY TO CONSERVE TOTAL QUANTITY C (NOTE: ONLY APPROPRIATE WITH NO-FLUX BOUNDARY CONDITIONS) C DO 5100 I=1,NUMNOD CONDNS(I)=MAX(CONNOD(I)-CONSAV(I),0.0) 5100 CONTINUE CALL INTERP (CONDNS,NODES,NUMEL,NUMNOD,OUTSCA) CALL VOLUME (INPUT,AREA,DETJ,NUMEL,.FALSE.,OUTSCA, + OUTPUT,VOLPOS) DO 5200 I=1,NUMNOD CONDNS(I)=CONNOD(I)-CONSAV(I) 5200 CONTINUE CALL INTERP (CONDNS,NODES,NUMEL,NUMNOD,OUTSCA) CALL VOLUME (INPUT,AREA,DETJ,NUMEL,.FALSE.,OUTSCA, + OUTPUT,VOLALL) VOLNEG=VOLALL-VOLPOS IF (VOLPOS.GT.ABS(VOLNEG)) THEN FACPOS=ABS(VOLNEG)/MAX(VOLPOS,1.) FACNEG=1. ELSE FACNEG=VOLPOS/MAX(ABS(VOLNEG),1.) FACPOS=1. ENDIF C C FINALLY APPLY CHANGES TO CONRAD DISCONTINUITY C DO 5500 I=1,NUMNOD DELTAC=CONNOD(I)-CONSAV(I) IF (DELTAC.GT.0.) THEN CONNOD(I)=CONSAV(I)+DELTAC*FACPOS ELSE CONNOD(I)=CONSAV(I)+DELTAC*FACNEG ENDIF CONNOD(I)=MAX(CONNOD(I),HMIN(1)) CONNOD(I)=MIN(CONNOD(I),HMAX(1),THNK(I)) 5500 CONTINUE CALL INTERP (CONNOD,NODES,NUMEL,NUMNOD,CONINT) DO 6000 M=1,7 DO 5900 I=1,NUMEL CONINT(M,I)=MAX(CONINT(M,I),HMIN(1)) CONINT(M,I)=MIN(CONINT(M,I),HMAX(1),THIK(M,I)) 5900 CONTINUE 6000 CONTINUE C C REPORT SECTION C IF (MOSTLM.GT.0) THEN WRITE(6,9001)MOSTLM,BIGLIM,MAXTEP 9001 FORMAT(' CAUTION: TO PRESERVE STABILITY, SUBPROGRAM PANCAK ', + 'HAD TO REDUCE CONDUCTIVITIES AT ',I10,' NODES' + /' BY FACTORS DOWN TO ',1P,E10.2 + /' MAXIMUM PERMITTED NUMBER OF STEPS (',I10,') ', + 'WAS USED FOR SMOOTHING.') ELSE IF (BADACC.GT.ACCURA) THEN WRITE(6,9002)MAXTEP,BADACC 9002 FORMAT(' SUBPROGRAM PANCAK WAS LIMITED TO ',I10, + ' SMOOTHING STEPS; PRECISION MAY LOCALLY RISE TO ', + F10.6) ELSE ISTEP=ISTEP+2 WRITE(6,9003)ISTEP,ACCURA 9003 FORMAT(' SUBPROGRAM PANCAK USED ',I10,' SMOOTHING STEPS ', + ' TO ACHIEVE DESIRED RMS PRECISION OF ',F10.6) ENDIF RETURN END C C C SUBROUTINE FETOFD (INPUT,NCOLN,NODES,NRD,NRDP1,NROWN,NUMEL, + NUMNOD,PRHOCP,CONDNS,XNOD,YNOD, + OUTPUT,PRCFD,P0,XFD,YFD) C C CONVERTS ARRAYS FROM FINITE-ELEMENT FORMAT USED IN LARAMY C TO FINITE-DIFFERENCE FORMAT USED IN STENCL. C THIS INVOLVES TRANSFERRING VALUES OF PRHOCP AT INTEGRATION C POINTS TO NEW VALUES PRCFD AT NODES; THIS IS THE SAME C FUNCTION THAT EXTRAP PERFORMS, BUT FETOFD DOES IT MUCH C FASTER (AND LESS ACCURATELY). C DIMENSION CONDNS(NUMNOD),NODES(6,0:NUMEL), + PRHOCP(7,NUMEL), + PRCFD(NRD,NCOLN), + P0(0:NRDP1,0:NRDP1), + XFD(NRD,NCOLN),YFD(NRD,NCOLN), + XNOD(NUMNOD),YNOD(NUMNOD) DIMENSION NID0(2:7) DATA (NID0(I),I=2,7)/5,6,4,1,2,3/ C C NOTE: IN THE SECTION THROUGH 100, ARRAYS XFD AND YFD ARE USED FOR C TEMPORARY STORAGE; THE PROPER VALUES ARE SUPPLIED AFTER C LINE 100. C DO 4 IR=1,NROWN DO 2 JC=1,NCOLN PRCFD(IR,JC)=0.0 XFD(IR,JC)=5.E-43 2 CONTINUE 4 CONTINUE DO 20 M=2,7 K=NID0(M) DO 10 I=1,NUMEL NODE=NODES(K,I) IR=1+(NODE-1)/NCOLN JC=NODE-(IR-1)*NCOLN PRCFD(IR,JC)=PRCFD(IR,JC)+PRHOCP(M,I) XFD(IR,JC)=XFD(IR,JC)+1. 10 CONTINUE 20 CONTINUE DO 24 IR=1,NROWN DO 22 JC=1,NCOLN PRCFD(IR,JC)=PRCFD(IR,JC)/XFD(IR,JC) 22 CONTINUE 24 CONTINUE C C DO 120 IROW=1,NROWN DO 110 JCOL=1,NCOLN K=NCOLN*(IROW-1)+JCOL P0(IROW,JCOL)= -CONDNS(K) XFD(IROW,JCOL)=XNOD(K) YFD(IROW,JCOL)=YNOD(K) 110 CONTINUE 120 CONTINUE RETURN END C C C SUBROUTINE PWAZUL (INPUT,ACREEP,BCREEP,CCREEP,CONRAD,DCREEP, + DVX,DVY,ECREEP,GEOTH1,GEOTH2,GEOTH3, + GEOTH4,GRADPX,GRADPY, + TEMLIM,THICK, + MODIFY,SIGHX,SIGHY, + OUTPUT,FLXMAG,FLXMUC) C C FOR LOWER CRUSTAL DEFORMATION IN PRESENCE OF UPPER (0) AND C LOWER (MAY BE NON-0) RELATIVE VELOCITY BOUNDARY CONDITIONS: C CORRECTS VALUE OF BASAL SHEAR VECTOR FOR EFFECT OF PRESSURE C GRADIENT, AND INTEGRATES HORIZONTAL FLUX USING THIS REVISED C VALUE TOGETHER WITH THE PRESSURE GRADIENT, RHEOLOGY, AND C GEOTHERM. C REPORTS AS "FLXMAG" ONLY THE MAGNITUDE OF EXCESS FLUX CAUSED C BY THE PRESSURE GRADIENT, BEYOND ANY DRAGGED FLUX. C RESULT "FLXMUC" IS LIKE "FLXMAG" EXCEPT THAT IT INCLUDES C ONLY THE GRAD-P FLUX ABOVE THE CONRAD DISCONTINUITY, C LIKEWISE IN EXCESS OF DRAG EFFECTS. C INDEPENDENT COMPONENTS OF THE EXCESS FLUXES ARE NOT REPORTED, AS C THESE FLUX VECTORS ARE PARALLEL TO -(GRADPX,GRADPY). C C NOTE THAT "FLXMAG" AND "FLXMUC" ARE BOTH DOUBLE PRECISION C (NECESSARY TO PREVENT UNDERFLOWS OF ESSENTIAL INFORMATION C UNDER COMPILERS WHICH LIMIT REAL'S TO ABOUT .GE. 5.E-43) C PARAMETER (NINT=50,NUE=30,NLB=31) C NOTE: NLB MUST BE = NUE+1; BOTH MUST BE LESS THAN NINT. C LOGICAL DEBUG,LAYERD,WAYOFF DOUBLE PRECISION ACCURA,ACTM3,AMP,ARG,ARGMIN, + C11,C12,C21,C22,CI11,CI12, + CI21,CI22,C11VEC,C12VEC,C22VEC, + DELFLX,DELFLY,DELVX,DELVY,DELVMG,DELVXF,DELVYF, + DET,DFLUX,DSBX,DSBY,DSHEAR, + DSHLIM,DSHLM1,DSHLM2,DSHLM3, + ERATEX,ERATEY, + FACTOR,FLX,FLY, + FLXMAG,FLXMUC,FLXOLD,FLXUC,FLYUC, + RATIO,RSAVE,RESVX,RESVY,RFLUX,RFLXUC, + SBX,SBY,SX,SY,S2,VX,VY DIMENSION ACTM3(2),C11VEC(NINT),C12VEC(NINT),C22VEC(NINT), + ERATEX(NINT),ERATEY(NINT),RSAVE(NINT), + VX(NINT),VY(NINT) DIMENSION ACREEP(3),BCREEP(3),CCREEP(3),DCREEP(3),ECREEP(3) DATA ACCURA/0.001D0/,NUMPWZ/0/,DEBUG/.FALSE./ SAVE NUMPWZ C C STATEMENT FUNCTION: TEMP(A)=MAX(272.,MIN(TEMLIM,GEOTH1 + +GEOTH2*A + +GEOTH3*A**2 + +GEOTH4*A**3)) C NUMPWZ=NUMPWZ+1 IF (DEBUG) THEN WRITE(*,1) NUMPWZ, + CONRAD,THICK,DVX,DVY,GRADPX,GRADPY,SIGHX,SIGHY 1 FORMAT(' PWAZUL CALLED (#',I8,')' + /' CONRAD:',1P,E12.4,' THICK: ',E12.4 + ,' DVX: ',E12.4,' DVY: ',E12.4 + /' GRADPX:',E12.4,' GRADPY:',E12.4 + ,' SIGHX: ',E12.4,' SIGHY: ',E12.4) END IF LAYERD=(CONRAD.LT.(0.99*THICK)).AND.(CONRAD.GT.0.) IF (LAYERD) THEN DZU=CONRAD/NUE DZL=(THICK-CONRAD)/(NINT-NLB) ELSE DZ=THICK/NINT ENDIF C C PRECOMPUTE RHEOLOGICAL CONSTANTS: THREE, TWO, ACTM2(1..2), C AND ARRAY RSAVE(1..NINT) = (D.HORIZON_VELOCITY/D.Z) C ------------------------ C SHEAR_STRESS**THREE C THREE=1./ECREEP(1) TWO=MAX(0.,THREE-1.) ACTM3(1)=ACREEP(1)**(-THREE) IF (LAYERD) THEN ACTM3(2)=ACREEP(2)**(-THREE) ARGMIN= -690.+MAX(0.0D0,-LOG(ACTM3(1)),-LOG(ACTM3(2))) DO 100 N=1,NINT IF (N.LE.NUE) THEN IL=1 Z=N*DZU ELSE IL=2 Z=CONRAD+(N-NLB)*DZL ENDIF T=TEMP(Z) ARG= -THREE*(BCREEP(IL)+CCREEP(IL)*Z)/T ARG=MAX(ARG,ARGMIN) RSAVE(N)=ACTM3(IL)*EXP(ARG) 100 CONTINUE ELSE C NOT LAYERD (BASICALLY ALL ONE MATERIAL) IF (CONRAD.GE.(0.5*THICK)) THEN IL=1 ELSE IL=2 ACTM3(2)=ACREEP(2)**(-THREE) ENDIF ARGMIN= -690.+MAX(0.0D0,-LOG(ACTM3(IL))) DO 101 N=1,NINT Z=N*DZ T=TEMP(Z) ARG= -THREE*(BCREEP(IL)+CCREEP(IL)*Z)/T ARG=MAX(ARG,ARGMIN) RSAVE(N)=ACTM3(IL)*EXP(ARG) 101 CONTINUE ENDIF C C DETERMINATION OF REFERENCE FLUXES WITH GRAD-P = 0 C VX(1)=0.D0 FLX=0. IF (LAYERD) THEN DO 110 N=2,NUE VX(N)=VX(N-1)+DZU*0.5*(RSAVE(N-1)+RSAVE(N)) 110 CONTINUE DO 111 N=1,NUE FLX=FLX+VX(N) 111 CONTINUE FLX=(FLX-0.5*VX(NUE))*DZU FLXUC=FLX VX(NLB)=VX(NUE) DO 112 N=NLB+1,NINT VX(N)=VX(N-1)+DZL*0.5*(RSAVE(N-1)+RSAVE(N)) 112 CONTINUE DO 113 N=NLB,NINT FLX=FLX+VX(N)*DZL 113 CONTINUE FLX=FLX-0.5*(VX(NLB)+VX(NINT))*DZL ELSE DO 114 N=2,NINT VX(N)=VX(N-1)+DZ*0.5*(RSAVE(N-1)+RSAVE(N)) 114 CONTINUE DO 115 N=2,NINT FLX=FLX+VX(N) 115 CONTINUE FLX=(FLX-0.5*VX(NINT))*DZ FLXUC=FLX ENDIF DELVX=DVX DELVY=DVY DELVMG=SQRT(DELVX**2+DELVY**2) IF (DELVMG.GT.0.0D0) THEN DELVXF=DELVX/DELVMG DELVYF=DELVY/DELVMG ELSE DELVXF=1.0D0 DELVYF=0.0D0 RFLUX=0.0D0 RFLXUC=0.0D0 ENDIF IF (VX(NINT).GT.0.0D0) THEN RFLUX=FLX*DELVMG/VX(NINT) RFLXUC=FLXUC*DELVMG/VX(NINT) ELSE RFLUX=0.0D0 RFLXUC=0.0D0 ENDIF C C ACTUAL CASE SOLVED BY NEWTON-METHOD ITERATION: C FLXOLD=1.D30 SBX=SIGHX SBY=SIGHY DSHLM1=SQRT((1.D0*SIGHX)**2+(1.D0*SIGHY)**2) DSHLM2=THICK*SQRT((1.D0*GRADPX)**2+(1.D0*GRADPY)**2) DSHLM3=1.D10 DSHLIM=MAX(DSHLM1,DSHLM2,DSHLM3) DO 300 ITER=1,12 IF (LAYERD) THEN DO 210 N=1,NUE Z=N*DZU ABOVE=THICK-Z SX=SBX-GRADPX*ABOVE SY=SBY-GRADPY*ABOVE S2=MAX(SX**2+SY**2,1.D-40) AMP=S2**(0.5D0*TWO) RATIO=RSAVE(N) ERATEX(N)=RATIO*SX*AMP ERATEY(N)=RATIO*SY*AMP C11VEC(N)=RATIO*(SX**2*TWO*S2** + ((THREE-3.)/2.)+AMP) C12VEC(N)=RATIO*SX*SY*TWO*S2**((THREE-3.)/2.) C22VEC(N)=RATIO*(SY**2*TWO*S2** + ((THREE-3.)/2.)+AMP) 210 CONTINUE DO 211 N=NLB,NINT Z=CONRAD+(N-NLB)*DZL ABOVE=THICK-Z SX=SBX-GRADPX*ABOVE SY=SBY-GRADPY*ABOVE S2=MAX(SX**2+SY**2,1.D-40) AMP=S2**(0.5*TWO) RATIO=RSAVE(N) ERATEX(N)=RATIO*SX*AMP ERATEY(N)=RATIO*SY*AMP C11VEC(N)=RATIO*(SX**2*TWO*S2** + ((THREE-3.)/2.)+AMP) C12VEC(N)=RATIO*SX*SY*TWO*S2**((THREE-3.)/2.) C22VEC(N)=RATIO*(SY**2*TWO*S2** + ((THREE-3.)/2.)+AMP) 211 CONTINUE VX(1)=0.D0 VY(1)=0.D0 DO 220 N=2,NUE VX(N)=VX(N-1)+DZU*0.5*(ERATEX(N-1)+ERATEX(N)) VY(N)=VY(N-1)+DZU*0.5*(ERATEY(N-1)+ERATEY(N)) 220 CONTINUE VX(NLB)=VX(NUE) VY(NLB)=VY(NUE) DO 221 N=NLB+1,NINT VX(N)=VX(N-1)+DZL*0.5*(ERATEX(N-1)+ERATEX(N)) VY(N)=VY(N-1)+DZL*0.5*(ERATEY(N-1)+ERATEY(N)) 221 CONTINUE FLX=0. FLY=0. C11= -0.5*C11VEC(1) C12= -0.5*C12VEC(1) C22= -0.5*C22VEC(1) DO 230 N=1,NUE FLX=FLX+VX(N) FLY=FLY+VY(N) C11=C11+C11VEC(N) C12=C12+C12VEC(N) C22=C22+C22VEC(N) 230 CONTINUE FLX=(FLX-0.5*VX(NUE))*DZU FLY=(FLY-0.5*VY(NUE))*DZU FLXUC=FLX FLYUC=FLY C11=(C11-0.5*C11VEC(NUE))*DZU C12=(C12-0.5*C12VEC(NUE))*DZU C22=(C22-0.5*C22VEC(NUE))*DZU DO 231 N=NLB,NINT FLX=FLX+VX(N)*DZL FLY=FLY+VY(N)*DZL C11=C11+C11VEC(N)*DZL C12=C12+C12VEC(N)*DZL C22=C22+C22VEC(N)*DZL 231 CONTINUE FLX=FLX-0.5*(VX(NLB)+VX(NINT))*DZL FLY=FLY-0.5*(VY(NLB)+VY(NINT))*DZL C11=C11-0.5*(C11VEC(NLB)+C11VEC(NINT))*DZL C12=C12-0.5*(C12VEC(NLB)+C12VEC(NINT))*DZL C22=C22-0.5*(C22VEC(NLB)+C22VEC(NINT))*DZL ELSE DO 260 N=1,NINT Z=N*DZ ABOVE=THICK-Z SX=SBX-GRADPX*ABOVE SY=SBY-GRADPY*ABOVE S2=MAX(SX**2+SY**2,1.D-40) AMP=S2**(0.5*TWO) RATIO=RSAVE(N) ERATEX(N)=RATIO*SX*AMP ERATEY(N)=RATIO*SY*AMP C11VEC(N)=RATIO*(SX**2*TWO*S2** + ((THREE-3.)/2.)+AMP) C12VEC(N)=RATIO*SX*SY*TWO*S2**((THREE-3.)/2.) C22VEC(N)=RATIO*(SY**2*TWO*S2** + ((THREE-3.)/2.)+AMP) 260 CONTINUE VX(1)=0.D0 VY(1)=0.D0 DO 270 N=2,NINT VX(N)=VX(N-1)+DZ*0.5*(ERATEX(N-1)+ERATEX(N)) VY(N)=VY(N-1)+DZ*0.5*(ERATEY(N-1)+ERATEY(N)) 270 CONTINUE FLX=0. FLY=0. C11= -0.5*C11VEC(1) C12= -0.5*C12VEC(1) C22= -0.5*C22VEC(1) DO 280 N=1,NINT FLX=FLX+VX(N) FLY=FLY+VY(N) C11=C11+C11VEC(N) C12=C12+C12VEC(N) C22=C22+C22VEC(N) 280 CONTINUE FLX=(FLX-0.5*VX(NINT))*DZ FLY=(FLY-0.5*VY(NINT))*DZ C11=(C11-0.5*C11VEC(NINT))*DZ C12=(C12-0.5*C12VEC(NINT))*DZ C22=(C22-0.5*C22VEC(NINT))*DZ FLXUC=FLX FLYUC=FLY ENDIF C C FLXMAG IS THE EXCESS FLUX DUE TO (GRADPX,GRADPY): DELFLX=FLX-RFLUX*DELVXF DELFLY=FLY-RFLUX*DELVYF FLXMAG=SQRT(DELFLX**2+DELFLY**2) C C CHECK FOR CONVERGENCE OF FLXMAG: DFLUX=FLXMAG-FLXOLD IF (FLXMAG.GT.0.D0) THEN IF ((ABS(DFLUX/FLXMAG).LE.ACCURA).AND. + (ITER.GE.3)) GO TO 301 ENDIF FLXOLD=FLXMAG C C INVERT 2X2 C (COMPLIANCE = D.VEL/D.SHEAR) MATRIX: IF (ABS(C11).LT.1.D-150) C11=0.0D0 IF (ABS(C12).LT.1.D-150) C12=0.0D0 IF (ABS(C22).LT.1.D-150) C22=0.0D0 C21=C12 DET=C11*C22-C21*C12 IF (DET.EQ.0.0D0) THEN IF (DEBUG) THEN WRITE(*,291) 291 FORMAT(' STOPPING ITERATION BECAUSE DET=0') END IF GO TO 301 END IF CI11=C22/DET CI12= -C21/DET CI21= -C12/DET CI22=C11/DET C CI MATRIX SHOULD NOW BE STIFFNESS (D.SHEAR/D.VEL) C C FIND ERROR IN BASAL VELOCITY, AND BASAL SHEAR CORRECTION RESVX=VX(NINT)-DVX RESVY=VY(NINT)-DVY DSBX=CI11*(-RESVX)+CI12*(-RESVY) DSBY=CI21*(-RESVX)+CI22*(-RESVY) C C LIMIT SIZE OF CORRECTION C TO PREVENT ANY WILD STEPS: DSHEAR=SQRT(DSBX**2+DSBY**2) IF (DSHEAR.GT.DSHLIM) THEN WAYOFF=.TRUE. FACTOR=DSHLIM/DSHEAR ELSE WAYOFF=.FALSE. FACTOR=1.D0 END IF SBX=SBX+FACTOR*DSBX SBY=SBY+FACTOR*DSBY IF (DEBUG) THEN WRITE(*,299) ITER,RESVX,RESVY,SBX,SBY,FLXMAG 299 FORMAT(' ',I2,' RESVX:',1P,D12.4,' RESVY:',D12.4 + ,' SBX:',D12.4,' SBY:',D12.4 + ,' FLXMAG:',D12.4) END IF 300 CONTINUE C NOTE: WINDING UP HERE IS NOT NECESSARILY AN ERROR; C IF FLXMAG IS QUITE SMALL, WE CANNOT EXPECT IT TO C HAVE EXCELLENT FRACTIONAL CONVERGENCE. 301 CONTINUE IF (LAYERD) THEN DELFLX=FLXUC-RFLXUC*DELVXF DELFLY=FLYUC-RFLXUC*DELVYF FLXMUC=SQRT(DELFLX**2+DELFLY**2) FLXMUC=MIN(FLXMUC,FLXMAG) ELSE FLXMUC=FLXMAG ENDIF IF (DEBUG) THEN IF (WAYOFF) THEN DO 396 N=1,NINT WRITE(*,395)N,RSAVE(N),ERATEX(N),ERATEY(N), + VX(N),VY(N),C11VEC(N),C12VEC(N), + C22VEC(N) 395 FORMAT(' ',I3,1P,8D12.3) 396 CONTINUE WRITE(*,397)C11,C12,C21,C22 397 FORMAT(' C11: ',1P,D12.3,' C12: ',D12.3 + /' C21: ',D12.3,' C22: ',D12.3) WRITE(*,398)CI11,CI12,CI21,CI22 398 FORMAT(' CI11:',1P,D12.3,' CI12:',D12.3 + /' CI21:',D12.3,' CI22:',D12.3) END IF WRITE(*,399) FLXMUC,FLXMAG 399 FORMAT(' FLXMUC=',1P,D12.4,' FLXMAG=',D12.4) END IF SIGHX=SBX SIGHY=SBY RETURN END C C C SUBROUTINE TWOTIM (INPUT, C,N,S,E,W,NRD,NRDP1,NX,NY, + MODIFY,T0, + WORK, T1) C C VERY-FAST SOLVER FOR EXPLICIT FINITE-DIFFERENCE TREATMENT OF C DIFFUSION (WITH NONUNIFORM GRID-SIZE AND DIFFUSION CONSTANTS) C C COEFFICIENTS OF NEIGHBORING POINTS MUST BE PRECOMPUTED AND STORED IN C ARRAYS N (NORTH), S (SOUTH), E (EAST), AND W (WEST). C THEY HAVE THE GENERIC FORM ( D*DT/H**2 ). C THE COEFFICIENT OF THE CENTRAL POINT IS C, AND IT HAS THE C FORM OF ( 1- 4*D*DT/H**2 ). C C THAT IS, N(I,J) IS THE COEFFICIENT APPLIED TO THE POINT NORTH OF C POINT (I,J) TO FIND ITS NEW TEMPERATURE AFTER THE STEP. C C ROUTINE PERFORMS TWO (2) TIME STEPS ON EACH CALL, TO AVOID A C POINTLESS DATA TRANSFER BETWEEN MATRICES. C C AN ADDITIONAL BENEFIT IS THAT WHEN PROCEDURE IS REPEATED, ALL THE C EIGENVALUES OF THE EIGENVECTORS MAKING UP THE SOLUTION ARE C SQUARED AND BECOME POSITIVE. THIS REDUCES THE NOISE IN THE C SOLUTION. C REAL N DIMENSION C(NRD,NX),N(NRD,NX),S(NRD,NX),E(NRD,NX),W(NRD,NX), + T0(0:NRDP1,0:NRDP1),T1(0:NRDP1,0:NRDP1) C C FIRST TIME STEP C DO 20 J=1,NX DO 10 I=1,NY T1(I,J)= N(I,J)*T0(I-1,J)+ + W(I,J)*T0(I,J-1)+C(I,J)*T0(I,J)+E(I,J)*T0(I,J+1)+ + S(I,J)*T0(I+1,J) 10 CONTINUE 20 CONTINUE C C SECOND TIME STEP C DO 40 J=1,NX DO 30 I=1,NY T0(I,J)= N(I,J)*T1(I-1,J)+ + W(I,J)*T1(I,J-1)+C(I,J)*T1(I,J)+E(I,J)*T1(I,J+1)+ + S(I,J)*T1(I+1,J) 30 CONTINUE 40 CONTINUE RETURN END C C C SUBROUTINE EBCS (NELCOL,FLOWIN,NUMNOD,NDIFF, + CODE,NCDIM) C C ADDS EDGE BOUNDARY CONDITIONS OF ZERO SCALAR VALUE ON ALL C INLAND BOUNDARY NODES BY OPERATIONS ON MATRIX CODE C AND VECTOR FLOWIN C DOUBLE PRECISION CODE,FLOWIN DIMENSION CODE(NCDIM),FLOWIN(NUMNOD) C NACROS=NELCOL*2+1 C C "TOP" SIDE: C DO 10 J=1,NACROS CALL FIXVAL (J,FLOWIN,NUMNOD,NDIFF,CODE,NCDIM,0.) 10 CONTINUE C C "BOTTOM" SIDE: C JL=NUMNOD JF=JL-NACROS+1 DO 20 J=JF,JL CALL FIXVAL (J,FLOWIN,NUMNOD,NDIFF,CODE,NCDIM,0.) 20 CONTINUE C C "RIGHT" SIDE (INLAND; OPPOSITE TO TRENCH, IF ANY): C IL=NUMNOD/NACROS-1 DO 30 I=2,IL J=NACROS*I CALL FIXVAL (J,FLOWIN,NUMNOD,NDIFF,CODE,NCDIM,0.) 30 CONTINUE RETURN END C C C SUBROUTINE FIXVAL (I,FLOWIN,NUMNOD,NDIFF,CODE,NCDIM,VALUE) C C SETS SCALAR TO VALUE AT NODE I C CAUTION: C NOTE THAT THIS ROUTINE WILL DESTROY SYMMETRY OF MATRIX CODE C THAT MAY PREVIOUSLY HAVE BEEN SYMMETRICAL !!! C DOUBLE PRECISION CODE,FLOWIN DIMENSION CODE(NCDIM),FLOWIN(NUMNOD) C C ****************** IMPORTANT ************************************ C ALL INDEXK DEFINITION STATEMENTS IN PACKAGE MUST AGREE ! INDEXK(IR,JC,NBAND)=2*NBAND+1+IR-JC+(JC-1)*(3*NBAND+16) C****************************************************************** C USEAGE IN THIS SUBPROGRAM: INDEXK(IR,JC,NDIFF) C KD=INDEXK(I,I,NDIFF) PIVOT=CODE(KD) JF=MAX(1,I-NDIFF) JL=MIN(NUMNOD,I+NDIFF) DO 10 J=JF,JL K=INDEXK(I,J,NDIFF) CODE(K)=0. 10 CONTINUE CODE(KD)=MAX(1.,PIVOT) FLOWIN(I)=CODE(KD)*VALUE RETURN END C C C SUBROUTINE COOLER (INPUT, AREAC,AREAM, + CONDUC,DIFFUS,DELT, + DETJC,DETJM,DNLINK,HMAX,HMIN, + NCDIM,NDIFF,NODES, + NUMEL,NUMNOD,NXL,RADIO,TASTH, + THIKC,THIKM,THNKC,THNKM,TOUCHC,UPLINK, + MODIFY,GEOTHA,GEOTHC,GEOTHM, + WORK, CODE,CONDNS,FLOWIN, + GWORKA,GWORKB,GWORKC,GWORKD, + LWORK,OUTSCA) C C CALULATES CHANGE OF GEOTHERMS FROM CONDUCTIVE COOLING OF C INDEPENDENT EIGENFUNCTIONS, IN EXCESS OF STEADY-STATE GEOTHERM. C USES IMPLICIT/EXACT FORMS VALID FOR ANY SIZE TIMESTEP. C TO BE CALLED ONLY ONCE PER TIMESTEP, WHEN TIME IS ADVANCED. C COMPLEX W,Z DOUBLE PRECISION CODE,FLOWIN LOGICAL DUMMY,FAILUR,LOCKIN,LOCKWC DIMENSION AREAC(NUMEL),AREAM(NUMEL),CODE(NCDIM), + CONDNS(NUMNOD),CONDUC(2), + DETJC(7,NUMEL),DETJM(7,NUMEL), + DIFFUS(2),DNLINK(3,7,NUMEL), + FLOWIN(NUMNOD),GEOTHA(4,7,NUMEL), + GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), + GWORKA(4,7,NUMEL),GWORKB(4,7,NUMEL), + GWORKC(4,7,NUMEL),GWORKD(4,7,NUMEL), + HMAX(2),HMIN(2),LWORK(NXL),NODES(6,0:NUMEL), + OUTSCA(7,NUMEL),RADIO(2), + THIKC(7,NUMEL),THIKM(7,NUMEL), + THNKC(NUMNOD),THNKM(NUMNOD), + TOUCHC(7,NUMEL),UPLINK(3,7,NUMEL) DIMENSION A(5),AUX(10),B(5),C(0:3),D(0:3),DUMMY(5),COPY(5,5), + EIGVAL(5),EIGVEC(5,5),G(0:3),H(0:3),IPVT(5), + PARTS(2,0:3,5),R(5,5),W(5),Z(5,5) DATA BIGNUM /3.E38/ DATA LOCKIN /.FALSE./, LOCKWC /.FALSE./ C HC=RADIO(1) HM=RADIO(2) PK=CONDUC(1) PL=CONDUC(2) DIFC=DIFFUS(1) DIFM=DIFFUS(2) DO 1000 K=1,4 DO 200 M=1,7 DO 100 I=1,NUMEL OUTSCA(M,I)=GEOTHM(K,M,I) 100 CONTINUE 200 CONTINUE CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 900 M=1,7 DO 800 I=1,NUMEL GWORKB(K,M,I)=OUTSCA(M,I) 800 CONTINUE 900 CONTINUE 1000 CONTINUE CALL GETSCA (INPUT,THNKM,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 3000 M=1,7 DO 2900 I=1,NUMEL IF ((DNLINK(1,M,I).EQ.0.).AND. + (TOUCHC(M,I).GT.0.)) THEN C C (1) CRUST OVERLYING SLAB OR CONVECTING ASTHENOSPHERE C D1=THIKC(M,I) D2=D1*D1 D3=D2*D1 TBASE=GEOTHC(1,M,I)+ GEOTHC(2,M,I)*D1+ + GEOTHC(3,M,I)*D2+GEOTHC(4,M,I)*D3 TIMES=MAX(DELT*DIFFUS(1)/D2,0.) ALPHA=0.25*(D1*GEOTHC(2,M,I)- + 0.5*D3*GEOTHC(4,M,I)+ + GEOTHC(1,M,I)-TBASE- + 0.5*D2*RADIO(1)/CONDUC(1)) BETA=0.5*GEOTHC(4,M,I)*D3 IF (ABS(BETA).LT.0.001) BETA=0.001 APRIME=ALPHA*EXP(MAX(-10.*TIMES,-97.)) BPRIME=BETA*EXP(MAX(-42.*TIMES,-97.)) GWORKC(2,M,I)=(TBASE-GEOTHC(1,M,I))/D1+ + 0.5*RADIO(1)*D1/CONDUC(1)+ + 4.*APRIME/D1+ + BPRIME/D1 GWORKC(3,M,I)= -0.5*RADIO(1)/CONDUC(1)+ + APRIME*(-4./D2)+ + BPRIME*(-3./D2) GWORKC(4,M,I)=2.*BPRIME/D3 ELSE C C (2) COMPLETE CRUST/MANTLE SECTIONS C C (2A) AT CRUSTAL INTEGRATION POINTS OVER BONDED MANTLE C D1=THIKC(M,I) D2=D1*D1 D3=D2*D1 IF (DNLINK(1,M,I).GT.0.) THEN E=MAX(OUTSCA(M,I),HMIN(2)) H(0)=GWORKB(1,M,I) H(1)=GWORKB(2,M,I) H(2)=GWORKB(3,M,I) H(3)=GWORKB(4,M,I) ELSE E=THIKM(5,NUMEL) H(0)=GEOTHA(1,M,I) H(1)=GEOTHA(2,M,I) H(2)=GEOTHA(3,M,I) H(3)=GEOTHA(4,M,I) ENDIF E2=E*E E3=E2*E G(0)=GEOTHC(1,M,I) G(1)=GEOTHC(2,M,I) G(2)=GEOTHC(3,M,I) G(3)=GEOTHC(4,M,I) TBASE=H(0)+H(1)*E+H(2)*E2+H(3)*E3 IF (TBASE.GT.TASTH) THEN H(3)=H(3)-(TBASE-TASTH)/E3 TBASE=TASTH ENDIF DT=TBASE-G(0) THETA=(PL/(D1*PL+E*PK))*(DT+0.5*HM*E2/PL)+ + (0.5*HC*D1/PK)*(1.+E*PK/(D1*PL+E*PK)) PHI=PK*(DT-0.5*HC*D2/PK+0.5*HM*E2/PL)/ + (D1*PL+E*PK) C(1)=G(1)-THETA C(2)=G(2)+0.5*HC/PK C(3)=G(3) D(0)=H(0)-TBASE-0.5*HM*E2/PL+PHI*E D(1)=H(1)-PHI D(2)=H(2)+0.5*HM/PL D(3)=H(3) A(1)=0.5*D(0) A(2)= -(D2*C(2)+1.5*D3*C(3))/6. A(3)= -(E2*D(2)+1.5*E3*D(3))/6. A(4)=0.5*D3*C(3) A(5)=0.5*E3*D(3) R(1,1)=(-15.*(D1*DIFM+DIFC*E))/(D1*E*(D1+E)) R(1,2)=(75.*DIFC)/(2.*D1*(D1+E)) R(1,3)=(75.*DIFM)/(2.*E*(D1+E)) R(1,4)=(-21.*DIFC)/(4.*D1*(D1+E)) R(1,5)=(21.*DIFM)/(4.*E*(D1+E)) R(2,1)=(25.*(D1*DIFM+DIFC*E))/(2.*D1*E*(D1+E)) R(2,2)=(5.*DIFC*(-33.*D1-8.*E))/(4.*D2*(D1+E)) R(2,3)=(-125.*DIFM)/(4.*E*(D1+E)) R(2,4)=(35.*DIFC)/(8.*D1*(D1+E)) R(2,5)=(-35.*DIFM)/(8.*E*(D1+E)) R(3,1)=(25.*(D1*DIFM+DIFC*E))/(2.*D1*E*(D1+E)) R(3,2)=(-125.*DIFC)/(4.*D1*(D1+E)) R(3,3)=(5.*DIFM*(-8.*D1-33.*E))/(4.*E**2*(D1+E)) R(3,4)=(35.*DIFC)/(8.*D1*(D1+E)) R(3,5)=(-35.*DIFM)/(8.*E*(D1+E)) R(4,1)=(-105.*(D1*DIFM+DIFC*E))/(D1*E*(D1+E)) R(4,2)=(525.*DIFC)/(2.*D1*(D1+E)) R(4,3)=(525.*DIFM)/(2.*E*(D1+E)) R(4,4)=(21.*DIFC*(-15.*D1-8.*E))/(4.*D2*(D1+E)) R(4,5)=(147.*DIFM)/(4.*E*(D1+E)) R(5,1)=(105.*(D1*DIFM+DIFC*E))/(D1*E*(D1+E)) R(5,2)=(-525.*DIFC)/(2.*D1*(D1+E)) R(5,3)=(-525.*DIFM)/(2.*E*(D1+E)) R(5,4)=(147.*DIFC)/(4.*D1*(D1+E)) R(5,5)=(21.*DIFM*(-8.*D1-15.*E))/(4.*E**2*(D1+E)) CALL SGEEV(1,R,5,W,Z,5,DUMMY,5,AUX,10) DO 2300 J=1,5 EIGVAL(J)=MIN(REAL(W(J)),0.) DO 2290 K=1,5 EIGVEC(K,J)=REAL(Z(K,J)) COPY(K,J)=EIGVEC(K,J) 2290 CONTINUE 2300 CONTINUE CALL SGEF(COPY,5,5,IPVT) CALL SGES(COPY,5,5,IPVT,A) DO 2400 J=1,5 B(J)=A(J)*EXP(MAX(EIGVAL(J)*DELT,-97.)) 2400 CONTINUE PARTS(1,0,1)=0. PARTS(1,1,1)=2./D1 PARTS(1,2,1)=0. PARTS(1,3,1)=0. PARTS(1,0,2)=0. PARTS(1,1,2)=6./D1 PARTS(1,2,2)=-6./D2 PARTS(1,3,2)=0. PARTS(1,0,3)=0. PARTS(1,1,3)=0. PARTS(1,2,3)=0. PARTS(1,3,3)=0. PARTS(1,0,4)=0. PARTS(1,1,4)=1./D1 PARTS(1,2,4)=-3./D2 PARTS(1,3,4)=2./D3 PARTS(1,0,5)=0. PARTS(1,1,5)=0. PARTS(1,2,5)=0. PARTS(1,3,5)=0. PARTS(2,0,1)=2. PARTS(2,1,1)=-2./E PARTS(2,2,1)=0. PARTS(2,3,1)=0. PARTS(2,0,2)=0. PARTS(2,1,2)=0. PARTS(2,2,2)=0. PARTS(2,3,2)=0. PARTS(2,0,3)=0. PARTS(2,1,3)=6./E PARTS(2,2,3)=-6./E2 PARTS(2,3,3)=0. PARTS(2,0,4)=0. PARTS(2,1,4)=0. PARTS(2,2,4)=0. PARTS(2,3,4)=0. PARTS(2,0,5)=0. PARTS(2,1,5)=1./E PARTS(2,2,5)=-3./E2 PARTS(2,3,5)=2./E3 DO 2660 N=1,3 C(N)=0. DO 2640 K=1,5 DO 2620 J=1,5 C(N)=C(N)+ + B(J)*EIGVEC(K,J)*PARTS(1,N,K) 2620 CONTINUE 2640 CONTINUE 2660 CONTINUE IF (DNLINK(1,M,I).LE.0.) THEN DO 2760 N=0,3 D(N)=0. DO 2740 K=1,5 DO 2720 J=1,5 D(N)=D(N)+ + B(J)*EIGVEC(K,J)*PARTS(2,N,K) 2720 CONTINUE 2740 CONTINUE 2760 CONTINUE ENDIF GWORKC(2,M,I)=C(1)+THETA GWORKC(3,M,I)=C(2)-0.5*HC/PK GWORKC(4,M,I)=C(3) IF (DNLINK(1,M,I).LE.0.) THEN GEOTHA(1,M,I)=D(0)+TBASE+ + 0.5*HM*E2/PL-PHI*E GEOTHA(2,M,I)=D(1)+PHI GEOTHA(3,M,I)=D(2)-0.5*HM/PL GEOTHA(4,M,I)=D(3) ENDIF ENDIF 2900 CONTINUE 3000 CONTINUE C C (2B) AT MANTLE INTEGRATION POINTS C DO 3100 K=1,3 DO 3020 M=1,7 DO 3010 I=1,NUMEL OUTSCA(M,I)=GEOTHC(K,M,I) 3010 CONTINUE 3020 CONTINUE CALL EXTRAP (AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DO 3090 M=1,7 DO 3080 I=1,NUMEL GWORKA(K,M,I)=OUTSCA(M,I) 3080 CONTINUE 3090 CONTINUE 3100 CONTINUE CALL GETSCA (INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DO 4000 M=1,7 DO 3900 I=1,NUMEL D1=MAX(OUTSCA(M,I),HMIN(1)) D2=D1*D1 D3=D2*D1 E=THIKM(M,I) E2=E*E E3=E2*E G(0)=GWORKA(1,M,I) G(1)=GWORKA(2,M,I) G(2)=GWORKA(3,M,I) H(0)=GEOTHM(1,M,I) G(3)=(H(0)-(G(0)+D1*G(1)+D2*G(2)))/D3 H(1)=GEOTHM(2,M,I) H(2)=GEOTHM(3,M,I) H(3)=GEOTHM(4,M,I) TBASE=H(0)+H(1)*E+H(2)*E2+H(3)*E3 DT=TBASE-G(0) THETA=(PL/(D1*PL+E*PK))*(DT+0.5*HM*E2/PL)+ + (0.5*HC*D1/PK)*(1.+E*PK/(D1*PL+E*PK)) PHI=PK*(DT-0.5*HC*D2/PK+0.5*HM*E2/PL)/ + (D1*PL+E*PK) C(1)=G(1)-THETA C(2)=G(2)+0.5*HC/PK C(3)=G(3) D(0)=H(0)-TBASE-0.5*HM*E2/PL+PHI*E D(1)=H(1)-PHI D(2)=H(2)+0.5*HM/PL D(3)=H(3) A(1)=0.5*D(0) A(2)= -(D2*C(2)+1.5*D3*C(3))/6. A(3)= -(E2*D(2)+1.5*E3*D(3))/6. A(4)=0.5*D3*C(3) A(5)=0.5*E3*D(3) R(1,1)=(-15.*(D1*DIFM+DIFC*E))/(D1*E*(D1+E)) R(1,2)=(75.*DIFC)/(2.*D1*(D1+E)) R(1,3)=(75.*DIFM)/(2.*E*(D1+E)) R(1,4)=(-21.*DIFC)/(4.*D1*(D1+E)) R(1,5)=(21.*DIFM)/(4.*E*(D1+E)) R(2,1)=(25.*(D1*DIFM+DIFC*E))/(2.*D1*E*(D1+E)) R(2,2)=(5.*DIFC*(-33.*D1-8.*E))/(4.*D2*(D1+E)) R(2,3)=(-125.*DIFM)/(4.*E*(D1+E)) R(2,4)=(35.*DIFC)/(8.*D1*(D1+E)) R(2,5)=(-35.*DIFM)/(8.*E*(D1+E)) R(3,1)=(25.*(D1*DIFM+DIFC*E))/(2.*D1*E*(D1+E)) R(3,2)=(-125.*DIFC)/(4.*D1*(D1+E)) R(3,3)=(5.*DIFM*(-8.*D1-33.*E))/(4.*E**2*(D1+E)) R(3,4)=(35.*DIFC)/(8.*D1*(D1+E)) R(3,5)=(-35.*DIFM)/(8.*E*(D1+E)) R(4,1)=(-105.*(D1*DIFM+DIFC*E))/(D1*E*(D1+E)) R(4,2)=(525.*DIFC)/(2.*D1*(D1+E)) R(4,3)=(525.*DIFM)/(2.*E*(D1+E)) R(4,4)=(21.*DIFC*(-15.*D1-8.*E))/(4.*D2*(D1+E)) R(4,5)=(147.*DIFM)/(4.*E*(D1+E)) R(5,1)=(105.*(D1*DIFM+DIFC*E))/(D1*E*(D1+E)) R(5,2)=(-525.*DIFC)/(2.*D1*(D1+E)) R(5,3)=(-525.*DIFM)/(2.*E*(D1+E)) R(5,4)=(147.*DIFC)/(4.*D1*(D1+E)) R(5,5)=(21.*DIFM*(-8.*D1-15.*E))/(4.*E2*(D1+E)) CALL SGEEV(1,R,5,W,Z,5,DUMMY,5,AUX,10) DO 3300 J=1,5 EIGVAL(J)=MIN(REAL(W(J)),0.) DO 3290 K=1,5 EIGVEC(K,J)=REAL(Z(K,J)) COPY(K,J)=EIGVEC(K,J) 3290 CONTINUE 3300 CONTINUE CALL SGEF(COPY,5,5,IPVT) CALL SGES(COPY,5,5,IPVT,A) DO 3400 J=1,5 B(J)=A(J)*EXP(MAX(EIGVAL(J)*DELT,-97.)) 3400 CONTINUE PARTS(2,0,1)=2. PARTS(2,1,1)=-2./E PARTS(2,2,1)=0. PARTS(2,3,1)=0. PARTS(2,0,2)=0. PARTS(2,1,2)=0. PARTS(2,2,2)=0. PARTS(2,3,2)=0. PARTS(2,0,3)=0. PARTS(2,1,3)=6./E PARTS(2,2,3)=-6./E2 PARTS(2,3,3)=0. PARTS(2,0,4)=0. PARTS(2,1,4)=0. PARTS(2,2,4)=0. PARTS(2,3,4)=0. PARTS(2,0,5)=0. PARTS(2,1,5)=1./E PARTS(2,2,5)=-3./E2 PARTS(2,3,5)=2./E3 DO 3660 N=0,3 D(N)=0. DO 3640 K=1,5 DO 3620 J=1,5 D(N)=D(N)+ + B(J)*EIGVEC(K,J)*PARTS(2,N,K) 3620 CONTINUE 3640 CONTINUE 3660 CONTINUE GWORKD(1,M,I)=D(0)+TBASE+0.5*HM*E2/PL-PHI*E GWORKD(2,M,I)=D(1)+PHI GWORKD(3,M,I)=D(2)-0.5*HM/PL GWORKD(4,M,I)=D(3) 3900 CONTINUE 4000 CONTINUE DO 5000 M=1,7 DO 4900 I=1,NUMEL GEOTHC(2,M,I)=GWORKC(2,M,I) GEOTHC(3,M,I)=GWORKC(3,M,I) GEOTHC(4,M,I)=GWORKC(4,M,I) GEOTHM(1,M,I)=GWORKD(1,M,I) GEOTHM(2,M,I)=GWORKD(2,M,I) GEOTHM(3,M,I)=GWORKD(3,M,I) GEOTHM(4,M,I)=GWORKD(4,M,I) 4900 CONTINUE 5000 CONTINUE RETURN END C C C SUBROUTINE VOLUME (INPUT,AREA,DETJ,NUMEL,PRINT,THIK, + OUTPUT,VOL) C C INTEGRATES THE VOLUME OF A LAYER, AND COMPARES TO INITIAL VALUE. C LOGICAL PRINT DOUBLE PRECISION WEIGHT COMMON /WGTVEC/ WEIGHT DIMENSION WEIGHT(7), + THIK(7,NUMEL), + AREA(NUMEL), + DETJ(7,NUMEL) SAVE ICALL,VOL0 DATA ICALL/0/ C ICALL=ICALL+1 VOL=0.0 DO 20 M=1,7 DO 10 I=1,NUMEL VOL=VOL+AREA(I)*DETJ(M,I)* + WEIGHT(M)*THIK(M,I) 10 CONTINUE 20 CONTINUE IF (ICALL.EQ.1) VOL0=VOL PERCEN=100.*VOL/VOL0 IF (PRINT) WRITE(6,100)VOL,PERCEN 100 FORMAT('+',43X,'LAYER VOLUME =',1P,E12.4,' = ',0P,F10.2,' %') RETURN END C C C SUBROUTINE TAPE (TITLE,TIME, + XNODC,XNODM,YNODC,YNODM,THNKC,CONNOD,THNKM, + GEOTHC,GEOTHM,GEOTHA,VC,VM,WC,WM,ESUMC,ESUMM, + NUMNOD,NUMEL) C C WRITES TAPE WITH ALL ARRAYS NEEDED IN ORDER TO C RESTART PROGRAM AND CONTINUE IN TIME, OR PRODUCE PLOTS. C GENERALLY, ONLY ESSENTIAL INTEGRATED VARIABLES ARE WRITTEN; C PARAMETERS MUST BE RE-INPUT BY "READIN", AND ALL C RECONSTRUCTABLE ARRAYS MUST BE RECOMPUTED. C HOWEVER, AN EXCEPTION IS MADE FOR THE CURRENT VELOCITIES; C TECHNICALLY THESE CAN BE RECOMPUTED; BUT SINCE IT IS SO C EXPENSIVE TO DO SO, WE SAVE THEM INSTEAD. C CHARACTER*80 TITLE DIMENSION CONNOD(NUMNOD),ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL), + GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), + THNKC(NUMNOD),THNKM(NUMNOD), + VC(2,NUMNOD),VM(2,NUMNOD), + WC(NUMNOD),WM(NUMNOD), + XNODC(NUMNOD),XNODM(NUMNOD), + YNODC(NUMNOD),YNODM(NUMNOD) C C NEW FORMAT SERIES (SEE SUBPROGRAM -GOON-): 2001 FORMAT(A80) 2002 FORMAT(1P,8E9.2) 2003 FORMAT(0P,8F9.5) 2004 FORMAT(' TIME = ',1P,E10.4,' (',0P,F10.4,')') 2005 FORMAT(1P,6E13.6) 2006 FORMAT(1P,8E10.3) 2007 FORMAT(0P,F10.3,1P,3E10.3,0P,F10.3,1P,3E10.3) C WRITE(9,2001) TITLE TMA=TIME/(1.E6*365.25*24.*60.*60.) WRITE(9,2004) TIME,TMA WRITE(9,1) 1 FORMAT(10X, '(XNODC(I),I=1,NUMNOD)') WRITE(9,2005) (XNODC(I),I=1,NUMNOD) WRITE(9,2) 2 FORMAT(10X, '(XNODM(I),I=1,NUMNOD)') WRITE(9,2005) (XNODM(I),I=1,NUMNOD) WRITE(9,3) 3 FORMAT(10X, '(YNODC(I),I=1,NUMNOD)') WRITE(9,2005) (YNODC(I),I=1,NUMNOD) WRITE(9,4) 4 FORMAT(10X, '(YNODM(I),I=1,NUMNOD)') WRITE(9,2005) (YNODM(I),I=1,NUMNOD) WRITE(9,5) 5 FORMAT(10X, '(THNKC(I),I=1,NUMNOD)') WRITE(9,2006) (THNKC(I),I=1,NUMNOD) WRITE(9,6) 6 FORMAT(10X, '(CONNOD(I),I=1,NUMNOD)') WRITE(9,2006) (CONNOD(I),I=1,NUMNOD) WRITE(9,7) 7 FORMAT(10X, '(THNKM(I),I=1,NUMNOD)') WRITE(9,2006) (THNKM(I),I=1,NUMNOD) WRITE(9,8) 8 FORMAT(10X, '(((GEOTHC(I,J,K),I=1,4),J=1,7),K=1,NUMEL)') WRITE(9,2007) (((GEOTHC(I,J,K),I=1,4),J=1,7),K=1,NUMEL) WRITE(9,9) 9 FORMAT(10X, '(((GEOTHM(I,J,K),I=1,4),J=1,7),K=1,NUMEL)') WRITE(9,2007) (((GEOTHM(I,J,K),I=1,4),J=1,7),K=1,NUMEL) WRITE(9,10) 10 FORMAT(10X, '(((GEOTHA(I,J,K),I=1,4),J=1,7),K=1,NUMEL)') WRITE(9,2007) (((GEOTHA(I,J,K),I=1,4),J=1,7),K=1,NUMEL) WRITE(9,11) 11 FORMAT(10X, '((VC(I,J),I=1,2),J=1,NUMNOD)') WRITE(9,2005) ((VC(I,J),I=1,2),J=1,NUMNOD) WRITE(9,12) 12 FORMAT(10X, '((VM(I,J),I=1,2),J=1,NUMNOD)') WRITE(9,2005) ((VM(I,J),I=1,2),J=1,NUMNOD) WRITE(9,13) 13 FORMAT(10X, '(WC(I),I=1,NUMNOD)') WRITE(9,2002) (WC(I),I=1,NUMNOD) WRITE(9,14) 14 FORMAT(10X, '(WM(I),I=1,NUMNOD)') WRITE(9,2002) (WM(I),I=1,NUMNOD) WRITE(9,15) 15 FORMAT(10X,'((((ESUMC(I,J,K,L),J=1,2),I=1,2),K=1,7),L=1,NUMEL)') WRITE(9,2003)((((ESUMC(I,J,K,L),J=1,2),I=1,2),K=1,7),L=1,NUMEL) WRITE(9,16) 16 FORMAT(10X,'((((ESUMM(I,J,K,L),J=1,2),I=1,2),K=1,7),L=1,NUMEL)') WRITE(9,2003)((((ESUMM(I,J,K,L),J=1,2),I=1,2),K=1,7),L=1,NUMEL) RETURN END C C C SUBROUTINE REPORT (XIPC,XIPM,YIPC,YIPM, 2 XNODC,XNODM,YNODC,YNODM,TITLE,VM,NODES, 3 OUTSCA,OUTVEC,VC,ERATEM,ERATEC, 4 THIKM,THIKC,GEOTHA,GEOTHC,CONDUC, 5 GEOTHM,DNLINK,VPMEAN,DVPBYE,DVPDT, 6 TIME2,NUMNOD,NUMEL, 7 G,HMAX,HMIN,RHOAST,RHOH2O,SIGHC,SIGHBM,SIGZZC, 8 SIGZZM,TAUMTC,TAUMTM,TAUZZC,TAUZZM, 9 TEMLIM,ONEKM,ESUMC,ESUMM,AREAC,AREAM, A CODE,CONDNS,DETJC,DETJM,FAILUR,FLOWIN, 1 NCDIM,NDIFF,NXL,LWORK,WC,WM, 2 SZZBC,SZZBM,TOUCHC,TOUCHM, 3 ECLOG,RADIUS,SLABSZ,CPNLAT,IBELOW, 4 X0ELON,Y0NLAT,VSLABC,VSLABM,OUTV2,RAMP, 5 THNKC,UPLINK,TASTH,TSLAB,FROMWC,FROMWM, 6 WANDES,CONINT,TSURF,PUSHUP,TERSE, 7 NELCOL) C C PRINTS MAPS OF IMPORTANT QUANTITIES ON LINE PRINTER. C PLOTS SHOW VALUES AT INTEGRATION POINTS, WITH LOCATION C FUDGED TO NEAREST POINT IN RECTANGULAR PRINTING GRIDS. C WHEN TWO OR MORE POINTS SHARE A PRINT GRID SQUARE, C SCALAR VALUES OR SIMPLE VECTORS ARE AVERAGED ACCORDING TO C THEIR GAUSSIAN WEIGHTS; BUT "VECTORS" REPRESENTING PRINCIPAL C AXES OF SECOND-RANK TENSORS ARE JUST OVERLAID, WITH C PRIORITY ACCORDING TO GAUSSIAN WEIGHT. C SCALARS ARE REPRESENTED BY DIGITS 0,1,2,3,4,5,6,7,8,9,*. C VECTORS (AND PRINCIPAL AXES OF TENSORS, TREATED AS VECTORS) C ARE REPRESENTED BY NUMERICAL DIGIT 0-* AND A LETTER A-L C WHICH REPRESENTS DIRECTION ACCORDING TO CODE A=1 O'CLOCK, C B=2 O'CLOCK....L=12 O'CLOCK. C IN THE CASE OF PRINCIPAL AXIS "VECTORS", THE CONVENTION IS C THAT DIRECTIONS A-F MEAN NEGATIVE PRINCIPAL VALUES, C AND DIRECTIONS G-L MEAN POSITIVE VALUES. C C BEFORE USE, FILL IN THE X (HORIZONTAL) AND Y (VERTICAL) C INCREMENT OF THE PRINTER (IN INCHES): DXPR & DYPR C AND ALSO THE EFFECTIVE NUMBER OF LINES IN A PAGE: NLINES C IN THE DATA STATEMENT BELOW. COLUMNS NPCOL WILL USUALLY BE 132; C THE INVISIBLE FIRST POSITION FOR CARRIAGE CONTROL IS NOT COUNTED. C CHARACTER*1 BLANK,BOARD1(59,63),BOARD2(59,63),CITY CHARACTER*80 TITLE LOGICAL AVERAG,FAILUR,TERSE,VERBOS DOUBLE PRECISION CODE,FLOWIN DIMENSION AREAC(NUMEL),AREAM(NUMEL), 2 CODE(NCDIM),CONDUC(2),COUNT(59,63),CONDNS(NUMNOD), 3 CONINT(7,NUMEL), 4 DETJC(7,NUMEL),DETJM(7,NUMEL),DVPBYE(2,2),DVPDT(2), 5 ERATEC(4,7,NUMEL),ERATEM(4,7,NUMEL), 6 ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL),FLOWIN(NUMNOD), 7 FROMWC(7,NUMEL),FROMWM(7,NUMEL),GEOTHA(4,7,NUMEL), 8 GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL),HMAX(2),HMIN(2), 9 DNLINK(3,7,NUMEL),LWORK(NXL),NODES(6,0:NUMEL), A OUTSCA(7,NUMEL),OUTVEC(2,7,NUMEL),OUTV2(2,7,NUMEL), 1 SIGHBM(2,7,NUMEL),SIGHC(2,7,NUMEL),SIGZZC(7,NUMEL), 2 SIGZZM(7,NUMEL),STACK(2,59,63), 3 SZZBC(7,NUMEL),SZZBM(7,NUMEL), 4 TAUMTC(3,7,NUMEL),TAUMTM(3,7,NUMEL) DIMENSION TAUZZC(7,NUMEL),TAUZZM(7,NUMEL),TEMLIM(2), 2 THIKC(7,NUMEL),THIKM(7,NUMEL), 3 THNKC(NUMNOD),UPLINK(3,7,NUMEL), 4 TOUCHC(7,NUMEL),TOUCHM(7,NUMEL), 5 VPMEAN(2),VC(2,NUMNOD),VM(2,NUMNOD), 6 VSLABC(2,7,NUMEL),VSLABM(2,7,NUMEL), 7 WC(NUMNOD),WM(NUMNOD), 8 XIPC(7,NUMEL),XIPM(7,NUMEL), 9 XNODC(NUMNOD),XNODM(NUMNOD), A YIPC(7,NUMEL),YIPM(7,NUMEL), 1 YNODC(NUMNOD),YNODM(NUMNOD) SAVE IRCALL,KRL,KCL,ROWFAC,ROWCON,COLFAC,COLCON,IORIGI,JORIGI DATA IRCALL/0/ DATA BLANK/' '/,CITY/'#'/ C C UCLA:DATA DXPR/0.100/,DYPR/0.125/,NLINES/63/,NPCOL/132/ C CHEV:DATA DXPR/0.100/,DYPR/0.167/,NLINES/58/,NPCOL/132/ DATA DXPR/0.100/,DYPR/0.125/,NLINES/63/,NPCOL/132/ C C STATEMENT FUNCTIONS: IROW(Y)=MAX(1,MIN(KRL,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(KCL,INT(COLFAC*X+COLCON+1.5))) C VERBOS=.NOT.TERSE IRCALL=IRCALL+1 IF (IRCALL.EQ.1) THEN KRL=MIN(59,NLINES-5) KCL=MIN(63,(NPCOL-6)/2) XMIN=3.E38 YMIN=3.E38 XMAX= -3.E38 YMAX= -3.E38 DO 10 I=1,NUMNOD XMIN=MIN(XMIN,XNODC(I),XNODM(I)) YMIN=MIN(YMIN,YNODC(I),YNODM(I)) XMAX=MAX(XMAX,XNODC(I),XNODM(I)) YMAX=MAX(YMAX,YNODC(I),YNODM(I)) 10 CONTINUE DX=(XMAX-XMIN)/(KCL-1.) DY=(YMAX-YMIN)/(KRL-1.) DX=MAX(DX,DY*DXPR/DYPR) DY=MAX(DY,DX*DYPR/DXPR) SCALE=DX/DXPR ROWFAC= -1./DY ROWCON= -ROWFAC*YMAX COLFAC= 1./DX COLCON= -COLFAC*XMIN IORIGI=IROW(0.) JORIGI=JCOL(0.) ENDIF T2MA=TIME2/(1.E6*365.25*24.*60.*60.) DO 9000 IPAGE=1,12 20 FORMAT('1',A80,' AGE = ',1P,E10.3,' (',0P,F8.3,')') IF (IPAGE.EQ.1) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,101) 101 FORMAT(' HORIZONTAL STRESSES ON:'/ + ' MANTLE (BASE ONLY)',51X, + 'CRUST (BASE ONLY)') AVERAG=.TRUE. CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,SIGHBM,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,SIGHC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 199 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 199 CONTINUE WRITE(6,2100) SCALE,SCALE CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 C -------------------------------------------- ELSE IF (IPAGE.EQ.2) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,201) 201 FORMAT(' VELOCITY VECTORS:'/' MANTLE',63X,'CRUST') CALL FLOW (VM,NUMNOD,NODES,NUMEL,OUTVEC) AVERAG=.TRUE. CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) CALL FLOW (VC,NUMNOD,NODES,NUMEL,OUTVEC) CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 299 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 299 CONTINUE WRITE(6,2100) SCALE,SCALE CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 C -------------------------------------------- ELSE IF (IPAGE.EQ.3) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,301) 301 FORMAT(' LARGEST MAGNITUDE PRINCIPAL STRAIN-RATE (NOTE' + ,': A-F NEGATIVE; G-L POSITIVE.)'/ + ' MANTLE',63X,'CRUST') CALL STRAIN (ERATEM,NUMEL,OUTVEC) AVERAG=.FALSE. CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) CALL STRAIN (ERATEC,NUMEL,OUTVEC) CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 399 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 399 CONTINUE WRITE(6,2100) SCALE,SCALE CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 C -------------------------------------------- ELSE IF (IPAGE.EQ.4) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,401) 401 FORMAT(' LARGEST MAGNITUDE HORIZONTAL PRINCIPAL', + ' STRESS ANOMALY', + ' INTEGRAL (NOTE: A-F NEGATIVE; G-L', + ' POSITIVE.):'/ + ' MANTLE',63X,'CRUST') CALL STRESS (TAUMTM,TAUZZM,OUTVEC,NUMEL) AVERAG=.FALSE. CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) CALL STRESS (TAUMTC,TAUZZC,OUTVEC,NUMEL) CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 499 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 499 CONTINUE WRITE(6,2100) SCALE,SCALE CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 C -------------------------------------------- ELSE IF ((IPAGE.EQ.5).AND.VERBOS) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,501) 501 FORMAT(' GRID OF FINITE ELEMENTS:'/ + ' MANTLE',63X,'CRUST') CALL NET + (BOARD1,XNODM,YNODM, + NUMNOD,NODES,NUMEL,ROWFAC,ROWCON, + COLFAC,COLCON) CALL NET + (BOARD2,XNODC,YNODC, + NUMNOD,NODES,NUMEL,ROWFAC,ROWCON, + COLFAC,COLCON) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 599 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 599 CONTINUE WRITE(6,2100) SCALE,SCALE C -------------------------------------------- ELSE IF ((IPAGE.EQ.6).AND.VERBOS) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,601) 601 FORMAT(' RATE OF THICKENING OF THE LAYERS', + ' (PURE SHEAR ONLY):'/ + ' MANTLE',63X,'CRUST') CALL INTERP(WM,NODES,NUMEL,NUMNOD,OUTSCA) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) CALL INTERP(WC,NODES,NUMEL,NUMNOD,OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 699 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 699 CONTINUE WRITE(6,2100) SCALE,SCALE CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 C -------------------------------------------- ELSE IF (IPAGE.EQ.7) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,701) 701 FORMAT(' THICKNESS OF LAYERS:'/ + ' MANTLE',63X,'CRUST') CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,THIKM,ROWFAC,ROWCON, + COLFAC,COLCON) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,THIKC,ROWFAC,ROWCON, + COLFAC,COLCON) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 799 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 799 CONTINUE WRITE(6,2100) SCALE,SCALE CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 C -------------------------------------------- ELSE IF ((IPAGE.EQ.8).AND.VERBOS) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,801) 801 FORMAT(' TEMPERATURE AT BASE OF LAYERS:'/ + ' MANTLE',63X,'CRUST') CALL SETCUB (THIKM,NUMEL,GEOTHM,GEOTHA,OUTSCA,TASTH, + THIKC,GEOTHC,DNLINK,TOUCHC,TOUCHM,TSLAB, + AREAM,CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NODES,NUMNOD,NXL,LWORK, + TSURF,FROMWC,FROMWM,ONEKM) CALL TMOHO (THIKM,NUMEL,GEOTHM,TEMLIM(2),OUTSCA) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) CALL TMOHO (THIKC,NUMEL,GEOTHC,TEMLIM(1),OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 899 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 899 CONTINUE WRITE(6,2100) SCALE,SCALE CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 C -------------------------------------------- ELSE IF ((IPAGE.EQ.9).AND.VERBOS) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,901) 901 FORMAT(' PALEO-SURFACE-OBSERVABLES:'/ + ' TELESEISMIC P-WAVE TRAVEL-TIME RESIDUAL', + 30X,'ISOSTATIC TOPOGRAPHY') CALL DELTP (GEOTHC,TEMLIM,ESUMC,ESUMM, + GEOTHM,GEOTHA,THIKM,THIKC,NUMEL,DNLINK, + VPMEAN,DVPBYE,DVPDT,OUTSCA,ONEKM, + THNKC,NODES,NUMNOD,UPLINK,AREAM, + CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NXL,LWORK,HMAX,HMIN) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) CALL PEAKS (INPUT,G,NUMEL,RADIUS,RHOAST,RHOH2O,SIGZZC, + TIME2, + OUTPUT,OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 999 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 999 CONTINUE WRITE(6,2100) SCALE,SCALE CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 C -------------------------------------------- ELSE IF ((IPAGE.EQ.10).AND.VERBOS) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,1001) 1001 FORMAT(' PALEO-HEAT-FLOW:',53X, + 'POST-DELAMINATION ELEVATIONS:'/ + ' AT M.Y.B.P. INDICATED IN ()',42X, + '(WITH MANTLE SHAVED TO .LE. NORMAL WEIGHT)') CALL HEAT(GEOTHC,NUMEL,CONDUC,OUTSCA) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) CALL BELOW (INPUT,CPNLAT,ECLOG,FROMWC,IBELOW, + NELCOL,NUMEL,PUSHUP, + RADIUS,RAMP,SLABSZ,TIME2,WANDES, + XIPC,YIPC,X0ELON,Y0NLAT, + OUTPUT,SZZBC,TOUCHC,VSLABC) CALL BELOW (INPUT,CPNLAT,ECLOG,FROMWM,IBELOW, + NELCOL,NUMEL,PUSHUP, + RADIUS,RAMP,SLABSZ,TIME2,WANDES, + XIPM,YIPM,X0ELON,Y0NLAT, + OUTPUT,SZZBM,TOUCHM,VSLABM) CALL REBOUN (INPUT, AREAC,AREAM,DETJC,DETJM,DNLINK, + G,NCDIM,NDIFF,NODES,NUMEL, + NUMNOD,NXL,RADIUS,RHOAST,RHOH2O, + SIGZZC,SIGZZM,SZZBC,SZZBM, + TOUCHC,TOUCHM,TIME2, + OUTPUT,OUTSCA, + WORK, CODE,CONDNS,FLOWIN,LWORK) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 1099 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 1099 CONTINUE WRITE(6,2100) SCALE,SCALE CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 C -------------------------------------------- ELSE IF ((IPAGE.EQ.11).AND.VERBOS) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,1101) 1101 FORMAT(' TOTAL DEFORMATION OF THE CRUST:'/ + ' LARGEST MAGNITUDE PRINCIPAL NET STRAIN', + ' (A-F NEGATIVE; G-L POSITIVE)', + 3X,'NET ROTATION (DEGREES CLOCKWISE)') CALL ELONG (ESUMC,NUMEL,OUTVEC) AVERAG=.FALSE. CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) CALL ROTOR (ESUMC,NUMEL,OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 1199 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 1199 CONTINUE WRITE(6,2100) SCALE,SCALE CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 C -------------------------------------------- ELSE IF (IPAGE.EQ.12) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,1201) 1201 FORMAT(' THICKNESS OF LAYERS:'/ + ' UPPER CRUST',58X,'LOWER CRUST ') CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,CONINT,ROWFAC,ROWCON, + COLFAC,COLCON) DO 1250 M=1,7 DO 1240 I=1,NUMEL OUTSCA(M,I)=THIKC(M,I)-CONINT(M,I) 1240 CONTINUE 1250 CONTINUE CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) C ------- FINISH PAGE ------ BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 1299 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 1299 CONTINUE WRITE(6,2100) SCALE,SCALE CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 C -------------------------------------------- ENDIF 1900 FORMAT(' ',63A1,6X,63A1) 2100 FORMAT(' MAP SCALE = ',1P,E10.3,' PER INCH', + 38X,'MAP SCALE = ',1P,E10.3,' PER INCH') 2200 FORMAT(' RANGE = ',1P,E10.3,' TO ',E10.3,', CI = ',E10.3, + 20X,'RANGE = ',E10.3,' TO ',E10.3,', CI = ',E10.3) 9000 CONTINUE RETURN END C C C SUBROUTINE VPLOT (BOARD,RLOW,RHI,COUNT,STACK,XIP,YIP, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) C C CONVERTS VECTOR FIELD TO 1-DIGIT INTEGERS AND DIRECTION LETTERS C AND LOADS THEM INTO APPROPRIATE CELLS IN PRINT MATRIX C CHARACTER*1 BLANK,BOARD(59,63),DIGIT(11),DIREC(13) LOGICAL AVERAG DOUBLE PRECISION WEIGHT COMMON /WGTVEC/ WEIGHT DIMENSION COUNT(59,63), + OUTVEC(2,7,NUMEL), + STACK(2,59,63),WEIGHT(7),XIP(7,NUMEL),YIP(7,NUMEL) DATA BLANK/' '/, DIGIT/'0','1','2','3','4','5','6','7', + '8','9','*'/, DIREC/'L','A','B','C','D','E','F','G','H', + 'I','J','K','L'/ IROW(Y)=MAX(1,MIN(59,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(63,INT(COLFAC*X+COLCON+1.5))) RLOW=3.E38 RHI= -3.E38 DO 10 I=1,59 DO 9 J=1,63 BOARD(I,J)=BLANK COUNT(I,J)=0. STACK(1,I,J)=0. STACK(2,I,J)=0. 9 CONTINUE 10 CONTINUE IF (AVERAG) THEN DO 100 M=1,7 DO 90 I=1,NUMEL IR=IROW(YIP(M,I)) JC=JCOL(XIP(M,I)) COUNT(IR,JC)=COUNT(IR,JC)+WEIGHT(M) STACK(1,IR,JC)=STACK(1,IR,JC)+ + WEIGHT(M)*OUTVEC(1,M,I) STACK(2,IR,JC)=STACK(2,IR,JC)+ + WEIGHT(M)*OUTVEC(2,M,I) 90 CONTINUE 100 CONTINUE ELSE DO 150 M=1,7 DO 140 I=1,NUMEL IR=IROW(YIP(M,I)) JC=JCOL(XIP(M,I)) IF (WEIGHT(M).GE.COUNT(IR,JC)) THEN STACK(1,IR,JC)= + WEIGHT(M)*OUTVEC(1,M,I) STACK(2,IR,JC)= + WEIGHT(M)*OUTVEC(2,M,I) COUNT(IR,JC)=WEIGHT(M) ENDIF 140 CONTINUE 150 CONTINUE ENDIF DO 200 I=1,59 DO 190 J=1,63 IF(COUNT(I,J).GT.0.) THEN STACK(1,I,J)=STACK(1,I,J)/COUNT(I,J) STACK(2,I,J)=STACK(2,I,J)/COUNT(I,J) VMAG=SQRT(STACK(1,I,J)**2+STACK(2,I,J)**2) BEARNG=ATAN2F(STACK(2,I,J),STACK(1,I,J)) RLOW=MIN(RLOW,VMAG) RHI=MAX(RHI,VMAG) STACK(1,I,J)=VMAG STACK(2,I,J)=BEARNG ENDIF 190 CONTINUE 200 CONTINUE IF(RHI.LE.RLOW) THEN RHI=RHI*1.001 RLOW=RLOW*0.999 ENDIF IF(RHI.EQ.0..AND.RLOW.EQ.0.) RHI=1. DO 300 I=1,59 DO 290 J=1,63 IF(COUNT(I,J).GT.0.) THEN ID=(STACK(1,I,J)-RLOW)/(RHI-RLOW) * 10. + 1.5 BOARD(I,J)=DIGIT(ID) IF (J.LT.63) THEN BD= -(STACK(2,I,J)/3.1415927)*6.+3. IF(BD.LT.0.) BD=BD+12. ID=BD+1.5 BOARD(I,J+1)=DIREC(ID) ENDIF ENDIF 290 CONTINUE 300 CONTINUE RETURN END C C C SUBROUTINE FLOW (V,NUMNOD,NODES,NUMEL,OUTVEC) C C CALCULATES VELOCITY VECTORS AT INTEGRATION POINTS, FROM NODAL VALUES C DOUBLE PRECISION PHI COMMON /PHITAB/ PHI DIMENSION NODES(6,0:NUMEL),OUTVEC(2,7,NUMEL), + PHI(6,7),V(2,NUMNOD) 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 STRAIN (ERATE,NUMEL,OUTVEC) + C C CALCULATES LARGEST-MAGNITUDE PRINCIPAL STRAIN-RATE IN VECTOR FORM C NOTE THAT STRAIN WORKS WITH VPLOT TO PUT NEGATIVE VECTORS IN A-F C DIMENSION ERATE(4,7,NUMEL),OUTVEC(2,7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) CENTER=(EXX+EYY)*0.5 R=SQRT((1.D0*EXX-CENTER)**2+(1.D0*EXY)**2) IF (CENTER.GT.0.) THEN E=CENTER+R ANGLE=ATAN2F(EXY,E-EYY) IF (ANGLE.LE.1.308996.AND.ANGLE.GT.-1.832596) + ANGLE=ANGLE+3.141593 ELSE E=CENTER-R ANGLE=ATAN2F(EXY,E-EYY) IF (ANGLE.GT.1.308996.OR.ANGLE.LE.-1.832596) + ANGLE=ANGLE+3.141593 E= -E ENDIF OUTVEC(1,M,I)=E*COS(ANGLE) OUTVEC(2,M,I)=E*SIN(ANGLE) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE ELONG (E,NUMEL,OUTVEC) + C C CALCULATES LARGEST-MAGNITUDE PRINCIPAL STRAIN IN VECTOR FORM C NOTE THAT ELONG WORKS WITH VPLOT TO PUT NEGATIVE VECTORS IN A-F C DIMENSION E(2,2,7,NUMEL),OUTVEC(2,7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL RNUM=2.*(E(1,1,M,I)*E(1,2,M,I)+E(2,1,M,I)*E(2,2,M,I)) RDENOM=E(1,1,M,I)**2+E(2,1,M,I)**2- + E(1,2,M,I)**2-E(2,2,M,I)**2 IF (RDENOM.NE.0.) THEN RHS=RNUM/RDENOM TTHETA=ATAN(RHS) THETA=TTHETA/2. ELSE THETA=0. ENDIF THETA2=THETA+1.570796327 S1X=COS(THETA) S1Y=SIN(THETA) S2X=COS(THETA2) S2Y=SIN(THETA2) BIGS1X=E(1,1,M,I)*S1X+E(1,2,M,I)*S1Y BIGS1Y=E(2,1,M,I)*S1X+E(2,2,M,I)*S1Y BIGS2X=E(1,1,M,I)*S2X+E(1,2,M,I)*S2Y BIGS2Y=E(2,1,M,I)*S2X+E(2,2,M,I)*S2Y BIGS1=SQRT(BIGS1X**2+BIGS1Y**2) BIGS2=SQRT(BIGS2X**2+BIGS2Y**2) ALPHA=ATAN2F(BIGS1Y,BIGS1X) ALPHA2=ATAN2F(BIGS2Y,BIGS2X) CENTER=SQRT(BIGS1*BIGS2)-1. R=MAX(ABS(BIGS1-1.-CENTER),ABS(BIGS2-1.-CENTER)) IF (CENTER.GT.0.) THEN EM=CENTER+R IF (BIGS1.GE.BIGS2) THEN ANGLE=ALPHA ELSE ANGLE=ALPHA2 ENDIF IF (ANGLE.LE.1.308996.AND.ANGLE.GT.-1.832596) + ANGLE=ANGLE+3.141593 ELSE EM=CENTER-R IF (BIGS1.LE.BIGS2) THEN ANGLE=ALPHA ELSE ANGLE=ALPHA2 ENDIF IF (ANGLE.GT.1.308996.OR.ANGLE.LE.-1.832596) + ANGLE=ANGLE+3.141593 EM= -EM ENDIF OUTVEC(1,M,I)=EM*COS(ANGLE) OUTVEC(2,M,I)=EM*SIN(ANGLE) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE STRESS (TAUMAT,TAUZZ,OUTVEC,NUMEL) C C CALCULATES LARGEST-MAGNITUDE HORIZONTAL PRINCIPAL C STRESS ANOMALY INTEGRAL, IN VECTOR FORM. C NOTE THAT STRESS WORKS WITH VPLOT TO PUT NEGATIVES IN A-F. C NOTE ALSO THAT THIS IS THE STRESS ANOMALY INTEGRAL (INCLUDES THE C VERTICAL STRESS ANOMALY INTEGRAL) NOT THE DEVIATORIC STRESS INTEGRAL C (WHICH CONTROLS LOCAL STRAIN-RATE), SO SHOULD SATISFY EQUILIBRIUM. C DIMENSION OUTVEC(2,7,NUMEL),TAUMAT(3,7,NUMEL), + TAUZZ(7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL TXX=TAUMAT(1,M,I)+TAUZZ(M,I) TYY=TAUMAT(2,M,I)+TAUZZ(M,I) TXY=TAUMAT(3,M,I) CENTER=(TXX+TYY)*0.5 R=SQRT((1.D0*TXX-CENTER)**2+(1.D0*TXY)**2) IF (CENTER.GT.0.) THEN T=CENTER+R ANGLE=ATAN2F(TXY,T-TYY) IF (ANGLE.LE.1.308996.AND.ANGLE.GT.-1.832596) + ANGLE=ANGLE+3.141593 ELSE T=CENTER-R ANGLE=ATAN2F(TXY,T-TYY) IF (ANGLE.GT.1.308996.OR.ANGLE.LE.-1.832596) + ANGLE=ANGLE+3.141593 T= -T ENDIF OUTVEC(1,M,I)=T*COS(ANGLE) OUTVEC(2,M,I)=T*SIN(ANGLE) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE NET (BOARD,XNOD,YNOD, + NUMNOD,NODES,NUMEL,ROWFAC,ROWCON, + COLFAC,COLCON) C C PUTS SYMBOLS INTO ARRAY BOARD IN ORDER TO PLOT NODES (@) AND C ELEMENT SIDES (@*****@*****@) C IMPLICIT DOUBLE PRECISION(A-H,O-Z) REAL XNOD,YNOD,ROWFAC,ROWCON,COLFAC,COLCON CHARACTER*1 BLANK,BOARD(59,63),DOT,LINE LOGICAL PRINT DIMENSION NODES(6,0:NUMEL),XNOD(NUMNOD),YNOD(NUMNOD) DATA BLANK/' '/,DOT/'@'/, LINE/'*'/ IROW(Y)=MAX(1,MIN(59,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(63,INT(COLFAC*X+COLCON+1.5))) XI(J)=(J-1-COLCON)/COLFAC YI(I)=(I-1-ROWCON)/ROWFAC DO 10 I=1,59 DO 8 J=1,63 BOARD(I,J)=BLANK 8 CONTINUE 10 CONTINUE DO 100 N=1,NUMEL DO 90 K=1,3 C ************************************************* C FOLLOWING OPTIONAL STATEMENT PREVENTS PLOTTING OF C THE DIAGONAL (HYPOTENUSE) OF EACH 2-ELEMENT C QUADRILATERAL CELL: C ************************************************* C IF (K.EQ.2) GO TO 90 C ************************************************* N1=NODES(K,N) N2=NODES((K+3),N) N3=NODES((MOD(K,3)+1),N) DX=XNOD(N3)-XNOD(N1) DY=YNOD(N3)-YNOD(N1) SIDE=SQRT(DX**2+DY**2) IF (ABS(DX).GE.ABS(DY)) THEN IF (DX.LT.0.) THEN NS=N1 N1=N3 N3=NS ENDIF X1=XNOD(N1) X2=XNOD(N2) X3=XNOD(N3) Y1=YNOD(N1) Y2=YNOD(N2) Y3=YNOD(N3) NX1=JCOL(X1) NX3=JCOL(X3) A=2.*X1-4.*X2+2.*X3 IF (ABS(A).GT.0.01*SIDE) THEN B= -3.*X1+4.*X2-X3 DO 20 J=NX1,NX3 X=XI(J) C=X1-X B2M4AC=B**2-4.*A*C IF (B2M4AC.GE.0.) THEN DISC=SQRT(B2M4AC) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) IF (ROOT1.GE.0..AND.ROOT1.LE.1.) THEN F=ROOT1 PRINT=.TRUE. ELSE IF(ROOT2.GE.0..AND.ROOT2.LE.1.) THEN F=ROOT2 PRINT=.TRUE. ELSE F=0. PRINT=.FALSE. ENDIF ELSE F=0. PRINT=.FALSE. ENDIF Y=Y1*(1.-3.*F+2.*F**2) + +Y2*(4.*F-4.*F**2) + +Y3*(-F+2.*F**2) IF (PRINT) BOARD(IROW(Y),J)=LINE 20 CONTINUE ELSE DO 21 J=NX1,NX3 X=XI(J) F=(X-X1)/(X3-X1) Y=Y1+F*(Y3-Y1) BOARD(IROW(Y),J)=LINE 21 CONTINUE ENDIF ELSE IF (DY.GT.0.) THEN NS=N1 N1=N3 N3=NS ENDIF X1=XNOD(N1) X2=XNOD(N2) X3=XNOD(N3) Y1=YNOD(N1) Y2=YNOD(N2) Y3=YNOD(N3) NY1=IROW(Y1) NY3=IROW(Y3) A=2.*Y1-4.*Y2+2.*Y3 IF (ABS(A).GT. 0.01*SIDE) THEN B= -3.*Y1+4.*Y2-Y3 DO 50 J=NY1,NY3 Y=YI(J) C=Y1-Y B2M4AC=B**2-4.*A*C IF (B2M4AC.GE.0.) THEN DISC=SQRT(B2M4AC) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) IF (ROOT1.GE.0..AND.ROOT1.LE.1.) THEN F=ROOT1 PRINT=.TRUE. ELSE IF(ROOT2.GE.0..AND.ROOT2.LE.1.) THEN F=ROOT2 PRINT=.TRUE. ELSE F=0. PRINT=.FALSE. ENDIF ELSE F=0. PRINT=.FALSE. ENDIF X=X1*(1.-3.*F+2.*F**2) + +X2*(4.*F-4.*F**2) + +X3*(-F+2.*F**2) IF (PRINT) BOARD(J,JCOL(X))=LINE 50 CONTINUE ELSE DO 51 J=NY1,NY3 Y=YI(J) F=(Y-Y1)/(Y3-Y1) X=X1+F*(X3-X1) BOARD(J,JCOL(X))=LINE 51 CONTINUE ENDIF ENDIF 90 CONTINUE 100 CONTINUE DO 200 I=1,NUMNOD X=XNOD(I) Y=YNOD(I) BOARD(IROW(Y),JCOL(X))=DOT 200 CONTINUE RETURN END C C C SUBROUTINE SPLOT (BOARD,RLOW,RHI,COUNT,STACK,XIP,YIP, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) C C CONVERTS SCALAR FIELD TO 1-DIGIT INTEGERS AND LOADS INTO C APPROPRIATE CELLS IN PRINT MATRIX C CHARACTER*1 BLANK,BOARD(59,63),DIGIT(11) DOUBLE PRECISION WEIGHT COMMON /WGTVEC/ WEIGHT DIMENSION COUNT(59,63), + OUTSCA(7,NUMEL), + STACK(2,59,63),WEIGHT(7),XIP(7,NUMEL),YIP(7,NUMEL) DATA BLANK/' '/, DIGIT/'0','1','2','3','4','5','6','7', + '8','9','*'/ IROW(Y)=MAX(1,MIN(59,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(63,INT(COLFAC*X+COLCON+1.5))) RLOW=3.E38 RHI= -3.E38 DO 10 I=1,59 DO 9 J=1,63 BOARD(I,J)=BLANK COUNT(I,J)=0. STACK(1,I,J)=0. 9 CONTINUE 10 CONTINUE DO 100 M=1,7 DO 90 I=1,NUMEL IR=IROW(YIP(M,I)) JC=JCOL(XIP(M,I)) COUNT(IR,JC)=COUNT(IR,JC)+WEIGHT(M) STACK(1,IR,JC)=STACK(1,IR,JC)+WEIGHT(M)*OUTSCA(M,I) 90 CONTINUE 100 CONTINUE DO 200 I=1,59 DO 190 J=1,63 IF(COUNT(I,J).GT.0.) THEN STACK(1,I,J)=STACK(1,I,J)/COUNT(I,J) RLOW=MIN(RLOW,STACK(1,I,J)) RHI=MAX(RHI,STACK(1,I,J)) ENDIF 190 CONTINUE 200 CONTINUE IF(RHI.LE.RLOW) THEN RHI=RHI*1.001 RLOW=RLOW*0.999 ENDIF IF(RHI.EQ.0..AND.RLOW.EQ.0.) RHI=1. DO 300 I=1,59 DO 290 J=1,63 IF(COUNT(I,J).GT.0.) THEN ID=(STACK(1,I,J)-RLOW)/(RHI-RLOW) * 10. + 1.5 BOARD(I,J)=DIGIT(ID) ENDIF 290 CONTINUE 300 CONTINUE RETURN END C C C SUBROUTINE TMOHO (THIK,NUMEL,GEOTH,TEMLIM,OUTSCA) C C CALCULATES TEMPERATURE AT THE BASE OF A LAYER BELOW INTEGRATION C POINTS C DIMENSION GEOTH(4,7,NUMEL),OUTSCA(7,NUMEL),THIK(7,NUMEL) TEMP(Z,L,J)=MIN(TEMLIM,GEOTH(1,L,J) + +GEOTH(2,L,J)*Z + +GEOTH(3,L,J)*Z**2 + +GEOTH(4,L,J)*Z**3) DO 100 M=1,7 DO 90 I=1,NUMEL OUTSCA(M,I)=TEMP(THIK(M,I),M,I) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE HEAT (GEOTH,NUMEL,CONDUC,OUTSCA) + C C CALCULATES SURFACE HEAT-FLOW C DIMENSION CONDUC(2),GEOTH(4,7,NUMEL),OUTSCA(7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL OUTSCA(M,I)=GEOTH(2,M,I)*CONDUC(1) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE PEAKS (INPUT,G,NUMEL,RADIUS,RHOAST,RHOH2O,SIGZZC,TSEC, + OUTPUT,OUTSCA) C C COMPUTES ISOSTATIC TOPOGRAPHY RELATIVE TO SEA LEVEL CONSIDERING C BOTH CRUST AND MANTLE DENSITY ANOMALIES, C AND GIVES RESULTS AT CRUSTAL GRID INTEGRATION POINTS, IN OUTSCA. C NOTE THAT WATER (NO SEDIMENT) LOADING IS ASSUMED BELOW SEA LEVEL. C C THE POSITION OF SEA LEVEL WAS DIFFERENT IN THE PAST, AND THIS C VARIATION IS CONTAINED IN FUNCTION PITMAN. C DIMENSION OUTSCA(7,NUMEL),SIGZZC(7,NUMEL) C SEALVL=PITMAN(TSEC,RADIUS) FACTOR=RHOAST/(RHOAST-RHOH2O) DO 100 M=1,7 DO 90 I=1,NUMEL HEIGHT= -SIGZZC(M,I)/(G*RHOAST) HEIGHT=HEIGHT-SEALVL IF (HEIGHT.LT.0.) HEIGHT=HEIGHT*FACTOR OUTSCA(M,I)=HEIGHT 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE REBOUN (INPUT, AREAC,AREAM,DETJC,DETJM,DNLINK, + G,NCDIM,NDIFF,NODES,NUMEL, + NUMNOD,NXL,RADIUS,RHOAST,RHOH2O, + SIGZZC,SIGZZM,SZZBC,SZZBM, + TOUCHC,TOUCHM,TSEC, + OUTPUT,OUTSCA, + WORK, CODE,CONDNS,FLOWIN,LWORK) C C COMPUTES ISOSTATIC TOPOGRAPHY CONSIDERING BOTH CRUST AND C MANTLE DENSITY ANOMALIES, WITH MANTLE LIMITED TO .LE. NORMAL WEIGHT C (NOTE THAT "NORMAL" IS DEFINED BY VALUES AT M=5, I=NUMEL) C AND ALL SUBDUCTING SLABS REMOVED FROM CONTACT, C AND EXPRESSES RESULTS IN TERMS OF CRUSTAL GRID INTEGRATION POINTS. C NOTE THAT WATER (NO SEDIMENT) LOADING IS ASSUMED BELOW SEA LEVEL. C LOGICAL FAILUR,LOCKIN,LOCKWC DOUBLE PRECISION CODE,FLOWIN DIMENSION AREAC(NUMEL),AREAM(NUMEL),CODE(NCDIM),CONDNS(NUMNOD), + DETJC(7,NUMEL),DETJM(7,NUMEL),FLOWIN(NUMNOD), + DNLINK(3,7,NUMEL),NODES(6,0:NUMEL),OUTSCA(7,NUMEL), + SIGZZC(7,NUMEL),SIGZZM(7,NUMEL),LWORK(NXL), + SZZBC(7,NUMEL),SZZBM(7,NUMEL),TOUCHC(7,NUMEL), + TOUCHM(7,NUMEL) DATA LOCKIN /.FALSE./, LOCKWC /.FALSE./ C SEALVL=PITMAN(TSEC,RADIUS) FACTOR=RHOAST/(RHOAST-RHOH2O) C C ELIMINATE SLAB EFFECTS FROM MANTLE ARRAY OF SZZ AT TOP C DO 20 M=1,7 DO 10 I=1,NUMEL OUTSCA(M,I)=SIGZZM(M,I)-TOUCHM(M,I)*SZZBM(M,I) 10 CONTINUE 20 CONTINUE C C TRANSFER VALUES TO CRUSTAL GRID C CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) C C MANTLE LITHOSPHERE IN FAR INLAND CORNER OF GRID IS "NORMAL" C REFSZM=OUTSCA(5,NUMEL) C C SUBTRACT OFF EXCESS LITHOSPHERE, AND ALSO ANY SLAB EFFECTS C DO 100 M=1,7 DO 90 I=1,NUMEL I2=DNLINK(1,M,I) IF (I2.GT.0) THEN SZMNA=OUTSCA(M,I) CORREC= -MAX(SZMNA-REFSZM,0.) + -TOUCHC(M,I)*SZZBC(M,I) ELSE CORREC= -TOUCHC(M,I)*SZZBC(M,I) ENDIF OUTSCA(M,I)=SIGZZC(M,I)+CORREC 90 CONTINUE 100 CONTINUE C C SMOOTH THE RESULTING SZZ AT TOP OF CRUST C CALL EXTRAP (AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) CALL INTERP (CONDNS,NODES,NUMEL,NUMNOD,OUTSCA) C C COMPUTE ISOSTATIC TOPOGRAPHY C DO 200 M=1,7 DO 190 I=1,NUMEL HEIGHT= -OUTSCA(M,I)/(G*RHOAST) HEIGHT=HEIGHT-SEALVL IF (HEIGHT.LT.0.)HEIGHT=HEIGHT*FACTOR OUTSCA(M,I)=HEIGHT 190 CONTINUE 200 CONTINUE RETURN END C C C REAL FUNCTION PITMAN (AGESEC,REARTH) C C RETURNS HEIGHT OF SEA LEVEL WITH RESPECT TO PRESENT, C IN CURRENT MEASUREMENT UNITS (DETERMINED FROM C REARTH, THE RADIUS OF THE EARTH), AT THE TIME C BEFORE PRESENT AGESEC (POSITIVE SECONDS). C C BASED ON W.C. PITMAN, 3RD (1978) GEOLOGICAL SOCIETY OF C AMERICA BULLETIN, V. 89, P. 1389-1403. C PARAMETER (NDATA=9) DIMENSION AGEDAT(NDATA),HDATA(NDATA) DATA AGEDAT /0., 15., 25., 35., 45., 55., 65., 75., 85./ DATA HDATA /0., 58., 98.,164.,200.,264.,327.,335.,344./ C AGEMY=AGESEC/3.15576E13 FACTOR=REARTH/6371000. IF (AGEMY.LT.0.0) THEN WRITE(6,1) 1 FORMAT(' FUNCTION PITMAN HAS BEEN ASKED FOR FUTURE SEALEVEL' + /' AND WILL ASSUME THAT THE PRESENT IS THE KEY TO' + /' THE FUTURE (I.E., NO CHANGE).') PITMAN=0. ELSE IF (AGEMY.GT.AGEDAT(NDATA)) THEN WRITE(6,2) AGEDAT(NDATA) 2 FORMAT(' FUNCTION PITMAN HAS BEEN ASKED FOR SEALEVEL BEFORE' + /' THE BEGINNING OF ITS TABLE, AT ',F3.0,' M.Y.,' + /' SO THE FIRST AVAILABLE VALUE WILL BE RETURNED.') PITMAN=HDATA(NDATA)*FACTOR ELSE N1=1 N2=2 DO 10 J=1,NDATA-1 IF (AGEMY.GE.AGEDAT(J).AND.AGEMY.LE.AGEDAT(J+1)) THEN N1=J N2=J+1 GO TO 11 ENDIF 10 CONTINUE 11 FRAC=(AGEMY-AGEDAT(N1))/(AGEDAT(N2)-AGEDAT(N1)) PITMAN=FACTOR*(HDATA(N1)+FRAC*(HDATA(N2)-HDATA(N1))) ENDIF RETURN END C C C SUBROUTINE DELTP (GEOTHC,TEMLIM,ESUMC,ESUMM, + GEOTHM,GEOTHA,THIKM,THIKC,NUMEL,DNLINK, + VPMEAN,DVPBYE,DVPDT,OUTSCA,ONEKM, + THNKC,NODES,NUMNOD,UPLINK,AREAM, + CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NXL,LWORK,HMAX,HMIN) C C COMPUTES TELESEISMIC P-WAVE VERTICAL TRAVEL-TIME RESIDUALS, C CONSIDERING THICKNESS AND TEMPERATURE VARIATIONS AND STRAIN EZZ, C AND USING ARRAYS UPLINK AND DNLINK TO RELATE GRIDS, C AND EXPRESSES RESULTS IN TERMS OF CRUSTAL GRID INTEGRATION POINTS C NOTE THAT RESIDUAL IS CALIBRATED TO ZERO AT BOTTOM LEFT (INLAND) C CORNER OF THE GRID. C NOTE THAT NO PROVISION IS MADE FOR TOPOGRAPHY; C RESIDUALS PRESENTED ARE CORRECTED TO SEA LEVEL. C TRAVEL-TIME EFFECTS OF ANY HORIZONTAL OCEANIC SLABS ARE IGNORED (!) C DOUBLE PRECISION CODE,FLOWIN LOGICAL FAILUR,LOCKIN,LOCKWC DIMENSION AREAM(NUMEL),CODE(NCDIM),CONDNS(NUMNOD),DETJM(7,NUMEL), + DNLINK(3,7,NUMEL), + DVPBYE(2,2),DVPDT(2), + ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL), + FLOWIN(NUMNOD),GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL), + GEOTHM(4,7,NUMEL),HMAX(2),HMIN(2),LWORK(NXL), + NODES(6,0:NUMEL),OUTSCA(7,NUMEL), + TEMLIM(2),THIKC(7,NUMEL),THIKM(7,NUMEL), + THNKC(NUMNOD),UPLINK(3,7,NUMEL), + VPMEAN(2) DATA LOCKIN /.FALSE./, LOCKWC /.FALSE./ TEMPC(Z,M,I)=MIN(TEMLIM(1),GEOTHC(1,M,I) + +GEOTHC(2,M,I)*Z + +GEOTHC(3,M,I)*Z**2 + +GEOTHC(4,M,I)*Z**3) TEMPM(Z,M,I)=MIN(TEMLIM(2),GEOTHM(1,M,I) + +GEOTHM(2,M,I)*Z + +GEOTHM(3,M,I)*Z**2 + +GEOTHM(4,M,I)*Z**3) TEMPA(Z,M,I)=MIN(TEMLIM(2),GEOTHA(1,M,I) + +GEOTHA(2,M,I)*Z + +GEOTHA(3,M,I)*Z**2 + +GEOTHA(4,M,I)*Z**3) C TASTH=TEMPM(THIKM(5,NUMEL),5,NUMEL) VASTH=VPMEAN(2)*(1.+DVPDT(2)*TASTH) NBL=THIKM(5,NUMEL)/ONEKM BLRES=THIKM(5,NUMEL)-ONEKM*NBL IBASE=(HMAX(1)+HMAX(2))/ONEKM C C PREPARE BY COMPUTING MANTLE LITHOSPHERE TRAVEL TIMES C CALL GETSCA (INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DO 100 M=1,7 DO 90 I=1,NUMEL CRUST=OUTSCA(M,I) TIME=0. DO 20 J=IBASE,1,-1 Z=ONEKM*(J-0.5) IF (Z.LT.CRUST) GO TO 21 IF (Z.LE.(CRUST+THIKM(M,I))) THEN ZP=Z-CRUST T=TEMPM(ZP,M,I) RELARE=ESUMM(1,1,M,I)*ESUMM(2,2,M,I)- + ESUMM(1,2,M,I)*ESUMM(2,1,M,I) RELARE=MIN(RELARE,5.0) RELARE=MAX(RELARE,0.3) EZZ=(1./RELARE)-1.0 VEL=VPMEAN(2)*(1.+DVPDT(2)*T+ + DVPBYE(1,2)*ATAN(EZZ/DVPBYE(2,2))) ELSE VEL=VASTH ENDIF TIME=TIME+ONEKM/VEL 20 CONTINUE 21 RESID=J*ONEKM-CRUST TIME=TIME+RESID/VEL OUTSCA(M,I)=TIME 90 CONTINUE 100 CONTINUE CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) C C COMPLETE INTEGRAL AT EACH CRUSTAL INTEGRATION POINT C CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 200 M=1,7 DO 190 I=1,NUMEL C C MANTLE PORTION C I2=DNLINK(1,M,I) IF (I2.GT.0) THEN C C NORMAL MANTLE LITHOSPHERE BELOW C TIME=OUTSCA(M,I) ELSE C C AREA OVER NEW ASTHENOSPHERE, WITH OR WITHOUT C A NEW THERMAL BOUNDARY LAYER C CRUST=THIKC(M,I) TIME=(HMAX(1)+HMAX(2)-CRUST-THIKM(5,NUMEL))/ + VASTH DO 110 J=NBL,1,-1 ZP=ONEKM*(J-0.5) T=TEMPA(ZP,M,I) VEL=VPMEAN(2)*(1.+DVPDT(2)*T) TIME=TIME+ONEKM/VEL 110 CONTINUE TIME=TIME+BLRES/VEL ENDIF C C CRUSTAL PORTION C DO 120 J=1,IBASE Z=ONEKM*(J-0.5) IF (Z.GT.THIKC(M,I)) GO TO 121 T=TEMPC(Z,M,I) RELARE=ESUMC(1,1,M,I)*ESUMC(2,2,M,I)- + ESUMC(1,2,M,I)*ESUMC(2,1,M,I) RELARE=MIN(RELARE,5.0) RELARE=MAX(RELARE,0.3) EZZ=(1./RELARE)-1.0 VEL=VPMEAN(1)*(1.+DVPDT(1)*T+ + DVPBYE(1,1)*ATAN(EZZ/DVPBYE(2,1))) TIME=TIME+ONEKM/VEL 120 CONTINUE 121 RESID=THIKC(M,I)-(J-1)*ONEKM TIME=TIME+RESID/VEL OUTSCA(M,I)=TIME 190 CONTINUE 200 CONTINUE C C CALIBRATE TO SOUTHEAST CORNER VALUES (=0) C STANDR=OUTSCA(5,NUMEL) DO 300 M=1,7 DO 290 I=1,NUMEL OUTSCA(M,I)=OUTSCA(M,I)-STANDR 290 CONTINUE 300 CONTINUE RETURN END C C C SUBROUTINE ROTOR (ESUM,NUMEL,OUTSCA) C C COMPUTE NET CLOCKWISE ROTATION IN DEGREES C OF A HYPOTHETICAL SOLID INCLUSION, C BY AVERAGING THE ROTATIONS OF THE X AND Y AXES. C DIMENSION ESUM(2,2,7,NUMEL),OUTSCA(7,NUMEL) DO 10 M=1,7 DO 9 I=1,NUMEL ROT1=ATAN2F(ESUM(2,1,M,I),ESUM(1,1,M,I)) ROT2=ATAN2F(-ESUM(1,2,M,I),ESUM(2,2,M,I)) IF(ABS(ROT1-ROT2).GT.3.141592654) THEN IF(ROT1.LT.ROT2) THEN ROT1=ROT1+6.283185307 ELSE ROT2=ROT2+6.283185307 ENDIF ENDIF ROTATE=(ROT1+ROT2)/2. OUTSCA(M,I)= -57.29577951*ROTATE 9 CONTINUE 10 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 BLOCK DATA BD1 C C DEFINE PHI (NODAL FUNCTIONS) AND WEIGHT (GAUSSIAN INTEGRATION C WEIGHTS) OF 6-NODED 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)=L1-3 OF C INTEGRATION POINT NUMBER M. C DOUBLE PRECISION PHI,POINTS,WEIGHT COMMON /L1L2L3/ POINTS COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) DATA PHI / + -0.1111111111111111,-0.1111111111111111,-0.1111111111111111, + 0.4444444444444444, 0.4444444444444444, 0.4444444444444444, + -0.0525839022774079,-0.0280749439026853,-0.0280749439026853, + 0.1122997756107412, 0.8841342388612960, 0.1122997756107412, + -0.0280749439026853,-0.0525839022774079,-0.0280749439026853, + 0.1122997756107412, 0.1122997756107412, 0.8841342388612960, + -0.0280749439026853,-0.0280749439026853,-0.0525839022774079, + 0.8841342388612960, 0.1122997756107412, 0.1122997756107412, + 0.4743526114618935,-0.0807685938011933,-0.0807685938011933, + 0.3230743752047730, 0.0410358257309469, 0.3230743752047730, + -0.0807685938011933, 0.4743526114618935,-0.0807685938011933, + 0.3230743752047730, 0.3230743752047730, 0.0410358257309469, + -0.0807685938011933,-0.0807685938011933, 0.4743526114618935, + 0.0410358257309469, 0.3230743752047730, 0.3230743752047730/ DATA POINTS / + 0.3333333333333333, 0.3333333333333333, 0.3333333333333333, + 0.3333333333333333, 0.3333333333333333, + 0.0597158733333333, 0.4701420633333333, 0.4701420633333333, + 0.0597158733333333, 0.4701420633333333, + 0.4701420633333333, 0.0597158733333333, 0.4701420633333333, + 0.4701420633333333, 0.0597158733333333, + 0.4701420633333333, 0.4701420633333333, 0.0597158733333333, + 0.4701420633333333, 0.4701420633333333, + 0.7974269866666667, 0.1012865066666667, 0.1012865066666667, + 0.7974269866666667, 0.1012865066666667, + 0.1012865066666667, 0.7974269866666667, 0.1012865066666667, + 0.1012865066666667, 0.7974269866666667, + 0.1012865066666667, 0.1012865066666667, 0.7974269866666667, + 0.1012865066666667, 0.1012865066666667/ DATA WEIGHT / 0.2250000000000000, + 0.1323941500000000, 0.1323941500000000, 0.1323941500000000, + 0.1259391833333333, 0.1259391833333333, 0.1259391833333333/ END C C C BLOCK DATA PROFIL C C ESTABLISHES PROFILE OF CORDILLERA, PER MODEL OF C GROW AND BOWIN (1975) JOURNAL OF GEOPHYSICAL RESEARCH, C VOL. 80, NUMBER 11, PAGE 1454. C THIS MODEL IS FOR AN EAST-WEST SECTION OF THE ANDES AT 23 SOUTH. C ITS ORIGINAL PARAMETER VALUES ARE: WANDES = 730 KM, APLANO = 5 KM. C C NOTE: HANDES IS A LIST OF DIMENSIONLESS NUMBERS WHICH REACH A C PLATEAU LEVEL OF +1.0 SOMEWHERE IN THE MIDDLE, DEFINING THE C HEIGHT PROFILE OF THE CORDILLERA RELATIVE TO HEIGHT "APLANO". C XANDES CONTAINS THE DIMENSIONLESS DISTANCES (RELATIVE TO C WANDES) AT WHICH THESE RATIOS ARE GIVEN. C XANDES(1) SHOULD ALWAYS BE ZERO; C XANDES(NPOINT) SHOULD ALWAYS BE 1.00. C LINEAR INTERPOLATION IS USED IN BETWEEN GIVEN POINTS; C THICKNESSES THICKN(2) APPLY AT X.GT.XANDES(NPOINT). C THE ALTIPLANO REGION IS LIMITED BY POINTS NALT1 AND NALT2; C AT X=XANDES(NALT1) THE SUBDUCTING SLAB LOSES CONTACT WITH C THE OVERRIDING PLATE. C AT X=XANDES(NALT2), A WEDGE OF MANTLE LITHOSPHERE IS ADDED C TO THE OVERRIDING PLATE, REACHING THICKNESS THICKN(2) C AT X=XANDES(NPOINT). C COMMON /GROBOW/ HANDES,XANDES,NPOINT,NALT1,NALT2 DIMENSION HANDES(5),XANDES(5) DATA HANDES/-1., 0. , 1.0 , 1.0 , 0. /, + XANDES/ 0.,0.209,0.350,0.694,1.000 /, + NPOINT/ 5/, + NALT1 / 3/, + NALT2 / 4/ END C C C BLOCK DATA NORTH C C ALL DATA NECESSARY TO DEFINE OCEANIC SLAB MOTIONS, AGES, AND C AREAS OF CONTACT WITH NORTH AMERICA UNDER ENGEBRETSON'S C "NORTHERN OPTION": KULA/VANCOUVER TRIPLE JUNCTION IN PACIFIC C NORTHWEST NEAR USA/CANADA BORDER. C C***************************************************************** C CAUTION!!! C WHEN INSTALLING THIS BLOCK DATA PROGRAM INTO ANOTHER CODE, SUCH C AS LARAMY, VERSCOMP, OR GDDMCOMP, IT IS NECESSARY TO MAKE THREE C SMALL EDITING CHANGES! C C IN THE "COMMON" STATEMENTS BELOW, CHANGE THE THREE NAMES AS C FOLLOWS: C C COMMON /SCALAR/ -> COMMON /NORTH1/ C COMMON /ARRAYS/ -> COMMON /NORTH2/ C COMMON /TAGS/ -> COMMON /NORTH3/ C C THIS IS NECESSARY SO THAT THE DATA WILL BE LINKED ONLY INTO C SUBPROGRAM BELOW1 (NORTHERN OPTION) AND NOT INTO BELOW2! C C CONVERSELY, IF YOU ARE BRINGING A BLOCK DATA PROGRAM BACK TO C BE INSPECTED AND/OR EDITED WITH MAPPER, IT IS NECCESARY TO C CHANGE THE COMMON BLOCK NAMES BACK TO THE NAMES IN THE LEFT C COLUMN ABOVE. C****************************************************************** C C COMMENTS ON COORDINATES AND UNITS C MOST OF THE DATA IN THIS UNIT ARE IN ROUND-EARTH COORDINATES C OF (LATITUDE,LONGITUDE). THE UNITS ARE DEGREES; FOR MORE C PRECISION WE USE DECIMAL FRACTIONS OF DEGREES INSTEAD OF C MINUTES AND/OR SECONDS OF ARC. LATITUDE IS POSITIVE IN THE C NORTHERN HEMISPHERE. LONGITUDE IS POSITIVE EAST OF C GREENWICH, ENGLAND. C THE FINITE-ROTATION MATRICES (3 X 3) AND THE ROTATION-AXIS C VECTORS (3 X 1) USE A DIFFERENT COORDINATE SYSTEM. C IT IS CARTESIAN (X,Y,Z), WITH ITS ORIGIN AT THE CENTER C OF THE EARTH. X POINTS TOWARD (LAT=0, LON=0). C Y POINTS TOWARD (LAT=0, LON=90). Z POINTS TOWARD (LAT=90). C THE UNITS DIFFER: THE FINITE-ROTATION MATRICES ARE C DIMENSIONLESS, BUT THE ROTATION-RATE VECTORS ARE IN C RADIANS PER SECOND. C THE GEOLOGIC TIMES WHICH LABEL THE VARIOUS FEATURES ARE C EXPRESSED IN MILLIONS OF YEARS (POSITIVE = PAST). THE C LENGTH OF 1 MILLION YEARS IN THE FUNDAMENTAL TIME UNIT C (THE SECOND) IS EXPRESSED BY "TUMAP". C C---------------------------------------------------------------- C GLOSSARY OF DATA: C -AGEFZ(J,I) IS THE AGE OF FRACTURE ZONE POINT #J C IN STRIP #I. (USED BY EDITOR, NOT BY BELOWY) C -AGEHNG(I) IS THE AGE OF THE HINGELINE CURVE K C DEFINED BY REHING(I=1,2;J=1,40?;K). C -AGEKV(I) IS THE AGE OF THE KULA/VANCOUVER/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REKV3J(1-3,I). C -AGEMAG(I,J) IS THE AGE OF MAGNETIC ANOMALY I (FROM W TO E) C IN STRIPE J (FROM S TO N) ON THE PRESENT-AGE MAP. C -AGEROT(I) IS THE AGE OF THE FINITE ROTATION MATRICES C ROMATF, ROMATK, ROMATP, AND ROMATV WITH AGE INDEX I. C -AGEVEL(I) IS THE AGE OF THE RELATIVE ROTATION-AXIS VECTORS C OMEGAF, OEMGAK, OMEGAP, AND OMEGAV WITH AGE INDEX I. C -AGEVF(I) IS THE AGE OF THE VANCOUVER/FARALLON/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REVF3J(1-3,I). C -FRACZN(2,I,J) ARE THE LAT. AND LON. COORDINATES OF POINTS I C (W TO E) ALONG FRACTURE ZONE J (S TO N) ON THE MAP OF C PRESENT SLAB AGES. C -NKV3J IS THE NUMBER OF KULA/VANCOUVER/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REKV3J(1-3,I) AT AGE AGEKV(I). C -NMAG(K) IS THE NUMBER OF LINEAR MAGNETIC ANOMALIES C WITHIN STRIPE K (S TO N) OF THE MAP OF PRESENT SLAB C AGES. C -NPHING(I) IS THE NUMBER C OF DIGITIZED POINTS IN HINGELINE CURVE #I OF REHING. C -NPFZ(J) IS THE NUMBER OF POINTS (W TO E) DEFINING FRACTURE ZONE C J (S TO N) ON THE MAP OF PRESENT SLAB AGES. C -NROMAT IS THE NUMBER OF FINITE-ROTATION MATRICES C GIVEN FOR EACH PLATE. C -NVF3J IS THE NUMBER OF VANCOUVER/FARALLON/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REVF3J(1-3,I) AT AGE AGEVF(I). C -NTAPES IS THE NUMBER OF STRIPS OF MAGNETIC ANOMALIES ON C THE MAP OF PRESENT SLAB AGES; ONE LESS THAN THE NUMBER OF C FRACTURE ZONES ON THE MAP. C -NUMHNG IS THE NUMBER OF SLAB HINGELINES (AT DIFFERENT TIMES). C -NUMVEL IS THE NUMBER OF AGES AGEVEL(I) WHERE RELATIVE C ROTATION-AXIS VECTORS (OMEGAF/K/P/V) ARE SUPPLIED. C -OMEGAF(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE FARALLON C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAK(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE KULA C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAP(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE PACIFIC C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAV(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE VANCOUVER C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -REHING(I,J,K) ARE THE LAT. (I=1) AND LON. (I=2) COORDINATES C OF THE DIGITIZED POINT #J (N TO S) OF THE HINGELINE C CURVE #K (PAST TO PRESENT). C -REKV3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE KULA/ C VANCOUVER/NORTH AMERICAN TRIPLE-JUNCTION AT AGE AGEKV(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -REMAG(2,2,I,J) ARE THE LAT., LON. COORDINATES (1ST SUB.) C OF THE N AND S ENDS (2ND SUB.) OF THE LINEAR MAGNETIC C ANOMALY I (W TO E) IN STRIPE J (S TO N) OF THE C PRESENT SLAB AGE MAP. C -REVF3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE C VANCOUVER/FARALLON/N.A. TRIPLE-JUNCTION AT AGE AGEVF(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -ROMATF(3,3,K) ARE THE ROTATION MATRICES FOR FARALLON WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATK(3,3,K) ARE THE ROTATION MATRICES FOR KULA WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATP(3,3,K) ARE THE ROTATION MATRICES FOR PACIFIC WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATV(3,3,K) ARE THE ROTATION MATRICES FOR VANCOUVER WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -TAGFZ(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE FRACTURE ZONE POINT #I C IN STRIP #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TAGMAG(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE MAGNETIC ANOM. #I IN STRIP C #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TUMAP IS A CONVENIENCE MULTIPLIER APPLIED TO AGES IN M.Y. C TO OBTAIN THE TRUE AGE IN PROGRAM UNITS (SECONDS). C------------------------------------------------------------------ C C MEMO: ORDER IS: PARAMETER, TYPE, COMMON, DIMENSION, DATA C C********************************************************************* C C NOTE: THESE DIMENSION PARAMETERS MUST AGREE C IN ALL PROGRAMS !!!!!! C C MAXIMUM NUMBER OF DIGITISED SLAB HINGELINES: PARAMETER (MAXHL=20) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED HINGELINE: PARAMETER (MAXHNG=40) C MAXIMUM NUMBER OF FINITE ROTATIONS FOR EACH PLATE: PARAMETER (MAXROT=21) C MAXIMUM NUMBER OF RELATIVE ROTATION-AXIS VECTORS FOR EACH PLATE: PARAMETER (MAXVEL=20) C MAXIMUM NUMBER OF AGES WHEN KULA/VANCOUVER TRIPLE-JUNCTION IS GIVEN: PARAMETER (MXKV3J =50) C MAXIM.NUMBER OF AGES WHEN VANCOUVER/FARALLON TRIPLE-JUNCTION IS GIVEN PARAMETER (MXVF3J =50) C MAXIMUM NUMBER OF STRIPS OF SEAFLOOR (BETWEEN FRACTURE ZONES) ON MAP: PARAMETER (MTAPES =40,MTAPP1=41) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED FRACTURE ZONE: PARAMETER (MAXFZP=100) C MAXIMUM NUMBER OF MAGNETIC ANOMALIES IN ANY ONE STRIP: PARAMETER (MAXMAG=100) C********************************************************************* CHARACTER*1 TAGFZ,TAGMAG C-------------------------------------------------------------------- COMMON /NORTH1/ + NKV3J, + NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, + TUMAP COMMON /NORTH2/ + AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, + FRACZN,NMAG,NPFZ,NPHING, + OMEGAF,OMEGAK,OMEGAP,OMEGAV, + REHING,REKV3J,REMAG,REVF3J, + ROMATF,ROMATK,ROMATP,ROMATV COMMON /NORTH3/ + TAGFZ,TAGMAG C-------------------------------------------------------------------- DIMENSION AGEFZ(MAXFZP,MTAPP1), 2 AGEHNG(MAXHL), 3 AGEKV(MXKV3J), 4 AGEMAG(MAXMAG,MTAPES), 5 AGEROT(MAXROT), 6 AGEVEL(MAXVEL), 7 AGEVF(MXVF3J), 8 FRACZN(2,MAXFZP,MTAPP1), 9 NPFZ(MTAPP1), A NPHING(MAXHNG) DIMENSION NMAG(MTAPES), 2 OMEGAF(3,MAXVEL), 3 OMEGAK(3,MAXVEL), 4 OMEGAP(3,MAXVEL), 5 OMEGAV(3,MAXVEL), 6 REHING(2,MAXHNG,MAXHL), 7 REKV3J(3,MXKV3J), 8 REMAG(2,2,MAXMAG,MTAPES), 9 REVF3J(3,MXVF3J), A ROMATF(3,3,MAXROT), 1 ROMATK(3,3,MAXROT), 2 ROMATP(3,3,MAXROT), 3 ROMATV(3,3,MAXROT), 4 TAGFZ(MAXFZP,MTAPP1), 5 TAGMAG(MAXMAG,MTAPES) C C===1=== SLAB HINGELINES ======================= C DATA NUMHNG / 14/ DATA TUMAP /3.15576E13/ DATA (AGEHNG(I),I=1, 14) / + 90.00, 80.00, 75.00, 65.00, 55.00, 45.00, 40.00, 35.00, + 30.00, 27.50, 20.00, 10.00, 0.00, -3.00 + / DATA (NPHING(I),I=1, 14) / + 29, 29, 33, 34, 31, 35, 32, 26, 31, 30, 30, 27, 31, 31 + / DATA ((REHING(I,J, 1),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.90,-121.85, 43.38,-120.70, 42.52,-119.85, + 41.41,-119.40, 40.22,-119.68, 38.73,-120.43, 37.05,-120.49, + 35.67,-120.08, 34.56,-118.00, 33.44,-115.89, 31.28,-114.73, + 29.55,-112.79, 27.91,-110.89, 26.28,-109.05, 24.78,-107.50, + 23.20,-106.00, 21.79,-104.58, 20.16,-103.23, 18.28,-101.73, + 16.37,-100.36 + / DATA ((REHING(I,J, 2),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.90,-121.85, 43.38,-120.70, 42.52,-119.85, + 41.41,-119.40, 40.22,-119.68, 38.73,-120.43, 37.05,-120.49, + 35.67,-120.08, 34.56,-118.00, 33.44,-115.89, 31.28,-114.73, + 29.55,-112.79, 27.91,-110.89, 26.28,-109.05, 24.78,-107.50, + 23.20,-106.00, 21.79,-104.58, 20.16,-103.23, 18.28,-101.73, + 16.37,-100.36 + / DATA ((REHING(I,J, 3),I=1,2),J=1, 33) / + 60.24,-142.90, 58.27,-136.08, 57.06,-133.84, 55.56,-132.30, + 54.31,-131.06, 52.34,-129.57, 50.99,-128.46, 49.68,-127.62, + 48.64,-126.31, 47.41,-124.10, 46.20,-121.40, 45.21,-118.79, + 44.38,-116.32, 43.59,-113.87, 42.71,-111.45, 41.95,-110.30, + 40.87,-109.75, 39.46,-109.53, 38.07,-109.47, 36.40,-109.69, + 34.97,-110.12, 33.38,-111.48, 32.18,-112.63, 31.23,-113.29, + 30.55,-113.21, 29.70,-112.07, 28.45,-110.41, 26.85,-108.26, + 25.03,-106.06, 22.76,-103.36, 20.40,-100.83, 18.53, -98.91, + 15.76, -95.35 + / DATA ((REHING(I,J, 4),I=1,2),J=1, 34) / + 59.74,-142.93, 57.85,-135.98, 57.15,-134.10, 56.01,-132.85, + 54.68,-131.71, 52.77,-130.21, 50.90,-128.84, 49.63,-127.75, + 48.60,-126.11, 47.65,-124.22, 47.03,-122.13, 46.41,-119.25, + 46.11,-116.86, 45.83,-114.22, 45.56,-111.04, 45.24,-108.41, + 44.65,-106.77, 43.72,-105.66, 42.82,-105.87, 41.25,-106.39, + 39.96,-107.68, 38.23,-109.58, 36.53,-111.05, 34.82,-112.31, + 33.11,-113.12, 32.14,-113.13, 31.23,-112.40, 30.09,-111.04, + 28.34,-108.86, 26.70,-106.84, 24.65,-104.56, 22.44,-102.17, + 18.04, -97.90, 14.33, -93.82 + / DATA ((REHING(I,J, 5),I=1,2),J=1, 31) / + 60.18,-142.67, 58.34,-135.99, 57.39,-133.91, 55.54,-131.68, + 53.24,-129.30, 51.45,-127.33, 49.34,-124.96, 47.58,-122.87, + 45.85,-120.92, 44.34,-118.67, 43.75,-116.92, 43.72,-114.46, + 43.59,-111.55, 43.34,-108.91, 42.86,-107.05, 42.13,-105.45, + 41.13,-104.87, 40.08,-104.90, 38.70,-105.39, 37.13,-106.70, + 35.70,-107.90, 34.13,-109.17, 32.75,-109.71, 31.34,-109.71, + 30.37,-109.16, 29.06,-107.62, 26.11,-104.35, 22.91,-101.21, + 20.18, -98.61, 18.86, -97.37, 15.81, -93.90 + / DATA ((REHING(I,J, 6),I=1,2),J=1, 35) / + 59.65,-143.76, 57.90,-136.31, 57.31,-134.75, 56.45,-133.35, + 55.25,-132.01, 53.95,-130.78, 52.54,-129.43, 50.88,-127.99, + 49.81,-126.43, 49.25,-124.90, 48.58,-123.85, 47.46,-122.86, + 46.31,-121.77, 44.75,-120.30, 43.36,-119.35, 41.49,-118.46, + 40.66,-117.90, 40.03,-116.96, 39.46,-115.55, 39.13,-113.64, + 38.99,-111.33, 38.87,-108.52, 38.77,-106.09, 38.39,-104.45, + 38.00,-103.53, 37.37,-103.42, 35.34,-103.89, 32.58,-104.54, + 29.82,-105.05, 27.44,-105.42, 24.90,-103.03, 22.70,-101.09, + 20.05, -98.86, 17.88, -96.95, 14.95, -94.01 + / DATA ((REHING(I,J, 7),I=1,2),J=1, 32) / + 60.15,-144.12, 58.32,-136.58, 57.58,-134.52, 55.82,-132.18, + 53.60,-130.20, 51.68,-128.54, 50.56,-127.44, 49.48,-125.13, + 48.21,-123.37, 45.85,-121.58, 43.62,-119.92, 41.89,-118.52, + 40.13,-116.35, 39.11,-114.39, 38.47,-112.91, 38.07,-111.01, + 37.86,-108.95, 37.68,-106.27, 37.11,-104.05, 36.49,-103.28, + 35.59,-103.92, 33.92,-105.34, 32.65,-107.07, 31.58,-108.11, + 30.77,-108.67, 30.04,-107.87, 28.35,-106.21, 25.94,-103.92, + 23.23,-101.36, 19.92, -98.62, 18.08, -97.05, 14.58, -93.85 + / DATA ((REHING(I,J, 8),I=1,2),J=1, 26) / + 60.73,-144.29, 58.48,-135.82, 56.96,-132.82, 54.44,-130.45, + 51.91,-128.35, 50.62,-126.85, 49.32,-124.72, 47.04,-122.53, + 45.09,-121.21, 43.27,-119.94, 41.70,-118.85, 39.66,-117.43, + 38.07,-115.05, 37.24,-112.97, 36.83,-110.87, 36.60,-109.39, + 36.22,-108.78, 35.56,-108.94, 33.64,-110.03, 32.23,-110.38, + 31.18,-109.93, 30.10,-108.77, 27.69,-106.20, 24.64,-103.37, + 19.55, -98.74, 14.66, -94.17 + / DATA ((REHING(I,J, 9),I=1,2),J=1, 31) / + 59.94,-142.45, 58.14,-135.36, 56.98,-133.18, 54.87,-131.29, + 52.93,-129.48, 51.68,-128.44, 50.98,-127.72, 50.43,-126.82, + 49.58,-125.10, 48.58,-123.85, 45.67,-121.39, 43.86,-120.19, + 41.92,-118.74, 39.65,-117.67, 38.14,-116.22, 37.34,-114.59, + 36.86,-113.27, 36.59,-112.50, 36.18,-112.04, 35.60,-111.96, + 34.88,-112.15, 34.29,-112.49, 33.70,-112.81, 32.69,-112.03, + 31.73,-110.98, 29.66,-108.65, 27.54,-106.42, 24.80,-103.95, + 23.88,-103.22, 18.54, -98.67, 14.42, -94.83 + / DATA ((REHING(I,J, 10),I=1,2),J=1, 30) / + 60.05,-142.71, 58.15,-135.55, 57.19,-133.78, 55.93,-132.21, + 54.27,-130.67, 53.02,-129.56, 51.61,-128.52, 50.80,-127.58, + 50.24,-126.63, 49.34,-124.96, 48.34,-123.62, 47.04,-122.53, + 45.82,-121.46, 44.32,-120.36, 42.71,-119.19, 40.97,-118.24, + 39.38,-117.47, 38.13,-116.62, 36.88,-115.49, 35.88,-114.63, + 35.07,-113.90, 34.07,-113.38, 32.72,-112.14, 31.60,-110.78, + 29.45,-108.57, 27.14,-106.05, 24.28,-103.50, 21.45,-101.15, + 18.32, -98.45, 14.79, -95.22 + / DATA ((REHING(I,J, 11),I=1,2),J=1, 30) / + 60.40,-143.60, 58.26,-135.89, 57.30,-133.82, 55.79,-132.11, + 54.09,-130.51, 52.22,-128.93, 50.89,-127.65, 50.16,-126.36, + 48.98,-124.38, 47.60,-123.01, 45.84,-122.17, 43.62,-121.86, + 41.51,-121.12, 39.45,-120.08, 37.52,-118.43, 36.38,-117.33, + 35.75,-116.30, 35.15,-114.95, 34.51,-113.95, 33.50,-113.29, + 32.45,-112.66, 31.69,-112.09, 30.03,-110.31, 28.29,-108.49, + 26.74,-106.94, 24.73,-105.04, 22.76,-103.43, 19.82,-100.93, + 18.03, -99.36, 15.25, -96.89 + / DATA ((REHING(I,J, 12),I=1,2),J=1, 27) / + 60.42,-144.51, 58.53,-136.13, 57.88,-134.36, 56.05,-132.25, + 54.05,-130.39, 52.11,-128.80, 50.74,-127.47, 50.15,-126.46, + 49.50,-125.28, 48.27,-123.80, 47.15,-122.81, 46.39,-122.50, + 45.08,-122.44, 43.55,-122.58, 41.65,-121.97, 39.91,-120.91, + 38.15,-119.72, 36.58,-117.83, 34.34,-115.15, 31.39,-111.97, + 28.32,-108.97, 26.00,-106.84, 23.14,-104.47, 21.37,-103.15, + 20.03,-101.83, 18.36,-100.47, 13.50, -94.94 + / DATA ((REHING(I,J, 13),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / DATA ((REHING(I,J, 14),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / C C===2=== CODE GENERATED BY PROGRAM "ALL4" PLATE ROTATER: ===== C DATA NROMAT / 18/ DATA (AGEROT(I),I=1, 18) / + 0.00, 3.63, 10.30, 19.90, 25.80, 30.00, 35.60, 42.00, + 49.55, 58.90, 68.50, 72.40, 85.00, 119.00, 127.00, 135.00, + 145.00, 163.00 + / DATA ((ROMATF(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATF(I,J, 2),J=1,3),I=1,3) +/ 0.9984418, 0.0249586, 0.0499063, + -0.0236761, 0.9993781,-0.0261258, + -0.0505273, 0.0249035, 0.9984120/ DATA ((ROMATF(I,J, 3),J=1,3),I=1,3) +/ 0.9965000,-0.0015017, 0.0835752, + 0.0016967, 0.9999958,-0.0022638, + -0.0835716, 0.0023977, 0.9964986/ DATA ((ROMATF(I,J, 4),J=1,3),I=1,3) +/ 0.9870884,-0.0794135, 0.1391012, + 0.0779809, 0.9968305, 0.0157267, + -0.1399093,-0.0046764, 0.9901530/ DATA ((ROMATF(I,J, 5),J=1,3),I=1,3) +/ 0.9816186,-0.0953112, 0.1653471, + 0.0902718, 0.9952011, 0.0377464, + -0.1681514,-0.0221263, 0.9855123/ DATA ((ROMATF(I,J, 6),J=1,3),I=1,3) +/ 0.9772222,-0.1307292, 0.1671685, + 0.1217395, 0.9905611, 0.0629824, + -0.1738244,-0.0411969, 0.9839141/ DATA ((ROMATF(I,J, 7),J=1,3),I=1,3) +/ 0.9643680,-0.2176023, 0.1504717, + 0.2023463, 0.9730743, 0.1103661, + -0.1704363,-0.0759863, 0.9824339/ DATA ((ROMATF(I,J, 8),J=1,3),I=1,3) +/ 0.9355122,-0.3127865, 0.1642541, + 0.2875628, 0.9442505, 0.1603019, + -0.2052376,-0.1027311, 0.9733049/ DATA ((ROMATF(I,J, 9),J=1,3),I=1,3) +/ 0.8698806,-0.4633711, 0.1690941, + 0.4200012, 0.8755688, 0.2386968, + -0.2586591,-0.1366181, 0.9562580/ DATA ((ROMATF(I,J, 10),J=1,3),I=1,3) +/ 0.7665346,-0.5965531, 0.2377952, + 0.4980173, 0.7859663, 0.3663787, + -0.4054641,-0.1624160, 0.8995655/ DATA ((ROMATF(I,J, 11),J=1,3),I=1,3) +/ 0.6799753,-0.6748897, 0.2866260, + 0.4922036, 0.7098752, 0.5037958, + -0.5434762,-0.2014907, 0.8148823/ DATA ((ROMATF(I,J, 12),J=1,3),I=1,3) +/ 0.6364845,-0.7003338, 0.3231361, + 0.4905679, 0.6908776, 0.5310636, + -0.5951703,-0.1794939, 0.7832956/ DATA ((ROMATF(I,J, 13),J=1,3),I=1,3) +/ 0.5407817,-0.7359961, 0.4072609, + 0.3967867, 0.6501144, 0.6480033, + -0.7416956,-0.1888330, 0.6436048/ DATA ((ROMATF(I,J, 14),J=1,3),I=1,3) +/ 0.1260393,-0.9004962, 0.4161935, + 0.4084943, 0.4294313, 0.8054301, + -0.9040152, 0.0684970, 0.4219739/ DATA ((ROMATF(I,J, 15),J=1,3),I=1,3) +/ 0.0432563,-0.8638376, 0.5019060, + 0.3372753, 0.4855096, 0.8065493, + -0.9404098, 0.1343924, 0.3123534/ DATA ((ROMATF(I,J, 16),J=1,3),I=1,3) +/ -0.0372843,-0.8243719, 0.5648155, + 0.2585098, 0.5380124, 0.8023162, + -0.9652870, 0.1759245, 0.1930498/ DATA ((ROMATF(I,J, 17),J=1,3),I=1,3) +/ -0.0857564,-0.7854440, 0.6129592, + 0.2832710, 0.5706134, 0.7708135, + -0.9551961, 0.2397366, 0.1735606/ DATA ((ROMATF(I,J, 18),J=1,3),I=1,3) +/ -0.3959168,-0.6532624, 0.6453629, + 0.3365481, 0.5506653, 0.7638706, + -0.8543893, 0.5196268, 0.0018373/ DATA ((ROMATK(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATK(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATK(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATK(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATK(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATK(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATK(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATK(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATK(I,J, 9),J=1,3),I=1,3) +/ 0.8926937, 0.3237427, 0.3135092, + -0.3673854, 0.9256842, 0.0902017, + -0.2610084,-0.1957012, 0.9452911/ DATA ((ROMATK(I,J, 10),J=1,3),I=1,3) +/ 0.8382884, 0.2792339, 0.4682950, + -0.4014298, 0.8973089, 0.1835486, + -0.3689522,-0.3418544, 0.8642969/ DATA ((ROMATK(I,J, 11),J=1,3),I=1,3) +/ 0.7479138, 0.2368386, 0.6201060, + -0.4491286, 0.8684335, 0.2100139, + -0.4887816,-0.4355798, 0.7558849/ DATA ((ROMATK(I,J, 12),J=1,3),I=1,3) +/ 0.7069741, 0.2202590, 0.6720657, + -0.4550582, 0.8691026, 0.1938600, + -0.5413948,-0.4428831, 0.7146643/ DATA ((ROMATK(I,J, 13),J=1,3),I=1,3) +/ 0.4927713, 0.2023760, 0.8462971, + -0.5685837, 0.8111188, 0.1371042, + -0.6587012,-0.5487522, 0.5147643/ DATA ((ROMATK(I,J, 14),J=1,3),I=1,3) +/ 0.2884439,-0.0305855, 0.9570071, + -0.2699646, 0.9563414, 0.1119320, + -0.9186499,-0.2906443, 0.2675945/ DATA ((ROMATK(I,J, 15),J=1,3),I=1,3) +/ 0.1826985, 0.0447444, 0.9821491, + -0.2405134, 0.9706448, 0.0005196, + -0.9532956,-0.2363152, 0.1880977/ DATA ((ROMATK(I,J, 16),J=1,3),I=1,3) +/ 0.0730065, 0.1148067, 0.9907003, + -0.2118030, 0.9724770,-0.0970868, + -0.9745805,-0.2027456, 0.0953141/ DATA ((ROMATK(I,J, 17),J=1,3),I=1,3) +/ 0.0737035, 0.1703374, 0.9826242, + -0.1573972, 0.9749421,-0.1572000, + -0.9847798,-0.1430762, 0.0986680/ DATA ((ROMATK(I,J, 18),J=1,3),I=1,3) +/ -0.0087966, 0.2534258, 0.9673132, + 0.1625878, 0.9548408,-0.2486796, + -0.9866534, 0.1550863,-0.0496027/ DATA ((ROMATP(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATP(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATP(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATP(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATP(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATP(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATP(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATP(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATP(I,J, 9),J=1,3),I=1,3) +/ 0.9036663, 0.3323698, 0.2700321, + -0.3557910, 0.9336445, 0.0414807, + -0.2383270,-0.1335597, 0.9619573/ DATA ((ROMATP(I,J, 10),J=1,3),I=1,3) +/ 0.8783061, 0.3137228, 0.3607716, + -0.3583550, 0.9314973, 0.0624035, + -0.3164804,-0.1840937, 0.9305640/ DATA ((ROMATP(I,J, 11),J=1,3),I=1,3) +/ 0.8133826, 0.3327699, 0.4771508, + -0.4012021, 0.9148389, 0.0458976, + -0.4212428,-0.2287661, 0.8776220/ DATA ((ROMATP(I,J, 12),J=1,3),I=1,3) +/ 0.7885006, 0.3410243, 0.5118291, + -0.4008002, 0.9161383, 0.0070450, + -0.4665038,-0.2106962, 0.8590583/ DATA ((ROMATP(I,J, 13),J=1,3),I=1,3) +/ 0.6594428, 0.4211499, 0.6227100, + -0.4718215, 0.8767433,-0.0933034, + -0.5852515,-0.2322797, 0.7768697/ DATA ((ROMATP(I,J, 14),J=1,3),I=1,3) +/ 0.5735050, 0.5730298, 0.5854303, + -0.4726608, 0.8151487,-0.3348495, + -0.6690916,-0.0846720, 0.7383407/ DATA ((ROMATP(I,J, 15),J=1,3),I=1,3) +/ 0.5466521, 0.6209800, 0.5617428, + -0.4979524, 0.7804186,-0.3781402, + -0.6732122,-0.0730101, 0.7358360/ DATA ((ROMATP(I,J, 16),J=1,3),I=1,3) +/ 0.5130962, 0.6671163, 0.5400814, + -0.5285266, 0.7413454,-0.4136018, + -0.6763074,-0.0732298, 0.7329704/ DATA ((ROMATP(I,J, 17),J=1,3),I=1,3) +/ 0.5677590, 0.7006614, 0.4321147, + -0.5501299, 0.7134408,-0.4340037, + -0.6123779, 0.0086904, 0.7905173/ DATA ((ROMATP(I,J, 18),J=1,3),I=1,3) +/ 0.7427920, 0.5855252, 0.3246846, + -0.3852086, 0.7703925,-0.5080448, + -0.5476077, 0.2523004, 0.7977908/ DATA ((ROMATV(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATV(I,J, 2),J=1,3),I=1,3) +/ 0.9993297, 0.0051820, 0.0362338, + -0.0047712, 0.9999232,-0.0114144, + -0.0362902, 0.0112339, 0.9992780/ DATA ((ROMATV(I,J, 3),J=1,3),I=1,3) +/ 0.9966072,-0.0024635, 0.0822646, + 0.0025242, 0.9999963,-0.0006345, + -0.0822628, 0.0008400, 0.9966100/ DATA ((ROMATV(I,J, 4),J=1,3),I=1,3) +/ 0.9874673,-0.0822613, 0.1346872, + 0.0813513, 0.9966096, 0.0122550, + -0.1352387,-0.0011445, 0.9908120/ DATA ((ROMATV(I,J, 5),J=1,3),I=1,3) +/ 0.9769385,-0.0981460, 0.1896242, + 0.0957089, 0.9951658, 0.0219901, + -0.1908659,-0.0033342, 0.9816099/ DATA ((ROMATV(I,J, 6),J=1,3),I=1,3) +/ 0.9672080,-0.1004198, 0.2332878, + 0.0970278, 0.9949411, 0.0260009, + -0.2347188,-0.0025129, 0.9720595/ DATA ((ROMATV(I,J, 7),J=1,3),I=1,3) +/ 0.9578496,-0.1985734, 0.2075841, + 0.1860558, 0.9794068, 0.0783809, + -0.2188739,-0.0364552, 0.9750712/ DATA ((ROMATV(I,J, 8),J=1,3),I=1,3) +/ 0.9285972,-0.3330147, 0.1637273, + 0.3143928, 0.9404002, 0.1296231, + -0.1971359,-0.0688933, 0.9779518/ DATA ((ROMATV(I,J, 9),J=1,3),I=1,3) +/ 0.8519540,-0.5116365, 0.1113576, + 0.4857856, 0.8516892, 0.1965587, + -0.1954090,-0.1133634, 0.9741470/ DATA ((ROMATV(I,J, 10),J=1,3),I=1,3) +/ 0.7341714,-0.6763662, 0.0593198, + 0.6286086, 0.7101420, 0.3170907, + -0.2565954,-0.1955106, 0.9465370/ DATA ((ROMATV(I,J, 11),J=1,3),I=1,3) +/ 0.6687082,-0.7369352, 0.0987580, + 0.6230298, 0.6278643, 0.4664944, + -0.4057837,-0.2504201, 0.8789921/ DATA ((ROMATV(I,J, 12),J=1,3),I=1,3) +/ 0.6332583,-0.7620972, 0.1348656, + 0.6199963, 0.6038375, 0.5009806, + -0.4632338,-0.2336346, 0.8548840/ DATA ((ROMATV(I,J, 13),J=1,3),I=1,3) +/ 0.5726639,-0.7899240, 0.2192550, + 0.5270615, 0.5596170, 0.6395554, + -0.6279004,-0.2506902, 0.7368125/ DATA ((ROMATV(I,J, 14),J=1,3),I=1,3) +/ 0.1862030,-0.9539652, 0.2351070, + 0.4969981, 0.2978723, 0.8150220, + -0.8475366,-0.0349119, 0.5295847/ DATA ((ROMATV(I,J, 15),J=1,3),I=1,3) +/ 0.1202118,-0.9349756, 0.3337152, + 0.4187091, 0.3525420, 0.8368945, + -0.9001268, 0.0391250, 0.4338636/ DATA ((ROMATV(I,J, 16),J=1,3),I=1,3) +/ 0.0559588,-0.9094425, 0.4120423, + 0.3322897, 0.4061266, 0.8512579, + -0.9415139, 0.0892823, 0.3249255/ DATA ((ROMATV(I,J, 17),J=1,3),I=1,3) +/ 0.0035101,-0.8845617, 0.4664051, + 0.3494043, 0.4380954, 0.8282415, + -0.9369633, 0.1600573, 0.3106084/ DATA ((ROMATV(I,J, 18),J=1,3),I=1,3) +/ -0.3217998,-0.7897338, 0.5222647, + 0.3520011, 0.4122773, 0.8403078, + -0.8789400, 0.4542502, 0.1453171/ DATA NUMVEL / 17/ DATA (AGEVEL(I),I=1, 17) / + 1.81, 6.97, 15.10, 22.85, 27.90, 32.80, 38.80, 45.77, + 54.22, 63.70, 70.45, 78.70, 102.00, 123.00, 131.00, 140.00, + 154.00 + / DATA (OMEGAF(I, 1),I=1,3) + / 2.22436E-16, 4.37785E-16,-2.11997E-16/ DATA (OMEGAF(I, 2),I=1,3) + /-1.15243E-16, 1.59143E-16, 1.18424E-16/ DATA (OMEGAF(I, 3),I=1,3) + /-5.20186E-17, 1.86928E-16, 2.53471E-16/ DATA (OMEGAF(I, 4),I=1,3) + /-1.06009E-16, 1.52830E-16, 7.04799E-17/ DATA (OMEGAF(I, 5),I=1,3) + /-1.88225E-16, 3.57680E-17, 2.41271E-16/ DATA (OMEGAF(I, 6),I=1,3) + /-2.80863E-16,-4.69432E-17, 4.60480E-16/ DATA (OMEGAF(I, 7),I=1,3) + /-2.23587E-16, 1.34246E-16, 4.59035E-16/ DATA (OMEGAF(I, 8),I=1,3) + /-3.01794E-16, 1.52210E-16, 6.43195E-16/ DATA (OMEGAF(I, 9),I=1,3) + /-2.67001E-16, 4.56656E-16, 4.83609E-16/ DATA (OMEGAF(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAF(I, 11),I=1,3) + /-7.69435E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAF(I, 12),I=1,3) + /-1.10799E-16, 4.93623E-16, 8.32111E-17/ DATA (OMEGAF(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAF(I, 14),I=1,3) + / 3.42999E-16, 4.32696E-16, 1.46227E-16/ DATA (OMEGAF(I, 15),I=1,3) + / 2.93430E-16, 4.47830E-16, 9.47212E-17/ DATA (OMEGAF(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAF(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAK(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAK(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAK(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAK(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAK(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAK(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAK(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAK(I, 8),I=1,3) + /-3.42895E-16, 3.07318E-16,-7.84280E-18/ DATA (OMEGAK(I, 9),I=1,3) + /-5.24123E-16, 4.21964E-16,-6.28934E-17/ DATA (OMEGAK(I, 10),I=1,3) + /-3.47853E-16, 5.17207E-16,-6.26469E-17/ DATA (OMEGAK(I, 11),I=1,3) + /-1.29789E-16, 5.39917E-16, 7.00136E-17/ DATA (OMEGAK(I, 12),I=1,3) + /-2.25126E-16, 6.46717E-16,-2.10399E-16/ DATA (OMEGAK(I, 13),I=1,3) + /-8.79291E-17, 2.40344E-16, 3.43456E-16/ DATA (OMEGAK(I, 14),I=1,3) + / 3.42972E-16, 4.32656E-16, 1.46203E-16/ DATA (OMEGAK(I, 15),I=1,3) + / 2.93406E-16, 4.47800E-16, 9.47100E-17/ DATA (OMEGAK(I, 16),I=1,3) + / 1.91374E-16, 2.29230E-17, 1.74145E-16/ DATA (OMEGAK(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAP(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAP(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAP(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAP(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAP(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAP(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAP(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAP(I, 8),I=1,3) + /-7.95765E-17, 2.01210E-16, 3.16566E-17/ DATA (OMEGAP(I, 9),I=1,3) + /-1.82793E-16, 2.78850E-16, 6.21172E-18/ DATA (OMEGAP(I, 10),I=1,3) + /-1.10363E-16, 4.11618E-16,-1.28934E-16/ DATA (OMEGAP(I, 11),I=1,3) + / 1.61156E-16, 4.19784E-16, 1.56999E-17/ DATA (OMEGAP(I, 12),I=1,3) + / 7.46968E-17, 4.23581E-16,-2.19155E-16/ DATA (OMEGAP(I, 13),I=1,3) + / 2.04277E-16, 1.08618E-16,-2.84094E-17/ DATA (OMEGAP(I, 14),I=1,3) + / 1.92305E-16, 3.73766E-17,-1.42336E-16/ DATA (OMEGAP(I, 15),I=1,3) + / 1.61534E-16, 3.43348E-17,-1.77105E-16/ DATA (OMEGAP(I, 16),I=1,3) + / 2.87845E-16,-2.68429E-16, 6.23380E-17/ DATA (OMEGAP(I, 17),I=1,3) + / 2.19652E-16,-7.13669E-17, 4.34363E-16/ DATA (OMEGAV(I, 1),I=1,3) + / 9.86981E-17, 3.16045E-16,-4.33668E-17/ DATA (OMEGAV(I, 2),I=1,3) + /-5.14985E-17, 2.19222E-16, 3.33668E-17/ DATA (OMEGAV(I, 3),I=1,3) + /-3.52269E-17, 1.75936E-16, 2.61668E-16/ DATA (OMEGAV(I, 4),I=1,3) + /-2.56065E-17, 3.02977E-16, 8.26955E-17/ DATA (OMEGAV(I, 5),I=1,3) + / 2.38990E-18, 3.39059E-16, 1.81821E-17/ DATA (OMEGAV(I, 6),I=1,3) + /-3.14872E-16,-1.02187E-16, 5.04872E-16/ DATA (OMEGAV(I, 7),I=1,3) + /-3.01822E-16,-1.44934E-16, 6.45606E-16/ DATA (OMEGAV(I, 8),I=1,3) + /-3.48720E-16,-8.07761E-17, 7.85876E-16/ DATA (OMEGAV(I, 9),I=1,3) + /-4.42586E-16, 1.09988E-16, 6.53606E-16/ DATA (OMEGAV(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAV(I, 11),I=1,3) + /-7.83352E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAV(I, 12),I=1,3) + /-1.10796E-16, 4.93633E-16, 8.32232E-17/ DATA (OMEGAV(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAV(I, 14),I=1,3) + / 3.42996E-16, 4.32686E-16, 1.46215E-16/ DATA (OMEGAV(I, 15),I=1,3) + / 2.93417E-16, 4.47842E-16, 9.47149E-17/ DATA (OMEGAV(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAV(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ C C===3=== DATA MODIFIED BY PROGRAM MAPPER ========== C C DATA NTAPES/ 16/,NTAPP1/ 17/,NKV3J/ 10/,NVF3J/ 10/ C C C DATA ((REKV3J(K,I),K=1,3),I=1, 10) / + 47.22,-130.46, 55., + 47.22,-130.46, 55., + 47.37,-132.82, 57., + 46.03,-131.91, 56., + 47.00,-133.97, 57., + 47.00,-133.97, 57., + 45.34,-128.86, 54., + 45.61,-129.99, 60., + 44.68,-129.34, 62., + 43.82,-129.20, 68. +/ DATA ((REVF3J(K,I),K=1,3),I=1, 10) / + 27.33,-117.02, 45., + 27.33,-117.02, 45., + 28.46,-118.67, 47., + 25.76,-113.07, 33., + 25.76,-113.07, 30., + 25.21,-111.68, 35., + 25.21,-111.68, 41., + 25.18,-112.65, 32., + 23.90,-110.19, 13., + 22.30,-107.00, 37. +/ DATA (AGEKV(I),I=1, 10) / + 0.00, 10.00, 20.00, 30.00, 40.00, 50.00, 65.00, 70.00, + 80.00, 85.00 +/ DATA (AGEVF(I),I=1, 10) / + 0.00, 10.00, 20.00, 30.00, 35.00, 40.00, 45.00, 50.00, + 55.00, 59.00 +/ C C C DATA (NPFZ(I),I=1, 17) / + 8, 9, 15, 21, 22, 28, 27, 27, 26, 20, 24, 30, 30, 29, 21, + 20, 11 +/ DATA (TAGFZ(K, 1),K=1, 8)/ +'F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 1),K=1, 8) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 1),K=1,2),L=1, 8)/ + 15.59,-125.04, 13.99,-104.17, 18.00, -94.37, 22.63, -84.11, + 25.16, -72.25, 27.86, -59.95, 30.09, -47.05, 29.56, -29.71 +/ DATA (TAGFZ(K, 2),K=1, 9)/ +'F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 2),K=1, 9) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00 +/ DATA ((FRACZN(K,L, 2),K=1,2),L=1, 9)/ + 15.59,-125.04, 25.72,-127.26, 27.71,-115.36, 23.44,-108.71, + 24.29, -94.18, 26.26, -81.92, 27.86, -59.95, 30.09, -47.05, + 29.56, -29.71 +/ DATA (TAGFZ(K, 3),K=1, 15)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 3),K=1, 15) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 3),K=1,2),L=1, 15)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 33.12,-120.57, + 27.71,-115.36, 23.44,-108.71, 31.30,-106.70, 31.39,-103.19, + 32.24, -96.28, 33.58, -83.48, 33.79, -66.16, 34.07, -56.01, + 33.30, -41.56, 31.31, -28.46, 29.56, -29.71 +/ DATA (TAGFZ(K, 4),K=1, 21)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F','F','F','F' +/ DATA (AGEFZ(K, 4),K=1, 21) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 4),K=1,2),L=1, 21)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 36.45,-130.48, + 36.30,-126.03, 34.39,-122.15, 33.12,-120.57, 27.71,-115.36, + 23.44,-108.71, 31.30,-106.70, 32.70,-101.50, 34.31, -96.22, + 35.02, -88.82, 37.37, -83.32, 39.82, -75.01, 37.48, -62.38, + 37.01, -56.15, 36.54, -44.03, 33.32, -26.81, 31.48, -28.31, + 29.56, -29.71 +/ DATA (TAGFZ(K, 5),K=1, 22)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 5),K=1, 22) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 5),K=1,2),L=1, 22)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 36.45,-130.48, + 36.30,-126.03, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 36.42,-103.96, + 29.31,-101.67, 30.90, -96.66, 31.63, -89.64, 33.99, -84.45, + 36.50, -76.61, 34.42, -64.53, 34.10, -58.57, 33.95, -46.94, + 30.70, -28.71, 28.36, -30.08 +/ DATA (TAGFZ(K, 6),K=1, 28)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 6),K=1, 28) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 6),K=1,2),L=1, 28)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 38.52,-125.98, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 36.42,-103.96, + 35.36,-100.33, 35.80, -96.04, 36.04, -87.64, 38.61, -83.49, + 40.03, -80.83, 40.75, -75.99, 42.08, -66.09, 42.76, -61.85, + 43.50, -58.17, 43.78, -48.52, 43.64, -38.32, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 7),K=1, 27)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 7),K=1, 27) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 7),K=1,2),L=1, 27)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 40.13,-131.75, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 37.83,-103.02, + 37.69, -97.94, 37.99, -94.65, 38.48, -90.74, 40.03, -80.83, + 40.75, -75.99, 42.08, -66.09, 42.76, -61.85, 43.50, -58.17, + 43.78, -48.52, 43.64, -38.32, 39.77, -21.11, 37.19, -23.42, + 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 8),K=1, 27)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 8),K=1, 27) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 8),K=1,2),L=1, 27)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 40.13,-131.75, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 37.83,-103.02, + 37.69, -97.94, 37.99, -94.65, 38.48, -90.74, 40.81, -81.78, + 43.05, -68.36, 43.82, -63.06, 45.47, -56.57, 45.94, -47.80, + 45.72, -36.12, 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, + 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 9),K=1, 26)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 9),K=1, 26) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00 +/ DATA ((FRACZN(K,L, 9),K=1,2),L=1, 26)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 43.26,-132.97, 42.34,-124.68, 41.51,-118.95, 41.92,-115.31, + 41.70,-109.93, 40.37,-100.85, 40.35, -98.25, 40.77, -95.67, + 41.34, -93.12, 42.06, -90.61, 42.74, -81.88, 43.05, -68.36, + 43.82, -63.06, 45.47, -56.57, 45.94, -47.80, 45.72, -36.12, + 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, + 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 10),K=1, 20)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V' +/ DATA (AGEFZ(K, 10),K=1, 20) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 10),K=1,2),L=1, 20)/ + 43.39,-133.14, 44.73,-133.51, 42.34,-124.68, 43.15,-119.71, + 45.49,-114.27, 45.73,-108.43, 44.73,-102.56, 48.58, -98.79, + 48.87, -94.66, 48.55, -89.67, 46.70, -85.91, 69.49, -10.11, + 69.17, 10.62, 55.83, 1.28, 41.92, -19.06, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 11),K=1, 24)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 11),K=1, 24) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 11),K=1,2),L=1, 24)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 49.49,-131.97, 48.65,-126.37, 49.93,-120.40, + 49.94,-115.54, 49.91,-111.07, 49.39,-107.30, 48.78,-104.25, + 48.58, -98.79, 48.87, -94.66, 48.55, -89.67, 46.70, -85.91, + 69.17, 10.62, 55.83, 1.28, 41.92, -19.06, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 12),K=1, 30)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 12),K=1, 30) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 12),K=1,2),L=1, 30)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 55.58,-138.46, 52.86,-133.79, + 51.31,-131.53, 50.15,-129.79, 50.53,-127.83, 51.55,-125.28, + 54.00,-120.83, 53.90,-116.85, 53.81,-112.33, 53.25,-108.90, + 53.06,-105.09, 48.58, -98.79, 48.87, -94.66, 48.55, -89.67, + 46.70, -85.91, 69.49, -10.11, 69.17, 10.62, 55.83, 1.28, + 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, + 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 13),K=1, 30)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 13),K=1, 30) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 13),K=1,2),L=1, 30)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 55.58,-138.46, 52.86,-133.79, + 51.31,-131.53, 50.15,-129.79, 50.53,-127.83, 51.55,-125.28, + 54.00,-120.83, 55.81,-113.06, 55.98,-108.85, 54.64,-108.33, + 53.06,-105.09, 48.58, -98.79, 48.87, -94.66, 48.55, -89.67, + 46.70, -85.91, 69.49, -10.11, 69.17, 10.62, 55.83, 1.28, + 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, + 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 14),K=1, 29)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 14),K=1, 29) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 14),K=1,2),L=1, 29)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 55.58,-138.46, 52.86,-133.79, + 51.31,-131.53, 50.15,-129.79, 50.53,-127.83, 51.55,-125.28, + 54.00,-120.83, 55.81,-113.06, 55.98,-108.85, 61.58, -99.29, + 63.17, -92.95, 65.54, -77.50, 70.17, -57.40, 72.85, -26.14, + 69.67, -7.24, 69.17, 10.62, 55.83, 1.28, 41.92, -19.06, + 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, + 29.56, -29.71 +/ DATA (TAGFZ(K, 15),K=1, 21)/ +'K','K','K','K','K','K','K','K','K','K','K','K','K','K','K', +'K','K','K','K','K','K' +/ DATA (AGEFZ(K, 15),K=1, 21) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 15),K=1,2),L=1, 21)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 63.11,-144.77, 69.34,-141.39, + 76.98,-131.11, 80.85, -90.15, 78.29, -32.39, 71.63, -18.19, + 69.67, -7.24, 69.44, 10.88, 55.38, 1.77, 41.92, -19.06, + 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, + 29.56, -29.71 +/ DATA (TAGFZ(K, 16),K=1, 20)/ +'K','K','K','K','K','K','K','K','K','K','K','K','K','K','K', +'K','K','K','K','K' +/ DATA (AGEFZ(K, 16),K=1, 20) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 16),K=1,2),L=1, 20)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 63.11,-144.77, 71.17,-152.92, + 83.00,-147.32, 85.08, -74.45, 71.63, -18.19, 67.61, -18.68, + 63.46, -11.94, 55.38, 1.77, 41.92, -19.06, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 17),K=1, 11)/ +'K','K','K','K','K','K','K','K','K','K','K' +/ DATA (AGEFZ(K, 17),K=1, 11) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 17),K=1,2),L=1, 11)/ + 15.59,-125.04, 40.13,-131.75, 55.63,-139.27, 63.11,-144.77, + 71.21,-152.93, 83.00,-147.32, 89.93,-130.41, 69.44, 10.88, + 55.38, 1.77, 47.07, -12.56, 29.56, -29.71 +/ C C C DATA (NMAG(I),I=1, 16) / + 12, 15, 15, 17, 16, 8, 12, 13, 17, 9, 8, 5, 7, 2, 6, + 7 +/ DATA (TAGMAG(K, 1),K=1, 12)/ +'F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 1),K=1, 12) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 59.00, 63.40, + 67.00, 77.00,142.00,240.00 +/ DATA (((REMAG(K,L,M, 1),K=1,2),L=1,2),M=1, 12) / + 22.94,-108.62, 19.57,-110.03, 22.15,-107.81, 19.38,-108.80, + 20.73,-106.17, 18.90,-106.87, 25.27,-102.94, 16.40,-102.97, + 24.14,-101.56, 16.66,-101.66, 24.11, -97.49, 18.53, -96.65, + 25.83, -82.46, 21.44, -81.63, 26.16, -80.77, 21.81, -79.71, + 26.56, -80.43, 22.47, -79.16, 26.83, -75.41, 23.15, -73.96, + 26.47, -61.99, 24.12, -63.58, 35.79, -17.17, 29.70, -28.97 +/ DATA (TAGMAG(K, 2),K=1, 15)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 2),K=1, 15) / + 0.00, 10.00, 20.00, 27.50, 35.70, 49.30, 59.00, 63.40, + 67.00, 77.00,126.00,165.00,200.00,240.00,240.00 +/ DATA (((REMAG(K,L,M, 2),K=1,2),L=1,2),M=1, 15) / + 28.07,-108.81, 23.70,-108.58, 28.08,-108.55, 23.71,-108.33, + 31.00,-106.14, 24.87,-105.49, 31.43,-103.56, 24.04,-103.46, + 31.38, -99.00, 24.02, -98.31, 31.79, -96.01, 24.87, -94.72, + 32.55, -90.64, 25.62, -90.16, 32.71, -88.50, 25.76, -88.05, + 33.05, -87.18, 25.94, -86.84, 33.50, -82.33, 26.27, -82.02, + 33.49, -71.21, 29.07, -70.66, 33.40, -59.78, 27.89, -59.33, + 33.47, -44.61, 30.67, -44.49, 31.24, -28.50, 29.95, -29.65, + 35.78, -17.17, 29.70, -28.97 +/ DATA (TAGMAG(K, 3),K=1, 15)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 3),K=1, 15) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 63.40, 67.00, + 77.00,126.00,134.00,150.00,180.00,220.00,220.00 +/ DATA (((REMAG(K,L,M, 3),K=1,2),L=1,2),M=1, 15) / + 32.05,-106.51, 31.16,-106.49, 32.92,-101.69, 31.43,-102.34, + 35.03, -96.52, 31.78, -96.40, 35.86, -92.66, 32.07, -92.63, + 37.00, -88.90, 32.71, -88.77, 40.00, -82.70, 33.09, -83.14, + 40.55, -80.73, 33.40, -81.29, 41.06, -79.60, 33.70, -80.32, + 41.71, -74.07, 33.98, -74.48, 37.49, -61.88, 34.61, -62.56, + 37.06, -58.84, 35.72, -59.17, 37.31, -53.84, 34.26, -53.85, + 36.15, -42.30, 34.03, -42.67, 33.41, -27.01, 32.02, -29.38, + 32.32, -27.45, 31.81, -28.32 +/ DATA (TAGMAG(K, 4),K=1, 17)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F' +/ DATA (AGEMAG(K, 4),K=1, 17) / + -0.10, -0.10, 27.50, 27.50, 35.70, 42.00, 49.30, 49.30, + 59.00, 63.40, 67.00, 77.00,119.00,126.00,134.00,142.00, +180.00 +/ DATA (((REMAG(K,L,M, 4),K=1,2),L=1,2),M=1, 17) / + 39.48,-125.50, 36.47,-125.64, 33.37,-102.05, 32.77,-102.07, + 33.37,-102.01, 32.76,-102.04, 34.89,-100.23, 32.53,-101.45, + 35.80, -95.98, 33.75, -95.69, 35.91, -91.95, 33.90, -91.90, + 37.00, -88.90, 32.71, -88.77, 36.09, -87.77, 34.12, -87.61, + 38.37, -83.89, 36.72, -83.58, 38.84, -82.31, 37.04, -82.08, + 39.82, -81.29, 38.02, -80.97, 40.77, -75.75, 38.64, -75.29, + 42.43, -64.58, 37.38, -63.68, 42.80, -61.72, 37.48, -61.76, + 43.18, -58.52, 37.61, -58.25, 43.81, -56.52, 36.98, -55.19, + 42.15, -41.18, 36.43, -41.72 +/ DATA (TAGMAG(K, 5),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEMAG(K, 5),K=1, 16) / + 27.50, 27.50, 35.70, 42.00, 49.30, 49.30, 59.00, 63.40, + 67.00, 77.00,119.00,126.00,134.00,142.00,180.00,215.00 +/ DATA (((REMAG(K,L,M, 5),K=1,2),L=1,2),M=1, 16) / + 37.61,-102.97, 36.01,-103.23, 34.89,-100.23, 32.53,-101.45, + 35.80, -95.98, 33.75, -95.69, 35.91, -91.95, 33.90, -91.90, + 37.00, -88.90, 32.71, -88.77, 36.09, -87.77, 34.12, -87.61, + 38.37, -83.89, 36.72, -83.58, 38.84, -82.31, 37.04, -82.08, + 39.82, -81.29, 38.02, -80.97, 40.77, -75.75, 38.64, -75.29, + 42.43, -64.58, 37.38, -63.68, 42.80, -61.72, 37.48, -61.76, + 43.18, -58.52, 37.61, -58.25, 43.81, -56.52, 36.98, -55.19, + 42.15, -41.18, 36.43, -41.72, 39.57, -21.55, 34.89, -25.78 +/ DATA (TAGMAG(K, 6),K=1, 8)/ +'V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 6),K=1, 8) / + 20.00, 27.50, 32.00, 35.70, 42.00, 49.30, 55.00, 71.00 +/ DATA (((REMAG(K,L,M, 6),K=1,2),L=1,2),M=1, 8) / + 38.74,-107.22, 37.20,-107.17, 37.61,-102.97, 36.01,-103.23, + 38.12,-100.16, 35.41,-100.24, 37.64, -97.96, 35.97, -98.10, + 37.75, -94.67, 35.97, -94.69, 37.72, -90.93, 36.00, -90.81, + 38.64, -88.39, 35.91, -87.72, 40.21, -81.16, 39.83, -81.31 +/ DATA (TAGMAG(K, 7),K=1, 12)/ +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 7),K=1, 12) / + 62.00, 79.00, 95.00,110.00,119.00,126.00,134.00,142.00, +150.00,180.00,200.00,225.00 +/ DATA (((REMAG(K,L,M, 7),K=1,2),L=1,2),M=1, 12) / + 39.44, -88.34, 38.22, -88.67, 40.68, -82.76, 39.71, -82.44, + 41.87, -76.97, 40.64, -76.68, 42.45, -71.61, 41.21, -71.43, + 42.89, -66.57, 42.23, -66.39, 43.73, -63.26, 42.95, -63.29, + 44.17, -60.23, 43.21, -60.02, 44.81, -58.21, 43.63, -57.96, + 45.78, -55.81, 43.77, -55.76, 45.91, -43.51, 43.91, -43.72, + 46.09, -37.00, 43.63, -37.73, 41.88, -19.07, 39.99, -21.35 +/ DATA (TAGMAG(K, 8),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 8),K=1, 13) / + 0.10, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 59.00, 63.40, 67.00, 77.00,140.00 +/ DATA (((REMAG(K,L,M, 8),K=1,2),L=1,2),M=1, 13) / + 42.80,-126.60, 40.17,-127.40, 42.45,-125.24, 40.18,-126.21, + 42.51,-123.83, 38.69,-124.00, 41.42,-118.95, 38.25,-119.07, + 41.80,-115.62, 38.70,-116.11, 41.73,-112.10, 38.61,-112.52, + 41.22,-108.00, 38.01,-108.00, 40.63,-103.87, 36.89,-103.78, + 40.11, -97.66, 36.61, -96.10, 40.78, -95.88, 37.24, -94.53, + 41.28, -95.05, 37.77, -93.70, 42.76, -89.98, 39.26, -88.59, + 43.41, -68.81, 43.05, -69.05 +/ DATA (TAGMAG(K, 9),K=1, 17)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V' +/ DATA (AGEMAG(K, 9),K=1, 17) / + 9.50, 27.50, 35.70, 42.00, 49.30, 59.00, 63.40, 67.00, + 77.00,126.00,134.00,142.00,158.00,180.00,200.00,230.00, +240.00 +/ DATA (((REMAG(K,L,M, 9),K=1,2),L=1,2),M=1, 17) / + 42.51,-123.83, 38.69,-124.00, 45.28,-113.55, 41.70,-114.19, + 45.66,-109.22, 41.61,-109.93, 45.23,-105.57, 41.19,-105.83, + 44.74,-102.25, 40.68,-101.27, 48.49, -98.41, 41.04, -94.18, + 49.16, -96.77, 41.62, -92.72, 48.67, -95.63, 41.97, -92.33, + 48.34, -89.32, 43.41, -87.14, 51.47, -70.15, 46.67, -68.59, + 52.83, -66.31, 43.84, -63.15, 53.00, -64.55, 44.39, -60.75, + 54.93, -57.93, 45.45, -55.29, 63.49, -47.57, 46.98, -46.80, + 65.69, -34.67, 45.99, -39.55, 68.71, 10.51, 41.73, -25.13, + 57.25, 0.37, 42.36, -19.36 +/ DATA (TAGMAG(K, 10),K=1, 9)/ +'V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 10),K=1, 9) / + 0.10, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 60.00 +/ DATA (((REMAG(K,L,M, 10),K=1,2),L=1,2),M=1, 9) / + 48.86,-129.11, 44.10,-131.38, 47.85,-128.22, 44.65,-129.45, + 47.92,-125.54, 44.65,-125.76, 49.83,-120.18, 47.58,-120.37, + 49.83,-114.87, 45.98,-115.58, 49.89,-111.38, 45.89,-112.04, + 49.48,-107.86, 45.30,-108.35, 48.95,-104.30, 44.77,-103.58, + 48.60, -99.23, 47.85, -99.31 +/ DATA (TAGMAG(K, 11),K=1, 8)/ +'V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 11),K=1, 8) / + 0.10, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, 60.00 +/ DATA (((REMAG(K,L,M, 11),K=1,2),L=1,2),M=1, 8) / + 49.95,-129.96, 49.31,-130.63, 51.53,-125.42, 48.75,-125.65, + 53.85,-120.86, 50.28,-120.71, 53.84,-116.82, 50.00,-116.45, + 53.79,-112.59, 50.21,-113.72, 53.31,-108.95, 49.63,-109.89, + 52.91,-105.16, 49.01,-105.38, 48.91, -99.38, 48.31, -99.45 +/ DATA (TAGMAG(K, 12),K=1, 5)/ +'V','V','V','V','V' +/ DATA (AGEMAG(K, 12),K=1, 5) / + 14.00, 27.50, 35.70, 42.00, 42.00 +/ DATA (((REMAG(K,L,M, 12),K=1,2),L=1,2),M=1, 5) / + 54.22,-120.58, 53.91,-120.48, 55.81,-113.13, 53.94,-113.12, + 55.83,-108.54, 53.46,-109.23, 53.84,-107.23, 53.24,-107.45, + 53.34,-105.45, 52.87,-105.44 +/ DATA (TAGMAG(K, 13),K=1, 7)/ +'V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 13),K=1, 7) / + 42.00, 43.80, 49.30, 59.00, 67.00, 77.00, 85.00 +/ DATA (((REMAG(K,L,M, 13),K=1,2),L=1,2),M=1, 7) / + 56.52,-108.44, 54.25,-108.27, 61.48, -99.41, 54.64,-108.33, + 63.10, -92.77, 53.20,-105.10, 65.51, -77.34, 48.75, -98.53, + 70.04, -57.53, 48.58, -95.06, 71.04, -26.15, 48.63, -89.31, + 70.21, -6.99, 69.46, -12.71 +/ DATA (TAGMAG(K, 14),K=1, 2)/ +'V','V' +/ DATA (AGEMAG(K, 14),K=1, 2) / + -0.10, -0.10 +/ DATA (((REMAG(K,L,M, 14),K=1,2),L=1,2),M=1, 2) / + 57.02,-140.64, 55.42,-139.28, 72.18, -16.71, 71.47, -21.32 +/ DATA (TAGMAG(K, 15),K=1, 6)/ +'K','K','K','K','K','K' +/ DATA (AGEMAG(K, 15),K=1, 6) / + 42.00, 49.30, 59.00, 67.00, 77.00, 85.00 +/ DATA (((REMAG(K,L,M, 15),K=1,2),L=1,2),M=1, 6) / + 63.38,-145.67, 64.08,-143.46, 66.37,-147.24, 69.08,-141.77, + 70.85,-152.26, 76.54,-131.98, 74.46,-151.71, 80.44, -97.60, + 80.47,-148.87, 78.59, -34.84, 74.94, -20.15, 72.70, -21.28 +/ DATA (TAGMAG(K, 16),K=1, 7)/ +'K','K','K','K','K','K','K' +/ DATA (AGEMAG(K, 16),K=1, 7) / +142.00,142.00,158.00,180.00,200.00,230.00,240.00 +/ DATA (((REMAG(K,L,M, 16),K=1,2),L=1,2),M=1, 7) / + 84.28,-153.66, 83.57,-145.73, 84.28,-153.66, 83.57,-145.73, + 87.37,-138.07, 84.91,-130.52, 83.59, -0.71, 83.56, -59.44, + 76.84, 7.82, 79.05, -32.45, 61.44, 5.79, 64.48, -9.60, + 56.17, 3.42, 57.15, -0.30 +/ END C C C BLOCK DATA SOUTH C C ALL DATA NECESSARY TO DEFINE OCEANIC SLAB MOTIONS, AGES, AND C AREAS OF CONTACT WITH NORTH AMERICA UNDER ENGEBRETSON'S C "SOUTHERN OPTION": KULA/VANCOUVER TRIPLE JUNCTION INITIALLY C IN CENTRAL AMERICA, THEN MIGRATING NORTH ALONG COAST. C C***************************************************************** C CAUTION!!! C WHEN INSTALLING THIS BLOCK DATA PROGRAM INTO ANOTHER CODE, SUCH C AS LARAMY, VERSCOMP, OR GDDMCOMP, IT IS NECESSARY TO MAKE THREE C SMALL EDITING CHANGES! C C IN THE "COMMON" STATEMENTS BELOW, CHANGE THE THREE NAMES AS C FOLLOWS: C C COMMON /SCALAR/ -> COMMON /SOUTH1/ C COMMON /ARRAYS/ -> COMMON /SOUTH2/ C COMMON /TAGS/ -> COMMON /SOUTH3/ C C THIS IS NECESSARY SO THAT THE DATA WILL BE LINKED ONLY INTO C SUBPROGRAM BELOW2 (SOUTHERN OPTION) AND NOT INTO BELOW1! C C CONVERSELY, IF YOU ARE BRINGING A BLOCK DATA PROGRAM BACK TO C BE INSPECTED AND/OR EDITED WITH MAPPER, IT IS NECCESARY TO C CHANGE THE COMMON BLOCK NAMES BACK TO THE NAMES IN THE LEFT C COLUMN ABOVE. C****************************************************************** C C COMMENTS ON COORDINATES AND UNITS C MOST OF THE DATA IN THIS UNIT ARE IN ROUND-EARTH COORDINATES C OF (LATITUDE,LONGITUDE). THE UNITS ARE DEGREES; FOR MORE C PRECISION WE USE DECIMAL FRACTIONS OF DEGREES INSTEAD OF C MINUTES AND/OR SECONDS OF ARC. LATITUDE IS POSITIVE IN THE C NORTHERN HEMISPHERE. LONGITUDE IS POSITIVE EAST OF C GREENWICH, ENGLAND. C THE FINITE-ROTATION MATRICES (3 X 3) AND THE ROTATION-AXIS C VECTORS (3 X 1) USE A DIFFERENT COORDINATE SYSTEM. C IT IS CARTESIAN (X,Y,Z), WITH ITS ORIGIN AT THE CENTER C OF THE EARTH. X POINTS TOWARD (LAT=0, LON=0). C Y POINTS TOWARD (LAT=0, LON=90). Z POINTS TOWARD (LAT=90). C THE UNITS DIFFER: THE FINITE-ROTATION MATRICES ARE C DIMENSIONLESS, BUT THE ROTATION-RATE VECTORS ARE IN C RADIANS PER SECOND. C THE GEOLOGIC TIMES WHICH LABEL THE VARIOUS FEATURES ARE C EXPRESSED IN MILLIONS OF YEARS (POSITIVE = PAST). THE C LENGTH OF 1 MILLION YEARS IN THE FUNDAMENTAL TIME UNIT C (THE SECOND) IS EXPRESSED BY "TUMAP". C C---------------------------------------------------------------- C GLOSSARY OF DATA: C -AGEFZ(J,I) IS THE AGE OF FRACTURE ZONE POINT #J C IN STRIP #I. (USED BY EDITOR, NOT BY BELOWY) C -AGEHNG(I) IS THE AGE OF THE HINGELINE CURVE K C DEFINED BY REHING(I=1,2;J=1,40?;K). C -AGEKV(I) IS THE AGE OF THE KULA/VANCOUVER/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REKV3J(1-3,I). C -AGEMAG(I,J) IS THE AGE OF MAGNETIC ANOMALY I (FROM W TO E) C IN STRIPE J (FROM S TO N) ON THE PRESENT-AGE MAP. C -AGEROT(I) IS THE AGE OF THE FINITE ROTATION MATRICES C ROMATF, ROMATK, ROMATP, AND ROMATV WITH AGE INDEX I. C -AGEVEL(I) IS THE AGE OF THE RELATIVE ROTATION-AXIS VECTORS C OMEGAF, OEMGAK, OMEGAP, AND OMEGAV WITH AGE INDEX I. C -AGEVF(I) IS THE AGE OF THE VANCOUVER/FARALLON/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REVF3J(1-3,I). C -FRACZN(2,I,J) ARE THE LAT. AND LON. COORDINATES OF POINTS I C (W TO E) ALONG FRACTURE ZONE J (S TO N) ON THE MAP OF C PRESENT SLAB AGES. C -NKV3J IS THE NUMBER OF KULA/VANCOUVER/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REKV3J(1-3,I) AT AGE AGEKV(I). C -NMAG(K) IS THE NUMBER OF LINEAR MAGNETIC ANOMALIES C WITHIN STRIPE K (S TO N) OF THE MAP OF PRESENT SLAB C AGES. C -NPHING(I) IS THE NUMBER C OF DIGITIZED POINTS IN HINGELINE CURVE #I OF REHING. C -NPFZ(J) IS THE NUMBER OF POINTS (W TO E) DEFINING FRACTURE ZONE C J (S TO N) ON THE MAP OF PRESENT SLAB AGES. C -NROMAT IS THE NUMBER OF FINITE-ROTATION MATRICES C GIVEN FOR EACH PLATE. C -NVF3J IS THE NUMBER OF VANCOUVER/FARALLON/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REVF3J(1-3,I) AT AGE AGEVF(I). C -NTAPES IS THE NUMBER OF STRIPS OF MAGNETIC ANOMALIES ON C THE MAP OF PRESENT SLAB AGES; ONE LESS THAN THE NUMBER OF C FRACTURE ZONES ON THE MAP. C -NUMHNG IS THE NUMBER OF SLAB HINGELINES (AT DIFFERENT TIMES). C -NUMVEL IS THE NUMBER OF AGES AGEVEL(I) WHERE RELATIVE C ROTATION-AXIS VECTORS (OMEGAF/K/P/V) ARE SUPPLIED. C -OMEGAF(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE FARALLON C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAK(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE KULA C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAP(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE PACIFIC C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAV(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE VANCOUVER C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -REHING(I,J,K) ARE THE LAT. (I=1) AND LON. (I=2) COORDINATES C OF THE DIGITIZED POINT #J (N TO S) OF THE HINGELINE C CURVE #K (PAST TO PRESENT). C -REKV3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE KULA/ C VANCOUVER/NORTH AMERICAN TRIPLE-JUNCTION AT AGE AGEKV(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -REMAG(2,2,I,J) ARE THE LAT., LON. COORDINATES (1ST SUB.) C OF THE N AND S ENDS (2ND SUB.) OF THE LINEAR MAGNETIC C ANOMALY I (W TO E) IN STRIPE J (S TO N) OF THE C PRESENT SLAB AGE MAP. C -REVF3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE C VANCOUVER/FARALLON/N.A. TRIPLE-JUNCTION AT AGE AGEVF(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -ROMATF(3,3,K) ARE THE ROTATION MATRICES FOR FARALLON WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATK(3,3,K) ARE THE ROTATION MATRICES FOR KULA WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATP(3,3,K) ARE THE ROTATION MATRICES FOR PACIFIC WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATV(3,3,K) ARE THE ROTATION MATRICES FOR VANCOUVER WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -TAGFZ(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE FRACTURE ZONE POINT #I C IN STRIP #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TAGMAG(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE MAGNETIC ANOM. #I IN STRIP C #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TUMAP IS A CONVENIENCE MULTIPLIER APPLIED TO AGES IN M.Y. C TO OBTAIN THE TRUE AGE IN PROGRAM UNITS (SECONDS). C------------------------------------------------------------------ C C MEMO: ORDER IS: PARAMETER, TYPE, COMMON, DIMENSION, DATA C C********************************************************************* C C NOTE: THESE DIMENSION PARAMETERS MUST AGREE C IN ALL PROGRAMS !!!!!! C C MAXIMUM NUMBER OF DIGITISED SLAB HINGELINES: PARAMETER (MAXHL=20) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED HINGELINE: PARAMETER (MAXHNG=40) C MAXIMUM NUMBER OF FINITE ROTATIONS FOR EACH PLATE: PARAMETER (MAXROT=21) C MAXIMUM NUMBER OF RELATIVE ROTATION-AXIS VECTORS FOR EACH PLATE: PARAMETER (MAXVEL=20) C MAXIMUM NUMBER OF AGES WHEN KULA/VANCOUVER TRIPLE-JUNCTION IS GIVEN: PARAMETER (MXKV3J =50) C MAXIM.NUMBER OF AGES WHEN VANCOUVER/FARALLON TRIPLE-JUNCTION IS GIVEN PARAMETER (MXVF3J =50) C MAXIMUM NUMBER OF STRIPS OF SEAFLOOR (BETWEEN FRACTURE ZONES) ON MAP: PARAMETER (MTAPES =40,MTAPP1=41) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED FRACTURE ZONE: PARAMETER (MAXFZP=100) C MAXIMUM NUMBER OF MAGNETIC ANOMALIES IN ANY ONE STRIP: PARAMETER (MAXMAG=100) C********************************************************************* CHARACTER*1 TAGFZ,TAGMAG C-------------------------------------------------------------------- COMMON /SOUTH1/ + NKV3J, + NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, + TUMAP COMMON /SOUTH2/ + AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, + FRACZN,NMAG,NPFZ,NPHING, + OMEGAF,OMEGAK,OMEGAP,OMEGAV, + REHING,REKV3J,REMAG,REVF3J, + ROMATF,ROMATK,ROMATP,ROMATV COMMON /SOUTH3/ + TAGFZ,TAGMAG C-------------------------------------------------------------------- DIMENSION AGEFZ(MAXFZP,MTAPP1), 2 AGEHNG(MAXHL), 3 AGEKV(MXKV3J), 4 AGEMAG(MAXMAG,MTAPES), 5 AGEROT(MAXROT), 6 AGEVEL(MAXVEL), 7 AGEVF(MXVF3J), 8 FRACZN(2,MAXFZP,MTAPP1), 9 NPFZ(MTAPP1), A NPHING(MAXHNG) DIMENSION NMAG(MTAPES), 2 OMEGAF(3,MAXVEL), 3 OMEGAK(3,MAXVEL), 4 OMEGAP(3,MAXVEL), 5 OMEGAV(3,MAXVEL), 6 REHING(2,MAXHNG,MAXHL), 7 REKV3J(3,MXKV3J), 8 REMAG(2,2,MAXMAG,MTAPES), 9 REVF3J(3,MXVF3J), A ROMATF(3,3,MAXROT), 1 ROMATK(3,3,MAXROT), 2 ROMATP(3,3,MAXROT), 3 ROMATV(3,3,MAXROT), 4 TAGFZ(MAXFZP,MTAPP1), 5 TAGMAG(MAXMAG,MTAPES) C C===1=== SLAB HINGELINES ======================= C DATA NUMHNG / 14/ DATA TUMAP /3.15576E13/ DATA (AGEHNG(I),I=1, 14) / + 90.00, 80.00, 75.00, 65.00, 55.00, 45.00, 40.00, 35.00, + 30.00, 27.50, 20.00, 10.00, 0.00, -3.00 + / DATA (NPHING(I),I=1, 14) / + 29, 29, 33, 34, 31, 35, 32, 26, 31, 30, 30, 27, 31, 31 + / DATA ((REHING(I,J, 1),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.93,-121.73, 43.26,-120.79, 42.45,-120.19, + 41.36,-119.63, 40.28,-119.46, 38.96,-119.44, 37.33,-119.31, + 35.93,-118.93, 33.70,-117.83, 31.95,-116.51, 30.19,-114.64, + 28.43,-112.42, 27.31,-110.50, 26.22,-108.89, 24.93,-106.85, + 23.66,-105.23, 22.25,-103.60, 20.84,-102.03, 19.21,-100.57, + 17.67, -99.09 + / DATA ((REHING(I,J, 2),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.93,-121.73, 43.26,-120.79, 42.45,-120.19, + 41.36,-119.63, 40.28,-119.46, 38.96,-119.44, 37.33,-119.31, + 35.93,-118.93, 33.70,-117.83, 31.95,-116.51, 30.19,-114.64, + 28.43,-112.42, 27.31,-110.50, 26.22,-108.89, 24.93,-106.85, + 23.66,-105.23, 22.25,-103.60, 20.84,-102.03, 19.21,-100.57, + 17.67, -99.09 + / DATA ((REHING(I,J, 3),I=1,2),J=1, 33) / + 60.24,-142.90, 58.27,-136.08, 57.06,-133.84, 55.56,-132.30, + 54.31,-131.06, 52.34,-129.57, 50.99,-128.46, 49.68,-127.62, + 48.64,-126.31, 47.41,-124.10, 46.20,-121.40, 45.21,-118.79, + 44.38,-116.32, 43.59,-113.87, 42.71,-111.45, 41.95,-110.30, + 40.87,-109.75, 39.46,-109.53, 38.07,-109.47, 36.40,-109.69, + 34.97,-110.12, 33.38,-111.48, 32.18,-112.63, 31.23,-113.29, + 30.55,-113.21, 29.70,-112.07, 28.45,-110.41, 26.85,-108.26, + 25.03,-106.06, 22.76,-103.36, 20.40,-100.83, 18.53, -98.91, + 15.76, -95.35 + / DATA ((REHING(I,J, 4),I=1,2),J=1, 34) / + 59.74,-142.93, 57.85,-135.98, 57.15,-134.10, 56.01,-132.85, + 54.68,-131.71, 52.77,-130.21, 50.90,-128.84, 49.63,-127.75, + 48.60,-126.11, 47.65,-124.22, 47.03,-122.13, 46.41,-119.25, + 46.11,-116.86, 45.83,-114.22, 45.56,-111.04, 45.24,-108.41, + 44.65,-106.77, 43.72,-105.66, 42.82,-105.87, 41.25,-106.39, + 39.96,-107.68, 38.23,-109.58, 36.53,-111.05, 34.82,-112.31, + 33.11,-113.12, 32.14,-113.13, 31.23,-112.40, 30.09,-111.04, + 28.34,-108.86, 26.70,-106.84, 24.65,-104.56, 22.44,-102.17, + 18.04, -97.90, 14.33, -93.82 + / DATA ((REHING(I,J, 5),I=1,2),J=1, 31) / + 60.18,-142.67, 58.34,-135.99, 57.39,-133.91, 55.54,-131.68, + 53.24,-129.30, 51.45,-127.33, 49.34,-124.96, 47.58,-122.87, + 45.85,-120.92, 44.34,-118.67, 43.75,-116.92, 43.72,-114.46, + 43.59,-111.55, 43.34,-108.91, 42.86,-107.05, 42.13,-105.45, + 41.13,-104.87, 40.08,-104.90, 38.70,-105.39, 37.13,-106.70, + 35.70,-107.90, 34.13,-109.17, 32.75,-109.71, 31.34,-109.71, + 30.37,-109.16, 29.06,-107.62, 26.11,-104.35, 22.91,-101.21, + 20.18, -98.61, 18.86, -97.37, 15.81, -93.90 + / DATA ((REHING(I,J, 6),I=1,2),J=1, 35) / + 59.65,-143.76, 57.90,-136.31, 57.31,-134.75, 56.45,-133.35, + 55.25,-132.01, 53.95,-130.78, 52.54,-129.43, 50.88,-127.99, + 49.81,-126.43, 49.25,-124.90, 48.58,-123.85, 47.46,-122.86, + 46.31,-121.77, 44.75,-120.30, 43.36,-119.35, 41.49,-118.46, + 40.66,-117.90, 40.03,-116.96, 39.46,-115.55, 39.13,-113.64, + 38.99,-111.33, 38.87,-108.52, 38.77,-106.09, 38.39,-104.45, + 38.00,-103.53, 37.37,-103.42, 35.34,-103.89, 32.58,-104.54, + 29.82,-105.05, 27.44,-105.42, 24.90,-103.03, 22.70,-101.09, + 20.05, -98.86, 17.88, -96.95, 14.95, -94.01 + / DATA ((REHING(I,J, 7),I=1,2),J=1, 32) / + 60.15,-144.12, 58.32,-136.58, 57.58,-134.52, 55.82,-132.18, + 53.60,-130.20, 51.68,-128.54, 50.56,-127.44, 49.48,-125.13, + 48.21,-123.37, 45.85,-121.58, 43.62,-119.92, 41.89,-118.52, + 40.13,-116.35, 39.11,-114.39, 38.47,-112.91, 38.07,-111.01, + 37.86,-108.95, 37.68,-106.27, 37.11,-104.05, 36.49,-103.28, + 35.59,-103.92, 33.92,-105.34, 32.65,-107.07, 31.58,-108.11, + 30.77,-108.67, 30.04,-107.87, 28.35,-106.21, 25.94,-103.92, + 23.23,-101.36, 19.92, -98.62, 18.08, -97.05, 14.58, -93.85 + / DATA ((REHING(I,J, 8),I=1,2),J=1, 26) / + 60.73,-144.29, 58.48,-135.82, 56.96,-132.82, 54.44,-130.45, + 51.91,-128.35, 50.62,-126.85, 49.32,-124.72, 47.04,-122.53, + 45.09,-121.21, 43.27,-119.94, 41.70,-118.85, 39.66,-117.43, + 38.07,-115.05, 37.24,-112.97, 36.83,-110.87, 36.60,-109.39, + 36.22,-108.78, 35.56,-108.94, 33.64,-110.03, 32.23,-110.38, + 31.18,-109.93, 30.10,-108.77, 27.69,-106.20, 24.64,-103.37, + 19.55, -98.74, 14.66, -94.17 + / DATA ((REHING(I,J, 9),I=1,2),J=1, 31) / + 59.94,-142.45, 58.14,-135.36, 56.98,-133.18, 54.87,-131.29, + 52.93,-129.48, 51.68,-128.44, 50.98,-127.72, 50.43,-126.82, + 49.58,-125.10, 48.58,-123.85, 45.67,-121.39, 43.86,-120.19, + 41.92,-118.74, 39.65,-117.67, 38.14,-116.22, 37.34,-114.59, + 36.86,-113.27, 36.59,-112.50, 36.18,-112.04, 35.60,-111.96, + 34.88,-112.15, 34.29,-112.49, 33.70,-112.81, 32.69,-112.03, + 31.73,-110.98, 29.66,-108.65, 27.54,-106.42, 24.80,-103.95, + 23.88,-103.22, 18.54, -98.67, 14.42, -94.83 + / DATA ((REHING(I,J, 10),I=1,2),J=1, 30) / + 60.05,-142.71, 58.15,-135.55, 57.19,-133.78, 55.93,-132.21, + 54.27,-130.67, 53.02,-129.56, 51.61,-128.52, 50.80,-127.58, + 50.24,-126.63, 49.34,-124.96, 48.34,-123.62, 47.04,-122.53, + 45.82,-121.46, 44.32,-120.36, 42.71,-119.19, 40.97,-118.24, + 39.38,-117.47, 38.13,-116.62, 36.88,-115.49, 35.88,-114.63, + 35.07,-113.90, 34.07,-113.38, 32.72,-112.14, 31.60,-110.78, + 29.45,-108.57, 27.14,-106.05, 24.28,-103.50, 21.45,-101.15, + 18.32, -98.45, 14.79, -95.22 + / DATA ((REHING(I,J, 11),I=1,2),J=1, 30) / + 60.40,-143.60, 58.26,-135.89, 57.30,-133.82, 55.79,-132.11, + 54.09,-130.51, 52.22,-128.93, 50.89,-127.65, 50.16,-126.36, + 48.98,-124.38, 47.60,-123.01, 45.84,-122.17, 43.62,-121.86, + 41.51,-121.12, 39.45,-120.08, 37.52,-118.43, 36.38,-117.33, + 35.75,-116.30, 35.15,-114.95, 34.51,-113.95, 33.50,-113.29, + 32.45,-112.66, 31.69,-112.09, 30.03,-110.31, 28.29,-108.49, + 26.74,-106.94, 24.73,-105.04, 22.76,-103.43, 19.82,-100.93, + 18.03, -99.36, 15.25, -96.89 + / DATA ((REHING(I,J, 12),I=1,2),J=1, 27) / + 60.42,-144.51, 58.53,-136.13, 57.88,-134.36, 56.05,-132.25, + 54.05,-130.39, 52.11,-128.80, 50.74,-127.47, 50.15,-126.46, + 49.50,-125.28, 48.27,-123.80, 47.15,-122.81, 46.39,-122.50, + 45.08,-122.44, 43.55,-122.58, 41.65,-121.97, 39.91,-120.91, + 38.15,-119.72, 36.58,-117.83, 34.34,-115.15, 31.39,-111.97, + 28.32,-108.97, 26.00,-106.84, 23.14,-104.47, 21.37,-103.15, + 20.03,-101.83, 18.36,-100.47, 13.50, -94.94 + / DATA ((REHING(I,J, 13),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / DATA ((REHING(I,J, 14),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / C C===2=== CODE GENERATED BY PROGRAM "ALL4" PLATE ROTATER: ===== C DATA NROMAT / 18/ DATA (AGEROT(I),I=1, 18) / + 0.00, 3.63, 10.30, 19.90, 25.80, 30.00, 35.60, 42.00, + 49.55, 58.90, 68.50, 72.40, 85.00, 119.00, 127.00, 135.00, + 145.00, 163.00 + / DATA ((ROMATF(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATF(I,J, 2),J=1,3),I=1,3) +/ 0.9984418, 0.0249586, 0.0499063, + -0.0236761, 0.9993781,-0.0261258, + -0.0505273, 0.0249035, 0.9984120/ DATA ((ROMATF(I,J, 3),J=1,3),I=1,3) +/ 0.9965000,-0.0015017, 0.0835752, + 0.0016967, 0.9999958,-0.0022638, + -0.0835716, 0.0023977, 0.9964986/ DATA ((ROMATF(I,J, 4),J=1,3),I=1,3) +/ 0.9870884,-0.0794135, 0.1391012, + 0.0779809, 0.9968305, 0.0157267, + -0.1399093,-0.0046764, 0.9901530/ DATA ((ROMATF(I,J, 5),J=1,3),I=1,3) +/ 0.9816186,-0.0953112, 0.1653471, + 0.0902718, 0.9952011, 0.0377464, + -0.1681514,-0.0221263, 0.9855123/ DATA ((ROMATF(I,J, 6),J=1,3),I=1,3) +/ 0.9772222,-0.1307292, 0.1671685, + 0.1217395, 0.9905611, 0.0629824, + -0.1738244,-0.0411969, 0.9839141/ DATA ((ROMATF(I,J, 7),J=1,3),I=1,3) +/ 0.9643680,-0.2176023, 0.1504717, + 0.2023463, 0.9730743, 0.1103661, + -0.1704363,-0.0759863, 0.9824339/ DATA ((ROMATF(I,J, 8),J=1,3),I=1,3) +/ 0.9355122,-0.3127865, 0.1642541, + 0.2875628, 0.9442505, 0.1603019, + -0.2052376,-0.1027311, 0.9733049/ DATA ((ROMATF(I,J, 9),J=1,3),I=1,3) +/ 0.8698806,-0.4633711, 0.1690941, + 0.4200012, 0.8755688, 0.2386968, + -0.2586591,-0.1366181, 0.9562580/ DATA ((ROMATF(I,J, 10),J=1,3),I=1,3) +/ 0.7665346,-0.5965531, 0.2377952, + 0.4980173, 0.7859663, 0.3663787, + -0.4054641,-0.1624160, 0.8995655/ DATA ((ROMATF(I,J, 11),J=1,3),I=1,3) +/ 0.6799753,-0.6748897, 0.2866260, + 0.4922036, 0.7098752, 0.5037958, + -0.5434762,-0.2014907, 0.8148823/ DATA ((ROMATF(I,J, 12),J=1,3),I=1,3) +/ 0.6364845,-0.7003338, 0.3231361, + 0.4905679, 0.6908776, 0.5310636, + -0.5951703,-0.1794939, 0.7832956/ DATA ((ROMATF(I,J, 13),J=1,3),I=1,3) +/ 0.5407817,-0.7359961, 0.4072609, + 0.3967867, 0.6501144, 0.6480033, + -0.7416956,-0.1888330, 0.6436048/ DATA ((ROMATF(I,J, 14),J=1,3),I=1,3) +/ 0.1260393,-0.9004962, 0.4161935, + 0.4084943, 0.4294313, 0.8054301, + -0.9040152, 0.0684970, 0.4219739/ DATA ((ROMATF(I,J, 15),J=1,3),I=1,3) +/ 0.0432563,-0.8638376, 0.5019060, + 0.3372753, 0.4855096, 0.8065493, + -0.9404098, 0.1343924, 0.3123534/ DATA ((ROMATF(I,J, 16),J=1,3),I=1,3) +/ -0.0372843,-0.8243719, 0.5648155, + 0.2585098, 0.5380124, 0.8023162, + -0.9652870, 0.1759245, 0.1930498/ DATA ((ROMATF(I,J, 17),J=1,3),I=1,3) +/ -0.0857564,-0.7854440, 0.6129592, + 0.2832710, 0.5706134, 0.7708135, + -0.9551961, 0.2397366, 0.1735606/ DATA ((ROMATF(I,J, 18),J=1,3),I=1,3) +/ -0.3959168,-0.6532624, 0.6453629, + 0.3365481, 0.5506653, 0.7638706, + -0.8543893, 0.5196268, 0.0018373/ DATA ((ROMATK(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATK(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATK(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATK(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATK(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATK(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATK(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATK(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATK(I,J, 9),J=1,3),I=1,3) +/ 0.8926937, 0.3237427, 0.3135092, + -0.3673854, 0.9256842, 0.0902017, + -0.2610084,-0.1957012, 0.9452911/ DATA ((ROMATK(I,J, 10),J=1,3),I=1,3) +/ 0.8382884, 0.2792339, 0.4682950, + -0.4014298, 0.8973089, 0.1835486, + -0.3689522,-0.3418544, 0.8642969/ DATA ((ROMATK(I,J, 11),J=1,3),I=1,3) +/ 0.7479138, 0.2368386, 0.6201060, + -0.4491286, 0.8684335, 0.2100139, + -0.4887816,-0.4355798, 0.7558849/ DATA ((ROMATK(I,J, 12),J=1,3),I=1,3) +/ 0.7069741, 0.2202590, 0.6720657, + -0.4550582, 0.8691026, 0.1938600, + -0.5413948,-0.4428831, 0.7146643/ DATA ((ROMATK(I,J, 13),J=1,3),I=1,3) +/ 0.4927713, 0.2023760, 0.8462971, + -0.5685837, 0.8111188, 0.1371042, + -0.6587012,-0.5487522, 0.5147643/ DATA ((ROMATK(I,J, 14),J=1,3),I=1,3) +/ 0.2884439,-0.0305855, 0.9570071, + -0.2699646, 0.9563414, 0.1119320, + -0.9186499,-0.2906443, 0.2675945/ DATA ((ROMATK(I,J, 15),J=1,3),I=1,3) +/ 0.1826985, 0.0447444, 0.9821491, + -0.2405134, 0.9706448, 0.0005196, + -0.9532956,-0.2363152, 0.1880977/ DATA ((ROMATK(I,J, 16),J=1,3),I=1,3) +/ 0.0730065, 0.1148067, 0.9907003, + -0.2118030, 0.9724770,-0.0970868, + -0.9745805,-0.2027456, 0.0953141/ DATA ((ROMATK(I,J, 17),J=1,3),I=1,3) +/ 0.0737035, 0.1703374, 0.9826242, + -0.1573972, 0.9749421,-0.1572000, + -0.9847798,-0.1430762, 0.0986680/ DATA ((ROMATK(I,J, 18),J=1,3),I=1,3) +/ -0.0087966, 0.2534258, 0.9673132, + 0.1625878, 0.9548408,-0.2486796, + -0.9866534, 0.1550863,-0.0496027/ DATA ((ROMATP(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATP(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATP(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATP(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATP(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATP(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATP(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATP(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATP(I,J, 9),J=1,3),I=1,3) +/ 0.9036663, 0.3323698, 0.2700321, + -0.3557910, 0.9336445, 0.0414807, + -0.2383270,-0.1335597, 0.9619573/ DATA ((ROMATP(I,J, 10),J=1,3),I=1,3) +/ 0.8783061, 0.3137228, 0.3607716, + -0.3583550, 0.9314973, 0.0624035, + -0.3164804,-0.1840937, 0.9305640/ DATA ((ROMATP(I,J, 11),J=1,3),I=1,3) +/ 0.8133826, 0.3327699, 0.4771508, + -0.4012021, 0.9148389, 0.0458976, + -0.4212428,-0.2287661, 0.8776220/ DATA ((ROMATP(I,J, 12),J=1,3),I=1,3) +/ 0.7885006, 0.3410243, 0.5118291, + -0.4008002, 0.9161383, 0.0070450, + -0.4665038,-0.2106962, 0.8590583/ DATA ((ROMATP(I,J, 13),J=1,3),I=1,3) +/ 0.6594428, 0.4211499, 0.6227100, + -0.4718215, 0.8767433,-0.0933034, + -0.5852515,-0.2322797, 0.7768697/ DATA ((ROMATP(I,J, 14),J=1,3),I=1,3) +/ 0.5735050, 0.5730298, 0.5854303, + -0.4726608, 0.8151487,-0.3348495, + -0.6690916,-0.0846720, 0.7383407/ DATA ((ROMATP(I,J, 15),J=1,3),I=1,3) +/ 0.5466521, 0.6209800, 0.5617428, + -0.4979524, 0.7804186,-0.3781402, + -0.6732122,-0.0730101, 0.7358360/ DATA ((ROMATP(I,J, 16),J=1,3),I=1,3) +/ 0.5130962, 0.6671163, 0.5400814, + -0.5285266, 0.7413454,-0.4136018, + -0.6763074,-0.0732298, 0.7329704/ DATA ((ROMATP(I,J, 17),J=1,3),I=1,3) +/ 0.5677590, 0.7006614, 0.4321147, + -0.5501299, 0.7134408,-0.4340037, + -0.6123779, 0.0086904, 0.7905173/ DATA ((ROMATP(I,J, 18),J=1,3),I=1,3) +/ 0.7427920, 0.5855252, 0.3246846, + -0.3852086, 0.7703925,-0.5080448, + -0.5476077, 0.2523004, 0.7977908/ DATA ((ROMATV(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATV(I,J, 2),J=1,3),I=1,3) +/ 0.9993297, 0.0051820, 0.0362338, + -0.0047712, 0.9999232,-0.0114144, + -0.0362902, 0.0112339, 0.9992780/ DATA ((ROMATV(I,J, 3),J=1,3),I=1,3) +/ 0.9966072,-0.0024635, 0.0822646, + 0.0025242, 0.9999963,-0.0006345, + -0.0822628, 0.0008400, 0.9966100/ DATA ((ROMATV(I,J, 4),J=1,3),I=1,3) +/ 0.9874673,-0.0822613, 0.1346872, + 0.0813513, 0.9966096, 0.0122550, + -0.1352387,-0.0011445, 0.9908120/ DATA ((ROMATV(I,J, 5),J=1,3),I=1,3) +/ 0.9769385,-0.0981460, 0.1896242, + 0.0957089, 0.9951658, 0.0219901, + -0.1908659,-0.0033342, 0.9816099/ DATA ((ROMATV(I,J, 6),J=1,3),I=1,3) +/ 0.9672080,-0.1004198, 0.2332878, + 0.0970278, 0.9949411, 0.0260009, + -0.2347188,-0.0025129, 0.9720595/ DATA ((ROMATV(I,J, 7),J=1,3),I=1,3) +/ 0.9578496,-0.1985734, 0.2075841, + 0.1860558, 0.9794068, 0.0783809, + -0.2188739,-0.0364552, 0.9750712/ DATA ((ROMATV(I,J, 8),J=1,3),I=1,3) +/ 0.9285972,-0.3330147, 0.1637273, + 0.3143928, 0.9404002, 0.1296231, + -0.1971359,-0.0688933, 0.9779518/ DATA ((ROMATV(I,J, 9),J=1,3),I=1,3) +/ 0.8519540,-0.5116365, 0.1113576, + 0.4857856, 0.8516892, 0.1965587, + -0.1954090,-0.1133634, 0.9741470/ DATA ((ROMATV(I,J, 10),J=1,3),I=1,3) +/ 0.7341714,-0.6763662, 0.0593198, + 0.6286086, 0.7101420, 0.3170907, + -0.2565954,-0.1955106, 0.9465370/ DATA ((ROMATV(I,J, 11),J=1,3),I=1,3) +/ 0.6687082,-0.7369352, 0.0987580, + 0.6230298, 0.6278643, 0.4664944, + -0.4057837,-0.2504201, 0.8789921/ DATA ((ROMATV(I,J, 12),J=1,3),I=1,3) +/ 0.6332583,-0.7620972, 0.1348656, + 0.6199963, 0.6038375, 0.5009806, + -0.4632338,-0.2336346, 0.8548840/ DATA ((ROMATV(I,J, 13),J=1,3),I=1,3) +/ 0.5726639,-0.7899240, 0.2192550, + 0.5270615, 0.5596170, 0.6395554, + -0.6279004,-0.2506902, 0.7368125/ DATA ((ROMATV(I,J, 14),J=1,3),I=1,3) +/ 0.1862030,-0.9539652, 0.2351070, + 0.4969981, 0.2978723, 0.8150220, + -0.8475366,-0.0349119, 0.5295847/ DATA ((ROMATV(I,J, 15),J=1,3),I=1,3) +/ 0.1202118,-0.9349756, 0.3337152, + 0.4187091, 0.3525420, 0.8368945, + -0.9001268, 0.0391250, 0.4338636/ DATA ((ROMATV(I,J, 16),J=1,3),I=1,3) +/ 0.0559588,-0.9094425, 0.4120423, + 0.3322897, 0.4061266, 0.8512579, + -0.9415139, 0.0892823, 0.3249255/ DATA ((ROMATV(I,J, 17),J=1,3),I=1,3) +/ 0.0035101,-0.8845617, 0.4664051, + 0.3494043, 0.4380954, 0.8282415, + -0.9369633, 0.1600573, 0.3106084/ DATA ((ROMATV(I,J, 18),J=1,3),I=1,3) +/ -0.3217998,-0.7897338, 0.5222647, + 0.3520011, 0.4122773, 0.8403078, + -0.8789400, 0.4542502, 0.1453171/ DATA NUMVEL / 17/ DATA (AGEVEL(I),I=1, 17) / + 1.81, 6.97, 15.10, 22.85, 27.90, 32.80, 38.80, 45.77, + 54.22, 63.70, 70.45, 78.70, 102.00, 123.00, 131.00, 140.00, + 154.00 + / DATA (OMEGAF(I, 1),I=1,3) + / 2.22436E-16, 4.37785E-16,-2.11997E-16/ DATA (OMEGAF(I, 2),I=1,3) + /-1.15243E-16, 1.59143E-16, 1.18424E-16/ DATA (OMEGAF(I, 3),I=1,3) + /-5.20186E-17, 1.86928E-16, 2.53471E-16/ DATA (OMEGAF(I, 4),I=1,3) + /-1.06009E-16, 1.52830E-16, 7.04799E-17/ DATA (OMEGAF(I, 5),I=1,3) + /-1.88225E-16, 3.57680E-17, 2.41271E-16/ DATA (OMEGAF(I, 6),I=1,3) + /-2.80863E-16,-4.69432E-17, 4.60480E-16/ DATA (OMEGAF(I, 7),I=1,3) + /-2.23587E-16, 1.34246E-16, 4.59035E-16/ DATA (OMEGAF(I, 8),I=1,3) + /-3.01794E-16, 1.52210E-16, 6.43195E-16/ DATA (OMEGAF(I, 9),I=1,3) + /-2.67001E-16, 4.56656E-16, 4.83609E-16/ DATA (OMEGAF(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAF(I, 11),I=1,3) + /-7.69435E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAF(I, 12),I=1,3) + /-1.10799E-16, 4.93623E-16, 8.32111E-17/ DATA (OMEGAF(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAF(I, 14),I=1,3) + / 3.42999E-16, 4.32696E-16, 1.46227E-16/ DATA (OMEGAF(I, 15),I=1,3) + / 2.93430E-16, 4.47830E-16, 9.47212E-17/ DATA (OMEGAF(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAF(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAK(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAK(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAK(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAK(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAK(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAK(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAK(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAK(I, 8),I=1,3) + /-3.42895E-16, 3.07318E-16,-7.84280E-18/ DATA (OMEGAK(I, 9),I=1,3) + /-5.24123E-16, 4.21964E-16,-6.28934E-17/ DATA (OMEGAK(I, 10),I=1,3) + /-3.47853E-16, 5.17207E-16,-6.26469E-17/ DATA (OMEGAK(I, 11),I=1,3) + /-1.29789E-16, 5.39917E-16, 7.00136E-17/ DATA (OMEGAK(I, 12),I=1,3) + /-2.25126E-16, 6.46717E-16,-2.10399E-16/ DATA (OMEGAK(I, 13),I=1,3) + /-8.79291E-17, 2.40344E-16, 3.43456E-16/ DATA (OMEGAK(I, 14),I=1,3) + / 3.42972E-16, 4.32656E-16, 1.46203E-16/ DATA (OMEGAK(I, 15),I=1,3) + / 2.93406E-16, 4.47800E-16, 9.47100E-17/ DATA (OMEGAK(I, 16),I=1,3) + / 1.91374E-16, 2.29230E-17, 1.74145E-16/ DATA (OMEGAK(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAP(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAP(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAP(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAP(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAP(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAP(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAP(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAP(I, 8),I=1,3) + /-7.95765E-17, 2.01210E-16, 3.16566E-17/ DATA (OMEGAP(I, 9),I=1,3) + /-1.82793E-16, 2.78850E-16, 6.21172E-18/ DATA (OMEGAP(I, 10),I=1,3) + /-1.10363E-16, 4.11618E-16,-1.28934E-16/ DATA (OMEGAP(I, 11),I=1,3) + / 1.61156E-16, 4.19784E-16, 1.56999E-17/ DATA (OMEGAP(I, 12),I=1,3) + / 7.46968E-17, 4.23581E-16,-2.19155E-16/ DATA (OMEGAP(I, 13),I=1,3) + / 2.04277E-16, 1.08618E-16,-2.84094E-17/ DATA (OMEGAP(I, 14),I=1,3) + / 1.92305E-16, 3.73766E-17,-1.42336E-16/ DATA (OMEGAP(I, 15),I=1,3) + / 1.61534E-16, 3.43348E-17,-1.77105E-16/ DATA (OMEGAP(I, 16),I=1,3) + / 2.87845E-16,-2.68429E-16, 6.23380E-17/ DATA (OMEGAP(I, 17),I=1,3) + / 2.19652E-16,-7.13669E-17, 4.34363E-16/ DATA (OMEGAV(I, 1),I=1,3) + / 9.86981E-17, 3.16045E-16,-4.33668E-17/ DATA (OMEGAV(I, 2),I=1,3) + /-5.14985E-17, 2.19222E-16, 3.33668E-17/ DATA (OMEGAV(I, 3),I=1,3) + /-3.52269E-17, 1.75936E-16, 2.61668E-16/ DATA (OMEGAV(I, 4),I=1,3) + /-2.56065E-17, 3.02977E-16, 8.26955E-17/ DATA (OMEGAV(I, 5),I=1,3) + / 2.38990E-18, 3.39059E-16, 1.81821E-17/ DATA (OMEGAV(I, 6),I=1,3) + /-3.14872E-16,-1.02187E-16, 5.04872E-16/ DATA (OMEGAV(I, 7),I=1,3) + /-3.01822E-16,-1.44934E-16, 6.45606E-16/ DATA (OMEGAV(I, 8),I=1,3) + /-3.48720E-16,-8.07761E-17, 7.85876E-16/ DATA (OMEGAV(I, 9),I=1,3) + /-4.42586E-16, 1.09988E-16, 6.53606E-16/ DATA (OMEGAV(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAV(I, 11),I=1,3) + /-7.83352E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAV(I, 12),I=1,3) + /-1.10796E-16, 4.93633E-16, 8.32232E-17/ DATA (OMEGAV(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAV(I, 14),I=1,3) + / 3.42996E-16, 4.32686E-16, 1.46215E-16/ DATA (OMEGAV(I, 15),I=1,3) + / 2.93417E-16, 4.47842E-16, 9.47149E-17/ DATA (OMEGAV(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAV(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ C C===3=== DATA MODIFIED BY PROGRAM MAPPER ========== C C DATA NTAPES/ 20/,NTAPP1/ 21/,NKV3J/ 25/,NVF3J/ 10/ C C C DATA ((REKV3J(K,I),K=1,3),I=1, 15) / + 48.02,-132.16, 56., + 49.33,-132.96, 12., + 49.33,-132.96, 12., + 48.01,-132.01, 11., + 47.39,-130.70, 10., + 45.93,-130.92, 10., + 44.32,-127.85, 8., + 41.83,-123.69, 5., + 41.25,-122.81, -14., + 41.25,-122.81, -14., + 41.25,-122.81, -22., + 40.05,-122.54, -22., + 38.85,-122.28, -22., + 37.90,-122.09, -22., + 36.42,-122.04, -27. +/ DATA ((REKV3J(K,I),K=1,3),I=16,25) / + 35.29,-121.58, -30., + 33.41,-121.23, -33., + 30.61,-118.12, -36., + 29.73,-117.83, -39., + 26.99,-113.59, -39., + 19.30,-103.73, -46., + 15.16, -99.67, 33., + 12.16, -99.50, 33., + 9.74, -97.46, 32., + 8.54, -96.87, 31. +/ DATA ((REVF3J(K,I),K=1,3),I=1, 10) / + 28.05,-115.85, 45., + 26.08,-113.70, 43., + 26.14,-112.87, 30., + 26.14,-112.87, 30., + 25.75,-112.18, 29., + 24.61,-111.01, 45., + 24.23,-111.46, 59., + 25.26,-112.76, 36., + 1.70, -92.72, 27., + 1.70, -92.72, 27. +/ DATA (AGEKV(I),I=1, 25) / + 0.00, 10.00, 25.00, 30.00, 35.00, 40.00, 45.00, 50.00, + 51.00, 52.00, 53.00, 54.00, 55.00, 56.00, 57.00, 58.00, + 59.00, 60.00, 61.00, 62.00, 63.00, 64.00, 70.00, 80.00, + 85.00 +/ DATA (AGEVF(I),I=1, 10) / + 0.00, 30.00, 35.00, 40.00, 45.00, 50.00, 55.00, 59.00, + 60.00, 85.00 +/ C C C DATA (NPFZ(I),I=1, 21) / + 7, 6, 12, 13, 14, 18, 18, 20, 16, 16, 19, 13, 14, 15, 16, + 13, 14, 2, 15, 9, 4 +/ DATA (TAGFZ(K, 1),K=1, 7)/ +'F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 1),K=1, 7) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 1),K=1,2),L=1, 7)/ + 14.85,-102.14, 13.45, -88.33, 14.58, -78.99, 16.96, -69.97, + 18.18, -58.64, 18.35, -52.40, 16.02, -31.04 +/ DATA (TAGFZ(K, 2),K=1, 6)/ +'F','F','F','F','F','F' +/ DATA (AGEFZ(K, 2),K=1, 6) / +999.00,999.00,999.00,999.00, 99.00, 99.00 +/ DATA ((FRACZN(K,L, 2),K=1,2),L=1, 6)/ + 18.50,-102.24, 18.23, -96.47, 18.92, -86.37, 20.51, -79.06, + 23.96, -50.14, 20.97, -25.60 +/ DATA (TAGFZ(K, 3),K=1, 12)/ +'F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 3),K=1, 12) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 3),K=1,2),L=1, 12)/ + 22.79,-109.08, 21.70,-105.68, 24.61,-101.95, 24.72, -99.36, + 24.98, -91.24, 26.22, -83.42, 26.90, -75.26, 27.60, -68.02, + 28.57, -59.45, 29.26, -52.83, 23.88, -51.18, 20.97, -25.60 +/ DATA (TAGFZ(K, 4),K=1, 13)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 4),K=1, 13) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 4),K=1,2),L=1, 13)/ + 27.82,-116.19, 25.02,-111.50, 24.46,-105.70, 24.61,-101.95, + 24.72, -99.36, 24.98, -91.24, 26.22, -83.42, 26.90, -75.26, + 27.60, -68.02, 28.57, -59.45, 29.26, -52.83, 23.88, -51.18, + 20.97, -25.60 +/ DATA (TAGFZ(K, 5),K=1, 14)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 5),K=1, 14) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 5),K=1,2),L=1, 14)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 31.25,-101.62, 31.91, -94.06, 32.63, -88.76, 33.50, -81.67, + 33.67, -74.35, 33.99, -66.95, 34.67, -59.52, 34.95, -54.76, + 23.88, -51.18, 20.97, -25.60 +/ DATA (TAGFZ(K, 6),K=1, 18)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F' +/ DATA (AGEFZ(K, 6),K=1, 18) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00 +/ DATA ((FRACZN(K,L, 6),K=1,2),L=1, 18)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 31.25,-101.62, 31.91, -94.06, 32.63, -88.76, 33.50, -81.67, + 33.67, -74.35, 33.99, -66.95, 34.67, -59.52, 34.95, -54.76, + 29.24, -52.74, 29.00, -50.88, 27.34, -43.02, 23.63, -34.70, + 22.41, -31.83, 20.97, -25.60 +/ DATA (TAGFZ(K, 7),K=1, 18)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F' +/ DATA (AGEFZ(K, 7),K=1, 18) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00 +/ DATA ((FRACZN(K,L, 7),K=1,2),L=1, 18)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 33.14,-101.36, 35.05, -96.68, 36.71, -88.89, 37.85, -82.76, + 38.13, -73.94, 37.64, -61.74, 37.17, -58.77, 34.95, -54.76, + 29.24, -52.74, 29.03, -50.81, 27.34, -43.02, 23.63, -34.70, + 22.41, -31.83, 20.97, -25.60 +/ DATA (TAGFZ(K, 8),K=1, 20)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F','F','F' +/ DATA (AGEFZ(K, 8),K=1, 20) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 8),K=1,2),L=1, 20)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 33.14,-101.36, 35.05, -96.68, 36.71, -88.89, 37.85, -82.76, + 38.13, -73.94, 42.88, -64.20, 43.02, -61.57, 42.96, -59.18, + 39.07, -56.76, 34.95, -54.76, 29.24, -52.74, 29.03, -50.81, + 27.34, -43.02, 23.63, -34.70, 22.41, -31.83, 20.97, -25.60 +/ DATA (TAGFZ(K, 9),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEFZ(K, 9),K=1, 16) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 9),K=1,2),L=1, 16)/ + 40.23,-127.34, 40.23,-126.02, 38.68,-123.96, 38.42,-119.01, + 38.54,-115.83, 38.43,-112.65, 37.98,-108.57, 35.87,-103.22, + 32.52,-101.45, 33.29, -95.67, 33.50, -92.15, 34.08, -87.66, + 34.87, -81.11, 36.30, -72.68, 42.44, -64.58, 43.18, -58.92 +/ DATA (TAGFZ(K, 10),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEFZ(K, 10),K=1, 16) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 10),K=1,2),L=1, 16)/ + 40.23,-127.34, 40.23,-126.02, 38.68,-123.96, 38.42,-119.01, + 38.54,-115.83, 38.43,-112.65, 37.79,-108.25, 35.86,-103.28, + 35.04,-100.02, 35.85, -96.03, 35.86, -91.85, 36.10, -88.03, + 37.41, -81.74, 39.62, -74.33, 42.44, -64.58, 43.18, -58.92 +/ DATA (TAGFZ(K, 11),K=1, 19)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V' +/ DATA (AGEFZ(K, 11),K=1, 19) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 11),K=1,2),L=1, 19)/ + 40.23,-127.34, 40.23,-126.02, 38.68,-123.96, 38.42,-119.01, + 38.54,-115.83, 38.43,-112.65, 37.79,-108.25, 37.77,-102.97, + 37.71, -98.10, 37.70, -94.55, 37.83, -91.31, 38.45, -83.72, + 39.29, -82.15, 41.03, -79.69, 41.20, -75.80, 43.06, -66.71, + 43.68, -63.22, 44.20, -60.23, 43.18, -58.92 +/ DATA (TAGFZ(K, 12),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 12),K=1, 13) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 12),K=1,2),L=1, 13)/ + 42.86,-126.48, 42.53,-124.84, 42.39,-123.83, 41.50,-119.02, + 41.88,-115.71, 41.90,-111.99, 41.29,-107.88, 40.67,-103.81, + 40.42, -97.63, 42.27, -90.61, 46.59, -69.00, 47.39, -63.98, + 43.88, -59.85 +/ DATA (TAGFZ(K, 13),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 13),K=1, 14) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 13),K=1,2),L=1, 14)/ + 44.04,-131.51, 42.86,-126.48, 42.53,-124.84, 42.39,-123.83, + 41.50,-119.02, 45.47,-114.02, 45.42,-108.55, 44.77,-103.42, + 44.50,-100.32, 40.42, -97.63, 42.27, -90.61, 46.59, -69.00, + 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 14),K=1, 15)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 14),K=1, 15) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 14),K=1,2),L=1, 15)/ + 49.15,-130.92, 49.01,-129.37, 48.41,-125.70, 49.64,-116.32, + 50.08,-113.29, 49.37,-109.57, 48.78,-104.69, 48.21, -97.40, + 47.75, -94.87, 47.28, -86.55, 46.77, -83.58, 47.70, -70.74, + 48.75, -66.00, 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 15),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEFZ(K, 15),K=1, 16) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 15),K=1,2),L=1, 16)/ + 49.99,-129.92, 50.40,-127.83, 51.58,-125.71, 53.96,-120.53, + 54.07,-119.53, 53.79,-112.80, 52.80,-105.15, 52.43, -97.63, + 50.82, -91.98, 49.03, -90.02, 47.28, -86.55, 46.77, -83.58, + 47.70, -70.74, 48.75, -66.00, 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 16),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 16),K=1, 13) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 16),K=1,2),L=1, 13)/ + 49.99,-129.92, 50.40,-127.83, 51.58,-125.71, 53.96,-120.53, + 54.07,-119.53, 55.84,-113.32, 55.68,-104.45, 54.40, -83.66, + 52.84, -80.13, 47.70, -70.74, 48.75, -66.00, 47.39, -63.98, + 43.88, -59.85 +/ DATA (TAGFZ(K, 17),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 17),K=1, 14) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 17),K=1,2),L=1, 14)/ + 49.99,-129.92, 50.40,-127.83, 51.58,-125.71, 53.96,-120.53, + 54.07,-119.53, 55.84,-113.32, 57.43,-104.59, 56.93, -98.28, + 54.40, -83.66, 54.00, -74.27, 52.44, -70.98, 48.75, -66.00, + 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 18),K=1, 2)/ +'K','K' +/ DATA (AGEFZ(K, 18),K=1, 2) / +999.00,999.00 +/ DATA ((FRACZN(K,L, 18),K=1,2),L=1, 2)/ + 46.50,-117.44, 41.33,-114.74 +/ DATA (TAGFZ(K, 19),K=1, 15)/ +'K','K','K','K','K','K','K','K','K','K','K','K','K','K','K' +/ DATA (AGEFZ(K, 19),K=1, 15) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 19),K=1,2),L=1, 15)/ + 56.25,-160.75, 59.67,-142.10, 60.76,-139.41, 63.24,-137.79, + 70.34,-143.21, 63.74,-134.83, 55.35,-124.00, 46.50,-117.44, + 45.56,-101.60, 44.04, -93.75, 43.58, -90.59, 42.85, -93.55, + 41.66,-100.53, 40.83,-114.46, 30.22, -97.48 +/ DATA (TAGFZ(K, 20),K=1, 9)/ +'K','K','K','K','K','K','K','K','K' +/ DATA (AGEFZ(K, 20),K=1, 9) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00 +/ DATA ((FRACZN(K,L, 20),K=1,2),L=1, 9)/ + 55.63,-160.57, 64.90,-174.23, 73.65,-166.35, 70.34,-143.21, + 64.60,-134.40, 55.35,-124.00, 46.50,-117.44, 43.44, -90.90, + 38.95, -80.24 +/ DATA (TAGFZ(K, 21),K=1, 4)/ +'K','K','K','K' +/ DATA (AGEFZ(K, 21),K=1, 4) / +999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 21),K=1,2),L=1, 4)/ + 70.70,-170.78, 68.29, 47.63, 49.94, 3.74, 38.14, -79.72 +/ C C C DATA (NMAG(I),I=1, 20) / + 8, 11, 1, 12, 14, 10, 6, 1, 10, 14, 14, 6, 13, 12, 10, + 10, 1, 4, 9, 8 +/ DATA (TAGMAG(K, 1),K=1, 8)/ +'F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 1),K=1, 8) / + 0.00, 20.00, 35.60, 59.00, 77.00,126.00,158.00,175.00 +/ DATA (((REMAG(K,L,M, 1),K=1,2),L=1,2),M=1, 8) / + 18.56,-102.15, 15.69,-102.16, 17.94, -96.02, 14.93, -96.40, + 18.12, -92.07, 14.51, -92.31, 20.95, -75.38, 16.58, -74.58, + 22.88, -67.14, 17.81, -66.34, 23.27, -55.51, 18.18, -55.41, + 22.62, -42.18, 17.60, -42.73, 21.58, -30.28, 16.93, -31.59 +/ DATA (TAGMAG(K, 2),K=1, 11)/ +'F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 2),K=1, 11) / + 0.00, 9.50, 20.00, 27.50, 35.70, 59.00, 63.40, 67.00, + 77.00,126.00,150.00 +/ DATA (((REMAG(K,L,M, 2),K=1,2),L=1,2),M=1, 11) / + 22.94,-108.62, 19.57,-110.03, 20.73,-106.17, 18.90,-106.87, + 25.27,-102.94, 18.54,-102.97, 24.14,-101.56, 18.49,-101.64, + 24.11, -97.49, 18.53, -96.65, 25.83, -82.46, 21.44, -81.63, + 26.16, -80.77, 21.81, -79.71, 26.56, -80.43, 22.47, -79.16, + 26.83, -75.41, 23.15, -73.96, 27.75, -64.59, 24.02, -63.72, + 24.35, -51.14, 23.84, -51.61 +/ DATA (TAGMAG(K, 3),K=1, 1)/ +' ' +/ DATA (AGEMAG(K, 3),K=1, 1) / + 1.00 +/ DATA (((REMAG(K,L,M, 3),K=1,2),L=1,2),M=1, 1) / + -19.43,-148.18, -19.43, -61.82 +/ DATA (TAGMAG(K, 4),K=1, 12)/ +'F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 4),K=1, 12) / + 9.50, 20.00, 27.50, 35.70, 49.30, 59.00, 63.40, 67.00, + 77.00,126.00,150.00,158.00 +/ DATA (((REMAG(K,L,M, 4),K=1,2),L=1,2),M=1, 12) / + 25.31,-108.39, 24.78,-108.37, 31.00,-106.14, 24.87,-105.49, + 31.43,-103.56, 24.04,-103.46, 31.38, -99.00, 24.02, -98.31, + 31.79, -96.01, 24.87, -94.72, 32.55, -90.64, 25.62, -90.16, + 32.71, -88.50, 25.76, -88.05, 33.05, -87.18, 25.94, -86.84, + 33.50, -82.33, 26.27, -82.02, 33.55, -70.63, 28.86, -69.79, + 34.12, -58.08, 29.49, -57.53, 29.87, -52.81, 29.29, -53.33 +/ DATA (TAGMAG(K, 5),K=1, 14)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 5),K=1, 14) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 77.00,126.00, +134.00,145.00, 63.00, 70.00, 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 5),K=1,2),L=1,2),M=1, 14) / + 31.79,-105.61, 31.33,-105.60, 32.92,-101.69, 31.43,-102.34, + 35.03, -96.52, 31.78, -96.40, 35.86, -92.66, 32.07, -92.63, + 37.00, -88.90, 32.71, -88.77, 37.71, -82.69, 33.09, -83.14, + 39.64, -74.13, 33.98, -74.48, 37.49, -61.88, 34.61, -62.56, + 37.06, -58.84, 35.72, -59.17, 35.06, -54.81, 34.80, -55.03, + 29.09, -51.09, 28.96, -52.66, 27.33, -42.94, 28.04, -52.02, + 23.76, -35.06, 25.63, -51.21, 22.46, -31.91, 22.25, -32.23 +/ DATA (TAGMAG(K, 6),K=1, 10)/ +'F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 6),K=1, 10) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 77.00,126.00, +134.00,145.00 +/ DATA (((REMAG(K,L,M, 6),K=1,2),L=1,2),M=1, 10) / + 31.79,-105.61, 31.33,-105.60, 32.92,-101.69, 31.43,-102.34, + 35.03, -96.52, 31.78, -96.40, 35.86, -92.66, 32.07, -92.63, + 37.00, -88.90, 32.71, -88.77, 37.71, -82.69, 33.09, -83.14, + 39.64, -74.13, 33.98, -74.48, 37.49, -61.88, 34.61, -62.56, + 37.06, -58.84, 35.72, -59.17, 35.06, -54.81, 34.80, -55.03 +/ DATA (TAGMAG(K, 7),K=1, 6)/ +'F','F','F','F','F','F' +/ DATA (AGEMAG(K, 7),K=1, 6) / + 80.00,119.00,126.00,134.00,142.00,145.00 +/ DATA (((REMAG(K,L,M, 7),K=1,2),L=1,2),M=1, 6) / + 38.41, -73.66, 38.02, -73.74, 42.86, -64.16, 37.77, -64.67, + 42.76, -61.27, 37.56, -62.75, 42.63, -58.05, 37.14, -59.29, + 38.53, -56.43, 36.04, -56.47, 35.06, -54.81, 34.80, -55.03 +/ DATA (TAGMAG(K, 8),K=1, 1)/ +' ' +/ DATA (AGEMAG(K, 8),K=1, 1) / + 1.00 +/ DATA (((REMAG(K,L,M, 8),K=1,2),L=1,2),M=1, 1) / + -19.43,-148.18, -19.43, -61.82 +/ DATA (TAGMAG(K, 9),K=1, 10)/ +'V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 9),K=1, 10) / + 20.00, 27.50, 27.50, 35.70, 42.00, 49.30, 59.00, 77.00, +119.00,126.00 +/ DATA (((REMAG(K,L,M, 9),K=1,2),L=1,2),M=1, 10) / + 37.79,-108.03, 37.41,-108.01, 37.61,-102.97, 36.01,-103.23, + 34.89,-100.23, 32.53,-101.45, 35.80, -95.98, 33.75, -95.69, + 35.91, -91.95, 33.90, -91.90, 36.09, -87.77, 34.12, -87.61, + 36.79, -81.49, 35.13, -81.34, 39.76, -73.75, 37.51, -73.24, + 42.89, -66.57, 42.23, -66.39, 43.69, -63.27, 42.89, -63.28 +/ DATA (TAGMAG(K, 10),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 10),K=1, 14) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 63.40, 63.20, + 67.00, 77.00,119.00,126.00,134.00,140.00 +/ DATA (((REMAG(K,L,M, 10),K=1,2),L=1,2),M=1, 14) / + 37.79,-108.03, 37.41,-108.01, 37.61,-102.97, 36.01,-103.23, + 37.64, -97.96, 35.97, -98.10, 37.75, -94.67, 35.97, -94.69, + 37.72, -90.93, 36.00, -90.81, 38.38, -83.89, 36.73, -83.58, + 39.08, -82.19, 37.30, -81.95, 40.55, -80.73, 37.93, -80.73, + 41.06, -79.60, 38.27, -79.68, 41.15, -75.80, 39.05, -75.32, + 42.89, -66.57, 42.23, -66.39, 43.69, -63.27, 42.89, -63.28, + 44.12, -60.23, 43.16, -60.01, 43.44, -58.90, 43.03, -59.25 +/ DATA (TAGMAG(K, 11),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 11),K=1, 14) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 59.00, 67.00, 77.00,126.00,134.00,142.00 +/ DATA (((REMAG(K,L,M, 11),K=1,2),L=1,2),M=1, 14) / + 42.80,-126.60, 40.17,-127.40, 42.45,-125.24, 40.18,-126.21, + 42.51,-123.83, 38.69,-124.00, 41.42,-118.95, 38.25,-119.07, + 41.80,-115.62, 38.70,-116.11, 41.73,-112.10, 38.61,-112.52, + 41.22,-108.00, 38.01,-108.00, 40.63,-103.87, 36.89,-103.78, + 40.11, -97.66, 36.61, -96.10, 41.28, -95.05, 37.77, -93.70, + 42.37, -89.93, 38.82, -88.54, 46.74, -67.31, 43.62, -66.65, + 47.13, -64.52, 43.92, -63.34, 44.44, -59.85, 43.90, -60.31 +/ DATA (TAGMAG(K, 12),K=1, 6)/ +'V','V','V','V','V','V' +/ DATA (AGEMAG(K, 12),K=1, 6) / + 20.00, 27.50, 35.70, 42.00, 49.30, 55.00 +/ DATA (((REMAG(K,L,M, 12),K=1,2),L=1,2),M=1, 6) / + 41.42,-118.95, 38.25,-119.07, 45.28,-113.55, 41.70,-114.19, + 45.66,-109.22, 41.61,-109.93, 45.23,-105.57, 41.19,-105.83, + 44.74,-102.25, 40.68,-101.27, 41.28, -97.71, 40.35, -97.82 +/ DATA (TAGMAG(K, 13),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 13),K=1, 13) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 59.00, 67.00, 77.00,126.00,138.00 +/ DATA (((REMAG(K,L,M, 13),K=1,2),L=1,2),M=1, 13) / + 47.52,-129.44, 44.01,-131.35, 47.85,-128.22, 44.65,-129.45, + 47.92,-125.54, 44.65,-125.76, 46.84,-119.55, 43.63,-119.79, + 49.83,-114.87, 45.98,-115.58, 49.89,-111.38, 45.89,-112.04, + 49.48,-107.86, 45.30,-108.35, 48.95,-104.30, 44.77,-103.58, + 48.49, -98.41, 41.04, -94.18, 48.61, -95.69, 41.87, -92.40, + 48.03, -89.23, 43.04, -87.07, 48.19, -69.04, 46.47, -68.60, + 47.91, -64.03, 47.09, -64.69 +/ DATA (TAGMAG(K, 14),K=1, 12)/ +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 14),K=1, 12) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 55.00, 60.00, 70.00, 80.00 +/ DATA (((REMAG(K,L,M, 14),K=1,2),L=1,2),M=1, 12) / + 49.95,-129.96, 49.31,-130.63, 50.47,-127.83, 49.04,-128.48, + 51.53,-125.42, 48.75,-125.65, 53.85,-120.86, 50.28,-120.71, + 53.84,-116.82, 50.00,-116.45, 53.79,-112.59, 50.21,-113.72, + 53.31,-108.95, 49.63,-109.89, 52.91,-105.16, 49.01,-105.38, + 52.35, -97.70, 50.29,-102.04, 50.89, -92.02, 48.29, -97.46, + 50.22, -85.37, 47.95, -94.94, 47.98, -87.21, 47.06, -87.52 +/ DATA (TAGMAG(K, 15),K=1, 10)/ +'V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 15),K=1, 10) / + 20.00, 27.50, 35.70, 42.00, 49.30, 55.00, 60.00, 70.00, + 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 15),K=1,2),L=1,2),M=1, 10) / + 54.36,-119.14, 53.89,-119.00, 55.81,-113.13, 53.94,-113.12, + 55.83,-108.54, 53.46,-109.23, 55.47,-104.55, 53.69,-106.77, + 54.74, -90.64, 52.76,-105.12, 54.29, -83.33, 52.27, -97.86, + 52.67, -80.56, 50.89, -92.02, 51.46, -76.45, 50.20, -85.38, + 48.43, -71.70, 47.38, -86.57, 48.19, -70.92, 47.62, -71.30 +/ DATA (TAGMAG(K, 16),K=1, 10)/ +'V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 16),K=1, 10) / + 27.50, 35.70, 42.00, 43.80, 49.30, 55.00, 60.00, 70.00, + 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 16),K=1,2),L=1,2),M=1, 10) / + 55.81,-113.13, 53.94,-113.12, 57.13,-107.59, 55.82,-107.83, + 56.87,-104.45, 55.55,-104.70, 56.92, -98.43, 55.82,-104.47, + 54.74, -90.64, 52.76,-105.12, 54.29, -83.33, 52.27, -97.86, + 53.99, -74.13, 52.62, -80.64, 52.69, -70.12, 51.31, -76.44, + 49.62, -66.86, 48.58, -72.30, 49.04, -66.19, 48.61, -66.52 +/ DATA (TAGMAG(K, 17),K=1, 1)/ +' ' +/ DATA (AGEMAG(K, 17),K=1, 1) / + 1.00 +/ DATA (((REMAG(K,L,M, 17),K=1,2),L=1,2),M=1, 1) / + -19.43,-148.18, -19.43, -61.82 +/ DATA (TAGMAG(K, 18),K=1, 4)/ +'K','K','K','K' +/ DATA (AGEMAG(K, 18),K=1, 4) / + 60.00, 70.00, 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 18),K=1,2),L=1,2),M=1, 4) / + 41.90,-115.31, 41.00,-112.55, 42.23,-101.71, 42.77,-112.64, + 43.03, -93.70, 44.73,-113.87, 43.41, -90.97, 46.59,-115.84 +/ DATA (TAGMAG(K, 19),K=1, 9)/ +'K','K','K','K','K','K','K','K','K' +/ DATA (AGEMAG(K, 19),K=1, 9) / + 43.80, 49.30, 55.00, 60.00, 70.00, 80.00, 85.00,120.00, +126.00 +/ DATA (((REMAG(K,L,M, 19),K=1,2),L=1,2),M=1, 9) / + 59.09,-149.03, 59.89,-142.34, 58.82,-156.71, 60.77,-139.67, + 61.45,-156.85, 63.34,-138.15, 62.63,-158.20, 64.48,-142.39, + 63.87,-159.93, 65.64,-146.99, 64.97,-172.94, 67.91,-149.21, + 65.83,-173.24, 68.92,-150.89, 66.15,-173.52, 69.23,-149.53, + 70.48,-143.92, 69.56,-142.41 +/ DATA (TAGMAG(K, 20),K=1, 8)/ +'K','K','K','K','K','K','K','K' +/ DATA (AGEMAG(K, 20),K=1, 8) / +120.00,126.00,134.00,142.00,158.00,175.00,225.00,250.00 +/ DATA (((REMAG(K,L,M, 20),K=1,2),L=1,2),M=1, 8) / + 74.07,-164.86, 73.39,-162.42, 80.84, 164.16, 72.08,-152.08, + 82.40, 148.05, 68.93,-139.56, 83.24, 111.62, 64.66,-127.88, + 75.74,-125.97, 50.70,-118.40, 70.36, 46.54, 46.22,-101.71, + 61.75, 22.89, 42.39, -88.39, 50.97, 4.24, 39.88, -79.37 +/ END