C PROGRAM PLOTPLATES 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 14 MAY 1998. C C **** COMPATIBLE WITH 14 MAY 1998 VERSION OF "PLATES" **** C TAKES OUTPUT FROM A FINITE ELEMENT SIMULATION OF CONTINENTAL C DEFORMATION PERFORMED BY "PLATES" 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/LAYER THICKNESS C DATA AT THE NODES) DATASET IDENTICAL TO THAT READ BY "PLATES"; C LIKE THAT PROGRAM, IT ALSO INTERPOLATES POSITIONS 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 USES STRATEGIC AND TACTICAL INPUT PARAMETERS IN C CARD FORMAT FROM DEVICE "IUNITP"; SHOULD CONFORM TO DATA USED C IN THE ORIGINAL RUN OF "PLATES"; PLOT CONTROLS ARE APPENDED C AT THE END OF THIS DATASET (WHERE "PLATES" WON'T READ THEM). C C OPTIONALLY READS BASE MAP FROM UNITS "IUNITM" (BOLD LINES) AND C "IUNITN" (FINE LINES AND TEXT) FOR INCLUSION IN PLOTS. C C READS THE VELOCITY SOLUTION (AT THE NODES ONLY) FROM C FORTRAN DEVICE NUMBER "IUNITV". C (NOTE: THIS INPUT IS NOT NEEDED FOR THE FIRST 8 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=2000) C C MAXBN = MAXIMUM NUMBER OF BOUNDARY NODES (BOTH "REAL" AND "FAKE"). PARAMETER (MAXBN=400) C C MAXEL = MAXIMUM NUMBER OF CONTINUUM ELEMENTS (TRIANGLES). PARAMETER (MAXEL=1000) C C MAXFEL = MAXIMUM NUMBER OF FAULT ELEMENTS (LINE SEGMENTS); PARAMETER (MAXFEL=200) 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=250000) C !===========================================================! C ! BE SURE TO SET PARAMETER MAXWRK TO THE EXACT SAME VALUE ! C ! IN ALL SUBPROGRAMS WERE IT APPEARS! THIS IS NOT ! C ! AUTOMATIC, BUT IT IS ESSENTIAL FOR CORRECT EXTRAPOLATION ! C !===========================================================! C C MAXSTA = MAXIMUM NUMBER OF POINTS IN STATELINE MAPS: PARAMETER (MAXSTA=20000) C C NPTYPE = NUMBER OF TYPES OF PLOTS PRODUCED BY THIS PROGRAM PARAMETER (NPTYPE=15) C C--------------------------------------------------------------------- C TYPE STATEMENTS C C (NOTE: THE IMPLICIT TYPING OF I-N = INTEGER, AND A-H,O-Z = REAL C IS OBSERVED IN THIS PROGRAM. NO TYPES ARE STATED FOR SUCH NAMES.) C CHARACTER*80 TITLE1,TITLE2,TITLE3 C DOUBLE PRECISION 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, + EMPTY,EOF,EVERYP,FIRST,NEEDSV, + 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), TLNODE(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), + GEOTHC (4,7,MAXEL), GEOTHM(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), + TLINT (7,MAXEL), TOFSET(3,7,MAXEL), + XIP (7,MAXEL), YIP (7,MAXEL), + ZMOHO (7,MAXEL), ZTRANC(2,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(2,MAXFEL), FSLIPS (MAXFEL), + FTAN (7,MAXFEL), FTSTAR(2,7,MAXFEL), NODEF (6,MAXFEL), + OFFSET (MAXFEL), ZTRANF(2,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: DIMENSION ACREEP(2), ALPHAT(2), BCREEP(2), CCREEP(2), + CONDUC(2), DCREEP(2), RADIO(2), RHOBAR(2), + TEMLIM(2) DIMENSION VECTOR(20) C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD1: DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD2: DIMENSION FPHI(6,7),FPOINT(7),FGAUSS(7) C C--------------------------------------------------------------------- C EQUIVALENCE STATEMENTS C (NOTE: ALL EQUIVALENCES ARE TO CONSERVE MEMORY, AND DO NOT IMPLY C LOGICAL EQUIVALENCE!) C C--------------------------------------------------------------------- C COMMON STATEMENTS C C 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 THE FOLLOWING COMMON BLOCK HOLDS THE LARGE WORKSPACE FOR THE C INTERPOLATION MATRIX. THERE IS NO LOGICAL REASON FOR IT TO BE C IN COMMON, BUT THE IBM VS-FORTRAN COMPILER CAN HANDLE A LARGER C MAXIMUM ARRAY SIZE WHEN WE DO IT THIS WAY. COMMON /BIGONE/ A1, A2 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 (NOTE: THIS FILE IS OPTIONAL FOR THE FIRST 8 PLOTS, BUT C REQUIRED FOR THE FINAL GROUP OF 7 PLOTS.) C C "IUNITM"= DEVICE NUMBER ASSOCIATED WITH THE BOLD LINES OF BASE MAP. DATA IUNITM /9/ C (NOTE: THIS FILE IS OPTIONAL.) C C "IUNITN"= DEVICE NUMBER ASSOCIATED WITH THE FINE LINES OF BASE MAP. DATA IUNITN /10/ C (NOTE: THIS FILE IS OPTIONAL.) C C--------------------------------------------------------------------- C C STATEMENT FUNCTIONS: C C ( NONE ) 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 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, + MXBN,MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF,DQDTDA,ELEV,FAZ,FDIP, + NFAKEN,NFL,NODEF,NODES, + NREALN,NUMEL,NUMNOD,N1000,OFFMAX, + OFFSET,TITLE1,TLNODE,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, OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT , + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , GMEAN , + MAXITR, OKDELV, OKTOQT, ONEKM, RADIO , + REFSTR, RHOAST, RHOBAR, RHOH2O, + TEMLIM, TITLE3, TRHMAX, TSURF, $ NPTYPE, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,NCONTR, $ STATES,RMSVEC, $ SDENOM,XCENTR,YCENTR,PAPER, $ IPEN1,IPEN2,IPEN3,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( 6).OR.DOPLOT( 7).OR. + DOPLOT( 8).OR.DOPLOT( 9).OR. + DOPLOT(12).OR.DOPLOT(14).OR. + DOPLOT(15) 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.' + /' BE SURE TO CHANGE THIS PARAMETER TO THE' + ,' SAME EXACT VALUE IN EVERY SUBPROGRAM' + /' WHERE IT APPEARS!') STOP ENDIF ENDIF C C READ BASEMAP, IF DESIRED: C IF (STATES) THEN NXYSTB=0 FIRST=.TRUE. 90 CALL READM (INPUT,IUNITM,2, + OUTPUT,EMPTY,EOF,VECTOR) IF (EOF) GO TO 101 IF (EMPTY) THEN FIRST=.TRUE. ELSE NXYSTB=NXYSTB+1 XST(NXYSTB)=VECTOR(1) YST(NXYSTB)=VECTOR(2) DRAWST(NXYSTB)=.NOT.FIRST FIRST=.FALSE. ENDIF IF (NXYSTB.LT.MXSTAT) THEN GO TO 90 ELSE WRITE (IUNITT,91) 91 FORMAT (/' INCREASE PARAMETER MAXSTA AND RECOMPILE.') STOP ENDIF 101 NXYSTF=0 FIRST=.TRUE. 102 CALL READM (INPUT,IUNITN,2, + OUTPUT,EMPTY,EOF,VECTOR) IF (EOF) GO TO 103 IF (EMPTY) THEN FIRST=.TRUE. ELSE NXYSTF=NXYSTF+1 XST(NXYSTB+NXYSTF)=VECTOR(1) YST(NXYSTB+NXYSTF)=VECTOR(2) DRAWST(NXYSTB+NXYSTF)=.NOT.FIRST FIRST=.FALSE. ENDIF IF (NXYSTB+NXYSTF.LT.MXSTAT) THEN GO TO 102 ELSE WRITE (IUNITT,91) STOP ENDIF 103 CONTINUE ELSE NXYSTB=0 NXYSTF=0 ENDIF C C ARE NODAL VELOCITIES REQUIRED? IF SO, READ NOW: C NEEDSV=DOPLOT( 9).OR.DOPLOT(10).OR.DOPLOT(11).OR. + DOPLOT(12).OR.DOPLOT(13).OR.DOPLOT(14).OR. + DOPLOT(15) IF (NEEDSV) THEN 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 ELSE TITLE2=TITLE1 TITLE3=TITLE1 DO 906 I=1,NUMNOD V(1,I)=0.0D0 V(2,I)=0.0D0 906 CONTINUE ENDIF C CALL FILLIN (INPUT,ACREEP,ALPHAT,BCREEP, + CCREEP,CONDUC,DQDTDA, + ECREEP,ELEV,GMEAN,IUNITT, + MXEL,MXNODE,NODES,NUMEL,NUMNOD,ONEKM, + RADIO,RHOAST,RHOBAR,RHOH2O,TEMLIM, + TLNODE,TRHMAX,TSURF,XNODE,YNODE,V,ZMNODE, + OUTPUT,GEOTHC,GEOTHM,GLUE,OVB,PULLED,SIGZZI, + TAUZZI,TAUZZN,TLINT,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 IF (NEEDSV) THEN CALL LIMITS (INPUT,AREA,DETJ,IUNITT,MXEL, + NUMEL,OKDELV,REFSTR,TLINT,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) ENDIF 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) C OUTPUT,A1 IS IN COMMON /BIGONE/. LDA=NDIFF+1 CALL SPBF (A1,LDA,NUMNOD,NDIFF) ENDIF C C INITIALIZE SOLUTION-SPECIFIC ARRAYS (IF USED): C IF (NEEDSV) THEN 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,GEOTHC,GEOTHM, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,TLINT, + VISMAX,ZMOHO, + OUTPUT,ALPHA,SCOREC,SCORED,TOFSET,ZTRANC) CALL TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) DO 930 I=1,NFL ZTRANF(1,I)=ZMNODE(NODEF(2,I))/2. ZTRANF(2,I)=TLNODE(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,TLNODE,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) IF (TRHMAX.GT.0.0) THEN CALL THONB (INPUT,ECREEP,ETAMAX,GLUE, + MXEL,MXNODE, + NODES,NUMEL,NUMNOD, + OVB,PULLED,TRHMAX,V, + OUTPUT,DVB,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 CALL RESULT + (INPUT,ALPHAT,ELEV,ERATE,FDIP,FIMUDZ,FPEAKS,FSLIPS, + FTAN,GEOTHC,GEOTHM,IUNITT,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES,NREALN,NUMEL,NUMNOD,N1000, + ONEKM,RHOAST,RHOBAR,RHOH2O,SIGHB,TAUMAT,TAUZZI, + TITLE1,TITLE2,TITLE3,TLINT,TLNODE, + V,WEDGE,ZMNODE,ZMOHO,ZTRANC,ZTRANF) ENDIF C CALL REPORT (INPUT,AREA,CINT,COLOR,DETJ,DOPLOT, + DQDTDA,DRAWST,ELEV,ERATE, + FBLAND,FDIP,FLEN,FSLIPS,FTAN, + GEOTHC,GEOTHM,IALIAS, + IPEN1,IPEN2,IPEN3,IUNITT, + LDA,LOWBLU, + MXEL,MXFEL,MXNODE,MXWORK, + NCONTR,NDIFF,NFL,NODEF, + NODES,MXSTAT,NTYPE, + NXYSTB,NXYSTF,NUMEL,NUMNOD,OVB,PAPER, + RMSVEC,SDENOM,SIGHB,STATES, + TAUMAT,TAUZZI, + TITLE1,TITLE2,TITLE3, + TEMLIM,TLINT,TLNODE,USEALI,V,WEDGE, + XCENTR,YCENTR, + ZMNODE,ZMOHO, + MODIFY,XIP,XNODE,XST, + YIP,YNODE,YST, + OUTPUT,VM, + WORK,ATNODE,OUTSCA,OUTVEC, + 999) C WRITE (IUNITT,999) 999 FORMAT (' *** ALL REQUESTED PLOTS COMPLETED. ***'/ + ' ==========================================================') C STOP END C C C SUBROUTINE EXTRAP (INPUT,AREA,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + VALUES, + OUTPUT,FPOLES) C WORK,A2 IS PROVIDED BY COMMON, C AS IS INPUT,A1. C C SMOOTHS VALUES OF A SCALAR FIELD KNOWN AT THE INTEGRATION C POINTS (VALUES) TO PRODUCE VALUES AT THE NODES (FPOLES). C PARAMETER (MAXWRK=250000) C LOGICAL USEALI DOUBLE PRECISION PHI,WEIGHT DIMENSION PHI(6,7),WEIGHT(7) DIMENSION AREA(MXEL),DETJ(7,MXEL),IALIAS(MXNODE), + FPOLES(MXNODE),NODES(6,MXEL), + VALUES(7,MXEL) DIMENSION A1(MAXWRK), A2(MAXWRK) COMMON /BIGONE/ A1, A2 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 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) C OUTPUT,CODE IS IN COMMON /BIGONE/. 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 PARAMETER (MAXWRK=250000) LOGICAL USEALI DOUBLE PRECISION PHI,WEIGHT DIMENSION AREA(NUMEL),DETJ(7,NUMEL),IALIAS(NUMNOD), + NODEF(6,NFL),NODES(6,NUMEL),PHI(6,7),WEIGHT(7) DIMENSION CODE(MAXWRK),CODE2(MAXWRK) COMMON /BIGONE/ CODE, CODE2 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,CINT,COLOR,DETJ,DOPLOT, + DQDTDA,DRAWST,ELEV,ERATE, + FBLAND,FDIP,FLEN,FSLIPS,FTAN, + GEOTHC,GEOTHM,IALIAS, + IPEN1,IPEN2,IPEN3,IUNITT, + LDA,LOWBLU, + MXEL,MXFEL,MXNODE,MXWORK, + NCONTR,NDIFF,NFL,NODEF, + NODES,MXSTAT,NTYPE, + NXYSTB,NXYSTF,NUMEL,NUMNOD,OVB,PAPER, + RMSVEC,SDENOM,SIGHB,STATES, + TAUMAT,TAUZZI, + TITLE1,TITLE2,TITLE3, + TEMLIM,TLINT,TLNODE,USEALI,V,WEDGE, + XCENTR,YCENTR, + ZMNODE,ZMOHO, + MODIFY,XIP,XNODE,XST, + YIP,YNODE,YST, + OUTPUT,VM, + WORK,ATNODE,OUTSCA,OUTVEC, + LAST) C C CREATES GRAPHICS OUTPUT FOR ALL REQUESTED VARIABLES IN THE C CURRENT ITERATION C PARAMETER (NPTYPE=15) 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), + 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),GEOTHC(4,7,MXEL), + GEOTHM(4,7,NUMEL),IALIAS(MXNODE), + LOWBLU(NTYPE), + NODEF(6,MXFEL),NODES(6,MXEL), + OUTSCA(7,MXEL),OUTVEC(2,7,MXEL), + OVB(2,7,MXEL),SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL),TAUZZI(7,MXEL), + TEMLIM(2),TLINT(7,MXEL),TLNODE(MXNODE), + 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)/'FINITE ELEMENT GRID '/ DATA NVCHAR(1)/19/ DATA TEXT(2)/'ELEVATION '/ DATA NVCHAR(2)/ 9/ DATA TEXT(3)/'HEAT-FLOW '/ DATA NVCHAR(3)/ 9/ DATA TEXT(4)/'CRUSTAL THICKNESS '/ DATA NVCHAR(4)/17/ DATA TEXT(5)/'MANTLE LITHOSPHERE THICKNESS '/ DATA NVCHAR(5)/28/ DATA TEXT(6)/'MOHO TEMPERATURE '/ DATA NVCHAR(6)/16/ DATA TEXT(7)/'TEMPERATURE AT BASE OF PLATE '/ DATA NVCHAR(7)/28/ DATA TEXT(8)/'VELOCITY BELOW BASE OF PLATE '/ DATA NVCHAR(8)/28/ DATA TEXT(9)/'SHEAR TRACTION ON BASE OF PLATE '/ DATA NVCHAR(9)/31/ DATA TEXT(10)/'SURFACE VELOCITY '/ DATA NVCHAR(10)/16/ DATA TEXT(11)/'VELOCITY CHANGES FROM LAST ITERATION '/ DATA NVCHAR(11)/36/ DATA TEXT(12)/'SURFACE STRAIN-RATES '/ DATA NVCHAR(12)/20/ DATA TEXT(13)/'MEAN SLIP-RATE OF FAULTS '/ DATA NVCHAR(13)/24/ DATA TEXT(14)/'RATE OF PLATE THICKENING '/ DATA NVCHAR(14)/24/ DATA TEXT(15)/'VERTICALLY-INTEGRATED STRESS ANOMALIES '/ DATA NVCHAR(15)/38/ C DATA VUNITS(1)/' '/ DATA NVUCHR(1)/0/ DATA VUNITS(2)/'m '/ DATA NVUCHR(2)/1/ DATA VUNITS(3)/'mW/m**2 '/ DATA NVUCHR(3)/7/ DATA VUNITS(4)/'km '/ DATA NVUCHR(4)/2/ DATA VUNITS(5)/'km '/ DATA NVUCHR(5)/2/ DATA VUNITS(6)/'C '/ DATA NVUCHR(6)/1/ DATA VUNITS(7)/'C '/ DATA NVUCHR(7)/1/ DATA VUNITS(8)/'mm/year '/ DATA NVUCHR(8)/7/ DATA VUNITS(9)/'MPa '/ DATA NVUCHR(9)/3/ DATA VUNITS(10)/'mm/year '/ DATA NVUCHR(10)/7/ DATA VUNITS(11)/'mm/year '/ DATA NVUCHR(11)/7/ DATA VUNITS(12)/'/s '/ DATA NVUCHR(12)/2/ DATA VUNITS(13)/'mm/year '/ DATA NVUCHR(13)/7/ DATA VUNITS(14)/'mm/year '/ DATA NVUCHR(14)/7/ DATA VUNITS(15)/'N/m '/ DATA NVUCHR(15)/3/ 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 C VFACT WILL BE USED IN "CALL FACTOR(VFACT)" TO PREPARE C VERSATEC FOR LATER PLOTTING CALLS IN PHYSICAL (EARTH) SPACE, IN M: C VFACT=1./(0.0254*SDENOM) C C DETERMINE HOW TO PLACE PLOT ON PAPER C XMIN=XNODE(1) YMIN=YNODE(1) XMAX=XMIN YMAX=YMIN DO 10 I=2,NUMNOD XMIN=MIN(XMIN,XNODE(I)) YMIN=MIN(YMIN,YNODE(I)) XMAX=MAX(XMAX,XNODE(I)) YMAX=MAX(YMAX,YNODE(I)) 10 CONTINUE HDENOM=(XMAX-XMIN)/((PAPER-2.)*0.0254) VDENOM=(YMAX-YMIN)/(9.5*0.0254) XINCH=PAPER-2. IF ((SDENOM.GE.HDENOM).AND.(SDENOM.GE.VDENOM)) THEN WRITE (IUNITT,11) SDENOM 11 FORMAT (/' SCALE DENOMINATOR OF', + 1P,E10.2,' WILL ALLOW DISPLAY OF WHOLE GRID.' + /' THE PLOT CENTER (XCENTR,YCENTR) WILL BE ' + ,'RECOMPUTED TO SHOW WHOLE GRID.') XCENTR=0.5*(XMAX+XMIN) YCENTR=0.5*(YMAX+YMIN) ELSE WRITE (IUNITT,12) SDENOM, XCENTR, YCENTR 12 FORMAT (/' SCALE DENOMINATOR OF',1P,E10.2 + ,' DOES NOT PERMIT DISPLAY OF WHOLE GRID.' + /' PORTION OMITTED WILL DEPEND ON CENTER' + ,' COORDINATES, WHICH WERE:' + /' (',E9.2,',',E9.2,').') ENDIF XADD=0.5*XINCH/VFACT-XCENTR YADD=(5.25/VFACT)-YCENTR 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 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,NXYSTB+NXYSTF XST(I)=XST(I)+XADD YST(I)=YST(I)+YADD 50 CONTINUE ENDIF C WRITE (IUNITT,99) 99 FORMAT (/ / + ' ----------------------------------------------------------') C C FINITE ELEMENT GRID: IF (DOPLOT(1)) THEN CALL ETCH (DRAWST,FDIP,FLEN,FTAN,1,NTYPE,NFL, + NODEF,NODES,NUMEL,NUMNOD,NVCHAR,NXYSTB,NXYSTF, + STATES,TEXT,TITLE1, + VFACT,WEDGE,XINCH, + XNODE,XST,YNODE,YST, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,199) 199 FORMAT (' PLOT OF FINITE ELEMENT GRID COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C ELEVATION: IF (DOPLOT(2)) THEN ALLPOS=.FALSE. CALL INTERP (INPUT,ELEV,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,OUTSCA) DFCON=CINT(2) 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,2,NTYPE, + ELEV,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,299) 299 FORMAT (' PLOT OF ELEVATION COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C HEAT FLOW: IF (DOPLOT(3)) THEN C C Convert from W/m**2 to mW/m**2 C DFCON=CINT(3)*1000. IF (FBLAND(3).NE.0.0) FBLAND(3)=FBLAND(3)*1000. DO 310 I=1,NUMNOD ATNODE(I)=DQDTDA(I)*1000. 310 CONTINUE ALLPOS=.TRUE. CALL INTERP (INPUT,ATNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,OUTSCA) 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,3,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,399) 399 FORMAT (' PLOT OF HEAT-FLOW COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C CRUSTAL THICKNESS: IF (DOPLOT(4)) THEN C C CONVERT TO KM C DFCON=CINT(4)/1000. IF (FBLAND(4).NE.0.) FBLAND(4)=FBLAND(4)/1000. DO 410 I=1,NUMNOD ATNODE(I)=ZMNODE(I)/1000. 410 CONTINUE DO 430 M=1,7 DO 420 I=1,NUMEL OUTSCA(M,I)=ZMOHO(M,I)/1000. 420 CONTINUE 430 CONTINUE IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,4,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,499) 499 FORMAT (' PLOT OF CRUSTAL THICKNESS COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C MANTLE LITHOSPHERE THICKNESS (EXCLUDING CRUST): IF (DOPLOT(5)) THEN C C CONVERT TO KM C DFCON=CINT(5)/1000. IF (FBLAND(5).NE.0.) FBLAND(5)=FBLAND(5)/1000. DO 510 I=1,NUMNOD ATNODE(I)=TLNODE(I)/1000. 510 CONTINUE DO 530 M=1,7 DO 520 I=1,NUMEL OUTSCA(M,I)=TLINT(M,I)/1000. 520 CONTINUE 530 CONTINUE IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,5,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,599) 599 FORMAT (' PLOT OF MANTLE LITHOSPHERE THICKNESS COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C MOHO TEMPERATURE: IF (DOPLOT(6)) THEN CALL TMOHO (INPUT,GEOTHC,NUMEL,TEMLIM(1),ZMOHO, + OUTPUT,OUTSCA) C C CONVERT TO CENTIGRADE C IF (FBLAND(6).NE.0.) FBLAND(6)=FBLAND(6)-273. DO 620 M=1,7 DO 610 I=1,NUMEL OUTSCA(M,I)=OUTSCA(M,I)-273. 610 CONTINUE 620 CONTINUE CALL EXTRAP (INPUT,AREA,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE) DO 630 I=1,NUMNOD ATNODE(I)=MIN(ATNODE(I),TEMLIM(1)-273.) 630 CONTINUE C DFCON=CINT(6) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,6,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,699) 699 FORMAT (' PLOT OF MOHO TEMPERATURE COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C TEMPERATURE AT BASE OF PLATE: IF (DOPLOT(7)) THEN CALL TMOHO (INPUT,GEOTHM,NUMEL,TEMLIM(2),TLINT, + OUTPUT,OUTSCA) C C CONVERT TO CENTIGRADE C IF (FBLAND(7).NE.0.) FBLAND(7)=FBLAND(7)-273. DO 720 M=1,7 DO 710 I=1,NUMEL OUTSCA(M,I)=OUTSCA(M,I)-273. 710 CONTINUE 720 CONTINUE CALL EXTRAP (INPUT,AREA,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE) DO 730 I=1,NUMNOD ATNODE(I)=MIN(ATNODE(I),TEMLIM(2)-273.) 730 CONTINUE C DFCON=CINT(7) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,7,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,799) 799 FORMAT (' PLOT OF TEMPERATURE AT PLATE BASE COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C SUB-PLATE VELOCITY: IF (DOPLOT(8)) THEN TOPVEL=0. DO 802 M=1,7 DO 801 I=1,NUMEL VMAGNI=SQRT((1.D0*OVB(1,M,I))**2+ + (1.D0*OVB(2,M,I))**2) TOPVEL=MAX(TOPVEL,VMAGNI) OUTSCA(M,I)=OVB(1,M,I) 801 CONTINUE 802 CONTINUE CALL EXTRAP (INPUT,AREA,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE) DO 803 I=1,NUMNOD VM(1,I)=ATNODE(I) 803 CONTINUE DO 805 M=1,7 DO 804 I=1,NUMEL OUTSCA(M,I)=OVB(2,M,I) 804 CONTINUE 805 CONTINUE CALL EXTRAP (INPUT,AREA,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE) DO 806 I=1,NUMNOD VM(2,I)=ATNODE(I) VMAGNI=SQRT(VM(1,I)**2+VM(2,I)**2) IF (VMAGNI.GT.TOPVEL) THEN VM(1,I)=VM(1,I)*TOPVEL/VMAGNI VM(2,I)=VM(2,I)*TOPVEL/VMAGNI ENDIF 806 CONTINUE C C CONVERT TO MM/YEAR C DFCON=CINT(8)*1000.*3.1558E7 IF (FBLAND(8).NE.0.) FBLAND(8)=FBLAND(8)*1000.*3.1558E7 CALL MAGNIN (INPUT,NUMNOD,VM, + OUTPUT,ATNODE) CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,VM, + OUTPUT,OUTVEC) DO 810 I=1,NUMNOD ATNODE(I)=ATNODE(I)*1000.*3.1558E7 810 CONTINUE DO 830 M=1,7 DO 820 I=1,NUMEL OUTVEC(1,M,I)=OUTVEC(1,M,I)*1000.*3.1558E7 OUTVEC(2,M,I)=OUTVEC(2,M,I)*1000.*3.1558E7 820 CONTINUE 830 CONTINUE C CALL MAGNIT (INPUT,NUMEL,OUTVEC, + OUTPUT,OUTSCA) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.TRUE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE2,TEXT,8,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,899) 899 FORMAT (' PLOT OF SUB-PLATE VELOCITY COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C SHEAR TRACTION ON PLATE BASE: IF (DOPLOT(9)) THEN CALL MAGNIT (INPUT,NUMEL,SIGHB, + OUTPUT,OUTSCA) C C CONVERT TO MPA C DFCON=CINT(9)/1.E6 IF (FBLAND(9).NE.0.) FBLAND(9)=FBLAND(9)/1.E6 DO 920 M=1,7 DO 910 I=1,NUMEL OUTSCA(M,I)=OUTSCA(M,I)/1.E6 910 CONTINUE 920 CONTINUE C CALL EXTRAP (INPUT,AREA,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.TRUE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,9,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,999) 999 FORMAT (' PLOT OF SHEAR TRACTION ON PLATE BASE COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C SURFACE VELOCITY: IF (DOPLOT(10)) THEN CALL MAGNIN (INPUT,NUMNOD,V, + OUTPUT,ATNODE) CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,V, + OUTPUT,OUTVEC) C C CONVERT TO MM/YEAR C DFCON=CINT(10)*1000.*3.1558E7 IF (FBLAND(10).NE.0.) FBLAND(10)=FBLAND(10)*1000.*3.1558E7 DO 1010 I=1,NUMNOD ATNODE(I)=ATNODE(I)*1000.*3.1558E7 1010 CONTINUE DO 1030 M=1,7 DO 1020 I=1,NUMEL OUTVEC(1,M,I)=OUTVEC(1,M,I)*1000.*3.1558E7 OUTVEC(2,M,I)=OUTVEC(2,M,I)*1000.*3.1558E7 1020 CONTINUE 1030 CONTINUE C CALL MAGNIT (INPUT,NUMEL,OUTVEC, + OUTPUT,OUTSCA) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.TRUE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.TRUE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,10,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,1099) 1099 FORMAT (' PLOT OF SURFACE VELOCITY COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C VELOCITY CHANGES IF (DOPLOT(11)) THEN WRITE (IUNITT,1199) 1199 FORMAT (' VELOCITY CHANGES ARE ONLY PLOTTED BY GDDMCOMP.'/ + ' ----------------------------------------------------------') ENDIF C C STRAIN RATES: IF (DOPLOT(12)) THEN ALLPOS=.TRUE. CALL MAXER (INPUT,ERATE,NUMEL, + OUTPUT,OUTSCA) CALL EXTRAP (INPUT,AREA,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE) DFCON=CINT(12) 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,12,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,1299) 1299 FORMAT (' PLOT OF SURFACE STRAIN-RATES COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C FAULT SLIP RATES: 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, + NXYSTB,NXYSTF, + RMSVEC,STATES,TEXT,TITLE3,V,VFACT,WEDGE, + XINCH,XNODE,XST,YNODE,YST, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,1399) 1399 FORMAT (' PLOT OF FAULT SLIP-RATES COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF ENDIF C C RATE OF PLATE THICKENING: IF (DOPLOT(14)) THEN DO 1420 M=1,7 DO 1410 I=1,NUMEL OUTSCA(M,I)= -ZMOHO(M,I)*(ERATE(1,M,I)+ + ERATE(2,M,I)) 1410 CONTINUE 1420 CONTINUE C C CONVERT TO MM/YEAR C DFCON=CINT(14)*1000.*3.1558E7 IF (FBLAND(14).NE.0.) FBLAND(14)=FBLAND(14)*1000.*3.1558E7 DO 1440 M=1,7 DO 1430 I=1,NUMEL OUTSCA(M,I)=OUTSCA(M,I)*1000.*3.1558E7 1430 CONTINUE 1440 CONTINUE C CALL EXTRAP (INPUT,AREA,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.FALSE. DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,14,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,1499) 1499 FORMAT (' PLOT OF PLATE THICKENING RATE COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C VERTICALLY-INTEGRATED STRESSES: IF (DOPLOT(15)) THEN ALLPOS=.TRUE. CALL MAXSS (INPUT,NUMEL,TAUMAT,TAUZZI, + OUTPUT,OUTSCA) CALL EXTRAP (INPUT,AREA,DETJ,IALIAS,LDA, + MXEL,MXNODE,MXWORK, + NDIFF,NODES,NUMNOD,NUMEL,USEALI, + OUTSCA, + OUTPUT,ATNODE) DFCON=CINT(15) 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,15,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + VFACT,XINCH, + STATES, + DRAWST,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) WRITE (IUNITT,1599) 1599 FORMAT (' PLOT OF INTEGRATED STRESS ANOMALIES COMPLETED.' + /' ----------------------------------------------------------') 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 (WHICH INCLUDES THE C LOCAL VERTICAL STRESS ANOMALY 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, + NXYSTB,NXYSTF, + RMSVEC,STATES,TEXT,TITLE,V,VFACT,WEDGE, + XINCH,XNOD,XST,YNOD,YST, + IPEN1,IPEN2,IPEN3,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(NXYSTB),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(NXYSTB),YST(NXYSTB) 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 MAXIMUM PEN WIDTH FOR FINE LINES C IPEN0=MIN(IPEN1,3) 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 (IPEN0,ICOLOR(IS)) ENDIF CALL NEWPEN (IPEN0) 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.70*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 (IPEN0,BLACK) CALL NEWPEN (IPEN0) 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 IF (COLOR) THEN C (PLOT NUMBER WITHIN COLOR BAND) HIGHT=0.0 ELSE C (PLOT NUMBER OUTSIDE OF SHADED BAND) HIGHT=RATE(5)*SCALE ENDIF XFMP=XFM+CROSSX*(HIGHT+HIGH*0.5)-CROSSY*HIGH*0.7 YFMP=YFM+CROSSY*(HIGHT+HIGH*0.5)+CROSSX*HIGH*0.7 IF (COLOR) THEN CALL PENCLR (IPEN1,BLACK) ENDIF CALL NEWPEN (IPEN1) 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 KOLOR=RED SUM=0.0 DO 32 I=1,NFL SUM=SUM+FLEN(I) 32 CONTINUE AVERAG=SUM/NFL IF (NUMNOD.LE.600) THEN NTIC=3 DIPSIZ=0.15*AVERAG ELSE NTIC=1 DIPSIZ=0.40*AVERAG ENDIF DO 35 I=1,NFL DASH=.NOT.FSLIPS(I) CALL FAULT (INPUT,COLOR,DASH,FDIP,FTAN,I,IPEN2,KOLOR,NFL, + NUMNOD,NODEF,NTIC,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 KOLOR=VIOLET C CALL USMAP (INPUT,COLOR,DRAWST,IPEN1,IPEN3,KOLOR, + NXYSTB,NXYSTF,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 (IPEN1,BLACK) CALL NEWPEN (IPEN1) 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) CALL RECT (XINCH+0.56666,XINCH+0.63333,YLINE,YLINE+0.2,1) ENDIF IF (COLOR) CALL PENCLR (IPEN1,BLACK) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.6-0.4*WIDTH, + YLINE+0.2+0.3*HEIGHT,HEIGHT,'5',IDUMMY,0.,1) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'mm/year',IDUMMY,0.,7) IF (COLOR) CALL PENCLR (IPEN2,RED) CALL NEWPEN (IPEN2) 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 (IPEN1,BLACK) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'LOCKED',IDUMMY,0.,6) IF (COLOR) CALL PENCLR (IPEN2,RED) CALL NEWPEN (IPEN2) 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 (IPEN1,BLACK) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'DEXTRAL',IDUMMY,0.,7) IF (COLOR) CALL PENCLR (IPEN2,RED) CALL NEWPEN (IPEN2) 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 (IPEN1,BLACK) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'SINISTRAL',IDUMMY,0.,9) IF (COLOR) CALL PENCLR (IPEN2,RED) CALL NEWPEN (IPEN2) 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 (IPEN1,BLACK) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'THRUST',IDUMMY,0.,6) IF (COLOR) CALL PENCLR (IPEN2,RED) CALL NEWPEN (IPEN2) 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 (IPEN1,BLACK) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'NORMAL',IDUMMY,0.,6) IF (COLOR) CALL PENCLR (IPEN2,RED) CALL NEWPEN (IPEN2) 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 (IPEN1,BLACK) CALL NEWPEN (IPEN1) 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 (IPEN2,RED) CALL NEWPEN (IPEN2) CALL PLOT (XINCH+0.45,YLINE+0.5*HIGH,UP) CALL PLOT (XINCH+0.75,YLINE+0.5*HIGH,DOWN) IF (COLOR) CALL PENCLR (IPEN1,BLACK) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'9O DEG.',IDUMMY,0.,7) C C STEEP DIP C YLINE=2.0 IF (COLOR) CALL PENCLR (IPEN2,RED) CALL NEWPEN (IPEN2) 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 (IPEN1,BLACK) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'65 DEG.',IDUMMY,0.,7) C C MEDIUM DIP C YLINE=1.5 IF (COLOR) CALL PENCLR (IPEN2,RED) CALL NEWPEN (IPEN2) 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 (IPEN1,BLACK) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'45 DEG.',IDUMMY,0.,7) C C SHALLOW DIP C YLINE=1.0 IF (COLOR) CALL PENCLR (IPEN2,RED) CALL NEWPEN (IPEN2) 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 (IPEN1,BLACK) CALL NEWPEN (IPEN1) 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 (IPEN1,BLACK) CALL NEWPEN (IPEN1) 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 (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,COLOR,DASH,FDIP,FTAN,I, + IPEN,KOLOR,MXFEL, + MXNODE,NODEF,NTIC, + 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, AND THERE ARE "NTIC" C SYMBOLS ALONG EACH ELEMENT. C C IF LOGICAL FLAG "DASH" IS ON, THE LINE IS DASHED. C INTEGER DOWN,UP,KOLOR,IPEN,USETIC LOGICAL COLOR,DASH DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS DIMENSION USETIC(7,7) 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) IF (COLOR) CALL PENCLR (IPEN,KOLOR) CALL NEWPEN (IPEN) 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 CERTAIN INTEGRATION POINTS: C NTIC = 0 -> NONE C NTIC = 1 -> POINT 4 C NTIC = 2 -> POINTS 2, 6 C NTIC = 3 -> POINTS 2, 4, 6 USETIC(1,1)=4 USETIC(1,2)=2 USETIC(2,2)=6 USETIC(1,3)=2 USETIC(2,3)=4 USETIC(3,3)=6 C MTIC=MIN(NTIC,3) IF (MTIC.GT.0) THEN IPEN0=MIN(IPEN,3) IF (COLOR) CALL PENCLR (IPEN0,KOLOR) CALL NEWPEN (IPEN0) DO 100 K=1,MTIC M=USETIC(K,MTIC) 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 ENDIF 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.25D0*(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.25D0*(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, + CCREEP,CONDUC,DQDTDA, + ECREEP,ELEV,GMEAN,IUNITT, + MXEL,MXNODE,NODES,NUMEL,NUMNOD,ONEKM, + RADIO,RHOAST,RHOBAR,RHOH2O,TEMLIM, + TLNODE,TRHMAX,TSURF, + XNODE,YNODE,V,ZMNODE, + OUTPUT,GEOTHC,GEOTHM,GLUE,OVB,PULLED,SIGZZI, + TAUZZI,TAUZZN,TLINT,ZMOHO, + WORK,ATNODE) C C PRECOMPUTE AND INTERPOLATE ALL "CONVENIENCE ARRAYS": C LOGICAL PULLED LOGICAL RESIST DOUBLE PRECISION V DOUBLE PRECISION PHI COMMON /PHITAB/ PHI DIMENSION PHI(6,7) DIMENSION ACREEP(2),ALPHAT(2),ATNODE(MXNODE),BCREEP(2), + CCREEP(2),CONDUC(2),DQDTDA(MXNODE),ELEV(MXNODE), + GEOTHC(4,7,MXEL),GEOTHM(4,7,MXEL), + GLUE(7,MXEL),NODES(6,MXEL), + OVB(2,7,MXEL),PULLED(7,MXEL),RADIO(2),RHOBAR(2), + SIGZZI(7,MXEL),TAUZZI(7,MXEL),TAUZZN(MXNODE), + TEMLIM(2),TLNODE(MXNODE), + TLINT(7,MXEL), + V(2,MXNODE),XNODE(MXNODE),YNODE(MXNODE), + ZMNODE(MXNODE),ZMOHO(7,MXEL) C C THICKNESS OF LAYERS: C CALL INTERP (INPUT,ZMNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,ZMOHO) CALL INTERP (INPUT,TLNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,TLINT) DO 2 M=1,7 DO 1 I=1,NUMEL TLINT(M,I)=MAX(TLINT(M,I),0.) 1 CONTINUE 2 CONTINUE C C GEOTHERM (STEADY-STATE, AND INTEGRATED STRICTLY FROM C INITIAL CONDITIONS ON TOP): C GEOTH1=TSURF GEOTH3= -0.5*RADIO(1)/CONDUC(1) GEOTH4=0. GEOTH7= -0.5*RADIO(2)/CONDUC(2) GEOTH8=0. DO 20 M=1,7 DO 10 I=1,NUMEL GEOTHC(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) GEOTHC(2,M,I)=Q/CONDUC(1) GEOTHC(3,M,I)=GEOTH3 GEOTHC(4,M,I)=GEOTH4 Z=ZMOHO(M,I) GEOTHM(1,M,I)=GEOTHC(1,M,I)+ + GEOTHC(2,M,I)*Z+ + GEOTHC(3,M,I)*Z**2+ + GEOTHC(4,M,I)*Z**3 DTDZC= GEOTHC(2,M,I)+ + 2.*GEOTHC(3,M,I)*Z+ + 3.*GEOTHC(4,M,I)*Z**2 DTDZM=DTDZC*CONDUC(1)/CONDUC(2) GEOTHM(2,M,I)=DTDZM GEOTHM(3,M,I)=GEOTH7 GEOTHM(4,M,I)=GEOTH8 10 CONTINUE 20 CONTINUE C C VERTICAL INTEGRALS OF VERTICAL STRESS ANOMALY C (RELATIVE TO A STANDARD PRESSURE CURVE, IN "SQUEEZ"): C DO 100 I=1,NUMNOD GEOTH2=DQDTDA(I)/CONDUC(1) GEOTH5=GEOTH1+ + GEOTH2*ZMNODE(I)+ + GEOTH3*ZMNODE(I)**2+ + GEOTH4*ZMNODE(I)**3 DTDZC= GEOTH2+ + 2.*GEOTH3*ZMNODE(I)+ + 3.*GEOTH4*ZMNODE(I)**2 GEOTH6=DTDZC*CONDUC(1)/CONDUC(2) CALL SQUEEZ (INPUT,ALPHAT,ELEV(I), + GEOTH1,GEOTH2,GEOTH3,GEOTH4, + GEOTH5,GEOTH6,GEOTH7,GEOTH8, + GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, + TEMLIM,ZMNODE(I),ZMNODE(I)+TLNODE(I), + OUTPUT,TAUZZN(I),ATNODE(I)) 100 CONTINUE CALL INTERP (INPUT,ATNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,SIGZZI) CALL INTERP (INPUT,TAUZZN,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,TAUZZI) C C COMPUTE STRENGTH OF SHEARING LAYER(S) IN DUCTILE LOWER CRUST, AND C MANTLE LITHOSPHERE, IF PRESENT: C CALL ONEBAR (INPUT,ACREEP,BCREEP,CCREEP, + ECREEP,GEOTHC,GEOTHM, + MXEL,NUMEL, + TEMLIM,TLINT,ZMOHO, + OUTPUT,GLUE) C C PRECOMPUTE VELOCITY OF THE TOP OF ASTHENOSPHERE/SLABS(?) C AND DETERMINE FOR EACH INTEGRATION POINT WHETHER IT IS ACTUALLY C PULLED BY A SUBDUCTED SLAB OR STRONG ASTHENOSPHERIC CURRENT. 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 BOTTOM (INPUT,TRHMAX,TCX,TCY,X,Y, + OUTPUT,RESIST,OVB(1,M,I),OVB(2,M,I)) 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, + MXBN,MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF,DQDTDA,ELEV,FAZ,FDIP, + NFAKEN,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,OFFMAX,OFFSET, + TITLE1,TLNODE,XNODE,YNODE,ZMNODE, + WORK,CHECKE,CHECKF,CHECKN) C C READ FINITE ELEMENT GRID FROM UNIT "IUNIT7". C ECHO THE IMPORTANT VALUES TO A PRINT DATASET ON UNIT "IUNIT8". C CHARACTER*80 TITLE1 LOGICAL ALLOK,BRIEF C C NOTE: FOLLOWING TYPE COULD BE "LOGICAL*1" IN IBM VS-FORTRAN: LOGICAL CHECKE,CHECKF,CHECKN C C EXTERNAL ARRAYS: 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), + TLNODE(MXNODE), + XNODE(MXNODE),YNODE(MXNODE),ZMNODE(MXNODE) C INTERNAL ARRAYS: DIMENSION DIPS(3),IFN(6),VECTOR(7) C WRITE (IUNIT8,1) IUNIT7 1 FORMAT (/' ATTEMPTING TO READ FINITE ELEMENT GRID FROM UNIT',I3) TITLE1=' '// + ' ' READ (IUNIT7,2) TITLE1 2 FORMAT (A80) WRITE (IUNIT8,3) TITLE1 3 FORMAT(/' TITLE OF FINITE ELEMENT GRID ='/' ',A80) C C READ NUMBER OF NODES, AND HOW MANY ARE "REAL" VERSUS "FAKE". C INPUT NODAL LOCATIONS (X,Y), ELEVATIONS, HEAT-FLOW, AND ISOSTATIC C GRAVITY ANOMALIES (ONE RECORD PER NODE). C (OPTION "BRIEF" SUPPRESSES MOST OUTPUT) C READ (IUNIT7,*) NUMNOD,NREALN,NFAKEN,N1000,BRIEF C IF (NUMNOD.NE.(NREALN+NFAKEN)) THEN WRITE (IUNIT8,5) 5 FORMAT (/' INCONSISTENT DATA:'/ + ' NUMBER OF NODES SHOULD EQUAL TOTAL OF REAL', + ' NODES AND FAKE NODES.') STOP ENDIF IF (NUMNOD.GT.MXNODE) THEN WRITE (IUNIT8,10) NUMNOD 10 FORMAT(/' INCREASE PARAMETER MAXNOD TO BE AT LEAST' + /' THE NUMBER OF NODES (',I6,') AND RECOMPILE.') STOP ENDIF N2=2*NUMNOD IF (NREALN.GT.N1000) THEN WRITE (IUNIT8,20) NREALN 20 FORMAT (/' INCREASE THE DATA VALUE N1000 TO BE GREATER' + /' OR EQUAL TO NREALN (',I6,') AND RECOMPILE.') STOP ENDIF IF (NFAKEN.GT.MXBN) THEN WRITE (IUNIT8,30) NFAKEN 30 FORMAT(/' INCREASE THE PARAMETER MAXBN TO BE GREATER' + /' OR EQUAL TO NFAKEN (',I6,') AND RECOMPILE.') STOP ENDIF C NBASE=N1000+1 NTOP=N1000+NFAKEN IF (BRIEF) THEN WRITE (IUNIT8,35) 35 FORMAT(/' (SINCE OPTION BRIEF=.TRUE., GRID WILL NOT BE ', + 'ECHOED HERE. BE CAREFUL!!!)') ELSE WRITE (IUNIT8,40) NUMNOD,NREALN,NREALN 40 FORMAT (/' THERE ARE',I5,' NODES IN THE GRID:'/ ' ',I5, + ' OF THESE ARE NUMBERED 1-',I4,' AND THESE REAL NODES', + ' HAVE TWO VELOCITY VARIABLES UNLESS CONSTRAINED.') IF (NFAKEN.GT.0) WRITE (IUNIT8,42) NFAKEN,NBASE,NTOP 42 FORMAT(' ',I5, + ' OF THESE ARE NUMBERED ',I6,'-',I6,' AND THESE ARE', + ' ARTIFICIAL;'/' THEIR VELOCITIES MUST BE', + ' COMPLETELY SPECIFIED.') WRITE (IUNIT8,49) 49 FORMAT(/ + ' (NOTE: X AND Y COORDINATES MAY BE ZERO FOR NODES WHICH' + ,' WILL BE AT MIDPOINTS OF ELEMENT SIDES AND/OR FAULTS.'/ + ' THE PROGRAM WILL INTERPOLATE VALUES FOR THESE.)') WRITE (IUNIT8,50) 50 FORMAT (/' ', + ' MANTLE'/ + ' ', + ' CRUSTAL LITHOSPHERE'/ + ' NODE X Y ELEVATION ', + 'HEAT-FLOW THICKNESS THICKNESS'/) 55 FORMAT (' ',I10,1P,2E11.3,4E10.2) ENDIF DO 90 K=1,NUMNOD CHECKN(K)=.FALSE. 90 CONTINUE DO 100 K=1,NUMNOD CALL READN (INPUT,IUNIT7,IUNIT8,7, + OUTPUT,VECTOR) INDEX=VECTOR(1)+0.5 XI=VECTOR(2) YI=VECTOR(3) ELEVI=VECTOR(4) QI=VECTOR(5) ZMI=VECTOR(6) TLI=VECTOR(7) 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,96) 96 FORMAT (' NEGATIVE HEAT-FLOW IS NON-PHYSICAL.') STOP ENDIF XNODE(I)=XI YNODE(I)=YI IF (ZMI.LT.0.) THEN WRITE (IUNIT8,97) 97 FORMAT(' NEGATIVE CRUSTAL THICKNESS IS NON-PHYSICAL.') STOP ENDIF ZMNODE(I)=ZMI IF (TLI.LT.0.) THEN WRITE (IUNIT8,98) 98 FORMAT(' NEGATIVE MANTLE LITHOSPHERE THICKNESS IS', + ' NON-PHYSICAL.') STOP ENDIF TLNODE(I)=TLI IF (.NOT.BRIEF) THEN WRITE (IUNIT8,55) INDEX,XI,YI,ELEVI,QI,ZMI,TLI 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 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,TLNODE,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) C C THIS SUBPROGRAM CONTAINS THE NONLINEAR RHEOLOGY OF THE FAULTS. C FOR EACH OF 7 INTEGRATION POINTS ALONG THE LENGTH OF EACH FAULT C ELEMENT, IT: C C (1) COMPUTES THE SLIP-RATE VECTOR ON THE FAULT SURFACE, C (2) DETERMINES THE SHEAR STRESS ON THE FAULT SURFACE BY MOHR/ C COULOMB/NAVIER THEORY (THIS STRESS IS PROPORTIONAL TO DEPTH, C SO THE CALCULATION IS ACTUALLY DONE AT UNIT DEPTH AND THEN C SCALED), C (3) PROCEEDS DOWN THE DIP OF THE FAULT, CHECKING TEMPERATURE, C STRAIN-RATE, AND PRESSURE TO SEE IF FRICTIONAL OR CREEP C SHEAR STRESS IS LOWER, C (4) REPORTS THE VERTICAL INTEGRAL OF "MU" (THE RATIO OF SHEAR C STRESS TO SLIP RATE) DOWN THE FAULT AS "FIMUDZ". C (NOTE THAT THE INTEGRAL IS VERTICAL, NOT ON A SLANT, EVEN THOUGH C CONDITIONS ARE EVALUATED ALONG A SLANT PATH.) C (5) FOR DIPPING, OBLIQUE-SLIP FAULT ONLY, ALSO REPORTS RECOMMENDED C TACTICAL VALUES FOR THE MATRIX "FC" AND THE VECTOR "FTSTAR" C WHICH JOINTLY DESCRIBE A LINEARIZED RHEOLOGY STIFFER THAN C THE ACTUAL NONLINEAR RHEOLOGY. C (6) "ZTRANF" IS THE LATEST ESTIMATE OF THE DEPTH C TO THE BRITTLE/DUCTILE TRANSITION, AT THE FAULT MIDPOINT. C (7) LOGICAL VARIABLE "FSLIPS" INDICATES WHETHER THE FAULT IS C SLIPPING AT ITS MIDPOINT. OTHERWISE, IT IS IN THE ARTIFICIAL C LINEARIZED REGIME, WITH STIFFNESS "FMUMAX". C (8) "FPEAKS" GIVES THE PEAK SHEAR STRESS AT THE MIDPOINT OF EACH C FAULT, EVALUATED AT THE BRITTLE/DUCTILE TRANSITION. C C NOTE THAT PORE PRESSURES ARE CONSIDERED IN THE CALCULATION OF C FRICTIONAL STRENGTH: C *NORMAL PORE PRESSURES REDUCE THE EFFECTIVE NORMAL STRESS ON THE C FAULT SURFACE BY THE AMOUNT C -BIOT*GMEAN*RHOH20*Z C *IF (OFFMAX.GT.0.), THEN THE REMAINING EFFECTIVE FRICTIONAL STRENGTH C OF THE FAULT IS MULTIPLIED BY THE REDUCING FACTOR C *(1.-BYERLY*OFFSET(I)/OFFMAX). C THIS IS ALSO A PORE PRESSURE EFFECT, BECAUSE BYERLY'S MODEL IS C THAT GOUGE LAYERS HAVE THICKNESS IN PROPORTION TO OFFSET, AND C THAT THEY SUPPORT NON-DARCY STATIC PORE PRESSURE GRADIENTS WHICH C REDUCE THE EFFECTIVE FRICTION OF THE FAULT. C C FOLLOWING PARAMETER GIVES NUMBER OF STEPS IN VERTICAL INTEGRAL C OF CREEP SHEAR STRESS ON DUCTILE PARTS OF FAULTS: PARAMETER (NSTEP=20) C HIGHER VALUES OBVIOUSLY COST MORE. ON THE OTHER HAND, SMALL VALUES C DO NOT MERELY APPROXIMATE THE CREEP LAW; THEY ALSO INTRODUCE C SOME RANDOM ERR0R WHICH CAN PUT A FLOOR ON CONVERGENCE. C C NOTE: IN VS-FORTRAN, FOLLOWING TYPE COULD BE LOGICAL*1: LOGICAL FSLIPS C LOGICAL LOCKED,PURESS,SLOPED DOUBLE PRECISION V DOUBLE PRECISION FPHI COMMON /FPHIS/ FPHI REAL MANTLE,NORMAL C DIMENSIONS PER COMMON BLOCK: DIMENSION FPHI(6,7) C DIMENSIONS OF INTERNAL CONVENIENCE ARRAYS: DIMENSION DLEPDZ(2),DSFDZ(2),RHO(2),SHEART(2),TMEAN(2),ZTRANS(2) C DIMENSIONS OF EXTERNAL ARGUMENTS ARRAYS: DIMENSION ACREEP(2),ALPHAT(2),BCREEP(2),CCREEP(2),CONDUC(2), + DCREEP(2),DQDTDA(MXNODE), + FC(2,2,7,MXFEL),FDIP(3,MXFEL), + FIMUDZ(7,MXFEL),FPEAKS(2,MXFEL),FSLIPS(MXFEL), + FTAN(7,MXFEL),FTSTAR(2,7,MXFEL),NODEF(6,MXFEL), + OFFSET(MXFEL),RADIO(2),RHOBAR(2),TLNODE(MXNODE), + V(2,MXNODE),ZMNODE(MXNODE),ZTRANF(2,MXFEL) C C FOLLOWING TWO NUMBERS ARE "VERY SMALL" AND "VERY LARGE", BUT NOT C SO EXTREME AS TO CAUSE UNDERFLOW OR OVERFLOW. THEY MAY NEED TO C BE ADJUSTED, DEPENDING ON THE COMPUTER AND COMPILER BEING USED. DATA TINY /1.E-30/ DATA HUGE /1.E+30/ 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 IF ((TLNODE(N2).LE.0.).OR.(ZTRANF(2,I).LE.0.)) THEN C CRUST ALONE RESISTS CONVERGENCE: DPMAX= -2.*DELTAU/ZTRANF(1,I) DDPNDZ=DPMAX/ZTRANF(1,I) ELSE C MANTLE LITHOSPHERE HELPS TO RESIST CONVERGENCE: DDPNDZ= -DELTAU/ + (0.5*ZTRANF(1,I)**2+ZTRANF(2,I)*ZMNODE(N2)+ + 0.5*ZTRANF(2,I)**2) ENDIF C DDPNDZ IS THE GRADIENT OF EXCESS NORMAL PRESSURE (IN C EXCESS OF VERTICAL PRESSURE) WITH DEPTH ON THIS FAULT; C CHECK THAT IT LIES WITHIN FRICTIONAL LIMITS OF BLOCKS: Q=0.5*(DQDTDA(N2)+DQDTDA(N5)) TTRANS=TSURF+ZTRANF(1,I)*Q/CONDUC(1)- + ZTRANF(1,I)**2*RADIO(1)/(2.*CONDUC(1)) TMEANC=(TSURF+TTRANS)/2. RHOC=RHOBAR(1)*(1.-ALPHAT(1)*TMEANC) DLEPDC=GMEAN*(RHOC-RHOH2O*BIOT) THRUST=DLEPDC*CGAMMA NORMAL=DLEPDC/CGAMMA DDPNDZ=MAX(DDPNDZ,NORMAL-DLEPDC) DDPNDZ=MIN(DDPNDZ,THRUST-DLEPDC) C ELSE C DIFFERENT LOGIC WILL BE USED; THIS PARAMETER IS NOT C REALLY NEEDED. ZERO IT JUST TO BE CAREFUL. DDPNDZ=0. ENDIF C DO 90 M=1,7 C HEAT-FLOW: Q=DQDTDA(N1)*FPHI(1,M)+DQDTDA(N2)*FPHI(2,M)+ + DQDTDA(N3)*FPHI(3,M) C C CRUSTAL THICKNESS: CRUST=ZMNODE(N1)*FPHI(1,M)+ZMNODE(N2)*FPHI(2,M)+ + ZMNODE(N3)*FPHI(3,M) C C MANTLE LITHOSPHERE THICKNESS: MANTLE=TLNODE(N1)*FPHI(1,M)+TLNODE(N2)*FPHI(2,M)+ + TLNODE(N3)*FPHI(3,M) MANTLE=MAX(MANTLE,0.) C C MOHO TEMPERATURE: TMOHO=TSURF+CRUST*Q/CONDUC(1)- + CRUST**2*RADIO(1)/(2.*CONDUC(1)) C C TEMPERATURE AT BASE OF PLATE: TASTH=TMOHO+MANTLE*(Q-CRUST*RADIO(1))/CONDUC(2)- + MANTLE**2*RADIO(2)/(2.*CONDUC(2)) C C MEAN TEMPERATURES: TMEAN(1)=(TSURF+TMOHO)/2. TMEAN(2)=(TMOHO+TASTH)/2. C C MEAN DENSITIES: RHO(1)=RHOBAR(1)*(1.-ALPHAT(1)*TMEAN(1)) RHO(2)=RHOBAR(2)*(1.-ALPHAT(2)*TMEAN(2)) C C DERIVITIVES OF LITHOSTATIC EFFECTIVE PRESSURE WRT DEPTH DLEPDZ(1)=GMEAN*(RHO(1)-RHOH2O*BIOT) EPMOHO=DLEPDZ(1)*CRUST DLEPDZ(2)=GMEAN*(RHO(2)-RHOH2O*BIOT) C C ANGLE IS THE FAULT STRIKE, IN RADIANS CCLKWS FROM +X. 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(1)=(DLEPDZ(1)+DDPNDZ)*FRIC SFMOHO=DSFDZ(1)*CRUST DSFDZ(2)=(DLEPDZ(2)+DDPNDZ)*FRIC SLIP=ABS(SINIST) LOCKED=.FALSE. ELSE C CASE OF A SHALLOW-DIPPING FAULT: C C VUPDIP IS THE UP-DIP VELOCITY COMPONENT, IN THE C FAULT PLANE, OF THE BLOCK ON THE N1-N3 SIDE. VUPDIP=CLOSE/COS(DIP) C C RAKE ANGLE IS MEASURED COUNTERCLOCKWISE IN C FAULT PLANE FROM HORIZONTAL & PARALLEL TO ANGLE. RAKE=ATAN2F(VUPDIP,SINIST) C C DERIVITIVE OF EFFECTIVE NORMAL PRESSURE C WITH RESPECT TO SHEAR TRACTION ON FAULT: DEPDST=TAN(DIP)*SIN(RAKE) C (NOTICE THAT WHEN SENSE OF DIP REVERSES, SIGN C CHANGE CAUSED BY TAN(DIP) IS CANCELLED BY SIGN C CHANGE CAUSED BY SIN(RAKE).) C C ACCORDING TO THEORY, THE EQUATION TO SOLVE IS: C D(SHEAR_TRACTION)/DZ = C "FRIC"*("DLEPDZ"+"DEPDST"*D(SHEAR_TRACTION)/DZ) C THIS MAY HAVE A PHYSICAL SOLUTION (ONE WITH C POSITIVE SHEAR_TRACTION). IF NOT, THE C FAULT IS LOCKED. LOCKED=(FRIC*DEPDST).GE.1.00 IF (LOCKED) THEN DSFDZ(1)=HUGE DSFDZ(2)=HUGE ELSE DSFDZ(1)=FRIC*DLEPDZ(1)/(1.00-FRIC*DEPDST) SFMOHO=DSFDZ(1)*CRUST DSFDZ(2)=FRIC*DLEPDZ(2)/(1.00-FRIC*DEPDST) ENDIF C SLIP=SQRT((1.D0*SINIST)**2+(1.D0*VUPDIP)**2) ENDIF SLIP=MAX(SLIP,TINY*50.*ONEKM) C C LOCATE PLASTIC/CREEP TRANSITION(S) C BY ITERATED HALVING OF DOMAIN: C IF (MANTLE.GT.0.) THEN LIMIT=2 ELSE LIMIT=1 ZTRANS(2)=0. SHEART(2)=0. ENDIF DO 60 LAYER=1,LIMIT TOPZ=0. IF (LAYER.EQ.1) THEN BASEZ=CRUST SF0=0. T0=TSURF Q0=Q Z0=0. ELSE BASEZ=MANTLE SF0=SFMOHO T0=TMOHO Q0=Q-CRUST*RADIO(1) Z0=CRUST ENDIF DO 50 KITER=1,15 Z=0.5*(TOPZ+BASEZ) ZABS=Z+Z0 SHEARF=Z*DSFDZ(LAYER)+SF0 SHEARP=MIN(SHEARF,DCREEP(LAYER)) T=T0+Q0*Z/CONDUC(LAYER)-(RADIO(LAYER)/ + (2.*CONDUC(LAYER)))*Z**2 IF (ZABS.LE.(15.*ONEKM)) THEN T90PC=0.5*ZABS ELSE IF (ZABS.LT.(45.*ONEKM)) THEN T90PC=(405./8.)*ONEKM+ + (-7.)*ZABS+ + (13./40.)*ONEKM*(ZABS/ONEKM)**2+ + (-1./300.)*ONEKM*(ZABS/ONEKM)**3 ELSE T90PC=2.*ZABS ENDIF C SEE TURCOTTE ET AL (1980) JGR, 85, B11, 6224-6230 STRAIN=SLIP/T90PC SHEARC=ACREEP(LAYER)*(STRAIN**ECREEP)* + EXP((BCREEP(LAYER)+CCREEP(LAYER)*Z)/T) IF (SHEARC.LT.SHEARP) THEN BASEZ=Z ELSE TOPZ=Z ENDIF 50 CONTINUE ZTRANS(LAYER)=0.5*(TOPZ+BASEZ) SHEART(LAYER)=ZTRANS(LAYER)*DSFDZ(LAYER)+SF0 60 CONTINUE C C PLASTIC PART OF VERTICAL INTEGRAL(S) OF TRACTION: C (A) CRUST: IF (SHEART(1).LE.DCREEP(1)) THEN VITDZ=0.5*SHEART(1)*ZTRANS(1) ELSE ZP=ZTRANS(1)*DCREEP(1)/SHEART(1) VITDZ=DCREEP(1)*(ZTRANS(1)-0.5*ZP) ENDIF C (B) MANTLE LITHOSPHERE: IF ((MANTLE.GT.0.).AND.(SHEART(2).GT.SFMOHO)) THEN IF (SHEART(2).LE.DCREEP(2)) THEN VITDZ=VITDZ+0.5*(SFMOHO+SHEART(2))*ZTRANS(2) ELSE ZP=ZTRANS(2)*(DCREEP(2)-SFMOHO)/ + (SHEART(2)-SFMOHO) ZP=MAX(ZP,0.) VITDZ=VITDZ+0.5*(SFMOHO+SHEART(2))*ZP+ + DCREEP(2)*(ZTRANS(2)-ZP) ENDIF ENDIF C C ADD CREEP PART(S) OF INTEGRAL, USING PARABOLIC RULE C SUM=0. DO 80 LAYER=1,LIMIT IF (LAYER.EQ.1) THEN THICK=CRUST T0=TSURF Q0=Q ZABS=0. ELSE THICK=MANTLE T0=TMOHO Q0=Q-CRUST*RADIO(1) ZABS=CRUST ENDIF DZ=(THICK-ZTRANS(LAYER))/NSTEP OLDSC=SHEART(LAYER) OLDSC=MIN(OLDSC,DCREEP(LAYER)) Z0=ZTRANS(LAYER) DO 70 J=1,NSTEP ZHALF=Z0+0.5*DZ ZFULL=Z0+DZ AZHALF=ZHALF+ZABS AZFULL=ZFULL+ZABS THALF=T0+Q0*ZHALF/CONDUC(LAYER)- + (RADIO(LAYER)/ + (2.*CONDUC(LAYER)))*ZHALF**2 TFULL=T0+Q0*ZFULL/CONDUC(LAYER)- + (RADIO(LAYER)/ + (2.*CONDUC(LAYER)))*ZFULL**2 IF (AZHALF.LE.(15.*ONEKM)) THEN WHALF=0.5*AZHALF ELSE IF (AZHALF.LT.(45.*ONEKM)) THEN WHALF=(405./8.)*ONEKM+ + (-7.)*AZHALF+ + (13./40.)*ONEKM*(AZHALF/ONEKM)**2+ + (-1./300.)*ONEKM*(AZHALF/ONEKM)**3 ELSE WHALF=2.*AZHALF ENDIF IF (AZFULL.LE.(15.*ONEKM)) THEN WFULL=0.5*AZFULL ELSE IF (AZFULL.LT.(45.*ONEKM)) THEN WFULL=(405./8.)*ONEKM+ + (-7.)*AZFULL+ + (13./40.)*ONEKM*(AZFULL/ONEKM)**2+ + (-1./300.)*ONEKM*(AZFULL/ONEKM)**3 ELSE WFULL=2.*AZHALF ENDIF C SEE TURCOTTE ET AL (1980) JGR, 85, B11, 6224-6230 EHALF=SLIP/WHALF EFULL=SLIP/WFULL SCHALF=ACREEP(LAYER)*(EHALF**ECREEP)* + EXP((BCREEP(LAYER)+CCREEP(LAYER)*ZHALF) + /THALF) SCHALF=MIN(SCHALF,DCREEP(LAYER)) SCFULL=ACREEP(LAYER)*(EFULL**ECREEP)* + EXP((BCREEP(LAYER)+CCREEP(LAYER)*ZFULL) + /TFULL) SCFULL=MIN(SCFULL,DCREEP(LAYER)) SUM=SUM+DZ*(0.1666667*OLDSC+ + 0.6666667*SCHALF+ + 0.1666666*SCFULL) Z0=ZFULL OLDSC=SCFULL 70 CONTINUE 80 CONTINUE C VITDZ=VITDZ+SUM C VIMUDZ=VITDZ/SLIP C FIMUDZ(M,I)=MIN(VIMUDZ,FMUMAX*(CRUST+MANTLE)) C C DIPPING, OBLIQUE-SLIP INTEGRATION C POINTS ARE ALSO CHARACTERIZED C BY "FC" AND "FTSTAR": C IF (SLOPED) THEN TS=SINIST*FIMUDZ(M,I) TU=VUPDIP*FIMUDZ(M,I) IF (LOCKED) THEN FC(1,1,M,I)=FIMUDZ(M,I) FC(1,2,M,I)=0. FC(2,1,M,I)=0. FC(2,2,M,I)=FIMUDZ(M,I) ELSE SINR=SIN(RAKE) COSR=COS(RAKE) TAND=TAN(DIP) C C *** IMPORTANT NOTE: *** C THE FOLLOWING 7 STATEMENTS ARE -NOT- THE C RESULT OF THEORY, BUT A TACTICAL CHOICE C WHICH ATTEMPTS TO COMPROMISE BETWEEN C STABILITY OF THE LINEAR SYSTEM, STABILITY C OF THE ITERATION, AND EFFICIENCY. C THEY MAY BE CHANGED IF THE PROGRAM DOES C 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*(CRUST+MANTLE))) ZTRANF(1,I)=ZTRANS(1) FPEAKS(1,I)=SHEART(1) ZTRANF(2,I)=ZTRANS(2) FPEAKS(2,I)=SHEART(2) ENDIF C 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE NEXT (INPUT,I,J,MXEL,MXFEL,NFL,NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) C C DETERMINE WHETHER THERE ARE MORE ELEMENTS ADJACENT TO SIDE J OF C TRIANGULAR CONTINUUM ELEMENT #I. C J = 1 MEANS THE SIDE 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 TITLE1=' '// + ' ' READ (IUNITV,'(A80)',END=100,ERR=100) TITLE1 TITLE2=' '// + ' ' READ (IUNITV,'(A80)',END=100,ERR=100) TITLE2 TITLE3=' '// + ' ' READ (IUNITV,'(A80)',END=100,ERR=100) TITLE3 READ (IUNITV,*,END=100,ERR=100) ((V(J,I),J=1,2),I=1,NUMNOD) ALDONE=.FALSE. RETURN C ------------------(THIS SECTION EXECUTED ONLY IF READ FAILS)--------- 100 ALDONE=.TRUE. RETURN END C C C SUBROUTINE ONEBAR (INPUT,ACREEP,BCREEP,CCREEP, + ECREEP,GEOTHC,GEOTHM, + MXEL,NUMEL, + TEMLIM,TLINT,ZMOHO, + OUTPUT,GLUE) C C CALCULATES "GLUE" (SHEAR STRESS REQUIRED TO CREATE UNIT RELATIVE C HORIZONTAL VELOCITY ACROSS THE PLATE) C C PARAMETER "NINT" SETS NUMBER OF STEPS IN VERTICAL INTEGRALS: PARAMETER (NINT=100) C C EXTERNAL ARGUMENT ARRAYS: DIMENSION ACREEP(2),BCREEP(2),CCREEP(2), + GEOTHC(4,7,MXEL),GEOTHM(4,7,MXEL), + GLUE(7,MXEL), + TEMLIM(2), + TLINT(7,MXEL),ZMOHO(7,MXEL) C INTERNAL ARRAYS: DIMENSION AILOG(2),GT(4) C C ECINI= -1.0/ECREEP AILOG(1)=LOG(ACREEP(1))*ECINI AILOG(2)=LOG(ACREEP(2))*ECINI DO 100 M=1,7 DO 90 I=1,NUMEL V=0. IF (TLINT(M,I).GT.0.) THEN LIMIT=2 ELSE LIMIT=1 ENDIF DO 20 LAYER=1,LIMIT IF (LAYER.EQ.1) THEN THICK=ZMOHO(M,I) GT(1)=GEOTHC(1,M,I) GT(2)=GEOTHC(2,M,I) GT(3)=GEOTHC(3,M,I) GT(4)=GEOTHC(4,M,I) ELSE THICK=TLINT(M,I) GT(1)=GEOTHM(1,M,I) GT(2)=GEOTHM(2,M,I) GT(3)=GEOTHM(3,M,I) GT(4)=GEOTHM(4,M,I) ENDIF DZ=THICK/NINT DO 10 J=1,NINT Z=(J-0.5)*DZ T=GT(1) + +GT(2)*Z + +GT(3)*Z*Z + +GT(4)*Z*Z*Z TH=MAX(T,200.) TL=MIN(TH,TEMLIM(LAYER)) BI=(BCREEP(LAYER)+CCREEP(LAYER)*Z)*ECINI ARG=MAX(AILOG(LAYER)+BI/TL,-89.9) V=V+DZ*EXP(ARG) 10 CONTINUE 20 CONTINUE GLUE(M,I)=1./(V**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, OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT , + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , GMEAN , + MAXITR, OKDELV, OKTOQT, ONEKM, RADIO , + REFSTR, RHOAST, RHOBAR, RHOH2O, + TEMLIM, TITLE3, TRHMAX, TSURF, $ NPTYPE, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,NCONTR, $ STATES,RMSVEC, $ SDENOM,XCENTR,YCENTR,PAPER, $ IPEN1,IPEN2,IPEN3,COLOR) C C READS STRATEGIC AND TACTICAL INPUT PARAMETERS FROM DEVICE IUNIT7, C FOLLOWED BY PLOT-CONTROL PARAMETERS, C AND ECHOES THEM ON DEVICE IUNIT8 WITH ANNOTATIONS. C CHARACTER*80 TITLE3 LOGICAL COLOR,DOPLOT,EVERYP,STATES DIMENSION CINT(NPTYPE),DOPLOT(NPTYPE), + FBLAND(NPTYPE),LOWBLU(NPTYPE) DIMENSION ACREEP(2),ALPHAT(2),BCREEP(2),CCREEP(2),CONDUC(2), + DCREEP(2),RADIO(2), + RHOBAR(2),TEMLIM(2) C WRITE (IUNIT8,1) IUNIT7 1 FORMAT (/ /' ATTEMPTING TO READ PARAMETERS FROM UNIT',I3) TITLE3=' '// + ' ' READ (IUNIT7,2) 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 CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,ACREEP) IF (ACREEP(2).EQ.0.) ACREEP(2)=ACREEP(1) WRITE (IUNIT8,50) ACREEP(1),ACREEP(2) 50 FORMAT (' ',1P, E10.2,'/',E10.2,' A FOR CREEP = ', + 'PRE-EXPONENTIAL SHEAR', + ' STRESS CONSTANT FOR CREEP. (CRUST/MANTLE)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,BCREEP) IF (BCREEP(2).EQ.0.) BCREEP(2)=BCREEP(1) WRITE (IUNIT8,60) BCREEP(1),BCREEP(2) 60 FORMAT (' ', F10.0,'/',F10.0,' B FOR CREEP =(ACTIVATION ', + 'ENERGY)/R/N', + ' IN K. (CRUST/MANTLE)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,CCREEP) IF (CCREEP(2).EQ.0.) CCREEP(2)=CCREEP(1) WRITE (IUNIT8,70) CCREEP(1),CCREEP(2) 70 FORMAT (' ',1P, E10.2,'/',E10.2,' C FOR CREEP = DERIVATIVE OF B', + ' WITH RESPECT TO DEPTH. (CRUST/MANTLE)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,DCREEP) IF (DCREEP(2).EQ.0.) DCREEP(2)=DCREEP(1) WRITE (IUNIT8,80) DCREEP(1),DCREEP(2) 80 FORMAT (' ',1P, E10.2,'/',E10.2,' D FOR CREEP = MAXIMUM SHEAR ', + 'STRESS UNDER ANY CONDITIONS. (CRUST/MANTLE)') READ (IUNIT7,*) ECREEP WRITE (IUNIT8,90) ECREEP 90 FORMAT (' ', F10.6,' E FOR CREEP = STRAIN-RATE EXPONENT FOR', + ' CREEP (1/N). (SAME FOR CRUST AND MANTLE!)') READ (IUNIT7,*) TRHMAX IF (TRHMAX.EQ.1.) TRHMAX=9.9E39 WRITE (IUNIT8,101) TRHMAX 101 FORMAT (' ',1P,E10.2,' LIMIT ON HORIZONTAL TRACTIONS', + ' APPLIED TO BASE OF PLATE') READ (IUNIT7,*) RHOH2O WRITE (IUNIT8,110) RHOH2O 110 FORMAT (' ',1P,E10.3,' DENSITY OF GROUNDWATER, LAKES, & OCEANS') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,RHOBAR) IF (RHOBAR(2).EQ.0.) RHOBAR(2)=RHOBAR(1) WRITE (IUNIT8,120) RHOBAR(1),RHOBAR(2) 120 FORMAT (' ',1P,E10.3,'/',E10.3,' MEAN DENSITY,', + ' CORRECTED TO 0 DEGREES KELVIN. (CRUST/MANTLE)') 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)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,ALPHAT) IF (ALPHAT(2).EQ.0.) ALPHAT(2)=ALPHAT(1) WRITE (IUNIT8,160) ALPHAT(1),ALPHAT(2) 160 FORMAT (' ',1P,E10.2,'/',E10.2,' VOLUMETERIC THERMAL ', + 'EXPANSION OF CRUST', + ' (1/VOL)*(D.VOL/D.T). (CRUST/MANTLE)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,CONDUC) IF (CONDUC(2).EQ.0.) CONDUC(2)=CONDUC(1) WRITE (IUNIT8,170) CONDUC(1),CONDUC(2) 170 FORMAT (' ',1P,E10.2,'/',E10.2,' THERMAL CONDUCTIVITY, ENERGY/', + 'LENGTH/SEC/DEG. (CRUST/MANTLE)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,RADIO) IF (RADIO(2).EQ.0.) RADIO(2)=RADIO(1) WRITE (IUNIT8,180) RADIO(1),RADIO(2) 180 FORMAT (' ',1P,E10.2,'/',E10.2,' RADIOACTIVE HEAT PRODUCTION', + ' ENERGY/VOLUME/SEC. (CRUST/MANTLE)') READ (IUNIT7,*) TSURF WRITE (IUNIT8,185) TSURF 185 FORMAT (' ', F10.0,' SURFACE TEMPERATURE, ON', + ' ABSOLUTE SCALE') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,TEMLIM) IF (TEMLIM(2).EQ.0.) TEMLIM(2)=TEMLIM(1) WRITE (IUNIT8,190) TEMLIM(1),TEMLIM(2) 190 FORMAT (' ', F10.0,'/',F10.0,' CONVECTING TEMPERATURE (TMAX), ON' + ,' ABSOLUTE SCALE. (CRUST/MANTLE)') WRITE (IUNIT8,199) 199 FORMAT (/' ========== TACTICAL PARAMETERS (HOW TO REACH ', + 'THE SOLUTION) =========='/) READ (IUNIT7,*) MAXITR WRITE (IUNIT8,200) MAXITR 200 FORMAT (' ',I10,' MAXIMUM ITERATIONS WITHIN VELOCITY SOLUTION') READ (IUNIT7,*) OKTOQT WRITE (IUNIT8,210) OKTOQT 210 FORMAT (' ',F10.6,' ACCEPTABLE FRACTIONAL CHANGE IN VELOCITY ', + '(STOPS ITERATION EARLY)') READ (IUNIT7,*) REFSTR WRITE (IUNIT8,220) REFSTR 220 FORMAT (' ',1P,E10.2,' EXPECTED MEAN VALUE OF SHEAR STRESS IN', + ' CRUST'/' ',10X, + ' (USED TO INITIALIZE AND SET STIFFNESS LIMITS)') READ (IUNIT7,*) OKDELV WRITE (IUNIT8,230) OKDELV 230 FORMAT (' ',1P,E10.2,' MAGNITUDE OF VELOCITY ERR0RS ALLOWED', + ' DUE TO FINITE STIFFNESS'/11X, + '(SUCH ERR0RS MAY APPEAR IN SUCH FORMS AS:'/11X, + ' 1. FICTICIOUS BASAL SLIP OF CRUST OVER MANTLE'/11X, + ' 2. ERRONEOUS CONVERGENCE/DIVERGENCE AT VERTICAL FAULTS'/ + 11X, + ' 3. VELOCITY EFFECT OF FICTICIOUS VISCOUS COMPLIANCES'/11X, + ' HOWEVER, VALUES WHICH ARE TOO SMALL WILL CAUSE ILL-CONDITIONED' + /11X, + ' LINEAR SYSTEMS AND STRESS ERR0RS, ', + 'AND MAY PREVENT CONVERGENCE!)') READ (IUNIT7,*) EVERYP WRITE (IUNIT8,240) EVERYP 240 FORMAT (' ',L10,' SHOULD NODAL VELOCITIES BE OUTPUT EVERY STE', + 'P? (FOR CONVERGENCE STUDIES)') WRITE (IUNIT8,999) 999 FORMAT (' --------------------------------------------------', + '-----------------------------') 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 PLATES) =====') C READ(IUNIT7,*) KTIME WRITE(IUNIT8,1001) KTIME 1001 FORMAT(/ / + ' ',I10,' KTIME (NOT USED BY THIS PROGRAM)') READ(IUNIT7,1011) DOPLOT(1) READ(IUNIT7,1010) DOPLOT(2),CINT(2),FBLAND(2),LOWBLU(2) READ(IUNIT7,1010) DOPLOT(3),CINT(3),FBLAND(3),LOWBLU(3) READ(IUNIT7,1010) DOPLOT(4),CINT(4),FBLAND(4),LOWBLU(4) READ(IUNIT7,1010) DOPLOT(5),CINT(5),FBLAND(5),LOWBLU(5) READ(IUNIT7,1010) DOPLOT(6),CINT(6),FBLAND(6),LOWBLU(6) READ(IUNIT7,1010) DOPLOT(7),CINT(7),FBLAND(7),LOWBLU(7) READ(IUNIT7,1010) DOPLOT(8),CINT(8),FBLAND(8),LOWBLU(8) READ(IUNIT7,1010) DOPLOT(9),CINT(9),FBLAND(9),LOWBLU(9) READ(IUNIT7,1010) DOPLOT(10),CINT(10),FBLAND(10),LOWBLU(10) READ(IUNIT7,1010) DOPLOT(11),CINT(11),FBLAND(11),LOWBLU(11) READ(IUNIT7,1010) DOPLOT(12),CINT(12),FBLAND(12),LOWBLU(12) READ(IUNIT7,1011) DOPLOT(13) READ(IUNIT7,1010) DOPLOT(14),CINT(14),FBLAND(14),LOWBLU(14) READ(IUNIT7,1010) DOPLOT(15),CINT(15),FBLAND(15),LOWBLU(15) 1010 FORMAT(L10,2E10.2,I2) 1011 FORMAT(L10) WRITE(IUNIT8,1101) DOPLOT( 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) WRITE(IUNIT8,1112) DOPLOT(12),CINT(12),FBLAND(12),LOWBLU(12) WRITE(IUNIT8,1113) DOPLOT(13) WRITE(IUNIT8,1114) DOPLOT(14),CINT(14),FBLAND(14),LOWBLU(14) WRITE(IUNIT8,1115) DOPLOT(15),CINT(15),FBLAND(15),LOWBLU(15) 1101 FORMAT(L11,22X, ' GRID OF ELEMENTS') 1102 FORMAT(L11,1P,2E10.2,I2,' ELEVATION') 1103 FORMAT(L11,1P,2E10.2,I2,' HEAT-FLOW') 1104 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL THICKNESS') 1105 FORMAT(L11,1P,2E10.2,I2,' MANTLE LITHOSPHERE THICKNESS') 1106 FORMAT(L11,1P,2E10.2,I2,' MOHO TEMPERATURE') 1107 FORMAT(L11,1P,2E10.2,I2,' TEMPERATURE AT BASE OF PLATE') 1108 FORMAT(L11,1P,2E10.2,I2,' VELOCITY VECTORS AT PLATE BASE') 1109 FORMAT(L11,1P,2E10.2,I2,' SHEAR TRACTION ON PLATE BASE') 1110 FORMAT(L11,1P,2E10.2,I2,' SURFACE VELOCITY VECTORS') 1111 FORMAT(L11,1P,2E10.2,I2,' VELOCITY CHANGE FROM LAST ITERATION') 1112 FORMAT(L11,1P,2E10.2,I2,' GREATEST PRINCIPAL STRAIN RATES') 1113 FORMAT(L11,22X, ' SLIP-RATE OF FAULTS') 1114 FORMAT(L11,1P,2E10.2,I2,' RATE OF CRUSTAL THICKENING') 1115 FORMAT(L11,1P,2E10.2,I2,' PRINCIPAL' + ,' STRESS ANOMALY INTEGRALS') 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,*) XCENTR, YCENTR WRITE (IUNIT8,1427) XCENTR, YCENTR 1427 FORMAT(' (',1P,E9.2,',',E9.2,')=(X,Y) OF PLOT CENTER, IF CLIPPIN' + ,'G IS NEEDED.') READ (IUNIT7,*) PAPER PAPER=MAX(PAPER,6.) PAPER=MIN(PAPER,17.) WRITE (IUNIT8,1428) PAPER 1428 FORMAT(' ',1P,E10.2,' MAXIMUM INCHES OF PAPER TO BE USED IN' + ,' PLOTS (.LE.17.).') READ (IUNIT7,*) IPEN1 IPEN1=MIN(IPEN1,31) IPEN1=MAX(IPEN1,1) WRITE (IUNIT8,1429) IPEN1 1429 FORMAT(' ',I10,' FINEST PEN WIDTH IN UNITS OF 0.1 MM') READ (IUNIT7,*) IPEN2 IPEN2=MIN(IPEN2,31) IPEN2=MAX(IPEN2,1) WRITE (IUNIT8,1430) IPEN2 1430 FORMAT(' ',I10,' MEDIUM PEN WIDTH IN UNITS OF 0.1 MM') READ (IUNIT7,*) IPEN3 IPEN3=MIN(IPEN3,31) IPEN3=MAX(IPEN3,1) WRITE (IUNIT8,1431) IPEN3 1431 FORMAT(' ',I10,' WIDEST PEN WIDTH IN UNITS OF 0.1 MM') READ(IUNIT7,*) COLOR WRITE(IUNIT8,1432) COLOR 1432 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,GEOTHC,GEOTHM, + IUNITT, + MXEL,MXFEL,MXNODE,NFL, + NODEF,NODES,NREALN,NUMEL,NUMNOD,N1000, + ONEKM,RHOAST,RHOBAR,RHOH2O,SIGHB, + TAUMAT,TAUZZI,TITLE1,TITLE2,TITLE3, + TLINT,TLNODE, + V,WEDGE,ZMNODE,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 ALPHAT(2),ELEV(MXNODE),ERATE(3,7,MXEL), + FDIP(3,MXFEL),FIMUDZ(7,MXFEL),FPEAKS(2,MXFEL), + FSLIPS(MXFEL),FTAN(7,MXFEL), + GEOTHC(4,7,MXEL),GEOTHM(4,7,MXEL), + NODEF(6,MXFEL),NODES(6,MXEL), + RHOBAR(2),SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL),TAUZZI(7,MXEL), + TLINT(7,MXEL),TLNODE(MXNODE),V(2,MXNODE), + ZMNODE(MXNODE),ZMOHO(7,MXEL), + ZTRANC(2,7,MXEL),ZTRANF(2,MXFEL) C C------------------------BEGIN WRITING TO UNIT IUNITT--------------- C C VELOCITIES AT NODES: C WRITE (IUNITT,30) 30 FORMAT(/ /' VELOCITIES OF THE NODES:'/ + ' ', + ' ARGUMENT'/ + ' ', + ' (DEGREES'/ + ' NODE X-COMPONENT Y-COMPONENT MAGNI', + 'TUDE FROM +X)'/) DO 100 I=1,NUMNOD IF (I.LE.NREALN) THEN IP=I ELSE IP=N1000+I-NREALN ENDIF VX=V(1,I) VY=V(2,I) AZIMUT=ATAN2F(VY,VX)*57.2957795 VMAG=SQRT(V(1,I)**2+V(2,I)**2) WRITE (IUNITT,40) IP,V(1,I),V(2,I),VMAG,AZIMUT 40 FORMAT(' ',I5,1P,2D20.12,E10.2,0P,F8.2) 100 CONTINUE C C TRIANGULAR CONTINUUM ELEMENT PROPERTIES AT THEIR CENTERS: C WRITE (IUNITT,110) C C (TABLE BROKEN AFTER 69 CHARACTERS, AND PRECEDED BY C'S): C C CONTINUUM ELEMENT PROPERTIES (AT CENTER POINTS): C C E1=MOST E2=MOST ISOSTATIC VERTICAL VERTICAL / C ELEMENT ARGUMENT COMPRESS. EXTENS. UPLIFT INTEGRAL INTEGRAL / C NUMBER OF E1 RATE RATE RATE OF(SZ+P0) OF(S1+P0)/ C 1 154.56 -1.23E-14 -1.23E-14 -1.23E-16 -1.23E+11 -1.23E+11 / C C VERTICAL BRITTLE/ BRITTLE/ BASAL BASAL<-LENGTH 118 BYTES C INTEGRAL DUCTILE DUCTILE SHEAR SHEAR C OF(S2+P0) IN CRUST IN MANTLE STRESS ARGUMENT C-1.23E+11 1.23E+04 4.15E+04 1.23E+06 145.34 C 110 FORMAT (/ /' CONTINUUM ELEMENT PROPERTIES (AT CENTER POINTS):'/ + /' E1=MOST E2=MOST ISOSTATIC VERTIC', +'AL VERTICAL VERTICAL BRITTLE/ BRITTLE/ BASAL BASAL' + /' ELEMENT ARGUMENT COMPRESS. EXTENS. UPLIFT INTEGR', +'AL INTEGRAL INTEGRAL DUCTILE DUCTILE SHEAR SHEAR' + /' NUMBER OF E1 RATE RATE RATE OF(SZ+', +'P0) OF(S1+P0) OF(S2+P0) IN CRUST IN MANTLE STRESS ARGUMENT'/) 120 FORMAT (' ',I7,F10.2,1P,9E10.2,0P,F10.2) 121 FORMAT (' ',I7,F10.2,1P,7E10.2,' --------',E10.2,0P,F10.2) 122 FORMAT (' ',I7,F10.2,1P,6E10.2,' --------',2E10.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=GEOTHC(1,M,I)+GEOTHC(2,M,I)*ZMOHO(M,I)/2.+ + GEOTHC(3,M,I)*(ZMOHO(M,I)/2.)**2 RHOC=RHOBAR(1)*(1.-ALPHAT(1)*TMID) 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) SIGHX=SIGHB(1,M,I) SIGHY=SIGHB(2,M,I) STHETA=57.2958*ATAN2F(SIGHY,SIGHX) SHEAR=SQRT((1.D0*SIGHX)**2+(1.D0*SIGHY)**2) ZTRANS=ZTRANC(1,M,I) IF ((TLINT(M,I).GT.0.).AND. + (ZTRANC(2,M,I).GT.(0.1*ONEKM))) THEN ZTRANM=ZMOHO(M,I)+ZTRANC(2,M,I) IF ((ZTRANS/ZMOHO(M,I)).GT.0.97) THEN WRITE (IUNITT,122) I,ANGLE,E1,E2,VZ, + TZZ,T1,T2, ZTRANM,SHEAR,STHETA ELSE WRITE (IUNITT,120) I,ANGLE,E1,E2,VZ, + TZZ,T1,T2,ZTRANS,ZTRANM,SHEAR,STHETA ENDIF ELSE WRITE (IUNITT,121) I,ANGLE,E1,E2,VZ, + TZZ,T1,T2,ZTRANS, SHEAR,STHETA ENDIF 200 CONTINUE WRITE (IUNITT,210) 210 FORMAT ( + /' THE FIGURES ABOVE INCLUDE VERTICAL INTEGRALS OF', + ' NORMAL STRESSES THROUGH THE PLATE. COMPRESSIVE' + /' STRESSES ARE NEGATIVE. FOR CONVENIENCE, NORMAL STRESSES ARE', + ' FIRST CORRECTED USING A STANDARD PRESSURE CURVE' + /' P0(Z), BASED ON THE STRUCTURE OF MID-OCEAN SPREADING', + ' RISES (SEE SUBPROGRAM -SQUEEZ-).') C C FAULT ELEMENT PROPERTIES, ALSO AT MIDPOINTS: C IF (NFL.GT.0) WRITE (IUNITT,300) C C (TABLE BROKEN AFTER 64 BYTES, AND PRECEDED BY C'S: C C FAULT ELEMENT PROPERTIES (AT MID-POINTS): C C / C FAULT NODES#2,5 HORIZ. ARGUMENT PLUNGE TOTAL RIGHT/ C ELEMENT (N2 MOVES SLIP OF OF SLIP LATERAL/ C NUMBER REL.TO N5) RATE SLIP SLIP RATE RATE/ C 13 236, 237 1.23E-09 145.16 74.16 1.23E-09 1.02E-09/ C C DOWN-DIP BRITTLE/ MANTLE / C PERPEN. RELATIVE INTEGRAL PEAK DUCTILE BRITTLE/ IS THIS /129 C SHORTNING VERTICAL OF SHEAR SHEAR DEPTH DUCTILE FAULT /BYTES C RATE RATE TRACTION TRACTION IN CRUST DEPTH ACTIVE?/ C 1.23E-09 1.23E-09 1.23E+13 1.23E+07 1.23E+04 4.56E+04 T 13/ C 300 FORMAT (/ / /' FAULT ELEMENT PROPERTIES (AT MID-POINTS):'/ + ' ', + ' ', + ' DOWN-DIP BRITTLE/ MANTLE '/ + ' FAULT NODES#2,5 HORIZ. ARGUMENT', + ' PLUNGE TOTAL RIGHT PERPEN. RELATIVE', + ' INTEGRAL PEAK DUCTILE BRITTLE/ IS THIS '/ + ' ELEMENT (N2 MOVES SLIP OF', + ' OF SLIP LATERAL SHORTNING VERTICAL', + ' OF SHEAR SHEAR DEPTH DUCTILE FAULT '/ + ' NUMBER REL.TO N5) RATE SLIP', + ' SLIP RATE RATE RATE RATE', + ' TRACTION TRACTION IN CRUST DEPTH ACTIVE?'/) 310 FORMAT (' ',I7,I5,',',I5,1P,E9.2,0P,F10.2,F7.2, + 1P,E9.2,3E10.2,4E9.2,L3,I6) 311 FORMAT (' ',I7,I5,',',I5,1P,E9.2,0P,F10.2,F7.2, + 1P,E9.2,3E10.2,3E9.2,' --------',L3,I6) 312 FORMAT (' ',I7,I5,',',I5,1P,E9.2,0P,F10.2,F7.2, + 1P,E9.2,3E10.2,2E9.2,' --------',E9.2,L3,I6) M=4 DO 400 I=1,NFL DIP=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*HORS)**2+(1.D0*VUPDIP)**2) IF (SNET.GT.0.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 IF ((TLNODE(JM).GT.0.).AND. + (ZTRANF(2,I).GT.(0.1*ONEKM))) THEN FPMAX=MAX(FPEAKS(1,I),FPEAKS(2,I)) ZTRANM=ZMNODE(JM)+ZTRANF(2,I) IF ((ZTRANF(1,I)/ZMNODE(JM)).GT.0.97) THEN WRITE (IUNITT,312) I,JM,JB,HORS,AZIMHS,PLUNGE, + SNET,RLT,CLOSE,RELV,SHEAR,FPMAX, + ZTRANM,FSLIPS(I),I ELSE WRITE (IUNITT,310) I,JM,JB,HORS,AZIMHS,PLUNGE, + SNET,RLT,CLOSE,RELV,SHEAR,FPMAX, + ZTRANF(1,I),ZTRANM,FSLIPS(I),I ENDIF ELSE WRITE (IUNITT,311) I,JM,JB,HORS,AZIMHS,PLUNGE,SNET, + RLT,CLOSE,RELV,SHEAR,FPEAKS(1,I), + ZTRANF(1,I), FSLIPS(I),I ENDIF 400 CONTINUE 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 AGREED,ALLOK,BRIEF,FOUND,MATCH,SWITCH,VERT1,VERT2,VERT3 C C NOTE: THE FOLLOWING TYPE COULD BE "LOGICAL*1" IN IBM VS-FORTRAN: LOGICAL CHECKN,EDGEFS,EDGETS C C NOTE: THE FOLLOWING COULD BE MADE "INTEGER*2" IN VS-FORTRAN: INTEGER NODTYP C CHARACTER*21 OBLIQU,TAG1,TAG2,TAG3,VERTIC DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS DIMENSION FPHI(6,7),FPOINT(7),FGAUSS(7) DIMENSION AREA(MXEL),CHECKN(MXNODE), + DETJ(7,MXEL),DXS(6,7,MXEL),DYS(6,7,MXEL), + EDGEFS(2,MXFEL),EDGETS(3,MXEL),FDIP(3,MXFEL), + FAZ(2,MXFEL),FLEN(MXFEL),FTAN(7,MXFEL), + LIST(MXSTAR),NODCON(MXBN), + NODEF(6,MXFEL),NODES(6,MXEL),NODTYP(MXNODE), + XNODE(MXNODE),YNODE(MXNODE) DATA OBLIQU /'(DIP SLIP IS ALLOWED)'/ DATA VERTIC /'(STRIKE-SLIP ONLY) '/ C C (1) CHECK THAT ALL REAL NODES ARE CONNECTED TO AT LEAST ONE C CONTINUUM (TRIANGULAR) ELEMENT OR FAULT ELEMENT; C DO 110 I=1,NREALN CHECKN(I)=.FALSE. 110 CONTINUE DO 130 I=1,NUMEL DO 120 J=1,6 CHECKN(NODES(J,I))=.TRUE. 120 CONTINUE 130 CONTINUE DO 132 I=1,NFL DO 131 J=1,6 CHECKN(NODEF(J,I))=.TRUE. 131 CONTINUE 132 CONTINUE ALLOK=.TRUE. DO 140 I=1,NREALN ALLOK=ALLOK.AND.CHECKN(I) 140 CONTINUE IF (.NOT.ALLOK) THEN WRITE(IUNIT8,150) 150 FORMAT(' BAD GRID TOPOLOGY: FOLLOWING REAL NODES DO NOT'/ 1 ' BELONG TO ANY CONTINUUM ELEMENT OR FAULT:') DO 160 I=1,NREALN IF (.NOT.CHECKN(I)) WRITE (IUNIT8,155) I 155 FORMAT (' ',43X,I6) 160 CONTINUE STOP ENDIF C C (2) CHECK THAT EVERY NODE IS EITHER A CORNER OR A MIDPOINT NODE, C BUT NOT BOTH. C DO 210 I=1,NUMNOD NODTYP(I)=0 210 CONTINUE NTOFIX=0 ALLOK=.TRUE. DO 250 I=1,NUMEL DO 240 J=1,6 IF (J.LE.3) THEN ITYPE=1 ELSE ITYPE=2 ENDIF N=NODES(J,I) IF (NODTYP(N).EQ.0) THEN NODTYP(N)=ITYPE IF (ITYPE.EQ.2) THEN IF ((XNODE(N).EQ.0.).AND.(YNODE(N).EQ.0.)) + NTOFIX=NTOFIX+1 ENDIF ELSE IF (NODTYP(N).NE.ITYPE) THEN ALLOK=.FALSE. WRITE (IUNIT8,220) N 220 FORMAT(' BAD GRID TOPOLOGY: NODE ',I6, + ' CANNOT BE AN ELEMENT CORNER AND AN', + ' ELEMENT SIDE-MIDPOINT AT THE SAME', + ' TIME.') ENDIF ENDIF 240 CONTINUE 250 CONTINUE DO 290 I=1,NFL DO 280 J=1,6 IF ((J.EQ.2).OR.(J.EQ.5)) THEN ITYPE=2 ELSE ITYPE=1 ENDIF N=NODEF(J,I) IF (NODTYP(N).EQ.0) THEN NODTYP(N)=ITYPE ELSE IF (NODTYP(N).NE.ITYPE) THEN ALLOK=.FALSE. WRITE (IUNIT8,220) N ENDIF ENDIF 280 CONTINUE 290 CONTINUE IF (.NOT.ALLOK) STOP C C (3) CHECK THAT EACH FAULT SIDE WITH REAL NODES ALONG IT SHARES C THOSE SAME 3 NODES WITH A TRIANGULAR CONTINUUM ELEMENT. C ALLOK=.TRUE. DO 390 I=1,NFL DO 380 J=2,5,3 N=NODEF(J,I) IF (N.LE.NREALN) THEN DO 320 K=1,NUMEL DO 310 L=4,6 IF (NODES(L,K).EQ.N) THEN LP=L-2 IF (LP.EQ.4) LP=1 LM=L-3 MATCH=((NODEF(J-1,I).EQ.NODES(LP,K)) + .OR.(NODEF(J-1,I).GT.NREALN)) + .AND.((NODEF(J+1,I).EQ.NODES(LM,K)) + .OR.(NODEF(J+1,I).GT.NREALN)) IF (.NOT.MATCH) THEN ALLOK=.FALSE. WRITE(IUNIT8,305) I,K 305 FORMAT(' BAD GRID TOPOLOGY:', + ' FAULT ',I6,' IS NOT PROPERL' + ,'Y CONNECTED TO ELEMENT ',I6) ELSE GO TO 380 ENDIF ENDIF 310 CONTINUE 320 CONTINUE ENDIF 380 CONTINUE 390 CONTINUE IF (.NOT.ALLOK) STOP C C (4) AVERAGE TOGETHER THE COORDINATES OF ALL NODES AT ONE "POINT" C DO 410 I=1,NUMNOD CHECKN(I)=.FALSE. C (MEANS "NOT YET INVOLVED IN AVERAGING') 410 CONTINUE DO 490 I=1,NFL DO 480 J1=1,3,2 NJ1=NODEF(J1,I) C (FAULT ENDS ARE THE ONLY PLACES THAT CAN HAVE PROBLEMS) IF (.NOT.CHECKN(NJ1)) THEN LIST(1)=NJ1 CHECKN(NJ1)=.TRUE. C BEGIN LIST OF NEIGHBORS WITH PAIRED NODE J2=7-J1 NJ2=NODEF(J2,I) LIST(2)=NJ2 CHECKN(NJ2)=.TRUE. NINSUM=2 C FIND SHORTEST FAULT CONNECTED TO EITHER ONE SHORT=SQRT( + (XNODE(NODEF(1,I))-XNODE(NODEF(3,I)))**2+ + (YNODE(NODEF(1,I))-YNODE(NODEF(3,I)))**2) DO 470 K=1,NFL NL1=NODEF(1,K) NL3=NODEF(3,K) NL4=NODEF(4,K) NL6=NODEF(6,K) IF ((NJ1.EQ.NL1).OR.(NJ2.EQ.NL1).OR. + (NJ1.EQ.NL3).OR.(NJ2.EQ.NL3).OR. + (NJ1.EQ.NL4).OR.(NJ2.EQ.NL4).OR. + (NJ1.EQ.NL6).OR.(NJ2.EQ.NL6)) THEN TEST=SQRT( + (XNODE(NL1)-XNODE(NL3))**2+ + (YNODE(NL1)-YNODE(NL3))**2) SHORT=MIN(SHORT,TEST) ENDIF 470 CONTINUE C COLLECT ALL CORNER NODES WITHIN 10% OF THIS TOLER=SHORT/10. T2=TOLER**2 DO 471 K=1,NUMNOD IF (.NOT.CHECKN(K)) THEN IF (NODTYP(K).EQ.1) THEN R2=(XNODE(NJ1)-XNODE(K))**2+ + (YNODE(NJ1)-YNODE(K))**2 IF (R2.LT.T2) THEN NINSUM=NINSUM+1 LIST(NINSUM)=K CHECKN(K)=.TRUE. ENDIF ENDIF ENDIF 471 CONTINUE C (QUICK EXIT IF ALL NODES IN SAME PLACE) AGREED=.TRUE. DO 472 K=2,NINSUM AGREED=AGREED.AND. + (XNODE(K).EQ.XNODE(1)).AND. + (YNODE(K).EQ.YNODE(1)) 472 CONTINUE IF (AGREED) GO TO 480 XSUM=0. YSUM=0. DO 473 K=1,NINSUM XSUM=XSUM+XNODE(LIST(K)) YSUM=YSUM+YNODE(LIST(K)) 473 CONTINUE XMEAN=XSUM/NINSUM YMEAN=YSUM/NINSUM RMAX=0. DO 474 K=1,NINSUM R=SQRT((XNODE(LIST(K))-XMEAN)**2+ + (YNODE(LIST(K))-YMEAN)**2) RMAX=MAX(RMAX,R) 474 CONTINUE DO 475 K=1,NINSUM XNODE(LIST(K))=XMEAN YNODE(LIST(K))=YMEAN 475 CONTINUE IF (.NOT.BRIEF) THEN IF (RMAX.GT.0.) THEN WRITE(IUNIT8,476) NINSUM, + (LIST(N),N=1,NINSUM) 476 FORMAT(/ + ' AVERAGING TOGETHER THE POSITIONS OF', + ' THESE ',I6,' NODES:',(/' ',12I6)) WRITE (IUNIT8,477) RMAX 477 FORMAT (' MAXIMUM CORRECTION TO ', + 'ANY POSITION IS',1P,E10.2/ + ' YOU ARE RESPONSIBLE FOR ', + ' DECIDING WHETHER THIS IS A', + ' SERIOUS ERR0R!') ENDIF ENDIF ENDIF 480 CONTINUE 490 CONTINUE C C (5) SURVEY STRIKE-SLIP (VERTICAL) FAULTS TO CHECK FOR CONFLICTS IN C ARGUMENT THAT WOULD LOCK THE FAULT. C C LOOP ON ALL FAULT ELEMENTS (I): DO 2000 I=1,NFL C LOOP ON 2 TERMINAL NODE PAIRS, 1-6, 4-3 (J = 1 OR 4): DO 1900 J=1,4,3 C DIP MUST BE WITHIN "WEDGE" OF VERTICAL FOR CONSTRAINT: NDIP=1+J/2 IF (ABS(FDIP(NDIP,I)-1.570796).LE.WEDGE) THEN NAZI=1+J/4 N1=J N6=7-J NODE1=NODEF(N1,I) NODE6=NODEF(N6,I) C NO CONSTRAINT APPLIED WHERE A FAULT ENDS: IF (NODE1.NE.NODE6) THEN C ENDPOINT PAIRS MUST BE CHECKED FOR DUPLICATION: C LOOK FOR OTHER STRIKE-SLIP FAULTS SHARING THIS C PAIR OF NODES, AT EITHER END: FOUND=.FALSE. DO 1600 L=1,NFL IF (L.NE.I) THEN IF (ABS(FDIP(1,L)-1.5708).LE.WEDGE) THEN IF (((NODE1.EQ.NODEF(1,L)).AND. + (NODE6.EQ.NODEF(6,L))).OR. + ((NODE1.EQ.NODEF(6,L)).AND. + (NODE6.EQ.NODEF(1,L)))) THEN FOUND=.TRUE. NUMBER=L NAZL=1 GO TO 1601 ENDIF ENDIF IF (ABS(FDIP(3,L)-1.5708).LE.WEDGE) THEN IF (((NODE1.EQ.NODEF(3,L)).AND. + (NODE6.EQ.NODEF(4,L))).OR. + ((NODE1.EQ.NODEF(4,L)).AND. + (NODE6.EQ.NODEF(3,L)))) THEN FOUND=.TRUE. NUMBER=L NAZL=2 GO TO 1601 ENDIF ENDIF ENDIF 1600 CONTINUE C DON'T WORRY IF THIS PAIR ALREADY CHECKED! 1601 IF (FOUND.AND.(NUMBER.GT.I)) THEN C AVERAGE ARGUMENTS TOGETHER (AVOID CYCLE SHIFTS): AZI=MOD(FAZ(NAZI,I)+1.570796,3.14159265) + -1.570796 AZL=MOD(FAZ(NAZL,NUMBER)+1.570796,3.14159265) + -1.570796 AZIMUT=0.5*(AZI+AZL) FAZ(NAZI,I)=AZIMUT FAZ(NAZL,NUMBER)=AZIMUT IF (ABS(AZI-AZL).GT.0.02) THEN DAZI=AZI*57.2957795 DAZL=AZL*57.2957795 DAZ=AZIMUT*57.2957795 IF (NODE1.LE.NREALN) THEN NP1=NODE1 ELSE NP1=N1000+NODE1-NREALN ENDIF IF (NODE6.LE.NREALN) THEN NP6=NODE6 ELSE NP6=N1000+NODE6-NREALN ENDIF WRITE (IUNIT8,1610) I,NUMBER,NP1,NP6, + DAZI,DAZL,DAZ 1610 FORMAT(/' WARNING: STRIKE-SLIP FAULT ELEMENTS' + ,I7,' AND',I7/' SHARE NODES',I7,' AND', + I7/' BUT THEIR ARGUMENTS OF ',F6.1, + ' AND ',F6.1,' DEGREES DIFFER SUBSTAN', + 'TIALLY.'/' THE ARGUMENTS WILL BE AVERAGED,' + ,' AND A VALUE OF ',F6.1,' WILL BE USED.' + /' THIS IS NECESSARY TO PREVENT FAULT', + ' LOCKING;'/' IF YOU -WANT- THE FAULT LOCKED' + ,', THEN USE A SINGLE NODE AT THIS POINT.') ENDIF ENDIF C ^END BLOCK WHICH LOOKS FOR CONSTRAINTS ON REAL NODES ENDIF C ^END BLOCK WHICH CHECKS FOR DISTINCT NODE NUMBERS ENDIF C ^END BLOCK WHICH CHECKS FOR DIP OF OVER 75 DEGREES 1900 CONTINUE C ^END LOOP ON 2 NODE PAIRS IN FAULT ELEMENT 2000 CONTINUE C ^END LOOP ON FAULT ELEMENTS C C (6) COMPUTE COORDINATES OF MIDPOINT NODES THAT WERE NOT INPUT. C C FIRST, FAULTS: IF ((.NOT.BRIEF).AND.(NFL.GT.0)) WRITE (IUNIT8,540) 540 FORMAT(/ /' FOLLOWING FAULT MID-POINT POSITIONS WERE COMPUTED:'/ + /' FAULT NODE2 NODE5 X Y'/) DO 550 I=1,NFL I1=NODEF(1,I) I2=NODEF(2,I) I3=NODEF(3,I) I5=NODEF(5,I) DX= XNODE(I3)- XNODE(I1) DY= YNODE(I3)- YNODE(I1) AZ=ATAN2(DY,DX) PHI1=FAZ(1,I)-AZ PHI1=MOD(PHI1+1.570796,3.14159265)-1.570796 PHI2=AZ-FAZ(2,I) PHI2=MOD(PHI2+1.570796,3.14159265)-1.570796 IF ((ABS(PHI1).GT.0.001).OR.(ABS(PHI2).GT.0.001)) THEN T1=TAN(PHI1) T2=TAN(PHI2) IF (ABS(T2-T1).GE.ABS(T1+T2)) THEN FACTOR=0.99*ABS(T1+T2)/ABS(T2-T1) IF (ABS(T1).GT.ABS(T2)) THEN T2=T1+FACTOR*(T2-T1) ELSE T1=T2+FACTOR*(T1-T2) ENDIF ENDIF PARRAL=(T2-T1)/(4.*(T1+T2)) PERPEN= T1*T2 /(2.*(T1+T2)) XNODE(I2)=XNODE(I1)+DX/2.+PARRAL*DX-PERPEN*DY YNODE(I2)=YNODE(I1)+DY/2.+PERPEN*DX+PARRAL*DY ELSE XNODE(I2)=(XNODE(I1)+XNODE(I3))/2. YNODE(I2)=(YNODE(I1)+YNODE(I3))/2. ENDIF XNODE(I5)= XNODE(I2) YNODE(I5)= YNODE(I2) NTOFIX=NTOFIX-1 IF (.NOT.BRIEF) WRITE (IUNIT8,549) I,I2,I5,XNODE(I2), 1 YNODE(I2) 549 FORMAT(' ',I6,2I10,1P,2E12.4) 550 CONTINUE C C NEXT, OTHER ELEMENT SIDES, IF NEEDED: IF ((.NOT.BRIEF).AND.(NTOFIX.GT.0)) WRITE (IUNIT8,551) 551 FORMAT(/ /' FOLLOWING MID-POINTS OF CONTINUUM ELEMENT SIDES', + ' THAT WERE 0.0 IN THE' + / ' INPUT DATASET ARE NOW COMPUTED, AS FOLLOWS:' + / / ' ELEMENT NODE X Y'/) DO 590 I=1,NUMEL DO 580 J=4,6 N=NODES(J,I) IF ((XNODE(N).EQ.0.).AND.(YNODE(N).EQ.0.)) THEN JP=J-2 IF (J.EQ.6) JP=1 JM=J-3 XNODE(N)=0.5* + (XNODE(NODES(JP,I))+XNODE(NODES(JM,I))) YNODE(N)=0.5* + (YNODE(NODES(JP,I))+YNODE(NODES(JM,I))) IF (.NOT.BRIEF) + WRITE (IUNIT8,579) I,N,XNODE(N),YNODE(N) 579 FORMAT(' ',I6,I10,1P,2E12.4) ENDIF 580 CONTINUE 590 CONTINUE C C (7) COMPUTE AREAS OF ELEMENTS AND COMPUTE DERIVITIVES OF NODAL C FUNCTIONS AT INTEGRATION POINTS; C THEN CHECK FOR NEGATIVE AREAS C CALL AREAS (INPUT,NODES,NUMEL,NUMNOD,XNODE,YNODE, + OUTPUT,AREA) CALL DERIV (INPUT,AREA,NODES,NUMEL,NUMNOD,XNODE,YNODE, + OUTPUT,DETJ,DXS,DYS) ALLOK=.TRUE. DO 620 M=1,7 DO 610 I=1,NUMEL TEST=AREA(I)*DETJ(M,I) IF (TEST.LE.0.) THEN WRITE(IUNIT8,605) M,I 605 FORMAT(/' EXCESSIVELY DISTORTED ELEMENT LEADS TO ' + ,'NEGATIVE AREA AT POINT ',I1,' IN ELEMENT ', + I5) ALLOK=.FALSE. ENDIF 610 CONTINUE 620 CONTINUE IF (.NOT.ALLOK) STOP C C (8) COMPUTE LENGTHS OF FAULT ELEMENTS. C DO 750 I=1,NFL FLEN(I)=0. X1=XNODE(NODEF(1,I)) X2=XNODE(NODEF(2,I)) X3=XNODE(NODEF(3,I)) Y1=YNODE(NODEF(1,I)) Y2=YNODE(NODEF(2,I)) Y3=YNODE(NODEF(3,I)) OLDX=X1 OLDY=Y1 DO 740 J=1,20 S=J/20. F1=1.-3.*S+2.*S**2 F2=4.*S*(1.-S) F3= -S+2.*S**2 X=X1*F1+X2*F2+X3*F3 Y=Y1*F1+Y2*F2+Y3*F3 FLEN(I)=FLEN(I)+SQRT((X-OLDX)**2+(Y-OLDY)**2) OLDX=X OLDY=Y 740 CONTINUE 750 CONTINUE C C (9) MAKE A LIST OF NODES THAT ARE ON THE BOUNDARY AND REQUIRE C BOUNDARY CONDITIONS (NODCON); THESE ARE IN COUNTERCLOCKWISE C ORDER. ALSO MAKE A LISTS OF ELEMENT SIDES WHICH CONTAIN THESE C NODES: EDGETS AND EDGEFS. C WRITE (IUNIT8,800) 800 FORMAT (/' ----------------------------------------' + / /' COMPILING AN ORDERED LIST OF BOUNDARY NODES...'/) 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 (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) NDONE, NODE, X, Y 866 FORMAT(/' AFTER CONNECTING ',I6,' NODES AROUND THE', + ' PERIMETER, '/ + ' PROCESS WAS STOPPED BY BAD GRID TOPOLOGY;'/ + ' COULD NOT FIND ANY WAY TO CONTINUE FROM NODE ',I6/ + ' AT (X=',1P,E10.3,',Y=',E10.3,')'/ + ' 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 X Y') DO 890 I=1,NCOND N=NODCON(I) IF (N.GT.NREALN) N=N1000+N-NREALN WRITE(IUNIT8,882) I, N, XNODE(I), YNODE(I) 882 FORMAT(' ',2I6,1P,2E11.3) 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 (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, + GEOTH5,GEOTH6,GEOTH7,GEOTH8, + GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, + TEMLIM,ZM,ZSTOP, + OUTPUT,TAUZZ,SIGZZB) C C CALCULATES "TAUZZ", THE VERTICAL INTEGRAL THROUGH THE PLATE C OF THE VERTICAL 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 SEA SURFACE, DOWN TO A DEPTH OF "ZSTOP" BELOW THE TOP OF C THE CRUST. C IF "ZSTOP" EXCEEDS MOHO DEPTH "ZM", THEN PROPERTIES OF THE MANTLE C WILL BE USED IN THE LOWER PART OF THE INTEGRAL. C ALSO RETURNS "SIGZZB", THE VERTICAL STRESS ANOMALY C AT DEPTH "ZSTOP" BELOW THE SOLID ROCK SURFACE. C NOTE: THIS VERSION IS DIFFERENT FROM THE VERSION FOUND IN THE LARAMY C PROGRAM PACKAGE. FIRST, IT ACTS ON ONLY A SINGLE POINT. C SECOND, IT INFERS SUB-PLATE NORMAL-STRESS ANOMALIES FROM C THE GIVEN TOPOGRAPHY, INSTEAD OF FROM MODEL STRUCTURE. C PARAMETER (NDREF=300) LOGICAL CALLED C INTERNAL ARRAYS: DIMENSION DREF(NDREF),PREF(0:NDREF) C ARGUMENT ARRAYS: DIMENSION ALPHAT(2),RHOBAR(2),TEMLIM(2) SAVE CALLED,DREF,PREF DATA CALLED /.FALSE./ C C STATEMENT FUNCTIONS: TEMPC(H)=MIN(TEMLIM(1),GEOTH1+GEOTH2*H+GEOTH3*H**2 + +GEOTH4*H**3) TEMPM(H)=MIN(TEMLIM(2),GEOTH5+GEOTH6*H+GEOTH7*H**2 + +GEOTH8*H**3) C C CREATE REFERENCE TEMPERATURE & DENSITY PROFILES TO DEPTH OF NDREF KM C IF (.NOT.CALLED) THEN RHOTOP=RHOBAR(1)*(1.-ALPHAT(1)*GEOTH1) DREF(1)=RHOH2O DREF(2)=RHOH2O DREF(3)=0.7*RHOH2O+0.3*RHOTOP DREF(4)=RHOTOP DREF(5)=RHOTOP DREF(6)=RHOTOP DREF(7)=RHOTOP DREF(8)=0.7*RHOTOP+0.3*RHOAST DO 50 J=9,NDREF DREF(J)=RHOAST 50 CONTINUE PREF(0)=0. DO 100 I=1,NDREF PREF(I)=PREF(I-1)+DREF(I)*GMEAN*ONEKM 100 CONTINUE CALLED=.TRUE. ENDIF C C ROUTINE PROCESSING (ON EVERY CALL): C IF (ELEVAT.GT.0.) THEN ZTOP= -ELEVAT ZBASE=ZSTOP-ELEVAT DENSE1=RHOBAR(1)*(1.-GEOTH1*ALPHAT(1)) H=0. ELSE ZTOP=0. ZBASE=ZSTOP+(-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 IF (H.LE.ZM) THEN T=TEMPC(H) DENSE2=RHOBAR(1)*(1.-T*ALPHAT(1)) ELSE T=TEMPM(H-ZM) DENSE2=RHOBAR(2)*(1.-T*ALPHAT(2)) ENDIF 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=ZSTOP Z=ZBASE IF (ZSTOP.LE.ZM) THEN T=TEMPC(H) DENSE2=RHOBAR(1)*(1.-T*ALPHAT(1)) ELSE T=TEMPM(H-ZM) DENSE2=RHOBAR(2)*(1.-T*ALPHAT(2)) ENDIF DENSE=0.5*(DENSE1+DENSE2) IF (Z.GT.0.) THEN N1=Z/ONEKM N2=N1+1 FRAC=Z/ONEKM-N1 PR=PREF(N1)+FRAC*(PREF(N2)-PREF(N1)) ELSE PR=0. ENDIF SIGZZB=SIGZZ-DENSE*GMEAN*RESID+(PR-OLDPR) TAUZZ=TAUZZ+0.5*(SIGZZB+OLDSZZ)*RESID RETURN END C C C SUBROUTINE TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) C C COMPUTES VERTICAL INTEGRALS OF RELATIVE C OR DEVIATORIC STRESS (TAUMAT). C C THE COMPONENTS ARE: C TAUMAT(1) = VERTICAL INTEGRAL OF (SXX-SZZ) C TAUMAT(2) = VERTICAL INTEGRAL OF (SYY-SZZ) C TAUMAT(3) = VERTICAL INTEGRAL OF SXY. C DIMENSION ALPHA(3,3,7,MXEL),ERATE(3,7,MXEL), + TAUMAT(3,7,MXEL),TOFSET(3,7,MXEL) C DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) TAUMAT(1,M,I)=TOFSET(1,M,I)+EXX*ALPHA(1,1,M,I)+ + EYY*ALPHA(1,2,M,I)+EXY*ALPHA(1,3,M,I) TAUMAT(2,M,I)=TOFSET(2,M,I)+EXX*ALPHA(2,1,M,I)+ + EYY*ALPHA(2,2,M,I)+EXY*ALPHA(2,3,M,I) TAUMAT(3,M,I)=TOFSET(3,M,I)+EXX*ALPHA(3,1,M,I)+ + EYY*ALPHA(3,2,M,I)+EXY*ALPHA(3,3,M,I) 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE THONB (INPUT,ECREEP,ETAMAX,GLUE, + MXEL,MXNODE, + NODES,NUMEL,NUMNOD, + OVB,PULLED,TRHMAX,V, + OUTPUT,DVB,SIGHB, + WORK,OUTVEC) C C CALCULATES SHEAR STRESSES ON BASE OF PLATE (SIGHB), AND C THE VECTOR VELOCITY OF THE LAYER BELOW (OVB), AND C THE SCALAR VELOCITY DIFFERENCE OF THE LAYER BELOW (DVB). C C NOTE: FOLLOWING TYPE CAN BE COMPRESSED TO LOGICAL*1 IN VS-FORTRAN: LOGICAL PULLED C DOUBLE PRECISION V DIMENSION DVB(7,MXEL), + GLUE(7,MXEL), + NODES(6,MXEL),OUTVEC(2,7,MXEL), + OVB(2,7,MXEL),PULLED(7,MXEL), + SIGHB(2,7,MXEL), + V(2,MXNODE) C CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,V, + OUTPUT,OUTVEC) DO 1000 M=1,7 DO 900 I=1,NUMEL VPX=OUTVEC(1,M,I) VPY=OUTVEC(2,M,I) VAX=OVB(1,M,I) VAY=OVB(2,M,I) VRX=VAX-VPX VRY=VAY-VPY VMAG=SQRT((1.D0*VRX)**2+(1.D0*VRY)**2) DVB(M,I)=VMAG IF (PULLED(M,I).AND.(VMAG.GT.0.)) THEN DVX=VRX/VMAG DVY=VRY/VMAG SHEAR1=GLUE(M,I)*VMAG**ECREEP SHEAR2=ETAMAX*VMAG SHEAR3=TRHMAX SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3) SIGHB(1,M,I)=SHEAR*DVX SIGHB(2,M,I)=SHEAR*DVY ELSE SIGHB(1,M,I)=0. SIGHB(2,M,I)=0. ENDIF 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE VISCOS (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,DCREEP,ECREEP, + ERATE,FRIC,G,GEOTHC,GEOTHM, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,TLINT, + VISMAX,ZMOHO, + OUTPUT,ALPHA,SCOREC,SCORED,TOFSET,ZTRANC) C C Computes tactical partial-derivitive tensor ALPHA(3,3,7,NUMEL) C (partial derivitives of vertically-integrated stresses C tau.ij [where normal components are relative to vertical stress] C with respect to strain-rates e.kl) C in 3 x 3 component form, from 2 x 2 principal-axis form C provided by DIAMND, at each integration point of each element. C Also records intercept values (TOFSET(3,7,NUMEL)) for next iteration C Calculation of TAUMAT = TOFSET + ALPHA*E will give model C relative stress integrals (relative to vertical stress integral). C ZTRANC(2,7,NUMEL) is the depth into the (1:crust, 2:mantle) where C the brittle/ductile transition occurs, for each integration point C of each element. Note: "C" in the name stands for "Continuum" C (as opposed to Fault), not for "Crust". C SCOREC and SCORED are measures of mismatch between current C linearized and actual nonlinear rheologies: C SCOREC is the maximum (absolute value) 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 External variables and arrays INTEGER I, INPUT, M, MXEL, NUMEL REAL BIOT, ECREEP, FRIC, G, + OUTPUT, RHOH2O, SCOREC, SCORED, VISMAX REAL ACREEP(2), ALPHA(3,3,7,MXEL), + ALPHAT(2), BCREEP(2), + CCREEP(2), DCREEP(2), + ERATE(3,7,MXEL), + GEOTHC(4,7,MXEL), GEOTHM(4,7,MXEL), + RHOBAR(2), SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL), TEMLIM(2), + TLINT(7,MXEL), TOFSET(3,7,MXEL), + ZMOHO(7,MXEL), ZTRANC(2,7,MXEL) C External function: REAL ATAN2F C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C Internal variables and arrays: REAL CENTER, DELP2, DENOM, DENOM0, DENOM1, DIVER, + DANDEX, DANDEY, DANDES, + DE1DEX, DE1DEY, DE1DES, + DE2DEX, DE2DEY, DE2DES, + DTSDE1, DTSDE2, + DTSDT1, DTSDT2, DTSDAN, + DTXDE1, DTXDE2, + DTXDT1, DTXDT2, DTXDAN, + DTYDE1, DTYDE2, + DTYDT1, DTYDT2, DTYDAN, + DT1DE1, DT1DE2, DT2DE1, DT2DE2, + DXX, DXY, DYY, + EXX, EXY, EYY, E1, E2, PL0, PW0, + PT1DE1, PT1DE2, PT2DE1, PT2DE2, + PT1, PT2, PTXX, PTXY, PTYY, + R, RHOUSE, + SHEAR, SHEAR2, SIGHBI, + THETA, THICKC, THICKM, TMEAN, TXX, TXY, TYY, + ZOFTOP, ZTRAN(2) C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C C Initialize sums to be used in computation of scores: SCOREC=0. SCORED=0. DENOM0=0. DENOM1=0. C DO 1000 M=1,7 DO 900 I=1,NUMEL C C ----------- rheology (& ZTRANC) section ------------ C C Extract data for this integration point, as scalars: SIGHBI=SQRT((1.D0*SIGHB(1,M,I))**2+ + (1.D0*SIGHB(2,M,I))**2) THICKC=ZMOHO(M,I) THICKM=TLINT(M,I) EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) C C Guard against special case of zero strain-rate: IF ((EXX.EQ.0.).AND.(EXY.EQ.0.).AND.(EYY.EQ.0.)) THEN TXX=0. TXY=0. TYY=0. C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) ALPHA(1,1,M,I)=4.*VISMAX*(THICKC+THICKM) ALPHA(1,2,M,I)=2.*VISMAX*(THICKC+THICKM) ALPHA(1,3,M,I)=0. ALPHA(2,1,M,I)=2.*VISMAX*(THICKC+THICKM) ALPHA(2,2,M,I)=4.*VISMAX*(THICKC+THICKM) ALPHA(2,3,M,I)=0. ALPHA(3,1,M,I)=0. ALPHA(3,2,M,I)=0. ALPHA(3,3,M,I)=2.*VISMAX*(THICKC+THICKM) TOFSET(1,M,I)=0. TOFSET(2,M,I)=0. TOFSET(3,M,I)=0. ZTRANC(1,M,I)=0. C Note: "C" is for Continuum, not for Crust! C 1st subscript is: (1:crust; 2:mantle). ZTRANC(2,M,I)=0. ELSE C (strain-rate tensor is not zero) C Find principal strain-rates (E1 <= E2) C in the horizontal plane: DIVER=EXX+EYY R=SQRT((1.D0*EXY)**2+(0.5D0*(EXX-EYY))**2) E1=0.5*DIVER-R E2=0.5*DIVER+R THETA=ATAN2F(2.*EXY,EXX-EYY) C see (29) of Bird (1989); C THETA is like angular coordinate of Mohr's circles C of strain-rate and also of stress; C THETA = 0 when EXX > EYY and EXY =0; C THETA = small, + when EXY > 0, EXX > EYY; C THETA = Pi when EXY = 0, EYY > EXX. C C Prepare to sum tau (and derivitives) over layers: TXX=0. TXY=0. TYY=0. DT1DE1=0. DT1DE2=0. DT2DE1=0. DT2DE2=0. C IF (THICKC.GT.0) THEN ZOFTOP=0. PL0=0. PW0=0. CALL DIAMND (INPUT,ACREEP(1),ALPHAT(1), + BCREEP(1),BIOT, + CCREEP(1),DCREEP(1), + ECREEP, + E1,E2,FRIC,G, + GEOTHC(1,M,I), + GEOTHC(2,M,I), + GEOTHC(3,M,I), + GEOTHC(4,M,I), + PL0,PW0, + RHOBAR(1),RHOH2O,SIGHBI, + THICKC,TEMLIM(1), + VISMAX,ZOFTOP, + OUTPUT,PT1DE1,PT1DE2, + PT2DE1,PT2DE2, + PT1,PT2,ZTRAN(1)) CENTER=0.5*(PT1+PT2) SHEAR=0.5*(PT2-PT1) PTXX=CENTER+SHEAR*COS(THETA) PTYY=CENTER-SHEAR*COS(THETA) PTXY=SHEAR*SIN(THETA) C Add contribution of crust to total: TXX=TXX+PTXX TXY=TXY+PTXY TYY=TYY+PTYY DT1DE1=DT1DE1+PT1DE1 DT1DE2=DT1DE2+PT1DE2 DT2DE1=DT2DE1+PT2DE1 DT2DE2=DT2DE2+PT2DE2 ZTRANC(1,M,I)=ZTRAN(1) ELSE ZTRANC(1,M,I)=0. END IF C IF (THICKM.GT.0) THEN ZOFTOP=THICKC PW0=RHOH2O*G*THICKC TMEAN=GEOTHC(1,M,I)+ + 0.5*GEOTHC(2,M,I)*THICKC+ + 0.333*GEOTHC(3,M,I)*THICKC**2+ + 0.25*GEOTHC(4,M,I)*THICKC**3 RHOUSE=RHOBAR(1)*(1.-ALPHAT(1)*TMEAN) PL0=RHOUSE*G*THICKC CALL DIAMND (INPUT,ACREEP(2),ALPHAT(2), + BCREEP(2),BIOT, + CCREEP(2),DCREEP(2), + ECREEP, + E1,E2,FRIC,G, + GEOTHM(1,M,I), + GEOTHM(2,M,I), + GEOTHM(3,M,I), + GEOTHM(4,M,I), + PL0,PW0, + RHOBAR(2),RHOH2O,SIGHBI, + THICKM,TEMLIM(2), + VISMAX,ZOFTOP, + OUTPUT,PT1DE1,PT1DE2, + PT2DE1,PT2DE2, + PT1,PT2,ZTRAN(2)) CENTER=0.5*(PT1+PT2) SHEAR=0.5*(PT2-PT1) PTXX=CENTER+SHEAR*COS(THETA) PTYY=CENTER-SHEAR*COS(THETA) PTXY=SHEAR*SIN(THETA) TXX=TXX+PTXX TXY=TXY+PTXY TYY=TYY+PTYY DT1DE1=DT1DE1+PT1DE1 DT1DE2=DT1DE2+PT1DE2 DT2DE1=DT2DE1+PT2DE1 DT2DE2=DT2DE2+PT2DE2 ZTRANC(2,M,I)=ZTRAN(2) ELSE ZTRANC(2,M,I)=0. END IF C C ---------- ALPHA and TOFSET section ------------- C (cases of non-zero strain-rate) C IF (R.LE.0.) THEN C Pathological case: EXY = 0, EXX = EYY /= 0. C See notes from derivations of 18 April 1998; C based on (28) of Bird(1989), but not using C (29) because r = 0 and alpha is undefined. C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) ALPHA(1,1,M,I)=DT2DE2 ALPHA(1,2,M,I)=DT1DE2 ALPHA(1,3,M,I)=0. ALPHA(2,1,M,I)=DT1DE2 ALPHA(2,2,M,I)=DT2DE2 ALPHA(2,3,M,I)=0. ALPHA(3,1,M,I)=0. ALPHA(3,2,M,I)=0. ALPHA(3,3,M,I)=0.5*(DT1DE1-DT2DE1- + DT1DE2+DT2DE2) ELSE C typical case, r > 0: see p. 3976 in Bird (1989). DE1DEX=0.5-((EXX-EYY)/(4.*R)) DE1DEY=0.5+((EXX-EYY)/(4.*R)) DE1DES= -EXY/R DE2DEX=DE1DEY DE2DEY=DE1DEX DE2DES= -DE1DES DANDEX= -SIN(THETA)/(2.*R) C Note: Formula above is equivalent to (29) of C Bird (1989), but less likely to be singular. DANDEY= -DANDEX DANDES=COS(THETA)/R C Note: Formula above is equivalent to (29) of C Bird (1989), but less likely to be singular. DTXDT1=0.5*(1.-COS(THETA)) DTXDT2=0.5*(1.+COS(THETA)) DTXDAN= -TXY DTYDT1=DTXDT2 DTYDT2=DTXDT1 DTYDAN=TXY DTSDT1= -0.5*SIN(THETA) DTSDT2= -DTSDT1 SHEAR=SQRT(TXY**2+(0.5*(TXX-TYY))**2) DTSDAN=SHEAR*COS(THETA) C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) DTXDE1=DTXDT1*DT1DE1+DTXDT2*DT2DE1 DTXDE2=DTXDT1*DT1DE2+DTXDT2*DT2DE2 ALPHA(1,1,M,I)= + DTXDE1*DE1DEX+DTXDE2*DE2DEX+DTXDAN*DANDEX ALPHA(1,2,M,I)= + DTXDE1*DE1DEY+DTXDE2*DE2DEY+DTXDAN*DANDEY ALPHA(1,3,M,I)= + DTXDE1*DE1DES+DTXDE2*DE2DES+DTXDAN*DANDES DTYDE1=DTYDT1*DT1DE1+DTYDT2*DT2DE1 DTYDE2=DTYDT1*DT1DE2+DTYDT2*DT2DE2 ALPHA(2,1,M,I)= + DTYDE1*DE1DEX+DTYDE2*DE2DEX+DTYDAN*DANDEX ALPHA(2,2,M,I)= + DTYDE1*DE1DEY+DTYDE2*DE2DEY+DTYDAN*DANDEY ALPHA(2,3,M,I)= + DTYDE1*DE1DES+DTYDE2*DE2DES+DTYDAN*DANDES DTSDE1=DTSDT1*DT1DE1+DTSDT2*DT2DE1 DTSDE2=DTSDT1*DT1DE2+DTSDT2*DT2DE2 ALPHA(3,1,M,I)= + DTSDE1*DE1DEX+DTSDE2*DE2DEX+DTSDAN*DANDEX ALPHA(3,2,M,I)= + DTSDE1*DE1DEY+DTSDE2*DE2DEY+DTSDAN*DANDEY ALPHA(3,3,M,I)= + DTSDE1*DE1DES+DTSDE2*DE2DES+DTSDAN*DANDES END IF C ----------- TOFSET section ------------------ C (case of non-zero strain rate) TOFSET(1,M,I)=TXX-ALPHA(1,1,M,I)*EXX + -ALPHA(1,2,M,I)*EYY + -ALPHA(1,3,M,I)*EXY TOFSET(2,M,I)=TYY-ALPHA(2,1,M,I)*EXX + -ALPHA(2,2,M,I)*EYY + -ALPHA(2,3,M,I)*EXY TOFSET(3,M,I)=TXY-ALPHA(3,1,M,I)*EXX + -ALPHA(3,2,M,I)*EYY + -ALPHA(3,3,M,I)*EXY END IF CC C ---------- SCORE section ----------------- C C Build tentative denominator for score, based C on old values of TAUMAT (tau relative to vertical). DELP2=(0.5*(TAUMAT(1,M,I)+TAUMAT(2,M,I)))**2 SHEAR2=TAUMAT(3,M,I)**2+ + (0.5*(TAUMAT(1,M,I)-TAUMAT(2,M,I)))**2 DENOM0=DENOM0+SQRT(MAX(DELP2,SHEAR2)) C C Build alternative denominator for score, based C on new values of TXX,TXY,TYY (tau relative to vertical). DELP2=(0.5*(TXX+TYY))**2 SHEAR2=TXY**2+(0.5*(TXX-TYY))**2 DENOM1=DENOM1+SQRT(MAX(DELP2,SHEAR2)) C C Evaluate difference between old and new tau: DXX=TAUMAT(1,M,I)-TXX DYY=TAUMAT(2,M,I)-TYY DXY=TAUMAT(3,M,I)-TXY DELP2=(0.5*(DXX+DYY))**2 SHEAR2=(0.5*(DXX-DYY))**2+DXY**2 SCOREC=MAX(SCOREC,SQRT(DELP2),SQRT(SHEAR2)) SCORED=SCORED+SQRT(MAX(DELP2,SHEAR2)) C 900 CONTINUE 1000 CONTINUE C C In computing SCORED, use larger of (old, new) denominators: DENOM=MAX(DENOM0,DENOM1) IF (DENOM.GT.0.) THEN SCORED=SCORED/DENOM ELSE SCORED=0.0 END IF C C NOTE: SCOREC is already computed in loop above. C RETURN END C C C 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,TLINT,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),TLINT(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)+TLINT(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,NXYSTB,NXYSTF,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, + IPEN1,IPEN2,IPEN3,COLOR) C C PLOTS CONTOUR DIAGRAMS AND (OPTIONALLY) A BASEMAP. C LABELS WITH VARIABLE AND TIME ABOVE, MODEL TITLE BELOW. C PLACES COLORBAR WITH CONTOUR VALUES AND UNITS ON RIGHT. C SYMBOLS FOR VECTORS OR TENSORS MAY BE OVERLAIN IN BLACK; C IF SO, THEY WILL HAVE A GRAPHICAL SCALE AT UPPER RIGHT. C PARAMETER (NCOLOR=12) CHARACTER*80 TITLE,TITLE2 CHARACTER*42 TEXT,VUNITS CHARACTER*9 ASCII9,CHAR9,SCALEV CHARACTER*8 SCALEA INTEGER DOWN,UP LOGICAL ALLPOS,COLOR,DASH,DOAROW,DOAXES,DOESYM,DOFLTS,STATES LOGICAL DRAWST,FSLIPS EXTERNAL ASCII9 DIMENSION DRAWST(NXYSTB),ERATE(3,7,NUMEL),FBLAND(NTYPE), + FDIP(3,NFL),FLEN(NFL),FSLIPS(NFL),FTAN(7,NFL), + FUNC(NUMNOD),ICOLOR(NCOLOR),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(NXYSTB),YST(NXYSTB) 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,IPEN1) 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 KEEP WINDOW TIGHT IN CASE CLIPPING IS NEEDED 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(IPEN1,1) ELSE CALL SETPAT(0) ENDIF CALL NEWPEN(IPEN1) SIZEAR=RMSVEC/VFACT CALL ARROW (INPUT,CINT,NUMEL,OUTVEC, + SIZEAR,XIP,YIP, + OUTPUT,BIG,FACTR) C PLOT A SAMPLE VECTOR AGAINST UPPER RIGHT CORNER C OPEN WINDOW TO EXTREME PLOTTER CAN REACH: CALL FACTOR (1.) CALL WINDOW(0.,XINCH+2.,0.0,10.5) CALL VPORT (0.,XINCH+2.,0.0,10.5) CALL PLOT(XINCH+1.95,10.45,3) WIDE=MAX(9*0.12,(0.1+BIG*FACTR*VFACT+0.1)) HIGH=0.4 CALL PLOT(XINCH+1.95-WIDE,10.45,2) CALL PLOT(XINCH+1.95-WIDE,10.45-HIGH,2) CALL PLOT(XINCH+1.95,10.45-HIGH,2) CALL PLOT(XINCH+1.95,10.45,2) X=XINCH+1.95-0.5*WIDE-0.5*BIG*FACTR*VFACT Y=10.45-0.15 CALL PLOT(X,Y,3) DX=BIG*FACTR*VFACT 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) SCALEV=ASCII9(BIG) CALL SYMBOL(XINCH+1.95-9*0.12,10.45-HIGH+0.03, + 0.12,SCALEV,IDUMMY,0.,9) ELSE IF (DOAXES) THEN C KEEP WINDOW TIGHT IN CASE CLIPPING IS NEEDED: 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(IPEN1,1) ELSE CALL SETPAT(0) ENDIF CALL NEWPEN (IPEN1) SIZEAX=RMSVEC/VFACT CALL AXES (INPUT,CINT,IPEN1,NUMEL,SIZEAX, + TAUMT,TAUZZ, + XIP,YIP, + OUTPUT,BIG,FACTR) C DRAW 2 LARGE SAMPLE TENSORS (ISOTROPIC, + AND - SAMPLES) C IN A BOX UP AGAINST UPPER RIGHT LIMITS OF PLOT AREA. C OPEN WINDOW TO EXTREME PLOTTER CAN REACH: CALL FACTOR (1.) CALL WINDOW(0.,XINCH+2.,0.0,10.5) CALL VPORT (0.,XINCH+2.,0.0,10.5) CALL PLOT(XINCH+1.95,10.45,3) WIDE=1.15*(4.*BIG*FACTR*VFACT) HIGH=1.10*(2.*BIG*FACTR*VFACT) CALL PLOT(XINCH+1.95-WIDE,10.45,2) CALL PLOT(XINCH+1.95-WIDE,10.45-HIGH-0.24,2) CALL PLOT(XINCH+1.95,10.45-HIGH-0.24,2) CALL PLOT(XINCH+1.95,10.45,2) ANGLE=0. DR=BIG*FACTR*VFACT C ISOTROPIC COMPRESSIVE TENSOR X=XINCH+1.95-WIDE+1.1*DR Y=10.45-1.1*DR TZZ= -BIG*VFACT T1= -BIG*VFACT T2= -BIG*VFACT CALL CIRCLE(X,Y,-DR,MIN0(IPEN1,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 ISOTROPIC EXTENSIONAL TENSOR X=XINCH+1.95-1.1*DR Y=10.45-1.1*DR TZZ=BIG*VFACT T1=BIG*VFACT T2=BIG*VFACT 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 WRITE LABEL WRITE (SCALEA,19) BIG 19 FORMAT (1P,E8.1) DO 20 I=1,8 IF (SCALEA(I:I).EQ.'0') THEN SCALEA(I:I)='O' ENDIF 20 CONTINUE CALL SYMBOL (XINCH+1.95-WIDE/2.-4*0.12, + 10.45-HIGH-0.18, + 0.18,SCALEA,IDUMMY,0.,8) 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(IPEN1,1) ELSE CALL SETPAT(0) ENDIF CALL NEWPEN(IPEN1) 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 KOLOR=6 SUM=0.0 DO 32 I=1,NFL SUM=SUM+FLEN(I) 32 CONTINUE AVERAG=SUM/NFL IF (NUMNOD.LE.600) THEN NTIC=3 DIPSIZ=0.15*AVERAG ELSE NTIC=1 DIPSIZ=0.40*AVERAG ENDIF DO 35 I=1,NFL DASH=.NOT.FSLIPS(I) CALL FAULT (INPUT,COLOR,DASH,FDIP,FTAN,I,IPEN2,KOLOR, + NFL,NUMNOD,NODEF,NTIC,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 KOLOR=1 C CALL USMAP (INPUT,COLOR,DRAWST,IPEN1,IPEN3,KOLOR, + NXYSTB,NXYSTF,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.18 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(IPEN1,1) ENDIF CALL NEWPEN(IPEN1) 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(IPEN1,1) CALL NEWPEN(IPEN1) 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(IPEN1,1) CALL NEWPEN(IPEN1) 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(IPEN1,1) ENDIF CALL NEWPEN(IPEN1) 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=1.5 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,NXYSTB,NXYSTF, + STATES,TEXT,TITLE, + VFACT,WEDGE,XINCH, + XNOD,XST,YNOD,YST, + IPEN1,IPEN2,IPEN3,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(NXYSTB),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(NXYSTB),YST(NXYSTB) 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; 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 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 (IPEN1,GREEN) CALL NEWPEN (IPEN1) ELSE IPEN0=MIN(IPEN1,3) CALL DEFPEN (63,IPEN0,2*IPEN1,4*IPEN1, + 2*IPEN1,4*IPEN1) C SAMPLE:** ** ** ** ** ** ** C :** ** ** ** ** ** ** 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 NODES, IF NUMBER IS NOT EXCESSIVE (IN BLUE, IF COLOR) C IF (NUMNOD.LE.600) THEN IPEN0=MIN(IPEN1,3) IF (COLOR) THEN CALL PENCLR(IPEN0,BLUE) ENDIF CALL NEWPEN(IPEN0) 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) ENDIF C C PLOT FAULTS (IN RED, IF COLOR) C IF (NFL.GT.0) THEN KOLOR=RED SUM=0.0 DO 50 I=1,NFL SUM=SUM+FLEN(I) 50 CONTINUE AVERAG=SUM/NFL IF (NUMNOD.LE.600) THEN NTIC=3 DIPSIZ=0.15*AVERAG ELSE NTIC=1 DIPSIZ=0.40*AVERAG ENDIF DO 60 I=1,NFL DASH=.FALSE. CALL FAULT (INPUT,COLOR,DASH,FDIP,FTAN,I,IPEN2,KOLOR, + NFL,NUMNOD,NODEF,NTIC,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 KOLOR=1 C CALL USMAP (INPUT,COLOR,DRAWST,IPEN1,IPEN3,KOLOR, + NXYSTB,NXYSTF,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+2.,0.,10.5) CALL VPORT (0.,XINCH+2.,0.,10.5) C C RETURN TO INCH UNITS C CALL FACTOR (1.) C HEIGHT=0.15 WIDTH=HEIGHT*0.87 C C USE BLACK FOR TEXT C IF (COLOR) THEN CALL PENCLR(IPEN1,BLACK) ENDIF CALL NEWPEN(IPEN1) 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=1.5 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+2.,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,IPEN) 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,DONE,ENDCON,FINISH,GONOUT, + HITLIM,INSIDE, + 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) 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 IPEN UNLESS MODIFIED C IF (COLOR) THEN CALL PENCLR(IPEN,1) LASTKO=1 ENDIF CALL NEWPEN(IPEN) 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 (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 (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 JPEN=3 C LIFT PEN ELSE JPEN=2 C LOWER PEN, POSSIBLY COLORED IF (COLOR.AND.(KOLORP.NE.LASTKO)) THEN CALL PENCLR(IPEN,KOLORP) CALL NEWPEN(IPEN) LASTKO=KOLORP ENDIF ENDIF CALL PLOT(XARRAY(J),YARRAY(J),JPEN) 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(IPEN,1) CALL NEWPEN(IPEN) 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,COLOR,DRAWST,IPEN1,IPEN3,KOLOR, + NXYSTB,NXYSTF,XST,YST) C C PLOTS OUTLINE OF STATES FROM DIGITIZED DATASET. C INTEGER IPEN1,IPEN3,KOLOR,NXYSTB,NXYSTF LOGICAL COLOR,DRAW LOGICAL DRAWST REAL XST,YST DIMENSION DRAWST(NXYSTB),XST(NXYSTB),YST(NXYSTB) C C BOLD LINES C IF (COLOR) CALL PENCLR (IPEN3,KOLOR) CALL NEWPEN(IPEN3) DO 100 I=1,NXYSTB 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 C C FINE LINES (TEXT) C IF (COLOR) CALL PENCLR (IPEN1,KOLOR) CALL NEWPEN(IPEN1) DO 200 I=1,NXYSTF XP=XST(NXYSTB+I) YP=YST(NXYSTB+I) DRAW=DRAWST(NXYSTB+I) IF (DRAW) THEN CALL PLOT(XP,YP,2) ELSE CALL PLOT(XP,YP,3) ENDIF 200 CONTINUE RETURN END C C C SUBROUTINE ARROW (INPUT,CINT,NUMEL,OUTVEC, + SIZEAR,XIP,YIP, + OUTPUT,BIG,FACTR) C C DRAWS VECTORS WITH RMS LENGTH SIZEAR FROM ELEMENT C CENTERS. C DIMENSION OUTVEC(2,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) 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 RETURN END C C C SUBROUTINE AXES (INPUT,CINT,IPEN,NUMEL,SIZEAX, + TAUMT,TAUZZ, + XIP,YIP, + OUTPUT,BIG,FACTR) C C DRAWS TENSOR PRINCIPAL AXES, WITH RMS LENGTH SIZEAX, C AT ELEMENT CENTERS. C CONVENTION IS THAT AN AXIS IS COMPRESSIVE (INWARD-POINTING) C IF THE CORRESPONDING PRINCIPAL VALUE OF THE TENSOR IS NEGATIVE. C DIMENSION TAUMT(3,7,NUMEL),TAUZZ(7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) C 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.25D0*(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.25D0*(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 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 C C C SUBROUTINE READM (INPUT,IUNITP,N, + OUTPUT,EMPTY,EOF,VECTOR) C C A UTILITY ROUTINE DESIGNED TO PERMIT -FAULTS- INPUT FILES C TO ALSO BE USED BY -PLATES-, WHICH EXPECTS MORE NUMBERS C IN SOME RECORDS. C THIS ROUTINE ATTEMPTS TO READ 'N' FLOATING-POINT VALUES C (USING * FORMAT) FROM THE NEXT RECORD ON DEVICE 'IUNITP'. C IF ANYTHING GOES WRONG, THE MISSING VALUES ARE SET TO ZERO. C PARAMETER (LENGTH=26) CHARACTER*26 LINE CHARACTER*1 C LOGICAL EMPTY,EOF LOGICAL ANYIN,DOTTED,EXPON,SIGNED DIMENSION VECTOR(N) C LINE=' ' READ (IUNITP,'(A)',END=1,ERR=2) LINE GO TO 2 1 EMPTY=.TRUE. EOF=.TRUE. RETURN C 2 EOF=.FALSE. NUMBER=0 ANYIN=.FALSE. EXPON=.FALSE. SIGNED=.FALSE. DOTTED=.FALSE. DO 10 I=1,LENGTH C=LINE(I:I) IF ((C.EQ.' ').OR.(C.EQ.',').OR.(C.EQ.'/')) THEN SIGNED=.FALSE. EXPON=.FALSE. DOTTED=.FALSE. IF (ANYIN) THEN NUMBER=NUMBER+1 ANYIN=.FALSE. ENDIF ELSE IF ((C.EQ.'+').OR.(C.EQ.'-')) THEN IF (SIGNED) THEN GO TO 50 ELSE SIGNED=.TRUE. ENDIF ELSE IF ((C.EQ.'E').OR.(C.EQ.'D').OR. + (C.EQ.'e').OR.(C.EQ.'d')) THEN IF (EXPON) THEN GO TO 50 ELSE EXPON=.TRUE. SIGNED=.FALSE. DOTTED=.TRUE. ENDIF ELSE IF (C.EQ.'.') THEN IF (DOTTED) THEN GO TO 50 ELSE DOTTED=.TRUE. ENDIF ELSE IF ((C.EQ.'0').OR.(C.EQ.'1').OR.(C.EQ.'2').OR. + (C.EQ.'3').OR.(C.EQ.'4').OR.(C.EQ.'5').OR. + (C.EQ.'6').OR.(C.EQ.'7').OR.(C.EQ.'8').OR. + (C.EQ.'9')) THEN SIGNED=.TRUE. ANYIN=.TRUE. ELSE GO TO 50 ENDIF 10 CONTINUE IF (ANYIN) NUMBER=NUMBER+1 C 50 IF (NUMBER.EQ.0) THEN EMPTY=.TRUE. ELSE EMPTY=.FALSE. NUMBER=MIN(NUMBER,N) BACKSPACE IUNITP READ (IUNITP,*) (VECTOR(I),I=1,NUMBER) IF (NUMBER.LT.N) THEN DO 99 I=NUMBER+1,N VECTOR(I)=0. 99 CONTINUE ENDIF ENDIF RETURN END C C C SUBROUTINE READN (INPUT,IUNITP,IUNITT,N, + OUTPUT,VECTOR) C C A UTILITY ROUTINE DESIGNED TO PERMIT -FAULTS- INPUT FILES C TO ALSO BE USED BY -PLATES-, WHICH EXPECTS MORE NUMBERS C IN SOME RECORDS. C THIS ROUTINE ATTEMPTS TO READ 'N' FLOATING-POINT VALUES C (USING * FORMAT) FROM THE NEXT RECORD ON DEVICE 'IUNITP'. C IF ANYTHING GOES WRONG, THE MISSING VALUES ARE SET TO ZERO. C CHARACTER*1 C CHARACTER*80 LINE LOGICAL ANYIN,DOTTED,EXPON,SIGNED DIMENSION VECTOR(N) C LINE=' '// + ' ' READ (IUNITP,1) LINE 1 FORMAT (A80) C NUMBER=0 ANYIN=.FALSE. EXPON=.FALSE. SIGNED=.FALSE. DOTTED=.FALSE. DO 10 I=1,80 C=LINE(I:I) IF ((C.EQ.' ').OR.(C.EQ.',').OR.(C.EQ.'/')) THEN SIGNED=.FALSE. EXPON=.FALSE. DOTTED=.FALSE. IF (ANYIN) THEN NUMBER=NUMBER+1 ANYIN=.FALSE. ENDIF ELSE IF ((C.EQ.'+').OR.(C.EQ.'-')) THEN IF (SIGNED) THEN GO TO 50 ELSE SIGNED=.TRUE. ENDIF ELSE IF ((C.EQ.'E').OR.(C.EQ.'D').OR. + (C.EQ.'e').OR.(C.EQ.'d')) THEN IF (EXPON) THEN GO TO 50 ELSE EXPON=.TRUE. SIGNED=.FALSE. DOTTED=.TRUE. ENDIF ELSE IF (C.EQ.'.') THEN IF (DOTTED) THEN GO TO 50 ELSE DOTTED=.TRUE. ENDIF ELSE IF ((C.EQ.'0').OR.(C.EQ.'1').OR.(C.EQ.'2').OR. + (C.EQ.'3').OR.(C.EQ.'4').OR.(C.EQ.'5').OR. + (C.EQ.'6').OR.(C.EQ.'7').OR.(C.EQ.'8').OR. + (C.EQ.'9')) THEN SIGNED=.TRUE. ANYIN=.TRUE. ELSE GO TO 50 ENDIF 10 CONTINUE IF (ANYIN) NUMBER=NUMBER+1 C 50 IF (NUMBER.EQ.0) THEN WRITE (IUNITT,91) N,LINE 91 FORMAT (/' ERR0R: A LINE OF PARAMETER INPUT WHICH', + ' WAS SUPPOSED TO CONTAIN 1-',I2,' NUMBERS'/ + ' COULD NOT BE INTERPRETED. LINE FOLLOWS:'/ + ' ',A80) STOP ELSE NUMBER=MIN(NUMBER,N) BACKSPACE IUNITP READ (IUNITP,*) (VECTOR(I),I=1,NUMBER) IF (NUMBER.LT.N) THEN DO 99 I=NUMBER+1,N VECTOR(I)=0. 99 CONTINUE ENDIF ENDIF RETURN END C C C SUBROUTINE BOTTOM (INPUT,TRHMAX,VCX,VCY,X,Y, + OUTPUT,RESIST,VMX,VMY) C C COMPUTES HORIZONTAL COMPONENTS OF FLOW AT TOP OF ANY SUBDUCTING C SLABS OR OTHER STRONG ELEMENTS WHICH MAY APPLY TRACTIONS TO THE C BASE OF THE PLATE. C C (BUT, ALL SUCH TRACTIONS ARE TURNED OFF IF TRHMAX=0.) C C**************************************************************** C CAVEAT HACKER !!! C UNLIKE OTHER SUBPROGRAMS IN THIS PACKAGE, "BOTTOM" IS VERY C SPECIFIC TO A PARTICULAR PROBLEM: C -IT ONLY DESCRIBES THE PACIFIC/NORTH AMERICAN BOUNDARY IN THE C REGION OF THE ALASKAN-ALEUTIAN ARC. C -IT ASSUMES A PARTICULAR ORIGIN AND ORIENTATION OF THE X-AXIS. C (ORIGIN AT 61 N, 147 W, WITH +X POINTING E) 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 PARAMETER (LAST=17) LOGICAL CONTAC,RESIST C XYARC HOLDS PAIRS OF (X, Y) OF VOLCANIC ARC, WITH X INCREASING: DIMENSION XYARC(2,LAST) DATA ((XYARC(I,J),I=1,2),J=1,17) / + -2.688E+06,+2.382E+05, + -2.564E+06,-9.064E+04, + -2.343E+06,-3.474E+05, + -2.088E+06,-5.215E+05, + -1.682E+06,-6.322E+05, + -1.420E+06,-6.290E+05, + -1.064E+06,-5.516E+05, + -8.054E+05,-4.764E+05, + -6.004E+05,-3.647E+05, + -3.868E+05,-2.185E+05, + -2.812E+05,+5.439E+04, + -2.080E+05,+2.306E+05, + -1.141E+05,+3.241E+05, + +7.915E+04,+1.160E+05, + +2.325E+05,+4.720E+04, + +4.203E+05,-7.314E+04, + +6.269E+05,-2.666E+05/ C IF (TRHMAX.LE.0.) THEN C NO-DRAG OPTION: RESIST=.FALSE. VMX=VCX VMY=VCY ELSE IF ((X.LT.XYARC(1,1)).OR.(X.GT.XYARC(1,LAST)).OR. + (X.GT.(-90000.-Y*1.28)).OR. + (X.GT.(287000.+Y*0.860))) THEN CONTAC=.FALSE. ELSE DO 10 I=2,LAST IF ((X.GE.XYARC(1,I-1)).AND. + (X.LE.XYARC(1,I))) THEN I1=I-1 I2=I FRAC=(X-XYARC(1,I1))/ + (XYARC(1,I2)-XYARC(1,I1)) GO TO 11 ENDIF 10 CONTINUE 11 YARC=XYARC(2,I1)+FRAC*(XYARC(2,I2)-XYARC(2,I1)) CONTAC=Y.LT.YARC ENDIF IF (CONTAC) THEN RESIST=.TRUE. CALL SIDES (INPUT,X,Y, + OUTPUT,VMX,VMY) ELSE RESIST=.FALSE. VMX=VCX VMY=VCY ENDIF ENDIF RETURN END C C C SUBROUTINE SIDES (INPUT,X,Y, + OUTPUT,VX,VY) C C COMPUTES HORIZONTAL COMPONENTS OF FLOW AT SIDES OF MODEL, IF C NEEDED FOR IMPOSITION OF TYPE-3 VELOCITY BOUNDARY CONDITIONS. C C**************************************************************** C CAVEAT HACKER !!! C UNLIKE OTHER SUBPROGRAMS IN THIS PACKAGE, "SIDES" IS VERY C SPECIFIC TO A PARTICULAR PROBLEM: C -IT ONLY DESCRIBES THE PLATE BOUNDARIES IN THE ALASKA/BERING SEA C REGION. C -IT ASSUMES A PARTICULAR ORIGIN AND ORIENTATION OF THE X-AXIS. C (ORIGIN AT 61 N, 147 W, WITH +X POINTING E) C -IT IS BASED ON A PARTICULAR PLATE MODELS (ROTATION POLES): C THOSE OF DEMETS ET. AL. (1990): NUVEL-1, AND C COOK ET AL. (1986): OKHOTSK/NORTH AMERICA. C -NOTE THAT ALL VELOCITIES ARE RELATIVE TO NORTH AMERICA. C C YOU WILL PROBABLY NEED TO REPLACE THE CODE GIVEN HERE WITH C NEW CODE OF YOUR OWN !!! C**************************************************************** C LOGICAL PACIFI,EURASI,OKHOTS REAL N1,N2,N3 C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C IF (Y.LT. +5.617E5) THEN PACIFI=.TRUE. EURASI=.FALSE. OKHOTS=.FALSE. ELSE DX=X-(-1.200E6) DY=Y-(+5.617E5) ARG=ATAN2F(DY,DX) IF (ARG.GT.2.3999) THEN OKHOTS=.TRUE. EURASI=.FALSE. PACIFI=.FALSE. ELSE EURASI=.TRUE. OKHOTS=.FALSE. PACIFI=.FALSE. ENDIF ENDIF C RADIUS=6371000. CPNLAT=61. Y0NLAT=61. X0ELON=-147. C RTAN=RADIUS*TANDEG(90.-CPNLAT) YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) CALL XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) R1=RADIUS*COSDEG(PLON)*COSDEG(PLAT) R2=RADIUS*SINDEG(PLON)*COSDEG(PLAT) R3=RADIUS*SINDEG(PLAT) N1= -COSDEG(PLON)*SINDEG(PLAT) N2= -SINDEG(PLON)*SINDEG(PLAT) N3=COSDEG(PLAT) E1= -SINDEG(PLON) E2=COSDEG(PLON) E3=0. C IF (PACIFI) THEN C (DEMETS ET AL.: C (48.7S, 101.8E, 0.78 DEG./MILLION-YEARS) RATE=SINDEG(0.78)/(1.E6*3.15576E7) P1=COSDEG(101.8)*COSDEG(-48.7)*RATE P2=SINDEG(101.8)*COSDEG(-48.7)*RATE P3=SINDEG(-48.7)*RATE ELSE IF (EURASI) THEN C (DEMETS ET AL.: C (62.4N, 135.8E, 0.22 DEG./MILLION-YEARS) RATE=SINDEG(0.22)/(1.E6*3.15576E7) P1=COSDEG(135.8)*COSDEG(+62.4)*RATE P2=SINDEG(135.8)*COSDEG(+62.4)*RATE P3=SINDEG(+62.4)*RATE ELSE IF (OKHOTS) THEN C (COOK ET AL., 1986; RATE IS REALLY A GUESS!) C (72.4N, 169.8E, 0.4 DEG./MILLION-YEARS) RATE=SINDEG(0.4 )/(1.E6*3.15576E7) P1=COSDEG(169.8)*COSDEG(+72.4)*RATE P2=SINDEG(169.8)*COSDEG(+72.4)*RATE P3=SINDEG(+72.4)*RATE ELSE VX=0. VY=0. RETURN ENDIF V1=P2*R3-P3*R2 V2=P3*R1-P1*R3 V3=P1*R2-P2*R1 VN=N1*V1+N2*V2+N3*V3 VE=E1*V1+E2*V2+E3*V3 VSQ=VN*VN+VE*VE IF (VSQ.GT.0.) THEN TIME=RADIUS*SINDEG(1.)/SQRT(VSQ) ELSE VX=0. VY=0. RETURN ENDIF QLAT=PLAT+57.296*VN*TIME/RADIUS QLON=PLON+57.296*VE*TIME/(RADIUS*COSDEG(PLAT)) CALL LLTOXY (INPUT,CPNLAT, + QLAT,QLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,XP,YP) VX=(XP-X)/TIME VY=(YP-Y)/TIME RETURN END C C C SUBROUTINE LLTOXY (INPUT,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X,Y) C C CONVERT A (NORTH LATITUDE=PLAT, EAST LONGITUDE=PLON) POSITION C INTO AN (X,Y) POSITION ON A CONIC PROJECTION WITH TANGENT C LATITUDE CPNLAT, WHEN THE (X,Y) ORIGIN IS AT C (NORTH LATITUDE=Y0NLAT, EAST LONGITUDE=X0ELON). C THE CUT NECESSARY IN THIS PROJECTION IS FROM THE POLE NEAREST C TO THE TANGENT LATITUDE (CPNLAT), ALONG A MERIDIAN WHICH C IS ON THE OPPOSITE SIDE OF THE EARTH FROM X0ELON. C IF PLAT IS MORE THAN 90 DEGREES DIFFERENT FROM CPNLAT, THE C POINT DOES NOT FALL ONTO THE PROJECTION AT ALL. TO PREVENT C CRASHES, WE MERELY PLACE IT VERY FAR OUT ON THE PROJECTION. C C NOTE: FOLLOWING TWO LINES ARE PRECOMPUTED AND PASSED TO SAVE TIME: C RTAN=RADIUS*TANDEG(90.-CPNLAT) C YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C IF (ABS(PLAT-CPNLAT).GE.90.) PLAT=CPNLAT+89.*(PLAT-CPNLAT)/ + ABS(PLAT-CPNLAT) R=RTAN-RADIUS*TANDEG(PLAT-CPNLAT) DPLON=PLON-X0ELON IF (DPLON.LT.-180.) DPLON=DPLON+360. IF (DPLON.GT. 180.) DPLON=DPLON-360. ANGLE=DPLON*SINDEG(CPNLAT) X=R*SINDEG(ANGLE) Y=YPOLE-R*COSDEG(ANGLE) RETURN END C C C SUBROUTINE XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) C C CONVERT POINTS EXPRESSED AS (X,Y) ON A CONIC PROJECTION PLANE C WITH TANGENT LATITUDE CPNLAT AND ORIGIN AT (Y0NLAT,X0ELON) C TO (PLAT = NORTH_LATITUDE, PLON = EAST_LONGITUDE) C IN DEGREES C C NOTE: FOLLOWING TWO VARIABLES ARE PRECOMPUTED TO SAVE TIME: C RTAN=RADIUS*TANDEG(90.-CPNLAT) C YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C YRP=Y-YPOLE R=SQRT(X**2+YRP**2) ANGLE=57.29578*ATAN2F(X,-YRP) PLON=X0ELON+ANGLE/SINDEG(CPNLAT) PLAT=CPNLAT+57.29578*ATAN((RTAN-R)/RADIUS) PLAT=MIN(90.,MAX(PLAT,-90.)) IF ((PLON-X0ELON).GT. 180.) PLON=PLON-360. IF ((PLON-X0ELON).GT. 180.) PLON=PLON-360. IF ((PLON-X0ELON).LT.-180.) PLON=PLON+360. IF ((PLON-X0ELON).LT.-180.) PLON=PLON+360. RETURN END