C C PROGRAM -ORBMAPAI-: MAPS OF INPUT TO AND OUTPUT FROM FINITE C ELEMENT PROGRAMS -SHELLS- (NEOTECTONICS) AND/OR -RESTORE- C (PALINSPASTIC AND PALEOTECTONIC RESTORATIONS), C IN CUSTOM FORMAT OF ADOBE ILLUSTRATOR FOR WINDOWS, VERSION 4. C C ========= PART OF THE -SHELLS- & -RESTORE- PACKAGES OF PROGRAMS===== C C GIVEN ANY FINITE ELEMENT GRID FILE, IN THE FORMAT PRODUCED BY C -ORBWEAVE- AND THEN RENUMBERED BY -OrbNumber-, WITH NODAL DATA C ADDED BY -ORBDATA-, AND PERHAPS WITH OUTPUT FROM -SHELLS-, C CREATE PLOTS OF THE GRID, INPUT VARIABLES (ELEVATION, C HEAT FLOW, CRUSTAL THICKNESS, MANTLE LITHOSPHERE THICKNESS), AND C RESULTS (VELOCITY, STRAIN-RATE, STRESS, FAULT SLIP RATE). C C *MAPS CAN BE VIEWED ON ANY IBM-COMPATIBLE PC RUNNING WINDOWS 3.1 C AND ADOBE ILLUSTRATOR FOR WINDOWS, VERSION 4; C OR WINDOWS NT 4.0 (OR WINDOWS 95) AND ADOBE ILLUSTRATOR 7. C *MAPS CAN BE PRINTED AS COLOR OR B/W ON ANY WINDOWS-COMPATIBLE C PRINTER, ESPECIALLY POSTSCRIPT PRINTERS. C C ***************** IMPORTANT HISTORICAL NOTES ******************* C C -ORBMAPAI- IS A TRANSLATION OF -ORBMAP-, WHICH CREATED GRAPHICS C METAFILES USING PROPRIETARY FORTRAN SUBROUTINES OF THE -DISSPLA- C PACKAGE OF DEVICE-INDEPENDENT GRAPHICS. FOR EASE OF MAINTENANCE, C MOST OF THE CODE REMAINS UNCHANGED, BUT AT THE END OF THE C PACKAGE (FOLLOWING THE COMMENT "C-DISSPLA2AI" ) C THERE ARE A GROUP OF SUBSTITUTE "DISSPLA" ROUTINES THAT C PERFORM THE TRANSLATION BETWEEN LANGUAGES. C THE SUBROUTINES FROM DISSPLA WHICH MUST BE REPLACED ARE: C ALNMES MAPOLE SWISSL C ANGLE MARKER THKCRV C ARC MESSAG THKVEC C AREA2D X (MRSCOD) X VECTOR C X (COMPRS) X NEWCLR XNAME C CURVE X (OREL) X X (XNONUM) X C DASH PAGE X (XTICKS) X C DONEPL X (PHYSOR) X YNAME C DOT PROJCT X (YNONUM) X C ENDGR REALNO X (YTICKS) X C ENDPL RESET C X (GRACE) X RLMESS C X (GRAF) X RLREAL C GRID RLVEC C HEADIN SETDEV C HEIGHT SHADE C HWSHD SHDCHR C MAPFIL SHDCRV C MAPGR SHDPAT C X ( ) X MARKS ROUTINES THAT WERE TOO CONFUSING TO TRANSLATE, C AND WERE SIMPLY ELIMINATED. NOTE THAT -ORBMAPAI- ALWAYS USES C THE BASIC POSTSCRIPT COORDINATE SYSTEM, IN WHICH X (RIGHT) C AND Y (UP) ARE MEASURED FROM THE LOWER LEFT PAGE CORNER, C AND ARE IN POINTS (72/INCH). C C THE "STATE" OR "MEMORY" FEATURE OF DISSPLA IS EMULATED BY C VARIABLES IN THE COMMON BLOCK "FAKEDI". C **************************************************************** C C BY C PETER BIRD, C DEPARTMENT OF EARTH AND SPACE SCIENCES, C UNIVERSITY OF CALIFORNIA, LOS ANGELES, CALIFORNIA 90024 C (C) COPYRIGHT 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999 C BY PETER BIRD AND C THE REGENTS OF THE UNIVERSITY OF CALIFORNIA C (FOR VERSION DATE SEE FORMAT 1 BELOW) C C THIS PROGRAM WAS DEVELOPED WITH SUPPORT FROM THE UNIVERSITY OF C CALIFORNIA, THE UNITED STATES GEOLOGIC SURVEY, THE NATIONAL C SCIENCE FOUNDATION, AND THE NATIONAL AERONAUTICS AND SPACE C ADMINISTRATION. C IT IS FREEWARE, AND MAY BE COPIED AND USED WITHOUT CHARGE. C IT MAY NOT BE MODIFIED IN A WAY WHICH HIDES ITS ORIGIN C OR REMOVES THIS MESSAGE OR THE COPYRIGHT MESSAGE. C IT MAY NOT BE RESOLD FOR MORE THAN THE COST OF REPRODUCTION C AND MAILING. 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=5000) C C MAXEL = MAXIMUM NUMBER OF CONTINUUM ELEMENTS (TRIANGLES). PARAMETER (MAXEL=8000) C C MAXFEL = MAXIMUM NUMBER OF FAULT ELEMENTS (LINE SEGMENTS); PARAMETER (MAXFEL=1015) C C MAXBN = MAXIMUM NUMBER OF BOUNDARY NODES: PARAMETER (MAXBN=300) C C MAXATP = MAXIMUM NUMBER OF NODES WHICH MAY OVERLAP AT A FAULT- C INTERSECTION POINT. PARAMETER (MAXATP=20) C C MAXPOI = MAXIMUM NUMBER OF POINTS IN GRAPHICS POLYGONS PARAMETER (MAXPOI=100) C C NPTYPE = NUMBER OF TYPES OF PLOTS AVAILABLE IN THIS PROGRAM PARAMETER (NPTYPE=21) C C PARAMETERS GIVING THE (EXACT) NUMBER OF NUVEL-1A PLATES, AND C MAXIMUM NUMBER OF DIGITISED BOUNDARY POINTS FOR EACH PLATE: PARAMETER (NUMPLT=14, MXBOUN=1200) 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 CHARACTER*81 TITLE4,TITLE6 CHARACTER*42 TEXT, VUNITS CHARACTER*20 COLNAM CHARACTER*12 STEPID CHARACTER*4 KOLOR CHARACTER*3 TIMCHR CHARACTER*2 NAMES CHARACTER*1 C1 C DOUBLE PRECISION V,VM,V2,V3 C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD1: DOUBLE PRECISION POINTS,WEIGHT C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD2: DOUBLE PRECISION FPHI,FPOINT,FGAUSS C FOLLOWING STATEMENT TO PREVENT OVERFLOWS WHEN SQUARING NODAL FORCES: DOUBLE PRECISION DPSUM,DPV1,DPV2 C LOGICAL BARIT,BRIEF,COLOR, + DASHED,DOGRID,DOMU,DOPLOT, + E1PART,E2PART,EZPART, + EDGEIT,EVERYP,FROM, + HAVENV,HAVEOV,MAGNIF,MOREV, + NEEDFS,NEEDGE,NEEDGL,NEEDST,NEEDSV,NEEDVM, + SPHERE C C NOTE: THE FOLLOWING ARRAYS COULD BE COMPRESSED WITH "LOGICAL*1" C IN VS-FORTRAN: LOGICAL CHECKE,CHECKF,CHECKN,CONTIN,EDGETS,EDGEFS,FSLIPS,LAND C REAL MULOG C C--------------------------------------------------------------------- C DIMENSION STATMENTS C C DIMENSIONS USING PARAMETER MAXNOD: DIMENSION ATNODE(MAXNOD), CHECKN(MAXNOD), DQDTDA(MAXNOD), + ELEV (MAXNOD), ICOUNT(MAXNOD), MULOG (MAXNOD), + TLNODE(MAXNOD), + V (2,MAXNOD), VM (2,MAXNOD), V2 (2,MAXNOD), + V3 (2,MAXNOD), VNODE(2,MAXNOD), + XNODE (MAXNOD), YNODE (MAXNOD), ZMNODE(MAXNOD) C C DIMENSIONS USING PARAMETER MAXEL: DIMENSION ALPHA(3,3,7,MAXEL),AREA (MAXEL),CHECKE (MAXEL), + CONTIN (7,MAXEL),DETJ (7,MAXEL), + DVB (7,MAXEL), + DXS(2,2,3,7,MAXEL),DYS(2,2,3,7,MAXEL), + DXSP (3,7,MAXEL),DYSP (3,7,MAXEL),EDGETS(3,MAXEL), + ERATE (3,7,MAXEL), + FPSFER(2,2,3,7,MAXEL), + GEOTHC (4,7,MAXEL),GEOTHM(4,7,MAXEL), + GLUE (7,MAXEL), + LIMTED (2,7,MAXEL), + NODES (3,MAXEL), + OVB (2,7,MAXEL), + OUTSCA (7,MAXEL),OUTVEC(2,7,MAXEL), + SIGHB (2,7,MAXEL),SITA (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), + FARG (2,MAXFEL), + FC(2,2,7,MAXFEL), FDIP (2,MAXFEL), + FIMUDZ(7,MAXFEL), FLEN (MAXFEL), + FPEAKS(2,MAXFEL), FPFLT (2,2,2,7,MAXFEL), + FSLIPS (MAXFEL), FTSTAR(2,7,MAXFEL), + NODEF (4,MAXFEL), + OFFSET (MAXFEL), ZTRANF (2,MAXFEL) C C DIMENSIONS USING PARAMETER MAXBN: DIMENSION NODCON(MAXBN) C C DIMENSIONS USING PARAMETER NPTYPE: DIMENSION CINT (NPTYPE), DOPLOT(NPTYPE), + FBLAND(NPTYPE), LOWBLU(NPTYPE), + TEXT (NPTYPE), NVCHAR(NPTYPE), + VUNITS(NPTYPE), NVUCHR(NPTYPE) C C DIMENSIONS OF (2) USUALLY REFER TO CRUST/MANTLE LITHOSPHERE: DIMENSION ACREEP(2), ALPHAT(2), BCREEP(2), CCREEP(2), CONDUC(2), + DCREEP(2), RADIO(2), RHOBAR(2), TAUMAX(2), TEMLIM(2) C C DIMENSIONS USING PARAMETER MAXATP: DIMENSION LIST (MAXATP) C C DIMENSION USING PARAMETER MAXPOI: DIMENSION ICYCLE(MAXPOI), + XARAY(MAXPOI),XARRAY(MAXPOI), + YARAY(MAXPOI),YARRAY(MAXPOI) C C DIMENSIONS USING PARAMETERS NUMPLT AND MXBOUN: DIMENSION NAMES (NUMPLT) , OMEGA (3,NUMPLT), + NDPLAT(NUMPLT) , + PLAT (NUMPLT,MXBOUN), PLON (NUMPLT,MXBOUN) C C DIMENSIONS OF FIXED SIZE: DIMENSION CARTVS(3,3),GAPRAY(1),POLE(3),TEMPV(3) C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD1: DIMENSION POINTS(3,7),WEIGHT(7) C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA BD2: DIMENSION FPHI(4,7),FPOINT(7),FGAUSS(7) C FOLLOWING STATEMENT TO AGREE WITH BLOCK DATA COLORS: DIMENSION ALONG(99),COLNAM(99),SPACIN(99) C C--------------------------------------------------------------------- C EQUIVALENCE STATEMENTS C (NOTE: ALL EQUIVALENCES ARE TO CONSERVE MEMORY, AND DO NOT IMPLY C LOGICAL EQUIVALENCE!) C C--------------------------------------------------------------------- C COMMON STATEMENTS C C NOTE: UN-NAMED COMMON PASSES INTEGER VARIABLES LDA AND MD USED IN THE C INTEGER-FUNCTION "INDEXK", TO AVOID PASSING THESE SAME C THROUGH LONG SEQUENCES OF SUBPROGRAMS. C IT ALSO INCLUDES SPECIAL VALUES USED AS FLAGS IN CALLS C TO RLMESS AND MESSAG: ABUT C (IN THE DISSPLA MANUAL, ONE IS INSTRUCTED TO USE EITHER C "CALL MESSAG (STRING,LENGTH,X,Y)", OR C "CALL MESSAG (STRING,LENGTH,'ABUT',ABUT')"; C HOWEVER, SOME COMPILERS REJECT THIS MIXING OF STRINGS WITH REALS. C SO, IN THE SAME SPIRIT, WE USE "CALL MESSAG (STRING,LENGTH,ABUT,ABUT)". COMMON LDA,MD,ABUT C C NAMED COMMON BLOCKS BD1 & B HOLD 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 C ENTRIES CORRESPONDING TO BD1: COMMON /S1S2S3/ POINTS COMMON /WGTVEC/ WEIGHT C C ENTRIES CORRESPONDING TO BD2: COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS C C NAMED COMMON BLOCK COLORS HOLDS THE COLOR-BAR AND GRAY-SCALE C DEFINITIONS. C ENTRIES CORRESPONDING TO COLORS: COMMON /MYOWN/ NGRAY,ALONG,COLNAM,SPACIN C C-------------------------------------------------------------------- C DATA STATEMENTS C C "PI" IS THE NUMBER OF DIAMETERS IN A CIRCLE: DATA PI /3.1415927/ C C "PIO180" IS PI/180. (CONVERSION FROM DEGREES TO RADIANS): DATA PIO180 /0.017453293/ DATA OEZOPI /57.29577951/ C C "SECPYR" IS THE NUMBER OF SECONDS IN A YEAR: DATA SECPYR /31557600./ C C "SUBDIP" IS THE MAXIMUM DIP (FROM HORIZONTAL, IN DEGREES) FOR A C FAULT IN A WHOLE-EARTH MODEL (SPHERE=.TRUE.) TO BE TREATED AS C A SUBDUCTION ZONE (IN WHICH CASE, THE FOOTWALL REQUIRES C BOUNDARY CONDITIONS). C IN ALL MODELS, FAULTS WITH LESS THAN THIS DIP HAVE THE DOWN-DIP C INTEGRAL OF TRACTION LIMITED TO "TAUMAX". IF SUCH A LIMIT IS C NOT WANTED, THEN "TAUMAX" CAN SIMPLY BE SET VERY LARGE. DATA SUBDIP /27.5/ C C "DIPMAX" IS THE MAXIMUM DIP (FROM HORIZONTAL, IN DEGREES) FOR A C FAULT ELEMENT TO BE TREATED AS A DIP-SLIP FAULT, WITH TWO DEGREES C OF FREEDOM PER NODE-PAIR. AT STEEPER DIPS, THE DEGREE OF FREEDOM C CORRESPONDING TO OPENING OR CONVERGENCE OF THE OPPOSITE SIDES IS C ELIMINATED BY A CONSTRAINT EQUATION, AND THE FAULT IS TREATED AS C A VERTICAL STRIKE-SLIP FAULT. THIS ARBITRARY LIMIT IS NECESSARY C BECAUSE THE EQUATIONS FOR DIP-SLIP FAULTS BECOME SINGULAR AS THE C DIP APPROACHES 90 DEGREES. IN PRACTICE, IT IS BEST TO SPECIFY DIPS C AS EITHER (1) VERTICAL, OR (2) CLEARLY LESS THAN "DIPMAX", WITHIN C EACH FAULT ELEMENT. IF THE DIP VARIES WITHIN AN ELEMENT IN SUCH A C WAY THAT IT PASSES THROUGH THIS LIMIT WITHIN THE ELEMENT, THEN C THE REPRESENTATION OF THAT FAULT ELEMENT IN THE EQUATIONS MAY C BE INACCURATE. DATA DIPMAX /75./ C C THE FOLLOWING ARE THE FORTRAN INPUT AND OUTPUT DEVICE NUMBERS: C "IUNITG"= DEVICE NUMBER ASSOCIATED WITH THE GRID INPUT FILE. DATA IUNITG /1/ C "IUNITV"= DEVICE NUMBER ASSOCIATED WITH THE VELOCITY C SOLUTION AT THE NODES: DATA IUNITV /2/ C "IUNITF"= DEVICE NUMBER ASSOCIATED WITH THE FORCES ON NODES C REQUIRED TO IMPOSE THE VELOCITY BOUNDARY CONDITIONS: DATA IUNITF /3/ C "IUNITP"= DEVICE NUMBER ASSOCIATED WITH THE PARAMETER INPUT FILE. C (NOTE: MAY EQUAL IUNITB.) DATA IUNITP /4/ C "IUNITT"= DEVICE NUMBER ASSOCIATED WITH TEXT OUTPUT, INCLUDING C STATUS AND WARNING MESSAGES. C (NOTE! ON SOME SYSTEMS, SYSTEM ERR0R MESSAGES ARE ALWAYS C OUTPUT ON DEVICE 6. IF SO, THEN IUNITT SHOULD BE 6.) DATA IUNITT /6/ C "IUNITM"= DEVICE NUMBER ASSOCIATED MANTLE VELOCITY VECTORS, C OR DIGITISED PLATE EDGES, OR ANYTHING NEEDED TO FIND C THE LOWER MANTLE VELOCITY C (NOTE: MAY EQUAL IUNITP.) DATA IUNITM /7/ C---------------------------------------------------------------- C Note on opening files: C This version is slightly customized for the "DIGITAL Visual C Fortran[90] Version 5.0A Professional Edition" compiler for C Windows NT and Windows 95. I hope that this will not C interfere with compilations under Fortran77 or other compilers! C C Before the first use of any file, there is a WRITE(*) line C which tells the user which file (generically speaking) is C about to be opened. Then, an OPEN (i, FILE = ' ') C statement with a blank (one-space) filename causes the C program to do one of two things: C (1) take the filename from the next parameter on the command C line (if any), or prompt the INTERACTIVE user for it C if none is found; OR, C (2) look for a file named FORT.i [i is some integer] C or an environment variable with this name that specifies C the actual filename. C Method (1) is for interactive use; (2) is for batch use. C The selection is made by compiler switches at compile time C (e.g., in Microsoft Developer Studio: C Project / Settings / Fortran / Compatability / C [Y] Filenames from Command Line [checked] C OR "/fpscomp:filesfromcmd" parameter on the compile command line C are two ways to specify method (1). C---------------------------------------------------------------- C C NUMVEL-1 PLATE NAMES: DATA NAMES / 1 'PA', 2 'AF', 3 'AN', 4 'AR', 5 'AU', 6 'CA', 7 'CO', 8 'EU', 9 'IN', A 'NZ', B 'NA', C 'SA', D 'JF', E 'PH'/ C 1 = PA = PACIFIC 2 = AF = AFRICA 3 = AN = ANTARCTICA C 4 = AR = ARABIA 5 = AU = AUSTRALIA 6 = CA = CARIBBEAN C 7 = CO = COCOS 8 = EU = EURASIA 9 = IN = INDIA C A = NZ = NAZCA B = NA = NORTH AMERICA C C = SA = SOUTH AMERICA D = JF = JUAN DE FUCA C E = PH = PHILIPINE-SEA C C Following rotation vectors in Cartesian (x,y,z) components, C with units of radians per million years (per DeMets et al., 1990, C Table 1, * 0,9562 [DeMets et al., 1994]): DATA ((omega(i, j),i = 1, 3), j = 1, numplt) / 1 0.000000, 0.000000, 0.000000, 2 0.002401, -0.007939, 0.013893, 3 0.000689, -0.006541, 0.013676, 4 0.008195, -0.005361, 0.016730, 5 0.009349, 0.000284, 0.016253, 6 0.001332, -0.008225, 0.011551, 7 -0.008915, -0.026446, 0.020896, 8 0.000529, -0.007236, 0.013123, 9 0.008180, -0.004800, 0.016760, A -0.000022, -0.013417, 0.019579, B 0.001768, -0.008439, 0.009817, C 0.000472, -0.006355, 0.009100, D 0.006512, 0.003175, 0.005077, E 0.011379, -0.012239, 0.000000/ 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)/'TOTAL LITHOSPHERE THICKNESS '/ DATA NVCHAR(5)/27/ DATA TEXT(6)/'MOHO TEMPERATURE '/ DATA NVCHAR(6)/16/ DATA TEXT(7)/'TEMPERATURE AT BASE OF PLATE '/ DATA NVCHAR(7)/28/ DATA TEXT(8)/'PRESSURE ANOMALY AT BASE OF PLATE '/ DATA NVCHAR(8)/33/ DATA TEXT(9)/'LOWER MANTLE VELOCITY, (*R/r) '/ DATA NVCHAR(9)/29/ DATA TEXT(10)/'SHEAR TRACTION ON BASE OF PLATE '/ DATA NVCHAR(10)/31/ DATA TEXT(11)/'SURFACE VELOCITY '/ DATA NVCHAR(11)/16/ DATA TEXT(12)/'VELOCITY CHANGES FROM PREVIOUS SOLUTION '/ DATA NVCHAR(12)/39/ DATA TEXT(13)/'SURFACE STRAIN-RATE '/ DATA NVCHAR(13)/20/ DATA TEXT(14)/'DISCONTINUITY IN HORIZONTAL VELOCITY '/ DATA NVCHAR(14)/36/ DATA TEXT(15)/'MEAN SLIP-RATE OF FAULTS '/ DATA NVCHAR(15)/24/ DATA TEXT(16)/'RATE OF CRUSTAL THICKENING '/ DATA NVCHAR(16)/26/ DATA TEXT(17)/'VERTICALLY-INTEGRATED STRESS ANOMALIES '/ DATA NVCHAR(17)/38/ DATA TEXT(18)/'MOST COMPRESSIVE HORIZONTAL STRESS '/ DATA NVCHAR(18)/34/ DATA TEXT(19)/'FORCE ON NODES TO IMPOSE BOUNDARY VELOCITY'/ DATA NVCHAR(19)/42/ DATA TEXT(20)/'Log10[Viscosity Integral, in Pa s m] '/ DATA NVCHAR(20)/36/ DATA TEXT(21)/'Log10[Strain-rate, in /s] '/ DATA NVCHAR(21)/25/ C DATA VUNITS(1)/' '/ DATA NVUCHR(1)/0/ DATA VUNITS(2)/'km '/ DATA NVUCHR(2)/2/ 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)/'MPa '/ DATA NVUCHR(8)/3/ DATA VUNITS(9)/'mm/year '/ DATA NVUCHR(9)/7/ DATA VUNITS(10)/'MPa '/ DATA NVUCHR(10)/3/ DATA VUNITS(11)/'mm/year '/ DATA NVUCHR(11)/7/ DATA VUNITS(12)/'mm/year '/ DATA NVUCHR(12)/7/ DATA VUNITS(13)/'/s '/ DATA NVUCHR(13)/2/ DATA VUNITS(14)/'mm/year '/ DATA NVUCHR(14)/7/ DATA VUNITS(15)/'mm/year '/ DATA NVUCHR(15)/7/ DATA VUNITS(16)/'mm/year '/ DATA NVUCHR(16)/7/ DATA VUNITS(17)/'N/m '/ DATA NVUCHR(17)/3/ DATA VUNITS(18)/' '/ DATA NVUCHR(18)/0/ DATA VUNITS(19)/'N '/ DATA NVUCHR(19)/1/ DATA VUNITS(20)/' '/ DATA NVUCHR(20)/0/ DATA VUNITS(21)/' = log10(strain-rate * 1 s) '/ DATA NVUCHR(21)/27/ C C SPECIAL CODE IN -ORBMAPAI- TO REQUEST SOLID BLACK FROM -SHADE-: DATA GAPRAY(1) /-0.1/ C C SPECIAL CODE IN CALLS TO RLMESS AND MESSAG, ASKING LOCATION C TO ABUT THE END OF THE PREVIOUS MESSAGE: ABUT = 1.23456E38 C C--------------------------------------------------------------------- C C BEGINNING OF EXECUTABLE CODE C C *** KLUDGE ALERT ************************************************* C CONVERSION OF PARAMETERS (CONSTANTS) TO VARIABLES SHOULD LOGICALLY C HAVE NO EFFECT, BUT IN FACT HELPS TO SUPPRESS SOME SPURIOUS C MESSAGES FROM THE IBM VS-FORTRAN COMPILER. MXNODE=MAXNOD MXEL =MAXEL MXFEL =MAXFEL MXBN =MAXBN MXSTAR=MAXATP MXPNTS=MAXPOI NPTIPE=NPTYPE NPLATE=NUMPLT NPBND =MXBOUN C ****************************************************************** C C WRITE HEADER ON OUTPUT FILE C WRITE (IUNITT,1) 1 FORMAT (/' GPB', +'OUT:'/ +' =============================================================='/ +' I -OrbMapAI- I'/ +' I A spherical-Earth, thin-shell program for plotting I'/ +' I time-averaged (anelastic) deformation of plates I'/ +' I computed by finite-element program -SHELLS-, I'/ +' I in the form of Adobe Illustrator 3 for Windows I'/ +' I .AI metafiles, editable on a PC or Mac. I'/ +' I by I'/ +' I Peter Bird I'/ +' I Department of Earth and Space Sciences I'/ +' I University of California I'/ +' I Los Angeles, CA 90095-1567 I'/ +' I Version of 1 July 1999 I'/ +' ==============================================================') C WEDGE=ABS(90.-ABS(DIPMAX))*0.017453293 C SLIDE=SUBDIP*0.017453293 C C INPUT FINITE ELEMENT GRID AND DATA VALUES AT NODE POINTS C CALL GETNET (INPUT,IUNITG,IUNITT, + MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF,DQDTDA,ELEV,FDIP, + NFAKEN,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,OFFMAX,OFFSET, + TITLE1,TLNODE,XNODE,YNODE,ZMNODE, + WORK,CHECKE,CHECKF,CHECKN) C C READ SCALAR PARAMETERS C CALL READPM (INPUT,IUNITP, IUNITT, NAMES, NUMPLT, OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT , + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , GMEAN , + GRADIE, ICONVE, IPVREF, MAXITR, MODESR, + OKDELV, OKTOQT, ONEKM, RADIO , + RADIUS, REFSTR, RHOAST, RHOBAR, RHOH2O, + TADIAB, + TAUMAX, TEMLIM, TITLE3, TRHMAX, TSURF, + VTIMES, ZBASTH, $ NPTIPE, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,NCONTR, $ ICOAST,RMSVEC, $ DEGWID,PERLON,PERLAT, $ IPEN1,IPEN2,IPEN3,COLOR) C C DETERMINE "MAP POLE" (CENTER POINT) AS A CARTESIAN UNIT VECTOR C AND AS (THETA,PHI) COORDINATES C POLE(1)=COS(PERLON*PIO180)*COS(PERLAT*PIO180) POLE(2)=SIN(PERLON*PIO180)*COS(PERLAT*PIO180) POLE(3)=SIN(PERLAT*PIO180) POLET=(90.-PERLAT)*PIO180 POLEP=PERLON*PIO180 C C LIMITS OF MAP LONGITUDE, IN DEGREES C CUTLN1=PERLON-179.99 CUTLN2=PERLON+179.99 C C CHECK GRID TOPOLOGY AND COMPUTE GEOMETRIC PROPERTIES C WRITE (IUNITT,10) 10 FORMAT(' ------------------------------------------------------' + //' Testing grid for topological problems...'/) CALL SQUARE (INPUT,BRIEF,FDIP,IUNITT, + MXBN,MXEL,MXFEL,MXNODE, + MXSTAR,NFL,NODEF,NODES, + NUMEL,NUMNOD,RADIUS,WEDGE, + MODIFY,XNODE,YNODE, + OUTPUT,AREA,DETJ, + DXS,DYS,DXSP,DYSP,EDGEFS, + EDGETS,FLEN,FPFLT,FPSFER, + FARG,NCOND,NODCON,SITA, + WORK,CHECKN,LIST) SPHERE=(NCOND.EQ.0) CALL CHOP (INPUT,TITLE1, + OUTPUT,TITLE4) CALL CHOP (INPUT,TITLE3, + OUTPUT,TITLE6) C C COMPUTE THE (THETA,PHI) OF INTEGRATION POINTS C DO 50 I=1,NUMEL DO 20 K=1,3 CARTVS(1,K)=COS(YNODE(NODES(K,I)))* + SIN(XNODE(NODES(K,I))) CARTVS(2,K)=SIN(YNODE(NODES(K,I)))* + SIN(XNODE(NODES(K,I))) CARTVS(3,K)=COS(XNODE(NODES(K,I))) 20 CONTINUE DO 40 M=1,7 DO 30 J=1,3 TEMPV(J)=0.0 DO 25 K=1,3 TEMPV(J)=TEMPV(J)+CARTVS(J,K)*POINTS(K,M) 25 CONTINUE 30 CONTINUE CALL UNIT (MODIFY,TEMPV) IF (ABS(TEMPV(3)).LE.0.5) THEN XIP(M,I)=ACOS(TEMPV(3)) ELSE EQUPAR=SQRT((1.D0*TEMPV(1))**2+(1.D0*TEMPV(2))**2) XIP(M,I)=ATAN2F(EQUPAR,TEMPV(3)) ENDIF YIP(M,I)=ATAN2F(TEMPV(2),TEMPV(1)) 40 CONTINUE 50 CONTINUE C C IF NEEDED, DECIDE WHICH POINTS ARE 'CONTINENTAL' C (A DISTINCTION THAT MATTERS ONLY IF ICONVE=4), C USING ZMOHO AS TEMPORARY STORAGE FOR INTERPOLATED ELEVATION, C AND TLINT AS TEMPORARY STORAGE FOR INTERPOLATED HEATFLOW: C IF (ICONVE.EQ.4) THEN CALL INTERP (INPUT,ELEV,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,ZMOHO) CALL INTERP (INPUT,DQDTDA,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,TLINT) DO 52 M=1,7 DO 51 I=1,NUMEL CONTIN(M,I)=(ZMOHO(M,I).GT.-2500.).AND. + (TLINT(M,I).LT.0.150) C NOTE: HEAT-FLOW LIMIT EXCLUDES ICELAND, AFAR. 51 CONTINUE 52 CONTINUE END IF C WRITE (IUNITT,59) 59 FORMAT (/' ============================================='/) C C-------------------------------------------------------------- C HAVENV=.FALSE. HAVEOV=.FALSE. NOWTIM=1 C C INPUT VELOCITIES AT NODE POINTS C NEEDSV=DOPLOT(10).OR.DOPLOT(11).OR.DOPLOT(12).OR. + DOPLOT(13).OR.DOPLOT(14).OR.DOPLOT(15).OR. + DOPLOT(16).OR.DOPLOT(17).OR.DOPLOT(18).OR. + DOPLOT(20) IF (NEEDSV) THEN WRITE (IUNITT,60) IUNITV 60 FORMAT (/' Attempting to read VELOCITIES OF NODES from ', + 'unit ',I2/) OPEN (UNIT = IUNITV, FILE = ' ', STATUS = 'OLD') CALL OLDVEL (INPUT,IUNITT,IUNITV,MXNODE,NUMNOD, + OUTPUT,HAVENV,TITLE1,TITLE2,TITLE3,V) CALL CHOP (INPUT,TITLE1, + OUTPUT,TITLE4) CALL CHOP (INPUT,TITLE3, + OUTPUT,TITLE6) ENDIF C C COMPUTE LOWER-MANTLE VELOCITIES, IF REQUIRED C NEEDVM=DOPLOT(9).OR.DOPLOT(10) IF (NEEDVM) THEN IF ((ICONVE.EQ.3).OR.(ICONVE.EQ.4)) THEN CALL GETNUV (INPUT,IUNITM,IUNITT,NAMES,NPBND,NPLATE, + OUTPUT,NDPLAT,PLAT,PLON) ENDIF CALL CONVEC (INPUT,ICONVE,IPVREF,IUNITM,IUNITT, + MXEL,MXFEL,MXNODE, + NAMES,NDPLAT, + NFL,NODEF,NODES, + NPBND,NPLATE,NUMEL,NUMNOD, + OMEGA,PLAT,PLON,RADIUS,VTIMES, + XNODE,YNODE, + OUTPUT,VM, + WORK,CHECKN) ENDIF C C COMPUTE GEOTHERMS OF INTEGRATIONS POINTS, IF REQUIRED C NEEDGE=DOPLOT(8).OR.DOPLOT(10).OR.DOPLOT(17).OR.DOPLOT(20) IF (NEEDGE) THEN CALL INTERP (INPUT,ZMNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,ZMOHO) CALL INTERP (INPUT,TLNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,TLINT) CALL LIMITS (INPUT,AREA,DETJ,IUNITT,MXEL,NUMEL, + OKDELV,RADIUS,REFSTR,SPHERE, + TLINT,TRHMAX,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) DO 80 M=1,7 DO 75 I=1,NUMEL N1=NODES(1,I) N2=NODES(2,I) N3=NODES(3,I) Q=DQDTDA(N1)*POINTS(1,M)+DQDTDA(N2)*POINTS(2,M)+ + DQDTDA(N3)*POINTS(3,M) GEOTHC(1,M,I)=TSURF GEOTHC(2,M,I)=Q/CONDUC(1) GEOTHC(3,M,I)= -RADIO(1)/(2.*CONDUC(1)) GEOTHC(4,M,I)=0. GEOTHM(1,M,I)=GEOTHC(1,M,I)+ + GEOTHC(2,M,I)*ZMOHO(M,I)+ + GEOTHC(3,M,I)*ZMOHO(M,I)**2 QM=Q-ZMOHO(M,I)*RADIO(1) GEOTHM(2,M,I)=QM/CONDUC(2) GEOTHM(3,M,I)= -RADIO(2)/(2.*CONDUC(2)) GEOTHM(4,M,I)=0. 75 CONTINUE 80 CONTINUE ENDIF C C COMPUTE GLUE, IF REQUIRED C NEEDGL=DOPLOT(10) IF (NEEDGL) THEN CALL ONEBAR (INPUT,ACREEP,BCREEP,CCREEP, + ECREEP,GEOTHC,GEOTHM,GRADIE, + IUNITT,MXEL,NUMEL,ONEKM,TADIAB, + ZBASTH,ZMOHO, + OUTPUT,GLUE) ENDIF C C COMPUTE WHETHER FAULTS SLIP, IF NEEDED C NEEDFS=DOPLOT(14).OR.DOPLOT(15) IF (NEEDFS) THEN C prepare additional arrays needed by MOHR: C first, prepare ZMOHO and TLINT, needed by LIMITS CALL INTERP (INPUT,ZMNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,ZMOHO) CALL INTERP (INPUT,TLNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,TLINT) C then, call LIMITS to get CONSTR, FMUMAX CALL LIMITS (INPUT,AREA,DETJ,IUNITT,MXEL,NUMEL, + OKDELV,RADIUS,REFSTR,SPHERE, + TLINT,TRHMAX,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) C give reasonable initial guesses for ZTRANF C (MOHR will adjust) DO 88 I=1,NFL ZTRANF(1,I)=(ZMNODE(NODEF(1,I))+ + ZMNODE(NODEF(2,I)))/4.0 ZTRANF(2,I)=(TLNODE(NODEF(1,I))+ + TLNODE(NODEF(2,I)))/4.0 88 CONTINUE C call MOHR to compute LOGICAL array FSLIPS: WRITE (*,89) 89 FORMAT(/' Making 5 calls to MOHR to see which faults ', + 'locked...') DO 90 KITER=1,5 C NOTE: REPEATED CALLS ALLOW ZTRANF TO STABILIZE CALL MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP, + DQDTDA,ECREEP,ELEV,FDIP,FFRIC,FMUMAX, + FPFLT,FARG,GMEAN, + MXFEL,MXNODE,NFL,NODEF, + OFFMAX,OFFSET, + ONEKM,RADIO,RHOH2O,RHOBAR, + SLIDE,SPHERE,TAUMAX, + TLNODE,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) 90 CONTINUE END IF C C COMPUTE STRESS IN CONTINUUM ELEMENTS, IF NEEDED: C NEEDST=DOPLOT(17).OR.DOPLOT(20) IF (NEEDST) THEN C find strain-rate at continuum integration points CALL EDOT (INPUT,DXS,DYS, + FPSFER,MXEL, + MXNODE,NODES,NUMEL,RADIUS,SITA,V, + OUTPUT,ERATE) DO 94 M=1,7 DO 93 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. 93 CONTINUE 94 CONTINUE C NOTE: Special version for OrbMapAI reports additional C array LIMTED. 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, + LIMTED) CALL TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) END IF C C=============== BEGIN LIST OF PLOTS ======================= C C PLOT THE FINITE ELEMENT GRID C IF (DOPLOT(1)) THEN WRITE (IUNITT,100) 100 FORMAT (/' Working on plot of FINITE ELEMENT GRID...') DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) CALL ANYMAP (ICOAST,DEGWID) CALL ETCH (COLOR,CUTLN1,CUTLN2, + FDIP,FLEN,FARG, + IPEN1,IPEN2,IPEN3, + MXFEL,MXNODE, + NFL,NODEF,NODES,NUMEL,NUMNOD, + RADIUS,SLIDE,WEDGE, + XNODE,YNODE) CALL FRAME (DOGRID) CALL HEADIN (TEXT(1),NVCHAR(1),1.,2) CALL HEADIN (TITLE4,100,1.,2) CALL ENDPL (0) WRITE (IUNITT,199) 199 FORMAT (/' ==============================================' + /' PLOT OF FINITE ELEMENT GRID COMPLETED.' + /' =============================================='/) DOPLOT(1)=.FALSE. ENDIF C C PLOT ELEVATIONS (FOR -SHELLS-), C OR LOG10(SIGMA OF ZERO STRAINRATE) (-RESTORE-) C OR LOG10(SMOOTHED SEISMIC OR MODEL STRAINRATE) (-ORBSCORE-) C IF (DOPLOT(2)) THEN WRITE (IUNITT,200) 200 FORMAT (/' Working on plot of ELEVATIONS (-SHELLS-)', + /' or log10(strainrate) (-RESTORE-, -ORBSCORE-)...') TOP=ELEV(1) BOT=ELEV(1) DO 202 I=2,NUMNOD TOP=MAX(TOP,ELEV(I)) BOT=MIN(BOT,ELEV(I)) 202 CONTINUE C C DECIDE WHETHER DATA ARE STRAIN-RATES (E.G., 1.E-17), OR ELEVATIONS DOMU=(BOT.GT.0.).AND.(TOP.LE.1.) C DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) DFC=CINT(2) IF ((DFC.LE.0.0).OR.(FBLAND(2).EQ.0.0)) THEN TOP=ELEV(1) BOT=ELEV(1) DO 210 I=2,NUMNOD TOP=MAX(TOP,ELEV(I)) BOT=MIN(BOT,ELEV(I)) 210 CONTINUE IF (DOMU) THEN TOP=ALOG10(TOP) BOT=ALOG10(BOT) ENDIF IF (DFC.LE.0.0) THEN DFC=MAX(1.E-5,(TOP-BOT)/(1.*NCONTR)) DFC=ROUND(DFC) END IF IF (FBLAND(2).EQ.0.0) THEN N=NINT((TOP+BOT)/(2.*DFC)) FBLAND(2)=N*DFC ENDIF END IF N=NINT(FBLAND(2)/DFC) FBLAND(2)=N*DFC IF (LOWBLU(2).NE.-1) LOWBLU(2)=+1 C EDGEIT=.TRUE. IF (DOMU) THEN VMULT=1. DO 220 I=1,NUMNOD MULOG(I)=ALOG10(ELEV(I)) 220 CONTINUE CALL SCALAR (INPUT,MULOG, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND( 2),LOWBLU( 2), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT, + WORK,ICYCLE, + XARAY,XARRAY,YARAY,YARRAY) ELSE C FOLLOWING STATEMENT CONVERTS M TO KM (ASSUMES SI) VMULT=0.001 CALL SCALAR (INPUT,ELEV, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND( 2),LOWBLU( 2), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT, + WORK,ICYCLE, + XARAY,XARRAY,YARAY,YARRAY) ENDIF CALL ANYMAP(ICOAST,DEGWID) CALL FRAME (DOGRID) IF (DOMU) THEN CALL HEADIN (TEXT(21),NVCHAR(21),1.,2) ELSE CALL HEADIN (TEXT(2),NVCHAR(2),1.,2) ENDIF CALL HEADIN (TITLE4,100,1.,2) IF (DOMU) THEN CALL BAR(INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU(2), + MXPNTS,NVUCHR(20),VMULT,VUNITS(20),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) ELSE CALL BAR(INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU(2), + MXPNTS,NVUCHR(2),VMULT,VUNITS(2),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) ENDIF CALL ENDPL (0) WRITE (IUNITT,299) 299 FORMAT (/' =============================', + '==============================' + /' Plot of Elevations (-SHELLS-)', + /' or log10(strainrate) (-RESTORE-, -ORBSCORE-)' + /' COMPLETED.' + /' =============================', + '=============================='/) DOPLOT(2)=.FALSE. ENDIF C C PLOT HEAT FLOW C IF (DOPLOT(3)) THEN WRITE (IUNITT,300) 300 FORMAT (/' Working on plot of HEAT-FLOW...') DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) DFC=CINT(3) IF ((CINT(3).LE.0.0).OR.(FBLAND(3).LE.0.0)) THEN TOP=DQDTDA(1) BOT=DQDTDA(1) DO 310 I=2,NUMNOD TOP=MAX(TOP,DQDTDA(I)) BOT=MIN(BOT,DQDTDA(I)) 310 CONTINUE IF (DFC.LE.0.0) THEN DFC=MAX(1.E-5,(TOP-BOT)/(1.*NCONTR)) DFC=ROUND(DFC) ENDIF IF (FBLAND(3).LE.0.0) THEN N=NINT((TOP+BOT)/(2.*DFC)) FBLAND(3)=N*DFC ENDIF ENDIF N=NINT(FBLAND(3)/DFC) FBLAND(3)=N*DFC IF (LOWBLU(3).NE.-1) LOWBLU(3)=+1 C C FOLLOWING STATEMENT CONVERTS W/M**2 TO MILLI-W/M**2 C VMULT=1000. C EDGEIT=.TRUE. CALL SCALAR (INPUT,DQDTDA, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND( 3),LOWBLU( 3), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT, + WORK,ICYCLE, + XARAY,XARRAY,YARAY,YARRAY) CALL ANYMAP(ICOAST,DEGWID) CALL FRAME (DOGRID) CALL HEADIN (TEXT(3),NVCHAR(3),1.,2) CALL HEADIN (TITLE4,100,1.,2) CALL BAR (INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU( 3), + MXPNTS,NVUCHR( 3),VMULT,VUNITS( 3),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) CALL ENDPL (0) WRITE (IUNITT,399) 399 FORMAT (/' ==============================================' + /' PLOT OF HEAT-FLOW COMPLETED.' + /' =============================================='/) DOPLOT(3)=.FALSE. ENDIF C C PLOT CRUSTAL THICKNESS C IF (DOPLOT(4)) THEN WRITE (IUNITT,400) 400 FORMAT (/' Working on plot of CRUSTAL THICKNESS...') DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) DFC=CINT(4) IF ((DFC.LE.0.0).OR.(FBLAND(4).LE.0.0)) THEN TOP=ZMNODE(1) BOT=ZMNODE(1) DO 410 I=2,NUMNOD TOP=MAX(TOP,ZMNODE(I)) BOT=MIN(BOT,ZMNODE(I)) 410 CONTINUE IF (DFC.LE.0.0) THEN DFC=MAX(1.E-5,(TOP-BOT)/(1.*NCONTR)) DFC=ROUND(DFC) ENDIF IF (FBLAND(4).LE.0.0) THEN N=NINT((TOP+BOT)/(2.*DFC)) FBLAND(4)=N*DFC ENDIF ENDIF N=NINT(FBLAND(4)/DFC) FBLAND(4)=N*DFC IF (LOWBLU(4).NE.-1) LOWBLU(4)=+1 C C FOLLOWING STATEMENT CONVERTS M TO KM (ASSUMES SI) C VMULT=0.001 C EDGEIT=.TRUE. CALL SCALAR (INPUT,ZMNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND( 4),LOWBLU( 4), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT, + WORK,ICYCLE, + XARAY,XARRAY,YARAY,YARRAY) CALL ANYMAP(ICOAST,DEGWID) CALL FRAME (DOGRID) CALL HEADIN (TEXT(4),NVCHAR(4),1.,2) CALL HEADIN (TITLE4,100,1.,2) CALL BAR (INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU( 4), + MXPNTS,NVUCHR( 4),VMULT,VUNITS( 4),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) CALL ENDPL (0) WRITE (IUNITT,499) 499 FORMAT (/' ==============================================' + /' PLOT OF CRUSTAL THICKNESS COMPLETED.' + /' =============================================='/) DOPLOT(4)=.FALSE. ENDIF C C PLOT TOTAL LITHOSPHERE THICKNESS C IF (DOPLOT(5)) THEN WRITE (IUNITT,500) 500 FORMAT (/' Working on plot of TOTAL LITHOSPHERE', + ' THICKNESS...') DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) DO 501 I=1,NUMNOD ATNODE(I)=ZMNODE(I)+TLNODE(I) 501 CONTINUE DFC=CINT(5) IF ((DFC.LE.0.0).OR.(FBLAND(5).LE.0.0)) THEN TOP=ATNODE(1) BOT=ATNODE(1) DO 510 I=2,NUMNOD TOP=MAX(TOP,ATNODE(I)) BOT=MIN(BOT,ATNODE(I)) 510 CONTINUE IF (DFC.LE.0.0) THEN DFC=MAX(1.E-5,(TOP-BOT)/(1.*NCONTR)) DFC=ROUND(DFC) ENDIF IF (FBLAND(5).LE.0.0) THEN N=NINT((TOP+BOT)/(2.*DFC)) FBLAND(5)=N*DFC ENDIF ENDIF N=NINT(FBLAND(5)/DFC) FBLAND(5)=N*DFC IF (LOWBLU(5).NE.-1) LOWBLU(5)=+1 C C FOLLOWING STATEMENT CONVERTS M TO KM (ASSUMES SI) C VMULT=0.001 C EDGEIT=.TRUE. CALL SCALAR (INPUT,ATNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND( 5),LOWBLU( 5), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT, + WORK,ICYCLE, + XARAY,XARRAY,YARAY,YARRAY) CALL ANYMAP(ICOAST,DEGWID) CALL FRAME (DOGRID) CALL HEADIN (TEXT(5),NVCHAR(5),1.,2) CALL HEADIN (TITLE4,100,1.,2) CALL BAR (INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU( 5), + MXPNTS,NVUCHR( 5),VMULT,VUNITS( 5),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) CALL ENDPL (0) WRITE (IUNITT,599) 599 FORMAT (/' ==============================================' + /' PLOT OF TOTAL LITHOSPHERE THICKNESS COMPLETED.' + /' =============================================='/) DOPLOT(5)=.FALSE. ENDIF C C PLOT TEMPERATURE OF THE MOHO C IF (DOPLOT(6)) THEN WRITE (IUNITT,600) 600 FORMAT (/' Working on plot of MOHO TEMPERATURE...') DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) DO 601 I=1,NUMNOD ATNODE(I)=TSURF+(DQDTDA(I)/CONDUC(1))*ZMNODE(I)- + 0.5*ZMNODE(I)**2*RADIO(1)/CONDUC(1) ATNODE(I)=MIN(ATNODE(I),TEMLIM(1)) C FOLLOWING STATEMENT CONVERTS K TO C: ATNODE(I)=ATNODE(I)-273. 601 CONTINUE DFC=CINT(6) IF ((DFC.LE.0.0).OR.(FBLAND(6).LE.0.0)) THEN TOP=ATNODE(1) BOT=ATNODE(1) DO 610 I=2,NUMNOD TOP=MAX(TOP,ATNODE(I)) BOT=MIN(BOT,ATNODE(I)) 610 CONTINUE IF (DFC.LE.0.0) THEN DFC=MAX(1.E-5,(TOP-BOT)/(1.*NCONTR)) DFC=ROUND(DFC) ENDIF IF (FBLAND(6).LE.0.0) THEN N=NINT((TOP+BOT)/(2.*DFC)) FBLAND(6)=N*DFC ENDIF ENDIF N=NINT(FBLAND(6)/DFC) FBLAND(6)=N*DFC IF (LOWBLU(6).NE.-1) LOWBLU(6)=+1 C VMULT=1. C EDGEIT=.TRUE. CALL SCALAR (INPUT,ATNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND( 6),LOWBLU( 6), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT, + WORK,ICYCLE, + XARAY,XARRAY,YARAY,YARRAY) CALL ANYMAP(ICOAST,DEGWID) CALL FRAME (DOGRID) CALL HEADIN (TEXT(6),NVCHAR(6),1.,2) CALL HEADIN (TITLE4,100,1.,2) CALL BAR (INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU( 6), + MXPNTS,NVUCHR( 6),VMULT,VUNITS( 6),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) CALL ENDPL (0) WRITE (IUNITT,699) 699 FORMAT (/' ==============================================' + /' PLOT OF MOHO TEMPERATURE COMPLETED.' + /' =============================================='/) DOPLOT(6)=.FALSE. ENDIF C C PLOT TEMPERATURE OF THE BASE OF THE LITHOSPHERE C IF (DOPLOT(7)) THEN WRITE (IUNITT,700) 700 FORMAT (/' Working on plot of TEMPERATURE AT BASE OF', + ' PLATE...') DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) DO 701 I=1,NUMNOD ATNODE(I)=TSURF+ + (DQDTDA(I)/CONDUC(1))*ZMNODE(I)- + (0.5*RADIO(1)/CONDUC(1))*ZMNODE(I)**2+ + ((DQDTDA(I)-ZMNODE(I)*RADIO(1))/CONDUC(2))*TLNODE(I)- + (0.5*RADIO(2)/CONDUC(2))*TLNODE(I)**2 ATNODE(I)=MIN(ATNODE(I),TEMLIM(2)) C FOLLOWING STATEMENT CONVERTS K TO C: ATNODE(I)=ATNODE(I)-273. 701 CONTINUE DFC=CINT(7) IF ((DFC.LE.0.0).OR.(FBLAND(7).LE.0.0)) THEN TOP=ATNODE(1) BOT=ATNODE(1) DO 710 I=2,NUMNOD TOP=MAX(TOP,ATNODE(I)) BOT=MIN(BOT,ATNODE(I)) 710 CONTINUE IF (DFC.LE.0.0) THEN DFC=MAX(1.E-5,(TOP-BOT)/(1.*NCONTR)) DFC=ROUND(DFC) ENDIF IF (FBLAND(7).LE.0.0) THEN N=NINT((TOP+BOT)/(2.*DFC)) FBLAND(7)=N*DFC ENDIF ENDIF N=NINT(FBLAND(7)/DFC) FBLAND(7)=N*DFC IF (LOWBLU(7).NE.-1) LOWBLU(7)=+1 C VMULT=1. C EDGEIT=.TRUE. CALL SCALAR (INPUT,ATNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND( 7),LOWBLU( 7), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT, + WORK,ICYCLE, + XARAY,XARRAY,YARAY,YARRAY) CALL ANYMAP(ICOAST,DEGWID) CALL FRAME (DOGRID) CALL HEADIN (TEXT(7),NVCHAR(7),1.,2) CALL HEADIN (TITLE4,100,1.,2) CALL BAR (INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU( 7), + MXPNTS,NVUCHR( 7),VMULT,VUNITS( 7),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) CALL ENDPL (0) WRITE (IUNITT,799) 799 FORMAT (/' ==============================================' + /' PLOT OF TEMPERATURE AT BASE OF PLATE COMPLETED.' + /' =============================================='/) DOPLOT(7)=.FALSE. ENDIF C C PLOT PRESSURE ANOMALY AT BASE OF LITHOSPHERE C (USING NODAL VALUES, CONSISTENT WITH TREATMENT IN ORBDATA, ALSO C BECAUSE IT GIVES AN ATTRACTIVE, COLORED, CONTINUOUS PLOT) C IF (DOPLOT(8)) THEN WRITE (IUNITT,800) 800 FORMAT (/' Working on plot of PRESSURE ANOMALY AT BASE ', + 'OF PLATE...') DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) DO 801 I=1,NUMNOD ELEVAT=ELEV(I) GEOTH1=TSURF GEOTH2=DQDTDA(I)/CONDUC(1) GEOTH3= -RADIO(1)/(2.*CONDUC(1)) GEOTH4=0.0 GEOTH5=TSURF+(DQDTDA(I)/CONDUC(1))*ZMNODE(I)- + 0.5*ZMNODE(I)**2*RADIO(1)/CONDUC(1) GEOTH6=(DQDTDA(I)-ZMNODE(I)*RADIO(1))/CONDUC(2) GEOTH7= -RADIO(2)/(2.*CONDUC(2)) GEOTH8=0.0 ZM=ZMNODE(I) ZSTOP=ZMNODE(I)+TLNODE(I) CALL SQUEEZ (INPUT,ALPHAT,ELEVAT, + GEOTH1,GEOTH2,GEOTH3,GEOTH4, + GEOTH5,GEOTH6,GEOTH7,GEOTH8, + GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, + TEMLIM,ZM,ZSTOP, + OUTPUT,TAUZZ,SIGZZB) ATNODE(I)= -SIGZZB 801 CONTINUE DFC=CINT(8) IF ((DFC.LE.0.0).OR.(FBLAND(8).LE.0.0)) THEN TOP=ATNODE(1) BOT=ATNODE(1) DO 810 I=2,NUMNOD TOP=MAX(TOP,ATNODE(I)) BOT=MIN(BOT,ATNODE(I)) 810 CONTINUE IF (DFC.LE.0.0) THEN DFC=MAX(1.E-5,(TOP-BOT)/(1.*NCONTR)) DFC=ROUND(DFC) ENDIF IF (FBLAND(8).LE.0.0) THEN N=NINT((TOP+BOT)/(2.*DFC)) FBLAND(8)=N*DFC ENDIF ENDIF N=NINT(FBLAND(8)/DFC) FBLAND(8)=N*DFC IF (LOWBLU(8).NE.-1) LOWBLU(8)=+1 C C FOLLOWING STATEMENT CONVERTS PA TO MPA (ASSUMING SI) VMULT=1.E-6 C EDGEIT=.TRUE. CALL SCALAR (INPUT,ATNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND( 8),LOWBLU( 8), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT, + WORK,ICYCLE, + XARAY,XARRAY,YARAY,YARRAY) CALL ANYMAP(ICOAST,DEGWID) CALL FRAME (DOGRID) CALL HEADIN (TEXT(8),NVCHAR(8),1.,2) CALL HEADIN (TITLE4,100,1.,2) CALL BAR (INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU( 8), + MXPNTS,NVUCHR( 8),VMULT,VUNITS( 8),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) CALL ENDPL (0) WRITE (IUNITT,899) 899 FORMAT (/' ==============================================' + /' PLOT OF PRESSURE ANOMALY AT BASE OF PLATE' + ,' COMPLETED.' + /' =============================================='/) DOPLOT(8)=.FALSE. ENDIF C C PLOT VELOCITIES OF LOWER MANTLE, BELOW ASTHENOSPHERE C IF (DOPLOT(9).AND.(ICONVE.NE.0)) THEN WRITE (IUNITT,900) 900 FORMAT (/' Working on plot of LOWER-MANTLE VELOCITY...') CALL CULL(INPUT,NUMNOD,'vectors',OUTPUT,NTH) DOGRID=((.NOT.COLOR).AND.(ICOAST.NE.2)).OR.(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) IF (COLOR) THEN DO 910 I=1,NUMNOD VNODE(1,I)=VM(1,I) VNODE(2,I)=VM(2,I) ATNODE(I)=SQRT(VM(1,I)**2+VM(2,I)**2) 910 CONTINUE DFC=CINT(9) IF ((DFC.LE.0.0).OR.(FBLAND(9).LE.0.0)) THEN TOP=ATNODE(1) BOT=ATNODE(1) DO 920 I=2,NUMNOD TOP=MAX(TOP,ATNODE(I)) BOT=MIN(BOT,ATNODE(I)) 920 CONTINUE IF (DFC.LE.0.0) THEN DFC=MAX(1.E-15,(TOP-BOT)/(1.*NCONTR)) C C FOLLOWING STATEMENTS GIVE CONTOUR INTERVAL C IN EVEN NUMBER OF MM/YEAR; C TO DISABLE (USE NATIVE UNITS) SET VMULT=1. VMULT=1000.*SECPYR DFC=ROUND(VMULT*DFC)/VMULT C ENDIF IF (FBLAND(9).LE.0.0) THEN FBLAND(9)=5.*DFC ENDIF ENDIF N=NINT(FBLAND(9)/DFC) FBLAND(9)=N*DFC IF (LOWBLU(9).NE.-1) LOWBLU(9)=+1 C EDGEIT=.FALSE. CALL PROJEC (INPUT,VNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND(9),LOWBLU(9), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT) ENDIF CALL ANYMAP(ICOAST,DEGWID) FROM=.TRUE. SUM=0. DO 940 I=1,NUMNOD SUM=SUM+VM(1,I)**2+VM(2,I)**2 940 CONTINUE DELTAT=RADIUS*PIO180*RMSVEC/SQRT(SUM/NUMNOD) CALL BGROUP IF (.NOT.COLOR) CALL THKVEC (2.) DO 950 I=1,NUMNOD IF (MOD(I,NTH).EQ.0) THEN THETA=XNODE(I) PHI=YNODE(I) SIZE=DELTAT*SQRT(VM(1,I)**2+VM(2,I)**2)/RADIUS VT=VM(1,I) VP=VM(2,I) AZIM=PI-ATAN2F(VP,VT) BARIT=.FALSE. CALL ARROW (INPUT,THETA,PHI,SIZE,AZIM, + MAPTYP,POLEP,POLET,DEGWID,FROM,BARIT) END IF 950 CONTINUE CALL EGROUP IF (.NOT.COLOR) CALL RESET ('THKVEC') CALL FRAME (DOGRID) CALL HEADIN (TEXT(9),NVCHAR(9),1.,2) CALL HEADIN (TITLE4,100,1.,2) IF (COLOR) THEN VMULT=1000.*SECPYR CALL BAR(INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU(9), + MXPNTS,NVUCHR(9),VMULT,VUNITS(9),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) ELSE YBASE=0.7 ENDIF IF (COLOR) THEN IF (LAND) THEN XMID=9.7 ELSE XMID=7.6 ENDIF ELSE XMID=XWIDE/2. ENDIF YMID=YBASE+0.3 IF (.NOT.COLOR) CALL THKVEC (2.) CALL VECTOR (XMID-0.1968,YMID,XMID+0.1968,YMID,1121) IF (.NOT.COLOR) CALL RESET ('THKVEC') SAMPLE=0.3937*DEGPEI*PIO180*RADIUS/DELTAT C CONVERT FROM M/S (?) TO MM/YEAR: SAMPLE=SAMPLE*1000.*SECPYR CALL ANGLE (0.) CALL RESET ('ALNMES') CALL REALNO (SAMPLE,+1,XMID-0.3,YBASE) CALL MESSAG (' '//VUNITS(9),NVUCHR(9)+1,ABUT,ABUT) CALL ENDPL (0) WRITE (IUNITT,998) 998 FORMAT (/' ==============================================' + /' PLOT OF LOWER-MANTLE VELOCITY COMPLETED.' + /' =============================================='/) ELSE IF (DOPLOT(9)) THEN WRITE (IUNITT,999) 999 FORMAT (/' ==============================================' + /' LOWER-MANTLE VELOCITY IS ZERO; NOT PLOTTED.' + /' =============================================='/) ENDIF C C - - - - - - - - LOOP RETURNS TO THIS POINT FROM END OF MAIN - - C NOTE THAT PLOTS IN THE FOLLOWING GROUP DEPEND ON THE VELOCITY C SOLUTION, AND THAT THERE MAY BE MANY IN SEQUENCE IN THE FILE, C AND THAT SOMETIMES WE ONLY WANT TO PLOT ONE OF THEM (E.G., LAST). C 1000 CONTINUE IF ((KTIME.EQ.0).OR.(NOWTIM.EQ.KTIME)) THEN C C PLOT TRACTION ON THE BASE OF THE PLATE C IF (DOPLOT(10)) THEN WRITE (IUNITT,1001) 1001 FORMAT (/' Working on plot of BASAL TRACTIONS...') CALL CULL(INPUT,NUMEL,'vectors',OUTPUT,NTH) CALL FLOW (INPUT,FPSFER,MXEL,MXNODE,NODES,NUMEL,VM, + OUTPUT,OVB) CALL THONB (INPUT,CONTIN,ECREEP,ETAMAX, + FPSFER,GLUE,ICONVE, + MXEL,MXNODE,NODES,NUMEL, + OVB,TRHMAX,V, + OUTPUT,CHECKE,DVB,SIGHB, + WORK,OUTVEC) DOGRID=(ICOAST.NE.2).OR.(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) CALL ANYMAP(ICOAST,DEGWID) FROM=.TRUE. SUM=0. DO 1040 I=1,NUMEL SUM=SUM+SIGHB(1,1,I)**2+SIGHB(2,1,I)**2 1040 CONTINUE SUM=MAX(SUM,1.) DELTAT=RADIUS*PIO180*RMSVEC/SQRT(SUM/NUMEL) CALL BGROUP DO 1050 I=1,NUMEL IF (MOD(I,NTH).EQ.0) THEN THETA=XIP(1,I) PHI =YIP(1,I) SIZE=DELTAT*SQRT((1.D0*SIGHB(1,1,I))**2+ + (1.D0*SIGHB(2,1,I))**2)/ + RADIUS VT=SIGHB(1,1,I) VP=SIGHB(2,1,I) AZIM=PI-ATAN2F(VP,VT) BARIT=CHECKE(I) CALL ARROW (INPUT,THETA,PHI,SIZE,AZIM, + MAPTYP,POLEP,POLET,DEGWID,FROM,BARIT) END IF 1050 CONTINUE CALL EGROUP CALL FRAME (DOGRID) IF (KTIME.EQ.0) THEN STEPID(1:5)='STEP ' WRITE (TIMCHR,'(I3)') NOWTIM STEPID(6:8)=TIMCHR STEPID(9:9)='$' CALL HEADIN (TEXT(10),NVCHAR(10),1.,3) CALL HEADIN (TITLE6,100,1.,3) CALL HEADIN (STEPID,100,1.,3) ELSE CALL HEADIN (TEXT(10),NVCHAR(10),1.,2) CALL HEADIN (TITLE6,100,1.,2) ENDIF XMID=XWIDE*0.4 C SAMPLE VECTOR: SIMPLE CALL VECTOR (XMID-0.3937,1.05,XMID,1.05,1121) C SAMPLE VECTOR: BARRED CALL VECTOR (XMID-0.3937,0.75,XMID,0.75,1121) CALL VECTOR (XMID,0.85,XMID,0.65,0) C NUMERICAL LABEL BELOW SAMPLE=0.3937*DEGPEI*PIO180*RADIUS/DELTAT C CONVERT FROM PA (?) TO MPA UNITS SAMPLE=SAMPLE/1.E6 CALL RESET ('HEIGHT') CALL ANGLE (0.) CALL RESET ('ALNMES') CALL REALNO (SAMPLE,-1,XMID-0.6,0.5) CALL MESSAG (' '//VUNITS(10),NVUCHR(10)+1,ABUT,ABUT) CALL MESSAG (' based on olivine rheology',27,XMID,1.0) CALL MESSAG (' limited by maximum viscosity',30,XMID,0.7) CALL ENDPL (0) WRITE (IUNITT,1099) 1099 FORMAT (/' ==============================================' + /' PLOT OF BASAL TRACTIONS COMPLETED.' + /' =============================================='/) ENDIF C C PLOT VELOCITY VECTORS C IF (DOPLOT(11)) THEN WRITE (IUNITT,1100) 1100 FORMAT (/' Working on plot of SURFACE VELOCITY...') CALL CULL(INPUT,NUMNOD,'vectors',OUTPUT,NTH) DOGRID=((.NOT.COLOR).AND.(ICOAST.NE.2)).OR.(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) IF (COLOR) THEN DO 1110 I=1,NUMNOD VNODE(1,I)=V(1,I) VNODE(2,I)=V(2,I) ATNODE(I)=SQRT(V(1,I)**2+V(2,I)**2) 1110 CONTINUE DFC=CINT(11) IF ((DFC.LE.0.0).OR.(FBLAND(11).LE.0.0)) THEN TOP=ATNODE(1) BOT=ATNODE(1) DO 1120 I=2,NUMNOD TOP=MAX(TOP,ATNODE(I)) BOT=MIN(BOT,ATNODE(I)) 1120 CONTINUE IF (DFC.LE.0.0) THEN DFC=MAX(1.E-15,(TOP-BOT)/(1.*NCONTR)) C C FOLLOWING STATEMENTS GIVE CONTOUR INTERVAL C IN MULTIPLES OF 1 OR 0.1 OR 0.01 MM/YEAR; C TO DISABLE (USE NATIVE UNITS) SET VMULT=1. VMULT=1000.*SECPYR IF ((VMULT*DFC).GT.1) THEN DFC=ROUND(VMULT*DFC)/VMULT ELSE IF ((VMULT*DFC).GT.0.1) THEN DFC=0.1*ROUND(10.*VMULT*DFC)/VMULT ELSE DFC=0.01*ROUND(100.*VMULT*DFC)/VMULT ENDIF C ENDIF IF (FBLAND(11).LE.0.0) THEN FBLAND(11)=5.*DFC ENDIF ENDIF N=NINT(FBLAND(11)/DFC) FBLAND(11)=N*DFC IF (LOWBLU(11).NE.-1) LOWBLU(11)=+1 C EDGEIT=.FALSE. CALL PROJEC (INPUT,VNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND(11),LOWBLU(11), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT) ELSE C SHOW FAULTS SO THAT VECTORS ARE IN CONTEXT C (THERE ARE NO COLORS OR SHADINGS TO SHOW PLATE EDGES) CALL FAULTS (INPUT,COLOR,CUTLN1,CUTLN2, + FARG,FDIP, + IPEN2,KOLOR,MXFEL, + MXNODE,NFL,NODEF,NTIC,DIPSIZ, + SLIDE,WEDGE,XNODE,YNODE) ENDIF CALL ANYMAP(ICOAST,DEGWID) FROM=.TRUE. SUM=0. DO 1140 I=1,NUMNOD SUM=SUM+V(1,I)**2+V(2,I)**2 1140 CONTINUE IF (SUM.GT.0.) THEN DELTAT=RADIUS*PIO180*RMSVEC/SQRT(SUM/NUMNOD) CALL BGROUP DO 1150 I=1,NUMNOD IF (MOD(I,NTH).EQ.0) THEN THETA=XNODE(I) PHI=YNODE(I) SIZE=DELTAT*SQRT(V(1,I)**2+V(2,I)**2)/RADIUS VT=V(1,I) VP=V(2,I) AZIM=PI-ATAN2F(VP,VT) BARIT=.FALSE. CALL ARROW (INPUT,THETA,PHI,SIZE,AZIM, + MAPTYP,POLEP,POLET,DEGWID,FROM, + BARIT) END IF 1150 CONTINUE CALL EGROUP ENDIF CALL FRAME (DOGRID) IF (KTIME.EQ.0) THEN STEPID(1:5)='STEP ' WRITE (TIMCHR,'(I3)') NOWTIM STEPID(6:8)=TIMCHR STEPID(9:9)='$' CALL HEADIN (TEXT(11),NVCHAR(11),1.,3) CALL HEADIN (TITLE6,100,1.,3) CALL HEADIN (STEPID,100,1.,3) ELSE CALL HEADIN (TEXT(11),NVCHAR(11),1.,2) CALL HEADIN (TITLE6,100,1.,2) ENDIF IF (COLOR) THEN VMULT=1000.*SECPYR CALL BAR(INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU(11), + MXPNTS,NVUCHR(11),VMULT,VUNITS(11),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) ELSE YBASE=0.7 ENDIF IF (COLOR) THEN IF (LAND) THEN XMID=9.7 ELSE XMID=7.6 ENDIF ELSE XMID=XWIDE/2. ENDIF YMID=YBASE+0.3 IF (.NOT.COLOR) CALL THKVEC (2.) CALL VECTOR (XMID-0.1968,YMID,XMID+0.1968,YMID,1121) IF (.NOT.COLOR) CALL RESET ('THKVEC') IF (SUM.GT.0.) THEN SAMPLE=0.3937*DEGPEI*PIO180*RADIUS/DELTAT ELSE SAMPLE=0. ENDIF C CONVERT FROM M/S (?) TO MM/YEAR: SAMPLE=SAMPLE*1000.*SECPYR CALL ANGLE (0.) CALL RESET ('ALNMES') IF (SAMPLE.GE.1.) THEN CALL REALNO (SAMPLE,+1,XMID-0.3,YBASE) ELSE CALL REALNO (SAMPLE,-2,XMID-0.3,YBASE) ENDIF CALL MESSAG (' '//VUNITS(11),NVUCHR(11)+1,ABUT,ABUT) CALL ENDPL (0) WRITE (IUNITT,1199) 1199 FORMAT (/' ==============================================' + /' PLOT OF SURFACE VELOCITY COMPLETED.' + /' =============================================='/) ENDIF C C PLOT CHANGE IN VELOCITY VECTORS SINCE PREVIOUS STEP/MODEL C IF (DOPLOT(12).AND.HAVEOV.AND.HAVENV) THEN WRITE (IUNITT,1200) 1200 FORMAT (/' Working on plot of VELOCITY CHANGES...') CALL CULL(INPUT,NUMNOD,'vectors',OUTPUT,NTH) DOGRID=((.NOT.COLOR).AND.(ICOAST.NE.2)).OR.(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) IF (COLOR) THEN DO 1210 I=1,NUMNOD VNODE(1,I)=V(1,I)-V2(1,I) VNODE(2,I)=V(2,I)-V2(2,I) ATNODE(I)=SQRT((V(1,I)-V2(1,I))**2+ + (V(2,I)-V2(2,I))**2) 1210 CONTINUE DFC=CINT(12) IF ((DFC.LE.0.0).OR.(FBLAND(12).LE.0.0)) THEN TOP=ATNODE(1) BOT=ATNODE(1) DO 1220 I=2,NUMNOD TOP=MAX(TOP,ATNODE(I)) BOT=MIN(BOT,ATNODE(I)) 1220 CONTINUE IF (DFC.LE.0.0) THEN DFC=MAX(1.E-25,(TOP-BOT)/(1.*NCONTR)) C C FOLLOWING STATEMENTS GIVE CONTOUR INTERVAL C IN EVEN NUMBER OF MM/YEAR; C TO DISABLE (USE NATIVE UNITS) SET VMULT=1. VMULT=1000.*SECPYR DFC=ROUND(VMULT*DFC)/VMULT C ENDIF IF (FBLAND(12).LE.0.0) THEN FBLAND(12)=5.*DFC ENDIF ENDIF N=NINT(FBLAND(12)/DFC) FBLAND(12)=N*DFC IF (LOWBLU(12).NE.-1) LOWBLU(12)=+1 C EDGEIT=.FALSE. CALL PROJEC (INPUT,VNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND(12),LOWBLU(12), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT) ELSE C SHOW FAULTS SO THAT VECTORS ARE IN CONTEXT C (THERE ARE NO COLORS OR SHADINGS TO SHOW PLATE EDGES) CALL FAULTS (INPUT,COLOR,CUTLN1,CUTLN2, + FARG,FDIP, + IPEN2,KOLOR,MXFEL, + MXNODE,NFL,NODEF,NTIC,DIPSIZ, + SLIDE,WEDGE,XNODE,YNODE) ENDIF CALL ANYMAP(ICOAST,DEGWID) FROM=.TRUE. SUM=0. DO 1230 I=1,NUMNOD VM(1,I)=V(1,I)-V2(1,I) VM(2,I)=V(2,I)-V2(2,I) SUM=SUM+VM(1,I)**2+VM(2,I)**2 1230 CONTINUE IF (SUM.GT.0.) THEN DELTAT=RADIUS*PIO180*RMSVEC/SQRT(SUM/NUMNOD) CALL BGROUP DO 1240 I=1,NUMNOD IF (MOD(I,NTH).EQ.0) THEN THETA=XNODE(I) PHI=YNODE(I) SIZE=DELTAT*SQRT(VM(1,I)**2+VM(2,I)**2)/RADIUS VT=VM(1,I) VP=VM(2,I) AZIM=PI-ATAN2F(VP,VT) BARIT=.FALSE. CALL ARROW (INPUT,THETA,PHI,SIZE,AZIM, + MAPTYP,POLEP,POLET,DEGWID,FROM, + BARIT) END IF 1240 CONTINUE CALL EGROUP ENDIF CALL FRAME (DOGRID) STEPID(1:2)='(V' WRITE (TIMCHR,'(I3)') NOWTIM IF (TIMCHR(1:1).EQ.' ') TIMCHR(1:1)='0' IF (TIMCHR(2:2).EQ.' ') TIMCHR(2:2)='0' STEPID(3:5)=TIMCHR STEPID(6:7)='-V' LASTIM=NOWTIM-1 WRITE (TIMCHR,'(I3)') LASTIM IF (TIMCHR(1:1).EQ.' ') TIMCHR(1:1)='0' IF (TIMCHR(2:2).EQ.' ') TIMCHR(2:2)='0' STEPID(8:10)=TIMCHR STEPID(11:12)=')$' CALL HEADIN (TEXT(12),NVCHAR(12),1.,3) CALL HEADIN (TITLE6,100,1.,3) CALL HEADIN (STEPID,100,1.,3) IF (COLOR) THEN VMULT=1000.*SECPYR CALL BAR(INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU(12), + MXPNTS,NVUCHR(12),VMULT,VUNITS(12),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) ELSE YBASE=0.7 ENDIF IF (COLOR) THEN IF (LAND) THEN XMID=9.7 ELSE XMID=7.6 ENDIF ELSE XMID=XWIDE/2. ENDIF YMID=YBASE+0.3 IF (.NOT.COLOR) CALL THKVEC (2.) CALL VECTOR (XMID-0.1968,YMID,XMID+0.1968,YMID,1121) IF (.NOT.COLOR) CALL RESET ('THKVEC') IF (SUM.GT.0.) THEN SAMPLE=0.3937*DEGPEI*PIO180*RADIUS/DELTAT ELSE SAMPLE=0. ENDIF C CONVERT FROM M/S (?) TO MM/YEAR: SAMPLE=SAMPLE*1000.*SECPYR CALL ANGLE (0.) CALL RESET ('ALNMES') CALL REALNO (SAMPLE,+1,XMID-0.3,YBASE) CALL MESSAG (' '//VUNITS(12),NVUCHR(12)+1,ABUT,ABUT) CALL ENDPL (0) WRITE (IUNITT,1299) 1299 FORMAT (/' ==============================================' + /' PLOT OF VELOCITY CHANGES COMPLETED.' + /' =============================================='/) ENDIF C C PLOT STRAIN RATES C IF (DOPLOT(13)) THEN WRITE (IUNITT,1300) 1300 FORMAT (/' Working on plot of SURFACE STRAIN-RATES...') CALL CULL(INPUT,NUMEL,'symbols',OUTPUT,NTH) CALL EDOT (INPUT,DXS,DYS, + FPSFER,MXEL, + MXNODE,NODES,NUMEL,RADIUS,SITA,V, + OUTPUT,ERATE) DOGRID=(ICOAST.NE.2).OR.(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) CALL ANYMAP(ICOAST,DEGWID) CALL SIZER (INPUT,ERATE,MODESR,NUMEL, + OUTPUT,E3ME1M) IF (E3ME1M.GT.0.) THEN CALL FICONS (INPUT,CUTLN1,CUTLN2,ERATE,E3ME1M,CFRIC, + MAPTYP,MODESR, + NTH,NUMEL,POLE,RMSVEC,XIP,YIP) ENDIF CALL FRAME (DOGRID) IF (KTIME.EQ.0) THEN STEPID(1:5)='STEP ' WRITE (TIMCHR,'(I3)') NOWTIM STEPID(6:8)=TIMCHR STEPID(9:9)='$' CALL HEADIN (TEXT(13),NVCHAR(13),1.,3) CALL HEADIN (TITLE6,100,1.,3) CALL HEADIN (STEPID,100,1.,3) ELSE CALL HEADIN (TEXT(13),NVCHAR(13),1.,2) CALL HEADIN (TITLE6,100,1.,2) ENDIF CALL RESET ('HEIGHT') CALL ALNMES (0.5,0.0) XADD=XWIDE/2.-5.5 C NOTE: RIGHT SYMBOLS ARE 1" LONG, LEFT ARE 0.316" LONG. CALL MESSAG ('normal faulting',15,5.5+XADD,1.0) CALL THKVEC (1.0) CALL VECTOR (4.3437+XADD,1.0625,4.6562+XADD,1.0625,0) CALL VECTOR (4.6562+XADD,1.0625,4.6562+XADD,1.1250,0) CALL VECTOR (4.6562+XADD,1.1250,4.3437+XADD,1.1250,0) CALL VECTOR (4.3437+XADD,1.1250,4.3437+XADD,1.0625,0) CALL VECTOR (6.1953+XADD,1.0000,7.1953+XADD,1.0000,0) CALL VECTOR (7.1953+XADD,1.0000,7.1953+XADD,1.1875,0) CALL VECTOR (7.1953+XADD,1.1875,6.1953+XADD,1.1875,0) CALL VECTOR (6.1953+XADD,1.1875,6.1953+XADD,1.0000,0) CALL MESSAG ('strike-slip faulting',20,5.5+XADD,0.8) CALL VECTOR (4.3516+XADD,0.7813,4.6375+XADD,0.9125,0) CALL VECTOR (4.3516+XADD,0.9125,4.6375+XADD,0.7813,0) CALL VECTOR (6.2500+XADD,0.6316,7.1563+XADD,1.0625,0) CALL VECTOR (6.2500+XADD,1.0625,7.1563+XADD,0.6316,0) CALL MESSAG ('thrust faulting',15,5.5+XADD,0.6) CALL VECTOR (4.3664+XADD,0.5938,4.6399+XADD,0.5938,0) XARAY(1)=4.3438+XADD XARAY(2)=4.3664+XADD XARAY(3)=4.3890+XADD XARAY(4)=XARAY(2) XARAY(5)=XARAY(1) YARAY(1)=0.5938 YARAY(2)=0.5712 YARAY(3)=YARAY(1) YARAY(4)=0.6164 YARAY(5)=YARAY(1) CALL SHADE (XARAY,YARAY,5,90.,GAPRAY,1,K,L) XARAY(1)=4.6173+XADD XARAY(2)=4.6399+XADD XARAY(3)=4.6625+XADD XARAY(4)=XARAY(2) XARAY(5)=XARAY(1) CALL SHADE (XARAY,YARAY,5,90.,GAPRAY,1,K,L) CALL VECTOR (6.2590+XADD,0.5938,7.1379+XADD,0.5938,0) XARAY(1)=6.1875+XADD XARAY(2)=6.2590+XADD XARAY(3)=6.3305+XADD XARAY(4)=XARAY(2) XARAY(5)=XARAY(1) YARAY(1)=0.5938 YARAY(2)=0.5223 YARAY(3)=YARAY(1) YARAY(4)=0.6653 YARAY(5)=YARAY(1) CALL SHADE (XARAY,YARAY,5,90.,GAPRAY,1,K,L) XARAY(1)=7.0664+XADD XARAY(2)=7.1379+XADD XARAY(3)=7.2094+XADD XARAY(4)=XARAY(2) XARAY(5)=XARAY(1) CALL SHADE (XARAY,YARAY,5,90.,GAPRAY,1,K,L) C LINE: "= E3 - E1 =" IS CHOPPED TO DOT E'S AND ENLARGE THEM CALL MESSAG ('=',1,5.0938+XADD,0.3500) CALL MESSAG ('-',1,5.5000+XADD,0.3500) CALL MESSAG ('=',1,5.9063+XADD,0.3500) CALL MESSAG ('3',1,5.3594+XADD,0.2500) CALL MESSAG ('1',1,5.6781+XADD,0.2500) CALL HEIGHT (0.22) CALL MESSAG ('e',1,5.2922+XADD,0.3500) CALL MESSAG ('.',1,5.2922+XADD,0.4938) CALL MESSAG ('e',1,5.6094+XADD,0.3500) CALL MESSAG ('.',1,5.6094+XADD,0.4938) CALL RESET ('HEIGHT') IF (MODESR.EQ.1) THEN T=E3ME1M*(0.316*DEGPEI/RMSVEC) ELSEIF (MODESR.EQ.2) THEN T=E3ME1M*(0.316*DEGPEI/RMSVEC)**2 ENDIF CALL REALNO (T,-1,4.5000+XADD,0.3500) CALL MESSAG (VUNITS(13),NVUCHR(13),ABUT,ABUT) IF (MODESR.EQ.1) THEN T=E3ME1M*(1.000*DEGPEI/RMSVEC) ELSEIF (MODESR.EQ.2) THEN T=E3ME1M*(1.000*DEGPEI/RMSVEC)**2 ENDIF CALL ALNMES (0.5,0.0) CALL REALNO (T,-1,6.7000+XADD,0.3500) CALL MESSAG (VUNITS(13),NVUCHR(13),ABUT,ABUT) CALL ENDPL (0) WRITE (IUNITT,1399) 1399 FORMAT (/' ==============================================' + /' PLOT OF SURFACE STRAIN-RATES COMPLETED.' + /' =============================================='/) ENDIF C C PLOT DISCONTINUITY IN HORIZONTAL VELOCITY ACROSS FAULTS C IF (DOPLOT(14)) THEN WRITE (IUNITT,1400) 1400 FORMAT (/' Working on plot of VELOCITY DISCONTINUITIES...') IF (NFL.LE.0) THEN WRITE(IUNITT,1401) 1401 FORMAT (/' NOTE: PLOT OF VELOCITY DISCONTINUITIES WAS', + ' REQUESTED, BUT'/' THERE ARE NO FAULT ELEMENTS,' + /' SO THIS PLOT WILL BE OMITTED.') ELSE DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) CALL ANYMAP(ICOAST,DEGWID) MAGNIF=.FALSE. CALL SLIPS (INPUT,COLOR,CUTLN1,CUTLN2, + DEGPEI,DEGWID,DOGRID, + FARG,FDIP,FLEN,FSLIPS, + IPEN1,IPEN2,IPEN3, + MAGNIF,MAPTYP,MXPNTS, + NFL,NODEF,NODES,NUMEL,NUMNOD, + POLE,POLEP,POLET, + RADIUS,RMSVEC,SLIDE,V,WEDGE, + XNODE,YNODE, + WORK,ICYCLE,XARAY,YARAY) IF (KTIME.EQ.0) THEN STEPID(1:5)='STEP ' WRITE (TIMCHR,'(I3)') NOWTIM STEPID(6:8)=TIMCHR STEPID(9:9)='$' CALL HEADIN (TEXT(14),NVCHAR(14),1.,3) CALL HEADIN (TITLE6,100,1.,3) CALL HEADIN (STEPID,100,1.,3) ELSE CALL HEADIN (TEXT(14),NVCHAR(14),1.,2) CALL HEADIN (TITLE6,100,1.,2) ENDIF CALL ENDPL (0) WRITE (IUNITT,1499) 1499 FORMAT + (/' ==============================================' + /' PLOT OF VELOCITY DISCONTINUITIES COMPLETED.' + /' =============================================='/) ENDIF ENDIF C C PLOT SLIP-RATES OF FAULTS C CGPG IF (DOPLOT(15)) THEN WRITE (IUNITT,1500) 1500 FORMAT (/' Working on plot of FAULT SLIP-RATES...') IF (NFL.LE.0) THEN WRITE(IUNITT,1501) 1501 FORMAT (/' NOTE: PLOT OF FAULT SLIP RATES WAS', + ' REQUESTED, BUT'/' THERE ARE NO FAULT ELEMENTS,' + /' SO THIS PLOT WILL BE OMITTED.') ELSE DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) CALL ANYMAP(ICOAST,DEGWID) MAGNIF=.TRUE. CALL SLIPS (INPUT,COLOR,CUTLN1,CUTLN2, + DEGPEI,DEGWID,DOGRID, + FARG,FDIP,FLEN,FSLIPS, + IPEN1,IPEN2,IPEN3, + MAGNIF,MAPTYP,MXPNTS, + NFL,NODEF,NODES,NUMEL,NUMNOD, + POLE,POLEP,POLET, + RADIUS,RMSVEC,SLIDE,V,WEDGE, + XNODE,YNODE, + WORK,ICYCLE,XARAY,YARAY) IF (KTIME.EQ.0) THEN STEPID(1:5)='STEP ' WRITE (TIMCHR,'(I3)') NOWTIM STEPID(6:8)=TIMCHR STEPID(9:9)='$' CALL HEADIN (TEXT(15),NVCHAR(15),1.,3) CALL HEADIN (TITLE6,100,1.,3) CALL HEADIN (STEPID,100,1.,3) ELSE CALL HEADIN (TEXT(15),NVCHAR(15),1.,2) CALL HEADIN (TITLE6,100,1.,2) ENDIF CALL ENDPL (0) WRITE (IUNITT,1599) 1599 FORMAT + (/' ==============================================' + /' PLOT OF FAULT SLIP-RATES COMPLETED.' + /' =============================================='/) ENDIF ENDIF C C PLOT RATE OF CRUSTAL THICKENING (FROM FAULTS + CONTINUUM STRAIN) C IF (DOPLOT(16)) THEN WRITE (IUNITT,1600) 1600 FORMAT (/' Working on plot of CRUSTAL THICKENING RATE...') DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) C C FIRST, TAKE LARGEST ABSOLUTE VALUE FROM FAULTS C DO 1601 I=1,NUMNOD ATNODE(I)=0. 1601 CONTINUE DO 1650 I=1,NFL DO 1640 J=1,2 DIP=FDIP(J,I) NL=NODEF(J,I) NH=NODEF(5-J,I) DU=V(1,NL)-V(1,NH) DV=V(2,NL)-V(2,NH) ARGUM=FARG(J,I) UNITX=COS(ARGUM) UNITY=SIN(ARGUM) CROSSX= -UNITY CROSSY= +UNITX CLOSE=DU*CROSSX+DV*CROSSY IF (ABS(DIP-1.570796).LT.WEDGE) THEN VUPDIP=0.0 ELSE VUPDIP=CLOSE/COS(DIP) ENDIF RELV=VUPDIP*SIN(DIP) IF (DIP.LT.1.570796) THEN N=NL ELSE N=NH RELV= -RELV ENDIF IF (ABS(RELV).GT.ABS(ATNODE(N))) THEN ATNODE(N)=RELV ENDIF 1640 CONTINUE 1650 CONTINUE C C NEXT, ADD CONTINUUM STRAIN, AVERAGED OVER ELEMENTS C IF (.NOT.DOPLOT(12)) THEN CALL EDOT (INPUT,DXS,DYS, + FPSFER,MXEL, + MXNODE,NODES,NUMEL,RADIUS,SITA,V, + OUTPUT,ERATE) ENDIF DO 1680 I=1,NUMNOD NON=0 SUM=0. DO 1678 IE=1,NUMEL IF ((NODES(1,IE).EQ.I).OR. + (NODES(2,IE).EQ.I).OR. + (NODES(3,IE).EQ.I)) THEN NON=NON+1 EZZ=-(ERATE(1,1,IE)+ERATE(2,1,IE)) SUM=SUM+EZZ ENDIF 1678 CONTINUE IF (NON.GT.0) THEN EZZ=SUM/(1.*NON) ATNODE(I)=ATNODE(I)+EZZ*ZMNODE(I) ENDIF 1680 CONTINUE C DFC=CINT(16) IF ((DFC.LE.0.0).OR.(FBLAND(16).EQ.0.0)) THEN TOP=ATNODE(1) BOT=ATNODE(1) DO 1690 I=2,NUMNOD TOP=MAX(TOP,ATNODE(I)) BOT=MIN(BOT,ATNODE(I)) 1690 CONTINUE IF (DFC.LE.0.0) THEN DFC=MAX(1.E-15,(TOP-BOT)/(1.*NCONTR)) DFC=ROUND(DFC) ENDIF IF (FBLAND(16).EQ.0.0) THEN N=NINT((TOP+BOT)/(2.*DFC)) FBLAND(16)=N*DFC ENDIF ENDIF N=NINT(FBLAND(16)/DFC) FBLAND(16)=N*DFC IF (LOWBLU(16).NE.-1) LOWBLU(16)=+1 C C FOLLOWING STATEMENT CONVERTS M/S TO MM/YEAR C VMULT=1000.*SECPYR C EDGEIT=.FALSE. CALL SCALAR (INPUT,ATNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND(16),LOWBLU(16), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT, + WORK,ICYCLE, + XARAY,XARRAY,YARAY,YARRAY) C C PLOT FAULTS ALSO C SUM=0.0 DO 1692 I=1,NFL SUM=SUM+FLEN(I)/RADIUS 1692 CONTINUE IF (NFL.GT.0) AVERAG=SUM/NFL IF (NUMNOD.LE.600) THEN NTIC=3 DIPSIZ=0.15*AVERAG ELSE NTIC=1 DIPSIZ=0.40*AVERAG ENDIF KOLOR='RED ' CALL FAULTS (INPUT,COLOR,CUTLN1,CUTLN2, + FARG,FDIP, + IPEN2,KOLOR,MXFEL, + MXNODE,NFL,NODEF,NTIC,DIPSIZ, + SLIDE,WEDGE,XNODE,YNODE) CALL ANYMAP(ICOAST,DEGWID) CALL FRAME (DOGRID) IF (KTIME.EQ.0) THEN STEPID(1:5)='STEP ' WRITE (TIMCHR,'(I3)') NOWTIM STEPID(6:8)=TIMCHR STEPID(9:9)='$' CALL HEADIN (TEXT(16),NVCHAR(16),1.,3) CALL HEADIN (TITLE6,100,1.,3) CALL HEADIN (STEPID,100,1.,3) ELSE CALL HEADIN (TEXT(16),NVCHAR(16),1.,2) CALL HEADIN (TITLE6,100,1.,2) ENDIF CALL BAR (INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU(16), + MXPNTS,NVUCHR(16),VMULT,VUNITS(16),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) C CALL ENDPL (0) WRITE (IUNITT,1699) 1699 FORMAT (/' ==============================================' + /' PLOT OF CRUSTAL THICKENING RATE COMPLETED.' + /' =============================================='/) END IF C C PLOT VERTICAL-INTEGRALS OF STRESS ANOMALIES C IF (DOPLOT(17)) THEN WRITE (IUNITT,1700) 1700 FORMAT (/' Working on plot of INTEGRATED', + ' STRESS ANOMALIES...') CALL CULL(INPUT,NUMEL,'tensors',OUTPUT,NTH) C C NOTE: COMPUTE VERTICAL STRESS AT ELEMENT CENTERS ONLY C DO 1720 I=1,NUMEL N1=NODES(1,I) N2=NODES(2,I) N3=NODES(3,I) ELEVAT=0.33333*(ELEV(N1)+ELEV(N2)+ELEV(N3)) ZM=0.33333*(ZMNODE(N1)+ZMNODE(N2)+ZMNODE(N3)) TL=0.33333*(TLNODE(N1)+TLNODE(N2)+TLNODE(N3)) GEOTH1=GEOTHC(1,1,I) GEOTH2=GEOTHC(2,1,I) GEOTH3=GEOTHC(3,1,I) GEOTH4=GEOTHC(4,1,I) GEOTH5=GEOTHM(1,1,I) GEOTH6=GEOTHM(2,1,I) GEOTH7=GEOTHM(3,1,I) GEOTH8=GEOTHM(4,1,I) ZSTOP=ZM+TL CALL SQUEEZ (INPUT,ALPHAT,ELEVAT, + GEOTH1,GEOTH2,GEOTH3,GEOTH4, + GEOTH5,GEOTH6,GEOTH7,GEOTH8, + GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, + TEMLIM,ZM,ZSTOP, + OUTPUT,TAUZZ,SIGZZB) TAUZZI(1,I)=TAUZZ 1720 CONTINUE DOGRID=(ICOAST.NE.2).OR.(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) CALL ANYMAP(ICOAST,DEGWID) CALL MAXSTR (INPUT,NUMEL,TAUMAT,TAUZZI, + OUTPUT,RMSS) SCALE=RMSVEC*PIO180/RMSS CALL SICONS (INPUT,CUTLN1,CUTLN2,DEGWID,MAPTYP, + NTH,NUMEL,POLE,POLEP,POLET, + SCALE,TAUMAT,TAUZZI,XIP,YIP) CALL FRAME (DOGRID) IF (KTIME.EQ.0) THEN STEPID(1:5)='STEP ' WRITE (TIMCHR,'(I3)') NOWTIM STEPID(6:8)=TIMCHR STEPID(9:9)='$' CALL HEADIN (TEXT(17),NVCHAR(17),1.,3) CALL HEADIN (TITLE6,100,1.,3) CALL HEADIN (STEPID,100,1.,3) ELSE CALL HEADIN (TEXT(17),NVCHAR(17),1.,2) CALL HEADIN (TITLE6,100,1.,2) ENDIF XMID=XWIDE*0.5 YA=1.5 CALL VECTOR (XMID,YA-.7,XMID-0.3937/2.,YA-.7,1121) CALL VECTOR (XMID-0.3937,YA-.7,XMID-0.3937/2.,YA-.7,1121) CALL VECTOR (XMID-0.3937/2.,YA-.503, + XMID-0.3937/2.,YA-.7,1121) CALL VECTOR (XMID-0.3937/2.,YA-.897, + XMID-0.3937/2.,YA-.7,1121) CALL ARC (XMID-.3937/2.,YA-.7,.1968,0.,360.,'NONE',.0138) SAMPLE=0.3937*DEGPEI*PIO180/SCALE CALL ANGLE (0.) CALL ALNMES (0.0,0.0) CALL RESET ('HEIGHT') CALL REALNO (SAMPLE,-1,XMID+0.1,YA-.8) CALL MESSAG (VUNITS(17),NVUCHR(17),ABUT,ABUT) CALL ENDPL (0) WRITE (IUNITT,1799) 1799 FORMAT (/' ==============================================' + /' PLOT OF INTEGRATED STRESS ANOMALIES COMPLETED' + /' =============================================='/) END IF C C PLOT MOST-COMPRESSIVE HORIZONTAL STRESS AXIS C (ACTUALLY, MOST-COMPRESSIVE STRAIN-RATE AXIS) C IF (DOPLOT(18)) THEN WRITE (IUNITT,1800) 1800 FORMAT (/' Working on plot of MOST-COMPRESSIVE STRESS', + ' AXES...') CALL CULL(INPUT,NUMEL,'directions',OUTPUT,NTH) IF (.NOT.DOPLOT(12)) THEN CALL EDOT (INPUT,DXS,DYS, + FPSFER,MXEL, + MXNODE,NODES,NUMEL,RADIUS,SITA,V, + OUTPUT,ERATE) ENDIF DOGRID=(ICOAST.NE.2).OR.(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) CALL ANYMAP(ICOAST,DEGWID) SCALE=RMSVEC*PIO180 CALL SIGMA1 (INPUT,COLOR,CUTLN1,CUTLN2,ERATE,MAPTYP, + NTH,NUMEL,POLE,SCALE,XIP,YIP) CALL FRAME (DOGRID) IF (KTIME.EQ.0) THEN STEPID(1:5)='STEP ' WRITE (TIMCHR,'(I3)') NOWTIM STEPID(6:8)=TIMCHR STEPID(9:9)='$' CALL HEADIN (TEXT(18),NVCHAR(18),1.,3) CALL HEADIN (TITLE6,100,1.,3) CALL HEADIN (STEPID,100,1.,3) ELSE CALL HEADIN (TEXT(18),NVCHAR(18),1.,2) CALL HEADIN (TITLE6,100,1.,2) ENDIF C C ADD ANY BOTTOM-LINE LABELS HERE C CALL RESET ('HEIGHT') CALL ALNMES (0.0,0.0) CALL MESSAG ('STRESS REGIMES:',16,3.6,0.7) CALL MESSAG ('normal faulting',15,5.9,1.0) CALL MESSAG ('strike-slip faulting',20,5.9,0.7) CALL MESSAG ('thrust faulting',15,5.9,0.4) IF (COLOR) THEN CALL THKVEC (3.0) CALL NEWCLR ('RED') CALL RLVEC (5.3,1.05,5.7,1.05,0) CALL NEWCLR ('GREEN') CALL RLVEC (5.3,0.75,5.7,0.75,0) CALL NEWCLR ('BLUE') CALL RLVEC (5.3,0.45,5.7,0.45,0) CALL RESET ('THKVEC') ELSE CALL THKVEC (1.0) C EMPTY WHITE BOX 3 POINTS THICK CALL RLVEC (5.3,1.029,5.7,1.029,0) CALL RLVEC (5.7,1.029,5.7,1.071,0) CALL RLVEC (5.7,1.071,5.3,1.071,0) CALL RLVEC (5.3,1.071,5.3,1.029,0) CALL THKVEC (3.0) CALL NEWCLR ('GRAY') CALL RLVEC (5.3,0.75,5.7,0.75,0) CALL NEWCLR ('FORE') CALL RLVEC (5.3,0.45,5.7,0.45,0) CALL RESET ('THKVEC') ENDIF C CALL ENDPL (0) WRITE (IUNITT,1899) 1899 FORMAT (/' ===============================================' + /' PLOT OF MOST-COMPRESSIVE STRESS AXES COMPLETED.' + /' =============================================='/) END IF C C PLOT Log10[Viscosity Integral, in Pa s m] C Note special code: LOWBLU = 1 gives crustal values of C LIMTED (0, 1, or 2) as an overprint of text, while C LOWBLU =2 gives mantle-lithosphere values of LIMTED. C IF (DOPLOT(20)) THEN WRITE (IUNITT,2000) 2000 FORMAT (/' Working on plot of Log10[Viscosity Integral]...') C LAYER=ABS(LOWBLU(20)) LAYER=MAX(1,MIN(2,LAYER)) LOWBLU(20)= -1 C (From here on, LOWBLU has its normal meaning.) C DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) C C EVALUATE LOG10((S3-S1)/(E3*-E1*)/2) AT INTEGRATION POINTS C (NOTE: * MEANS STRAIN-RATE PARTITIONED(?) IF E2 /= 0) C M=1 DO 2005 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) EZ= -(EXX+EYY) IF ((E2.EQ.0.).AND.(E1.EQ.0)) THEN OUTSCA(M,I)=ALOG10(VISMAX)+ + ALOG10(ZMOHO(M,I)+TLINT(M,I)) ELSE IF ((E2*EZ).GT.0.) THEN C E1 HAS THE UNIQUE SIGN AND IS PARTITIONED E1PART=.TRUE. E2PART=.FALSE. EZPART=.FALSE. ELSE IF ((E1*EZ).GT.0.) THEN C E2 HAS THE UNIQUE SIGN AND IS PARTITIONED E1PART=.FALSE. E2PART=.TRUE. EZPART=.FALSE. ELSE C EZZ HAS THE UNIQUE SIGN AND IS PARTITIONED E1PART=.FALSE. E2PART=.FALSE. EZPART=.TRUE. END IF C STRIKE-SLIP RATE (E2ME1) IF (E1PART) THEN E2ME1=2.*ABS(E2) ELSE IF (E2PART) THEN E2ME1=2.*ABS(E1) ELSE E2ME1=ABS(E2-E1) END IF C THRUST-FAULTING RATE (EZME1) IF (E1PART) THEN EZME1=2.*ABS(EZ) ELSE IF (EZPART) THEN EZME1=2.*ABS(E1) ELSE EZME1=ABS(EZ-E1) END IF C NORMAL FAULTING RATE (E2MEZ) IF (E2PART) THEN E2MEZ=2.*ABS(EZ) ELSE IF (EZPART) THEN E2MEZ=2.*ABS(E2) ELSE E2MEZ=ABS(E2-EZ) END IF ELARGE=MAX(E2ME1,EZME1,E2MEZ) TXX=TAUMAT(1,M,I) TYY=TAUMAT(2,M,I) TXY=TAUMAT(3,M,I) CALL PRINCE (INPUT,TXX,TYY,TXY, + OUTPUT,T1,T2,U1X,U1Y,U2X,U2Y) C (NOTE: THESE ARE RELATIVE TO TZZ!) IF (E2ME1.EQ.ELARGE) THEN OUTSCA(M,I)=ALOG10(0.5*(T2-T1))- + ALOG10(E2ME1) ELSE IF (EZME1.EQ.ELARGE) THEN OUTSCA(M,I)=ALOG10(0.5*ABS(T1))- + ALOG10(EZME1) ELSE C (THEN E2MEZ == ELARGE) OUTSCA(M,I)=ALOG10(0.5*ABS(T2))- + ALOG10(E2MEZ) END IF END IF 2005 CONTINUE C2010 CCCCC CONTINUE C C FIND NODAL VALUES BY SIMPLE AVERAGING: C Note: This is an OrbMapAI version, using only M=1! C One drawback of this method is that it does C not compute values for nodes which only belong C to fault elements, but not to triangles. C CALL IP2NOD(INPUT,OUTSCA, + NODES,NUMEL,NUMNOD, + OUTPUT,ATNODE, + WORK,ICOUNT) C C CONTOUR THE SMOOTHED NODAL VALUES C DFC=CINT(20) IF ((CINT(20).LE.0.0).OR.(FBLAND(20).LE.0.0)) THEN TOP=-9.99E37 BOT=+9.99E37 DO 2050 I=1,NUMNOD IF (ATNODE(I).NE.0.0) THEN TOP=MAX(TOP,ATNODE(I)) BOT=MIN(BOT,ATNODE(I)) END IF 2050 CONTINUE DO 2051 I=1,NUMNOD ATNODE(I)=MAX(BOT,MIN(TOP,ATNODE(I))) 2051 CONTINUE IF (DFC.LE.0.0) THEN DFC=MAX(1.E-5,(TOP-BOT)/(1.*NCONTR)) DFC=ROUND(DFC) ENDIF IF (FBLAND(20).LE.0.0) THEN N=NINT((TOP+BOT)/(2.*DFC)) FBLAND(20)=N*DFC ENDIF ENDIF N=NINT(FBLAND(20)/DFC) FBLAND(20)=N*DFC VMULT=1. EDGEIT=.TRUE. CALL SCALAR (INPUT,ATNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND(20),LOWBLU(20), + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT, + WORK,ICYCLE, + XARAY,XARRAY,YARAY,YARRAY) C C OVERPLOT NUMBERS TO SHOW LIMTED(LAYER,M=1,I) = 0, 1, OR 2: C CALL BGROUP CALL ALNMES (0.5,0.5) CALL ANGLE (0.) DO 2060 I=1,NUMEL WRITE (C1,2059) LIMTED(LAYER,1,I) 2059 FORMAT(I1) XLON=OEZOPI*YIP(1,I) XLON=CUTLN1+MOD(XLON-CUTLN1+720.,360.) YLAT=90.-OEZOPI*XIP(1,I) CALL RLMESS (C1,1,XLON,YLAT) 2060 CONTINUE CALL EGROUP C C FINISH AND ANNOTATE PLOT C CALL ANYMAP(ICOAST,DEGWID) CALL FRAME (DOGRID) CALL HEADIN (TEXT(20),NVCHAR(20),1.,2) CALL HEADIN (TITLE6,100,1.,2) CALL BAR (INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU(20), + MXPNTS,NVUCHR(20),VMULT,VUNITS(20),XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) CALL ENDPL (0) WRITE (IUNITT,2099) 2099 FORMAT (/' ==============================================' + /' PLOT OF Log10[Viscosity Integral] COMPLETED.' + /' =============================================='/) END IF C C C C===============Following END IF relates WAY BACK to 1000 ! END IF C===============Preceding END IF relates WAY BACK to 1000 ! C C LOOP IF MULTIPLE VELOCITY SOLUTIONS ARE INPUT C IF (NEEDSV) THEN IF ((KTIME.EQ.0).OR.(NOWTIM.LT.KTIME)) THEN C NOTE: IUNITV is already open at this point. CALL OLDVEL (INPUT,IUNITT,IUNITV,MXNODE,NUMNOD, + OUTPUT,MOREV,TITLE1,TITLE2,TITLE3,V3) CALL CHOP (INPUT,TITLE1, + OUTPUT,TITLE4) CALL CHOP (INPUT,TITLE3, + OUTPUT,TITLE6) IF (MOREV) THEN NOWTIM=NOWTIM+1 DO 9600 I=1,NUMNOD V2(1,I)=V(1,I) V2(2,I)=V(2,I) V(1,I)=V3(1,I) V(2,I)=V3(2,I) 9600 CONTINUE HAVENV=.TRUE. HAVEOV=.TRUE. GO TO 1000 ELSE IF (KTIME.EQ.999) THEN KTIME=NOWTIM GO TO 1000 ELSE IF (KTIME.GT.0) THEN WRITE (IUNITT,9601) KTIME,IUNITV 9601 FORMAT (/' UNABLE TO FIND',I3,' CONSECUTIVE' + ,' VELOCITY SOLUTIONS ON DEVICE',I3) ENDIF ENDIF ENDIF ENDIF C C C PLOT FORCES ON NODES REQUIRED TO IMPOSE THE VELOCITY BOUNDARY C CONDITIONS C IF (DOPLOT(19)) THEN WRITE (IUNITT,1900) 1900 FORMAT (/' Working on plot of FORCES ON NODES TO IMPOSE ', + 'V.B.C...') DOGRID=(PERLAT.NE.0.) CALL GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) C C PLOT FAULTS ALSO C SUM=0.0 DO 1902 I=1,NFL SUM=SUM+FLEN(I)/RADIUS 1902 CONTINUE IF (NFL.GT.0) AVERAG=SUM/NFL IF (NUMNOD.LE.600) THEN NTIC=3 DIPSIZ=0.15*AVERAG ELSE NTIC=1 DIPSIZ=0.40*AVERAG ENDIF DASHED=.FALSE. IF (COLOR) THEN KOLOR='RED ' ELSE KOLOR='FORE' ENDIF CALL FAULTS (INPUT,COLOR,CUTLN1,CUTLN2, + FARG,FDIP, + IPEN2,KOLOR,MXFEL, + MXNODE,NFL,NODEF,NTIC,DIPSIZ, + SLIDE,WEDGE,XNODE,YNODE) CALL ANYMAP(ICOAST,DEGWID) WRITE (IUNITT,1910) IUNITF 1910 FORMAT(/' Attempting to read REACTION FORCES ON NODES', + ' from unit ',I2/) OPEN (UNIT = IUNITF, FILE = ' ', STATUS = 'OLD') READ (IUNITF,1911,IOSTAT=IOS) TITLE1 1911 FORMAT (A80) READ (IUNITF,1911,IOSTAT=IOS) TITLE2 READ (IUNITF,1911,IOSTAT=IOS) TITLE3 READ (IUNITF,*) ((V(J,I),J=1,2),I=1,NUMNOD) CALL CHOP (INPUT,TITLE3, + OUTPUT,TITLE6) FROM=.TRUE. DPSUM=0. DO 1940 I=1,NUMNOD DPV1=V(1,I) DPV2=V(2,I) DPSUM=DPSUM+DPV1**2+DPV2**2 1940 CONTINUE DELTAT=RADIUS*PIO180*RMSVEC/SQRT(DPSUM/NUMNOD) CALL THKCRV (2.0) CALL BGROUP DO 1950 I=1,NUMNOD THETA=XNODE(I) PHI=YNODE(I) DPV1=V(1,I) DPV2=V(2,I) SIZE=DELTAT*SQRT(DPV1**2+DPV2**2)/RADIUS VT=V(1,I) VP=V(2,I) AZIM=PI-ATAN2F(VP,VT) BARIT=.FALSE. CALL ARROW (INPUT,THETA,PHI,SIZE,AZIM, + MAPTYP,POLEP,POLET,DEGWID,FROM,BARIT) 1950 CONTINUE CALL EGROUP CALL RESET('THKCRV') CALL FRAME (DOGRID) CALL HEADIN (TEXT(19),NVCHAR(19),1.,2) CALL HEADIN (TITLE6,100,1.,2) XMID=XWIDE*0.5 YA=1.5 CALL THKVEC(2.0) CALL VECTOR (XMID-0.3937,YA-.65,XMID,YA-.65,1121) CALL RESET('THKVEC') SAMPLE=0.3937*DEGPEI*PIO180*RADIUS/DELTAT CALL ANGLE (0.) CALL RESET ('ALNMES') CALL HEIGHT (0.21) CALL REALNO (SAMPLE,-1,XMID+0.1,YA-.7) CALL MESSAG (VUNITS(19),NVUCHR(19),ABUT,ABUT) CALL RESET ('HEIGHT') CALL ENDPL (0) WRITE (IUNITT,1999) 1999 FORMAT ( + /' ==================================================' + /' PLOT OF FORCES ON NODES TO IMPOSE V.B.C COMPLETED.' + /' =================================================='/) END IF C C----------------------------------- C TERMINATE DISSPLA C CALL DONEPL C----------------------------------- STOP END C C C SUBROUTINE ANYMAP (ICOAST,DEGWID) C SELECTS BASEMAP, USING MAPFIL IF (ICOAST.EQ.1) THEN IF (DEGWID.GT.21.) THEN CALL MAPFIL ('MAPDTA') ELSE CALL MAPFIL ('COASTLINES') ENDIF ELSE IF (ICOAST.EQ.2) THEN CALL MAPFIL ('USER') ENDIF RETURN END C C C SUBROUTINE BLANK (STRING,N1,N2) C CHARACTER*81 STRING C IF (N1.LE.N2) THEN DO 10 I=N1,N2 STRING(I:I)=' ' 10 CONTINUE ENDIF RETURN END C C C REAL FUNCTION CHORD (ANGLE1,S,ANGLE2) C C RETURNS AN ANGLE OBTAINED BY INTERPOLATION BETWEEN ANGLE1 C AND ANGLE2. THE INTERPOLATION METHOD IS NOT SENSITIVE TO C POSSIBLE CYCLE SHIFTS (OF 2*N*PI) BETWEEN ANGLE1 AND ANGLE2. C C UNIT VECTORS ARE CONSTRUCTED FOR ANGLE1 AND ANGLE2, AND A C LINEAR CHORD IS DRAWN BETWEEN THEIR TIPS. C C DOUBLE PRECISION S IS THE INTERNAL COORDINATE ALONG THE CHORD; C IT IS DIMENSIONLESS, WITH VALUE 0.0D0 AT ANGLE1 AND 1.0D0 AT C ANGLE2. (THE USER MAY INPUT S VALUES OUTSIDE THIS RANGE C TO GET RESULTS OUTSIDE THE (SMALLER) ANGLE BETWEEN ANGLE1 AND C ANGLE2, IF DESIRED.) THE ANGLE RETURNED IS THAT FROM THE C ORIGIN TO THIS CHORD POINT. C C THIS ALGORITHM SHOULD WORK EQUALLY WELL FOR ANGLES MEASURED C EITHER CLOCKWISE OR COUNTERCLOCKWISE FROM ANY REFERENCE, AS C LONG AS THE USAGE IS CONSISTENT. C C BOTH THE INPUT ANGLES AND THE RESULT "CHORD" ARE IN RADIANS. C DOUBLE PRECISION S REAL ANGLE1,ANGLE2,UVEC1,UVEC2,UVECS DIMENSION UVEC1(2),UVEC2(2),VECS(2) UVEC1(1)=COS(ANGLE1) UVEC1(2)=SIN(ANGLE1) UVEC2(1)=COS(ANGLE2) UVEC2(2)=SIN(ANGLE2) VECS(1)=(1.0D0-S)*UVEC1(1)+S*UVEC2(1) VECS(2)=(1.0D0-S)*UVEC1(2)+S*UVEC2(2) CHORD=ATAN2F(VECS(2),VECS(1)) RETURN END C C C SUBROUTINE GETNET (INPUT,IUNIT7,IUNIT8, + MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF,DQDTDA,ELEV,FDIP, + NFAKEN,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,OFFMAX,OFFSET, + TITLE1,TLNODE,XNODE,YNODE,ZMNODE, + WORK,CHECKE,CHECKF,CHECKN) C C READ FINITE ELEMENT GRID FROM UNIT "IUNIT7". C ECHO THE IMPORTANT VALUES TO A PRINT DATASET ON UNIT "IUNIT8". C CHARACTER*80 TITLE1 LOGICAL ALLOK,BRIEF C C NOTE: FOLLOWING TYPE COULD BE "LOGICAL*1" IN IBM VS-FORTRAN: LOGICAL CHECKE,CHECKF,CHECKN C DIMENSION CHECKE(MXEL),CHECKF(MXFEL),CHECKN(MXNODE), + DQDTDA(MXNODE),ELEV(MXNODE), + FDIP(2,MXFEL),NODEF(4,MXFEL), + NODES(3,MXEL),OFFSET(MXFEL),TLNODE(MXNODE), + XNODE(MXNODE),YNODE(MXNODE),ZMNODE(MXNODE) DIMENSION DIPS(3),VECTON(7) C WRITE (IUNIT8,1) IUNIT7 1 FORMAT (/' Attempting to read FINITE ELEMENT GRID from unit',I3/) OPEN (UNIT = IUNIT7, FILE = ' ', STATUS = 'OLD') TITLE1=' '// + ' ' READ (IUNIT7,2,IOSTAT=IOS) TITLE1 2 FORMAT (A) WRITE (IUNIT8,3) TITLE1(1:79) 3 FORMAT(' TITLE OF FINITE ELEMENT GRID ='/' ',A) C C READ NUMBER OF NODES. 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,4) NUMNOD,NREALN,NFAKEN 4 FORMAT (/' ERR0R: NUMNOD (',I6,') IS NOT EQUAL TO SUM' + /' OF NREALN (',I6,') AND NFAKEN (',I6,').') STOP ENDIF C IF (NREALN.GT.N1000) THEN WRITE (IUNIT8,5) NREALN,N1000 5 FORMAT (/' ERR0R: NREALN (',I6,') IS GREATER THAN' + /' N1000 (',I6,').') STOP ENDIF C IF (NUMNOD.GT.MXNODE) THEN WRITE (IUNIT8,10) NUMNOD 10 FORMAT(/' INCREASE PARAMETER MAXNOD TO BE AT LEAST' + /' THE NUMBER OF NODES (',I6,') AND RECOMPILE.') STOP ENDIF C 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 40 FORMAT (/' THERE ARE',I5,' NODES IN THE GRID') WRITE (IUNIT8,50) 50 FORMAT (/ + 77X,' MANTLE'/ + 77X,' CRUSTAL LITHOSPHERE'/ + ' NODE E-LONGITUDE N-LATITUDE', + ' THETA PHI ELEVATION', + ' HEAT-FLOW THICKNESS THICKNESS'/) ENDIF DO 90 K=1,NUMNOD CHECKN(K)=.FALSE. 90 CONTINUE DO 100 K=1,NUMNOD CALL READN (INPUT,IUNIT7,IUNIT8,7, + OUTPUT,VECTON) INDEX=VECTON(1)+0.5 IF (INDEX.GT.NREALN) THEN IF ((INDEX.LE.N1000).OR. + (INDEX.GT.(N1000+NFAKEN))) THEN WRITE (IUNIT8,91) INDEX 91 FORMAT (/' ERR0R: ILLEGAL NODE NUMBER: ',I6) STOP ENDIF ENDIF PLON=VECTON(2) PLAT=VECTON(3) IF (ABS(PLAT).GT.90.01) THEN WRITE (IUNIT8,92) INDEX 92 FORMAT (/' ERR0R: ABS(LATITUDE) > 90 AT NODE ',I6) STOP ENDIF IF (ABS(PLAT).GT.89.99) THEN WRITE (IUNIT8,93) INDEX 93 FORMAT (/' ERR0R: NODE ',I6,' LIES ON A POLE.' + /' THIS IS A SINGULAR POINT OF THE' + ,' SPHERICAL COORDINATE SYSTEM.' + /' MOVE THIS NODE, AT LEAST SLIGHTLY.') STOP ENDIF XI=(90.0-PLAT)*0.017453292 YI=PLON*0.017453292 ELEVI=VECTON(4) QI=VECTON(5) ZMI=VECTON(6) TLI=VECTON(7) IF (INDEX.LE.NREALN) THEN I=INDEX ELSE I=NREALN+INDEX-N1000 ENDIF CHECKN(I)=.TRUE. XNODE(I)=XI YNODE(I)=YI ELEV(I)=ELEVI DQDTDA(I)=QI IF (QI.LT.-2.) THEN WRITE (IUNIT8,96) 96 FORMAT (' NEGATIVE HEAT-FLOW IS NON-PHYSICAL.') STOP ENDIF IF (ZMI.LT.-10.) THEN WRITE (IUNIT8,97) 97 FORMAT(' NEGATIVE CRUSTAL THICKNESS IS NON-PHYSICAL.') STOP ENDIF ZMNODE(I)=ZMI IF (TLI.LT.-10.) THEN WRITE (IUNIT8,98) 98 FORMAT(' NEGATIVE MANTLE LITHOSPHERE THICKNESS IS', + ' NON-PHYSICAL.') STOP ENDIF TLNODE(I)=TLI IF (.NOT.BRIEF) THEN WRITE (IUNIT8,99) INDEX,PLON,PLAT,XI,YI,ELEVI, + QI,ZMI,TLI 99 FORMAT (' ',I10,0P,2F12.3,2F11.5,1P,3E10.2,E12.2) ENDIF 100 CONTINUE ALLOK=.TRUE. DO 101 I=1,NUMNOD ALLOK=ALLOK.AND.CHECKN(I) 101 CONTINUE IF (.NOT.ALLOK) THEN WRITE (IUNIT8,102) 102 FORMAT(' THE FOLLOWING NODES WERE NEVER READ:') DO 104 I=1,NUMNOD IF (I.LE.NREALN) THEN INDEX=I ELSE INDEX=N1000+I-NREALN ENDIF IF (.NOT.CHECKN(I)) WRITE(IUNIT8,103)INDEX 103 FORMAT (' ',36X,I6) 104 CONTINUE 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, COUNTER', + 'CLOCKWISE'/ / + ' ELEMENT C1 C2 C3') DO 200 K=1,NUMEL C (ELEMENTS NEED NOT BE INPUT IN ORDER, BUT MUST ALL BE PRESENT.) READ (IUNIT7,*) I,(NODES(J,I),J=1,3) IF ((I.LT.1).OR.(I.GT.NUMEL)) THEN WRITE (IUNIT8,111) I 111 FORMAT (/' ERR0R: ILLEGAL ELEMENT NUMBER: ',I6) STOP ENDIF CHECKE(I)=.TRUE. IF (.NOT.BRIEF) WRITE (IUNIT8,120) I,(NODES(J,I),J=1,3) 120 FORMAT (' ',I6,':',3I10) DO 130 J=1,3 N=NODES(J,I) IF (N.GT.NREALN) N=NREALN+(N-N1000) IF ((N.LE.0).OR.(N.GT.NUMNOD)) THEN WRITE (IUNIT8,125) NODES(J,I) 125 FORMAT (' NODE NUMBER ',I6,' IS ILLEGAL.') STOP ENDIF NODES(J,I)=N 130 CONTINUE 200 CONTINUE ALLOK=.TRUE. DO 201 I=1,NUMEL ALLOK=ALLOK.AND.CHECKE(I) 201 CONTINUE IF (.NOT.ALLOK) THEN WRITE (IUNIT8,202) 202 FORMAT (' THE FOLLOWING ELEMENTS WERE NEVER READ:') DO 204 I=1,NUMEL IF (.NOT.CHECKE(I)) WRITE(IUNIT8,203)I 203 FORMAT (' ',39X,I6) 204 CONTINUE 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,' GREAT CIRCLE FAULT ELEMENTS.') IF ((.NOT.BRIEF).AND.(NFL.GT.0)) WRITE(IUNIT8,231) 231 FORMAT (/' (THE 4 NODE NUMBERS DEFINING EACH ELEMENT MUST BE', + ' IN A COUNTERCLOCKWISE ORDER:'/ + ' N1, AND N2 ARE IN LEFT-TO-RIGHT SEQUENCE ON THE', + ' NEAR SIDE,'/ + ' THEN N3 IS OPPOSITE N2, N4 IS OPPOSITE N1 '/, + ' (FAULT DIPS ARE GIVEN AT N1, N2, ', + ' IN DEGREES FROM HORIZONTAL;'/ + ' POSITIVE DIPS ARE TOWARD N1, AND N2, RESPECTIVELY, '/ + ' WHILE NEGATIVE DIPS ARE TOWARD N4, AND N3.)'/ + ' OFFSET IS THE TOTAL PAST SLIP OF THE FAULT.'/ / + ' ELEMENT N1 N2 N3 N4 DIP1 DIP2', + ' OFFSET'/) 240 FORMAT (' ',I6,':',4I5,1X,2F6.1,1X,F9.0) DO 300 K=1,NFL OFF=0. READ(IUNIT7,*) I,(NODEF(J,K),J=1,4),(DIPS(L),L=1,2),OFF IF ((I.LT.1).OR.(I.GT.NFL)) THEN WRITE (IUNIT8,241) I 241 FORMAT (/' ERR0R: ILLEGAL FAULT NUMBER: ',I6) STOP ENDIF CHECKF(I)=.TRUE. IF (.NOT.BRIEF) WRITE (IUNIT8,240) I,(NODEF(J,I),J=1,4), + (DIPS(L),L=1,2),OFF DO 250 J=1,4 N=NODEF(J,I) IF (N.GT.NREALN) N=NREALN+(N-N1000) IF ((N.LE.0).OR.(N.GT.NUMNOD)) THEN WRITE (IUNIT8,243) NODEF(J,I),I 243 FORMAT (/' ERR0R: ILLEGAL NODE NUMBER (',I6, + ') IN FAULT ',I6) STOP ENDIF NODEF(J,I)=N 250 CONTINUE DO 260 L=1,2 IF (ABS(DIPS(L)).GT.90.) THEN WRITE(IUNIT8,252) DIPS(L) 252 FORMAT(' ILLEGAL DIP OF ',F10.4,'; SHOULD BE IN', + ' RANGE OF -90. TO +90. DEGREES.'/ + ' (NOTE: ALL DIPS ARE IN DEGREES FROM THE', + ' HORIZONAL;'/ + ' A + PREFIX (OR NONE) INDICATES A DIP', + ' TOWARD THE N1-N2 SIDE;'/ + ' A - PREFIX INDICATES A DIP TOWARD', + ' THE N4-N3 SIDE.)') STOP ENDIF IF (DIPS(L).LT.0.) DIPS(L)=180.+DIPS(L) FDIP(L,I)=DIPS(L)*0.017453293 260 CONTINUE IF (OFF.LT.0.) THEN WRITE (IUNIT8,280) OFF 280 FORMAT (' ILLEGAL FAULT OFFSET OF ',1P,E10.2, + ' FOR FAULT ELEMENT',I6/ + ' OFFSETS MAY NOT BE NEGATIVE.') 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 READN (INPUT,IUNITP,IUNITT,N, + OUTPUT,VECTON) 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 VECTON(N) C LINE=' '// + ' ' READ (IUNITP,1,IOSTAT=IOS) 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,*,IOSTAT=IOS) (VECTON(I),I=1,NUMBER) IF (NUMBER.LT.N) THEN DO 99 I=NUMBER+1,N VECTON(I)=0. 99 CONTINUE ENDIF ENDIF RETURN END C C C SUBROUTINE READPM (INPUT,IUNIT7, IUNIT8, NAMES, NUMPLT, OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT , + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , GMEAN , + GRADIE, ICONVE, IPVREF, MAXITR, MODESR, + OKDELV, OKTOQT, ONEKM, RADIO , + RADIUS, REFSTR, RHOAST, RHOBAR, RHOH2O, + TADIAB, + TAUMAX, TEMLIM, TITLE3, TRHMAX, TSURF, + VTIMES, ZBASTH, $ NPTIPE, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,NCONTR, $ ICOAST,RMSVEC, $ DEGWID,PERLON,PERLAT, $ 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*2 NAMES,PLTREF CHARACTER*80 TITLE3 LOGICAL COLOR,DOPLOT,EVERYP DIMENSION CINT(NPTIPE),DOPLOT(NPTIPE), + FBLAND(NPTIPE),LOWBLU(NPTIPE) DIMENSION ACREEP(2),ALPHAT(2),BCREEP(2),CCREEP(2),CONDUC(2), + DCREEP(2),NAMES(NUMPLT),RADIO(2), + RHOBAR(2),TAUMAX(2),TEMLIM(2),TEMPV(2),VECTOR(2) C WRITE (IUNIT8,1) IUNIT7 1 FORMAT (/ /' Attempting to read physical & PLOT-CONTROL', + ' parameters from unit',I3/) OPEN (UNIT = IUNIT7, FILE = ' ', STATUS = 'OLD') READ (IUNIT7,2,IOSTAT=IOS) TITLE3 2 FORMAT (A80) WRITE (IUNIT8,3) TITLE3 3 FORMAT (/' TITLE OF PARAMETER SET ='/' ',A80) WRITE (IUNIT8,4) 4 FORMAT (/' **************************************************'/ + ' IT IS THE USERS RESPONSIBILITY TO INPUT ALL OF THE'/ + ' FOLLOWING NUMERICAL QUANTITIES IN CONSISTENT UNITS,'/ + ' SUCH AS SYSTEM-INTERNATIONAL (SI) OR CM-G-S (CGS).'/ + ' NOTE THAT TIME UNIT MUST BE THE SECOND (HARD-CODED).'/ + ' **************************************************'/ + /' ========== STRATEGIC PARAMETERS (DEFINE THE REAL', + '-EARTH PROBLEM) ======'/) READ (IUNIT7,*) FFRIC WRITE (IUNIT8,20) FFRIC 20 FORMAT (' ', F10.3,' COEFFICIENT OF FRICTION ON FAULTS') READ (IUNIT7,*) CFRIC WRITE (IUNIT8,30) CFRIC 30 FORMAT (' ', F10.3,' COEFFICIENT OF FRICTION WITHIN BLOCKS') READ (IUNIT7,*) BIOT BIOT = MAX(0.0,MIN(1.0,BIOT)) WRITE (IUNIT8,40) BIOT 40 FORMAT (' ',F10.4,' EFFECTIVE-PRESSURE (BIOT) COEFFICIENT,', + ' 0.0 TO 1.0') READ (IUNIT7,*) BYERLY BYERLY = MAX(0.0,MIN(0.99,BYERLY)) IF (OFFMAX.GT.0.) THEN WRITE (IUNIT8,41) BYERLY 41 FORMAT (' ',F10.4,' BYERLY COEFFICIENT (0. TO 0.99) ='/ + 11X,' FRACTIONAL FRICTION REDUCTION ON MASTER', + ' FAULT'/ + 11X,' (OTHER FAULTS HAVE LESS REDUCTION, IN', + ' PROPORTION TO'/ + 11X,' THEIR TOTAL PAST OFFSETS)') ELSE WRITE (IUNIT8,42) BYERLY 42 FORMAT (' ',F10.4,' BYERLY COEFFICIENT (NOT USED IN', + ' THIS RUN,'/ + 11X,' AS ALL OFFSETS ARE ZERO)') ENDIF CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,ACREEP) 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) 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) 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) 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,*) TADIAB, GRADIE WRITE (IUNIT8,92) TADIAB, GRADIE 92 FORMAT (' ',F10.0,1P,E10.2,' INTERCEPT AND GRADIENT OF THE UPPER' + ,' MANTLE ADIABAT (K, K/M)') READ (IUNIT7,*) ZBASTH WRITE (IUNIT8,94) ZBASTH 94 FORMAT (' ',1P,E10.2,' DEPTH OF BASE OF ASTHENOSPHERE') C READ (IUNIT7,952) PLTREF 952 FORMAT(A2) WRITE (IUNIT8,954) PLTREF 954 FORMAT(' ',A2,9X,'PLTREF: PLATE DEFINING VELOCITY ', + 'REFERENCE FRAME (EU, NA, AF, ...)') IPVREF=0 DO 956 I=1,NUMPLT IF (NAMES(I).EQ.PLTREF) IPVREF=I 956 CONTINUE IF (IPVREF.EQ.0) THEN WRITE (IUNIT8,958) (NAMES(I),I=1,NUMPLT) 958 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' In line 13 (after ZBASTH, before ICONVE),' + /' in the first two columns of the line,' + /' define the velocity reference frame by' + /' entering one of the following plate names:' + /' ',26(A2,1X)) STOP END IF C READ (IUNIT7,*) ICONVE WRITE (IUNIT8,96) ICONVE 96 FORMAT (' ',I10,' ICONVE: CODE FOR LOWER MANTLE FLOW:' + /' ',10X,' 0 = NONE.' + /' ',10X,' 1 = HAGER AND OCONNELL (1979) MODEL II' + /' ',10X,' 2 = BAUMGARDNER (1988) FIGURE 7,A-F' + /' ',10X,' 3 = NUVEL-1A (DEMETS ET AL., 1994)' + /' ',10X,' 4 = NV1A DRAG ON CONTINENTS, NO OCEAN DRAG' + ) IF (ICONVE.GT.0) THEN BACKSPACE IUNIT7 CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,TEMPV) IF (TEMPV(2).GT.0) THEN VTIMES=TEMPV(2) WRITE (IUNIT8,98) VTIMES 98 FORMAT (' ',F10.4,' SPEED FACTOR FOR CONVECTION', + ' MODEL IDENTIFIED ABOVE') ELSE WRITE (IUNIT8,99) 99 FORMAT (' UNINTERPRETABLE VALUE FOR VTIMES; SET ' + ,'TO 1.0') VTIMES=1.0 ENDIF ELSE VTIMES=1.0 ENDIF READ (IUNIT7,*) TRHMAX WRITE (IUNIT8,101) TRHMAX 101 FORMAT (' ',1P,E10.2,' LIMIT ON HORIZONTAL TRACTIONS', + ' APPLIED TO BASE OF PLATE') C CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,VECTOR) TAUMAX(1)=VECTOR(1) TAUMAX(2)=VECTOR(2) C PROVIDE FOR OLD PARAMETER FILES WITH ONLY ONE TAUMAX: IF (TAUMAX(2).LE.0.0) TAUMAX(2)=TAUMAX(1) WRITE (IUNIT8,106) TAUMAX(1),TAUMAX(2) 106 FORMAT (' ',1P,E7.1,',',E7.1, + ' TAUMAX: SEA/LAND UPPER LIMIT', + ' ON INTEGRATED SUBDUCTION DRAG (N/m)') IF ((TAUMAX(1).LT.0.).OR.(TAUMAX(2).LT.0.)) THEN WRITE (IUNIT8,107) 107 FORMAT (/' *** ERR','OR in parameter input file: ***' + /' TAUMAX may not be negative.') STOP END IF C 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) 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)') READ (IUNIT7,*) RADIUS WRITE (IUNIT8,155) RADIUS 155 FORMAT (' ',1P,E10.3,' RADIUS OF THE PLANET') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,ALPHAT) 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) 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) 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) 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,' ORDINAL NUMBER OF VELOCITY SOLUTION TO USE' + /' (OR 999 FOR LAST, OR 0 FOR ALL)') 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,1012) DOPLOT(13),MODESR IF (MODESR.NE.1) MODESR=2 READ(IUNIT7,1011) DOPLOT(14) READ(IUNIT7,1011) DOPLOT(15) READ(IUNIT7,1010) DOPLOT(16),CINT(16),FBLAND(16),LOWBLU(16) READ(IUNIT7,1010) DOPLOT(17),CINT(17),FBLAND(17),LOWBLU(17) READ(IUNIT7,1011) DOPLOT(18) READ(IUNIT7,1011) DOPLOT(19) READ(IUNIT7,1010) DOPLOT(20),CINT(20),FBLAND(20),LOWBLU(20) 1010 FORMAT(L10,2E10.2,I2) 1011 FORMAT(L10) 1012 FORMAT(L10,10X,10X,I2) 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),MODESR WRITE(IUNIT8,1114) DOPLOT(14) WRITE(IUNIT8,1115) DOPLOT(15) WRITE(IUNIT8,1116) DOPLOT(16),CINT(16),FBLAND(16),LOWBLU(16) WRITE(IUNIT8,1117) DOPLOT(17),CINT(17),FBLAND(17),LOWBLU(17) WRITE(IUNIT8,1118) DOPLOT(18) WRITE(IUNIT8,1119) DOPLOT(19) WRITE(IUNIT8,1120) DOPLOT(20),CINT(20),FBLAND(20),LOWBLU(20) 1101 FORMAT(L11,22X, ' GRID OF ELEMENTS') 1102 FORMAT(L11,1P,2E10.2,I2,' ELEVATION (-SHELLS-)', + ' OR mu_ (-RESTORE-)') 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,' TOTAL 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,' PRESSURE ANOMALY', + ' ON BASE OF PLATE') 1109 FORMAT(L11,1P,2E10.2,I2,' LOWER MANTLE VELOCITY (*R/r)') 1110 FORMAT(L11,1P,2E10.2,I2,' SHEAR TRACTION ON PLATE BASE') 1111 FORMAT(L11,1P,2E10.2,I2,' SURFACE VELOCITY VECTORS') 1112 FORMAT(L11,1P,2E10.2,I2,' VELOCITY CHANGE FROM LAST ITERATION') 1113 FORMAT(L11, 10X, 10X,I2,' PRINCIPAL STRAIN-RATES (MODE 1 OR 2)') 1114 FORMAT(L11,22X, ' DISCONTINUITY IN HORIZONTAL VELOCITY') 1115 FORMAT(L11,22X, ' SLIP-RATE OF FAULTS') 1116 FORMAT(L11,1P,2E10.2,I2,' RATE OF CRUSTAL THICKENING') 1117 FORMAT(L11,1P,2E10.2,I2,' GREATEST PRINCIPAL' + ,' STRESS ANOMALY INTEGRALS') 1118 FORMAT(L11,22X, ' GREATEST HORIZONTAL PRINCIPAL STRESS') 1119 FORMAT(L11,22X, ' FORCE ON NODES TO IMPOSE V.B.C.S') READ(IUNIT7,*) NCONTR NCONTR=MAX(NCONTR,1) WRITE(IUNIT8,1200)NCONTR 1120 FORMAT(L11,1P,2E10.2,I2,' Log10[Viscosity Integral] (LAYER 1', + ' OR 2)') 1200 FORMAT(' ',I10,' APPROXIMATE NUMBER OF CONTOURS IN PLOTS', + ' WHEN CINT=0 (AUTO-SCALED)') READ(IUNIT7,*) ICOAST WRITE(IUNIT8,1300) ICOAST 1300 FORMAT(' ',I10,' COASTS: 0=NONE, 1=PRESENT, 2=USER DATA') READ (IUNIT7,*) RMSVEC WRITE (IUNIT8,1400) RMSVEC 1400 FORMAT(' ',F10.3,' RMS LENGTH VECTORS AND SYMBOLS, IN DEGREES') READ(IUNIT7,*) DEGWID DEGWID=MIN(DEGWID,360.) DEGWID=MAX(DEGWID,1.) WRITE(IUNIT8,1426) DEGWID 1426 FORMAT(' ',F10.2,' WIDTH OF MAP AREA, IN DEGREES') READ (IUNIT7,*) PERLON, PERLAT IF (PERLON.LT.-180.) PERLON=PERLON+360. IF (PERLON.LT.-180.) PERLON=PERLON+360. IF (PERLON.GT.+180.) PERLON=PERLON-360. IF (PERLON.GT.+180.) PERLON=PERLON-360. PERLAT=MIN(PERLAT,89.9) PERLAT=MAX(PERLAT,-89.9) WRITE (IUNIT8,1427) PERLON, PERLAT 1427 FORMAT(' (',F7.2,',',F7.2,')=(E.LON,N.LAT) OF MAP CENTER') READ(IUNIT7,*) IPEN1 WRITE(IUNIT8,1429)IPEN1 1429 FORMAT(' ',I10,' PEN WEIGHT FOR LIGHTEST LINES') READ(IUNIT7,*) IPEN2 WRITE(IUNIT8,1430)IPEN2 1430 FORMAT(' ',I10,' PEN WEIGHT FOR MEDIUM LINES') READ(IUNIT7,*) IPEN3 WRITE(IUNIT8,1431)IPEN3 1431 FORMAT(' ',I10,' PEN WEIGHT FOR HEAVY LINES') 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 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 OLDVEL (INPUT,IUNITT,IUNITV,MXNODE,NUMNOD, + OUTPUT,HAVENV,TITLE1,TITLE2,TITLE3,V) C C READ OLD VELOCITY SOLUTION FROM UNIT IUNITV, OR ELSE SET LOGICAL C VARIABLE 'HAVENV" TO FALSE. C WRITES 3 TITLE LINES TO IUNITT. C LOGICAL HAVENV CHARACTER*80 TITLE1,TITLE2,TITLE3 DOUBLE PRECISION V DIMENSION V(2,MXNODE) C C Note: The usual user-notification and OPEN statements are C not here because this routine is sometimes called from C inside a loop. They must be outside the loop. C TITLE1=' '// + ' ' READ (IUNITV,'(A80)',END=100,IOSTAT=IOS) TITLE1 TITLE2=' '// + ' ' READ (IUNITV,'(A80)',END=100,IOSTAT=IOS) TITLE2 TITLE3=' '// + ' ' READ (IUNITV,'(A80)',END=100,IOSTAT=IOS) TITLE3 READ (IUNITV,*,END=100,ERR=100) ((V(J,I),J=1,2),I=1,NUMNOD) HAVENV=.TRUE. WRITE (IUNITT,50) IUNITV,TITLE1(1:79),TITLE2(1:79),TITLE3(1:79) 50 FORMAT (/ /' VELOCITY SOLUTION WAS', + ' READ FROM UNIT',I3,'; TITLES WERE:'/3(/' ',A)) GO TO 900 C ------------------(THIS SECTION EXECUTED ONLY IF READ FAILS)--------- 100 WRITE (IUNITT,110) IUNITV 110 FORMAT (/ /' NO FURTHER VELOCITY SOLUTIONS FOUND ON UNIT', + I3) HAVENV=.FALSE. C --------------------------------------------------------------------- 900 WRITE (IUNITT,999) 999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE ARROW (INPUT,THETA,PHI,SIZE,AZIM, + MAPTYP,POLEP,POLET,DEGWID,FROM,BARIT) C C DRAW AN ARROW LIKE "--->" ON THE SURFACE C OF A SPHERE, WHERE: C THETA = COLATITUDE OF POINT, FROM NORTH POLE, IN RADIANS. C PHI = LONGITUDE OF POINT, MEASURED EASTWARD, IN RADIANS. C SIZE = LENGTH OF VECTOR, IN RADIANS C (NOTE: SIZE IS ADJUSTED FOR MAP PROJECTION, SO THE C VECTOR CAN BE COMPARED TO A GRAPHICAL SCALE.) C AZIM = AZIMUTH OF VECTOR, CLOCKWISE FROM NORTH, IN RADIANS. C MAPTYP= INDICATOR OF PROJECTION TYPE IS USE: C 1: OBLIQUE MERCATOR PROJECTION C 2: STEREOGRAPHIC PROJECTION C POLET = THETA OF MAP "POLE" OR CENTER POINT (SEE "THETA"). C POLEP = PHI OF MAP "POLE" OR CENTER POINT (SEE "PHI"). C DEGWID= WIDTH OF MAP, IN DEGREES OF LONGITUDE C FROM = .TRUE. IF VECTOR DEPARTS FROM (THETA,PHI); C OR,.FALSE. IF VECTOR ENDS AT (THETA,PHI). C BARIT = .TRUE. IF ARROW SHOULD BE MARKED WITH A CROSS-BAR C (E.G., PERHAPS TO SHOW BASAL TRACTION LIMITED BY C ETAMAX) C LOGICAL BARIT,FROM,GREAT REAL LBAR,LEFT,LLAT,LLON DIMENSION BASE(3),HEAD(3),LBAR(3),LEFT(3), + OMEGA(3),POLE(3),RBAR(3), + RESULT(3),RIGHT(3),TAIL(3) DATA OEZOPI /57.29577951/ GREAT=.TRUE. C BASE(1)=COS(PHI)*SIN(THETA) BASE(2)=SIN(PHI)*SIN(THETA) BASE(3)=COS(THETA) POLE(1)=COS(POLEP)*SIN(POLET) POLE(2)=SIN(POLEP)*SIN(POLET) POLE(3)=COS(POLET) CALL RESIZE (INPUT,BASE,MAPTYP,POLE, + OUTPUT,DIMINI) FAR=SIZE*DIMINI IF (FROM) THEN TAZIM=AZIM ELSE TAZIM=AZIM+3.14159 ENDIF CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,RESULT) IF (FROM) THEN TAIL(1)=BASE(1) TAIL(2)=BASE(2) TAIL(3)=BASE(3) HEAD(1)=RESULT(1) HEAD(2)=RESULT(2) HEAD(3)=RESULT(3) ELSE HEAD(1)=BASE(1) HEAD(2)=BASE(2) HEAD(3)=BASE(3) TAIL(1)=RESULT(1) TAIL(2)=RESULT(2) TAIL(3)=RESULT(3) ENDIF LEFT(1)=0.8*HEAD(1)+0.2*TAIL(1)+0.1*FAR*OMEGA(1) LEFT(2)=0.8*HEAD(2)+0.2*TAIL(2)+0.1*FAR*OMEGA(2) LEFT(3)=0.8*HEAD(3)+0.2*TAIL(3)+0.1*FAR*OMEGA(3) CALL UNIT (MODIFY,LEFT) LBAR(1)=HEAD(1)+0.22*FAR*OMEGA(1) LBAR(2)=HEAD(2)+0.22*FAR*OMEGA(2) LBAR(3)=HEAD(3)+0.22*FAR*OMEGA(3) CALL UNIT (MODIFY,LBAR) RIGHT(1)=0.8*HEAD(1)+0.2*TAIL(1)-0.1*FAR*OMEGA(1) RIGHT(2)=0.8*HEAD(2)+0.2*TAIL(2)-0.1*FAR*OMEGA(2) RIGHT(3)=0.8*HEAD(3)+0.2*TAIL(3)-0.1*FAR*OMEGA(3) CALL UNIT (MODIFY,RIGHT) RBAR(1)=HEAD(1)-0.22*FAR*OMEGA(1) RBAR(2)=HEAD(2)-0.22*FAR*OMEGA(2) RBAR(3)=HEAD(3)-0.22*FAR*OMEGA(3) CALL UNIT (MODIFY,RBAR) TLAT=90.-OEZOPI*ACOS(TAIL(3)) TLON=OEZOPI*ATAN2F(TAIL(2),TAIL(1)) HLAT=90.-OEZOPI*ACOS(HEAD(3)) HLON=OEZOPI*ATAN2F(HEAD(2),HEAD(1)) LLAT=90.-OEZOPI*ACOS(LEFT(3)) LLON=OEZOPI*ATAN2F(LEFT(2),LEFT(1)) RLAT=90.-OEZOPI*ACOS(RIGHT(3)) RLON=OEZOPI*ATAN2F(RIGHT(2),RIGHT(1)) CUTLN1=OEZOPI*POLEP-179.99 CUTLN2=OEZOPI*POLEP+179.99 CALL MYARC (INPUT,TLON,TLAT,HLON,HLAT,CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,LLON,LLAT,HLON,HLAT,CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,HLON,HLAT,RLON,RLAT,CUTLN1,CUTLN2,GREAT) IF (BARIT) THEN LLAT=90.-OEZOPI*ACOS(LBAR(3)) LLON=OEZOPI*ATAN2F(LBAR(2),LBAR(1)) RLAT=90.-OEZOPI*ACOS(RBAR(3)) RLON=OEZOPI*ATAN2F(RBAR(2),RBAR(1)) CALL MYARC (INPUT,LLON,LLAT,RLON,RLAT,CUTLN1,CUTLN2,GREAT) ENDIF C RETURN END C C C SUBROUTINE MYARC (INPUT,ELOND1,NLATD1,ELOND2,NLATD2, + CUTLN1,CUTLN2,GREAT) C C DRAWS AN ARC OF A GREAT CIRCLE (IF GREAT; ELSE A STRAIGHT LINE) C FROM (ELOND1,NLATD1) TO (ELOND2,NLATD2), C BUT IF THE SEGMENT PASSES THROUGH LONGITUDE CUTLN1 OR CUTLN2, C IT IS DIVIDED INTO TWO SEGMENTS. C C ALL PARAMETERS ARE IN DEGREES. C CUTLN1 SHOULD BE LESS THAN CUTLN2. C C NOTE: -ORBMAPAI- VERSION USES BASIS VECTORS VDI01,VDI02,VDI03 C RATHER THAN CUTLN1 AND CUTLN2 TO LOCATE THE CUT (MORE ACCURATE). C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RID18,RDI19, + VDI01,VDI02,VDI03 C LOGICAL CUT,GREAT REAL NLATD1,NLATD2,NLATM1,NLATM2 DIMENSION V1(3),V2(3),VT(3) C C FANCY TESTS ARE ONLY NEEDED IF MERCATOR PROJECTION IN USE C IF (CDI02(1:8).EQ.'MERCATOR') THEN C C DO NOT MODIFY THE INPUT PARAMETERS C ELONM1=ELOND1 ELONM2=ELOND2 NLATM1=NLATD1 NLATM2=NLATD2 C C BRING BOTH ENDS INTO RELATIVE COORDINATES, AND MOVE C POINTS OUT OF THE (0.2 DEGREE WIDE) CUT IF NEEDED. C C 1ST POINT: CALL LL2XYZ (INPUT,ELONM1,NLATM1,OUTPUT,V1) P1=V1(1)*VDI01(1)+V1(2)*VDI01(2)+V1(3)*VDI01(3) E1=V1(1)*VDI02(1)+V1(2)*VDI02(2)+V1(3)*VDI02(3) U1=V1(1)*VDI03(1)+V1(2)*VDI03(2)+V1(3)*VDI03(3) VT(1)=P1 VT(2)=E1 VT(3)=U1 CALL XYZ2LL (INPUT,VT,OUTPUT,ELONM1,NLATM1) ELONM1=MAX(ELONM1,-179.9) ELONM1=MIN(ELONM1,+179.9) C REDO RELATIVE CARTESIAN VECTOR, IN CASE MODIFIED: CALL LL2XYZ (INPUT,ELONM1,NLATM1,OUTPUT,VT) P1=VT(1) E1=VT(2) U1=VT(3) C C 2ND POINT: CALL LL2XYZ (INPUT,ELONM2,NLATM2,OUTPUT,V2) P2=V2(1)*VDI01(1)+V2(2)*VDI01(2)+V2(3)*VDI01(3) E2=V2(1)*VDI02(1)+V2(2)*VDI02(2)+V2(3)*VDI02(3) U2=V2(1)*VDI03(1)+V2(2)*VDI03(2)+V2(3)*VDI03(3) VT(1)=P2 VT(2)=E2 VT(3)=U2 CALL XYZ2LL (INPUT,VT,OUTPUT,ELONM2,NLATM2) ELONM2=MAX(ELONM2,-179.9) ELONM2=MIN(ELONM2,+179.9) C REDO RELATIVE CARTESIAN VECTOR, IN CASE MODIFIED: CALL LL2XYZ (INPUT,ELONM2,NLATM2,OUTPUT,VT) P2=VT(1) E2=VT(2) U2=VT(3) C C TEST FOR CROSSING THE CUT C IF (E1.EQ.E2) THEN CUT=.FALSE. ELSE FRAC=(0.-E1)/(E2-E1) IF ((FRAC.GT.0.).AND.(FRAC.LT.1.)) THEN P=P1+FRAC*(P2-P1) CUT=(P.LT.0.0) ELSE CUT=.FALSE. ENDIF ENDIF IF (CUT) THEN C LOCATE CUT POINT U=U1+FRAC*(U2-U1) R=SQRT(P**2+U**2) P=P/R E=0. U=U/R VT(1)=P VT(2)=E VT(3)=U CALL XYZ2LL (INPUT,VT,OUTPUT,CUTLON,CUTLAT) C NOTE: RELATIVE DEGREES; CUTLON SHOULD BE +-180. C C PLOT FIRST SEGMENT IF (E1.LT.0.) THEN CUTLON= -179.9 ELSE CUTLON= +179.9 ENDIF C BACK TO ORIGINAL COORDINATES CALL LL2XYZ (INPUT,CUTLON,CUTLAT,OUTPUT,VT) P=VT(1)*VDI01(1)+VT(2)*VDI02(1)+VT(3)*VDI03(1) E=VT(1)*VDI01(2)+VT(2)*VDI02(2)+VT(3)*VDI03(2) U=VT(1)*VDI01(3)+VT(2)*VDI02(3)+VT(3)*VDI03(3) VT(1)=P VT(2)=E VT(3)=U CALL XYZ2LL (INPUT,VT,OUTPUT,THELON,THELAT) CALL MYCURV (INPUT,ELOND1,NLATD1, + THELON,THELAT,GREAT,PERLON) C C PLOT SECOND SEGMENT IF (E2.LT.0.) THEN CUTLON= -179.9 ELSE CUTLON= +179.9 ENDIF C BACK TO ORIGINAL COORDINATES CALL LL2XYZ (INPUT,CUTLON,CUTLAT,OUTPUT,VT) P=VT(1)*VDI01(1)+VT(2)*VDI02(1)+VT(3)*VDI03(1) E=VT(1)*VDI01(2)+VT(2)*VDI02(2)+VT(3)*VDI03(2) U=VT(1)*VDI01(3)+VT(2)*VDI02(3)+VT(3)*VDI03(3) VT(1)=P VT(2)=E VT(3)=U CALL XYZ2LL (INPUT,VT,OUTPUT,THELON,THELAT) CALL MYCURV (INPUT,THELON,THELAT, + ELOND2,NLATD2,GREAT,PERLON) ELSE C USE ORIGINAL, UNMODIFIED COORDINATES CALL MYCURV (INPUT,ELOND1,NLATD1, + ELOND2,NLATD2,GREAT,PERLON) ENDIF ELSE C USE ORIGINAL, UNMODIFIED COORDINATES CALL MYCURV (INPUT,ELOND1,NLATD1,ELOND2,NLATD2,GREAT,PERLON) ENDIF RETURN END C C C SUBROUTINE MYCURV (INPUT,ELOND1,NLATD1,ELOND2,NLATD2, + GREAT,PERLON) C C GIVEN THE ENDPOINTS OF A LINE IN DEGREES OF LONG. AND LAT. C (ALREADY TESTED, AND KNOWN NOT TO CROSS ANY LONGIUTUDE CUTS) C THIS ROUTINE WILL SELECT A METHOD FOR DRAWING IT ON THE MAP: C C IF (GREAT), WHICH IS NORMALLY TRUE, THE ENDPOINTS DEFINE C AN ARC OF A GREAT CIRCLE, WHICH WILL BE SLIGHTLY CURVED C AFTER MAP PROJECTION. IF NOT, THEN A STRAIGHT LINE IS C DRAWN ON THE MAP (THIS OPTION IS ONLY FOR COMPATIBILITY OF C CONTOUR LINES WITH -SHADE-ING IN B/W, BECAUSE -SHADE- C BOUNDS ITS AREAS WITH STRAIGHT LINES ON THE MAP, NOT C WITH ARCS OF GREAT CIRCLES! C C ALL INPUT COORDINATES ARE IN DEGREES. C LOGICAL GREAT REAL NLATD1,NLATD2 DIMENSION XLIST(2),YLIST(2) C IF (GREAT) THEN C DRAW AN ARC OF A GREAT CIRCLE XLIST(1)=ELOND1 YLIST(1)=NLATD1 XLIST(2)=ELOND2 YLIST(2)=NLATD2 CALL CURVE (XLIST,YLIST,2,0) ELSE C DRAW A STRAIGHT LINE (ON THE MAP) CALL RLVEC (ELOND1,NLATD1,ELOND2,NLATD2,0) ENDIF RETURN END C C C SUBROUTINE UNIT (MODIFY,ANYVEC) C C CONVERTS ANY 3-COMPONENT VECTOR TO A UNIT VECTOR C DIMENSION ANYVEC(3) R2=ANYVEC(1)*ANYVEC(1)+ANYVEC(2)*ANYVEC(2)+ + ANYVEC(3)*ANYVEC(3) IF (R2.GT.0.) THEN SIZE=1./SQRT(R2) ANYVEC(1)=ANYVEC(1)*SIZE ANYVEC(2)=ANYVEC(2)*SIZE ANYVEC(3)=ANYVEC(3)*SIZE ELSE ANYVEC(1)=1. ANYVEC(2)=0. ANYVEC(3)=0. ENDIF RETURN END C C C SUBROUTINE CROSS (INPUT,A,B, + OUTPUT,C) C C COMPUTES VECTOR CROSS PRODUCT C = A x B C DIMENSION A(3),B(3),C(3) C(1)=A(2)*B(3)-A(3)*B(2) C(2)=A(3)*B(1)-A(1)*B(3) C(3)=A(1)*B(2)-A(2)*B(1) RETURN END C C C SUBROUTINE GOPLOT (INPUT,COLOR,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE,LAND) C C INITIALIZES THE MAP AT THE CENTER OF THE PLOT C C AS OUTPUT PROVIDES SELECTION OF PROJECTION, AND SCALE C AT MAP CENTER. C C COLOR = LOGICAL VARIABLE; SHOULD COLORS BE USED TO DISTINGUISH C BETWEEN CONTOUR LEVELS (OR JUST SHADINGS)? C DEGWID = WIDTH OF MAP, IN DEGREES OF LONGITUDE C IPEN1,IPEN2,IPEN3 = WIDTHS OF PEN FOR FINE, MEDIUM, HEAVY LINES. C MXBN = MAXIMUM NUMBER OF BOUNDARY NODES ALLOWED. C NCOND = ACTUAL NUMBER OF BOUNDARY NODES (MAY BE 0). C NODCON = INTEGER LIST OF BOUNDARY NODES. C PERLON = EAST LONGITUDE OF MAP CENTER, IN DEGREES. C PERLAT = NORTH LATITUDE OF MAP CENTER, IN DEGREES. C XNODE = THETA, OR COLATITUDES OF ALL NODES, IN RADIANS. C YNODE = PHI, OR EAST LONGITUDE OF ALL NODES, IN RADIANS. C DEGPEI = DEGREES OF LONGITUDE PER PLOT INCH, AT CENTER. C MAPTYP = 1 FOR MERCATOR, 2 FOR STEREOGRAPHIC C (THE TWO MAIN CONFORMAL MAP OPTIONS) C XWIDE = WIDTH OF THE PAPER, IN INCHES; USED TO ALIGN C SAMPLE VECTORS/FAULT SYMBOLS, ETC. EITHER 8.5 OR 11. C LAND = T FOR LANDSCAPE FORMAT, F FOR PORTRAIT FORMAT C C (ALL THAT IS LEFT IS TO DRAW VECTORS, ETC. C AND TO PROVIDE THE HEADER LABELS.) C LOGICAL COLOR,GREAT,LAND REAL LAT1,LAT1S,LAT2,LON1,LON1S,LON2,NLAT1,NLAT2 DIMENSION NODCON(MXBN),TV1(3),TV2(3),TV3(3), + XNODE(MXNODE),YNODE(MXNODE) DATA OEZOPI /57.29577951/ C C SELECT TYPE OF PROJECTION C IF (DEGWID.GE.181.) THEN C MERCATOR MAP CENTERED ON EQUATOR (GOOD FOR GLOBAL VIEWS) MAPTYP=1 ELSE C STEREOGRAPHIC PROJECTION (GOOD FOR SMALL AREAS) MAPTYP=2 ENDIF C C FIND EXTREME DISTANCES (GREAT CIRCLE ARC RADIANS) C BETWEEN CENTER OF MAP AND N-MOST, E-MOST, S-MOST, W-MOST C BOUNDARY NODES CALL LL2XYZ (INPUT,PERLON,PERLAT, + OUTPUT,TV1) ARCTON = 0. ARCTOE = 0. ARCTOS = 0. ARCTOW = 0. DO 50 I = 1, NCOND NODE = NODCON(I) LON2 = YNODE(NODE)* 57.2957 LAT2 = 90.0 - XNODE(NODE)*57.2957 CALL LL2XYZ (INPUT,PERLON,PERLAT, + OUTPUT,TV2) CALL COMPAS (INPUT,TV1,TV2, + OUTPUT,AZIM) C AZIM IS IN RADIANS CLOCKWISE FROM NORTH, AT TV1 DOT = TV1(1)*TV2(1)+TV1(2)*TV2(2)+TV1(3)*TV2(3) CALL CROSS (INPUT,TV1,TV2, + OUTPUT,TV3) CROSSM = SQRT(TV3(1)**2+TV3(2)**2+TV3(3)**2) ARC = ATAN2F(CROSSM,DOT) C ARC IS ALWAYS POSITIVE, AND IN RADIANS IF (COS(AZIM).GT.0.7071) THEN ARCTON = MAX(ARCTON,ARC) ELSE IF (COS(AZIM).LT.-0.7071) THEN ARCTOS = MAX(ARCTOS,ARC) ELSE IF (SIN(AZIM).GT.0.) THEN ARCTOE = MAX(ARCTOE,ARC) ELSE ARCTOW = MAX(ARCTOW,ARC) END IF 50 CONTINUE C C SELECT PAGE WIDTH AND HEIGHT LAND = (MAPTYP.EQ.1).OR.(MAX(ARCTOE,ARCTOW).GE. + MAX(ARCTON,ARCTOS)) IF (LAND) THEN C LANDSCAPE FORMAT CALL PAGE (11.,8.5) ELSE C PORTRAIT FORMAT CALL PAGE (8.5,11.) ENDIF C C RETURN ALL VARIABLES TO DEFAULTS C (NOTE: IN -ORBMAPAI-, CALL RESET(ALL) MUST FOLLOW CALL PAGE.) C CALL RESET ('ALL') C C SELECT MAP PROJECTION (ONLY CONFORMAL MAPS ARE USED): IF (MAPTYP.EQ.1) THEN CALL PROJCT ('MERCATOR ') ELSE IF (MAPTYP.EQ.2) THEN CALL PROJCT ('STEREOGRAPHIC ') ENDIF C C SET CENTER POINT OF MAP C CALL MAPOLE(PERLON,PERLAT) C C ARGUMENTS TO AREA2D ARE DIFFERENT FROM -ORBMAP- ! C (IN ORDER TO ACTUALLY GET THE SAME RESULT!!!) IF (LAND) THEN CALL AREA2D (9.8,5.444) XWIDE=11. ELSE CALL AREA2D (7.0,8.0) XWIDE=8.5 ENDIF C C DEFINE MAP LIMITS AND FREQUENCY OF MARGINAL LABELS ELON1=PERLON-0.5*DEGWID ELON2=PERLON+0.5*DEGWID IF (MAPTYP.EQ.1) THEN DLON=DEGWID/18. ELSE DLON=DEGWID/6. C SPECIAL CASE OF PLOT INCLUDING POLE: IF ((90.-ABS(PERLAT)).LE.(0.7*DEGWID)) DLON=10.001 ENDIF IF (DLON.LT.1.5) THEN DLON=1. ELSE IF (DLON.LT.3.5) THEN DLON=2. ELSE IF (DLON.LT.10.) THEN DLON=5. ELSE ILON=(DLON/5.)+0.5 DLON=ILON*5. ENDIF NLAT1=PERLAT-0.5*DEGWID NLAT2=PERLAT+0.5*DEGWID IF (MAPTYP.EQ.1) THEN NLAT1=MAX(PERLAT-70.,NLAT1) NLAT2=MIN(PERLAT+70.,NLAT2) ENDIF C CALL MAPGR (ELON1,DLON,ELON2,NLAT1,DLON,NLAT2) C C DETERMINE SCALE AT CENTER C CALL MAP2XY (INPUT,PERLON,PERLAT+1., + OUTPUT,ROTAT,XP,YP) CALL MAP2XY (INPUT,PERLON,PERLAT-1., + OUTPUT,ROTAT,XM,YM) DEGPEI=(2./SQRT((XP-XM)**2+(YP-YM)**2))*72. C C DRAW THE OUTER BOUNDARY OF THE GRID, IF ANY. C GREAT=.TRUE. IF (NCOND.GE.2) THEN CALL THKVEC (IPEN3+0.05) LAT1=90.-OEZOPI*XNODE(NODCON(1)) LON1=OEZOPI*YNODE(NODCON(1)) LAT1S=LAT1 LON1S=LON1 DO 100 I=2,NCOND LAT2=90.-OEZOPI*XNODE(NODCON(I)) LON2=OEZOPI*YNODE(NODCON(I)) CALL MYARC (INPUT,LON1,LAT1,LON2,LAT2, + ELON1,ELON2,GREAT) LAT1=LAT2 LON1=LON2 100 CONTINUE CALL MYARC (INPUT,LON1,LAT1,LON1S,LAT1S, + ELON1,ELON2,GREAT) CALL RESET ('THKVEC') ENDIF C RETURN END C C C SUBROUTINE EDOT (INPUT,DXS,DYS, + FPSFER,MXEL, + MXNODE,NODES,NUMEL,RADIUS,SITA,V, + OUTPUT,ERATE) C C COMPUTE STRAIN-RATE COMPONENTS EDOTXX, EDOTYY, AND C EDOTXY (TENSOR FORM; EQUAL TO C (1/2) * ((DVX/DY)+(DVY/DX)) C AT THE INTEGRATION POINTS OF TRIANGULAR CONTINUUM ELEMENTS. C DOUBLE PRECISION POINTS,V DIMENSION DXS(2,2,3,7,MXEL),DYS(2,2,3,7,MXEL), + ERATE(3,7,MXEL), + FPSFER(2,2,3,7,MXEL), + NODES(3,MXEL), POINTS(3,7), + SITA(7,MXEL),V(2,MXNODE) COMMON /S1S2S3/ POINTS C DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=0. EYY=0. EXY=0. DO 800 J=1,3 NODE=NODES(J,I) VX=V(1,NODE) VY=V(2,NODE) DY11=DYS(1,1,J,M,I)/SIN(SITA(M,I)) DY21=DYS(2,1,J,M,I)/SIN(SITA(M,I)) DY12=DYS(1,2,J,M,I)/SIN(SITA(M,I)) DY22=DYS(2,2,J,M,I)/SIN(SITA(M,I)) FP11=FPSFER(1,1,J,M,I)/TAN(SITA(M,I)) FP21=FPSFER(2,1,J,M,I)/TAN(SITA(M,I)) FP12=FPSFER(1,2,J,M,I)/TAN(SITA(M,I)) FP22=FPSFER(2,2,J,M,I)/TAN(SITA(M,I)) EXX=EXX+VX*DXS(1,1,J,M,I)+VY*DXS(2,1,J,M,I) EYY=EYY+VX*DY12+VY*DY22+VX*FP11+VY*FP21 EXY=EXY+VX*DY11+VY*DY21 + +VX*DXS(1,2,J,M,I)+VY*DXS(2,2,J,M,I) + -VX*FP12-VY*FP22 800 CONTINUE ERATE(1,M,I)=EXX/RADIUS ERATE(2,M,I)=EYY/RADIUS ERATE(3,M,I)=0.5*EXY/RADIUS 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE SQUARE (INPUT,BRIEF,FDIP,IUNIT8, + MXBN,MXEL,MXFEL,MXNODE, + MXSTAR,NFL,NODEF,NODES, + NUMEL,NUMNOD,RADIUS,WEDGE, + MODIFY,XNODE,YNODE, + OUTPUT,AREA,DETJ, + DXS,DYS,DXSP,DYSP,EDGEFS, + EDGETS,FLEN,FPFLT,FPSFER, + FARG,NCOND,NODCON,SITA, + WORK,CHECKN,LIST) C C CHECK, CORRECT, AND COMPLETE THE GEOMETRY OF THE GRID C LOGICAL AGREED,ALLOK,BRIEF,FOUND,SWITCH,VERT1,VERT2 C C NOTE: THE FOLLOWING TYPE COULD BE "LOGICAL*1" IN IBM VS-FORTRAN: LOGICAL CHECKN,EDGEFS,EDGETS,GOON C CHARACTER*21 OBLIQU,TAG1,TAG2,VERTIC DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS DIMENSION FANGLE(2),FPHI(4,7),FPOINT(7),FGAUSS(7),PHI(2),THETA(2) DIMENSION AREA(MXEL),CHECKN(MXNODE), + DETJ(7,MXEL), + DXS(2,2,3,7,MXEL),DYS(2,2,3,7,MXEL), + DXSP(3,7,MXEL),DYSP(3,7,MXEL), + EDGEFS(2,MXFEL),EDGETS(3,MXEL),FDIP(2,MXFEL), + FLEN(MXFEL), + FPFLT(2,2,2,7,MXFEL), + FPSFER(2,2,3,7,MXEL),FARG(2,MXFEL), + LIST(MXSTAR),NODCON(MXBN), + NODEF(4,MXFEL),NODES(3,MXEL), + SITA(7,MXEL),XNODE(MXNODE),YNODE(MXNODE) DATA OBLIQU /'(DIP SLIP IS ALLOWED)'/ DATA VERTIC /'(STRIKE-SLIP ONLY) '/ C C (1) CHECK THAT ALL NODES ARE CONNECTED TO AT LEAST ONE C CONTINUUM (TRIANGULAR) ELEMENT OR FAULT ELEMENT; C DO 110 I=1,NUMNOD CHECKN(I)=.FALSE. 110 CONTINUE DO 130 I=1,NUMEL DO 120 J=1,3 CHECKN(NODES(J,I))=.TRUE. 120 CONTINUE 130 CONTINUE DO 136 I=1,NFL DO 134 J=1,4 CHECKN(NODEF(J,I))=.TRUE. 134 CONTINUE 136 CONTINUE ALLOK=.TRUE. DO 140 I=1,NUMNOD ALLOK=ALLOK.AND.CHECKN(I) 140 CONTINUE IF (.NOT.ALLOK) THEN WRITE(IUNIT8,150) 150 FORMAT(' BAD GRID TOPOLOGY: FOLLOWING REAL NODES DO NOT'/ 1 ' BELONG TO ANY TRIANGULAR CONTINUUM ELEMENT'/ 2 ' OR FAULT ELEMENT:') DO 160 I=1,NUMNOD IF (.NOT.CHECKN(I)) WRITE (IUNIT8,155) I 155 FORMAT (' ',43X,I6) 160 CONTINUE STOP ENDIF C C (2) AVERAGE TOGETHER THE COORDINATES OF ALL NODES AT ONE "POINT" C DO 410 I=1,NUMNOD CHECKN(I)=.FALSE. C (MEANS "NOT YET INVOLVED IN AVERAGING') 410 CONTINUE DO 490 I=1,NFL DO 480 J1=1,2 NJ1=NODEF(J1,I) C (FAULT ENDS ARE THE ONLY PLACES THAT CAN HAVE PROBLEMS) IF (.NOT.CHECKN(NJ1)) THEN LIST(1)=NJ1 CHECKN(NJ1)=.TRUE. C BEGIN LIST OF NEIGHBORS WITH PAIRED NODE J2=5-J1 NJ2=NODEF(J2,I) LIST(2)=NJ2 CHECKN(NJ2)=.TRUE. NINSUM=2 C FIND SHORTEST FAULT CONNECTED TO EITHER ONE DX=XNODE(NJ1)-XNODE(NJ2) DY=YNODE(NJ1)-YNODE(NJ2) IF (DY.GT.3.14) DY=DY-6.28318 IF (DY.LT.-3.14) DY=DY+6.28318 DY=DY*SIN(XNODE(NJ1)) SHORT=SQRT(DX**2+DY**2) DO 470 K=1,NFL NL1=NODEF(1,K) NL2=NODEF(2,K) NL3=NODEF(3,K) NL4=NODEF(4,K) IF ((NJ1.EQ.NL1).OR.(NJ2.EQ.NL1).OR. + (NJ1.EQ.NL2).OR.(NJ2.EQ.NL2).OR. + (NJ1.EQ.NL3).OR.(NJ2.EQ.NL3).OR. + (NJ1.EQ.NL4).OR.(NJ2.EQ.NL4)) THEN DX=XNODE(NL1)-XNODE(NL2) DY=YNODE(NL1)-YNODE(NL2) IF (DY.GT.3.14) DY=DY-6.28318 IF (DY.LT.-3.14) DY=DY+6.28318 DY=DY*SIN(XNODE(NL1)) TEST=SQRT(DX**2+DY**2) SHORT=MIN(SHORT,TEST) ENDIF 470 CONTINUE C COLLECT ALL CORNER NODES WITHIN 10% OF THIS TOLER=SHORT/10. T2=TOLER**2 DO 471 K=1,NUMNOD IF (.NOT.CHECKN(K)) THEN DX=XNODE(NJ1)-XNODE(K) DY=YNODE(NJ1)-YNODE(K) IF (DY.GT.3.14) DY=DY-6.28318 IF (DY.LT.-3.14) DY=DY+6.28318 DY=DY*SIN(XNODE(NJ1)) R2=DX**2+DY**2 IF (R2.LT.T2) THEN NINSUM=NINSUM+1 IF (NINSUM.GT.MXSTAR) THEN WRITE(IUNIT8,421) 421 FORMAT(/' INCREASE VALUE' + ,' OF PARAMETER MAXATP.') STOP ENDIF LIST(NINSUM)=K CHECKN(K)=.TRUE. ENDIF ENDIF 471 CONTINUE C (QUICK EXIT IF ALL NODES IN SAME PLACE) AGREED=.TRUE. DO 472 K=2,NINSUM AGREED=AGREED.AND. + (XNODE(LIST(K)).EQ.XNODE(LIST(1))).AND. + (YNODE(LIST(K)).EQ.YNODE(LIST(1))) 472 CONTINUE IF (AGREED) GO TO 480 XSUM=0. YSUM=0. DO 473 K=1,NINSUM XSUM=XSUM+XNODE(LIST(K)) YSUM=YSUM+YNODE(LIST(K)) 473 CONTINUE XMEAN=XSUM/NINSUM YMEAN=YSUM/NINSUM RMAX=0. DO 474 K=1,NINSUM R=SQRT((XNODE(LIST(K))-XMEAN)**2+ + (YNODE(LIST(K))-YMEAN)**2) RMAX=MAX(RMAX,R) 474 CONTINUE DO 475 K=1,NINSUM XNODE(LIST(K))=XMEAN YNODE(LIST(K))=YMEAN 475 CONTINUE IF (.NOT.BRIEF) THEN IF (RMAX.GT.0.) THEN WRITE(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 (3) COMPUTE DERIVATIVES OF NODAL C FUNCTIONS AT INTEGRATION POINTS; C THEN CHECK FOR NEGATIVE AREAS C CALL DERIV (INPUT,IUNITT,MXEL,MXNODE,NODES,NUMEL, + RADIUS,XNODE,YNODE, + OUTPUT,AREA,DETJ, + DXS,DYS,DXSP,DYSP,FPSFER,SITA) ALLOK=.TRUE. DO 620 I=1,NUMEL DO 610 M=1,7 TEST=AREA(I)*DETJ(M,I) IF (TEST.LE.0.) THEN WRITE(IUNIT8,605) M,I 605 FORMAT(/' EXCESSIVELY DISTORTED ELEMENT LEADS TO ' + ,'NEGATIVE AREA AT POINT ',I1,' IN ELEMENT ', + I5) WRITE(IUNIT8,606) AREA(I),DETJ(M,I) 606 FORMAT('AREA = ',1P,E12.4,' DETJ: ',0P,F12.6) ALLOK=.FALSE. ENDIF 610 CONTINUE 620 CONTINUE IF (.NOT.ALLOK) STOP C C (4) COMPUTE LENGTHS OF FAULT ELEMENTS. C DO 750 I=1,NFL N1=NODEF(1,I) N2=NODEF(2,I) THETA1=XNODE(N1) THETA2=XNODE(N2) PHI1 =YNODE(N1) PHI2 =YNODE(N2) FLEN(I)=FLTLEN (PHI1,PHI2,RADIUS,THETA1,THETA2) 750 CONTINUE C C (5) MAKE A LIST OF NODES THAT ARE ON THE BOUNDARY AND REQUIRE C BOUNDARY CONDITIONS (NODCON); THESE ARE IN COUNTERCLOCKWISE C ORDER. ALSO MAKE A LISTS OF ELEMENT SIDES WHICH CONTAIN THESE C NODES: EDGETS AND EDGEFS. C NCOND=0 DO 801 I=1,NUMNOD CHECKN(I)=.FALSE. 801 CONTINUE DO 802 I=1,NFL EDGEFS(1,I)=.FALSE. EDGEFS(2,I)=.FALSE. 802 CONTINUE DO 810 I=1,NUMEL DO 809 J=1,3 CALL NEXT (INPUT,I,J,MXEL,MXFEL,NFL,NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) IF (KELE.GT.0) THEN C (ORDINARY INTERIOR SIDE) EDGETS(J,I)=.FALSE. ELSE IF (KFAULT.EQ.0) THEN C (EXTERIOR SIDE) EDGETS(J,I)=.TRUE. N1=NODES(MOD(J, 3)+1,I) N2=NODES(MOD(J+1,3)+1,I) IF (.NOT.CHECKN(N1)) THEN NCOND=NCOND+1 CHECKN(N1)=.TRUE. ENDIF IF (.NOT.CHECKN(N2)) THEN NCOND=NCOND+1 CHECKN(N2)=.TRUE. ENDIF ELSE C (TRIANGULAR ELEMENT HAS AN EXTERIOR FAULT ELEMENT C ADJACENT TO IT) EDGETS(J,I)=.FALSE. N1=NODES(MOD(J, 3)+1,I) IF (NODEF(2,KFAULT).EQ.N1) THEN EDGEFS(2,KFAULT)=.TRUE. DO 806 K=3,4 N=NODEF(K,KFAULT) IF (.NOT.CHECKN(N)) THEN NCOND=NCOND+1 CHECKN(N)=.TRUE. ENDIF 806 CONTINUE ELSE EDGEFS(1,KFAULT)=.TRUE. DO 808 K=1,2 N=NODEF(K,KFAULT) IF (.NOT.CHECKN(N)) THEN NCOND=NCOND+1 CHECKN(N)=.TRUE. ENDIF 808 CONTINUE ENDIF ENDIF 809 CONTINUE 810 CONTINUE IF (NCOND.GT.MXBN) THEN WRITE(IUNIT8,820) NCOND 820 FORMAT(/' INCREASE PARAMETER MAXBN TO',I6,' AND RECOMPILE.') STOP ENDIF C C STOP WORK IF NO BOUNDARY NODES FOUND (GLOBAL GRID) C IF (NCOND.EQ.0) GO TO 899 C C BEGIN CIRCUIT WITH LOWEST-NUMBERED BOUNDARY NODE DO 830 I=1,NUMNOD IF (CHECKN(I)) GO TO 831 830 CONTINUE 831 NODCON(1)=I NDONE=1 NLEFT=NCOND C BEGINNING OF INDEFINATE LOOP WHICH TRACES AROUND THE PERIMETER. C EACH TIME, IT PROGRESSES BY ONE OF 3 STEPS: C -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 BEGINNING OF MAIN INDEFINATE LOOP: 840 NODE=NODCON(NDONE) C C IMPORTANT: CHECK THAT WE ARE NOT REVISITING A NODE! C THIS WOULD MEAN THAT THERE ARE TOO MANY BOUNDARY NODES C TO FIT IN THE SIMPLY-CONNECTED LOOP, AND THAT THERE C ARE EXCESS BOUNDARY NODES SOMEWHERE UNCONNECTED! IF (.NOT.CHECKN(NODE)) THEN NGOOD=NDONE-2 WRITE (IUNIT8,841) NGOOD, NCOND 841 FORMAT(/' ERROR IN GRID, reported by -SQUARE-:' + /' BOUNDARY IS NOT SIMPLY-CONNECTED.' + /' Closed loop of ',I6,' nodes does not' + /' include all ',I6,' boundary nodes.' + /' Run command Perimeter in OrbWeaver' + /' for a map of the bad nodes.'/) WRITE(IUNIT8,869) READ(*,*) GOON IF (GOON) THEN NCOND=0 GOTO 900 ELSE STOP END IF END IF IF (NDONE.GT.1) CHECKN(NODE)=.FALSE. C 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+1,3)+1,I) NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N2 NLEFT=NLEFT-1 IF (NLEFT.GT.0) THEN GO TO 840 ELSE GO TO 870 ENDIF C ELSE, LOOK FOR AN ADJACENT FAULT ELEMENT USING THIS NODE. 850 DO 854 I=1,NFL IF (EDGEFS(1,I)) THEN IF (NODEF(1,I).EQ.NODE) THEN N2=NODEF(2,I) GO TO 856 ENDIF ELSE IF (EDGEFS(2,I)) THEN IF (NODEF(3,I).EQ.NODE) THEN N2=NODEF(4,I) GO TO 856 ENDIF ENDIF 854 CONTINUE GO TO 860 856 NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N2 NLEFT=NLEFT-1 IF (NLEFT.GT.0) THEN GO TO 840 ELSE GO TO 870 ENDIF C ELSE, LOOK FOR ANOTHER EXTERIOR CORNER NODE AT SAME LOCATION 860 DO 865 I=1,NUMNOD IF ((I.NE.NODE).AND.CHECKN(I)) THEN IF ( (ABS(XNODE(I)-X).LT.1.E-6) .AND. + (ABS(YNODE(I)-Y).LT.1.E-6) ) GO TO 867 ENDIF 865 CONTINUE WRITE(IUNIT8,866) NODE 866 FORMAT(' BAD GRID TOPOLOGY: WHILE TRACING PERIMETER,'/ + ' COULD NOT FIND ANY WAY TO CONTINUE FROM NODE ',I6/ + ' EITHER THROUGH SHARED BOUNDARY ELEMENTS, OR'/ + ' THROUGH OTHER BOUNDARY NODES SHARING THE SAME ', + 'POSITION.') WRITE(IUNIT8,869) 869 FORMAT(/' Do you wish to continue plotting anyway? [T/F]: ') READ(*,*) GOON IF (GOON) THEN NCOND=0 GOTO 900 ELSE STOP END IF 867 NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=I NLEFT=NLEFT-1 IF (NLEFT.GT.0) GO TO 840 C END OF INDEFINATE LOOP WHICH TRACES AROUND PERIMETER. 870 IF (.NOT.BRIEF) THEN WRITE(IUNIT8,880) 880 FORMAT(/ /' HERE FOLLOWS A LIST, IN CONSECUTIVE ORDER,'/ + ' OF THE NODES WHICH DEFINE THE PERIMETER'/ + ' OF THE MODEL; THESE NODES REQUIRE BOUNDARY', + ' CONDITIONS:'/' BC# NODE') DO 890 I=1,NCOND N=NODCON(I) WRITE(IUNIT8,882) I, N 882 FORMAT(' ',2I6) 890 CONTINUE N=NODCON(1) WRITE (IUNIT8,892) N 892 FORMAT(' (NOTE: NODE ',I6,' COMPLETES THE LOOP, BUT WILL', + ' NOT BE LISTED TWICE.)') ENDIF 899 CONTINUE C C (6) SURVEY FAULT ELEMENTS AND ISSUE WARNING IF ANY ELEMENT IS OF C MIXED TYPE (PART STRIKE-SLIP, AND PART SHALLOW-DIPPING: C 900 DO 920 I=1,NFL DELD1=FDIP(1,I)-1.570796 DELD2=FDIP(2,I)-1.570796 VERT1=ABS(DELD1).LE.WEDGE VERT2=ABS(DELD2).LE.WEDGE NVPART=0 IF (VERT1) THEN NVPART=NVPART+1 TAG1=VERTIC ELSE TAG1=OBLIQU ENDIF IF (VERT2) THEN NVPART=NVPART+1 TAG2=VERTIC ELSE TAG2=OBLIQU ENDIF SWITCH=((NVPART.GT.0).AND.(NVPART.LT.2)) IF (SWITCH) THEN DIP1=FDIP(1,I)*57.2957795 IF (DIP1.GT.90.) DIP1=DIP1-180. DIP2=FDIP(2,I)*57.2957795 IF (DIP2.GT.90.) DIP2=DIP2-180. WRITE (IUNIT8,905) I,DIP1,TAG1,DIP2,TAG2 905 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES ',A21/ + ' ',F7.2,' DEGREES ',A21/ + ' WHICH MAKES IT MIXED-MODE.'/ + ' SUCH ELEMENTS ARE INACCURATE AND NOT RECOMMENDED.'/ + ' PREFERABLY EACH ELEMENT SHOULD BE OF A SINGLE TYPE.'/ + ' (REMEMBER, DIP NEED NOT BE CONTINUOUS FROM ONE', + ' FAULT ELEMENT TO THE NEXT.)') ELSE NVPART=0 DO 910 M=1,7 DELD=DELD1*FPHI(1,M)+DELD2*FPHI(2,M) IF (ABS(DELD).LE.WEDGE) NVPART=NVPART+1 910 CONTINUE IF ((NVPART.GT.0).AND.(NVPART.LT.7)) THEN IF (NVPART.GE.4) THEN WRITE (IUNIT8,912) I,DIP1,DIP2 912 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES, AND'/ + ' ',F7.2,' DEGREES'/ + ' WHICH APPEAR TO MAKE IT STRIKE-SLIP.'/ + ' HOWEVER, THESE VALUES ARE SUCH THAT DIP-SLIP'/ + ' IS PERMITTED AT ONE OR MORE INTEGRATION POINTS.'/ + ' SUCH ELEMENTS ARE INACCURATE AND NOT RECOMMENDED.'/ + ' PREFERABLY EACH ELEMENT SHOULD BE OF A SINGLE TYPE.'/ + ' (REMEMBER, DIP NEED NOT BE CONTINUOUS FROM ONE', + ' FAULT ELEMENT TO THE NEXT.)') ELSE WRITE (IUNIT8,914) I,DIP1,DIP2 914 FORMAT(/ /' CAUTION:'/ + ' FAULT ELEMENT ',I6,' HAS DIPS OF '/ + ' ',F7.2,' DEGREES, AND'/ + ' ',F7.2,' DEGREES'/ + ' WHICH APPEAR TO MAKE IT FREE-SLIPPING.'/ + ' HOWEVER, THESE VALUES ARE SUCH THAT DIP-SLIP'/ + ' IS PROHIBITED AT ONE OR MORE INTEGRATION POINTS.'/ + ' SUCH ELEMENTS ARE INACCURATE AND NOT RECOMMENDED.'/ + ' PREFERABLY EACH ELEMENT SHOULD BE OF A SINGLE TYPE.'/ + ' (REMEMBER, DIP NEED NOT BE CONTINUOUS FROM ONE', + ' FAULT ELEMENT TO THE NEXT.)') ENDIF ENDIF ENDIF 920 CONTINUE C C (7) CALCULATE FAULT ARGUMENT (IN RADIANS, MEASURED COUNTERCLOCKWISE C FROM +THETA) FOR EACH INTEGRATION POINT IN EACH FAULT ELEMENT. C C HERE USE CROSS PRODUCT "D" OF POSITION VECTOR "A" AND "B" C OF FAULT ELEMENT NODE "N1" AND "N2" RESPECTIVELY, TO CALCULATE C VECTOR "D" IN PLANE OF "A" AND "B" AND PERPENDICULAR TO "A". C THEN USE "D" AND "A" TO DECIDE THE POSITION VECTOR "GOLD" OF C INTERPOLATION POINT "M" AND "G" OF "M+1". FINALLY USE THE C DOT PRODUCT OF OF "GOLD-POL" AND "G-GOLD" TO DECIDE THE ANGLE C BETWEEN THESE TWO VECTORS, I.E., FARG. HERE POL IS POSITION C VECTOR OF NORTH POLE. DO 1000 I=1,NFL N1=NODEF(1,I) N2=NODEF(2,I) THETA(1)=XNODE(N1) THETA(2)=XNODE(N2) PHI(1) =YNODE(N1) PHI(2) =YNODE(N2) ALFAD=FLEN(I)/RADIUS CALL FANGLS(INPUT, PHI,THETA, + OUTPUT, FANGLE) DO 980 J=1,2 FARG(J,I)=FANGLE(J) FANGLE(J)=FANGLE(J)*57.29577951 980 CONTINUE 1000 CONTINUE C C (8) 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-4, 2-3 (J = 1 OR 2): DO 1900 J=1,2 C DIP MUST BE WITHIN "WEDGE" OF VERTICAL FOR CONSTRAINT: IF (ABS(FDIP(J,I)-1.570796).LE.WEDGE) THEN NAZI=J N1=J IF(J.EQ.1) THEN N4=4 ELSE N4=3 ENDIF NODE1=NODEF(N1,I) NODE4=NODEF(N4,I) C NO CONSTRAINT APPLIED WHERE A FAULT ENDS: IF (NODE1.NE.NODE4) THEN C ENDPOINT PAIRS MUST BE CHECKED FOR DUPLICATION: C LOOK FOR OTHER STRIKE-SLIP FAULTS SHARING THIS C PAIR OF NODES, AT EITHER END: FOUND=.FALSE. DO 1600 L=1,NFL IF (L.NE.I) THEN IF (ABS(FDIP(1,L)-1.5708).LE.WEDGE) THEN IF (((NODE1.EQ.NODEF(1,L)).AND. + (NODE4.EQ.NODEF(4,L))).OR. + ((NODE1.EQ.NODEF(4,L)).AND. + (NODE4.EQ.NODEF(1,L)))) THEN FOUND=.TRUE. NUMBER=L NAZL=1 GO TO 1601 ENDIF ENDIF IF (ABS(FDIP(2,L)-1.5708).LE.WEDGE) THEN IF (((NODE1.EQ.NODEF(2,L)).AND. + (NODE4.EQ.NODEF(3,L))).OR. + ((NODE1.EQ.NODEF(3,L)).AND. + (NODE4.EQ.NODEF(2,L)))) THEN FOUND=.TRUE. NUMBER=L NAZL=2 GO TO 1601 ENDIF ENDIF ENDIF 1600 CONTINUE C DON'T WORRY IF THIS PAIR ALREADY CHECKED! 1601 IF (FOUND.AND.(NUMBER.GT.I)) THEN C AVERAGE ARGUMENTS TOGETHER (AVOID CYCLE SHIFTS): IF(NAZI.EQ.NAZL) THEN AZL=FARG(NAZL,NUMBER)+3.141592654 ELSE AZL=FARG(NAZL,NUMBER) ENDIF AZI=FARG(NAZI,I) COSZ=0.5*(COS(AZI)+COS(AZL)) SINZ=0.5*(SIN(AZI)+SIN(AZL)) AZIMUT=ATAN2F(SINZ,COSZ) FARG(NAZI,I)=AZIMUT IF(NAZL.EQ.NAZI) THEN FARG(NAZL,NUMBER)=AZIMUT-3.141592654 ELSE FARG(NAZL,NUMBER)=AZIMUT ENDIF 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 C (9) CALCULATE NODAL FUNCTION AT INTERPOLATION POINTS C ON SPHERICAL GREAT CIRCLE FAULT. C CALL FNODAL (INPUT,IUNITT,MXFEL, + MXNODE,NFL,NODEF,XNODE,YNODE, + OUTPUT,FPFLT) C IF (.NOT. BRIEF) WRITE (IUNIT8,9999) 9999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END C C C SUBROUTINE SIZER (INPUT,ERATE,MODESR,NUMEL, + OUTPUT,E3ME1M) C C FINDS LARGEST (ABS. VALUE) SCALAR DIFFERENCE BETWEEN ANY C TWO OF THE PRINCIPAL VALUES OF TENSOR "ERATE" (E3 - E1), C REPEATS THIS FOR ALL THE ELEMENTS, C AND COMPUTES A MEASURE OF THESE SCALARS AND REPORTS AS "E3ME1M". C C IF MODESR = 1, THE MEASURE IS THE ROOT-MEAN-SQUARE SIZE. C IF MODESR = 2, THE MEASURE IS THE MEAN SIZE. C CHARACTER*80 FILNAM LOGICAL WRITIT DIMENSION ERATE(3,7,NUMEL) C WRITE(*,1) 1 FORMAT(/' Do you wish to write E3-E1 for each element ', + 'to a file? [T/F]: ') READ(*,*)WRITIT IF (WRITIT) THEN WRITE(*,2) 2 FORMAT(' Enter [drive:][\path\]filename for output: ') READ(*,3) FILNAM 3 FORMAT(A) OPEN(UNIT=49,FILE=FILNAM) END IF C SUM=0. 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-EZ),ABS(E2-EZ),ABS(E1-E2)) IF (WRITIT.AND.(M.EQ.1)) THEN WRITE(49,49) I, BIGSHR 49 FORMAT(I6,1P,E12.4) END IF IF (MODESR.EQ.1) THEN SUM=SUM+BIGSHR**2 ELSEIF (MODESR.EQ.2) THEN SUM=SUM+BIGSHR ENDIF 90 CONTINUE 100 CONTINUE SUM=SUM/7. IF (MODESR.EQ.1) THEN E3ME1M=SQRT(SUM/(1.*NUMEL)) ELSEIF (MODESR.EQ.2) THEN E3ME1M=SUM/(1.*NUMEL) ENDIF IF (WRITIT) CLOSE(49) RETURN END C C C SUBROUTINE FICONS (INPUT,CUTLN1,CUTLN2,ERATE,E3ME1M,FRIC,MAPTYP, + MODESR,NTH,NUMEL,POLE,RMSVEC,XIP,YIP) C C DRAWS CONJUGATE-FAULT ICONS, WHOSE SIZE IS PROPORTIONAL TO C EITHER THE VALUE (MODESR = 1) OR THE SQUARE ROOT OF C THE VALUE (MODESR = 2 ) OF C THE STRAIN-RATES ACCOMODATED BY CONJUGATE FAULT SETS C AT THE BRITTLE UPPER SURFACE OF CONTINUUM ELEMENTS. C (E3 - E1, AND EITHER E3 - E2 OR E2 - E1; WE USE ONLY PAIRS C OF PRINCIPAL STRAIN RATES THAT HAVE OPPOSITE SIGNS). C THE (ONE) PRINCIPAL STRAIN RATE WHOSE SIGN IS OPPOSITE TO THE C OTHER TWO IS PARTITIONED INTO TWO PARTS, WHICH CORRESPOND C TO THE TWO SETS OF CONJUGATE FAULTS IT CONTRIBUTES TO. C SYMBOLS ARE SCALED SO THAT E3 - E1 = "E3ME1M" PRODUCES A SYMBOL C OF LENGTH "RMSVEC" DEGREES ON THE MAP (ASSUMING E2 = 0) C (NEAR THE PROJECTION POINT; OTHERS ADJUSTED FOR MAP DISTORTION). C XIP AND YIP HOLD THETA AND PHI (REPECTIVELY) OF INTEGRATION C POINTS; ONLY THE FIRST (CENTER) POINT IS USED. C CONVENTION IS THAT STRAIN IS COMPRESSIVE (INWARD-POINTING) C IF PRINCIPAL VALUE(S) OF ERATE ARE NEGATIVE. C THE ANGLE BETWEEN THE TWO CONJUGATE STRIKE-SLIP FAULT SYMBOLS C IN EACH "X" PATTERN IS DETERMINED BY THE COEFFICIENT OF C FRACTION "FRIC". C "CUTLN1" AND "CUTLN2" ARE MARGINS OF THE MAP, IN DEGREES OF C EAST-LONGITUDE, REQUIRED BY -MYARC -. CUTLN1 < CUTLN2. C "NTH" is an integer decimation factor; only every Nth symbol C is actually plotted. C REAL NLAT LOGICAL E1PART,E2PART,EZPART,GREAT,OK DIMENSION ERATE(3,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) DIMENSION BASE(3),NCTEST(20),OMEGA(3),POLE(3), + STKRAY(1),TV0(3),TV1(3),TV2(3),TV3(3),TV4(3), + XARRAY(20),YARRAY(20) C DATA DIASID /0.20/ C "DIASID" IS THE RATIO OF ONE SIZE OF THE (SQUARE) "DIAMOND" C SYMBOL AT THE END OF A THRUST/LENGTH OF ONE ARM OF THRUST C SYMBOL. DATA PIO180 /0.0174533/ DATA STKRAY(1) /-0.007/ C (SPECIAL CODE IN -ORBMAPAI-: NEGATIVE MEANS SOLID BLACK) C DATA OEZOPI /57.29577951/ C C STATEMENT FUNCTION CONVERTS THETA (RADIANS) TO LATITUDE (DEG.): NLAT(THETA)=90.-OEZOPI*THETA C STATEMENT FUNCTION CONVERTS PHI (RADIANS) TO LONGITUDE (DEG.): C (NOTE: RESULT MUST BE IN RANGE "CUTLN1" TO "CUTLN2") ELON(PHI)=AMOD((OEZOPI*PHI+720.-CUTLN1),360.)+CUTLN1 NCYCLE(PHI)=4.+(PHI*OEZOPI-CUTLN1)/360. C GREAT=.TRUE. SARADS=0.5*ATAN(1./MAX(MIN(FRIC,1.5),0.01)) C THIS IS THE ANGLE BETWEEN SIGMA1H AND STRIKE-SLIP FAULTS CALL BGROUP DO 100 I=1,NUMEL IF (MOD(I,NTH).EQ.0) THEN X=XIP(1,I) Y=YIP(1,I) BASE(1)=COS(Y)*SIN(X) BASE(2)=SIN(Y)*SIN(X) BASE(3)=COS(X) CALL RESIZE (INPUT,BASE,MAPTYP,POLE, + OUTPUT,DIMINI) IF (MODESR.EQ.1) THEN SCALE=0.5*RMSVEC*PIO180*DIMINI*(1./E3ME1M) ELSEIF (MODESR.EQ.2) THEN SCALE=0.5*RMSVEC*PIO180*DIMINI*SQRT(1./E3ME1M) ENDIF C USAGE: RADIUS (NOT DIAMETER) OF ANY SYMBOL, IN RADIANS, IS C = SCALE * (E3-E1) C = SCALE * SQRT(E3-E1) C (ASSUMING THAT E2 = 0 SO WE CAN IGNORE PARTITIONING) 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 C E1 HAS THE UNIQUE SIGN AND IS PARTITIONED E1PART=.TRUE. E2PART=.FALSE. EZPART=.FALSE. ELSE IF ((E1*EZ).GT.0.) THEN C E2 HAS THE UNIQUE SIGN AND IS PARTITIONED E1PART=.FALSE. E2PART=.TRUE. EZPART=.FALSE. ELSE C EZZ HAS THE UNIQUE SIGN AND IS PARTITIONED E1PART=.FALSE. E2PART=.FALSE. EZPART=.TRUE. END IF ANGLE=0.5*ATAN2F(-EXY,(EYY-EXX)/2.) C NOTE THAT INTERNAL VARIABLE "ANGLE" IS DIRECTION OF E1 C MEASURED COUNTERCLOCKWISE FROM +X (+THETA, OR SOUTH). AZIM=3.14159-ANGLE IF ((E1.LT.0.).AND.(E2.GT.0.)) THEN C STRIKE-SLIP FAULTS IF (MODESR.EQ.1) THEN IF (E1PART) THEN FAR=SCALE*2.*ABS(E2) ELSE FAR=SCALE*2.*ABS(E1) END IF ELSEIF (MODESR.EQ.2) THEN IF (E1PART) THEN FAR=SCALE*SQRT(2.*ABS(E2)) ELSE FAR=SCALE*SQRT(2.*ABS(E1)) END IF ENDIF TAZIM=AZIM+SARADS CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV1) TAZIM=TAZIM+3.14159 CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV2) TAZIM=AZIM-SARADS CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV3) TAZIM=TAZIM+3.14159 CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV4) CALL VEC2XY (INPUT,TV1,OUTPUT,X1,Y1) CALL VEC2XY (INPUT,TV2,OUTPUT,X2,Y2) CALL VEC2XY (INPUT,TV3,OUTPUT,X3,Y3) CALL VEC2XY (INPUT,TV4,OUTPUT,X4,Y4) CALL MYARC (INPUT,ELON(Y1),NLAT(X1), + ELON(Y2),NLAT(X2), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y3),NLAT(X3), + ELON(Y4),NLAT(X4), + CUTLN1,CUTLN2,GREAT) ENDIF IF ((E1.LT.0.).AND.(EZ.GT.0.)) THEN C THRUST FAULTS PERP. TO E1 IF (MODESR.EQ.1) THEN IF (E1PART) THEN FAR1=SCALE*2.*ABS(EZ) ELSE FAR1=SCALE*2.*ABS(E1) END IF ELSEIF (MODESR.EQ.2) THEN IF (E1PART) THEN FAR1=SCALE*SQRT(2.*ABS(EZ)) ELSE FAR1=SCALE*SQRT(2.*ABS(E1)) END IF ENDIF TAZIM1=AZIM+1.5708 CALL TURNTO (INPUT,TAZIM1,BASE,FAR1, + OUTPUT,OMEGA,TV1) CALL VEC2XY (INPUT,TV1,OUTPUT,X1,Y1) FAR2=FAR1*(1.-0.707*DIASID) TAZIM2=TAZIM1+ATAN(0.707*DIASID/(1.0-0.707*DIASID)) CALL TURNTO (INPUT,TAZIM2,BASE,FAR2, + OUTPUT,OMEGA,TV2) CALL VEC2XY (INPUT,TV2,OUTPUT,X2,Y2) FAR3=FAR1*(1.00-1.414*DIASID) TAZIM3=TAZIM1 CALL TURNTO (INPUT,TAZIM3,BASE,FAR3, + OUTPUT,OMEGA,TV3) CALL VEC2XY (INPUT,TV3,OUTPUT,X3,Y3) FAR4=FAR2 TAZIM4=TAZIM1-(TAZIM2-TAZIM1) CALL TURNTO (INPUT,TAZIM4,BASE,FAR4, + OUTPUT,OMEGA,TV4) CALL VEC2XY (INPUT,TV4,OUTPUT,X4,Y4) XARRAY(1)=ELON(Y1) NCTEST(1)=NCYCLE(Y1) XARRAY(2)=ELON(Y2) NCTEST(2)=NCYCLE(Y2) XARRAY(3)=ELON(Y3) NCTEST(3)=NCYCLE(Y3) XARRAY(4)=ELON(Y4) NCTEST(4)=NCYCLE(Y4) XARRAY(5)=ELON(Y1) NCTEST(5)=NCYCLE(Y1) NCTEST(6)=NCYCLE(Y) OK=(NCTEST(2).EQ.NCTEST(1)).AND. + (NCTEST(3).EQ.NCTEST(2)).AND. + (NCTEST(4).EQ.NCTEST(3)).AND. + (NCTEST(5).EQ.NCTEST(6)) IF (OK) THEN YARRAY(1)=NLAT(X1) YARRAY(2)=NLAT(X2) YARRAY(3)=NLAT(X3) YARRAY(4)=NLAT(X4) YARRAY(5)=NLAT(X1) CALL SHADE (XARRAY,YARRAY,5,90.,STKRAY,1,0,0) ENDIF FAR0=FAR2 TAZIM0=TAZIM1 CALL TURNTO (INPUT,TAZIM0,BASE,FAR0, + OUTPUT,OMEGA,TV0) CALL VEC2XY (INPUT,TV0,OUTPUT,X0,Y0) CALL MYARC (INPUT,ELON(Y ),NLAT(X ), + ELON(Y0),NLAT(X0), + CUTLN1,CUTLN2,GREAT) C TAZIM1=AZIM-1.5708 CALL TURNTO (INPUT,TAZIM1,BASE,FAR1, + OUTPUT,OMEGA,TV1) CALL VEC2XY (INPUT,TV1,OUTPUT,X1,Y1) TAZIM2=TAZIM1+ATAN(0.707*DIASID/(1.0-0.707*DIASID)) CALL TURNTO (INPUT,TAZIM2,BASE,FAR2, + OUTPUT,OMEGA,TV2) CALL VEC2XY (INPUT,TV2,OUTPUT,X2,Y2) TAZIM3=TAZIM1 CALL TURNTO (INPUT,TAZIM3,BASE,FAR3, + OUTPUT,OMEGA,TV3) CALL VEC2XY (INPUT,TV3,OUTPUT,X3,Y3) TAZIM4=TAZIM1-(TAZIM2-TAZIM1) CALL TURNTO (INPUT,TAZIM4,BASE,FAR4, + OUTPUT,OMEGA,TV4) CALL VEC2XY (INPUT,TV4,OUTPUT,X4,Y4) XARRAY(1)=ELON(Y1) NCTEST(1)=NCYCLE(Y1) XARRAY(2)=ELON(Y2) NCTEST(2)=NCYCLE(Y2) XARRAY(3)=ELON(Y3) NCTEST(3)=NCYCLE(Y3) XARRAY(4)=ELON(Y4) NCTEST(4)=NCYCLE(Y4) XARRAY(5)=ELON(Y1) NCTEST(5)=NCYCLE(Y1) NCTEST(6)=NCYCLE(Y) OK=(NCTEST(2).EQ.NCTEST(1)).AND. + (NCTEST(3).EQ.NCTEST(2)).AND. + (NCTEST(4).EQ.NCTEST(3)).AND. + (NCTEST(5).EQ.NCTEST(6)) IF (OK) THEN YARRAY(1)=NLAT(X1) YARRAY(2)=NLAT(X2) YARRAY(3)=NLAT(X3) YARRAY(4)=NLAT(X4) YARRAY(5)=NLAT(X1) CALL SHADE (XARRAY,YARRAY,5,90.,STKRAY,1,0,0) ENDIF FAR0=FAR2 TAZIM0=TAZIM1 CALL TURNTO (INPUT,TAZIM0,BASE,FAR0, + OUTPUT,OMEGA,TV0) CALL VEC2XY (INPUT,TV0,OUTPUT,X0,Y0) CALL MYARC (INPUT,ELON(Y ),NLAT(X ), + ELON(Y0),NLAT(X0), + CUTLN1,CUTLN2,GREAT) ENDIF IF ((E2.LT.0.).AND.(EZ.GT.0.)) THEN C THRUST FAULTS PERP. TO E2 IF (MODESR.EQ.1) THEN IF (EZPART) THEN FAR1=SCALE*2.*ABS(E2) ELSE FAR1=SCALE*2.*ABS(EZ) END IF ELSEIF (MODESR.EQ.2) THEN IF (EZPART) THEN FAR1=SCALE*SQRT(2.*ABS(E2)) ELSE FAR1=SCALE*SQRT(2.*ABS(EZ)) END IF ENDIF TAZIM1=AZIM CALL TURNTO (INPUT,TAZIM1,BASE,FAR1, + OUTPUT,OMEGA,TV1) CALL VEC2XY (INPUT,TV1,OUTPUT,X1,Y1) FAR2=FAR1*(1.-0.707*DIASID) TAZIM2=TAZIM1+ATAN(0.707*DIASID/(1.0-0.707*DIASID)) CALL TURNTO (INPUT,TAZIM2,BASE,FAR2, + OUTPUT,OMEGA,TV2) CALL VEC2XY (INPUT,TV2,OUTPUT,X2,Y2) FAR3=FAR1*(1.00-1.414*DIASID) TAZIM3=TAZIM1 CALL TURNTO (INPUT,TAZIM3,BASE,FAR3, + OUTPUT,OMEGA,TV3) CALL VEC2XY (INPUT,TV3,OUTPUT,X3,Y3) FAR4=FAR2 TAZIM4=TAZIM1-(TAZIM2-TAZIM1) CALL TURNTO (INPUT,TAZIM4,BASE,FAR4, + OUTPUT,OMEGA,TV4) CALL VEC2XY (INPUT,TV4,OUTPUT,X4,Y4) XARRAY(1)=ELON(Y1) NCTEST(1)=NCYCLE(Y1) XARRAY(2)=ELON(Y2) NCTEST(2)=NCYCLE(Y2) XARRAY(3)=ELON(Y3) NCTEST(3)=NCYCLE(Y3) XARRAY(4)=ELON(Y4) NCTEST(4)=NCYCLE(Y4) XARRAY(5)=ELON(Y1) NCTEST(5)=NCYCLE(Y1) NCTEST(6)=NCYCLE(Y) OK=(NCTEST(2).EQ.NCTEST(1)).AND. + (NCTEST(3).EQ.NCTEST(2)).AND. + (NCTEST(4).EQ.NCTEST(3)).AND. + (NCTEST(5).EQ.NCTEST(6)) IF (OK) THEN YARRAY(1)=NLAT(X1) YARRAY(2)=NLAT(X2) YARRAY(3)=NLAT(X3) YARRAY(4)=NLAT(X4) YARRAY(5)=NLAT(X1) CALL SHADE (XARRAY,YARRAY,5,90.,STKRAY,1,0,0) ENDIF FAR0=FAR2 TAZIM0=TAZIM1 CALL TURNTO (INPUT,TAZIM0,BASE,FAR0, + OUTPUT,OMEGA,TV0) CALL VEC2XY (INPUT,TV0,OUTPUT,X0,Y0) CALL MYARC (INPUT,ELON(Y ),NLAT(X ), + ELON(Y0),NLAT(X0), + CUTLN1,CUTLN2,GREAT) C TAZIM1=AZIM+3.1415 CALL TURNTO (INPUT,TAZIM1,BASE,FAR1, + OUTPUT,OMEGA,TV1) CALL VEC2XY (INPUT,TV1,OUTPUT,X1,Y1) TAZIM2=TAZIM1+ATAN(0.707*DIASID/(1.0-0.707*DIASID)) CALL TURNTO (INPUT,TAZIM2,BASE,FAR2, + OUTPUT,OMEGA,TV2) CALL VEC2XY (INPUT,TV2,OUTPUT,X2,Y2) TAZIM3=TAZIM1 CALL TURNTO (INPUT,TAZIM3,BASE,FAR3, + OUTPUT,OMEGA,TV3) CALL VEC2XY (INPUT,TV3,OUTPUT,X3,Y3) TAZIM4=TAZIM1-(TAZIM2-TAZIM1) CALL TURNTO (INPUT,TAZIM4,BASE,FAR4, + OUTPUT,OMEGA,TV4) CALL VEC2XY (INPUT,TV4,OUTPUT,X4,Y4) XARRAY(1)=ELON(Y1) NCTEST(1)=NCYCLE(Y1) XARRAY(2)=ELON(Y2) NCTEST(2)=NCYCLE(Y2) XARRAY(3)=ELON(Y3) NCTEST(3)=NCYCLE(Y3) XARRAY(4)=ELON(Y4) NCTEST(4)=NCYCLE(Y4) XARRAY(5)=ELON(Y1) NCTEST(5)=NCYCLE(Y1) NCTEST(6)=NCYCLE(Y) OK=(NCTEST(2).EQ.NCTEST(1)).AND. + (NCTEST(3).EQ.NCTEST(2)).AND. + (NCTEST(4).EQ.NCTEST(3)).AND. + (NCTEST(5).EQ.NCTEST(6)) IF (OK) THEN YARRAY(1)=NLAT(X1) YARRAY(2)=NLAT(X2) YARRAY(3)=NLAT(X3) YARRAY(4)=NLAT(X4) YARRAY(5)=NLAT(X1) CALL SHADE (XARRAY,YARRAY,5,90.,STKRAY,1,0,0) ENDIF FAR0=FAR2 TAZIM0=TAZIM1 CALL TURNTO (INPUT,TAZIM0,BASE,FAR0, + OUTPUT,OMEGA,TV0) CALL VEC2XY (INPUT,TV0,OUTPUT,X0,Y0) CALL MYARC (INPUT,ELON(Y ),NLAT(X ), + ELON(Y0),NLAT(X0), + CUTLN1,CUTLN2,GREAT) ENDIF IF ((E1.GT.0.).AND.(EZ.LT.0.)) THEN C NORMAL FAULTS PERP. TO E1 IF (MODESR.EQ.1) THEN IF (E1PART) THEN FAR=SCALE*2.*ABS(EZ) ELSE FAR=SCALE*2.*ABS(E1) END IF ELSEIF (MODESR.EQ.2) THEN IF (E1PART) THEN FAR=SCALE*SQRT(2.*ABS(EZ)) ELSE FAR=SCALE*SQRT(2.*ABS(E1)) END IF ENDIF TAZIM=AZIM+1.7682 CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV1) TAZIM=AZIM+1.3734 CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV2) TAZIM=AZIM-1.3734 CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV3) TAZIM=AZIM-1.7682 CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV4) CALL VEC2XY (INPUT,TV1,OUTPUT,X1,Y1) CALL VEC2XY (INPUT,TV2,OUTPUT,X2,Y2) CALL VEC2XY (INPUT,TV3,OUTPUT,X3,Y3) CALL VEC2XY (INPUT,TV4,OUTPUT,X4,Y4) CALL MYARC (INPUT,ELON(Y1),NLAT(X1), + ELON(Y2),NLAT(X2), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y2),NLAT(X2), + ELON(Y3),NLAT(X3), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y3),NLAT(X3), + ELON(Y4),NLAT(X4), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y4),NLAT(X4), + ELON(Y1),NLAT(X1), + CUTLN1,CUTLN2,GREAT) ENDIF IF ((E2.GT.0.).AND.(EZ.LT.0.)) THEN C NORMAL FAULTS PERP. TO E2 IF (MODESR.EQ.1) THEN IF (EZPART) THEN FAR=SCALE*2.*ABS(E2) ELSE FAR=SCALE*2.*ABS(EZ) END IF ELSEIF (MODESR.EQ.2) THEN IF (EZPART) THEN FAR=SCALE*SQRT(2.*ABS(E2)) ELSE FAR=SCALE*SQRT(2.*ABS(EZ)) END IF ENDIF TAZIM=AZIM+1.7682+1.5708 CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV1) TAZIM=AZIM+1.3734+1.5708 CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV2) TAZIM=AZIM-1.3734+1.5708 CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV3) TAZIM=AZIM-1.7682+1.5708 CALL TURNTO (INPUT,TAZIM,BASE,FAR, + OUTPUT,OMEGA,TV4) CALL VEC2XY (INPUT,TV1,OUTPUT,X1,Y1) CALL VEC2XY (INPUT,TV2,OUTPUT,X2,Y2) CALL VEC2XY (INPUT,TV3,OUTPUT,X3,Y3) CALL VEC2XY (INPUT,TV4,OUTPUT,X4,Y4) CALL MYARC (INPUT,ELON(Y1),NLAT(X1), + ELON(Y2),NLAT(X2), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y2),NLAT(X2), + ELON(Y3),NLAT(X3), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y3),NLAT(X3), + ELON(Y4),NLAT(X4), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y4),NLAT(X4), + ELON(Y1),NLAT(X1), + CUTLN1,CUTLN2,GREAT) ENDIF END IF 100 CONTINUE CALL EGROUP RETURN END C C C SUBROUTINE SIGMA1 (INPUT,COLOR,CUTLN1,CUTLN2,ERATE,MAPTYP, + NTH,NUMEL,POLE,SCALE,XIP,YIP) C C DRAWS MOST-COMPRESSIVE HORIZONTAL STRESS (ACTUALLY, STRAIN-RATE) C AXES, AT ELEMENT CENTERS ONLY. C LENGTH OF EACH ARC IS "SCALE" RADIANS. C XIP AND YIP HOLD THETA AND PHI (REPECTIVELY) OF INTEGRATION C POINTS; ONLY THE FIRST (CENTER) POINT IS USED. C IF (COLOR), THEN NORMAL FAULTING REGIMES ARE RED, C STRIKE-SLIP REGIMES ARE GREEN, AND THRUST REGIMES ARE C BLUE. (NOTE: THERE WOULD BE NO GREEN SYMBOLS WITHOUT SOME C TOLERANCE ON EITHER SIDE OF PURE STRIKE-SLIP; I ALLOW C VERTICAL STRAIN-RATE UP TO 0.2* GREATEST-HORIZONTAL. C "CUTLN1" AND "CUTLN2" ARE MARGINS OF THE MAP, IN DEGREES OF C EAST-LONGITUDE, REQUIRED BY -MYARC -. CUTLN1 < CUTLN2. C "NTH" is an integer decimation factor; only every Nth symbol C is actually plotted. C REAL NLAT LOGICAL BOXIT,COLOR,GREAT DIMENSION ERATE(3,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) DIMENSION BASE(3),POLE(3) C DATA OEZOPI /57.29577951/ C C STATEMENT FUNCTION CONVERTS THETA (RADIANS) TO LATITUDE (DEG.): NLAT(THETA)=90.-OEZOPI*THETA C STATEMENT FUNCTION CONVERTS PHI (RADIANS) TO LONGITUDE (DEG.): C (NOTE: RESULT MUST BE IN RANGE "CUTLN1" TO "CUTLN2") ELON(PHI)=AMOD((OEZOPI*PHI+720.-CUTLN1),360.)+CUTLN1 C GREAT=.TRUE. CALL BGROUP DO 100 I=1,NUMEL IF (MOD(I,NTH).EQ.0) THEN X=XIP(1,I) Y=YIP(1,I) BASE(1)=COS(Y)*SIN(X) BASE(2)=SIN(Y)*SIN(X) BASE(3)=COS(X) YFACT=1./SIN(X) CALL RESIZE (INPUT,BASE,MAPTYP,POLE, + OUTPUT,DIMINI) EXX=ERATE(1,1,I) EYY=ERATE(2,1,I) EXY=ERATE(3,1,I) DIVER=EXX+EYY ER= -DIVER SHEAR=SQRT((1.D0*EXY)**2+0.25D0*(1.D0*EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR ANGLE=0.5*ATAN2F(-EXY,(EYY-EXX)/2.) EHMAX=MAX(ABS(E1),ABS(E2)) IF (COLOR) THEN BOXIT=.FALSE. CALL THKCRV (3.0) IF (ABS(ER).LE.0.2*EHMAX) THEN C STRIKE-SLIP REGIME CALL NEWCLR ('GREEN') ELSE IF (ER.GT.0.0) THEN C THRUST REGIME CALL NEWCLR ('BLUE') ELSE C NORMAL FAULTING REGIME CALL NEWCLR ('RED') ENDIF ELSE C IN B/W, USE WHITE BOX FOR NORMAL, GRAY FOR S-S, C AND BLACK FOR THRUSTING IF (ABS(ER).LE.0.2*EHMAX) THEN C STRIKE-SLIP REGIME CALL THKCRV (3.0) CALL NEWCLR ('GRAY') BOXIT=.FALSE. ELSE IF (ER.GT.0.0) THEN C THRUST REGIME CALL THKCRV (3.0) CALL NEWCLR ('FORE') BOXIT=.FALSE. ELSE C NORMAL FAULTING REGIME CALL THKCRV (1.0) CALL NEWCLR ('FORE') BOXIT=.TRUE. ENDIF ENDIF R=DIMINI*SCALE/2. DX=R*COS(ANGLE) DY=R*SIN(ANGLE)*YFACT IF (BOXIT) THEN DXP=0.12*R*COS(ANGLE+1.5708) DYP=0.12*R*SIN(ANGLE+1.5708)*YFACT CALL MYARC (INPUT,ELON(Y+DY+DYP),NLAT(X+DX+DXP), + ELON(Y-DY+DYP),NLAT(X-DX+DXP), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y-DY+DYP),NLAT(X-DX+DXP), + ELON(Y-DY-DYP),NLAT(X-DX-DXP), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y-DY-DYP),NLAT(X-DX-DXP), + ELON(Y+DY-DYP),NLAT(X+DX-DXP), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y+DY-DYP),NLAT(X+DX-DXP), + ELON(Y+DY+DYP),NLAT(X+DX+DXP), + CUTLN1,CUTLN2,GREAT) ELSE CALL MYARC (INPUT,ELON(Y+DY),NLAT(X+DX), + ELON(Y-DY),NLAT(X-DX), + CUTLN1,CUTLN2,GREAT) ENDIF END IF 100 CONTINUE CALL EGROUP CALL RESET ('THKCRV') CALL RESET ('NEWCLR') RETURN END C C C C Note: Special OrbMapAI version; uses only M=1 values! SUBROUTINE MAXSTR (INPUT,NUMEL,TAUMAT,TAUZZI, + OUTPUT,RMSS) C C FINDS LARGEST (ABS. VALUE) PRINCIPAL STRESS ANOMALY C AND COMPUTES RMS VALUE AND REPORTS AS "RMSS". C Note: Special OrbMapAI version; uses only M=1 values! C DIMENSION TAUMAT(3,7,NUMEL),TAUZZI(7,NUMEL) C SUM=0. M=1 CCCCC 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) DIVER=TXX+TYY SHEAR=SQRT((1.D0*TXY)**2+0.25D0*(1.D0*TXX-TYY)**2) T1=0.5*DIVER-SHEAR T2=0.5*DIVER+SHEAR TZ=TAUZZI(M,I) BIGSTR=MAX(ABS(T1),ABS(T2),ABS(TZ)) SUM=SUM+BIGSTR**2 90 CONTINUE 100 CONTINUE CCCCC SUM=SUM/7. RMSS=SQRT(SUM/(1.*NUMEL)) RETURN END C C C SUBROUTINE SICONS (INPUT,CUTLN1,CUTLN2,DEGWID,MAPTYP, + NTH,NUMEL,POLE,POLEP,POLET, + SCALE,TAUMAT,TAUZZI,XIP,YIP) C C DRAWS PRINCIPAL-STRESS ANOMALY INTEGRAL ICONS, WITH LENGTH C (IN RADIANS) OF C "SCALE" TIMES ABS(TI), AT ELEMENT CENTERS ONLY. C XIP AND YIP HOLD THETA AND PHI (REPECTIVELY) OF INTEGRATION C POINTS; ONLY THE FIRST (CENTER) POINT IS USED. C CONVENTION IS THAT STRESS IS COMPRESSIVE (INWARD-POINTING) C IF PRINCIPAL VALUE(S) OF (TAUMAT + I*TAUZZI) ARE NEGATIVE. C ALSO NOTE THAT INTERNAL VARIABLE "ANGLE" IS DIRECTION OF T1 C MEASURED COUNTERCLOCKWISE FROM +X (+THETA, OR SOUTH). C "CUTLN1" AND "CUTLN2" ARE MARGINS OF THE MAP, IN DEGREES OF C EAST-LONGITUDE, REQUIRED BY -MYARC -. CUTLN1 < CUTLN2. C "NTH" is an integer decimation factor; only every Nth symbol C is actually plotted. C REAL NEW,NLAT LOGICAL FROM,GREAT DIMENSION TAUMAT(3,7,NUMEL),TAUZZI(7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) DIMENSION BASE(3),NEW(3),OLD(3),POLE(3), + ROTMAT(3,3) C DATA OEZOPI /57.29577951/ DATA PIO180 /0.017453293/ C C STATEMENT FUNCTION CONVERTS THETA (RADIANS) TO LATITUDE (DEG.): NLAT(THETA)=90.-OEZOPI*THETA C STATEMENT FUNCTION CONVERTS PHI (RADIANS) TO LONGITUDE (DEG.): C (NOTE: RESULT MUST BE IN RANGE "CUTLN1" TO "CUTLN2") ELON(PHI)=AMOD((OEZOPI*PHI+720.-CUTLN1),360.)+CUTLN1 C GREAT=.TRUE. C CALL BGROUP DO 100 I=1,NUMEL IF (MOD(I,NTH).EQ.0) THEN CALL BGROUP X=XIP(1,I) Y=YIP(1,I) BASE(1)=COS(Y)*SIN(X) BASE(2)=SIN(Y)*SIN(X) BASE(3)=COS(X) YFACT=1./SIN(X) TXX=(TAUMAT(1,1,I)+TAUZZI(1,I)) TYY=(TAUMAT(2,1,I)+TAUZZI(1,I)) TXY=TAUMAT(3,1,I) DIVER=TXX+TYY SHEAR=SQRT((1.D0*TXY)**2+0.25D0*(1.D0*TXX-TYY)**2) T1=0.5*DIVER-SHEAR T2=0.5*DIVER+SHEAR TZ=TAUZZI(1,I) ANGLE=0.5*ATAN2F(-TXY,(TYY-TXX)/2.) C C MOST COMPRESSIVE HORIZONTAL PRINCIPAL STRESS ANOMALY INTEGRAL C IF (T1.LT.0.) THEN FROM=.FALSE. ELSE FROM=.TRUE. ENDIF SIZE=0.5*SCALE*ABS(T1) AZIM=3.14159-ANGLE CALL ARROW (INPUT,X,Y,SIZE,AZIM, + MAPTYP,POLEP,POLET,DEGWID,FROM,.FALSE.) AZIM=AZIM+3.14159 CALL ARROW (INPUT,X,Y,SIZE,AZIM, + MAPTYP,POLEP,POLET,DEGWID,FROM,.FALSE.) C C LEAST COMPRESSIVE HORIZONTAL PRINCIPAL STRESS ANOMALY INTEGRAL C IF (T2.LT.0.) THEN FROM=.FALSE. ELSE FROM=.TRUE. ENDIF SIZE=0.5*SCALE*ABS(T2) AZIM=3.14159/2.-ANGLE CALL ARROW (INPUT,X,Y,SIZE,AZIM, + MAPTYP,POLEP,POLET,DEGWID,FROM,.FALSE.) AZIM=AZIM+3.14159 CALL ARROW (INPUT,X,Y,SIZE,AZIM, + MAPTYP,POLEP,POLET,DEGWID,FROM,.FALSE.) C C VERTICAL PRINCIPAL STRESS ANOMALY INTEGRAL C CALL RESIZE (INPUT,BASE,MAPTYP,POLE, + OUTPUT,DIMINI) IF (TZ.GT.0.) THEN DR=0.5*TZ*SCALE*DIMINI CALL MYARC (INPUT,ELON(Y+0.866*DR*YFACT), + NLAT(X+0.5*DR), + ELON(Y),NLAT(X-DR), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y),NLAT(X-DR), + ELON(Y-0.866*DR*YFACT), + NLAT(X+0.5*DR), + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,ELON(Y-0.866*DR*YFACT), + NLAT(X+0.5*DR), + ELON(Y+0.866*DR*YFACT), + NLAT(X+0.5*DR), + CUTLN1,CUTLN2,GREAT) ELSE DR=0.5*ABS(TZ)*SCALE*DIMINI CSIZE=COS(20.*PIO180) COMP=1.-CSIZE SSIZE=SIN(20.*PIO180) ROTMAT(1,1)=CSIZE+COMP*BASE(1)*BASE(1) ROTMAT(1,2)=COMP*BASE(1)*BASE(2)-SSIZE*BASE(3) ROTMAT(1,3)=COMP*BASE(1)*BASE(3)+SSIZE*BASE(2) ROTMAT(2,1)=COMP*BASE(2)*BASE(1)+SSIZE*BASE(3) ROTMAT(2,2)=CSIZE+COMP*BASE(2)*BASE(2) ROTMAT(2,3)=COMP*BASE(2)*BASE(3)-SSIZE*BASE(1) ROTMAT(3,1)=COMP*BASE(3)*BASE(1)-SSIZE*BASE(2) ROTMAT(3,2)=COMP*BASE(3)*BASE(2)+SSIZE*BASE(1) ROTMAT(3,3)=CSIZE+COMP*BASE(3)*BASE(3) OLD(1)=COS(Y)*SIN(X-DR) OLD(2)=SIN(Y)*SIN(X-DR) OLD(3)=COS(X-DR) TOLD=X-DR POLD=Y DO 90 K=1,18 NEW(1)=ROTMAT(1,1)*OLD(1)+ROTMAT(1,2)*OLD(2)+ + ROTMAT(1,3)*OLD(3) NEW(2)=ROTMAT(2,1)*OLD(1)+ROTMAT(2,2)*OLD(2)+ + ROTMAT(2,3)*OLD(3) NEW(3)=ROTMAT(3,1)*OLD(1)+ROTMAT(3,2)*OLD(2)+ + ROTMAT(3,3)*OLD(3) TNEW=ACOS(NEW(3)) PNEW=ATAN2F(NEW(2),NEW(1)) CALL MYARC (INPUT,ELON(POLD),NLAT(TOLD), + ELON(PNEW),NLAT(TNEW), + CUTLN1,CUTLN2,GREAT) OLD(1)=NEW(1) OLD(2)=NEW(2) OLD(3)=NEW(3) TOLD=TNEW POLD=PNEW 90 CONTINUE ENDIF CALL EGROUP END IF 100 CONTINUE CALL EGROUP RETURN END C C C SUBROUTINE FNODAL (INPUT,IUNITT,MXFEL,MXNODE,NFL,NODEF, + XNODE,YNODE, + OUTPUT,FPFLT) C C CALCULATES VECTOR NODAL FUNCTIONS AT INTERPOLATION POINT ON A C GREAT CIRCLE FAULT ELEMENT C DOUBLE PRECISION FPHI DIMENSION FPHI(4,7),FPFLT(2,2,2,7,MXFEL),FPP(2,2,2,7), + NODEF(4,MXFEL),PHI(2),THETA(2), + XNODE(MXNODE),YNODE(MXNODE) COMMON /FPHIS/ FPHI C SNCCOP: SIN(SITA)*COS(PHAI) AT INTERPOLATION POINT C SNCSNP SIN(SITA)*SIN(PHAI) AT INTERPOLATION POINT C DO 900 I=1,NFL N1=NODEF(1,I) N2=NODEF(2,I) THETA(1)=XNODE(N1) THETA(2)=XNODE(N2) PHI(1)=YNODE(N1) PHI(2)=YNODE(N2) CALL SNODAL (INPUT,PHI,THETA, + OUTPUT,FPP) DO 800 M=1,7 DO 500 J=1,2 DO 400 K=1,2 DO 300 L=1,2 FPFLT(L,K,J,M,I)=FPP(L,K,J,M) 300 CONTINUE 400 CONTINUE 500 CONTINUE SNCCOP=FPHI(1,M)*SIN(THETA(1))*COS(PHI(1))+ + FPHI(2,M)*SIN(THETA(2))*COS(PHI(2)) SNCSNP=FPHI(1,M)*SIN(THETA(1))*SIN(PHI(1))+ + FPHI(2,M)*SIN(THETA(2))*SIN(PHI(2)) COSM =FPHI(1,M)*COS(THETA(1))+FPHI(2,M)*COS(THETA(2)) PP=SQRT(SNCCOP*SNCCOP+SNCSNP*SNCSNP+COSM*COSM) COSM=COSM/PP SITA=ACOS(COSM) IF(SITA.LE.0.0.OR.SITA.GE.3.141592654) THEN SITA=SITA*57.29577951 WRITE(IUNITT,220) M,I,SITA 220 FORMAT('LATITUDE OF INTEGRATION POINT',I5, + ' OF FAULT ELEMENT', + I5,' IS OUT RANGE', + E14.4) ENDIF 800 CONTINUE 900 CONTINUE RETURN END C C C SUBROUTINE FANGLS (INPUT,PHI,THETA, + OUTPUT,FANGLE) C C CALCULATE THE ARGUMENTS (ANGLES COUNTERCLOCKWISE FROM +THETA) C AT BOTH ENDS OF AN ARC OF A GREAT CIRCLE. C DOUBLE PRECISION FPOINT COMMON /SFAULT/ FPOINT DIMENSION FANGLE(2),FPOINT(7),PHI(2),THETA(2) DG180=3.141592654 A1=SIN(THETA(1))*COS(PHI(1)) A2=SIN(THETA(1))*SIN(PHI(1)) A3=COS(THETA(1)) B1=SIN(THETA(2))*COS(PHI(2)) B2=SIN(THETA(2))*SIN(PHI(2)) B3=COS(THETA(2)) S=0.99 XX=S*A1+(1.0-S)*B1 YY=S*A2+(1.0-S)*B2 ZZ=S*A3+(1.0-S)*B3 XVAL=SQRT(XX*XX+YY*YY+ZZ*ZZ) XX=XX/XVAL YY=YY/XVAL ZZ=ZZ/XVAL DX=XX-A1 DY=YY-A2 DZ=ZZ-A3 SITA=THETA(1) PHAI=PHI(1) S1=COS(SITA)*COS(PHAI) S2=COS(SITA)*SIN(PHAI) S3=-SIN(SITA) P1=-SIN(PHAI) P2=COS(PHAI) DXX=DX*S1+DY*S2+DZ*S3 DYY=DX*P1+DY*P2 FANGLE(1)=ATAN2F(DYY,DXX) S=0.01 XX=S*A1+(1.0-S)*B1 YY=S*A2+(1.0-S)*B2 ZZ=S*A3+(1.0-S)*B3 XVAL=SQRT(XX*XX+YY*YY+ZZ*ZZ) XX=XX/XVAL YY=YY/XVAL ZZ=ZZ/XVAL DX=B1-XX DY=B2-YY DZ=B3-ZZ SITA=ACOS(ZZ) PHAI=ATAN2F(YY,XX) IF(PHAI.LT.0.0) PHAI=2.0*DG180+PHAI S1=COS(SITA)*COS(PHAI) S2=COS(SITA)*SIN(PHAI) S3=-SIN(SITA) P1=-SIN(PHAI) P2=COS(PHAI) DXX=DX*S1+DY*S2+DZ*S3 DYY=DX*P1+DY*P2 FANGLE(2)=ATAN2F(DYY,DXX) RETURN END C C C REAL FUNCTION FLTLEN (PHI1,PHI2,RADIUS,THETA1,THETA2) C C CALCULATES LENGTH OF GREAT CIRCLE SEGMENT BETWEEN C POINT (THETA1,PHI1) AND POINT (THETA2,PHI2), C IN PHYSICAL LENGTH UNITS (RADIANS*PLANET RADIUS). C DOUBLE PRECISION AB AB =SIN(THETA1)*SIN(THETA2)*COS(PHI1)*COS(PHI2)+ + SIN(THETA1)*SIN(THETA2)*SIN(PHI1)*SIN(PHI2)+ + COS(THETA1)*COS(THETA2) AB=ACOS(AB) FLTLEN=AB*RADIUS RETURN END C C C SUBROUTINE SNODAL (INPUT,PHI,THETA, + OUTPUT,FPP) C C CALCULATES VECTOR NODAL FUNCTION AT INTERPOLATION POINT ON A C GREAT CIRCLE OF A SIDE OF A FINITE ELEMENT C DOUBLE PRECISION FPHI,PP DIMENSION FPHI(4,7),FPP(2,2,2,7),PHI(2),THETA(2) COMMON /FPHIS/ FPHI C SNCCOP: SIN(SITA)*COS(PHAI) AT INTERPOLATION POINT C SNCSNP SIN(SITA)*SIN(PHAI) AT INTERPOLATION POINT C X1=SIN(THETA(1))*COS(PHI(1)) Y1=SIN(THETA(1))*SIN(PHI(1)) Z1=COS(THETA(1)) X2=SIN(THETA(2))*COS(PHI(2)) Y2=SIN(THETA(2))*SIN(PHI(2)) Z2=COS(THETA(2)) XN=X1+X2 YN=Y1+Y2 ZN=Z1+Z2 XYZN=SQRT(XN*XN+YN*YN+ZN*ZN) XN=XN/XYZN YN=YN/XYZN ZN=ZN/XYZN DD=X1*XN+Y1*YN+Z1*ZN DO 800 M=1,7 XX=FPHI(1,M)*X1+FPHI(2,M)*X2 YY=FPHI(1,M)*Y1+FPHI(2,M)*Y2 ZZ=FPHI(1,M)*Z1+FPHI(2,M)*Z2 PP=SQRT(XX*XX+YY*YY+ZZ*ZZ) XX=XX/PP YY=YY/PP ZZ=ZZ/PP SITAJ=ACOS(ZZ) PHAIJ=ATAN2F(YY,XX) RN=XX*XN+YY*YN+ZZ*ZN PPM=RN/DD CSCS=COS(SITAJ)*COS(PHAIJ) CSSN=COS(SITAJ)*SIN(PHAIJ) SNSN=SIN(SITAJ)*SIN(PHAIJ) SNC=SIN(SITAJ) SNP=SIN(PHAIJ) CSP=COS(PHAIJ) DO 500 J=1,2 FP=FPHI(J,M)*PPM FPP(1,1,J,M)=( COS(THETA(J))*COS(PHI(J))*CSCS + +COS(THETA(J))*SIN(PHI(J))*CSSN + +SIN(THETA(J))*SNC)*FP FPP(2,1,J,M)=(-SIN(PHI(J))*CSCS+COS(PHI(J))*CSSN)*FP FPP(1,2,J,M)=(-COS(THETA(J))*COS(PHI(J))*SNP + +COS(THETA(J))*SIN(PHI(J))*CSP)*FP FPP(2,2,J,M)=( SIN(PHI(J))*SNP + +COS(PHI(J))*CSP)*FP 500 CONTINUE 800 CONTINUE RETURN END C C C SUBROUTINE DERIV (INPUT,IUNITT,MXEL,MXNODE, + NODES,NUMEL, + RADIUS,XNODE,YNODE, + OUTPUT,AREA,DETJ, + DXS,DYS,DXSP,DYSP,FPSFER,SITA) C C SETS UP 6 VECTOR NODAL FUNCTIONS (FPSFER) OF EACH SPHERICAL C TRIANGLE FINITE ELEMENT, AT EACH OF ITS 7 INTEGRATION POINTS. C CALCULATES DXS AND DYS, THE THETA-DERIVATIVE AND PHI-DERIVATIVE C OF EACH OF THESE 6 VECTOR NODAL FUNCTIONS. C ALSO COMPUTES AREA, THE AREAS OF THE PLANE TRIANGLES. C ALSO COMPUTES DETJ, THE LOCAL RATIO OF AREAS ON THE SPHERE C TO AREAS ON THE PLANE TRIANGLES. C DOUBLE PRECISION POINTS DOUBLE PRECISION FFF,SKKC,SKKE,SNCSNE,SNCCSE,CSCCSE,CSCSNE DOUBLE PRECISION XA,XB,XC,YA,YB,YC,ZA,ZB,ZC,XYZP DIMENSION XNODE(MXNODE),YNODE(MXNODE),NODES(3,MXEL),AREA(MXEL) DIMENSION DETJ(7,MXEL) DIMENSION DXS(2,2,3,7,MXEL),DYS(2,2,3,7,MXEL) DIMENSION DXSP(3,7,MXEL),DYSP(3,7,MXEL),POINTS(3,7) DIMENSION PHI(3),THETA(3),SKKC(3),SKKE(3),FFF(3), + SITA(7,MXEL),FPSFER(2,2,3,7,MXEL) COMMON /S1S2S3/ POINTS C C DO 900 I=1,NUMEL DO 100 J=1,3 THETA(J)=XNODE(NODES(J,I)) PHI(J) =YNODE(NODES(J,I)) 100 CONTINUE X21=SIN(THETA(2))*COS(PHI(2))-SIN(THETA(1))*COS(PHI(1)) X31=SIN(THETA(3))*COS(PHI(3))-SIN(THETA(1))*COS(PHI(1)) Y21=SIN(THETA(2))*SIN(PHI(2))-SIN(THETA(1))*SIN(PHI(1)) Y31=SIN(THETA(3))*SIN(PHI(3))-SIN(THETA(1))*SIN(PHI(1)) Z21=COS(THETA(2))-COS(THETA(1)) Z31=COS(THETA(3))-COS(THETA(1)) A=Y21*Z31-Y31*Z21 B=Z21*X31-Z31*X21 C=X21*Y31-X31*Y21 AREAP=SQRT(A*A+B*B+C*C) AREA(I)=RADIUS*RADIUS*(0.5*AREAP) PNX=A/AREAP PNY=B/AREAP PNZ=C/AREAP DD1=SIN(THETA(1))*COS(PHI(1))*PNX DD2=SIN(THETA(1))*SIN(PHI(1))*PNY DD3=COS(THETA(1))*PNZ DD=DD1+DD2+DD3 C C THIS PART IS TO TEST IF KONG'S METHOD AND BIRD'S METHOD ARE SAME FOR C CALCULATING DEERIVATIVE C XA=SIN(THETA(1))*COS(PHI(1)) XB=SIN(THETA(2))*COS(PHI(2)) XC=SIN(THETA(3))*COS(PHI(3)) YA=SIN(THETA(1))*SIN(PHI(1)) YB=SIN(THETA(2))*SIN(PHI(2)) YC=SIN(THETA(3))*SIN(PHI(3)) ZA=COS(THETA(1)) ZB=COS(THETA(2)) ZC=COS(THETA(3)) CKA=(YB*ZC-ZB*YC)*XA+(ZB*XC-XB*ZC)*YA+(XB*YC-YB*XC)*ZA C C C DO 800 M=1,7 SNCCSE=0.0 SNCSNE=0.0 COSM=0.0 DO 200 J=1,3 SNCCSE=SNCCSE+POINTS(J,M)*SIN(THETA(J))*COS(PHI(J)) SNCSNE=SNCSNE+POINTS(J,M)*SIN(THETA(J))*SIN(PHI(J)) COSM=COSM+POINTS(J,M)*COS(THETA(J)) 200 CONTINUE XYZP=SQRT(SNCCSE*SNCCSE+SNCSNE*SNCSNE+COSM*COSM) SNCCSE=SNCCSE/XYZP SNCSNE=SNCSNE/XYZP COSM=COSM/XYZP SITAJ=ACOS(COSM) TY=SNCSNE TX=SNCCSE PHAIJ=ATAN2F(TY,TX) CSCCSE=COS(SITAJ)*COS(PHAIJ) CSCSNE=COS(SITAJ)*SIN(PHAIJ) C C BIRD'S METHOD C FFF(1)=((YB*ZC-ZB*YC)*SNCCSE+(ZB*XC-XB*ZC)*SNCSNE + +(XB*YC-YB*XC)*COSM)/CKA FFF(2)=((YC*ZA-ZC*YA)*SNCCSE+(ZC*XA-XC*ZA)*SNCSNE + +(XC*YA-YC*XA)*COSM)/CKA FFF(3)=((YA*ZB-ZA*YB)*SNCCSE+(ZA*XB-XA*ZB)*SNCSNE + +(XA*YB-YA*XB)*COSM)/CKA SKKC(1)=((YB*ZC-ZB*YC)*CSCCSE + +(ZB*XC-XB*ZC)*CSCSNE + -(XB*YC-YB*XC)*SIN(SITAJ))/CKA SKKC(2)=((YC*ZA-ZC*YA)*CSCCSE + +(ZC*XA-XC*ZA)*CSCSNE + -(XC*YA-YC*XA)*SIN(SITAJ))/CKA SKKC(3)=((YA*ZB-ZA*YB)*CSCCSE + +(ZA*XB-XA*ZB)*CSCSNE + -(XA*YB-YA*XB)*SIN(SITAJ))/CKA SKKE(1)=(-(YB*ZC-ZB*YC)*SNCSNE + +(ZB*XC-XB*ZC)*SNCCSE)/CKA SKKE(2)=(-(YC*ZA-ZC*YA)*SNCSNE + +(ZC*XA-XC*ZA)*SNCCSE)/CKA SKKE(3)=(-(YA*ZB-ZA*YB)*SNCSNE + +(ZA*XB-XA*ZB)*SNCCSE)/CKA C C C SITA(M,I)=SITAJ RR1=SIN(SITAJ)*COS(PHAIJ) RR2=SIN(SITAJ)*SIN(PHAIJ) RR3=COS(SITAJ) RN=RR1*PNX+RR2*PNY+RR3*PNZ PP=DD/RN DPDC=(COS(SITAJ)*COS(PHAIJ)*PNX+COS(SITAJ)*SIN(PHAIJ)*PNY + -SIN(SITAJ)*PNZ) DPDE=(-SIN(SITAJ)*SIN(PHAIJ)*PNX+ + SIN(SITAJ)*COS(PHAIJ)*PNY) DDPN=PP/RN DPDC=-DDPN*DPDC DPDE=-DDPN*DPDE IF(SITA(M,I).LE.0.0.OR.SITA(M,I).GE.3.141592654) THEN SITAMI=SITA(M,I)*57.29577951 WRITE(IUNITT,220) M,I,SITAMI 220 FORMAT(' COLATITUDE OF INTEGRATION POINT',I5, + ' OF ELEMENT', + I5,' IS OUT RANGE', + E14.4) STOP ENDIF DO 500 J=1,3 DXSP(J,M,I)= DPDC*FFF(J)+PP*SKKC(J) DYSP(J,M,I)= DPDE*FFF(J)+PP*SKKE(J) CSCS=COS(THETA(J))*COS(PHI(J)) CSSN=COS(THETA(J))*SIN(PHI(J)) SNC=SIN(THETA(J)) SNE=SIN(PHI(J)) CSE=COS(PHI(J)) FPSFER(1,1,J,M,I)= CSCS*CSCCSE+CSSN*CSCSNE + +SNC*SIN(SITAJ) FPSFER(2,1,J,M,I)=-SNE*CSCCSE+CSE*CSCSNE FPSFER(1,2,J,M,I)=-CSCS*SIN(PHAIJ)+CSSN*COS(PHAIJ) FPSFER(2,2,J,M,I)=SNE*SIN(PHAIJ)+CSE*COS(PHAIJ) DXS(1,1,J,M,I)=(-CSCS*SNCCSE-CSSN*SNCSNE + +SNC*COS(SITAJ))*FFF(J) + +FPSFER(1,1,J,M,I)*SKKC(J) DXS(2,1,J,M,I)=(SNE*SNCCSE-CSE*SNCSNE)*FFF(J) + +FPSFER(2,1,J,M,I)*SKKC(J) DYS(1,1,J,M,I)=(-CSCS*CSCSNE+CSSN*CSCCSE)*FFF(J) + +FPSFER(1,1,J,M,I)*SKKE(J) DYS(2,1,J,M,I)=(SNE*CSCSNE+CSE*CSCCSE)*FFF(J) + +FPSFER(2,1,J,M,I)*SKKE(J) DXS(1,2,J,M,I)=FPSFER(1,2,J,M,I)*SKKC(J) DXS(2,2,J,M,I)=FPSFER(2,2,J,M,I)*SKKC(J) DYS(1,2,J,M,I)=(-CSCS*COS(PHAIJ)-CSSN*SIN(PHAIJ)) + *FFF(J) + +FPSFER(1,2,J,M,I)*SKKE(J) DYS(2,2,J,M,I)=(SNE*COS(PHAIJ)-CSE*SIN(PHAIJ)) + *FFF(J) + +FPSFER(2,2,J,M,I)*SKKE(J) FPSFER(1,1,J,M,I)=FPSFER(1,1,J,M,I)*FFF(J) FPSFER(2,1,J,M,I)=FPSFER(2,1,J,M,I)*FFF(J) FPSFER(1,2,J,M,I)=FPSFER(1,2,J,M,I)*FFF(J) FPSFER(2,2,J,M,I)=FPSFER(2,2,J,M,I)*FFF(J) 500 CONTINUE PFQ=FFF(1)+FFF(2)+FFF(3) DETJ(M,I)=RN**3/(DD*DD) 800 CONTINUE 900 CONTINUE RETURN END C C C BLOCK DATA BD1 C C DEFINE "WEIGHT" (GAUSSIAN INTEGRATION WEIGHTS) OF THE C SEVEN INTEGRATION POINTS IN EACH ELEMENT, DEFINED BY INTERNAL C COORDINATES "POINTS(3,7)", WHERE POINTS(1-3,M)=S1-S3 OF C INTEGRATION POINT NUMBER M. C BECAUSE ALL OF THESE ARRAYS ARE FUNCTIONS OF INTERNAL C COORDINATES, THEY ARE NOT AFFECTED BY SCALING OR DEFORMATION OF C THE ELEMENTS. C DOUBLE PRECISION POINTS,WEIGHT COMMON /S1S2S3/ POINTS COMMON /WGTVEC/ WEIGHT DIMENSION POINTS(3,7),WEIGHT(7) C C C "POINTS" CONTAINS THE INTERNAL COORDINATES (S1,S2,S3) OF THE 7 C GAUSSIAN INTEGRATION POINTS (FOR AREA INTEGRALS) OF THE C TRIANGULAR ELEMENTS. "POINTS" IS ALSO THE SET OF NODAL FUNCTIONS C FOR UNPROJECTED SCALAR QUANTITIES WITHIN AN ELEMENT. DATA POINTS / + 0.3333333333333333D0, 0.3333333333333333D0, 0.3333333333333333D0, + 0.0597158733333333D0, 0.4701420633333333D0, 0.4701420633333333D0, + 0.4701420633333333D0, 0.0597158733333333D0, 0.4701420633333333D0, + 0.4701420633333333D0, 0.4701420633333333D0, 0.0597158733333333D0, + 0.7974269866666667D0, 0.1012865066666667D0, 0.1012865066666667D0, + 0.1012865066666667D0, 0.7974269866666667D0, 0.1012865066666667D0, + 0.1012865066666667D0, 0.1012865066666667D0, 0.7974269866666667D0/ C C "WEIGHT" IS THE GAUSSIAN WEIGHT (FOR AREA INTEGRALS) OF THE 7 C INTEGRATION POINTS IN EACH TRIANGULAR ELEMENT. DATA WEIGHT / 0.2250000000000000D0, + 0.1323941500000000D0, 0.1323941500000000D0, 0.1323941500000000D0, + 0.1259391833333333D0, 0.1259391833333333D0, 0.1259391833333333D0/ C END C C C BLOCK DATA BD2 C C DEFINE "FPHI" (NODAL FUNCTIONS) AND "FGAUSS" (GAUSSIAN INTEGRATION C WEIGHTS) AT THE 7 INTEGRATION POINTS IN EACH FAULT ELEMENT, C DEFINED BY INTERNAL COORDINATE "FPOINT(M=1,...,7)" C WHICH CONTAINS THE RELATIVE POSITION C (FRACTIONAL LENGTH) OF THE INTEGRATION POINTS. C BECAUSE ALL OF THESE ARRAYS ARE FUNCTIONS OF INTERNAL C COORDINATES, THEY ARE NOT AFFECTED BY SCALING OR DEFORMATION OF C THE ELEMENTS. C DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS DIMENSION FPHI(4,7),FPOINT(7),FGAUSS(7) C C "FPOINT" CONTAINS THE SEVEN INTEGRATION POINT LOCATIONS FOR THE FAULT C ELEMENTS. EACH VALUE GIVES A POSITION AS A FRACTION OF TOTAL LENGTH C MEASURED FROM NODE1 TO NODE2 (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 4 NODAL FUNCTIONS (ONE PER NODE) C AT EACH OF THESE 7 INTEGRATION POINTS IN THE FAULT ELEMENT. C A SPECIAL CONVENTION IS THAT THE NODAL FUNCTION OF NODE 3 C IS THE NEGATIVE OF THAT FOR NODE 2, WHILE THE NODAL FUNCTION C FOR NODE 4 IS THE NEGATIVE OF THAT FOR NODE 1. THIS SIMPLIFIES C MANY EXPRESSIONS IN WHICH WE WOULD OTHERWISE HAVE TO HAVE C A SEPARATE FACTOR OR +1 OR -1 FOR THE TWO SIDES OF THE FAULT. DATA FPHI/ + 0.9745539D0, 0.0254461D0, -0.0254461D0, -0.9745539D0, + 0.8707656D0, 0.1292344D0, -0.1292344D0, -0.8707656D0, + 0.7029226D0, 0.2970774D0, -0.2970774D0, -0.7029226D0, + 0.5000000D0, 0.5000000D0, -0.5000000D0, -0.5000000D0, + 0.2970774D0, 0.7029226D0, -0.7029226D0, -0.2970774D0, + 0.1292344D0, 0.8707656D0, -0.8707656D0, -0.1292344D0, + 0.0254461D0, 0.9745539D0, -0.9745539D0, -0.0254461D0/ C END C C C SUBROUTINE RESIZE (INPUT,BASE,MAPTYP,POLE, + OUTPUT,DIMINI) C C DETERMINES THE CORRECTION FACTOR "DIMINI" (DIMINI < 1.00) C NECESSARY TO CORRECT FOR THE RELATIVE DISTORTION OF LENGTHS C ON THE CURRENT MAP. C C "BASE" IS THE POSITION (A CARTESIAN UNIT VECTOR). C "MAPTYP" =1 FOR MERCATOR, 2 FOR STEREOGRAPHIC. C "POLE" IS THE MAP POLE (CENTRAL POINT) (A CARTESIAN UNIT VECTOR). C DIMENSION AXIS(3),BASE(3),EASTP(3),POLE(3) IF (MAPTYP.EQ.1) THEN IF (POLE(3).EQ.1.) THEN EASTP(1)=0. EASTP(2)= -1. EASTP(3)=0. ELSE IF (POLE(3).EQ.-1.) THEN EASTP(1)=0. EASTP(2)=1. EASTP(3)=0. ELSE EASTP(1)= -POLE(2) EASTP(2)=POLE(1) EASTP(3)=0. CALL UNIT (MODIFY,EASTP) ENDIF CALL CROSS (INPUT,POLE,EASTP, + OUTPUT,AXIS) DOT=BASE(1)*AXIS(1)+BASE(2)*AXIS(2)+BASE(3)*AXIS(3) DOT=MIN(1.,MAX(-1.,DOT)) DIMINI=SIN(ACOS(ABS(DOT))) ELSE IF (MAPTYP.EQ.2) THEN DOT=BASE(1)*POLE(1)+BASE(2)*POLE(2)+BASE(3)*POLE(3) DOT=MIN(1.,MAX(-1.,DOT)) ANGLE=ACOS(DOT) IF (ANGLE.GT.0.1) THEN DIMINI=0.5*SIN(ANGLE)*COS(0.5*ANGLE)/SIN(0.5*ANGLE) ELSE DIMINI=1.00 ENDIF ELSE DIMINI=1.00 ENDIF RETURN END C C C SUBROUTINE TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) C C COMPUTES VERTICAL INTEGRALS OF RELATIVE DEVIATORIC C STRESS (TAUMAT). C C THE COMPONENTS ARE: C TAUMAT(1) = VERTICAL INTEGRAL OF (SXX-SZZ) C TAUMAT(2) = VERTICAL INTEGRAL OF (SYY-SZZ) C TAUMAT(3) = VERTICAL INTEGRAL OF SXY. C DIMENSION ALPHA(3,3,7,MXEL),ERATE(3,7,MXEL), + TAUMAT(3,7,MXEL),TOFSET(3,7,MXEL) C DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) TAUMAT(1,M,I)=TOFSET(1,M,I)+EXX*ALPHA(1,1,M,I)+ + EYY*ALPHA(1,2,M,I)+EXY*ALPHA(1,3,M,I) TAUMAT(2,M,I)=TOFSET(2,M,I)+EXX*ALPHA(2,1,M,I)+ + EYY*ALPHA(2,2,M,I)+EXY*ALPHA(2,3,M,I) TAUMAT(3,M,I)=TOFSET(3,M,I)+EXX*ALPHA(3,1,M,I)+ + EYY*ALPHA(3,2,M,I)+EXY*ALPHA(3,3,M,I) 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE 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 ENDIF C C ROUTINE PROCESSING (ON EVERY CALL): C IF (ELEVAT.GT.0.) THEN C LAND ZTOP= -ELEVAT ZBASE=ZSTOP-ELEVAT DENSE1=RHOBAR(1)*(1.-GEOTH1*ALPHAT(1)) H=0. LAYER1=1 ELSE C OCEAN ZTOP=0. ZBASE=ZSTOP+(-ELEVAT) DENSE1=RHOH2O H=ELEVAT LAYER1=0 ENDIF LASTDR=ZBASE/ONEKM IF (ZBASE.GT.ONEKM*LASTDR) LASTDR=LASTDR+1 IF (LASTDR.GT.NDREF) THEN WRITE(IUNITT,110) LASTDR 110 FORMAT(' IN SUBPROGRAM SQUEEZ, PARAMETER NDREF '/ + ' MUST BE INCREASED TO AT LEAST ',I10) 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)) LAYER2=1 ELSE T=TEMPM(H-ZM) DENSE2=RHOBAR(2)*(1.-T*ALPHAT(2)) LAYER2=2 ENDIF ELSE DENSE2=RHOH2O LAYER2=0 ENDIF IF ((LAYER1.EQ.0).AND.(LAYER2.EQ.1)) THEN FRAC2=H/ONEKM FRAC1=1.-FRAC2 ELSE IF ((LAYER1.EQ.1).AND.(LAYER2.EQ.2)) THEN FRAC2=(H-ZM)/ONEKM FRAC1=1.-FRAC2 ELSE FRAC1=0.5 FRAC2=0.5 ENDIF DENSE=FRAC1*DENSE1+FRAC2*DENSE2 IF (Z.GT.0.) THEN N1=Z/ONEKM N2=N1+1 FRAC=Z/ONEKM-N1 PR=PREF(N1)+FRAC*(PREF(N2)-PREF(N1)) ELSE PR=0. ENDIF SIGZZ=SIGZZ-DENSE*GMEAN*ONEKM+(PR-OLDPR) TAUZZ=TAUZZ+0.5*(SIGZZ+OLDSZZ)*ONEKM DENSE1=DENSE2 OLDSZZ=SIGZZ OLDPR=PR LAYER1=LAYER2 200 CONTINUE RESID=ZBASE-Z H=ZSTOP Z=ZBASE IF (ZSTOP.LE.ZM) THEN T=TEMPC(H) DENSE2=RHOBAR(1)*(1.-T*ALPHAT(1)) 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 CALLED=.TRUE. RETURN END C C C C NOTE: Special version for OrbMapAI reports additional C array LIMTED (see notes on LIMITS in SUBROUTINE DIAMND). 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, + LIMTED) 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, LIMITS, LIMTED(2,7,MXEL), 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. LIMTED(1,M,I)=2 LIMTED(2,M,I)=2 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), + LIMITS) LIMTED(1,M,I)=LIMITS 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. LIMTED(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), + LIMITS) LIMTED(2,M,I)=LIMITS 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. LIMTED(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 NOTE: Special version for OrbMapAI; reports LIMITS C =0 in N/N, N/S, T/S, and T/T regions; C =1 in N, S, T regions; C =2 in V region. 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, + LIMITS) 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, LIMITS 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 LIMITS=0 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. LIMITS=1 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. LIMITS=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 LIMITS=0 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 LIMITS=1 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 LIMITS=0 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 LIMITS=0 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 LIMITS=1 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 LIMITS=0 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. LIMITS=2 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 MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DQDTDA, + ECREEP,ELEV,FDIP,FFRIC,FMUMAX, + FPFLT,FARG,GMEAN, + MXFEL,MXNODE,NFL,NODEF, + OFFMAX,OFFSET, + ONEKM,RADIO,RHOH2O,RHOBAR, + SLIDE,SPHERE,TAUMAX, + TLNODE,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) C C THIS SUBPROGRAM CONTAINS THE NONLINEAR RHEOLOGY OF THE FAULTS. C FOR EACH OF 7 INTEGRATION POINTS ALONG THE LENGTH OF EACH FAULT C ELEMENT, IT: C C (1) COMPUTES THE SLIP-RATE VECTOR ON THE FAULT SURFACE, C (2) DETERMINES THE SHEAR STRESS ON THE FAULT SURFACE BY MOHR/ C COULOMB/NAVIER THEORY (THIS STRESS IS PROPORTIONAL TO DEPTH, C SO THE CALCULATION IS ACTUALLY DONE AT UNIT DEPTH AND THEN C SCALED), C (3) PROCEEDS DOWN THE DIP OF THE FAULT, CHECKING TEMPERATURE, C STRAIN-RATE, AND PRESSURE TO SEE IF FRICTIONAL OR CREEP C SHEAR STRESS IS LOWER, C (4) REPORTS THE VERTICAL INTEGRAL OF "MU" (THE RATIO OF SHEAR C STRESS TO SLIP RATE) DOWN THE FAULT AS "FIMUDZ". C (NOTE THAT THE INTEGRAL IS VERTICAL, NOT ON A SLANT, EVEN THOUGH C CONDITIONS ARE EVALUATED ALONG A SLANT PATH.) C (5) FOR DIPPING, OBLIQUE-SLIP 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 (9) FAULTS WITH DIP LESS THAN "SLIDE" (RADIANS) ARE LIMITED C TO A MAXIMUM DOWN-DIP INTEGRAL SHEAR TRACTION OF "TAUMAX". C C NOTE THAT PORE PRESSURES ARE CONSIDERED IN THE CALCULATION OF C FRICTIONAL STRENGTH: C *NORMAL PORE PRESSURES REDUCE THE EFFECTIVE NORMAL STRESS ON THE C FAULT SURFACE BY THE AMOUNT C -BIOT*GMEAN*RHOH20*Z C *IF (OFFMAX.GT.0.), THEN THE REMAINING EFFECTIVE FRICTIONAL STRENGTH C OF THE FAULT IS MULTIPLIED BY THE REDUCING FACTOR C *(1.-BYERLY*OFFSET(I)/OFFMAX). C THIS IS ALSO A PORE PRESSURE EFFECT, BECAUSE 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,SPHERE DOUBLE PRECISION V DOUBLE PRECISION FPHI COMMON /FPHIS/ FPHI REAL MANTLE,NORMAL C DIMENSIONS PER COMMON BLOCK: DIMENSION FPHI(4,7) C DIMENSIONS OF INTERNAL CONVENIENCE ARRAYS: DIMENSION DLEPDZ(2),DSFDZ(2),RHO(2),SHEART(2),TMEAN(2),ZTRANS(2) C DIMENSIONS OF EXTERNAL ARGUMENTS ARRAYS: DIMENSION ACREEP(2),ALPHAT(2),BCREEP(2),CCREEP(2),CONDUC(2), + DCREEP(2),DQDTDA(MXNODE),ELEV(MXNODE), + FC(2,2,7,MXFEL),FDIP(2,MXFEL), + FIMUDZ(7,MXFEL),FPEAKS(2,MXFEL), + FPFLT(2,2,2,7,MXFEL), FSLIPS(MXFEL), + FARG(2,MXFEL),FTSTAR(2,7,MXFEL),NODEF(4,MXFEL), + OFFSET(MXFEL),RADIO(2),RHOBAR(2), + TAUMAX(2),TLNODE(MXNODE), + V(2,MXNODE),ZMNODE(MXNODE),ZTRANF(2,MXFEL) C C FOLLOWING TWO NUMBERS ARE "VERY SMALL" AND "VERY LARGE", BUT NOT C SO EXTREME AS TO CAUSE UNDERFLOW OR OVERFLOW. THEY MAY NEED TO C BE ADJUSTED, DEPENDING ON THE COMPUTER AND COMPILER 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) C C IS THIS A PURELY STRIKE-SLIP FAULT ELEMENT? PURESS=(ABS(FDIP(1,I)-1.570796).LE.WEDGE).AND. + (ABS(FDIP(2,I)-1.570796).LE.WEDGE) C C IF SO, COMPUTE ESTIMATE OF RELATIVE NORMAL STRESS C (RELATIVE TO VERTICAL STRESS) BY USING AMOUNT OF DIVERGENCE C BETWEEN AVERAGE OF NODE N1 AND N2 AND AVERAGE OF NODE N3 C AND NODE N4 (IN SPITE OF CONSTRAINT EQUATION): IF (PURESS) THEN ANGLE=CHORD(FARG(1,I),0.5D0,FARG(2,I)) UNITBX=SIN(ANGLE) UNITBY= -COS(ANGLE) DELVX=V(1,N1)*FPFLT(1,1,1,4,I)+V(2,N1)*FPFLT(2,1,1,4,I) + +V(1,N2)*FPFLT(1,1,2,4,I)+V(2,N2)*FPFLT(2,1,2,4,I) + -V(1,N3)*FPFLT(1,1,2,4,I)-V(2,N3)*FPFLT(2,1,2,4,I) + -V(1,N4)*FPFLT(1,1,1,4,I)-V(2,N4)*FPFLT(2,1,1,4,I) DELVY=V(1,N1)*FPFLT(1,2,1,4,I)+V(2,N1)*FPFLT(2,2,1,4,I) + +V(1,N2)*FPFLT(1,2,2,4,I)+V(2,N2)*FPFLT(2,2,2,4,I) + -V(1,N3)*FPFLT(1,2,2,4,I)-V(2,N3)*FPFLT(2,2,2,4,I) + -V(1,N4)*FPFLT(1,2,1,4,I)-V(2,N4)*FPFLT(2,2,1,4,I) SPREAD=DELVX*UNITBX+DELVY*UNITBY DELTAU=CONSTR*SPREAD TLAN=0.5*(TLNODE(N1)+TLNODE(N2)) ZMAN=0.5*(ZMNODE(N1)+ZMNODE(N2)) IF ((TLAN.LE.0.).OR.(ZTRANF(2,I).LE.0.)) THEN C CRUST 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)*ZMAN+ + 0.5*ZTRANF(2,I)**2) ENDIF C DDPNDZ IS THE GRADIENT OF EXCESS NORMAL PRESSURE (IN C EXCESS OF VERTICAL PRESSURE) WITH DEPTH ON THIS FAULT; C CHECK THAT IT LIES WITHIN FRICTIONAL LIMITS OF BLOCKS: Q=0.25*(DQDTDA(N1)+DQDTDA(N2)+ + DQDTDA(N3)+DQDTDA(N4)) TTRANS=TSURF+ZTRANF(1,I)*Q/CONDUC(1)- + ZTRANF(1,I)**2*RADIO(1)/(2.*CONDUC(1)) TMEANC=(TSURF+TTRANS)/2. RHOC=RHOBAR(1)*(1.-ALPHAT(1)*TMEANC) DLEPDC=GMEAN*(RHOC-RHOH2O*BIOT) THRUST=DLEPDC*CGAMMA NORMAL=DLEPDC/CGAMMA DDPNDZ=MAX(DDPNDZ,NORMAL-DLEPDC) DDPNDZ=MIN(DDPNDZ,THRUST-DLEPDC) C ELSE C DIFFERENT LOGIC WILL BE USED; THIS PARAMETER IS NOT C REALLY NEEDED. ZERO IT JUST TO BE CAREFUL. DDPNDZ=0. ENDIF C DO 90 M=1,7 C ELEVATION: ELEVAT=ELEV(N1)*FPHI(1,M)+ELEV(N2)*FPHI(2,M) C C HEAT-FLOW: Q=DQDTDA(N1)*FPHI(1,M)+DQDTDA(N2)*FPHI(2,M) C C CRUSTAL THICKNESS: CRUST=ZMNODE(N1)*FPHI(1,M)+ZMNODE(N2)*FPHI(2,M) C C MANTLE LITHOSPHERE THICKNESS: MANTLE=TLNODE(N1)*FPHI(1,M)+TLNODE(N2)*FPHI(2,M) MANTLE=MAX(MANTLE,0.) C C MOHO TEMPERATURE: TMOHO=TSURF+CRUST*Q/CONDUC(1)- + CRUST**2*RADIO(1)/(2.*CONDUC(1)) C C TEMPERATURE AT BASE OF PLATE: TASTH=TMOHO+MANTLE*(Q-CRUST*RADIO(1))/CONDUC(2)- + MANTLE**2*RADIO(2)/(2.*CONDUC(2)) C C MEAN TEMPERATURES: TMEAN(1)=(TSURF+TMOHO)/2. TMEAN(2)=(TMOHO+TASTH)/2. C C MEAN DENSITIES: RHO(1)=RHOBAR(1)*(1.-ALPHAT(1)*TMEAN(1)) RHO(2)=RHOBAR(2)*(1.-ALPHAT(2)*TMEAN(2)) C C DERIVATIVES 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=CHORD(FARG(1,I),FPHI(2,M),FARG(2,I)) C C UNITA IS A UNIT VECTOR ALONG THE FAULT, FROM N1 TO N2. UNITAX=COS(ANGLE) UNITAY=SIN(ANGLE) C C UNITB IS A PERPENDICULAR UNIT VECTOR, POINTING OUT C TOWARD THE N4-N3 SIDE. UNITBX= -UNITAY UNITBY= +UNITAX C C RELATIVE VELOCITIES ARE FOR N1-2 SIDE RELATIVE TO C THE N4-3 SIDE: DELVX=V(1,N1)*FPFLT(1,1,1,M,I)+V(2,N1)*FPFLT(2,1,1,M,I) + +V(1,N2)*FPFLT(1,1,2,M,I)+V(2,N2)*FPFLT(2,1,2,M,I) + -V(1,N3)*FPFLT(1,1,2,M,I)-V(2,N3)*FPFLT(2,1,2,M,I) + -V(1,N4)*FPFLT(1,1,1,M,I)-V(2,N4)*FPFLT(2,1,1,M,I) DELVY=V(1,N1)*FPFLT(1,2,1,M,I)+V(2,N1)*FPFLT(2,2,1,M,I) + +V(1,N2)*FPFLT(1,2,2,M,I)+V(2,N2)*FPFLT(2,2,2,M,I) + -V(1,N3)*FPFLT(1,2,2,M,I)-V(2,N3)*FPFLT(2,2,2,M,I) + -V(1,N4)*FPFLT(1,2,1,M,I)-V(2,N4)*FPFLT(2,2,1,M,I) C C SINISTRAL STRIKE-SLIP RATE COMPONENT: SINIST=DELVX*UNITAX+DELVY*UNITAY C C CONVERGENCE RATE COMPONENT (IN HORIZONTAL PLANE): CLOSE =DELVX*UNITBX+DELVY*UNITBY C C DIP OF THE FAULT (FROM HORIZONTAL ON THE N1-N2 SIDE): DIP=FDIP(1,I)*FPHI(1,M)+FDIP(2,I)*FPHI(2,M) SLOPED=ABS(DIP-1.570796).GT.WEDGE C IF (.NOT.SLOPED) THEN C CASE OF A NEAR-VERTICAL FAULT: DSFDZ(1)=(DLEPDZ(1)+DDPNDZ)*FRIC SFMOHO=DSFDZ(1)*CRUST DSFDZ(2)=(DLEPDZ(2)+DDPNDZ)*FRIC SLIP=ABS(SINIST) LOCKED=.FALSE. ELSE C CASE OF A SHALLOW-DIPPING FAULT: C C VUPDIP IS THE UP-DIP VELOCITY COMPONENT, IN THE C FAULT PLANE, OF THE BLOCK ON THE N1-N3 SIDE. VUPDIP=CLOSE/COS(DIP) C C RAKE ANGLE IS MEASURED COUNTERCLOCKWISE IN C FAULT PLANE FROM HORIZONTAL & PARALLEL TO ANGLE. RAKE=ATAN2F(VUPDIP,SINIST) C C DERIVATIVE 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 C LIMIT SHEAR TRACTION ON SUBDUCTION ZONES ONLY: C DIPPY=MIN(DIP,3.141592654-DIP) IF (DIPPY.LE.SLIDE) THEN IF (ELEVAT.LT.0.0) THEN C APPLY OCEANIC SUBDUCTION ZONE LIMIT: VITDZ=MIN(VITDZ,TAUMAX(1)*SIN(DIP)) ELSE C APPLY CONTINENTAL SUBDUCTION ZONE LIMIT: VITDZ=MIN(VITDZ,TAUMAX(2)*SIN(DIP)) END IF ENDIF C 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)=MIN(SHEART(1),DCREEP(1)) ZTRANF(2,I)=ZTRANS(2) FPEAKS(2,I)=MIN(SHEART(2),DCREEP(2)) ENDIF C 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE LIMITS (INPUT,AREA,DETJ,IUNITT,MXEL,NUMEL, + OKDELV,RADIUS,REFSTR,SPHERE, + TLINT,TRHMAX,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) C C COMPUTE AREA, MEAN THICKNESS, AND OTHER DIMENSIONAL PARAMETERS C OF THE PLATE, THEN DETERMINE VALUES OF STIFFNESS LIMITS NEEDED C TO KEEP VELOCITY ERR0RS DOWN TO ORDER "OKDELV" AT SHEAR STRESS C LEVEL "REFSTR". C LOGICAL SPHERE DOUBLE PRECISION WEIGHT COMMON /WGTVEC/ WEIGHT DIMENSION WEIGHT(7) DIMENSION AREA(MXEL),DETJ(7,MXEL),TLINT(7,MXEL),ZMOHO(7,MXEL) C TOTALA=0. TOTALV=0. DO 20 M=1,7 DO 10 I=1,NUMEL DA=AREA(I)*DETJ(M,I)*WEIGHT(M) TOTALA=TOTALA+DA TOTALV=TOTALV+DA*(ZMOHO(M,I)+TLINT(M,I)) 10 CONTINUE 20 CONTINUE THICK=TOTALV/TOTALA IF (SPHERE) THEN SIDE=RADIUS NFAULT=1 ELSE SIDE=SQRT(TOTALA) NFAULT=4 ENDIF CONSTR=NFAULT*REFSTR*THICK/OKDELV ETAMAX=REFSTR*THICK/(SIDE*OKDELV) ETAMAX=MIN(ETAMAX,TRHMAX/OKDELV) FMUMAX=NFAULT*REFSTR/OKDELV VISMAX=0.25*REFSTR*SIDE/OKDELV WRITE (IUNITT,50) TOTALA,TOTALV,THICK,SIDE,CONSTR,ETAMAX, + FMUMAX,VISMAX 50 FORMAT (/ /' SUBPROGRAM -LIMITS- PERFORMS DIMENSIONAL ANALYSIS'/ + ' AND ESTIMATES NECESSARY STIFFNESS LIMITS TO BALANCE'/1P, + ' THE CONFLICTING OBJECTIVES OF ACCURACY AND PRECISION:'/ / + ' AREA OF MODEL = ',E10.3,' LENGTH**2'/ + ' VOLUME OF MODEL = ',E10.3,' LENGTH**3'/ + ' TYPICAL THICKNESS = ',E10.3,' LENGTH'/ + ' TYPICAL WIDTH = ',E10.3,' LENGTH'/ + ' CONSTR (CONSTRAINT WEIGHT) = ',E10.3,' FORCE-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 INTERP (INPUT,FATNOD,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,FATIP) C C INTERPOLATE A SCALAR FUNCTION KNOWN AT THE NODES ("FATNOD") C TO VALUES AT THE 7 INTEGRATION POINTS IN EACH TRIANGULAR C CONTINUUM ELEMENT. C DOUBLE PRECISION POINTS COMMON /S1S2S3/ POINTS DIMENSION POINTS(3,7) DIMENSION FATNOD(MXNODE),FATIP(7,MXEL),NODES(3,MXEL) C DO 100 M=1,7 DO 90 I=1,NUMEL FATIP(M,I)=POINTS(1,M)*FATNOD(NODES(1,I))+ + POINTS(2,M)*FATNOD(NODES(2,I))+ + POINTS(3,M)*FATNOD(NODES(3,I)) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE 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 FOUNDF DIMENSION NODEF(4,MXFEL),NODES(3,MXEL) C C THREE NODE NUMBERS ALONG THE SIDE OF INTEREST, COUNTERCLOCKWISE: N1=NODES(MOD(J, 3)+1,I) N2=NODES(MOD(J+1,3)+1,I) C CHECK FOR ADJACENT FAULT ELEMENT FIRST: FOUNDF=.FALSE. KFAULT=0 IF (NFL.GT.0) THEN DO 10 K=1,NFL M1=NODEF(1,K) M2=NODEF(2,K) M3=NODEF(3,K) M4=NODEF(4,K) IF (((M1.EQ.N2).AND.(M2.EQ.N1)).OR. + ((M3.EQ.N2).AND.(M4.EQ.N1))) THEN FOUNDF=.TRUE. KFAULT=K GO TO 11 ENDIF 10 CONTINUE 11 IF (.NOT.FOUNDF) KFAULT=0 C IF THERE WAS A FAULT, REPLACE 2 NODE NUMBERS THAT WE SEARCH FOR: IF (FOUNDF) THEN IF (M2.EQ.N1) THEN N1=M3 N2=M4 ELSE N1=M1 N2=M2 ENDIF ENDIF ENDIF C SEARCH FOR ADJACENT TRIANGULAR CONTINUUM ELEMENT: KELE=0 KLOW=I KHIGH=I C --- BEGIN IRREGULAR LOOP, TO SEARCH OUT NEAREST ELEMENTS FIRST --- 100 KLOW=KLOW-1 IF (KLOW.GE.1) THEN DO 110 L=1,3 M1=NODES(MOD(L, 3)+1,KLOW) M2=NODES(MOD(L+1,3)+1,KLOW) IF ((M2.EQ.N1).AND.(M1.EQ.N2)) THEN KELE=KLOW RETURN ENDIF 110 CONTINUE ENDIF KHIGH=KHIGH+1 IF (KHIGH.LE.NUMEL) THEN DO 120 L=1,3 M1=NODES(MOD(L, 3)+1,KHIGH) M2=NODES(MOD(L+1,3)+1,KHIGH) IF ((M2.EQ.N1).AND.(M1.EQ.N2)) THEN KELE=KHIGH RETURN ENDIF 120 CONTINUE ENDIF IF ((KLOW.GT.1).OR.(KHIGH.LT.NUMEL)) GO TO 100 RETURN END C C C SUBROUTINE CULL (INPUT,NUMBER,THINGS, + OUTPUT,NTH) C C TELLS USER THAT "NUMBER" OF "THINGS" WILL APPEAR IN THE C PLOT IF WE USE DEFAULT DECIMATION FACTOR OF 1; C ALLOWS ENTRY OF A HIGHER FACTOR. C INTEGER NUMBER, NTH, IOS CHARACTER*(*) THINGS 1 WRITE (*,10) NUMBER, TRIM(THINGS) 10 FORMAT (/' Plot will contain ',I7,' ',A, + /' at default decimation factor of 1;' + /' Enter desired integer factor (>= 1): '\) READ (*, *, IOSTAT = IOS) NTH IF (IOS .NE. 0) THEN WRITE (*, 20) 20 FORMAT (' ERROR: Your response was not an integer.') GO TO 1 END IF IF (NTH .LT. 1) THEN WRITE (*, 30) 30 FORMAT (' ERROR: Values < 1 not allowed.') GO TO 1 END IF END C C C SUBROUTINE ETCH (COLOR,CUTLN1,CUTLN2, + FDIP,FLEN,FARG, + IPEN1,IPEN2,IPEN3, + MXFEL,MXNODE, + NFL,NODEF,NODES,NUMEL,NUMNOD, + RADIUS,SLIDE,WEDGE, + XNODE,YNODE) C C PLOTS THE FINITE ELEMENT GRID. C CHARACTER*4 KOLOR LOGICAL COLOR,GREAT,SIDE REAL LAT1,LAT2,LON1,LON2 DIMENSION FDIP(2,NFL),FLEN(NFL),FARG(2,NFL), + NODEF(4,NFL),NODES(3,NUMEL), + XNODE(NUMNOD),YNODE(NUMNOD) DIMENSION XPLOT(1),YPLOT(1) DATA OEZOPI /57.29577951/ C GREAT=.TRUE. C C PLOT NODES, IF NUMBER IS NOT EXCESSIVE (IN BLUE, IF COLOR) C IF (NUMNOD.LE.400) THEN IF (COLOR) THEN CALL NEWCLR ('BLUE') ELSE CALL NEWCLR ('FORE') END IF C USE CENTERED HEXAGON SYMBOL (1): CALL MARKER (1) CALL BGROUP DO 10 I=1,NUMNOD PHIDEG=YNODE(I)*OEZOPI PHIDEG=CUTLN1+AMOD(PHIDEG-CUTLN1+720.,360.) XPLOT(1)=PHIDEG THETA=XNODE(I) YPLOT(1)=90.-OEZOPI*THETA CALL CURVE (XPLOT,YPLOT,1,-1) 10 CONTINUE CALL EGROUP IF (COLOR) CALL RESET ('NEWCLR') ENDIF 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 NEWCLR ('GREEN') ELSE CALL NEWCLR ('FORE') CALL DOT ENDIF C CALL BGROUP DO 20 I=1,NUMEL DO 19 K=1,3 SIDE=.TRUE. NODEA=NODES(MOD(K,3)+1,I) NODEB=NODES(MOD(K+1,3)+1,I) DO 11 J=1,NFL IF (((NODEF(2,J).EQ.NODEA).AND. + (NODEF(1,J).EQ.NODEB)).OR. + ((NODEF(4,J).EQ.NODEA).AND. + (NODEF(3,J).EQ.NODEB))) SIDE=.FALSE. 11 CONTINUE IF (SIDE) THEN DO 12 J=1,I-1 IF (((NODES(2,J).EQ.NODEA).AND. + (NODES(1,J).EQ.NODEB)).OR. + ((NODES(3,J).EQ.NODEA).AND. + (NODES(2,J).EQ.NODEB)).OR. + ((NODES(1,J).EQ.NODEA).AND. + (NODES(3,J).EQ.NODEB))) SIDE=.FALSE. 12 CONTINUE IF (SIDE) THEN LAT1=90.-OEZOPI*XNODE(NODEA) LON1=OEZOPI*YNODE(NODEA) LAT2=90.-OEZOPI*XNODE(NODEB) LON2=OEZOPI*YNODE(NODEB) CALL MYARC (INPUT,LON1,LAT1,LON2,LAT2, + CUTLN1,CUTLN2,GREAT) ENDIF ENDIF 19 CONTINUE 20 CONTINUE CALL EGROUP C IF (COLOR) THEN CALL NEWCLR ('RED') ELSE CALL NEWCLR ('FORE') CALL RESET ('DOT') ENDIF C C PLOT FAULTS (IN RED, IF COLOR) C IF (NFL.GT.0) THEN SUM=0.0 DO 25 I=1,NFL SUM=SUM+FLEN(I)/RADIUS 25 CONTINUE AVERAG=SUM/NFL IF (NUMNOD.LE.600) THEN NTIC=3 DIPSIZ=0.15*AVERAG ELSE NTIC=1 DIPSIZ=0.40*AVERAG ENDIF IF (COLOR) THEN KOLOR='RED ' ELSE KOLOR='FORE' END IF CALL FAULTS (INPUT,COLOR,CUTLN1,CUTLN2, + FARG,FDIP, + IPEN2,KOLOR,MXFEL, + MXNODE,NFL,NODEF,NTIC,DIPSIZ, + SLIDE,WEDGE,XNODE,YNODE) ENDIF IF (COLOR) CALL RESET ('NEWCLR') C RETURN END C C C SUBROUTINE FAULTS (INPUT,COLOR,CUTLN1,CUTLN2, + FARG,FDIP, + IPEN,KOLOR,MXFEL, + MXNODE,NFL,NODEF,NTIC,SIZE, + SLIDE,WEDGE,XNODE,YNODE) C C DRAWS THE WHOLE SET OF FAULTS, C ARRANGING FOR ALL TRACES TO BE IN ONE GRAPHICS GROUP, C AND ALL DIP SYMBOLS IN ANOTHER. C THIS IS SOMEWHAT COMPUTATIONALLY INEFFICIENT, BUT ALLOWS C FOR FILLING (OR DELETING), AND EMPHASIZING OR DEEMPHASIZING C THE DIP SYMBOLS DURING HAND-EDITING. C NOTE: UNLIKE -FAULT-, DOES NOT PERMIT DASHING OF INACTIVE FAULTS. C CHARACTER*4 KOLOR INTEGER IPEN LOGICAL COLOR,DASHED,DOTICS,DOTRAC DIMENSION FDIP(2,MXFEL),FARG(2,MXFEL),NODEF(4,MXFEL), + XNODE(MXNODE),YNODE(MXNODE) C DASHED=.FALSE. C DOTRAC=.TRUE. DOTICS=.FALSE. CALL BGROUP DO 100 I=1,NFL CALL FAULT (INPUT,COLOR,CUTLN1,CUTLN2,DASHED, + DOTICS,DOTRAC,FARG,FDIP, + I, + IPEN,KOLOR,MXFEL, + MXNODE,NODEF,NTIC, + SIZE,SLIDE,WEDGE,XNODE,YNODE) 100 CONTINUE CALL EGROUP C DOTRAC=.FALSE. DOTICS=.TRUE. CALL BGROUP DO 200 I=1,NFL CALL FAULT (INPUT,COLOR,CUTLN1,CUTLN2,DASHED, + DOTICS,DOTRAC,FARG,FDIP, + I, + IPEN,KOLOR,MXFEL, + MXNODE,NODEF,NTIC, + SIZE,SLIDE,WEDGE,XNODE,YNODE) 200 CONTINUE CALL EGROUP RETURN END C C C SUBROUTINE FAULT (INPUT,COLOR,CUTLN1,CUTLN2,DASHED, + DOTICS,DOTRAC,FARG,FDIP, + I, + IPEN,KOLOR,MXFEL, + MXNODE,NODEF,NTIC, + SIZE,SLIDE,WEDGE,XNODE,YNODE) C C DRAW ONE FAULT ELEMENT (IF DOTRAC), WITH DIP SYMBOLS (IF DOTICS). C THE DIP SYMBOLS HAVE A CHARACTERISTIC DIMENSION C OF "SIZE" (RADIANS), AND THERE ARE "NTIC" C SYMBOLS ALONG EACH ELEMENT. C IF LOGICAL FLAG "DASHED" IS ON, THE LINE IS DASHED. C C (CAUTION: INPUT PARAMETER "I" MUST NOT BE CHANGED!) C PARAMETER (MXPNTS=10,NSTEP=7) CHARACTER*4 KOLOR INTEGER IPEN,USETIC LOGICAL COLOR,DASHED,DOTICS,DOTRAC,GREAT REAL LAT0,LAT1,LAT2,LON0,LON1,LON2 DOUBLE PRECISION FPHI,FPOINT,FGAUSS COMMON /SFAULT/ FPOINT COMMON /FPHIS/ FPHI COMMON /FGLIST/ FGAUSS DIMENSION FPHI(4,7),FPOINT(7),FGAUSS(7) DIMENSION FDIP(2,MXFEL),FARG(2,MXFEL), + ICYCLE(MXPNTS), + NODEF(4,MXFEL), + XARAY(MXPNTS),YARAY(MXPNTS), + XARRAY(MXPNTS),YARRAY(MXPNTS), + XNODE(MXNODE),YNODE(MXNODE) DIMENSION USETIC(7,7) DATA OEZOPI /57.29577951/ C C STATEMENT FUNCTION: PHIVAL(S,F1,F2)=F1*(1.-S)+F2*S C STEP=1./(1.*NSTEP) C CALL NEWCLR (KOLOR) GREAT=.TRUE. IF (DOTRAC) CALL THKVEC (IPEN+0.05) I1=NODEF(1,I) I2=NODEF(2,I) X1=XNODE(I1) X2=XNODE(I2) Y1=YNODE(I1) Y2=YNODE(I2) A1=COS(Y1)*SIN(X1) B1=SIN(Y1)*SIN(X1) G1=COS(X1) A2=COS(Y2)*SIN(X2) B2=SIN(Y2)*SIN(X2) G2=COS(X2) D1=FDIP(1,I) D2=FDIP(2,I) ARG1=FARG(1,I) ARG2=FARG(2,I) LON1=OEZOPI*Y1 LAT1=90.-OEZOPI*X1 C C NOTE: ALL FAULTS ARE "WASTEFULLY" PLOTTED IN SEGMENTS, BECAUSE C THE RESULT IS MORE ACCURATE AFTER PROJECTION OF THE GLOBE. C S=0. DO 10 K=1,NSTEP S=S+STEP A=PHIVAL(S,A1,A2) B=PHIVAL(S,B1,B2) G=PHIVAL(S,G1,G2) R=SQRT(A*A+B*B+G*G) A=A/R B=B/R G=G/R EQUPAR=SQRT(A*A+B*B) X=ATAN2F(EQUPAR,G) Y=ATAN2F(B,A) LON2=OEZOPI*Y LAT2=90.-OEZOPI*X IF (DASHED.AND.(MOD(K,2).EQ.0)) THEN C (SKIP THIS SEGMENT) ELSE IF (DOTRAC) CALL MYARC (INPUT,LON1,LAT1,LON2,LAT2, + CUTLN1,CUTLN2,GREAT) ENDIF LON1=LON2 LAT1=LAT2 10 CONTINUE IF (DOTRAC) CALL RESET ('THKVEC') 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 GREAT=.FALSE. MTIC=MIN(NTIC,3) IF (DOTICS.AND.(MTIC.GT.0)) THEN CALL RESET ('THKVEC') DO 100 K=1,MTIC M=USETIC(K,MTIC) S=FPOINT(M) A0=PHIVAL(S,A1,A2) B0=PHIVAL(S,B1,B2) G0=PHIVAL(S,G1,G2) R=SQRT(A0*A0+B0*B0+G0*G0) A0=A0/R B0=B0/R G0=G0/R EQUPAR=SQRT(A0*A0+B0*B0) X0=ATAN2F(EQUPAR,G0) Y0=ATAN2F(B0,A0) LON0=OEZOPI*Y0 LAT0=90.-OEZOPI*X0 C NOTE: "ARG" AND "PARG" ARE COUNTERCLOCKWISE FROM EAST: ARG= -1.570796+CHORD(ARG1,S*1.0D0,ARG2) DIP=PHIVAL(S,D1,D2) IF (DIP.LT.1.5708) THEN PARG=ARG-1.570796 ELSE PARG=ARG+1.570796 ENDIF PX=SIZE*OEZOPI*COS(PARG)/SIN(X0) PY=SIZE*OEZOPI*SIN(PARG) C "PX,PY" ARE D.LON AND D.LAT OF A STRAIGHT TIC C "DX,DY" ARE D.LON AND D.LAT OF A PERPENDICULAR C OFFSET THAT IS HALF AS LONG. DX= 0.5*SIZE*OEZOPI*SIN(PARG)/SIN(X0) DY= -0.5*SIZE*OEZOPI*COS(PARG) FROMVE=ABS(1.570796-DIP) IF (FROMVE.LT.WEDGE) THEN C VERTICAL STRIKE-SLIP FAULT ELSE IF (FROMVE.LT.0.610865) THEN C DIP LESS THAN VERTICAL, BUT UNDER 55: C NORMAL FAULT CALL MYARC (INPUT,LON0,LAT0, + LON0+PX,LAT0+PY, + CUTLN1,CUTLN2,GREAT) ELSE IF (FROMVE.LT.0.95993) THEN C DIP BETWEEN 55 AND 35: C INTERMEDIATE-DIP FAULT CALL MYARC (INPUT,LON0+DX,LAT0+DY, + LON0+DX+PX,LAT0+DY+PY, + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,LON0+DX+PX,LAT0+DY+PY, + LON0-DX+PX,LAT0-DY+PY, + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,LON0-DX+PX,LAT0-DY+PY, + LON0-DX,LAT0-DY, + CUTLN1,CUTLN2,GREAT) ELSE IF (FROMVE.LT.(1.570796-SLIDE)) THEN C DIP FROM 35 TO SUBDIP: C ORDINARY THRUST FAULT CALL MYARC (INPUT,LON0+DX,LAT0+DY, + LON0+PX,LAT0+PY, + CUTLN1,CUTLN2,GREAT) CALL MYARC (INPUT,LON0+PX,LAT0+PY, + LON0-DX,LAT0-DY, + CUTLN1,CUTLN2,GREAT) ELSE C DIP OF SUBDIP OR LESS: C SUBDUCTION-ZONE FAULT CGPB NPNTS=4 XARAY(1)=LON0+DX YARAY(1)=LAT0+DY XARAY(2)=LON0+PX YARAY(2)=LAT0+PY XARAY(3)=LON0-DX YARAY(3)=LAT0-DY XARAY(4)=XARAY(1) YARAY(4)=YARAY(1) MXGAPS=1 IF (.NOT.COLOR) GAPRAY=-1.0 C SPECIAL CODE PASSED THROUGH MYSHAD TO SHADE, C REQUESTING SOLID-BLACK INSTEAD OF A PATTERN. C CALL MYSHAD (INPUT,XARAY,YARAY,NPNTS,ANGLE,GAPRAY, + MXGAPS,MXPNTS,NGAPS, + CUTLN1,COLOR, + WORK,ICYCLE, + XARRAY,YARRAY) ENDIF 100 CONTINUE ENDIF C IF (COLOR) CALL RESET ('NEWCLR') RETURN END C C C SUBROUTINE SLIPS (INPUT,COLOR,CUTLN1,CUTLN2, + DEGPEI,DEGWID,DOGRID, + FARG,FDIP,FLEN,FSLIPS, + IPEN1,IPEN2,IPEN3, + MAGNIF,MAPTYP,MXPNTS, + NFL,NODEF,NODES,NUMEL,NUMNOD, + POLE,POLEP,POLET, + RADIUS,RMSVEC,SLIDE,V,WEDGE, + XNODE,YNODE, + WORK,ICYCLE,XARAY,YARAY) C C PLOTS THE FAULT ELEMENTS AND THEIR SLIP RATES. C FAULTS WHICH ARE NOT SLIPPING ARE DASHED; NOTE THAT LOGICAL C ARRAY "FSLIPS" IS REQUIRED BY THIS ROUTINE. C IF (MAGNIF), CROSS-STRIKE COMPONENT OF VELOCITY DISCONTINUITY C IS MAGNIFIED BY *COSECANT(DIP) TO FIND TRUE SLIP-RATE; C OTHERWISE, QUANTITY PLOTTED IS VELOCITY DISCONTINUITY IN C THE HORIZONTAL PLANE ONLY, IGNORING THE DISCONTINUITY IN C VERTICAL VELOCITY. C FAULT ELEMENTS ARE IN BLACK WITH DIP SYMBOLS. C A CURVING GRAPH OF SCALAR SLIP-RATE PARALLELS EACH ELEMENT C ON THE OPPOSITE SIDE FROM THE DIP SYMBOLS. C IF (COLOR), RED IS C USED FOR NORMAL SLIP, GREEN FOR DEXTRAL STRIKE-SLIP, C YELLOW FOR SINISTRAL STRIKE-SLIP, C AND CYAN FOR REVERSE OR THRUST SLIP. C ON THE SIDE OF THE DIP SYMBOLS, A VECTOR SHOWS THE DIRECTION C OF RELATIVE MOTION. C PARAMETER (NUMSEG=7) DOUBLE PRECISION V,V2,VMAX CHARACTER*4 C4,ICOLOR,KOLOR,MMPERY LOGICAL COLOR,DASHED,DOGRID,DOTICS,DOTRAC,GREAT,INSIDE,MAGNIF C NOTE: FOLLOWING COULD BE "LOGICAL*1" IN VS-FORTRAN: LOGICAL FSLIPS REAL DERIVA,LABEL,LATT,LATU,LAT0,LAT1,LONT,LONU,LON0,LON1 DIMENSION FDIP(2,NFL),FLEN(NFL),FARG(2,NFL), + FSLIPS(NFL),NODEF(4,NFL), + NODES(3,NUMEL), + V(2,NUMNOD),XNODE(NUMNOD),YNODE(NUMNOD) DIMENSION XDUMMY(1),YDUMMY(1) DIMENSION BASE(3),POLE(3),GAPRAY(1),XARRAY(63),YARRAY(63) DIMENSION ICYCLE(MXPNTS),XARAY(MXPNTS),YARAY(MXPNTS) C DIMENSIONS USING PARAMETER "NUMSEG": DIMENSION FARGU(0:NUMSEG),HARG(0:NUMSEG),HRATE(0:NUMSEG), + ICOLOR(0:NUMSEG),RATE(0:NUMSEG) DATA PIO180 /0.017453293/ DATA OEZOPI /57.29577951/ DATA INSIDE /.FALSE./ C C STATEMENT FUNCTIONS FOR FAULT NODAL FUNCTIONS AND DERIVATIVES: PHIVAL(S,F1,F2)=F1*(1.-S)+F2*S DERIVA(S,F1,F2)=F2-F1 C (NOTE: THIS IS THE FLAT-EARTH VERSION, FOR SIMPLICITY!) C C STATEMENT FUNCTION TO INSURE AGAINST EXTRA CUTS IN LONGITUDE C WHICH ARE NOT ALLOWED WITHIN ONE ELEMENT C (LATER ROUTINE -MYSHAD- WILL DIVIDE AREAS THAT CROSS CUT) PHIOK(PHI)=AMOD(PHI+12.566371-CUTRAD,6.2831853)+CUTRAD C C GREAT=.TRUE. ANGDUM=90. GAPRAY(1)=1. DS=1./(1.*NUMSEG) MIDSEG=1.0+NUMSEG/2. C CHARACTER HEIGHT IN RADIANS: HIGH=0.10*DEGPEI*PIO180 C CHARACTER HEIGHT IN INCHES: HITE=0.10 CALL HEIGHT (HITE) C C DETERMINE REASONABLE SCALE FOR SLIP BANDS C VMAX=0.D0 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.D0 ENDIF SCALE=RMSVEC*PIO180/VMAX C C WHOLE COMPUTATION IS DONE THRICE, SO THAT SHADING, C TEXT, AND ARROWS CAN BE SEPARATE GROUPS! C IPASS = 1: SHADING C IPASS = 2: VECTORS C IPASS = 3: NUMBERS C DO 101 IPASS=1,3 CALL BGROUP DO 100 I=1,NFL D1=FDIP(1,I) D2=FDIP(2,I) AR1=FARG(1,I) AR2=FARG(2,I) I1=NODEF(1,I) I2=NODEF(2,I) I3=NODEF(3,I) I4=NODEF(4,I) X1=XNODE(I1) X2=XNODE(I2) Y1=YNODE(I1) Y2=YNODE(I2) CUTRAD=MIN(Y1,Y2)-3.1415926 Y1=PHIOK(Y1) Y2=PHIOK(Y2) A1=COS(Y1)*SIN(X1) B1=SIN(Y1)*SIN(X1) G1=COS(X1) A2=COS(Y2)*SIN(X2) B2=SIN(Y2)*SIN(X2) G2=COS(X2) VX1=V(1,I1) VX2=V(1,I2) UX1=V(1,I4) UX2=V(1,I3) VY1=V(2,I1) VY2=V(2,I2) UY1=V(2,I4) UY2=V(2,I3) C C COMPUTE SLIPS AT 11 POINTS PER FAULT (NO GRAPHICS YET) C DO 50 IS=0,NUMSEG S=DS*IS DIP=PHIVAL(S,D1,D2) ARG=CHORD(AR1,S*1.0D0,AR2) DVX=PHIVAL(S,VX1,VX2)-PHIVAL(S,UX1,UX2) DVY=PHIVAL(S,VY1,VY2)-PHIVAL(S,UY1,UY2) C NOTE: ALL ANGLES (EXCEPT "RMSVEC") ARE IN RADIANS, AND C MEASURED COUNTERCLOCKWISE FROM +THETA (= SOUTH). C CONVERSIONS TO DEGREES OF LATITUDE AND C LONGITUDE WILL OCCUR EITHER IN, OR JUST C BEFORE, THE CALLS TO -MYARC -. 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 FARGU(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)='GREE' ELSE C SINISTRAL STRIKE-SLIP ICOLOR(IS)='YELL' ENDIF ELSE IF (CLOSE.LT.0.) THEN C NORMAL SLIP ICOLOR(IS)='RED ' ELSE C REVERSE OR THRUST SLIP ICOLOR(IS)='CYAN' ENDIF 50 CONTINUE C C - - - - BEGIN GRAPHICS - - - - - - - - - - C C DRAW BAR GRAPH ON UPDIP SIDE C IF (FSLIPS(I)) THEN XF0=X1 YF0=Y1 LON0=OEZOPI*YF0 LAT0=90.-OEZOPI*XF0 S0=0. DO 60 IS=0,NUMSEG-1 S1=DS*(IS+1) A=PHIVAL(S1,A1,A2) B=PHIVAL(S1,B1,B2) G=PHIVAL(S1,G1,G2) R=SQRT(A*A+B*B+G*G) A=A/R B=B/R G=G/R BASE(1)=A BASE(2)=B BASE(3)=G CALL RESIZE (INPUT,BASE,MAPTYP,POLE, + OUTPUT,DIMINI) EQUPAR=SQRT(A*A+B*B) XF1=ATAN2F(EQUPAR,G) YF1=ATAN2F(B,A) YF1=PHIOK(YF1) LON1=OEZOPI*YF1 LAT1=90.-OEZOPI*XF1 XARRAY(1)=LON0 YARRAY(1)=LAT0 ARG=FARGU(IS) UNITX=COS(ARG) UNITY=SIN(ARG) DIP=PHIVAL(S0,D1,D2) IF (DIP.LE.(1.570796+WEDGE)) THEN CROSSX= -UNITY CROSSY= +UNITX ELSE CROSSX= +UNITY CROSSY= -UNITX ENDIF IF (MAGNIF) THEN XT=XF0+RATE(IS)*SCALE*DIMINI*CROSSX YT=YF0+RATE(IS)*SCALE*DIMINI*CROSSY/SIN(XF0) ELSE XT=XF0+HRATE(IS)*SCALE*DIMINI*CROSSX YT=YF0+HRATE(IS)*SCALE*DIMINI*CROSSY/SIN(XF0) ENDIF YT=PHIOK(YT) C (SCALE IS RADIANS/VELOCITY, SO RESULT IS C IN RADIANS) LONT=OEZOPI*YT LATT=90.-OEZOPI*XT IF ((IPASS.EQ.1).AND.(.NOT.COLOR)) THEN CALL MYARC (INPUT,LON0,LAT0,LONT,LATT, + CUTLN1,CUTLN2,GREAT) ENDIF XARRAY(2)=LONT YARRAY(2)=LATT ARG=FARGU(IS+1) UNITX=COS(ARG) UNITY=SIN(ARG) DIP=PHIVAL(S1,D1,D2) IF (DIP.LE.(1.570796+WEDGE)) THEN CROSSX= -UNITY CROSSY= +UNITX ELSE CROSSX= +UNITY CROSSY= -UNITX ENDIF IF (MAGNIF) THEN XU=XF1+RATE(IS+1)*SCALE*DIMINI*CROSSX YU=YF1+RATE(IS+1)*SCALE*DIMINI*CROSSY/SIN(XF1) ELSE XU=XF1+HRATE(IS+1)*SCALE*DIMINI*CROSSX YU=YF1+HRATE(IS+1)*SCALE*DIMINI*CROSSY/SIN(XF1) ENDIF YU=PHIOK(YU) LONU=OEZOPI*YU LATU=90.-OEZOPI*XU IF ((IPASS.EQ.1).AND.(.NOT.COLOR)) THEN CALL MYARC (INPUT,LONT,LATT,LONU,LATU, + CUTLN1,CUTLN2,GREAT) ENDIF XARRAY(3)=LONU YARRAY(3)=LATU IF ((IPASS.EQ.1).AND.(.NOT.COLOR)) THEN CALL MYARC (INPUT,LONU,LATU,LON1,LAT1, + CUTLN1,CUTLN2,GREAT) ENDIF XARRAY(4)=LON1 YARRAY(4)=LAT1 XARRAY(5)=LON0 YARRAY(5)=LAT0 C C IF "COLOR", THEN SHADE IN POLYGON DEFINED BY C "XARRAY, YARRAY" (IN DEGREES LON AND LAT) IF (COLOR.AND.(IPASS.EQ.1)) THEN CALL NEWCLR (ICOLOR(IS)) CALL MYSHAD (INPUT,XARRAY,YARRAY,5, + ANGDUM,GAPRAY, + 1,MXPNTS,1, + CUTLN1,COLOR, + WORK,ICYCLE, + XARAY,YARAY) CALL NEWCLR ('FORE') ENDIF C C PREPARE TO RECYCLE: S0=S1 XF0=XF1 YF0=YF1 LAT0=LAT1 LON0=LON1 60 CONTINUE C C DRAW SINGLE VECTOR AT MIDPOINT C A=0.5*(A1+A2) B=0.5*(B1+B2) G=0.5*(G1+G2) R=SQRT(A*A+B*B+G*G) A=A/R B=B/R G=G/R EQUPAR=SQRT(A*A+B*B) XC=ATAN2F(EQUPAR,G) YC=ATAN2F(B,A) ARG=FARGU(MIDSEG) UNITX=COS(ARG) UNITY=SIN(ARG) DIP=0.5*(FDIP(1,I)+FDIP(2,I)) IF (DIP.LE.(1.570796+WEDGE)) THEN CROSSX= +UNITY CROSSY= -UNITX VARG=HARG(MIDSEG) ELSE CROSSX= -UNITY CROSSY= +UNITX VARG=HARG(MIDSEG)+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 VECTR=HRATE(MIDSEG)*SCALE VECTR=0.70*RMSVEC*PIO180 C**************************************************************** OFFSET=MAX( 1.3*(0.5*VECTR*ABS(SIN(VARG-ARG))), + 0.20*FLEN(I)/RADIUS ) XVC=XC+OFFSET*CROSSX YVC=YC+OFFSET*CROSSY/SIN(XC) DX=VECTR*COS(VARG) DY=VECTR*SIN(VARG)/SIN(XC) X0=XVC-0.5*DX Y0=YVC-0.5*DY AZIM=3.14159-VARG IF (IPASS.EQ.2) + CALL ARROW (INPUT,X0,Y0,VECTR,AZIM, + MAPTYP,POLEP,POLET,DEGWID,.TRUE., + .FALSE.) C C LABEL IN MM/YEAR (NOTE: "LABEL" IS REAL) C CROSSX= -CROSSX CROSSY= -CROSSY C (NOTE: FOLLOWING LINE ASSUMES V IN M/S.) IF (MAGNIF) THEN LABEL=RATE(MIDSEG)*1000.*3.15576E7 ELSE LABEL=HRATE(MIDSEG)*1000.*3.15576E7 ENDIF IF (LABEL.LE.0.) THEN MMPERY='0 ' ELSE IF (LABEL.GE.10.) THEN WRITE (MMPERY,'(F4.0)') LABEL MMPERY(4:4)=' ' NUMCHR=3 ELSE IF (LABEL.GE.1.) THEN WRITE (MMPERY,'(F4.1)') LABEL NUMCHR=4 IF (MMPERY(2:2).EQ.' ') MMPERY(2:2)='0' IF (MMPERY(3:4).EQ.'.0') THEN MMPERY(3:4)=' ' NUMCHR=2 END IF ELSE WRITE (MMPERY,'(F4.2)') LABEL NUMCHR=4 IF (MMPERY(1:1).EQ.' ') MMPERY(1:1)='0' IF (MMPERY(4:4).EQ.'0') THEN MMPERY(4:4)=' ' NUMCHR=3 END IF END IF IF (MMPERY(1:1).EQ.' ') THEN C4=MMPERY(2:4)//' ' MMPERY=C4 NUMCHR=NUMCHR-1 END IF IF (MMPERY(1:1).EQ.' ') THEN C4=MMPERY(2:4)//' ' MMPERY=C4 NUMCHR=NUMCHR-1 END IF ARG=ATAN2F(CROSSY,CROSSX)-1.5708 IF (INSIDE) THEN C (PLOT NUMBER WITHIN COLOR BAND) HIGHT=0.0 ELSE C (PLOT NUMBER OUTSIDE OF SHADED BAND) IF (MAGNIF) THEN HIGHT=RATE(MIDSEG)*SCALE*DIMINI ELSE HIGHT=HRATE(MIDSEG)*SCALE*DIMINI ENDIF C ("HIGHT" IS IN RADIANS) ENDIF XFMP=XC+CROSSX*HIGHT YFMP=YC+CROSSY*HIGHT/SIN(XC) LONT=OEZOPI*YFMP LONT=CUTLN1+MOD(LONT-CUTLN1+720.,360.) LATT=90.-OEZOPI*XFMP IF (IPASS.EQ.3) THEN CALL ALNMES (0.5,-0.5) CALL ANGLE (ARG*OEZOPI-90.) CALL RLMESS (MMPERY,NUMCHR,LONT,LATT) ENDIF ENDIF 100 CONTINUE CALL EGROUP 101 CONTINUE C CALL RESET ('ALNMES') CALL RESET ('ANGLE') C C END COLORED GRAPHS AND VECTORS) C C******************************************************************* C C BEGIN FAULT GRID C C PLOT ALL FAULTS IN FOREGROUND COLOR C KOLOR='FORE' SUM=0.0 DO 110 I=1,NFL SUM=SUM+FLEN(I)/RADIUS 110 CONTINUE AVERAG=SUM/NFL IF (NUMNOD.LE.600) THEN NTIC=3 DIPSIZ=0.15*AVERAG ELSE NTIC=1 DIPSIZ=0.40*AVERAG ENDIF DOTRAC=.TRUE. CALL BGROUP DO 200 I=1,NFL DASHED=.NOT.FSLIPS(I) DOTICS=FSLIPS(I) CALL FAULT (INPUT,COLOR,CUTLN1,CUTLN2,DASHED, + DOTICS,DOTRAC,FARG,FDIP,I,IPEN2,KOLOR, + NFL,NUMNOD,NODEF,NTIC,DIPSIZ, + SLIDE,WEDGE,XNODE,YNODE) 200 CONTINUE CALL EGROUP C C**************************************************************** C C BEGIN KEY SEGMENT C C CLOSE THE MAIN SUBPLOT: CALL FRAME (DOGRID) C C CHARACTER DIMENSIONS, IN INCHES HITE=0.14 CALL HEIGHT (HITE) WIDTH=1.0*HITE C C SLIP-KEY C C VERTICAL POSITION OF FAULT-LINE OF ALL SYMBOLS: YLINE= 0.7 C C CONVENIENT ADJUSTMENT TERM FOR WHOLE LEGEND: XA=1.00 C C X-POSITIONS FOR TEXT WILL REFER TO CENTERS C CALL ALNMES (0.5,0.0) C C SLIP RATE IN MM/YEAR C XLINE=0.7+XA XARRAY(1)=XLINE-0.1 XARRAY(2)=XLINE+0.1 XARRAY(3)=XARRAY(2) XARRAY(4)=XARRAY(1) XARRAY(5)=XARRAY(1) YARRAY(1)=YLINE YARRAY(2)=YARRAY(1) YARRAY(3)=YLINE+0.2 YARRAY(4)=YARRAY(3) YARRAY(5)=YARRAY(1) IF (COLOR) THEN CALL NEWCLR ('YELL') CALL SHDCRV(XARRAY,YARRAY,5,XDUMMY,YDUMMY,0) ENDIF CALL CURVE (XARRAY,YARRAY,5,0) IF (COLOR) CALL NEWCLR ('FORE') CALL MESSAG ('SLIP-RATE:',10,XLINE,YLINE+0.3) CALL MESSAG ('5',1,XLINE,YLINE+0.03) CALL MESSAG ('mm/year',7,XLINE,YLINE-.4) CALL THKVEC (IPEN2+0.05) CALL VECTOR (XLINE-0.15,YLINE,XLINE+0.15,YLINE,0) CALL RESET ('THKVEC') CALL VECTOR (XLINE-0.15,YLINE-0.15, + XLINE+0.15,YLINE-0.15,1121) C C LOCKED FAULT C XLINE=2.4+XA CALL MESSAG ('LOCKED',6,XLINE,YLINE+0.3) CALL THKVEC (IPEN2+0.05) CALL DASH CALL VECTOR (XLINE-0.35,YLINE, + XLINE+0.35,YLINE,0) CALL RESET ('DASH') CALL RESET ('THKVEC') C C DEXTRAL C XLINE=3.6+XA XARRAY(1)=XLINE-0.1 XARRAY(2)=XLINE+0.1 XARRAY(3)=XARRAY(2) XARRAY(4)=XARRAY(1) XARRAY(5)=XARRAY(1) YARRAY(1)=YLINE YARRAY(2)=YARRAY(1) YARRAY(3)=YLINE+0.2 YARRAY(4)=YARRAY(3) YARRAY(5)=YARRAY(1) IF (COLOR) THEN CALL NEWCLR ('GREE') CALL SHDCRV(XARRAY,YARRAY,5,XDUMMY,YDUMMY,0) ELSE GAPRAY(1)=0.05 CALL SHADE (XARRAY,YARRAY,5,90.,GAPRAY,1,0,0) ENDIF CALL CURVE (XARRAY,YARRAY,5,0) IF (COLOR) CALL NEWCLR ('FORE') CALL MESSAG ('DEXTRAL',7,XLINE,YLINE+0.3) CALL THKVEC (IPEN2+0.05) CALL VECTOR (XLINE-0.15,YLINE,XLINE+0.15,YLINE,0) CALL RESET ('THKVEC') CALL VECTOR (XLINE+0.15,YLINE-0.15, + XLINE-0.15,YLINE-0.15,1121) C C SINISTRAL C XLINE=4.8 +XA XARRAY(1)=XLINE-0.1 XARRAY(2)=XLINE+0.1 XARRAY(3)=XARRAY(2) XARRAY(4)=XARRAY(1) XARRAY(5)=XARRAY(1) YARRAY(1)=YLINE YARRAY(2)=YARRAY(1) YARRAY(3)=YLINE+0.2 YARRAY(4)=YARRAY(3) YARRAY(5)=YARRAY(1) IF (COLOR) THEN CALL NEWCLR ('YELL') CALL SHDCRV(XARRAY,YARRAY,5,XDUMMY,YDUMMY,0) ELSE GAPRAY(1)=0.05 CALL SHADE (XARRAY,YARRAY,5,90.,GAPRAY,1,0,0) ENDIF CALL CURVE (XARRAY,YARRAY,5,0) IF (COLOR) CALL NEWCLR ('FORE') CALL MESSAG ('SINISTRAL',9,XLINE,YLINE+0.3) CALL THKVEC (IPEN2+0.05) CALL VECTOR (XLINE-0.15,YLINE,XLINE+0.15,YLINE,0) CALL RESET ('THKVEC') CALL VECTOR (XLINE-0.15,YLINE-0.15, + XLINE+0.15,YLINE-0.15,1121) C C THRUST C XLINE=6.0+XA XARRAY(1)=XLINE-0.1 XARRAY(2)=XLINE+0.1 XARRAY(3)=XARRAY(2) XARRAY(4)=XARRAY(1) XARRAY(5)=XARRAY(1) YARRAY(1)=YLINE YARRAY(2)=YARRAY(1) YARRAY(3)=YLINE+0.2 YARRAY(4)=YARRAY(3) YARRAY(5)=YARRAY(1) IF (COLOR) THEN CALL NEWCLR ('CYAN') CALL SHDCRV(XARRAY,YARRAY,5,XDUMMY,YDUMMY,0) ELSE GAPRAY(1)=0.05 CALL SHADE (XARRAY,YARRAY,5,90.,GAPRAY,1,0,0) ENDIF CALL CURVE (XARRAY,YARRAY,5,0) IF (COLOR) CALL NEWCLR ('FORE') CALL MESSAG ('THRUST',6,XLINE,YLINE+0.3) CALL THKVEC (IPEN2+0.05) CALL VECTOR (XLINE-0.15,YLINE,XLINE+0.15,YLINE,0) CALL RESET ('THKVEC') CALL VECTOR (XLINE,YLINE-0.35, + XLINE,YLINE-0.05,1121) C C NORMAL C XLINE=7.2+XA XARRAY(1)=XLINE-0.1 XARRAY(2)=XLINE+0.1 XARRAY(3)=XARRAY(2) XARRAY(4)=XARRAY(1) XARRAY(5)=XARRAY(1) YARRAY(1)=YLINE YARRAY(2)=YARRAY(1) YARRAY(3)=YLINE+0.2 YARRAY(4)=YARRAY(3) YARRAY(5)=YARRAY(1) IF (COLOR) THEN CALL NEWCLR ('RED ') CALL SHDCRV(XARRAY,YARRAY,5,XDUMMY,YDUMMY,0) ELSE GAPRAY(1)=0.05 CALL SHADE (XARRAY,YARRAY,5,90.,GAPRAY,1,0,0) ENDIF CALL CURVE (XARRAY,YARRAY,5,0) IF (COLOR) CALL NEWCLR ('FORE') CALL MESSAG ('NORMAL',6,XLINE,YLINE+0.3) CALL THKVEC (IPEN2+0.05) CALL VECTOR (XLINE-0.15,YLINE,XLINE+0.15,YLINE,0) CALL RESET ('THKVEC') CALL VECTOR (XLINE,YLINE-0.05, + XLINE,YLINE-0.35,1121) C CALL RESET ('HEIGHT') RETURN END C C C SUBROUTINE TOMYSH (INPUT,ANGLE,COLOR,CUTLN1,GAPRAY, + MXGAPS,MXPNTS,NGAPS,NPNTS, + MODIFY,XARAY,YARAY, + WORK,ICYCLE, + XARRAY, + YARRAY) C C CONVERTS (THETA,PHI) LISTS IN RADIANS TO (ELON,NLAT) C LISTS IN DEGREES, ON THE WAY TO CALLING -MYSHAD-. C LOGICAL COLOR DIMENSION GAPRAY(NGAPS),ICYCLE(MXPNTS), + XARAY(MXPNTS),XARRAY(MXPNTS), + YARAY(MXPNTS),YARRAY(MXPNTS) DATA OEZOPI /57.29577951/ C DO 10 I=1,NPNTS SAVE=XARAY(I) XARAY(I)=OEZOPI*YARAY(I) YARAY(I)=90.-OEZOPI*SAVE 10 CONTINUE C CALL MYSHAD (INPUT,XARAY,YARAY,NPNTS,ANGLE,GAPRAY, + MXGAPS,MXPNTS,NGAPS, + CUTLN1,COLOR, + WORK,ICYCLE, + XARRAY,YARRAY) C RETURN END C C C C SUBROUTINE MYSHAD (INPUT,XARAY,YARAY,NPNTS,ANGLE,GAPRAY, + MXGAPS,MXPNTS,NGAPS, + CUTLN1,COLOR, + WORK,ICYCLE, + XARRAY,YARRAY) C C CORRECTS FOR DEFICIENCIES OF -SHADE- FROM DISSPLA C (LACK OF PLOTTING WHEN ABS(LONGITUDE)>180; STREAKING C ACROSS THE PLOT WHEN AREA SPANS THE MERCATOR CUT). C C INPUT ARRAYS "XARAY" AND "YARAY" HOLD EAST LONGITUDES AND C NORTH LATITUDES, RESPECTIVELY, IN DEGREES. C "CUTLN1" IS THE EAST LONGITUDE OF THE WESTERN CUT IN THE PLOT. C PARAMETER (MAXPNT=100) C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) DIMENSION XDUMMY(1),YDUMMY(1) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C LOGICAL COLOR,CUT,DOUBLE DIMENSION GAPRAY(MXGAPS),ICYCLE(MXPNTS), + XARAY (MXPNTS),XARRAY(MXPNTS), + YARAY (MXPNTS),YARRAY(MXPNTS) DIMENSION XP(MAXPNT),YP(MAXPNT),XT(MAXPNT),YT(MAXPNT) DIMENSION V1(3),V2(3),VT(3) C C STATEMENT FUNCTION: JC(I,N,I1)=1+MOD((I1-1+I-1+N),N) C IF (NPNTS.LT.3) RETURN C C BE SURE CONTOUR DOES NOT HAVE A REDUDANT START/END POINT: C (NOTE: THIS WILL BE RESTORED AS THE LAST STEP BEFORE LEAVING) C IF ((YARAY(NPNTS).NE.YARAY(1)).OR. + ((MOD(720.+XARAY(NPNTS),360.)- + MOD(720.+XARAY( 1),360.)).GT.0.01)) THEN MYPNTS=NPNTS ELSE MYPNTS=NPNTS-1 ENDIF C DOUBLE=.FALSE. DO 1 I=1,MYPNTS XARRAY(I)=XARAY(I) YARRAY(I)=YARAY(I) 1 CONTINUE C IF (CDI02(1:8).EQ.'MERCATOR') THEN C C MERCATOR PROJECTION, PROBABLY WHOLE-EARTH: BEWARE THE CUT! C C PUT POINTS INTO NEW COORDINATES, AND ALSO C DECIDE WHETHER ANY ARC OF GREAT CIRCLE PASSES THROUGH CUT C RLTMIN=90.0 CALL LL2XYZ (INPUT,XARAY(MYPNTS),YARAY(MYPNTS), + OUTPUT,V1) C THIS V1 IS IN ORIGINAL COORDINATES P1=VDI01(1)*V1(1)+VDI01(2)*V1(2)+VDI01(3)*V1(3) E1=VDI02(1)*V1(1)+VDI02(2)*V1(2)+VDI02(3)*V1(3) U1=VDI03(1)*V1(1)+VDI03(2)*V1(2)+VDI03(3)*V1(3) VT(1)=P1 VT(2)=E1 VT(3)=U1 CALL XYZ2LL (INPUT,VT,OUTPUT,RELLON,RELLAT) RELLON=MAX(RELLON,-179.9) RELLON=MIN(RELLON,+179.9) CALL LL2XYZ (INPUT,RELLON,RELLAT, + OUTPUT,V1) C THIS V1 IS IN RELATIVE COORDINATES P1=V1(1) E1=V1(2) DO 10 I=1,MYPNTS CALL LL2XYZ (INPUT,XARAY(I),YARAY(I), + OUTPUT,V2) C THIS V2 IS IN ORIGINAL COORDINATES P2=VDI01(1)*V2(1)+VDI01(2)*V2(2)+VDI01(3)*V2(3) E2=VDI02(1)*V2(1)+VDI02(2)*V2(2)+VDI02(3)*V2(3) U2=VDI03(1)*V2(1)+VDI03(2)*V2(2)+VDI03(3)*V2(3) VT(1)=P2 VT(2)=E2 VT(3)=U2 CALL XYZ2LL (INPUT,VT,OUTPUT,XP(I),YP(I)) XP(I)=MAX(XP(I),-179.9) XP(I)=MIN(XP(I),+179.9) CALL LL2XYZ (INPUT,XP(I),YP(I), + OUTPUT,V2) C THIS V2 IS IN RELATIVE COORDINATES P2=V2(1) E2=V2(2) RLTMIN=MIN(RLTMIN,ABS(YP(I))) IF (E1.NE.E2) THEN FRAC=(0.-E1)/(E2-E1) IF ((FRAC.GE.0.).AND.(FRAC.LE.1.)) THEN P=P1+FRAC*(P2-P1) IF (P.LE.0.) DOUBLE=.TRUE. ENDIF ENDIF P1=P2 E1=E2 10 CONTINUE C C DON'T BOTHER ABOUT POLYGONS THAT ARE OFF THE MAP C IF (RLTMIN.GE.70.) RETURN C C AT THIS POINT, XP AND YP ARE RELATIVE LON AND LAT, IN DEGREES C ENDIF C IF (DOUBLE) THEN C C FIRST, PLOT THE PART OF THE CIRCUIT IN LEFT HALF OF MAP: C C FIND A STARTING POINT ON THE LEFT SIDE DO 120 I1=1,MYPNTS IF (XP(I1).LT.0.0) GO TO 121 120 CONTINUE 121 CONTINUE XT(1)=XP(I1) YT(1)=YP(I1) INEXT=2 CALL LL2XYZ (INPUT,XP(I1),YP(I1), + OUTPUT,V1) P1=V1(1) E1=V1(2) U1=V1(3) DO 190 K=2,MYPNTS+1 J1=JC(K-1,MYPNTS,I1) J2=JC(K ,MYPNTS,I1) CALL LL2XYZ (INPUT,XP(J2),YP(J2), + OUTPUT,V2) P2=V2(1) E2=V2(2) U2=V2(3) IF (E1.EQ.E2) THEN CUT=.FALSE. ELSE FRAC=(0.-E1)/(E2-E1) IF ((FRAC.GT.0.0).AND.(FRAC.LT.1.00)) THEN P=P1+FRAC*(P2-P1) CUT=(P.LT.0.0) ELSE CUT=.FALSE. ENDIF ENDIF IF (.NOT.CUT) THEN C WHOLE SEGMENT IS ONE ONE SIDE OR THE OTHER IF (E2.LT.0.0) THEN C THIS SEGMENT SHOULD BE SHOWN INTACT XT(INEXT)=XP(J2) YT(INEXT)=YP(J2) INEXT=INEXT+1 ENDIF ELSE C THIS SEGMENT CROSSES CUT IF (E2.GT.0.00) THEN C THIS SEGMENT GOES INTO LIMBO E=0. U=U1+FRAC*(U2-U1) R=SQRT(P**2+U**2) P=P/R U=U/R VT(1)=P VT(2)=0. VT(3)=U CALL XYZ2LL (INPUT,VT, + OUTPUT,XT(INEXT),YT(INEXT)) XT(INEXT)=-179.9 INEXT=INEXT+1 ELSE C THIS SEGMENT EMERGES FROM LIMBO E=0. U=U1+FRAC*(U2-U1) R=SQRT(P**2+U**2) P=P/R U=U/R VT(1)=P VT(2)=0. VT(3)=U CALL XYZ2LL (INPUT,VT, + OUTPUT,XT(INEXT),YT(INEXT)) XT(INEXT)=-179.9 INEXT=INEXT+1 XT(INEXT)=XP(J2) YT(INEXT)=YP(J2) INEXT=INEXT+1 ENDIF ENDIF V1(1)=V2(1) V1(2)=V2(2) V1(3)=V2(3) P1=P2 E1=E2 U1=U2 190 CONTINUE N2SHOW=INEXT-1 C DO 199 I=1,N2SHOW C CONVERT BACK TO NORMAL COORDINATES CALL LL2XYZ (INPUT,XT(I),YT(I), + OUTPUT,VT) P=VT(1)*VDI01(1)+VT(2)*VDI02(1)+VT(3)*VDI03(1) E=VT(1)*VDI01(2)+VT(2)*VDI02(2)+VT(3)*VDI03(2) U=VT(1)*VDI01(3)+VT(2)*VDI02(3)+VT(3)*VDI03(3) VT(1)=P VT(2)=E VT(3)=U CALL XYZ2LL (INPUT,VT, + OUTPUT,XARRAY(I),YARRAY(I)) 199 CONTINUE C IF (COLOR) THEN CALL SHDCRV (XARRAY,YARRAY,N2SHOW,XDUMMY,YDUMMY,0) ELSE CALL SHADE (XARRAY,YARRAY,N2SHOW,ANGLE,GAPRAY,1,0,0) ENDIF C C SECOND, PLOT THE PART OF THE CIRCUIT IN RIGHT HALF OF MAP: C C FIND A STARTING POINT ON THE RIGHT SIDE DO 220 I1=1,MYPNTS IF (XP(I1).GT.0.0) GO TO 221 220 CONTINUE 221 CONTINUE XT(1)=XP(I1) YT(1)=YP(I1) INEXT=2 CALL LL2XYZ (INPUT,XP(I1),YP(I1), + OUTPUT,V1) P1=V1(1) E1=V1(2) U1=V1(3) DO 290 K=2,MYPNTS+1 J1=JC(K-1,MYPNTS,I1) J2=JC(K ,MYPNTS,I1) CALL LL2XYZ (INPUT,XP(J2),YP(J2), + OUTPUT,V2) P2=V2(1) E2=V2(2) U2=V2(3) IF (E1.EQ.E2) THEN CUT=.FALSE. ELSE FRAC=(0.-E1)/(E2-E1) IF ((FRAC.GT.0.0).AND.(FRAC.LT.1.00)) THEN P=P1+FRAC*(P2-P1) CUT=(P.LT.0.0) ELSE CUT=.FALSE. ENDIF ENDIF IF (.NOT.CUT) THEN C WHOLE SEGMENT IS ONE ONE SIDE OR THE OTHER IF (E2.GT.0.0) THEN C THIS SEGMENT SHOULD BE SHOWN INTACT XT(INEXT)=XP(J2) YT(INEXT)=YP(J2) INEXT=INEXT+1 ENDIF ELSE C THIS SEGMENT CROSSES CUT IF (E2.LT.0.00) THEN C THIS SEGMENT GOES INTO LIMBO E=0. U=U1+FRAC*(U2-U1) R=SQRT(P**2+U**2) P=P/R U=U/R VT(1)=P VT(2)=0. VT(3)=U CALL XYZ2LL (INPUT,VT, + OUTPUT,XT(INEXT),YT(INEXT)) XT(INEXT)=+179.9 INEXT=INEXT+1 ELSE C THIS SEGMENT EMERGES FROM LIMBO E=0. U=U1+FRAC*(U2-U1) R=SQRT(P**2+U**2) P=P/R U=U/R VT(1)=P VT(2)=0. VT(3)=U CALL XYZ2LL (INPUT,VT, + OUTPUT,XT(INEXT),YT(INEXT)) XT(INEXT)=+179.9 INEXT=INEXT+1 XT(INEXT)=XP(J2) YT(INEXT)=YP(J2) INEXT=INEXT+1 ENDIF ENDIF V1(1)=V2(1) V1(2)=V2(2) V1(3)=V2(3) P1=P2 E1=E2 U1=U2 290 CONTINUE N2SHOW=INEXT-1 C DO 299 I=1,N2SHOW C CONVERT BACK TO NORMAL COORDINATES CALL LL2XYZ (INPUT,XT(I),YT(I), + OUTPUT,VT) P=VT(1)*VDI01(1)+VT(2)*VDI02(1)+VT(3)*VDI03(1) E=VT(1)*VDI01(2)+VT(2)*VDI02(2)+VT(3)*VDI03(2) U=VT(1)*VDI01(3)+VT(2)*VDI02(3)+VT(3)*VDI03(3) VT(1)=P VT(2)=E VT(3)=U CALL XYZ2LL (INPUT,VT, + OUTPUT,XARRAY(I),YARRAY(I)) 299 CONTINUE C IF (COLOR) THEN CALL SHDCRV (XARRAY,YARRAY,N2SHOW,XDUMMY,YDUMMY,0) ELSE CALL SHADE (XARRAY,YARRAY,N2SHOW,ANGLE,GAPRAY,1,0,0) ENDIF ELSE N2SHOW=MYPNTS+1 XARRAY(N2SHOW)=XARRAY(1) YARRAY(N2SHOW)=YARRAY(1) IF (COLOR) THEN CALL SHDCRV (XARRAY,YARRAY,N2SHOW,XDUMMY,YDUMMY,0) ELSE CALL SHADE (XARRAY,YARRAY,N2SHOW,ANGLE,GAPRAY,1,0,0) ENDIF ENDIF RETURN END C C C SUBROUTINE SCALAR (INPUT,ATNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND,LOWBLU, + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT, + WORK,ICYCLE, + XARAY,XARRAY,YARAY,YARRAY) C C SHADES THE AREAS WITHIN ALL THE TRIANGULAR ELEMENTS. C IN BLACK-AND-WHITE PLOTTING (WHEN "COLOR"=F) THE SHADED C AREAS ARE ALWAYS BOUNDED BY CONTOUR LINES. IN COLOR C PLOTTING, YOU HAVE A CHOICE: IF (EDGEIT) THEN ALL C CONTOUR LINES ARE DRAWN; OTHERWISE, CONTOURS ARE ONLY C DRAWN FOR EXTREME VALUES WHICH ARE OFF THE END OF THE COLOR C SCALE. THIS OPTION REDUCES THE CLUTTER OF LINES WHEN C YOU ALSO WISH TO PLOT COASTLINES, VECTORS, TENSORS, ETC.. C "CUTLN1" AND "CUTLN2" ARE THE LEFT AND RIGHT LIMITS OF THE MAP C IN DEGREES EAST; "XNODE" AND "YNODE" ARE THETA AND C PHI OF THE NODES, IN RADIANS. C "DFC" IS THE CONTOUR INTERVAL. C IN COLOR PLOTTING, "FBLAND" IS THE VALUE WHICH SEPARATES C THE HIGH COLORS (YELLOW-ORANGE-RED-PINK-WHITE) FROM THE C LOW COLORS (GREEN-BLUE/GREEN-BLUE-DARK BLUE) C (THAT IS, IF LOWBLU=+1; OTHERWISE, COLORS ARE REVERSED.) C IN BLACK/WHITE PLOTTING, "FGRAY" IS THE VALUE C BELOW WHICH GRAY SHADING BEGINS IF (LOWBLU.GE.0); C OTHERWISE "FGRAY" IS THE VALUE ABOVE WHICH GRAY SHADING BEGINS. C CHARACTER*20 COLNAM LOGICAL COLOR,EDGEIT,GREAT,INOLD,INSIDE,SHOLIN REAL NLATD1,NLATD2 DIMENSION ATNODE(MXNODE),NODES(3,MXEL), + XNODE(MXNODE),YNODE(MXNODE) DIMENSION GAPRAY(1),ICYCLE(MXPNTS),RATRAY(2), + XARAY(MXPNTS),XARRAY(MXPNTS), + YARAY(MXPNTS),YARRAY(MXPNTS) DIMENSION ALONG(99),COLNAM(99),SPACIN(99) COMMON /MYOWN/ NGRAY,ALONG,COLNAM,SPACIN C C "OEZOPI" IS 180./PI (CONVERSION FROM RADIANS TO DEGREES): DATA OEZOPI /57.29577951/ C C STATEMENT FUNCTION TO INSURE AGAINST EXTRA CUTS IN LONGITUDE C WHICH ARE NOT ALLOWED WITHIN ONE ELEMENT C (LATER ROUTINE -MYSHAD- WILL DIVIDE AREAS THAT CROSS CUT) PHIOK(PHI)=AMOD(PHI+12.566371-CUTRAD,6.2831853)+CUTRAD C FGRAY=FBLAND+LOWBLU*4.*DFC C C BECAUSE -SHADE- (USED FOR B/W SHADING) BOUNDS ITS AREAS C WITH STRAIGHT LINES ON THE MAP (NOT ARCS OF GREAT CIRCLES), C IT IS NECESSARY TO DRAW CONTOUR LINES IN THE SAME WAY: GREAT=COLOR C FNADIR=ATNODE(1) FZENIT=ATNODE(1) C C --- ADDED IN ORBMAPAI: ------------ C TWO PASSES (IF EDGEIT) SO THAT CONTOUR C LINES CAN LIE COMPLETELY OVER COLOR PATCHES, C AND ALSO BE GROUPED FOR EASY CHANGE OF LINE TYPE C - - - - - - - - - - - - - - - - -- - - - -- - - - IF (EDGEIT) THEN NPASS=2 ELSE NPASS=1 ENDIF DO 2000 KPASS=1,NPASS CALL BGROUP DO 1000 I=1,NUMEL N1=NODES(1,I) N2=NODES(2,I) N3=NODES(3,I) X1=XNODE(N1) X2=XNODE(N2) X3=XNODE(N3) Y1=YNODE(N1) Y2=YNODE(N2) Y3=YNODE(N3) CUTRAD=MIN(Y1,Y2,Y3)-3.1415926 Y1=PHIOK(Y1) Y2=PHIOK(Y2) Y3=PHIOK(Y3) F1=ATNODE(N1) F2=ATNODE(N2) F3=ATNODE(N3) FLOW=MIN(F1,F2,F3) FHIGH=MAX(F1,F2,F3) FNADIR=MIN(FNADIR,FLOW) FZENIT=MAX(FZENIT,FHIGH) ILOW=IBELOW((FGRAY-FLOW)/DFC+0.99) IHIGH=IBELOW((FGRAY-FHIGH)/DFC+1.01) IF (ILOW.LE.IHIGH) THEN C UNIFORM COLOR; NO CONTOURS XARAY(1)=X1 XARAY(2)=X2 XARAY(3)=X3 XARAY(4)=XARAY(1) YARAY(1)=Y1 YARAY(2)=Y2 YARAY(3)=Y3 YARAY(4)=YARAY(1) NPNTS=4 IF (LOWBLU.GE.0) THEN INDEX=ILOW ELSE INDEX=1-ILOW ENDIF IF ((INDEX.GE.1).AND.(KPASS.EQ.1)) THEN IF (COLOR) THEN INDEX=MIN(INDEX,NGRAY) CALL NEWCLR (COLNAM(INDEX)) ANGLE=90. CALL TOMYSH (INPUT,ANGLE,COLOR, + CUTLN1,GAPRAY, + 1,MXPNTS,1,NPNTS, + MODIFY,XARAY,YARAY, + WORK,ICYCLE, + XARRAY, + YARRAY) ELSE INDEX=MIN(INDEX,NGRAY) ANGLE=MOD(INDEX+1,4)*45. RATRAY(1)=ALONG(INDEX) RATRAY(2)=0.100-RATRAY(1) GAPRAY(1)=SPACIN(INDEX) CALL TOMYSH (INPUT,ANGLE,COLOR, + CUTLN1,GAPRAY, + 1,MXPNTS,1,NPNTS, + MODIFY,XARAY,YARAY, + WORK,ICYCLE, + XARRAY, + YARRAY) ENDIF ENDIF ELSE C CONTOUR(S) MUST BE LOCATED NUMCON=ILOW-IHIGH C FIRST, ROTATE TO STANDARD VIEW IF (F1.EQ.FLOW) THEN XLOW=X1 YLOW=Y1 IF (F2.LE.F3) THEN FMID=F2 XMID=X2 YMID=Y2 XHIGH=X3 YHIGH=Y3 ELSE FMID=F3 XMID=X3 YMID=Y3 XHIGH=X2 YHIGH=Y2 ENDIF ELSE IF (F2.EQ.FLOW) THEN XLOW=X2 YLOW=Y2 IF (F1.LE.F3) THEN FMID=F1 XMID=X1 YMID=Y1 XHIGH=X3 YHIGH=Y3 ELSE FMID=F3 XMID=X3 YMID=Y3 XHIGH=X1 YHIGH=Y1 ENDIF ELSE C (F3 IS THE LOW VALUE) XLOW=X3 YLOW=Y3 IF (F1.LE.F2) THEN FMID=F1 XMID=X1 YMID=Y1 XHIGH=X2 YHIGH=Y2 ELSE FMID=F2 XMID=X2 YMID=Y2 XHIGH=X1 YHIGH=Y1 ENDIF ENDIF ALOW=COS(YLOW)*SIN(XLOW) BLOW=SIN(YLOW)*SIN(XLOW) GLOW=COS(XLOW) AMID=COS(YMID)*SIN(XMID) BMID=SIN(YMID)*SIN(XMID) GMID=COS(XMID) AHIGH=COS(YHIGH)*SIN(XHIGH) BHIGH=SIN(YHIGH)*SIN(XHIGH) GHIGH=COS(XHIGH) DO 900 J=1,NUMCON IIN=ILOW-(J-1) IOUT=IIN-1 FCON=FGRAY-IOUT*DFC SBASE=(FCON-FLOW)/(FHIGH-FLOW) ABASE=ALOW+SBASE*(AHIGH-ALOW) BBASE=BLOW+SBASE*(BHIGH-BLOW) GBASE=GLOW+SBASE*(GHIGH-GLOW) R=SQRT(ABASE*ABASE+BBASE*BBASE+GBASE*GBASE) ABASE=ABASE/R BBASE=BBASE/R GBASE=GBASE/R EQUPAR=SQRT(ABASE*ABASE+BBASE*BBASE) XBASE=ATAN2F(EQUPAR,GBASE) YBASE=ATAN2F(BBASE,ABASE) YBASE=PHIOK(YBASE) INSIDE=(FCON.LT.FMID) IF (INSIDE) THEN SFAR=(FCON-FLOW)/(FMID-FLOW) AFAR=ALOW+SFAR*(AMID-ALOW) BFAR=BLOW+SFAR*(BMID-BLOW) GFAR=GLOW+SFAR*(GMID-GLOW) ELSE SFAR=(FCON-FMID)/(FHIGH-FMID) AFAR=AMID+SFAR*(AHIGH-AMID) BFAR=BMID+SFAR*(BHIGH-BMID) GFAR=GMID+SFAR*(GHIGH-GMID) ENDIF R=SQRT(AFAR*AFAR+BFAR*BFAR+GFAR*GFAR) AFAR=AFAR/R BFAR=BFAR/R GFAR=GFAR/R EQUPAR=SQRT(AFAR*AFAR+BFAR*BFAR) XFAR=ATAN2F(EQUPAR,GFAR) YFAR=ATAN2F(BFAR,AFAR) YFAR=PHIOK(YFAR) IF (J.EQ.1) THEN C FIRST POLYGON XARAY(1)=XLOW YARAY(1)=YLOW XARAY(2)=XBASE YARAY(2)=YBASE XARAY(3)=XFAR YARAY(3)=YFAR IF (INSIDE) THEN NPNTS=3 ELSE NPNTS=4 XARAY(4)=XMID YARAY(4)=YMID ENDIF C C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C FIXUP: LOGIC OF ORBMAPAI REQUIRES POLYGONS TO BE EXPLICITLY C CLOSED (OR ELSE SOME DON'T PLOT). C NPNTS=NPNTS+1 XARAY(NPNTS)=XARAY(1) YARAY(NPNTS)=YARAY(1) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF (LOWBLU.GE.0) THEN INDEXI=IIN INDEXO=IOUT ELSE INDEXI=1-IIN INDEXO=1-IOUT ENDIF INDEX=INDEXI IF ((INDEX.GE.1).AND.(KPASS.EQ.1)) THEN IF (COLOR) THEN INDEX=MIN(INDEX,NGRAY) CALL NEWCLR (COLNAM(INDEX)) ANGLE=90. CALL TOMYSH (INPUT,ANGLE,COLOR, + CUTLN1,GAPRAY, + 1,MXPNTS,1,NPNTS, + MODIFY,XARAY,YARAY, + WORK,ICYCLE, + XARRAY, + YARRAY) ELSE INDEX=MIN(INDEX,NGRAY) ANGLE=MOD(INDEX+1,4)*45. RATRAY(1)=ALONG(INDEX) RATRAY(2)=0.100-RATRAY(1) GAPRAY(1)=SPACIN(INDEX) CALL TOMYSH (INPUT,ANGLE,COLOR, + CUTLN1,GAPRAY, + 1,MXPNTS,1,NPNTS, + MODIFY,XARAY,YARAY, + WORK,ICYCLE, + XARRAY, + YARRAY) ENDIF ENDIF ELSE C ONE MORE POLYGON IN A SERIES XARAY(1)=XOBASE YARAY(1)=YOBASE XARAY(2)=XBASE YARAY(2)=YBASE XARAY(3)=XFAR YARAY(3)=YFAR IF (INSIDE.EQV.INOLD) THEN NPNTS=4 XARAY(4)=XOFAR YARAY(4)=YOFAR ELSE NPNTS=5 XARAY(4)=XMID YARAY(4)=YMID XARAY(5)=XOFAR YARAY(5)=YOFAR ENDIF IF (LOWBLU.GE.0) THEN INDEXI=IIN INDEXO=IOUT ELSE INDEXI=1-IIN INDEXO=1-IOUT ENDIF INDEX=INDEXI IF ((INDEX.GE.1).AND.(KPASS.EQ.1)) THEN IF (COLOR) THEN INDEX=MIN(INDEX,NGRAY) CALL NEWCLR (COLNAM(INDEX)) ANGLE=90. CALL TOMYSH (INPUT,ANGLE,COLOR, + CUTLN1,GAPRAY, + 1,MXPNTS,1,NPNTS, + MODIFY,XARAY,YARAY, + WORK,ICYCLE, + XARRAY, + YARRAY) ELSE INDEX=MIN(INDEX,NGRAY) ANGLE=MOD(INDEX+1,4)*45. RATRAY(1)=ALONG(INDEX) RATRAY(2)=0.100-RATRAY(1) GAPRAY(1)=SPACIN(INDEX) CALL TOMYSH (INPUT,ANGLE,COLOR, + CUTLN1,GAPRAY, + 1,MXPNTS,1,NPNTS, + MODIFY,XARAY,YARAY, + WORK,ICYCLE, + XARRAY, + YARRAY) ENDIF ENDIF ENDIF IF (J.EQ.NUMCON) THEN C LAST POLYGON TO FILL IN XARAY(1)=XBASE YARAY(1)=YBASE XARAY(2)=XHIGH YARAY(2)=YHIGH IF (INSIDE) THEN NPNTS=4 XARAY(3)=XMID YARAY(3)=YMID XARAY(4)=XFAR YARAY(4)=YFAR ELSE NPNTS=3 XARAY(3)=XFAR YARAY(3)=YFAR ENDIF IF (LOWBLU.GE.0) THEN INDEXI=IIN INDEXO=IOUT ELSE INDEXI=1-IIN INDEXO=1-IOUT ENDIF INDEX=INDEXO IF ((INDEX.GE.1).AND.(KPASS.EQ.1)) THEN IF (COLOR) THEN INDEX=MIN(INDEX,NGRAY) CALL NEWCLR (COLNAM(INDEX)) ANGLE=90. CALL TOMYSH (INPUT,ANGLE,COLOR, + CUTLN1,GAPRAY, + 1,MXPNTS,1,NPNTS, + MODIFY,XARAY,YARAY, + WORK,ICYCLE, + XARRAY, + YARRAY) ELSE INDEX=MIN(INDEX,NGRAY) ANGLE=MOD(INDEX+1,4)*45. RATRAY(1)=ALONG(INDEX) RATRAY(2)=0.100-RATRAY(1) GAPRAY(1)=SPACIN(INDEX) CALL TOMYSH (INPUT,ANGLE,COLOR, + CUTLN1,GAPRAY, + 1,MXPNTS,1,NPNTS, + MODIFY,XARAY,YARAY, + WORK,ICYCLE, + XARRAY, + YARRAY) ENDIF ENDIF ENDIF IF (COLOR) THEN CALL NEWCLR ('FORE') ENDIF SHOLIN=(.NOT.COLOR).OR. + (EDGEIT).OR. + (.NOT. ( + ((INDEXI.GE.1).AND.(INDEXI.LT.NGRAY)) + .OR. + ((INDEXO.GE.1).AND.(INDEXO.LT.NGRAY)) + ) ) SHOLIN=SHOLIN.AND.(KPASS.EQ.NPASS) IF (SHOLIN) THEN THETA1=XBASE PHI1=YBASE THETA2=XFAR PHI2=YFAR ELOND1=PHI1*OEZOPI ELOND2=PHI2*OEZOPI NLATD1=90.-OEZOPI*THETA1 NLATD2=90.-OEZOPI*THETA2 CALL MYARC (INPUT,ELOND1,NLATD1,ELOND2, + NLATD2,CUTLN1,CUTLN2, + GREAT) ENDIF XOBASE=XBASE YOBASE=YBASE XOFAR=XFAR YOFAR=YFAR INOLD=INSIDE 900 CONTINUE ENDIF 1000 CONTINUE CALL EGROUP 2000 CONTINUE C C POST-CORRECT FOR BUG IN THIS (GENERALLY FINE) ALGORITHM: C CONTOURS ARE OMITTED C (EVEN IF EDGEIT) WHEN THEY LIE EXACTLY ALONG ELEMENT SIDES. C SO, ADD THESE, UNLESS ALL 3 NODES HAVE SAME VALUE = PLANE! C NOTE: THIS MUST BE DONE AFTER ALL SHADED AREAS ARE COMPLETED, C SO THE ADDED CONTOURS ARE SURE TO BE ON TOP. C IF (COLOR) THEN CALL NEWCLR ('FORE') ENDIF CALL BGROUP DO 3000 I=1,NUMEL N1=NODES(1,I) N2=NODES(2,I) N3=NODES(3,I) X1=XNODE(N1) X2=XNODE(N2) X3=XNODE(N3) Y1=YNODE(N1) Y2=YNODE(N2) Y3=YNODE(N3) CUTRAD=MIN(Y1,Y2,Y3)-3.1415926 Y1=PHIOK(Y1) Y2=PHIOK(Y2) Y3=PHIOK(Y3) F1=ATNODE(N1) F2=ATNODE(N2) F3=ATNODE(N3) FLOW=MIN(F1,F2,F3) FHIGH=MAX(F1,F2,F3) FNADIR=MIN(FNADIR,FLOW) FZENIT=MAX(FZENIT,FHIGH) ILOW=IBELOW((FGRAY-FLOW)/DFC+0.99) IHIGH=IBELOW((FGRAY-FHIGH)/DFC+1.01) IF (F2.EQ.F3) THEN IF (F1.LT.F2) THEN TEST=F2/DFC TEST2=ABS(AMOD((TEST+0.5),1.)) IF (ABS(TEST2-0.5).LT.0.01) THEN IOUT=(FGRAY-F2)/DFC IIN=IOUT+1 IF (LOWBLU.GE.0) THEN INDEXI=IIN INDEXO=IOUT ELSE INDEXI=1-IIN INDEXO=1-IOUT ENDIF SHOLIN=(.NOT.COLOR).OR. + (EDGEIT).OR. + (.NOT. ( + ((INDEXI.GE.1).AND.(INDEXI.LT.NGRAY)) + .OR. + ((INDEXO.GE.1).AND.(INDEXO.LT.NGRAY)) + ) ) IF (SHOLIN) THEN ELOND1=Y2*OEZOPI ELOND2=Y3*OEZOPI NLATD1=90.-OEZOPI*X2 NLATD2=90.-OEZOPI*X3 CALL MYARC (INPUT,ELOND1,NLATD1,ELOND2, + NLATD2,CUTLN1,CUTLN2, + GREAT) ENDIF ENDIF ENDIF ENDIF IF (F3.EQ.F1) THEN IF (F2.LT.F1) THEN TEST=F1/DFC TEST2=ABS(AMOD((TEST+0.5),1.)) IF (ABS(TEST2-0.5).LT.0.01) THEN IOUT=(FGRAY-F1)/DFC IIN=IOUT+1 IF (LOWBLU.GE.0) THEN INDEXI=IIN INDEXO=IOUT ELSE INDEXI=1-IIN INDEXO=1-IOUT ENDIF SHOLIN=(.NOT.COLOR).OR. + (EDGEIT).OR. + (.NOT. ( + ((INDEXI.GE.1).AND.(INDEXI.LT.NGRAY)) + .OR. + ((INDEXO.GE.1).AND.(INDEXO.LT.NGRAY)) + ) ) IF (SHOLIN) THEN ELOND1=Y3*OEZOPI ELOND2=Y1*OEZOPI NLATD1=90.-OEZOPI*X3 NLATD2=90.-OEZOPI*X1 CALL MYARC (INPUT,ELOND1,NLATD1,ELOND2, + NLATD2,CUTLN1,CUTLN2, + GREAT) ENDIF ENDIF ENDIF ENDIF IF (F1.EQ.F2) THEN IF (F3.LT.F2) THEN TEST=F1/DFC TEST2=ABS(AMOD((TEST+0.5),1.)) IF (ABS(TEST2-0.5).LT.0.01) THEN IOUT=(FGRAY-F1)/DFC IIN=IOUT+1 IF (LOWBLU.GE.0) THEN INDEXI=IIN INDEXO=IOUT ELSE INDEXI=1-IIN INDEXO=1-IOUT ENDIF SHOLIN=(.NOT.COLOR).OR. + (EDGEIT).OR. + (.NOT. ( + ((INDEXI.GE.1).AND.(INDEXI.LT.NGRAY)) + .OR. + ((INDEXO.GE.1).AND.(INDEXO.LT.NGRAY)) + ) ) IF (SHOLIN) THEN ELOND1=Y1*OEZOPI ELOND2=Y2*OEZOPI NLATD1=90.-OEZOPI*X1 NLATD2=90.-OEZOPI*X2 CALL MYARC (INPUT,ELOND1,NLATD1,ELOND2, + NLATD2,CUTLN1,CUTLN2, + GREAT) ENDIF ENDIF ENDIF ENDIF 3000 CONTINUE CALL EGROUP CALL RESET ('NEWCLR') C C NOTE: MAIN SUBPLOT IS INTENTIONALLY LEFT OPEN, SO THAT C MORE CAN BE ADDED ON TOP (I.E., VECTORS, COASTLINES). C C WHEN DONE WITH MAIN PLOT, CALL -FRAME- AND -BAR-. C RETURN END C C C SUBROUTINE BAR (INPUT,COLOR,DFC,FGRAY,FNADIR,FZENIT,LOWBLU, + MXPNTS,NVUCHR,VMULT,VUNITS,XWIDE, + OUTPUT,YBASE, + WORK,XARAY,YARAY) C C ADDS SEVERAL LINES BELOW THE MAP, C CONTAINING THE COLOR-BAR (OR GRAYSCALE BAR). C CHARACTER*20 COLNAM CHARACTER*42 VUNITS LOGICAL COLOR DIMENSION GAPRAY(1),RATRAY(2), + XARAY(MXPNTS),YARAY(MXPNTS), + XDUMMY(1),YDUMMY(1) DIMENSION ALONG(99),COLNAM(99),SPACIN(99) COMMON /MYOWN/ NGRAY,ALONG,COLNAM,SPACIN COMMON LDA,MD,ABUT C C**************************************************************** C C BEGIN COLOR-BAR (GRAY-BAR) SUBPLOT C CALL BGROUP C C CHARACTER DIMENSIONS, IN INCHES HITE=11./72. CALL HEIGHT (HITE) WIDTH=1.0*HITE C C VERTICAL POSITION OF BASE-LINE OF ALL BOXES (IN INCHES): C YLINE= 0.7 YBASE=YLINE-HITE C C ADJUST HORIZONTAL POSITION FOR WIDTH OF PAPER C XMID=0.5*XWIDE HALF=3.*(XWIDE/11.) C C X-POSITIONS FOR TEXT WILL REFER TO CENTERS: C CALL ALNMES (0.5,0.0) C CALL THKVEC (1.) C ILOW=IBELOW((FGRAY-FNADIR)/DFC+0.99) IHIGH=IBELOW((FGRAY-FZENIT)/DFC+1.01) FLOW=FNADIR*VMULT FHIGH=FZENIT*VMULT IF (ILOW.LE.IHIGH) THEN C UNIFORM COLOR; NO INTERNAL CONTOURS C USE 2" BOX TO ALLOW ROOM FOR END LABELS XARAY(1)=XMID-1. XARAY(2)=XMID+1. XARAY(3)=XARAY(2) XARAY(4)=XARAY(1) XARAY(5)=XARAY(1) YARAY(1)=YLINE YARAY(2)=YARAY(1) YARAY(3)=YLINE+0.3 YARAY(4)=YARAY(3) YARAY(5)=YARAY(1) IF (LOWBLU.GE.0) THEN INDEX=ILOW ELSE INDEX=1-ILOW ENDIF IF (INDEX.GE.1) THEN IF (COLOR) THEN INDEX=MIN(INDEX,NGRAY) CALL NEWCLR (COLNAM(INDEX)) CALL SHDCRV(XARAY,YARAY,5,XDUMMY,YDUMMY,0) CALL RESET ('NEWCLR') ELSE INDEX=MIN(INDEX,NGRAY) ANGLE=MOD(INDEX+1,4)*45. RATRAY(1)=ALONG(INDEX) RATRAY(2)=0.100-RATRAY(1) GAPRAY(1)=SPACIN(INDEX) CALL SHADE (XARAY,YARAY,5,ANGLE,GAPRAY,1,0,0) ENDIF ENDIF CALL VECTOR (XMID-1.,YLINE,XMID+1.,YLINE,0) CALL VECTOR (XMID+1.,YLINE,XMID+1.,YLINE+0.3,0) CALL VECTOR (XMID+1.,YLINE+0.3,XMID-1.,YLINE+0.3,0) CALL VECTOR (XMID-1.,YLINE+0.3,XMID-1.,YLINE,0) IF ((ABS(FNADIR)/ABS(DFC)).LE.0.10) FLOW=0.0 CALL RLREAL (FLOW,103,XMID-1.,YBASE) IF ((ABS(FZENIT)/ABS(DFC)).LE.0.10) FHIGH=0.0 CALL RLREAL (FHIGH,103,XMID+1.,YBASE) ELSE C CONTOUR(S) MUST BE LOCATED C STRETCH BOX TO (2*HALF) INCHES WIDE NUMCON=ILOW-IHIGH NPNTS=5 C C FIRST LOOP DOES SHADING RECTANGLES AND NUMBERS C BUT NOT CONTOUR BARS OR FRAME (WHICH MUST BE ON TOP) C DO 1900 J=1,NUMCON IIN=ILOW-(J-1) IOUT=IIN-1 FCON=FGRAY-IOUT*DFC X=XMID-HALF+2.*HALF*(FCON-FNADIR)/(FZENIT-FNADIR) IF (J.EQ.1) THEN C FIRST POLYGON XARAY(1)=XMID-HALF YARAY(1)=YLINE XARAY(2)=X YARAY(2)=YARAY(1) XARAY(3)=XARAY(2) YARAY(3)=YLINE+0.3 XARAY(4)=XARAY(1) YARAY(4)=YARAY(3) XARAY(5)=XARAY(1) YARAY(5)=YARAY(1) IF (LOWBLU.GE.0) THEN INDEX=IIN ELSE INDEX=1-IIN ENDIF IF (INDEX.GE.1) THEN IF (COLOR) THEN INDEX=MIN(INDEX,NGRAY) CALL NEWCLR (COLNAM(INDEX)) CALL SHDCRV(XARAY,YARAY,5,XDUMMY, + YDUMMY,0) CALL RESET ('NEWCLR') ELSE INDEX=MIN(INDEX,NGRAY) ANGLE=MOD(INDEX+1,4)*45. RATRAY(1)=ALONG(INDEX) RATRAY(2)=0.100-RATRAY(1) GAPRAY(1)=SPACIN(INDEX) CALL SHADE (XARAY,YARAY,5,ANGLE,GAPRAY, + 1,0,0) ENDIF ENDIF C CALL RLREAL (FLOW,103,XARAY(1),YBASE) FTEMP=FCON*VMULT CALL RLREAL (FTEMP,103,XARAY(2),YBASE) ELSE C ONE MORE POLYGON IN A SERIES XARAY(1)=XOLD YARAY(1)=YLINE XARAY(2)=X YARAY(2)=YARAY(1) XARAY(3)=XARAY(2) YARAY(3)=YLINE+0.3 XARAY(4)=XARAY(1) YARAY(4)=YARAY(3) XARAY(5)=XARAY(1) YARAY(5)=YARAY(1) IF (LOWBLU.GE.0) THEN INDEX=IIN ELSE INDEX=1-IIN ENDIF IF (INDEX.GE.1) THEN IF (COLOR) THEN INDEX=MIN(INDEX,NGRAY) CALL NEWCLR (COLNAM(INDEX)) CALL SHDCRV(XARAY,YARAY,5,XDUMMY, + YDUMMY,0) CALL RESET ('NEWCLR') ELSE INDEX=MIN(INDEX,NGRAY) ANGLE=MOD(INDEX+1,4)*45. RATRAY(1)=ALONG(INDEX) RATRAY(2)=0.100-RATRAY(1) GAPRAY(1)=SPACIN(INDEX) CALL SHADE (XARAY,YARAY,5,ANGLE,GAPRAY, + 1,0,0) ENDIF ENDIF FTEMP=FCON*VMULT CALL RLREAL (FTEMP,103,XARAY(2),YBASE) ENDIF IF (J.EQ.NUMCON) THEN C LAST POLYGON TO FILL IN XARAY(1)=X YARAY(1)=YLINE XARAY(2)=XMID+HALF YARAY(2)=YARAY(1) XARAY(3)=XARAY(2) YARAY(3)=YLINE+0.3 XARAY(4)=XARAY(1) YARAY(4)=YARAY(3) XARAY(5)=XARAY(1) YARAY(5)=YARAY(1) IF (LOWBLU.GE.0) THEN INDEX=IOUT ELSE INDEX=1-IOUT ENDIF IF (INDEX.GE.1) THEN IF (COLOR) THEN INDEX=MIN(INDEX,NGRAY) CALL NEWCLR (COLNAM(INDEX)) CALL SHDCRV(XARAY,YARAY,5,XDUMMY, + YDUMMY,0) CALL RESET ('NEWCLR') ELSE INDEX=MIN(INDEX,NGRAY) ANGLE=MOD(INDEX+1,4)*45. RATRAY(1)=ALONG(INDEX) RATRAY(2)=0.100-RATRAY(1) GAPRAY(1)=SPACIN(INDEX) CALL SHADE (XARAY,YARAY,5,ANGLE,GAPRAY, + 1,0,0) ENDIF ENDIF ENDIF IF (COLOR) THEN CALL NEWCLR ('FORE') ENDIF XOLD=X 1900 CONTINUE C C SECOND LOOP ONLY PLOTS VERTICAL CONTOUR BARS, SO THEY ARE ON TOP C CALL THKVEC (1.5) IF (COLOR) THEN CALL NEWCLR ('FORE') ENDIF DO 2900 J=1,NUMCON IIN=ILOW-(J-1) IOUT=IIN-1 FCON=FGRAY-IOUT*DFC X=XMID-HALF+2.*HALF*(FCON-FNADIR)/(FZENIT-FNADIR) CALL VECTOR (X,YLINE,X,YLINE+0.3,0) 2900 CONTINUE C C ADD OUTER (LONG) BOX C CALL VECTOR (XMID-HALF,YLINE,XMID+HALF,YLINE,0) CALL VECTOR (XMID+HALF,YLINE,XMID+HALF,YLINE+0.3,0) CALL VECTOR (XMID+HALF,YLINE+0.3,XMID-HALF,YLINE+0.3,0) CALL VECTOR (XMID-HALF,YLINE+0.3,XMID-HALF,YLINE,0) ENDIF CALL RESET ('THKVEC') C CALL RLMESS (' ',1,ABUT,ABUT) CALL RLMESS (VUNITS,NVUCHR,ABUT,ABUT) C CALL EGROUP RETURN END C C C INTEGER FUNCTION IBELOW (X) C C RETURNS INTEGER WHICH IS ALWAYS ROUNDED IN THE NEGATIVE C DIRECTION, UNLIKE IMPLICIT TYPE CONVERSION, WHICH C ALWAYS ROUNDS TOWARD ZERO. C IF (X.GE.0.0) THEN IBELOW=INT(X) ELSE I=INT(X) IF (X.GE.(1.*I)) THEN IBELOW=I ELSE IBELOW=I-1 ENDIF ENDIF RETURN END C C C REAL FUNCTION ROUND (X) C C ROUNDS A POSITIVE REAL NUMBER TO THE FORM N*10**M C M=IBELOW(ALOG10(X)) N=INT(X/10.**M + 0.5) ROUND=N*10.**M RETURN END C C C BLOCK DATA COLORS C C CONTAINS COLOR AND GRAY-SCALE DEFINITIONS USED BY C BOTH -SCALAR- AND -BAR-. C CHARACTER*20 COLNAM COMMON /MYOWN/ NGRAY,ALONG,COLNAM,SPACIN C NOTE: DIMENSION EXCEEDS ACTUAL NUMBER OR COLORS; C MUST MATCH DIMENSION STATEMENTS IN OTHER PROGRAMS; C ACTUAL NUMBER OF ENTRIES IS INDICATED BY "NGRAY". DIMENSION ALONG(99),COLNAM(99),SPACIN(99) C C GRAY SCALE IS CONSTRUCTED WITHIN A 0.010" SQUARE, WITH C DENSITY INCREASING AS THE INDEX RISES. C "ALONG" IS THE LENGTH OF THE DASHES, WHILE "SPACIN" IS THE C SPACING OF THE DASHED LINES. C DATA NGRAY /9/ DATA ALONG(1)/0.010/, SPACIN(1)/0.100/, COLNAM(1)/'MAGE'/, + ALONG(2)/0.020/, SPACIN(2)/0.095/, COLNAM(2)/'RED'/, + ALONG(3)/0.030/, SPACIN(3)/0.090/, COLNAM(3)/'KHAK'/, + ALONG(4)/0.040/, SPACIN(4)/0.080/, COLNAM(4)/'YELL'/, + ALONG(5)/0.050/, SPACIN(5)/0.070/, COLNAM(5)/'GRYE'/, + ALONG(6)/0.060/, SPACIN(6)/0.060/, COLNAM(6)/'KELL'/, + ALONG(7)/0.070/, SPACIN(7)/0.050/, COLNAM(7)/'GRBL'/, + ALONG(8)/0.080/, SPACIN(8)/0.040/, COLNAM(8)/'SKY'/, + ALONG(9)/0.090/, SPACIN(9)/0.030/, COLNAM(9)/'GHBL'/ C--------------------------------------------------------------- C IMPORTANT COLOR NOTES C C THE COLOR LIST ABOVE IS CAREFULLY CHOSEN TO GIVE A REASONABLE C COLOR ORDER ON BOTH THE TERMINAL AND VERSATEC. MOST 'REASONABLE' C CHANGES WILL DESTROY THE ORDER ON THE TERMINAL. C C IT IS NOT POSSIBLE TO HAVE 1-TO-1 CORRESPONDANCE BETWEEN C DEVICES BECAUSE THE TERMINAL CAN ONLY DO 6 REAL COLORS C BESIDES BLACK AND WHITE (BLUE, CYAN, GREEN, YELLOW, RED, PINK). C I HAVE USED EACH OF THE MORE PLEASANT COLORS TWICE. C THEREFORE, BOTH 'GHBL' AND 'SKY' WILL APPEAR IN BLUE, C BOTH 'GRYE' AND 'KELL' WILL APPEAR IN GREEN, C AND 'YELL' AND 'KHAK' WILL APPEAR IN YELLOW. C THE LESS PLEASANT CYAN AND PINK ARE ONLY USED ONCE EACH, C CORRESPONDING TO 'GRBL' AND 'MAGE', RESPECTIVELY. C OF COURSE, 'RED' IS RED. C C 'FORE' (FOREGROUND) IS WHITE ON TERMINAL, BUT BLACK ON PLOT. C 'BACK' (BACKGROUND) IS BLACK ON TERMINAL, BUT WHITE ON PLOT. C C OVER-WRITING WORKS FINE ON TERMINAL, BUT ON THE VERSATEC C YOU GET THE SUM OF ALL REQUESTED PIGMENTS. THEREFORE, IT IS C BEST TO OVERWRITE WITH BLACK, AND NOTHING CAN OVERWRITE ON C TOP OF BLACK. C C CONSIDERING ALL OF THIS, THE GENERAL BEST COLOR FOR OVERWRITING C IS 'FORE', AND IT IS BEST TO AVOID BLACK AS A SHADING COLOR. C C (IT IS ALSO WISE TO AVOID SHADING WITH 'BACK', BECAUSE ALTHOUGH C AT FIRST SIGHT THIS MIGHT NOT SEEM TO MAKE ANY DIFFERENCE, ON C THE TERMINAL IT CAN BLANK OUT CONTOUR LINES ALONG THE MARGINS.) C------------------------------------------------------------------ END C C C SUBROUTINE CONVEC (INPUT,ICONVE,IPVREF,IUNITM,IUNITT, + MXEL,MXFEL,MXNODE, + NAMES,NDPLAT, + NFL,NODEF,NODES, + NPBND,NPLATE,NUMEL,NUMNOD, + OMEGA,PLAT,PLON,RADIUS,VTIMES, + XNODE,YNODE, + OUTPUT,VM, + WORK,CHECKN) C C COMPUTES LOWER-MANTLE FLOW VELOCITY BELOW ASTHENOSPHERE C C COMPUTATION STRATEGY VARIES BY MODEL; FOR MANY, DATA FILES C MUST BE READ FROM UNIT IUNITM. C C REGARDLESS OF MODEL, THE FACTOR VTIMES IS APPLIED. C C VELOCITIES ARE INITIALLY COMPUTED IN THE AFRICA-FIXED C REFERENCE FRAME (FOR HISTORICAL REASONS); THEN THEY ARE C TRANSFORMED TO APPEAR IN THE REFERENCE FRAME OF PLATE C #IPVREF; THIS IS DONE BY A COMMON TRANSFORMATION AT THE END OF C THIS ROUTINE. C REAL NLAT1,NLAT2 LOGICAL CHECKN,GOTOUT DOUBLE PRECISION VM CHARACTER*27 ENDSEG CHARACTER*2 NAMES DIMENSION NODES(3,MXEL) DIMENSION NODEF(4,MXFEL) DIMENSION CHECKN(MXNODE),XNODE(MXNODE),YNODE(MXNODE),VM(2,MXNODE) DIMENSION HOC792(2,-8:8,1:36) DIMENSION BAUM88(5,1000) DIMENSION NAMES(NPLATE),OMEGA(3,NPLATE),PLAT(NPLATE,NPBND), + PLON(NPLATE,NPBND),NDPLAT(NPLATE) C C STATEMENT FUNCTIONS: COSDEG(DEG)=COS(DEG*0.017453293D0) SINDEG(DEG)=SIN(DEG*0.017453293D0) C IF (ICONVE.EQ.0) THEN C DO 99 I=1,NUMNOD VM(1,I)=0.0D0 VM(2,I)=0.0D0 C NOTE: THIS IS IN AFRICA-FIXED REFERENCE FRAME; C SEE BELOW AT END OF ROUTINE FOR TRANSFORMATION. 99 CONTINUE C ELSE IF (ICONVE.EQ.1) THEN C C HAGER AND O'CONNELL (1979) VISCOSITY MODEL II C C READ FROM FILE "HOC79II.DIG" C VECTORS ARE EVERY 10 DEGREES IN LATITUDE AND LONGITUDE C COLUMNS MARCH EAST FROM 10E TO 360E. C WITHIN EACH COLUMN, TRAVEL IS S FROM 80N TO 80S. C UNITS OF INPUT DATA ARE DEGREES EAST AND NORTH. C 2ND END OF LINE SEGMENT SHOWS WHERE THE GRID POINT C WILL BE DISPLACED TO AFTER 50 MA OF FLOW. C DO 140 JEAST=1,36 DO 130 ISOUTH=-8,8 READ (IUNITM,*,END=101,ERR=101) ELON1,NLAT1 GO TO 103 C -------------------- ERR0R HANDLER ---------- 101 WRITE (IUNITT,102) IUNITM,JEAST,ISOUTH 102 FORMAT (/' ERR0R IN -CONVEC-:' + /' WHILE READING MANTLE VELOCITIES FROM' + ,' UNIT ',I3 + /' TO FILL IN COLUMN ',I2,', ROW ',I2 + /' ENCOUNTERED A RECORD WHICH DOES NOT' + ,' HOLD TWO RECOGNIZABLE NUMBERS.') STOP C --------------------------------------------- 103 JC=(ELON1/10.)+0.5 IF (NLAT1.GE.0.) THEN IR=(NLAT1/10.)+0.5 IR= -IR ELSE IR=(-NLAT1/10.)+0.5 ENDIF IF ((JC.NE.JEAST).OR.(IR.NE.ISOUTH)) THEN WRITE (IUNITT,104) IUNITM,ISOUTH,JEAST,IR,JC, + ELON1,NLAT1 104 FORMAT (/' ERR0R: WHILE READING LOWER-MANTLE' + ,' FLOW VECTORS FROM UNIT ',I3 + /' AND LOOKING FOR ROW ',I2,', COLUMN ',I2 + /' ENCOUNTERED ROW ',I2,', COLUMN ',I2 + /' (LONGITUDE ',F7.2,', LATITUDE ',F6.2,') + ') STOP ENDIF READ (IUNITM,*,ERR=101,END=101) ELON2,NLAT2 READ (IUNITM,'(A)') ENDSEG TX=COSDEG(NLAT1)*COSDEG(ELON1) TY=COSDEG(NLAT1)*SINDEG(ELON1) TZ=SINDEG(NLAT1) HX=COSDEG(NLAT2)*COSDEG(ELON2) HY=COSDEG(NLAT2)*SINDEG(ELON2) HZ=SINDEG(NLAT2) VX=(HX-TX)*RADIUS/(50.E6*3.15576E7) VY=(HY-TY)*RADIUS/(50.E6*3.15576E7) VZ=(HZ-TZ)*RADIUS/(50.E6*3.15576E7) THETAX=SINDEG(NLAT1)*COSDEG(ELON1) THETAY=SINDEG(NLAT1)*SINDEG(ELON1) THETAZ= -COSDEG(NLAT1) VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ PHIX= -SINDEG(ELON1) PHIY=COSDEG(ELON1) PHIZ=0. VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ HOC792(1,IR,JC)=VTHETA HOC792(2,IR,JC)=VPHI 130 CONTINUE 140 CONTINUE DO 190 I=1,NUMNOD NLAT1=90.-XNODE(I)*57.2958 NLAT1=MIN(NLAT1,+80.) NLAT1=MAX(NLAT1,-80.) ELON1=YNODE(I)*57.2958 IF (ELON1.LT.0.) ELON1=ELON1+360. IF (ELON1.LT.0.) ELON1=ELON1+360. IF (ELON1.GT.360.) ELON1=ELON1-360. IF (NLAT1.GE.0.) THEN IRTOP=(NLAT1/10.)+1. IRTOP= -IRTOP ELSE IRTOP=(-NLAT1/10.) ENDIF IF (IRTOP.LT.8) THEN IRBOT=IRTOP+1 FS=(-IRTOP*10.-NLAT1)/10. ELSE IRBOT=IRTOP FS=0. ENDIF JCRIGH=ELON1/10.+1. JCRIGH=MIN(JCRIGH,36) IF (JCRIGH.GT.1) THEN JCLEFT=JCRIGH-1 FE=(ELON1-10.*JCLEFT)/10. ELSE JCLEFT=36 FE=ELON1/10. ENDIF VTOP=HOC792(1,IRTOP,JCLEFT)+ + (HOC792(1,IRTOP,JCRIGH)-HOC792(1,IRTOP,JCLEFT))*FE VBOT=HOC792(1,IRBOT,JCLEFT)+ + (HOC792(1,IRBOT,JCRIGH)-HOC792(1,IRBOT,JCLEFT))*FE VM(1,I)=VTOP+(VBOT-VTOP)*FS VTOP=HOC792(2,IRTOP,JCLEFT)+ + (HOC792(2,IRTOP,JCRIGH)-HOC792(2,IRTOP,JCLEFT))*FE VBOT=HOC792(2,IRBOT,JCLEFT)+ + (HOC792(2,IRBOT,JCRIGH)-HOC792(2,IRBOT,JCLEFT))*FE VM(2,I)=VTOP+(VBOT-VTOP)*FS VM(1,I)=VM(1,I)*VTIMES VM(2,I)=VM(2,I)*VTIMES 190 CONTINUE C ELSE IF (ICONVE.EQ.2) THEN C C BAUMGARDNER (1988) FIGURE 7, PARTS A-F C C READ FROM FILE "BAUM887.DIG" C VECTORS ARE IN RANDOM ORDER, ABOUT 729 IN ALL. C UNITS OF INPUT DATA ARE DEGREES EAST AND NORTH. C 2ND END OF LINE SEGMENT SHOWS WHERE THE GRID POINT C WILL BE DISPLACED TO AFTER 11 MA OF FLOW. C (TIME WOULD BE 110 MA, BUT HE SAYS TO SCALE V UP C *10 BECAUSE EARTH'S RAYLEIGH NUMBER IS HIGHER THAN C THAT OF THE MODEL.) C NUMVEC=0 DO 220 JVEC=1,1000 READ (IUNITM,*,END=221,ERR=201) ELON1,NLAT1 GO TO 203 C -------------------- ERR0R HANDLER ---------- 201 WRITE (IUNITT,202) IUNITM,JVEC 202 FORMAT (/' ERR0R IN -CONVEC-:' + /' WHILE READING MANTLE VELOCITIES FROM' + ,' UNIT ',I3 + /' TO FILL IN VECTOR ',I2, + /' ENCOUNTERED A RECORD WHICH DOES NOT' + ,' HOLD TWO RECOGNIZABLE NUMBERS.') STOP C --------------------------------------------- 203 READ (IUNITM,*,ERR=201,END=221) ELON2,NLAT2 READ (IUNITM,'(A)') ENDSEG TX=COSDEG(NLAT1)*COSDEG(ELON1) TY=COSDEG(NLAT1)*SINDEG(ELON1) TZ=SINDEG(NLAT1) HX=COSDEG(NLAT2)*COSDEG(ELON2) HY=COSDEG(NLAT2)*SINDEG(ELON2) HZ=SINDEG(NLAT2) VX=(HX-TX)*RADIUS/(11.E6*3.15576E7) VY=(HY-TY)*RADIUS/(11.E6*3.15576E7) VZ=(HZ-TZ)*RADIUS/(11.E6*3.15576E7) THETAX=SINDEG(NLAT1)*COSDEG(ELON1) THETAY=SINDEG(NLAT1)*SINDEG(ELON1) THETAZ= -COSDEG(NLAT1) VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ PHIX= -SINDEG(ELON1) PHIY=COSDEG(ELON1) PHIZ=0. VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ BAUM88(1,JVEC)=VTHETA BAUM88(2,JVEC)=VPHI BAUM88(3,JVEC)=TX BAUM88(4,JVEC)=TY BAUM88(5,JVEC)=TZ NUMVEC=NUMVEC+1 220 CONTINUE 221 DO 290 I=1,NUMNOD TX=SIN(XNODE(I))*COS(YNODE(I)) TY=SIN(XNODE(I))*SIN(YNODE(I)) TZ=COS(XNODE(I)) R2MIN=999. DO 280 J=1,NUMVEC R2=(TX-BAUM88(3,J))**2+ + (TY-BAUM88(4,J))**2+ + (TZ-BAUM88(5,J))**2 IF (R2.LT.R2MIN) THEN R2MIN=R2 VM(1,I)=BAUM88(1,J) VM(2,I)=BAUM88(2,J) VM(1,I)=VM(1,I)*VTIMES VM(2,I)=VM(2,I)*VTIMES ENDIF 280 CONTINUE 290 CONTINUE C ELSE IF ((ICONVE.EQ.3).OR.(ICONVE.EQ.4)) THEN C C NUVEL-1A PLATE MODEL OF DE METS ET AL. (1994); C ALREADY HAS PLATE -NAMES- AND -OMEGA- VECTORS FROM C CALLING PROGRAM; MUST ALSO HAVE DIGITISED PLATE C BOUNDARIES IN ARRAYS -PLAT- AND -PLON-. C THAT IS, THIS ROUTINE DOES NO I/O. C C CHECK WHICH NODES ARE ON FAULTS: DO 310 I=1,NUMNOD CHECKN(I)=.FALSE. 310 CONTINUE DO 320 I=1,NFL DO 315 K=1,4 CHECKN(NODEF(K,I))=.TRUE. 315 CONTINUE 320 CONTINUE C C FOR NODES ON FAULTS, ATTEMPT TO OFFSET TEST POSITION C WHICH IS USED TO DETERMINE PLATE MEMBERSHIP C (BUT NOT POSITION USED IN V = OMEGA X R ) DO 390 I=1,NUMNOD XVEL=XNODE(I) YVEL=YNODE(I) IF (CHECKN(I)) THEN GOTOUT=.FALSE. DO 330 J=1,NUMEL N1=NODES(1,J) N2=NODES(2,J) N3=NODES(3,J) IF ((N1.EQ.I).OR.(N2.EQ.I).OR.(N3.EQ.I)) THEN IF ((N1.NE.I).AND.(.NOT.CHECKN(N1)))THEN GOTOUT=.TRUE. XINPL=XNODE(N1) YINPL=YNODE(N1) GO TO 331 ENDIF IF ((N2.NE.I).AND.(.NOT.CHECKN(N2)))THEN GOTOUT=.TRUE. XINPL=XNODE(N2) YINPL=YNODE(N2) GO TO 331 ENDIF IF ((N3.NE.I).AND.(.NOT.CHECKN(N3)))THEN GOTOUT=.TRUE. XINPL=XNODE(N3) YINPL=YNODE(N3) GO TO 331 ENDIF ENDIF 330 CONTINUE 331 IF (.NOT.GOTOUT) THEN DO 340 J=1,NUMEL N1=NODES(1,J) N2=NODES(2,J) N3=NODES(3,J) IF ((N1.EQ.I).OR.(N2.EQ.I).OR. + (N3.EQ.I)) THEN A1=SIN(XNODE(N1))*COS(YNODE(N1)) B1=SIN(XNODE(N1))*SIN(YNODE(N1)) G1=COS(XNODE(N1)) A2=SIN(XNODE(N2))*COS(YNODE(N2)) B2=SIN(XNODE(N2))*SIN(YNODE(N2)) G2=COS(XNODE(N2)) A3=SIN(XNODE(N3))*COS(YNODE(N3)) B3=SIN(XNODE(N3))*SIN(YNODE(N3)) G3=COS(XNODE(N3)) AC=(A1+A2+A3)/3. BC=(B1+B2+B3)/3. GC=(G1+G2+G3)/3. SIZE=SQRT(AC**2+BC**2+GC**2) AC=AC/SIZE BC=BC/SIZE GC=GC/SIZE EQUAT=SQRT(AC**2+BC**2) XINPL=ATAN2(EQUAT,GC) YINPL=ATAN2(BC,AC) GO TO 341 ENDIF 340 CONTINUE 341 CONTINUE ENDIF ELSE XINPL=XVEL YINPL=YVEL ENDIF CALL FINDPV (INPUT,IUNITT,NDPLAT,NPBND,NPLATE,OMEGA, + PLAT,PLON,RADIUS, + XINPL,XVEL,YINPL,YVEL, + OUTPUT,VPHI,VTHETA) VM(1,I)=VTHETA*VTIMES VM(2,I)=VPHI*VTIMES 390 CONTINUE ELSE C WRITE (IUNITT,999) ICONVE 999 FORMAT (/' ILLEGAL INTEGER CODE FOR LOWER-MANTLE' + /' CONVECTION PATTERN (ICONVE): ',I6) STOP C ENDIF C C END OF SELECTION BASED ON ICONVE; C NOW APPLY VELOCITY REFERENCE FRAME TRANSFORMATION FROM C AFRICA-FIXED TO PLATE #IPVREF FIXED: C C ROTATION OF PLATE IPVREF WRT AFRICA, IN RADIANS/SECOND: OMEGAX=(OMEGA(1,IPVREF)-OMEGA(1,2))*3.168809E-14 OMEGAY=(OMEGA(2,IPVREF)-OMEGA(2,2))*3.168809E-14 OMEGAZ=(OMEGA(3,IPVREF)-OMEGA(3,2))*3.168809E-14 C CONVERT TO LENGTH/SECOND: OMEGAX=OMEGAX*RADIUS OMEGAY=OMEGAY*RADIUS OMEGAZ=OMEGAZ*RADIUS C DO 2000 I=1,NUMNOD C VELOCITY OF IPVREF WRT AFRICA = OMEGA X POSITION: THETA=XNODE(I) PHI=YNODE(I) XN=SIN(THETA)*COS(PHI) YN=SIN(THETA)*SIN(PHI) ZN=COS(THETA) VX=OMEGAY*ZN-OMEGAZ*YN VY=OMEGAZ*XN-OMEGAX*ZN VZ=OMEGAX*YN-OMEGAY*XN C CREATE UNIT +THETA AND +PHI VECTORS IN CARTESIAN: THETAX=COS(THETA)*COS(PHI) THETAY=COS(THETA)*SIN(PHI) THETAZ= -SIN(THETA) PHIX= -SIN(PHI) PHIY=COS(PHI) PHIZ=0. C FIND ARGUMENT FROM DOT PRODUCTS: VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ C C TRANSFORM THE VELOCITY PREVIOUSLY FOUND IN THE C AFRICA-FIXED REFERENCE FRAME TO ONE IN THE C IPVREF-FIXED REFERENCE FRAME: VM(1,I)=VM(1,I)-VTHETA VM(2,I)=VM(2,I)-VPHI C 2000 CONTINUE C RETURN END C C C SUBROUTINE ONEBAR (INPUT,ACREEP,BCREEP,CCREEP, + ECREEP,GEOTHC,GEOTHM,GRADIE, + IUNITT,MXEL,NUMEL,ONEKM,TADIAB, + ZBASTH,ZMOHO, + OUTPUT,GLUE) C C CALCULATES "GLUE" (SHEAR STRESS REQUIRED TO CREATE UNIT RELATIVE C HORIZONTAL VELOCITY ACROSS THE LITHOSPHERE+ASTHENOSPHERE) C C EXTERNAL ARGUMENT ARRAYS: DIMENSION ACREEP(2),BCREEP(2),CCREEP(2), + GEOTHC(4,7,MXEL),GEOTHM(4,7,MXEL), + GLUE(7,MXEL), + ZMOHO(7,MXEL) C INTERNAL ARRAYS: DIMENSION AILOG(2),GT(4) C C DZ=ONEKM LIMIT=ZBASTH/DZ+0.5 ECINI= -1.0/ECREEP AILOG(1)=LOG(ACREEP(1))*ECINI AILOG(2)=LOG(ACREEP(2))*ECINI DO 100 M=1,7 DO 90 I=1,NUMEL V=0. DO 20 LEVEL=1,LIMIT Z=(LEVEL-0.5)*DZ IF (Z.LT.ZMOHO(M,I)) THEN LAYER=1 GT(1)=GEOTHC(1,M,I) GT(2)=GEOTHC(2,M,I) GT(3)=GEOTHC(3,M,I) GT(4)=GEOTHC(4,M,I) ELSE LAYER=2 GT(1)=GEOTHM(1,M,I) GT(2)=GEOTHM(2,M,I) C NOTE: QUADRATIC AND CUBIC TERMS COULD C CAUSE LITHOSPHERIC GEOTHERM TO HAVE C MULTIPLE (NONPHYSICAL) INTERSECTIONS C WITH THE ADIABAT! GT(3)=0. GT(4)=0. ENDIF TG=GT(1) + +GT(2)*Z + +GT(3)*Z*Z + +GT(4)*Z*Z*Z TA=TADIAB+Z*GRADIE T=MIN(TG,TA) T=MAX(T,200.) BI=(BCREEP(LAYER)+CCREEP(LAYER)*Z)*ECINI ARG=MAX(AILOG(LAYER)+BI/T,-89.9) V=V+DZ*EXP(ARG) 20 CONTINUE GLUE(M,I)=1./(V**ECREEP) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE THONB (INPUT,CONTIN,ECREEP,ETAMAX, + FPSFER,GLUE,ICONVE, + MXEL,MXNODE,NODES,NUMEL, + OVB,TRHMAX,V, + OUTPUT,CHECKE,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*** SPECIAL FEATURE ADDED TO ORBMAP VERSION ONLY: ******* C CHECKE IS SET .TRUE. IF BASAL TRACTION OF INTEGRATION POINT 1 C IS LIMITED BY ETAMAX. C******************************************************** C LOGICAL CHECKE,CONTIN DOUBLE PRECISION V DIMENSION CHECKE(MXEL),CONTIN(7,MXEL),DVB(7,MXEL), + FPSFER(2,2,3,7,MXEL), + GLUE(7,MXEL), + NODES(6,MXEL),OUTVEC(2,7,MXEL), + OVB(2,7,MXEL), + SIGHB(2,7,MXEL), + V(2,MXNODE) C CALL FLOW (INPUT,FPSFER,MXEL,MXNODE,NODES,NUMEL,V, + OUTPUT,OUTVEC) DO 1000 M=1,7 DO 900 I=1,NUMEL VCX=OUTVEC(1,M,I) VCY=OUTVEC(2,M,I) VMX=OVB(1,M,I) VMY=OVB(2,M,I) VRX=VMX-VCX VRY=VMY-VCY VMAG=SQRT((1.D0*VRX)**2+(1.D0*VRY)**2) DVB(M,I)=VMAG IF (VMAG.GT.0.) THEN DVX=VRX/VMAG DVY=VRY/VMAG SHEAR1=GLUE(M,I)*VMAG**ECREEP SHEAR2=ETAMAX*VMAG SHEAR3=TRHMAX SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3) ELSE DVX=0. DVY=0. SHEAR=0. END IF IF (M.EQ.1) THEN IF (SHEAR.GE.SHEAR2) THEN CHECKE(I)=.TRUE. ELSE CHECKE(I)=.FALSE. ENDIF ENDIF SIGHB(1,M,I)=SHEAR*DVX SIGHB(2,M,I)=SHEAR*DVY IF (ICONVE.EQ.4) THEN C DRAG ONLY APPLIES TO CONTINENTS IF (.NOT.CONTIN(M,I)) THEN SIGHB(1,M,I)=0.0 SIGHB(2,M,I)=0.0 END IF END IF 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE FLOW (INPUT,FPSFER,MXEL,MXNODE,NODES,NUMEL,V, + OUTPUT,OUTVEC) C C CALCULATES VELOCITY VECTORS AT INTEGRATION POINTS, FROM NODAL VALUES C DOUBLE PRECISION V DIMENSION FPSFER(2,2,3,7,MXEL),NODES(3,MXEL),OUTVEC(2,7,MXEL), + V(2,MXNODE) DO 50 M=1,7 DO 40 I=1,NUMEL OUTVEC(1,M,I)=0. OUTVEC(2,M,I)=0. 40 CONTINUE 50 CONTINUE DO 100 J=1,3 DO 90 M=1,7 DO 80 I=1,NUMEL NJI=NODES(J,I) OUTVEC(1,M,I)=OUTVEC(1,M,I) + +V(1,NJI)*FPSFER(1,1,J,M,I) + +V(2,NJI)*FPSFER(2,1,J,M,I) OUTVEC(2,M,I)=OUTVEC(2,M,I) + +V(1,NJI)*FPSFER(1,2,J,M,I) + +V(2,NJI)*FPSFER(2,2,J,M,I) 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE PROJEC (INPUT,VNODE, + COLOR,CUTLN1,CUTLN2, + DFC,EDGEIT,FBLAND,LOWBLU, + MXEL,MXNODE,MXPNTS, + NODES,NUMEL, + XNODE,YNODE, + OUTPUT,FGRAY,FNADIR,FZENIT) C--------------------------------------------------------- C FUNCTIONALLY, THIS IS ALMOST IDENTICAL TO -SCALAR-, C EXCEPT THAT IT IS USED TO PLOT VELOCITY MAGNITUDES, AND C SO IT PROJECTS TO THE EARTH'S SURFACE. C C INTERNALLY, IT IS TOTALLY DIFFERENT, SINCE THIS RESULTS C IN CURVED CONTOUR LINES, AND THEY HAVE TO BE CONTOURED C BY -CONTEL- FOR 6-NODE ELEMENTS, WHICH WE CREATE C ONE-AT-A-TIME. C C FOR ADDED COMPLICATION, -CONTEL- USES VERSATEC LANGUAGE, C SO WE HAVE TO USE FOLLOW-ON ROUTINES TO CONVERT TO DISSPLA. C C A SOMEWHAT SQUIRRELY DIFFERENCE IS THAT -SCALAR- GOT ITS C WORKING STORAGE IN ARRAYS FROM -MAIN-, BUT -CONTEL- CREATES C ITS OWN. I HAVE LEFT -CONTEL- UNCHANGED TO MAKE IT EASIER C TO MIGRATE BUG-FIXES FROM -CONTEL- OF VERSCOMP.PLATES! C-------------------------------------------------------------- C C SHADES THE AREAS WITHIN ALL THE TRIANGULAR ELEMENTS. C IN BLACK-AND-WHITE PLOTTING (WHEN "COLOR"=F) THE SHADED C AREAS ARE ALWAYS BOUNDED BY CONTOUR LINES. IN COLOR C PLOTTING, YOU HAVE A CHOICE: IF (EDGEIT) THEN ALL C CONTOUR LINES ARE DRAWN; OTHERWISE, CONTOURS ARE ONLY C DRAWN FOR EXTREME VALUES WHICH ARE OFF THE END OF THE COLOR C SCALE. THIS OPTION REDUCES THE CLUTTER OF LINES WHEN C YOU ALSO WISH TO PLOT COASTLINES, VECTORS, TENSORS, ETC.. C "CUTLN1" AND "CUTLN2" ARE THE LEFT AND RIGHT LIMITS OF THE MAP C IN DEGREES EAST; "XNODE" AND "YNODE" ARE THETA AND C PHI OF THE NODES, IN RADIANS. C "DFC" IS THE CONTOUR INTERVAL. C IN COLOR PLOTTING, "FBLAND" IS THE VALUE WHICH SEPARATES C THE HIGH COLORS (YELLOW-ORANGE-RED-PINK-WHITE) FROM THE C LOW COLORS (GREEN-BLUE/GREEN-BLUE-DARK BLUE) C (THAT IS, IF LOWBLU=+1; OTHERWISE, COLORS ARE REVERSED.) C IN BLACK/WHITE PLOTTING, "FGRAY" IS THE VALUE C BELOW WHICH GRAY SHADING BEGINS IF (LOWBLU.GE.0); C OTHERWISE "FGRAY" IS THE VALUE ABOVE WHICH GRAY SHADING BEGINS. C CHARACTER*20 COLNAM LOGICAL ALLPOS,COLOR,DOLOR,EDGEIT,GREAT DIMENSION NODES(3,MXEL),VNODE(2,MXNODE), + XNODE(MXNODE),YNODE(MXNODE) DIMENSION ICOLOR(99) DIMENSION NODET(6,1),XNOD(6),YNOD(6),FUNC(6) DIMENSION ALONG(99),COLNAM(99),SPACIN(99) COMMON /MYOWN/ NGRAY,ALONG,COLNAM,SPACIN C FOLLOWING COMMON PASSES ARGUMENTS *AROUND* -CONTEL-: COMMON /CHEAT/ DOLOR,DUTLN1,DUTLN2 C C STATEMENT FUNCTION TO INSURE AGAINST EXTRA CUTS IN LONGITUDE C WHICH ARE NOT ALLOWED WITHIN ONE ELEMENT C (LATER ROUTINE -MYSHAD- WILL DIVIDE AREAS THAT CROSS CUT) PHIOK(PHI)=AMOD(PHI+12.566371-CUTRAD,6.2831853)+CUTRAD C C (FOR REASONS WHICH ARE UNCLEAR, NAME CHANGE NEEDED TO SET COMMON: DOLOR=COLOR DUTLN1=CUTLN1 DUTLN2=CUTLN2 C C ALIGN COLOR SCALE FOR COLOR BAR, USING NATIVE CONVENTIONS FGRAY=FBLAND+LOWBLU*4.*DFC C C TRICK -CONTEL- INTO GENERATING THE SAME COLORS C BY CONSPIRING WITH NEW (REPLACED) -IHUE- C (THIS WILL ALLOW CONTEL TO BE REPLACED WHOLESALE IF THERE IS C ANY NEED TO CORRECT ITS INTRICATE LOGIC.) CCCC CONTEL: N=IHUE (NCOLOR,DFCON,FMIDLE,IFLIP, F) CCCC INTEGER FUNCTION IHUE (NGRAY, DFC, FGRAY, LOWBLU,F) NCOLOR=NGRAY DFCON=DFC FMIDLE=FGRAY IFLIP=LOWBLU C SPECIAL TRICK: OFFSET COLORS BY ONE IN LOOKUP TABLE, BECAUSE C TABLE HAS NO ZERO ENTRY IN -CONTEL-. DO 10 I=0,NGRAY ICOLOR(I+1)=I 10 CONTINUE C C BECAUSE -SHADE- (USED FOR B/W SHADING) BOUNDS ITS AREAS C WITH STRAIGHT LINES ON THE MAP (NOT ARCS OF GREAT CIRCLES), C IT IS NECESSARY TO DRAW CONTOUR LINES IN THE SAME WAY: GREAT=COLOR C FNADIR=SQRT((1.D0*VNODE(1,1))**2+(1.D0*VNODE(2,1))**2) FZENIT=FNADIR NODET(1,1)=1 NODET(2,1)=2 NODET(3,1)=3 NODET(4,1)=4 NODET(5,1)=5 NODET(6,1)=6 IPEN=1 ALLPOS=.TRUE. CALL BGROUP DO 1000 I=1,NUMEL N1=NODES(1,I) N2=NODES(2,I) N3=NODES(3,I) X1=XNODE(N1) X2=XNODE(N2) X3=XNODE(N3) XNOD(1)=X1 XNOD(2)=X2 XNOD(3)=X3 Y1=YNODE(N1) Y2=YNODE(N2) Y3=YNODE(N3) CUTRAD=MIN(Y1,Y2,Y3)-3.1415926 Y1=PHIOK(Y1) Y2=PHIOK(Y2) Y3=PHIOK(Y3) YNOD(1)=Y1 YNOD(2)=Y2 YNOD(3)=Y3 F1=SQRT((1.D0*VNODE(1,N1))**2+(1.D0*VNODE(2,N1))**2) F2=SQRT((1.D0*VNODE(1,N2))**2+(1.D0*VNODE(2,N2))**2) F3=SQRT((1.D0*VNODE(1,N3))**2+(1.D0*VNODE(2,N3))**2) FUNC(1)=F1 FUNC(2)=F2 FUNC(3)=F3 C C PROJECT VELOCITIES AT MIDPOINTS OF SIDES TO CREATE 3 MORE NODES: C DO 100 K=1,3 NS=K NM=K+3 NF=1+MOD(K,3) AS=SIN(XNOD(NS))*COS(YNOD(NS)) BS=SIN(XNOD(NS))*SIN(YNOD(NS)) GS=COS(XNOD(NS)) AF=SIN(XNOD(NF))*COS(YNOD(NF)) BF=SIN(XNOD(NF))*SIN(YNOD(NF)) GF=COS(XNOD(NF)) AM=0.5*(AS+AF) BM=0.5*(BS+BF) GM=0.5*(GS+GF) SIZE=SQRT(AM**2+BM**2+GM**2) AM=AM/SIZE BM=BM/SIZE GM=GM/SIZE EQUAT=SQRT(AM**2+BM**2) XNOD(NM)=ATAN2F(EQUAT,GM) YNOD(NM)=ATAN2F(BM,AM) YNOD(NM)=PHIOK(YNOD(NM)) VAS=+VNODE(1,NODES(NS,I))*COS(XNOD(NS))*COS(YNOD(NS)) + -VNODE(2,NODES(NS,I))*SIN(YNOD(NS)) VBS=+VNODE(1,NODES(NS,I))*COS(XNOD(NS))*SIN(YNOD(NS)) + +VNODE(2,NODES(NS,I))*COS(YNOD(NS)) VGS=-VNODE(1,NODES(NS,I))*SIN(XNOD(NS)) VAF=+VNODE(1,NODES(NF,I))*COS(XNOD(NF))*COS(YNOD(NF)) + -VNODE(2,NODES(NF,I))*SIN(YNOD(NF)) VBF=+VNODE(1,NODES(NF,I))*COS(XNOD(NF))*SIN(YNOD(NF)) + +VNODE(2,NODES(NF,I))*COS(YNOD(NF)) VGF=-VNODE(1,NODES(NF,I))*SIN(XNOD(NF)) VAM=0.5*(VAS+VAF)/SIZE VBM=0.5*(VBS+VBF)/SIZE VGM=0.5*(VGS+VGF)/SIZE DOT=VAM*AM+VBM*BM+VGM*GM VAM=VAM-DOT*AM VBM=VBM-DOT*BM VGM=VGM-DOT*GM FUNC(NM)=SQRT(VAM**2+VBM**2+VGM**2) 100 CONTINUE F4=FUNC(4) F5=FUNC(5) F6=FUNC(6) C FLOW=MIN(F1,F2,F3,F4,F5,F6) FHIGH=MAX(F1,F2,F3,F4,F5,F6) FNADIR=MIN(FNADIR,FLOW) FZENIT=MAX(FZENIT,FHIGH) C- - - - - - - - - - - -- - - - - - - - - - - - - CALL CONTEL (NODET,XNOD,YNOD,FUNC,DFCON,6,1, + FGMAX,FGMIN,NCOLOR,ICOLOR,FMIDLE,IFLIP, + NBLUE,NYELOW,ALLPOS,COLOR,IPEN) C- - - - - - - - - - - - - - - - - - - - - - - - FNADIR=MIN(FNADIR,FGMIN) FZENIT=MAX(FZENIT,FGMAX) 1000 CONTINUE CALL EGROUP CALL RESET ('NEWCLR') C C NOTE: MAIN SUBPLOT IS INTENTIONALLY LEFT OPEN, SO THAT C MORE CAN BE ADDED ON TOP (I.E., VECTORS, COASTLINES). C C WHEN DONE WITH MAIN PLOT, CALL -BAR-. 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 C-------------------------------------------------------- C THIS ROUTINE TAKEN UNCHANGED FROM VERSCOMP.PLATES, C AND THE TRANSLATION FROM VERSATEC TO DISSPLA IS HANDLED BY C VERSATEC-SIMULATING SUBROUTINES WHICH FOLLOW. C ALSO, CALLING PROGRAM -PROJEC- CONSPIRES WITH SUPPORT C FUNCTION -IHUE- TO ENFORCE CORRECT COLOR CHOICES BY C DISSPLA CONVECTIONS, WITH OUT CHANGING -CONTEL-. C-------------------------------------------------------- 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+1), + 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.10/ 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.E38 FGMAX=-1.E38 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.E38 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-40) 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((1.D0*DFDS2)**2+(1.D0*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((1.D0*DFDS2)**2+(1.D0*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((1.D0*DS2)**2+(1.D0*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((1.D0*DFDS2)**2+(1.D0*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=1.E38 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((1.D0*DFDS2)**2+(1.D0*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 CCCCCCCCCCCCCCCCCCCCCCCCCCC C ADDED 15 SEPT 94 IN ORBMAP VERSION ONLY, C TO FORCE ALL CONTOURS TO SHOW: KOLORC=1 CCCCCCCCCCCCCCCCCCCCCCCCCCCC 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.E38 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 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 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 INTEGER FUNCTION IHUE (NGRAY,DFC,FGRAY,LOWBLU,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- - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NOTE: THE FORM OF THIS IS ENTIRELY UNCHANGED FROM C VERSCOMP.PLATES (SO IT IS STILL COMPATIBLE WITH C OLD -CONTEL- WHICH CALLS IT. C HOWEVER, THE LOGIC IS ALL REPLACED; IT NOW C CONSPIRES WITH -PROJEC- (WHICH CALLS -CONTEL-) C TO MAKE THE RIGHT COLOR APPEAR ACCORDING TO THE C CONVECTIONS OF -SCALAR-. C ALSO, THE VARIABLE NAMES ARE CONSISTENT WITH -SCALAR-, C NOT WITH -CONTEL-. C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - C I=IBELOW((FGRAY-F)/DFC+0.99) IF (LOWBLU.GE.0) THEN IHUE=I ELSE IHUE=1-I ENDIF IHUE=MAX(IHUE,0) IHUE=MIN(IHUE,NGRAY) C C CORRECT FOR FACT THAT IHUE MUST BE POSITIVE, BECAUSE C ARRAY ICOLOR IN -CONTEL- HAS NO ZERO ENTRY. IHUE=IHUE+1 C RETURN END C C C SUBROUTINE NEWPEN (IPEN) C C CONVERTS VERSATEC CALLS FROM CONTEL: CCCCC CALL NEWPEN(IPEN) CCCCC CALL NEWPEN(IPEN) CCCCC CALL NEWPEN(IPEN) CCCCC CALL NEWPEN(IPEN) C (SWITCHING TO PEN OF WIDTH IPEN WHOSE COLOR WAS ALREADY SET) C INTO DISSPLA CALLS LIKE REST OF ORBMAP. C C (NO NEED FOR ANY ACTION) RETURN END C C C SUBROUTINE PENCLR (IPEN,KOLOR) C C CONVERTS VERSATEC CALLS FROM CONTEL: CCCCC CALL PENCLR(IPEN,1) CCCCC CALL PENCLR(IPEN,KOLORP) CCCCC CALL PENCLR(IPEN,1) CCCCC CALL PENCLR(IPEN,1) C (WHICH DEFINES THE COLOR OF THE PEN WITH WIDTH IPEN AS KOLOR, C WHERE 1 = BLACK, OR MORE PROPERLY FOREGROUND, AND C WHERE 9 = WHITE, OR MORE PROPERLY BACKGROUND) C INTO DISSPLA CALLS LIKE REST OF ORBMAP. C CALL NEWCLR ('FORE') RETURN END C C C SUBROUTINE PLOT (X,Y,N) C C CONVERTS VERSATEC CALLS FROM CONTEL: CCCCC CALL PLOT(XARRAY(N1),YARRAY(N1),3) CCCCC CALL PLOT(XARRAY(N1),YARRAY(N1),3) CCCCC CALL PLOT(XARRAY(J),YARRAY(J),JPEN) C (WHICH DRAWS A LINE TO (X,Y) WITH PEN DOWN IF N = 2, UP IF N = 3) C INTO DISSPLA CALLS LIKE REST OF ORBMAP. C LOGICAL COLOR,GREAT REAL NLATD1,NLATD2 DATA OEZOPI /57.29577951/ COMMON /CHEAT/ COLOR,CUTLN1,CUTLN2 COMMON /OLDPNT/ ELOND1,NLATD1 GREAT=COLOR C (FOR COMPATIBILITY WITH -SHADE-) IF (N.EQ.3) THEN ELOND1=Y*OEZOPI NLATD1=90.-X*OEZOPI ELSE ELOND2=Y*OEZOPI NLATD2=90.-X*OEZOPI CALL NEWCLR ('FORE') CALL MYARC (INPUT,ELOND1,NLATD1,ELOND2, + NLATD2,CUTLN1,CUTLN2, + GREAT) ELOND1=ELOND2 NLATD1=NLATD2 ENDIF RETURN END C C C SUBROUTINE SETPAT (N) C C CONVERTS VERSATEC CALLS FROM CONTEL: CCCCC CALL SETPAT(N) C (WHICH SETS THE SHADING PATTERN FOR SUBSEQUENT B/W AREA-FILLS) C INTO DISSPLA CALLS LIKE REST OF ORBMAP. C CHARACTER*20 COLNAM COMMON /PATTRN/ NPAT COMMON /MYOWN/ NGRAY,ALONG,COLNAM,SPACIN DIMENSION ALONG(99),COLNAM(99),SPACIN(99) NPAT=MAX(0,MIN(N,NGRAY)) RETURN END C C C SUBROUTINE TONCLR (N) C C CONVERTS VERSATEC CALLS FROM CONTEL: CCCCC CALL TONCLR(ICOLOR(N)) C (WHICH SETS THE COLOR CODE FOR SUBSEQUENT AREA-FILLS) C INTO DISSPLA CALLS LIKE REST OF ORBMAP. C CHARACTER*20 COLNAM COMMON /PATTRN/ NPAT COMMON /MYOWN/ NGRAY,ALONG,COLNAM,SPACIN DIMENSION ALONG(99),COLNAM(99),SPACIN(99) NPAT=MAX(0,MIN(N,NGRAY)) RETURN END C C C SUBROUTINE TONE (XLIST,YLIST,NINARE,NAREAS) C C CONVERTS VERSATEC CALLS FROM CONTEL: CCCCC CALL TONE(XARRAY,YARRAY,NINARE,NAREAS) C INTO DISSPLA CALLS LIKE REST OF ORBMAP. C PARAMETER (MXAREA=10,NPOLYV=1000) CHARACTER*20 COLNAM LOGICAL COLOR DIMENSION XLIST(1),YLIST(1) C LOCAL STORAGE FOR WORK ARRAYS (WHICH UNFORTUNATELY CANNOT C BE PASSED THROUGH -CONTEL-): DIMENSION ICYCLE(NPOLYV),NINARE(MXAREA), + XARAY (NPOLYV),YARAY (NPOLYV), + XARRAY(NPOLYV),YARRAY(NPOLYV) C DIMENSION ALONG(99),COLNAM(99),SPACIN(99) DIMENSION GAPRAY(1),RATRAY(2) COMMON /MYOWN/ NGRAY,ALONG,COLNAM,SPACIN COMMON /PATTRN/ NPAT COMMON /CHEAT/ COLOR,CUTLN1,CUTLN2 MXPNTS=NPOLYV NLAST=0 DO 100 M=1,NAREAS NFIRST=NLAST+1 NLAST=NLAST+NINARE(M) DO 10 N=NFIRST,NLAST XARAY(1+N-NFIRST)=XLIST(N) YARAY(1+N-NFIRST)=YLIST(N) 10 CONTINUE IF (COLOR) THEN IF (NPAT.LE.0) RETURN ANGLE=90. CALL NEWCLR (COLNAM(NPAT)) ELSE RATRAY(1)=ALONG(NPAT) RATRAY(2)=1.000-RATRAY(1) ANGLE=MOD(NPAT+1,4)*45. GAPRAY(1)=SPACIN(NPAT) CALL NEWCLR ('FORE') ENDIF CALL TOMYSH (INPUT,ANGLE,COLOR, + CUTLN1,GAPRAY, + 1,MXPNTS,1,NINARE(M), + MODIFY,XARAY,YARAY, + WORK,ICYCLE, + XARRAY, + YARRAY) 100 CONTINUE RETURN END C C C SUBROUTINE GETNUV (INPUT,IUNITM,IUNITT,NAMES,NPBND,NPLATE, + OUTPUT,NDPLAT,PLAT,PLON) C C SETS UP ARRAYS DEFINING THE PLATES IN THE NUVEL-1A MODEL OF: C DE METS ET AL. (1994). C C (THE ROTATION VECTORS OF THE PLATES ARE CONTAINED IN DATA C STATEMENTS IN THE MAIN PROGRAM.) C C THE DIGITISED BOUNDARIES OF THE PLATES (CONTINUOUS CLOSED CURVES, C ALWAYS CIRCLING COUNTERCLOCKWISE, AND REDUNDANTLY DESCRIBING C EACH PLATE BOUNDARY TWICE- FROM EACH SIDE) C ARE READ HERE, FROM AN INPUT FILE SUCH AS 'PB1999_plates.dig', C ON FORTRAN INPUT DEVICE 'IUNIT'. C C THE CONVENTION FOR IDENTIFYING THE PLATES IS A 2-CHARACTER SYMBOL. C C------------------------------------------------------- CHARACTER*2 NAMES, SYMBOL CHARACTER*3 STARS DIMENSION NAMES (NPLATE) , NDPLAT(NPLATE) DIMENSION PLAT (NPLATE,NPBND), PLON (NPLATE,NPBND) C------------------------------------------------------ C C WRITE (IUNITT,1) IUNITM 1 FORMAT(/' Attempting to read DIGITISED PLATE', + ' OUTLINES from unit ',I2/) OPEN (UNIT = IUNITM, FILE = ' ', STATUS = 'OLD') 100 READ (IUNITM,101,END=201) SYMBOL 101 FORMAT (A2) DO 120 L=1,NPLATE IF(SYMBOL.EQ.NAMES(L)) THEN IP=L GO TO 140 ENDIF 120 CONTINUE WRITE (IUNITT,121) IUNITM 121 FORMAT (/' ERR0R: BAD PLATE NAME ON INPUT DEVICE ',I3) STOP C 140 I=0 141 READ (IUNITM,145,END=201) STARS 145 FORMAT (A3) IF (STARS.EQ.'***') THEN NDPLAT(IP)=I GO TO 100 ENDIF BACKSPACE IUNITM I=I+1 READ (IUNITM, * ) PLON(IP,I), PLAT(IP,I) PLON(IP,I)=PLON(IP,I)*0.017453293 PLAT(IP,I)=PLAT(IP,I)*0.017453293 GO TO 141 201 CONTINUE C RETURN END C C C SUBROUTINE FINDPV (INPUT, IUNITT, NDPLAT, NPBND, NPLATE, OMEGA, + PLAT, PLON, RADIUS, + XINPL, XVEL, YINPL, YVEL, + OUTPUT, VPHI, VTHETA) C C A SUBROUTINE TO FIND OUT IN WHICH PLATE (XINPL,YINPL) IS IN, C AND CALCULATE THE VELOCITY OF THE POINT (XVEL,YVEL) FROM THE C NUVEL-1A MODEL OF DEMETS ET AL., 1994. C C REQUIRES THAT NAMES AND OMEGA BE PRE-FILLED WITH NAMES AND C ROTATION VECTORS, UNDER THE CONVENTION THAT THE PACIFIC PLATE IS C FIXED. C C REQUIRES THAT -GETNUV- HAS ALREADY BEEN CALLED TO FILL IN THE C ARRAYS WITH DIGITISED PLATES BOUNDARIES. C C RETURNS VPHI (SOUTHWARD VELOCITY) AND VTHETA (EASTWARD VELOCITY) C IN A REFERENCE FRAME WHERE THE AFRICA PLATE IS FIXED. C DIMENSION PLAT (NPLATE,NPBND), PLON (NPLATE,NPBND) DIMENSION NDPLAT (NPLATE), OMEGA (3,NPLATE) C XO=COS(YINPL)*SIN(XINPL) YO=SIN(YINPL)*SIN(XINPL) ZO=COS(XINPL) OXYZ=XO*XO+YO*YO+ZO*ZO OXYZ=SQRT(OXYZ) XO=XO/OXYZ YO=YO/OXYZ ZO=ZO/OXYZ NPOINT=0 ANGLE=0.0 IPLATE=0 DO 500 I=1,NPLATE TANGL=0.0 NEND=NDPLAT(I) DO 300 J=1,NEND J2=J+1 IF(J.EQ.NEND) THEN J2=1 ENDIF A1=COS(PLON(I,J))*COS(PLAT(I,J)) A2=SIN(PLON(I,J))*COS(PLAT(I,J)) A3=SIN(PLAT(I,J)) B1=COS(PLON(I,J2))*COS(PLAT(I,J2)) B2=SIN(PLON(I,J2))*COS(PLAT(I,J2)) B3=SIN(PLAT(I,J2)) AO=XO*A1+YO*A2+ZO*A3 BO=XO*B1+YO*B2+ZO*B3 A1=A1/AO A2=A2/AO A3=A3/AO B1=B1/BO B2=B2/BO B3=B3/BO A1=A1-XO A2=A2-YO A3=A3-ZO B1=B1-XO B2=B2-YO B3=B3-ZO AA=SQRT(A1*A1+A2*A2+A3*A3) BB=SQRT(B1*B1+B2*B2+B3*B3) AB1=A2*B3-A3*B2 AB2=A3*B1-A1*B3 AB3=A1*B2-A2*B1 STHETA=(AB1*XO+AB2*YO+AB3*ZO)/(AA*BB) TANGL=TANGL+ASIN(STHETA) 300 CONTINUE DANGLE=TANGL-3.1416 310 IF(DANGLE.GE.0.0001) THEN NPOINT=NPOINT+1 IPLATE=I ENDIF 500 CONTINUE IF(NPOINT.GE.3) THEN XPOINT=90.0-XINPL*57.29577951 YPOINT=YINPL*57.29577951 WRITE(IUNITT,505) XPOINT,YPOINT 505 FORMAT(' POINT ',2F10.3,' WAS FOUND IN MORE THAN TWO PLATES' + ,' SOMETHING IS WRONG') ENDIF 510 IF(IPLATE.GT.0) THEN C CONVERT TO AFRICA-FIXED, AND RADIANS/SECOND: OMEGAX=(OMEGA(1,IPLATE)-OMEGA(1,2))*3.168809E-14 OMEGAY=(OMEGA(2,IPLATE)-OMEGA(2,2))*3.168809E-14 OMEGAZ=(OMEGA(3,IPLATE)-OMEGA(3,2))*3.168809E-14 C CONVERT TO LENGTH/SECOND: OMEGAX=OMEGAX*RADIUS OMEGAY=OMEGAY*RADIUS OMEGAZ=OMEGAZ*RADIUS C VELOCITY = OMEGA X POSITION: THETA=XVEL PHI=YVEL XN=SIN(THETA)*COS(PHI) YN=SIN(THETA)*SIN(PHI) ZN=COS(THETA) VX=OMEGAY*ZN-OMEGAZ*YN VY=OMEGAZ*XN-OMEGAX*ZN VZ=OMEGAX*YN-OMEGAY*XN C CREATE UNIT +THETA AND +PHI VECTORS IN CARTESIAN: THETAX=COS(THETA)*COS(PHI) THETAY=COS(THETA)*SIN(PHI) THETAZ= -SIN(THETA) PHIX= -SIN(PHI) PHIY=COS(PHI) PHIZ=0. C FIND ARGUMENT FROM DOT PRODUCTS: VTHETA=VX*THETAX+VY*THETAY+VZ*THETAZ VPHI=VX*PHIX+VY*PHIY+VZ*PHIZ ELSE XPOINT=90.0-XINPL*57.29577951 YPOINT=YINPL*57.29577951 WRITE(IUNITT,600) XPOINT,YPOINT 600 FORMAT('THE POINT ', 2F10.2,' DOES NOT BELONG ANY PLATE !!!!') ENDIF RETURN END C C C SUBROUTINE CHOP (INPUT,TITLE1, + OUTPUT,TITLE2) C C CREATE MODIFIED TITLE, TERMINATED BY '$' C CHARACTER*80 TITLE1 CHARACTER*81 TITLE2 TITLE2=TITLE1//' ' DO 10 I=80,1,-1 IF (TITLE2(I:I).NE.' ') THEN TITLE2(I+1:I+1)='$' RETURN ENDIF 10 CONTINUE TITLE2(1:1)='$' RETURN END C C C SUBROUTINE TURNTO (INPUT,AZIM,BASE,FAR, + OUTPUT,OMEGA,RESULT) C C COMPUTES POSITION "RESULT" (A 3-COMPONENT CARTESIAN UNIT VECTOR) C WHICH RESULTS FROM ROTATING ALONG A GREAT CIRCLE BEGINNING AT C "BASE" (ALSO A 3-COMPONENT CARTESIAN UNIT VECTOR) FOR "FAR" C RADIANS, IN THE (INITIAL) DIRECTION GIVEN BY "AZIM" (IN RADIANS, C CLOCKWISE FROM NORTH). C REAL NORTH,NPART DIMENSION BASE(3),EAST(3),NORTH(3),OMEGA(3),RESULT(3), + ROTMAT(3,3) C IF (BASE(3).EQ.1.) THEN EAST(1)=0. EAST(2)= -1. EAST(3)=0. ELSE IF (BASE(3).EQ.-1.) THEN EAST(1)=0. EAST(2)=1. EAST(3)=0. ELSE EAST(1)= -BASE(2) EAST(2)=BASE(1) EAST(3)=0. CALL UNIT (MODIFY,EAST) ENDIF CALL CROSS (INPUT,BASE,EAST, + OUTPUT,NORTH) EPART= -COS(AZIM) NPART=SIN(AZIM) OMEGA(1)=EPART*EAST(1)+NPART*NORTH(1) OMEGA(2)=EPART*EAST(2)+NPART*NORTH(2) OMEGA(3)=EPART*EAST(3)+NPART*NORTH(3) CSIZE=COS(FAR) SSIZE=SIN(FAR) COMP=1.-CSIZE ROTMAT(1,1)=CSIZE+COMP*OMEGA(1)*OMEGA(1) ROTMAT(1,2)=COMP*OMEGA(1)*OMEGA(2)-SSIZE*OMEGA(3) ROTMAT(1,3)=COMP*OMEGA(1)*OMEGA(3)+SSIZE*OMEGA(2) ROTMAT(2,1)=COMP*OMEGA(2)*OMEGA(1)+SSIZE*OMEGA(3) ROTMAT(2,2)=CSIZE+COMP*OMEGA(2)*OMEGA(2) ROTMAT(2,3)=COMP*OMEGA(2)*OMEGA(3)-SSIZE*OMEGA(1) ROTMAT(3,1)=COMP*OMEGA(3)*OMEGA(1)-SSIZE*OMEGA(2) ROTMAT(3,2)=COMP*OMEGA(3)*OMEGA(2)+SSIZE*OMEGA(1) ROTMAT(3,3)=CSIZE+COMP*OMEGA(3)*OMEGA(3) RESULT(1)=ROTMAT(1,1)*BASE(1)+ + ROTMAT(1,2)*BASE(2)+ + ROTMAT(1,3)*BASE(3) RESULT(2)=ROTMAT(2,1)*BASE(1)+ + ROTMAT(2,2)*BASE(2)+ + ROTMAT(2,3)*BASE(3) RESULT(3)=ROTMAT(3,1)*BASE(1)+ + ROTMAT(3,2)*BASE(2)+ + ROTMAT(3,3)*BASE(3) RETURN END C C C SUBROUTINE COMPAS (INPUT,BASE,RESULT, + OUTPUT,AZIM) C C COMPUTES AZIMUTH "AZIM" (IN RADIANS CLOCKWISE FROM NORTH) C OF THE GREAT CIRCLE ARC WHICH BEGINS AT "BASE" AND PASSES C THROUGH "RESULT". THE AZIMUTH IS THAT AT LOCATION "BASE". C BOTH "BASE" AND "RESULT" ARE 3-COMPONENT CARTESIAN UNIT VECTORS C RELATIVE TO THE CENTER OF A UNIT SPHERE. C REAL NORTH DIMENSION BASE(3),EAST(3),NORTH(3),OMEGA(3),RESULT(3),V(3) C CALL CROSS (INPUT,BASE,RESULT,OUTPUT,OMEGA) CALL UNIT (MODIFY,OMEGA) CALL CROSS (INPUT,OMEGA,BASE,OUTPUT,V) CALL UNIT (MODIFY,V) EAST(1)= -BASE(2) EAST(2)=BASE(1) EAST(3)=0. CALL UNIT (MODIFY,EAST) CALL CROSS (INPUT,BASE,EAST,OUTPUT,NORTH) VN=NORTH(1)*V(1)+NORTH(2)*V(2)+NORTH(3)*V(3) VE=EAST(1)*V(1)+EAST(2)*V(2)+EAST(3)*V(3) AZIM=ATAN2F(VE,VN) RETURN END C C C SUBROUTINE VEC2XY (INPUT,V,OUTPUT,X,Y) C C CONVERT CARTESIAN UNIT VECTOR V TO X (COLATITUDE) C AND Y (EAST LONGITUDE), BOTH IN RADIANS. C DIMENSION V(3) C EQUATO=SQRT((1.D0*V(1))**2+(1.D0*V(2))**2) X=ATAN2(EQUATO,V(3)) Y=ATAN2(V(2),V(1)) RETURN END C C C C----------------------------------------------------------------- C-DISSPLA2AI : BEGINNING OF DUMMY DISSPLA ROUTINES WITH AI OUTPUT C----------------------------------------------------------------- C C C SUBROUTINE ALNMES (XFRAC,YFRAC) C C 0. <= XFRAC <= 1. IS THE FRACTIONAL HORIZONTAL POSITION, AND C 0. <= YFRAC <= 1. IS THE FRACTIONAL VERTICAL POSITION C WITHIN ANY TEXT STRING WHICH ITS NOMINAL POSITION REFERS TO. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C RDI01=XFRAC RDI02=YFRAC RETURN END C C C SUBROUTINE ANGLE (ANG) C C ANG (IN DEGREES, COUNTERCLOCKWISE FROM HORIZONTAL) GIVES C THE ORIENTATION OF TEXT STRINGS PRODUCED BY: C MESSAG, RLMESS, REALNO, INTNO, RLREAL, RLINT C (BUT NOT BY STORY OR LEGEND). C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C RDI03=ANG RETURN END C C C SUBROUTINE ARC (X,Y,R,DEG1,DEG2,TEXT,THICK) C C DRAWS A PARTIAL CIRCLE AT (X,Y) INCHES FROM LOWER LEFT OF PAGE, C WITH RADIUS R AND LINE THICKNESS C THICK (BOTH OF THESE ALSO IN INCHES), C BEGINNING AT ANGLE "DEG1" AND ENDING AT "DEG2" (IN DEGREES). C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C CHARACTER*(*) TEXT CALL STROKE CALL THKCRV(THICK*72.) C X0=(X+R*COS(DEG1/57.296))*72. Y0=(Y+R*SIN(DEG1/57.296))*72. CALL MOVETO (X0,Y0) C DEG3=DEG2 IF (DEG3.LT.DEG1) DEG3=DEG3+360. IF (DEG3.LT.DEG1) DEG3=DEG3+360. I1=IABOVE((DEG1+0.1)/90.) I2=IBELOW((DEG3-0.1)/90.) D1=DEG1 DO 100 I=I1,I2 D2=90*I X3=(X+R*COS(D2/57.296))*72. Y3=(Y+R*SIN(D2/57.296))*72. SIZE=72.*R*0.5523*(D2-D1)/90. X1=X0+SIZE*COS((D1+90.)/57.296) Y1=Y0+SIZE*SIN((D1+90.)/57.296) X2=X3-SIZE*COS((D2+90.)/57.296) Y2=Y3-SIZE*SIN((D2+90.)/57.296) CALL CURVTO (X1,Y1,X2,Y2,X3,Y3) X0=X3 Y0=Y3 D1=D2 100 CONTINUE D2=DEG3 X3=(X+R*COS(D2/57.296))*72. Y3=(Y+R*SIN(D2/57.296))*72. SIZE=72.*R*0.5523*(D2-D1)/90. X1=X0+SIZE*COS((D1+90.)/57.296) Y1=Y0+SIZE*SIN((D1+90.)/57.296) X2=X3-SIZE*COS((D2+90.)/57.296) Y2=Y3-SIZE*SIN((D2+90.)/57.296) CALL CURVTO (X1,Y1,X2,Y2,X3,Y3) XC=72.*X YC=72.*Y CALL MOVETO (XC,YC) RETURN END C C C SUBROUTINE AREA2D (XWIDTH,YHEIGH) C C DEFINES A MAP AREA IN THE CENTER OF THE PAGE, WITH WIDTH C AND HEIGHT AS REQUESTED (IN INCHES). C NOTE: IN DISSPLA, THIS ROUTINE IS ALSO USED AGAIN TO DEFINE THE C SCALE-BAR AREAS, BUT THIS WILL NOT BE DONE IN -ORBMAPAI-. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C RDI11=(RDI09-72.*XWIDTH)/2. RDI12=RDI09-RDI11 RDI13=(RDI10-72.*YHEIGH)/2. RDI14=RDI10-RDI13 RETURN END C C C SUBROUTINE NEWCLR (NAME) C C SETS NAME OF NEXT DESIRED COLOR INTO COMMON BLOCK C (TO AWAIT LATER USE IF NOT SUPERCEDED). C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C CHARACTER*(*) NAME CDI00=NAME RETURN END C C C SUBROUTINE CURVE (XARAY,YARAY,NPNTS,IMARK) C C DRAW A POLYLINE WITHIN THE MAP AREA; C USING EARTH COORDINATES: X = EAST LONGITUDE, IN DEGREES; C Y = NORTH LATITUDE, IN DEGREES. C WHICH WILL NEED TO BE PROJECTED AND PLACED INTO C THE MAP WINDOW BEFORE PLOTTING. C THIS POLYLINE IS SUBJECT TO CLIPPING, BOTH C LOGICALLY FOR ENTIRELY-OUTSIDE ELEMENTS, AND BY THE C OVERLAYING OF THE FRAME. C WHEN IMARK=0, POINTS ARE CONNECTED BY LINES, BUT NO SYMBOLS SHOWN. C NOTE THAT SUBDIVISION OF EACH LINE SEGMENT INTO A SUFFICIENT C NUMBER OF BEZIER CURVES IS AUTOMATIC, TO PRODUCE A GREAT CIRCLE ARC. C WHEN IMARK=-1, POINTS ARE PLOTTED WITH SYMBOLS BUT NOT CONNECTED. C C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C LOGICAL IN1,IN2 DIMENSION XARAY(NPNTS),YARAY(NPNTS) DIMENSION BASE(3),DX(6),DY(6),OMEGA(3),TV1(3),TV2(3) DATA DX /4.16,2.08,-2.08,-4.16,-2.08,2.08/ DATA DY /0.,3.6,3.6,0.,-3.6,-3.6/ IF (IMARK.EQ.-1) THEN DO 100 I=1,NPNTS CALL MAP2XY (INPUT,XARAY(I),YARAY(I), + OUTPUT,ROTAT,XPTS,YPTS) IF ((XPTS.GE.RDI11).AND.(XPTS.LE.RDI12).AND. + (YPTS.GE.RDI13).AND.(YPTS.LE.RDI14)) THEN XP=XPTS+DX(6) YP=YPTS+DY(6) CALL MOVETO (XP,YP) DO 20 J=1,6 XP=XPTS+DX(J) YP=YPTS+DY(J) CALL LINETO (XP,YP) 20 CONTINUE ENDIF 100 CONTINUE ELSE IF ((IMARK.EQ.0).AND.(NPNTS.GE.2)) THEN CALL LL2XYZ (INPUT,XARAY(1),YARAY(1), + OUTPUT,TV1) CALL MAP2XY (INPUT,XARAY(1),YARAY(1), + OUTPUT,ROTAT1,XPT1,YPT1) IN1=(XPT1.GE.RDI11).AND.(XPT1.LE.RDI12).AND. + (YPT1.GE.RDI13).AND.(YPT1.LE.RDI14) DO 1000 I2=2,NPNTS CALL LL2XYZ (INPUT,XARAY(I2),YARAY(I2), + OUTPUT,TV2) T2=(TV1(1)-TV2(1))**2+ + (TV1(2)-TV2(2))**2+ + (TV1(3)-TV2(3))**2 IF (T2.LE.0.00762) THEN C UNDER 5 DEGREES ARC, USE STRAIGHT LINE CALL MAP2XY (INPUT,XARAY(I2),YARAY(I2), + OUTPUT,ROTAT2,XPT2,YPT2) IN2=(XPT2.GE.RDI11).AND.(XPT2.LE.RDI12).AND. + (YPT2.GE.RDI13).AND.(YPT2.LE.RDI14) IF (IN1.OR.IN2) THEN CALL MOVETO (XPT1,YPT1) CALL LINETO (XPT2,YPT2) ENDIF ELSE IF (T2.LE.0.120) THEN C UNDER 20 DEGREES, SINGLE BEZIER CURVE CALL MAP2XY (INPUT,XARAY(I2),YARAY(I2), + OUTPUT,ROTAT2,XPT2,YPT2) IN2=(XPT2.GE.RDI11).AND.(XPT2.LE.RDI12).AND. + (YPT2.GE.RDI13).AND.(YPT2.LE.RDI14) IF (IN1.OR.IN2) THEN X0=XPT1 Y0=YPT1 CALL MOVETO (X0,Y0) X3=XPT2 Y3=YPT2 R=SQRT((XPT1-XPT2)**2+(YPT1-YPT2)**2) CALL COMPAS (INPUT,TV1,TV2, + OUTPUT,AZIM1) AZIM1=AZIM1-ROTAT1 C ROTAT1 IS THE COUNTERCLOCKWISE ROTATION C (IN RADIANS) OF THE LOCAL GEOGRAPHIC C COORDINATES AT POINT 1 WITH RESPECT TO THE C PAPER COORDINATES. CALL COMPAS (INPUT,TV2,TV1, + OUTPUT,AZIM2) AZIM2=AZIM2-ROTAT2 X1=X0+0.35*R*SIN(AZIM1) Y1=Y0+0.35*R*COS(AZIM1) X2=X3+0.35*R*SIN(AZIM2) Y2=Y3+0.35*R*COS(AZIM2) CALL CURVTO (X1,Y1,X2,Y2,X3,Y3) ENDIF ELSE C DIVIDE INTO MULTIPLE 10-DEGREE BEZIER CURVES T=SQRT(T2) ARCLEN=2.*ASIN(0.5*T) NUMSEG=(ARCLEN/0.1745) CALL COMPAS (INPUT,TV1,TV2, + OUTPUT,AZIMB) BASE(1)=TV1(1) BASE(2)=TV1(2) BASE(3)=TV1(3) DO 900 K=1,NUMSEG FAR=(ARCLEN*K)/NUMSEG CALL TURNTO (INPUT,AZIMB,BASE,FAR, + OUTPUT,OMEGA,TV2) CALL XYZ2LL (INPUT,TV2, + OUTPUT,XDEG,YDEG) CALL MAP2XY (INPUT,XDEG,YDEG, + OUTPUT,ROTAT2,XPT2,YPT2) IN2=(XPT2.GE.RDI11).AND.(XPT2.LE.RDI12).AND. + (YPT2.GE.RDI13).AND.(YPT2.LE.RDI14) IF (IN1.OR.IN2) THEN X0=XPT1 Y0=YPT1 CALL MOVETO (X0,Y0) X3=XPT2 Y3=YPT2 R=SQRT((XPT1-XPT2)**2+(YPT1-YPT2)**2) CALL COMPAS (INPUT,TV1,TV2, + OUTPUT,AZIM1) AZIM1=AZIM1-ROTAT1 CALL COMPAS (INPUT,TV2,TV1, + OUTPUT,AZIM2) AZIM2=AZIM2-ROTAT2 X1=X0+0.35*R*SIN(AZIM1) Y1=Y0+0.35*R*COS(AZIM1) X2=X3+0.35*R*SIN(AZIM2) Y2=Y3+0.35*R*COS(AZIM2) CALL CURVTO (X1,Y1,X2,Y2,X3,Y3) ENDIF XPT1=XPT2 YPT1=YPT2 IN1=IN2 TV1(1)=TV2(1) TV1(2)=TV2(2) TV1(3)=TV2(3) ROTAT1=ROTAT2 900 CONTINUE ENDIF TV1(1)=TV2(1) TV1(2)=TV2(2) TV1(3)=TV2(3) XPT1=XPT2 YPT1=YPT2 IN1=IN2 ROTAT1=ROTAT2 1000 CONTINUE ENDIF RETURN END C C C SUBROUTINE DASH C C TURNS ON DASHED LINES C CALL STROKE WRITE (99,10) 10 FORMAT ('[7 5]0 d') RETURN END C C C SUBROUTINE DONEPL C C IN DISSPLA, TERMINATES PLOT METAFILE OF MANY PAGES C C HERE, HAS NO FUNCTION, BECAUSE EACH PAGE IS A SEPARATE FILE C AND THERE IS NO LARGER STRUCTURE CONTAINING ALL THE PAGES. C RETURN END C C C SUBROUTINE DOT C C TURNS ON DOTTED LINES C CALL STROKE WRITE (99,10) 10 FORMAT ('[2 4]0 d') RETURN END C C C SUBROUTINE ENDGR C C IN DISSPLA, ENDS A SUBPLOT AND PERMITS MORE WORK ON SAME PAGE C IN -ORBMAPAI-, NO SPECIAL ACTION IS NEEDED; JUST DON'T CALL C -MAP2XY- FOR PROJECTION TRANSFORMATIONS ANYMORE! C RETURN END C C C SUBROUTINE ENDPL (IZERO) C C IN DISSPLA, TERMINATES A PAGE, BUT CONTINUES METAFILE. C IN -ORBMAPAI-, C TERMINATES ADOBE ILLUSTRATOR 3 FOR WINDOWS .AI FILE. C (EACH PAGE WILL BE A SEPARATE FILE) C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C LOGICAL LAND CHARACTER*97 LINE CALL EGROUP CALL EGROUP CALL EGROUP LAND=RDI09.GT.RDI10 IF (LAND) THEN IREAD=11 ELSE IREAD=12 ENDIF 10 LINE=' '// + ' ' READ (IREAD,11,IOSTAT=IOS,END=999) LINE 11 FORMAT (A) 12 DO 20 I=97,1,-1 IF (LINE(I:I).NE.' ') THEN LAST=I GO TO 21 ENDIF 20 CONTINUE 21 WRITE (99,11) LINE(1:LAST) GO TO 10 999 CLOSE (99) REWIND (IREAD) RETURN END C C C SUBROUTINE GRID (IXGRID,IYGRID) C C GRIDS MAP AREA WITH DOTTED LATITUDE AND LONGITUDE LINES C THE NUMBER OF LINES PER "RDI16" DEGREES OF LONGITUDE IS IXGRID. C THE NUMBER OF LINES PER "RDI17" DEGREES OF LATITUDE IS IYGRID. C IF EITHER IS ZERO, THE LINES ARE OMITTED, C BUT THE TEXT LABELS WILL STILL BE INCLUDED IN THE MARGIN. C NOTE, HOWEVER, THAT TEXT LABELS ARE NOW PRODUCED BY -FIDUC-, C BECAUSE UNDER THE -ORBMAPAI- STRATEGY, PARALLELS AND MERIDIANS C ARE PLOTTED BEFORE MASKING, BUT MARGINAL LABELS MUST BE PRODUCED C AFTER MASKING. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 LOGICAL GREAT C GREAT=.TRUE. CUTLN1=-180. CUTLN2=+180. C NOTE: THESE CUTLN VALUES ARE NOT USED! C C MERIDIANS OF LONGITUDE: IF (IXGRID.GT.0) THEN CALL DOT C NOTE: BOTH OF THESE WILL CALL STROKE CALL BGROUP DEGPER=RDI16/IXGRID DO 100 THELON=0.0,359.,DEGPER X=THELON DO 90 ILAT=-7,+8 Y1=(ILAT-1)*10. Y2=ILAT*10. CALL MYARC (INPUT,X,Y1,X,Y2, + CUTLN1,CUTLN2,GREAT) 90 CONTINUE 100 CONTINUE CALL EGROUP CALL RESET ('DOT') ENDIF C C PARALLELS OF LATITUDE: C GREAT=.FALSE. C (PARALLELS ARE SMALL CIRCLES, NOT GREAT CIRCLES; C DRAW THEM IN SHORT PIECES SO INCORRECT CURVATURE WON'T SHOW) IF (IYGRID.GT.0) THEN CALL DOT C NOTE: BOTH OF THESE WILL CALL STROKE CALL BGROUP DEGPER=RDI17/IYGRID NORTH=89./DEGPER DO 200 ILAT= -NORTH, +NORTH THELAT=ILAT*DEGPER DO 190 ILON= -179,180 Y=THELAT X1=ILON-1. X2=ILON CALL MYARC (INPUT,X1,Y,X2,Y, + CUTLN1,CUTLN2,GREAT) 190 CONTINUE 200 CONTINUE CALL EGROUP CALL RESET ('DOT') ENDIF RETURN END C C C SUBROUTINE HEADIN (LHEAD,IHEAD,HTMULT,NLINES) C C PLACES UP TO 4 LINES OF HEADING AT TOP OF PLOT, ABOVE MAP, C REMEMBERING WHICH LINES ARE ALREADY FULL, AND CENTERING C THE BLOCK BOTH VERTICALLY AND HORIZONTALLY. C LHEAD = TEXT OF ONE LINE C IHEAD = NUMBER OF CHARACTERS (OR 100, IF TEXT ENDS IN $) C HTMULT = MULTIPLE OF CURRENT CHARACTER HEIGHT (TEMPORARY) C NLINES = ANTICIPATED TOTAL NUMBER OF LINES IN HEADING C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C CHARACTER*(*) LHEAD CALL STROKE CALL RESET ('HEIGHT') NOLDPT=IDI03 NEWPNT=IDI03*HTMULT+0.5 CALL HEIGHT(NEWPNT/72.) IDI05=IDI05+1 Y=RDI10-0.5*(RDI10-RDI14-NEWPNT*NLINES)-(IDI05*NEWPNT) X=RDI09/2. CALL ANGLE (0.0) CALL ALNMES (0.5,0.0) CALL MESSAG (LHEAD,IHEAD,X/72.,Y/72.) CALL HEIGHT((NOLDPT+0.01)/72.) RETURN END C C C SUBROUTINE HEIGHT (HITE) C C SETS HEIGHT OF TEXT CHARACTERS TO HITE INCHES C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C NPOINT=HITE*72.+0.5 IDI03=NPOINT RETURN END C C C SUBROUTINE HWSHD C C HAS NO EFFECT IN -ORBMAPAI- C RETURN END C C C SUBROUTINE MAPFIL (FILNAM) C C PLOT THE WORLD BASEMAP IN THE MAP WINDOW. C C NOTE: IN THIS PACKAGE, THE FILNAM IS IGNORED, AND C THE DATA IS ALWAYS READ (IN PETER BIRD'S .DIG FORMAT) C FROM FORTRAN DEVICE 13. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C C PARAMETER (LONGES=500) LOGICAL GREAT, READY REAL NLATD CHARACTER*(*) FILNAM CHARACTER*26 LINE DIMENSION ELOND(LONGES), NLATD(LONGES) DATA OEZOPI /57.29577951/ C GREAT=.TRUE. PERLON=OEZOPI*ATAN2F(VDI01(2),VDI01(1)) CUTLN1=PERLON-179.99 CUTLN2=PERLON+179.99 C CALL THKVEC (2.) CALL BGROUP NIN=0 WRITE(6,99) 99 FORMAT (/' Attempting to read DIGITISED (.DIG) BASEMAP', + ' from unit 13'/) INQUIRE (UNIT = 13, OPENED = READY) IF (.NOT.READY) OPEN (UNIT = 13, FILE = ' ', STATUS = 'OLD') 100 LINE=' ' READ (13,110,END=999,IOSTAT=IOS) LINE 110 FORMAT (A26) IF (LINE(1:3).EQ.'***') THEN C SHOULD BE AN '*** END OF LINE SEGMENT ***' LINE IF (NIN.GE.2) THEN DO 120 J=2,NIN CALL MYARC (INPUT,ELOND(J-1),NLATD(J-1), + ELOND(J),NLATD(J), + CUTLN1,CUTLN2,GREAT) 120 CONTINUE ENDIF NIN=0 ELSE IF ((LINE(1:1).EQ.' ').AND. + ((LINE(2:2).EQ.'+').OR.(LINE(2:2).EQ.'-').OR.(LINE(2:2).EQ.' ')) + .AND.((LINE(14:14).EQ.',').OR.(LINE(14:14).EQ.' ')).AND. + ((LINE(15:15).EQ.'+').OR.(LINE(15:15).EQ.'-').OR. + (LINE(15:15).EQ.' '))) THEN C LINE IS A PAIR OF NUMBERS NIN=NIN+1 READ (LINE,125) ELOND(NIN),NLATD(NIN) 125 FORMAT(1X,E12.5,1X,E12.5) IF (NIN.EQ.LONGES) THEN DO 220 J=2,NIN CALL MYARC (INPUT,ELOND(J-1),NLATD(J-1), + ELOND(J),NLATD(J), + CUTLN1,CUTLN2,GREAT) 220 CONTINUE NIN=0 ENDIF ELSE C LINE IS A TITLE; DO NOTHING NIN=0 ENDIF GO TO 100 999 CALL EGROUP CALL RESET('THKVEC') REWIND(13) RETURN END C C C SUBROUTINE MAPGR (XORIG,XSTP,XMAX,YORIG,YSTP,YMAX) C C SELECTS THE GENERAL SCALE OF THE MAP, C AND DEFINES SPACING OF LATITUDE AND LONGITUDE LABELS ON MARGIN C BUT DOES -NOT- DEFINE MAP LIMITS AS IT SEEMS TO! C C PER DISSPLA: C XORIG = EAST LONGITUDE OF LEFT SIDE OF MAP, IN DEGREES C XSTP = SPACE BETWEEN LONGITUDE MARKERS, IN DEGREES C XMAX = EAST LONGITUDE OF RIGHT SIDE OF MAP, IN DEGREES C (MUST EXCEED XORIG; OK TO USE VALUES OVER 360.) C YORIG = NORTH LATITUDE OF BOTTOM OF MAP, IN DEGREES. C (IGNORED; SEE BELOW). C YSTP = SPACE BETWEEN LATITUDE MARKERS, IN DEGREES C YMAX = NORTH LATITUDE OF TOP OF MAP, IN DEGREES C (IGNORED; SEE BELOW). C C CORRECTIONS, BY PETER BIRD: C SINCE MAP WINDOW IS ALREADY DEFINED (-AREA2D-), ONLY ONE OF THE C REQUESTED MAP DIMENSIONS CAN BE HONORED WITHOUT CAUSING C MAP DISTORTION. THE LONGITUDE LIMITS ARE USED, AND THE C LATITUDE LIMITS ARE IGNORED! C THE CENTER OF THE MAP MUST ALWAYS BE THE POSTION CHOSEN C WITH SUBPROGRAM -MAPOLE-, ALSO TO PREVENT DISTORTION. C THUS, THE ONLY INFORMATION ACTUALLY USED FROM THE ABOVE C PARAMETERS IS THE DIFFERENCE XMAX-XORIG = DEGWID, C AND THE INFORMATION ON LABEL SPACING. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C REAL LEFT,LLOND,LLATD DIMENSION LEFT(3),OMEGA(3),RIGHT(3) T=XMAX IF (T.LE.XORIG) T=T+360. IF (T.LE.XORIG) T=T+360. DEGWID=T-XORIG CALL TURNTO (INPUT,+1.5708,VDI01,0.5*DEGWID/57.298, + OUTPUT,OMEGA,RIGHT) CALL TURNTO (INPUT,-1.5708,VDI01,0.5*DEGWID/57.298, + OUTPUT,OMEGA,LEFT) CALL XYZ2LL (INPUT,RIGHT, + OUTPUT,RLOND,RLATD) CALL XYZ2LL (INPUT,LEFT, + OUTPUT,LLOND,LLATD) RDI15=1000. CALL MAP2XY (INPUT,RLOND,RLATD, + OUTPUT,ROTAT,XR,YR) CALL MAP2XY (INPUT,LLOND,LLATD, + OUTPUT,ROTAT,XL,YL) RDI15=1000.*(RDI12-RDI11)/(XR-XL) RDI16=ABS(XSTP) RDI17=ABS(YSTP) RETURN END C C C SUBROUTINE MAPOLE (XPOLE,YPOLE) C C SETS POINT OF TANGENCY (ALSO CENTER OF MAP) AT LOCATION: C XPOLE = EAST LONGITUDE, IN DEGREES C YPOLE = NORTH LATITUDE, IN DEGREES. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C CALL LL2XYZ (INPUT,XPOLE,YPOLE, + OUTPUT,VDI01) CALL UNIT (MODIFY,VDI01) CALL LL2XYZ (INPUT,XPOLE,YPOLE+90., + OUTPUT,VDI03) CALL UNIT (MODIFY,VDI03) CALL CROSS (INPUT,VDI03,VDI01,OUTPUT,VDI02) VDI02(3)=0.0 CALL UNIT (MODIFY,VDI02) RETURN END C C C SUBROUTINE MARKER (ITYPE) C C DEFINES THE SYMBOL USED BY CURVE IN ITS POINT-PLOTTING MODE C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C IDI01=ITYPE RETURN END C C C SUBROUTINE MESSAG (LMESS,IMESS,XPOS,YPOS) C C PLOTS A CHARACTER STRING "LMESS" OF LENGTH "IMESS" C AT NOMINAL POSITION (XPOS,YPOS); BOTH IN INCHES FROM C THE PAGE ORIGIN AT THE LOWER LEFT CORNER. C C THE INTERPRETATION OF (XPOS,YPOS) DEPENDS ON THE MOST C RECENT CALLS TO -ANGLE- AND -ALNMES-. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 COMMON LDA,MD,ABUT C CHARACTER*(*) LMESS EQUIVALENCE (XP2,XP3), (YP2,YP3) C CALL STROKE CALL CHGCLR (CDI00) C IF (IMESS.LE.0) RETURN C IF (XPOS.EQ.ABUT) THEN CALL ALNMES (0.,0.) XPOINT=RDI18 ELSE XPOINT=72.*XPOS ENDIF IF (YPOS.EQ.ABUT) THEN CALL ALNMES (0.,0.) YPOINT=RDI19 ELSE YPOINT=72.*YPOS ENDIF IF (RDI02.NE.0) THEN XPOINT=XPOINT+RDI02*IDI03*SIN(RDI03/57.298) YPOINT=YPOINT-RDI02*IDI03*COS(RDI03/57.298) ENDIF COSA=COS(RDI03/57.298) SINA=SIN(RDI03/57.298) OPP= -SINA WRITE (99,10) COSA,SINA,OPP,COSA,XPOINT,YPOINT 10 FORMAT ('0 To' + /4F7.3,2F8.1,' 0 Tp' + /'TP') RDI06=0. IF (RDI01.LT.0.25) THEN IALIGN=0 ELSE IF (RDI01.LT.0.75) THEN IALIGN=1 ELSE IALIGN=2 ENDIF WRITE (99,20) IALIGN 20 FORMAT (I1,' Ta' + /'0 Tr' + /'0 O' + /'0 g' + /'1 w') DO 25 I=2,IMESS IF (LMESS(I:I).EQ.'$') THEN NMESS=I-1 GO TO 26 ENDIF 25 CONTINUE NMESS=IMESS 26 CONTINUE WRITE (99,30) IDI03, + LMESS(1:NMESS) 30 FORMAT ('/_Helvetica ',i4,' Tf' + /'(',A,') Tx' + /'(\r) TX' + /'TO') RDI18=XPOINT+0.60*NMESS*(1.-RDI01)*IDI03*COS(RDI03/57.298) RDI19=YPOINT+0.60*NMESS*(1.-RDI01)*IDI03*SIN(RDI03/57.298) C C WARN -SHADE- THAT IT NEEDS TO RESET THE GRAY SCALE IDI04= -1 RETURN END C C C SUBROUTINE CHGCLR (NAME) C C SENDS CURRENT DESIRED COLOR (CDI00) TO OUTPUT FILE C CHARACTER*(*) NAME C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C INTEGER C,M,Y,K IF (CDI01.EQ.NAME(1:4)) RETURN CDI01=NAME(1:4) CALL STROKE IF (NAME(1:4).EQ.'FORE') THEN C - - - BLACK - - - - - WRITE (99,10) 10 FORMAT ('0 g' + /'0 G') IDI04= -1 ELSE IF (NAME(1:4).EQ.'GRAY') THEN C - - - GRAY - - - - WRITE (99,15) 15 FORMAT ('0.7 g' + /'0.7 G') IDI04= -2 ELSE IF (NAME(1:4).EQ.'BACK') THEN C - - - WHITE - - - - WRITE (99,20) 20 FORMAT ('1 g' + /'1 G') IDI04=0 ELSE C NOTE: FOLLOWING IS DEFAULT (BLACK) C= 0 M= 0 Y= 0 K=100 IDI04= -1 IF (NAME(1:4).EQ.'GHBL') THEN C=100 M= 0 Y= 0 K= 25 IDI04= -1 ELSE IF (NAME(1:4).EQ.'BLUE') THEN C=100 M= 0 Y= 0 K= 25 IDI04= -1 ELSE IF (NAME(1:3).EQ.'SKY') THEN NAME(4:4)=' ' C=85 M= 0 Y= 0 K= 0 IDI04= -1 ELSE IF (NAME(1:4).EQ.'CYAN') THEN C=85 M= 0 Y= 0 K= 0 IDI04= -1 ELSE IF (NAME(1:4).EQ.'GRBL') THEN C=40 M= 0 Y= 0 K= 0 IDI04= -1 ELSE IF (NAME(1:4).EQ.'KELL') THEN C=100 M= 10 Y=100 K= 0 IDI04= -1 ELSE IF (NAME(1:4).EQ.'GREE') THEN C=100 M= 10 Y=100 K= 0 IDI04= -1 ELSE IF (NAME(1:4).EQ.'GRYE') THEN C=50 M= 0 Y=90 K= 0 IDI04= -1 ELSE IF (NAME(1:4).EQ.'YELL') THEN C= 0 M= 0 Y=100 K= 0 IDI04= -1 ELSE IF (NAME(1:4).EQ.'KHAK') THEN C=20 M=55 Y=60 K= 0 IDI04= -1 ELSE IF (NAME(1:3).EQ.'RED') THEN NAME(4:4)=' ' C= 0 M=100 Y= 60 K= 0 IDI04= -1 ELSE IF (NAME(1:4).EQ.'MAGE') THEN C=10 M=35 Y= 0 K= 0 IDI04= -1 ENDIF RC=0.01*C RM=0.01*M RY=0.01*Y RK=0.01*K WRITE (99,30) RC,RM,RY,RK 30 FORMAT (4F5.2,' k') C 'k' is to set the fill color WRITE (99,31) RC,RM,RY,RK 31 FORMAT (4F5.2,' K') C 'K' is to set the stroke color ENDIF RETURN END C C C SUBROUTINE PAGE (PAGEX,PAGEY) C C IN DISSPLA, C SETS WIDTH AND HEIGHT OF PAPER C (ARGUMENTS IN INCHES; STORED VALUES IN POINTS) C IN -ORBMAPAI-, C ALSO FULFILLS FUNCTION OF BEGINNING NEW PLOT, C SINCE EACH PAGE WILL BE A SEPARATE FILE. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C C ---------------- NEW-FILE FUNCTIONS ------------------------ C LOGICAL LAND CHARACTER*97 LANFIL, LINE, PORFIL SAVE LANFIL, PORFIL DATA LANFIL/'LanModel.ai'/, PORFIL/'PorModel.ai'/ C LAND=PAGEX.GT.PAGEY IF (LAND) THEN IREAD=11 WRITE (6,1) TRIM(LANFIL),IREAD 1 FORMAT (/' Attempting to read MODEL .AI FILE IN LANDSCAPE'/ + ' FORMAT (',A,') from unit ',I2/) OPEN (UNIT = IREAD, FILE = LANFIL, STATUS = 'OLD', + IOSTAT = IOS) IF (IOS.NE.0) THEN WRITE (*,2) TRIM(LANFIL) 2 FORMAT(/' ERR0R: ',A,' not found;' + /' Enter correct [drive:][\path\]filename:') READ (*,"(A)") LANFIL CLOSE (UNIT = IREAD, IOSTAT = IOS) OPEN (UNIT = IREAD, FILE = LANFIL, + STATUS = 'OLD', IOSTAT = IOS) IF (IOS.NE.0) THEN WRITE(*,"(/' ERR0R: This file not found either')") STOP 'Not able to continue.' END IF END IF ELSE IREAD=12 WRITE (6,3) TRIM(PORFIL),IREAD 3 FORMAT (/' Attempting to read MODEL .AI FILE IN PORTRAIT'/ + ' FORMAT (',A,') from unit ',I2/) OPEN (UNIT = IREAD, FILE = PORFIL, STATUS = 'OLD', + IOSTAT = IOS) IF (IOS.NE.0) THEN WRITE (*,4) TRIM(PORFIL) 4 FORMAT(/' ERR0R: ',A,' not found;' + /' Enter correct [drive:][\path\]filename:') READ (*,"(A)") PORFIL CLOSE (UNIT = IREAD, IOSTAT = IOS) OPEN (UNIT = IREAD, FILE = LANFIL, + STATUS = 'OLD', IOSTAT = IOS) IF (IOS.NE.0) THEN WRITE(*,"(/' ERR0R: This file not found either')") STOP 'Not able to continue.' END IF END IF END IF C TRIAL READ, TO FORCE FILENAME QUERY ON INTERACTIVE SYSTEMS: READ (IREAD,'(A)',IOSTAT=IOS) LINE BACKSPACE (IREAD) C WRITE (6,9) 9 FORMAT (/' Attempting to create NEW OUTPUT (.AI) FILE', + ' WITH GRAPHICS on unit 99'/) OPEN (UNIT = 99, FILE = ' ') C C SUPPRESS END-OF-RECORD ERR0R: C CALL ERRSET (212,999,-1,1) C 10 LINE=' '// + ' ' READ (IREAD,11,ERR=12) LINE 11 FORMAT (A) 12 DO 20 I=97,1,-1 IF (LINE(I:I).NE.' ') THEN LAST=I GO TO 21 ENDIF 20 CONTINUE LAST=0 21 IF (LINE(1:13).EQ.'%%PageTrailer') THEN BACKSPACE IREAD ELSE IF (LAST.GE.1) WRITE (99,11) LINE(1:LAST) GO TO 10 ENDIF C C ---------------- PAGE-DEFINING FUNCTION -------------------- C RDI09=PAGEX*72. RDI10=PAGEY*72. RETURN END C C C SUBROUTINE PROJCT (TYPE) C C SETS MAP PROJECTION MODE (IF ANY) C CHARACTER*(*) TYPE C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C CDI02=TYPE(1:16) RETURN END C C C SUBROUTINE REALNO (ANUM,IPLACE,XPOS,YPOS) C C PLOTS A REAL NUMBER AT A NOMINAL POSITION IN INCHES FROM C THE LOWER LEFT CORNER OF THE PAGE. C ANUM IS THE REAL NUMBER. C IPLACE MAY BE: >=0: IPLACE DECIMAL PLACES AFTER POINT C : >100: IPLACE-100 TOTAL DIGITS C : <0: EXPONENTIAL FORM, -IPLACE DIGITS C AFTER THE DECIMAL POINT C (EXCEPT THAT 'E+00' WILL BE STRIPPED OFF) C EITHER XPOS OR YPOS MAY BE 'ABUT' TO APPEND TO OTHER TEXT. C COMMON LDA,MD,ABUT CHARACTER*20 LMESS,TMESS IF ((IPLACE.GE.0).AND.(IPLACE.LE.100)) THEN WRITE (TMESS,10) ANUM 10 FORMAT(F20.9) DO 20 I=1,20 IF (TMESS(I:I).NE.' ') THEN I1=I GO TO 21 ENDIF 20 CONTINUE 21 CONTINUE I2=11+MIN(IPLACE,9) IMESS=I2-I1+1 LMESS(1:IMESS)=TMESS(I1:I2) ELSE IF (IPLACE.GT.100) THEN WRITE (TMESS,10) ANUM DO 120 I=1,20 IF (TMESS(I:I).NE.' ') THEN I1=I GO TO 121 ENDIF 120 CONTINUE 121 CONTINUE IMESS=IPLACE-100 I2=I1+IMESS-1 LMESS(1:IMESS)=TMESS(I1:I2) ELSE C (IPLACE < 0) WRITE (TMESS,210) ANUM 210 FORMAT (1P,E20.13) I1= -IPLACE+3 LMESS(1:I1)=TMESS(1:I1) LMESS(I1+1:I1+4)=TMESS(17:20) IMESS=I1+4 IF (LMESS(IMESS-1:IMESS).EQ.'00') THEN IMESS=IMESS-4 ENDIF ENDIF CALL MESSAG (LMESS,IMESS,XPOS,YPOS) C RETURN END C C C SUBROUTINE RESET (NAME) C C RETURNS "STATE" OR "MEMORY" OF DISSPLA TO DEFAULT: C (EXCEPT PAGE SIZE, WHICH MUST BE SET FIRST) C C CDI00 = 4-BYTE NAME OF NEXT COLOR TO GO TO OUTPUT FILE C CDI01 = 4-BYTE NAME OF LAST COLOR SENT TO OUTPUT FILE C CDI02 = 16-BYTE NAME OF CURRENT MAP PROJECTION (OR "NONE") C IDI01 = ID OF SYMBOL USED TO PLOT POINTS (ONLY 1 = HEXAGON DONE) C IDI02 = NUMBER OF GRAPHICS GROUPS CURRENTLY OPEN C IDI03 = HEIGHT OF TEXT, IN POINTS C IDI04 = NUMBER OF B/W PATTERN WHICH IS CURRENT (1-9, 9 DARKEST), C OR 0 FOR PURE WHITE, OR -1 FOR BLACK, OR -2 FOR 30% GRAY. C IDI05 = NUMBER OF HEADING LINES ALREADY WRITTEN ON THIS PLOT C LDI01 = (NOT CURRENTLY IN USE) C LDI02 = T IF A PATH IS OPEN, AND NEEDS TO BE ENDED BY -STROKE- C RDI01 = XFRAC FOR NOMINAL POSITION OF CERTAIN TEXT STRINGS C RDI02 = YFRAC FOR NOMINAL POSITION OF CERTAIN TEXT STRINGS C RDI03 = ANG FOR CERTAIN TEXT STRINGS (DEGREES CCW FROM HORIONTAL) C RDI04 = PEN WIDTH IN POINTS FOR ALL CURVES C RDI05 = PEN WIDTH IN POINTS FOR ALL VECTORS C RDI06 = MOST RECENT PEN WITH, IN POINTS C RDI07 = LAST PLOTTED (PROJECTED) X COORDINATE, IN POINTS C RDI08 = LAST PLOTTED (PROJECTED) Y COORDINATE, IN POINTS C (NOTE: THESE TWO ARE ALSO USED TO ABUT TEXT STRINGS) C RDI09 = WIDTH OF PAGE (IN POINTS) C RDI10 = HEIGHT OF PAGE (IN POINTS) C RDI11 = MINIMUM X (IN POINTS) OF MAP WINDOW C RDI12 = MAXIMUM X (IN POINTS) OF MAP WINDOW C RDI13 = MINIMUM Y (IN POINTS) OF MAP WINDOW C RDI14 = MAXIMUM Y (IN POINTS) OF MAP WINDOW C RDI15 = SCALE FACTOR FOR MAP, IN POINTS PER RADIAN, AT MAP POLE C RDI16 = SPACING OF LONGITUDE LABELS, IN DEGREES C RDI17 = SPACING OF LATITUDE LABELS, IN DEGREES C RDI18 = X (POINTS) AT END OF LAST TEXT STRING C RDI19 = Y (POINTS) AT END OF LAST TEXT STRING C VDI01 = CARTESIAN UNIT VECTOR FOR MAP POLE C VDI02 = CARTESIAN UNIT VECTOR POINTING EAST FROM MAP POLE C VDI03 = CARTESIAN UNIT VECTOR POINTING NORTH FROM MAP POLE C CHARACTER*(*) NAME C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C IF (NAME.EQ.'ALL') THEN CALL EGROUP CDI01=' ' CALL NEWCLR ('FORE') LDI01=.FALSE. LDI02=.FALSE. CDI02='NONE ' IDI01=1 IDI02=0 IDI03=11 IDI04= -1 IDI05=0 RDI01=0. RDI02=0. RDI03=0. RDI04=1. RDI05=1. RDI06=-1. RDI07=-1. RDI08=-1. RDI11=0. RDI12=0. RDI13=0. RDI14=0. RDI15=6.5*72./(2.*3.14159) RDI16=10. RDI17=10. VDI01(1)=1. VDI01(2)=0. VDI01(3)=0. VDI02(1)=0. VDI02(2)=1. VDI02(3)=0. VDI03(1)=0. VDI03(2)=0. VDI03(3)=1. WRITE (99,10) 10 FORMAT ('[]0 d') ELSE IF (NAME.EQ.'ALNMES') THEN RDI01=0. RDI02=0. ELSE IF (NAME.EQ.'ANGLE' ) THEN RDI03=0. ELSE IF (NAME.EQ.'DASH' ) THEN CALL STROKE WRITE (99,10) ELSE IF (NAME.EQ.'DOT' ) THEN CALL STROKE WRITE (99,10) ELSE IF (NAME.EQ.'HEIGHT') THEN IDI03=11 ELSE IF (NAME.EQ.'MAPOLE') THEN VDI01(1)=1. VDI01(2)=0. VDI01(3)=0. ELSE IF (NAME.EQ.'NEWCLR') THEN CALL NEWCLR ('FORE') ELSE IF (NAME.EQ.'PAGE') THEN WRITE (6,99) 99 FORMAT (/' ERR0R: CALL RESET(PAGE) IS ILLEGAL,' + /' BECAUSE PAGE MUST BE SET FIRST AND NOT CHANGED.' + /' TO MAKE MULTIPLE PLOTS, THE CORRECT WAY IS:' + /' CALL PAGE (WIDTH,HEIGHT)' + /' CALL RESET (ALL) <- ADVISABLE' + /' -- CREATE THE MAP ----------' + /' CALL FRAME' + /' -- DECORATE THE MARGINS ----' + /' CALL ENDGR' + /' AND REPEAT AS NEEDED FOR MORE PAGES.') STOP ELSE IF (NAME.EQ.'PROJCT') THEN CDI02='NONE ' ELSE IF (NAME.EQ.'THKCRV') THEN RDI04=1. RDI05=1. ELSE IF (NAME.EQ.'THKVEC') THEN RDI04=1. RDI05=1. ENDIF RETURN END C C C SUBROUTINE RLMESS (LMESS,IMESS,XVAL,YVAL) C C PLOTS A CHARACTER STRING "LMESS" OF LENGTH "IMESS" C AT NOMINAL POSITION (XVAL,YVAL) = (EAST-LONGITUDE, NORTH-LATITUDE) C IN DEGREES (ON THE MAP). C C THE INTERPRETATION OF (XVAL,YVAL) DEPENDS ON THE MOST C RECENT CALLS TO -ANGLE- AND -ALNMES-. C C NOTE THAT RDI03 (-ANGLE-) IS HERE INTERPRETED AS THE DESIRED TEXT C ANGLE WITH RESPECT TO PARALLELS OF LATITUDE, NOT WITH C RESPECT TO THE PAGE AXES. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C CHARACTER*(*) LMESS LOGICAL IN COMMON LDA,MD,ABUT IF ((XVAL.NE.ABUT).AND.(YVAL.NE.ABUT)) THEN CALL MAP2XY (INPUT,XVAL,YVAL, + OUTPUT,ROTAT,XPOS,YPOS) IF (CDI02(1:4).EQ.'NONE') THEN IN=.TRUE. ELSE IN=(XPOS.GE.RDI11).AND.(XPOS.LE.RDI12).AND. + (YPOS.GE.RDI13).AND.(YPOS.LE.RDI14) ENDIF IF (IN) THEN SAVANG=RDI03 RDI03=RDI03+57.298*ROTAT CALL MESSAG (LMESS,IMESS,XPOS/72.,YPOS/72.) RDI03=SAVANG ENDIF ELSE CALL MESSAG (LMESS,IMESS,XVAL,YVAL) ENDIF RETURN END C C C SUBROUTINE RLREAL (ANUM,IPLACE,XVAL,YVAL) C C PLOTS A REAL NUMBER ON THE MAP C C ANUM IS THE REAL NUMBER. C IPLACE MAY BE: 102: C : 103: C XVAL MAY BE EAST-LONGITUDE IN DEGREES OR X IN INCHES C YVAL MAY BE NORTH-LATITUDE IN DEGREES OR Y IN INCHES C (IF PROJECTION IS CURRENTLY 'NONE', USE INCHES FROM C THE LOWER-LEFT CORNER OF THE PAGE). C C EITHER XVAL OR YVAL MAY BE 'ABUT' TO APPEND TO OTHER TEXT. C CHARACTER*20 LMESS COMMON LDA,MD,ABUT IF (ANUM.EQ.0.) THEN LMESS='0' IMESS=1 ELSE IF ((ABS(ANUM).GE.0.1).AND.(ABS(ANUM).LT.999.)) THEN WRITE (LMESS,10) ANUM 10 FORMAT (F8.3) IMESS=8 DO 11 I=8,6,-1 IF (LMESS(I:I).EQ.'0') THEN IMESS=IMESS-1 ELSE GO TO 12 ENDIF 11 CONTINUE 12 CONTINUE IF (IMESS.EQ.5) IMESS=4 IF (LMESS(1:1).EQ.' ') THEN LMESS=LMESS(2:8)//' ' IMESS=IMESS-1 ENDIF IF (LMESS(1:1).EQ.' ') THEN LMESS=LMESS(2:8)//' ' IMESS=IMESS-1 ENDIF IF (LMESS(1:1).EQ.' ') THEN LMESS=LMESS(2:8)//' ' IMESS=IMESS-1 ENDIF ELSE WRITE (LMESS,20) ANUM 20 FORMAT (1P,E9.2) IMESS=9 IF (LMESS(8:8).EQ.'0') THEN LMESS(8:8)=LMESS(9:9) IMESS=8 ENDIF IF (LMESS(5:5).EQ.'0') THEN LMESS(5:9)=LMESS(6:9)//' ' IMESS=IMESS-1 IF (LMESS(4:4).EQ.'0') THEN LMESS(3:9)=LMESS(5:9)//' ' IMESS=IMESS-2 ENDIF ENDIF IF (LMESS(1:1).EQ.' ') THEN LMESS=LMESS(2:9)//' ' IMESS=IMESS-1 ENDIF ENDIF CALL RLMESS (LMESS,IMESS,XVAL,YVAL) RETURN END C C C SUBROUTINE RLVEC (XFROM,YFROM,XTO,YTO,IVEC) C C DRAW A STRAIGHT LINE (NOT AN ARC OF A GREAT CIRCLE) C ON THE MAP, BETWEEN SPECIFIED ENDPOINTS: C XFROM AND XTO IN DEGREES OF EAST-LONGITUDE (OR INCHES) C YFROM AND YTO IN DEGREES OF NORTH-LATITUDE (OR INCHES) C NOTE THAT ARROWHEADS ARE NOT IMPLEMENTED YET. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C LOGICAL ANYIN,IN1,IN2 CALL MAP2XY (INPUT,XFROM,YFROM, + OUTPUT,ROTAT,X1,Y1) CALL MAP2XY (INPUT,XTO,YTO, + OUTPUT,ROTAT,X2,Y2) IF (CDI02(1:4).EQ.'NONE') THEN ANYIN=.TRUE. ELSE IN1=(X1.GE.RDI11).AND.(X1.LE.RDI12).AND. + (Y1.GE.RDI13).AND.(Y1.LE.RDI14) IN2=(X2.GE.RDI11).AND.(X2.LE.RDI12).AND. + (Y2.GE.RDI13).AND.(Y2.LE.RDI14) ANYIN=IN1.OR.IN2 ENDIF IF (ANYIN) THEN CALL MOVETO (X1,Y1) CALL LINETO (X2,Y2) ENDIF RETURN END C C C SUBROUTINE SETDEV C C HAS NO FUNCTION UNDER -ORBMAPAI- C SINCE THIS PROGRAM DOES NOT PRODUCE VOLUMINOUS MESSAGES. C RETURN END C C C SUBROUTINE SHADE (XARAY,YARAY,NPNTS,ANGLE,GAPRAY,NGAPS,K,L) C C IN DISSPLA, C FILLS THE AREA WITHIN A POLYGON WITH ANGLED PARALLEL C HATCHING. C IN -ORBMAP- AND -ORBMAPAI-, THIS ROUTINE IS ONLY CALLED C WHEN IN B/W MODE, BECAUSE IT DOES NOT CANNOT PRODUCE C SMOOTH SOLID COLOR, BUT IT CAN PRODUCE COARSE-GRAINED C CROSS-HATCHING SUITABLE FOR B/W REPRODUCTION AND XEROXING. C IN -ORBMAPAI-, THE SHADING LINES ARE NOT SPECIFIED INDIVIDUALLY; C RATHER A PREDEFINED SHADING PATTERN IS USED. C THE PATTERN IS CHOSEN TO (ROUGHLY) MATCH THE SHADING C DENSITY IMPLIED BY THE LINE SPACING REQUESTED. C A SPECIAL -ORBMAPAI- CONVENTION IS THAT A NEGATIVE LINE C SPACING CALLS FOR SOLID BLACK SHADING. C XARAY = EAST LONGITUDE IN DEGREES, OR X IN INCHES C YARAY = NORTH LATITUDE IN DEGREES, OR Y IN INCHES C NPNTS = NUMBER OF POINTS IN POLYLINE C ANGLE = SHADING ANGLE (NOT USED) C GAPRAY = ARRAY OF SHADING LINE SEPARATIONS IN INCHES C (USED TO DECIDE WHICH PATTERN IS WANTED; C NOTE THAT GREY PATTERNS ARE NUMBERED 1 - 9 AND C BECOME DARKER WITH INCREASING NUMBER.) C NGAPS = NUMBER OF ELEMENTS IN GAPRAY (SHOULD BE 1) C K, L = DUMMY ARGUMENTS (NOT USED) C SPECIAL NOTES: C IN DISSPLA, -SHADE- BOUNDS ITS AREAS WITH STRAIGHT LINES C ON THE MAP (NOT ARCS OF GREAT CIRCLES). THIS IS PROBABLY C A BUG, BUT FOR COMPATIBILITY, WE DO THE SAME IN -ORBMAPAI-. C THUS, IF IT IS DESIRED TO OVERLAY CONTOURS ON THE SHADING, C USE -RLVEC-, INSTEAD OF -CURVE- C THE WHITE BACKGROUND OF ALL THESE SHADES IS OPAQUE. C PARAMETER (MAXPNT=100) C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C LOGICAL ANYIN,IN DIMENSION XARAY(NPNTS),YARAY(NPNTS),GAPRAY(NGAPS) DIMENSION XSAVE(MAXPNT),YSAVE(MAXPNT) C IF (NPNTS.LT.3) RETURN ANYIN=.FALSE. DO 1 I=1,NPNTS CALL MAP2XY (INPUT,XARAY(I),YARAY(I), + OUTPUT,ROTAT,X,Y) XSAVE(I)=X YSAVE(I)=Y IF (CDI02(1:4).EQ.'NONE') THEN IN=.TRUE. ELSE IN=(X.GE.RDI11).AND.(X.LE.RDI12).AND. + (Y.GE.RDI13).AND.(Y.LE.RDI14) ENDIF ANYIN=ANYIN.OR.IN 1 CONTINUE IF (.NOT.ANYIN) RETURN CALL STROKE IF (GAPRAY(1).LT.0.) THEN C SPECIAL -ORBMAPAI- CONVENTION, REQUESTS SOLID BLACK IGREY= -1 ELSE IF (GAPRAY(1).GT.0.1025) THEN C NO SHADING AT ALL IGREY=0 ELSE IF (ABS(GAPRAY(1)-0.100).LE.0.0025) THEN C LIGHTEST SHADING IGREY=1 ELSE IF (ABS(GAPRAY(1)-0.095).LE.0.0025) THEN IGREY=2 ELSE IF (ABS(GAPRAY(1)-0.090).LE.0.0025) THEN IGREY=3 ELSE IF (ABS(GAPRAY(1)-0.080).LE.0.005) THEN IGREY=4 ELSE IF (ABS(GAPRAY(1)-0.070).LE.0.005) THEN IGREY=5 ELSE IF (ABS(GAPRAY(1)-0.060).LE.0.005) THEN IGREY=6 ELSE IF (ABS(GAPRAY(1)-0.050).LE.0.005) THEN IGREY=7 ELSE IF (ABS(GAPRAY(1)-0.040).LE.0.005) THEN IGREY=8 ELSE C DARKEST PRACTICAL SHADING (NOT ALL-BLACK) IGREY=9 ENDIF C IF (IGREY.LT.0) THEN IF (IDI04.NE.IGREY) CALL NEWCLR ('FORE') ELSE IF (IGREY.EQ.0) THEN IF (IDI04.NE.0) CALL NEWCLR ('BACK') ELSE IF (IDI04.NE.IGREY) WRITE (99,20) IGREY 20 FORMAT ('(Gray',I1,') 0 0 1 1 0 0 0 0 0 [1 0 0 1 0 0]p') ENDIF IDI04=IGREY C C KLUDGE: PREVENT -MOVETO- FROM CHANGING COLOR: CDI00=CDI01 C CALL MOVETO (XSAVE(1),YSAVE(1)) NSHOW=MIN(NPNTS,MAXPNT) DO 100 I=2,NSHOW CALL LINETO (XSAVE(I),YSAVE(I)) 100 CONTINUE LDI02=.FALSE. WRITE (99,110) 110 FORMAT ('f') RETURN END C C C SUBROUTINE SHDCHR C C NOT NECESSARY, .AI TEXT IS FILLED WITH BLACK BY DEFAULT C RETURN END C C C SUBROUTINE SHDCRV (XARAY,YARAY,NPTS,XARAY2,YARAY2,NPTS2) C C IN DISSPLA, C SHADES AN AREA ON THE MAP WHICH LIES BETWEEN TWO CURVES C (IF NPTS2 > 0) OR WITHIN ONE POLYGON (IF NPTS2 = 0). C XARAY = EAST LONGITUDE IN DEGREES (OR X IN INCHES) C YARAY = NORTH LATITUDE IN DEGREES (OR Y IN INCHES) C NPTS = NUMBER OF POINTS IN CURVE 1 C XARAY2 = X-COORDINATE OF SECOND CURVE C ( NOT USED IN -ORBMAP- AND -ORBMAPAI-) C YARAY2 = Y-COORDINATE OF SECOND CURVE C ( NOT USED IN -ORBMAP- AND -ORBMAPAI-) C NPTS2 = NUMBER OF POINTS IN SECOND CURVE C ( = 0 IN -ORBMAP- AND -ORBMAPAI-). C NOTE THAT BOUNDARY LINES (UNSTROKED) ARE ARCS OF GREAT CIRCLES C ON THE MAP, SO FOR COMPATIBILITY, USE -CURVE- IF YOU C WISH TO STROKE THE CONTOUR LINES. C C ALSO NOTE THAT IN -ORBMAP- AND -ORBMAPAI-, THIS ROUTINE C WILL ONLY BE CALLED IN COLOR MODE, NOT IN B/W. C (FOR B/W SHADING OF AREAS, SEE -SHADE-.) C C THERE IS NO CODE HERE FOR SETTING THE FILL COLOR; C THAT SHOULD HAVE BEEN HANDLED PREVIOUSLY BY -NEWCLR-. C PARAMETER (MAXPNT=100) C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C LOGICAL ANYIN,IN DIMENSION XARAY(NPTS),YARAY(NPTS),XARAY2(NPTS2),YARAY2(NPTS2) DIMENSION BASE(3),OMEGA(3),TV1(3),TV2(3) DIMENSION XSAVE(MAXPNT),YSAVE(MAXPNT),ROSAVE(MAXPNT) C IF (NPTS.LT.3) RETURN ANYIN=.FALSE. DO 1 I=1,NPTS CALL MAP2XY (INPUT,XARAY(I),YARAY(I), + OUTPUT,ROTAT,X,Y) ROSAVE(I)=ROTAT XSAVE(I)=X YSAVE(I)=Y IF (CDI02(1:4).EQ.'NONE') THEN IN=.TRUE. ELSE IN=(X.GE.RDI11).AND.(X.LE.RDI12).AND. + (Y.GE.RDI13).AND.(Y.LE.RDI14) ENDIF ANYIN=ANYIN.OR.IN 1 CONTINUE IF (.NOT.ANYIN) RETURN C CALL STROKE CALL LL2XYZ (INPUT,XARAY(1),YARAY(1), + OUTPUT,TV1) ROTAT1=ROSAVE(1) XPT1=XSAVE(1) YPT1=YSAVE(1) CALL MOVETO (XPT1,YPT1) DO 1000 I2=2,NPTS CALL LL2XYZ (INPUT,XARAY(I2),YARAY(I2), + OUTPUT,TV2) T2=(TV1(1)-TV2(1))**2+ + (TV1(2)-TV2(2))**2+ + (TV1(3)-TV2(3))**2 IF ((CDI02(1:4).EQ.'NONE').OR.(T2.LE.0.00762)) THEN C IF NO MAP PROJECTION IS IN USE, OR IF LENGTH IS C UNDER 5 DEGREES ARC, USE STRAIGHT LINE XPT2=XSAVE(I2) YPT2=YSAVE(I2) ROTAT2=ROSAVE(I2) CALL LINETO (XPT2,YPT2) ELSE IF (T2.LE.0.120) THEN C UNDER 20 DEGREES, SINGLE BEZIER CURVE X0=XPT1 Y0=YPT1 XPT2=XSAVE(I2) YPT2=YSAVE(I2) ROTAT2=ROSAVE(I2) X3=XPT2 Y3=YPT2 R=SQRT((XPT1-XPT2)**2+(YPT1-YPT2)**2) CALL COMPAS (INPUT,TV1,TV2, + OUTPUT,AZIM1) AZIM1=AZIM1-ROTAT1 C ROTAT1 IS THE COUNTERCLOCKWISE ROTATION C (IN RADIANS) OF THE LOCAL GEOGRAPHIC C COORDINATES AT POINT 1 WITH RESPECT TO THE C PAPER COORDINATES. CALL COMPAS (INPUT,TV2,TV1, + OUTPUT,AZIM2) AZIM2=AZIM2-ROTAT2 X1=X0+0.35*R*SIN(AZIM1) Y1=Y0+0.35*R*COS(AZIM1) X2=X3+0.35*R*SIN(AZIM2) Y2=Y3+0.35*R*COS(AZIM2) CALL CURVTO (X1,Y1,X2,Y2,X3,Y3) ELSE C DIVIDE INTO MULTIPLE 10-DEGREE BEZIER CURVES T=SQRT(T2) ARCLEN=2.*ASIN(0.5*T) NUMSEG=(ARCLEN/0.1745) CALL COMPAS (INPUT,TV1,TV2, + OUTPUT,AZIMB) BASE(1)=TV1(1) BASE(2)=TV1(2) BASE(3)=TV1(3) DO 900 K=1,NUMSEG FAR=(ARCLEN*K)/NUMSEG CALL TURNTO (INPUT,AZIMB,BASE,FAR, + OUTPUT,OMEGA,TV2) CALL XYZ2LL (INPUT,TV2, + OUTPUT,XDEG,YDEG) CALL MAP2XY (INPUT,XDEG,YDEG, + OUTPUT,ROTAT2,XPT2,YPT2) X0=XPT1 Y0=YPT1 X3=XPT2 Y3=YPT2 R=SQRT((XPT1-XPT2)**2+(YPT1-YPT2)**2) CALL COMPAS (INPUT,TV1,TV2, + OUTPUT,AZIM1) AZIM1=AZIM1-ROTAT1 CALL COMPAS (INPUT,TV2,TV1, + OUTPUT,AZIM2) AZIM2=AZIM2-ROTAT2 X1=X0+0.35*R*SIN(AZIM1) Y1=Y0+0.35*R*COS(AZIM1) X2=X3+0.35*R*SIN(AZIM2) Y2=Y3+0.35*R*COS(AZIM2) CALL CURVTO (X1,Y1,X2,Y2,X3,Y3) XPT1=XPT2 YPT1=YPT2 TV1(1)=TV2(1) TV1(2)=TV2(2) TV1(3)=TV2(3) ROTAT1=ROTAT2 900 CONTINUE ENDIF TV1(1)=TV2(1) TV1(2)=TV2(2) TV1(3)=TV2(3) XPT1=XPT2 YPT1=YPT2 ROTAT1=ROTAT2 1000 CONTINUE LDI02=.FALSE. WRITE (99,1110) 1110 FORMAT ('f') RETURN END C C C SUBROUTINE SHDPAT C C IN DISSPLA, SETS SHADING PATTERN; BUT C HAS NO FUNCTION IN -ORBMAPAI- C RETURN END C C C SUBROUTINE SWISSL C C HAS NO EFFECT; ALL TEXT IN THESE PLOTS WILL BE HELVETICA C ANYWAY. C RETURN END C C C SUBROUTINE THKCRV (POINTS) C C SET CURRENT PEN WIDTH, IN POINTS C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C RDI04=POINTS RDI05=POINTS RETURN END C C C SUBROUTINE THKVEC (POINTS) C C SET CURRENT PEN WIDTH, IN POINTS (USE REAL VARIABLE) C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C RDI04=POINTS RDI05=POINTS RETURN END C C C SUBROUTINE VECTOR (XFROM,YFROM,XTO,YTO,IVEC) C C DRAW A STRAIGHT LINE C ON THE PAGE, BETWEEN SPECIFIED ENDPOINTS: C XFROM AND XTO IN INCHES C YFROM AND YTO IN INCHES C NOTE THAT ARROWHEADS ARE NOT FULLY IMPLEMENTED YET, BUT C 0 = NO ARROWHEAD C 1121 = SIMPLE, 30-DEGREE, OPEN ARROWHEAD OF PROPORTIONAL SIZE C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C CALL RESET ('NEWCLR') CALL RESET ('THKVEC') IF (IVEC.EQ.1121) CALL BGROUP X1=XFROM*72. Y1=YFROM*72. CALL MOVETO (X1,Y1) X2=XTO*72. Y2=YTO*72. CALL LINETO (X2,Y2) IF (IVEC.EQ.1121) THEN ANGLE=ATAN2F((Y2-Y1),(X2-X1)) ANGLEF=ANGLE+2.618 ANGRIG=ANGLE-2.618 DR=0.20*SQRT((X2-X1)**2+(Y2-Y1)**2) XT=X2+DR*COS(ANGLEF) YT=Y2+DR*SIN(ANGLEF) CALL MOVETO (XT,YT) CALL LINETO (X2,Y2) XT=X2+DR*COS(ANGRIG) YT=Y2+DR*SIN(ANGRIG) CALL LINETO (XT,YT) CALL EGROUP ENDIF RETURN END C C C SUBROUTINE XNAME (LXNAME,IXNAME) C C LABELS X-AXIS OF MAP WITH TEXT (BELOW THE FIDUCIAL NUMBERS) C LXNAME IS THE TEXT STRING C IXNAME IS >= THE NUMBER OF CHARACTERS C (IF GREATER, TEXT STRING SHOULD END WITH $) C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C CHARACTER*(*) LXNAME CALL ANGLE (0.0) CALL ALNMES (0.5,0.0) X=RDI09/2. Y=RDI13-2.*IDI03 CALL MESSAG (LXNAME,IXNAME,X/72.,Y/72.) RETURN END C C C SUBROUTINE YNAME (LYNAME,IYNAME) C C LABELS Y-AXIS OF MAP WITH TEXT (LEFT OF THE FIDUCIAL NUMBERS) C LYNAME IS THE TEXT STRING C IYNAME IS >= THE NUMBER OF CHARACTERS C (IF GREATER, TEXT STRING SHOULD END WITH $) C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C CHARACTER*(*) LYNAME CALL ANGLE (90.) CALL ALNMES (0.5,0.0) X=RDI11-1.5*IDI03 Y=(RDI13+RDI14)/2. CALL MESSAG (LYNAME,IYNAME,X/72.,Y/72.) CALL RESET ('ANGLE') RETURN END C C C SUBROUTINE BGROUP C C BEGINS A NEW GRAPHICS GROUP IN THE AI OUTPUT FILE C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C CALL STROKE WRITE (99,20) 20 FORMAT ('u') IDI02=IDI02+1 RETURN END C C C SUBROUTINE EGROUP C C ENDS A GRAPHICS GROUP IN THE AI OUTPUT FILE C (IF ONE OR MORE GROUP(S) IS/ARE ALREADY OPEN) C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C CALL STROKE IF (IDI02.GE.1) THEN WRITE (99,10) 10 FORMAT ('U') RDI07=-1. RDI08=-1. ENDIF IDI02=MAX(0,IDI02-1) RETURN END C C C SUBROUTINE LL2XYZ (INPUT,LONDEG,LATDEG, + OUTPUT,VECTOR) C C CONVERTS POSITION (LONDEG = EAST LONGITUDE, C LATDEG = NORTH LATITUDE) C WHERE BOTH ARE IN DEGREES, C TO A CARTESIAN UNIT VECTOR IN A SYSTEM WITH C X POINTING FROM EARTH CENTER TO ( 0 E, 0 N); C Y POINTING FROM EARTH CENTER TO (90 E, 0 N); C Z POINTING FROM EARTH CENTER TO (?? E, 90 N). C REAL LONDEG,LATDEG DIMENSION VECTOR(3) DATA PIO180 /0.0174533/ RADLON=LONDEG*PIO180 RADLAT=LATDEG*PIO180 VECTOR(1)=COS(RADLAT)*COS(RADLON) VECTOR(2)=COS(RADLAT)*SIN(RADLON) VECTOR(3)=SIN(RADLAT) RETURN END C C C SUBROUTINE XYZ2LL (INPUT,VECTOR, + OUTPUT,LONDEG,LATDEG) C C CONVERTS A CARTESIAN UNIT VECTOR IN A SYSTEM WITH C X POINTING FROM EARTH CENTER TO ( 0 E, 0 N); C Y POINTING FROM EARTH CENTER TO (90 E, 0 N); C Z POINTING FROM EARTH CENTER TO (?? E, 90 N). C TO A MAP POSITION (LONDEG = EAST LONGITUDE, C LATDEG = NORTH LATITUDE) C WHERE BOTH ARE IN DEGREES, C REAL LONDEG,LATDEG DIMENSION VECTOR(3) DATA OEZOPI /57.2958/ EQUAT=SQRT((1.D0*VECTOR(1))**2+(1.D0*VECTOR(2))**2) YLAT=ATAN2F(VECTOR(3),EQUAT) XLON=ATAN2F(VECTOR(2),VECTOR(1)) LONDEG=XLON*OEZOPI LATDEG=YLAT*OEZOPI RETURN END C C C SUBROUTINE MAP2XY (INPUT,DEGLON,DEGLAT, + OUTPUT,ROTAT,X,Y) C C CONVERTS FROM (EAST LONGITUDE, NORTH LATITUDE) IN DEGREES C TO (X,Y) IN POINTS, RELATIVE TO THE LOWER LEFT CORNER OF THE C CURRENT PAGE. C TO COMPUTE (X,Y), TAKES ACCOUNT OF CURRENT MAP PROJECTION, C CURRENT MAP AREA, AND VIEWPOINT INFORMATION FROM COMMON BLOCK. C ROTAT IS THE COUNTERCLOCKWISE ROTATION C (IN RADIANS) OF THE LOCAL GEOGRAPHIC C COORDINATES WITH RESPECT TO THE PAPER COORDINATES. C IF THE CURRENT PROJECTION IS "NONE", THEN DEGLON AND DEGLAT C ARE INTERPRETED AS INCHES IN THE PAGE COORDINATES, AND C SIMPLY CONVERTED TO POINTS. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C DIMENSION TV(3),VECTOR(3) IF (CDI02(1:4).EQ.'NONE') THEN ROTAT=0. X=72.*DEGLON Y=72.*DEGLAT ELSE IF (CDI02(1:8).EQ.'MERCATOR') THEN CALL LL2XYZ (INPUT,DEGLON,DEGLAT, + OUTPUT,VECTOR) DP=VECTOR(1)*VDI01(1)+VECTOR(2)*VDI01(2)+VECTOR(3)*VDI01(3) DE=VECTOR(1)*VDI02(1)+VECTOR(2)*VDI02(2)+VECTOR(3)*VDI02(3) DN=VECTOR(1)*VDI03(1)+VECTOR(2)*VDI03(2)+VECTOR(3)*VDI03(3) HORIZ=ATAN2F(DE,DP) X=RDI15*HORIZ+0.5*(RDI11+RDI12) RELLAT=ASIN(DN) VERTI=ALOG(TAN(ABS(RELLAT)*0.5+0.785398)) IF (DN.LT.0.) VERTI= -VERTI Y=RDI15*VERTI+0.5*(RDI13+RDI14) IF (ABS(VDI01(3)).LE.0.01) THEN ROTAT=0. ELSE CALL LL2XYZ (INPUT,DEGLON+1.0,DEGLAT, + OUTPUT,VECTOR) DP=VECTOR(1)*VDI01(1)+VECTOR(2)*VDI01(2)+ + VECTOR(3)*VDI01(3) DE=VECTOR(1)*VDI02(1)+VECTOR(2)*VDI02(2)+ + VECTOR(3)*VDI02(3) DN=VECTOR(1)*VDI03(1)+VECTOR(2)*VDI03(2)+ + VECTOR(3)*VDI03(3) HORIZ=ATAN2F(DE,DP) XP=RDI15*HORIZ+0.5*(RDI11+RDI12) RELLAT=ASIN(DN) VERTI=ALOG(TAN(ABS(RELLAT)*0.5+0.785398)) IF (DN.LT.0.) VERTI= -VERTI YP=RDI15*VERTI+0.5*(RDI13+RDI14) ROTAT=ATAN2F(YP-Y,XP-X) ENDIF ELSE IF (CDI02(1:13).EQ.'STEREOGRAPHIC') THEN CALL LL2XYZ (INPUT,DEGLON,DEGLAT, + OUTPUT,VECTOR) TV(1)=VECTOR(1)+VDI01(1) C TEMPVEC = VECTOR - (-POLE) TV(2)=VECTOR(2)+VDI01(2) TV(3)=VECTOR(3)+VDI01(3) DP=TV(1)*VDI01(1)+TV(2)*VDI01(2)+TV(3)*VDI01(3) FACTOR=2.0/DP TV(1)=TV(1)*FACTOR TV(2)=TV(2)*FACTOR TV(3)=TV(3)*FACTOR DE=TV(1)*VDI02(1)+TV(2)*VDI02(2)+TV(3)*VDI02(3) DN=TV(1)*VDI03(1)+TV(2)*VDI03(2)+TV(3)*VDI03(3) X=DE*RDI15+0.5*(RDI11+RDI12) Y=DN*RDI15+0.5*(RDI13+RDI14) CALL LL2XYZ (INPUT,DEGLON+1.0,DEGLAT, + OUTPUT,VECTOR) TV(1)=VECTOR(1)+VDI01(1) TV(2)=VECTOR(2)+VDI01(2) TV(3)=VECTOR(3)+VDI01(3) DP=TV(1)*VDI01(1)+TV(2)*VDI01(2)+TV(3)*VDI01(3) FACTOR=2.0/DP TV(1)=TV(1)*FACTOR TV(2)=TV(2)*FACTOR TV(3)=TV(3)*FACTOR DE=TV(1)*VDI02(1)+TV(2)*VDI02(2)+TV(3)*VDI02(3) DN=TV(1)*VDI03(1)+TV(2)*VDI03(2)+TV(3)*VDI03(3) XP=DE*RDI15+0.5*(RDI11+RDI12) YP=DN*RDI15+0.5*(RDI13+RDI14) ROTAT=ATAN2F(YP-Y,XP-X) ELSE WRITE (6,1010) CDI02 1010 FORMAT (/' ERR0R: UNKNOWN MAP PROJECTION: ',A16 + /' REQUESTED FROM SUBPROGRAM -MAP2XY-.') STOP ENDIF RETURN END C C C SUBROUTINE XY2MAP (INPUT,X,Y, + OUTPUT,DEGLON,DEGLAT) C C OPPOSITE IN FUNCTION TO -MAP2XY-. C CONVERTS FROM (X,Y) IN POINTS, RELATIVE TO THE LOWER LEFT C CORNER OF THE CURRENT PAGE, C TO (EAST LONGITUDE, NORTH LATITUDE) IN DEGREES C TAKING ACCOUNT OF CURRENT MAP PROJECTION, C CURRENT MAP AREA, AND VIEWPOINT INFORMATION FROM COMMON BLOCK. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C DIMENSION TU(3),TV(3),VECTOR(3) IF (CDI02(1:4).EQ.'NONE') THEN DEGLON=X/72. DEGLAT=Y/72. ELSE IF (CDI02(1:8).EQ.'MERCATOR') THEN VERTI=(Y-0.5*(RDI13+RDI14))/RDI15 RELLAT=2.0*(ATAN(EXP(ABS(VERTI)))-0.785398) IF (VERTI.LT.0.) RELLAT= -RELLAT DN=SIN(RELLAT) EQUAT=COS(RELLAT) HORIZ=(X-0.5*(RDI11+RDI12))/RDI15 DP=EQUAT*COS(HORIZ) DE=EQUAT*SIN(HORIZ) VECTOR(1)=DP*VDI01(1)+DE*VDI02(1)+DN*VDI03(1) VECTOR(2)=DP*VDI01(2)+DE*VDI02(2)+DN*VDI03(2) VECTOR(3)=DP*VDI01(3)+DE*VDI02(3)+DN*VDI03(3) CALL XYZ2LL (INPUT,VECTOR, + OUTPUT,DEGLON,DEGLAT) ELSE IF (CDI02(1:13).EQ.'STEREOGRAPHIC') THEN DE=(X-0.5*(RDI11+RDI12))/RDI15 DN=(Y-0.5*(RDI13+RDI14))/RDI15 DP=2.0 TV(1)=DP*VDI01(1)+DE*VDI02(1)+DN*VDI03(1) TV(2)=DP*VDI01(2)+DE*VDI02(2)+DN*VDI03(2) TV(3)=DP*VDI01(3)+DE*VDI02(3)+DN*VDI03(3) C TV POINTS FROM FAR SIDE OF EARTH TO MAP PLANE TU(1)=TV(1) TU(2)=TV(2) TU(3)=TV(3) CALL UNIT (MODIFY,TU) DOT=TU(1)*VDI01(1)+TU(2)*VDI01(2)+TU(3)*VDI01(3) ARC=2.0*ACOS(DOT) FACTOR=(1.+COS(ARC))/2. TV(1)=TV(1)*FACTOR TV(2)=TV(2)*FACTOR TV(3)=TV(3)*FACTOR C TV POINTS FROM FAR SIDE OF EARTH TO SURFACE POINT VECTOR(1)=TV(1)-VDI01(1) VECTOR(2)=TV(2)-VDI01(2) VECTOR(3)=TV(3)-VDI01(3) CALL XYZ2LL (INPUT,VECTOR, + OUTPUT,DEGLON,DEGLAT) ELSE WRITE (6,1010) CDI02 1010 FORMAT (/' ERR0R: UNKNOWN MAP PROJECTION: ',A16 + /' REQUESTED FROM SUBPROGRAM -XY2MAP-.') STOP ENDIF RETURN END C C C SUBROUTINE FRAME (DOGRID) C C COMPLETES MAP WITH GRID OF PARALLELS AND MERIDIANS, IF DOGRID. C C BLANKS-OUT EVERYTHING OUTSIDE THE MAP AREA, WHICH SHOULD C TIDILY TRUNCATE ALL PARALLELS, MERIDIANS, COASTLINES, ETC. C C THIS ROUTINE DOES NOT EXIST IN DISSPLA, BUT WAS ADDED C TO TAKE ADVANTAGE OF THE MASKING AVAILABLE IN POSTSCRIPT C C SINCE MAP IS PRESUMED COMPLETE AT MASKING TIME, THIS ROUTINE C ALSO SHIFTS TO THE COORDINATE SYSTEM IN INCHES FROM LOWER C LEFT OF PAGE. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C LOGICAL DOGRID C JUST TO BE SURE: CALL EGROUP CALL EGROUP CALL EGROUP C C ADD DOTTED-LINE GRID OF MERIDIANS AND PARALLELS? IF (DOGRID) THEN CALL DOT CALL GRID (1,1) CALL RESET ('DOT') ENDIF C CALL STROKE CALL NEWCLR ('BACK') C C GROUP OF WHITE RECTANGLES SHOULD BE LOCKED AGAINST C ACCIDENTAL SELECTION AND MOVEMENT DURING EDITING: WRITE (99,10) 10 FORMAT ('1 A') CALL BGROUP C C TOP: X1=0. X2=RDI09 Y1=RDI14 Y2=RDI10 CALL MOVETO (X1,Y1) CALL LINETO (X2,Y1) CALL LINETO (X2,Y2) CALL LINETO (X1,Y2) CALL LINETO (X1,Y1) LDI02=.FALSE. WRITE (99,120) 120 FORMAT ('f') C C BOTTOM: X1=0. X2=RDI09 Y1=0. Y2=RDI13 CALL MOVETO (X1,Y1) CALL LINETO (X2,Y1) CALL LINETO (X2,Y2) CALL LINETO (X1,Y2) CALL LINETO (X1,Y1) LDI02=.FALSE. WRITE (99,120) C C LEFT: X1=0. X2=RDI11 Y1=0. Y2=RDI10 CALL MOVETO (X1,Y1) CALL LINETO (X2,Y1) CALL LINETO (X2,Y2) CALL LINETO (X1,Y2) CALL LINETO (X1,Y1) LDI02=.FALSE. WRITE (99,120) C C RIGHT: X1=RDI12 X2=RDI09 Y1=0. Y2=RDI10 CALL MOVETO (X1,Y1) CALL LINETO (X2,Y1) CALL LINETO (X2,Y2) CALL LINETO (X1,Y2) CALL LINETO (X1,Y1) LDI02=.FALSE. WRITE (99,120) C CALL EGROUP C AND, UNLOCK WRITE (99,150) 150 FORMAT ('0 A') C C BOX: CALL NEWCLR ('FORE') CALL THKVEC (3.) X1=RDI11 X2=RDI12 Y1=RDI13 Y2=RDI14 CALL MOVETO (X1,Y1) CALL LINETO (X2,Y1) CALL LINETO (X2,Y2) CALL LINETO (X1,Y2) CALL LINETO (X1,Y1) CALL STROKE C C ADD LATITUDE AND LONGITUDE LABELS: CALL FIDUC C C RESET COORDINATE SYSTEM C CALL RESET ('PROJCT') RETURN END C C C SUBROUTINE FIDUC C C ADDS LATITUDE AND LONGITUDE NUMBERS OUTSIDE FRAME OF MAP C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C PARAMETER (MAXCNT=100) CHARACTER*6 THELAT CHARACTER*7 THELON DIMENSION TEMP(2,MAXCNT) C CALL STROKE CALL RESET ('NEWCLR') CALL RESET ('HEIGHT') CALL ALNMES (0.5,0.0) C C LEFT AND RIGHT SIDES: C CALL ANGLE (90.) CALL THKVEC (2.) C CALL BGROUP C NCOUNT=0 DY=10. DO 100 YLOW=RDI13-DY,RDI14,DY YHIGH=YLOW+DY CALL XY2MAP (INPUT,RDI11,YLOW, + OUTPUT,DLON1,DLAT1) CALL XY2MAP (INPUT,RDI11,YHIGH, + OUTPUT,DLON2,DLAT2) NCON1=IBELOW(DLAT1/RDI17) NCON2=IBELOW(DLAT2/RDI17) IF (NCON2.NE.NCON1) THEN NCOUNT=NCOUNT+1 Z=MAX(NCON1,NCON2)*RDI17 TEMP(1,NCOUNT)=Z IF (DLAT2.NE.DLAT1) THEN FRAC=(Z-DLAT1)/(DLAT2-DLAT1) ELSE FRAC=0.5 ENDIF Y=YLOW+DY*FRAC TEMP(2,NCOUNT)=Y ROTLON=DLON1+(DLON2-DLON1)*FRAC CALL MAP2XY (INPUT,ROTLON,Z, + OUTPUT,ROTAT,XT,YT) EX=12.*COS(ROTAT) EY=12.*SIN(ROTAT) IF (EX.LT.0.) THEN EX= -EX EY= -EY ENDIF CALL MOVETO (RDI11,Y) CALL LINETO (RDI11+EX,Y+EY) CALL MOVETO (RDI12,Y) CALL LINETO (RDI12-EX,Y+EY) IF (NCOUNT.EQ.MAXCNT) GO TO 101 ENDIF 100 CONTINUE C CALL EGROUP CALL BGROUP C 101 YFULL=0. DO 190 I=1,NCOUNT Z=TEMP(1,I) Y=TEMP(2,I) WRITE (THELAT,110) Z 110 FORMAT (F6.2) NCHAR=6 IF (THELAT(6:6).EQ.'0') THEN NCHAR=5 IF (THELAT(5:5).EQ.'0') THEN NCHAR=3 ENDIF ENDIF IF (THELAT(1:1).EQ.' ') THEN NCHAR=NCHAR-1 THELAT=THELAT(2:6)//' ' ENDIF IF (THELAT(1:1).EQ.' ') THEN NCHAR=NCHAR-1 THELAT=THELAT(2:6)//' ' ENDIF YBOT=Y-IDI03*NCHAR*0.3 IF (YBOT.GE.YFULL) THEN CALL MESSAG (THELAT,NCHAR,(RDI11-IDI03/2.)/72.,Y/72.) YFULL=Y+IDI03*NCHAR*0.3 ENDIF 190 CONTINUE C CALL EGROUP C C BOTTOM: C CALL ANGLE (0.) CALL THKVEC (2.) C CALL BGROUP C NCOUNT=0 DX=10. DO 200 XLOW=RDI11-DX,RDI12,DX XHIGH=XLOW+DX CALL XY2MAP (INPUT,XLOW,RDI13, + OUTPUT,DLON1,DLAT1) CALL XY2MAP (INPUT,XHIGH,RDI13, + OUTPUT,DLON2,DLAT2) NCON1=IBELOW(DLON1/RDI16) NCON2=IBELOW(DLON2/RDI16) IF (NCON2.NE.NCON1) THEN NCOUNT=NCOUNT+1 IF ((ABS(NCON1-NCON2)*RDI16).GT.180.) THEN Z=180. TEMP(1,NCOUNT)=Z FRAC=0.5 ELSE Z=MAX(NCON1,NCON2)*RDI16 TEMP(1,NCOUNT)=Z IF (DLON2.NE.DLON1) THEN FRAC=(Z-DLON1)/(DLON2-DLON1) ELSE FRAC=0.5 ENDIF ENDIF X=XLOW+DX*FRAC TEMP(2,NCOUNT)=X ROTLAT=DLAT1+FRAC*(DLAT2-DLAT1) CALL MAP2XY (INPUT,Z,ROTLAT, + OUTPUT,ROTAT,XT,YT) EX= -12.*SIN(ROTAT) EY=12.*COS(ROTAT) IF (EY.LT.0.) THEN EX= -EX EY= -EY ENDIF CALL MOVETO (X,RDI13) CALL LINETO (X+EX,RDI13+EY) IF (NCOUNT.EQ.MAXCNT) GO TO 201 ENDIF 200 CONTINUE C CALL EGROUP CALL BGROUP C 201 XFULL=0. DO 290 I=1,NCOUNT Z=TEMP(1,I) X=TEMP(2,I) WRITE (THELON,210) Z 210 FORMAT (F7.2) NCHAR=7 IF (THELON(7:7).EQ.'0') THEN NCHAR=6 IF (THELON(6:6).EQ.'0') THEN NCHAR=4 ENDIF ENDIF IF (THELON(1:1).EQ.' ') THEN NCHAR=NCHAR-1 THELON=THELON(2:7)//' ' ENDIF IF (THELON(1:1).EQ.' ') THEN NCHAR=NCHAR-1 THELON=THELON(2:7)//' ' ENDIF IF (THELON(1:1).EQ.' ') THEN NCHAR=NCHAR-1 THELON=THELON(2:7)//' ' ENDIF XLEFT=X-IDI03*NCHAR*0.3 IF (XLEFT.GE.XFULL) THEN CALL MESSAG (THELON,NCHAR,X/72.,(RDI13-IDI03)/72.) XFULL=X+IDI03*NCHAR*0.3 ENDIF 290 CONTINUE C CALL EGROUP C C TOP: C CALL ANGLE (0.) CALL THKVEC (2.) C CALL BGROUP C NCOUNT=0 DX=10. DO 300 XLOW=RDI11-DX,RDI12,DX XHIGH=XLOW+DX CALL XY2MAP (INPUT,XLOW,RDI14, + OUTPUT,DLON1,DLAT1) CALL XY2MAP (INPUT,XHIGH,RDI14, + OUTPUT,DLON2,DLAT2) NCON1=IBELOW(DLON1/RDI16) NCON2=IBELOW(DLON2/RDI16) IF (NCON2.NE.NCON1) THEN NCOUNT=NCOUNT+1 IF ((ABS(NCON1-NCON2)*RDI16).GT.180.) THEN Z=180. TEMP(1,NCOUNT)=Z FRAC=0.5 ELSE Z=MAX(NCON1,NCON2)*RDI16 TEMP(1,NCOUNT)=Z IF (DLON1.NE.DLON2) THEN FRAC=(Z-DLON1)/(DLON2-DLON1) ELSE FRAC=0.5 ENDIF ENDIF X=XLOW+DX*FRAC TEMP(2,NCOUNT)=X ROTLAT=DLAT1+(DLAT2-DLAT1)*FRAC CALL MAP2XY (INPUT,Z,ROTLAT, + OUTPUT,ROTAT,XT,YT) EX=12.*SIN(ROTAT) EY= -12.*COS(ROTAT) IF (EY.GT.0.) THEN EX= -EX EY= -EY ENDIF CALL MOVETO (X,RDI14) CALL LINETO (X+EX,RDI14+EY) IF (NCOUNT.EQ.MAXCNT) GO TO 301 ENDIF 300 CONTINUE C CALL EGROUP CALL BGROUP C 301 XFULL=0. DO 390 I=1,NCOUNT Z=TEMP(1,I) X=TEMP(2,I) WRITE (THELON,310) Z 310 FORMAT (F7.2) NCHAR=7 IF (THELON(7:7).EQ.'0') THEN NCHAR=6 IF (THELON(6:6).EQ.'0') THEN NCHAR=4 ENDIF ENDIF IF (THELON(1:1).EQ.' ') THEN NCHAR=NCHAR-1 THELON=THELON(2:7)//' ' ENDIF IF (THELON(1:1).EQ.' ') THEN NCHAR=NCHAR-1 THELON=THELON(2:7)//' ' ENDIF IF (THELON(1:1).EQ.' ') THEN NCHAR=NCHAR-1 THELON=THELON(2:7)//' ' ENDIF XLEFT=X-IDI03*NCHAR*0.3 IF (XLEFT.GE.XFULL) THEN CALL MESSAG (THELON,NCHAR,X/72.,(RDI14+IDI03/2.)/72.) XFULL=X+IDI03*NCHAR*0.3 ENDIF 390 CONTINUE C CALL EGROUP C C LABEL THE X AXIS CALL XNAME ('LONGITUDE',9) C C LABEL THE Y AXIS CALL YNAME ('LATITUDE',8) RETURN END C C C SUBROUTINE STROKE C C CLOSES AN OPEN PATH BY STROKING IT, IF NEEDED. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C IF (LDI02) THEN WRITE (99,10) 10 FORMAT ('S') LDI02=.FALSE. ENDIF RETURN END C C C SUBROUTINE MOVETO (X,Y) C C BEGINS A NEW PATH IF ONE IS TRULY NEEDED, OTHERWISE NOT. C X AND Y ARE IN POINTS FROM LOWER LEFT OF PAGE. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C LOGICAL NEWCOL,NEWPEN,NEWXY,NOPATH NEWCOL=CDI00.NE.CDI01 NOPATH=.NOT.LDI02 NEWPEN=(RDI05.NE.RDI06) R2=(X-RDI07)**2+(Y-RDI08)**2 NEWXY=(R2.GT.0.01) IF (NOPATH.OR.NEWCOL.OR.NEWPEN.OR.NEWXY) THEN CALL STROKE IF (NEWCOL) CALL CHGCLR (CDI00) IF (NEWPEN) THEN WRITE (99,10) RDI05 10 FORMAT (F4.1,' w') RDI06=RDI05 ENDIF WRITE (99,20) X,Y 20 FORMAT (F7.1,F8.1,' m') RDI07=X RDI08=Y LDI02=.TRUE. ENDIF RETURN END C C C SUBROUTINE LINETO (X,Y) C C DRAWS A STRAIGHT LINE TO (X,Y), BUT LEAVES IT UNSTROKED. C X AND Y ARE IN POINTS FROM LOWER LEFT OF PAGE. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C LOGICAL NOPATH NOPATH=.NOT.LDI02 C THIS SECTION IS JUST TO PREVENT CRASHES; SHOULD NOT BE NEEDED. IF (NOPATH) THEN XT=RDI07 YT=RDI08 CALL MOVETO (XT,YT) ELSE C IF ((X.NE.RDI07).OR.(Y.NE.RDI08)) THEN WRITE (99,10) X,Y 10 FORMAT (F7.1,F8.1,' l') RDI07=X RDI08=Y LDI02=.TRUE. ENDIF ENDIF RETURN END C C C SUBROUTINE CURVTO (X1,Y1,X2,Y2,X3,Y3) C C DRAWS A BEZIER CURVE FROM CURRENT POSITION, C BUT LEAVES IT UNSTROKED. C XI AND YI ARE IN POINTS FROM LOWER LEFT OF PAGE. C CHARACTER*4 CDI00,CDI01 CHARACTER*16 CDI02 LOGICAL LDI01,LDI02 DIMENSION VDI01(3),VDI02(3),VDI03(3) COMMON /FAKEDI/ + CDI00,CDI01,CDI02, + IDI01,IDI02,IDI03,IDI04,IDI05, + LDI01,LDI02, + RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16,RDI17, + RDI18,RDI19, + VDI01,VDI02,VDI03 C LOGICAL NOPATH NOPATH=.NOT.LDI02 C THIS SECTION IS JUST TO PREVENT CRASHES; SHOULD NOT BE NEEDED. IF (NOPATH) THEN XT=RDI07 YT=RDI08 CALL MOVETO (XT,YT) ELSE IF ((X3.NE.RDI07).OR.(Y3.NE.RDI08)) THEN WRITE (99,10) X1,Y1,X2,Y2,X3,Y3 10 FORMAT (F7.1,5F8.1,' c') RDI07=X3 RDI08=Y3 LDI02=.TRUE. ENDIF ENDIF 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 C Note: This is a special OrbMapAI version, which uses only C the values at M=1 (almost same answer, anyway!) SUBROUTINE IP2NOD(INPUT,OUTSCA, + NODES,NUMEL,NUMNOD, + OUTPUT,ATNODE, + WORK,ICOUNT) C C AVERAGES VALUES OF "OUTSCA" AT INTEGRATION POINT #1 (CENTERS) C OF ALL TRIANGULAR CONTINUUM ELEMENTS TO GET MEAN VALUES C AT NODES. AT NODES WHICH ARE NOT CONNECTED TO ANY CONTINUUM C ELEMENT, AN AVERAGE OF ZERO IS REPORTED. C Note: This is a special OrbMapAI version, which uses only C the values at M=1 (almost same answer, anyway!) C DIMENSION ATNODE(NUMNOD),ICOUNT(NUMNOD), + NODES(3,NUMEL),OUTSCA(7,NUMEL) DO 10 I=1,NUMNOD ICOUNT(I)=0 ATNODE(I)=0.0 10 CONTINUE DO 20 I=1,NUMEL NODE=NODES(1,I) ICOUNT(NODE)=ICOUNT(NODE)+1 CCCCC ATNODE(NODE)=ATNODE(NODE)+OUTSCA(5,I) ATNODE(NODE)=ATNODE(NODE)+OUTSCA(1,I) NODE=NODES(2,I) ICOUNT(NODE)=ICOUNT(NODE)+1 CCCCC ATNODE(NODE)=ATNODE(NODE)+OUTSCA(6,I) ATNODE(NODE)=ATNODE(NODE)+OUTSCA(1,I) NODE=NODES(3,I) ICOUNT(NODE)=ICOUNT(NODE)+1 CCCCC ATNODE(NODE)=ATNODE(NODE)+OUTSCA(7,I) ATNODE(NODE)=ATNODE(NODE)+OUTSCA(1,I) 20 CONTINUE DO 30 I=1,NUMNOD IF (ICOUNT(I).GT.0) ATNODE(I)=ATNODE(I)/ICOUNT(I) 30 CONTINUE RETURN END