C PROGRAM PLOTFAULTS C C BY C PETER BIRD, C DEPARTMENT OF EARTH AND SPACE SCIENCES, C UNIVERSITY OF CALIFORNIA, LOS ANGELES, CALIFORNIA 90095-1567 C VERSION OF 19 MAY 1998 C C **** COMPATIBLE WITH 19 MAY 1998 VERSION OF "FAULTS" **** C TAKES OUTPUT FROM A FINITE ELEMENT SIMULATION OF CONTINENTAL C DEFORMATION PERFORMED BY "FAULTS" AND PLOTS UP TO 15 MAPS C OF THE VARIABLES IN COLOR OR BLACK-AND-WHITE ON VERSATEC SPECTRUM. C C USES FINITE ELEMENT GRID (AND ELEVATION/HEAT-FLOW/CRUSTAL THICKNESS C DATA AT THE NODES) DATASET IDENTICAL TO THAT READ BY "FAULTS"; C LIKE THAT PROGRAM, IT ALSO INTERPOLATES POSTIONS OF ELEMENT C MIDPOINTS. THIS GRID IS READ FROM FORTRAN DEVICE NUMBER C "IUNITG". C C IN SOME CASES, THIS FINITE ELEMENT GRID MAY CONTAIN "FAKE" NODES C ALONG THE BOUNDARY, WHICH HAVE NO REAL DEGREES OF FREEDOM. C HOWEVER, IN THE SUBPROGRAM "EXTRAP" OF THIS GRAPHICS PACKAGE, C VALUES OF VARIABLES MUST BE FOUND AT THESE NODES AS WELL AS AT C OTHERS, BY SOLVING A LINER SYSTEM THAT INCLUDES THEM. IF THEY C WERE INCLUDED MERELY BY TACKING THEM ON AT THE END, THE C BANDWIDTH OF THE SYSTEM WOULD BE TERRIBLE! THEREFORE, IF C ANY EXTRAPOLATION OF VARIABLES IS CALLED FOR, THIS PROGRAM C WILL ATTEMPT TO READ AN INTEGER LIST FROM DEVICE "IUNITR" C WHICH WILL GIVE THE ALIAS (NEW NUMBER) OF EACH NODE AS C RENUMBERED TO REDUCE BANDWIDTH. UTILITY PROGRAM "NUMBER" C CAN BE USED TO GENERATE SUCH LISTS. C C READS THE VELOCITY SOLUTION (AT THE NODES ONLY) FROM C FORTRAN DEVICE NUMBER "IUNITV". C C USES STRATEGIC AND TACTICAL INPUT PARAMETERS IN C CARD FORMAT FROM DEVICE "IUNITP"; SHOULD CONFORM TO DATA USED C IN THE ORIGINAL RUN OF "FAULTS"; PLOT CONTROLS ARE APPENDED C AT THE END OF THIS DATASET (WHERE "FAULTS" WON'T READ THEM). C C OPTIONALLY READS DIGITIZED BASEMAP FROM "IUNITM" & INCLUDES IN PLOTS. C---------------------------------------------------------------------- C C THIS PROGRAM WAS DEVELOPED WITH SUPPORT FROM THE UNIVERSITY OF C CALIFORNIA, THE UNITED STATES GEOLOGIC SURVEY, AND THE NATIONAL C SCIENCE FOUNDATION. IT IS IN THE PUBLIC DOMAIN, AND MAY BE COPIED C AND USED WITHOUT RESTRICTION. HOWEVER, SCIENTIFIC ETHICS AND C COURTESY REQUIRE THE SOURCE OF THE PROGRAM TO BE STATED IN ANY C RESULTING PUBLICATIONS. (THE AUTHOR WOULD ALSO LIKE TO BE INFORMED C OF THESE PROJECTS.) C---------------------------------------------------------------------- C C EXTERNAL ROUTINES USED: C -ENGINEERING SCIENCES SUBROUTINE LIBRARY (IBM PRODUCT) ROUTINES: C SPBF AND SPBS (SINGLE-PRECISION FACTOR AND C SOLVE A POSITIVE DEFINITE, SYMMETRIC, BANDED C LINEAR SYSTEM) C -FORTRAN INTRINSIC FUNCTIONS CALLED BY GENERIC NAMES: C ABS,ASIN,ATAN2,COS,EXP,LOG,MAX,MIN,MOD,SIN,SQRT,TAN C -VERSATEC ROUTINES: C CIRCLE, DEFPAT, DEFPEN, NEWPEN, PAPER, PENCLR, C PLOT, PLOTS, RECT, SETFNT, SETPAT, SYMBOL, C TONCLR, TONE, TONFLG, VPOPT, VPORT, WINDOW. C C--------------------------------------------------------------------- C PARAMETER (ARRAY-SIZE) STATEMENTS C C SET THE FOLLOWING PARAMETERS AT LEAST AS LARGE AS YOUR PROBLEM: C C MAXNOD = MAXIMUM NUMBER OF NODES (INCLUDES BOTH "REAL"AND & "FAKE") PARAMETER (MAXNOD=994) C C MAXBN = MAXIMUM NUMBER OF BOUNDARY NODES (BOTH "REAL" AND "FAKE"). PARAMETER (MAXBN=103) C C MAXEL = MAXIMUM NUMBER OF CONTINUUM ELEMENTS (TRIANGLES). PARAMETER (MAXEL=314) C C MAXFEL = MAXIMUM NUMBER OF FAULT ELEMENTS (LINE SEGMENTS); PARAMETER (MAXFEL=147) C C MAXATP = MAXIMUM NUMBER OF NODES WHICH MAY OVERLAP AT A FAULT- C INTERSECTION POINT. PARAMETER (MAXATP=20) C C MAXWRK = SIZE OF STORAGE RESERVED FOR DIAGONAL AND LOWER BAND C OF A SYMMETRIC BAND MATRIX WHOSE FULL SIZE IS MAXNOD BY MAXNOD: PARAMETER (MAXWRK=71568) C C MAXSTA = MAXIMUM NUMBER OF POINTS IN STATELINE MAPS: PARAMETER (MAXSTA=10000) C C NPTYPE = NUMBER OF TYPES OF PLOTS PRODUCED BY THIS PROGRAM PARAMETER (NPTYPE=13) C C--------------------------------------------------------------------- C TYPE STATEMENTS C C (NOTE: THE IMPLICIT TYPING OF I-N = INTEGER, AND A-H,O-Z = REAL C IS OBSERVED IN THIS PROGRAM. NO TYPES ARE STATED FOR SUCH NAMES.) C CHARACTER*26 CARD CHARACTER*80 TITLE1,TITLE2,TITLE3 C DOUBLE PRECISION V,VM C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD1: DOUBLE PRECISION PHI,POINTS,WEIGHT C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD2: DOUBLE PRECISION FPHI,FPOINT,FGAUSS C C NOTE: THE FOLLOWING CAN BE MADE "INTEGER*2" IN VS-FORTRAN: INTEGER NODTYP C LOGICAL ALDONE,BRIEF,COLOR,DIMERR,DOPLOT, + EVERYP,FIRST, + SHOWIT,STATES,USEALI,WILLEX C C NOTE: THE FOLLOWING ARRAYS COULD BE COMPRESSED WITH "LOGICAL*1" C IN VS-FORTRAN: LOGICAL CHECKE,CHECKF,CHECKN,DRAWST, + EDGETS,EDGEFS,FSLIPS,PULLED C C--------------------------------------------------------------------- C DIMENSION STATMENTS C C DIMENSIONS USING PARAMETER MAXNOD: DIMENSION ATNODE(MAXNOD), + CHECKN(MAXNOD), DQDTDA(MAXNOD), + ELEV (MAXNOD), IALIAS(MAXNOD), + IUSER (MAXNOD), JLAST (MAXNOD), + NODTYP(MAXNOD), TAUZZN(MAXNOD), + V (2,MAXNOD), VM (2,MAXNOD), + XNODE (MAXNOD), YNODE (MAXNOD), ZMNODE(MAXNOD) C C DIMENSIONS USING PARAMETER MAXBN: DIMENSION NODCON(MAXBN) C C DIMENSIONS USING PARAMETER MAXEL: DIMENSION ALPHA(3,3,7,MAXEL), AREA (MAXEL), CHECKE (MAXEL), + DETJ (7,MAXEL), DVB (7,MAXEL), + DXS (6,7,MAXEL), DYS (6,7,MAXEL), EDGETS(3,MAXEL), + ERATE (3,7,MAXEL), GEOTH(4,7,MAXEL), + GLUE (7,MAXEL), NODES (6,MAXEL), + OVB (2,7,MAXEL), OUTSCA (7,MAXEL), + OUTVEC (2,7,MAXEL), PULLED (7,MAXEL), + SIGHB (2,7,MAXEL), SIGZZI (7,MAXEL), + TAUMAT (3,7,MAXEL), TAUZZI (7,MAXEL), + TOFSET (3,7,MAXEL), + XIP (7,MAXEL), YIP (7,MAXEL), + ZMOHO (7,MAXEL), ZTRANC (7,MAXEL) C C DIMENSIONS USING PARAMETER MAXFEL: DIMENSION CHECKF (MAXFEL), EDGEFS (2,MAXFEL), + FAZ (2,MAXFEL), FC (2,2,7,MAXFEL), FDIP (3,MAXFEL), + FIMUDZ(7,MAXFEL), FLEN (MAXFEL), + FPEAKS (MAXFEL), FSLIPS (MAXFEL), + FTAN (7,MAXFEL), FTSTAR(2,7,MAXFEL), NODEF (6,MAXFEL), + OFFSET (MAXFEL), ZTRANF (MAXFEL) C C DIMENSIONS USING PARAMETER MAXATP: DIMENSION LIST (MAXATP) C C DIMENSION USING PARAMETER MAXWRK: DIMENSION A1 (MAXWRK), A2 (MAXWRK) C C DIMENSIONS USING PARAMETER MAXSTA: DIMENSION DRAWST(MAXSTA), + XST(MAXSTA),YST(MAXSTA) C C DIMENSIONS USING PARAMETER NPTYPE: DIMENSION CINT (NPTYPE), DOPLOT (NPTYPE), + FBLAND (NPTYPE), LOWBLU (NPTYPE) C C DIMENSIONS OF FIXED SIZE: C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD1: DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD2: DIMENSION FPHI(6,7),FPOINT(7),FGAUSS(7) C C--------------------------------------------------------------------- C COMMON STATEMENTS C C NAMED COMMON BLOCKS HOLD THE FIXED VALUES OF THE POSITIONS, C WEIGHTS, AND NODAL FUNCTION VALUES AT THE INTEGRATION POINTS C IN THE ELEMENTS (TRIANGULAR ELEMENTS IN BLOCK DATA BD1, AND C FAULT ELEMENTS IN BLOCK DATA BD2). C ENTRIES CORRESPONDING TO BD1: COMMON /S1S2S3/ POINTS COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT C ENTRIES CORRESPONDING TO BD2: COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS C C-------------------------------------------------------------------- C DATA STATEMENTS C C "DIPMAX" IS THE MAXIMUM DIP (FROM HORIZONTAL, IN DEGREES) FOR A C FAULT ELEMENT TO BE TREATED AS A DIP-SLIP FAULT, WITH TWO DEGREES C OF FREEDOM PER NODE-PAIR. AT STEEPER DIPS, THE DEGREE OF FREEDOM C CORRESPONDING TO OPENING OR CONVERGENCE OF THE OPPOSITE SIDES IS C ELIMINATED BY A CONSTRAINT EQUATION, AND THE FAULT IS TREATED AS C A VERTICAL STRIKE-SLIP FAULT. THIS ARBITRARY LIMIT IS NECESSARY C BECAUSE THE EQUATIONS FOR DIP-SLIP FAULTS BECOME SINGULAR AS THE C DIP APPROACHES 90 DEGREES. IN PRACTICE, IT IS BEST TO SPECIFY DIPS C AS EITHER (1) VERTICAL, OR (2) CLEARLY LESS THAN "DIPMAX", WITHIN C EACH FAULT ELEMENT. IF THE DIP VARIES WITHIN AN ELEMENT IN SUCH A C WAY THAT IT PASSES THROUGH THIS LIMIT WITHIN THE ELEMENT, THEN C THE REPRESENTATION OF THAT FAULT ELEMENT IN THE EQUATIONS MAY C BE INACCURATE. DATA DIPMAX /75./ C C THE FOLLOWING ARE THE FORTRAN INPUT AND OUTPUT DEVICE NUMBERS: C C "IUNITG"= DEVICE NUMBER ASSOCIATED WITH THE GRID INPUT FILE. DATA IUNITG /1/ C C "IUNITR"= DEVICE NUMBER ASSOCIATED WITH THE INTEGER ALIASES C (RE-NUMBERING) OF THE NODES OF THE FINITE ELEMENT GRID, C SUCH THAT FAKE NODES ARE TREATED AS REAL AND INCLUDED, C WHILE THE BANDWIDTH IS KEPT AT A REASONABLE VALUE. DATA IUNITR /2/ C C "IUNITP"= DEVICE NUMBER ASSOCIATED WITH THE PARAMETER INPUT FILE. C (NOTE: MAY EQUAL IUNITB.) DATA IUNITP /4/ C C "IUNITT"= DEVICE NUMBER ASSOCIATED WITH TEXT OUTPUT, INCLUDING C STATUS AND WARNING MESSAGES. C (NOTE! ON SOME SYSTEMS, SYSTEM ERR0R MESSAGES ARE ALWAYS C OUTPUT ON DEVICE 6. IF SO, THEN IUNITT SHOULD BE 6.) DATA IUNITT /6/ C C "IUNITV"= DEVICE NUMBER ASSOCIATED WITH VELOCITY SOLUTION FILE. DATA IUNITV /8/ C C "IUNITM"= DEVICE NUMBER ASSOCIATED WITH THE BASE MAP OF STATE LINES DATA IUNITM /9/ C C--------------------------------------------------------------------- C C BEGINNING OF EXECUTABLE CODE C C C *** KLUDGE ALERT ************************************************* C CONVERSION OF PARAMETERS (CONSTANTS) TO VARIABLES SHOULD LOGICALLY C HAVE NO EFFECT, BUT IN FACT HELPS TO SUPPRESS SOME SPURIOUS C MESSAGES FROM THE IBM VS-FORTRAN COMPILER. MXNODE=MAXNOD MXEL =MAXEL MXFEL =MAXFEL MXBN =MAXBN MXSTAR=MAXATP MXWORK=MAXWRK MXSTAT=MAXSTA NTYPE =NPTYPE C ****************************************************************** C WEDGE=ABS(90.-ABS(DIPMAX))*0.017453293 C C READ FINITE ELEMENT GRID AND RECONSTRUCT GEOMETRIC ARRAYS C C C INPUT FINITE ELEMENT GRID AND DATA VALUES AT NODE POINTS C CALL GETNET (INPUT,IUNITG,IUNITT, + MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF,DQDTDA,ELEV,FAZ,FDIP, + NFAKEN,NFL,NODEF,NODES, + NREALN,NUMEL,NUMNOD,N1000,OFFMAX, + OFFSET,TITLE1,XNODE,YNODE,ZMNODE, + WORK,CHECKE,CHECKF,CHECKN) C C CHECK GRID TOPOLOGY AND COMPUTE GEOMETRIC PROPERTIES C CALL SQUARE (INPUT,BRIEF,FDIP,IUNITT, + MXBN,MXEL,MXFEL,MXNODE, + MXSTAR,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,WEDGE, + MODIFY,FAZ,XNODE,YNODE, + OUTPUT,AREA,DETJ,DXS,DYS,EDGEFS,EDGETS, + FLEN,FTAN,NCOND,NODCON, + WORK,CHECKN,LIST,NODTYP) C C READ SCALAR PARAMETERS C CALL READPM (INPUT,IUNITP, IUNITT, $ NTYPE , OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT , + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , + IFLOW , GMEAN , + MAXITR, OKDELV, OKTOQT, ONEKM, RADIO , + REFSTR, RHOAST, RHOBAR, RHOH2O, + TEMLIM, TITLE3, TSURF, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,NCONTR, $ STATES,RMSVEC, $ SDENOM,IPENCT,IPENST,IPENLB,COLOR) C C WILL EXTRAPOLATION OF VARIABLES BE DONE? C SHOULD ALIASES OF NODE NUMBERS BE USED TO REDUCE BANDWIDTH? C IF SO, READ THEM NOW. C WILLEX=DOPLOT(1).OR.DOPLOT(4).OR.DOPLOT(5).OR.DOPLOT(7).OR. + DOPLOT(9) USEALI=WILLEX.AND.(NUMNOD.GT.NREALN) IF (USEALI) THEN DO 20 I=1,NUMNOD READ (IUNITR,*) IALSO,IALIAS(I),IUSER(I) 20 CONTINUE ENDIF C C CHECK ADEQUACY OF WORKSPACE DIMENSIONS, IF NEEDED: C IF (WILLEX) THEN CALL KSIZE (INPUT,BRIEF,IALIAS, + IUNITT,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES, + NUMEL,NUMNOD, + USEALI, + OUTPUT,NDIFF,NKSIZE, + WORK,JLAST) DIMERR=NKSIZE.GT.MXWORK IF (DIMERR) THEN WRITE (IUNITT,58) NKSIZE 58 FORMAT (/' CHANGE PARAMETER MAXWRK TO AT LEAST ', + I10,' AND RECOMPILE.') STOP ENDIF ENDIF C C READ BASEMAP C IF (STATES) THEN NXYST=0 FIRST=.TRUE. 90 READ (IUNITM,91,END=101) CARD 91 FORMAT (A26) IF ((CARD( 4: 4).EQ.'.').AND. + (CARD(17:17).EQ.'.')) THEN READ (CARD,*) X,Y NXYST=NXYST+1 XST(NXYST)=X YST(NXYST)=Y DRAWST(NXYST)=.NOT.FIRST FIRST=.FALSE. ELSE FIRST=.TRUE. ENDIF IF (NXYST.LT.MXSTAT) GO TO 90 101 CONTINUE ELSE NXYST=0 ENDIF C C READ IN NODAL VELOCITIES: C CALL OLDVEL (INPUT,IUNITV,MXNODE,NUMNOD, + OUTPUT,ALDONE,TITLE1,TITLE2,TITLE3,V) IF (ALDONE) THEN WRITE (IUNITT,895) IUNITV 895 FORMAT (/' UNABLE TO READ INITIALIZING SOLUTION ON UNIT', + I3/' VELOCITY, STRAIN-RATE, AND SLIP WILL BE ZERO.'/) DO 900 I=1,NUMNOD V(1,I)=0.0D0 V(2,I)=0.0D0 900 CONTINUE ELSE WRITE (IUNITT,905) IUNITV,TITLE1,TITLE2,TITLE3 905 FORMAT (/' READ INITIALIZING SOLUTION FROM UNIT ',I3/ + ' TITLES WERE:',3(/' ',A80)/ /) ENDIF C CALL FILLIN (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,CFRIC,CONDUC,DQDTDA, + ECREEP,ELEV,ERATE,GMEAN,IFLOW,IUNITT, + MXEL,MXNODE,NODES,NUMEL,NUMNOD,ONEKM, + RADIO,RHOAST,RHOBAR,RHOH2O,TEMLIM, + TSURF,XNODE,YNODE,V,ZMNODE, + OUTPUT,GEOTH,GLUE,PULLED,SIGZZI,TAUZZI, + TAUZZN,VM,ZMOHO, + WORK,ATNODE) CALL INTERP (INPUT,XNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,XIP) CALL INTERP (INPUT,YNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,YIP) C C COMPUTE TACTICAL VALUES OF LIMITS ON VISCOSITY, AND WEIGHTS FOR C IMPOSITION OF CONSTRAINTS IN LINEAR SYSTEMS: C CALL LIMITS (INPUT,AREA,DETJ,IUNITT,MXEL, + NUMEL,OKDELV,REFSTR,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) C C SET UP MATRICES FOR OPERATION OF EXTRAPOLATION FROM INTEGRATION C POINTS TO NODES, IF NECESSARY C IF (WILLEX) THEN CALL BUILDC (INPUT,AREA,DETJ,IALIAS, + MXWORK,NDIFF,NFL,NODEF, + NODES,NUMEL,NUMNOD,USEALI, + OUTPUT,A1) LDA=NDIFF+1 CALL SPBF (A1,LDA,NUMNOD,NDIFF) ENDIF C C INITIALIZE SOLUTION-SPECIFIC ARRAYS C CALL EDOT (INPUT,DXS,DYS,MXEL,MXNODE,NODES,NUMEL,V, + OUTPUT,ERATE) DO 920 M=1,7 DO 910 I=1,NUMEL SIGHB(1,M,I)=0. SIGHB(2,M,I)=0. TAUMAT(1,M,I)=0. TAUMAT(2,M,I)=0. TAUMAT(3,M,I)=0. 910 CONTINUE 920 CONTINUE CALL VISCOS (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,DCREEP,ECREEP, + ERATE,CFRIC,GMEAN,GEOTH, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,VISMAX,ZMOHO, + OUTPUT,ALPHA,SCOREC,SCORED,TOFSET,ZTRANC) CALL TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) DO 930 I=1,NFL ZTRANF(I)=ZMNODE(NODEF(2,I))/2. 930 CONTINUE CALL MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DQDTDA, + ECREEP,FDIP,FFRIC,FMUMAX,FTAN,GMEAN,MXFEL, + MXNODE,NFL,NODEF,OFFMAX,OFFSET,ONEKM, + RADIO,RHOH2O,RHOBAR,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) 1000 IF (IFLOW.GT.0) THEN CALL THONC (INPUT,ECREEP,ETAMAX,GLUE, + MXEL,MXNODE,NODES,NUMEL,NUMNOD, + V,VM,ZMOHO, + OUTPUT,DVB,OVB,SIGHB, + WORK,OUTVEC) ELSE DO 1090 M=1,7 DO 1080 I=1,NUMEL SIGHB(1,M,I)=0. SIGHB(2,M,I)=0. 1080 CONTINUE 1090 CONTINUE ENDIF C CALL RESULT + (INPUT,ALPHAT,ELEV,ERATE,FDIP,FIMUDZ,FPEAKS,FSLIPS, + FTAN,GEOTH,IUNITT,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES,NREALN,NUMEL,NUMNOD,N1000, + RHOAST,RHOBAR,RHOH2O,SIGHB,TAUMAT,TAUZZI, + TITLE1,TITLE2,TITLE3, + V,WEDGE,ZMOHO,ZTRANC,ZTRANF) C CALL REPORT (INPUT,AREA,A1,CINT,COLOR,DETJ,DOPLOT, + DQDTDA,DRAWST,ELEV,ERATE, + FBLAND,FDIP,FLEN,FSLIPS,FTAN, + GEOTH,IALIAS, + IPENCT,IPENST,IPENLB,IUNITT, + LDA,LOWBLU, + MXEL,MXFEL,MXNODE,MXWORK, + NCONTR,NDIFF,NFL,NODEF, + NODES,MXSTAT,NTYPE, + NXYST,NUMEL,NUMNOD, + RMSVEC,SDENOM,SIGHB,STATES, + TAUMAT,TAUZZI, + TITLE1,TITLE2,TITLE3, + TEMLIM,USEALI,V,VM,WEDGE, + ZMNODE,ZMOHO, + MODIFY,XIP,XNODE,XST, + YIP,YNODE,YST, + WORK,A2,ATNODE,OUTSCA,OUTVEC, + 999) C WRITE (IUNITT,999) 999 FORMAT (' *** ALL REQUESTED PLOTS COMPLETED. ***'/ + ' ==========================================================') C STOP END C C C SUBROUTINE EXTRAP (INPUT,AREA,A1,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + VALUES, + OUTPUT,FPOLES, + WORK,A2) C C SMOOTHS VALUES OF A SCALAR FIELD KNOWN AT THE INTEGRATION C POINTS (VALUES) TO PRODUCE VALUES AT THE NODES (FPOLES). C LOGICAL USEALI C DOUBLE PRECISION PHI,WEIGHT DIMENSION PHI(6,7),WEIGHT(7) DIMENSION A1(MXWORK),A2(MXWORK) DIMENSION AREA(MXEL),DETJ(7,MXEL),IALIAS(MXNODE), + FPOLES(MXNODE),NODES(6,MXEL), + VALUES(7,MXEL) C COMMON /WGTVEC/ WEIGHT COMMON /PHITAB/ PHI C C ZERO THE FORCING VECTOR C DO 200 I=1,NUMNOD FPOLES(I)=0. 200 CONTINUE C C BUILD FORCING VECTOR AS AREA INTEGRAL OF NODAL FUNCTIONS TIMES C A SCALAR VARIABLE DEFINED AT THE INTEGRATION POINTS. C DO 800 M=1,7 DO 700 I=1,NUMEL VALDA=VALUES(M,I)*AREA(I)*DETJ(M,I)*WEIGHT(M) DO 600 J=1,6 IF (USEALI) THEN K=IALIAS(NODES(J,I)) ELSE K=NODES(J,I) ENDIF FPOLES(K)=FPOLES(K)+PHI(J,M)*VALDA 600 CONTINUE 700 CONTINUE 800 CONTINUE C C MAKE A COPY OF THE FACTORED COEFFICIENT MATRIX (TO PROTECT ORIGINAL) C DO 810 I=1,MXWORK A2(I)=A1(I) 810 CONTINUE C CALL SPBS (A2,LDA,NUMNOD,NDIFF,FPOLES) C NOTE: SPBS IS NOT PROVIDED; IT IS FROM IBM'S C ESSL = ENGINEERING SCIENCES SUBROUTINE LIBRARY. C C CONVERT BACK TO OLD NODE NUMBERS, IF NEEDED C IF (USEALI) THEN DO 890 I=1,NUMNOD A2(I)=FPOLES(I) 890 CONTINUE DO 900 I=1,NUMNOD FPOLES(I)=A2(IALIAS(I)) 900 CONTINUE ENDIF C RETURN END C C C SUBROUTINE INTERP (INPUT,FPOLES,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,VALUES) C C INTERPOLATES SCALAR FROM NODES TO INTEGRATION POINTS C DOUBLE PRECISION PHI DIMENSION FPOLES(MXNODE),NODES(6,MXEL), + PHI(6,7),VALUES(7,MXEL) 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,ATNODE,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 ATNODE(NUMNOD),NODES(6,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=ATNODE(NODES(1,IE)) F2=ATNODE(NODES(2,IE)) F3=ATNODE(NODES(3,IE)) F4=ATNODE(NODES(4,IE)) F5=ATNODE(NODES(5,IE)) F6=ATNODE(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 VALUE PER INTEGRATION POINT) C DIMENSION VECNOD(2,NUMNOD),NODES(6,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 @PROCESS NOVECTOR C C SUBROUTINE BUILDC (INPUT,AREA,DETJ,IALIAS, + NCDIM,NDIFF,NFL,NODEF, + NODES,NUMEL,NUMNOD,USEALI, + OUTPUT,CODE) C C WARNING!!! THE "@PROCESS NOVECTOR" STATEMENT C ABOVE IS NEEDED FOR 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 LOGICAL USEALI DOUBLE PRECISION PHI,WEIGHT DIMENSION AREA(NUMEL),CODE(NCDIM),DETJ(7,NUMEL),IALIAS(NUMNOD), + NODEF(6,NFL),NODES(6,NUMEL),PHI(6,7),WEIGHT(7) COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT C C************************************************************* INDEXC(IR,JC,NDIFF)=(NDIFF+1)*(MIN(JC,IR)-1)+ABS(IR-JC)+1 C************************************************************** C C BEGIN BY ZEROING C DO 10 I=1,NCDIM CODE(I)=0. 10 CONTINUE C C MAIN CONTRIBUTION IS AREA INTEGRAL OF PRODUCTS OF NODAL FUNCTIONS C C NOTE THAT ONLY DIAGONAL AND LOWER-BAND TERMS ARE ADDED, C WHILE SYMMETRICAL UPPER BAND IS DISCARDED. C DO 100 I=1,NUMEL DO 90 I6=1,6 DO 80 J6=1,6 IF (USEALI) THEN IR=IALIAS(NODES(I6,I)) JC=IALIAS(NODES(J6,I)) ELSE IR=NODES(I6,I) JC=NODES(J6,I) ENDIF IF (IR.GE.JC) THEN SUM=0. DO 70 M=1,7 SUM=SUM+WEIGHT(M)*DETJ(M,I)* + PHI(I6,M)*PHI(J6,M) 70 CONTINUE K=INDEXC(IR,JC,NDIFF) CODE(K)=CODE(K)+SUM*AREA(I) ENDIF 80 CONTINUE 90 CONTINUE 100 CONTINUE C C PREVENT SINGULARITY BY TYING DOWN BOUNDARY NODES WHICH MAY ONLY C BELONG TO FAULT ELEMENTS RUNNING ALONG THE BOUNDARY. C NOTE THAT IT DOESN'T MATTER HOW THESE ZERO EIGENVALUES ARE C REMOVED, BECUASE THE VARIABLE VALUES AT SUCH NODES ARE C NEVER USED IN PLOTTING, AND THE FORCING-VECTOR ENTRIES C CORRESPONDING TO THEM ARE ALWAYS ZERO. C BIGEST=0. DO 110 I=1,NCDIM BIGEST=MAX(BIGEST,CODE(I)) 110 CONTINUE C DO 200 I=1,NFL DO 190 I6=1,6 IF (USEALI) THEN NODE=IALIAS(NODEF(I6,I)) ELSE NODE=NODEF(I6,I) ENDIF K=INDEXC(NODE,NODE,NDIFF) IF (CODE(K).EQ.0.) CODE(K)=BIGEST 190 CONTINUE 200 CONTINUE C RETURN END C C C SUBROUTINE REPORT (INPUT,AREA,A1,CINT,COLOR,DETJ,DOPLOT, + DQDTDA,DRAWST,ELEV,ERATE, + FBLAND,FDIP,FLEN,FSLIPS,FTAN, + GEOTH,IALIAS, + IPENCT,IPENST,IPENLB,IUNITT, + LDA,LOWBLU, + MXEL,MXFEL,MXNODE,MXWORK, + NCONTR,NDIFF,NFL,NODEF, + NODES,MXSTAT,NTYPE, + NXYST,NUMEL,NUMNOD, + RMSVEC,SDENOM,SIGHB,STATES, + TAUMAT,TAUZZI, + TITLE1,TITLE2,TITLE3, + TEMLIM,USEALI,V,VM,WEDGE, + ZMNODE,ZMOHO, + MODIFY,XIP,XNODE,XST, + YIP,YNODE,YST, + WORK,A2,ATNODE,OUTSCA,OUTVEC, + LAST) C C CREATES GRAPHICS OUTPUT FOR ALL REQUESTED VARIABLES IN THE C CURRENT ITERATION C PARAMETER (NPTYPE=13) C (SHOULD MATCH PARAMETER OF SAME NAME IN MAIN PROGRAM, AND C ALSO VARIABLE NTYPE IN THE CALL.) C CHARACTER*80 TITLE1,TITLE2,TITLE3 CHARACTER*42 TEXT,VUNITS LOGICAL ALLPOS,COLOR,DOPLOT,DOAROW,DOESYM,DOAXES,DOFLTS, + STATES,USEALI LOGICAL DRAWST,FSLIPS DOUBLE PRECISION V,VM C DIMENSION AREA(MXEL),A1(MXWORK),A2(MXWORK), + CINT(NTYPE),ATNODE(MXNODE), + DETJ(7,MXEL),DOPLOT(NTYPE),DQDTDA(MXNODE), + DRAWST(MXSTAT),ELEV(MXNODE),ERATE(3,7,MXEL), + FBLAND(NTYPE),FDIP(3,MXFEL),FLEN(MXFEL), + FSLIPS(MXFEL),FTAN(7,MXFEL),GEOTH(4,7,MXEL), + IALIAS(MXNODE), + LOWBLU(NTYPE), + NODEF(6,MXFEL),NODES(6,MXEL), + OUTSCA(7,MXEL),OUTVEC(2,7,MXEL), + SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL),TAUZZI(7,MXEL), + V(2,MXNODE),VM(2,MXNODE), + XIP(7,MXEL),XNODE(MXNODE),XST(MXSTAT), + YIP(7,MXEL),YNODE(MXNODE),YST(MXSTAT), + ZMNODE(MXNODE),ZMOHO(7,MXEL) C DIMENSION TEXT (NPTYPE),NVCHAR(NPTYPE), + VUNITS(NPTYPE),NVUCHR(NPTYPE) C DATA TEXT(1)/'SHEAR TRACTION ON MOHO '/ DATA NVCHAR(1)/22/ DATA TEXT(2)/'VELOCITY OF MOHO '/ DATA NVCHAR(2)/16/ DATA TEXT(3)/'SURFACE VELOCITY '/ DATA NVCHAR(3)/16/ DATA TEXT(4)/'SURFACE STRAIN-RATES '/ DATA NVCHAR(4)/20/ DATA TEXT(5)/'VERTICALLY-INTEGRATED STRESS ANOMALIES '/ DATA NVCHAR(5)/38/ DATA TEXT(6)/'FINITE ELEMENT GRID '/ DATA NVCHAR(6)/19/ DATA TEXT(7)/'RATE OF CRUSTAL THICKENING '/ DATA NVCHAR(7)/26/ DATA TEXT(8)/'CRUSTAL THICKNESS '/ DATA NVCHAR(8)/17/ DATA TEXT(9)/'MOHO TEMPERATURE '/ DATA NVCHAR(9)/16/ DATA TEXT(10)/'ELEVATION '/ DATA NVCHAR(10)/ 9/ DATA TEXT(11)/'HEAT-FLOW '/ DATA NVCHAR(11)/ 9/ DATA TEXT(12)/'VELOCITY CHANGES FROM LAST ITERATION '/ DATA NVCHAR(12)/36/ DATA TEXT(13)/'MEAN SLIP-RATE OF FAULTS '/ DATA NVCHAR(13)/24/ C DATA VUNITS(1)/'Pa '/ DATA NVUCHR(1)/2/ DATA VUNITS(2)/'m/s '/ DATA NVUCHR(2)/3/ DATA VUNITS(3)/'m/s '/ DATA NVUCHR(3)/3/ DATA VUNITS(4)/'/s '/ DATA NVUCHR(4)/2/ DATA VUNITS(5)/'N/m '/ DATA NVUCHR(5)/3/ DATA VUNITS(6)/' '/ DATA NVUCHR(6)/0/ DATA VUNITS(7)/'m/s '/ DATA NVUCHR(7)/3/ DATA VUNITS(8)/'m '/ DATA NVUCHR(8)/1/ DATA VUNITS(9)/'K '/ DATA NVUCHR(9)/1/ DATA VUNITS(10)/'m '/ DATA NVUCHR(10)/1/ DATA VUNITS(11)/'mW/m**2 '/ DATA NVUCHR(11)/7/ DATA VUNITS(12)/'m/s '/ DATA NVUCHR(12)/3/ DATA VUNITS(13)/' '/ DATA NVUCHR(13)/0/ C IF (LAST.NE.999) THEN WRITE(IUNITT,1) 1 FORMAT (/ /' WRONG NUMBER OF ARGUMENTS IN CALL TO ', + ' SUBPROGRAM REPORT.') STOP ENDIF IF (NTYPE.NE.NPTYPE) THEN WRITE (IUNITT,2) NTYPE 2 FORMAT(/ /' CORRECT PARAMETER NPTYPE IN SUBPROGRAM', + ' REPORT TO ',I3,' AND RECOMPILE.') STOP ENDIF C XMIN=1.E50 YMIN=1.E50 XMAX= -1.E50 YMAX= -1.E50 DO 10 I=1,NUMNOD XMIN=MIN(XMIN,XNODE(I)) YMIN=MIN(YMIN,YNODE(I)) XMAX=MAX(XMAX,XNODE(I)) YMAX=MAX(YMAX,YNODE(I)) 10 CONTINUE C C DETERMINE IF REQUESTED SCALE WILL FIT ONTO PAPER; REDUCE IF NEEDED. C HDENOM=(XMAX-XMIN)/(15.*0.0254) VDENOM=(YMAX-YMIN)/(9.5*0.0254) IF ((SDENOM.GE.HDENOM).AND.(SDENOM.GE.VDENOM)) THEN WRITE (IUNITT,11) SDENOM 11 FORMAT (/' REQUESTED PLOT SCALE DENOMINATOR OF', + 1P,E10.2,' HAS BEEN USED.') ELSE SDENOM=MAX(HDENOM,VDENOM) WRITE (IUNITT,12) SDENOM 12 FORMAT (/' PLOT SCALE DENOMINATOR HAS BEEN INCREASED TO ', + 1P,E10.2/' TO FIT PLOT INTO 9.5 X 15 INCH BOX,' + /' BECAUSE VERSATEC HAS MAXIMA OF 10.5 X 17 INCHES,' + /' AND SPACE MUST BE RESERVED FOR TITLES AND BOX-SCALE') ENDIF C C FOLLOWING FACTOR WILL BE USED IN "CALL FACTOR(VFACT)" TO PREPARE C VERSATEC FOR LATER PLOTTING CALLS IN PHYSICAL (EARTH) SPACE, IN M: VFACT=1./(0.0254*SDENOM) C C FOLLOWING VARIABLE GIVES NUMBER OF INCHES NEEDED FOR GRID, C HORIZONTALLY; PLOTS WILL BE 2" WIDER WHEN LEGEND IS ADDED: XINCH=(XMAX-XMIN)*VFACT C C ADJUST X AND Y VALUES OF ARRAYS (WITH NO PHYSICAL SIGNIFICANCE) BY C CONSTANT ADDITIONS TO CENTER THE PLOT ON PAPER (W/O MOVING ORIGIN) C XADD= -XMIN YADD=(5.25/VFACT)-0.5*(YMAX+YMIN) DO 20 I=1,NUMNOD XNODE(I)=XNODE(I)+XADD YNODE(I)=YNODE(I)+YADD 20 CONTINUE DO 40 M=1,7 DO 30 I=1,NUMEL XIP(M,I)=XIP(M,I)+XADD YIP(M,I)=YIP(M,I)+YADD 30 CONTINUE 40 CONTINUE IF (STATES) THEN DO 50 I=1,NXYST XST(I)=XST(I)+XADD YST(I)=YST(I)+YADD 50 CONTINUE ENDIF C WRITE (IUNITT,99) 99 FORMAT (/ / + ' ----------------------------------------------------------') C IF (DOPLOT(1)) THEN ALLPOS=.TRUE. CALL MAGNIT (INPUT,NUMEL,SIGHB, + OUTPUT,OUTSCA) CALL EXTRAP (INPUT,AREA,A1,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE, + WORK,A2) DFCON=CINT(1) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.TRUE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,1,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,SIGHB,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,199) 199 FORMAT (' PLOT OF SHEAR TRACTION ON MOHO COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF IF (DOPLOT(2)) THEN ALLPOS=.TRUE. CALL MAGNIN (INPUT,NUMNOD,VM, + OUTPUT,ATNODE) CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,VM, + OUTPUT,OUTVEC) CALL MAGNIT (INPUT,NUMEL,OUTVEC, + OUTPUT,OUTSCA) DFCON=CINT(2) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.TRUE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,2,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,299) 299 FORMAT (' PLOT OF MANTLE VELOCITY COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF IF (DOPLOT(3)) THEN ALLPOS=.TRUE. CALL MAGNIN (INPUT,NUMNOD,V, + OUTPUT,ATNODE) CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,V, + OUTPUT,OUTVEC) CALL MAGNIT (INPUT,NUMEL,OUTVEC, + OUTPUT,OUTSCA) DFCON=CINT(3) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.TRUE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.TRUE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,3,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,399) 399 FORMAT (' PLOT OF SURFACE VELOCITY COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF IF (DOPLOT(4)) THEN ALLPOS=.TRUE. CALL MAXER (INPUT,ERATE,NUMEL, + OUTPUT,OUTSCA) CALL EXTRAP (INPUT,AREA,A1,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE, + WORK,A2) DFCON=CINT(4) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.TRUE. DOAXES=.FALSE. DOFLTS=.TRUE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,4,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,499) 499 FORMAT (' PLOT OF SURFACE STRAIN-RATES COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF IF (DOPLOT(5)) THEN ALLPOS=.TRUE. CALL MAXSS (INPUT,NUMEL,TAUMAT,TAUZZI, + OUTPUT,OUTSCA) CALL EXTRAP (INPUT,AREA,A1,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE, + WORK,A2) DFCON=CINT(5) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.TRUE. DOFLTS=.TRUE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,5,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,599) 599 FORMAT (' PLOT OF INTEGRATED STRESS ANOMALIES COMPLETED.' + /' ----------------------------------------------------------') ENDIF IF (DOPLOT(6)) THEN CALL ETCH (DRAWST,FDIP,FLEN,FTAN,6,NTYPE,NFL, + NODEF,NODES,NUMEL,NUMNOD,NVCHAR,NXYST, + STATES,TEXT,TITLE1, + VFACT,WEDGE,XINCH, + XNODE,XST,YNODE,YST, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,699) 699 FORMAT (' PLOT OF FINITE ELEMENT GRID COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF IF (DOPLOT(7)) THEN ALLPOS=.FALSE. DFCON=CINT(7) DO 720 M=1,7 DO 710 I=1,NUMEL OUTSCA(M,I)= -ZMOHO(M,I)*(ERATE(1,M,I)+ + ERATE(2,M,I)) 710 CONTINUE 720 CONTINUE CALL EXTRAP (INPUT,AREA,A1,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE, + WORK,A2) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,7,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,799) 799 FORMAT (' PLOT OF CRUSTAL THICKENING RATE COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF IF (DOPLOT(8)) THEN ALLPOS=.TRUE. DFCON=CINT(8) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ZMNODE,NCONTR,NUMEL,NUMNOD,ZMOHO, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,8,NTYPE, + ZMNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,899) 899 FORMAT (' PLOT OF CRUSTAL THICKNESS COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF IF (DOPLOT(9)) THEN ALLPOS=.TRUE. CALL TMOHO (INPUT,GEOTH,NUMEL,TEMLIM,ZMOHO, + OUTPUT,OUTSCA) CALL EXTRAP (INPUT,AREA,A1,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE, + WORK,A2) DO 910 I=1,NUMNOD ATNODE(I)=MIN(ATNODE(I),TEMLIM) 910 CONTINUE DFCON=CINT(9) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,9,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,999) 999 FORMAT (' PLOT OF MOHO TEMPERATURE COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF IF (DOPLOT(10)) THEN ALLPOS=.FALSE. CALL INTERP (INPUT,ELEV,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,OUTSCA) DFCON=CINT(10) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ELEV,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,10,NTYPE, + ELEV,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,1099) 1099 FORMAT (' PLOT OF ELEVATION COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF IF (DOPLOT(11)) THEN DO 1110 I=1,NUMNOD C C Convert from W/m**2 to mW/m**2 C ATNODE(I)=DQDTDA(I)*1000. 1110 CONTINUE ALLPOS=.TRUE. CALL INTERP (INPUT,ATNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,OUTSCA) DFCON=CINT(11) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,11,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,1199) 1199 FORMAT (' PLOT OF HEAT-FLOW COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF IF (DOPLOT(12)) THEN ENDIF IF (DOPLOT(13)) THEN IF (NFL.LE.0) THEN WRITE(IUNITT,1301) 1301 FORMAT (/' NOTE: PLOT OF FAULT SLIP RATES WAS', + ' REQUESTED, BUT'/' THERE ARE NO FAULT ELEMENTS,' + /' SO THIS PLOT WILL BE OMITTED.') ELSE CALL SLIPS (DRAWST,FDIP,FLEN,FSLIPS,FTAN,13,NTYPE, + NODEF,NODES,NFL,NUMEL,NUMNOD,NVCHAR,NXYST, + RMSVEC,STATES,TEXT,TITLE3,V,VFACT,WEDGE, + XINCH,XNODE,XST,YNODE,YST, + IPENCT,IPENST,IPENLB,COLOR) WRITE (IUNITT,1399) 1399 FORMAT (' PLOT OF FAULT SLIP-RATES COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF ENDIF 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(3,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 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 (INCLUDES THE C LOCAL VERTICAL STRESS INTEGRAL) NOT THE DEVIATORIC STRESS 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 TMOHO (INPUT,GEOTH,NUMEL,TEMLIM,ZMOHO, + OUTPUT,OUTSCA) C C CALCULATES TEMPERATURE AT THE BASE OF CRUST BELOW INTEGRATION C POINTS C DIMENSION GEOTH(4,7,NUMEL),OUTSCA(7,NUMEL),ZMOHO(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(ZMOHO(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 SLIPS (DRAWST,FDIP,FLEN,FSLIPS,FTAN,JV,NTYPE, + NODEF,NODES,NFL,NUMEL,NUMNOD,NVCHAR,NXYST, + RMSVEC,STATES,TEXT,TITLE,V,VFACT,WEDGE, + XINCH,XNOD,XST,YNOD,YST, + IPENCT,IPENST,IPENLB,COLOR) C C PLOTS THE FAULT ELEMENT AND THEIR SLIP RATES. C FAULT ELEMENTS ARE IN RED WITH DIP SYMBOLS. C FAULTS WITH A VERY LOW SLIP RATE ARE DASHED; NOTE THAT LOGICAL C ARRAY "FSLIPS" IS REDEFINED BY THIS ROUTINE. C A CURVING GRAPH OF SCALAR SLIP-RATE PARALLELS EACH ELEMENT C ON THE OPPOSITE SIDE FROM THE DIP SYMBOLS. YELLOW IS C USED FOR NORMAL SLIP, GREEN FOR DEXTRAL STRIKE-SLIP, C BLACK FOR SINISTRAL STRIKE-SLIP, C AND BLUE FOR REVERSE OR THRUST SLIP. C ON THE SIDE OF THE DIP SYMBOLS, A VECTOR SHOWS THE DIRECTION C OF RELATIVE MOTION. C LABELS WITH MODEL TITLE BELOW. C DOUBLE PRECISION V,V2,VMAX CHARACTER*80 TITLE,TITLE2 CHARACTER*42 TEXT CHARACTER*2 MMPERY INTEGER DOWN,UP INTEGER BLACK,BLUE,GREEN,ORANGE,PINK,RED,VIOLET LOGICAL COLOR,DASH,STATES LOGICAL DRAWST,FSLIPS DIMENSION DRAWST(NXYST),FDIP(3,NFL),FLEN(NFL),FTAN(7,NFL), + FSLIPS(NFL),IARRAY(1),NODEF(6,NFL), + NODES(6,NUMEL),NVCHAR(NTYPE),TEXT(NTYPE), + V(2,NUMNOD),XNOD(NUMNOD),YNOD(NUMNOD), + XST(NXYST),YST(NXYST) DIMENSION NPOINT(1),XARRAY(63),YARRAY(63) DIMENSION FARG(0:10),HARG(0:10),HRATE(0:10), + ICOLOR(0:10),RATE(0:10) DATA DOWN/2/, UP/3/ DATA BLACK/1/,BLUE/2/,GREEN/7/,ORANGE/144/, + PINK/183/,RED/6/,VIOLET/5/ C C STATEMENT FUNCTIONS: PHIVAL(S,F1,F2,F3)= + F1*(1.-3.*S+2.*S**2)+ + F2*(4.*S*(1.-S))+ + F3*(2.*S**2-S) DERIV(S,F1,F2,F3)= + F1*(4.*S-3.)+ + F2*(4.-8.*S)+ + F3*(4.*S-1.) C C INITIALIZE VERSATEC C NPOINT(1)=4 IF (COLOR) CALL VPOPT (101,0,0.0,IERR) IARRAY(1)=7 CALL VPOPT (20,IARRAY,RARG,IER) CALL PAPER (0.0,XINCH+2.,0.0,10.5) CALL PLOTS (0,0,0) CALL SETFNT (18) IF (COLOR) THEN CALL TONFLG (1) ENDIF C C********************************************************************** C C OPEN SEGMENT 1 (COLORED-IN GRAPHS AND VECTORS ALONG THE FAULTS) C C LEAVE 0.5" AT BOTTOM, 0.5" ON TOP, AND 2.0" ON RIGHT C CALL WINDOW(0.,XINCH,0.5,10.0) CALL VPORT (0.,XINCH,0.5,10.0) C (SET TO DO PLOT IN PHYSICAL, EARTH DIMENSIONS, IN METERS:) CALL FACTOR (VFACT) C C CHARACTER HEIGHT: C HIGH=0.14/VFACT C C DETERMINE REASONABLE SCALE FOR SLIP BANDS C VMAX=0. DO 10 I=1,NUMNOD V2=V(1,I)**2+V(2,I)**2 VMAX=MAX(VMAX,V2) 10 CONTINUE IF (VMAX.GT.0.) THEN VMAX=SQRT(VMAX) ELSE VMAX=1. ENDIF SCALE=1.5*(RMSVEC/VFACT)/VMAX C C COMPUTE SLIPS AT 11 POINTS PER FAULT C DO 100 I=1,NFL D1=FDIP(1,I) D2=FDIP(2,I) D3=FDIP(3,I) I1=NODEF(1,I) I2=NODEF(2,I) I3=NODEF(3,I) I4=NODEF(4,I) I5=NODEF(5,I) I6=NODEF(6,I) X1=XNOD(I1) X2=XNOD(I2) X3=XNOD(I3) Y1=YNOD(I1) Y2=YNOD(I2) Y3=YNOD(I3) VX1=V(1,I1) VX2=V(1,I2) VX3=V(1,I3) UX1=V(1,I6) UX2=V(1,I5) UX3=V(1,I4) VY1=V(2,I1) VY2=V(2,I2) VY3=V(2,I3) UY1=V(2,I6) UY2=V(2,I5) UY3=V(2,I4) DO 50 IS=0,10 S=0.10*IS DIP=PHIVAL(S,D1,D2,D3) DXDS=DERIV(S,X1,X2,X3) DYDS=DERIV(S,Y1,Y2,Y3) ARG=ATAN2(DYDS,DXDS) DVX=PHIVAL(S,VX1,VX2,VX3)-PHIVAL(S,UX1,UX2,UX3) DVY=PHIVAL(S,VY1,VY2,VY3)-PHIVAL(S,UY1,UY2,UY3) AZIMHS=ATAN2F(DVY,DVX) HORS=SQRT((1.D0*DVX)**2+(1.D0*DVY)**2) UNITX=COS(ARG) UNITY=SIN(ARG) CROSSX= -UNITY CROSSY= +UNITX SINIST=DVX*UNITX+DVY*UNITY IF (ABS(DIP-1.570796).LT.WEDGE) THEN CLOSE=0. VUPDIP=0. IF (SINIST.GE.0.) THEN RAKE=0. ELSE RAKE=3.14159 ENDIF ELSE CLOSE=DVX*CROSSX+DVY*CROSSY VUPDIP=CLOSE/COS(DIP) RAKE=ATAN2F(VUPDIP,SINIST) ENDIF RELV=VUPDIP*SIN(DIP) SNET=SQRT((1.D0*SINIST)**2+ + (1.D0*VUPDIP)**2) IF (SNET.GT.0.) THEN PLUNGE= -ASIN(RELV/SNET) ELSE PLUNGE=0. ENDIF RATE(IS)=SNET HRATE(IS)=HORS HARG(IS)=AZIMHS FARG(IS)=ARG IF ((ABS(DIP-1.570796).LT.WEDGE) .OR. + (ABS(SIN(RAKE)).LT.0.5)) THEN IF (SINIST.LE.0.) THEN C DEXTRAL STRIKE-SLIP ICOLOR(IS)=GREEN ELSE C SINISTRAL STRIKE-SLIP ICOLOR(IS)=ORANGE ENDIF ELSE IF (CLOSE.LT.0.) THEN C NORMAL SLIP ICOLOR(IS)=PINK ELSE C REVERSE OR THRUST SLIP ICOLOR(IS)=BLUE ENDIF 50 CONTINUE C C IS THIS FAULT SEGMENT ACTIVE (SOLID LINE, VECTOR, AND NUMBER),OR C INACTIVE (DASHED LINE ONLY) ? C FSLIPS(I)=ABS(HRATE(5)).GT.(0.01*VMAX) IF (FSLIPS(I)) THEN C C DRAW COLORED GRAPH ON UPDIP SIDE C DO 60 IS=0,9 S0=0.10*IS S1=0.10*(IS+1) XF0=PHIVAL(S0,X1,X2,X3) XF1=PHIVAL(S1,X1,X2,X3) YF0=PHIVAL(S0,Y1,Y2,Y3) YF1=PHIVAL(S1,Y1,Y2,Y3) IF (COLOR) THEN CALL PENCLR (2,ICOLOR(IS)) ENDIF CALL NEWPEN (2) CALL PLOT (XF0,YF0,UP) XARRAY(1)=XF0 YARRAY(1)=YF0 ARG=FARG(IS) UNITX=COS(ARG) UNITY=SIN(ARG) DIP=PHIVAL(S0,D1,D2,D3) IF (DIP.LE.(1.570796+WEDGE)) THEN CROSSX= -UNITY CROSSY= +UNITX ELSE CROSSX= +UNITY CROSSY= -UNITX ENDIF XT=XF0+RATE(IS)*SCALE*CROSSX YT=YF0+RATE(IS)*SCALE*CROSSY CALL PLOT (XT,YT,DOWN) XARRAY(2)=XT YARRAY(2)=YT ARG=FARG(IS+1) UNITX=COS(ARG) UNITY=SIN(ARG) DIP=PHIVAL(S1,D1,D2,D3) IF (DIP.LE.(1.570796+WEDGE)) THEN CROSSX= -UNITY CROSSY= +UNITX ELSE CROSSX= +UNITY CROSSY= -UNITX ENDIF XT=XF1+RATE(IS+1)*SCALE*CROSSX YT=YF1+RATE(IS+1)*SCALE*CROSSY CALL PLOT (XT,YT,DOWN) XARRAY(3)=XT YARRAY(3)=YT CALL PLOT (XF1,YF1,DOWN) XARRAY(4)=XF1 YARRAY(4)=YF1 IF (COLOR) THEN CALL TONCLR (ICOLOR(IS)) CALL TONE (XARRAY,YARRAY,NPOINT,1) ENDIF 60 CONTINUE C C DRAW SINGLE VECTOR AT MIDPOINT C ARG=FARG(5) UNITX=COS(ARG) UNITY=SIN(ARG) DIP=FDIP(2,I) IF (DIP.LE.(1.570796+WEDGE)) THEN CROSSX= +UNITY CROSSY= -UNITX VARG=HARG(5) ELSE CROSSX= -UNITY CROSSY= +UNITX VARG=HARG(5)+3.14159 ENDIF C**************************************************************** C CHOOSE ONE OF THE FOLLOWING LINES TO SELECT VARIABLE- C OR CONSTANT-LENGTH SLIP VECTORS (CONSTANT IS MORE LEGIBLE) CCCCC VECTOR=HRATE(5)*SCALE VECTOR=0.50*RMSVEC/VFACT C**************************************************************** OFFSET=MAX( 1.2*(0.5*VECTOR*ABS(SIN(VARG-ARG))), + 0.10*FLEN(I) ) XC=X2+OFFSET*CROSSX YC=Y2+OFFSET*CROSSY DX=VECTOR*COS(VARG) DY=VECTOR*SIN(VARG) X0=XC-0.5*DX Y0=YC-0.5*DY CALL PLOT (X0,Y0,UP) IF (COLOR) CALL PENCLR (3,BLACK) CALL NEWPEN (3) XP=X0+DX YP=Y0+DY CALL PLOT (XP,YP,DOWN) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT (XP+AX,YP+AY,DOWN) CALL PLOT (XP,YP,UP) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT (XP+BX,YP+BY,DOWN) C C LABEL IN MM/YEAR C CROSSX= - CROSSX CROSSY= - CROSSY LABEL=RATE(5)*1000.*3.15576E7 + 0.5 WRITE (MMPERY,'(I2)') LABEL IF (MMPERY(2:2).EQ.'0') MMPERY(2:2)='O' XFM=PHIVAL(0.5,X1,X2,X3) YFM=PHIVAL(0.5,Y1,Y2,Y3) ARG=ATAN2F(CROSSY,CROSSX)-1.5708 XFMP=XFM+CROSSX*HIGH*0.5-CROSSY*HIGH*0.7 YFMP=YFM+CROSSY*HIGH*0.5+CROSSX*HIGH*0.7 IF (COLOR) THEN CALL PENCLR (IPENLB,BLACK) ENDIF CALL NEWPEN (IPENLB) CALL SYMBOL(XFMP,YFMP,HIGH,MMPERY,IDUMMY,ARG*57.3,2) ENDIF 100 CONTINUE C C END SEGMENT 1 (COLORED GRAPHS AND VECTORS) C C******************************************************************* C C BEGIN SEGMENT 2 (FAULT GRID) C C C PLOT ALL FAULTS IN RED C IF (COLOR) CALL PENCLR (IPENST,RED) CALL NEWPEN (IPENST) SUM=0.0 DO 32 I=1,NFL SUM=SUM+FLEN(I) 32 CONTINUE AVERAG=SUM/NFL DIPSIZ=0.10*AVERAG DO 35 I=1,NFL DASH=.NOT.FSLIPS(I) CALL FAULT (INPUT,DASH,FDIP,FTAN,I,NFL, + NUMNOD,NODEF,DIPSIZ, + WEDGE,XNOD,YNOD) 35 CONTINUE C C END SEGMENT OF FAULT GRID C C**************************************************************** C IF (STATES) THEN C C USE VIOLET PEN C IF (COLOR) CALL PENCLR (IPENST,VIOLET) CALL NEWPEN (IPENST) C CALL USMAP (INPUT,DRAWST,NXYST,XST,YST) C C END SEGMENT WITH STATE LINES C ENDIF C**************************************************************** C C BEGIN SEGMENT 4 (KEY SEGMENT, CORRESPONDS TO COLOR BAR C INCLUDED WITH OTHER VARIABLES) C C OPEN UP WINDOW, AND RETURN TO INCH UNITS C CALL FACTOR (1.) CALL WINDOW(0.,XINCH+2.,0.5,10.0) CALL VPORT (0.,XINCH+2.,0.5,10.0) CALL FACTOR (1.) C C CHARACTER SIZE C HIGH=0.12 HEIGHT=HIGH WIDTH=0.87*HEIGHT C C SLIP-KEY C YLINE=8.8 IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+.45,YLINE,HIGH,'SLIP-RATE',IDUMMY,0.,9) CALL PLOT (XINCH+.45,YLINE-0.3*HIGH,UP) CALL PLOT (XINCH+.45+9.*WIDTH,YLINE-0.3*HIGH,DOWN) C C SLIP RATE IN MM/YEAR C YLINE=8.1 IF (COLOR) THEN CALL PENCLR (2,ORANGE) CALL NEWPEN (2) CALL TONCLR (ORANGE) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,0) ELSE CALL NEWPEN (2) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,1) ENDIF IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+0.6-0.4*WIDTH, + YLINE+0.3*HEIGHT,HEIGHT,'5',IDUMMY,0.,1) CALL SYMBOL(XINCH+0.9,YLINE,0.12,'MM/YEAR',IDUMMY,0.,7) IF (COLOR) CALL PENCLR (IPENST,RED) CALL NEWPEN (IPENST) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) C C LOCKED FAULT C YLINE=7.4 IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'LOCKED',IDUMMY,0.,6) IF (COLOR) CALL PENCLR (IPENST,RED) CALL NEWPEN (IPENST) CALL PLOT (XINCH+0.45,YLINE+0.5*HIGH,UP) CALL PLOT (XINCH+0.51,YLINE+0.5*HIGH,DOWN) CALL PLOT (XINCH+0.57,YLINE+0.5*HIGH,UP) CALL PLOT (XINCH+0.63,YLINE+0.5*HIGH,DOWN) CALL PLOT (XINCH+0.69,YLINE+0.5*HIGH,UP) CALL PLOT (XINCH+0.75,YLINE+0.5*HIGH,DOWN) C C DEXTRAL C YLINE=6.7 IF (COLOR) THEN CALL TONCLR (GREEN) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,0) ELSE CALL NEWPEN (2) CALL RECT (XINCH+0.50,XINCH+0.55,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.55,XINCH+0.60,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.60,XINCH+0.65,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.65,XINCH+0.70,YLINE,YLINE+0.2,1) ENDIF IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'DEXTRAL',IDUMMY,0.,7) IF (COLOR) CALL PENCLR (IPENST,RED) CALL NEWPEN (IPENST) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) DX= -0.3 DY= 0.0 X0=XINCH+0.75 Y0=YLINE-0.15 CALL PLOT (X0,Y0,UP) IF (COLOR) CALL PENCLR (3,BLACK) CALL NEWPEN (3) XP=X0+DX YP=Y0+DY CALL PLOT (XP,YP,DOWN) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT (XP+AX,YP+AY,DOWN) CALL PLOT (XP,YP,UP) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT (XP+BX,YP+BY,DOWN) C C SINISTRAL C YLINE=5.8 IF (COLOR) THEN CALL TONCLR (ORANGE) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,0) ELSE CALL NEWPEN (2) CALL RECT (XINCH+0.50,XINCH+0.55,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.55,XINCH+0.60,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.60,XINCH+0.65,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.65,XINCH+0.70,YLINE,YLINE+0.2,1) ENDIF IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'SINISTRAL',IDUMMY,0.,9) IF (COLOR) CALL PENCLR (IPENST,RED) CALL NEWPEN (IPENST) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) DX= 0.3 DY= 0.0 X0=XINCH+0.45 Y0=YLINE-0.15 CALL PLOT (X0,Y0,UP) IF (COLOR) CALL PENCLR (3,BLACK) CALL NEWPEN (3) XP=X0+DX YP=Y0+DY CALL PLOT (XP,YP,DOWN) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT (XP+AX,YP+AY,DOWN) CALL PLOT (XP,YP,UP) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT (XP+BX,YP+BY,DOWN) C C THRUST C YLINE=4.9 IF (COLOR) THEN CALL TONCLR (BLUE) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,0) ELSE CALL NEWPEN (2) CALL RECT (XINCH+0.50,XINCH+0.55,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.55,XINCH+0.60,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.60,XINCH+0.65,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.65,XINCH+0.70,YLINE,YLINE+0.2,1) ENDIF IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'THRUST',IDUMMY,0.,6) IF (COLOR) CALL PENCLR (IPENST,RED) CALL NEWPEN (IPENST) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) DX= 0.0 DY= 0.3 X0=XINCH+0.60 Y0=YLINE-0.35 CALL PLOT (X0,Y0,UP) IF (COLOR) CALL PENCLR (3,BLACK) CALL NEWPEN (3) XP=X0+DX YP=Y0+DY CALL PLOT (XP,YP,DOWN) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT (XP+AX,YP+AY,DOWN) CALL PLOT (XP,YP,UP) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT (XP+BX,YP+BY,DOWN) C C NORMAL C YLINE=4.0 IF (COLOR) THEN CALL TONCLR (PINK) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,0) ELSE CALL NEWPEN (2) CALL RECT (XINCH+0.50,XINCH+0.55,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.55,XINCH+0.60,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.60,XINCH+0.65,YLINE,YLINE+0.2,1) CALL RECT (XINCH+0.65,XINCH+0.70,YLINE,YLINE+0.2,1) ENDIF IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'NORMAL',IDUMMY,0.,6) IF (COLOR) CALL PENCLR (IPENST,RED) CALL NEWPEN (IPENST) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) DX= 0.0 DY= -0.3 X0=XINCH+0.60 Y0=YLINE-0.05 CALL PLOT (X0,Y0,UP) IF (COLOR) CALL PENCLR (3,BLACK) CALL NEWPEN (3) XP=X0+DX YP=Y0+DY CALL PLOT (XP,YP,DOWN) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT (XP+AX,YP+AY,DOWN) CALL PLOT (XP,YP,UP) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT (XP+BX,YP+BY,DOWN) C C DIP-KEY C YLINE=3. IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+0.7,YLINE,HIGH,'DIP',IDUMMY,0.,3) CALL PLOT (XINCH+0.7,YLINE-0.3*HIGH,UP) CALL PLOT (XINCH+0.7+3.*WIDTH,YLINE-0.3*HIGH,DOWN) C C VERTICAL DIP C YLINE=2.5 IF (COLOR) CALL PENCLR (IPENST,RED) CALL NEWPEN (IPENST) CALL PLOT (XINCH+0.45,YLINE+0.5*HIGH,UP) CALL PLOT (XINCH+0.75,YLINE+0.5*HIGH,DOWN) IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'9O DEG.',IDUMMY,0.,7) C C STEEP DIP C YLINE=2.0 IF (COLOR) CALL PENCLR (IPENST,RED) CALL NEWPEN (IPENST) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) CALL PLOT (XINCH+0.6,YLINE,UP) CALL PLOT (XINCH+0.6,YLINE+0.15,DOWN) IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'65 DEG.',IDUMMY,0.,7) C C MEDIUM DIP C YLINE=1.5 IF (COLOR) CALL PENCLR (IPENST,RED) CALL NEWPEN (IPENST) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) CALL PLOT (XINCH+0.53,YLINE,UP) CALL PLOT (XINCH+0.53,YLINE+0.14,DOWN) CALL PLOT (XINCH+0.67,YLINE+0.14,DOWN) CALL PLOT (XINCH+0.67,YLINE,DOWN) IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'45 DEG.',IDUMMY,0.,7) C C SHALLOW DIP C YLINE=1.0 IF (COLOR) CALL PENCLR (IPENST,RED) CALL NEWPEN (IPENST) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) CALL PLOT (XINCH+0.53,YLINE,UP) CALL PLOT (XINCH+0.6,YLINE+0.2,DOWN) CALL PLOT (XINCH+0.67,YLINE,DOWN) IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'25 DEG.',IDUMMY,0.,7) C C END KEY SEGMENT C C******************************************************************* C C BEGIN SEGMENT 5 (TITLES) C C OPEN WINDOW WIDE, IN INCHES C CALL FACTOR (1.) CALL WINDOW(0.,XINCH+2.,0.,10.5) CALL VPORT (0.,XINCH+2.,0.,10.5) CALL FACTOR (1.) C C CHARACTER HEIGHT: HEIGHT=0.15 WIDTH=HEIGHT*0.87 HIGH=HEIGHT C C WRITE MODEL TITLE C DO 4010 I=1,80 IF (TITLE(I:I).EQ.'0') THEN TITLE2(I:I)='O' ELSE TITLE2(I:I)=TITLE(I:I) ENDIF 4010 CONTINUE IF (COLOR) CALL PENCLR (IPENLB,BLACK) CALL NEWPEN (IPENLB) CALL SYMBOL (0.2,0.2,HEIGHT,TITLE2,IDUMMY,0.,80) C C WRITE VARIABLE IDENTIFIER C CALL SYMBOL(0.2,10.15,HIGH,TEXT(JV),IDUMMY,0.,NVCHAR(JV)) C C ADD GRAPHICAL LENGTH SCALE FOLLOWING VARIABLE IDENTIFIER C CALL WHERE (XP,YP,F) XSPACE=3.0 CALL PLOT (XP+XSPACE,10.4,UP) CALL PLOT (XP+XSPACE,10.3,DOWN) XLONG=100.E3*VFACT CALL PLOT (XP+XSPACE+XLONG,10.3,DOWN) CALL PLOT (XP+XSPACE+XLONG,10.4,DOWN) CALL SYMBOL (XP+XSPACE+0.5*XLONG-3.*WIDTH, + 10.3-1.3*HEIGHT, + HEIGHT,'1OO km',IDUMMY,0.,6) C C END SEGMENT OF TEXT LABELS C C**************************************************************** C C SHUT DOWN VERSATEC C CALL FACTOR (1.) CALL PLOT (XINCH+2.,0.0,999) C RETURN END C C C SUBROUTINE DOSIDE (FMAX,FMIN,DFCON,FN,N1,N2,NM,PS,NPS,NINLIN,Z) C C FIND BEGINNING/END POINTS OF CONTOURS ALONG SIDE OF ELEMENT C LOGICAL Z DIMENSION FN(6),PS(5,NINLIN) ILOW=IUNDER(FMIN/DFCON) IF (FMIN.EQ.(DFCON*ILOW)) ILOW=ILOW-1 IHI=IABOVE(FMAX/DFCON) IF (FMAX.EQ.(DFCON*IHI)) IHI=IHI+1 NBTWEN=IHI-ILOW-1 IF (NBTWEN.GE.1) THEN NBASE=ILOW A=2.*FN(N1)-4.*FN(NM)+2.*FN(N2) B= -3.*FN(N1)+4.*FN(NM)-FN(N2) DO 10 K=1,NBTWEN N=K+NBASE F=N*DFCON C= FN(N1)-F IF (A.NE.0.) THEN DISC=SQRT(MAX(B**2-4.*A*C,0.)) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) OUT1=MAX(MAX(0.,-ROOT1),MAX(0.,ROOT1-1.)) OUT2=MAX(MAX(0.,-ROOT2),MAX(0.,ROOT2-1.)) IF (OUT1.LE.OUT2) THEN IF (OUT1.GT.0.10)GO TO 10 S=ROOT1 ELSE IF (OUT2.GT.0.10)GO TO 10 S=ROOT2 ENDIF ELSE IF (FN(N2).NE.FN(N1)) THEN S=(F-FN(N1))/(FN(N2)-FN(N1)) ELSE S=0. ENDIF Z=(NPS.GE.NINLIN) IF (Z) RETURN NPS=NPS+1 PS(N1,NPS)=1.-S PS(N2,NPS)=S N3=6-N1-N2 PS(N3,NPS)=0. PS(4,NPS)=F 10 CONTINUE ENDIF RETURN END C C C SUBROUTINE DOPART (FEXT,FMAX,FMIN,DFCON,FN, + N1,N2,NM,S1,S2,PS,NPS,NINLIN,Z) C C FIND CONTOUR END POINTS ALONG PART OF AN ELEMENT SIDE C LOGICAL Z DIMENSION FN(6),PS(5,NINLIN) ILOW=IUNDER(FMIN/DFCON) IF (FMIN.EQ.(DFCON*ILOW)) ILOW=ILOW-1 IHI=IABOVE(FMAX/DFCON) IF (FMAX.EQ.(DFCON*IHI)) IHI=IHI+1 NBTWEN=IHI-ILOW-1 IF (NBTWEN.GE.1) THEN NBASE=ILOW A=2.*FN(N1)-4.*FN(NM)+2.*FN(N2) B= -3.*FN(N1)+4.*FN(NM)-FN(N2) DO 20 K=1,NBTWEN N=K+NBASE F=N*DFCON C= FN(N1)-F IF (A.NE.0.) THEN DISC=SQRT(MAX(B**2-4.*A*C,0.)) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) OUT1=MAX(MAX(0.,S1-ROOT1),MAX(0.,ROOT1-S2)) OUT2=MAX(MAX(0.,S1-ROOT2),MAX(0.,ROOT2-S2)) IF (OUT1.LE.OUT2) THEN IF (OUT1.GT.0.10) GO TO 20 S=ROOT1 ELSE IF (OUT2.GT.0.10) GO TO 20 S=ROOT2 ENDIF ELSE IF (FN(N1).NE.FN(N2)) THEN S=(F-FN(N1))/(FN(N2)-FN(N1)) ELSE S=0. ENDIF Z=(NPS.GE.NINLIN) IF (Z) RETURN NPS=NPS+1 PS(N1,NPS)=1.-S PS(N2,NPS)=S N3=6-N1-N2 PS(N3,NPS)=0. PS(4,NPS)=F 20 CONTINUE ENDIF RETURN END C C C SUBROUTINE DOLINE (FEXT,DFCON,FN,NCL,DS,S1EXT,S2EXT,S3EXT, + IHIC,ILOC,PS,NPS,NINLIN,Z) C C FINDS CONTOUR START/END POINT ALONG LINE FROM A NODE TO AN EXTREMUM C NOTE THAT POINTS ARE STORED ONLY IF (F/DEFCON) FALLS OUTSIDE OF C PREVIOUS RANGE ILOC-IHIC FOUND ALONG ELEMENT SIDES. C LOGICAL Z DIMENSION FN(6),DS(3),PS(5,NINLIN) 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) FMAX=AMAX1(FN(NCL),FEXT) FMIN=AMIN1(FN(NCL),FEXT) ILOW=IUNDER(FMIN/DFCON) IF (FMIN.EQ.(DFCON*ILOW)) ILOW=ILOW-1 IHI=IABOVE(FMAX/DFCON) IF (FMAX.EQ.(DFCON*IHI)) IHI=IHI+1 NBTWEN=IHI-ILOW-1 IF (NBTWEN.GE.1) THEN NBASE=ILOW FMID=PHIVAL((S1EXT-0.5*DS(1)),(S2EXT-0.5*DS(2)), + (S3EXT-0.5*DS(3)),FN(1),FN(2),FN(3), + FN(4),FN(5),FN(6)) A=2.*FN(NCL)-4.*FMID+2.*FEXT B= -3.*FN(NCL)+4.*FMID-FEXT DO 20 K=1,NBTWEN N=K+NBASE F=N*DFCON C= FN(NCL)-F IF (A.NE.0.) THEN DISC=SQRT(MAX(B**2-4.*A*C,0.)) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) OUT1=MAX(MAX(0.,-ROOT1),MAX(0.,ROOT1-1.)) OUT2=MAX(MAX(0.,-ROOT2),MAX(0.,ROOT2-1.)) IF (OUT1.LE.OUT2) THEN IF (OUT1.GT.0.10) GO TO 20 S=ROOT1 ELSE IF (OUT2.GT.0.10) GO TO 20 S=ROOT2 ENDIF ELSE IF (FEXT.NE.FN(NCL)) THEN S=(F-FN(NCL))/(FEXT-FN(NCL)) ELSE S=0. ENDIF Z=(NPS.GE.NINLIN) IF (Z) RETURN IF (F.GE.0.) THEN IC=F/DFCON+0.1 ELSE IT= -F/DFCON+0.1 IC= -IT ENDIF IF ((IC.GT.IHIC).OR.(IC.LT.ILOC)) THEN NPS=NPS+1 PS(1,NPS)=S1EXT-(1.-S)*DS(1) PS(2,NPS)=S2EXT-(1.-S)*DS(2) PS(3,NPS)=S3EXT-(1.-S)*DS(3) PS(4,NPS)=F ENDIF 20 CONTINUE ENDIF RETURN END C C C SUBROUTINE FAULT (INPUT,DASH,FDIP,FTAN,I,MXFEL,MXNODE, + NODEF,SIZE,WEDGE,XNODE,YNODE) C C DRAW ONE FAULT ELEMENT, WITH DIP SYMBOLS C THE DIP SYMBOLS HAVE A CHARACTERISTIC DIMENSION OF "SIZE", C IN PHYSICAL (MAP) LENGTH UNITS. C C IF LOGICAL FLAG "DASH" IS ON, THE LINE IS DASHED. C INTEGER DOWN,UP LOGICAL DASH DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS DIMENSION FPHI(6,7),FPOINT(7),FGAUSS(7) DIMENSION FDIP(3,MXFEL),FTAN(7,MXFEL),NODEF(6,MXFEL), + XNODE(MXNODE),YNODE(MXNODE) DATA DOWN/2/, UP/3/ DATA STEP/0.10/, ISTEP/10/ C C STATEMENT FUNCTION: PHIVAL(S,F1,F2,F3)= + F1*(1.-3.*S+2.*S**2)+ + F2*(4.*S*(1.-S))+ + F3*(2.*S**2-S) C I1=NODEF(1,I) I2=NODEF(2,I) I3=NODEF(3,I) X1=XNODE(I1) X2=XNODE(I2) X3=XNODE(I3) Y1=YNODE(I1) Y2=YNODE(I2) Y3=YNODE(I3) S=0. D1=FDIP(1,I) D2=FDIP(2,I) D3=FDIP(3,I) DS=STEP X=PHIVAL(S,X1,X2,X3) Y=PHIVAL(S,Y1,Y2,Y3) DO 10 K=1,ISTEP CALL PLOT(X,Y,UP) S=S+DS X=PHIVAL(S,X1,X2,X3) Y=PHIVAL(S,Y1,Y2,Y3) IF (DASH.AND.(MOD(K,2).EQ.0)) THEN CALL PLOT(X,Y,UP) ELSE CALL PLOT(X,Y,DOWN) ENDIF 10 CONTINUE C C ADD DIP SYMBOLS AT INTEGRATION POINTS 2, 4, AND 6. C DO 100 M=2,6,2 S=FPOINT(M) X0=PHIVAL(S,X1,X2,X3) Y0=PHIVAL(S,Y1,Y2,Y3) ARG=FTAN(M,I) DIP=PHIVAL(S,D1,D2,D3) FROMVE=ABS(1.570796-DIP) IF (FROMVE.LT.WEDGE) THEN C VERTICAL STRIKE-SLIP FAULT ELSE IF (FROMVE.LT.0.610865) THEN C NORMAL FAULT IF (DIP.LT.1.5708) THEN PARG=ARG-1.570796 ELSE PARG=ARG+1.570796 ENDIF PX=SIZE*COS(PARG) PY=SIZE*SIN(PARG) CALL PLOT(X0+PX,Y0+PY,UP) CALL PLOT(X0,Y0,DOWN) ELSE IF (FROMVE.LT.0.95993) THEN C INTERMEDIATE-DIP FAULT IF (DIP.LT.1.5708) THEN PARG=ARG-1.570796 ELSE PARG=ARG+1.570796 ENDIF PX=SIZE*COS(PARG) PY=SIZE*SIN(PARG) DX=0.5*SIZE*COS(ARG) DY=0.5*SIZE*SIN(ARG) CALL PLOT(X0+DX, Y0+DY ,UP ) CALL PLOT(X0+DX+PX,Y0+DY+PY,DOWN) CALL PLOT(X0-DX+PX,Y0-DY+PY,DOWN) CALL PLOT(X0-DX ,Y0-DY ,DOWN) ELSE C THRUST FAULT IF (DIP.LT.1.5708) THEN PARG=ARG-1.570796 ELSE PARG=ARG+1.570796 ENDIF PX=SIZE*COS(PARG) PY=SIZE*SIN(PARG) DX=0.3*SIZE*COS(ARG) DY=0.3*SIZE*SIN(ARG) CALL PLOT(X0+DX,Y0+DY,UP ) CALL PLOT(X0+PX,Y0+PY,DOWN) CALL PLOT(X0-DX,Y0-DY,DOWN) ENDIF 100 CONTINUE C RETURN END C C C SUBROUTINE MAGNIT (INPUT,NUMEL,OUTVEC, + OUTPUT,OUTSCA) C C CONVERT VECTOR TO SCALAR MAGNITUDE AT INTEGRATION POINTS C INCLUDES OPTION TO MAKE MAGNITUDES OF RIGHT-POINTING C VECTORS BE NEGATIVE, "UNDOING" THE EFFECT OF VPLOT ON C PRINCIPAL-AXIS "VECTORS". C DIMENSION OUTSCA(7,NUMEL),OUTVEC(2,7,NUMEL) DO 10 M=1,7 DO 9 I=1,NUMEL OUTSCA(M,I)=SQRT((1.D0*OUTVEC(1,M,I))**2+ + (1.D0*OUTVEC(2,M,I))**2) 9 CONTINUE 10 CONTINUE RETURN END C C C SUBROUTINE MAGNIN (INPUT,NUMNOD,V, + OUTPUT,ATNODE) C C CONVERT VECTOR TO SCALAR MAGNITUDE AT NODES C DOUBLE PRECISION V DIMENSION ATNODE(NUMNOD),V(2,NUMNOD) DO 10 I=1,NUMNOD ATNODE(I)=SQRT(V(1,I)**2+V(2,I)**2) 10 CONTINUE RETURN END C C C SUBROUTINE INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) C C COMPUTE CONTOUR INTERVAL ROUNDED TO NEAREST 1,2,3,4,5, X 10**P C LOGICAL MONOTO DIMENSION ATNODE(NUMNOD),OUTSCA(7,NUMEL) RLOW=9.9E59 RHI=-9.9E59 DO 20 M=1,7 DO 10 I=1,NUMEL RLOW=MIN(RLOW,OUTSCA(M,I)) RHI =MAX(RHI ,OUTSCA(M,I)) 10 CONTINUE 20 CONTINUE DO 30 I=1,NUMNOD RLOW=MIN(RLOW,ATNODE(I)) RHI =MAX(RHI ,ATNODE(I)) 30 CONTINUE SCALE=MAX(ABS(RHI-RLOW),ABS(RHI),ABS(RLOW)) IF (SCALE.EQ.0.) THEN DFCON=1.00 ELSE MONOTO=ABS(RHI-RLOW).LT.(0.01*SCALE) IF (MONOTO) THEN MCONTR=NCONTR/2 MCONTR=MAX(MCONTR,1) GUESS=SCALE/MCONTR IZERO=IUNDER(ALOG10(GUESS)) FACTOR=GUESS/10.**IZERO IFACTR=FACTOR+0.5 IFACTR=MIN(5,IFACTR) IF (FACTOR.GT.7.) IFACTR=10 DFCON=IFACTR*10.**IZERO ELSE GUESS=(RHI-RLOW)/NCONTR IZERO=IUNDER(ALOG10(GUESS)) FACTOR=GUESS/10.**IZERO IFACTR=FACTOR+0.5 IFACTR=MIN(5,IFACTR) IF (FACTOR.GT.7.) IFACTR=10 DFCON=IFACTR*10.**IZERO ENDIF ENDIF RETURN END C C C INTEGER FUNCTION IUNDER (X) C C RETURNS INTEGER .LE. X, UNLIKE INT FUNCTION C IUNDER=INT(X) IF (X.LT.(1.*IUNDER)) IUNDER=IUNDER-1 RETURN END C C C INTEGER FUNCTION IABOVE (X) C C RETURNS INTEGER .GE. X, UNLIKE INT FUNCTION C IF (X.LE.0.) THEN IABOVE=INT(X) ELSE IABOVE=INT(X) IF (X.GT.IABOVE) IABOVE=IABOVE+1 ENDIF RETURN END C C C SUBROUTINE MAXER (INPUT,ERATE,NUMEL, + OUTPUT,OUTSCA) C C FINDS LARGEST (ABS. VALUE) LINEAR STRETCH RATE IN THE TENSOR ERATE C AND ASSIGNS ITS SCALAR VALUE TO OUTSCA C DIMENSION ERATE(3,7,NUMEL),OUTSCA(7,NUMEL) C 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) DIVER=EXX+EYY SHEAR=SQRT((1.D0*EXY)**2+0.25*(1.D0*EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR EZ= -DIVER BIGSHR=MAX(ABS(E1),ABS(E2),ABS(EZ)) OUTSCA(M,I)=BIGSHR 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE MAXSS (INPUT,NUMEL,TAUMAT,TAUZZI, + OUTPUT,OUTSCA) C C FINDS LARGEST (ABS. VALUE) SHEAR STRESS INTEGRAL IN TENSOR TAUMAT C AND ASSIGNS ITS SCALAR VALUE TO OUTSCA C DIMENSION TAUMAT(3,7,NUMEL),TAUZZI(7,NUMEL),OUTSCA(7,NUMEL) C DO 100 M=1,7 DO 90 I=1,NUMEL TXX=TAUMAT(1,M,I)+TAUZZI(M,I) TYY=TAUMAT(2,M,I)+TAUZZI(M,I) TXY=TAUMAT(3,M,I) SHEAR=SQRT((1.D0*TXY)**2+0.25*(1.D0*TXX-TYY)**2) CENTER=(TXX+TYY)/2. T1=CENTER-SHEAR T2=CENTER+SHEAR TZ=TAUZZI(M,I) BIGSHR=MAX(SHEAR,ABS(T2-TZ)/2.,ABS(T1-TZ)/2.) OUTSCA(M,I)=BIGSHR 90 CONTINUE 100 CONTINUE RETURN END C C C INTEGER FUNCTION IHUE (NCOLOR,CINT,FMIDLE,IFLIP,F) C C RETURNS ORDINAL NUMBER OF COLOR ASSOCIATED WITH FUNCTION VALUE 'F' C WHEN CONTOURED WITH INTERVAL 'CINT', AND WHEN VALUE 'FMIDLE' IS C ROUNDED TO A CONTOUR LEVEL IN THE CENTER OF THE SPECTRUM. C IF IFLIP=+1, BLUE GOES WITH LOW VALUES AND RED WITH HIGH; C IF IFLIP=-1, THE SPECTRUM IS REVERSED. C OUTPUT VALUE SHOULD BE USED AS INDEX IN "ICOLOR" TO SELECT CODE C NUMBER OF THE SHADING PATTERN APPLIED. C THAT IS, ARRAY "ICOLOR" CONTAINS THE SPECTRUM DEFINITION. C C FMP=IUNDER((FMIDLE/CINT)+0.5)*CINT STEPS=IFLIP*(F-FMP)/CINT IHUE=STEPS+(NCOLOR/2.)+1.0 IHUE=MAX(IHUE,1) IHUE=MIN(IHUE,NCOLOR) RETURN END C C C SUBROUTINE AREAS (INPUT,NODES,NUMEL,NUMNOD,XNODE,YNODE, 1 OUTPUT,AREA) C C COMPUTE AREAS OF ELEMENTS IN GRID AS IF THEY HAD STRAIGHT C SIDES. EFFECT OF SIDE CURVATURE WILL BE HANDLED LATER BY C MULTIPLYING BY DETERMINANT OF JACOBIAN MATRIX FOR THE SIDE- C BENDING MAPPING. NOTE THAT AREA MAY BE NEGATIVE, BUT ELEMENT C IS OK IF DETERMINANT IN DERIV IS ALSO NEGATIVE. C DIMENSION AREA(NUMEL),NODES(6,NUMEL),XNODE(NUMNOD),YNODE(NUMNOD) DO 100 I=1,NUMEL I1=NODES(1,I) I2=NODES(2,I) I3=NODES(3,I) AREA(I)= 0.5*(XNODE(I1)*YNODE(I2)-XNODE(I2)*YNODE(I1) + +XNODE(I2)*YNODE(I3)-XNODE(I3)*YNODE(I2) + +XNODE(I3)*YNODE(I1)-XNODE(I1)*YNODE(I3)) 100 CONTINUE RETURN END C C C REAL FUNCTION ATAN2F (Y,X) C C CORRECTS FOR PROBLEM OF TWO ZERO ARGUMENTS C IF ((Y.NE.0.).OR.(X.NE.0.)) THEN ATAN2F=ATAN2(Y,X) ELSE ATAN2F=0. ENDIF RETURN END C C C SUBROUTINE DERIV (INPUT,AREA,NODES,NUMEL,NUMNOD,XNODE,YNODE, + OUTPUT,DETJ,DXS,DYS) C C CALCULATES DXS AND DYS, THE X-DERIVITIVE AND Y-DERIVITIVE C OF EACH OF THE 6 NODAL FUNCTIONS OF A DEFORMED-TRIANGLE C FINITE ELEMENT, AT EACH OF THE 7 INTEGRATION POINTS IN C THAT ELEMENT. ALSO PROVIDES DETJ, THE DETERMINANT OF THE C JACOBIAN MATRIX FOR THE TRANSFORMATION IN WHICH INTERNAL C POINTS OF A TRIANGLE WITH STRAIGHT SIDES ARE MAPPED INTO C NEW LOCATIONS AS SIDES BEND (BUT CORNERS STAY FIXED). C DOUBLE PRECISION POINTS DIMENSION AREA(NUMEL),DETJ(7,NUMEL), + DXS(6,7,NUMEL),DYS(6,7,NUMEL), + NODES(6,NUMEL), + XNODE(NUMNOD),YNODE(NUMNOD) DIMENSION B(4),C(4),DN(6,2),POINTS(5,7),X(6),Y(6) COMMON /S1S2S3/ POINTS DO 500 I=1,NUMEL DO 100 J=1,6 NODE=NODES(J,I) X(J)=XNODE(NODE) Y(J)=YNODE(NODE) 100 CONTINUE B(1)=Y(2)-Y(3) B(2)=Y(3)-Y(1) B(3)=Y(1)-Y(2) B(4)=B(1) C(1)=X(3)-X(2) C(2)=X(1)-X(3) C(3)=X(2)-X(1) C(4)=C(1) AI2=1./(2.*AREA(I)) DO 400 M=1,7 DO 200 J=1,3 DN(J,1)=AI2*B(J)*(4.*POINTS(J,M)-1.) DN(J+3,1)=AI2*4.*(B(J)*POINTS(J+1,M) + +B(J+1)*POINTS(J,M)) DN(J,2)=AI2*C(J)*(4.*POINTS(J,M)-1.) DN(J+3,2)=AI2*4.*(C(J)*POINTS(J+1,M) + +C(J+1)*POINTS(J,M)) 200 CONTINUE AJ11=0. AJ12=0. AJ21=0. AJ22=0. DO 300 J=1,6 AJ11=AJ11+DN(J,1)*X(J) AJ12=AJ12+DN(J,1)*Y(J) AJ21=AJ21+DN(J,2)*X(J) AJ22=AJ22+DN(J,2)*Y(J) 300 CONTINUE DETJAC=AJ11*AJ22-AJ12*AJ21 DETJ(M,I)=DETJAC AJ11S=AJ11 AJ11=AJ22/DETJAC AJ12=-AJ12/DETJAC AJ21=-AJ21/DETJAC AJ22=AJ11S/DETJAC DO 350 J=1,6 DXS(J,M,I)=AJ11*DN(J,1)+AJ12*DN(J,2) DYS(J,M,I)=AJ21*DN(J,1)+AJ22*DN(J,2) 350 CONTINUE 400 CONTINUE 500 CONTINUE RETURN END C C C SUBROUTINE DIAMND (INPUT,ACREEP,ALPHAT,BCREEP, + BIOT,CCREEP,DCREEP, + ECREEP, + E1,E2,FRIC,G, + GEOTH1, + GEOTH2, + GEOTH3, + GEOTH4, + PL0,PW0, + RHOBAR,RHOH2O,SIGHBI, + THICK,TEMLIM, + VISMAX,ZOFTOP, + OUTPUT,PT1DE1,PT1DE2, + PT2DE1,PT2DE2, + PT1,PT2,ZTRAN) C C For one homogeneous layer (crust, OR mantle lithosphere), C computes the vertical integral through the layer of C horizontal principal stresses (relative to the vertical stress); C reports these as PT1 (more negative) and PT2 (more positive). C C Also reports ZTRAN, the depth into the layer of the brittle/ C ductile transition (greatest depth of earthquakes). C C Finally, recommends layer partial derivitives C PT1DE1, PT1DE2, PT2DE1, PT2DE2 C to be used in constructing ALPHA and TOFSET (in VISCOS), C according to strategy in pages 3973-3977 of Bird (1989). C In computing these, as in computing PT1 and PT2, the viscosity C limit VISMAX is applied to the average behavior of the whole C frictional layer, and again to the average behavior of the C whole creeping layer; it is not applied locally at each depth. C C Necessary conditions when calling DIAMND: C -> horizontal principal strain-rates E1 and E2 not both zero; C -> E2 >= E1; C -> layer thickness THICK is positive. C C Note special kludge: if friction FRIC is >2., then this is C taken to be a signal that no frictional layer is desired, C and that the whole layer should be power-law (or plastic, or C viscous-- whichever gives the least shear stress). C C New version, May 5, 1998, by Peter Bird; intended to improve C the convergence behavior of all F-E programs which use it. C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C External variables (*** all are scalars, even though C these same names may be arrays in other programs! ***): INTEGER INPUT REAL ACREEP, ALPHAT, BCREEP, BIOT, CCREEP, DCREEP, + ECREEP, E1, E2, FRIC, G, + GEOTH1, GEOTH2, GEOTH3, GEOTH4, + OUTPUT, PL0, PW0, + PT1, PT2, PT1DE1, PT1DE2, PT2DE1, PT2DE2, + RHOBAR, RHOH2O, SIGHBI, + THICK, TEMLIM, VISMAX, ZOFTOP, ZTRAN C External function: REAL ATAN2F C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C Internal variables: INTEGER N, NVSTEP DOUBLE PRECISION SECINV REAL ANGAT2, ANGAT3, ANGLE, + DELNEG, DELPOS, DSFDEV, + DS1DE1, DS1DE2, DS2DE1, DS2DE2, + DT1DE1, DT1DE2, DT2DE1, DT2DE2, DZ, + E1AT1, E1AT2, E1AT3, E1AT4, + E2AT1, E2AT2, E2AT3, E2AT4, + ESCRIT, EZ, + FRAC, + GAMMA, GREAT, + PH2O, + R, RHOUSE, + SIGMA1, SIGMA2, S1EFF, S2EFF, S1REL, S2REL, + SC0, SCH, SC1, SF0, SFH, SF1, STFRIC, SZ, SZEFF, + TAU1, TAU2, TECN, TECS, TECT, TMEAN, TSFN, TSFS, TSFT, + T, T0, TH, T1, + VIS, VISDCR, VISINF, VISINT, VISMIN, VISSHB, + Z, Z0, ZH, Z1 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C C CHARACTERIZE THE STRAIN-RATE TENSOR: EZ= -(E1+E2) C (Formula for vertical strain-rate EZ comes from the C incompressibility of all permanent, anelastic strain types.) SECINV= -((1.D0*E1)*E2 + (1.D0*E1)*EZ + (1.D0*E2)*EZ) C (One possible form for the second invariant of the matrix.) C Note that the double-precision is just to prevent underflows C from squaring small strain rates, not for precision. VISINF=0.5*ACREEP*(2.*SQRT(SECINV))**(ECREEP-1.) C VISINF is the viscosity for dislocation creep, lacking only C the exponential term; therefore, as a mathematical abstraction, C we can say that it is the viscosity at infinite temperature. C C CHARACTERIZE THE CONTINUUM FRICTION: C STFRIC=SIN(ATAN(FRIC)) GAMMA=(1+STFRIC)/(1-STFRIC) C Note: For thrusting, effective-sigma1h is effective-sigma1z C times GAMMA. For normal faulting, effective-sigma2h C is effective-sigmaz/GAMMA. For small FRIC, GAMMA C is approximately equal to 1.+2.*FRIC C C FIND THE BRITTLE/DUCTILE TRANSITION (ZTRAN, measured from C the top of the layer): C C In the thrusting quadrant (E1<0, E2<0) and in the normal- C faulting quadrant (E1>0, E2>0) the brittle/ductile transtion C is clear: it the greatest depth of frictional behavior C (possibly including earthquakes) on any fault, which is also C the greatest depth of frictional behavior on the most active C fault set. C C However, in the strike-slip quadrant (E1<0, E2>0) the C transition is less clear. I do not know of any empirical C field study which has determined how the transition depth C depends on (E1+E2) within the transtensional and transpressional C wedges of the strain-rate field. Therefore, we have to choose C some simple rule. The rule that the transition is at the C greatest depth of frictional behavior on any fault would C create two discontinuities (at the E1=0 line, where normal C faulting appears/dissapears; and at the E2=0 line, where C strike-slip faulting appears/dissapears). Furthermore, the C transition depth near to these lines (on the deeper side) would C be defined by the less-active fault set, which asymptotically C becomes totally inactive as the line is approached! If we C chose the alternate rule of taking the deepest frictional C behavior on the most active fault set, we would still have C two discontinuities, although at different places, both within C the strike-slip quadrant. My F-E programs cannot converge well C when there is any discontinuity; therefore, I have chosen an C arbitrary rule which smooths the transition depth across each C of the transpressional and transtensional wedges, giving the C correct (unambiguous) depths on the lines E1=0, E1=-E2, and C E2=0. In order to do this, I apply SIN(2*theta) smoothing to C both the frictional parameter DSFDEV and also to the creep C parameter ESCRIT, and then compute the transition depth from C the combination of values. (I do this instead of smoothing C the depth itself because I have no formula for the transition C depth on any of these three lines, and would have to locate C it by additional numerical searches.) C C ESCRIT is the shear strain rate (tensor type, = C 0.5*(larger principal rate - smaller principal rate) C of the shear system which defines the transition C from the creep side (from below); C DSFDEV is the partial derivitive of the maximum shear C stress (on any plane) in the frictional domain C with respect to effective vertical stress C (vertical stress plus BIOT times water pressure). C IF (E1.GE.0.) THEN IF (E2.GE.0.) THEN C Normal-normal; faster E2 dominates. ESCRIT=0.5*(E2-EZ) DSFDEV=0.5*(1.-1./GAMMA) ELSE C (E1 >=0, E2 < 0) C E2 < E1? Should not happen! WRITE(*,"(/' Error: E1:',1P,E10.2,' > E2:', + E10.2)") E1,E2 STOP 'DIAMND detected incorrect INPUTs.' END IF ELSE C (E1 < 0) IF (E2.GE.0.) THEN C (E1 < 0, E2 >= 0) IF (EZ.GE.0.) THEN C Transpression (T/S). C Enforce smooth transition in DSFDEV C as the pure strike-slip line is approached. C (This smoothing cannot be with VISMAX because C ZTRAN is not yet known; instead, use a smooth C function of angle from origin of the C strain-rate plane, varying over 45 degrees C from the pure-strike-slip line E1=-E2 C to the pure-thrust line E2=0.) TSFT=0.5*(GAMMA-1.) TSFS=STFRIC C Note: One might expect TSFS=FRIC, but check on C a Mohr-circle diagram, remembering that the C pure strike-slip condition is EZ==0 -> C SZZEFF=0.5*(S1EFF+S2EFF). C Also remember that the "SF" in DSFDEV is not the C shear stress on the fault, but the maximum shear C stress, because this is what creep will attack and C lower first, at the brittle/ductile transition. ANGLE=ATAN2F(E2,E1) DSFDEV=TSFS+(TSFT-TSFS)*SIN(2.*(ANGLE-2.3561945)) C R=SQRT((1.D0*E1)**2+(1.D0*E2)**2) TECT=1. TECS=0.7071067 ESCRIT=R* + (TECS+(TECT-TECS)*SIN(2.*(ANGLE-2.3561945))) ELSE C (E1 < 0, E2 >= 0, EZ < 0) C Transtension (N/S). C Enforce smooth transition in DSFDEV C as the pure strike-slip line is approached. C (This smoothing cannot be with VISMAX because C ZTRAN is not yet known; instead, use a smooth C function of angle from origin of the C strain-rate plane, varying over 45 degrees C from the pure-strike-slip line E1=-E2 to the C pure-normal faulting line E1=0.) TSFN=0.5*(1.-1./GAMMA) TSFS=STFRIC C Note: One might expect TSFS=FRIC, but check on C a Mohr-circle diagram, remembering that the C pure strike-slip condition is EZ==0 -> C SZZEFF=0.5*(S1EFF+S2EFF). C Also remember that the "SF" in DSFDEV is not the C shear stress on the fault, but the maximum shear C stress, because this is what creep will attack and C lower first, at the brittle/ductile transition. ANGLE=ATAN2F(E2,E1) DSFDEV=TSFS+(TSFN-TSFS)*SIN(2.*(2.3561945-ANGLE)) C R=SQRT((1.D0*E1)**2+(1.D0*E2)**2) TECN=1. TECS=0.7071067 ESCRIT=R* + (TECS+(TECN-TECS)*SIN(2.*(2.3561945-ANGLE))) END IF ELSE C (E1 < 0, E2 < 0) C Thrust-thrust; faster (more negative) E1 dominates. ESCRIT=0.5*(EZ-E1) DSFDEV=0.5*(GAMMA-1.) END IF END IF C C Use ESCRIT and DSFDEV to locate ZTRAN (brittle/ductile trans.): C IF (FRIC.GT.2.) THEN C Special kludge; no frictional layer is wanted C (for models with a purely power-law or linear-viscous C rheology, you specify an unrealistically high friction. C This makes the transition occur at the surface, and C below the surface, the friction value is irrelevant.) ZTRAN=0. ELSE C Normal case; compute friction and creep at top and bottom: C Z0=0. SF0=DSFDEV*(PL0-BIOT*PW0) T0=MIN(TEMLIM,GEOTH1) SC0=2.*VISINF*EXP((BCREEP+CCREEP*ZOFTOP)/T0)*ESCRIT SC0=MIN(SC0,DCREEP) C Z1=THICK TMEAN=GEOTH1+ + 0.5*GEOTH2*Z1+ + 0.333*GEOTH3*Z1**2+ + 0.25*GEOTH4*Z1**3 RHOUSE=RHOBAR*(1.-ALPHAT*TMEAN) SF1=SF0+DSFDEV*(RHOUSE-BIOT*RHOH2O)*G*THICK T1=MIN(TEMLIM,GEOTH1+GEOTH2*Z1+GEOTH3*Z1**2+GEOTH4*Z1**3) SC1=2.*VISINF*EXP((BCREEP+CCREEP*(ZOFTOP+Z1))/T1)*ESCRIT SC1=MIN(SC1,DCREEP) SC1=MAX(SC1,SIGHBI) C C Check if whole layer is frictional: IF (SC1.GE.SF1) THEN ZTRAN=THICK C C Check if none of layer is frictional: ELSE IF (SC0.LE.SF0) THEN ZTRAN=0. C ELSE C Transition is within layer, between Z0 and Z1. C Use a binary-division search to bracket within C the nearest 1/128 of the layer (usually, within C 0.5 km); then, finish with linear interpolation. C Note ASSUMPTION: T increases montonically with z!!! C Also note that linearity may fail if the C power-law/DCREEP-limit transition falls into the C remaining interval; however, the error will be small. DO 100 N=1,7 ZH=0.5*(Z0+Z1) TMEAN=0.5*(T0+T1) RHOUSE=RHOBAR*(1.-ALPHAT*TMEAN) SFH=SF0+DSFDEV*(RHOUSE-BIOT*RHOH2O)*G*(ZH-Z0) TH=MIN(TEMLIM,GEOTH1+GEOTH2*ZH+GEOTH3*ZH**2+ + GEOTH4*ZH**3) SCH=2.*VISINF*EXP((BCREEP+CCREEP*(ZOFTOP+ZH))/TH) + *ESCRIT SCH=MIN(SCH,DCREEP) SCH=MAX(SCH,SIGHBI) IF (SCH.GT.SFH) THEN C Transition is between ZH and Z1. Z0=ZH SF0=SFH T0=TH SC0=SCH ELSE C Transition is between Z0 and ZH. Z1=ZH SF1=SFH T1=TH SC1=SCH END IF 100 CONTINUE DELNEG=SF0-SC0 DELPOS=SF1-SC1 FRAC= -DELNEG/(DELPOS-DELNEG) IF ((FRAC.LT.-0.01).OR.(FRAC.GT.1.01)) THEN WRITE(*,"(' WARNING: Failure to bracket ZTRAN', + ' within DIAMND')") END IF FRAC=MIN(1.,MAX(0.,FRAC)) ZTRAN=Z0+FRAC*(Z1-Z0) END IF END IF C C SUM TAU (AND DERIVITIVES) OVER FRICTIONAL AND CREEP LAYERS: C C Initialize sums over (up to) two layers: C -brittle layer at <= ZTRAN from the top; C -creeping layer at > ZTRAN from the top. PT1=0. PT2=0. PT1DE1=0. PT1DE2=0. PT2DE1=0. PT2DE2=0. C C COMPUTE AND ADD STRENGTH OF FRICTIONAL PART OF LAYER: C IF (ZTRAN.GT.0.) THEN C Compute the effective vertical stress at the midpoint C of the frictional layer: TMEAN=GEOTH1+ + 0.5*GEOTH2*(ZTRAN/2.)+ + 0.333*GEOTH3*(ZTRAN/2.)**2+ + 0.25*GEOTH4*(ZTRAN/2.)**3 RHOUSE=RHOBAR*(1.-ALPHAT*TMEAN) SZ= -PL0-RHOUSE*G*ZTRAN/2. PH2O=PW0+RHOH2O*G*ZTRAN/2. SZEFF=SZ+BIOT*PH2O C C Compute effective horizontal principal stresses, C and their derivitives with respect to E1 and E2, C at the midpoint of the frictional layer, according C to the methods in Bird (1989), pages 3973-3977 C (except, correcting the typos in the caption for C Figure 4): C C Define the corner points of the diamond in the C ordered principal strain-rate plane: E1AT1=((1./GAMMA)-1.)*SZEFF/(6.*VISMAX) E2AT1=E1AT1 E1AT2=(1.-(1./GAMMA))*SZEFF/(6.*VISMAX) E2AT2=((2./GAMMA)-2.)*SZEFF/(6.*VISMAX) E1AT3=(2.*GAMMA-2.)*SZEFF/(6.*VISMAX) E2AT3=(1.-GAMMA)*SZEFF/(6.*VISMAX) E1AT4=(GAMMA-1.)*SZEFF/(6.*VISMAX) E2AT4=E1AT4 ANGAT2=ATAN2F((E2-E2AT2),(E1-E1AT2)) ANGAT3=ATAN2F((E2-E2AT3),(E1-E1AT3)) C C Select proper segment of diagram and assign effective C principal stresses. C Also, begin definition of strategic stiffnesses C DS1DE1, DS1DE2, DS2DE1, and DS2DE2, by computing C stiffness required to give warning of local cliffs. C Afterward, basic minimum stiffness required to avoid C singularity of stiffness matrix will be imposed with C a formula common to all regions. IF (E1.GT.E1AT1) THEN C Region N/N: two conjugate sets of normal faults S1EFF=SZEFF/GAMMA S2EFF=S1EFF C DS1DE1=(0.5*((1/GAMMA)-1.)*SZEFF)/E1 DS1DE2=0. DS2DE1=0. DS2DE2=(0.5*((1/GAMMA)-1.)*SZEFF)/E2 ELSE IF ((E1.GE.E1AT2).AND. + (ANGAT2.GT.ATAN2F((E2AT1-E2AT2),(E1AT1-E1AT2)))) THEN C Region N: single conjugate set of normal faults S2EFF=SZEFF/GAMMA FRAC=(E1-E1AT1)/(E1AT2-E1AT1) C fraction increases in -E1 direction, from point 1 -> 2 S1EFF=SZEFF*((1/GAMMA)+FRAC*(1.-(1./GAMMA))) C DS1DE1=4.*VISMAX DS1DE2=0. DS2DE1=0. DS2DE2=0. ELSE IF ((ANGAT2.LE.1.9635).AND.(ANGAT2.GE.1.5707)) THEN C Region N/S: transtension, dominantly normal. S1EFF=SZEFF S2EFF=SZEFF/GAMMA C DS1DE1=(0.5*((1.-1/GAMMA))*SZEFF)/E1 DS1DE2=0. DS2DE1=0. DS2DE2=0. ELSE IF ((ANGAT2.LE.2.3562).AND.(ANGAT2.GE.1.9635)) THEN C Region S/N: transtension, dominantly strike-slip. S1EFF=SZEFF S2EFF=SZEFF/GAMMA C C GREAT is the value of DS1DE1 in region S: GREAT=6.*VISMAX*(GAMMA-1.)/(GAMMA-(1./GAMMA)) C FRAC is also defined exactly as in S, so here it C will be negative: FRAC=((E1+E2)-(E1AT2+E2AT2))/ + ((E1AT3+E2AT3)-(E1AT2+E2AT2)) C Reduce all derivitives according to distance: GREAT=GREAT*(-0.5)/(FRAC-0.5) C Pattern of derivitives is the same as in S: DS1DE1=GREAT DS1DE2=DS1DE1 DS2DE1=DS1DE1/GAMMA DS2DE2=DS2DE1 ELSE IF ((ANGAT3.LE.2.3562).AND. + (ANGAT3.GE.ATAN2F((E2AT2-E2AT3),(E1AT2-E1AT3)))) THEN C Region S: single set of conjugate strike-slip faults FRAC=((E1+E2)-(E1AT2+E2AT2))/ + ((E1AT3+E2AT3)-(E1AT2+E2AT2)) C FRAC increases across band from the S/N (point 2) side C toward the S/T (point 3) side; contours of FRAC are C parallel to the band sides, not normal to the diamond. S1EFF=SZEFF*(1.+FRAC*(GAMMA-1.)) S2EFF=SZEFF*((1./GAMMA)+FRAC*(1.-(1./GAMMA))) C Notes: The equation of this line is S2EFF=S1EFF/GAMMA. C I used algebra to check (98.4.21) that the C pure strike-slip stress (S1EFF,S2EFF)= C SZZEFF*(1.+STFRIC,1.-STFRIC) correctly falls on C this line, at the correct point (E1= -E2). C DS1DE1=6.*VISMAX*(GAMMA-1.)/(GAMMA-(1./GAMMA)) DS1DE2=DS1DE1 DS2DE1=DS1DE1/GAMMA DS2DE2=DS2DE1 ELSE IF ((ANGAT3.LE.2.7489).AND.(ANGAT3.GE.2.3562)) THEN C Region S/T: transpression; strike-slip dominant. S1EFF=SZEFF*GAMMA S2EFF=SZEFF C C GREAT is the value of DS1DE1 in region S: GREAT=6.*VISMAX*(GAMMA-1.)/(GAMMA-(1./GAMMA)) C FRAC is also defined exactly as in S, so here it C will be greater than one: FRAC=((E1+E2)-(E1AT2+E2AT2))/ + ((E1AT3+E2AT3)-(E1AT2+E2AT2)) C Reduce all derivitives according to distance: GREAT=GREAT*(0.5)/(FRAC-0.5) C Pattern of derivitives is the same as in S: DS1DE1=GREAT DS1DE2=DS1DE1 DS2DE1=DS1DE1/GAMMA DS2DE2=DS2DE1 ELSE IF ((E2.GE.E2AT3).AND.(ANGAT3.GE.2.7489)) THEN C Region T/S: transpression; thrusting dominant. S1EFF=SZEFF*GAMMA S2EFF=SZEFF C DS1DE1=0. DS1DE2=0. DS2DE1=0. DS2DE2=(0.5*(1.-GAMMA)*SZEFF)/E2 ELSE IF ((E2.GE.E2AT4).AND. + (ANGAT3.LE.ATAN2F((E2AT4-E2AT3),(E1AT4-E1AT3)))) THEN C Region T: single conjugate thrust fault set. S1EFF=SZEFF*GAMMA FRAC=(E2-E2AT3)/(E2AT4-E2AT3) C FRAC increases in the -E2 direction across the band. S2EFF=SZEFF*(1.+FRAC*(GAMMA-1.)) C DS1DE1=0. DS1DE2=0. DS2DE1=0. DS2DE2=4.*VISMAX ELSE IF (E2.LE.E2AT4) THEN C Region T/T: Two set of conjugate thrust faults. S1EFF=SZEFF*GAMMA S2EFF=S1EFF C DS1DE1=(0.5*(GAMMA-1.)*SZEFF)/E1 DS1DE2=0. DS2DE1=0. DS2DE2=(0.5*(GAMMA-1.)*SZEFF)/E2 ELSE C Region V: linear viscosity C Note that equations are now for SIGMA1,2 and no C longer for S1EFF and S2EFF. However, we can C easily compute both: SIGMA1=SZ+VISMAX*(4.*E1+2.*E2) SIGMA2=SZ+VISMAX*(2.*E1+4.*E2) S1EFF=SIGMA1+BIOT*PH2O S2EFF=SIGMA2+BIOT*PH2O C DS1DE1=0. DS1DE2=0. DS2DE1=0. DS2DE2=0. END IF C C Regardless of region, be sure that stiffnesses do C not fall below those which represent a minimum C effective viscosity-- one based on the weakest of C the active fault sets. This is to guaruntee that C the linear system will not have any zero eigenvalues, C even if a creeping layer does not exist. VISMIN=VISMAX IF ((E1.LT.0.).AND.(E2.GT.0.)) THEN C strike-slip faults are active VISMIN=MIN(VISMIN,0.5*(S2EFF-S1EFF)/(E2-E1)) END IF IF ((E1.LT.0.).AND.(EZ.GT.0.)) THEN C thrust faults are active VISMIN=MIN(VISMIN,0.5*(SZEFF-S1EFF)/(EZ-E1)) END IF IF ((E2.GT.0.).AND.(EZ.LT.0.)) THEN C normal faults are active VISMIN=MIN(VISMIN,0.5*(S2EFF-SZEFF)/(E2-EZ)) END IF DS1DE1=DS1DE1+4.*VISMIN DS1DE2=DS1DE2+2.*VISMIN DS2DE1=DS2DE1+2.*VISMIN DS2DE2=DS2DE2+4.*VISMIN C C Convert effective principal stresses at the midpoint C of the frictional layer into total principal stresses: SIGMA1=S1EFF-BIOT*PH2O SIGMA2=S2EFF-BIOT*PH2O C (Note that correcting S1 and S2 by a constant does not C affect the values of the derivitives DS1DE1...DS2DE2.) C C Convert total principal stresses at the midpoint of C the frictional layer into relative principal stresses C (relative to the total vertical stress, that is): S1REL=SIGMA1-SZ S2REL=SIGMA2-SZ C (Note that correcting S1 and S2 by a constant does not C affect the values of the derivitives DS1DE1...DS2DE2.) C C Convert values at midpoint of frictional layer to C integrals over the frictional layer: TAU1=S1REL*ZTRAN TAU2=S2REL*ZTRAN DT1DE1=DS1DE1*ZTRAN DT1DE2=DS1DE2*ZTRAN DT2DE1=DS2DE1*ZTRAN DT2DE2=DS2DE2*ZTRAN C C Add integrals over frictional layer to layer totals: PT1=PT1+TAU1 PT2=PT2+TAU2 PT1DE1=PT1DE1+DT1DE1 PT1DE2=PT1DE2+DT1DE2 PT2DE1=PT2DE1+DT2DE1 PT2DE2=PT2DE2+DT2DE2 END IF C (IF the frictional layer thickness ZTRAN > 0) C C COMPUTE AND ADD STRENGTH OF CREEPING PART OF LAYER: C IF (ZTRAN.LT.THICK) THEN C C Precompute the maximum viscosity limit imposed by the C requirement that creep shear stress never exceeds C DCREEP on any plane: VISDCR=DCREEP/(MAX(E1,E2,EZ)-MIN(E1,E2,EZ)) C C Precompute the lower viscosity limit imposed by the C requirement that creep shear stress does not C fall below SIGHBI: VISSHB=SIGHBI/(MAX(E1,E2,EZ)-MIN(E1,E2,EZ)) C C Compute the vertical integral of viscosity, C observing the local limit VISDCR, and terminating C the integral if creep shear stress falls below C SIGHBI (because then we are in a horizontally- C sheared boundary layer which does not contribute C anything to plate strength): C NVSTEP=50 DZ=(THICK-ZTRAN)/NVSTEP C VISINT=0. DO 200 N=0,NVSTEP Z=ZTRAN+N*DZ C Note that Z is measured from top of layer C (surface, or Moho) and may not be absolute depth. T=GEOTH1+GEOTH2*Z+GEOTH3*Z**2+GEOTH4*Z**3 T=MIN(T,TEMLIM) VIS=VISINF*EXP((BCREEP+CCREEP*(ZOFTOP+Z))/T) VIS=MIN(VIS,VISDCR) IF ((N.EQ.0).OR.(N.EQ.NVSTEP)) THEN FRAC=0.5 ELSE FRAC=1. END IF IF (VIS.LT.VISSHB) GO TO 201 VISINT=VISINT+FRAC*VIS*DZ 200 CONTINUE 201 CONTINUE C C Limit the mean viscosity of the creeping layer to C be no more than VISMAX: VISINT=MIN(VISINT,VISMAX*(THICK-ZTRAN)) C TAU1=4.*VISINT*E1+2.*VISINT*E2 TAU2=2.*VISINT*E1+4.*VISINT*E2 C Note that these principal values of TAU (the two C horizontal principal values, contributed by the C creeping layer only) are relative to TAUZZ, which C is the vertical integral of the vertical stress C anomaly through the creeping layer. C DT1DE1=4.*VISINT DT1DE2=2.*VISINT DT2DE1=2.*VISINT DT2DE2=4.*VISINT C C Add integrals over creeping layer to layer totals: PT1=PT1+TAU1 PT2=PT2+TAU2 PT1DE1=PT1DE1+DT1DE1 PT1DE2=PT1DE2+DT1DE2 PT2DE1=PT2DE1+DT2DE1 PT2DE2=PT2DE2+DT2DE2 END IF C (IF the creeping layer thickness (THICK-ZTRAN) > 0) C RETURN END C C C SUBROUTINE EDOT (INPUT,DXS,DYS,MXEL,MXNODE,NODES,NUMEL,V, + OUTPUT,ERATE) C C COMPUTE STRAIN-RATE COMPONENTS EDOTXX, EDOTYY, AND C EDOTXY (TENSOR FORM; EQUAL TO C (1/2) * ((DVX/DY)+(DVY/DX)) C AT THE INTEGRATION POINTS OF TRIANGULAR CONTINUUM ELEMENTS. C DOUBLE PRECISION V DIMENSION DXS(6,7,MXEL),DYS(6,7,MXEL), + ERATE(3,7,MXEL),NODES(6,MXEL), + V(2,MXNODE) C DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=0. EYY=0. EXY=0. DO 800 J=1,6 NODE=NODES(J,I) VX=V(1,NODE) VY=V(2,NODE) DX=DXS(J,M,I) DY=DYS(J,M,I) EXX=EXX+VX*DX EYY=EYY+VY*DY EXY=EXY+(VX*DY+VY*DX)*0.5 800 CONTINUE ERATE(1,M,I)=EXX ERATE(2,M,I)=EYY ERATE(3,M,I)=EXY 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE FILLIN (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,CFRIC,CONDUC,DQDTDA, + ECREEP,ELEV,ERATE,GMEAN,IFLOW,IUNITT, + MXEL,MXNODE,NODES,NUMEL,NUMNOD,ONEKM, + RADIO,RHOAST,RHOBAR,RHOH2O,TEMLIM, + TSURF,XNODE,YNODE,V,ZMNODE, + OUTPUT,GEOTH,GLUE,PULLED,SIGZZI,TAUZZI, + TAUZZN,VM,ZMOHO, + WORK,ATNODE) C C PRECOMPUTE AND INTERPOLATE ALL "CONVENIENCE ARRAYS": C LOGICAL RESIST LOGICAL PULLED DOUBLE PRECISION V,VM DOUBLE PRECISION PHI COMMON /PHITAB/ PHI DIMENSION PHI(6,7) DIMENSION ATNODE(MXNODE),DQDTDA(MXNODE),ELEV(MXNODE), + ERATE(3,7,MXEL),GEOTH(4,7,MXEL),GLUE(7,MXEL), + NODES(6,MXEL),PULLED(7,MXEL), + SIGZZI(7,MXEL),TAUZZI(7,MXEL),TAUZZN(MXNODE), + V(2,MXNODE),VM(2,MXNODE),XNODE(MXNODE),YNODE(MXNODE), + ZMNODE(MXNODE),ZMOHO(7,MXEL) C C GEOTHERM (STEADY-STATE): C GEOTH1=TSURF GEOTH3= -0.5*RADIO/CONDUC GEOTH4=0.0 DO 20 M=1,7 DO 10 I=1,NUMEL GEOTH(1,M,I)=GEOTH1 Q=DQDTDA(NODES(1,I))*PHI(1,M)+ + DQDTDA(NODES(2,I))*PHI(2,M)+ + DQDTDA(NODES(3,I))*PHI(3,M)+ + DQDTDA(NODES(4,I))*PHI(4,M)+ + DQDTDA(NODES(5,I))*PHI(5,M)+ + DQDTDA(NODES(6,I))*PHI(6,M) GEOTH(2,M,I)=Q/CONDUC GEOTH(3,M,I)=GEOTH3 GEOTH(4,M,I)=GEOTH4 10 CONTINUE 20 CONTINUE C C THICKNESS OF CRUST (DEPTH OF MOHO, RELATIVE TO SURFACE): C CALL INTERP (INPUT,ZMNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,ZMOHO) C C VERTICAL INTEGRALS OF VERTICAL STRESS ANOMALY C (RELATIVE TO A STANDARD PRESSURE CURVE, IN "SQUEEZ"): C DO 100 I=1,NUMNOD GEOTH2=DQDTDA(I)/CONDUC CALL SQUEEZ (INPUT,ALPHAT,ELEV(I),GEOTH1,GEOTH2, + GEOTH3,GEOTH4,GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, + TEMLIM,ZMNODE(I), + OUTPUT,TAUZZN(I),ATNODE(I)) 100 CONTINUE CALL INTERP (INPUT,ATNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,SIGZZI) CALL INTERP (INPUT,TAUZZN,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,TAUZZI) C C COMPUTE STRENGTH OF SHEARING LAYER IN DUCTILE LOWER CRUST: C CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP, + ECREEP,ERATE,CFRIC,GMEAN,GEOTH, + NODES,NUMEL,RHOH2O,RHOBAR, + TEMLIM,ZMOHO, + OUTPUT,GLUE) C C PRECOMPUTE VELOCITY OF THE TOP OF THE MANTLE C (AT NODES, SO THAT INTERPOLATION WILL BE IDENTICAL TO THAT C OCCURRING IN THE CRUSTAL LAYER). C DO 400 I=1,NUMNOD C (NOTE: V, VM ARE DOUBLE PRECISION; BUT MANTLE ISN'T. C THUS, IMPLICIT TYPE CONVERSIONS OCCUR BEFORE AND AFTER CALL.) TCX=V(1,I) TCY=V(2,I) CALL MANTLE (INPUT,IFLOW,TCX,TCY,XNODE(I),YNODE(I), + OUTPUT,RESIST,TMX,TMY) VM(1,I)=TMX VM(2,I)=TMY 400 CONTINUE C C NOW, DETERMINE FOR EACH INTEGRATION POINT WHETHER IT IS ACTUALLY C PULLED BY A STRONG UPPER MANTLE LITHOSPHERE C DO 500 M=1,7 DO 490 I=1,NUMEL X=XNODE(NODES(1,I))*PHI(1,M)+ + XNODE(NODES(2,I))*PHI(2,M)+ + XNODE(NODES(3,I))*PHI(3,M)+ + XNODE(NODES(4,I))*PHI(4,M)+ + XNODE(NODES(5,I))*PHI(5,M)+ + XNODE(NODES(6,I))*PHI(6,M) Y=YNODE(NODES(1,I))*PHI(1,M)+ + YNODE(NODES(2,I))*PHI(2,M)+ + YNODE(NODES(3,I))*PHI(3,M)+ + YNODE(NODES(4,I))*PHI(4,M)+ + YNODE(NODES(5,I))*PHI(5,M)+ + YNODE(NODES(6,I))*PHI(6,M) TCX=0. TCY=0. CALL MANTLE (INPUT,IFLOW,TCX,TCY,X,Y, + OUTPUT,RESIST,TMX,TMY) PULLED(M,I)=RESIST 490 CONTINUE 500 CONTINUE RETURN END C C C SUBROUTINE FLOW (INPUT,NODES,NUMEL,NUMNOD,V, + OUTPUT,OUTVEC) C C CALCULATES VELOCITY VECTORS AT INTEGRATION POINTS, FROM NODAL VALUES C DOUBLE PRECISION PHI,V DIMENSION NODES(6,NUMEL),OUTVEC(2,7,NUMEL), + PHI(6,7),V(2,NUMNOD) COMMON /PHITAB/ PHI DO 50 M=1,7 DO 40 I=1,NUMEL OUTVEC(1,M,I)=0. OUTVEC(2,M,I)=0. 40 CONTINUE 50 CONTINUE DO 100 J=1,6 DO 90 M=1,7 DO 80 I=1,NUMEL OUTVEC(1,M,I)=OUTVEC(1,M,I)+V(1,NODES(J,I)) + *PHI(J,M) OUTVEC(2,M,I)=OUTVEC(2,M,I)+V(2,NODES(J,I)) + *PHI(J,M) 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE GETNET (INPUT,IUNIT7,IUNIT8, + MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF,DQDTDA,ELEV,FAZ,FDIP, + NFAKEN,NFL,NODEF,NODES, + NREALN,NUMEL,NUMNOD,N1000,OFFMAX, + OFFSET,TITLE1,XNODE,YNODE,ZMNODE, + WORK,CHECKE,CHECKF,CHECKN) C C READ FINITE ELEMENT GRID FROM UNIT "IUNIT7". C ECHO THE IMPORTANT VALUES TO A PRINT DATASET ON UNIT "IUNIT8". C CHARACTER*80 TITLE1 LOGICAL ALLOK,BRIEF C LOGICAL CHECKE,CHECKF,CHECKN C DIMENSION CHECKE(MXEL),CHECKF(MXFEL),CHECKN(MXNODE), + DQDTDA(MXNODE),ELEV(MXNODE), + FAZ(2,MXFEL),FDIP(3,MXFEL), + NODEF(6,MXFEL),NODES(6,MXEL),OFFSET(MXFEL), + XNODE(MXNODE),YNODE(MXNODE),ZMNODE(MXNODE) DIMENSION DIPS(3),IFN(6) C**************************************************************** C THE FOLLOWING INTIALIZATIONS ARE NOT LOGICALLY NECESSARY, C BUT DUE TO BUGS IN THE VS-FORTRAN 2.4 COMPILER, THERE C WILL BE AN ERRONEOUS ERR0R MESSAGE IF THEY ARE NOT PERFORMED: AZ1=0. AZ3=0. C**************************************************************** C WRITE (IUNIT8,1) IUNIT7 1 FORMAT (' ATTEMPTING TO READ FINITE ELEMENT GRID FROM UNIT',I3) READ (IUNIT7,2) TITLE1 2 FORMAT (A80) WRITE (IUNIT8,3) TITLE1 3 FORMAT(/' TITLE OF FINITE ELEMENT GRID ='/' ',A80) C C READ NUMBER OF NODES, AND HOW MANY ARE "REAL" VERSUS "FAKE". C INPUT NODAL LOCATIONS (X,Y), ELEVATIONS, HEAT-FLOW, AND ISOSTATIC C GRAVITY ANOMALIES (ONE RECORD PER NODE). C (OPTION "BRIEF" SUPPRESSES MOST OUTPUT) C READ (IUNIT7,*) NUMNOD,NREALN,NFAKEN,N1000,BRIEF C IF (NUMNOD.NE.(NREALN+NFAKEN)) THEN WRITE (IUNIT8,5) 5 FORMAT (/' INCONSISTENT DATA:'/ + ' NUMBER OF NODES SHOULD EQUAL TOTAL OF REAL', + ' NODES AND FAKE NODES.') STOP ENDIF IF (NUMNOD.GT.MXNODE) THEN WRITE (IUNIT8,10) NUMNOD 10 FORMAT(/' INCREASE PARAMETER MAXNOD TO BE AT LEAST' + /' THE NUMBER OF NODES (',I6,') AND RECOMPILE.') STOP ENDIF N2=2*NUMNOD IF (NREALN.GT.N1000) THEN WRITE (IUNIT8,20) NREALN 20 FORMAT (/' INCREASE THE DATA VALUE N1000 TO BE GREATER' + /' OR EQUAL TO NREALN (',I6,') AND RECOMPILE.') STOP ENDIF C NBASE=N1000+1 NTOP=N1000+NFAKEN IF (BRIEF) THEN WRITE (IUNIT8,35) 35 FORMAT(/' (SINCE OPTION BRIEF=.TRUE., GRID WILL NOT BE ', + 'ECHOED HERE. BE CAREFUL!!!)') ELSE WRITE (IUNIT8,40) NUMNOD,NREALN,NREALN 40 FORMAT (/' THERE ARE',I5,' NODES IN THE GRID:'/ ' ',I5, + ' OF THESE ARE NUMBERED 1-',I4,' AND THESE REAL NODES', + ' HAVE TWO VELOCITY VARIABLES UNLESS CONSTRAINED.') IF (NFAKEN.GT.0) WRITE (IUNIT8,42) NFAKEN,NBASE,NTOP 42 FORMAT(' ',I5, + ' OF THESE ARE NUMBERED ',I6,'-',I6,' AND THESE ARE', + ' ARTIFICIAL;'/' THEIR VELOCITIES MUST BE', + ' COMPLETELY SPECIFIED.') WRITE (IUNIT8,49) 49 FORMAT(/ + ' (NOTE: X AND Y COORDINATES MAY BE ZERO FOR NODES WHICH' + ,' WILL BE AT MIDPOINTS OF ELEMENT SIDES AND/OR FAULTS.'/ + ' THE PROGRAM WILL INTERPOLATE VALUES FOR THESE.)') WRITE (IUNIT8,50) 50 FORMAT (/' ', + ' CRUSTAL'/ + ' NODE X Y ELEVATION ', + 'HEAT-FLOW THICKNESS'/) ENDIF DO 90 K=1,NUMNOD CHECKN(K)=.FALSE. 90 CONTINUE DO 100 K=1,NUMNOD READ (IUNIT7,*) INDEX,XI,YI,ELEVI,QI,ZMI C (NODES NEED NOT BE INPUT IN ORDER, BUT MUST ALL BE PRESENT.) IF (INDEX.LE.NREALN) THEN I=INDEX ELSE I=INDEX-N1000+NREALN ENDIF CHECKN(I)=.TRUE. ELEV(I)=ELEVI DQDTDA(I)=QI IF (QI.LT.0.) THEN WRITE (IUNIT8,91) 91 FORMAT (' NEGATIVE HEAT-FLOW IS NON-PHYSICAL.') STOP ENDIF XNODE(I)=XI YNODE(I)=YI IF (ZMI.LT.0.) THEN WRITE (IUNIT8,92) 92 FORMAT(' NEGATIVE CRUSTAL THICKNESS IS NON-PHYSICAL.') STOP ENDIF ZMNODE(I)=ZMI IF (.NOT.BRIEF) THEN WRITE (IUNIT8,95) INDEX,XI,YI,ELEVI,QI,ZMI 95 FORMAT (' ',I10,1P,2E11.3,3E10.2) ENDIF 100 CONTINUE ALLOK=.TRUE. DO 101 I=1,NUMNOD ALLOK=ALLOK.AND.CHECKN(I) 101 CONTINUE IF (.NOT.ALLOK) THEN WRITE (IUNIT8,102) 102 FORMAT(' THE FOLLOWING NODES WERE NEVER READ:') DO 104 I=1,NUMNOD IF (.NOT.CHECKN(I)) WRITE(IUNIT8,103)I 103 FORMAT (' ',36X,I6) 104 CONTINUE STOP ENDIF C C READ TRIANGULAR ELEMENTS C READ (IUNIT7,*) NUMEL IF (NUMEL.GT.MXEL) THEN WRITE (IUNIT8,108) NUMEL 108 FORMAT(/' INCREASE PARAMETER MAXEL TO BE AT LEAST EQUAL' + /' TO THE NUMBER OF ELEMENTS (',I6,') AND RECOMPILE.') STOP ENDIF DO 109 K=1,NUMEL CHECKE(K)=.FALSE. 109 CONTINUE IF (.NOT.BRIEF) WRITE (IUNIT8,110) NUMEL 110 FORMAT(/' THERE ARE ',I6,' TRIANGULAR CONTINUUM ELEMENTS.'/ + ' (NODE NUMBERS FOR EACH ARE GIVEN CORNERS-FIRST, COUNTER', + 'CLOCKWISE; THEN'/' MIDPOINTS, COUNTERCLOCKWISE, BEGINNING' + ,' WITH THE MIDPOINT BETWEEN CORNER #1 AND CORNER #2)'/ / + ' ELEMENT C1 C2 C3 M1 M2', + ' M3') DO 200 K=1,NUMEL C (ELEMENTS NEED NOT BE INPUT IN ORDER, BUT MUST ALL BE PRESENT.) READ (IUNIT7,*) I,(IFN(J),J=1,6) CHECKE(I)=.TRUE. IF (.NOT.BRIEF) WRITE (IUNIT8,120) I,(IFN(J),J=1,6) 120 FORMAT (' ',I6,':',6I10) DO 130 J=1,6 N=IFN(J) IF ((N.LE.0).OR.(N.GT.NTOP).OR. + ((N.GT.NREALN).AND.(N.LE.N1000))) THEN WRITE (IUNIT8,125) N 125 FORMAT (' NODE NUMBER ',I6,' IS ILLEGAL.') STOP ENDIF IF (N.GT.NREALN) N=N-N1000+NREALN NODES(J,I)=N 130 CONTINUE 200 CONTINUE ALLOK=.TRUE. DO 201 I=1,NUMEL ALLOK=ALLOK.AND.CHECKE(I) 201 CONTINUE IF (.NOT.ALLOK) THEN WRITE (IUNIT8,202) 202 FORMAT (' THE FOLLOWING ELEMENTS WERE NEVER READ:') DO 204 I=1,NUMEL IF (.NOT.CHECKE(I)) WRITE(IUNIT8,203)I 203 FORMAT (' ',39X,I6) 204 CONTINUE STOP ENDIF C C READ FAULT ELEMENTS C READ (IUNIT7,*) NFL IF (NFL.GT.MXFEL) THEN WRITE (IUNIT8,220)NFL 220 FORMAT (/' INCREASE PARAMETER MAXFEL TO BE AT LEAST EQUAL' + /' TO THE NUMBER OF FAULTS (',I6,') AND RECOMPILE.') STOP ENDIF OFFMAX=0. DO 222 I=1,NFL CHECKF(I)=.FALSE. 222 CONTINUE IF (.NOT.BRIEF) WRITE(IUNIT8,230) NFL 230 FORMAT(/ /' THERE ARE ',I6,' CURVILINEAR FAULT ELEMENTS.') IF ((.NOT.BRIEF).AND.(NFL.GT.0)) WRITE(IUNIT8,231) 231 FORMAT (/' (THE 6 NODE NUMBERS DEFINING EACH ELEMENT MUST BE', + ' IN A COUNTERCLOCKWISE ORDER:'/ + ' N1, N2, AND N3 ARE IN LEFT-TO-RIGHT SEQUENCE ON THE', + ' NEAR SIDE,'/ + ' THEN N4 IS OPPOSITE N3, N5 IS OPPOSITE N2, AND ', + 'N6 IS OPPOSITE N1.)'/' (FAULT DIPS ARE GIVEN AT N1, N2, ', + 'AND N3, IN DEGREES FROM HORIZONTAL;'/ + ' POSITIVE DIPS ARE TOWARD N1, N2, AND N3, RESPECTIVELY, '/ + ' WHILE NEGATIVE DIPS ARE TOWARD N6, N5, AND N4.)'/ + ' (THE ARGUMENT OF THE FAULT TRACE IS GIVEN AT N1 AND N3,'/ + ' IN DEGREES COUNTERCLOCKWISE FROM THE X AXIS.)'/ + ' OFFSET IS THE TOTAL PAST SLIP OF THE FAULT.'/ / + ' ELEMENT N1 N2 N3 N4 N5 N6 DIP1 DIP2 DIP3', + ' ARG1 ARG3 OFFSET'/) 240 FORMAT (' ',I6,':',6I5,1X,3F6.1,1X,2F5.0,F9.0) DO 300 K=1,NFL OFF=0. READ (IUNIT7,*,ERR=242) I,(IFN(J),J=1,6),(DIPS(L),L=1,3), + AZ1,AZ3,OFF 242 CHECKF(I)=.TRUE. IF (.NOT.BRIEF) WRITE (IUNIT8,240) I,(IFN(J),J=1,6), + (DIPS(L),L=1,3),AZ1,AZ3,OFF DO 250 J=1,6 N=IFN(J) IF ((N.LE.0).OR.(N.GT.NTOP).OR. + ((N.GT.NREALN).AND.(N.LE.N1000))) THEN WRITE (IUNIT8,125) N STOP ENDIF IF (N.GT.NREALN) N=N-N1000+NREALN NODEF(J,I)=N 250 CONTINUE DO 260 L=1,3 IF (ABS(DIPS(L)).GT.90.) THEN WRITE(IUNIT8,252) DIPS(L) 252 FORMAT(' ILLEGAL DIP OF ',F10.4,'; SHOULD BE IN', + ' RANGE OF -90. TO +90. DEGREES.'/ + ' (NOTE: ALL DIPS ARE IN DEGREES FROM THE', + ' HORIZONAL;'/ + ' A + PREFIX (OR NONE) INDICATES A DIP', + ' TOWARD THE N1-N2-N3 SIDE;'/ + ' A - PREFIX INDICATES A DIP TOWARD', + ' THE N6-N5-N4 SIDE.)') STOP ENDIF IF (DIPS(L).LT.0.) DIPS(L)=180.+DIPS(L) FDIP(L,I)=DIPS(L)*0.017453293 260 CONTINUE IF ((ABS(AZ1).GT.361.).OR.(ABS(AZ3).GT.361.)) THEN WRITE (IUNIT8,272) AZ1,AZ3 272 FORMAT (' ILLEGAL ARGUMENT OF ',F10.4,' OR ',F10.4, + '; SHOULD BE IN RANGE -360. TO +360. DEGREES.') STOP ENDIF FAZ(1,I)=AZ1*0.017453293 FAZ(2,I)=AZ3*0.017453293 IF (OFF.LT.0.) THEN WRITE (IUNIT8,280) OFF 280 FORMAT (' ILLEGAL FAULT OFFSET OF ',1P,E10.2, + ' FOR FAULT ELEMENT',I6/ + ' OFFSETS MAY NOT BE NEGATIVE.') STOP ENDIF OFFSET(I)=OFF OFFMAX=MAX(OFFMAX,OFF) 300 CONTINUE ALLOK=.TRUE. DO 301 I=1,NFL ALLOK=ALLOK.AND.CHECKF(I) 301 CONTINUE IF (.NOT.ALLOK) THEN WRITE(IUNIT8,302) 302 FORMAT(' THE FOLLOWING FAULTS WERE NEVER READ:') DO 304 I=1,NFL IF (.NOT.CHECKF(I)) WRITE(IUNIT8,303)I 303 FORMAT(' ',36X,I6) 304 CONTINUE STOP ELSE IF (OFFMAX.GT.0.) THEN WRITE (IUNIT8,400) OFFMAX 400 FORMAT (/' GREATEST FAULT OFFSET READ WAS ',1P,E10.2) ELSE WRITE (IUNIT8,401) 401 FORMAT (/' SINCE FAULT OFFSETS ARE ALL ZERO,', + ' INPUT PARAMETER BYERLY WILL HAVE NO EFFECT.') ENDIF ENDIF IF (.NOT. BRIEF) WRITE (IUNIT8,999) 999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE LOOKUP (INPUT,DETJ,IUNITT,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES,NUMEL, + X,XNODE,Y,YNODE, + MODIFY,IE,S1,S2,S3, + OUTPUT,ATSEA) C C FINDS ELEMENT AND INTERNAL COORDINATES IN GRID MATCHING LOCATION C OF A PARTICULAR POINT (X,Y) AND REPORTS THEM AS IE AND S1,S2,S3. C C A RETURNED VALUE OF ATSEA INDICATES THAT POINT FELL OFF EDGE C OF THE GRID. C PARAMETER (NTOTRY=50) LOGICAL ATSEA,ISTRAP,TRUBBL REAL M11,M12,M13,M21,M22,M23 DIMENSION DETJ(7,MXEL), + NODEF(6,MXFEL),NODES(6,MXEL), + XNODE(MXNODE),YNODE(MXNODE) DIMENSION IEHIST(NTOTRY),SHIST(3,NTOTRY) C C STATEMENT FUNCTION: C PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) C C NTRIED=0 C C LOOP AS MANY TIMES AS NEEDED: C 100 NTRIED=NTRIED+1 IEHIST(NTRIED)=IE TRUBBL=(NTRIED.GE.(NTOTRY-10)).AND.(IEHIST(NTRIED).EQ. + IEHIST(NTRIED-2)) IF (TRUBBL) THEN ATSEA=.TRUE. RETURN ENDIF I1=NODES(1,IE) I2=NODES(2,IE) I3=NODES(3,IE) I4=NODES(4,IE) I5=NODES(5,IE) I6=NODES(6,IE) X1=XNODE(I1) X2=XNODE(I2) X3=XNODE(I3) Y1=YNODE(I1) Y2=YNODE(I2) Y3=YNODE(I3) ISTRAP=(DETJ(1,IE).LE.0.2).OR. + (DETJ(2,IE).LE.0.2).OR. + (DETJ(3,IE).LE.0.2).OR. + (DETJ(4,IE).LE.0.2).OR. + (DETJ(5,IE).LE.0.2).OR. + (DETJ(6,IE).LE.0.2).OR. + (DETJ(7,IE).LE.0.2) IF (ISTRAP) THEN X4=0.5*(X1+X2) X5=0.5*(X2+X3) X6=0.5*(X3+X1) Y4=0.5*(Y1+Y2) Y5=0.5*(Y2+Y3) Y6=0.5*(Y3+Y1) ELSE X4=XNODE(I4) X5=XNODE(I5) X6=XNODE(I6) Y4=YNODE(I4) Y5=YNODE(I5) Y6=YNODE(I6) ENDIF S3=1.-S1-S2 LIMIT=3 NREFIN=0 C C LOOP TO REFINE ESTIMATE OF INTERNAL COORDINATES C 150 NREFIN=NREFIN+1 XT=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YT=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) C C COEF:=MAT((DXDS1,DXDS2,DXDS3), C (DYDS1,DYDS2,DYDS3),(1,1,1)); C COEF11=4.*S2*X4+4.*S1*X1+4.*X6*S3-X1 COEF12=4.*S2*X2+4.*S1*X4+4.*X5*S3-X2 COEF13=4.*S2*X5+4.*S1*X6+4.*X3*S3-X3 COEF21=4.*S2*Y4+4.*S1*Y1+4.*Y6*S3-Y1 COEF22=4.*S2*Y2+4.*S1*Y4+4.*Y5*S3-Y2 COEF23=4.*S2*Y5+4.*S1*Y6+4.*Y3*S3-Y3 M11=COEF22-COEF23 M12=COEF21-COEF23 M13=COEF21-COEF22 M21=COEF12-COEF13 M22=COEF11-COEF13 M23=COEF11-COEF12 CF11=+M11 CF12=-M12 CF13=+M13 CF21=-M21 CF22=+M22 CF23=-M23 DET=COEF11*CF11+COEF12*CF12+COEF13*CF13 IF (DET.EQ.0.0) THEN ATSEA=.TRUE. RETURN ENDIF DETI= 1./DET STEP11=CF11 STEP12=CF21 STEP21=CF12 STEP22=CF22 STEP31=CF13 STEP32=CF23 DELX=X-XT DELY=Y-YT DS1=(STEP11*DELX+STEP12*DELY)*DETI DS2=(STEP21*DELX+STEP22*DELY)*DETI DS3=(STEP31*DELX+STEP32*DELY)*DETI ERR=(DS1+DS2+DS3)/3. DS1=DS1-ERR DS2=DS2-ERR DS3=DS3-ERR DSTEP=MAX(ABS(DS1),ABS(DS2),ABS(DS3)) IF (DSTEP.GT. 0.10) THEN LIMIT=LIMIT+1 DS1=DS1*0.1/DSTEP DS2=DS2*0.1/DSTEP DS3=DS3*0.1/DSTEP ENDIF S1=S1+DS1 S2=S2+DS2 S3=S3+DS3 C C LOOP-BACK (WITH SOME CONDITIONS): C IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.(NTOTRY-10)).AND. + (S1.GE.-0.1.AND.S1.LE.1.1).AND. + (S2.GE.-0.1.AND.S2.LE.1.1).AND. + (S3.GE.-0.1.AND.S3.LE.1.1)) GO TO 150 C C POINT IS NOW AS WELL-LOCATED AS POSSIBLE "IN" THE CURRENT ELEMENT; C HOWEVER, THE INTERNAL COORDINATES MAY NOT ALL BE POSITIVE, SO C POINT MAY BE OUTSIDE, AND WE MAY NEED TO SHIFT TO A NEW ELEMENT. C SHIST(1,NTRIED)=S1 SHIST(2,NTRIED)=S2 SHIST(3,NTRIED)=S3 IF (TRUBBL.OR.NTRIED.GE.NTOTRY) THEN WRITE(IUNITT,201) X,Y 201 FORMAT(' REQUEST FOR VALUE AT LOCATION', + ' (',1P,E10.2,',',E10.2,') CAUSES ', + 'INFINITE LOOP IN LOOKUP.'/ + ' HISTORY OF SEARCH: ELEMENT S1 S2', + ' S3') DO 203 N=1,NTRIED-1 WRITE(IUNITT,202) IEHIST(N),(SHIST(K,N),K=1,3) 202 FORMAT(22X,I3,2X,3F12.4) 203 CONTINUE WRITE(IUNITT,204) IEHIST(NTRIED-1), + (NODES(J,IEHIST(NTRIED-1)),J=1,6), + (XNODE(NODES(J,IEHIST(NTRIED-1))),J=1,6), + (YNODE(NODES(J,IEHIST(NTRIED-1))),J=1,6) WRITE(IUNITT,204) IEHIST(NTRIED), + (NODES(J,IEHIST(NTRIED)),J=1,6), + (XNODE(NODES(J,IEHIST(NTRIED))),J=1,6), + (YNODE(NODES(J,IEHIST(NTRIED))),J=1,6) 204 FORMAT(' ELEMENT',I3,' NODES:',I3,5I10/ + 9X,'X:',1P,6E10.2/9X,'Y:',6E10.2) RETURN ENDIF IF (S1.GT.-0.03) THEN IF (S2.GT.-0.03) THEN IF (S3.GT.-0.03) THEN C POINT HAS BEEN SUCCESSFULLY FOUND! ATSEA=.FALSE. RETURN ELSE CALL NEXT (INPUT,IE,3,MXEL,MXFEL,NFL, + NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) ENDIF ELSE CALL NEXT (INPUT,IE,2,MXEL,MXFEL,NFL, + NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) ENDIF ELSE CALL NEXT (INPUT,IE,1,MXEL,MXFEL,NFL, + NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) ENDIF IF (KELE.GT.0) THEN IE=KELE S1=0.3333 S2=0.3333 S3=0.3334 GO TO 100 ELSE ATSEA=.TRUE. RETURN ENDIF C C NOTE: INDENTATION REFLECTS INDEFINITE LOOP ON TRIAL ELEMENT IE. C END C C C SUBROUTINE MANTLE (INPUT,IFLOW,VCX,VCY,X,Y, + OUTPUT,RESIST,VMX,VMY) C C COMPUTES HORIZONTAL COMPONENTS OF FLOW AT TOP OF MANTLE. C UPDATED 3/13/84 TO CHOICE OF NO DRAG (IFLOW=0) OR BIRD AND C ROSENSTOCK (1984) BOUNDARY (IFLOW=1), WITH NORTH AMERICA ENDING C AT THE CIMA RIFT, AND NO DRAG APPLIED TO SUBPLATES (E.G. SIERRA). C C**************************************************************** C CAVEAT HACKER !!! C UNLIKE OTHER SUBPROGRAMS IN THIS PACKAGE, "MANTLE" IS VERY C SPECIFIC TO A PARTICULAR PROBLEM: C -IT ONLY DESCRIBES THE PACIFIC/NORTH AMERICAN BOUNDARY IN THE C REGION OF CALIFORNIA. C -IT ASSUMES A PARTICULAR ORIGIN AND ORIENTATION OF THE X-AXIS. C (ORIGIN AT 34.371 N, 122.650 W, WITH +X POINTING S41.5E) C -IT ASSUMES A PARTICULAR MAP PROJECTION OF CALIFORNIA. C (LAMBERT CONFORMAL CONIC, 33/45 DEGREES; LIKE 1:750,000 C GEOLOGIC MAP OF CALIFORNIA) C -IT ASSUMES THAT INPUT COORDINATES ARE IN METERS. C -IT IS BASED ON A PARTICULAR PLATE MODEL (ROTATION POLE): C THAT OF DEMETS ET. AL. (1990): NUVEL-1. C C YOU WILL PROBABLY NEED TO REPLACE THE CODE GIVEN HERE WITH C NEW CODE OF YOUR OWN !!! C**************************************************************** C LOGICAL NOAM,PACIF,RESIST,SIERRA DATA VXC/-1.57707E-9/, VXX/ 0.0 /, VXY/3.5455E-16/, + VYC/+0.14242E-9/, VYX/-3.5455E-16/, VYY/ 0.0 / C IF (IFLOW.EQ.0) THEN C NO-DRAG OPTION: RESIST=.FALSE. VMX=VCX VMY=VCY ELSE IF (IFLOW.EQ.1) THEN C BIRD AND ROSENSTOCK (1984) OPTION: C V NORTHERN AND CENTRAL CALIFORNIA TRANSFORM SEGMENT YBOUND =175.5E3-0.036* X C V TRANPRESSIVE BOUNDARY BENEATH TRANSVERSE RANGES IF (X.GE.326.6E3) YBOUND=163.0E3+2.028*(X-326.6E3) C V SEGMENT APPROXIMATELY PARALLEL TO LITTLE SAN BERNARDINO C V MOUNTAINS FRONT IF (X.GE.420.8E3) YBOUND=355.4E3-0.029*(X-420.8E3) C V OBLIQUE SPREADING SEGMENT, NODES 44-39 IF (X.GE.597.0E3) YBOUND=349.5E3-0.675*(X-597.0E3) C V CRYPTIC PLATE BOUNDARY SEGMENT, NODES 39-9 IF (X.GE.649.5E3) YBOUND=312.7E3+0.032*(X-649.5E3) PACIF=Y.LE.YBOUND NOAM=(.NOT.PACIF).AND.(X.GE.(448.7E3-Y*0.0787)) SIERRA=(.NOT.PACIF).AND.(.NOT.NOAM) IF (NOAM) THEN RESIST=.TRUE. VMX=0. VMY=0. ELSE IF (PACIF) THEN RESIST=.TRUE. VMX=VXC+VXX*X+VXY*Y VMY=VYC+VYX*X+VYY*Y ELSE IF (SIERRA) THEN RESIST=.FALSE. VMX=VCX VMY=VCY ENDIF ENDIF RETURN END C C C SUBROUTINE MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DQDTDA, + ECREEP,FDIP,FFRIC,FMUMAX,FTAN,GMEAN, + MXFEL,MXNODE,NFL,NODEF, + OFFMAX,OFFSET, + ONEKM,RADIO,RHOH2O, + RHOBAR,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) C C THIS SUBPROGRAM CONTAINS THE NONLINEAR RHEOLOGY OF THE FAULTS. C FOR EACH OF 7 INTEGRATION POINTS ALONG THE LENGTH OF EACH FAULT C ELEMENT, IT: C C (1) COMPUTES THE SLIP-RATE VECTOR ON THE FAULT SURFACE, C (2) DETERMINES THE SHEAR STRESS ON THE FAULT SURFACE BY MOHR/ C COULOMB/NAVIER THEORY (THIS STRESS IS PROPORTIONAL TO DEPTH, C SO THE CALCULATION IS ACTUALLY DONE AT UNIT DEPTH AND THEN C SCALED), C (3) PROCEEDS DOWN THE DIP OF THE FAULT, CHECKING TEMPERATURE, C STRAIN-RATE, AND PRESSURE TO SEE IF FRICTIONAL OR CREEP C SHEAR STRESS IS LOWER, C (4) REPORTS THE VERTICAL INTEGRAL OF "MU" (THE RATIO OF SHEAR C STRESS TO SLIP RATE) DOWN THE FAULT AS "FIMUDZ". C (NOTE THAT THE INTEGRAL IS VERTICAL, NOT ON A SLANT, EVEN THOUGH C CONDITIONS ARE EVALUATED ALONG A SLANT PATH.) C (5) FOR DIPPING, OBLIQUE-SLIP FAULT ONLY, ALSO REPORTS RECOMMENDED C TACTICAL VALUES FOR THE MATRIX "FC" AND THE VECTOR "FTSTAR" C WHICH JOINTLY DESCRIBE A LINEARIZED RHEOLOGY STIFFER THAN C THE ACTUAL NONLINEAR RHEOLOGY. C (6) "ZTRANF" IS THE LATEST ESTIMATE OF THE DEPTH C TO THE BRITTLE/DUCTILE TRANSITION, AT THE FAULT MIDPOINT. C (7) LOGICAL VARIABLE "FSLIPS" INDICATES WHETHER THE FAULT IS C SLIPPING AT ITS MIDPOINT. OTHERWISE, IT IS IN THE ARTIFICIAL C LINEARIZED REGIME, WITH STIFFNESS "FMUMAX". C (8) "FPEAKS" GIVES THE PEAK SHEAR STRESS AT THE MIDPOINT OF EACH C FAULT, EVALUATED AT THE BRITTLE/DUCTILE TRANSITION. C C NOTE THAT PORE PRESSURES ARE CONSIDERED IN THE CALCULATION OF C FRICTIONAL STRENGTH: C *NORMAL PORE PRESSURES REDUCE THE EFFECTIVE NORMAL STRESS ON THE C FAULT SURFACE BY THE AMOUNT C -BIOT*GMEAN*RHOH20*Z C *IF (OFFMAX.GT.0.), THEN THE REMAINING EFFECTIVE FRICTIONAL STRENGTH C OF THE FAULT IS MULTIPLIED BY THE REDUCING FACTOR C *(1.-BYERLY*OFFSET(I)/OFFMAX). C THIS IS ALSO A PORE PRESSURE EFFECT, BECAUSE BYERLY'S MODEL IS C THAT GOUGE LAYERS HAVE THICKNESS IN PROPORTION TO OFFSET, AND C THAT THEY SUPPORT NON-DARCY STATIC PORE PRESSURE GRADIENTS WHICH C REDUCE THE EFFECTIVE FRICTION OF THE FAULT. C C FOLLOWING PARAMETER GIVES NUMBER OF STEPS IN VERTICAL INTEGRAL C OF CREEP SHEAR STRESS ON DUCTILE PARTS OF FAULTS: PARAMETER (NSTEP=20) C HIGHER VALUES OBVIOUSLY COST MORE. ON THE OTHER HAND, SMALL VALUES C DO NOT MERELY APPROXIMATE THE CREEP LAW; THEY ALSO INTRODUCE C SOME RANDOM ERR0R WHICH CAN PUT A FLOOR ON CONVERGENCE. C LOGICAL FSLIPS C LOGICAL LOCKED,PURESS,SLOPED DOUBLE PRECISION V DOUBLE PRECISION FPHI REAL NORMAL COMMON /FPHIS/ FPHI DIMENSION FPHI(6,7) DIMENSION DQDTDA(MXNODE), + FC(2,2,7,MXFEL),FDIP(3,MXFEL), + FIMUDZ(7,MXFEL),FPEAKS(MXFEL),FSLIPS(MXFEL), + FTAN(7,MXFEL),FTSTAR(2,7,MXFEL),NODEF(6,MXFEL), + OFFSET(MXFEL),V(2,MXNODE),ZMNODE(MXNODE),ZTRANF(MXFEL) C C FOLLOWING TWO NUMBERS ARE "VERY SMALL" AND "VERY LARGE", BUT NOT C SO EXTREME AS TO CAUSE UNDERFLOW OR OVERFLOW. THEY MAY NEED TO C BE ADJUSTED, DEPENDING ON THE COMPUTER AND COMPILER BEING USED. DATA TINY /1.E-30/ DATA HUGE /1.E+30/ C**************************************************************** C THE FOLLOWING INTIALIZATIONS ARE NOT LOGICALLY NECESSARY, C BUT DUE TO BUGS IN THE VS-FORTRAN 2.4 COMPILER, THERE C WILL BE AN ERRONEOUS ERR0R MESSAGE IF THEY ARE NOT PERFORMED: RAKE=0. VUPDIP=0. C**************************************************************** C CGAMMA=(1.+SIN(ATAN(CFRIC)))/(1.-SIN(ATAN(CFRIC))) DO 100 I=1,NFL IF (OFFMAX.LE.0.) THEN FRIC=FFRIC ELSE FRIC=FFRIC*(1.-BYERLY*OFFSET(I)/OFFMAX) ENDIF N1=NODEF(1,I) N2=NODEF(2,I) N3=NODEF(3,I) N4=NODEF(4,I) N5=NODEF(5,I) N6=NODEF(6,I) C C IS THIS A PURELY STRIKE-SLIP FAULT ELEMENT? PURESS=(ABS(FDIP(1,I)-1.570796).LE.WEDGE).AND. + (ABS(FDIP(2,I)-1.570796).LE.WEDGE).AND. + (ABS(FDIP(3,I)-1.570796).LE.WEDGE) C C IF SO, COMPUTE ESTIMATE OF RELATIVE NORMAL STRESS C (RELATIVE TO VERTICAL STRESS) BY USING AMOUNT OF DIVERGENCE C BETWEEN NODES N2 AND N5 (IN SPITE OF CONSTRAINT EQUATION): IF (PURESS) THEN ANGLE=FTAN(4,I) UNITBX=SIN(ANGLE) UNITBY= -COS(ANGLE) DELVX=V(1,N2)-V(1,N5) DELVY=V(2,N2)-V(2,N5) SPREAD=DELVX*UNITBX+DELVY*UNITBY DELTAU=CONSTR*SPREAD DPMAX= -2.*DELTAU/ZTRANF(I) DDPNDZ=DPMAX/ZTRANF(I) C DDPNDZ IS THE GRADIENT OF EXCESS NORMAL PRESSURE (IN C EXCESS OF VERTICAL PRESSURE) WITH DEPTH ON THIS FAULT; C CHECK THAT IT LIES WITHIN FRICTIONAL LIMITS OF BLOCKS: Q=0.5*(DQDTDA(N2)+DQDTDA(N5)) TTRANS=TSURF+ZTRANF(I)*Q/CONDUC- + ZTRANF(I)**2*RADIO/(2.*CONDUC) TMEAN=(TSURF+TTRANS)/2. RHO=RHOBAR*(1.-ALPHAT*TMEAN) DLEPDZ=GMEAN*(RHO-RHOH2O*BIOT) THRUST=DLEPDZ*CGAMMA NORMAL=DLEPDZ/CGAMMA DDPNDZ=MAX(DDPNDZ,NORMAL-DLEPDZ) DDPNDZ=MIN(DDPNDZ,THRUST-DLEPDZ) C ELSE C SITUATION TOO COMPLEX TO ANALYZE, SO JUST SET NORMAL C STRESS ON THE VERTICAL PART OF THIS FAULT ELEMENT C EQUAL TO VERTICAL STRESS: DDPNDZ=0. ENDIF C DO 90 M=1,7 C HEAT-FLOW: Q=DQDTDA(N1)*FPHI(1,M)+DQDTDA(N2)*FPHI(2,M)+ + DQDTDA(N3)*FPHI(3,M) C C CRUSTAL THICKNESS: THICK=ZMNODE(N1)*FPHI(1,M)+ZMNODE(N2)*FPHI(2,M)+ + ZMNODE(N3)*FPHI(3,M) C C MOHO TEMPERATURE: TMOHO=TSURF+THICK*Q/CONDUC-THICK**2*RADIO/(2.*CONDUC) C C MEAN TEMPERATURE: TMEAN=(TSURF+TMOHO)/2. C C MEAN DENSITY: RHO=RHOBAR*(1.-ALPHAT*TMEAN) C C DERIVITIVE OF LITHOSTATIC EFFECTIVE PRESSURE WITH DEPTH DLEPDZ=GMEAN*(RHO-RHOH2O*BIOT) C C ANGLE IS THE FAULT STRIKE, IN RADIANS CCLKWS FROM +X. ANGLE=FTAN(M,I) C C UNITA IS A UNIT VECTOR ALONG THE FAULT, FROM N1 TO N3. UNITAX=COS(ANGLE) UNITAY=SIN(ANGLE) C C UNITB IS A PERPENDICULAR UNIT VECTOR, POINTING OUT C TOWARD THE N6-N4 SIDE. UNITBX= -UNITAY UNITBY= +UNITAX C C RELATIVE VELOCITIES ARE FOR N1-3 SIDE RELATIVE TO C THE N6-4 SIDE: DELVX=V(1,N1)*FPHI(1,M)+V(1,N2)*FPHI(2,M)+ + V(1,N3)*FPHI(3,M)+V(1,N4)*FPHI(4,M)+ + V(1,N5)*FPHI(5,M)+V(1,N6)*FPHI(6,M) DELVY=V(2,N1)*FPHI(1,M)+V(2,N2)*FPHI(2,M)+ + V(2,N3)*FPHI(3,M)+V(2,N4)*FPHI(4,M)+ + V(2,N5)*FPHI(5,M)+V(2,N6)*FPHI(6,M) C C SINISTRAL STRIKE-SLIP RATE COMPONENT: SINIST=DELVX*UNITAX+DELVY*UNITAY C C CONVERGENCE RATE COMPONENT (IN HORIZONTAL PLANE): CLOSE =DELVX*UNITBX+DELVY*UNITBY C C DIP OF THE FAULT (FROM HORIZONTAL ON THE N1-3 SIDE): DIP=FDIP(1,I)*FPHI(1,M)+FDIP(2,I)*FPHI(2,M)+ + FDIP(3,I)*FPHI(3,M) SLOPED=ABS(DIP-1.570796).GT.WEDGE C IF (.NOT.SLOPED) THEN C CASE OF A NEAR-VERTICAL FAULT: DSFDZ=(DLEPDZ+DDPNDZ)*FRIC SLIP=ABS(SINIST) LOCKED=.FALSE. ELSE C CASE OF A SHALLOW-DIPPING FAULT: C C VUPDIP IS THE UP-DIP VELOCITY COMPONENT, IN THE C FAULT PLANE, OF THE BLOCK ON THE N1-N3 SIDE. VUPDIP=CLOSE/COS(DIP) C C RAKE ANGLE IS MEASURED COUNTERCLOCKWISE IN C FAULT PLANE FROM HORIZONTAL & PARALLEL TO ANGLE. RAKE=ATAN2F(VUPDIP,SINIST) C C DERIVITIVE OF EFFECTIVE NORMAL PRESSURE C WITH RESPECT TO SHEAR TRACTION ON FAULT: DEPDST=TAN(DIP)*SIN(RAKE) C (NOTICE THAT WHEN SENSE OF DIP REVERSES, SIGN C CHANGE CAUSED BY TAN(DIP) IS CANCELLED BY SIGN C CHANGE CAUSED BY SIN(RAKE).) C C ACCORDING TO THEORY, THE EQUATION TO SOLVE IS: C D(SHEAR_TRACTION)/DZ = C "FRIC"*("DLEPDZ"+"DEPDST"*D(SHEAR_TRACTION)/DZ) C THIS MAY HAVE A PHYSICAL SOLUTION (ONE WITH C POSITIVE SHEAR_TRACTION). IF NOT, THE C FAULT IS LOCKED. LOCKED=(FRIC*DEPDST).GE.1.00 IF (LOCKED) THEN DSFDZ=HUGE ELSE DSFDZ=FRIC*DLEPDZ/(1.00-FRIC*DEPDST) ENDIF C SLIP=SQRT((1.D0*SINIST)**2+(1.D0*VUPDIP)**2) ENDIF SLIP=MAX(SLIP,TINY*50.*ONEKM) C C LOCATE PLASTIC/CREEP TRANSITION C BY ITERATED HALVING OF DOMAIN: C TOPZ=0. BASEZ=THICK DO 50 KITER=1,15 Z=0.5*(TOPZ+BASEZ) SHEARF=Z*DSFDZ SHEARP=MIN(SHEARF,DCREEP) T=TSURF+Q*Z/CONDUC-(RADIO/(2.*CONDUC))*Z**2 IF (Z.LE.17.*ONEKM) THEN T90PC=0.5*Z ELSE T90PC=25.*ONEKM-2.83*Z+ + 0.11111*ONEKM*(Z/ONEKM)**2 ENDIF C SEE TURCOTTE ET AL (1980) JGR, 85, B11, 6224-6230 STRAIN=SLIP/T90PC SHEARC=ACREEP*(STRAIN**ECREEP)* + EXP((BCREEP+CCREEP*Z)/T) IF (SHEARC.LT.SHEARP) THEN BASEZ=Z ELSE TOPZ=Z ENDIF 50 CONTINUE ZTRANS=0.5*(TOPZ+BASEZ) SHEARF=ZTRANS*DSFDZ C C PLASTIC PART OF VERTICAL INTEGRAL OF TRACTION: C IF (SHEARF.LT.DCREEP) THEN VITDZ=0.5*SHEARF*ZTRANS ELSE ZP=ZTRANS*DCREEP/SHEARF VITDZ=DCREEP*(ZTRANS-0.5*ZP) ENDIF C C ADD CREEP PART OF INTEGRAL, USING PARABOLIC RULE C DZ=(THICK-ZTRANS)/NSTEP OLDSC=SHEARC Z0=ZTRANS SUM=0. DO 80 J=1,NSTEP ZHALF=Z0+0.5*DZ ZFULL=Z0+DZ THALF=TSURF+Q*ZHALF/CONDUC- + (RADIO/(2.*CONDUC))*ZHALF**2 TFULL=TSURF+Q*ZFULL/CONDUC- + (RADIO/(2.*CONDUC))*ZFULL**2 IF (ZHALF.LE.17.*ONEKM) THEN WHALF=0.5*ZHALF ELSE WHALF=25.*ONEKM-2.83*ZHALF+ + 0.11111*ONEKM*(ZHALF/ONEKM)**2 ENDIF IF (ZFULL.LE.17.*ONEKM) THEN WFULL=0.5*ZFULL ELSE WFULL=25.*ONEKM-2.83*ZFULL+ + 0.11111*ONEKM*(ZFULL/ONEKM)**2 ENDIF C SEE TURCOTTE ET AL (1980) JGR, 85, B11, 6224-6230 EHALF=SLIP/WHALF EFULL=SLIP/WFULL SCHALF=ACREEP*(EHALF**ECREEP)* + EXP((BCREEP+CCREEP*ZHALF)/THALF) SCFULL=ACREEP*(EFULL**ECREEP)* + EXP((BCREEP+CCREEP*ZFULL)/TFULL) SUM=SUM+DZ*(0.1666667*OLDSC+ + 0.6666667*SCHALF+ + 0.1666666*SCFULL) Z0=ZFULL OLDSC=SCFULL 80 CONTINUE VITDZ=VITDZ+SUM C VIMUDZ=VITDZ/SLIP C FIMUDZ(M,I)=MIN(VIMUDZ,FMUMAX*THICK) C C DIPPING, OBLIQUE-SLIP INTEGRATION C POINTS ARE ALSO CHARACTERIZED C BY "FC" AND "FTSTAR": C IF (SLOPED) THEN TS=SINIST*FIMUDZ(M,I) TU=VUPDIP*FIMUDZ(M,I) IF (LOCKED) THEN FC(1,1,M,I)=FIMUDZ(M,I) FC(1,2,M,I)=0. FC(2,1,M,I)=0. FC(2,2,M,I)=FIMUDZ(M,I) ELSE SINR=SIN(RAKE) COSR=COS(RAKE) TAND=TAN(DIP) C C *** IMPORTANT NOTE: *** C THE FOLLOWING 7 STATEMENTS ARE -NOT- THE C RESULT OF THEORY, BUT A TACTICAL CHOICE C WHICH ATTEMPTS TO COMPROMISE BETWEEN C STABILITY OF THE LINEAR SYSTEM, STABILITY C OF THE ITERATION, AND EFFICIENCY. C THEY MAY BE CHANGED IF THE PROGRAM DOES C NOT CONVERGE SATISFACTORILY! C TUNE=2. FC(1,1,M,I)=FIMUDZ(M,I)* + (1.-TUNE*SINR*COSR**2*TAND) FC(1,2,M,I)=FIMUDZ(M,I)* + (TUNE*COSR**3*TAND) FC(2,1,M,I)=FIMUDZ(M,I)* + (-TUNE*SINR**2*COSR*TAND) FC(2,2,M,I)=FIMUDZ(M,I)* + (1.+TUNE*SINR*COSR**2*TAND) C (OFTEN, FC(1,2) IS THE BIGGEST TERM. C IN SOME CASES, DIAGONALS BECOME NEGATIVE. C FOR STABILITY, BE SURE THAT THE FC C MATRIX REMAINS POSITIVE DEFINITE: FC(1,1,M,I)=MAX(FC(1,1,M,I),ABS(FC(1,2,M,I))) FC(2,2,M,I)=MAX(FC(2,2,M,I),ABS(FC(1,2,M,I))) ENDIF FTSTAR(1,M,I)=TS-FC(1,1,M,I)*SINIST- + FC(1,2,M,I)*VUPDIP FTSTAR(2,M,I)=TU-FC(2,1,M,I)*SINIST- + FC(2,2,M,I)*VUPDIP ENDIF C C PROVIDE INTERESTING DIAGNOSTIC DATA AT MIDPOINTS ONLY: C IF (M.EQ.4) THEN FSLIPS(I)=(.NOT.LOCKED).AND. + (FIMUDZ(M,I).LT.(0.99*FMUMAX*THICK)) ZTRANF(I)=ZTRANS FPEAKS(I)=SHEARP ENDIF C 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE NEXT (INPUT,I,J,MXEL,MXFEL,NFL,NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) C C DETERMINE WHETHER THERE ARE MORE ELEMENTS ADJACENT TO SIDE J OF C TRIANGULAR CONTINUUM ELEMENT #I. C J = 1 MEANS THE SIDE OPPOSITE NODE # NODES(1,I). C J = 2 MEANS THE SIDE OPPOSITE NODE # NODES(2,I). C J = 3 MEANS THE SIDE OPPOSITE NODE # NODES(3,I). C IF A FAULT ELEMENT IS ADJACENT, ITS NUMBER IS KFAULT; OTHERWISE, C KFAULT IS SET TO ZERO. C IF ANOTHER TRIANGULAR CONTINUUM ELEMENT IS ADJACENT (EVEN ACROSS C FAULT ELEMENT KFAULT!) THEN ITS NUMBER IS KELE; OTHERWISE, KELE = 0. C LOGICAL FOUNDE,FOUNDF DIMENSION NODEF(6,MXFEL),NODES(6,MXEL) C**************************************************************** C THE FOLLOWING INTIALIZATIONS ARE NOT LOGICALLY NECESSARY, C BUT DUE TO BUGS IN THE VS-FORTRAN 2.4 COMPILER, THERE C WILL BE AN ERRONEOUS ERR0R MESSAGE IF THEY ARE NOT PERFORMED: M1=0 M2=0 M3=0 M4=0 M5=0 M6=0 C**************************************************************** C C THREE NODE NUMBERS ALONG THE SIDE OF INTEREST, COUNTERCLOCKWISE: N1=NODES(MOD(J, 3)+1,I) N2=NODES(MOD(J, 3)+4,I) N3=NODES(MOD(J+1,3)+1,I) C CHECK FOR ADJACENT FAULT ELEMENT FIRST: FOUNDF=.FALSE. DO 10 K=1,NFL M1=NODEF(1,K) M2=NODEF(2,K) M3=NODEF(3,K) M4=NODEF(4,K) M5=NODEF(5,K) M6=NODEF(6,K) IF (((M1.EQ.N3).AND.(M2.EQ.N2).AND.(M3.EQ.N1)).OR. + ((M4.EQ.N3).AND.(M5.EQ.N2).AND.(M6.EQ.N1))) THEN FOUNDF=.TRUE. KFAULT=K GO TO 11 ENDIF 10 CONTINUE 11 IF (.NOT.FOUNDF) KFAULT=0 C IF THERE WAS A FAULT, REPLACE 3 NODE NUMBERS THAT WE SEARCH FOR: IF (FOUNDF) THEN IF (M2.EQ.N2) THEN N1=M4 N2=M5 N3=M6 ELSE N1=M1 N2=M2 N3=M3 ENDIF ENDIF C SEARCH FOR ADJACENT TRIANGULAR CONTINUUM ELEMENT: FOUNDE=.FALSE. DO 20 K=1,NUMEL IF (K.NE.I) THEN DO 15 L=1,3 M1=NODES(MOD(L, 3)+1,K) M2=NODES(MOD(L, 3)+4,K) M3=NODES(MOD(L+1,3)+1,K) IF ((M3.EQ.N1).AND.(M2.EQ.N2).AND.(M1.EQ.N3)) THEN FOUNDE=.TRUE. KELE=K GO TO 21 ENDIF 15 CONTINUE ENDIF 20 CONTINUE 21 IF (.NOT.FOUNDE) KELE=0 RETURN END C C C SUBROUTINE OLDVEL (INPUT,IUNITV,MXNODE,NUMNOD, + OUTPUT,ALDONE,TITLE1,TITLE2,TITLE3,V) C C READ OLD VELOCITY SOLUTION FROM UNIT IUNITV, OR ELSE SET FLAG C "ALDONE". C LOGICAL ALDONE CHARACTER*80 TITLE1,TITLE2,TITLE3 DOUBLE PRECISION V DIMENSION V(2,MXNODE) C READ (IUNITV,'(A80)',END=100,ERR=100) TITLE1 READ (IUNITV,'(A80)',END=100,ERR=100) TITLE2 READ (IUNITV,'(A80)',END=100,ERR=100) TITLE3 READ (IUNITV,*,END=100,ERR=100) ((V(J,I),J=1,2),I=1,NUMNOD) ALDONE=.FALSE. RETURN C ------------------(THIS SECTION EXECUTED ONLY IF READ FAILS)--------- 100 ALDONE=.TRUE. RETURN END C C C SUBROUTINE ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP, + ECREEP,ERATE,FRIC,GMEAN,GEOTH, + NODES,NUMEL,RHOH2O,RHOBAR, + TEMLIM,ZMOHO, + OUTPUT,GLUE) C C CALCULATES "GLUE" (SHEAR STRESS REQUIRED TO CREATE UNIT RELATIVE C HORIZONTAL VELOCITY ACROSS A LAYER) C C PARAMETER "NINT" SETS NUMBER OF STEPS IN VERTICAL INTEGRALS: PARAMETER (NINT=100) C DIMENSION ERATE(3,7,NUMEL), + GEOTH(4,7,NUMEL), + GLUE(7,NUMEL), + NODES(6,NUMEL), + ZMOHO(7,NUMEL) C C C INITIALIZE SUMS TO ZERO C (NOTE THAT THESE SUMS DO NOT YET HAVE THE MEANING DESCRIBED ABOVE, C AND THE ARRAYS ARE ONLY BEING USED FOR WORKING STORAGE. C UNTIL THE FINAL LOOP, GLUE WILL HOLD THE VELOCITY AND FLUX WILL C HOLD THE FLUX AT/ABOVE THE CURRENT DEPTH.) C STFRIC=SIN(ATAN(FRIC)) DPEDZ=GMEAN*(RHOBAR-RHOH2O*BIOT) C DO 7 M=1,7 DO 6 I=1,NUMEL GLUE(M,I)=0. 6 CONTINUE 7 CONTINUE C C BEGIN CRITICAL TRIPLY-NESTED LOOP C DO 100 M=1,7 DO 60 J=1,NINT DO 50 I=1,NUMEL C C INTEGRATION OF "GLUE" (VELOCITY) IS PERFORMED BY MIDPOINT RULE, C SO ALL QUANTITIES ARE EVALUATED AT MIDDLE OF DEPTH STEP: C Z=(J-0.5)*ZMOHO(M,I)/NINT T=GEOTH(1,M,I) + +GEOTH(2,M,I)*Z + +GEOTH(3,M,I)*Z*Z + +GEOTH(4,M,I)*Z*Z*Z TH=MAX(T,200.) TL=MIN(TH,TEMLIM) ECINI= -1.0/ECREEP AILOG=LOG(ACREEP)*ECINI BI=(BCREEP+CCREEP*Z)*ECINI ARG=MAX(AILOG+BI/TL,-89.9) GLUE(M,I)=GLUE(M,I)+EXP(ARG) 50 CONTINUE 60 CONTINUE C C MULTIPLY SUMS BY COMMON FACTORS AND TRANSFORM DIMENSIONS C DO 90 I=1,NUMEL GLUE(M,I)=(GLUE(M,I)*ZMOHO(M,I)/NINT)**(-ECREEP) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE PRINCE (INPUT,E11,E22,E12, + OUTPUT,E1,E2,U1X,U1Y,U2X,U2Y) C C FIND PRINCIPAL VALUES (E1,E2) OF THE SYMMETRIC 2X2 TENSOR E11 E12 C E12 E22 C AND ALSO THE ASSOCIATED EIGENVECTORS #1=(U1X,U1Y),#2=(U2X,U2Y). C THE CONVENTION IS THAT E1 <= E2. C R=SQRT(((1.D0*E11-E22)/2.D0)**2+(1.D0*E12)**2) C=(E11+E22)/2. E1=C-R E2=C+R SCALE=MAX(ABS(E1),ABS(E2)) TEST=0.01*SCALE IF ((ABS(E12).GT.TEST).OR.(ABS(E11-E1).GT.TEST)) THEN THETA=ATAN2F(E11-E1, -E12) ELSE THETA=ATAN2F(E12, E1-E22) ENDIF U1X=COS(THETA) U1Y=SIN(THETA) U2X=U1Y U2Y= -U1X RETURN END C C C SUBROUTINE READPM (INPUT,IUNIT7, IUNIT8, $ NPTYPE, OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT, + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , + IFLOW , GMEAN , + MAXITR, OKDELV, OKTOQT, ONEKM, RADIO , + REFSTR, RHOAST, RHOBAR, RHOH2O, + TEMLIM, TITLE3, TSURF, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,NCONTR, $ STATES,RMSVEC, $ SDENOM,IPENCT,IPENST,IPENLB,COLOR) C C READS STRATEGIC AND TACTICAL INPUT PARAMETERS FROM DEVICE IUNIT7, C AND ECHOES THEM ON DEVICE IUNIT8 WITH ANNOTATIONS. C LOGICAL COLOR,DOPLOT,EVERYP,STATES CHARACTER*80 TITLE3 DIMENSION CINT(NPTYPE),DOPLOT(NPTYPE), + FBLAND(NPTYPE),LOWBLU(NPTYPE) C WRITE (IUNIT8,1) IUNIT7 1 FORMAT (/ /' ATTEMPTING TO READ PARAMETERS FROM UNIT ',I2) READ (IUNIT7,2,IOSTAT=IOS) TITLE3 2 FORMAT (A80) WRITE (IUNIT8,3) TITLE3 3 FORMAT (/' TITLE OF PARAMETER SET ='/' ',A80) WRITE (IUNIT8,4) 4 FORMAT (/' **************************************************'/ + ' IT IS THE USERS RESPONSIBILITY TO INPUT ALL OF THE'/ + ' FOLLOWING NUMERICAL QUANTITIES IN CONSISTENT UNITS,'/ + ' SUCH AS SYSTEM-INTERNATIONAL (SI) OR CM-G-S (CGS).'/ + ' NOTE THAT TIME UNIT MUST BE THE SECOND (HARD-CODED).'/ + ' **************************************************'/ + /' ========== STRATEGIC PARAMETERS (DEFINE THE REAL', + '-EARTH PROBLEM) ======'/) READ (IUNIT7,*) FFRIC WRITE (IUNIT8,20) FFRIC 20 FORMAT (' ', F10.3,' COEFFICIENT OF FRICTION ON FAULTS') READ (IUNIT7,*) CFRIC WRITE (IUNIT8,30) CFRIC 30 FORMAT (' ', F10.3,' COEFFICIENT OF FRICTION WITHIN BLOCKS') READ (IUNIT7,*) BIOT BIOT = MAX(0.0,MIN(1.0,BIOT)) WRITE (IUNIT8,40) BIOT 40 FORMAT (' ',F10.4,' EFFECTIVE-PRESSURE (BIOT) COEFFICIENT,', + ' 0.0 TO 1.0') READ (IUNIT7,*) BYERLY BYERLY = MAX(0.0,MIN(0.99,BYERLY)) IF (OFFMAX.GT.0.) THEN WRITE (IUNIT8,41) BYERLY 41 FORMAT (' ',F10.4,' BYERLY COEFFICIENT (0. TO 0.99) ='/ + 11X,' FRACTIONAL FRICTION REDUCTION ON MASTER', + ' FAULT'/ + 11X,' (OTHER FAULTS HAVE LESS REDUCTION, IN', + ' PROPORTION TO'/ + 11X,' THEIR TOTAL PAST OFFSETS)') ELSE WRITE (IUNIT8,42) BYERLY 42 FORMAT (' ',F10.4,' BYERLY COEFFICIENT (NOT USED IN', + ' THIS RUN,'/ + 11X,' AS ALL OFFSETS ARE ZERO)') ENDIF READ (IUNIT7,*) ACREEP WRITE (IUNIT8,50) ACREEP 50 FORMAT (' ',1P, E10.2,' A FOR CREEP = PRE-EXPONENTIAL SHEAR', + ' STRESS CONSTANT FOR CREEP') READ (IUNIT7,*) BCREEP WRITE (IUNIT8,60) BCREEP 60 FORMAT (' ', F10.0,' B FOR CREEP =(ACTIVATION ENERGY)/R/N', + ' (IN K)') READ (IUNIT7,*) CCREEP WRITE (IUNIT8,70) CCREEP 70 FORMAT (' ',1P, E10.2,' C FOR CREEP = DERIVATIVE OF B WITH', + ' RESPECT TO DEPTH') READ (IUNIT7,*) DCREEP WRITE (IUNIT8,80) DCREEP 80 FORMAT (' ',1P, E10.2,' D FOR CREEP = MAXIMUM SHEAR STRESS', + ' UNDER ANY CONDITIONS') READ (IUNIT7,*) ECREEP WRITE (IUNIT8,90) ECREEP 90 FORMAT (' ', F10.6,' E FOR CREEP = STRAIN-RATE EXPONENT FOR', + ' CREEP (1/N)') READ (IUNIT7,*) IFLOW WRITE (IUNIT8,100) 100 FORMAT(12X,'VELOCITY BOUNDARY CONDITION AT BASE OF CRUST IS:') IF (IFLOW.EQ.0) THEN WRITE (IUNIT8,101) IFLOW 101 FORMAT (' ',I10,' PARALLEL TO CRUST, CREATING NO', + ' DRAG ANYWHERE.') ELSE IF (IFLOW.EQ.1) THEN WRITE (IUNIT8,102) IFLOW 102 FORMAT (' ',I10,' PER BIRD AND ROSENSTOCK (1984),', + ' WITH RIFT BELOW CIMA'/11X, + ' AND NO DRAG APPLIED BENEATH SUBPLATES', + ' (SIERRA, MOJAVE, B/R)') ELSE WRITE (IUNIT8,103) IFLOW 103 FORMAT (11X, + ' NOT UNDERSTOOD. WHAT DOES IFLOW=',I6,' MEAN ?') STOP ENDIF READ (IUNIT7,*) RHOH2O WRITE (IUNIT8,110) RHOH2O 110 FORMAT (' ',1P,E10.3,' DENSITY OF GROUNDWATER, LAKES, & OCEANS') READ (IUNIT7,*) RHOBAR WRITE (IUNIT8,120) RHOBAR 120 FORMAT (' ',1P,E10.3,' MEAN DENSITY OF CRUST,', + ' CORRECTED TO 0 DEGREES KELVIN') READ (IUNIT7,*) RHOAST WRITE (IUNIT8,130) RHOAST 130 FORMAT (' ',1P,E10.3,' DENSITY OF ASTHENOSPHERE') READ (IUNIT7,*) GMEAN WRITE (IUNIT8,140) GMEAN 140 FORMAT (' ',1P,E10.3,' MEAN GRAVITATIONAL ACCELERATION', + ' (LENGTH/SEC**2)') READ (IUNIT7,*) ONEKM WRITE (IUNIT8,150) ONEKM 150 FORMAT (' ',1P,E10.3,' NUMBER OF LENGTH UNITS NEEDED TO', + ' MAKE 1 KILOMETER'/11X, + ' (E.G., 1000. IN SI, 1.E5 IN CGS)') READ (IUNIT7,*) ALPHAT WRITE (IUNIT8,160) ALPHAT 160 FORMAT (' ',1P,E10.2,' VOLUMETERIC THERMAL EXPANSION OF CRUST', + ' (1/VOL)*(D.VOL/D.T)') READ (IUNIT7,*) CONDUC WRITE (IUNIT8,170) CONDUC 170 FORMAT (' ',1P,E10.2,' THERMAL CONDUCTIVITY OF CRUST (ENERGY/', + 'LENGTH/SEC/DEG)') READ (IUNIT7,*) RADIO WRITE (IUNIT8,180) RADIO 180 FORMAT (' ',1P,E10.2,' RADIOACTIVE HEAT PRODUCTION OF CRUST', + ' (ENERGY/VOLUME/SEC)') READ (IUNIT7,*) TSURF WRITE (IUNIT8,185) TSURF 185 FORMAT (' ', F10.0,' SURFACE TEMPERATURE, ON', + ' ABSOLUTE SCALE') READ (IUNIT7,*) TEMLIM WRITE (IUNIT8,190) TEMLIM 190 FORMAT (' ', F10.0,' CONVECTING TEMPERATURE (TMAX), ON', + ' ABSOLUTE SCALE') WRITE (IUNIT8,199) 199 FORMAT (/' ========== TACTICAL PARAMETERS (HOW TO REACH ', + 'THE SOLUTION) =========='/) READ (IUNIT7,*) MAXITR WRITE (IUNIT8,200) MAXITR 200 FORMAT (' ',I10,' MAXITR (NOT USED BY THIS PROGRAM)') READ (IUNIT7,*) OKTOQT WRITE (IUNIT8,210) OKTOQT 210 FORMAT (' ',F10.6,' OKTOQT (NOT USED BY THIS PROGRAM)') READ (IUNIT7,*) REFSTR WRITE (IUNIT8,220) REFSTR 220 FORMAT (' ',1P,E10.2,' EXPECTED MEAN VALUE OF SHEAR STRESS IN', + ' CRUST'/' ',10X, + ' (USED TO SET STIFFNESS LIMITS)') READ (IUNIT7,*) OKDELV WRITE (IUNIT8,230) OKDELV 230 FORMAT (' ',1P,E10.2,' MAGNITUDE OF VELOCITY ERR0RS ALLOWED', + ' DUE TO FINITE STIFFNESS'/11X, + '(SUCH ERR0RS MAY APPEAR IN SUCH FORMS AS:'/11X, + ' 1. FICTICIOUS BASAL SLIP OF CRUST OVER MANTLE'/11X, + ' 2. ERRONEOUS CONVERGENCE/DIVERGENCE AT VERTICAL FAULTS'/ + 11X, + ' 3. VELOCITY EFFECT OF FICTICIOUS VISCOUS COMPLIANCES'/11X, + ' HOWEVER, VALUES WHICH ARE TOO SMALL WILL CAUSE ILL-CONDITIONED' + /11X, + ' LINEAR SYSTEMS AND STRESS ERR0RS, ', + 'AND MAY PREVENT CONVERGENCE!)') READ (IUNIT7,*) EVERYP WRITE (IUNIT8,240) EVERYP 240 FORMAT (' ',L10,' EVERYP (NOT USED BY THIS PROGRAM)') C READ(IUNIT7,*) C THIS WASTED READ IS TO GET PAST THE '======' LINE IN THE FILE. WRITE(IUNIT8,1000) 1000 FORMAT(/ / /' ===== POST-PROCESSING PLOT CONTROL PARAMETERS', + ' (NOT USED BY FAULTS) =====') C READ(IUNIT7,*) KTIME WRITE(IUNIT8,1001) KTIME 1001 FORMAT(/ / + ' ',I10,' KTIME (NOT USED BY THIS PROGRAM)') DO 1100 I=1,NPTYPE READ(IUNIT7,1010) DOPLOT(I),CINT(I),FBLAND(I),LOWBLU(I) 1010 FORMAT(L10,2E10.2,I2) 1100 CONTINUE WRITE(IUNIT8,1101) DOPLOT( 1),CINT( 1),FBLAND(1),LOWBLU(1) WRITE(IUNIT8,1102) DOPLOT( 2),CINT( 2),FBLAND(2),LOWBLU(2) WRITE(IUNIT8,1103) DOPLOT( 3),CINT( 3),FBLAND(3),LOWBLU(3) WRITE(IUNIT8,1104) DOPLOT( 4),CINT( 4),FBLAND(4),LOWBLU(4) WRITE(IUNIT8,1105) DOPLOT( 5),CINT( 5),FBLAND(5),LOWBLU(5) WRITE(IUNIT8,1106) DOPLOT( 6),CINT( 6),FBLAND(6),LOWBLU(6) WRITE(IUNIT8,1107) DOPLOT( 7),CINT( 7),FBLAND(7),LOWBLU(7) WRITE(IUNIT8,1108) DOPLOT( 8),CINT( 8),FBLAND(8),LOWBLU(8) WRITE(IUNIT8,1109) DOPLOT( 9),CINT( 9),FBLAND(9),LOWBLU(9) WRITE(IUNIT8,1110) DOPLOT(10),CINT(10),FBLAND(10),LOWBLU(10) WRITE(IUNIT8,1111) DOPLOT(11),CINT(11),FBLAND(11),LOWBLU(11) DOPLOT(12)=.FALSE. WRITE(IUNIT8,1112) DOPLOT(12),CINT(12),FBLAND(12),LOWBLU(12) WRITE(IUNIT8,1113) DOPLOT(13),CINT(13),FBLAND(13),LOWBLU(13) 1101 FORMAT(L11,1P,2E10.2,I2,' SHEAR TRACTION ON MOHO') 1102 FORMAT(L11,1P,2E10.2,I2,' MOHO VELOCITY VECTORS') 1103 FORMAT(L11,1P,2E10.2,I2,' SURFACE VELOCITY VECTORS') 1104 FORMAT(L11,1P,2E10.2,I2,' GREATEST PRINCIPAL STRAIN RATES') 1105 FORMAT(L11,1P,2E10.2,I2,' GREATEST PRINCIPAL' + ,' STRESS ANOMALY INTEGRALS') 1106 FORMAT(L11,1P,2E10.2,I2,' GRID OF ELEMENTS') 1107 FORMAT(L11,1P,2E10.2,I2,' RATE OF CRUSTAL THICKENING') 1108 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL THICKNESS') 1109 FORMAT(L11,1P,2E10.2,I2,' MOHO TEMPERATURE') 1110 FORMAT(L11,1P,2E10.2,I2,' ELEVATION') 1111 FORMAT(L11,1P,2E10.2,I2,' HEAT-FLOW') 1112 FORMAT(L11,1P,2E10.2,I2,' VELOCITY CHANGE FROM LAST ITERATION') 1113 FORMAT(L11,1P,2E10.2,I2,' SLIP-RATE OF FAULTS') READ(IUNIT7,*) NCONTR NCONTR=MAX(NCONTR,1) WRITE(IUNIT8,1200)NCONTR 1200 FORMAT(' ',I10,' APPROXIMATE NUMBER OF CONTOURS IN PLOTS', + ' WHEN CINT=0 (AUTO-SCALED)') READ(IUNIT7,*) STATES WRITE(IUNIT8,1300) STATES 1300 FORMAT(' ',L10,' THAT STATE OUTLINES ARE SUPERPOSED') READ (IUNIT7,*) RMSVEC WRITE (IUNIT8,1400) RMSVEC 1400 FORMAT(' ',F10.3,' RMS LENGTH OF PLOTTED VECTORS, IN INCHES') C READ(IUNIT7,*) C THIS WASTED READ IS TO GET PAST THE '======' LINE IN THE FILE. WRITE (IUNIT8,9999) C READ(IUNIT7,*) SDENOM WRITE(IUNIT8,1426) SDENOM 1426 FORMAT(' ',1PE10.2,' SCALE DENOMINATOR =', + ' (INPUT LENGTH UNITS)/(METER ON PLOT)') READ(IUNIT7,*) IPENCT IPENCT=MIN(IPENCT,31) IPENCT=MAX(IPENCT,1) WRITE(IUNIT8,1428)IPENCT 1428 FORMAT(' ',I10,' PEN WEIGHT FOR CONTOURS AND ELEMENT SIDES') READ(IUNIT7,*) IPENST IPENST=MIN(IPENST,31) IPENST=MAX(IPENST,1) WRITE(IUNIT8,1430)IPENST 1430 FORMAT(' ',I10,' PEN WEIGHT FOR STATE LINES AND FAULTS, IF ANY') READ(IUNIT7,*) IPENLB IPENLB=MIN(IPENLB,31) IPENLB=MAX(IPENLB,1) WRITE(IUNIT8,1431)IPENLB 1431 FORMAT(' ',I10,' PEN WEIGHT FOR TEXT LABELS AND NODES') READ(IUNIT7,*) COLOR WRITE(IUNIT8,1433) COLOR 1433 FORMAT(' ',L10,' THAT OUTPUT WILL BE IN COLOR (ELSE B & W)') 9999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE RESULT (INPUT,ALPHAT,ELEV,ERATE,FDIP,FIMUDZ, + FPEAKS,FSLIPS,FTAN,GEOTH,IUNITT, + MXEL,MXFEL,MXNODE,NFL, + NODEF,NODES,NREALN,NUMEL,NUMNOD,N1000, + RHOAST,RHOBAR,RHOH2O,SIGHB, + TAUMAT,TAUZZI,TITLE1,TITLE2,TITLE3, + V,WEDGE,ZMOHO,ZTRANC,ZTRANF) C C OUTPUT THE SOLUTION: C -DESCRIPTIVE TABLES TO UNIT "IUNITT". C CHARACTER*80 TITLE1,TITLE2,TITLE3 C C NOTE: IN VS-FORTRAN, FOLLOWING TYPE COULD BE LOGICAL*1: LOGICAL FSLIPS C DOUBLE PRECISION V DOUBLE PRECISION PHI,POINTS,WEIGHT COMMON /S1S2S3/ POINTS COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) DIMENSION ELEV(MXNODE), ERATE(3,7,MXEL), + FDIP(3,MXFEL), FIMUDZ(7,MXFEL),FPEAKS(MXFEL), + FSLIPS(MXFEL),FTAN(7,MXFEL),GEOTH(4,7,MXEL), + NODEF(6,MXFEL),NODES(6,MXEL), SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL),TAUZZI(7,MXEL),V(2,MXNODE), + ZMOHO(7,MXEL), + ZTRANC(7,MXEL),ZTRANF(MXFEL) C C VELOCITIES AT NODES: C WRITE (IUNITT,30) 30 FORMAT(/ /' VELOCITIES OF THE NODES:'/ + ' ', + ' ARGUMENT'/ + ' ', + ' (DEGREES'/ + ' NODE X-COMPONENT Y-COMPONENT MAGNI', + 'TUDE FROM +X)'/) DO 100 I=1,NUMNOD IF (I.LE.NREALN) THEN IP=I ELSE IP=N1000+I-NREALN ENDIF VX=V(1,I) VY=V(2,I) AZIMUT=ATAN2F(VY,VX)*57.2957795 VMAG=SQRT(V(1,I)**2+V(2,I)**2) WRITE (IUNITT,40) IP,V(1,I),V(2,I),VMAG,AZIMUT 40 FORMAT(' ',I5,1P,2D20.12,E10.2,0P,F8.2) 100 CONTINUE C C TRIANGULAR CONTINUUM ELEMENT PROPERTIES AT THEIR CENTERS: C WRITE (IUNITT,110) 110 FORMAT (/ /' CONTINUUM ELEMENT PROPERTIES (AT CENTER POINTS):'/ + /' E1=MOST E2=MOST ISOSTATIC VERTIC', + 'AL VERTICAL VERTICAL DEPTH OF BASAL BASAL' + /' ELEMENT ARGUMENT COMPRESS. EXTENS. UPLIFT INTEGR', + 'AL INTEGRAL INTEGRAL SEISMIC SHEAR SHEAR' + /' NUMBER OF E1 RATE RATE RATE OF(SZ+', + 'P0) OF(S1+P0) OF(S2+P0) ZONE STRESS ARGUMENT'/) 120 FORMAT (' ',I7,F10.2,1P,8E10.2,0P,F10.2) M=1 DO 200 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) CALL PRINCE (INPUT,EXX,EYY,EXY, + OUTPUT,E1,E2,U1X,U1Y,U2X,U2Y) ANGLE=ATAN2F(U1Y,U1X)*57.2957795 EZZ= -(EXX+EYY) TMID=GEOTH(1,M,I)+GEOTH(2,M,I)*ZMOHO(M,I)/2.+ + GEOTH(3,M,I)*(ZMOHO(M,I)/2.)**2 RHOC=RHOBAR*(1.-ALPHAT*TMID) HEIGHT=0. DO 150 N=1,6 HEIGHT=HEIGHT+ELEV(NODES(N,I))*PHI(N,M) 150 CONTINUE IF (HEIGHT.GT.0.) THEN FACTOR=(RHOAST-RHOC)/RHOAST ELSE FACTOR=(RHOAST-RHOC)/(RHOAST-RHOH2O) ENDIF VZ=EZZ*ZMOHO(M,I)*FACTOR TXX=TAUMAT(1,M,I)+TAUZZI(M,I) TYY=TAUMAT(2,M,I)+TAUZZI(M,I) TXY=TAUMAT(3,M,I) TZZ=TAUZZI(M,I) CALL PRINCE (INPUT,TXX,TYY,TXY, + OUTPUT,T1,T2,U1X,U1Y,U2X,U2Y) ZTRANS=ZTRANC(M,I) SIGHX=SIGHB(1,M,I) SIGHY=SIGHB(2,M,I) STHETA=57.298*ATAN2F(SIGHY,SIGHX) SHEAR=SQRT((1.D0*SIGHX)**2+(1.D0*SIGHY)**2) WRITE (IUNITT,120) I,ANGLE,E1,E2,VZ, + TZZ,T1,T2,ZTRANS,SHEAR,STHETA 200 CONTINUE WRITE (IUNITT,210) 210 FORMAT ( + /' THE FIGURES ABOVE INCLUDE VERTICAL INTEGRALS OF', + ' NORMAL STRESSES THROUGH THE CRUSTAL LAYER. COMPRESSIVE' + /' STRESSES ARE NEGATIVE. FOR CONVENIENCE, NORMAL STRESSES ARE', + ' FIRST CORRECTED USING A STANDARD PRESSURE CURVE' + /' P0(Z), BASED ON THE STRUCTURE OF MID-OCEAN SPREADING', + ' RISES (SEE SUBPROGRAM SQUEEZ).') C C FAULT ELEMENT PROPERTIES, ALSO AT MIDPOINTS: C IF (NFL.GT.0) WRITE (IUNITT,300) 300 FORMAT (/ / /' FAULT ELEMENT PROPERTIES (AT MID-POINTS):'/ + ' ', + ' ', + ' DOWN-DIP '/ + ' FAULT NODES#2,5 HORIZ. ARGUMENT', + ' PLUNGE TOTAL RIGHT PERPEN. RELATIVE', + ' INTEGRAL PEAK DEPTH OF IS THIS'/ + ' ELEMENT (N2 MOVES SLIP OF', + ' OF SLIP LATERAL SHORTNING VERTICAL', + ' OF SHEAR SHEAR SEISMIC FAULT'/ + ' NUMBER REL.TO N5) RATE SLIP', + ' SLIP RATE RATE RATE RATE', + ' TRACTION TRACTION ZONE ACTIVE?'/) 310 FORMAT (' ',I7,I5,',',I5,1P,E10.2,0P,2F10.2,1P,7E10.2,L10) M=4 DO 400 I=1,NFL DIP=FDIP(2,I) JM=NODEF(2,I) JB=NODEF(5,I) DU=V(1,JM)-V(1,JB) DV=V(2,JM)-V(2,JB) IF (JM.GT.NREALN) JM=N1000+(JM-NREALN) IF (JB.GT.NREALN) JB=N1000+(JB-NREALN) AZIMHS=ATAN2F(DV,DU) HORS=SQRT((1.D0*DU)**2+(1.D0*DV)**2) C C ANGLE IS THE FAULT STRIKE, IN RADIANS CCLKWS FROM +X. ANGLE=FTAN(M,I) UNITX=COS(ANGLE) UNITY=SIN(ANGLE) CROSSX= -UNITY CROSSY= +UNITX SINIST=DU*UNITX+DV*UNITY IF (ABS(FDIP(2,I)-1.570796).LT.WEDGE) THEN CLOSE=0. VUPDIP=0. ELSE CLOSE=DU*CROSSX+DV*CROSSY VUPDIP=CLOSE/COS(DIP) ENDIF RELV=VUPDIP*SIN(DIP) SNET=SQRT((1.D0*SINIST)**2+(1.D0*VUPDIP)**2) IF (SNET.GT.0.) THEN PLUNGE= -ASIN(RELV/SNET) ELSE PLUNGE=0. ENDIF RLT= -SINIST SHEAR=FIMUDZ(4,I)*SNET/SIN(DIP) AZIMHS=AZIMHS*57.2957795 PLUNGE=PLUNGE*57.2957795 WRITE (IUNITT,310) I,JM,JB,HORS,AZIMHS,PLUNGE,SNET, + RLT,CLOSE,RELV,SHEAR,FPEAKS(I),ZTRANF(I),FSLIPS(I) 400 CONTINUE WRITE (IUNITT,401) 401 FORMAT(' -----------------------------------', + '-----------------------------------') RETURN END C C C SUBROUTINE SQUARE (INPUT,BRIEF,FDIP,IUNIT8, + MXBN,MXEL,MXFEL,MXNODE, + MXSTAR,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,WEDGE, + MODIFY,FAZ,XNODE,YNODE, + OUTPUT,AREA,DETJ,DXS,DYS,EDGEFS,EDGETS, + FLEN,FTAN,NCOND,NODCON, + WORK,CHECKN,LIST,NODTYP) C C CHECK, CORRECT, AND COMPLETE THE GEOMETRY OF THE GRID C LOGICAL ALLOK,BRIEF,FOUND,MATCH,SWITCH,VERT1,VERT2,VERT3 C C NOTE: THE FOLLOWING TYPE COULD BE "LOGICAL*1" IN IBM VS-FORTRAN: LOGICAL CHECKN,EDGEFS,EDGETS C C NOTE: THE FOLLOWING COULD BE MADE "INTEGER*2" IN VS-FORTRAN: INTEGER NODTYP C CHARACTER*21 OBLIQU,TAG1,TAG2,TAG3,VERTIC DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS DIMENSION FPHI(6,7),FPOINT(7),FGAUSS(7) DIMENSION AREA(MXEL),CHECKN(MXNODE), + DETJ(7,MXEL),DXS(6,7,MXEL),DYS(6,7,MXEL), + EDGEFS(2,MXFEL),EDGETS(3,MXEL),FDIP(3,MXFEL), + FAZ(2,MXFEL),FLEN(MXFEL),FTAN(7,MXFEL), + LIST(MXSTAR),NODCON(MXBN), + NODEF(6,MXFEL),NODES(6,MXEL),NODTYP(MXNODE), + XNODE(MXNODE),YNODE(MXNODE) DATA OBLIQU /'(DIP SLIP IS ALLOWED)'/ DATA VERTIC /'(STRIKE-SLIP ONLY) '/ C**************************************************************** C THE FOLLOWING INTIALIZATIONS ARE NOT LOGICALLY NECESSARY, C BUT DUE TO BUGS IN THE VS-FORTRAN 2.4 COMPILER, THERE C WILL BE AN ERRONEOUS ERR0R MESSAGE IF THEY ARE NOT PERFORMED: DIP1=0. DIP2=0. DIP3=0. NUMBER=0 NAZL=0 C**************************************************************** C C (1) CHECK THAT ALL REAL NODES ARE CONNECTED TO AT LEAST ONE C CONTINUUM (TRIANGULAR) ELEMENT; C DO 110 I=1,NREALN CHECKN(I)=.FALSE. 110 CONTINUE DO 130 I=1,NUMEL DO 120 J=1,6 CHECKN(NODES(J,I))=.TRUE. 120 CONTINUE 130 CONTINUE ALLOK=.TRUE. DO 140 I=1,NREALN ALLOK=ALLOK.AND.CHECKN(I) 140 CONTINUE IF (.NOT.ALLOK) THEN WRITE(IUNIT8,150) 150 FORMAT(' BAD GRID TOPOLOGY: FOLLOWING REAL NODES DO NOT'/ 1 ' BELONG TO ANY TRIANGULAR CONTINUUM ELEMENT:') DO 160 I=1,NREALN IF (.NOT.CHECKN(I)) WRITE (IUNIT8,155) I 155 FORMAT (' ',43X,I6) 160 CONTINUE STOP ENDIF C C (2) CHECK THAT EVERY NODE IS EITHER A CORNER OR A MIDPOINT NODE, C BUT NOT BOTH. C DO 210 I=1,NUMNOD NODTYP(I)=0 210 CONTINUE NTOFIX=0 ALLOK=.TRUE. DO 250 I=1,NUMEL DO 240 J=1,6 IF (J.LE.3) THEN ITYPE=1 ELSE ITYPE=2 ENDIF N=NODES(J,I) IF (NODTYP(N).EQ.0) THEN NODTYP(N)=ITYPE IF (ITYPE.EQ.2) THEN IF ((XNODE(N).EQ.0.).AND.(YNODE(N).EQ.0.)) + NTOFIX=NTOFIX+1 ENDIF ELSE IF (NODTYP(N).NE.ITYPE) THEN ALLOK=.FALSE. WRITE (IUNIT8,220) N 220 FORMAT(' BAD GRID TOPOLOGY: NODE ',I6, + ' CANNOT BE AN ELEMENT CORNER AND AN', + ' ELEMENT SIDE-MIDPOINT AT THE SAME', + ' TIME.') ENDIF ENDIF 240 CONTINUE 250 CONTINUE DO 290 I=1,NFL DO 280 J=1,6 IF ((J.EQ.2).OR.(J.EQ.5)) THEN ITYPE=2 ELSE ITYPE=1 ENDIF N=NODEF(J,I) IF (NODTYP(N).EQ.0) THEN NODTYP(N)=ITYPE ELSE IF (NODTYP(N).NE.ITYPE) THEN ALLOK=.FALSE. WRITE (IUNIT8,220) N ENDIF ENDIF 280 CONTINUE 290 CONTINUE IF (.NOT.ALLOK) STOP C C (3) CHECK THAT EACH FAULT SIDE WITH REAL NODES ALONG IT SHARES C THOSE SAME 3 NODES WITH A TRIANGULAR CONTINUUM ELEMENT. C ALLOK=.TRUE. DO 390 I=1,NFL DO 380 J=2,5,3 N=NODEF(J,I) IF (N.LE.NREALN) THEN DO 320 K=1,NUMEL DO 310 L=4,6 IF (NODES(L,K).EQ.N) THEN LP=L-2 IF (LP.EQ.4) LP=1 LM=L-3 MATCH=((NODEF(J-1,I).EQ.NODES(LP,K)) + .OR.(NODEF(J-1,I).GT.NREALN)) + .AND.((NODEF(J+1,I).EQ.NODES(LM,K)) + .OR.(NODEF(J+1,I).GT.NREALN)) IF (.NOT.MATCH) THEN ALLOK=.FALSE. WRITE(IUNIT8,305) I,K 305 FORMAT(' BAD GRID TOPOLOGY:', + ' FAULT ',I6,' IS NOT PROPERL' + ,'Y CONNECTED TO ELEMENT ',I6) ELSE GO TO 380 ENDIF ENDIF 310 CONTINUE 320 CONTINUE ENDIF 380 CONTINUE 390 CONTINUE IF (.NOT.ALLOK) STOP C C (4) AVERAGE TOGETHER THE COORDINATES OF ALL NODES AT ONE "POINT" C DO 410 I=1,NUMNOD CHECKN(I)=.FALSE. 410 CONTINUE DO 490 I=1,NFL DO 480 J1=1,3,2 NJ1=NODEF(J1,I) IF (.NOT.CHECKN(NJ1)) THEN LIST(1)=NJ1 CHECKN(NJ1)=.TRUE. J2=7-J1 NJ2=NODEF(J2,I) LIST(2)=NJ2 CHECKN(NJ2)=.TRUE. NINSUM=2 DO 470 K=I,NFL DO 460 L1=1,3,2 NL1=NODEF(L1,K) IF (.NOT.CHECKN(NL1)) THEN MATCH=.FALSE. DO 420 M=1,NINSUM MATCH=MATCH.OR.(NL1.EQ.LIST(M)) 420 CONTINUE IF (MATCH) THEN NINSUM=NINSUM+1 IF (NINSUM.GT.MXSTAR) THEN WRITE(IUNIT8,421) 421 FORMAT(/' INCREASE VALUE' + ,' OF PARAMETER MAXATP.') STOP ENDIF LIST(NINSUM)=NL1 CHECKN(NL1)=.TRUE. ENDIF L2=7-L1 NL2=NODEF(L2,K) MATCH=.FALSE. DO 430 M=1,NINSUM MATCH=MATCH.OR.(NL2.EQ.LIST(M)) 430 CONTINUE IF (MATCH) THEN NINSUM=NINSUM+1 IF (NINSUM.GT.MXSTAR) THEN WRITE(IUNIT8,421) STOP ENDIF LIST(NINSUM)=NL2 CHECKN(NL2)=.TRUE. ENDIF ENDIF 460 CONTINUE 470 CONTINUE XSUM=0. YSUM=0. DO 473 K=1,NINSUM XSUM=XSUM+XNODE(LIST(K)) YSUM=YSUM+YNODE(LIST(K)) 473 CONTINUE XMEAN=XSUM/NINSUM YMEAN=YSUM/NINSUM RMAX=0. DO 474 K=1,NINSUM R=SQRT((XNODE(LIST(K))-XMEAN)**2+ + (YNODE(LIST(K))-YMEAN)**2) RMAX=MAX(RMAX,R) 474 CONTINUE DO 475 K=1,NINSUM XNODE(LIST(K))=XMEAN YNODE(LIST(K))=YMEAN 475 CONTINUE IF (.NOT.BRIEF) THEN IF (RMAX.GT.0.) THEN WRITE(IUNIT8,472) NINSUM, + (LIST(N),N=1,NINSUM) 472 FORMAT(/ + ' AVERAGING TOGETHER THE POSITIONS OF', + ' THESE ',I6,' NODES:',(/' ',12I6)) WRITE (IUNIT8,476) RMAX 476 FORMAT (' MAXIMUM CORRECTION TO ', + 'ANY POSITION IS',1P,E10.2/ + ' YOU ARE RESPONSIBLE FOR ', + ' DECIDING WHETHER THIS IS A', + ' SERIOUS ERR0R!') ENDIF ENDIF ENDIF 480 CONTINUE 490 CONTINUE C C (5) SURVEY STRIKE-SLIP (VERTICAL) FAULTS TO CHECK FOR CONFLICTS IN C ARGUMENT THAT WOULD LOCK THE FAULT. C C LOOP ON ALL FAULT ELEMENTS (I): DO 2000 I=1,NFL C LOOP ON 2 TERMINAL NODE PAIRS, 1-6, 4-3 (J = 1 OR 4): DO 1900 J=1,4,3 C DIP MUST BE WITHIN "WEDGE" OF VERTICAL FOR CONSTRAINT: IF (ABS(FDIP(J,I)-1.570796).LE.WEDGE) THEN NAZI=1+J/4 N1=J N6=7-J NODE1=NODEF(N1,I) NODE6=NODEF(N6,I) C NO CONSTRAINT APPLIED WHERE A FAULT ENDS: IF (NODE1.NE.NODE6) THEN C ENDPOINT PAIRS MUST BE CHECKED FOR DUPLICATION: C LOOK FOR OTHER STRIKE-SLIP FAULTS SHARING THIS C PAIR OF NODES, AT EITHER END: FOUND=.FALSE. DO 1600 L=1,NFL IF (L.NE.I) THEN IF (ABS(FDIP(1,L)-1.5708).LE.WEDGE) THEN IF (((NODE1.EQ.NODEF(1,L)).AND. + (NODE6.EQ.NODEF(6,L))).OR. + ((NODE1.EQ.NODEF(6,L)).AND. + (NODE6.EQ.NODEF(1,L)))) THEN FOUND=.TRUE. NUMBER=L NAZL=1 GO TO 1601 ENDIF ENDIF IF (ABS(FDIP(2,L)-1.5708).LE.WEDGE) THEN IF (((NODE1.EQ.NODEF(3,L)).AND. + (NODE6.EQ.NODEF(4,L))).OR. + ((NODE1.EQ.NODEF(4,L)).AND. + (NODE6.EQ.NODEF(3,L)))) THEN FOUND=.TRUE. NUMBER=L NAZL=2 GO TO 1601 ENDIF ENDIF ENDIF 1600 CONTINUE C DON'T WORRY IF THIS PAIR ALREADY CHECKED! 1601 IF (FOUND.AND.(NUMBER.GT.I)) THEN C AVERAGE ARGUMENTS TOGETHER (AVOID CYCLE SHIFTS): AZI=MOD(FAZ(NAZI,I)+1.570796,3.14159265) + -1.570796 AZL=MOD(FAZ(NAZL,NUMBER)+1.570796,3.14159265) + -1.570796 AZIMUT=0.5*(AZI+AZL) FAZ(NAZI,I)=AZIMUT FAZ(NAZL,NUMBER)=AZIMUT IF (ABS(AZI-AZL).GT.0.02) THEN DAZI=AZI*57.2957795 DAZL=AZL*57.2957795 DAZ=AZIMUT*57.2957795 IF (NODE1.LE.NREALN) THEN NP1=NODE1 ELSE NP1=N1000+NODE1-NREALN ENDIF IF (NODE6.LE.NREALN) THEN NP6=NODE6 ELSE NP6=N1000+NODE6-NREALN ENDIF WRITE (IUNIT8,1610) I,NUMBER,NP1,NP6, + DAZI,DAZL,DAZ 1610 FORMAT(/' WARNING: STRIKE-SLIP FAULT ELEMENTS' + ,I7,' AND',I7/' SHARE NODES',I7,' AND', + I7/' BUT THEIR ARGUMENTS OF ',F6.1, + ' AND ',F6.1,' DEGREES DIFFER SUBSTAN', + 'TIALLY.'/' THE ARGUMENTS WILL BE AVERAGED,' + ,' AND A VALUE OF ',F6.1,' WILL BE USED.' + /' THIS IS NECESSARY TO PREVENT FAULT', + ' LOCKING;'/' IF YOU -WANT- THE FAULT LOCKED' + ,', THEN USE A SINGLE NODE AT THIS POINT.') ENDIF ENDIF C ^END BLOCK WHICH LOOKS FOR CONSTRAINTS ON REAL NODES ENDIF C ^END BLOCK WHICH CHECKS FOR DISTINCT NODE NUMBERS ENDIF C ^END BLOCK WHICH CHECKS FOR DIP OF OVER 75 DEGREES 1900 CONTINUE C ^END LOOP ON 2 NODE PAIRS IN FAULT ELEMENT 2000 CONTINUE C ^END LOOP ON FAULT ELEMENTS C C (6) COMPUTE COORDINATES OF MIDPOINT NODES THAT WERE NOT INPUT. C C FIRST, FAULTS: IF ((.NOT.BRIEF).AND.(NFL.GT.0)) WRITE (IUNIT8,540) 540 FORMAT(/ /' FOLLOWING FAULT MID-POINT POSITIONS WERE COMPUTED:'/ + /' FAULT NODE2 NODE5 X Y'/) DO 550 I=1,NFL I1=NODEF(1,I) I2=NODEF(2,I) I3=NODEF(3,I) I5=NODEF(5,I) DX= XNODE(I3)- XNODE(I1) DY= YNODE(I3)- YNODE(I1) AZ=ATAN2(DY,DX) PHI1=FAZ(1,I)-AZ PHI1=MOD(PHI1+1.570796,3.14159265)-1.570796 PHI2=AZ-FAZ(2,I) PHI2=MOD(PHI2+1.570796,3.14159265)-1.570796 IF ((ABS(PHI1).GT.0.).OR.(ABS(PHI2).GT.0.)) THEN T1=TAN(PHI1) T2=TAN(PHI2) IF (ABS(T2-T1).GE.ABS(T1+T2)) THEN FACTOR=0.99*ABS(T1+T2)/ABS(T2-T1) IF (ABS(T1).GT.ABS(T2)) THEN T2=T1+FACTOR*(T2-T1) ELSE T1=T2+FACTOR*(T1-T2) ENDIF ENDIF PARRAL=(T2-T1)/(4.*(T1+T2)) PERPEN= T1*T2 /(2.*(T1+T2)) XNODE(I2)=XNODE(I1)+DX/2.+PARRAL*DX-PERPEN*DY YNODE(I2)=YNODE(I1)+DY/2.+PERPEN*DX+PARRAL*DY ELSE XNODE(I2)=(XNODE(I1)+XNODE(I3))/2. YNODE(I2)=(YNODE(I1)+YNODE(I3))/2. ENDIF XNODE(I5)= XNODE(I2) YNODE(I5)= YNODE(I2) NTOFIX=NTOFIX-1 IF (.NOT.BRIEF) WRITE (IUNIT8,549) I,I2,I5,XNODE(I2), 1 YNODE(I2) 549 FORMAT(' ',I6,2I10,1P,2E12.4) 550 CONTINUE C C NEXT, OTHER ELEMENT SIDES, IF NEEDED: IF ((.NOT.BRIEF).AND.(NTOFIX.GT.0)) WRITE (IUNIT8,551) 551 FORMAT(/ /' FOLLOWING MID-POINTS OF CONTINUUM ELEMENT SIDES', + ' THAT WERE 0.0 IN THE' + / ' INPUT DATASET ARE NOW COMPUTED, AS FOLLOWS:' + / / ' ELEMENT NODE X Y'/) DO 590 I=1,NUMEL DO 580 J=4,6 N=NODES(J,I) IF ((XNODE(N).EQ.0.).AND.(YNODE(N).EQ.0.)) THEN JP=J-2 IF (J.EQ.6) JP=1 JM=J-3 XNODE(N)=0.5* + (XNODE(NODES(JP,I))+XNODE(NODES(JM,I))) YNODE(N)=0.5* + (YNODE(NODES(JP,I))+YNODE(NODES(JM,I))) IF (.NOT.BRIEF) + WRITE (IUNIT8,579) I,N,XNODE(N),YNODE(N) 579 FORMAT(' ',I6,I10,1P,2E12.4) ENDIF 580 CONTINUE 590 CONTINUE C C (7) COMPUTE AREAS OF ELEMENTS AND COMPUTE DERIVITIVES OF NODAL C FUNCTIONS AT INTEGRATION POINTS; C THEN CHECK FOR NEGATIVE AREAS C CALL AREAS (INPUT,NODES,NUMEL,NUMNOD,XNODE,YNODE, + OUTPUT,AREA) CALL DERIV (INPUT,AREA,NODES,NUMEL,NUMNOD,XNODE,YNODE, + OUTPUT,DETJ,DXS,DYS) ALLOK=.TRUE. DO 620 M=1,7 DO 610 I=1,NUMEL TEST=AREA(I)*DETJ(M,I) IF (TEST.LE.0.) THEN WRITE(IUNIT8,605) M,I 605 FORMAT(/' EXCESSIVELY DISTORTED ELEMENT LEADS TO ' + ,'NEGATIVE AREA AT POINT ',I1,' IN ELEMENT ', + I5) ALLOK=.FALSE. ENDIF 610 CONTINUE 620 CONTINUE IF (.NOT.ALLOK) STOP C C (8) COMPUTE LENGTHS OF FAULT ELEMENTS. C DO 750 I=1,NFL FLEN(I)=0. X1=XNODE(NODEF(1,I)) X2=XNODE(NODEF(2,I)) X3=XNODE(NODEF(3,I)) Y1=YNODE(NODEF(1,I)) Y2=YNODE(NODEF(2,I)) Y3=YNODE(NODEF(3,I)) OLDX=X1 OLDY=Y1 DO 740 J=1,20 S=J/20. F1=1.-3.*S+2.*S**2 F2=4.*S*(1.-S) F3= -S+2.*S**2 X=X1*F1+X2*F2+X3*F3 Y=Y1*F1+Y2*F2+Y3*F3 FLEN(I)=FLEN(I)+SQRT((X-OLDX)**2+(Y-OLDY)**2) OLDX=X OLDY=Y 740 CONTINUE 750 CONTINUE C C (9) MAKE A LIST OF NODES THAT ARE ON THE BOUNDARY AND REQUIRE C BOUNDARY CONDITIONS (NODCON); THESE ARE IN COUNTERCLOCKWISE C ORDER. ALSO MAKE A LISTS OF ELEMENT SIDES WHICH CONTAIN THESE C NODES: EDGETS AND EDGEFS. C NCOND=0 DO 801 I=1,NUMNOD CHECKN(I)=.FALSE. 801 CONTINUE DO 802 I=1,NFL EDGEFS(1,I)=.FALSE. EDGEFS(2,I)=.FALSE. 802 CONTINUE DO 810 I=1,NUMEL DO 809 J=1,3 CALL NEXT (INPUT,I,J,MXEL,MXFEL,NFL,NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) IF (KELE.GT.0) THEN C (ORDINARY INTERIOR SIDE) EDGETS(J,I)=.FALSE. ELSE IF (KFAULT.EQ.0) THEN C (EXTERIOR SIDE) EDGETS(J,I)=.TRUE. N1=NODES(MOD(J, 3)+1,I) N2=NODES(MOD(J, 3)+4,I) N3=NODES(MOD(J+1,3)+1,I) IF (.NOT.CHECKN(N1)) THEN NCOND=NCOND+1 CHECKN(N1)=.TRUE. ENDIF IF (.NOT.CHECKN(N2)) THEN NCOND=NCOND+1 CHECKN(N2)=.TRUE. ENDIF IF (.NOT.CHECKN(N3)) THEN NCOND=NCOND+1 CHECKN(N3)=.TRUE. ENDIF ELSE C (TRIANGULAR ELEMENT HAS AN EXTERIOR FAULT ELEMENT C ADJACENT TO IT) EDGETS(J,I)=.FALSE. N2=NODES(MOD(J, 3)+4,I) IF (NODEF(2,KFAULT).EQ.N2) THEN EDGEFS(2,KFAULT)=.TRUE. DO 806 K=4,6 N=NODEF(K,KFAULT) IF (.NOT.CHECKN(N)) THEN NCOND=NCOND+1 CHECKN(N)=.TRUE. ENDIF 806 CONTINUE ELSE EDGEFS(1,KFAULT)=.TRUE. DO 808 K=1,3 N=NODEF(K,KFAULT) IF (.NOT.CHECKN(N)) THEN NCOND=NCOND+1 CHECKN(N)=.TRUE. ENDIF 808 CONTINUE ENDIF ENDIF 809 CONTINUE 810 CONTINUE IF (NCOND.GT.MXBN) THEN WRITE(IUNIT8,820) NCOND 820 FORMAT(/' INCREASE PARAMETER MAXBN TO',I6,' AND RECOMPILE.') STOP ENDIF IF (NUMNOD.GT.NREALN) THEN DO 824 I=NREALN+1,NUMNOD IF (.NOT.CHECKN(I)) THEN IO=N1000+I-NREALN WRITE(IUNIT8,822) IO 822 FORMAT(' BAD GRID TOPOLOGY; FAKE NODES ARE NOT', + ' PERMITTED IN THE INTERIOR.'/' CHECK NODE ',I6) STOP ENDIF 824 CONTINUE ENDIF C BEGIN CIRCUIT WITH LOWEST-NUMBERED BOUNDARY NODE DO 830 I=1,NUMNOD IF (CHECKN(I)) GO TO 831 830 CONTINUE 831 NODCON(1)=I NDONE=1 NLEFT=NCOND C BEGINNING OF INDEFINATE LOOP WHICH TRACES AROUND THE PERIMETER. C EACH TIME, IT PROGRESSES BY ONE OF 3 STEPS: C -2 NODES AT A TIME ALONG A TRIANGLE SIDE, OR C -2 NODES AT A TIME ALONG A FAULT ELEMENT SIDE, OR C -BY FINDING ANOTHER (CORNER) NODE WHICH SHARES THE SAME LOCATION. C FIRST, BE SURE THAT WE ARE NOT STARTING ON A MIDPOINT: IF (NODTYP(I).EQ.2) THEN DO 833 K=1,NUMEL DO 832 L=1,3 IF (EDGETS(L,K)) THEN N2=NODES(MOD(L, 3)+4,K) IF (N2.EQ.I) THEN J=NODES(MOD(L+1,3)+1,K) GO TO 839 ENDIF ENDIF 832 CONTINUE 833 CONTINUE DO 835 K=1,NFL IF (EDGEFS(1,K)) THEN IF (NODEF(2,K).EQ.I) THEN J=NODEF(3,K) GO TO 839 ENDIF ELSE IF (EDGEFS(2,K)) THEN IF (NODEF(5,K).EQ.I) THEN J=NODEF(6,K) GO TO 839 ENDIF ENDIF 835 CONTINUE 839 NDONE=2 NODCON(2)=J NLEFT=NCOND-1 ENDIF C BEGINNING OF MAIN INDEFINATE LOOP: 840 NODE=NODCON(NDONE) X=XNODE(NODE) Y=YNODE(NODE) C LOOK FOR AN ADJACENT TRIANGULAR ELEMENT USING THIS NODE. DO 844 I=1,NUMEL DO 842 J=1,3 IF (EDGETS(J,I)) THEN N1=NODES(MOD(J,3)+1,I) IF (N1.EQ.NODE) GO TO 846 ENDIF 842 CONTINUE 844 CONTINUE GO TO 850 846 N2=NODES(MOD(J,3)+4,I) NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N2 CHECKN(N2)=.FALSE. N3=NODES(MOD(J+1,3)+1,I) NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N3 CHECKN(N3)=.FALSE. NLEFT=NLEFT-2 IF (NLEFT.GT.0) THEN GO TO 840 ELSE GO TO 870 ENDIF C ELSE, LOOK FOR AN ADJACENT FAULT ELEMENT USING THIS NODE. 850 DO 854 I=1,NFL IF (EDGEFS(1,I)) THEN IF (NODEF(1,I).EQ.NODE) THEN N2=NODEF(2,I) N3=NODEF(3,I) GO TO 856 ENDIF ELSE IF (EDGEFS(2,I)) THEN IF (NODEF(4,I).EQ.NODE) THEN N2=NODEF(5,I) N3=NODEF(6,I) GO TO 856 ENDIF ENDIF 854 CONTINUE GO TO 860 856 NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N2 CHECKN(N2)=.FALSE. NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N3 CHECKN(N3)=.FALSE. NLEFT=NLEFT-2 IF (NLEFT.GT.0) THEN GO TO 840 ELSE GO TO 870 ENDIF C ELSE, LOOK FOR ANOTHER EXTERIOR CORNER NODE AT SAME LOCATION. 860 DO 865 I=1,NUMNOD IF ((I.NE.NODE).AND.CHECKN(I)) THEN IF ((NODTYP(I).EQ.1).AND. + ((XNODE(I).EQ.X).AND.(YNODE(I).EQ.Y)))GO TO 867 ENDIF 865 CONTINUE WRITE(IUNIT8,866) NODE 866 FORMAT(' BAD GRID TOPOLOGY: WHILE TRACING PERIMETER,'/ + ' COULD NOT FIND ANY WAY TO CONTINUE FROM NODE ',I6/ + ' EITHER THROUGH SHARED BOUNDARY ELEMENTS, OR'/ + ' THROUGH OTHER BOUNDARY NODES SHARING THE SAME ', + 'POSITION.') STOP 867 NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=I CHECKN(I)=.FALSE. NLEFT=NLEFT-1 IF (NLEFT.GT.0) GO TO 840 C END OF INDEFINATE LOOP WHICH TRACES AROUND PERIMETER. 870 IF (.NOT.BRIEF) THEN WRITE(IUNIT8,880) 880 FORMAT(/ /' HERE FOLLOWS A LIST, IN CONSECUTIVE ORDER,'/ + ' OF THE NODES WHICH DEFINE THE PERIMETER'/ + ' OF THE MODEL; THESE NODES REQUIRE BOUNDARY', + ' CONDITIONS:'/' BC# NODE') DO 890 I=1,NCOND N=NODCON(I) IF (N.GT.NREALN) N=N1000+N-NREALN WRITE(IUNIT8,882) I, N 882 FORMAT(' ',2I6) 890 CONTINUE N=NODCON(1) IF (N.GT.NREALN) N=N1000+N-NREALN WRITE (IUNIT8,892) N 892 FORMAT(' (NOTE: NODE ',I6,' COMPLETES THE LOOP, BUT WILL', + ' NOT BE LISTED TWICE.)') ENDIF C C (10) SURVEY FAULT ELEMENTS AND ISSUE WARNING IF ANY ELEMENT IS OF C MIXED TYPE (PART STRIKE-SLIP, AND PART SHALLOW-DIPPING: C DO 920 I=1,NFL DELD1=FDIP(1,I)-1.570796 DELD2=FDIP(2,I)-1.570796 DELD3=FDIP(3,I)-1.570796 VERT1=ABS(DELD1).LE.WEDGE VERT2=ABS(DELD2).LE.WEDGE VERT3=ABS(DELD3).LE.WEDGE NVPART=0 IF (VERT1) THEN NVPART=NVPART+1 TAG1=VERTIC ELSE TAG1=OBLIQU ENDIF IF (VERT2) THEN NVPART=NVPART+1 TAG2=VERTIC ELSE TAG2=OBLIQU ENDIF IF (VERT3) THEN NVPART=NVPART+1 TAG3=VERTIC ELSE TAG3=OBLIQU ENDIF SWITCH=((NVPART.GT.0).AND.(NVPART.LT.3)) IF (SWITCH) THEN DIP1=FDIP(1,I)*57.2957795 IF (DIP1.GT.90.) DIP1=DIP1-180. DIP2=FDIP(2,I)*57.2957795 IF (DIP2.GT.90.) DIP2=DIP2-180. DIP3=FDIP(3,I)*57.2957795 IF (DIP3.GT.90.) DIP3=DIP3-180. WRITE (IUNIT8,905) I,DIP1,TAG1,DIP2,TAG2,DIP3,TAG3 905 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES ',A21/ + ' ',F7.2,' DEGREES ',A21/ + ' ',F7.2,' DEGREES ',A21/ + ' WHICH MAKES IT MIXED-MODE.'/ + ' SUCH ELEMENTS ARE INACCURATE AND NOT RECOMMENDED.'/ + ' PREFERABLY EACH ELEMENT SHOULD BE OF A SINGLE TYPE.'/ + ' (REMEMBER, DIP NEED NOT BE CONTINUOUS FROM ONE', + ' FAULT ELEMENT TO THE NEXT.)') ELSE NVPART=0 DO 910 M=1,7 DELD=DELD1*FPHI(1,M)+DELD2*FPHI(2,M)+ + DELD3*FPHI(3,M) IF (ABS(DELD).LE.WEDGE) NVPART=NVPART+1 910 CONTINUE IF ((NVPART.GT.0).AND.(NVPART.LT.7)) THEN IF (NVPART.GE.4) THEN WRITE (IUNIT8,912) I,DIP1,DIP2,DIP3 912 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES,'/ + ' ',F7.2,' DEGREES, AND'/ + ' ',F7.2,' DEGREES'/ + ' WHICH APPEAR TO MAKE IT STRIKE-SLIP.'/ + ' HOWEVER, THESE VALUES ARE SUCH THAT DIP-SLIP'/ + ' IS PERMITTED AT ONE OR MORE INTEGRATION POINTS.'/ + ' SUCH ELEMENTS ARE INACCURATE AND NOT RECOMMENDED.'/ + ' PREFERABLY EACH ELEMENT SHOULD BE OF A SINGLE TYPE.'/ + ' (REMEMBER, DIP NEED NOT BE CONTINUOUS FROM ONE', + ' FAULT ELEMENT TO THE NEXT.)') ELSE WRITE (IUNIT8,914) I,DIP1,DIP2,DIP3 914 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES,'/ + ' ',F7.2,' DEGREES, AND'/ + ' ',F7.2,' DEGREES'/ + ' WHICH APPEAR TO MAKE IT FREE-SLIPPING.'/ + ' HOWEVER, THESE VALUES ARE SUCH THAT DIP-SLIP'/ + ' IS PROHIBITED AT ONE OR MORE INTEGRATION POINTS.'/ + ' SUCH ELEMENTS ARE INACCURATE AND NOT RECOMMENDED.'/ + ' PREFERABLY EACH ELEMENT SHOULD BE OF A SINGLE TYPE.'/ + ' (REMEMBER, DIP NEED NOT BE CONTINUOUS FROM ONE', + ' FAULT ELEMENT TO THE NEXT.)') ENDIF ENDIF ENDIF 920 CONTINUE C C (11) CALCULATE FAULT ARGUMENT (IN RADIANS, MEASURED COUNTERCLOCKWISE C FROM +X) FOR EACH INTEGRATION POINT IN EACH FAULT ELEMENT. C DO 1000 M=1,7 S=FPOINT(M) DF1DS= -3.+4.*S DF2DS=4.-8.*S DF3DS= -1.+4.*S DO 900 I=1,NFL N1=NODEF(1,I) N2=NODEF(2,I) N3=NODEF(3,I) X1=XNODE(N1) X2=XNODE(N2) X3=XNODE(N3) Y1=YNODE(N1) Y2=YNODE(N2) Y3=YNODE(N3) DXDS=X1*DF1DS+X2*DF2DS+X3*DF3DS DYDS=Y1*DF1DS+Y2*DF2DS+Y3*DF3DS FTAN(M,I)=ATAN2(DYDS,DXDS) 900 CONTINUE 1000 CONTINUE C IF (.NOT. BRIEF) WRITE (IUNIT8,9999) 9999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE SQUEEZ (INPUT,ALPHAT,ELEVAT,GEOTH1,GEOTH2, + GEOTH3,GEOTH4,GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, + TEMLIM,THICK, + OUTPUT,TAUZZ,SIGZZB) C C CALCULATES "TAUZZ", THE VERTICAL INTEGRAL THROUGH THE CRUST C OF THE VERTICAL STRESS ANOMALY, WHICH IS C RELATIVE TO A COLUMN OF MANTLE AT ASTHENOSPHERE TEMPERATURE C WITH A 5 KM CRUST AND A 2.7 KM OCEAN ON TOP, LIKE A MID-OCEAN C RISE. THE INTEGRAL IS FROM EITHER THE LAND SURFACE OR THE C SURFACE, DOWN TO A DEPTH OF "THICK" INTO THE CRUST. C ALSO RETURNS "SIGZZB", THE VERTICAL STRESS ANOMALY C AT DEPTH "THICK" BELOW THE SOLID ROCK SURFACE. C NOTE: THIS VERSION IS DIFFERENT FROM THE VERSION FOUND IN THE LARAMY C PROGRAM PACKAGE. FIRST, IT ACTS ON ONLY A SINGLE POINT. C SECOND, IT INFERS THE MANTLE-LITHOSPHERE WEIGHT INDIRECTLY FROM C THE GIVEN TOPOGRAPHY, INSTEAD OF FROM ITS INTERNAL STRUCTURE. C PARAMETER (NDREF=100) LOGICAL CALLED DIMENSION DREF(NDREF),PREF(0:NDREF) SAVE CALLED,DREF,PREF DATA CALLED /.FALSE./ C C STATEMENT FUNCTION: TEMP(H)=MIN(TEMLIM,GEOTH1+GEOTH2*H+GEOTH3*H**2 + +GEOTH4*H**3) C C CREATE REFERENCE TEMPERATURE & DENSITY PROFILES TO DEPTH OF NDREF KM C IF (.NOT.CALLED) THEN RHOTOP=RHOBAR*(1.-ALPHAT*GEOTH1) DREF(1)=RHOH2O DREF(2)=RHOH2O DREF(3)=0.7*RHOH2O+0.3*RHOTOP DREF(4)=RHOTOP DREF(5)=RHOTOP DREF(6)=RHOTOP DREF(7)=RHOTOP DREF(8)=0.7*RHOTOP+0.3*RHOAST DO 50 J=9,NDREF DREF(J)=RHOAST 50 CONTINUE PREF(0)=0. DO 100 I=1,NDREF PREF(I)=PREF(I-1)+DREF(I)*GMEAN*ONEKM 100 CONTINUE CALLED=.TRUE. ENDIF C C ROUTINE PROCESSING (ON EVERY CALL): C IF (ELEVAT.GT.0.) THEN ZTOP= -ELEVAT ZBASE=THICK-ELEVAT DENSE1=RHOBAR*(1.-GEOTH1*ALPHAT) H=0. ELSE ZTOP=0. ZBASE=THICK+(-ELEVAT) DENSE1=RHOH2O H=ELEVAT ENDIF LASTDR=ZBASE/ONEKM IF (ZBASE.GT.ONEKM*LASTDR) LASTDR=LASTDR+1 IF (LASTDR.GT.NDREF) THEN WRITE(IUNITT,110) LASTDR 110 FORMAT(' IN SUBPROGRAM SQUEEZ, PARAMETER NDREF '/ + ' MUST BE INCREASED TO AT LEAST ',I10) STOP ENDIF NSTEP=(ZBASE-ZTOP)/ONEKM OLDSZZ=0. OLDPR=0. SIGZZ=0. TAUZZ=0. Z=ZTOP DO 200 I=1,NSTEP Z=Z+ONEKM H=H+ONEKM IF (H.GT.0.) THEN T=TEMP(H) DENSE2=RHOBAR*(1.-T*ALPHAT) ELSE DENSE2=RHOH2O ENDIF DENSE=0.5*(DENSE1+DENSE2) IF (Z.GT.0.) THEN N1=Z/ONEKM N2=N1+1 FRAC=Z/ONEKM-N1 PR=PREF(N1)+FRAC*(PREF(N2)-PREF(N1)) ELSE PR=0. ENDIF SIGZZ=SIGZZ-DENSE*GMEAN*ONEKM+(PR-OLDPR) TAUZZ=TAUZZ+0.5*(SIGZZ+OLDSZZ)*ONEKM DENSE1=DENSE2 OLDSZZ=SIGZZ OLDPR=PR 200 CONTINUE RESID=ZBASE-Z H=THICK Z=ZBASE T=TEMP(H) DENSE2=RHOBAR*(1.-T*ALPHAT) DENSE=0.5*(DENSE1+DENSE2) IF (Z.GT.0.) THEN N1=Z/ONEKM N2=N1+1 FRAC=Z/ONEKM-N1 PR=PREF(N1)+FRAC*(PREF(N2)-PREF(N1)) ELSE PR=0. ENDIF SIGZZB=SIGZZ-DENSE*GMEAN*RESID+(PR-OLDPR) TAUZZ=TAUZZ+0.5*(SIGZZB+OLDSZZ)*RESID RETURN END C C C SUBROUTINE TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) C C COMPUTES VERTICAL INTEGRALS OF RELATIVE OR DEVIATORIC C STRESS (TAUMAT). C C THE COMPONENTS ARE: C TAUMAT(1) = VERTICAL INTEGRAL OF (SXX-SZZ) C TAUMAT(2) = VERTICAL INTEGRAL OF (SYY-SZZ) C TAUMAT(3) = VERTICAL INTEGRAL OF SXY. C DIMENSION ALPHA(3,3,7,MXEL),ERATE(3,7,MXEL), + TAUMAT(3,7,MXEL),TOFSET(3,7,MXEL) C DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) TAUMAT(1,M,I)=TOFSET(1,M,I)+EXX*ALPHA(1,1,M,I)+ + EYY*ALPHA(1,2,M,I)+EXY*ALPHA(1,3,M,I) TAUMAT(2,M,I)=TOFSET(2,M,I)+EXX*ALPHA(2,1,M,I)+ + EYY*ALPHA(2,2,M,I)+EXY*ALPHA(2,3,M,I) TAUMAT(3,M,I)=TOFSET(3,M,I)+EXX*ALPHA(3,1,M,I)+ + EYY*ALPHA(3,2,M,I)+EXY*ALPHA(3,3,M,I) 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE THONC (INPUT,ECREEP,ETAMAX,GLUE, + MXEL,MXNODE,NODES,NUMEL,NUMNOD, + V,VM,ZMOHO, + OUTPUT,DVB,OVB,SIGHB, + WORK,OUTVEC) C C CALCULATES SHEAR STRESSES ON BASE OF CRUST (SIGHB), AND C THE VECTOR VELOCITY OF THE LAYER BELOW (OVB), AND C THE SCALAR VELOCITY DIFFERENCE OF THE LAYER BELOW (DVB). C DOUBLE PRECISION V,VM DIMENSION DVB(7,MXEL), + GLUE(7,MXEL), + NODES(6,MXEL),OUTVEC(2,7,MXEL), + OVB(2,7,MXEL), + SIGHB(2,7,MXEL), + V(2,MXNODE),VM(2,MXNODE),ZMOHO(7,MXEL) C CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,V, + OUTPUT,OUTVEC) CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,VM, + OUTPUT,OVB) DO 1000 M=1,7 DO 900 I=1,NUMEL VCX=OUTVEC(1,M,I) VCY=OUTVEC(2,M,I) VMX=OVB(1,M,I) VMY=OVB(2,M,I) VRX=VMX-VCX VRY=VMY-VCY VMAG=SQRT((1.D0*VRX)**2+(1.D0*VRY)**2) DVB(M,I)=VMAG IF (VMAG.GT.0.) THEN DVX=VRX/VMAG DVY=VRY/VMAG SHEAR1=GLUE(M,I)*VMAG**ECREEP ELSE DVX=0. DVY=0. SHEAR1=0. ENDIF SHEAR2=ETAMAX*VMAG SHEAR=MIN(SHEAR1,SHEAR2) DECOLL=(SHEAR/GLUE(M,I))**(1./ECREEP) SIGHB(1,M,I)=SHEAR*DVX SIGHB(2,M,I)=SHEAR*DVY 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE VISCOS (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,DCREEP,ECREEP, + ERATE,FRIC,G,GEOTH, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM, + VISMAX,ZMOHO, + OUTPUT,ALPHA,SCOREC,SCORED,TOFSET,ZTRANC) C C Computes tactical partial-derivitive tensor ALPHA(3,3,7,NUMEL) C (partial derivitives of vertically-integrated stresses C tau.ij [where normal components are relative to vertical stress] C with respect to strain-rates e.kl) C in 3 x 3 component form, from 2 x 2 principal-axis form C provided by DIAMND, at each integration point of each element. C Also records intercept values (TOFSET(3,7,NUMEL)) for next iteration C Calculation of TAUMAT = TOFSET + ALPHA*E will give model C relative stress integrals (relative to vertical stress integral). C ZTRANC(7,NUMEL) is the depth into the crust where C the brittle/ductile transition occurs, for each integration point C of each element. Note: "C" in the name stands for "Continuum" C (as opposed to Fault). C SCOREC and SCORED are measures of mismatch between current C linearized and actual nonlinear rheologies: C SCOREC is the maximum (absolute value) error in tau [N/m]; C SCORED is the mean-error/mean-value [dimensionless; <=1?]. C C New version, May 5, 1998, by Peter Bird; intended to improve C the convergence behavior of all F-E programs which use it. C For an elementary (not comprehensive) test of VISCOS, C see test program ISOTROPY.for, 1998.4.18, which shows that C it preserves linear-viscous behavior in all 3 branches C of its code (when linear-viscous behavior is reported by DIAMND). C C This new version is specific to FAULTS: C *expects parameters ACREEP, ALPHAT, BCREEP, CCREEP, DCREEP, C RHOBAR, TEMLIM to be scalars, not 2- C component (crust/mantle) vectors; C *expects one input array GEOTH instead of GEOTHC and GEOTHM; C *does not expect an input array TLINT of mantle lithosphere; C *internal variable THICKM is eliminated; C *calls DIAMND only once per integration point (Note: DIAMND C is the same in all programs now!) C *reports results as ZTRANC(7,NUMEL), not ZTRANC(2,7,NUMEL). C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C External variables and arrays INTEGER I, INPUT, M, MXEL, NUMEL REAL BIOT, ECREEP, FRIC, G, + OUTPUT, RHOH2O, SCOREC, SCORED, VISMAX REAL ACREEP, ALPHA(3,3,7,MXEL), + ALPHAT, BCREEP, + CCREEP, DCREEP, + ERATE(3,7,MXEL), + GEOTH(4,7,MXEL), + RHOBAR, SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL), TEMLIM, + TOFSET(3,7,MXEL), + ZMOHO(7,MXEL), ZTRANC(7,MXEL) C External function: REAL ATAN2F C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C Internal variables and arrays: REAL CENTER, DELP2, DENOM, DENOM0, DENOM1, DIVER, + DANDEX, DANDEY, DANDES, + DE1DEX, DE1DEY, DE1DES, + DE2DEX, DE2DEY, DE2DES, + DTSDE1, DTSDE2, + DTSDT1, DTSDT2, DTSDAN, + DTXDE1, DTXDE2, + DTXDT1, DTXDT2, DTXDAN, + DTYDE1, DTYDE2, + DTYDT1, DTYDT2, DTYDAN, + DT1DE1, DT1DE2, DT2DE1, DT2DE2, + DXX, DXY, DYY, + EXX, EXY, EYY, E1, E2, PL0, PW0, + PT1DE1, PT1DE2, PT2DE1, PT2DE2, + PT1, PT2, PTXX, PTXY, PTYY, + R, RHOUSE, + SHEAR, SHEAR2, SIGHBI, + THETA, THICKC, TMEAN, TXX, TXY, TYY, + ZOFTOP, ZTRAN C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C C Initialize sums to be used in computation of scores: SCOREC=0. SCORED=0. DENOM0=0. DENOM1=0. C DO 1000 M=1,7 DO 900 I=1,NUMEL C C ----------- rheology (& ZTRANC) section ------------ C C Extract data for this integration point, as scalars: SIGHBI=SQRT((1.D0*SIGHB(1,M,I))**2+ + (1.D0*SIGHB(2,M,I))**2) THICKC=ZMOHO(M,I) EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) C C Guard against special case of zero strain-rate: IF ((EXX.EQ.0.).AND.(EXY.EQ.0.).AND.(EYY.EQ.0.)) THEN TXX=0. TXY=0. TYY=0. C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) ALPHA(1,1,M,I)=4.*VISMAX*THICKC ALPHA(1,2,M,I)=2.*VISMAX*THICKC ALPHA(1,3,M,I)=0. ALPHA(2,1,M,I)=2.*VISMAX*THICKC ALPHA(2,2,M,I)=4.*VISMAX*THICKC ALPHA(2,3,M,I)=0. ALPHA(3,1,M,I)=0. ALPHA(3,2,M,I)=0. ALPHA(3,3,M,I)=2.*VISMAX*THICKC TOFSET(1,M,I)=0. TOFSET(2,M,I)=0. TOFSET(3,M,I)=0. ZTRANC(M,I)=0. C Note: "C" is for Continuum, not for Crust! ELSE C (strain-rate tensor is not zero) C Find principal strain-rates (E1 <= E2) C in the horizontal plane: DIVER=EXX+EYY R=SQRT((1.D0*EXY)**2+(0.5D0*(EXX-EYY))**2) E1=0.5*DIVER-R E2=0.5*DIVER+R THETA=ATAN2F(2.*EXY,EXX-EYY) C see (29) of Bird (1989); C THETA is like angular coordinate of Mohr's circles C of strain-rate and also of stress; C THETA = 0 when EXX > EYY and EXY =0; C THETA = small, + when EXY > 0, EXX > EYY; C THETA = Pi when EXY = 0, EYY > EXX. C C Prepare to sum tau (and derivitives) over layers: TXX=0. TXY=0. TYY=0. DT1DE1=0. DT1DE2=0. DT2DE1=0. DT2DE2=0. C IF (THICKC.GT.0) THEN ZOFTOP=0. PL0=0. PW0=0. CALL DIAMND (INPUT,ACREEP,ALPHAT, + BCREEP,BIOT, + CCREEP,DCREEP, + ECREEP, + E1,E2,FRIC,G, + GEOTH(1,M,I), + GEOTH(2,M,I), + GEOTH(3,M,I), + GEOTH(4,M,I), + PL0,PW0, + RHOBAR,RHOH2O,SIGHBI, + THICKC,TEMLIM, + VISMAX,ZOFTOP, + OUTPUT,PT1DE1,PT1DE2, + PT2DE1,PT2DE2, + PT1,PT2,ZTRAN) CENTER=0.5*(PT1+PT2) SHEAR=0.5*(PT2-PT1) PTXX=CENTER+SHEAR*COS(THETA) PTYY=CENTER-SHEAR*COS(THETA) PTXY=SHEAR*SIN(THETA) C Add contribution of crust to total: TXX=TXX+PTXX TXY=TXY+PTXY TYY=TYY+PTYY DT1DE1=DT1DE1+PT1DE1 DT1DE2=DT1DE2+PT1DE2 DT2DE1=DT2DE1+PT2DE1 DT2DE2=DT2DE2+PT2DE2 ZTRANC(M,I)=ZTRAN ELSE ZTRANC(M,I)=0. END IF C C ---------- ALPHA and TOFSET section ------------- C (cases of non-zero strain-rate) C IF (R.LE.0.) THEN C Pathological case: EXY = 0, EXX = EYY /= 0. C See notes from derivations of 18 April 1998; C based on (28) of Bird(1989), but not using C (29) because r = 0 and alpha is undefined. C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) ALPHA(1,1,M,I)=DT2DE2 ALPHA(1,2,M,I)=DT1DE2 ALPHA(1,3,M,I)=0. ALPHA(2,1,M,I)=DT1DE2 ALPHA(2,2,M,I)=DT2DE2 ALPHA(2,3,M,I)=0. ALPHA(3,1,M,I)=0. ALPHA(3,2,M,I)=0. ALPHA(3,3,M,I)=0.5*(DT1DE1-DT2DE1- + DT1DE2+DT2DE2) ELSE C typical case, r > 0: see p. 3976 in Bird (1989). DE1DEX=0.5-((EXX-EYY)/(4.*R)) DE1DEY=0.5+((EXX-EYY)/(4.*R)) DE1DES= -EXY/R DE2DEX=DE1DEY DE2DEY=DE1DEX DE2DES= -DE1DES DANDEX= -SIN(THETA)/(2.*R) C Note: Formula above is equivalent to (29) of C Bird (1989), but less likely to be singular. DANDEY= -DANDEX DANDES=COS(THETA)/R C Note: Formula above is equivalent to (29) of C Bird (1989), but less likely to be singular. DTXDT1=0.5*(1.-COS(THETA)) DTXDT2=0.5*(1.+COS(THETA)) DTXDAN= -TXY DTYDT1=DTXDT2 DTYDT2=DTXDT1 DTYDAN=TXY DTSDT1= -0.5*SIN(THETA) DTSDT2= -DTSDT1 SHEAR=SQRT(TXY**2+(0.5*(TXX-TYY))**2) DTSDAN=SHEAR*COS(THETA) C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) DTXDE1=DTXDT1*DT1DE1+DTXDT2*DT2DE1 DTXDE2=DTXDT1*DT1DE2+DTXDT2*DT2DE2 ALPHA(1,1,M,I)= + DTXDE1*DE1DEX+DTXDE2*DE2DEX+DTXDAN*DANDEX ALPHA(1,2,M,I)= + DTXDE1*DE1DEY+DTXDE2*DE2DEY+DTXDAN*DANDEY ALPHA(1,3,M,I)= + DTXDE1*DE1DES+DTXDE2*DE2DES+DTXDAN*DANDES DTYDE1=DTYDT1*DT1DE1+DTYDT2*DT2DE1 DTYDE2=DTYDT1*DT1DE2+DTYDT2*DT2DE2 ALPHA(2,1,M,I)= + DTYDE1*DE1DEX+DTYDE2*DE2DEX+DTYDAN*DANDEX ALPHA(2,2,M,I)= + DTYDE1*DE1DEY+DTYDE2*DE2DEY+DTYDAN*DANDEY ALPHA(2,3,M,I)= + DTYDE1*DE1DES+DTYDE2*DE2DES+DTYDAN*DANDES DTSDE1=DTSDT1*DT1DE1+DTSDT2*DT2DE1 DTSDE2=DTSDT1*DT1DE2+DTSDT2*DT2DE2 ALPHA(3,1,M,I)= + DTSDE1*DE1DEX+DTSDE2*DE2DEX+DTSDAN*DANDEX ALPHA(3,2,M,I)= + DTSDE1*DE1DEY+DTSDE2*DE2DEY+DTSDAN*DANDEY ALPHA(3,3,M,I)= + DTSDE1*DE1DES+DTSDE2*DE2DES+DTSDAN*DANDES END IF C ----------- TOFSET section ------------------ C (case of non-zero strain rate) TOFSET(1,M,I)=TXX-ALPHA(1,1,M,I)*EXX + -ALPHA(1,2,M,I)*EYY + -ALPHA(1,3,M,I)*EXY TOFSET(2,M,I)=TYY-ALPHA(2,1,M,I)*EXX + -ALPHA(2,2,M,I)*EYY + -ALPHA(2,3,M,I)*EXY TOFSET(3,M,I)=TXY-ALPHA(3,1,M,I)*EXX + -ALPHA(3,2,M,I)*EYY + -ALPHA(3,3,M,I)*EXY END IF CC C ---------- SCORE section ----------------- C C Build tentative denominator for score, based C on old values of TAUMAT (tau relative to vertical). DELP2=(0.5*(TAUMAT(1,M,I)+TAUMAT(2,M,I)))**2 SHEAR2=TAUMAT(3,M,I)**2+ + (0.5*(TAUMAT(1,M,I)-TAUMAT(2,M,I)))**2 DENOM0=DENOM0+SQRT(MAX(DELP2,SHEAR2)) C C Build alternative denominator for score, based C on new values of TXX,TXY,TYY (tau relative to vertical). DELP2=(0.5*(TXX+TYY))**2 SHEAR2=TXY**2+(0.5*(TXX-TYY))**2 DENOM1=DENOM1+SQRT(MAX(DELP2,SHEAR2)) C C Evaluate difference between old and new tau: DXX=TAUMAT(1,M,I)-TXX DYY=TAUMAT(2,M,I)-TYY DXY=TAUMAT(3,M,I)-TXY DELP2=(0.5*(DXX+DYY))**2 SHEAR2=(0.5*(DXX-DYY))**2+DXY**2 SCOREC=MAX(SCOREC,SQRT(DELP2),SQRT(SHEAR2)) SCORED=SCORED+SQRT(MAX(DELP2,SHEAR2)) C 900 CONTINUE 1000 CONTINUE C C In computing SCORED, use larger of (old, new) denominators: DENOM=MAX(DENOM0,DENOM1) IF (DENOM.GT.0.) THEN SCORED=SCORED/DENOM ELSE SCORED=0.0 END IF C C NOTE: SCOREC is already computed in loop above. C RETURN END C C C BLOCK DATA BD1 C C DEFINE "PHI" (NODAL FUNCTIONS) AND "WEIGHT" (GAUSSIAN INTEGRATION C WEIGHTS) OF THE 6-NODE TRIANGULAR FINITE ELEMENT FOR THE C SEVEN INTEGRATION POINTS IN EACH ELEMENT, DEFINED BY INTERNAL C COORDINATES "POINTS(5,7)", WHERE POINTS(1-3,M)=S1-S3 OF C INTEGRATION POINT NUMBER M. (NOTE: POINTS(4,M)=POINTS(1,M) AND C POINTS(5,M)=POINTS(2,M), FOR PROGRAMMING CONVENIENCE, AS IN C SUBPROGRAM "DERIV".) C BECAUSE ALL OF THESE ARRAYS ARE FUNCTIONS OF INTERNAL C COORDINATES, THEY ARE NOT AFFECTED BY SCALING OR DEFORMATION OF C THE ELEMENTS. C DOUBLE PRECISION PHI,POINTS,WEIGHT COMMON /S1S2S3/ POINTS COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) C C "PHI" CONTAINS THE VALUES OF THE 6 NODAL FUNCTIONS AT THE 7 C GAUSSIAN INTEGRATION POINTS (FOR AREA INTEGRALS) OF THE C TRIANGULAR ELEMENTS. DATA PHI / +-0.1111111111111111D0,-0.1111111111111111D0,-0.1111111111111111D0, + 0.4444444444444444D0, 0.4444444444444444D0, 0.4444444444444444D0, +-0.0525839022774079D0,-0.0280749439026853D0,-0.0280749439026853D0, + 0.1122997756107412D0, 0.8841342388612960D0, 0.1122997756107412D0, +-0.0280749439026853D0,-0.0525839022774079D0,-0.0280749439026853D0, + 0.1122997756107412D0, 0.1122997756107412D0, 0.8841342388612960D0, +-0.0280749439026853D0,-0.0280749439026853D0,-0.0525839022774079D0, + 0.8841342388612960D0, 0.1122997756107412D0, 0.1122997756107412D0, + 0.4743526114618935D0,-0.0807685938011933D0,-0.0807685938011933D0, + 0.3230743752047730D0, 0.0410358257309469D0, 0.3230743752047730D0, +-0.0807685938011933D0, 0.4743526114618935D0,-0.0807685938011933D0, + 0.3230743752047730D0, 0.3230743752047730D0, 0.0410358257309469D0, +-0.0807685938011933D0,-0.0807685938011933D0, 0.4743526114618935D0, + 0.0410358257309469D0, 0.3230743752047730D0, 0.3230743752047730D0/ C C "POINTS" CONTAINS THE INTERNAL COORDINATES (S1,S2,S3) OF THE 7 C GAUSSIAN INTEGRATION POINTS (FOR AREA INTEGRALS) OF THE C TRIANGULAR ELEMENTS. DATA POINTS / + 0.3333333333333333D0, 0.3333333333333333D0, 0.3333333333333333D0, + 0.3333333333333333D0, 0.3333333333333333D0, + 0.0597158733333333D0, 0.4701420633333333D0, 0.4701420633333333D0, + 0.0597158733333333D0, 0.4701420633333333D0, + 0.4701420633333333D0, 0.0597158733333333D0, 0.4701420633333333D0, + 0.4701420633333333D0, 0.0597158733333333D0, + 0.4701420633333333D0, 0.4701420633333333D0, 0.0597158733333333D0, + 0.4701420633333333D0, 0.4701420633333333D0, + 0.7974269866666667D0, 0.1012865066666667D0, 0.1012865066666667D0, + 0.7974269866666667D0, 0.1012865066666667D0, + 0.1012865066666667D0, 0.7974269866666667D0, 0.1012865066666667D0, + 0.1012865066666667D0, 0.7974269866666667D0, + 0.1012865066666667D0, 0.1012865066666667D0, 0.7974269866666667D0, + 0.1012865066666667D0, 0.1012865066666667D0/ C C "WEIGHT" IS THE GAUSSIAN WEIGHT (FOR AREA INTEGRALS) OF THE 7 C INTEGRATION POINTS IN EACH TRIANGULAR ELEMENT. DATA WEIGHT / 0.2250000000000000D0, + 0.1323941500000000D0, 0.1323941500000000D0, 0.1323941500000000D0, + 0.1259391833333333D0, 0.1259391833333333D0, 0.1259391833333333D0/ C END C C C BLOCK DATA BD2 C C DEFINE "FPHI" (NODAL FUNCTIONS) AND "FGAUSS" (GAUSSIAN INTEGRATION C WEIGHTS) OF THE 6-NODE LINEAR FAULT ELEMENT FOR THE SEVEN C INTEGRATION POINTS IN EACH ELEMENT, DEFINED BY INTERNAL C COORDINATE "FPOINT(M=1-7)", WHICH CONTAINS THE RELATIVE POSITION C (FRACTIONAL LENGTH) OF THE INTEGRATION POINTS. C BECAUSE ALL OF THESE ARRAYS ARE FUNCTIONS OF INTERNAL C COORDINATES, THEY ARE NOT AFFECTED BY SCALING OR DEFORMATION OF C THE ELEMENTS. C DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS DIMENSION FPHI(6,7),FPOINT(7),FGAUSS(7) C C "FPOINT" CONTAINS THE SEVEN INTEGRATION POINT LOCATIONS FOR THE FAULT C ELEMENTS. EACH VALUE GIVES A POSITION AS A FRACTION OF TOTAL LENGTH C MEASURED FROM NODE1 TO NODE3 (OF ARRAY "NODEF"). DATA FPOINT/ 1 0.0254461D0, 2 0.1292344D0, 3 0.2970774D0, 4 0.5000000D0, 5 0.7029226D0, 6 0.8707656D0, 7 0.9745539D0 / C C "FGAUSS" CONTAINS THE SEVEN CORRESPONDING WEIGHT FACTORS FOR USE IN C LINE INTEGRALS. DATA FGAUSS/ 1 0.0647425D0, 2 0.1398527D0, 3 0.1909150D0, 4 0.2089796D0, 5 0.1909150D0, 6 0.1398527D0, 7 0.0647425D0/ C C "FPHI" CONTAINS THE VALUES OF THE 6 NODAL FUNCTIONS (ONE PER NODE) C AT EACH OF THESE 7 INTEGRATION POINTS IN THE FAULT ELEMENT. DATA FPHI/ + .92495670801042D0, .09919438397916D0,-.02415109198958D0, + .02415109198958D0,-.09919438397916D0,-.92495670801042D0, + .64569986028672D0, .45013147942656D0,-.09583133971328D0, + .09583133971328D0,-.45013147942656D0,-.64569986028672D0, + .28527776318152D0, .83528967363696D0,-.12056743681848D0, + .12056743681848D0,-.83528967363696D0,-.28527776318152D0, + 0.0D0, 1.0D0, 0.0D0, + 0.0D0, -1.0D0, 0.0D0, + -.12056743681848D0, .83528967363696D0, .28527776318152D0, + -.28527776318152D0,-.83528967363696D0, .12056743681848D0, + -.09583133971328D0, .45013147942656D0, .64569986028672D0, + -.64569986028672D0,-.45013147942656D0, .09583133971328D0, + -.02415109198958D0, .09919438397916D0, .92495670801042D0, + -.92495670801042D0,-.09919438397916D0, .02415109198958D0/ C END C C C SUBROUTINE KSIZE (INPUT,BRIEF, + IALIAS,IUNITT,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES, + NUMEL,NUMNOD, + USEALI, + OUTPUT,NDIFF,NKSIZE, + WORK,JLAST) C C DETERMINE THE HALF-BANDWIDTH OF THE NODE-NODE CONNECTIVITY C MATRIX, AND COMPUTE THE STORAGE NECESSARY TO HOLD IT. C THE MATRIX IS ASSUMED TO BE REAL AND SYMMETRICAL. C HALF-BANDWIDTH NDIFF" DOES NOT INCLUDE THE DIAGONAL. C C IF (USEALI) THEN NODES ARE CONSIDERED TO HAVE BEEN RENUMBERED C ACCORDING TO INTEGER VECTOR "IALIAS" BEFORE BANDWIDTH IS FOUND. C CHARACTER*1 BLANK,STAR,ASC LOGICAL BRIEF,USEALI,WORST DIMENSION IALIAS(MXNODE),JLAST(MXNODE), + NODEF(6,MXFEL),NODES(6,MXEL) DATA BLANK/' '/, STAR/'*'/ C C INITIALIZE BANDWIDTH TO 0 NODES: C DO 10 I=1,NUMNOD JLAST(I)=I 10 CONTINUE C C BAND WIDENING BY TRIANGULAR CONTINUUM ELEMENTS: C DO 50 K=1,NUMEL DO 40 I6=1,5 IF (USEALI) THEN NI=IALIAS(NODES(I6,K)) ELSE NI=NODES(I6,K) ENDIF DO 30 J6=I6+1,6 IF (USEALI) THEN NJ=IALIAS(NODES(J6,K)) ELSE NJ=NODES(J6,K) ENDIF IF (NJ.GT.NI) THEN JLAST(NI)=MAX(JLAST(NI),NJ) ELSE JLAST(NJ)=MAX(JLAST(NJ),NI) ENDIF 30 CONTINUE 40 CONTINUE 50 CONTINUE C C BAND WIDENING BY FAULT ELEMENTS: C DO 150 K=1,NFL DO 140 I6=1,5 IF (USEALI) THEN NI=IALIAS(NODEF(I6,K)) ELSE NI=NODEF(I6,K) ENDIF DO 130 J6=I6+1,6 IF (USEALI) THEN NJ=IALIAS(NODEF(J6,K)) ELSE NJ=NODEF(J6,K) ENDIF IF (NJ.GT.NI) THEN JLAST(NI)=MAX(JLAST(NI),NJ) ELSE JLAST(NJ)=MAX(JLAST(NJ),NI) ENDIF 130 CONTINUE 140 CONTINUE 150 CONTINUE C NDIFF=0 DO 190 I=1,NUMNOD NDIFF=MAX(NDIFF,JLAST(I)-I) 190 CONTINUE C IF (.NOT.BRIEF) THEN WRITE(IUNITT,200) 200 FORMAT(/ /' TABLE OF MOST DISTANT CONNECTIONS BETWEEN', + ' NODES'/ + ' (* MARKS THE CASES WHICH DETERMINE THE BANDWIDTH)'/ / + ' NODE HIGHEST-CONNECTION') DO 220 I=1,NUMNOD WORST=(JLAST(I)-I).EQ.NDIFF IF (WORST) THEN ASC=STAR ELSE ASC=BLANK ENDIF WRITE (IUNITT,210) I,ASC,JLAST(I),ASC 210 FORMAT(' ',I11,A1,I11,A1) 220 CONTINUE ENDIF C C DETERMINE MINIMUM STORAGE POSSIBLE C NKSIZE=0 DO 300 IR=1,NUMNOD JC1=IR JC2=JLAST(IR) NKSIZE=NKSIZE+(JC2-JC1+1) 300 CONTINUE IF (.NOT.BRIEF) WRITE (IUNITT,310) NKSIZE,NUMNOD,NDIFF 310 FORMAT (/' IF NO SPACE WERE WASTED, CONNECTION MATRIX WOULD HAVE' + ,I10,' ENTRIES.'/' IT HAS ',I6,' ROWS, AND THE ', + 'BANDWIDTH IS ',I6,'.') C C ADJUST FOR INEFFICIENCIES OF ACTUAL LINEAR-SYSTEM SOLVER USED: C SUBPROGRAMS SPBF/SPBS OF IBM'S ESSL SOFTWARE. C NDP1=NDIFF+1 NKSIZE=NUMNOD*(NDIFF+1) IF (.NOT.BRIEF) WRITE (IUNITT,320) NKSIZE,NUMNOD,NDP1 320 FORMAT (/' ACTUAL STORAGE NEEDED FOR STIFFNESS MATRIX IS', + I10,' ENTRIES;'/' IT HAS ',I6,' COLUMNS, EACH OF ', + I6,' ROWS.') RETURN END C C C SUBROUTINE LIMITS (INPUT,AREA,DETJ,IUNITT,MXEL, + NUMEL,OKDELV,REFSTR,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) C C COMPUTE AREA, MEAN THICKNESS, AND OTHER DIMENSIONAL PARAMETERS C OF THE CRUST, THEN DETERMINE VALUES OF STIFFNESS LIMITS NEEDED C TO KEEP VELOCITY ERR0RS DOWN TO ORDER "OKDELV" AT SHEAR STRESS C LEVEL "REFSTR". C DOUBLE PRECISION WEIGHT COMMON /WGTVEC/ WEIGHT DIMENSION WEIGHT(7) DIMENSION AREA(MXEL),DETJ(7,MXEL),ZMOHO(7,MXEL) C C DATA ITEM "NFAULT" GIVES THE TYPICAL NUMBER OF FAULTS WHICH ARE C CROSSED BY ANY STRAIGHT LINE RUNNING ACROSS THE MODEL. IT DOES C NOT NEED TO BE ACCURATE! DATA NFAULT /5/ C TOTALA=0. TOTALV=0. DO 20 M=1,7 DO 10 I=1,NUMEL DA=AREA(I)*DETJ(M,I)*WEIGHT(M) TOTALA=TOTALA+DA TOTALV=TOTALV+DA*ZMOHO(M,I) 10 CONTINUE 20 CONTINUE THICK=TOTALV/TOTALA SIDE=SQRT(TOTALA) CONSTR=NFAULT*REFSTR*THICK/OKDELV ETAMAX=2.*REFSTR*THICK/(SIDE*OKDELV) FMUMAX=NFAULT*REFSTR/OKDELV VISMAX=REFSTR*SIDE/OKDELV WRITE (IUNITT,50) TOTALA,TOTALV,THICK,SIDE,CONSTR,ETAMAX, + FMUMAX,VISMAX 50 FORMAT (/ /' SUBPROGRAM -LIMITS- PERFORMS DIMENSIONAL ANALYSIS'/ + ' AND ESTIMATES NECESSARY STIFFNESS LIMITS TO BALANCE'/1P, + ' THE CONFLICTING OBJECTIVES OF ACCURACY AND PRECISION:'/ / + ' AREA OF MODEL = ',E10.3,' LENGTH**2'/ + ' VOLUME OF CRUST = ',E10.3,' LENGTH**3'/ + ' TYPICAL THICKNESS = ',E10.3,' LENGTH'/ + ' TYPICAL WIDTH = ',E10.3,' LENGTH'/ + ' CONSTR (CONSTRAINT WEIGHT) = ',E10.3,' FORCE-SEC/LENGTH**2'/ + ' ETAMAX (MAX. BASAL COUPLING) = ',E10.3,' FORCE-SEC/LENGTH**3'/ + ' FMUMAX (MAX. FAULT STIFFNESS) = ',E10.3,' FORCE-SEC/LENGTH**3'/ + ' VISMAX (MAX. BLOCK VISCOSITY) = ',E10.3,' FORCE-SEC/LENGTH**2') RETURN END C C C SUBROUTINE PAINT (NODES,XNOD,YNOD,TITLE,TEXT,JV,NTYPE, + FUNC,CINT,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMT,TAUZZ, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPENCT,IPENST,IPENLB,COLOR) C C PLOTS CONTOUR DIAGRAMS AND A GRID OF STATE OUTLINES. C LABELS WITH VARIABLE AND TIME ABOVE, MODEL TITLE BELOW. C PLACES COLORBAR WITH CONTOUR VALUES AND UNITS ON RIGHT. C PARAMETER (NCOLOR=12) CHARACTER*80 TITLE,TITLE2 CHARACTER*42 TEXT,TTEXT,VUNITS CHARACTER*9 ASCII9,CHAR9 INTEGER DOWN,UP LOGICAL ALLPOS,COLOR,DASH,DOAROW,DOAXES,DOESYM,DOFLTS,STATES LOGICAL DRAWST,FSLIPS EXTERNAL ASCII9 DIMENSION DRAWST(NXYST),ERATE(4,7,NUMEL),FBLAND(NTYPE), + FDIP(3,NFL),FLEN(NFL),FSLIPS(NFL),FTAN(7,NFL), + FUNC(NUMNOD),ICOLOR(NCOLOR),IDSEG(1),LOWBLU(NTYPE), + NODEF(6,NFL),NODES(6,NUMEL),NVCHAR(NTYPE), + NVUCHR(NTYPE),OUTVEC(2,7,NUMEL), + TAUMT(3,7,NUMEL),TAUZZ(7,NUMEL), + TEXT(NTYPE),VUNITS(NTYPE),XIP(7,NUMEL),YIP(7,NUMEL), + XNOD(NUMNOD),YNOD(NUMNOD), + XST(NXYST),YST(NXYST) DIMENSION IFILL1(16),IFILL2(16),IFILL3(16),IFILL4(16), + IFILL5(16),IFILL6(16),IFILL7(16),IFILL8(16), + IFILL9(16),IFILLA(16),IFILLB(16),IFILLC(16) DIMENSION IARRAY(1) DATA DOWN/2/, UP/3/ C C SELECT COLORS: 9 = WHITE, 12 C 171 = PINK, 11 C 175 = RED, 10 C 178 = DARK RED, 9 C 144 = ORANGE, 8 C 130 = YELLOW, 7 C 123 = YELLOW/GREEN, 6 C 87 = GREEN 5 C 85 = TURQUOISE, 4 C 2 = BLUE, 3 ___________ C 29 = DARK BLUE, 2 __CINT___ C 1 = BLACK. 1 C DATA ICOLOR/1,29,2,85,87,123,130,144,178,175,171,9/ C C SELECT SHADING PATTERNS: C 12 = * ] 135/256 (DARKEST) C 11 = # ] 112/256 C 10 = H ] 46/256 C 9 = / / ] 32/256 C 8 = = ] 32/256 C 7 = / ] 16/256 C 6 = .] ] 16/256 C 5 = :.: ] 12/256 C 4 = : : ] 8/256 C 3 = : ] 6/256 ______________ C 2 = . ] 4/256 __CINT________ C 1 = ] 0/256 (WHITE) C DATA IFILL1 /Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000, + Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000/ DATA IFILL2 /Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0180, + Z0180,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000/ DATA IFILL3 /Z0000,Z0000,Z0000,Z1800,Z1000,Z0000,Z0000,Z0000, + Z0000,Z0000,Z0000,Z0008,Z0018,Z0000,Z0000,Z0000/ DATA IFILL4 /Z0000,Z0000,Z0000,Z1818,Z0000,Z0000,Z0000,Z0000, + Z0000,Z0000,Z0000,Z1818,Z0000,Z0000,Z0000,Z0000/ DATA IFILL5 /Z0180,Z0000,Z0000,Z8001,Z8001,Z0000,Z0000,Z0000, + Z0000,Z0000,Z0000,Z8001,Z8001,Z0000,Z0000,Z0180/ DATA IFILL6 /Z0002,Z0002,Z0002,Z0002,Z0002,Z0002,Z0002,Z0002, + Z0002,Z0002,Z0002,Z0002,Z0002,Z0002,Z0002,Z0002/ DATA IFILL7 /Z8000,Z4000,Z2000,Z1000,Z0800,Z0400,Z0200,Z0100, + Z0080,Z0040,Z0020,Z0010,Z0008,Z0004,Z0002,Z0001/ DATA IFILL8 /Z0000,ZFFFF,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000, + Z0000,ZFFFF,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000/ DATA IFILL9 /Z0101,Z0202,Z0404,Z0808,Z1010,Z2020,Z4040,Z8080, + Z0101,Z0202,Z0404,Z0808,Z1010,Z2020,Z4040,Z8080/ DATA IFILLA /ZFF01,Z0101,Z0101,Z0101,Z0101,Z0101,Z0101,Z0101, + Z01FF,Z0101,Z0101,Z0101,Z0101,Z0101,Z0101,Z0101/ DATA IFILLB /ZFFFF,Z8181,Z8181,Z8181,Z8181,Z8181,Z8181,ZFFFF, + ZFFFF,Z8181,Z8181,Z8181,Z8181,Z8181,Z8181,ZFFFF/ DATA IFILLC /ZFFFF,Z9248,Z9248,ZFFFF,Z9248,Z9248,ZFFFF,Z9248, + Z9248,ZFFFF,Z9248,Z9248,ZFFFF,Z9248,Z9248,Z9248/ C C INITIALIZE VERSATEC C IF (COLOR) CALL VPOPT(101,0,0.0,IERR) IARRAY(1)=7 CALL VPOPT(20,IARRAY,RARG,IER) CALL PAPER (0.0,XINCH+2.,0.0,10.5) CALL PLOTS(0,0,0) CALL SETFNT(18) IF (COLOR) THEN CALL TONFLG(1) ENDIF CALL DEFPAT(1,IFILL1,16) CALL DEFPAT(2,IFILL2,16) CALL DEFPAT(3,IFILL3,16) CALL DEFPAT(4,IFILL4,16) CALL DEFPAT(5,IFILL5,16) CALL DEFPAT(6,IFILL6,16) CALL DEFPAT(7,IFILL7,16) CALL DEFPAT(8,IFILL8,16) CALL DEFPAT(9,IFILL9,16) CALL DEFPAT(10,IFILLA,16) CALL DEFPAT(11,IFILLB,16) CALL DEFPAT(12,IFILLC,16) C IF (FBLAND(JV).NE.0.) THEN FMIDLE=FBLAND(JV) ELSE FTOPS=FUNC(1) FLOOR=FUNC(1) DO 5 I=2,NUMNOD FTOPS=MAX(FTOPS,FUNC(I)) FLOOR=MIN(FLOOR,FUNC(I)) 5 CONTINUE FMIDLE=(FTOPS+FLOOR)/2. ENDIF IFLIP=LOWBLU(JV) C C********************************************************************** C C BEGIN "SEGMENT 1" (CONTOURED ELEMENTS) C C RESERVE SPACE FOR TITLES AND COLOR BAR C CALL WINDOW(0.,XINCH,0.5,10.0) CALL VPORT (0.,XINCH,0.5,10.0) C (SET TO DO PLOT IN PHYSICAL, EARTH DIMENSIONS, IN METERS:) CALL FACTOR (VFACT) CALL CONTEL (NODES,XNOD,YNOD,FUNC,CINT,NUMNOD,NUMEL, + FMAX,FMIN,NCOLOR,ICOLOR,FMIDLE,IFLIP, + NBLUE,NYELOW,ALLPOS,COLOR,IPENCT) C C END SEGMENT OF COLORED ELEMENTS C C************************************************************* C C BEGIN "SEGMENT 2" (VECTORS OR TENSOR SYMBOLS, OR DUMMY) C TENSORS INCLUDED WITH OTHER VARIABLES) C IF (DOAROW) THEN C ENLARGE WINDOW 2" TO RIGHT, BUT NOT UPWARD CALL FACTOR (1.) CALL WINDOW(0.,XINCH+2.,0.5,10.0) CALL VPORT (0.,XINCH+2.,0.5,10.0) C (SET TO DO PLOT IN PHYSICAL, EARTH DIMENSIONS, IN METERS:) CALL FACTOR (VFACT) IF (COLOR) THEN CALL TONCLR(1) CALL PENCLR(IPENLB,1) ELSE CALL SETPAT(0) ENDIF CALL NEWPEN(IPENLB) SIZEAR=RMSVEC/VFACT XMAXAX=(XINCH+2.)/VFACT YTOPAX=10.0/VFACT CALL ARROW (NUMEL,OUTVEC,SIZEAR, + XIP,YIP,CINT,XMAXAX,YTOPAX) ELSE IF (DOAXES) THEN C ENLARGE WINDOW 2" TO RIGHT, BUT NOT UPWARD CALL FACTOR (1.) CALL WINDOW(0.,XINCH+2.,0.5,10.0) CALL VPORT (0.,XINCH+2.,0.5,10.0) C (SET TO DO PLOT IN PHYSICAL, EARTH DIMENSIONS, IN METERS:) CALL FACTOR (VFACT) IF (COLOR) THEN CALL TONCLR(1) CALL PENCLR(IPENLB,1) ELSE CALL SETPAT(0) ENDIF CALL NEWPEN (IPENLB) SIZEAX=RMSVEC/VFACT XMAXAX=(XINCH+1.96)/VFACT YTOPAX=10.0/VFACT CALL AXES (NUMEL,TAUMT,TAUZZ,SIZEAX,IPENLB, + XIP,YIP,CINT,VFACT,XMAXAX,YTOPAX) ELSE IF (DOESYM) THEN C REPLACE LIMITS ON PLOTTING WINDOW CALL FACTOR (1.) CALL WINDOW(0.,XINCH,0.5,10.0) CALL VPORT (0.,XINCH,0.5,10.0) C (SET TO DO PLOT IN PHYSICAL, EARTH DIMENSIONS, IN METERS:) CALL FACTOR (VFACT) IF (COLOR) THEN CALL TONCLR(1) CALL PENCLR(IPENLB,1) ELSE CALL SETPAT(0) ENDIF CALL NEWPEN(IPENLB) SIZEIC=RMSVEC/VFACT CALL FICONS (NUMEL,ERATE,SIZEIC, + XIP,YIP) ENDIF C IF (DOFLTS.AND.(NFL.GT.0)) THEN C REPLACE LIMITS ON PLOTTING WINDOW CALL FACTOR (1.) CALL WINDOW(0.,XINCH,0.5,10.0) CALL VPORT (0.,XINCH,0.5,10.0) C (SET TO DO PLOT IN PHYSICAL, EARTH DIMENSIONS, IN METERS:) CALL FACTOR (VFACT) C C IF COLOR, THEN PLOT ALL FAULTS IN RED C IF (COLOR) CALL PENCLR(IPENST,6) CALL NEWPEN(IPENST) SUM=0.0 DO 32 I=1,NFL SUM=SUM+FLEN(I) 32 CONTINUE AVERAG=SUM/NFL DIPSIZ=0.15*AVERAG DO 35 I=1,NFL DASH=.NOT.FSLIPS(I) CALL FAULT (INPUT,DASH,FDIP,FTAN,I,NFL, + NUMNOD,NODEF,DIPSIZ, + WEDGE,XNOD,YNOD) 35 CONTINUE ENDIF C C END SEGMENT C C******************************************************************* IF (STATES) THEN C C BEGIN SEGMENT FOR STATE LINES (3) C CALL FACTOR (1.) CALL WINDOW(0.,XINCH,0.5,10.0) CALL VPORT (0.,XINCH,0.5,10.0) C (SET TO DO PLOT IN PHYSICAL, EARTH DIMENSIONS, IN METERS:) CALL FACTOR (VFACT) C C USE BLACK PEN TO OVERWRITE OTHER COLORS C IF (COLOR) THEN CALL PENCLR (IPENST,1) ENDIF CALL NEWPEN (IPENST) CALL USMAP (INPUT,DRAWST,NXYST,XST,YST) C C END SEGMENT WITH STATE LINES C ENDIF C**************************************************************** C C BEGIN SEGMENT 4 (COLOR BAR AND CONTOUR INTERVALS) C C OPEN WINDOW TO ALLOW SPACE C CALL FACTOR (1.) CALL WINDOW(0.,XINCH+2.,0.,10.5) CALL VPORT (0.,XINCH+2.,0.,10.5) C C RETURN TO PLOTTING IN INCHES C CALL FACTOR (1.) C C DETERMINE SCALE FACTORS FOR COLOR BAR C IF (ALLPOS) FMIN=MAX(FMIN,0.) RANGE=FMAX-FMIN STEPS=RANGE/CINT YPERST=MIN(0.5,8.0/MAX(STEPS,0.01)) YTOP=5.25+YPERST*STEPS/2. YBOT=5.25-YPERST*STEPS/2. ORIGIN=5.25-((FMAX+FMIN)/(2.*CINT))*YPERST NSTEPT=IUNDER(FMAX/CINT) NSTEPB=IUNDER(FMIN/CINT) HEIGHT=0.12 WIDTH=HEIGHT*0.87 C C ADD UNITS C WIDE=WIDTH*NVUCHR(JV) IF ((WIDE/2.).LE.(2.-1.65)) THEN X=XINCH+1.65-WIDE/2. ELSE X=XINCH+2.-WIDE ENDIF Y=YTOP+0.7*HEIGHT YOLD=Y YNEXT=Y-1.1*HEIGHT C C USE BLACK FOR CONTOUR LEVEL LABELS C IF (COLOR) THEN CALL PENCLR(IPENLB,1) ENDIF CALL NEWPEN(IPENLB) C CALL SYMBOL (X,Y,HEIGHT,VUNITS(JV),IDUMMY,0.,NVUCHR(JV)) C C DRAW BOXES AND CONTOUR LABELS C C DO 1050 I=NSTEPT,NSTEPB,-1 FTOP=(I+1)*CINT IF (I.EQ.NSTEPT) FTOP=FMAX FBOT=I*CINT IF (I.EQ.NSTEPB) FBOT=FMIN YTOP=FTOP*YPERST/CINT+ORIGIN YBOT=FBOT*YPERST/CINT+ORIGIN F=(FTOP+FBOT)/2. N=IHUE (NCOLOR,CINT,FMIDLE,IFLIP,F) IF (COLOR) THEN CALL TONCLR(ICOLOR(N)) IF (N.EQ.NCOLOR) THEN CALL PENCLR(IPENLB,1) CALL NEWPEN(IPENLB) IBOX=1 ELSE IBOX=0 ENDIF ELSE CALL SETPAT(N) IBOX=1 ENDIF CALL RECT (XINCH+1.4,XINCH+1.9,YBOT+0.01,YTOP-0.01,IBOX) C C USE BLACK FOR CONTOUR LEVEL LABELS C IF (COLOR) THEN CALL PENCLR(IPENLB,1) CALL NEWPEN(IPENLB) ENDIF C CHAR9=ASCII9 (FTOP) X=XINCH+1.4-9.5*WIDTH Y=YTOP-0.5*HEIGHT IF (Y.LE.YNEXT) THEN YOLD=Y YNEXT=Y-1.1*HEIGHT CALL SYMBOL (X,Y,HEIGHT,CHAR9,IDUMMY,0.,9) ENDIF IF (I.EQ.NSTEPB) THEN CHAR9=ASCII9 (FBOT) X=XINCH+1.4-9.5*WIDTH Y=YBOT-0.5*HEIGHT IF (Y.LE.YNEXT) + CALL SYMBOL (X,Y,HEIGHT,CHAR9,IDUMMY,0.,9) ENDIF 1050 CONTINUE C C END SEGMENT OF COLOR BAR C C******************************************************************* C C BEGIN SEGMENT 5 (TITLE + VARIABLE) C HEIGHT=0.15 WIDTH=HEIGHT*0.87 C C USE BLACK FOR TITLES C IF (COLOR) THEN CALL PENCLR(IPENLB,1) ENDIF CALL NEWPEN(IPENLB) C C WRITE MODEL TITLE C DO 4010 I=1,80 IF (TITLE(I:I).EQ.'0') THEN TITLE2(I:I)='O' ELSE TITLE2(I:I)=TITLE(I:I) ENDIF 4010 CONTINUE CALL SYMBOL (0.2,0.2,HEIGHT,TITLE2,IDUMMY,0.,80) C C WRITE VARIABLE C CALL SYMBOL (0.2,10.15,HEIGHT,TEXT(JV),IDUMMY,0.,NVCHAR(JV)) C C ADD GRAPHICAL LENGTH SCALE FOLLOWING VARIABLE IDENTIFIER C CALL WHERE (XP,YP,F) XSPACE=3.0 CALL PLOT (XP+XSPACE,10.4,UP) CALL PLOT (XP+XSPACE,10.3,DOWN) XLONG=100.E3*VFACT CALL PLOT (XP+XSPACE+XLONG,10.3,DOWN) CALL PLOT (XP+XSPACE+XLONG,10.4,DOWN) CALL SYMBOL (XP+XSPACE+0.5*XLONG-3.*WIDTH, + 10.3-1.3*HEIGHT, + HEIGHT,'1OO km',IDUMMY,0.,6) C C END SEGMENT WITH TEXT LABELS C C**************************************************************** C C SHUT DOWN VERSATEC C CALL FACTOR (1.) CALL PLOT(XINCH+2.2,0.0,999) C RETURN END C C C SUBROUTINE ETCH (DRAWST,FDIP,FLEN,FTAN,JV,NTYPE,NFL, + NODEF,NODES,NUMEL,NUMNOD,NVCHAR,NXYST, + STATES,TEXT,TITLE, + VFACT,WEDGE,XINCH, + XNOD,XST,YNOD,YST, + IPENCT,IPENST,IPENLB,COLOR) C C PLOTS THE FINITE ELEMENT GRID AND STATE OUTLINES. C LABELS WITH GRID TITLE BELOW. C CHARACTER*1 ITEXT CHARACTER*42 TEXT CHARACTER*80 TITLE,TITLE2 INTEGER DOWN,NEWORG,UP INTEGER BLUE,GREEN,RED,BLACK LOGICAL COLOR,DASH,S4,S5,S6,STATES LOGICAL DRAWST DIMENSION DRAWST(NXYST),IARRAY(1), + FDIP(3,NFL),FLEN(NFL),FTAN(7,NFL), + NODEF(6,NFL),NODES(6,NUMEL),NVCHAR(NTYPE), + TEXT(NTYPE),XNOD(NUMNOD),YNOD(NUMNOD), + XST(NXYST),YST(NXYST) DATA DOWN/2/, NEWORG/-3/, UP/3/ DATA BLUE/2/, GREEN/7/, RED/6/, BLACK/1/ C C INITIALIZE VERSATEC C IF (COLOR) CALL VPOPT(101,0,0.0,IERR) IARRAY(1)=7 CALL VPOPT(20,IARRAY,RARG,IER) CALL PAPER (0.,XINCH+0.2,0.0,10.5) CALL PLOTS(0,0,0) CALL SETFNT(18) IF (COLOR) THEN CALL TONFLG(1) ENDIF C C C********************************************************************** C C BEGIN SEGMENT 1 (FINITE ELEMENT GRID) C C RESERVE SPACE FOR TITLES VERTICALLY; C ALLOW 0.1 MARGIN OF GRACE HORIZONTALLY FOR EDGE NODE OCTAGONS CALL WINDOW(0.,XINCH+0.2,0.5,10.0) CALL VPORT (0.,XINCH+0.2,0.5,10.0) CALL PLOTS (0.1,0.0,NEWORG) C (SET TO DO PLOT IN PHYSICAL, EARTH DIMENSIONS, IN METERS:) CALL FACTOR (VFACT) C C PLOT ALL ELEMENT SIDES (IN GREEN, IF COLOR; DASHED, IF B/W). C NOTE: DO NOT DRAW ANY SIDE TWICE, OR DASHES WILL NOT REGISTER. C ALSO, DO NOT DRAW OVER FAULTS, TO AVOID GREEN-OVER-RED=BLACK. C IF (COLOR) THEN CALL PENCLR (IPENCT,GREEN) CALL NEWPEN (IPENCT) ELSE CALL DEFPEN (63,IPENCT,2*IPENCT,4*IPENCT, + 2*IPENST,4*IPENCT) C SAMPLE:** ** ** ** ** ** ** CALL NEWPEN (63) ENDIF DO 30 I=1,NUMEL S4=.TRUE. NODE=NODES(4,I) DO 14 J=1,NFL IF ((NODEF(2,J).EQ.NODE).OR. + (NODEF(5,J).EQ.NODE)) S4=.FALSE. 14 CONTINUE DO 24 J=1,I-1 IF ((NODES(4,J).EQ.NODE).OR. + (NODES(5,J).EQ.NODE).OR. + (NODES(6,J).EQ.NODE)) S4=.FALSE. 24 CONTINUE S5=.TRUE. NODE=NODES(5,I) DO 15 J=1,NFL IF ((NODEF(2,J).EQ.NODE).OR. + (NODEF(5,J).EQ.NODE)) S5=.FALSE. 15 CONTINUE DO 25 J=1,I-1 IF ((NODES(4,J).EQ.NODE).OR. + (NODES(5,J).EQ.NODE).OR. + (NODES(6,J).EQ.NODE)) S5=.FALSE. 25 CONTINUE S6=.TRUE. NODE=NODES(6,I) DO 16 J=1,NFL IF ((NODEF(2,J).EQ.NODE).OR. + (NODEF(5,J).EQ.NODE)) S6=.FALSE. 16 CONTINUE DO 26 J=1,I-1 IF ((NODES(4,J).EQ.NODE).OR. + (NODES(5,J).EQ.NODE).OR. + (NODES(6,J).EQ.NODE)) S6=.FALSE. 26 CONTINUE CALL AROUND (I,S4,S5,S6,NODES,XNOD,YNOD,NUMNOD,NUMEL) 30 CONTINUE C C PLOT ALL NODES (IN BLUE, IF COLOR) C IF (COLOR) THEN CALL PENCLR(IPENLB,BLUE) ENDIF CALL NEWPEN(IPENLB) C USE CENTERED OCTAGON SYMBOL: CALL SETFNT (17) INTEG=1 DO 40 I=1,NUMNOD CALL SYMBOL(XNOD(I),YNOD(I),0.08/VFACT, + ITEXT,INTEG,0.0,-1) 40 CONTINUE CALL SETFNT (18) C C PLOT FAULTS (IN RED, IF COLOR) C IF (NFL.GT.0) THEN IF (COLOR) CALL PENCLR(IPENST,RED) CALL NEWPEN(IPENST) SUM=0.0 DO 50 I=1,NFL SUM=SUM+FLEN(I) 50 CONTINUE AVERAG=SUM/NFL DIPSIZ=0.15*AVERAG DO 60 I=1,NFL DASH=.FALSE. CALL FAULT (INPUT,DASH,FDIP,FTAN,I,NFL, + NUMNOD,NODEF,DIPSIZ, + WEDGE,XNOD,YNOD) 60 CONTINUE ENDIF C C CLOSE SEGMENT OF FINITE ELEMENT GRID C C**************************************************************** IF (STATES) THEN C C BEGIN SEGMENT FOR STATE LINES (3) C C USE BLACK PEN TO WRITE OVER OTHER COLORS C IF (COLOR) THEN CALL PENCLR (IPENST,BLACK) ENDIF C CALL NEWPEN (IPENST) CALL USMAP (INPUT,DRAWST,NXYST,XST,YST) C C CLOSE SEGMENT WITH STATE LINES C ENDIF C**************************************************************** C C BEGIN SEGMENT 5 (TITLE) C C OPEN UP WINDOW C CALL FACTOR (1.) CALL WINDOW(0.,XINCH,0.,10.5) CALL VPORT (0.,XINCH,0.,10.5) C C RETURN TO INCH UNITS C CALL FACTOR (1.) C CALL NEWPEN(IPENLB) HEIGHT=0.15 WIDTH=HEIGHT*0.87 C C USE BLACK FOR TEXT C IF (COLOR) THEN CALL PENCLR(IPENLB,BLACK) ENDIF CALL NEWPEN(IPENLB) C C WRITE MODEL TITLE C DO 4010 I=1,80 IF (TITLE(I:I).EQ.'0') THEN TITLE2(I:I)='O' ELSE TITLE2(I:I)=TITLE(I:I) ENDIF 4010 CONTINUE CALL SYMBOL (0.1,0.2,HEIGHT,TITLE2,IDUMMY,0.,80) C CALL SYMBOL (0.20,10.15,HEIGHT,TEXT(JV),IDUMMY,0.,NVCHAR(JV)) C C ADD GRAPHICAL LENGTH SCALE FOLLOWING VARIABLE IDENTIFIER C CALL WHERE (XP,YP,F) XSPACE=3.0 CALL PLOT (XP+XSPACE,10.4,UP) CALL PLOT (XP+XSPACE,10.3,DOWN) XLONG=100.E3*VFACT CALL PLOT (XP+XSPACE+XLONG,10.3,DOWN) CALL PLOT (XP+XSPACE+XLONG,10.4,DOWN) CALL SYMBOL (XP+XSPACE+0.5*XLONG-3.*WIDTH, + 10.3-1.3*HEIGHT, + HEIGHT,'1OO km',IDUMMY,0.,6) C C CLOSE SEGMENT WITH TEXT LABELS C C**************************************************************** C C SHUT DOWN VERSATEC C CALL FACTOR (1.) CALL PLOT(XINCH,0.0,999) C RETURN END C C C SUBROUTINE CONTEL (NODES,XNOD,YNOD,FUNC,DFCON,NUMNOD,NUMEL, + FGMAX,FGMIN,NCOLOR,ICOLOR,FMIDLE,IFLIP, + NBLUE,NYELOW,ALLPOS,COLOR,IPENCT) C C CONTOURS AND COLORS A SCALAR FIELD ON THE FINITE ELEMENT GRID. C INSTEAD OF FOLLOWING CONTOURS ACROSS ELEMENT BOUNDARIES, IT C CONTOURS EACH ELEMENT SEPARATELY. C PARAMETER(MXAREA=10,NINLIN=130,NWORK=1300,NPOLYV=1000) LOGICAL ALLPOS,ANEDGE,BEGCON,BEGNXT,BITSEG,CENTER,CIRCLE, + COLOR,DASHED,DONE,ENDCON,FINISH,GONOUT, + HITLIM,INSIDE, + NEIGHB,SIDMAX,SIDMIN,SURROU, + THRU,Z C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ LOGICAL DUMPIT C (LEAVE IN THIS DEBUG CODE FOR A FEW YEARS MORE) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ REAL LOWEST DIMENSION NODES(6,NUMEL),ICOLOR(NCOLOR), + XNOD(NUMNOD),YNOD(NUMNOD),FUNC(NUMNOD) C C LOCAL STORAGE FOR PROPERTIES OF ONE ELEMENT: DIMENSION IN(6),XN(6),YN(6),FN(6),DS(3),SSE(3),DSIN(3) C C LOCAL STORAGE FOR INITIAL POINTS OF CONTOUR SEGMENTS: DIMENSION PS(5,NINLIN),PS2(5,NINLIN),DONE(NINLIN) C C LOCAL STORAGE FOR SHAPES OF CONTOUR AND EDGE SEGMENTS: DIMENSION SPACE(2,NWORK),ISPPNT(0:NINLIN),ISPLEN(0:NINLIN), & FOFSEG(NINLIN),ANEDGE(NINLIN),MENU(NINLIN), & NTOGO(NINLIN) C C LOCAL STORAGE FOR OUTLINES OF COLORED AREAS: DIMENSION IPCLR(NPOLYV),NINARE(MXAREA), + XARRAY(NPOLYV),YARRAY(NPOLYV) C DATA DSTEP/0.05/ C C STATEMENT FUNCTION: C PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) C C**************************************************************** C THE FOLLOWING INTIALIZATIONS ARE NOT LOGICALLY NECESSARY, C BUT DUE TO BUGS IN THE VS-FORTRAN 2.4 COMPILER, THERE C WILL BE AN ERRONEOUS ERR0R MESSAGE IF THEY ARE NOT PERFORMED: KOLORC=0 LASTKO=0 XEXT=0. YEXT=0. C**************************************************************** C C GLOBAL INITIALIZATION (WHOLE GRID) C LIMINT=4./DSTEP FGMIN= 1.E60 FGMAX=-1.E60 NBLUE=0 NYELOW=0 C C USE BLACK PEN OF WIDTH IPENCT UNLESS MODIFIED C IF (COLOR) THEN CALL PENCLR(IPENCT,1) LASTKO=1 ENDIF CALL NEWPEN(IPENCT) DO 9999 IEL=1,NUMEL C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ DUMPIT=.FALSE. C (LEAVE IN THIS DEBUG CODE FOR A FEW YEARS MORE) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C LOCAL INITIALIZATION (ONE ELEMENT) C NPS=0 ISPNUM=0 ISPLEN(0)=0 ISPPNT(0)=1 CENTER=.FALSE. TSIDE=1.E60 IHIC= -9999 ILOC= +9999 DO 5 J=1,6 K=NODES(J,IEL) IN(J)=K XN(J)=XNOD(K) YN(J)=YNOD(K) FN(J)=FUNC(K) 5 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7771)IEL,(NODES(J,IEL),J=1,6), + (XN(J),J=1,6),(YN(J),J=1,6),(FN(J),J=1,6) 7771 FORMAT(/ / /' ========================================'/ + ' IEL=',I4/ + ' NODES =',6I10/ + ' XN =',1P,6E10.3/ + ' YN =', 6E10.3/ + ' FN =', 6E10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ I1=IN(1) I2=IN(2) I3=IN(3) I4=IN(4) I5=IN(5) I6=IN(6) X1=XN(1) X2=XN(2) X3=XN(3) X4=XN(4) X5=XN(5) X6=XN(6) Y1=YN(1) Y2=YN(2) Y3=YN(3) Y4=YN(4) Y5=YN(5) Y6=YN(6) FMAX=MAX(FN(1),FN(2),FN(3),FN(4),FN(5),FN(6)) FMIN=MIN(FN(1),FN(2),FN(3),FN(4),FN(5),FN(6)) RANGE=MAX((FMAX-FMIN),DFCON) C C PREVENT DEGENERATE CASES WHERE NODES FALL EXACTLY ON CONTOURS C DO 10 J=1,6 I=FN(J)/DFCON IF ((I*DFCON).EQ.FN(J)) FN(J)=FN(J)+0.01*RANGE 10 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7772) + (FN(J),J=1,6) 7772 FORMAT(/ /' AFTER ADJUSTMENT TO PREVENT SINGULARITY:'/ + ' FN =',1P,6E10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ F1=FN(1) F2=FN(2) F3=FN(3) F4=FN(4) F5=FN(5) F6=FN(6) C C*************************************************************** C C EXAMINE SIDES FOR EXTREMA AND MARK CONTOUR INTERSECTIONS C DO 100 MSIDE=1,3 N1=MSIDE N2=MOD(MSIDE,3)+1 SIDE=SQRT((XN(N1)-XN(N2))**2+(YN(N1)-YN(N2))**2) TSIDE=MIN(TSIDE,SIDE) NM=MSIDE+3 DFDS1= -3.*FN(N1)+4.*FN(NM)- FN(N2) DFDS2= FN(N1)-4.*FN(NM)+3.*FN(N2) D2FDS=4.*FN(N1)-8.*FN(NM)+4.*FN(N2) IF ((DFDS1*DFDS2.GE.0.).OR.(D2FDS.EQ.0.0)) THEN FMX=AMAX1(FN(N1),FN(N2)) FMN=AMIN1(FN(N1),FN(N2)) CALL DOSIDE (FMX,FMN,DFCON,FN,N1,N2,NM,PS,NPS,NINLIN,Z) IF (Z) THEN NCRASH=1 WRITE(6,401)IEL,NCRASH GO TO 9999 ENDIF ELSE SEXT= -DFDS1/D2FDS FEXT=FN(N1)+ + DFDS1*SEXT+ + 0.5*D2FDS*SEXT**2 FMAX=MAX(FMAX,FEXT) FMIN=MIN(FMIN,FEXT) C C FIND INTERSECTIONS OF CONTOURS WITH SIDE CONTAINING EXTREMUM C FMX=AMAX1(FN(N1),FEXT) FMN=AMIN1(FN(N1),FEXT) CALL DOPART (FEXT,FMX,FMN,DFCON,FN, + N1,N2,NM,0.,SEXT,PS,NPS,NINLIN,Z) IF (Z) THEN NCRASH=2 WRITE(6,401)IEL,NCRASH GO TO 9999 ENDIF FMX=AMAX1(FEXT,FN(N2)) FMN=AMIN1(FEXT,FN(N2)) CALL DOPART (FEXT,FMX,FMN,DFCON,FN, + N1,N2,NM,SEXT,1.,PS,NPS,NINLIN,Z) IF (Z) THEN NCRASH=3 WRITE(6,401)IEL,NCRASH GO TO 9999 ENDIF ENDIF 100 CONTINUE RTESTR=TSIDE*DSTEP C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7773) 7773 FORMAT(/ /' CONTOUR POINTS ON SIDES, BEFORE SORTING:'/) DO 101 INPS=1,NPS XQ=PHIVAL(PS(1,INPS),PS(2,INPS),PS(3,INPS),X1,X2,X3,X4,X5,X6) YQ=PHIVAL(PS(1,INPS),PS(2,INPS),PS(3,INPS),Y1,Y2,Y3,Y4,Y5,Y6) WRITE(6,7774)INPS,(PS(J,INPS),J=1,4),XQ,YQ 7774 FORMAT(' ',I10,0P,3F10.5,1P,3E10.3) 101 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C*************************************************************** C C SORT THE POINTS FOUND BY CLOCKWISE PARAMETER S = PS(5,) C DO 200 INPS=1,NPS S1=PS(1,INPS) S2=PS(2,INPS) S3=PS(3,INPS) F=PS(4,INPS) IF (F.GE.0.) THEN IC=F/DFCON+0.1 ELSE IT= -F/DFCON+0.1 IC= -IT ENDIF IHIC=MAX(IHIC,IC) ILOC=MIN(ILOC,IC) IF (S3.EQ.0.) THEN SN=S2 ELSE IF (S1.EQ.0.) THEN SN=1.+S3 ELSE SN=2.+S1 ENDIF PS(5,INPS)=SN 200 CONTINUE SNOW= -0.1 DO 300 INPS=1,NPS LOWEST=3.1 JMOVE=INPS DO 250 JNPS=1,NPS IF (PS(5,JNPS).GT.SNOW) THEN IF (PS(5,JNPS).LT.LOWEST) THEN LOWEST=PS(5,JNPS) JMOVE=JNPS ENDIF ENDIF 250 CONTINUE DO 270 K=1,5 PS2(K,INPS)=PS(K,JMOVE) 270 CONTINUE SNOW=LOWEST 300 CONTINUE DO 320 I=1,5 DO 310 J=1,NPS PS(I,J)=PS2(I,J) 310 CONTINUE 320 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7775) 7775 FORMAT(/ /' CONTOUR POINTS ON SIDES, AFTER SORTING:'/) DO 102 INPS=1,NPS XQ=PHIVAL(PS(1,INPS),PS(2,INPS),PS(3,INPS),X1,X2,X3,X4,X5,X6) YQ=PHIVAL(PS(1,INPS),PS(2,INPS),PS(3,INPS),Y1,Y2,Y3,Y4,Y5,Y6) WRITE(6,7774)INPS,(PS(J,INPS),J=1,4),XQ,YQ 102 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C CREATE TABLE OF ELEMENT-SIDE SEGMENTS C S=0. NPSD=0 BEGNXT=.FALSE. C BEGIN NEW SEGMENT 400 ISPNUM=ISPNUM+1 IF (ISPNUM.GT.NINLIN) THEN NCRASH=4 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF ISPPNT(ISPNUM)=ISPPNT(ISPNUM-1)+ISPLEN(ISPNUM-1) IF (ISPPNT(ISPNUM).GT.NWORK) THEN NCRASH=5 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF 401 FORMAT(' INSUFFICIENT WORKSPACE IN SUBPROGRAM CONTEL. ELEMENT ', & I5,' WILL NOT BE SHOWN. DEBUGGING CODE NCRASH=',I3) ISPLEN(ISPNUM)=1 NTOGO(ISPNUM)=1 ANEDGE(ISPNUM)=.TRUE. BEGCON=BEGNXT NINSEG=1 IF(S.LE.1.) THEN S1=1.-S S2=S S3=0. ELSE IF (S.LE.2.) THEN S1=0. S2=2.-S S3=S-1. ELSE S1=S-2. S2=0. S3=3.-S ENDIF X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) F=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) SUMSEG=F SPACE(1,ISPPNT(ISPNUM))=X SPACE(2,ISPPNT(ISPNUM))=Y C FIND NEXT POINT 500 IS=IABOVE(S/DSTEP+0.05) IF (S.LT.1.0) THEN SLIM=1.0 ELSE IF (S.LT.2.0) THEN SLIM=2.0 ELSE SLIM=3.0 ENDIF ST=MIN(SLIM,IS*DSTEP) THRU=.FALSE. ENDCON=.FALSE. BEGNXT=.FALSE. IF (NPSD.LT.NPS) THEN IF (PS(5,NPSD+1).LE.ST) THEN NPSD=NPSD+1 IF ((.NOT.ALLPOS).OR.(PS(4,NPSD).GT.0.0)) THEN THRU=.TRUE. ENDCON=.TRUE. BEGNXT=.TRUE. ST=PS(5,NPSD) ENDIF ENDIF ENDIF IF (ST.EQ.SLIM) THRU=.TRUE. C UPDATE REPRESENTATIVE FUNCTION VALUE FOR SEGMENT NINSEG=NINSEG+1 IF(ST.LE.1.) THEN S1=1.-ST S2=ST S3=0. ELSE IF (ST.LE.2.) THEN S1=0. S2=2.-ST S3=ST-1. ELSE S1=ST-2. S2=0. S3=3.-ST ENDIF F=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) BITSEG=THRU.AND.(NINSEG.EQ.2).AND.BEGCON.AND.ENDCON.AND. + (ABS(F-SUMSEG).LT.(0.1*ABS(DFCON))) IF (BITSEG) THEN IF (F.GT.FOFSEG(ISPNUM-1)) THEN FOFSEG(ISPNUM)=F+0.5*ABS(DFCON) ELSE FOFSEG(ISPNUM)=F-0.5*ABS(DFCON) ENDIF ELSE SUMSEG=SUMSEG+F FOFSEG(ISPNUM)=SUMSEG/NINSEG ENDIF C RECORD NEXT POINT IN LIST X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) ISPLEN(ISPNUM)=ISPLEN(ISPNUM)+1 IF ((ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1).GT.NWORK) THEN NCRASH=6 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF SPACE(1,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=X SPACE(2,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=Y S=ST IF (S.LT.3.0) THEN IF (THRU) THEN GO TO 400 ELSE GO TO 500 ENDIF ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7779) 7779 FORMAT(/ / /' TABLE OF NON-CONTOUR SEGMENTS ALONG SIDES:'/ + ' NUMBER FOFSEG ISPPNT ISPLEN ', + 'X, Y OF FIRST POINT X,Y OF LAST POINT') DO 107 I=1,ISPNUM WRITE(6,7780)I,FOFSEG(I),ISPPNT(I),ISPLEN(I), + (SPACE(J,ISPPNT(I)),J=1,2), + (SPACE(J,ISPPNT(I)+ISPLEN(I)-1),J=1,2) 7780 FORMAT(' ',I5,5X,1P,E10.3,0P,2I10,1P,4E10.3) 107 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C CLEAN-UP THE SEGMENT F VALUES TO MID-RANGE NUMBERS C DO 550 I=1,ISPNUM T=FOFSEG(I)/DFCON IF (ALLPOS) T=MAX(T,0.0) T=IUNDER(T)+0.5 FOFSEG(I)=T*DFCON 550 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7782) DFCON 7782 FORMAT(/ / ' REVISED FOFSEG VALUES: (DFCON=', + 1P,E12.5,')') DO 108 I=1,ISPNUM WRITE(6,7784)I,FOFSEG(I) 7784 FORMAT(' ',I10,1P,E10.3) 108 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C*************************************************************** C C SEARCH FOR EXTREMUM WITHIN DOMAIN OF ELEMENT C CDET=16.*(-F6**2+2.*F6*F5+2.*F6*F4-2.*F6*F2-F5**2+2.*F5*F4 + -2.*F5*F1-F4**2-2.*F4*F3+F3*F2+F3*F1+F2*F1) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7785) CDET 7785 FORMAT(/' EXTREMUM DETERMINANT CDET=',1P,E12.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (ABS(CDET).LT. 1.E-30) GO TO 1000 S2EXT=(4.*F6**2-4.*F6*F5-4.*F6*F4-F6*F3+2.*F6*F2-F6*F1+F5* + F3+3.*F5*F1+3.*F4*F3+F4*F1-F3*F2-2.*F3*F1-F2*F1)/(4.*(F6 + **2-2.*F6*F5-2.*F6*F4+2.*F6*F2+F5**2-2.*F5*F4+2.*F5*F1+F4 + **2+2.*F4*F3-F3*F2-F3*F1-F2*F1)) S3EXT=(-4.*F6*F4+3.*F6*F2+F6*F1-4.*F5*F4+F5*F2+3.*F5*F1+4. + *F4**2+2.*F4*F3-F4*F2-F4*F1-F3*F2-F3*F1-2.*F2*F1)/(4.*(F6 + **2-2.*F6*F5-2.*F6*F4+2.*F6*F2+F5**2-2.*F5*F4+2.*F5*F1+F4 + **2+2.*F4*F3-F3*F2-F3*F1-F2*F1)) S1EXT=1.0-S2EXT-S3EXT C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7786)S1EXT,S2EXT,S3EXT 7786 FORMAT(/' EXTREMUM AT S1-3=',3F10.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (S1EXT.GT.0.99999.OR.S1EXT.LT.0.00001) GO TO 1000 IF (S2EXT.GT.0.99999.OR.S2EXT.LT.0.00001) GO TO 1000 IF (S3EXT.GT.0.99999.OR.S3EXT.LT.0.00001) GO TO 1000 C C REJECT SADDLE POINTS C DISCA=F1-2.*F4+F2 DISCB=F2-2.*F5+F3 DISCC=F3-2.*F6+F1 CENTER=((DISCA.GT.0.).AND.(DISCB.GT.0.).AND.(DISCC.GT.0.)) + .OR.((DISCA.LT.0.).AND.(DISCB.LT.0.).AND.(DISCC.LT.0.)) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7789) CENTER,DISCA,DISCB,DISCC 7789 FORMAT(/' CENTER=',L2,' BECAUSE DISCA-C=',1P,3E12.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (.NOT.CENTER) GO TO 1000 XEXT=PHIVAL(S1EXT,S2EXT,S3EXT,X1,X2,X3,X4,X5,X6) YEXT=PHIVAL(S1EXT,S2EXT,S3EXT,Y1,Y2,Y3,Y4,Y5,Y6) FEXT=PHIVAL(S1EXT,S2EXT,S3EXT,F1,F2,F3,F4,F5,F6) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8801)XEXT,YEXT,FEXT 8801 FORMAT(/' EXTREMUM IS AT X=',1P,E10.3,', Y=',E10.2, + ', F=',E10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ FMAX=MAX(FMAX,FEXT) FMIN=MIN(FMIN,FEXT) C C FIND CONTOUR STARTING/STOPPING POINT ALONG CHORD FROM A NODE TO EXT. C NCL=1 DIFF=ABS(F1-FEXT) DS(1)=S1EXT-1. DS(2)=S2EXT DS(3)=S3EXT DO 600 J=2,6 DFF=ABS(FN(J)-FEXT) IF (DFF.LT.DIFF) THEN NCL=J DIFF=DFF DS(1)=S1EXT DS(2)=S2EXT DS(3)=S3EXT IF (J.EQ.2) DS(2)=S2EXT-1. IF (J.EQ.3) DS(3)=S3EXT-1. IF (J.EQ.4.OR.J.EQ.6) DS(1)=S1EXT-0.5 IF (J.EQ.4.OR.J.EQ.5) DS(2)=S2EXT-0.5 IF (J.EQ.5.OR.J.EQ.6) DS(3)=S3EXT-0.5 ENDIF 600 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8812)NCL,DIFF,(DS(K),K=1,3) 8812 FORMAT(/' PARTITION LINE:'/ + ' NCL=',I10,' DIFF=',1P,E10.3,' DS(1-3)=',0P, + 3F10.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ CALL DOLINE (FEXT,DFCON,FN,NCL,DS,S1EXT,S2EXT,S3EXT, + IHIC,ILOC,PS,NPS,NINLIN,Z) IF (Z) THEN NCRASH=7 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF C C END OF CODE RELATED TO CASE OF AN INTERNAL EXTREMUM C C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT.AND.(NPS.GT.0)) THEN WRITE(6,8821) 8821 FORMAT(/ /' TABLE OF CONTOUR STARTING POINTS:') DO 8825 I=1,NPS XQ=PHIVAL(PS(1,I),PS(2,I),PS(3,I),X1,X2,X3,X4,X5,X6) YQ=PHIVAL(PS(1,I),PS(2,I),PS(3,I),Y1,Y2,Y3,Y4,Y5,Y6) WRITE(6,8823)I,(PS(K,I),K=1,4),XQ,YQ 8823 FORMAT(' ',I10,0P,3F10.5,1P,3E10.3) 8825 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 1000 IF (NPS.EQ.0) GO TO 9001 C C************************************************************* C C INTEGRATE ALL CONTOUR SEGMENTS C DO 1150 K=1,NPS DONE(K)=.FALSE. 1150 CONTINUE DO 9000 N=1,NPS C C INTEGRATE ONE CONTOUR SEGMENT C IF (.NOT.DONE(N)) THEN C C INITIALIZE INTEGRATION OF CONTOUR C DONE(N)=.TRUE. FVALUE=PS(4,N) IF (ALLPOS.AND.(FVALUE.LE.0.0)) GO TO 9000 ISPNUM=ISPNUM+1 C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8831)ISPNUM,FVALUE 8831 FORMAT(/' HISTORY OF SEGMENT ',I5,' (',1P,E10.3,')') ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (ISPNUM.GT.NINLIN) THEN NCRASH=8 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF FOFSEG(ISPNUM)=FVALUE ISPPNT(ISPNUM)=ISPPNT(ISPNUM-1)+ISPLEN(ISPNUM-1) IF (ISPPNT(ISPNUM).GT.NWORK) THEN NCRASH=9 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF ISPLEN(ISPNUM)=1 NTOGO(ISPNUM)=2 ANEDGE(ISPNUM)=.FALSE. S1=PS(1,N) S2=PS(2,N) S3=PS(3,N) INSIDE=(S1*S2*S3).GT.0.0 S1OLD=S1 S2OLD=S2 S3OLD=S3 X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) SPACE(1,ISPPNT(ISPNUM))=X SPACE(2,ISPPNT(ISPNUM))=Y ANGLE=0. IF (CENTER) ANGLE=ATAN2((Y-YEXT),(X-XEXT)) ANGLEP=ANGLE ROT=0. DFDS2=-4.*S3*F6+4.*S3*F5-4.*S3*F4+4.*S3*F1-8.*S2*F4+4.*S2* + F2+4.*S2*F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3*F6+4.*S3*F3+4.*S3*F1-4.*S2*F6+4.*S2*F5-4.*S2* + F4+4.*S2*F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX DS2=ROUNDX*DSTEP*0.1 DS3=ROUNDY*DSTEP*0.1 C C REVERSE INTEGRATION STEP DIRECTION IF CONTOUR POINTS OUTWARD C S2P=S2+DS2 S3P=S3+DS3 S1P=1.00-S2P-S3P COUNTR=1. IF ( (S1P.LT.0..OR.S1P.GT.1.) + .OR.(S2P.LT.0..OR.S2P.GT.1.) + .OR.(S3P.LT.0..OR.S3P.GT.1.)) COUNTR= -1. NSEG=0 C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,3412)ISPPNT(ISPNUM),X,Y,ANGLE 3412 FORMAT(' BEGINNING AT ISPPNT=',I10,' X=',1P,E10.3, + ' Y=',E10.3,' ANGLE=',0P,F10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C BEGIN LOOP OF INTEGRATION OF CONTOUR LINE C-------------------------------------------- C 3000 NSEG=NSEG+1 C EXTRAPOLATE TO NEXT POINT BY FORWARD METHOD DS2=ROUNDX*COUNTR*DSTEP DS3=ROUNDY*COUNTR*DSTEP S2P=S2+DS2 S3P=S3+DS3 S1P=1.00-S2P-S3P C RECOMPUTE SAME STEP BY BACKWARD METHOD DFDS2=-4.*S3P*F6+4.*S3P*F5-4.*S3P*F4 + +4.*S3P*F1-8.*S2P*F4+4.*S2P* + F2+4.*S2P*F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3P*F6+4.*S3P*F3+4.*S3P*F1 + -4.*S2P*F6+4.*S2P*F5-4.*S2P* + F4+4.*S2P*F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX DS2P=ROUNDX*DSTEP*COUNTR DS3P=ROUNDY*DSTEP*COUNTR C ACTUAL INTEGRATION STEP BY TRAPEZOIDAL METHOD DS2=0.5*(DS2+DS2P) DS3=0.5*(DS3+DS3P) DSLEN=SQRT(DS2**2+DS3**2) IF((DSLEN/DSTEP).LT.0.10) GO TO 8999 S2=S2+DS2 S3=S3+DS3 S1=1.00-S2-S3 C CORRECT CONTOUR TO ACTUAL VALUE DESIRED TRIAL=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) ERRER=TRIAL-FVALUE IF (ABS(ERRER).GE.DFCON) GO TO 8999 DFDS2=-4.*S3 *F6+4.*S3 *F5-4.*S3 *F4 + +4.*S3 *F1-8.*S2 *F4+4.*S2 * + F2+4.*S2 *F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3 *F6+4.*S3 *F3+4.*S3 *F1 + -4.*S2 *F6+4.*S2 *F5-4.*S2 * + F4+4.*S2 *F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF DISTNC= -ERRER/(GRADF*GSIZE) IF (ABS(DISTNC).GT.DSTEP) DISTNC= + DISTNC*DSTEP/ABS(DISTNC) S2=S2+DISTNC*GRADFX S3=S3+DISTNC*GRADFY S1=1.00-S2-S3 C DECIDE WHETHER CONTOUR IS FINISHED OR NOT HITLIM=NSEG.GE.LIMINT IF (HITLIM) WRITE(6,3501)FVALUE,I 3501 FORMAT(' ',1PE10.2,' CONTOUR IN ELEMENT ',I3, + ' SEEMS TO BE IN LOOP. TERMINATED.') GONOUT=(S1.LT.0..OR.S1.GT.1.).OR. + (S2.LT.0..OR.S2.GT.1.).OR. + (S3.LT.0..OR.S3.GT.1.) FINISH=GONOUT.OR.HITLIM IF (CENTER) THEN XT=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YT=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) ANGLEP=ATAN2((YT-YEXT),(XT-XEXT)) DROT=MIN(ABS(ANGLEP-ANGLE), & 6.2832-ABS(ANGLEP-ANGLE)) ROT=ROT+DROT CIRCLE=ROT.GE.6.2832 FINISH=FINISH.OR.CIRCLE IF (CIRCLE.AND.INSIDE) THEN S1=PS(1,N) S2=PS(2,N) S3=PS(3,N) ENDIF ENDIF C IF VECTOR EXTENDS OUTSIDE OF THE ELEMENT, SHORTEN IT ....... IF (GONOUT) THEN RAT=1.0 IF(S1.GT.1.)RAT=AMIN1(RAT,((1.-S1OLD)/(S1-S1OLD))) IF(S2.GT.1.)RAT=AMIN1(RAT,((1.-S2OLD)/(S2-S2OLD))) IF(S3.GT.1.)RAT=AMIN1(RAT,((1.-S3OLD)/(S3-S3OLD))) IF(S1.LT.0.)RAT=AMIN1(RAT,((0.-S1OLD)/(S1-S1OLD))) IF(S2.LT.0.)RAT=AMIN1(RAT,((0.-S2OLD)/(S2-S2OLD))) IF(S3.LT.0.)RAT=AMIN1(RAT,((0.-S3OLD)/(S3-S3OLD))) RAT=AMAX1(RAT,0.0) S2=S2OLD+(S2-S2OLD)*RAT S3=S3OLD+(S3-S3OLD)*RAT S1=1.00-S2-S3 C .... AND CROSS OFF THE CORRESPONDING SIDE-CROSSING POINT IF ((N.LT.NPS).AND.(.NOT.INSIDE)) THEN XE=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YE=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) MATE=N R2MIN=9.9E59 NP1=N+1 DO 4000 M=NP1,NPS TEST=PS(1,M)*PS(2,M)*PS(3,M) IF ((.NOT.DONE(M)).AND. + (PS(4,M).EQ.FVALUE).AND. + (TEST.EQ.0.0) ) THEN XT=PHIVAL(PS(1,M),PS(2,M),PS(3,M), + X1,X2,X3,X4,X5,X6) YT=PHIVAL(PS(1,M),PS(2,M),PS(3,M), + Y1,Y2,Y3,Y4,Y5,Y6) R2=(XT-XE)**2+(YT-YE)**2 IF(R2.LT.R2MIN) THEN MATE=M R2MIN=R2 ENDIF ENDIF 4000 CONTINUE DONE(MATE)=.TRUE. S1=PS(1,MATE) S2=PS(2,MATE) S3=PS(3,MATE) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,3210)MATE 3210 FORMAT(' (CROSSING OFF STARTING POINT ',I5,')') ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ENDIF ENDIF C LOCATE (X,Y) COORDINATES OF DESTINATION POINT X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) C STORE (X,Y) COORDINATES FOR LATER ISPLEN(ISPNUM)=ISPLEN(ISPNUM)+1 IF ((ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1).GT.NWORK) THEN NCRASH=10 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF SPACE(1,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=X SPACE(2,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=Y C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,4026)S1,S2,S3,X,Y 4026 FORMAT(' S1-3=',0P,3F10.5,' X=',1P,E10.3,' Y=',E10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$4 C PREPARE FOR NEXT ITERATION IF ONE IS NEEDED S1OLD=S1 S2OLD=S2 S3OLD=S3 IF (.NOT.FINISH) THEN DFDS2=-4.*S3 *F6+4.*S3 *F5-4.*S3 *F4 + +4.*S3 *F1-8.*S2 *F4+4.*S2 * + F2+4.*S2 *F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3 *F6+4.*S3 *F3+4.*S3 *F1 + -4.*S2 *F6+4.*S2 *F5-4.*S2 * + F4+4.*S2 *F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX ANGLE=ANGLEP C C END LOOP OF PUSHING FORWARD ONE CONTOUR SEGMENT C ------------------------------------------ C GO TO 3000 ENDIF C PROVIDE EMERGENCY TERMINATION POINT FOR BEWILDERED CONTOURS 8999 CONTINUE C END OF CODE EXECUTED IF (SEGMENT NOT ALREADY INTEGRATED) ENDIF C CLOSE LOOP ON ALL CONTOUR SEGMENTS 9000 CONTINUE C C**************************************************************** C C BEGIN C CONNECTION OF CONTOUR SEGMENTS AND EDGE SEGMENTS TO CLOSE AREAS C 9001 LEVEL1=IUNDER(FMIN/DFCON) LEVEL2=IUNDER(FMAX/DFCON) IF (ALLPOS) LEVEL1=MAX(LEVEL1,0) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,9542)LEVEL1,LEVEL2 9542 FORMAT(/ / /' BASE (UNDER) LEVELS ARE LEVEL1=',I5, + ' LEVEL2=',I5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ DO 9900 IC=LEVEL1,LEVEL2 FCENTR=(IC+0.5)*DFCON IF (ALLPOS) THEN FCENTC=MAX(FCENTR,0.5*DFCON) ELSE FCENTC=FCENTR ENDIF N=IHUE(NCOLOR,DFCON,FMIDLE,IFLIP,FCENTC) IF (COLOR) THEN CALL TONCLR(ICOLOR(N)) IF (N.EQ.1) THEN KOLORC=9 SURROU=.TRUE. C OUTLINE OFF-SPECTRUM LOW (BLACK?) AREAS W/ WHITE ELSE IF (N.EQ.NCOLOR) THEN KOLORC=1 SURROU=.TRUE. C OUTLINE OFF-SPECTRUM HIGH (WHITE?) AREAS W/ BLACK ELSE SURROU=.FALSE. C DO NOT SURROUND COLORED AREAS WITH CONTOURS IF (N.GE.2.AND.N.LE.4) NBLUE=NBLUE+1 IF (N.GE.6.AND.N.LE.8) NYELOW=NYELOW+1 ENDIF IF (ALLPOS.AND.FCENTR.LT.0.0) THEN SURROU=.FALSE. ENDIF ELSE CALL SETPAT(N) SURROU=.TRUE. KOLORC=1 C MEANS SURROUND ALL AREAS WITH BLACK CONTOURS ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,4056)IC ,N 4056 FORMAT(/' FOR BASE LEVEL ',I5,' HUE OR PATTERN=',I5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C BUILD MENU OF RELEVANT SEGMENTS (SO THAT NONE IS USED TWICE) NMENU=0 DO 9020 I=1,ISPNUM IF(ABS((FOFSEG(I)-FCENTR)/DFCON).LE.0.75) THEN IF (NTOGO(I).GT.0) THEN NTOGO(I)=NTOGO(I)-1 NMENU=MIN(NMENU+1,NINLIN) MENU(NMENU)=I ENDIF ENDIF 9020 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,4278) 4278 FORMAT(/' MENU OF SEGMENTS:'/ + ' INDEX SEGMENT') DO 4280 I=1,NMENU WRITE(6,4279)I,MENU(I) 4279 FORMAT(' ',2I10) 4280 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NAREAS=0 NPOLY=0 C DRAW ONE OR MORE CLOSED AREAS FROM MENU OF RELEVANT SEGMENTS C (NEXT STATEMENT IS BEGINNING OF INDEFINITE LOOP ON AREAS) 9050 IF (NMENU.LE.0) GO TO 9900 IF (NAREAS.LT.MXAREA) THEN NAREAS=NAREAS+1 ELSE NCRASH=11 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF NINARE(NAREAS)=0 C BEGIN EACH CLOSED AREA WITH THE TOP SEGMENT IN THE MENU C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8238) 8238 FORMAT(/' BEGINNING NEW CLOSED AREA; SEGMENTS USED ARE:') ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IDISH=1 NADD=+1 I1=ISPPNT(MENU(1)) XORIGN=SPACE(1,I1) YORIGN=SPACE(2,I1) C BEGIN INDEFINATE LOOP ON SEGMENTS IN ONE AREA C ------------------------------------- 9100 NAME=MENU(IDISH) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,3756)NAME,NADD 3756 FORMAT(' ',I5,I10) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (ANEDGE(NAME)) THEN KOLORP=0 ELSE KOLORP=KOLORC ENDIF IF (NADD.EQ.1) THEN I1=ISPPNT(NAME) I2=I1+ISPLEN(NAME)-1 ELSE I2=ISPPNT(NAME) I1=I2+ISPLEN(NAME)-1 ENDIF DO 9500 I=I1,I2,NADD X=SPACE(1,I) Y=SPACE(2,I) IF (NPOLY.LT.NPOLYV) THEN NPOLY=NPOLY+1 NINARE(NAREAS)=NINARE(NAREAS)+1 ELSE NCRASH=12 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF XARRAY(NPOLY)=X YARRAY(NPOLY)=Y IPCLR(NPOLY)=KOLORP 9500 CONTINUE C DROP SEGMENT FROM MENU IMMEDIATELY AFTER DRAWING NMENU=NMENU-1 DO 9510 J=IDISH,NMENU MENU(J)=MENU(J+1) 9510 CONTINUE C IF NECESSARY, STRING TOGETHER OTHER SEGMENTS TO COMPLETE AREA IF (NMENU.LE.0) GO TO 9895 RMIN=1.E60 DO 9600 J=1,NMENU XB=SPACE(1,ISPPNT(MENU(J))) YB=SPACE(2,ISPPNT(MENU(J))) RB=SQRT((X-XB)**2+(Y-YB)**2) IF (RB.LT.RMIN) THEN RMIN=RB IDISH=J NADD=+1 ENDIF XE=SPACE(1,ISPPNT(MENU(J))+ISPLEN(MENU(J))-1) YE=SPACE(2,ISPPNT(MENU(J))+ISPLEN(MENU(J))-1) RE=SQRT((X-XE)**2+(Y-YE)**2) IF (RE.LT.RMIN) THEN RMIN=RE IDISH=J NADD= -1 ENDIF 9600 CONTINUE C DECISION POINT: POSSIBLE END OF INNER LOOP ON SEGMENTS R=SQRT((X-XORIGN)**2+(Y-YORIGN)**2) IF (R.GT.RMIN) THEN C LOOP IS NOT FINISHED; GET MORE SEGMENTS. GO TO 9100 ELSE C LOOP IS FINISHED; TIDY UP AND BEGIN ANOTHER. IF (R.GT.0.) THEN IF (NPOLY.LT.NPOLYV) THEN NPOLY=NPOLY+1 NINARE(NAREAS)=NINARE(NAREAS)+1 ELSE NCRASH=13 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF XARRAY(NPOLY)=XORIGN YARRAY(NPOLY)=YORIGN IPCLR(NPOLY)=KOLORP ENDIF IF (NMENU.GT.0) GO TO 9050 ENDIF C C CALL FOR SHADING OF THE AREA(S) OF A SINGLE COLOR C 9895 CALL TONE(XARRAY,YARRAY,NINARE,NAREAS) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,3945) 3945 FORMAT(' PAINTING AND OUTLINING THIS AREA...') ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (SURROU) THEN C IF AREAS ARE TO BE OUTLINED, THEN C DRAW OUTLINES OF AREA(S) WITH PEN C N2=0 DO 9899 KAREA=1,NAREAS N1=N2+1 N2=N1+NINARE(KAREA)-1 CALL PLOT(XARRAY(N1),YARRAY(N1),3) DO 9898 J=N1+1,N2 KOLORP=IPCLR(J) IF (KOLORP.EQ.0) THEN IPEN=3 C LIFT PEN ELSE IPEN=2 C LOWER PEN, POSSIBLY COLORED IF (COLOR.AND.(KOLORP.NE.LASTKO)) THEN CALL PENCLR(IPENCT,KOLORP) CALL NEWPEN(IPENCT) LASTKO=KOLORP ENDIF ENDIF CALL PLOT(XARRAY(J),YARRAY(J),IPEN) 9898 CONTINUE 9899 CONTINUE ENDIF C C CLOSE LOOP ON THE DIFFERENT COLOR LEVELS IN ONE ELEMENT C 9900 CONTINUE C C *************************************************************** C C CLOSE LOOP ON ALL ELEMENTS FGMAX=MAX(FGMAX,FMAX) FGMIN=MIN(FGMIN,FMIN) 9999 CONTINUE IF (COLOR) THEN CALL PENCLR(IPENCT,1) CALL NEWPEN(IPENCT) ENDIF RETURN END C C C SUBROUTINE AROUND (I,S4,S5,S6,NODES,XNOD,YNOD,NUMNOD,NUMEL) C C DRAW ONE OR MORE SIDE OF AN ELEMENT C (A LOT OF CODE IS NEEDED TO DECIDE IF THE SIDE IS BENT OR NOT. C THIS IS BECAUSE STRAIGHT SIDES CAN BE DRAWN IN ONE STEP, GIVING C A BETTER DASHED LINE IN B/W. OFTEN, A CURVED SIDE DRAWN IN A C NUMBER OF STEPS (NSTEP9) WILL HAVE PROBLEMS WITH ITS DASHES.) C LOGICAL BENT,S4,S5,S6 DIMENSION NODES(6,NUMEL),XNOD(NUMNOD),YNOD(NUMNOD) DIMENSION S(3),DS(3) DATA NSTEP9 /6/ 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) I1=NODES(1,I) I2=NODES(2,I) I3=NODES(3,I) I4=NODES(4,I) I5=NODES(5,I) I6=NODES(6,I) X1=XNOD(I1) X2=XNOD(I2) X3=XNOD(I3) X4=XNOD(I4) X5=XNOD(I5) X6=XNOD(I6) Y1=YNOD(I1) Y2=YNOD(I2) Y3=YNOD(I3) Y4=YNOD(I4) Y5=YNOD(I5) Y6=YNOD(I6) DO 100 ISIDE=1,3 IF (ISIDE.EQ.1.AND..NOT.S4) GO TO 100 IF (ISIDE.EQ.2.AND..NOT.S5) GO TO 100 IF (ISIDE.EQ.3.AND..NOT.S6) GO TO 100 J1=ISIDE J2=MOD(ISIDE,3)+1 X0=XNOD(NODES(J1,I)) Y0=YNOD(NODES(J1,I)) XH=XNOD(NODES(J1+3,I)) YH=YNOD(NODES(J1+3,I)) XW=XNOD(NODES(J2,I)) YW=YNOD(NODES(J2,I)) SIDE=SQRT((XW-X0)**2+(YW-Y0)**2) XM=0.5*(X0+XW) YM=0.5*(Y0+YW) OFFSET=SQRT((XH-XM)**2+(YH-YM)**2) BENT=(OFFSET/SIDE).GT.0.05 DO 10 K=1,3 S(K)=0. DS(K)=0. 10 CONTINUE S(J1)=1.00 IF (BENT) THEN NSTEP=NSTEP9 ELSE NSTEP=1 ENDIF STEP=1./(1.*NSTEP) DS(J1)= -STEP DS(J2)= STEP X=PHIVAL(S(1),S(2),S(3),X1,X2,X3,X4,X5,X6) Y=PHIVAL(S(1),S(2),S(3),Y1,Y2,Y3,Y4,Y5,Y6) CALL PLOT(X,Y,3) DO 20 K=1,NSTEP DO 15 L=1,3 S(L)=S(L)+DS(L) 15 CONTINUE X=PHIVAL(S(1),S(2),S(3),X1,X2,X3,X4,X5,X6) Y=PHIVAL(S(1),S(2),S(3),Y1,Y2,Y3,Y4,Y5,Y6) CALL PLOT(X,Y,2) 20 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE USMAP (INPUT,DRAWST,NXYST,XST,YST) C C PLOTS OUTLINE OF STATES FROM DIGITIZED DATASET. C LOGICAL DRAW LOGICAL DRAWST DIMENSION DRAWST(NXYST),XST(NXYST),YST(NXYST) DO 100 I=1,NXYST XP=XST(I) YP=YST(I) DRAW=DRAWST(I) IF (DRAW) THEN CALL PLOT(XP,YP,2) ELSE CALL PLOT(XP,YP,3) ENDIF 100 CONTINUE RETURN END C C C SUBROUTINE ARROW (NUMEL,OUTVEC,SIZEAR, + XIP,YIP,CINT,XMAX,YTOP) C C DRAWS VECTORS WITH RMS LENGTH SIZEAR FROM ELEMENT C CENTERS. C THEN DRAWS A LARGE SAMPLE ARROW IN A BOX UP AGAINST LIMITS C XMAX AND YTOP. C DIMENSION OUTVEC(2,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) CHARACTER*8 SCALE C**************************************************************** C COPY INPUT PARAMETERS XMAX AND YTOP C BECAUSE COMPILER WORRIES THEY MIGHT BE CHANGED BY "CALL PLOT" XMAXT=XMAX YTOPT=YTOP C****************************************************************** SUM=0. BIG=0. DO 100 I=1,NUMEL T=OUTVEC(1,1,I)**2+OUTVEC(2,1,I)**2 SUM=SUM+T BIG=MAX(BIG,T) 100 CONTINUE IF (SUM.LE.0.) RETURN FACTR=SIZEAR/SQRT(SUM/NUMEL) BIG=SQRT(BIG) BIG=MIN(BIG,2.*SIZEAR/FACTR) N=BIG/CINT+0.5 BIG=MAX(N,1)*CINT DO 200 I=1,NUMEL X=XIP(1,I) Y=YIP(1,I) CALL PLOT(X,Y,3) DX=FACTR*OUTVEC(1,1,I) DY=FACTR*OUTVEC(2,1,I) XP=X+DX YP=Y+DY CALL PLOT(XP,YP,2) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XP+BX,YP+BY,2) 200 CONTINUE CALL PLOT(XMAXT,YTOPT,3) WIDE=MAX(0.85,(0.1+BIG*FACTR+0.1)) HIGH=0.4 CALL PLOT(XMAX-WIDE,YTOPT,2) CALL PLOT(XMAX-WIDE,YTOP-HIGH,2) CALL PLOT(XMAXT,YTOP-HIGH,2) CALL PLOT(XMAXT,YTOPT,2) X=XMAX-0.5*WIDE-0.5*BIG*FACTR Y=YTOP-0.15 CALL PLOT(X,Y,3) DX=BIG*FACTR DY=0. XP=X+DX YP=Y+DY CALL PLOT(XP,YP,2) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XP+BX,YP+BY,2) WRITE (SCALE,390) BIG 390 FORMAT(1P,E8.1) DO 400 I=1,8 IF (SCALE(I:I).EQ.'0') THEN SCALE(I:I)='O' ENDIF 400 CONTINUE CALL SYMBOL(XMAX-0.85-0.5*(WIDE-0.85),YTOP-HIGH+0.03, + 0.12,SCALE,IDUMMY,0.,8) RETURN END C C C SUBROUTINE AXES (NUMEL,TAUMT,TAUZZ,SIZEAX,IPEN, + XIP,YIP,CINT,VFACT,XMAX,YTOP) C C DRAWS TENSOR PRINCIPAL AXES, WITH RMS LENGTH SIZEAX, C AT ELEMENT CENTERS. (VFACT IS CURRENT SCALE FACTOR, INCH/M.) C CONVENTION IS THAT AN AXIS IS COMPRESSIVE (INWARD-POINTING) C IF THE CORRESPONDING PRINCIPAL VALUE OF THE TENSOR IS NEGATIVE. C ALSO DRAWS 2 LARGE SAMPLE TENSORS (ISOTROPIC, + AND - SAMPLES) C IN A BOX UP AGAINST LIMITS XMAX AND YTOP. C CHARACTER*8 SCALE DIMENSION TAUMT(3,7,NUMEL),TAUZZ(7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) C 1001 FORMAT(1P,E8.1) C CALL NEWPEN (IPEN) SUM=0. BIG=0. DO 100 I=1,NUMEL TZZ=TAUZZ(1,I) TXX=TAUMT(1,1,I)+TZZ TYY=TAUMT(2,1,I)+TZZ TXY=TAUMT(3,1,I) SHEAR=SQRT((1.D0*TXY)**2+0.25*(1.D0*TXX-TYY)**2) CENTER=(TXX+TYY)/2. T1=CENTER-SHEAR T2=CENTER+SHEAR SUM=SUM+(MAX(ABS(T1),ABS(T2),ABS(TZZ)))**2 BIG=MAX(BIG,ABS(T1),ABS(T2)) 100 CONTINUE IF (SUM.LE.0.) RETURN FACTR=0.5*SIZEAX/SQRT(SUM/NUMEL) BIG=MIN(0.5*BIG,SIZEAX/FACTR) N=BIG/CINT+0.5 BIG=MAX(N,1)*CINT C DO 200 I=1,NUMEL X=XIP(1,I) Y=YIP(1,I) TZZ=TAUZZ(1,I) TXX=TAUMT(1,1,I)+TZZ TYY=TAUMT(2,1,I)+TZZ TXY=TAUMT(3,1,I) SHEAR=SQRT((1.D0*TXY)**2+0.25*(1.D0*TXX-TYY)**2) CENTER=(TXX+TYY)/2. T1=CENTER-SHEAR T2=CENTER+SHEAR ANGLE=0.5*ATAN2F(-TXY,(TYY-TXX)/2.) DR=FACTR*ABS(TZZ) IF (TZZ.LT.0.0) THEN C CIRCLE FOR COMPRESSIVE VERTICAL STRESS CALL CIRCLE(X,Y,-DR,MIN0(IPEN,7)) ELSE IF (TZZ.GT.0.0) THEN C TRIANGLE FOR TENSILE VERTICAL STRESS CALL PLOT(X+0.866*DR,Y-0.5*DR,3) CALL PLOT(X,Y+DR,2) CALL PLOT(X-0.866*DR,Y-0.5*DR,2) CALL PLOT(X+0.866*DR,Y-0.5*DR,2) ENDIF DX=FACTR*T1*COS(ANGLE) DY=FACTR*T1*SIN(ANGLE) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) IF (T1.GT.0.0) THEN C TENSILE PRINCIPAL STRESS CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) ELSE C COMPRESSIVE PRINCIPAL STRESS CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) ENDIF DX=FACTR*T2*COS(ANGLE+1.5708) DY=FACTR*T2*SIN(ANGLE+1.5708) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) IF (T2.GT.0.0) THEN C TENSILE PRINCIPAL STRESS CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) ELSE C COMPRESSIVE PRINCIPAL STRESS CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) ENDIF 200 CONTINUE C C PLOT REFERENCE BOX C CALL PLOT(XMAX,YTOP,3) WIDE=1.15*(4.*BIG*FACTR) HIGH=1.10*(2.*BIG*FACTR) CALL PLOT(XMAX-WIDE,YTOP,2) CALL PLOT(XMAX-WIDE,YTOP-HIGH,2) CALL PLOT(XMAX,YTOP-HIGH,2) CALL PLOT(XMAX,YTOP,2) ANGLE=0. DR=BIG*FACTR C C ISOTROPIC COMPRESSIVE TENSOR C X=XMAX-WIDE+1.1*DR Y=YTOP-1.1*DR TZZ= -BIG T1= -BIG T2= -BIG CALL CIRCLE(X,Y,-DR,MIN0(IPEN,7)) DX=FACTR*T1*COS(ANGLE) DY=FACTR*T1*SIN(ANGLE) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) DX=FACTR*T2*COS(ANGLE+1.5708) DY=FACTR*T2*SIN(ANGLE+1.5708) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) C C ISOTROPIC EXTENSIONAL TENSOR C X=XMAX-1.1*DR Y=YTOP-1.1*DR TZZ=BIG T1=BIG T2=BIG CALL PLOT(X+0.866*DR,Y-0.5*DR,3) CALL PLOT(X,Y+DR,2) CALL PLOT(X-0.866*DR,Y-0.5*DR,2) CALL PLOT(X+0.866*DR,Y-0.5*DR,2) DX=FACTR*T1*COS(ANGLE) DY=FACTR*T1*SIN(ANGLE) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) DX=FACTR*T2*COS(ANGLE+1.5708) DY=FACTR*T2*SIN(ANGLE+1.5708) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) C C WRITE LABEL C WRITE (SCALE,390) BIG 390 FORMAT (1P,E8.1) DO 400 I=1,8 IF (SCALE(I:I).EQ.'0') THEN SCALE(I:I)='O' ENDIF 400 CONTINUE CALL SYMBOL (XMAX-0.85/VFACT-0.5*(WIDE-0.85/VFACT), + YTOP-HIGH+0.03/VFACT, + 0.12/VFACT,SCALE,IDUMMY,0.,8) RETURN END C C C SUBROUTINE FICONS (NUMEL,ERATE,SIZEIC, + XIP,YIP) C C DRAWS FAULT ICONS, WITH UNIFORM LENGTH OF SIZEIC, C AT ELEMENT CENTERS. C CONVENTION IS THAT STRAIN IS COMPRESSIVE (INWARD-POINTING) C IF PRINCIPAL VALUE(S) OF ERATE ARE NEGATIVE. C ALSO NOTE THAT INTERNAL VARIABLE "ANGLE" IS DIRECTION OF E1 C MEASURED COUNTERCLOCKWISE FROM X (RIGHT). C DIMENSION ERATE(3,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) DIMENSION XARRAY(20),YARRAY(20) LOGICAL E1PART,E2PART,EZPART C DO 200 I=1,NUMEL X=XIP(1,I) Y=YIP(1,I) EXX=ERATE(1,1,I) EYY=ERATE(2,1,I) EXY=ERATE(3,1,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 EZ= -DIVER IF ((E2*EZ).GT.0.) THEN E1PART=.TRUE. E2PART=.FALSE. EZPART=.FALSE. ELSE IF ((E1*EZ).GT.0.) THEN E1PART=.FALSE. E2PART=.TRUE. EZPART=.FALSE. ELSE E1PART=.FALSE. E2PART=.FALSE. EZPART=.TRUE. END IF ANGLE=0.5*ATAN2F(-EXY,(EYY-EXX)/2.) BIGSHR=0. IF (E1*E2.LT.0.) BIGSHR=MAX(BIGSHR,MIN(ABS(E1),ABS(E2))) IF (E1*EZ.LT.0.) BIGSHR=MAX(BIGSHR,MIN(ABS(E1),ABS(EZ))) IF (E2*EZ.LT.0.) BIGSHR=MAX(BIGSHR,MIN(ABS(E2),ABS(EZ))) FACTR=0.5*SIZEIC/MAX(BIGSHR,1.E-30) IF (E1*E2.LT.0.) THEN C STRIKE-SLIP FAULTS IF (E1PART) THEN R=FACTR*ABS(E2) ELSE R=FACTR*ABS(E1) END IF DX=R*COS(ANGLE+0.5236) DY=R*SIN(ANGLE+0.5236) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) DX=R*COS(ANGLE-0.5236) DY=R*SIN(ANGLE-0.5236) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) ENDIF IF (E1.LT.0..AND.EZ.GT.0.) THEN C THRUST FAULTS PERP. TO E1 IF (E1PART) THEN R=FACTR*ABS(EZ) ELSE R=FACTR*ABS(E1) END IF DX=R*COS(ANGLE+1.5708) DY=R*SIN(ANGLE+1.5708) DXP=0.20*R*COS(ANGLE+3.937) DYP=0.20*R*SIN(ANGLE+3.927) XARRAY(1)=X+DX XARRAY(2)=X+DX+DXP XARRAY(3)=X+DX+DXP-DYP XARRAY(4)=X+DX-DYP XARRAY(5)=X+DX YARRAY(1)=Y+DY YARRAY(2)=Y+DY+DYP YARRAY(3)=Y+DY+DYP+DXP YARRAY(4)=Y+DY+DXP YARRAY(5)=Y+DY CALL TONE(XARRAY,YARRAY,5,1) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) XARRAY(1)=X-DX XARRAY(2)=X-DX-DXP XARRAY(3)=X-DX-DXP+DYP XARRAY(4)=X-DX+DYP XARRAY(5)=X-DX YARRAY(1)=Y-DY YARRAY(2)=Y-DY-DYP YARRAY(3)=Y-DY-DYP-DXP YARRAY(4)=Y-DY-DXP YARRAY(5)=Y-DY CALL TONE(XARRAY,YARRAY,5,1) ENDIF IF (E2.LT.0..AND.EZ.GT.0.) THEN C THRUST FAULTS PERP. TO E2 IF (EZPART) THEN R=FACTR*ABS(E2) ELSE R=FACTR*ABS(EZ) END IF DX=R*COS(ANGLE) DY=R*SIN(ANGLE) DXP=0.20*R*COS(ANGLE+2.356) DYP=0.20*R*SIN(ANGLE+2.356) XARRAY(1)=X+DX XARRAY(2)=X+DX+DXP XARRAY(3)=X+DX+DXP-DYP XARRAY(4)=X+DX-DYP XARRAY(5)=X+DX YARRAY(1)=Y+DY YARRAY(2)=Y+DY+DYP YARRAY(3)=Y+DY+DYP+DXP YARRAY(4)=Y+DY+DXP YARRAY(5)=Y+DY CALL TONE(XARRAY,YARRAY,5,1) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) XARRAY(1)=X-DX XARRAY(2)=X-DX-DXP XARRAY(3)=X-DX-DXP+DYP XARRAY(4)=X-DX+DYP XARRAY(5)=X-DX YARRAY(1)=Y-DY YARRAY(2)=Y-DY-DYP YARRAY(3)=Y-DY-DYP-DXP YARRAY(4)=Y-DY-DXP YARRAY(5)=Y-DY CALL TONE(XARRAY,YARRAY,5,1) ENDIF IF (E1.GT.0..AND.EZ.LT.0.) THEN C NORMAL FAULTS PERP. TO E1 IF (E1PART) THEN R=FACTR*ABS(EZ) ELSE R=FACTR*ABS(E1) END IF DX1=R*COS(ANGLE+1.7682) DY1=R*SIN(ANGLE+1.7682) DX2=R*COS(ANGLE+1.3734) DY2=R*SIN(ANGLE+1.3734) XARRAY(1)=X+DX1 XARRAY(2)=X+DX2 XARRAY(3)=X-DX1 XARRAY(4)=X-DX2 XARRAY(5)=X+DX1 YARRAY(1)=Y+DY1 YARRAY(2)=Y+DY2 YARRAY(3)=Y-DY1 YARRAY(4)=Y-DY2 YARRAY(5)=Y+DY1 CALL TONE(XARRAY,YARRAY,5,1) ENDIF IF (E2.GT.0..AND.EZ.LT.0.) THEN C NORMAL FAULTS PERP. TO E2 IF (EZPART) THEN R=FACTR*ABS(E2) ELSE R=FACTR*ABS(EZ) END IF DX1=R*COS(ANGLE+0.1974) DY1=R*SIN(ANGLE+0.1974) DX2=R*COS(ANGLE-0.1974) DY2=R*SIN(ANGLE-0.1974) XARRAY(1)=X+DX1 XARRAY(2)=X+DX2 XARRAY(3)=X-DX1 XARRAY(4)=X-DX2 XARRAY(5)=X+DX1 YARRAY(1)=Y+DY1 YARRAY(2)=Y+DY2 YARRAY(3)=Y-DY1 YARRAY(4)=Y-DY2 YARRAY(5)=Y+DY1 CALL TONE(XARRAY,YARRAY,5,1) ENDIF 200 CONTINUE RETURN END C C C CHARACTER*9 FUNCTION ASCII9 (X) C C RETURNS A RIGHT-JUSTIFIED 9-BYTE ASCII VERSION OF A FLOATING- C POINT NUMBER, IN "HUMAN" FORMAT, WITH NO MORE THAN 3 SIGNIFICANT C DIGITS, AND WITH ALL '0' REPLACED BY 'O' (FOR ELEGANCE ON PLOTS). C CHARACTER*9 TEMP9 CHARACTER*17 TEMP17 LOGICAL PUNT C IF (X.GT.0.) THEN PUNT=(X.GT.9990000.).OR.(X.LT.0.0000100) ELSE IF (X.LT.0.) THEN PUNT=(X.LT.-999000.).OR.(X.GT.-0.000100) ELSE PUNT=.FALSE. ENDIF C IF (PUNT) THEN WRITE (TEMP9,'(1P,E9.2)') X IF (TEMP9(7:7).EQ.'+') THEN TEMP17(8:9)=TEMP9(8:9) TEMP17(2:7)=TEMP9(1:6) TEMP17(1:1)=' ' TEMP9=TEMP17(1:9) ENDIF IF (TEMP9(8:8).EQ.'0') THEN TEMP17(9:9)=TEMP9(9:9) TEMP17(2:8)=TEMP9(1:7) TEMP17(1:1)=' ' TEMP9=TEMP17(1:9) ENDIF DO 5 I=1,9 IF (TEMP9(I:I).EQ.'0') TEMP9(I:I)='O' 5 CONTINUE ASCII9=TEMP9 ELSE WRITE (TEMP17,'(F17.7)') X C C NPLACE IS THE POSITION OF THE FIRST SIG. DIGIT, COUNTING LEFT C FROM THE DECIMAL POINT (WHICH IS THE ZERO ORIGIN) IF (ABS(X).GE.1.) THEN NPLACE=1.00001+LOG10(ABS(X)) ELSE IF (X.NE.0.) THEN NPLACE=0.99999-LOG10(ABS(X)) NPLACE= -NPLACE ELSE NPLACE=0 ENDIF C C ZERO OUT NON-SIG. DIGITS NKEEP1=10-NPLACE IF ((NPLACE.EQ.1).OR.(NPLACE.EQ.2)) THEN NKEEP3=NKEEP1+3 ELSE NKEEP3=NKEEP1+2 ENDIF IF (NKEEP3.LT.17) THEN DO 20 J=NKEEP3+1,17 IF (TEMP17(J:J).NE.'.') THEN TEMP17(J:J)='0' ENDIF 20 CONTINUE ENDIF C C CONVERT '0' TO 'O' (LOOKS BETTER ON PLOTS) DO 30 J=1,17 IF (TEMP17(J:J).EQ.'0') TEMP17(J:J)='O' 30 CONTINUE C C FIND FIRST INFORMATION, FROM RIGHT TO LEFT, AND CHOOSE 9 BYTES DO 90 M=17,11,-1 IF (TEMP17(M:M).NE.'O') THEN K9=M GO TO 99 ENDIF 90 CONTINUE K9=9 99 CONTINUE K1=K9-8 TEMP9=TEMP17(K1:K9) C C INSERT COMMAS FOR LARGE NUMBERS C IF (ABS(X).GT.999.9) THEN TEMP9(1:5)=TEMP9(2:6) TEMP9(6:6)=',' IF (ABS(X).GT.999900.) THEN ASCII9(1:1)=TEMP9(2:2) ASCII9(2:2)=',' ASCII9(3:9)=TEMP9(3:9) ELSE ASCII9=TEMP9 ENDIF ELSE ASCII9=TEMP9 ENDIF ENDIF RETURN END