MODULE SPHERE C C ROUTINES FOR SPHERICAL-PLANET COMPUTATIONS, C USED BY OTHER MAPPING MODULES. C C NOTE: THIS IS THE LOWEST-LEVEL MODULE, AND DOES NOT CALL ANY OTHER. C C IN FORTRAN-90 FIXED-FORM, BUT MOST ROUTINES C ARE INHERITED FROM FORTRAN77. C C BY PETER BIRD, UCLA, 1997 C C--------------- CONTENTS -------------------------------------------- C ATAN2F LIKE INTRINSIC ATAN2(), BUT DOESN'T CRASH ON (0.,0.) INPUT C COMPAS COMPUTES AZIMUTH OF AN ARC OF A GREAT CIRCLE C CROSS VECTOR CROSS PRODUCT C IABOVE RETURNS INTEGER .GE. X, UNLIKE INT(X) C IBELOW RETURNS INTEGER WHICH IS ALWAYS ROUNDED TOWARD NEGATIVE AXIS C TURNTO PROJECTS ON SPHERE FOR GIVEN ARC AT GIVEN INITIAL AZIMUTH C UNIT CONVERTS ANY NON-ZERO 3-VECTOR TO A UNIT VECTOR C--------------------------------------------------------------------- C CONTAINS C C C REAL FUNCTION ATAN2F (Y,X) C C CORRECTS FOR PROBLEM OF TWO ZERO ARGUMENTS C IF ((X.NE.0.).OR.(Y.NE.0.)) THEN ATAN2F=ATAN2(Y,X) ELSE ATAN2F=0. END IF RETURN END FUNCTION ATAN2F 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 SUBROUTINE COMPAS 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 SUBROUTINE CROSS C C C INTEGER FUNCTION IABOVE (X) C "SUBROUTINE" (for subprogram title search purposes) C C RETURNS INTEGER .GE. X, UNLIKE INT() C IF (X.LE.0.) THEN IABOVE=INT(X) ELSE IABOVE=INT(X) IF (X.GT.IABOVE) IABOVE=IABOVE+1 ENDIF RETURN END FUNCTION IABOVE C C C INTEGER FUNCTION IBELOW (X) C "SUBROUTINE" (for subprogram title search purposes) 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 FUNCTION IBELOW 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 SUBROUTINE TURNTO 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 SUBROUTINE UNIT C C C END MODULE SPHERE C====================================================================== C MODULE DISSPLA2AI USE SPHERE C C----------------------------------------------------------------------- C-DISSPLA2AI : CATCHES CALLS TO DISSPLA AND PRODUCES POSTSCRIPT OUTPUT C----------------------------------------------------------------------- C C IN FORTRAN-90 FIXED-FORM, BUT MOST ROUTINES C ARE INHERITED FROM FORTRAN77. C C BY PETER BIRD, UCLA, 1997 C C-----------CONTENTS---------------------------------------------------- C ALNMES ALIGNS FUTURE TEXT MESSAGES WITH RESPECT TO CONTROL POINT C ANGLE SETS ORIENTATION OF FUTURE TEXT MESSAGES C ARC DRAWS A SEGMENT OF A CIRCLE C AREA2D DEFINES MAP AREA WITHIN THE PAGE C BGROUP BEGINS A GRAPHICS GROUP IN THE OUTPUT .AI FILE C CHGCLR CHANGES CURRENT COLOR, AFFECTING FUTURE GRAPHICS C CURVE DRAWS A POLYLINE WITHIN THE MAP AREA (PROJECTED) C CURVTO POSTSCRIPT: ADDS A BEZIER CURVE TO OPEN PATH, LVING UNSTROKED C DASH TURNS ON DASHED LINES C DONEPL ENDS GROUP OF PLOTS (INACTIVE DUMMY) C DOT TURNS ON DOTTED LINES C EGROUP ENDS A GRAPHICS GROUP IN THE OUTPUT .AI FILE C ENDGR ENDS 1 SUBPLOT OUT OF SEVERAL ON PAGE (INACTIVE DUMMY) C ENDPL ENDS A PAGE (AND TERMINATES OUTPUT .AI FILE) C FRAME COMPLETES A MAP BY OVERLAYING GRID AND MASKING EDGES C GRID ADDS DOTTED PARALLELS AND MERIDIANS IN MAP AREA C HEADIN WRITES UP TO 4 LINES OF TEXT ABOVE THE MAP C HEIGHT SETS HEIGHT OF FUTURE TEXT CHARACTERS C HWSHD TURNS ON HARDWARE-SHADING (INACTIVE DUMMY) C LINEAR LINEAR TRANSFORMATION FROM METERS TO PLOT INCHES. C LINETO POSTSCRIPT: ADDS A SEGMENT TO AN OPEN PATH, LEAVING UNSTROKED C LLTOXY CONIC-PROJECTION ROUTINE: DEGREES TO METERS C LL2XYZ CONVERTS LONGITUDE/LATITUDE TO CARTESIAN UNIT VECTOR C MAPFIL PLOTS THE BASEMAP IN THE MAP WINDOW C MAPGR SELECTS MAP SCALE AND SPACING OF MERIDIANS, PARALLELS C MAPOLE SETS CENTER POINT OF MAP C MAP2XY CONVERTS LONGITUDE/LATITUDE TO ABSOLUTE X/Y IN POINTS C MARKER SETS THE SYMBOL USED BY CURVE TO MARK POINTS C MESSAG PLOTS A TEXT MESSAGE IN ABSOLUTE PAGE COORDINATES C MOVETO POSTSCRIPT: BEGINS A NEW PATH IF ONE IS NEEDED C MYARC DRAWS AN ARC OF A GREAT CIRCLE (OR, A STRAIGHT LINE) C MYCURV DRAWS EITHER A LINE OR AN ARC ON MAP, DEPENDING ON LENGTH C PAGE SETS SIZE OF PAPER, AND BEGINS A NEW PLOT PAGE/.AI FILE C POLYGONS FILLS AND/OR SHADES POLYGONS IN MAP COORDINATES C (OR PAGE INCHES, IF PROJCT('NONE'), USING CURRENT C SHADING AND FILL PATTERNS/COLORS (SET ELSEWHERE). C PROJCT SELECTS MAP PROJECTION MODE C RAENIL INVERSE OPERATION FROM LINEAR: PLOT INCHES TO METERS C REALNO PLOTS A REAL NUMBER IN ABSOLUTE PAGE COORDINATES C REPDIS REPORTS BACK VALUE OF ANY STATE VARIABLE OF DISSPLA C RESET RESETS ANY OR ALL STATE VARIABLES OF DISSPLA (EXCEPT PAGE) C RLMESS PLOTS A CHARACTER STRING ON THE MAP (PROJECTED LOCATION) C RLREAL PLOTS A REAL NUMBER ON THE MAP (PROJECTED LOCATION) C RLVEC DRAWS A STRAIGHT LINE (NOT GREAT CIRCLE) BETWEEN 2 MAP POINTS C SETDEV SET OUTPUT DEVICE (INACTIVE DUMMY) C SHDCHR SETS COLOR USED FOR TEXT CHARACTERS (INACTIVE DUMMY) C STROKE POSTSCRIPT: CLOSES AN OPEN PATH BY STROKING IT C SWISSL SELECTS HELVETIC FONT (INACTIVE DUMMY) C THKCRV SETS PEN WIDTH, IN POINTS (INTEGER INPUT) C THKVEC SETS PEN WIDTH, IN POINTS (REAL INPUT) C VECTOR DRAWS A STRAIGHT LINE IN ABSOLUTE PAGE COORDINATES C XNAME LABELS THE HORIZONTAL AXIS OF MAP (BELOW NUMBERS) C XYTOLL INVERSE CONIC PROJECTION: METERS TO DEGREES. C XYZ2LL CONVERTS CARTESIAN UNIT VECTOR TO LONGITUDE/LATITUDE C XY2MAP CONVERTS ABSOLUTE PAGE POSITION TO LONGITUDE/LATITUDE C YNAME LABELS THE VERTICAL AXIS OF MAP (TO LEFT OF NUMBERS) C----------------------------------------------------------------------- C C GRAPHICS STATE VARIABLES C (ROUGHLY EMULATING THOSE IN THE DISSPLA PACKAGE, AND C ALSO IN MOST IMPLEMENTATIONS OF POSTSCRIPT) C C CDI00 = 10-BYTE NAME OF LAST FILL COLOR SENT TO OUTPUT FILE C CDI01 = 10-BYTE NAME OF LAST PEN 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 SHADING COLOR/PATTERN WHICH IS CURRENT C (1-9, 9 DARKEST), C OR 0 FOR OFF-WHITE, OR 10 FOR 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/FILL. C LDI03 = T IF LAST LINE SENT TO UNIT 99 WAS A CUSTOM STROKE COLOR C LDI04 = T IF LAST LINE SENT TO UNIT 99 WAS A CUSTOM FILL COLOR 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*10 CDI00,CDI01 CHARACTER*16 CDI02 INTEGER IDI01,IDI02,IDI03,IDI04,IDI05 LOGICAL LDI01,LDI02,LDI03,LDI04 REAL RDI01,RDI02,RDI03,RDI04,RDI05,RDI06,RDI07,RDI08, + RDI09,RDI10,RDI11,RDI12,RDI13,RDI14,RDI15,RDI16, + RDI17,RDI18,RDI19, + VDI01,VDI02,VDI03 DIMENSION VDI01(3),VDI02(3),VDI03(3) C C------------------------------------------------------------------ C C SPECIAL FLAG USED TO ABUT TEXT STRINGS: REAL ABUT DATA ABUT /-1024./ C C------------------------------------------------------------------ C C GLOBAL PARAMETERS WHICH DEFINE THE CONIC PROJECTION C (THE SAME AS THE FOUR APPENDED TO ALL .DIG FILES C WHICH HAVE UNITS OF METERS INSTEAD OF DEGREES). C REAL RADIUS, CPNLAT, Y0NLAT, X0ELON C (m?) (deg.) (deg.) (deg.) C C------------------------------------------------------------------ C C GLOBAL PARAMETERS USED BY LINEAR AND RAENIL TO CONVERT C BETWEEN PLOT INCHES AND METERS ON THE IDEALIZED CONIC C PROJECTION PLANE: REAL SDENOM,XCENTR,YCENTR C C------------------------------------------------------------------ C C COLOR AND GRAY-SCALE INFORMATION C CHARACTER*10 COLNAM INTEGER NCOLOR,NGRAY LOGICAL COLOR DIMENSION COLNAM(9) C C GRAY SCALE IS CONSTRUCTED WITHIN A 0.010" SQUARE, WITH C DENSITY INCREASING AS THE INDEX RISES. C DATA NGRAY /9/ C THEY ARE NAMED Gray1 ... Gray9 AND ARE DEFINED IN THE C MODEL .AI FILE READ IN AT RUN TIME. C DATA NCOLOR /9/ DATA COLNAM(1)/'pink______'/, + COLNAM(2)/'red_______'/, + COLNAM(3)/'brown_____'/, + COLNAM(4)/'yellow____'/, + COLNAM(5)/'yellowgree'/, + COLNAM(6)/'green_____'/, + COLNAM(7)/'sky_blue__'/, + COLNAM(8)/'mid_blue__'/, + COLNAM(9)/'dark_blue_'/ C C NOTE: Additional colors 'off_white__' and 'gray______' are C used for fills of areas off the end of this color C spectrum. C Lines and text can be prescribed additionally as: C 'black_____', 'white_____', 'foreground', or 'background'. C C================================================================== CONTAINS 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 RDI01=XFRAC RDI02=YFRAC RETURN END SUBROUTINE ALNMES 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 RDI03=ANG RETURN END SUBROUTINE ANGLE C C C SUBROUTINE ARC (X,Y,R,DEG1,DEG2,TEXT,THICK) C C DRAWS A PARTIAL CIRCLE AT (X,Y), WHOSE MEANING DEPENDS C ON THE CURRENT MAP PROJECTION (IF 'NONE', THEN IN INCHES), C WITH RADIUS R (MAP UNITS OR INCHES), C AND LINE THICKNESS THICK (ALWAYS IN INCHES). C BEGINNING AT ANGLE "DEG1" AND ENDING AT "DEG2" (IN DEGREES) C COUNTERCLOCKWISE FROM THE X AXIS. C CHARACTER*(*), INTENT(IN) :: TEXT REAL, INTENT(IN) :: DEG1, DEG2, R, THICK, X, Y C INTEGER I1,I2 REAL D1,D2,DEG3,SIZE, + X0,X0P,X1,X1P,X2,X2P,X3,X3P, + Y0,Y0P,Y1,Y1P,Y2,Y2P,Y3,Y3P C CALL THKVEC(THICK*72.) C X0=X+R*COS(DEG1/57.296) Y0=Y+R*SIN(DEG1/57.296) CALL MAP2XY (INPUT,X0,Y0, + OUTPUT,ROTAT,X0P,Y0P) CALL MOVETO (X0P,Y0P) 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) Y3=Y+R*SIN(D2/57.296) CALL MAP2XY (INPUT,X3,Y3, + OUTPUT,ROTAT,X3P,Y3P) SIZE=R*0.5523*(D2-D1)/90. X1=X0+SIZE*COS((D1+90.)/57.296) Y1=Y0+SIZE*SIN((D1+90.)/57.296) CALL MAP2XY (INPUT,X1,Y1, + OUTPUT,ROTAT,X1P,Y1P) X2=X3-SIZE*COS((D2+90.)/57.296) Y2=Y3-SIZE*SIN((D2+90.)/57.296) CALL MAP2XY (INPUT,X2,Y2, + OUTPUT,ROTAT,X2P,Y2P) CALL CURVTO (X1P,Y1P,X2P,Y2P,X3P,Y3P) X0=X3 Y0=Y3 D1=D2 100 CONTINUE D2=DEG3 X3=X+R*COS(D2/57.296) Y3=Y+R*SIN(D2/57.296) CALL MAP2XY (INPUT,X3,Y3, + OUTPUT,ROTAT,X3P,Y3P) SIZE=R*0.5523*(D2-D1)/90. X1=X0+SIZE*COS((D1+90.)/57.296) Y1=Y0+SIZE*SIN((D1+90.)/57.296) CALL MAP2XY (INPUT,X1,Y1, + OUTPUT,ROTAT,X1P,Y1P) X2=X3-SIZE*COS((D2+90.)/57.296) Y2=Y3-SIZE*SIN((D2+90.)/57.296) CALL MAP2XY (INPUT,X2,Y2, + OUTPUT,ROTAT,X2P,Y2P) CALL CURVTO (X1P,Y1P,X2P,Y2P,X3P,Y3P) CALL STROKE RETURN END SUBROUTINE ARC C C C SUBROUTINE AREA2D (XWIDTH,YHEIGH) C C DEFINES A MAP AREA BEGINNING AT (0.5",0.5") FROM LOWER LEFT, C WITH REQUESTED WIDTH AND HEIGHT AS REQUESTED (IN INCHES). C REAL XWIDTH,YHEIGH RDI11=0.5*72. RDI12=RDI11+72.*XWIDTH RDI13=0.5*72. RDI14=RDI13+72.*YHEIGH RETURN END SUBROUTINE AREA2D C C C SUBROUTINE BGROUP C C BEGINS A NEW GRAPHICS GROUP IN THE AI OUTPUT FILE C C FOR INSURANCE, FIRST: CALL STROKE C WRITE (99,20) 20 FORMAT ('u') IDI02=IDI02+1 LDI03=.FALSE. LDI04=.FALSE. RETURN END SUBROUTINE BGROUP C C C SUBROUTINE CHGCLR (color_name,LINE,FILL) C C RESETS LINE AND FILL COLORS IN OUTPUT FILE, IF NEEDED C CHARACTER*10, INTENT(IN) :: color_name LOGICAL, INTENT(IN) :: LINE, FILL C LINE = T MEANS RESET PEN COLOR; FILL = T MEANS RESET FILL COLOR. C INTEGER C,M,Y,K C C ILLEGAL TO CHANGE COLORS WITHIN A PATH! C (SO, AS A KLUDGE, WE END THE PATH) CALL STROKE C C IF THE REQUIRED COLOR IS CURRENT, TAKE NO ACTION IF (.NOT.(LINE.OR.FILL)) RETURN IF ((.NOT.FILL).AND.(CDI01.EQ.color_name)) RETURN IF ((.NOT.LINE).AND.(CDI00.EQ.color_name)) RETURN IF ((LINE.AND.FILL).AND.(CDI00.EQ.color_name).AND. + (CDI01.EQ.color_name)) RETURN C C IF THIS COLOR WILL OVERRIDE THE PREVIOUS LINE OF 99, OVERWRITE IT IF (LDI03.AND.LINE) BACKSPACE 99 IF (LDI04.AND.FILL) BACKSPACE 99 C C RECORD THE COLOR THAT IS ABOUT TO BE SET IF (LINE) CDI01 = color_name IF (FILL) CDI00 = color_name C C ---- start with absolute, unchangeable black and white ---- IF (color_name.EQ.'black_____') THEN IF (LINE) THEN WRITE (99,"('0 G')") LDI03=.TRUE. LDI04=.FALSE. END IF IF (FILL) THEN WRITE (99,"('0 g')") IDI04= -1 LDI03=.FALSE. LDI04=.TRUE. END IF ELSE IF (color_name.EQ.'white_____') THEN IF (LINE) THEN WRITE (99,"('1 G')") LDI03=.TRUE. LDI04=.FALSE. END IF IF (FILL) THEN WRITE (99,"('1 g')") IDI04= -2 LDI03=.TRUE. LDI04=.FALSE. END IF ELSE C NOTE: FOLLOWING IS DEFAULT (GREY) C= 0 M= 0 Y= 0 K= 33 IF (FILL) IDI04= 999 C ----- foreground and background are redefinable (for slides)---- IF (color_name.EQ.'foreground') THEN IF (LINE) IDI04 = -101 C= 0 M= 0 Y= 0 K=100 ELSE IF (color_name.EQ.'background') THEN IF (FILL) IDI04= -102 C= 0 M= 0 Y= 0 K= 0 C ---------------------- gray brackets spectrum on high-index end ELSE IF (color_name.EQ.'gray______') THEN IF (FILL) IDI04= NCOLOR+1 C= 0 M= 0 Y= 0 K= 50 C ------------------ begin spectrum of NCOLOR colors ------------ ELSE IF (color_name.EQ.'dark_blue_') THEN IF (FILL) IDI04= 9 C=100 M= 0 Y= 0 K= 25 ELSE IF (color_name.EQ.'mid_blue__') THEN IF (FILL) IDI04= 8 C=85 M= 0 Y= 0 K= 0 ELSE IF (color_name.EQ.'sky_blue__') THEN IF (FILL) IDI04= 7 C=40 M= 0 Y= 0 K= 0 ELSE IF (color_name.EQ.'green_____') THEN IF (FILL) IDI04= 6 C=100 M= 10 Y=100 K= 0 ELSE IF (color_name.EQ.'yellowgree') THEN IF (FILL) IDI04= 5 C=50 M= 0 Y=90 K= 0 ELSE IF (color_name.EQ.'yellow____') THEN IF (FILL) IDI04= 4 C= 0 M= 0 Y=100 K= 0 ELSE IF (color_name.EQ.'brown_____') THEN IF (FILL) IDI04= 3 C=20 M=55 Y=60 K= 0 ELSE IF (color_name.EQ.'red_______') THEN IF (FILL) IDI04= 2 C= 0 M=100 Y= 60 K= 0 ELSE IF (color_name.EQ.'pink______') THEN IF (FILL) IDI04= 1 C=10 M=35 Y= 0 K= 0 C ---- off-white brackets the spectrum on the low-index end ----- ELSE IF (color_name.EQ.'off_white_') THEN IF (FILL) IDI04= 0 C= 0 M= 0 Y= 0 K= 4 ENDIF RC=0.01*C RM=0.01*M RY=0.01*Y RK=0.01*K IF (LINE) THEN WRITE (99,31) RC,RM,RY,RK, color_name 31 FORMAT (4F5.2,' (',A,') 0 X') CDI01=color_name LDI03 = .TRUE. LDI04 = .FALSE. END IF IF (FILL) THEN WRITE (99,40) RC,RM,RY,RK, color_name 40 FORMAT (4F5.2,' (',A,') 0 x') LDI03 = .FALSE. LDI04 = .TRUE. END IF END IF RETURN END SUBROUTINE CHGCLR 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 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/ C 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 ((CDI02(1:4).EQ.'NONE').OR. + (CDI02(1:6).EQ.'LINEAR').OR. + (T2.LE.0.00762)) THEN C IF NO MAP PROJECTION, OR LINEAR ONE, OR 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 SUBROUTINE CURVE 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 LOGICAL NOPATH C 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. LDI03=.FALSE. LDI04=.FALSE. ENDIF ENDIF RETURN END SUBROUTINE CURVTO C C C SUBROUTINE DASH C C TURNS ON DASHED LINES C WRITE (99,10) C 7-POINT DASHES AND 5-POINT GAPS ALTERNATE 10 FORMAT ('[7 5]0 d') LDI03=.FALSE. LDI04=.FALSE. RETURN END SUBROUTINE DASH C C C SUBROUTINE DONEPL C C IN DISSPLA, TERMINATES PLOT METAFILE OF MANY PAGES C C HERE, TAKES NO ACTION, BECAUSE EACH PAGE IS A SEPARATE FILE C AND THERE IS NO LARGER STRUCTURE CONTAINING ALL THE PAGES. C RETURN END SUBROUTINE DONEPL C C C SUBROUTINE DOT C C TURNS ON DOTTED LINES C WRITE (99,10) C 1-POINT DOTS AND 4-POINT GAPS ALTERNATE 10 FORMAT ('[1 4]0 d') LDI03=.FALSE. LDI04=.FALSE. RETURN END SUBROUTINE DOT 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 C FOR INSURANCE, FIRST: CALL STROKE C IF (IDI02.GE.1) THEN WRITE (99,10) 10 FORMAT ('U') RDI07=-1. RDI08=-1. LDI03=.FALSE. LDI04=.FALSE. ENDIF IDI02=MAX(0,IDI02-1) RETURN END SUBROUTINE EGROUP 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 SUBROUTINE ENDGR 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 LOGICAL LAND C CHARACTER*97 LINE CALL EGROUP CALL EGROUP CALL EGROUP LAND=RDI09.GT.(9.0*72.) 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) LDI03=.FALSE. LDI04=.FALSE. RETURN END SUBROUTINE ENDPL C C C SUBROUTINE FIDUC C C ADDS LATITUDE AND LONGITUDE NUMBERS OUTSIDE FRAME OF MAP C PARAMETER (MAXCNT=100) CHARACTER*6 THELAT CHARACTER*7 THELON DIMENSION TEMP(2,MAXCNT) C CALL RESET ('HEIGHT') CALL ALNMES (0.5,0.0) C C LEFT SIDE: 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) 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 RIGHT SIDE: C CALL ANGLE (-90.) CALL THKVEC (2.) C CALL BGROUP C NCOUNT=0 DY=10. DO 200 YLOW=RDI13-DY,RDI14,DY YHIGH=YLOW+DY CALL XY2MAP (INPUT,RDI12,YLOW, + OUTPUT,DLON1,DLAT1) CALL XY2MAP (INPUT,RDI12,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 (RDI12,Y) CALL LINETO (RDI12-EX,Y-EY) IF (NCOUNT.EQ.MAXCNT) GO TO 201 ENDIF 200 CONTINUE C CALL EGROUP CALL BGROUP C 201 YFULL=0. DO 290 I=1,NCOUNT Z=TEMP(1,I) Y=TEMP(2,I) WRITE (THELAT,210) Z 210 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,(RDI12+IDI03/2.)/72.,Y/72.) YFULL=Y+IDI03*NCHAR*0.3 ENDIF 290 CONTINUE C CALL EGROUP C C BOTTOM: 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,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 301 ENDIF 300 CONTINUE C CALL EGROUP CALL BGROUP C 301 XFULL=0. DO 390 I=1,NCOUNT Z=TEMP(1,I) IF (Z.LE.-180.) Z=Z+360. IF (Z.GT.+180.) Z=Z-360. 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.,(RDI13-IDI03)/72.) XFULL=X+IDI03*NCHAR*0.3 ENDIF 390 CONTINUE C CALL EGROUP C C TOP: C CALL ANGLE (0.) CALL THKVEC (2.) C CALL BGROUP C NCOUNT=0 DX=10. DO 400 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 401 ENDIF 400 CONTINUE C CALL EGROUP CALL BGROUP C 401 XFULL=0. DO 490 I=1,NCOUNT Z=TEMP(1,I) IF (Z.LE.-180.) Z=Z+360. IF (Z.GT.+180.) Z=Z-360. X=TEMP(2,I) WRITE (THELON,410) Z 410 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 490 CONTINUE C CALL EGROUP C C LABEL THE X AXIS CCCCC CALL XNAME ('LONGITUDE',9) C C LABEL THE Y AXIS CCCCC CALL YNAME ('LATITUDE',8) RETURN END SUBROUTINE FIDUC 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 LOGICAL DOGRID C C JUST TO BE SURE: CALL EGROUP CALL EGROUP CALL EGROUP C C ADD DOTTED-LINE GRID OF MERIDIANS AND PARALLELS? CALL CHGCLR ('foreground',.TRUE.,.FALSE.) IF (DOGRID) CALL GRID (1,1) C C GROUP OF WHITE RECTANGLES SHOULD BE LOCKED AGAINST C ACCIDENTAL SELECTION AND MOVEMENT DURING EDITING: C CALL CHGCLR ('background',.FALSE.,.TRUE.) WRITE (99,10) 10 FORMAT ('1 A') LDI03=.FALSE. LDI04=.FALSE. 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 CHGCLR ('foreground',.TRUE.,.FALSE.) 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 SUBROUTINE FRAME 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 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 THKCRV(1) CALL DOT 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 THKCRV(1) CALL DOT 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 SUBROUTINE GRID 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*(*) LHEAD C 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 SUBROUTINE HEADIN C C C SUBROUTINE HEIGHT (HITE) C C SETS HEIGHT OF TEXT CHARACTERS TO HITE INCHES C NPOINT=HITE*72.+0.5 IDI03=NPOINT RETURN END SUBROUTINE HEIGHT C C C SUBROUTINE HWSHD C C HAS NO EFFECT IN -ORBMAPAI- C RETURN END SUBROUTINE HWSHD C C C SUBROUTINE LINEAR(INPUT,XM,YM, + OUTPUT,XINCH,YINCH) C C USES GLOBAL VARIABLES TO CONVERT FROM METERS IN AN IDEALIZED C EARTH-SIZED PROJECTION PLANE TO INCHES ON THE CURRENT PAGE. C REAL XINCH,XM,YINCH,YM C XINCH = (0.5*(RDI11+RDI12)/72.) + 39.37*((XM-XCENTR)/SDENOM) YINCH = (0.5*(RDI13+RDI14)/72.) + 39.37*((YM-YCENTR)/SDENOM) RETURN END SUBROUTINE LINEAR 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 LOGICAL NOPATH C 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. LDI03=.FALSE. LDI04=.FALSE. ENDIF ENDIF RETURN END SUBROUTINE LINETO C C C SUBROUTINE LLTOXY (INPUT,PLAT,PLON, + OUTPUT,X,Y) C C CONVERT A (NORTH LATITUDE=PLAT, EAST LONGITUDE=PLON) POSITION C INTO AN (X,Y) POSITION ON A CONIC PROJECTION WITH TANGENT C LATITUDE CPNLAT, WHEN THE (X,Y) ORIGIN IS AT C (NORTH LATITUDE=Y0NLAT, EAST LONGITUDE=X0ELON). C NECESSARY CONSTANTS ARE GLOBAL DATA (RADIUS,CPNLAT,Y0NLAT,X0ELON). C THE CUT NECESSARY IN THIS PROJECTION IS FROM THE POLE NEAREST C TO THE TANGENT LATITUDE (CPNLAT), ALONG A MERIDIAN WHICH C IS ON THE OPPOSITE SIDE OF THE EARTH FROM X0ELON. C IF PLAT IS MORE THAN 90 DEGREES DIFFERENT FROM CPNLAT, THE C POINT DOES NOT FALL ONTO THE PROJECTION AT ALL. TO PREVENT C CRASHES, WE MERELY PLACE IT VERY FAR OUT ON THE PROJECTION. C C REAL ANGLE C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C RTAN=RADIUS*TANDEG(90.-CPNLAT) YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) IF (ABS(PLAT-CPNLAT).GE.90.) PLAT=CPNLAT+89.*(PLAT-CPNLAT)/ + ABS(PLAT-CPNLAT) R=RTAN-RADIUS*TANDEG(PLAT-CPNLAT) DPLON=PLON-X0ELON IF (DPLON.LT.-180.) DPLON=DPLON+360. IF (DPLON.GT. 180.) DPLON=DPLON-360. ANGLE=DPLON*SINDEG(CPNLAT) X=R*SINDEG(ANGLE) Y=YPOLE-R*COSDEG(ANGLE) RETURN END SUBROUTINE LLTOXY 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,VECTOR DIMENSION VECTOR(3) DATA PIO180 /0.0174533/ C RADLON=LONDEG*PIO180 RADLAT=LATDEG*PIO180 VECTOR(1)=COS(RADLAT)*COS(RADLON) VECTOR(2)=COS(RADLAT)*SIN(RADLON) VECTOR(3)=SIN(RADLAT) RETURN END SUBROUTINE LL2XYZ 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 PARAMETER (LONGES=500) LOGICAL GREAT 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 CALL BGROUP NIN=0 WRITE(6,99) 99 FORMAT (/ /' Attempting to read DIGITISED (.DIG) BASEMAP', + ' from unit 13'/) 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 REWIND(13) RETURN END SUBROUTINE MAPFIL 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 REAL LEFT,LLOND,LLATD DIMENSION LEFT(3),OMEGA(3),RIGHT(3) C 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 SUBROUTINE MAPGR C C C SUBROUTINE MAPOLE (PERLON,PERLAT) C C SETS POINT OF TANGENCY (ALSO CENTER OF MAP) AT LOCATION: C PERLON = EAST LONGITUDE, IN DEGREES C PERLAT = NORTH LATITUDE, IN DEGREES. C CALL LL2XYZ (INPUT,PERLON,PERLAT, + OUTPUT,VDI01) CALL UNIT (MODIFY,VDI01) CALL LL2XYZ (INPUT,PERLON,PERLAT+90., + OUTPUT,VDI03) CALL UNIT (MODIFY,VDI03) CALL CROSS (INPUT,VDI03,VDI01,OUTPUT,VDI02) VDI02(3)=0.0 CALL UNIT (MODIFY,VDI02) RETURN END SUBROUTINE MAPOLE 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 MODULE DATA. 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 IF THE CURRENT PROJECTION IS "LINEAR", THEN DEGLON AND DEGLAT C ARE INTERPRETED AS METERS IN A PLANET-SIZED FLAT PROJECTION C PLANE, AND CONVERTED TO PLOT INCHES AND THEN TO POINTS. C REAL DELDEG,TV,VECTOR,X,XINCH,XM,Y,YINCH,YM DIMENSION TV(3),VECTOR(3) C IF (CDI02(1:4).EQ.'NONE') THEN ROTAT=0. X=72.*DEGLON Y=72.*DEGLAT ELSE IF (CDI02(1:6).EQ.'LINEAR') THEN ROTAT=0. XM=DEGLON YM=DEGLAT CALL LINEAR(INPUT,XM,YM, + OUTPUT,XINCH,YINCH) C CONVERT TO DRAFTING POINTS X=72.*XINCH Y=72.*YINCH ELSE IF (CDI02(1:5).EQ.'CONIC') THEN CALL LLTOXY (INPUT,DEGLAT,DEGLON, + OUTPUT,XM,YM) C AT THIS POINT, ANSWER IS IN METERS; C USE CURRENT LINEAR SCALING TO PLOT INCHES CALL LINEAR(INPUT,XM,YM, + OUTPUT,XINCH,YINCH) C CONVERT TO DRAFTING POINTS X=XINCH*72. Y=YINCH*72. DELDEG=DEGLON-X0ELON DELDEG=MOD((DELDEG+1260.),360.)-180. ROTAT=VDI01(3)*DELDEG/57.296 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 SUBROUTINE MAP2XY C C C SUBROUTINE MARKER (ITYPE) C C DEFINES THE SYMBOL USED BY CURVE IN ITS POINT-PLOTTING MODE C IDI01=ITYPE RETURN END SUBROUTINE MARKER 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*(*) LMESS EQUIVALENCE (XP2,XP3), (YP2,YP3) C CALL STROKE 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') LDI03=.FALSE. LDI04=.FALSE. 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 C C THE FOLLOWING METHOD MAKES ALL TEXT FOREGROUND-FILLED, C WITH AN INITIAL DEFINITION OF FOREGROUND AS BLACK. 20 FORMAT (I1,' Ta' + /'0 Tr' + /'0 O') CALL CHGCLR ('foreground',.FALSE.,.TRUE.) WRITE (99,21) 21 FORMAT ('1 w') LDI03=.FALSE. LDI04=.FALSE. C CCC THE FOLLOWING FORMAT MAKES ALL TEXT BLACK-FILLED: CCC20 FORMAT (I1,' Ta' CCC + /'0 Tr' CCC + /'0 O' CCC + /'0 g' CCC + /'1 w') C 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') CDI00='undefined_' CDI01='undefined_' LDI03=.FALSE. LDI04=.FALSE. RDI18=XPOINT+0.60*NMESS*(1.-RDI01)*IDI03*COS(RDI03/57.298) RDI19=YPOINT+0.60*NMESS*(1.-RDI01)*IDI03*SIN(RDI03/57.298) RETURN END SUBROUTINE MESSAG 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 LOGICAL NEWPEN,NEWXY,NOPATH C NOPATH=.NOT.LDI02 NEWPEN=(RDI05.NE.RDI06) R2=(X-RDI07)**2+(Y-RDI08)**2 NEWXY=(R2.GT.0.01) IF (NOPATH.OR.NEWPEN.OR.NEWXY) THEN CALL STROKE IF (NEWPEN) THEN WRITE (99,10) RDI05 10 FORMAT (F4.1,' w') RDI06=RDI05 LDI03=.FALSE. LDI04=.FALSE. ENDIF WRITE (99,20) X,Y 20 FORMAT (F7.1,F8.1,' m') RDI07=X RDI08=Y LDI02=.TRUE. LDI03=.FALSE. LDI04=.FALSE. ENDIF RETURN END SUBROUTINE MOVETO 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: THIS VERSION USES BASIS VECTORS VDI01,VDI02,VDI03 C RATHER THAN CUTLN1 AND CUTLN2 TO LOCATE THE CUT (MORE ACCURATE). 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 SUBROUTINE MYARC 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 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 SUBROUTINE MYCURV 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 -DISSPLA2AI-, C ALSO FULFILLS FUNCTION OF BEGINNING NEW PLOT, C SINCE EACH PAGE WILL BE A SEPARATE FILE. C C C ---------------- NEW-FILE FUNCTIONS ------------------------ C CHARACTER*11 AIFILE CHARACTER*80 FILE99 CHARACTER*97 LINE INTEGER IOS,IREAD LOGICAL LAND C LAND=PAGEX.GT.9.0 IF (LAND) THEN IREAD=11 AIFILE='LanModel.AI' WRITE (6,1) AIFILE,IREAD 1 FORMAT (/' Attempting to read MODEL .AI FILE IN LANDSCAPE'/ + ' FORMAT (',A,') from unit ',I2/) ELSE IREAD=12 AIFILE='PorModel.AI' WRITE (6,2) AIFILE,IREAD 2 FORMAT (/' Attempting to read MODEL .AI FILE IN PORTRAIT'/ + ' FORMAT (',A,') from unit ',I2/) ENDIF 3 OPEN (UNIT=IREAD,FILE=AIFILE,PAD='YES',STATUS='OLD',IOSTAT=IOS) IF (IOS.NE.0) THEN WRITE (*,4) AIFILE 4 FORMAT(' Adobe Illustrator model file ',A,' not found.'/ + ' Enter alternative filename (.LE. 11 bytes): ') READ (*,'(A)') AIFILE GO TO 3 END IF C C TRIAL READ, TO DISCOVER ANY PROBLEMS BEFORE ANOTHER FILE IS C OPENED FOR OUTPUT, ADDING CONFUSION. READ (IREAD,'(A)') LINE BACKSPACE (IREAD) C 10 WRITE (6,11) 11 FORMAT (/' Enter name for NEW graphics output (.AI) file: ') READ (*,'(A)') FILE99 OPEN (UNIT=99,FILE=FILE99,STATUS='NEW',IOSTAT=IOS) IF (IOS.NE.0) THEN WRITE (6,12) TRIM(FILE99) 12 FORMAT(' Your suggested filename of: ',A + ' is either illegal or in use. ', + 'Choose a different name.') GO TO 10 END IF C C BEGIN LOOP IN INPUT LINES: C 100 LINE=' '// + ' ' READ (IREAD,'(A)') LINE IF (LINE(1:13).EQ.'%%PageTrailer') THEN BACKSPACE IREAD ELSE WRITE (99,'(A)') TRIM(LINE) GO TO 100 ENDIF C C ---------------- PAGE-DEFINING FUNCTION -------------------- C LDI03=.FALSE. LDI04=.FALSE. RDI09=PAGEX*72. RDI10=PAGEY*72. C C BEGIN WITH A LOCKED RECTANGLE OF BACKGROUND COLOR CALL CHGCLR ('background',.FALSE.,.TRUE.) WRITE (99,"('1 A')") CALL MOVETO (0.0, 0.0) CALL LINETO (RDI09,0.0) CALL LINETO (RDI09,RDI10) CALL LINETO (0.0,RDI10) CALL LINETO (0.0,0.0) WRITE (99,"('f')") LDI02=.FALSE. WRITE (99,"('0 A')") LDI03=.FALSE. LDI04=.FALSE. RETURN END SUBROUTINE PAGE C C C SUBROUTINE POLYGONS (XARAY,YARAY,NUMPNT,NUMARE,LINE,FILL) C C CONVERTS COORDINATES USING MAP PROJECTION C (OR, CONVERTS INCHES TO TO POINTS IF PROJCT('NONE') ) C AND SENDS POLYGONS TO .AI FILE. C C IF (LINE), POLYGONS ARE OUTLINED. C IF (FILL), POLYGONS ARE FILLED. C C NOTE THAT THIS USES "closepath [fill] [stroke]" C PostScript commands, so it should not be called for polylines C which are not intended to be closed loops! C C CURRENT PEN COLOR AND FILL COLOR/PATTERN ARE SET ELSEWHERE. C REAL, DIMENSION(:), INTENT(IN) :: XARAY, YARAY INTEGER, DIMENSION(:), INTENT(IN) :: NUMPNT INTEGER, INTENT(IN) :: NUMARE LOGICAL, INTENT(IN) :: LINE, FILL C INTEGER :: A,I,LAST LOGICAL :: ANYIN, IN REAL :: ROTAT REAL, DIMENSION(:), ALLOCATABLE :: XPOINTS,YPOINTS C CALL STROKE IF (.NOT.(LINE.OR.FILL)) RETURN LAST = 0 DO 1000 A=1,NUMARE IF (NUMPNT(A).GE.2) THEN ALLOCATE ( XPOINTS(NUMPNT(A)) ) ALLOCATE ( YPOINTS(NUMPNT(A)) ) ANYIN=.FALSE. DO 10 I=1,NUMPNT(A) CALL MAP2XY (INPUT,XARAY(I+LAST),YARAY(I+LAST), + OUTPUT,ROTAT,XPOINTS(I),YPOINTS(I)) IF (CDI02(1:4).EQ.'NONE') THEN IN = (XPOINTS(I).GT. 0.).AND. + (XPOINTS(I).LT.RDI09).AND. + (YPOINTS(I).GT. 0.).AND. + (YPOINTS(I).LT.RDI10) ELSE IN = (XPOINTS(I).GT.RDI11).AND. + (XPOINTS(I).LT.RDI12).AND. + (YPOINTS(I).GT.RDI13).AND. + (YPOINTS(I).LT.RDI14) END IF ANYIN = ANYIN .OR. IN 10 CONTINUE IF (ANYIN) THEN CALL MOVETO (XPOINTS(1),YPOINTS(1)) DO 100 I=2,NUMPNT(A) CALL LINETO (XPOINTS(I),YPOINTS(I)) 100 CONTINUE IF (LINE.AND.FILL) THEN WRITE (99,101) 101 FORMAT ('b') LDI03=.FALSE. LDI04=.FALSE. ELSE IF (LINE) THEN WRITE (99,102) 102 FORMAT ('s') LDI03=.FALSE. LDI04=.FALSE. ELSE IF (FILL) THEN WRITE (99,103) 103 FORMAT ('f') LDI03=.FALSE. LDI04=.FALSE. END IF LDI02=.FALSE. END IF DEALLOCATE ( XPOINTS, YPOINTS ) END IF LAST=LAST+NUMPNT(A) 1000 CONTINUE C (NO LONGER IN A PATH) C RETURN END SUBROUTINE POLYGONS C C C SUBROUTINE PROJCT (TYPE) C C SETS MAP PROJECTION MODE (IF ANY) C CHARACTER*(*) TYPE C CDI02=TRIM(TYPE) RETURN END SUBROUTINE PROJCT C C C SUBROUTINE RAENIL(INPUT,XINCH,YINCH, + OUTPUT,XM,YM) C C OPPOSITE OF "LINEAR": C USES GLOBAL VARIABLES TO CONVERT FROM INCHES ON THE PAGE TO C METERS IN AN EARTH-SIZED PROJECTION PLANE C REAL XINCH,XM,YINCH,YM C XM = XCENTR + SDENOM*((XINCH - (0.5*(RDI11+RDI12)/72.))/39.37) YM = YCENTR + SDENOM*((YINCH - (0.5*(RDI13+RDI14)/72.))/39.37) RETURN END SUBROUTINE RAENIL 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 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 SUBROUTINE REALNO C C C SUBROUTINE REPDIS (NAME,CVALUE,IVALUE,RVALUE,VVALUE) C C REPORTS ANY DISSPLA STATE VARIABLE VALUE C PLACING IT IN THE APPROPRIATE TYPE VARIABLE C CHARACTER*(*) NAME CHARACTER*16 CVALUE INTEGER IVALUE REAL RVALUE, VVALUE DIMENSION VVALUE(3) C IF (NAME.EQ.'ALNMES') THEN VVALUE(1)=RDI01 VVALUE(2)=RDI02 VVALUE(3)=0. ELSE IF (NAME.EQ.'ANGLE' ) THEN RVALUE=RDI03 ELSE IF (NAME.EQ.'HEIGHT') THEN IVALUE=IDI03 ELSE IF (NAME.EQ.'MAPOLE') THEN VVALUE(1)=VDI01(1) VVALUE(2)=VDI01(2) VVALUE(3)=VDI01(3) ELSE IF (NAME.EQ.'PAGE') THEN VVALUE(1)=RDI09 VVALUE(2)=RDI10 VVALUE(3)=0. ELSE IF (NAME.EQ.'PROJCT') THEN CVALUE=CDI02 ELSE IF (NAME.EQ.'THKCRV') THEN RVALUE=RDI04 ELSE IF (NAME.EQ.'THKVEC') THEN RVALUE=RDI05 ELSE IF (NAME.EQ.'PENXY') THEN VVALUE(1)=RDI07 VVALUE(2)=RDI08 VVALUE(3)=0. ENDIF RETURN END SUBROUTINE REPDIS 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 CHARACTER*(*) NAME C IF (NAME.EQ.'ALL') THEN CALL EGROUP CDI00='undefined_' CDI01='undefined_' LDI01=.FALSE. LDI02=.FALSE. LDI03=.FALSE. LDI04=.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.'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 SUBROUTINE RESET 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*(*) LMESS LOGICAL IN C 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 SUBROUTINE RLMESS 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 C 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 SUBROUTINE RLREAL 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 LOGICAL ANYIN,IN1,IN2 C 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 SUBROUTINE RLVEC C C C SUBROUTINE SETDEV C C HAS NO ACTIVITY IN -DISSPLA2AI- C SINCE THIS PROGRAM DOES NOT PRODUCE VOLUMINOUS MESSAGES. C RETURN END SUBROUTINE SETDEV C C C SUBROUTINE STROKE C C CLOSES AN OPEN PATH BY STROKING IT, IF NEEDED. C IF (LDI02) THEN WRITE (99,10) 10 FORMAT ('S') LDI02=.FALSE. LDI03=.FALSE. LDI04=.FALSE. ENDIF RETURN END SUBROUTINE STROKE C C C SUBROUTINE SWISSL C C HAS NO EFFECT; ALL TEXT IN THESE PLOTS WILL BE HELVETICA C ANYWAY. C RETURN END SUBROUTINE SWISSL C C C SUBROUTINE THKCRV (IPOINT) C C SET CURRENT PEN WIDTH, IN POINTS, USING INTEGER INPUT C INTEGER IPOINT REAL POINTS POINTS=IPOINT RDI04=POINTS RDI05=POINTS RETURN END SUBROUTINE THKCRV C C C SUBROUTINE THKVEC (POINTS) C C SET CURRENT PEN WIDTH, IN POINTS (USE REAL VARIABLE) C RDI04=POINTS RDI05=POINTS RETURN END SUBROUTINE THKVEC 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 REAL ANGLE C 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 SUBROUTINE VECTOR 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*(*) LXNAME C CALL ANGLE (0.0) CALL ALNMES (0.5,0.0) X=(RDI11+RDI12)/2. Y=RDI13-2.*IDI03 CALL MESSAG (LXNAME,IXNAME,X/72.,Y/72.) RETURN END SUBROUTINE XNAME C C C SUBROUTINE XYTOLL (INPUT,X,Y, + OUTPUT,PLAT,PLON) C C CONVERT POINTS EXPRESSED AS (X,Y) ON A CONIC PROJECTION PLANE C WITH TANGENT LATITUDE CPNLAT AND ORIGIN AT (Y0NLAT,X0ELON) C TO (PLAT = NORTH_LATITUDE, PLON = EAST_LONGITUDE) C IN DEGREES. C NECESSARY CONSTANTS ARE GLOBAL DATA (RADIUS,CPNLAT,Y0NLAT,X0ELON). C REAL ANGLE C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C RTAN=RADIUS*TANDEG(90.-CPNLAT) YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) YRP=Y-YPOLE R=SQRT(X**2+YRP**2) ANGLE=57.29578*ATAN2F(X,-YRP) PLON=X0ELON+ANGLE/SINDEG(CPNLAT) PLAT=CPNLAT+57.29578*ATAN((RTAN-R)/RADIUS) PLAT=MIN(90.,MAX(PLAT,-90.)) IF ((PLON-X0ELON).GT. 180.) PLON=PLON-360. IF ((PLON-X0ELON).GT. 180.) PLON=PLON-360. IF ((PLON-X0ELON).LT.-180.) PLON=PLON+360. IF ((PLON-X0ELON).LT.-180.) PLON=PLON+360. RETURN END SUBROUTINE XYTOLL 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/ C EQUAT=SQRT(VECTOR(1)**2+VECTOR(2)**2) YLAT=ATAN2F(VECTOR(3),EQUAT) XLON=ATAN2F(VECTOR(2),VECTOR(1)) LONDEG=XLON*OEZOPI LATDEG=YLAT*OEZOPI RETURN END SUBROUTINE XYZ2LL C C C SUBROUTINE XY2MAP (INPUT,X,Y, + OUTPUT,DEGLON,DEGLAT) C C OPPOSITE 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 MODULE DATA. C (EXCEPT IF PROJECTION IS "LINEAR", THEN OUTPUT IS IN METERS C IN THE PLANET-SIZED IDEALIZED PROJECTION PLANE) C REAL ARC,DEGLAT,DEGLON,DOT,X,XINCH,XM,Y,YINCH,YM DIMENSION TU(3),TV(3),VECTOR(3) C IF (CDI02(1:4).EQ.'NONE') THEN DEGLON=X/72. DEGLAT=Y/72. ELSE IF (CDI02(1:6).EQ.'LINEAR') THEN XINCH=X/72. YINCH=Y/72. CALL RAENIL(INPUT,XINCH,YINCH, + OUTPUT,XM,YM) DEGLON=XM DEGLAT=YM ELSE IF (CDI02(1:5).EQ.'CONIC') THEN XINCH=X/72. YINCH=Y/72. CALL RAENIL(INPUT,XINCH,YINCH, + OUTPUT,XM,YM) C AT THIS POINT, METERS IN IDEALIZED CONIC PROJECTION PLANE CALL XYTOLL (INPUT,XM,YM, + OUTPUT,DEGLAT,DEGLON) 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 SUBROUTINE XY2MAP 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*(*) LYNAME C 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 SUBROUTINE YNAME END MODULE DISSPLA2AI C============================================================ C MODULE VERSATEC2AI C USE SPHERE USE DISSPLA2AI C C C CONVERTS CALLS TO VERSATEC (ELECTROSTATIC PLOTTER) SOFTWARE C INTO CALLS TO DISSPLA DEVICE-INDEPENDENT GRAPHICS SOFTWARE. C (AND DISSPLA2AI CONVERTS THEM TO ADOBE ILLUSTRATOR POSTSCRIPT.) C C IN FORTRAN-90 FIXED-FORM, BUT MOST ROUTINES C ARE INHERITED FROM FORTRAN77. C C BY PETER BIRD, UCLA, 1997 C C--------------- CONTENTS -------------------------------------------- C CIRCLE (X,Y,RMINUS,IPEN) : DRAWS A CIRCLE C NEWPEN (IPEN) : CHANGES PEN WIDTH (WIDTH=IPEN) C PENCLR (color_name) : ASSIGNS COLOR TO PEN (NOT FILL) C PLOT (X,Y,N) : MOVES PEN (UP OR DOWN) C RECT (X1,X2,Y1,Y2,IBOX) : SHADES(?) & OUTLINES(?) RECTANGLE C SETPAT (N) : SETS SHADING PATTERN C SYMBOL(X,Y,H,TEXT,ISYM,ANG,NUM) : PLOTS TEXT STRING OR CENTERED O C WHERE (X,Y,F) : REPORTS BACK PEN LOCATION C--------------------------------------------------------------------- C C REAL CUTLN1,CUTLN2,ELOND1,NLATD1 C C================================================================== CONTAINS C================================================================== C C C SUBROUTINE CIRCLE (X,Y,RMINUS,IPEN) C C DRAWS A CIRCLE (CAUTION: RMINUS MAY BE A NEGATIVE RADIUS) C CHARACTER*1 TEXT REAL R, THICK R=ABS(RMINUS) THICK=IPEN/72. CALL ARC (X,Y,R,0.0,360.0,TEXT,THICK) RETURN END SUBROUTINE CIRCLE C C C SUBROUTINE NEWPEN (IPEN) C C CONVERTS VERSATEC CALLS: 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. C CALL THKCRV(IPEN) RETURN END SUBROUTINE NEWPEN C C C SUBROUTINE PENCLR (color_name) C C DEFINES THE COLOR OF THE PEN AS color_name, WHICH CAN BE C 'foreground', 'background', 'white_____', 'black_____', C or any color listed in the COLNAM array above in global data. C C NOTE: PEN COLOR DOES NOT DETERMINE TEXT COLOR; TEXT IS C FILLED RATHER THAN STROKED IN MOST CASES! C CHARACTER*10, INTENT(IN) :: color_name C CALL CHGCLR (color_name,.TRUE.,.FALSE.) RETURN END SUBROUTINE PENCLR C C C SUBROUTINE PLOT (X,Y,N) C C CONVERTS VERSATEC CALLS: 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. C INTEGER DOWN, UP LOGICAL GREAT REAL ELOND1,ELOND2,NLATD1,NLATD2 DATA DOWN/2/, UP/3/ SAVE C GREAT=COLOR.AND. + (.NOT.((CDI02(1:4).EQ.'NONE').OR.(CDI02(1:6).EQ.'LINEAR'))) IF (N.EQ.UP) THEN CALL STROKE ELOND1=X NLATD1=Y ELSE IF (N.EQ.DOWN) THEN ELOND2=X NLATD2=Y CALL MYARC (INPUT,ELOND1,NLATD1,ELOND2, + NLATD2,CUTLN1,CUTLN2, + GREAT) ELOND1=ELOND2 NLATD1=NLATD2 ENDIF RETURN END SUBROUTINE PLOT C C C SUBROUTINE RECT (X1,X2,Y1,Y2,IBOX) C C CREATES A RECTANGLE PARALLEL TO THE SIDES OF THE PAPER C (IF PROJECTION IS 'NONE' OR 'LINEAR') C OR, PARALELL TO MERIDIANS AND PARALELLS (OTHER PROJECTIONS). C IBOX CONTROLS SHADING AND OUTLINING: C = -1 : OUTLINING ONLY C = 0 : SHADING ONLY C = 1 : SHADING AND OUTLINING C (DOES NOT SET SHADING AND/OR PEN COLORS) C INTEGER IBOX LOGICAL ANYIN,IN REAL ROTAT,XT,X1,X2,YT,Y1,Y2 DIMENSION XARAY(5),XSAVE(5),YARAY(5),YSAVE(5) C XARAY(1)=X1 XARAY(2)=X2 XARAY(3)=X2 XARAY(4)=X1 XARAY(5)=X1 YARAY(1)=Y1 YARAY(2)=Y1 YARAY(3)=Y2 YARAY(4)=Y2 YARAY(5)=Y1 ANYIN=.FALSE. DO 1 I=1,5 CALL MAP2XY (INPUT,XARAY(I),YARAY(I), + OUTPUT,ROTAT,XT,YT) XSAVE(I)=XT YSAVE(I)=YT IF (CDI02(1:4).EQ.'NONE') THEN IN=.TRUE. ELSE IN=(XT.GE.RDI11).AND.(XT.LE.RDI12).AND. + (YT.GE.RDI13).AND.(YT.LE.RDI14) ENDIF ANYIN=ANYIN.OR.IN 1 CONTINUE IF (.NOT.ANYIN) RETURN CALL MOVETO (XSAVE(1),YSAVE(1)) DO 100 I=2,5 CALL LINETO (XSAVE(I),YSAVE(I)) 100 CONTINUE IF (IBOX.LT.0) THEN C OUTLINING ONLY CALL STROKE ELSE IF (IBOX.EQ.0) THEN C SHADING ONLY WRITE (99,110) 110 FORMAT ('f') LDI03=.FALSE. LDI04=.FALSE. ELSE C IBOX .GT. 0; C OUTLINE AND SHADE WRITE (99,120) 120 FORMAT ('b') LDI03=.FALSE. LDI04=.FALSE. END IF LDI02=.FALSE. RETURN END SUBROUTINE RECT C C C SUBROUTINE SETPAT (N) C C IN B/W MODE, SETS SHADING PATTERN C (N = 1...NGRAY; HIGH NUMBERS ARE DARKER). C N = 0 GIVES off_white_ C N > NGRAY GIVES (50%) gray______ C INTEGER, INTENT(IN) :: N CHARACTER*1 ASCIIN C IF (COLOR) RETURN CALL STROKE IF (N.NE.IDI04) THEN IF (N.LE.0) THEN CALL CHGCLR ('off_white_',.FALSE.,.TRUE.) ELSE IF (N.GT.NGRAY) THEN CALL CHGCLR ('gray______',.FALSE.,.TRUE.) ELSE WRITE (99,5) N 5 FORMAT + ('(Gray',I1,') 0 0 1 1 0 0 0 0 0 [1 0 0 1 0 0]p') WRITE (ASCIIN,"(I1)") N CDI00='Gray'//ASCIIN//'_____' LDI03=.FALSE. LDI04=.FALSE. END IF IDI04=N END IF RETURN END SUBROUTINE SETPAT C C C SUBROUTINE SYMBOL (X,Y,HEIGHT,TEXT,ISYMBL,DEGREE,NUMCHR) C C PLOTS TEXT STRING "TEXT" AT (X,Y) AT ANGLE "DEGREE" WITH C "HEIGHT". IF STRING LENGTH "NUMCHR" IS -1, THEN PLOTS C THE CENTERED SYMBOL IDENTIFIED BY "ISYMBL" (AT PRESENT, C ONLY THE CIRCLE IS AVAILABLE). C X AND Y ARE IN WHATEVER UNITS ONE SENDS TO MAP2XY C (DEGREES, METERS, OR INCHES, DEPENDING ON PROJECTION). C SYMBOL SIZE HEIGHT IS IN INCHES. C THIS ROUTINE DOES NOT CHECK WHETHER SYMBOL IS IN MAP WINDOW. C CHARACTER*(*) TEXT INTEGER IPEN,ISYMBL,NUMCHR REAL DEGREE,DT,HEIGHT,R,ROTAT,X,XT,Y,YT C CALL MAP2XY (INPUT,X,Y, + OUTPUT,ROTAT,XT,YT) C NOW XT AND YT ARE IN POINTS. C IF (NUMCHR.LT.0) THEN IPEN=1 R=0.5*HEIGHT XT=XT/72. YT=YT/72. C CIRCLE WILL EXPECT XT,YT,R IN INCHES, IPEN INTEGER. CALL CIRCLE (XT,YT,R,IPEN) ELSE IF (NUMCHR.GT.0) THEN DT=DEGREE+ROTAT*57.296 CALL ANGLE(DT) CALL MESSAG(TEXT,NUMCHR,XT/72.,YT/72.) CALL RESET('ANGLE') END IF C RETURN END SUBROUTINE SYMBOL C C C SUBROUTINE WHERE (X,Y,F) C C REPORTS BACK PEN LOCATION, IN INCHES ABSOLUTE COORDINATES C CHARACTER*16 CVALUE INTEGER IVALUE REAL F, RVALUE, VVALUE, X, Y DIMENSION VVALUE(3) CALL REPDIS ('PENXY',CVALUE,IVALUE,RVALUE,VVALUE) X=VVALUE(1)/72. Y=VVALUE(2)/72. RETURN END SUBROUTINE WHERE C END MODULE VERSATEC2AI C================================================================== C MODULE MAPTOOLS C (ABBREVIATED VERSION; SOME 3-NODE-TRIANGLE AND 4-NODE-FAULT C ROUTINES WITH SAME FUNCTIONS AS 6-NODE-TRIANGLE AND C 6-NODE-FAULT ROUTINES OF Plates2AI.f90 WERE CUT ("X"). C USE SPHERE USE DISSPLA2AI USE VERSATEC2AI C C A COLLECTION OF USEFUL SUBROUTINES FROM PREVIOUS PLOTTING PACKAGES. C THESE ROUTINES CALL VERSATEC OR DISSPLA SOFTWARE . C HOWEVER, THE USED MODULES CONVERT ALL TO ADOBE ILLUSTRATOR C POSTSCRIPT (.AI FILE) OUTPUT. C C IN FORTRAN-90 FIXED-FORM, BUT MOST ROUTINES C ARE INHERITED FROM FORTRAN77. C C BY PETER BIRD, UCLA, 1997 C C-----------CONTENTS (ITEMS MARKED WITH X WERE CUT OUT) -------------- C ARROW DRAWS AN ARROW ON THE SURFACE OF THE SPHERE (PROJECTED) C BAR ADDS A COLOR-SCALE BAR BELOW A MAP C CONTEL CONTOURS & COLORS A SCALAR FIELD IN 6-NODE PLANE TRIANGLES C DOSIDE FIND END POINTS OF CONTOUR SEGMENTS ON 6-NODE-ELEMENT SIDE C DOPART FIND END POINTS OF CONTOUR SEGMENTS ON PART OF ELEMENT SIDE C DOLINE FIND END POINTS OF CONTOUR SEGMENTS ON AN INTERNAL LINE C IHUE RETURNS ORDINAL NUMBER OF COLOR ASSOCIATED WITH SCALAR VALUE C X ETCH PLOTS A GRID OF 3-NODE SPHERICAL TRIANGLES & 4-NODE FAULTS C X FAULT PLOTS ONE 4-NODE GREAT-CIRCLE FAULT ELEMENT WITH DIP SYMBOLS C X FAULTS DRAWS ALL 4-NODE FAULT ELEMENTS AS ONE GRAPHICS GROUP C X FICONS DRAWS CONJUGATE-FAULT ICONS SHOWING STRAIN-RATES IN CONTINUM C GOPLOT INITIALIZES THE MAP AT THE CENTER OF THE PLOT C X PROJEC LIKE SCALAR, BUT PROJECTS VALUE FROM PLANE TO SPHERE TRIANGL C RESIZE CORRECTS SCALE OF SYMBOLS FOR MAP-PROJECTION DISTORTIONS C ROUND ROUNDS A POSITIVE REAL NUMBER TO A VALUE WHICH IS N*(10**M) C X SCALAR SHADES OR COLORS IN 3-NODE PLANE TRIANGLES TO SHOW A SCALAR C X SICONS DRAWS PRINCIPAL-STRESS-ANOMALY ICONS AT ELEMENT CENTERS C X SIGMA1 DRAWS MOST-COMPRESSIVE HORIZONTAL PRINCIPAL STRESS AXES C SIZER FINDS MAX(ABS(E3 - E1)) FOR A GROUP OF STRAIN-RATES C X SLIPS PLOTS 4-NODE GREAT-CIRCLE FAULT ELEMENTS WITH SLIP RATES C TONCLR SETS SHADING COLOR OR B/W PATTERN (NEW FOR Plates2AI). C VEC2XY CONVERTS CARTESIAN UNIT VECTOR TO THETA AND PHI IN RADIANS C----------------------------------------------------------------------- C C SHARED DATA C DOUBLE PRECISION FPOINT DIMENSION FPOINT(7) 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================================================================== CONTAINS C================================================================== 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 INTEGER MAPTYP LOGICAL BARIT,FROM,GREAT REAL AZIM,BASE,DEGWID,DIMINI,FAR,HEAD,HLAT,HLON, + LBAR,LEFT,LLAT,LLON,OMEGA, + PHI,POLE,POLEP,POLET,RBAR,RESULT,RIGHT,RLAT,RLON, + SIZE,TAIL,TAZIM,THETA,TLAT,TLON 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 SUBROUTINE ARROW C C C SUBROUTINE CONTEL (NODES,XNOD,YNOD,FUNC,DFCON,NUMNOD,NUMEL, + FGMAX,FGMIN,NCOLOR,FMIDLE,IFLIP, + ALLPOS,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 VERSION MODIFIED FOR Plates2AI, April 1997. C-------------------------------------------------------- C PARAMETER(MXAREA=10,NINLIN=130,NWORK=1300,NPOLYV=1000) CHARACTER*10 IPCLR, KOLORC, KOLORP, LASTKO LOGICAL ALLPOS,ANEDGE,BEGCON,BEGNXT,BITSEG,CENTER,CIRCLE, + 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 ANGLE, LOWEST DIMENSION NODES(6,NUMEL), + 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 FUNKTION: 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 GLOBAL INITIALIZATION (WHOLE GRID) C LIMINT=4./DSTEP FGMIN= 1.E38 FGMAX=-1.E38 C C USE foreground PEN OF WIDTH IPEN UNLESS MODIFIED C IF (COLOR) THEN CALL PENCLR('foreground') LASTKO='foreground' END IF 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 FUNKTION 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=IBELOW(T)+0.5 FOFSEG(I)=T*DFCON 550 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7782) DFCON 7782 FORMAT(/ / ' REVISED FOFSEG VALUES: (DFCON=', + 1P,E12.5,')') DO 108 I=1,ISPNUM WRITE(6,7784)I,FOFSEG(I) 7784 FORMAT(' ',I10,1P,E10.3) 108 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C*************************************************************** C C SEARCH FOR EXTREMUM WITHIN DOMAIN OF ELEMENT C CDET=16.*(-F6**2+2.*F6*F5+2.*F6*F4-2.*F6*F2-F5**2+2.*F5*F4 + -2.*F5*F1-F4**2-2.*F4*F3+F3*F2+F3*F1+F2*F1) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7785) CDET 7785 FORMAT(/' EXTREMUM DETERMINANT CDET=',1P,E12.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (ABS(CDET).LT. 1.E-30) GO TO 1000 S2EXT=(4.*F6**2-4.*F6*F5-4.*F6*F4-F6*F3+2.*F6*F2-F6*F1+F5* + F3+3.*F5*F1+3.*F4*F3+F4*F1-F3*F2-2.*F3*F1-F2*F1)/(4.*(F6 + **2-2.*F6*F5-2.*F6*F4+2.*F6*F2+F5**2-2.*F5*F4+2.*F5*F1+F4 + **2+2.*F4*F3-F3*F2-F3*F1-F2*F1)) S3EXT=(-4.*F6*F4+3.*F6*F2+F6*F1-4.*F5*F4+F5*F2+3.*F5*F1+4. + *F4**2+2.*F4*F3-F4*F2-F4*F1-F3*F2-F3*F1-2.*F2*F1)/(4.*(F6 + **2-2.*F6*F5-2.*F6*F4+2.*F6*F2+F5**2-2.*F5*F4+2.*F5*F1+F4 + **2+2.*F4*F3-F3*F2-F3*F1-F2*F1)) S1EXT=1.0-S2EXT-S3EXT C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7786)S1EXT,S2EXT,S3EXT 7786 FORMAT(/' EXTREMUM AT S1-3=',3F10.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (S1EXT.GT.0.99999.OR.S1EXT.LT.0.00001) GO TO 1000 IF (S2EXT.GT.0.99999.OR.S2EXT.LT.0.00001) GO TO 1000 IF (S3EXT.GT.0.99999.OR.S3EXT.LT.0.00001) GO TO 1000 C C REJECT SADDLE POINTS C DISCA=F1-2.*F4+F2 DISCB=F2-2.*F5+F3 DISCC=F3-2.*F6+F1 CENTER=((DISCA.GT.0.).AND.(DISCB.GT.0.).AND.(DISCC.GT.0.)) + .OR.((DISCA.LT.0.).AND.(DISCB.LT.0.).AND.(DISCC.LT.0.)) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7789) CENTER,DISCA,DISCB,DISCC 7789 FORMAT(/' CENTER=',L2,' BECAUSE DISCA-C=',1P,3E12.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (.NOT.CENTER) GO TO 1000 XEXT=PHIVAL(S1EXT,S2EXT,S3EXT,X1,X2,X3,X4,X5,X6) YEXT=PHIVAL(S1EXT,S2EXT,S3EXT,Y1,Y2,Y3,Y4,Y5,Y6) FEXT=PHIVAL(S1EXT,S2EXT,S3EXT,F1,F2,F3,F4,F5,F6) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8801)XEXT,YEXT,FEXT 8801 FORMAT(/' EXTREMUM IS AT X=',1P,E10.3,', Y=',E10.2, + ', F=',E10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ FMAX=MAX(FMAX,FEXT) FMIN=MIN(FMIN,FEXT) C C FIND CONTOUR STARTING/STOPPING POINT ALONG CHORD FROM A NODE TO EXT. C NCL=1 DIFF=ABS(F1-FEXT) DS(1)=S1EXT-1. DS(2)=S2EXT DS(3)=S3EXT DO 600 J=2,6 DFF=ABS(FN(J)-FEXT) IF (DFF.LT.DIFF) THEN NCL=J DIFF=DFF DS(1)=S1EXT DS(2)=S2EXT DS(3)=S3EXT IF (J.EQ.2) DS(2)=S2EXT-1. IF (J.EQ.3) DS(3)=S3EXT-1. IF (J.EQ.4.OR.J.EQ.6) DS(1)=S1EXT-0.5 IF (J.EQ.4.OR.J.EQ.5) DS(2)=S2EXT-0.5 IF (J.EQ.5.OR.J.EQ.6) DS(3)=S3EXT-0.5 ENDIF 600 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8812)NCL,DIFF,(DS(K),K=1,3) 8812 FORMAT(/' PARTITION LINE:'/ + ' NCL=',I10,' DIFF=',1P,E10.3,' DS(1-3)=',0P, + 3F10.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ CALL DOLINE (FEXT,DFCON,FN,NCL,DS,S1EXT,S2EXT,S3EXT, + IHIC,ILOC,PS,NPS,NINLIN,Z) IF (Z) THEN NCRASH=7 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF C C END OF CODE RELATED TO CASE OF AN INTERNAL EXTREMUM C C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT.AND.(NPS.GT.0)) THEN WRITE(6,8821) 8821 FORMAT(/ /' TABLE OF CONTOUR STARTING POINTS:') DO 8825 I=1,NPS XQ=PHIVAL(PS(1,I),PS(2,I),PS(3,I),X1,X2,X3,X4,X5,X6) YQ=PHIVAL(PS(1,I),PS(2,I),PS(3,I),Y1,Y2,Y3,Y4,Y5,Y6) WRITE(6,8823)I,(PS(K,I),K=1,4),XQ,YQ 8823 FORMAT(' ',I10,0P,3F10.5,1P,3E10.3) 8825 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 1000 IF (NPS.EQ.0) GO TO 9001 C C************************************************************* C C INTEGRATE ALL CONTOUR SEGMENTS C DO 1150 K=1,NPS DONE(K)=.FALSE. 1150 CONTINUE DO 9000 N=1,NPS C C INTEGRATE ONE CONTOUR SEGMENT C IF (.NOT.DONE(N)) THEN C C INITIALIZE INTEGRATION OF CONTOUR C DONE(N)=.TRUE. FVALUE=PS(4,N) IF (ALLPOS.AND.(FVALUE.LE.0.0)) GO TO 9000 ISPNUM=ISPNUM+1 C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8831)ISPNUM,FVALUE 8831 FORMAT(/' HISTORY OF SEGMENT ',I5,' (',1P,E10.3,')') ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (ISPNUM.GT.NINLIN) THEN NCRASH=8 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF FOFSEG(ISPNUM)=FVALUE ISPPNT(ISPNUM)=ISPPNT(ISPNUM-1)+ISPLEN(ISPNUM-1) IF (ISPPNT(ISPNUM).GT.NWORK) THEN NCRASH=9 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF ISPLEN(ISPNUM)=1 NTOGO(ISPNUM)=2 ANEDGE(ISPNUM)=.FALSE. S1=PS(1,N) S2=PS(2,N) S3=PS(3,N) INSIDE=(S1*S2*S3).GT.0.0 S1OLD=S1 S2OLD=S2 S3OLD=S3 X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) SPACE(1,ISPPNT(ISPNUM))=X SPACE(2,ISPPNT(ISPNUM))=Y ANGLE=0. IF (CENTER) ANGLE=ATAN2((Y-YEXT),(X-XEXT)) ANGLEP=ANGLE ROT=0. DFDS2=-4.*S3*F6+4.*S3*F5-4.*S3*F4+4.*S3*F1-8.*S2*F4+4.*S2* + F2+4.*S2*F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3*F6+4.*S3*F3+4.*S3*F1-4.*S2*F6+4.*S2*F5-4.*S2* + F4+4.*S2*F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX DS2=ROUNDX*DSTEP*0.1 DS3=ROUNDY*DSTEP*0.1 C C REVERSE INTEGRATION STEP DIRECTION IF CONTOUR POINTS OUTWARD C S2P=S2+DS2 S3P=S3+DS3 S1P=1.00-S2P-S3P COUNTR=1. IF ( (S1P.LT.0..OR.S1P.GT.1.) + .OR.(S2P.LT.0..OR.S2P.GT.1.) + .OR.(S3P.LT.0..OR.S3P.GT.1.)) COUNTR= -1. NSEG=0 C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,3412)ISPPNT(ISPNUM),X,Y,ANGLE 3412 FORMAT(' BEGINNING AT ISPPNT=',I10,' X=',1P,E10.3, + ' Y=',E10.3,' ANGLE=',0P,F10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C BEGIN LOOP OF INTEGRATION OF CONTOUR LINE C-------------------------------------------- C 3000 NSEG=NSEG+1 C EXTRAPOLATE TO NEXT POINT BY FORWARD METHOD DS2=ROUNDX*COUNTR*DSTEP DS3=ROUNDY*COUNTR*DSTEP S2P=S2+DS2 S3P=S3+DS3 S1P=1.00-S2P-S3P C RECOMPUTE SAME STEP BY BACKWARD METHOD DFDS2=-4.*S3P*F6+4.*S3P*F5-4.*S3P*F4 + +4.*S3P*F1-8.*S2P*F4+4.*S2P* + F2+4.*S2P*F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3P*F6+4.*S3P*F3+4.*S3P*F1 + -4.*S2P*F6+4.*S2P*F5-4.*S2P* + F4+4.*S2P*F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX DS2P=ROUNDX*DSTEP*COUNTR DS3P=ROUNDY*DSTEP*COUNTR C ACTUAL INTEGRATION STEP BY TRAPEZOIDAL METHOD DS2=0.5*(DS2+DS2P) DS3=0.5*(DS3+DS3P) DSLEN=SQRT(DS2**2+DS3**2) IF((DSLEN/DSTEP).LT.0.10) GO TO 8999 S2=S2+DS2 S3=S3+DS3 S1=1.00-S2-S3 C CORRECT CONTOUR TO ACTUAL VALUE DESIRED TRIAL=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) ERRER=TRIAL-FVALUE IF (ABS(ERRER).GE.DFCON) GO TO 8999 DFDS2=-4.*S3 *F6+4.*S3 *F5-4.*S3 *F4 + +4.*S3 *F1-8.*S2 *F4+4.*S2 * + F2+4.*S2 *F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3 *F6+4.*S3 *F3+4.*S3 *F1 + -4.*S2 *F6+4.*S2 *F5-4.*S2 * + F4+4.*S2 *F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF DISTNC= -ERRER/(GRADF*GSIZE) IF (ABS(DISTNC).GT.DSTEP) DISTNC= + DISTNC*DSTEP/ABS(DISTNC) S2=S2+DISTNC*GRADFX S3=S3+DISTNC*GRADFY S1=1.00-S2-S3 C DECIDE WHETHER CONTOUR IS FINISHED OR NOT HITLIM=NSEG.GE.LIMINT IF (HITLIM) WRITE(6,3501)FVALUE,I 3501 FORMAT(' ',1PE10.2,' CONTOUR IN ELEMENT ',I3, + ' SEEMS TO BE IN LOOP. TERMINATED.') GONOUT=(S1.LT.0..OR.S1.GT.1.).OR. + (S2.LT.0..OR.S2.GT.1.).OR. + (S3.LT.0..OR.S3.GT.1.) FINISH=GONOUT.OR.HITLIM IF (CENTER) THEN XT=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YT=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) ANGLEP=ATAN2((YT-YEXT),(XT-XEXT)) DROT=MIN(ABS(ANGLEP-ANGLE), & 6.2832-ABS(ANGLEP-ANGLE)) ROT=ROT+DROT CIRCLE=ROT.GE.6.2832 FINISH=FINISH.OR.CIRCLE IF (CIRCLE.AND.INSIDE) THEN S1=PS(1,N) S2=PS(2,N) S3=PS(3,N) ENDIF ENDIF C IF VECTOR EXTENDS OUTSIDE OF THE ELEMENT, SHORTEN IT ....... IF (GONOUT) THEN RAT=1.0 IF(S1.GT.1.)RAT=AMIN1(RAT,((1.-S1OLD)/(S1-S1OLD))) IF(S2.GT.1.)RAT=AMIN1(RAT,((1.-S2OLD)/(S2-S2OLD))) IF(S3.GT.1.)RAT=AMIN1(RAT,((1.-S3OLD)/(S3-S3OLD))) IF(S1.LT.0.)RAT=AMIN1(RAT,((0.-S1OLD)/(S1-S1OLD))) IF(S2.LT.0.)RAT=AMIN1(RAT,((0.-S2OLD)/(S2-S2OLD))) IF(S3.LT.0.)RAT=AMIN1(RAT,((0.-S3OLD)/(S3-S3OLD))) RAT=AMAX1(RAT,0.0) S2=S2OLD+(S2-S2OLD)*RAT S3=S3OLD+(S3-S3OLD)*RAT S1=1.00-S2-S3 C .... AND CROSS OFF THE CORRESPONDING SIDE-CROSSING POINT IF ((N.LT.NPS).AND.(.NOT.INSIDE)) THEN XE=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YE=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) MATE=N R2MIN=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(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX ANGLE=ANGLEP C C END LOOP OF PUSHING FORWARD ONE CONTOUR SEGMENT C ------------------------------------------ C GO TO 3000 ENDIF C PROVIDE EMERGENCY TERMINATION POINT FOR BEWILDERED CONTOURS 8999 CONTINUE C END OF CODE EXECUTED IF (SEGMENT NOT ALREADY INTEGRATED) ENDIF C CLOSE LOOP ON ALL CONTOUR SEGMENTS 9000 CONTINUE C C**************************************************************** C C BEGIN C CONNECTION OF CONTOUR SEGMENTS AND EDGE SEGMENTS TO CLOSE AREAS C 9001 LEVEL1=IBELOW(FMIN/DFCON) LEVEL2=IBELOW(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 IF (COLOR) THEN N=IHUE(NCOLOR,DFCON,FMIDLE,IFLIP,FCENTC) CALL TONCLR(N) IF (N.EQ.0) THEN C OUTLINE OFF-SPECTRUM (off_white) areas w/black KOLORC='black_____' SURROU=.TRUE. ELSE IF (N.GT.NCOLOR) THEN C OUTLINE OFF-SPECTRUM (gray) areas w/white KOLORC='white_____' SURROU=.TRUE. ELSE SURROU=.FALSE. C DO NOT SURROUND COLORED AREAS WITH CONTOURS ENDIF IF (ALLPOS.AND.FCENTR.LT.0.0) THEN SURROU=.FALSE. ENDIF ELSE N=IHUE(NGRAY,DFCON,FMIDLE,IFLIP,FCENTC) CALL TONCLR(N) SURROU=.TRUE. KOLORC='foreground' C MEANS SURROUND ALL AREAS WITH foreground 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= 'no line ' C Special code within CONTEL only; lift pen. 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 POLYGONS(XARRAY,YARRAY,NINARE,NAREAS,.FALSE.,.TRUE.) 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.'no line ') THEN JPEN=3 C LIFT PEN ELSE JPEN=2 C LOWER PEN, POSSIBLY COLORED IF (COLOR.AND.(KOLORP.NE.LASTKO)) THEN CALL PENCLR(KOLORP) LASTKO=KOLORP CALL NEWPEN(IPEN) 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 CALL STROKE IF (COLOR) CALL PENCLR('foreground') RETURN END SUBROUTINE CONTEL 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=IBELOW(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 SUBROUTINE DOSIDE 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=IBELOW(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 SUBROUTINE DOPART 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=IBELOW(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 SUBROUTINE DOLINE C C C INTEGER FUNCTION IHUE (NCOLOR,CINT,FMIDLE,IFLIP,F) C C RETURNS ORDINAL NUMBER OF COLOR ASSOCIATED WITH FUNCTION VALUE 'F' C WHEN CONTOURED WITH INTERVAL 'CINT', AND WHEN VALUE 'FMIDLE' IS C IN THE CENTER OF THE SPECTRUM. C IF IFLIP=+1, BLUE/FORE GOES WITH LOW VALUES AND RED/BACK WITH HIGH; C IF IFLIP=-1, RED/BACK GOES WITH LOW VALUES AND BLUE/FORE WITH HIGH. C VALUES WHICH GO OUT OF RANGE ARE REPORTED AS 0 OR (NCOLOR+1). C C NOTE: TO USE THIS FUNCTION IN B/W MODE, USE NGRAY AS THE C ACTUAL PARAMETER IN PLACE OF NCOLOR. C REAL FMP,STEPS C IF (MOD(NCOLOR,2).EQ.0) THEN C EVEN NUMBER OF COLORS IN SPECTRUM; C ROUND FMIDLE TO NEAREST CONTOUR LEVEL FMP=CINT*IBELOW((FMIDLE/CINT)+0.5) STEPS=IFLIP*(FMP-F)/CINT IHUE=STEPS+(NCOLOR/2.)+1.0 ELSE C ODD NUMBER OF COLORS IN SPECTRUM; C ROUND FMIDLE TO NEAREST MID-COLOR FMP=CINT*(0.5+IBELOW(FMIDLE/CINT)) STEPS=IFLIP*(FMP-F)/CINT IHUE=STEPS+(NCOLOR/2.)+1.0 END IF IHUE=MAX(IHUE,0) IHUE=MIN(IHUE,NCOLOR+1) RETURN END FUNCTION IHUE C C C SUBROUTINE GOPLOT (INPUT,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + PERLON,PERLAT, + XNODE,YNODE, + OUTPUT,DEGPEI,MAPTYP,XWIDE) 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 = GLOBAL 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, 3 FOR CONIC C (THE TWO MAIN CONFORMAL MAP OPTIONS) (FOR PLATES) C XWIDE = WIDTH OF THE PAPER, IN INCHES; USED TO ALIGN C SAMPLE VECTORS/FAULT SYMBOLS, ETC. EITHER 8.5 OR 11. C C (ALL THAT IS LEFT IS TO DRAW VECTORS, ETC. C AND TO PROVIDE THE HEADER LABELS.) C LOGICAL GREAT REAL LAT1,LAT1S,LAT2,LON1,LON1S,LON2,NLAT1,NLAT2 DIMENSION NODCON(MXBN),XNODE(MXNODE),YNODE(MXNODE) C C SELECT TYPE OF PROJECTION MAPTYP=3 C C SELECT PAGE WIDTH AND HEIGHT CALL PAGE (11.,8.5) 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: CALL PROJCT ('CONIC') C C SET CENTER POINT OF MAP PROJECTION C (FOR ALL BUT CONIC, THIS IS ALSO CENTER OF MAP) C CALL MAPOLE(PERLON,PERLAT) C CALL AREA2D (9.0,7.0) 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=.FALSE. IF (NCOND.GE.2) THEN CALL THKVEC (IPEN3+0.05) LAT1=YNODE(NODCON(1)) LON1=XNODE(NODCON(1)) LAT1S=LAT1 LON1S=LON1 DO 100 I=2,NCOND LAT2=YNODE(NODCON(I)) LON2=XNODE(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 SUBROUTINE GOPLOT 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 REAL ANGLE, DOT 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 SUBROUTINE RESIZE C C C REAL FUNCTION ROUND (X) C "SUBROUTINE" (for subprogram title search purposes) 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 FUNCTION ROUND 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 DIMENSION ERATE(3,7,NUMEL) C SUM=0. CCCC DO 100 M=1,7 M=1 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(EXY**2+0.25*(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 (MODESR.EQ.1) THEN SUM=SUM+BIGSHR**2 ELSEIF (MODESR.EQ.2) THEN SUM=SUM+BIGSHR ENDIF 90 CONTINUE CC100 CONTINUE CCCC SUM=SUM/7. IF (MODESR.EQ.1) THEN E3ME1M=SQRT(SUM/(1.*NUMEL)) ELSEIF (MODESR.EQ.2) THEN E3ME1M=SUM/(1.*NUMEL) ENDIF RETURN END SUBROUTINE SIZER C C C SUBROUTINE TONCLR (N) C C SETS CURRENT SHADING COLOR (IN COLOR MODE) OR C PATTERN (IN B/W MODE) BASED IN INPUT INTEGER C N = 1...NGRAY/NCOLOR, WHERE INCREASING VALUES GIVE C MORE GRAY OR MORE BLUE. C IF N = 0, off_white IS USED. C IF N > NGRAY/NCOLOR, 50% gray IS USED. C INTEGER, INTENT(IN):: N C IF (COLOR) THEN IF (N.LE.0) THEN CALL CHGCLR ('off_white_',.FALSE.,.TRUE.) ELSE IF (N.LE.NCOLOR) THEN CALL CHGCLR (COLNAM(N),.FALSE.,.TRUE.) ELSE CALL CHGCLR ('gray______',.FALSE.,.TRUE.) END IF ELSE C BLACK/WHITE MODE: CALL SETPAT (N) END IF C RETURN END SUBROUTINE TONCLR 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(V(1)**2+V(2)**2) X=ATAN2(EQUATO,V(3)) Y=ATAN2(V(2),V(1)) RETURN END SUBROUTINE VEC2XY C END MODULE MAPTOOLS C=================================================================== C PROGRAM PLATES2AI C C BY C PETER BIRD, C DEPARTMENT OF EARTH AND SPACE SCIENCES, C UNIVERSITY OF CALIFORNIA, LOS ANGELES, CALIFORNIA 90095-1567 C For version date see first FORMAT statement below. C C **** COMPATIBLE WITH 14 MAY 1998 VERSION OF "PLATES" **** C TAKES OUTPUT FROM A FINITE ELEMENT SIMULATION OF CONTINENTAL C DEFORMATION PERFORMED BY "PLATES" AND PLOTS UP TO 16 MAPS C OF THE VARIABLES IN COLOR OR BLACK-AND-WHITE AS POSTSCRIPT C FILES IN THE DIALECT READ AND EDITED BY ADOBE ILLUSTRATOR 4 C FOR WINDOWS (.AI FILES). C C USES FINITE ELEMENT GRID (AND ELEVATION/HEAT-FLOW/LAYER THICKNESS C DATA AT THE NODES) DATASET IDENTICAL TO THAT READ BY "PLATES"; C LIKE THAT PROGRAM, IT ALSO INTERPOLATES POSITIONS OF ELEMENT- C SIDE MIDPOINTS. THIS GRID IS READ FROM FORTRAN DEVICE NUMBER C "IUNITG". C C IN SOME CASES, THIS FINITE ELEMENT GRID MAY CONTAIN "FAKE" NODES C ALONG THE BOUNDARY, WHICH HAVE NO REAL DEGREES OF FREEDOM. C HOWEVER, IN THE SUBPROGRAM "EXTRAP" OF THIS GRAPHICS PACKAGE, C VALUES OF VARIABLES MUST BE FOUND AT THESE NODES AS WELL AS AT C OTHERS, BY SOLVING A LINER SYSTEM THAT INCLUDES THEM. IF THEY C WERE INCLUDED MERELY BY TACKING THEM ON AT THE END, THE C BANDWIDTH OF THE SYSTEM WOULD BE TERRIBLE! THEREFORE, IF C ANY EXTRAPOLATION OF VARIABLES IS CALLED FOR, THIS PROGRAM C WILL ATTEMPT TO READ AN INTEGER LIST FROM DEVICE "IUNITR" C WHICH WILL GIVE THE ALIAS (NEW NUMBER) OF EACH NODE AS C RENUMBERED TO REDUCE BANDWIDTH. UTILITY PROGRAM "NUMBER" C CAN BE USED TO GENERATE SUCH LISTS. C C USES STRATEGIC AND TACTICAL INPUT PARAMETERS IN C CARD FORMAT FROM DEVICE "IUNITP"; SHOULD CONFORM TO DATA USED C IN THE ORIGINAL RUN OF "PLATES"; PLOT CONTROLS ARE APPENDED C AT THE END OF THIS DATASET (WHERE "PLATES" WON'T READ THEM). C C OPTIONALLY READS BASE MAP FROM UNIT "IUNITM" C FOR INCLUSION IN PLOTS. C C READS THE VELOCITY SOLUTION (AT THE NODES ONLY) FROM C FORTRAN DEVICE NUMBER "IUNITV". C (NOTE: THIS INPUT IS NOT NEEDED FOR THE FIRST 9 PLOTS.) C---------------------------------------------------------------------- C C THIS PROGRAM WAS DEVELOPED WITH SUPPORT FROM THE UNIVERSITY OF C CALIFORNIA, THE UNITED STATES GEOLOGIC SURVEY, AND THE NATIONAL C SCIENCE FOUNDATION. IT IS IN THE PUBLIC DOMAIN, AND MAY BE COPIED C AND USED WITHOUT RESTRICTION. HOWEVER, SCIENTIFIC ETHICS AND C COURTESY REQUIRE THE SOURCE OF THE PROGRAM TO BE STATED IN ANY C RESULTING PUBLICATIONS. (THE AUTHOR WOULD ALSO LIKE TO BE INFORMED C OF THESE PROJECTS.) C---------------------------------------------------------------------- C USE SPHERE USE DISSPLA2AI USE VERSATEC2AI USE MAPTOOLS C C Choose source of IMSL: CCCC USE MSIMSL, ONLY: LSLPB C Note: MSIMSL is not provided. This is the Microsoft version C of the International Mathematics Subroutine Library. C Routine "LSLPB" is used to factor and solve a C positive-definate symmetric system with real coefficients C in banded symmetric storage form. USE Numerical_Libraries, ONLY: LSLPB C Note: Numerical_Libraries is not provided. C This is the DIGITAL Visual Fortran 5.0 Pro version of IMSL. 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=2500) C C MAXBN = MAXIMUM NUMBER OF BOUNDARY NODES (BOTH "REAL" AND "FAKE"). PARAMETER (MAXBN=500) C C MAXEL = MAXIMUM NUMBER OF CONTINUUM ELEMENTS (TRIANGLES). PARAMETER (MAXEL=1000) C C MAXFEL = MAXIMUM NUMBER OF FAULT ELEMENTS (LINE SEGMENTS); PARAMETER (MAXFEL=300) C C MAXATP = MAXIMUM NUMBER OF NODES WHICH MAY OVERLAP AT A FAULT- C INTERSECTION POINT. PARAMETER (MAXATP=20) C C MAXSTA = MAXIMUM NUMBER OF POINTS IN STATELINE MAPS: PARAMETER (MAXSTA=20000) C C NPTYPE = NUMBER OF TYPES OF PLOTS PRODUCED BY THIS PROGRAM PARAMETER (NPTYPE=16) C C--------------------------------------------------------------------- C TYPE STATEMENTS C C (NOTE: THE IMPLICIT TYPING OF I-N = INTEGER, AND A-H, O-Z = REAL C IS OBSERVED IN THIS PROGRAM. NO TYPES ARE STATED FOR SUCH NAMES.) C CHARACTER*80 TITLE1,TITLE2,TITLE3 C DOUBLE PRECISION V,VM C INTEGER lda, ncoda C Preceding are global variables used by ABCDrow, ABCDcol, etc. C C NOTE: THE FOLLOWING CAN BE MADE "INTEGER*2" IN VS-FORTRAN: INTEGER NODTYP C LOGICAL ALDONE,BRIEF,DOPLOT, + EMPTY,EOF,EVERYP,FIRST,NEEDDP,NEEDST,NEEDSV, + STATES,TABLES,USEALI,WILLEX C C NOTE: THE FOLLOWING ARRAYS COULD BE COMPRESSED WITH "LOGICAL*1" C IN VS-FORTRAN: LOGICAL CHECKE,CHECKF,CHECKN,DRAWST, + EDGETS,EDGEFS,FSLIPS,PULLED C C C--------------------------------------------------------------------- C DIMENSION STATMENTS C C DIMENSIONS USING PARAMETER MAXNOD: DIMENSION ATNODE(MAXNOD), + CHECKN(MAXNOD), DPBASE(MAXNOD), DQDTDA(MAXNOD), + ELEV (MAXNOD), IALIAS(MAXNOD), + IUSER (MAXNOD), + NODTYP(MAXNOD), TAUZZN(MAXNOD), TLNODE(MAXNOD), + u_flag(MAXNOD), + V (2,MAXNOD), VM (2,MAXNOD), + XNODE (MAXNOD), YNODE (MAXNOD), ZMNODE(MAXNOD) C C DIMENSIONS USING PARAMETER MAXBN: DIMENSION NODCON(MAXBN) C C DIMENSIONS USING PARAMETER MAXEL: DIMENSION ALPHA(3,3,7,MAXEL), AREA (MAXEL), CHECKE (MAXEL), + DETJ (7,MAXEL), DVB (7,MAXEL), + DXS (6,7,MAXEL), DYS (6,7,MAXEL), EDGETS(3,MAXEL), + ERATE (3,7,MAXEL), + GEOTHC (4,7,MAXEL), GEOTHM(4,7,MAXEL), + GLUE (7,MAXEL), NODES (6,MAXEL), + OVB (2,7,MAXEL), OUTSCA (7,MAXEL), + OUTVEC (2,7,MAXEL), PULLED (7,MAXEL), + SIGHB (2,7,MAXEL), SIGZZI (7,MAXEL), + TAUMAT (3,7,MAXEL), TAUZZI (7,MAXEL), + TLINT (7,MAXEL), TOFSET(3,7,MAXEL), + XIP (7,MAXEL), YIP (7,MAXEL), + ZMOHO (7,MAXEL), + ZTRANC(2,7,MAXEL) C C DIMENSIONS USING PARAMETER MAXFEL: DIMENSION CHECKF (MAXFEL), EDGEFS (2,MAXFEL), + FAZ (2,MAXFEL), FC (2,2,7,MAXFEL), FDIP (3,MAXFEL), + FIMUDZ(7,MAXFEL), FLEN (MAXFEL), + FPEAKS(2,MAXFEL), FSLIPS (MAXFEL), + FTAN (7,MAXFEL), FTSTAR(2,7,MAXFEL), NODEF (6,MAXFEL), + OFFSET (MAXFEL), ZTRANF(2,MAXFEL) C C DIMENSIONS USING PARAMETER MAXATP: DIMENSION LIST (MAXATP) C C DIMENSIONS USING PARAMETER MAXSTA: DIMENSION DRAWST(MAXSTA), + XST(MAXSTA),YST(MAXSTA) C C DIMENSIONS USING PARAMETER NPTYPE: DIMENSION CINT (NPTYPE), DOPLOT (NPTYPE), + FBLAND (NPTYPE), LOWBLU (NPTYPE) C C DIMENSIONS OF FIXED SIZE: DIMENSION ACREEP(2), ALPHAT(2), BCREEP(2), CCREEP(2), + CONDUC(2), DCREEP(2), RADIO(2), RHOBAR(2), + TEMLIM(2) DIMENSION VEKTOR(20) C C ARRAYS FOR LINEAR SYSTEMS USED FOR EXTRAPOLATION TO NODES: REAL, DIMENSION(:,:), ALLOCATABLE :: A1, A2 C C--------------------------------------------------------------------- C SHARED DATA C C THE FIXED VALUES OF THE POSITIONS, C WEIGHTS, AND NODAL FUNCTION VALUES AT THE INTEGRATION POINTS C IN THE ELEMENTS (BOTH 6-NODE PLANAR TRIANGLES AND 6-NODE FAULTS) C C DEFINE "PHI" (NODAL FUNCTIONS) AND "WEIGHT" (GAUSSIAN INTEGRATION C WEIGHTS) OF THE 6-NODE TRIANGULAR FINITE ELEMENT FOR THE C SEVEN INTEGRATION POINTS IN EACH ELEMENT, DEFINED BY INTERNAL C COORDINATES "POINTS(5,7)", WHERE POINTS(1-3,M)=S1-S3 OF C INTEGRATION POINT NUMBER M. (NOTE: POINTS(4,M)=POINTS(1,M) AND C POINTS(5,M)=POINTS(2,M), FOR PROGRAMMING CONVENIENCE, AS IN C SUBPROGRAM "DERIV".) C BECAUSE ALL OF THESE ARRAYS ARE FUNCTIONS OF INTERNAL C COORDINATES, THEY ARE NOT AFFECTED BY SCALING OR DEFORMATION OF C THE ELEMENTS. C DOUBLE PRECISION PHI,POINTS,WEIGHT DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) C C "PHI" CONTAINS THE VALUES OF THE 6 NODAL FUNCTIONS AT THE 7 C GAUSSIAN INTEGRATION POINTS (FOR AREA INTEGRALS) OF THE C TRIANGULAR ELEMENTS. DATA PHI / +-0.1111111111111111D0,-0.1111111111111111D0,-0.1111111111111111D0, + 0.4444444444444444D0, 0.4444444444444444D0, 0.4444444444444444D0, +-0.0525839022774079D0,-0.0280749439026853D0,-0.0280749439026853D0, + 0.1122997756107412D0, 0.8841342388612960D0, 0.1122997756107412D0, +-0.0280749439026853D0,-0.0525839022774079D0,-0.0280749439026853D0, + 0.1122997756107412D0, 0.1122997756107412D0, 0.8841342388612960D0, +-0.0280749439026853D0,-0.0280749439026853D0,-0.0525839022774079D0, + 0.8841342388612960D0, 0.1122997756107412D0, 0.1122997756107412D0, + 0.4743526114618935D0,-0.0807685938011933D0,-0.0807685938011933D0, + 0.3230743752047730D0, 0.0410358257309469D0, 0.3230743752047730D0, +-0.0807685938011933D0, 0.4743526114618935D0,-0.0807685938011933D0, + 0.3230743752047730D0, 0.3230743752047730D0, 0.0410358257309469D0, +-0.0807685938011933D0,-0.0807685938011933D0, 0.4743526114618935D0, + 0.0410358257309469D0, 0.3230743752047730D0, 0.3230743752047730D0/ C C "POINTS" CONTAINS THE INTERNAL COORDINATES (S1,S2,S3) OF THE 7 C GAUSSIAN INTEGRATION POINTS (FOR AREA INTEGRALS) OF THE C TRIANGULAR ELEMENTS. DATA POINTS / + 0.3333333333333333D0, 0.3333333333333333D0, 0.3333333333333333D0, + 0.3333333333333333D0, 0.3333333333333333D0, + 0.0597158733333333D0, 0.4701420633333333D0, 0.4701420633333333D0, + 0.0597158733333333D0, 0.4701420633333333D0, + 0.4701420633333333D0, 0.0597158733333333D0, 0.4701420633333333D0, + 0.4701420633333333D0, 0.0597158733333333D0, + 0.4701420633333333D0, 0.4701420633333333D0, 0.0597158733333333D0, + 0.4701420633333333D0, 0.4701420633333333D0, + 0.7974269866666667D0, 0.1012865066666667D0, 0.1012865066666667D0, + 0.7974269866666667D0, 0.1012865066666667D0, + 0.1012865066666667D0, 0.7974269866666667D0, 0.1012865066666667D0, + 0.1012865066666667D0, 0.7974269866666667D0, + 0.1012865066666667D0, 0.1012865066666667D0, 0.7974269866666667D0, + 0.1012865066666667D0, 0.1012865066666667D0/ C C "WEIGHT" IS THE GAUSSIAN WEIGHT (FOR AREA INTEGRALS) OF THE 7 C INTEGRATION POINTS IN EACH TRIANGULAR ELEMENT. DATA WEIGHT / 0.2250000000000000D0, + 0.1323941500000000D0, 0.1323941500000000D0, 0.1323941500000000D0, + 0.1259391833333333D0, 0.1259391833333333D0, 0.1259391833333333D0/ C C DEFINE "FPHI" (NODAL FUNCTIONS) C OF THE 6-NODE LINEAR FAULT ELEMENT FOR THE SEVEN C INTEGRATION POINTS IN EACH ELEMENT, DEFINED BY INTERNAL C COORDINATE "FPOINT(M=1-7)", WHICH CONTAINS THE RELATIVE POSITION C (FRACTIONAL LENGTH) OF THE INTEGRATION POINTS. C BECAUSE ALL OF THESE ARRAYS ARE FUNCTIONS OF INTERNAL C COORDINATES, THEY ARE NOT AFFECTED BY SCALING OR DEFORMATION OF C THE ELEMENTS. C DOUBLE PRECISION FPHI DIMENSION FPHI(6,7) C C "FPHI" CONTAINS THE VALUES OF THE 6 NODAL FUNCTIONS (ONE PER NODE) C AT EACH OF THESE 7 INTEGRATION POINTS IN THE FAULT ELEMENT. DATA FPHI/ + .92495670801042D0, .09919438397916D0,-.02415109198958D0, + .02415109198958D0,-.09919438397916D0,-.92495670801042D0, + .64569986028672D0, .45013147942656D0,-.09583133971328D0, + .09583133971328D0,-.45013147942656D0,-.64569986028672D0, + .28527776318152D0, .83528967363696D0,-.12056743681848D0, + .12056743681848D0,-.83528967363696D0,-.28527776318152D0, + 0.0D0, 1.0D0, 0.0D0, + 0.0D0, -1.0D0, 0.0D0, + -.12056743681848D0, .83528967363696D0, .28527776318152D0, + -.28527776318152D0,-.83528967363696D0, .12056743681848D0, + -.09583133971328D0, .45013147942656D0, .64569986028672D0, + -.64569986028672D0,-.45013147942656D0, .09583133971328D0, + -.02415109198958D0, .09919438397916D0, .92495670801042D0, + -.92495670801042D0,-.09919438397916D0, .02415109198958D0/ C C-------------------------------------------------------------------- C DATA STATEMENTS C C "DIPMAX" IS THE MAXIMUM DIP (FROM HORIZONTAL, IN DEGREES) FOR A C FAULT ELEMENT TO BE TREATED AS A DIP-SLIP FAULT, WITH TWO DEGREES C OF FREEDOM PER NODE-PAIR. AT STEEPER DIPS, THE DEGREE OF FREEDOM C CORRESPONDING TO OPENING OR CONVERGENCE OF THE OPPOSITE SIDES IS C ELIMINATED BY A CONSTRAINT EQUATION, AND THE FAULT IS TREATED AS C A VERTICAL STRIKE-SLIP FAULT. THIS ARBITRARY LIMIT IS NECESSARY C BECAUSE THE EQUATIONS FOR DIP-SLIP FAULTS BECOME SINGULAR AS THE C DIP APPROACHES 90 DEGREES. IN PRACTICE, IT IS BEST TO SPECIFY DIPS C AS EITHER (1) VERTICAL, OR (2) CLEARLY LESS THAN "DIPMAX", WITHIN C EACH FAULT ELEMENT. IF THE DIP VARIES WITHIN AN ELEMENT IN SUCH A C WAY THAT IT PASSES THROUGH THIS LIMIT WITHIN THE ELEMENT, THEN C THE REPRESENTATION OF THAT FAULT ELEMENT IN THE EQUATIONS MAY C BE INACCURATE. DATA DIPMAX /75./ C C THE FOLLOWING ARE THE FORTRAN INPUT AND OUTPUT DEVICE NUMBERS: C C "IUNITG"= DEVICE NUMBER ASSOCIATED WITH THE GRID INPUT FILE. DATA IUNITG /1/ C C "IUNITR"= DEVICE NUMBER ASSOCIATED WITH THE INTEGER ALIASES C (RE-NUMBERING) OF THE NODES OF THE FINITE ELEMENT GRID, C SUCH THAT FAKE NODES ARE TREATED AS REAL AND INCLUDED, C WHILE THE BANDWIDTH IS KEPT AT A REASONABLE VALUE. DATA IUNITR /2/ C C "IUNITP"= DEVICE NUMBER ASSOCIATED WITH THE PARAMETER INPUT FILE. C (NOTE: MAY EQUAL IUNITB.) DATA IUNITP /4/ C C "IUNITT"= DEVICE NUMBER ASSOCIATED WITH TEXT OUTPUT, INCLUDING C STATUS AND WARNING MESSAGES. C (NOTE! ON SOME SYSTEMS, SYSTEM ERR0R MESSAGES ARE ALWAYS C OUTPUT ON DEVICE 6. IF SO, THEN IUNITT SHOULD BE 6.) DATA IUNITT /6/ C C "IUNITV"= DEVICE NUMBER ASSOCIATED WITH VELOCITY SOLUTION FILE. DATA IUNITV /8/ C (NOTE: THIS FILE IS OPTIONAL FOR THE FIRST 8 PLOTS, BUT C REQUIRED FOR THE FINAL GROUP OF 7 PLOTS.) C C "IUNITM"= DEVICE NUMBER ASSOCIATED WITH BASEMAP. DATA IUNITM /9/ C (NOTE: THIS FILE IS OPTIONAL.) C C TABLES: ARE LENGTHY TABLES OF VELOCITY, STRAIN-RATE, STRESS WANTED? DATA TABLES /.FALSE./ C C--------------------------------------------------------------------- C C BEGINNING OF EXECUTABLE CODE C C C *** KLUDGE ALERT ************************************************* C CONVERSION OF PARAMETERS (CONSTANTS) TO VARIABLES SHOULD LOGICALLY C HAVE NO EFFECT, BUT IN FACT HELPS TO SUPPRESS SOME SPURIOUS C MESSAGES FROM THE IBM VS-FORTRAN COMPILER. MXNODE=MAXNOD MXEL =MAXEL MXFEL =MAXFEL MXBN =MAXBN MXSTAR=MAXATP MXSTAT=MAXSTA NTYPE =NPTYPE C ****************************************************************** C C------------------------------------------------------------------ C C WRITE IDENTIFYING BANNER TO USER SCREEN/OUTPUT FILE: C WRITE(IUNITT,1) 1 FORMAT(/' =====================================================' + /' Plates2AI' + /' for converting .FEG files from DrawGrid and' + /' FillGrid, and/or output from F-E code PLATES to' + /' Adobe Illustrator graphics files.' + /' by Peter Bird' + /' Dept. of Earth & Space Sciences' + /' University of California' + /' Los Angeles, CA 90095-1567' + /' version of 16 March 2000' + /' =====================================================') C WEDGE=ABS(90.-ABS(DIPMAX))*0.017453293 C C READ FINITE ELEMENT GRID AND RECONSTRUCT GEOMETRIC ARRAYS C C C INPUT FINITE ELEMENT GRID AND DATA VALUES AT NODE POINTS C CALL GETNET (INPUT,IUNITG,IUNITT, + MXBN,MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF,DQDTDA,ELEV,FAZ,FDIP, + NFAKEN,NFL,NODEF,NODES, + NREALN,NUMEL,NUMNOD,N1000,OFFMAX, + OFFSET,TITLE1,TLNODE,XNODE,YNODE,ZMNODE, + WORK,CHECKE,CHECKF,CHECKN) C C CHECK GRID TOPOLOGY AND COMPUTE GEOMETRIC PROPERTIES C CALL SQUARE (INPUT,BRIEF,FDIP,IUNITT, + MXBN,MXEL,MXFEL,MXNODE, + MXSTAR,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,WEDGE, + MODIFY,FAZ,XNODE,YNODE, + OUTPUT,AREA,DETJ,DXS,DYS,EDGEFS,EDGETS, + FLEN,FTAN,NCOND,NODCON, + WORK,CHECKN,LIST,NODTYP) C C READ SCALAR PARAMETERS C CALL READPM (INPUT,IUNITP, IUNITT, OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT , + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , GMEAN , + MAXITR, OKDELV, OKTOQT, ONEKM, RADIO , + REFSTR, RHOAST, RHOBAR, RHOH2O, + TEMLIM, TITLE3, TRHMAX, TSURF, $ NPTYPE, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,NCONTR, $ STATES,RMSVEC, $ SDENOM,XCENTR,YCENTR,PAPRE, $ IPEN1,IPEN2,IPEN3,COLOR, + RADIUS,CPNLAT,Y0NLAT,X0ELON) C C WILL EXTRAPOLATION OF VARIABLES BE DONE? C SHOULD ALIASES OF NODE NUMBERS BE USED TO REDUCE BANDWIDTH? C IF SO, READ THEM NOW. C WILLEX=DOPLOT( 6).OR.DOPLOT( 7).OR. + DOPLOT( 9).OR.DOPLOT(10).OR. + DOPLOT(13).OR.DOPLOT(15).OR. + DOPLOT(16) USEALI=WILLEX.AND.(NUMNOD.GT.NREALN) IF (USEALI) THEN WRITE (IUNITT,19) 19 FORMAT ( + /' ATTEMPTING TO READ DATASET OF THE INTEGER ALIASES'/ + ' (re-numbering) of the nodes of the finite element grid,'/ + ' in which fake nodes are treated as real and included,'/ + ' while the bandwidth is kept at a reasonable value;' + ' this file of aliases can be produced by NUMBER.'/) DO 20 I=1,NUMNOD READ (IUNITR,*) IALSO,IALIAS(I),IUSER(I) 20 CONTINUE ENDIF C C READ BASEMAP, IF DESIRED: C IF (STATES) THEN WRITE(IUNITT,80) IUNITM 80 FORMAT(//' Attempting to read BASEMAP (.DIG) FILE on unit ', + I3/) NXYSTB=0 FIRST=.TRUE. 90 CALL READM (INPUT,IUNITM,2, + OUTPUT,EMPTY,EOF,VEKTOR) IF (EOF) GO TO 101 IF (EMPTY) THEN FIRST=.TRUE. ELSE NXYSTB=NXYSTB+1 XST(NXYSTB)=VEKTOR(1) YST(NXYSTB)=VEKTOR(2) DRAWST(NXYSTB)=.NOT.FIRST FIRST=.FALSE. ENDIF IF (NXYSTB.LT.MXSTAT) THEN GO TO 90 ELSE WRITE (IUNITT,91) 91 FORMAT (/' INCREASE PARAMETER MAXSTA AND RECOMPILE.') STOP ENDIF 101 CONTINUE ELSE NXYSTB=0 ENDIF C C ARE NODAL VELOCITIES REQUIRED? IF SO, READ NOW: C NEEDSV=DOPLOT(10).OR.DOPLOT(11).OR.DOPLOT(12).OR. + DOPLOT(13).OR.DOPLOT(14).OR.DOPLOT(15).OR. + DOPLOT(16) IF (NEEDSV) THEN CALL OLDVEL (INPUT,IUNITV,MXNODE,NUMNOD, + OUTPUT,ALDONE,TITLE1,TITLE2,TITLE3,V) IF (ALDONE) THEN WRITE (IUNITT,895) IUNITV 895 FORMAT(/' UNABLE TO READ INITIALIZING SOLUTION ON UNIT' + ,I3/' VELOCITY, STRAIN-RATE, AND SLIP WILL BE ZERO.'/) DO 900 I=1,NUMNOD V(1,I)=0.0D0 V(2,I)=0.0D0 900 CONTINUE ELSE WRITE (IUNITT,905) IUNITV,TITLE1,TITLE2,TITLE3 905 FORMAT (/' Read precomputed solution from unit ',I3/ + ' Titles were:',3(/' ',A)/ /) ENDIF ELSE TITLE2=TITLE1 TITLE3=TITLE1 DO 906 I=1,NUMNOD V(1,I)=0.0D0 V(2,I)=0.0D0 906 CONTINUE ENDIF C C NOTE: This call to FILLIN is different from that in PLATES C because of added array parameter DPBASE(MXNODE), which C is used to preserve the computed pressure anomaly at C the base of the plate (at each node) for plotting. CALL FILLIN (INPUT,ACREEP,ALPHAT,BCREEP, + CCREEP,CONDUC,DQDTDA, + ECREEP,ELEV,GMEAN,IUNITT, + MXEL,MXNODE,NODES,NUMEL,NUMNOD,ONEKM, + RADIO,RHOAST,RHOBAR,RHOH2O,TEMLIM, + TLNODE,TRHMAX,TSURF,XNODE,YNODE,ZMNODE, + OUTPUT,DPBASE,GEOTHC,GEOTHM,GLUE,OVB,PULLED, + SIGZZI,TAUZZI,TAUZZN,TLINT,ZMOHO, + WORK,ATNODE) CALL INTERP (INPUT,XNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,XIP) CALL INTERP (INPUT,YNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,YIP) C C COMPUTE TACTICAL VALUES OF LIMITS ON VISCOSITY, AND WEIGHTS FOR C IMPOSITION OF CONSTRAINTS IN LINEAR SYSTEMS: C IF (NEEDSV) THEN CALL LIMITS (INPUT,AREA,DETJ,IUNITT,MXEL, + NUMEL,OKDELV,REFSTR,TLINT,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) ENDIF C C SET UP MATRIX FOR OPERATION OF EXTRAPOLATION FROM INTEGRATION C POINTS TO NODES, IF NECESSARY C IF (WILLEX) THEN NDIFF=0 DO 30 I=1,NUMEL I1=NODES(1,I) I2=NODES(2,I) I3=NODES(3,I) I4=NODES(4,I) I5=NODES(5,I) I6=NODES(6,I) IMAX=MAX(I1,I2,I3,I4,I5,I6) IMIN=MIN(I1,I2,I3,I4,I5,I6) NDIFF=MAX(NDIFF,(IMAX-IMIN)) 30 CONTINUE DO 40 I=1,NFL I1=NODEF(1,I) I2=NODEF(2,I) I3=NODEF(3,I) I4=NODEF(4,I) I5=NODEF(5,I) I6=NODEF(6,I) IMAX=MAX(I1,I2,I3,I4,I5,I6) IMIN=MIN(I1,I2,I3,I4,I5,I6) NDIFF=MAX(NDIFF,(IMAX-IMIN)) 40 CONTINUE ncoda = NDIFF lda = NUMNOD + ncoda ALLOCATE ( A1(lda,ncoda+2), A2(lda,ncoda+2) ) C CALL BUILDA (INPUT,AREA,DETJ,IALIAS, + NFL,NODEF, + NODES,NUMEL,NUMNOD,USEALI, + OUTPUT,A1) C ENDIF C C INITIALIZE SOLUTION-SPECIFIC ARRAYS (IF USED): C IF (NEEDSV) THEN CALL EDOT (INPUT,DXS,DYS,MXEL,MXNODE,NODES,NUMEL,V, + OUTPUT,ERATE) C C ARE STRESSES, VISCOSITIES, B/D TRANSITIONS NEEDED? NEEDST=DOPLOT(10).OR.DOPLOT(16) IF (NEEDST) THEN DO 920 M=1,7 DO 910 I=1,NUMEL SIGHB(1,M,I)=0. SIGHB(2,M,I)=0. TAUMAT(1,M,I)=0. TAUMAT(2,M,I)=0. TAUMAT(3,M,I)=0. 910 CONTINUE 920 CONTINUE CALL VISCOS(INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,DCREEP,ECREEP,ERATE, + CFRIC,GMEAN,GEOTHC,GEOTHM, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,TLINT, + VISMAX,ZMOHO, + OUTPUT,ALPHA,SCOREC,SCORED,TOFSET,ZTRANC) CALL TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) END IF DO 1000 I=1,NFL ZTRANF(1,I)=ZMNODE(NODEF(2,I))/2. ZTRANF(2,I)=TLNODE(NODEF(2,I))/2. 1000 CONTINUE CALL MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DQDTDA, + ECREEP,FDIP,FFRIC,FMUMAX,FTAN,GMEAN,MXFEL, + MXNODE,NFL,NODEF,OFFMAX,OFFSET,ONEKM, + RADIO,RHOH2O,RHOBAR,TLNODE,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) IF (TRHMAX.GT.0.0) THEN CALL THONB (INPUT,ECREEP,ETAMAX,GLUE, + MXEL,MXNODE, + NODES,NUMEL,NUMNOD, + OVB,PULLED,TRHMAX,V, + OUTPUT,DVB,SIGHB, + WORK,OUTVEC) ELSE DO 1090 M=1,7 DO 1080 I=1,NUMEL SIGHB(1,M,I)=0. SIGHB(2,M,I)=0. 1080 CONTINUE 1090 CONTINUE ENDIF IF (TABLES) THEN CALL RESULT + (INPUT,ALPHAT,ELEV,ERATE,FDIP,FIMUDZ,FPEAKS,FSLIPS, + FTAN,GEOTHC,IUNITT,MXEL,MXFEL,MXNODE, + NFL,NODEF,NODES,NREALN,NUMEL,NUMNOD,N1000, + ONEKM,RHOAST,RHOBAR,RHOH2O,SIGHB,TAUMAT,TAUZZI, + TLINT,TLNODE, + V,WEDGE,ZMNODE,ZMOHO,ZTRANC,ZTRANF) END IF ENDIF C CALL REPORT (INPUT,AREA,CINT,DETJ,DOPLOT,DPBASE, + DQDTDA,DRAWST,ELEV,ERATE, + FBLAND,FDIP,FLEN,FSLIPS,FTAN, + GEOTHC,GEOTHM,IALIAS, + IPEN1,IPEN2,IPEN3,IUNITT, + LOWBLU, + MXBN,MXEL,MXFEL,MXNODE, + NCOND,NCONTR,NFL,NODCON,NODEF, + NODES,MXSTAT,NTYPE, + NXYSTB,NUMEL,NUMNOD,OVB,PAPRE, + RMSVEC,SIGHB,STATES, + TAUMAT,TAUZZI, + TITLE1,TITLE2,TITLE3, + TEMLIM,TLINT,TLNODE, + u_flag,USEALI,V,WEDGE, + ZMNODE,ZMOHO, + MODIFY,XIP,XNODE,XST, + YIP,YNODE,YST, + OUTPUT,VM, + WORK,A2,ATNODE,OUTSCA,OUTVEC, + 999) C WRITE (IUNITT,999) 999 FORMAT (' *** ALL REQUESTED PLOTS COMPLETED. ***'/ + ' ==========================================================') C STOP ' ' C C====================================================================== CONTAINS C====================================================================== C C C SUBROUTINE EXTRAP (INPUT,A1,AREA,DETJ,IALIAS, + MXEL,MXNODE, + NODES,NUMNOD,NUMEL,USEALI, + u_flag,VALUES, + OUTPUT,FPOLES, + WORK,A2) C C SMOOTHS VALUES OF A SCALAR FIELD KNOWN AT THE INTEGRATION C POINTS (VALUES) TO PRODUCE VALUES AT THE NODES (FPOLES). C INTEGER I,K,KC,KR,M LOGICAL USEALI REAL VALDA DIMENSION AREA(MXEL),DETJ(7,MXEL),IALIAS(MXNODE), + FPOLES(MXNODE),NODES(6,MXEL), + u_flag(MXNODE),VALUES(7,MXEL) REAL,DIMENSION(:,:) :: A1, A2 C C MAKE A COPY OF THE FACTORED COEFFICIENT MATRIX (TO PROTECT ORIGINAL) C A2=A1 ! WHOLE MATRIX C C ZERO THE FORCING VECTOR C DO 200 I=1,NUMNOD KR=EFrow(I) KC=EFcol() A2(KR,KC)=0. 200 CONTINUE C C BUILD FORCING VECTOR AS AREA INTEGRAL OF NODAL FUNCTIONS TIMES C A SCALAR VARIABLE DEFINED AT THE INTEGRATION POINTS. C DO 800 M=1,7 DO 700 I=1,NUMEL VALDA=VALUES(M,I)*AREA(I)*DETJ(M,I)*WEIGHT(M) DO 600 J=1,6 IF (USEALI) THEN K=IALIAS(NODES(J,I)) ELSE K=NODES(J,I) ENDIF KR=EFrow(K) KC=EFcol() A2(KR,KC)=A2(KR,KC)+PHI(J,M)*VALDA 600 CONTINUE 700 CONTINUE 800 CONTINUE C CALL LSLPB (NUMNOD, A2, lda, ncoda, 1, u_flag) C Usage: C CALL LSLPB (N, A, LDA, NCODA, IJOB, U) C Arguments: C N = Order of the matrix. (Input) C Must satisfy N > 0. C A = Array containing the N by N positive definite band coefficient C matrix and right hand side in MS-IMSL's C codiagonal band symmetric storage mode. (Input/Output) C The number of array columns must be at least NCODA + 2. C The number of columns is not an input to this subprogram. C LDA = Leading dimension of A exactly as specified in the C dimension statement of the calling program. (Input) C Must satisfy LDA >= N + NCODA. C NCODA = Number of upper codiagonals of matrix A. (Input) C Must satisfy NCODA >= 0 and NCODA < N. C IJOB = Flag to direct the desired factorization or solving step. C IJOB Meaning: C 1 factor the matrix A and solve the system Ax = b, where b is C stored in column NCODA + 2 of array A. C The vector x overwrites b in storage. C 2 solve step only. Use b as column NCODA + 2 of A. (The C factorization step has already been done.) C The vector x overwrites b in storage. C 3 factor the matrix A but do not solve a system. C 4,5,6 same meaning as with the value IJOB - 3. For efficiency, no C error checking is done on values LDA, N, NCODA, and U(*). C U = Array of flags that indicate any singularities of A, namely loss C of positive-definiteness of a leading minor. (Output) C A value U(I) = 0. means that the leading minor of dimension I is C not positive-definite. Otherwise, U(I) = 1. C Comments: C Automatic workspace usage is: NCODA real numbers. C C UNPACK SOLUTION FROM A2 EXTENDED MATRIX C DO 850 I=1,NUMNOD KR=EFrow(I) KC=EFcol() FPOLES(I)=A2(KR,KC) 850 CONTINUE C C CONVERT BACK TO OLD NODE NUMBERS, IF NEEDED C IF (USEALI) THEN DO 900 I=1,NUMNOD KR=EFrow(IALIAS(I)) KC=EFcol() FPOLES(I)=A2(KR,KC) 900 CONTINUE ENDIF C RETURN END SUBROUTINE EXTRAP C C C SUBROUTINE INTERP (INPUT,FPOLES,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,VALUES) C C INTERPOLATES SCALAR FROM NODES TO INTEGRATION POINTS C INTEGER I,K,M DIMENSION FPOLES(MXNODE),NODES(6,MXEL), + VALUES(7,MXEL) C DO 100 M=1,7 DO 10 I=1,NUMEL VALUES(M,I)=0. 10 CONTINUE 100 CONTINUE DO 200 K=1,6 DO 190 M=1,7 DO 180 I=1,NUMEL VALUES(M,I)=VALUES(M,I)+FPOLES(NODES(K,I))* + PHI(K,M) 180 CONTINUE 190 CONTINUE 200 CONTINUE RETURN END SUBROUTINE INTERP C C C SUBROUTINE GETSCA (INPUT,ATNODE,NODES,NUMEL,NUMNOD,UDLINK, + OUTPUT,OUTSCA) C C INTERPOLATES SCALAR FROM NODES TO POSITIONS GIVEN IN UDLINK C (ONE VALUE PER INTEGRATION POINT) C INTEGER I,IE,M REAL F1,F2,F3,F4,F5,F6,S1,S2,S3 DIMENSION ATNODE(NUMNOD),NODES(6,NUMEL),OUTSCA(7,NUMEL), + UDLINK(3,7,NUMEL) C STATEMENT FUNKTION: PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) C DO 1000 M=1,7 DO 900 I=1,NUMEL IE=UDLINK(1,M,I) S2=UDLINK(2,M,I) S3=UDLINK(3,M,I) S1=1.00-S2-S3 F1=ATNODE(NODES(1,IE)) F2=ATNODE(NODES(2,IE)) F3=ATNODE(NODES(3,IE)) F4=ATNODE(NODES(4,IE)) F5=ATNODE(NODES(5,IE)) F6=ATNODE(NODES(6,IE)) OUTSCA(M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE GETSCA C C C SUBROUTINE GETVEC (INPUT,VECNOD,NODES,NUMEL,NUMNOD,UDLINK, + OUTPUT,OUTVEC) C C INTERPOLATES VECTOR FROM NODES TO POSITIONS GIVEN IN UDLINK C (ONE VALUE PER INTEGRATION POINT) C INTEGER I,IE,I1,I2,I3,M REAL F1,F2,F3,F4,F5,F6,S1,S2,S3 DIMENSION VECNOD(2,NUMNOD),NODES(6,NUMEL),OUTVEC(2,7,NUMEL), + UDLINK(3,7,NUMEL) C STATEMENT FUNKTION: PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) C DO 1000 M=1,7 DO 900 I=1,NUMEL IE=UDLINK(1,M,I) I1=NODES(1,IE) I2=NODES(2,IE) I3=NODES(3,IE) I4=NODES(4,IE) I5=NODES(5,IE) I6=NODES(6,IE) S2=UDLINK(2,M,I) S3=UDLINK(3,M,I) S1=1.00-S2-S3 F1=VECNOD(1,I1) F2=VECNOD(1,I2) F3=VECNOD(1,I3) F4=VECNOD(1,I4) F5=VECNOD(1,I5) F6=VECNOD(1,I6) OUTVEC(1,M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) F1=VECNOD(2,I1) F2=VECNOD(2,I2) F3=VECNOD(2,I3) F4=VECNOD(2,I4) F5=VECNOD(2,I5) F6=VECNOD(2,I6) OUTVEC(2,M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE GETVEC C C C SUBROUTINE BUILDA (INPUT,AREA,DETJ,IALIAS, + NFL,NODEF, + NODES,NUMEL,NUMNOD,USEALI, + OUTPUT,A) C C CREATES SMOOTHING MATRIX A (CROSS-PRODUCTS OF PHI) C INTEGER IALIAS,NFL,NODEF,NODES,NUMEL, + I,IR,I6,JC,J6,KC,KR,NODE LOGICAL USEALI REAL AREA,BIGEST,DETJ,SUM DIMENSION AREA(NUMEL),DETJ(7,NUMEL),IALIAS(NUMNOD), + NODEF(6,NFL),NODES(6,NUMEL) REAL, DIMENSION(:,:), INTENT(OUT) :: A C C BEGIN BY ZEROING C A = 0.0 ! WHOLE MATRIX C C MAIN CONTRIBUTION IS AREA INTEGRAL OF PRODUCTS OF NODAL FUNCTIONS C C NOTE THAT ONLY DIAGONAL AND UPPER-BAND TERMS ARE ADDED, C WHILE SYMMETRICAL LOWER BAND IS DISCARDED. C DO 100 I=1,NUMEL DO 90 I6=1,6 DO 80 J6=1,6 IF (USEALI) THEN IR=IALIAS(NODES(I6,I)) JC=IALIAS(NODES(J6,I)) ELSE IR=NODES(I6,I) JC=NODES(J6,I) ENDIF IF (IR.LE.JC) THEN SUM=0. DO 70 M=1,7 SUM=SUM+WEIGHT(M)*DETJ(M,I)* + PHI(I6,M)*PHI(J6,M) 70 CONTINUE KR=ABCDrow(JC) KC=ABCDcol(IR,JC) A(KR,KC)=A(KR,KC)+SUM*AREA(I) ENDIF 80 CONTINUE 90 CONTINUE 100 CONTINUE C C PREVENT SINGULARITY BY TYING DOWN BOUNDARY NODES WHICH MAY ONLY C BELONG TO FAULT ELEMENTS RUNNING ALONG THE BOUNDARY. C NOTE THAT IT DOESN'T MATTER HOW THESE ZERO EIGENVALUES ARE C REMOVED, BECAUSE THE VARIABLE VALUES AT SUCH NODES ARE C NEVER USED IN PLOTTING, AND THE FORCING-VECTOR ENTRIES C CORRESPONDING TO THEM ARE ALWAYS ZERO. C BIGEST=0.0 C FIND LARGEST DIAGONAL COEFFICIENT DO 110 I=1,NUMNOD KR=ABCDrow(I) KC=ABCDcol(I,I) BIGEST=MAX(BIGEST,A(KR,KC)) 110 CONTINUE C DO 200 I=1,NFL DO 190 I6=1,6 IF (USEALI) THEN NODE=IALIAS(NODEF(I6,I)) ELSE NODE=NODEF(I6,I) ENDIF KR=ABCDrow(NODE) KC=ABCDcol(NODE,NODE) IF (A(KR,KC).EQ.0.0) A(KR,KC)=BIGEST 190 CONTINUE 200 CONTINUE C RETURN END SUBROUTINE BUILDA C C C SUBROUTINE REPORT (INPUT,AREA,CINT,DETJ,DOPLOT,DPBASE, + DQDTDA,DRAWST,ELEV,ERATE, + FBLAND,FDIP,FLEN,FSLIPS,FTAN, + GEOTHC,GEOTHM,IALIAS, + IPEN1,IPEN2,IPEN3,IUNITT, + LOWBLU, + MXBN,MXEL,MXFEL,MXNODE, + NCOND,NCONTR,NFL,NODCON,NODEF, + NODES,MXSTAT,NTYPE, + NXYSTB,NUMEL,NUMNOD,OVB,PAPRE, + RMSVEC,SIGHB,STATES, + TAUMAT,TAUZZI, + TITLE1,TITLE2,TITLE3, + TEMLIM,TLINT,TLNODE, + u_flag,USEALI,V,WEDGE, + ZMNODE,ZMOHO, + MODIFY,XIP,XNODE,XST, + YIP,YNODE,YST, + OUTPUT,VM, + WORK,A2,ATNODE,OUTSCA,OUTVEC, + LAST) C C CREATES GRAPHICS OUTPUT FOR ALL REQUESTED VARIABLES IN THE C CURRENT ITERATION C PARAMETER (NPTYPE=16) C (SHOULD MATCH PARAMETER OF SAME NAME IN MAIN PROGRAM, AND C ALSO VARIABLE NTYPE IN THE CALL.) C CHARACTER*42 TEXT,VUNITS CHARACTER*80 TITLE1,TITLE2,TITLE3 DOUBLE PRECISION V,VM,VMAG2 INTEGER I,M LOGICAL ALLPOS,DOPLOT,DOAROW,DOESYM,DOAXES,DOFLTS, + DRAWST,FSLIPS,STATES,USEALI REAL DFCON,HDENOM,RMSVEC,TOPVEL,VDENOM,VMAGNI, + XMAX,XMIN,YMAX,YMIN DIMENSION AREA(MXEL), + CINT(NTYPE),ATNODE(MXNODE), + DETJ(7,MXEL),DOPLOT(NTYPE), + DPBASE(MXNODE),DQDTDA(MXNODE), + DRAWST(MXSTAT),ELEV(MXNODE),ERATE(3,7,MXEL), + FBLAND(NTYPE),FDIP(3,MXFEL),FLEN(MXFEL), + FSLIPS(MXFEL),FTAN(7,MXFEL),GEOTHC(4,7,MXEL), + GEOTHM(4,7,NUMEL),IALIAS(MXNODE), + LOWBLU(NTYPE),NODCON(MAXBN), + NODEF(6,MXFEL),NODES(6,MXEL), + OUTSCA(7,MXEL),OUTVEC(2,7,MXEL), + OVB(2,7,MXEL),SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL),TAUZZI(7,MXEL), + TEMLIM(2),TLINT(7,MXEL),TLNODE(MXNODE), + u_flag(MXNODE), + V(2,MXNODE),VM(2,MXNODE), + XIP(7,MXEL),XNODE(MXNODE),XST(MXSTAT), + YIP(7,MXEL),YNODE(MXNODE),YST(MXSTAT), + ZMNODE(MXNODE),ZMOHO(7,MXEL) DIMENSION TEXT (NPTYPE),NVCHAR(NPTYPE), + VUNITS(NPTYPE),NVUCHR(NPTYPE) REAL, DIMENSION(:,:) :: A2 C GPB TITLES DATA TEXT(1)/'FINITE ELEMENT GRID '/ DATA NVCHAR(1)/19/ DATA TEXT(2)/'ELEVATION '/ DATA NVCHAR(2)/ 9/ DATA TEXT(3)/'HEAT-FLOW '/ DATA NVCHAR(3)/ 9/ DATA TEXT(4)/'CRUSTAL THICKNESS '/ DATA NVCHAR(4)/17/ DATA TEXT(5)/'MANTLE LITHOSPHERE THICKNESS '/ DATA NVCHAR(5)/28/ DATA TEXT(6)/'MOHO TEMPERATURE '/ DATA NVCHAR(6)/16/ DATA TEXT(7)/'TEMPERATURE AT BASE OF PLATE '/ DATA NVCHAR(7)/28/ DATA TEXT(8)/'PRESSURE ANOMALY AT BASE OF PLATE '/ DATA NVCHAR(8)/33/ DATA TEXT(9)/'VELOCITY BELOW BASE OF PLATE '/ DATA NVCHAR(9)/28/ 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 LAST ITERATION '/ DATA NVCHAR(12)/36/ DATA TEXT(13)/'SURFACE STRAIN-RATES '/ DATA NVCHAR(13)/20/ DATA TEXT(14)/'MEAN SLIP-RATE OF FAULTS '/ DATA NVCHAR(14)/24/ DATA TEXT(15)/'RATE OF PLATE THICKENING '/ DATA NVCHAR(15)/24/ DATA TEXT(16)/'STRESS ANOMALY AND SHEAR STRESS INTEGRALS '/ DATA NVCHAR(16)/41/ C DATA VUNITS( 1)/' '/ DATA NVUCHR( 1)/0/ DATA VUNITS( 2)/'m '/ DATA NVUCHR( 2)/1/ DATA VUNITS( 3)/'mW/m**2 '/ DATA NVUCHR( 3)/7/ DATA VUNITS( 4)/'km '/ DATA NVUCHR( 4)/2/ DATA VUNITS( 5)/'km '/ DATA NVUCHR( 5)/2/ DATA VUNITS( 6)/'C '/ DATA NVUCHR( 6)/1/ DATA VUNITS( 7)/'C '/ DATA NVUCHR( 7)/1/ DATA VUNITS( 8)/'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)/'N/m '/ DATA NVUCHR(16)/3/ C IF (LAST.NE.999) THEN WRITE(IUNITT,1) 1 FORMAT (/ /' WRONG NUMBER OF ARGUMENTS IN CALL TO ', + ' SUBPROGRAM REPORT.') STOP ENDIF IF (NTYPE.NE.NPTYPE) THEN WRITE (IUNITT,2) NTYPE 2 FORMAT(/ /' CORRECT PARAMETER NPTYPE IN SUBPROGRAM', + ' REPORT TO ',I3,' AND RECOMPILE.') STOP ENDIF C C DETERMINE HOW TO PLACE PLOT ON PAPER C XMIN=XNODE(1) YMIN=YNODE(1) XMAX=XMIN YMAX=YMIN DO 10 I=2,NUMNOD XMIN=MIN(XMIN,XNODE(I)) YMIN=MIN(YMIN,YNODE(I)) XMAX=MAX(XMAX,XNODE(I)) YMAX=MAX(YMAX,YNODE(I)) 10 CONTINUE HDENOM=(XMAX-XMIN)/((9.00)/39.37) VDENOM=(YMAX-YMIN)/((7.00)/39.37) TDENOM=MAX(HDENOM,VDENOM) IF ((SDENOM.GE.HDENOM).AND.(SDENOM.GE.VDENOM)) THEN WRITE (IUNITT,11) SDENOM 11 FORMAT (/' SCALE DENOMINATOR OF', + 1P,E10.2,' WILL ALLOW DISPLAY OF WHOLE GRID.' + /' THE PLOT CENTER (XCENTR,YCENTR) WILL BE ' + ,'RECOMPUTED TO SHOW WHOLE GRID.') XCENTR=0.5*(XMAX+XMIN) YCENTR=0.5*(YMAX+YMIN) ELSE TDENOM=TDENOM*1.01 WRITE (IUNITT,12) SDENOM, TDENOM, XCENTR, YCENTR 12 FORMAT (/' SCALE DENOMINATOR OF',1P,E10.2 + ,' DOES NOT PERMIT DISPLAY OF WHOLE GRID.' + /' (MINIMUM DENOMINATOR REQUIRED WOULD BE ',E9.2,')' + /' PORTION DISPLAYED WILL DEPEND ON CENTER' + ,' COORDINATES (X, Y, in m), WHICH WERE:' + /' (',E9.2,',',E9.2,').') ENDIF C WRITE (IUNITT,99) 99 FORMAT (/ / + ' ----------------------------------------------------------') C C FINITE ELEMENT GRID: IF (DOPLOT(1)) THEN WRITE (IUNITT,101) 101 FORMAT (/' CREATING PLOT OF FINITE ELEMENT GRID...') CALL ETCH (DRAWST,FDIP,FLEN,FTAN,1,NTYPE,NFL, + MXBN,MXNODE,NCOND,NODCON, + NODEF,NODES,NUMEL,NUMNOD,NVCHAR,NXYSTB, + STATES,TEXT,TITLE1, + WEDGE, + XNODE,XST,YNODE,YST, + IPEN1,IPEN2,IPEN3,IUNITT) WRITE (IUNITT,199) 199 FORMAT (' PLOT OF FINITE ELEMENT GRID COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C ELEVATION: IF (DOPLOT(2)) THEN WRITE (IUNITT,201) 201 FORMAT (/' CREATING PLOT OF ELEVATION/BATHYMETRY...') ALLPOS=.FALSE. CALL INTERP (INPUT,ELEV,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,OUTSCA) DFCON=CINT(2) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ELEV,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,2,NTYPE, + ELEV,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,299) 299 FORMAT (' PLOT OF ELEVATION COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C HEAT FLOW: IF (DOPLOT(3)) THEN WRITE (IUNITT,301) 301 FORMAT (/' CREATING PLOT OF HEAT-FLOW...') C C Convert from W/m**2 to mW/m**2 C DFCON=CINT(3)*1000. IF (FBLAND(3).NE.0.0) FBLAND(3)=FBLAND(3)*1000. DO 310 I=1,NUMNOD ATNODE(I)=DQDTDA(I)*1000. 310 CONTINUE ALLPOS=.TRUE. CALL INTERP (INPUT,ATNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,OUTSCA) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,3,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,399) 399 FORMAT (' PLOT OF HEAT-FLOW COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C CRUSTAL THICKNESS: IF (DOPLOT(4)) THEN WRITE (IUNITT,401) 401 FORMAT (/' CREATING PLOT OF CRUSTAL THICKNESS...') C C CONVERT TO KM C DFCON=CINT(4)/1000. IF (FBLAND(4).NE.0.) FBLAND(4)=FBLAND(4)/1000. DO 410 I=1,NUMNOD ATNODE(I)=ZMNODE(I)/1000. 410 CONTINUE DO 430 M=1,7 DO 420 I=1,NUMEL OUTSCA(M,I)=ZMOHO(M,I)/1000. 420 CONTINUE 430 CONTINUE IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,4,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,499) 499 FORMAT (' PLOT OF CRUSTAL THICKNESS COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C MANTLE LITHOSPHERE THICKNESS (EXCLUDING CRUST): IF (DOPLOT(5)) THEN WRITE (IUNITT,501) 501 FORMAT(/' CREATING PLOT OF MANTLE LITHOSPHERE THICKNESS...') C C CONVERT TO KM C DFCON=CINT(5)/1000. IF (FBLAND(5).NE.0.) FBLAND(5)=FBLAND(5)/1000. DO 510 I=1,NUMNOD ATNODE(I)=TLNODE(I)/1000. 510 CONTINUE DO 530 M=1,7 DO 520 I=1,NUMEL OUTSCA(M,I)=TLINT(M,I)/1000. 520 CONTINUE 530 CONTINUE IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,5,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,599) 599 FORMAT (' PLOT OF MANTLE LITHOSPHERE THICKNESS COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C MOHO TEMPERATURE: IF (DOPLOT(6)) THEN WRITE (IUNITT,601) 601 FORMAT (/' CREATING PLOT OF MOHO TEMPERATURE...') CALL TMOHO (INPUT,GEOTHC,NUMEL,TEMLIM(1),ZMOHO, + OUTPUT,OUTSCA) C C CONVERT TO CENTIGRADE C IF (FBLAND(6).NE.0.) FBLAND(6)=FBLAND(6)-273. DO 620 M=1,7 DO 610 I=1,NUMEL OUTSCA(M,I)=OUTSCA(M,I)-273. 610 CONTINUE 620 CONTINUE CALL EXTRAP (INPUT,A1,AREA,DETJ,IALIAS, + MXEL,MXNODE, + NODES,NUMNOD,NUMEL,USEALI, + u_flag,OUTSCA, + OUTPUT,ATNODE, + WORK,A2) DO 630 I=1,NUMNOD ATNODE(I)=MIN(ATNODE(I),TEMLIM(1)-273.) 630 CONTINUE C DFCON=CINT(6) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,6,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,699) 699 FORMAT (' PLOT OF MOHO TEMPERATURE COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C TEMPERATURE AT BASE OF PLATE: IF (DOPLOT(7)) THEN WRITE (IUNITT,701) 701 FORMAT (/' CREATING PLOT OF TEMPERATURE AT PLATE BASE...') CALL TMOHO (INPUT,GEOTHM,NUMEL,TEMLIM(2),TLINT, + OUTPUT,OUTSCA) C C CONVERT TO CENTIGRADE C IF (FBLAND(7).NE.0.) FBLAND(7)=FBLAND(7)-273. DO 720 M=1,7 DO 710 I=1,NUMEL OUTSCA(M,I)=OUTSCA(M,I)-273. 710 CONTINUE 720 CONTINUE CALL EXTRAP (INPUT,A1,AREA,DETJ,IALIAS, + MXEL,MXNODE, + NODES,NUMNOD,NUMEL,USEALI, + u_flag,OUTSCA, + OUTPUT,ATNODE, + WORK,A2) DO 730 I=1,NUMNOD ATNODE(I)=MIN(ATNODE(I),TEMLIM(2)-273.) 730 CONTINUE C DFCON=CINT(7) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,7,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,799) 799 FORMAT (' PLOT OF TEMPERATURE AT PLATE BASE COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C PRESSURE ANOMALY AT BASE OF PLATE: IF (DOPLOT(8)) THEN WRITE (IUNITT,801) 801 FORMAT (/' PLOTTING PRESSURE ANOMALY AT BASE OF PLATE...') DO 802 I=1,NUMNOD C Convert Pa to MPa of pressure anomaly at base of plate ATNODE(I)=DPBASE(I)/1.0E6 802 CONTINUE ALLPOS=.FALSE. CALL INTERP (INPUT,ATNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,OUTSCA) DFCON=CINT(8) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE1,TEXT,8,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,899) 899 FORMAT (' PLOT OF PRESSURE ANOMALY AT BASE OF PLATE ', + 'COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C SUB-PLATE VELOCITY: IF (DOPLOT(9)) THEN WRITE (IUNITT,901) 901 FORMAT (/' CREATING PLOT OF SUB-PLATE VELOCITY...') TOPVEL=0. DO 912 M=1,7 DO 911 I=1,NUMEL VMAGNI=SQRT((1.D0*OVB(1,M,I))**2+ + (1.D0*OVB(2,M,I))**2) TOPVEL=MAX(TOPVEL,VMAGNI) OUTSCA(M,I)=OVB(1,M,I) 911 CONTINUE 912 CONTINUE CALL EXTRAP (INPUT,A1,AREA,DETJ,IALIAS, + MXEL,MXNODE, + NODES,NUMNOD,NUMEL,USEALI, + u_flag,OUTSCA, + OUTPUT,ATNODE, + WORK,A2) DO 913 I=1,NUMNOD VM(1,I)=ATNODE(I) 913 CONTINUE DO 915 M=1,7 DO 914 I=1,NUMEL OUTSCA(M,I)=OVB(2,M,I) 914 CONTINUE 915 CONTINUE CALL EXTRAP (INPUT,A1,AREA,DETJ,IALIAS, + MXEL,MXNODE, + NODES,NUMNOD,NUMEL,USEALI, + u_flag,OUTSCA, + OUTPUT,ATNODE, + WORK,A2) DO 916 I=1,NUMNOD VM(2,I)=ATNODE(I) VMAG2=VM(1,I)**2+VM(2,I)**2 VMAGNI=SQRT(VMAG2) IF (VMAGNI.GT.TOPVEL) THEN VM(1,I)=VM(1,I)*TOPVEL/VMAGNI VM(2,I)=VM(2,I)*TOPVEL/VMAGNI ENDIF 916 CONTINUE C C CONVERT TO MM/YEAR C DFCON=CINT(9)*1000.*3.1558E7 IF (FBLAND(9).NE.0.) FBLAND(9)=FBLAND(9)*1000.*3.1558E7 CALL MAGNIN (INPUT,NUMNOD,VM, + OUTPUT,ATNODE) CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,VM, + OUTPUT,OUTVEC) DO 920 I=1,NUMNOD ATNODE(I)=ATNODE(I)*1000.*3.1558E7 920 CONTINUE DO 940 M=1,7 DO 930 I=1,NUMEL OUTVEC(1,M,I)=OUTVEC(1,M,I)*1000.*3.1558E7 OUTVEC(2,M,I)=OUTVEC(2,M,I)*1000.*3.1558E7 930 CONTINUE 940 CONTINUE C CALL MAGNIT (INPUT,NUMEL,OUTVEC, + OUTPUT,OUTSCA) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.TRUE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE2,TEXT,9,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,999) 999 FORMAT (' PLOT OF SUB-PLATE VELOCITY COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C SHEAR TRACTION ON PLATE BASE: IF (DOPLOT(10)) THEN WRITE (IUNITT,1001) 1001 FORMAT(/' CREATING PLOT OF SHEAR TRACTION ON PLATE BASE...') CALL MAGNIT (INPUT,NUMEL,SIGHB, + OUTPUT,OUTSCA) C C CONVERT TO MPA C DFCON=CINT(10)/1.E6 IF (FBLAND(10).NE.0.) FBLAND(10)=FBLAND(10)/1.E6 DO 1020 M=1,7 DO 1010 I=1,NUMEL OUTSCA(M,I)=OUTSCA(M,I)/1.E6 1010 CONTINUE 1020 CONTINUE C CALL EXTRAP (INPUT,A1,AREA,DETJ,IALIAS, + MXEL,MXNODE, + NODES,NUMNOD,NUMEL,USEALI, + u_flag,OUTSCA, + OUTPUT,ATNODE, + WORK,A2) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.TRUE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,10,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,SIGHB,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,1099) 1099 FORMAT (' PLOT OF SHEAR TRACTION ON PLATE BASE COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C SURFACE VELOCITY: IF (DOPLOT(11)) THEN WRITE (IUNITT,1101) 1101 FORMAT (/' CREATING PLOT OF SURFACE VELOCITY...') CALL MAGNIN (INPUT,NUMNOD,V, + OUTPUT,ATNODE) CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,V, + OUTPUT,OUTVEC) C C CONVERT TO MM/YEAR C DFCON=CINT(11)*1000.*3.1558E7 IF (FBLAND(11).NE.0.) FBLAND(11)=FBLAND(11)*1000.*3.1558E7 DO 1110 I=1,NUMNOD ATNODE(I)=ATNODE(I)*1000.*3.1558E7 1110 CONTINUE DO 1130 M=1,7 DO 1120 I=1,NUMEL OUTVEC(1,M,I)=OUTVEC(1,M,I)*1000.*3.1558E7 OUTVEC(2,M,I)=OUTVEC(2,M,I)*1000.*3.1558E7 1120 CONTINUE 1130 CONTINUE C CALL MAGNIT (INPUT,NUMEL,OUTVEC, + OUTPUT,OUTSCA) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.TRUE. DOAROW=.TRUE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.TRUE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,11,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,1199) 1199 FORMAT (' PLOT OF SURFACE VELOCITY COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C VELOCITY CHANGES IF (DOPLOT(12)) THEN WRITE (IUNITT,1299) 1299 FORMAT (' VELOCITY CHANGES ARE ONLY PLOTTED BY GDDMCOMP.'/ + ' ----------------------------------------------------------') ENDIF C C STRAIN RATES: IF (DOPLOT(13)) THEN WRITE (IUNITT,1301) 1301 FORMAT (/' CREATING PLOT OF SURFACE STRAIN-RATES...') ALLPOS=.TRUE. CALL MAXER (INPUT,ERATE,NUMEL, + OUTPUT,OUTSCA) CALL EXTRAP (INPUT,A1,AREA,DETJ,IALIAS, + MXEL,MXNODE, + NODES,NUMNOD,NUMEL,USEALI, + u_flag,OUTSCA, + OUTPUT,ATNODE, + WORK,A2) DFCON=CINT(13) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.TRUE. DOAXES=.FALSE. DOFLTS=.TRUE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,13,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,1399) 1399 FORMAT (' PLOT OF SURFACE STRAIN-RATES COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C FAULT SLIP RATES: IF (DOPLOT(14)) THEN IF (NFL.LE.0) THEN WRITE(IUNITT,1401) 1401 FORMAT (/' NOTE: PLOT OF FAULT SLIP RATES WAS', + ' REQUESTED, BUT'/' THERE ARE NO FAULT ELEMENTS,' + /' SO THIS PLOT WILL BE OMITTED.') ELSE WRITE (IUNITT,1402) 1402 FORMAT (/' CREATING PLOT OF FAULT SLIP RATES...') CALL SLIPS (DRAWST,FDIP,FLEN,FSLIPS,FTAN,14,NTYPE, + MXBN,MXNODE,NCOND,NODCON, + NODEF,NODES,NFL,NUMEL,NUMNOD,NVCHAR, + NXYSTB, + RMSVEC,STATES,TEXT,TITLE3,V,WEDGE, + XNODE,XST,YNODE,YST, + IPEN1,IPEN2,IPEN3,IUNITT) WRITE (IUNITT,1499) 1499 FORMAT (' PLOT OF FAULT SLIP-RATES COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF ENDIF C C RATE OF PLATE THICKENING: IF (DOPLOT(15)) THEN WRITE (IUNITT,1501) 1501 FORMAT (/' CREATING PLOT OF PLATE THICKENING RATE...') DO 1520 M=1,7 DO 1510 I=1,NUMEL OUTSCA(M,I)= -ZMOHO(M,I)*(ERATE(1,M,I)+ + ERATE(2,M,I)) 1510 CONTINUE 1520 CONTINUE C C CONVERT TO MM/YEAR C DFCON=CINT(15)*1000.*3.1558E7 IF (FBLAND(15).NE.0.) FBLAND(15)=FBLAND(15)*1000.*3.1558E7 DO 1540 M=1,7 DO 1530 I=1,NUMEL OUTSCA(M,I)=OUTSCA(M,I)*1000.*3.1558E7 1530 CONTINUE 1540 CONTINUE C CALL EXTRAP (INPUT,A1,AREA,DETJ,IALIAS, + MXEL,MXNODE, + NODES,NUMNOD,NUMEL,USEALI, + u_flag,OUTSCA, + OUTPUT,ATNODE, + WORK,A2) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) ALLPOS=.FALSE. DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.FALSE. DOFLTS=.TRUE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,15,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,1599) 1599 FORMAT (' PLOT OF PLATE THICKENING RATE COMPLETED.'/ + ' ----------------------------------------------------------') ENDIF C C VERTICALLY-INTEGRATED STRESSES: IF (DOPLOT(16)) THEN WRITE (IUNITT,1601) 1601 FORMAT (/' CREATING PLOT OF INTEGRATED STRESS ANOMALIES...') ALLPOS=.TRUE. CALL MAXSS (INPUT,NUMEL,TAUMAT,TAUZZI, + OUTPUT,OUTSCA) CALL EXTRAP (INPUT,A1,AREA,DETJ,IALIAS, + MXEL,MXNODE, + NODES,NUMNOD,NUMEL,USEALI, + u_flag,OUTSCA, + OUTPUT,ATNODE, + WORK,A2) DFCON=CINT(16) IF (DFCON.LE.0.) + CALL INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) DOAROW=.FALSE. DOESYM=.FALSE. DOAXES=.TRUE. DOFLTS=.TRUE. CALL PAINT (NODES,XNODE,YNODE,TITLE3,TEXT,16,NTYPE, + ATNODE,DFCON,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMAT,TAUZZI, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) WRITE (IUNITT,1699) 1699 FORMAT (' PLOT OF INTEGRATED STRESS ANOMALIES COMPLETED.' + /' ----------------------------------------------------------') ENDIF RETURN END SUBROUTINE REPORT C C C SUBROUTINE STRAIN (ERATE,NUMEL,OUTVEC) C C CALCULATES LARGEST-MAGNITUDE PRINCIPAL STRAIN-RATE IN VECTOR FORM C NOTE THAT STRAIN WORKS WITH VPLOT TO PUT NEGATIVE VECTORS IN A-F C REAL ANGLE DIMENSION ERATE(3,7,NUMEL),OUTVEC(2,7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) CENTER=(EXX+EYY)*0.5 R=SQRT((1.D0*EXX-CENTER)**2+(1.D0*EXY)**2) IF (CENTER.GT.0.) THEN E=CENTER+R ANGLE=ATAN2F(EXY,E-EYY) IF (ANGLE.LE.1.308996.AND.ANGLE.GT.-1.832596) + ANGLE=ANGLE+3.141593 ELSE E=CENTER-R ANGLE=ATAN2F(EXY,E-EYY) IF (ANGLE.GT.1.308996.OR.ANGLE.LE.-1.832596) + ANGLE=ANGLE+3.141593 E= -E ENDIF OUTVEC(1,M,I)=E*COS(ANGLE) OUTVEC(2,M,I)=E*SIN(ANGLE) 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE STRAIN C C C SUBROUTINE STRESS (TAUMAT,TAUZZ,OUTVEC,NUMEL) C C CALCULATES LARGEST-MAGNITUDE HORIZONTAL PRINCIPAL C STRESS ANOMALY INTEGRAL, IN VECTOR FORM. C NOTE THAT STRESS WORKS WITH VPLOT TO PUT NEGATIVES IN A-F. C NOTE ALSO THAT THIS IS THE STRESS ANOMALY (WHICH INCLUDES THE C LOCAL VERTICAL STRESS ANOMALY INTEGRAL) NOT THE DEVIATORIC STRESS C (WHICH CONTROLS LOCAL STRAIN-RATE), SO SHOULD SATISFY EQUILIBRIUM. C REAL ANGLE DIMENSION OUTVEC(2,7,NUMEL),TAUMAT(3,7,NUMEL), + TAUZZ(7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL TXX=TAUMAT(1,M,I)+TAUZZ(M,I) TYY=TAUMAT(2,M,I)+TAUZZ(M,I) TXY=TAUMAT(3,M,I) CENTER=(TXX+TYY)*0.5 R=SQRT((1.D0*TXX-CENTER)**2+(1.D0*TXY)**2) IF (CENTER.GT.0.) THEN T=CENTER+R ANGLE=ATAN2F(TXY,T-TYY) IF (ANGLE.LE.1.308996.AND.ANGLE.GT.-1.832596) + ANGLE=ANGLE+3.141593 ELSE T=CENTER-R ANGLE=ATAN2F(TXY,T-TYY) IF (ANGLE.GT.1.308996.OR.ANGLE.LE.-1.832596) + ANGLE=ANGLE+3.141593 T= -T ENDIF OUTVEC(1,M,I)=T*COS(ANGLE) OUTVEC(2,M,I)=T*SIN(ANGLE) 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE STRESS C C C SUBROUTINE TMOHO (INPUT,GEOTH,NUMEL,TEMLIM,ZMOHO, + OUTPUT,OUTSCA) C C CALCULATES TEMPERATURE AT THE BASE OF CRUST BELOW INTEGRATION C POINTS C DIMENSION GEOTH(4,7,NUMEL),OUTSCA(7,NUMEL),ZMOHO(7,NUMEL) TEMP(Z,L,J)=MIN(TEMLIM,GEOTH(1,L,J) + +GEOTH(2,L,J)*Z + +GEOTH(3,L,J)*Z**2 + +GEOTH(4,L,J)*Z**3) DO 100 M=1,7 DO 90 I=1,NUMEL OUTSCA(M,I)=TEMP(ZMOHO(M,I),M,I) 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE TMOHO C C C SUBROUTINE HEAT (GEOTH,NUMEL,CONDUC,OUTSCA) + C C CALCULATES SURFACE HEAT-FLOW C DIMENSION CONDUC(2),GEOTH(4,7,NUMEL),OUTSCA(7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL OUTSCA(M,I)=GEOTH(2,M,I)*CONDUC(1) 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE HEAT C C C SUBROUTINE MAGNIT (INPUT,NUMEL,OUTVEC, + OUTPUT,OUTSCA) C C CONVERT VECTOR TO SCALAR MAGNITUDE AT INTEGRATION POINTS C INCLUDES OPTION TO MAKE MAGNITUDES OF RIGHT-POINTING C VECTORS BE NEGATIVE, "UNDOING" THE EFFECT OF VPLOT ON C PRINCIPAL-AXIS "VECTORS". C DIMENSION OUTSCA(7,NUMEL),OUTVEC(2,7,NUMEL) DO 10 M=1,7 DO 9 I=1,NUMEL OUTSCA(M,I)=SQRT((1.D0*OUTVEC(1,M,I))**2+ + (1.D0*OUTVEC(2,M,I))**2) 9 CONTINUE 10 CONTINUE RETURN END SUBROUTINE MAGNIT C C C SUBROUTINE MAGNIN (INPUT,NUMNOD,V, + OUTPUT,ATNODE) C C CONVERT VECTOR TO SCALAR MAGNITUDE AT NODES C DOUBLE PRECISION V DIMENSION ATNODE(NUMNOD),V(2,NUMNOD) DO 10 I=1,NUMNOD ATNODE(I)=SQRT(V(1,I)**2+V(2,I)**2) 10 CONTINUE RETURN END SUBROUTINE MAGNIN C C C SUBROUTINE INTRVL (INPUT,ATNODE,NCONTR,NUMEL,NUMNOD,OUTSCA, + OUTPUT,DFCON) C C COMPUTE CONTOUR INTERVAL ROUNDED TO NEAREST 1,2,3,4,5, X 10**P C LOGICAL MONOTO DIMENSION ATNODE(NUMNOD),OUTSCA(7,NUMEL) RLOW=9.9E37 RHI=-9.9E37 DO 20 M=1,7 DO 10 I=1,NUMEL RLOW=MIN(RLOW,OUTSCA(M,I)) RHI =MAX(RHI ,OUTSCA(M,I)) 10 CONTINUE 20 CONTINUE DO 30 I=1,NUMNOD RLOW=MIN(RLOW,ATNODE(I)) RHI =MAX(RHI ,ATNODE(I)) 30 CONTINUE SCALE=MAX(ABS(RHI-RLOW),ABS(RHI),ABS(RLOW)) IF (SCALE.EQ.0.) THEN DFCON=1.00 ELSE MONOTO=ABS(RHI-RLOW).LT.(0.01*SCALE) IF (MONOTO) THEN MCONTR=NCONTR/2 MCONTR=MAX(MCONTR,1) GUESS=SCALE/MCONTR IZERO=IBELOW(ALOG10(GUESS)) FACTOR=GUESS/10.**IZERO IFACTR=FACTOR+0.5 IFACTR=MIN(5,IFACTR) IF (FACTOR.GT.7.) IFACTR=10 DFCON=IFACTR*10.**IZERO ELSE GUESS=(RHI-RLOW)/NCONTR IZERO=IBELOW(ALOG10(GUESS)) FACTOR=GUESS/10.**IZERO IFACTR=FACTOR+0.5 IFACTR=MIN(5,IFACTR) IF (FACTOR.GT.7.) IFACTR=10 DFCON=IFACTR*10.**IZERO ENDIF ENDIF RETURN END SUBROUTINE INTRVL C C C SUBROUTINE MAXER (INPUT,ERATE,NUMEL, + OUTPUT,OUTSCA) C C FINDS LARGEST (ABS. VALUE) LINEAR STRETCH RATE IN THE TENSOR ERATE C AND ASSIGNS ITS SCALAR VALUE TO OUTSCA C INTEGER I,M,NUMEL REAL BIGSHR,DIVER,ERATE,EXX,EXY,EYY,E1,E2,EZ,OUTSCA,SHEAR DIMENSION ERATE(3,7,NUMEL),OUTSCA(7,NUMEL) C DO 100 M=1,7 DO 90 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) DIVER=EXX+EYY SHEAR=SQRT((1.D0*EXY)**2+0.25D0*(1.D0*EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR EZ= -DIVER BIGSHR=MAX(ABS(E1),ABS(E2),ABS(EZ)) OUTSCA(M,I)=BIGSHR 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE MAXER C C C SUBROUTINE MAXSS (INPUT,NUMEL,TAUMAT,TAUZZI, + OUTPUT,OUTSCA) C C FINDS LARGEST (ABS. VALUE) SHEAR STRESS INTEGRAL IN TENSOR TAUMAT C AND ASSIGNS ITS SCALAR VALUE TO OUTSCA C DIMENSION TAUMAT(3,7,NUMEL),TAUZZI(7,NUMEL),OUTSCA(7,NUMEL) C DO 100 M=1,7 DO 90 I=1,NUMEL TXX=TAUMAT(1,M,I)+TAUZZI(M,I) TYY=TAUMAT(2,M,I)+TAUZZI(M,I) TXY=TAUMAT(3,M,I) SHEAR=SQRT((1.D0*TXY)**2+0.25D0*(1.D0*TXX-TYY)**2) CENTER=(TXX+TYY)/2. T1=CENTER-SHEAR T2=CENTER+SHEAR TZ=TAUZZI(M,I) BIGSHR=MAX(SHEAR,ABS(T2-TZ)/2.,ABS(T1-TZ)/2.) OUTSCA(M,I)=BIGSHR 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE MAXSS C C C SUBROUTINE AREAS (INPUT,NODES,NUMEL,NUMNOD,XNODE,YNODE, 1 OUTPUT,AREA) C C COMPUTE AREAS OF ELEMENTS IN GRID AS IF THEY HAD STRAIGHT C SIDES. EFFECT OF SIDE CURVATURE WILL BE HANDLED LATER BY C MULTIPLYING BY DETERMINANT OF JACOBIAN MATRIX FOR THE SIDE- C BENDING MAPPING. NOTE THAT AREA MAY BE NEGATIVE, BUT ELEMENT C IS OK IF DETERMINANT IN DERIV IS ALSO NEGATIVE. C DIMENSION AREA(NUMEL),NODES(6,NUMEL),XNODE(NUMNOD),YNODE(NUMNOD) DO 100 I=1,NUMEL I1=NODES(1,I) I2=NODES(2,I) I3=NODES(3,I) AREA(I)= 0.5*(XNODE(I1)*YNODE(I2)-XNODE(I2)*YNODE(I1) + +XNODE(I2)*YNODE(I3)-XNODE(I3)*YNODE(I2) + +XNODE(I3)*YNODE(I1)-XNODE(I1)*YNODE(I3)) 100 CONTINUE RETURN END SUBROUTINE AREAS C C C SUBROUTINE DERIV (INPUT,AREA,NODES,NUMEL,NUMNOD,XNODE,YNODE, + OUTPUT,DETJ,DXS,DYS) C C CALCULATES DXS AND DYS, THE X-DERIVATIVE AND Y-DERIVATIVE C OF EACH OF THE 6 NODAL FUNCTIONS OF A DEFORMED-TRIANGLE C FINITE ELEMENT, AT EACH OF THE 7 INTEGRATION POINTS IN C THAT ELEMENT. ALSO PROVIDES DETJ, THE DETERMINANT OF THE C JACOBIAN MATRIX FOR THE TRANSFORMATION IN WHICH INTERNAL C POINTS OF A TRIANGLE WITH STRAIGHT SIDES ARE MAPPED INTO C NEW LOCATIONS AS SIDES BEND (BUT CORNERS STAY FIXED). C DIMENSION AREA(NUMEL),DETJ(7,NUMEL), + DXS(6,7,NUMEL),DYS(6,7,NUMEL), + NODES(6,NUMEL), + XNODE(NUMNOD),YNODE(NUMNOD) DIMENSION B(4),C(4),DN(6,2),X(6),Y(6) DO 500 I=1,NUMEL DO 100 J=1,6 NODE=NODES(J,I) X(J)=XNODE(NODE) Y(J)=YNODE(NODE) 100 CONTINUE B(1)=Y(2)-Y(3) B(2)=Y(3)-Y(1) B(3)=Y(1)-Y(2) B(4)=B(1) C(1)=X(3)-X(2) C(2)=X(1)-X(3) C(3)=X(2)-X(1) C(4)=C(1) AI2=1./(2.*AREA(I)) DO 400 M=1,7 DO 200 J=1,3 DN(J,1)=AI2*B(J)*(4.*POINTS(J,M)-1.) DN(J+3,1)=AI2*4.*(B(J)*POINTS(J+1,M) + +B(J+1)*POINTS(J,M)) DN(J,2)=AI2*C(J)*(4.*POINTS(J,M)-1.) DN(J+3,2)=AI2*4.*(C(J)*POINTS(J+1,M) + +C(J+1)*POINTS(J,M)) 200 CONTINUE AJ11=0. AJ12=0. AJ21=0. AJ22=0. DO 300 J=1,6 AJ11=AJ11+DN(J,1)*X(J) AJ12=AJ12+DN(J,1)*Y(J) AJ21=AJ21+DN(J,2)*X(J) AJ22=AJ22+DN(J,2)*Y(J) 300 CONTINUE DETJAC=AJ11*AJ22-AJ12*AJ21 DETJ(M,I)=DETJAC AJ11S=AJ11 AJ11=AJ22/DETJAC AJ12=-AJ12/DETJAC AJ21=-AJ21/DETJAC AJ22=AJ11S/DETJAC DO 350 J=1,6 DXS(J,M,I)=AJ11*DN(J,1)+AJ12*DN(J,2) DYS(J,M,I)=AJ21*DN(J,1)+AJ22*DN(J,2) 350 CONTINUE 400 CONTINUE 500 CONTINUE RETURN END SUBROUTINE DERIV C C C SUBROUTINE DIAMND (INPUT,ACREEP,ALPHAT,BCREEP, + BIOT,CCREEP,DCREEP, + ECREEP, + E1,E2,FRIC,G, + GEOTH1, + GEOTH2, + GEOTH3, + GEOTH4, + PL0,PW0, + RHOBAR,RHOH2O,SIGHBI, + THICK,TEMLIM, + VISMAX,ZOFTOP, + OUTPUT,PT1DE1,PT1DE2, + PT2DE1,PT2DE2, + PT1,PT2,ZTRAN) C C For one homogeneous layer (crust, OR mantle lithosphere), C computes the vertical integral through the layer of C horizontal principal stresses (relative to the vertical stress); C reports these as PT1 (more negative) and PT2 (more positive). C C Also reports ZTRAN, the depth into the layer of the brittle/ C ductile transition (greatest depth of earthquakes). C C Finally, recommends layer partial derivitives C PT1DE1, PT1DE2, PT2DE1, PT2DE2 C to be used in constructing ALPHA and TOFSET (in VISCOS), C according to strategy in pages 3973-3977 of Bird (1989). C In computing these, as in computing PT1 and PT2, the viscosity C limit VISMAX is applied to the average behavior of the whole C frictional layer, and again to the average behavior of the C whole creeping layer; it is not applied locally at each depth. C C Necessary conditions when calling DIAMND: C -> horizontal principal strain-rates E1 and E2 not both zero; C -> E2 >= E1; C -> layer thickness THICK is positive. C C Note special kludge: if friction FRIC is >2., then this is C taken to be a signal that no frictional layer is desired, C and that the whole layer should be power-law (or plastic, or C viscous-- whichever gives the least shear stress). C C New version, May 5, 1998, by Peter Bird; intended to improve C the convergence behavior of all F-E programs which use it. C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C External variables (*** all are scalars, even though C these same names may be arrays in other programs! ***): INTEGER INPUT REAL ACREEP, ALPHAT, BCREEP, BIOT, CCREEP, DCREEP, + ECREEP, E1, E2, FRIC, G, + GEOTH1, GEOTH2, GEOTH3, GEOTH4, + OUTPUT, PL0, PW0, + PT1, PT2, PT1DE1, PT1DE2, PT2DE1, PT2DE2, + RHOBAR, RHOH2O, SIGHBI, + THICK, TEMLIM, VISMAX, ZOFTOP, ZTRAN C External function (part of SPHERE): C REAL ATAN2F C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C Internal variables: INTEGER N, NVSTEP DOUBLE PRECISION SECINV REAL ANGAT2, ANGAT3, ANGLE, + DELNEG, DELPOS, DSFDEV, + DS1DE1, DS1DE2, DS2DE1, DS2DE2, + DT1DE1, DT1DE2, DT2DE1, DT2DE2, DZ, + E1AT1, E1AT2, E1AT3, E1AT4, + E2AT1, E2AT2, E2AT3, E2AT4, + ESCRIT, EZ, + FRAC, + GAMMA, GREAT, + PH2O, + R, RHOUSE, + SIGMA1, SIGMA2, S1EFF, S2EFF, S1REL, S2REL, + SC0, SCH, SC1, SF0, SFH, SF1, STFRIC, SZ, SZEFF, + TAU1, TAU2, TECN, TECS, TECT, TMEAN, TSFN, TSFS, TSFT, + T, T0, TH, T1, + VIS, VISDCR, VISINF, VISINT, VISMIN, VISSHB, + Z, Z0, ZH, Z1 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C C CHARACTERIZE THE STRAIN-RATE TENSOR: EZ= -(E1+E2) C (Formula for vertical strain-rate EZ comes from the C incompressibility of all permanent, anelastic strain types.) SECINV= -((1.D0*E1)*E2 + (1.D0*E1)*EZ + (1.D0*E2)*EZ) C (One possible form for the second invariant of the matrix.) C Note that the double-precision is just to prevent underflows C from squaring small strain rates, not for precision. VISINF=0.5*ACREEP*(2.*SQRT(SECINV))**(ECREEP-1.) C VISINF is the viscosity for dislocation creep, lacking only C the exponential term; therefore, as a mathematical abstraction, C we can say that it is the viscosity at infinite temperature. C C CHARACTERIZE THE CONTINUUM FRICTION: C STFRIC=SIN(ATAN(FRIC)) GAMMA=(1+STFRIC)/(1-STFRIC) C Note: For thrusting, effective-sigma1h is effective-sigma1z C times GAMMA. For normal faulting, effective-sigma2h C is effective-sigmaz/GAMMA. For small FRIC, GAMMA C is approximately equal to 1.+2.*FRIC C C FIND THE BRITTLE/DUCTILE TRANSITION (ZTRAN, measured from C the top of the layer): C C In the thrusting quadrant (E1<0, E2<0) and in the normal- C faulting quadrant (E1>0, E2>0) the brittle/ductile transtion C is clear: it the greatest depth of frictional behavior C (possibly including earthquakes) on any fault, which is also C the greatest depth of frictional behavior on the most active C fault set. C C However, in the strike-slip quadrant (E1<0, E2>0) the C transition is less clear. I do not know of any empirical C field study which has determined how the transition depth C depends on (E1+E2) within the transtensional and transpressional C wedges of the strain-rate field. Therefore, we have to choose C some simple rule. The rule that the transition is at the C greatest depth of frictional behavior on any fault would C create two discontinuities (at the E1=0 line, where normal C faulting appears/dissapears; and at the E2=0 line, where C strike-slip faulting appears/dissapears). Furthermore, the C transition depth near to these lines (on the deeper side) would C be defined by the less-active fault set, which asymptotically C becomes totally inactive as the line is approached! If we C chose the alternate rule of taking the deepest frictional C behavior on the most active fault set, we would still have C two discontinuities, although at different places, both within C the strike-slip quadrant. My F-E programs cannot converge well C when there is any discontinuity; therefore, I have chosen an C arbitrary rule which smooths the transition depth across each C of the transpressional and transtensional wedges, giving the C correct (unambiguous) depths on the lines E1=0, E1=-E2, and C E2=0. In order to do this, I apply SIN(2*theta) smoothing to C both the frictional parameter DSFDEV and also to the creep C parameter ESCRIT, and then compute the transition depth from C the combination of values. (I do this instead of smoothing C the depth itself because I have no formula for the transition C depth on any of these three lines, and would have to locate C it by additional numerical searches.) C C ESCRIT is the shear strain rate (tensor type, = C 0.5*(larger principal rate - smaller principal rate) C of the shear system which defines the transition C from the creep side (from below); C DSFDEV is the partial derivitive of the maximum shear C stress (on any plane) in the frictional domain C with respect to effective vertical stress C (vertical stress plus BIOT times water pressure). C IF (E1.GE.0.) THEN IF (E2.GE.0.) THEN C Normal-normal; faster E2 dominates. ESCRIT=0.5*(E2-EZ) DSFDEV=0.5*(1.-1./GAMMA) ELSE C (E1 >=0, E2 < 0) C E2 < E1? Should not happen! WRITE(*,"(/' Error: E1:',1P,E10.2,' > E2:', + E10.2)") E1,E2 STOP 'DIAMND detected incorrect INPUTs.' END IF ELSE C (E1 < 0) IF (E2.GE.0.) THEN C (E1 < 0, E2 >= 0) IF (EZ.GE.0.) THEN C Transpression (T/S). C Enforce smooth transition in DSFDEV C as the pure strike-slip line is approached. C (This smoothing cannot be with VISMAX because C ZTRAN is not yet known; instead, use a smooth C function of angle from origin of the C strain-rate plane, varying over 45 degrees C from the pure-strike-slip line E1=-E2 C to the pure-thrust line E2=0.) TSFT=0.5*(GAMMA-1.) TSFS=STFRIC C Note: One might expect TSFS=FRIC, but check on C a Mohr-circle diagram, remembering that the C pure strike-slip condition is EZ==0 -> C SZZEFF=0.5*(S1EFF+S2EFF). C Also remember that the "SF" in DSFDEV is not the C shear stress on the fault, but the maximum shear C stress, because this is what creep will attack and C lower first, at the brittle/ductile transition. ANGLE=ATAN2F(E2,E1) DSFDEV=TSFS+(TSFT-TSFS)*SIN(2.*(ANGLE-2.3561945)) C R=SQRT((1.D0*E1)**2+(1.D0*E2)**2) TECT=1. TECS=0.7071067 ESCRIT=R* + (TECS+(TECT-TECS)*SIN(2.*(ANGLE-2.3561945))) ELSE C (E1 < 0, E2 >= 0, EZ < 0) C Transtension (N/S). C Enforce smooth transition in DSFDEV C as the pure strike-slip line is approached. C (This smoothing cannot be with VISMAX because C ZTRAN is not yet known; instead, use a smooth C function of angle from origin of the C strain-rate plane, varying over 45 degrees C from the pure-strike-slip line E1=-E2 to the C pure-normal faulting line E1=0.) TSFN=0.5*(1.-1./GAMMA) TSFS=STFRIC C Note: One might expect TSFS=FRIC, but check on C a Mohr-circle diagram, remembering that the C pure strike-slip condition is EZ==0 -> C SZZEFF=0.5*(S1EFF+S2EFF). C Also remember that the "SF" in DSFDEV is not the C shear stress on the fault, but the maximum shear C stress, because this is what creep will attack and C lower first, at the brittle/ductile transition. ANGLE=ATAN2F(E2,E1) DSFDEV=TSFS+(TSFN-TSFS)*SIN(2.*(2.3561945-ANGLE)) C R=SQRT((1.D0*E1)**2+(1.D0*E2)**2) TECN=1. TECS=0.7071067 ESCRIT=R* + (TECS+(TECN-TECS)*SIN(2.*(2.3561945-ANGLE))) END IF ELSE C (E1 < 0, E2 < 0) C Thrust-thrust; faster (more negative) E1 dominates. ESCRIT=0.5*(EZ-E1) DSFDEV=0.5*(GAMMA-1.) END IF END IF C C Use ESCRIT and DSFDEV to locate ZTRAN (brittle/ductile trans.): C IF (FRIC.GT.2.) THEN C Special kludge; no frictional layer is wanted C (for models with a purely power-law or linear-viscous C rheology, you specify an unrealistically high friction. C This makes the transition occur at the surface, and C below the surface, the friction value is irrelevant.) ZTRAN=0. ELSE C Normal case; compute friction and creep at top and bottom: C Z0=0. SF0=DSFDEV*(PL0-BIOT*PW0) T0=MIN(TEMLIM,GEOTH1) SC0=2.*VISINF*EXP((BCREEP+CCREEP*ZOFTOP)/T0)*ESCRIT SC0=MIN(SC0,DCREEP) C Z1=THICK TMEAN=GEOTH1+ + 0.5*GEOTH2*Z1+ + 0.333*GEOTH3*Z1**2+ + 0.25*GEOTH4*Z1**3 RHOUSE=RHOBAR*(1.-ALPHAT*TMEAN) SF1=SF0+DSFDEV*(RHOUSE-BIOT*RHOH2O)*G*THICK T1=MIN(TEMLIM,GEOTH1+GEOTH2*Z1+GEOTH3*Z1**2+GEOTH4*Z1**3) SC1=2.*VISINF*EXP((BCREEP+CCREEP*(ZOFTOP+Z1))/T1)*ESCRIT SC1=MIN(SC1,DCREEP) SC1=MAX(SC1,SIGHBI) C C Check if whole layer is frictional: IF (SC1.GE.SF1) THEN ZTRAN=THICK C C Check if none of layer is frictional: ELSE IF (SC0.LE.SF0) THEN ZTRAN=0. C ELSE C Transition is within layer, between Z0 and Z1. C Use a binary-division search to bracket within C the nearest 1/128 of the layer (usually, within C 0.5 km); then, finish with linear interpolation. C Note ASSUMPTION: T increases montonically with z!!! C Also note that linearity may fail if the C power-law/DCREEP-limit transition falls into the C remaining interval; however, the error will be small. DO 100 N=1,7 ZH=0.5*(Z0+Z1) TMEAN=0.5*(T0+T1) RHOUSE=RHOBAR*(1.-ALPHAT*TMEAN) SFH=SF0+DSFDEV*(RHOUSE-BIOT*RHOH2O)*G*(ZH-Z0) TH=MIN(TEMLIM,GEOTH1+GEOTH2*ZH+GEOTH3*ZH**2+ + GEOTH4*ZH**3) SCH=2.*VISINF*EXP((BCREEP+CCREEP*(ZOFTOP+ZH))/TH) + *ESCRIT SCH=MIN(SCH,DCREEP) SCH=MAX(SCH,SIGHBI) IF (SCH.GT.SFH) THEN C Transition is between ZH and Z1. Z0=ZH SF0=SFH T0=TH SC0=SCH ELSE C Transition is between Z0 and ZH. Z1=ZH SF1=SFH T1=TH SC1=SCH END IF 100 CONTINUE DELNEG=SF0-SC0 DELPOS=SF1-SC1 FRAC= -DELNEG/(DELPOS-DELNEG) IF ((FRAC.LT.-0.01).OR.(FRAC.GT.1.01)) THEN WRITE(*,"(' WARNING: Failure to bracket ZTRAN', + ' within DIAMND')") END IF FRAC=MIN(1.,MAX(0.,FRAC)) ZTRAN=Z0+FRAC*(Z1-Z0) END IF END IF C C SUM TAU (AND DERIVITIVES) OVER FRICTIONAL AND CREEP LAYERS: C C Initialize sums over (up to) two layers: C -brittle layer at <= ZTRAN from the top; C -creeping layer at > ZTRAN from the top. PT1=0. PT2=0. PT1DE1=0. PT1DE2=0. PT2DE1=0. PT2DE2=0. C C COMPUTE AND ADD STRENGTH OF FRICTIONAL PART OF LAYER: C IF (ZTRAN.GT.0.) THEN C Compute the effective vertical stress at the midpoint C of the frictional layer: TMEAN=GEOTH1+ + 0.5*GEOTH2*(ZTRAN/2.)+ + 0.333*GEOTH3*(ZTRAN/2.)**2+ + 0.25*GEOTH4*(ZTRAN/2.)**3 RHOUSE=RHOBAR*(1.-ALPHAT*TMEAN) SZ= -PL0-RHOUSE*G*ZTRAN/2. PH2O=PW0+RHOH2O*G*ZTRAN/2. SZEFF=SZ+BIOT*PH2O C C Compute effective horizontal principal stresses, C and their derivitives with respect to E1 and E2, C at the midpoint of the frictional layer, according C to the methods in Bird (1989), pages 3973-3977 C (except, correcting the typos in the caption for C Figure 4): C C Define the corner points of the diamond in the C ordered principal strain-rate plane: E1AT1=((1./GAMMA)-1.)*SZEFF/(6.*VISMAX) E2AT1=E1AT1 E1AT2=(1.-(1./GAMMA))*SZEFF/(6.*VISMAX) E2AT2=((2./GAMMA)-2.)*SZEFF/(6.*VISMAX) E1AT3=(2.*GAMMA-2.)*SZEFF/(6.*VISMAX) E2AT3=(1.-GAMMA)*SZEFF/(6.*VISMAX) E1AT4=(GAMMA-1.)*SZEFF/(6.*VISMAX) E2AT4=E1AT4 ANGAT2=ATAN2F((E2-E2AT2),(E1-E1AT2)) ANGAT3=ATAN2F((E2-E2AT3),(E1-E1AT3)) C C Select proper segment of diagram and assign effective C principal stresses. C Also, begin definition of strategic stiffnesses C DS1DE1, DS1DE2, DS2DE1, and DS2DE2, by computing C stiffness required to give warning of local cliffs. C Afterward, basic minimum stiffness required to avoid C singularity of stiffness matrix will be imposed with C a formula common to all regions. IF (E1.GT.E1AT1) THEN C Region N/N: two conjugate sets of normal faults S1EFF=SZEFF/GAMMA S2EFF=S1EFF C DS1DE1=(0.5*((1/GAMMA)-1.)*SZEFF)/E1 DS1DE2=0. DS2DE1=0. DS2DE2=(0.5*((1/GAMMA)-1.)*SZEFF)/E2 ELSE IF ((E1.GE.E1AT2).AND. + (ANGAT2.GT.ATAN2F((E2AT1-E2AT2),(E1AT1-E1AT2)))) THEN C Region N: single conjugate set of normal faults S2EFF=SZEFF/GAMMA FRAC=(E1-E1AT1)/(E1AT2-E1AT1) C fraction increases in -E1 direction, from point 1 -> 2 S1EFF=SZEFF*((1/GAMMA)+FRAC*(1.-(1./GAMMA))) C DS1DE1=4.*VISMAX DS1DE2=0. DS2DE1=0. DS2DE2=0. ELSE IF ((ANGAT2.LE.1.9635).AND.(ANGAT2.GE.1.5707)) THEN C Region N/S: transtension, dominantly normal. S1EFF=SZEFF S2EFF=SZEFF/GAMMA C DS1DE1=(0.5*((1.-1/GAMMA))*SZEFF)/E1 DS1DE2=0. DS2DE1=0. DS2DE2=0. ELSE IF ((ANGAT2.LE.2.3562).AND.(ANGAT2.GE.1.9635)) THEN C Region S/N: transtension, dominantly strike-slip. S1EFF=SZEFF S2EFF=SZEFF/GAMMA C C GREAT is the value of DS1DE1 in region S: GREAT=6.*VISMAX*(GAMMA-1.)/(GAMMA-(1./GAMMA)) C FRAC is also defined exactly as in S, so here it C will be negative: FRAC=((E1+E2)-(E1AT2+E2AT2))/ + ((E1AT3+E2AT3)-(E1AT2+E2AT2)) C Reduce all derivitives according to distance: GREAT=GREAT*(-0.5)/(FRAC-0.5) C Pattern of derivitives is the same as in S: DS1DE1=GREAT DS1DE2=DS1DE1 DS2DE1=DS1DE1/GAMMA DS2DE2=DS2DE1 ELSE IF ((ANGAT3.LE.2.3562).AND. + (ANGAT3.GE.ATAN2F((E2AT2-E2AT3),(E1AT2-E1AT3)))) THEN C Region S: single set of conjugate strike-slip faults FRAC=((E1+E2)-(E1AT2+E2AT2))/ + ((E1AT3+E2AT3)-(E1AT2+E2AT2)) C FRAC increases across band from the S/N (point 2) side C toward the S/T (point 3) side; contours of FRAC are C parallel to the band sides, not normal to the diamond. S1EFF=SZEFF*(1.+FRAC*(GAMMA-1.)) S2EFF=SZEFF*((1./GAMMA)+FRAC*(1.-(1./GAMMA))) C Notes: The equation of this line is S2EFF=S1EFF/GAMMA. C I used algebra to check (98.4.21) that the C pure strike-slip stress (S1EFF,S2EFF)= C SZZEFF*(1.+STFRIC,1.-STFRIC) correctly falls on C this line, at the correct point (E1= -E2). C DS1DE1=6.*VISMAX*(GAMMA-1.)/(GAMMA-(1./GAMMA)) DS1DE2=DS1DE1 DS2DE1=DS1DE1/GAMMA DS2DE2=DS2DE1 ELSE IF ((ANGAT3.LE.2.7489).AND.(ANGAT3.GE.2.3562)) THEN C Region S/T: transpression; strike-slip dominant. S1EFF=SZEFF*GAMMA S2EFF=SZEFF C C GREAT is the value of DS1DE1 in region S: GREAT=6.*VISMAX*(GAMMA-1.)/(GAMMA-(1./GAMMA)) C FRAC is also defined exactly as in S, so here it C will be greater than one: FRAC=((E1+E2)-(E1AT2+E2AT2))/ + ((E1AT3+E2AT3)-(E1AT2+E2AT2)) C Reduce all derivitives according to distance: GREAT=GREAT*(0.5)/(FRAC-0.5) C Pattern of derivitives is the same as in S: DS1DE1=GREAT DS1DE2=DS1DE1 DS2DE1=DS1DE1/GAMMA DS2DE2=DS2DE1 ELSE IF ((E2.GE.E2AT3).AND.(ANGAT3.GE.2.7489)) THEN C Region T/S: transpression; thrusting dominant. S1EFF=SZEFF*GAMMA S2EFF=SZEFF C DS1DE1=0. DS1DE2=0. DS2DE1=0. DS2DE2=(0.5*(1.-GAMMA)*SZEFF)/E2 ELSE IF ((E2.GE.E2AT4).AND. + (ANGAT3.LE.ATAN2F((E2AT4-E2AT3),(E1AT4-E1AT3)))) THEN C Region T: single conjugate thrust fault set. S1EFF=SZEFF*GAMMA FRAC=(E2-E2AT3)/(E2AT4-E2AT3) C FRAC increases in the -E2 direction across the band. S2EFF=SZEFF*(1.+FRAC*(GAMMA-1.)) C DS1DE1=0. DS1DE2=0. DS2DE1=0. DS2DE2=4.*VISMAX ELSE IF (E2.LE.E2AT4) THEN C Region T/T: Two set of conjugate thrust faults. S1EFF=SZEFF*GAMMA S2EFF=S1EFF C DS1DE1=(0.5*(GAMMA-1.)*SZEFF)/E1 DS1DE2=0. DS2DE1=0. DS2DE2=(0.5*(GAMMA-1.)*SZEFF)/E2 ELSE C Region V: linear viscosity C Note that equations are now for SIGMA1,2 and no C longer for S1EFF and S2EFF. However, we can C easily compute both: SIGMA1=SZ+VISMAX*(4.*E1+2.*E2) SIGMA2=SZ+VISMAX*(2.*E1+4.*E2) S1EFF=SIGMA1+BIOT*PH2O S2EFF=SIGMA2+BIOT*PH2O C DS1DE1=0. DS1DE2=0. DS2DE1=0. DS2DE2=0. END IF C C Regardless of region, be sure that stiffnesses do C not fall below those which represent a minimum C effective viscosity-- one based on the weakest of C the active fault sets. This is to guaruntee that C the linear system will not have any zero eigenvalues, C even if a creeping layer does not exist. VISMIN=VISMAX IF ((E1.LT.0.).AND.(E2.GT.0.)) THEN C strike-slip faults are active VISMIN=MIN(VISMIN,0.5*(S2EFF-S1EFF)/(E2-E1)) END IF IF ((E1.LT.0.).AND.(EZ.GT.0.)) THEN C thrust faults are active VISMIN=MIN(VISMIN,0.5*(SZEFF-S1EFF)/(EZ-E1)) END IF IF ((E2.GT.0.).AND.(EZ.LT.0.)) THEN C normal faults are active VISMIN=MIN(VISMIN,0.5*(S2EFF-SZEFF)/(E2-EZ)) END IF DS1DE1=DS1DE1+4.*VISMIN DS1DE2=DS1DE2+2.*VISMIN DS2DE1=DS2DE1+2.*VISMIN DS2DE2=DS2DE2+4.*VISMIN C C Convert effective principal stresses at the midpoint C of the frictional layer into total principal stresses: SIGMA1=S1EFF-BIOT*PH2O SIGMA2=S2EFF-BIOT*PH2O C (Note that correcting S1 and S2 by a constant does not C affect the values of the derivitives DS1DE1...DS2DE2.) C C Convert total principal stresses at the midpoint of C the frictional layer into relative principal stresses C (relative to the total vertical stress, that is): S1REL=SIGMA1-SZ S2REL=SIGMA2-SZ C (Note that correcting S1 and S2 by a constant does not C affect the values of the derivitives DS1DE1...DS2DE2.) C C Convert values at midpoint of frictional layer to C integrals over the frictional layer: TAU1=S1REL*ZTRAN TAU2=S2REL*ZTRAN DT1DE1=DS1DE1*ZTRAN DT1DE2=DS1DE2*ZTRAN DT2DE1=DS2DE1*ZTRAN DT2DE2=DS2DE2*ZTRAN C C Add integrals over frictional layer to layer totals: PT1=PT1+TAU1 PT2=PT2+TAU2 PT1DE1=PT1DE1+DT1DE1 PT1DE2=PT1DE2+DT1DE2 PT2DE1=PT2DE1+DT2DE1 PT2DE2=PT2DE2+DT2DE2 END IF C (IF the frictional layer thickness ZTRAN > 0) C C COMPUTE AND ADD STRENGTH OF CREEPING PART OF LAYER: C IF (ZTRAN.LT.THICK) THEN C C Precompute the maximum viscosity limit imposed by the C requirement that creep shear stress never exceeds C DCREEP on any plane: VISDCR=DCREEP/(MAX(E1,E2,EZ)-MIN(E1,E2,EZ)) C C Precompute the lower viscosity limit imposed by the C requirement that creep shear stress does not C fall below SIGHBI: VISSHB=SIGHBI/(MAX(E1,E2,EZ)-MIN(E1,E2,EZ)) C C Compute the vertical integral of viscosity, C observing the local limit VISDCR, and terminating C the integral if creep shear stress falls below C SIGHBI (because then we are in a horizontally- C sheared boundary layer which does not contribute C anything to plate strength): C NVSTEP=50 DZ=(THICK-ZTRAN)/NVSTEP C VISINT=0. DO 200 N=0,NVSTEP Z=ZTRAN+N*DZ C Note that Z is measured from top of layer C (surface, or Moho) and may not be absolute depth. T=GEOTH1+GEOTH2*Z+GEOTH3*Z**2+GEOTH4*Z**3 T=MIN(T,TEMLIM) VIS=VISINF*EXP((BCREEP+CCREEP*(ZOFTOP+Z))/T) VIS=MIN(VIS,VISDCR) IF ((N.EQ.0).OR.(N.EQ.NVSTEP)) THEN FRAC=0.5 ELSE FRAC=1. END IF IF (VIS.LT.VISSHB) GO TO 201 VISINT=VISINT+FRAC*VIS*DZ 200 CONTINUE 201 CONTINUE C C Limit the mean viscosity of the creeping layer to C be no more than VISMAX: VISINT=MIN(VISINT,VISMAX*(THICK-ZTRAN)) C TAU1=4.*VISINT*E1+2.*VISINT*E2 TAU2=2.*VISINT*E1+4.*VISINT*E2 C Note that these principal values of TAU (the two C horizontal principal values, contributed by the C creeping layer only) are relative to TAUZZ, which C is the vertical integral of the vertical stress C anomaly through the creeping layer. C DT1DE1=4.*VISINT DT1DE2=2.*VISINT DT2DE1=2.*VISINT DT2DE2=4.*VISINT C C Add integrals over creeping layer to layer totals: PT1=PT1+TAU1 PT2=PT2+TAU2 PT1DE1=PT1DE1+DT1DE1 PT1DE2=PT1DE2+DT1DE2 PT2DE1=PT2DE1+DT2DE1 PT2DE2=PT2DE2+DT2DE2 END IF C (IF the creeping layer thickness (THICK-ZTRAN) > 0) C RETURN END SUBROUTINE DIAMND C C C SUBROUTINE EDOT (INPUT,DXS,DYS,MXEL,MXNODE,NODES,NUMEL,V, + OUTPUT,ERATE) C C COMPUTE STRAIN-RATE COMPONENTS EDOTXX, EDOTYY, AND C EDOTXY (TENSOR FORM; EQUAL TO C (1/2) * ((DVX/DY)+(DVY/DX)) C AT THE INTEGRATION POINTS OF TRIANGULAR CONTINUUM ELEMENTS. C DOUBLE PRECISION V DIMENSION DXS(6,7,MXEL),DYS(6,7,MXEL), + ERATE(3,7,MXEL),NODES(6,MXEL), + V(2,MXNODE) C DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=0. EYY=0. EXY=0. DO 800 J=1,6 NODE=NODES(J,I) VX=V(1,NODE) VY=V(2,NODE) DX=DXS(J,M,I) DY=DYS(J,M,I) EXX=EXX+VX*DX EYY=EYY+VY*DY EXY=EXY+(VX*DY+VY*DX)*0.5 800 CONTINUE ERATE(1,M,I)=EXX ERATE(2,M,I)=EYY ERATE(3,M,I)=EXY 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE EDOT C C C NOTE: This version of FILLIN is different from that in PLATES C because of added array parameter DPBASE(MXNODE), which C is used to preserve the computed pressure anomaly at C the base of the plate (at each node) for plotting. C SUBROUTINE FILLIN (INPUT,ACREEP,ALPHAT,BCREEP, + CCREEP,CONDUC,DQDTDA, + ECREEP,ELEV,GMEAN,IUNITT, + MXEL,MXNODE,NODES,NUMEL,NUMNOD,ONEKM, + RADIO,RHOAST,RHOBAR,RHOH2O,TEMLIM, + TLNODE,TRHMAX,TSURF, + XNODE,YNODE,ZMNODE, + OUTPUT,DPBASE,GEOTHC,GEOTHM,GLUE,OVB,PULLED, + SIGZZI,TAUZZI,TAUZZN,TLINT,ZMOHO, + WORK,ATNODE) C C PRECOMPUTE AND INTERPOLATE ALL "CONVENIENCE ARRAYS": C LOGICAL PULLED LOGICAL RESIST DIMENSION ACREEP(2),ALPHAT(2),ATNODE(MXNODE),BCREEP(2), + CCREEP(2),CONDUC(2),DPBASE(MXNODE), + DQDTDA(MXNODE),ELEV(MXNODE), + GEOTHC(4,7,MXEL),GEOTHM(4,7,MXEL), + GLUE(7,MXEL),NODES(6,MXEL), + OVB(2,7,MXEL),PULLED(7,MXEL),RADIO(2),RHOBAR(2), + SIGZZI(7,MXEL),TAUZZI(7,MXEL),TAUZZN(MXNODE), + TEMLIM(2),TLNODE(MXNODE), + TLINT(7,MXEL), + XNODE(MXNODE),YNODE(MXNODE), + ZMNODE(MXNODE),ZMOHO(7,MXEL) C C THICKNESS OF LAYERS: C CALL INTERP (INPUT,ZMNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,ZMOHO) CALL INTERP (INPUT,TLNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,TLINT) DO 2 M=1,7 DO 1 I=1,NUMEL TLINT(M,I)=MAX(TLINT(M,I),0.) 1 CONTINUE 2 CONTINUE C C GEOTHERM (STEADY-STATE, AND INTEGRATED STRICTLY FROM C INITIAL CONDITIONS ON TOP): C GEOTH1=TSURF GEOTH3= -0.5*RADIO(1)/CONDUC(1) GEOTH4=0. GEOTH7= -0.5*RADIO(2)/CONDUC(2) GEOTH8=0. DO 20 M=1,7 DO 10 I=1,NUMEL GEOTHC(1,M,I)=GEOTH1 Q=DQDTDA(NODES(1,I))*PHI(1,M)+ + DQDTDA(NODES(2,I))*PHI(2,M)+ + DQDTDA(NODES(3,I))*PHI(3,M)+ + DQDTDA(NODES(4,I))*PHI(4,M)+ + DQDTDA(NODES(5,I))*PHI(5,M)+ + DQDTDA(NODES(6,I))*PHI(6,M) GEOTHC(2,M,I)=Q/CONDUC(1) GEOTHC(3,M,I)=GEOTH3 GEOTHC(4,M,I)=GEOTH4 Z=ZMOHO(M,I) GEOTHM(1,M,I)=GEOTHC(1,M,I)+ + GEOTHC(2,M,I)*Z+ + GEOTHC(3,M,I)*Z**2+ + GEOTHC(4,M,I)*Z**3 DTDZC= GEOTHC(2,M,I)+ + 2.*GEOTHC(3,M,I)*Z+ + 3.*GEOTHC(4,M,I)*Z**2 DTDZM=DTDZC*CONDUC(1)/CONDUC(2) GEOTHM(2,M,I)=DTDZM GEOTHM(3,M,I)=GEOTH7 GEOTHM(4,M,I)=GEOTH8 10 CONTINUE 20 CONTINUE C C VERTICAL INTEGRALS OF VERTICAL STRESS ANOMALY C (RELATIVE TO A STANDARD PRESSURE CURVE, IN "SQUEEZ"): C DO 100 I=1,NUMNOD GEOTH2=DQDTDA(I)/CONDUC(1) GEOTH5=GEOTH1+ + GEOTH2*ZMNODE(I)+ + GEOTH3*ZMNODE(I)**2+ + GEOTH4*ZMNODE(I)**3 DTDZC= GEOTH2+ + 2.*GEOTH3*ZMNODE(I)+ + 3.*GEOTH4*ZMNODE(I)**2 GEOTH6=DTDZC*CONDUC(1)/CONDUC(2) CALL SQUEEZ (INPUT,ALPHAT,ELEV(I), + GEOTH1,GEOTH2,GEOTH3,GEOTH4, + GEOTH5,GEOTH6,GEOTH7,GEOTH8, + GMEAN, + IUNITT,ONEKM,RHOAST,RHOBAR,RHOH2O, + TEMLIM,ZMNODE(I),ZMNODE(I)+TLNODE(I), + OUTPUT,TAUZZN(I),ATNODE(I)) DPBASE(I)= -ATNODE(I) 100 CONTINUE CALL INTERP (INPUT,ATNODE,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,SIGZZI) CALL INTERP (INPUT,TAUZZN,MXEL,MXNODE,NODES,NUMEL, + OUTPUT,TAUZZI) C C COMPUTE STRENGTH OF SHEARING LAYER(S) IN DUCTILE LOWER CRUST, AND C MANTLE LITHOSPHERE, IF PRESENT: C CALL ONEBAR (INPUT,ACREEP,BCREEP,CCREEP, + ECREEP,GEOTHC,GEOTHM, + MXEL,NUMEL, + TEMLIM,TLINT,ZMOHO, + OUTPUT,GLUE) C C PRECOMPUTE VELOCITY OF THE TOP OF ASTHENOSPHERE/SLABS(?) C AND DETERMINE FOR EACH INTEGRATION POINT WHETHER IT IS ACTUALLY C PULLED BY A SUBDUCTED SLAB OR STRONG ASTHENOSPHERIC CURRENT. C DO 500 M=1,7 DO 490 I=1,NUMEL X=XNODE(NODES(1,I))*PHI(1,M)+ + XNODE(NODES(2,I))*PHI(2,M)+ + XNODE(NODES(3,I))*PHI(3,M)+ + XNODE(NODES(4,I))*PHI(4,M)+ + XNODE(NODES(5,I))*PHI(5,M)+ + XNODE(NODES(6,I))*PHI(6,M) Y=YNODE(NODES(1,I))*PHI(1,M)+ + YNODE(NODES(2,I))*PHI(2,M)+ + YNODE(NODES(3,I))*PHI(3,M)+ + YNODE(NODES(4,I))*PHI(4,M)+ + YNODE(NODES(5,I))*PHI(5,M)+ + YNODE(NODES(6,I))*PHI(6,M) TCX=0. TCY=0. CALL BOTTOM (INPUT,TRHMAX,TCX,TCY,X,Y, + OUTPUT,RESIST,OVB(1,M,I),OVB(2,M,I)) PULLED(M,I)=RESIST 490 CONTINUE 500 CONTINUE RETURN END SUBROUTINE FILLIN C C C SUBROUTINE FLOW (INPUT,NODES,NUMEL,NUMNOD,V, + OUTPUT,OUTVEC) C C CALCULATES VELOCITY VECTORS AT INTEGRATION POINTS, FROM NODAL VALUES C DOUBLE PRECISION V DIMENSION NODES(6,NUMEL),OUTVEC(2,7,NUMEL), + V(2,NUMNOD) DO 50 M=1,7 DO 40 I=1,NUMEL OUTVEC(1,M,I)=0. OUTVEC(2,M,I)=0. 40 CONTINUE 50 CONTINUE DO 100 J=1,6 DO 90 M=1,7 DO 80 I=1,NUMEL OUTVEC(1,M,I)=OUTVEC(1,M,I)+V(1,NODES(J,I)) + *PHI(J,M) OUTVEC(2,M,I)=OUTVEC(2,M,I)+V(2,NODES(J,I)) + *PHI(J,M) 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE FLOW C C C SUBROUTINE GETNET (INPUT,IUNIT7,IUNIT8, + MXBN,MXEL,MXFEL,MXNODE, + OUTPUT,BRIEF,DQDTDA,ELEV,FAZ,FDIP, + NFAKEN,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,OFFMAX,OFFSET, + TITLE1,TLNODE,XNODE,YNODE,ZMNODE, + WORK,CHECKE,CHECKF,CHECKN) C C READ FINITE ELEMENT GRID FROM UNIT "IUNIT7". C ECHO THE IMPORTANT VALUES TO A PRINT DATASET ON UNIT "IUNIT8". C CHARACTER*80 TITLE1 LOGICAL ALLOK,BRIEF REAL VECTOR C C NOTE: FOLLOWING TYPE COULD BE "LOGICAL*1" IN IBM VS-FORTRAN: LOGICAL CHECKE,CHECKF,CHECKN C C EXTERNAL ARRAYS: DIMENSION CHECKE(MXEL),CHECKF(MXFEL),CHECKN(MXNODE), + DQDTDA(MXNODE),ELEV(MXNODE), + FAZ(2,MXFEL),FDIP(3,MXFEL), + NODEF(6,MXFEL),NODES(6,MXEL),OFFSET(MXFEL), + TLNODE(MXNODE), + XNODE(MXNODE),YNODE(MXNODE),ZMNODE(MXNODE) C INTERNAL ARRAYS: DIMENSION DIPS(3),IFN(6),VECTOR(7) C WRITE (IUNIT8,1) IUNIT7 1 FORMAT (/' Attempting to read FINITE ELEMENT GRID from unit',I3/) TITLE1=' '// + ' ' READ (IUNIT7,2,IOSTAT=IOS) TITLE1 2 FORMAT (A80) WRITE (IUNIT8,3) TITLE1 3 FORMAT(/' Title of FINITE ELEMENT GRID ='/' ',A80) C C READ NUMBER OF NODES, AND HOW MANY ARE "REAL" VERSUS "FAKE". C INPUT NODAL LOCATIONS (X,Y), ELEVATIONS, HEAT-FLOW, AND ISOSTATIC C GRAVITY ANOMALIES (ONE RECORD PER NODE). C (OPTION "BRIEF" SUPPRESSES MOST OUTPUT) C READ (IUNIT7,*) NUMNOD,NREALN,NFAKEN,N1000,BRIEF C IF (NUMNOD.NE.(NREALN+NFAKEN)) THEN WRITE (IUNIT8,5) 5 FORMAT (/' INCONSISTENT DATA:'/ + ' NUMBER OF NODES SHOULD EQUAL TOTAL OF REAL', + ' NODES AND FAKE NODES.') STOP ENDIF IF (NUMNOD.GT.MXNODE) THEN WRITE (IUNIT8,10) NUMNOD 10 FORMAT(/' INCREASE PARAMETER MAXNOD TO BE AT LEAST' + /' THE NUMBER OF NODES (',I6,') AND RECOMPILE.') STOP ENDIF N2=2*NUMNOD IF (NREALN.GT.N1000) THEN WRITE (IUNIT8,20) NREALN 20 FORMAT (/' INCREASE THE DATA VALUE N1000 TO BE GREATER' + /' OR EQUAL TO NREALN (',I6,') AND RECOMPILE.') STOP ENDIF IF (NFAKEN.GT.MXBN) THEN WRITE (IUNIT8,30) NFAKEN 30 FORMAT(/' INCREASE THE PARAMETER MAXBN TO BE GREATER' + /' OR EQUAL TO NFAKEN (',I6,') AND RECOMPILE.') STOP ENDIF C NBASE=N1000+1 NTOP=N1000+NFAKEN IF (BRIEF) THEN WRITE (IUNIT8,35) 35 FORMAT(/' (SINCE OPTION BRIEF=.TRUE., GRID WILL NOT BE ', + 'ECHOED HERE. BE CAREFUL!!!)') ELSE WRITE (IUNIT8,40) NUMNOD,NREALN,NREALN 40 FORMAT (/' THERE ARE',I5,' NODES IN THE GRID:'/ ' ',I5, + ' OF THESE ARE NUMBERED 1-',I4,' AND THESE REAL NODES', + ' HAVE TWO VELOCITY VARIABLES UNLESS CONSTRAINED.') IF (NFAKEN.GT.0) WRITE (IUNIT8,42) NFAKEN,NBASE,NTOP 42 FORMAT(' ',I5, + ' OF THESE ARE NUMBERED ',I6,'-',I6,' AND THESE ARE', + ' ARTIFICIAL;'/' THEIR VELOCITIES MUST BE', + ' COMPLETELY SPECIFIED.') WRITE (IUNIT8,49) 49 FORMAT(/ + ' (NOTE: X AND Y COORDINATES MAY BE ZERO FOR NODES WHICH' + ,' WILL BE AT MIDPOINTS OF ELEMENT SIDES AND/OR FAULTS.'/ + ' THE PROGRAM WILL INTERPOLATE VALUES FOR THESE.)') WRITE (IUNIT8,50) 50 FORMAT (/' ', + ' MANTLE'/ + ' ', + ' CRUSTAL LITHOSPHERE'/ + ' NODE X Y ELEVATION ', + 'HEAT-FLOW THICKNESS THICKNESS'/) 55 FORMAT (' ',I10,1P,2E11.3,4E10.2) ENDIF DO 90 K=1,NUMNOD CHECKN(K)=.FALSE. 90 CONTINUE DO 100 K=1,NUMNOD CALL READN (INPUT,IUNIT7,IUNIT8,7, + OUTPUT,VECTOR) INDEX=VECTOR(1)+0.5 XI=VECTOR(2) YI=VECTOR(3) ELEVI=VECTOR(4) QI=VECTOR(5) ZMI=VECTOR(6) TLI=VECTOR(7) IF (INDEX.LE.NREALN) THEN I=INDEX ELSE I=INDEX-N1000+NREALN ENDIF CHECKN(I)=.TRUE. ELEV(I)=ELEVI DQDTDA(I)=QI IF (QI.LT.0.) THEN WRITE (IUNIT8,96) 96 FORMAT (' NEGATIVE HEAT-FLOW IS NON-PHYSICAL.') STOP ENDIF XNODE(I)=XI YNODE(I)=YI IF (ZMI.LT.0.) THEN WRITE (IUNIT8,97) 97 FORMAT(' NEGATIVE CRUSTAL THICKNESS IS NON-PHYSICAL.') STOP ENDIF ZMNODE(I)=ZMI IF (TLI.LT.0.) THEN WRITE (IUNIT8,98) 98 FORMAT(' NEGATIVE MANTLE LITHOSPHERE THICKNESS IS', + ' NON-PHYSICAL.') STOP ENDIF TLNODE(I)=TLI IF (.NOT.BRIEF) THEN WRITE (IUNIT8,55) INDEX,XI,YI,ELEVI,QI,ZMI,TLI ENDIF 100 CONTINUE ALLOK=.TRUE. DO 101 I=1,NUMNOD ALLOK=ALLOK.AND.CHECKN(I) 101 CONTINUE IF (.NOT.ALLOK) THEN WRITE (IUNIT8,102) 102 FORMAT(' THE FOLLOWING NODES WERE NEVER READ:') DO 104 I=1,NUMNOD IF (.NOT.CHECKN(I)) WRITE(IUNIT8,103)I 103 FORMAT (' ',36X,I6) 104 CONTINUE STOP ENDIF C C READ TRIANGULAR ELEMENTS C READ (IUNIT7,*) NUMEL IF (NUMEL.GT.MXEL) THEN WRITE (IUNIT8,108) NUMEL 108 FORMAT(/' INCREASE PARAMETER MAXEL TO BE AT LEAST EQUAL' + /' TO THE NUMBER OF ELEMENTS (',I6,') AND RECOMPILE.') STOP ENDIF DO 109 K=1,NUMEL CHECKE(K)=.FALSE. 109 CONTINUE IF (.NOT.BRIEF) WRITE (IUNIT8,110) NUMEL 110 FORMAT(/' THERE ARE ',I6,' TRIANGULAR CONTINUUM ELEMENTS.'/ + ' (NODE NUMBERS FOR EACH ARE GIVEN CORNERS-FIRST, COUNTER', + 'CLOCKWISE; THEN'/' MIDPOINTS, COUNTERCLOCKWISE, BEGINNING' + ,' WITH THE MIDPOINT BETWEEN CORNER #1 AND CORNER #2)'/ / + ' ELEMENT C1 C2 C3 M1 M2', + ' M3') DO 200 K=1,NUMEL C (ELEMENTS NEED NOT BE INPUT IN ORDER, BUT MUST ALL BE PRESENT.) READ (IUNIT7,*) I,(IFN(J),J=1,6) CHECKE(I)=.TRUE. IF (.NOT.BRIEF) WRITE (IUNIT8,120) I,(IFN(J),J=1,6) 120 FORMAT (' ',I6,':',6I10) DO 130 J=1,6 N=IFN(J) IF ((N.LE.0).OR.(N.GT.NTOP).OR. + ((N.GT.NREALN).AND.(N.LE.N1000))) THEN WRITE (IUNIT8,125) N 125 FORMAT (' NODE NUMBER ',I6,' IS ILLEGAL.') STOP ENDIF IF (N.GT.NREALN) N=N-N1000+NREALN NODES(J,I)=N 130 CONTINUE 200 CONTINUE ALLOK=.TRUE. DO 201 I=1,NUMEL ALLOK=ALLOK.AND.CHECKE(I) 201 CONTINUE IF (.NOT.ALLOK) THEN WRITE (IUNIT8,202) 202 FORMAT (' THE FOLLOWING ELEMENTS WERE NEVER READ:') DO 204 I=1,NUMEL IF (.NOT.CHECKE(I)) WRITE(IUNIT8,203)I 203 FORMAT (' ',39X,I6) 204 CONTINUE STOP ENDIF C C READ FAULT ELEMENTS C READ (IUNIT7,*) NFL IF (NFL.GT.MXFEL) THEN WRITE (IUNIT8,220)NFL 220 FORMAT (/' INCREASE PARAMETER MAXFEL TO BE AT LEAST EQUAL' + /' TO THE NUMBER OF FAULTS (',I6,') AND RECOMPILE.') STOP ENDIF OFFMAX=0. DO 222 I=1,NFL CHECKF(I)=.FALSE. 222 CONTINUE IF (.NOT.BRIEF) WRITE(IUNIT8,230) NFL 230 FORMAT(/ /' THERE ARE ',I6,' CURVILINEAR FAULT ELEMENTS.') IF ((.NOT.BRIEF).AND.(NFL.GT.0)) WRITE(IUNIT8,231) 231 FORMAT (/' (THE 6 NODE NUMBERS DEFINING EACH ELEMENT MUST BE', + ' IN A COUNTERCLOCKWISE ORDER:'/ + ' N1, N2, AND N3 ARE IN LEFT-TO-RIGHT SEQUENCE ON THE', + ' NEAR SIDE,'/ + ' THEN N4 IS OPPOSITE N3, N5 IS OPPOSITE N2, AND ', + 'N6 IS OPPOSITE N1.)'/' (FAULT DIPS ARE GIVEN AT N1, N2, ', + 'AND N3, IN DEGREES FROM HORIZONTAL;'/ + ' POSITIVE DIPS ARE TOWARD N1, N2, AND N3, RESPECTIVELY, '/ + ' WHILE NEGATIVE DIPS ARE TOWARD N6, N5, AND N4.)'/ + ' (THE ARGUMENT OF THE FAULT TRACE IS GIVEN AT N1 AND N3,'/ + ' IN DEGREES COUNTERCLOCKWISE FROM THE X AXIS.)'/ + ' OFFSET IS THE TOTAL PAST SLIP OF THE FAULT.'/ / + ' ELEMENT N1 N2 N3 N4 N5 N6 DIP1 DIP2 DIP3', + ' ARG1 ARG3 OFFSET'/) 240 FORMAT (' ',I6,':',6I5,1X,3F6.1,1X,2F5.0,F9.0) DO 300 K=1,NFL OFF=0. READ (IUNIT7,*,ERR=242) I,(IFN(J),J=1,6),(DIPS(L),L=1,3), + AZ1,AZ3,OFF 242 CHECKF(I)=.TRUE. IF (.NOT.BRIEF) WRITE (IUNIT8,240) I,(IFN(J),J=1,6), + (DIPS(L),L=1,3),AZ1,AZ3,OFF DO 250 J=1,6 N=IFN(J) IF ((N.LE.0).OR.(N.GT.NTOP).OR. + ((N.GT.NREALN).AND.(N.LE.N1000))) THEN WRITE (IUNIT8,125) N STOP ENDIF IF (N.GT.NREALN) N=N-N1000+NREALN NODEF(J,I)=N 250 CONTINUE DO 260 L=1,3 IF (ABS(DIPS(L)).GT.90.) THEN WRITE(IUNIT8,252) DIPS(L) 252 FORMAT(' ILLEGAL DIP OF ',F10.4,'; SHOULD BE IN', + ' RANGE OF -90. TO +90. DEGREES.'/ + ' (NOTE: ALL DIPS ARE IN DEGREES FROM THE', + ' HORIZONAL;'/ + ' A + PREFIX (OR NONE) INDICATES A DIP', + ' TOWARD THE N1-N2-N3 SIDE;'/ + ' A - PREFIX INDICATES A DIP TOWARD', + ' THE N6-N5-N4 SIDE.)') STOP ENDIF IF (DIPS(L).LT.0.) DIPS(L)=180.+DIPS(L) FDIP(L,I)=DIPS(L)*0.017453293 260 CONTINUE IF ((ABS(AZ1).GT.361.).OR.(ABS(AZ3).GT.361.)) THEN WRITE (IUNIT8,272) AZ1,AZ3 272 FORMAT (' ILLEGAL ARGUMENT OF ',F10.4,' OR ',F10.4, + '; SHOULD BE IN RANGE -360. TO +360. DEGREES.') STOP ENDIF FAZ(1,I)=AZ1*0.017453293 FAZ(2,I)=AZ3*0.017453293 IF (OFF.LT.0.) THEN WRITE (IUNIT8,280) OFF 280 FORMAT (' ILLEGAL FAULT OFFSET OF ',1P,E10.2, + ' FOR FAULT ELEMENT',I6/ + ' OFFSETS MAY NOT BE NEGATIVE.') STOP ENDIF OFFSET(I)=OFF OFFMAX=MAX(OFFMAX,OFF) 300 CONTINUE ALLOK=.TRUE. DO 301 I=1,NFL ALLOK=ALLOK.AND.CHECKF(I) 301 CONTINUE IF (.NOT.ALLOK) THEN WRITE(IUNIT8,302) 302 FORMAT(' THE FOLLOWING FAULTS WERE NEVER READ:') DO 304 I=1,NFL IF (.NOT.CHECKF(I)) WRITE(IUNIT8,303)I 303 FORMAT(' ',36X,I6) 304 CONTINUE STOP ELSE IF (OFFMAX.GT.0.) THEN WRITE (IUNIT8,400) OFFMAX 400 FORMAT (/' GREATEST FAULT OFFSET READ WAS ',1P,E10.2) ELSE WRITE (IUNIT8,401) 401 FORMAT (/' SINCE FAULT OFFSETS ARE ALL ZERO,', + ' INPUT PARAMETER BYERLY WILL HAVE NO EFFECT.') ENDIF ENDIF IF (.NOT. BRIEF) WRITE (IUNIT8,999) 999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END SUBROUTINE GETNET C C C C C C SUBROUTINE MOHR (INPUT,ACREEP,ALPHAT,BCREEP,BIOT,BYERLY, + CCREEP,CFRIC,CONDUC,CONSTR,DCREEP,DQDTDA, + ECREEP,FDIP,FFRIC,FMUMAX,FTAN,GMEAN, + MXFEL,MXNODE,NFL,NODEF, + OFFMAX,OFFSET, + ONEKM,RADIO,RHOH2O, + RHOBAR,TLNODE,TSURF,V,WEDGE, + ZMNODE, + MODIFY,ZTRANF, + OUTPUT,FC,FIMUDZ,FPEAKS,FSLIPS,FTSTAR) C C THIS SUBPROGRAM CONTAINS THE NONLINEAR RHEOLOGY OF THE FAULTS. C FOR EACH OF 7 INTEGRATION POINTS ALONG THE LENGTH OF EACH FAULT C ELEMENT, IT: C C (1) COMPUTES THE SLIP-RATE VECTOR ON THE FAULT SURFACE, C (2) DETERMINES THE SHEAR STRESS ON THE FAULT SURFACE BY MOHR/ C COULOMB/NAVIER THEORY (THIS STRESS IS PROPORTIONAL TO DEPTH, C SO THE CALCULATION IS ACTUALLY DONE AT UNIT DEPTH AND THEN C SCALED), C (3) PROCEEDS DOWN THE DIP OF THE FAULT, CHECKING TEMPERATURE, C STRAIN-RATE, AND PRESSURE TO SEE IF FRICTIONAL OR CREEP C SHEAR STRESS IS LOWER, C (4) REPORTS THE VERTICAL INTEGRAL OF "MU" (THE RATIO OF SHEAR C STRESS TO SLIP RATE) DOWN THE FAULT AS "FIMUDZ". C (NOTE THAT THE INTEGRAL IS VERTICAL, NOT ON A SLANT, EVEN THOUGH C CONDITIONS ARE EVALUATED ALONG A SLANT PATH.) C (5) FOR DIPPING, OBLIQUE-SLIP FAULT ONLY, ALSO REPORTS RECOMMENDED C TACTICAL VALUES FOR THE MATRIX "FC" AND THE VECTOR "FTSTAR" C WHICH JOINTLY DESCRIBE A LINEARIZED RHEOLOGY STIFFER THAN C THE ACTUAL NONLINEAR RHEOLOGY. C (6) "ZTRANF" IS THE LATEST ESTIMATE OF THE DEPTH C TO THE BRITTLE/DUCTILE TRANSITION, AT THE FAULT MIDPOINT. C (7) LOGICAL VARIABLE "FSLIPS" INDICATES WHETHER THE FAULT IS C SLIPPING AT ITS MIDPOINT. OTHERWISE, IT IS IN THE ARTIFICIAL C LINEARIZED REGIME, WITH STIFFNESS "FMUMAX". C (8) "FPEAKS" GIVES THE PEAK SHEAR STRESS AT THE MIDPOINT OF EACH C FAULT, EVALUATED AT THE BRITTLE/DUCTILE TRANSITION. C C NOTE THAT PORE PRESSURES ARE CONSIDERED IN THE CALCULATION OF C FRICTIONAL STRENGTH: C *NORMAL PORE PRESSURES REDUCE THE EFFECTIVE NORMAL STRESS ON THE C FAULT SURFACE BY THE AMOUNT C -BIOT*GMEAN*RHOH20*Z C *IF (OFFMAX.GT.0.), THEN THE REMAINING EFFECTIVE FRICTIONAL STRENGTH C OF THE FAULT IS MULTIPLIED BY THE REDUCING FACTOR C *(1.-BYERLY*OFFSET(I)/OFFMAX). C THIS IS ALSO A PORE PRESSURE EFFECT, BECAUSE BYERLY'S MODEL IS C THAT GOUGE LAYERS HAVE THICKNESS IN PROPORTION TO OFFSET, AND C THAT THEY SUPPORT NON-DARCY STATIC PORE PRESSURE GRADIENTS WHICH C REDUCE THE EFFECTIVE FRICTION OF THE FAULT. C C FOLLOWING PARAMETER GIVES NUMBER OF STEPS IN VERTICAL INTEGRAL C OF CREEP SHEAR STRESS ON DUCTILE PARTS OF FAULTS: PARAMETER (NSTEP=20) C HIGHER VALUES OBVIOUSLY COST MORE. ON THE OTHER HAND, SMALL VALUES C DO NOT MERELY APPROXIMATE THE CREEP LAW; THEY ALSO INTRODUCE C SOME RANDOM ERR0R WHICH CAN PUT A FLOOR ON CONVERGENCE. C C NOTE: IN VS-FORTRAN, FOLLOWING TYPE COULD BE LOGICAL*1: LOGICAL FSLIPS C LOGICAL LOCKED,PURESS,SLOPED DOUBLE PRECISION V REAL ANGLE,MANTLE,NORMAL,STRAIN,TMOHO C DIMENSIONS OF INTERNAL CONVENIENCE ARRAYS: DIMENSION DLEPDZ(2),DSFDZ(2),RHO(2),SHEART(2),TMEAN(2),ZTRANS(2) C DIMENSIONS OF EXTERNAL ARGUMENTS ARRAYS: DIMENSION ACREEP(2),ALPHAT(2),BCREEP(2),CCREEP(2),CONDUC(2), + DCREEP(2),DQDTDA(MXNODE), + FC(2,2,7,MXFEL),FDIP(3,MXFEL), + FIMUDZ(7,MXFEL),FPEAKS(2,MXFEL),FSLIPS(MXFEL), + FTAN(7,MXFEL),FTSTAR(2,7,MXFEL),NODEF(6,MXFEL), + OFFSET(MXFEL),RADIO(2),RHOBAR(2),TLNODE(MXNODE), + V(2,MXNODE),ZMNODE(MXNODE),ZTRANF(2,MXFEL) C C FOLLOWING TWO NUMBERS ARE "VERY SMALL" AND "VERY LARGE", BUT NOT C SO EXTREME AS TO CAUSE UNDERFLOW OR OVERFLOW. THEY MAY NEED TO C BE ADJUSTED, DEPENDING ON THE COMPUTER AND COMPILER BEING USED. DATA TINY /1.E-30/ DATA HUGE /1.E+30/ C CGAMMA=(1.+SIN(ATAN(CFRIC)))/(1.-SIN(ATAN(CFRIC))) DO 100 I=1,NFL IF (OFFMAX.LE.0.) THEN FRIC=FFRIC ELSE FRIC=FFRIC*(1.-BYERLY*OFFSET(I)/OFFMAX) ENDIF N1=NODEF(1,I) N2=NODEF(2,I) N3=NODEF(3,I) N4=NODEF(4,I) N5=NODEF(5,I) N6=NODEF(6,I) C C IS THIS A PURELY STRIKE-SLIP FAULT ELEMENT? PURESS=(ABS(FDIP(1,I)-1.570796).LE.WEDGE).AND. + (ABS(FDIP(2,I)-1.570796).LE.WEDGE).AND. + (ABS(FDIP(3,I)-1.570796).LE.WEDGE) C C IF SO, COMPUTE ESTIMATE OF RELATIVE NORMAL STRESS C (RELATIVE TO VERTICAL STRESS) BY USING AMOUNT OF DIVERGENCE C BETWEEN NODES N2 AND N5 (IN SPITE OF CONSTRAINT EQUATION): IF (PURESS) THEN ANGLE=FTAN(4,I) UNITBX=SIN(ANGLE) UNITBY= -COS(ANGLE) DELVX=V(1,N2)-V(1,N5) DELVY=V(2,N2)-V(2,N5) SPREAD=DELVX*UNITBX+DELVY*UNITBY DELTAU=CONSTR*SPREAD IF ((TLNODE(N2).LE.0.).OR.(ZTRANF(2,I).LE.0.)) THEN C CRUST ALONE RESISTS CONVERGENCE: DPMAX= -2.*DELTAU/ZTRANF(1,I) DDPNDZ=DPMAX/ZTRANF(1,I) ELSE C MANTLE LITHOSPHERE HELPS TO RESIST CONVERGENCE: DDPNDZ= -DELTAU/ + (0.5*ZTRANF(1,I)**2+ZTRANF(2,I)*ZMNODE(N2)+ + 0.5*ZTRANF(2,I)**2) ENDIF C DDPNDZ IS THE GRADIENT OF EXCESS NORMAL PRESSURE (IN C EXCESS OF VERTICAL PRESSURE) WITH DEPTH ON THIS FAULT; C CHECK THAT IT LIES WITHIN FRICTIONAL LIMITS OF BLOCKS: Q=0.5*(DQDTDA(N2)+DQDTDA(N5)) TTRANS=TSURF+ZTRANF(1,I)*Q/CONDUC(1)- + ZTRANF(1,I)**2*RADIO(1)/(2.*CONDUC(1)) TMEANC=(TSURF+TTRANS)/2. RHOC=RHOBAR(1)*(1.-ALPHAT(1)*TMEANC) DLEPDC=GMEAN*(RHOC-RHOH2O*BIOT) THRUST=DLEPDC*CGAMMA NORMAL=DLEPDC/CGAMMA DDPNDZ=MAX(DDPNDZ,NORMAL-DLEPDC) DDPNDZ=MIN(DDPNDZ,THRUST-DLEPDC) C ELSE C DIFFERENT LOGIC WILL BE USED; THIS PARAMETER IS NOT C REALLY NEEDED. ZERO IT JUST TO BE CAREFUL. DDPNDZ=0. ENDIF C DO 90 M=1,7 C HEAT-FLOW: Q=DQDTDA(N1)*FPHI(1,M)+DQDTDA(N2)*FPHI(2,M)+ + DQDTDA(N3)*FPHI(3,M) C C CRUSTAL THICKNESS: CRUST=ZMNODE(N1)*FPHI(1,M)+ZMNODE(N2)*FPHI(2,M)+ + ZMNODE(N3)*FPHI(3,M) C C MANTLE LITHOSPHERE THICKNESS: MANTLE=TLNODE(N1)*FPHI(1,M)+TLNODE(N2)*FPHI(2,M)+ + TLNODE(N3)*FPHI(3,M) MANTLE=MAX(MANTLE,0.) C C MOHO TEMPERATURE: TMOHO=TSURF+CRUST*Q/CONDUC(1)- + CRUST**2*RADIO(1)/(2.*CONDUC(1)) C C TEMPERATURE AT BASE OF PLATE: TASTH=TMOHO+MANTLE*(Q-CRUST*RADIO(1))/CONDUC(2)- + MANTLE**2*RADIO(2)/(2.*CONDUC(2)) C C MEAN TEMPERATURES: TMEAN(1)=(TSURF+TMOHO)/2. TMEAN(2)=(TMOHO+TASTH)/2. C C MEAN DENSITIES: RHO(1)=RHOBAR(1)*(1.-ALPHAT(1)*TMEAN(1)) RHO(2)=RHOBAR(2)*(1.-ALPHAT(2)*TMEAN(2)) C C 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=FTAN(M,I) C C UNITA IS A UNIT VECTOR ALONG THE FAULT, FROM N1 TO N3. UNITAX=COS(ANGLE) UNITAY=SIN(ANGLE) C C UNITB IS A PERPENDICULAR UNIT VECTOR, POINTING OUT C TOWARD THE N6-N4 SIDE. UNITBX= -UNITAY UNITBY= +UNITAX C C RELATIVE VELOCITIES ARE FOR N1-3 SIDE RELATIVE TO C THE N6-4 SIDE: DELVX=V(1,N1)*FPHI(1,M)+V(1,N2)*FPHI(2,M)+ + V(1,N3)*FPHI(3,M)+V(1,N4)*FPHI(4,M)+ + V(1,N5)*FPHI(5,M)+V(1,N6)*FPHI(6,M) DELVY=V(2,N1)*FPHI(1,M)+V(2,N2)*FPHI(2,M)+ + V(2,N3)*FPHI(3,M)+V(2,N4)*FPHI(4,M)+ + V(2,N5)*FPHI(5,M)+V(2,N6)*FPHI(6,M) C C SINISTRAL STRIKE-SLIP RATE COMPONENT: SINIST=DELVX*UNITAX+DELVY*UNITAY C C CONVERGENCE RATE COMPONENT (IN HORIZONTAL PLANE): CLOSE =DELVX*UNITBX+DELVY*UNITBY C C DIP OF THE FAULT (FROM HORIZONTAL ON THE N1-3 SIDE): DIP=FDIP(1,I)*FPHI(1,M)+FDIP(2,I)*FPHI(2,M)+ + FDIP(3,I)*FPHI(3,M) SLOPED=ABS(DIP-1.570796).GT.WEDGE C IF (.NOT.SLOPED) THEN C CASE OF A NEAR-VERTICAL FAULT: DSFDZ(1)=(DLEPDZ(1)+DDPNDZ)*FRIC SFMOHO=DSFDZ(1)*CRUST DSFDZ(2)=(DLEPDZ(2)+DDPNDZ)*FRIC SLIP=ABS(SINIST) LOCKED=.FALSE. ELSE C CASE OF A SHALLOW-DIPPING FAULT: C C VUPDIP IS THE UP-DIP VELOCITY COMPONENT, IN THE C FAULT PLANE, OF THE BLOCK ON THE N1-N3 SIDE. VUPDIP=CLOSE/COS(DIP) C C RAKE ANGLE IS MEASURED COUNTERCLOCKWISE IN C FAULT PLANE FROM HORIZONTAL & PARALLEL TO ANGLE. RAKE=ATAN2F(VUPDIP,SINIST) C C 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 VIMUDZ=VITDZ/SLIP C FIMUDZ(M,I)=MIN(VIMUDZ,FMUMAX*(CRUST+MANTLE)) C C DIPPING, OBLIQUE-SLIP INTEGRATION C POINTS ARE ALSO CHARACTERIZED C BY "FC" AND "FTSTAR": C IF (SLOPED) THEN TS=SINIST*FIMUDZ(M,I) TU=VUPDIP*FIMUDZ(M,I) IF (LOCKED) THEN FC(1,1,M,I)=FIMUDZ(M,I) FC(1,2,M,I)=0. FC(2,1,M,I)=0. FC(2,2,M,I)=FIMUDZ(M,I) ELSE SINR=SIN(RAKE) COSR=COS(RAKE) TAND=TAN(DIP) C C *** IMPORTANT NOTE: *** C THE FOLLOWING 7 STATEMENTS ARE -NOT- THE C RESULT OF THEORY, BUT A TACTICAL CHOICE C WHICH ATTEMPTS TO COMPROMISE BETWEEN C STABILITY OF THE LINEAR SYSTEM, STABILITY C OF THE ITERATION, AND EFFICIENCY. C THEY MAY BE CHANGED IF THE PROGRAM DOES C NOT CONVERGE SATISFACTORILY! C TUNE=2. FC(1,1,M,I)=FIMUDZ(M,I)* + (1.-TUNE*SINR*COSR**2*TAND) FC(1,2,M,I)=FIMUDZ(M,I)* + (TUNE*COSR**3*TAND) FC(2,1,M,I)=FIMUDZ(M,I)* + (-TUNE*SINR**2*COSR*TAND) FC(2,2,M,I)=FIMUDZ(M,I)* + (1.+TUNE*SINR*COSR**2*TAND) C (OFTEN, FC(1,2) IS THE BIGGEST TERM. C IN SOME CASES, DIAGONALS BECOME NEGATIVE. C FOR STABILITY, BE SURE THAT THE FC C MATRIX REMAINS POSITIVE DEFINITE: FC(1,1,M,I)=MAX(FC(1,1,M,I),ABS(FC(1,2,M,I))) FC(2,2,M,I)=MAX(FC(2,2,M,I),ABS(FC(1,2,M,I))) ENDIF FTSTAR(1,M,I)=TS-FC(1,1,M,I)*SINIST- + FC(1,2,M,I)*VUPDIP FTSTAR(2,M,I)=TU-FC(2,1,M,I)*SINIST- + FC(2,2,M,I)*VUPDIP ENDIF C C PROVIDE INTERESTING DIAGNOSTIC DATA AT MIDPOINTS ONLY: C IF (M.EQ.4) THEN FSLIPS(I)=(.NOT.LOCKED).AND. + (FIMUDZ(M,I).LT.(0.99*FMUMAX*(CRUST+MANTLE))) ZTRANF(1,I)=ZTRANS(1) FPEAKS(1,I)=SHEART(1) ZTRANF(2,I)=ZTRANS(2) FPEAKS(2,I)=SHEART(2) ENDIF C 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE MOHR C C C SUBROUTINE NEXT (INPUT,I,J,MXEL,MXFEL,NFL,NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) C C DETERMINE WHETHER THERE ARE MORE ELEMENTS ADJACENT TO SIDE J OF C TRIANGULAR CONTINUUM ELEMENT #I. C J = 1 MEANS THE SIDE OPPOSITE NODE # NODES(1,I). C J = 2 MEANS THE SIDE OPPOSITE NODE # NODES(2,I). C J = 3 MEANS THE SIDE OPPOSITE NODE # NODES(3,I). C IF A FAULT ELEMENT IS ADJACENT, ITS NUMBER IS KFAULT; OTHERWISE, C KFAULT IS SET TO ZERO. C IF ANOTHER TRIANGULAR CONTINUUM ELEMENT IS ADJACENT (EVEN ACROSS C FAULT ELEMENT KFAULT!) THEN ITS NUMBER IS KELE; OTHERWISE, KELE = 0. C LOGICAL FOUNDE,FOUNDF DIMENSION NODEF(6,MXFEL),NODES(6,MXEL) C**************************************************************** C THE FOLLOWING INTIALIZATIONS ARE NOT LOGICALLY NECESSARY, C BUT DUE TO BUGS IN THE VS-FORTRAN 2.4 COMPILER, THERE C WILL BE AN ERRONEOUS ERR0R MESSAGE IF THEY ARE NOT PERFORMED: M1=0 M2=0 M3=0 M4=0 M5=0 M6=0 C**************************************************************** C C THREE NODE NUMBERS ALONG THE SIDE OF INTEREST, COUNTERCLOCKWISE: N1=NODES(MOD(J, 3)+1,I) N2=NODES(MOD(J, 3)+4,I) N3=NODES(MOD(J+1,3)+1,I) C CHECK FOR ADJACENT FAULT ELEMENT FIRST: FOUNDF=.FALSE. DO 10 K=1,NFL M1=NODEF(1,K) M2=NODEF(2,K) M3=NODEF(3,K) M4=NODEF(4,K) M5=NODEF(5,K) M6=NODEF(6,K) IF (((M1.EQ.N3).AND.(M2.EQ.N2).AND.(M3.EQ.N1)).OR. + ((M4.EQ.N3).AND.(M5.EQ.N2).AND.(M6.EQ.N1))) THEN FOUNDF=.TRUE. KFAULT=K GO TO 11 ENDIF 10 CONTINUE 11 IF (.NOT.FOUNDF) KFAULT=0 C IF THERE WAS A FAULT, REPLACE 3 NODE NUMBERS THAT WE SEARCH FOR: IF (FOUNDF) THEN IF (M2.EQ.N2) THEN N1=M4 N2=M5 N3=M6 ELSE N1=M1 N2=M2 N3=M3 ENDIF ENDIF C SEARCH FOR ADJACENT TRIANGULAR CONTINUUM ELEMENT: FOUNDE=.FALSE. DO 20 K=1,NUMEL IF (K.NE.I) THEN DO 15 L=1,3 M1=NODES(MOD(L, 3)+1,K) M2=NODES(MOD(L, 3)+4,K) M3=NODES(MOD(L+1,3)+1,K) IF ((M3.EQ.N1).AND.(M2.EQ.N2).AND.(M1.EQ.N3)) THEN FOUNDE=.TRUE. KELE=K GO TO 21 ENDIF 15 CONTINUE ENDIF 20 CONTINUE 21 IF (.NOT.FOUNDE) KELE=0 RETURN END SUBROUTINE NEXT C C C SUBROUTINE OLDVEL (INPUT,IUNITV,MXNODE,NUMNOD, + OUTPUT,ALDONE,TITLE1,TITLE2,TITLE3,V) C C READ OLD VELOCITY SOLUTION FROM UNIT IUNITV, OR ELSE SET FLAG C "ALDONE". C INTEGER IOS LOGICAL ALDONE CHARACTER*80 INFILE,TITLE1,TITLE2,TITLE3 DOUBLE PRECISION V DIMENSION V(2,MXNODE) C WRITE (*,10) IUNITV 10 FORMAT(/' Attempting to read VELOCITIES OF NODES from unit',I3) 20 WRITE (*,30) 30 FORMAT(' Enter name of output file from PLATES: '/) READ (*,'(A)') INFILE OPEN (UNIT=IUNITV,FILE=INFILE,STATUS='OLD',PAD='YES',IOSTAT=IOS) IF (IOS.NE.0) GO TO 20 READ (IUNITV,'(A)',END=100,ERR=100) TITLE1 READ (IUNITV,'(A)',END=100,ERR=100) TITLE2 READ (IUNITV,'(A)',END=100,ERR=100) TITLE3 READ (IUNITV,*,END=100,ERR=100) ((V(J,I),J=1,2),I=1,NUMNOD) ALDONE=.FALSE. RETURN C ------------------(THIS SECTION EXECUTED ONLY IF READ FAILS)--------- 100 ALDONE=.TRUE. RETURN END SUBROUTINE OLDVEL C C C SUBROUTINE ONEBAR (INPUT,ACREEP,BCREEP,CCREEP, + ECREEP,GEOTHC,GEOTHM, + MXEL,NUMEL, + TEMLIM,TLINT,ZMOHO, + OUTPUT,GLUE) C C CALCULATES "GLUE" (SHEAR STRESS REQUIRED TO CREATE UNIT RELATIVE C HORIZONTAL VELOCITY ACROSS THE PLATE) C C PARAMETER "NINT" SETS NUMBER OF STEPS IN VERTICAL INTEGRALS: PARAMETER (NINT=100) C REAL V C C EXTERNAL ARGUMENT ARRAYS: DIMENSION ACREEP(2),BCREEP(2),CCREEP(2), + GEOTHC(4,7,MXEL),GEOTHM(4,7,MXEL), + GLUE(7,MXEL), + TEMLIM(2), + TLINT(7,MXEL),ZMOHO(7,MXEL) C INTERNAL ARRAYS: DIMENSION AILOG(2),GT(4) C C ECINI= -1.0/ECREEP AILOG(1)=LOG(ACREEP(1))*ECINI AILOG(2)=LOG(ACREEP(2))*ECINI DO 100 M=1,7 DO 90 I=1,NUMEL V=0. IF (TLINT(M,I).GT.0.) THEN LIMIT=2 ELSE LIMIT=1 ENDIF DO 20 LAYER=1,LIMIT IF (LAYER.EQ.1) THEN THICK=ZMOHO(M,I) GT(1)=GEOTHC(1,M,I) GT(2)=GEOTHC(2,M,I) GT(3)=GEOTHC(3,M,I) GT(4)=GEOTHC(4,M,I) ELSE THICK=TLINT(M,I) GT(1)=GEOTHM(1,M,I) GT(2)=GEOTHM(2,M,I) GT(3)=GEOTHM(3,M,I) GT(4)=GEOTHM(4,M,I) ENDIF DZ=THICK/NINT DO 10 J=1,NINT Z=(J-0.5)*DZ T=GT(1) + +GT(2)*Z + +GT(3)*Z*Z + +GT(4)*Z*Z*Z TH=MAX(T,200.) TL=MIN(TH,TEMLIM(LAYER)) BI=(BCREEP(LAYER)+CCREEP(LAYER)*Z)*ECINI ARG=MAX(AILOG(LAYER)+BI/TL,-89.9) V=V+DZ*EXP(ARG) 10 CONTINUE 20 CONTINUE GLUE(M,I)=1./(V**ECREEP) 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE ONEBAR 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 SUBROUTINE PRINCE C C C SUBROUTINE READPM (INPUT,IUNIT7, IUNIT8, OFFMAX, + OUTPUT,ACREEP, ALPHAT, BCREEP, BIOT , + BYERLY, CCREEP, CFRIC , CONDUC, + DCREEP, ECREEP, EVERYP, FFRIC , GMEAN , + MAXITR, OKDELV, OKTOQT, ONEKM, RADIO , + REFSTR, RHOAST, RHOBAR, RHOH2O, + TEMLIM, TITLE3, TRHMAX, TSURF, $ NPTYPE, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,NCONTR, $ STATES,RMSVEC, $ SDENOM,XCENTR,YCENTR,PAPRE, $ IPEN1,IPEN2,IPEN3,COLOR, + RADIUS,CPNLAT,Y0NLAT,X0ELON) C C READS STRATEGIC AND TACTICAL INPUT PARAMETERS FROM DEVICE IUNIT7, C FOLLOWED BY PLOT-CONTROL PARAMETERS, C AND ECHOES THEM ON DEVICE IUNIT8 WITH ANNOTATIONS. C CHARACTER*80 TITLE3 INTEGER IOS LOGICAL COLOR,DOPLOT,EVERYP,STATES DIMENSION CINT(NPTYPE),DOPLOT(NPTYPE), + FBLAND(NPTYPE),LOWBLU(NPTYPE) DIMENSION ACREEP(2),ALPHAT(2),BCREEP(2),CCREEP(2),CONDUC(2), + DCREEP(2),RADIO(2), + RHOBAR(2),TEMLIM(2) C WRITE (IUNIT8,1) IUNIT7 1 FORMAT (/ /' Attempting to read PARAMETERS from unit',I3/) TITLE3=' '// + ' ' READ (IUNIT7,2,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) IF (ACREEP(2).EQ.0.) ACREEP(2)=ACREEP(1) WRITE (IUNIT8,50) ACREEP(1),ACREEP(2) 50 FORMAT (' ',1P, E10.2,'/',E10.2,' A FOR CREEP = ', + 'PRE-EXPONENTIAL SHEAR', + ' STRESS CONSTANT FOR CREEP. (CRUST/MANTLE)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,BCREEP) IF (BCREEP(2).EQ.0.) BCREEP(2)=BCREEP(1) WRITE (IUNIT8,60) BCREEP(1),BCREEP(2) 60 FORMAT (' ', F10.0,'/',F10.0,' B FOR CREEP =(ACTIVATION ', + 'ENERGY)/R/N', + ' IN K. (CRUST/MANTLE)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,CCREEP) IF (CCREEP(2).EQ.0.) CCREEP(2)=CCREEP(1) WRITE (IUNIT8,70) CCREEP(1),CCREEP(2) 70 FORMAT (' ',1P, E10.2,'/',E10.2,' C FOR CREEP = DERIVATIVE OF B', + ' WITH RESPECT TO DEPTH. (CRUST/MANTLE)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,DCREEP) IF (DCREEP(2).EQ.0.) DCREEP(2)=DCREEP(1) WRITE (IUNIT8,80) DCREEP(1),DCREEP(2) 80 FORMAT (' ',1P, E10.2,'/',E10.2,' D FOR CREEP = MAXIMUM SHEAR ', + 'STRESS UNDER ANY CONDITIONS. (CRUST/MANTLE)') READ (IUNIT7,*) ECREEP WRITE (IUNIT8,90) ECREEP 90 FORMAT (' ', F10.6,' E FOR CREEP = STRAIN-RATE EXPONENT FOR', + ' CREEP (1/N). (SAME FOR CRUST AND MANTLE!)') READ (IUNIT7,*) TRHMAX IF (TRHMAX.EQ.1.) TRHMAX=9.9E37 WRITE (IUNIT8,101) TRHMAX 101 FORMAT (' ',1P,E10.2,' LIMIT ON HORIZONTAL TRACTIONS', + ' APPLIED TO BASE OF PLATE') READ (IUNIT7,*) RHOH2O WRITE (IUNIT8,110) RHOH2O 110 FORMAT (' ',1P,E10.3,' DENSITY OF GROUNDWATER, LAKES, & OCEANS') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,RHOBAR) IF (RHOBAR(2).EQ.0.) RHOBAR(2)=RHOBAR(1) WRITE (IUNIT8,120) RHOBAR(1),RHOBAR(2) 120 FORMAT (' ',1P,E10.3,'/',E10.3,' MEAN DENSITY,', + ' CORRECTED TO 0 DEGREES KELVIN. (CRUST/MANTLE)') READ (IUNIT7,*) RHOAST WRITE (IUNIT8,130) RHOAST 130 FORMAT (' ',1P,E10.3,' DENSITY OF ASTHENOSPHERE') READ (IUNIT7,*) GMEAN WRITE (IUNIT8,140) GMEAN 140 FORMAT (' ',1P,E10.3,' MEAN GRAVITATIONAL ACCELERATION', + ' (LENGTH/SEC**2)') READ (IUNIT7,*) ONEKM WRITE (IUNIT8,150) ONEKM 150 FORMAT (' ',1P,E10.3,' NUMBER OF LENGTH UNITS NEEDED TO', + ' MAKE 1 KILOMETER'/11X, + ' (E.G., 1000. IN SI, 1.E5 IN CGS)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,ALPHAT) IF (ALPHAT(2).EQ.0.) ALPHAT(2)=ALPHAT(1) WRITE (IUNIT8,160) ALPHAT(1),ALPHAT(2) 160 FORMAT (' ',1P,E10.2,'/',E10.2,' VOLUMETERIC THERMAL ', + 'EXPANSION OF CRUST', + ' (1/VOL)*(D.VOL/D.T). (CRUST/MANTLE)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,CONDUC) IF (CONDUC(2).EQ.0.) CONDUC(2)=CONDUC(1) WRITE (IUNIT8,170) CONDUC(1),CONDUC(2) 170 FORMAT (' ',1P,E10.2,'/',E10.2,' THERMAL CONDUCTIVITY, ENERGY/', + 'LENGTH/SEC/DEG. (CRUST/MANTLE)') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,RADIO) IF (RADIO(2).EQ.0.) RADIO(2)=RADIO(1) WRITE (IUNIT8,180) RADIO(1),RADIO(2) 180 FORMAT (' ',1P,E10.2,'/',E10.2,' RADIOACTIVE HEAT PRODUCTION', + ' ENERGY/VOLUME/SEC. (CRUST/MANTLE)') READ (IUNIT7,*) TSURF WRITE (IUNIT8,185) TSURF 185 FORMAT (' ', F10.0,' SURFACE TEMPERATURE, ON', + ' ABSOLUTE SCALE') CALL READN (INPUT,IUNIT7,IUNIT8,2, + OUTPUT,TEMLIM) IF (TEMLIM(2).EQ.0.) TEMLIM(2)=TEMLIM(1) WRITE (IUNIT8,190) TEMLIM(1),TEMLIM(2) 190 FORMAT (' ', F10.0,'/',F10.0,' CONVECTING TEMPERATURE (TMAX), ON' + ,' ABSOLUTE SCALE. (CRUST/MANTLE)') WRITE (IUNIT8,199) 199 FORMAT (/' ========== TACTICAL PARAMETERS (HOW TO REACH ', + 'THE SOLUTION) =========='/) READ (IUNIT7,*) MAXITR WRITE (IUNIT8,200) MAXITR 200 FORMAT (' ',I10,' MAXIMUM ITERATIONS WITHIN VELOCITY SOLUTION') READ (IUNIT7,*) OKTOQT WRITE (IUNIT8,210) OKTOQT 210 FORMAT (' ',F10.6,' ACCEPTABLE FRACTIONAL CHANGE IN VELOCITY ', + '(STOPS ITERATION EARLY)') READ (IUNIT7,*) REFSTR WRITE (IUNIT8,220) REFSTR 220 FORMAT (' ',1P,E10.2,' EXPECTED MEAN VALUE OF SHEAR STRESS IN', + ' CRUST'/' ',10X, + ' (USED TO INITIALIZE AND SET STIFFNESS LIMITS)') READ (IUNIT7,*) OKDELV WRITE (IUNIT8,230) OKDELV 230 FORMAT (' ',1P,E10.2,' MAGNITUDE OF VELOCITY ERR0RS ALLOWED', + ' DUE TO FINITE STIFFNESS'/11X, + '(SUCH ERR0RS MAY APPEAR IN SUCH FORMS AS:'/11X, + ' 1. FICTICIOUS BASAL SLIP OF CRUST OVER MANTLE'/11X, + ' 2. ERRONEOUS CONVERGENCE/DIVERGENCE AT VERTICAL FAULTS'/ + 11X, + ' 3. VELOCITY EFFECT OF FICTICIOUS VISCOUS COMPLIANCES'/11X, + ' HOWEVER, VALUES WHICH ARE TOO SMALL WILL CAUSE ILL-CONDITIONED' + /11X, + ' LINEAR SYSTEMS AND STRESS ERR0RS, ', + 'AND MAY PREVENT CONVERGENCE!)') READ (IUNIT7,*) EVERYP WRITE (IUNIT8,240) EVERYP 240 FORMAT (' ',L10,' SHOULD NODAL VELOCITIES BE OUTPUT EVERY STE', + 'P? (FOR CONVERGENCE STUDIES)') WRITE (IUNIT8,999) 999 FORMAT (' --------------------------------------------------', + '-----------------------------') C READ(IUNIT7,*) C THIS WASTED READ IS TO GET PAST THE '======' LINE IN THE FILE. WRITE(IUNIT8,1000) 1000 FORMAT(/ / /' ===== POST-PROCESSING PLOT CONTROL PARAMETERS', + ' (NOT USED BY PLATES) =====') C READ(IUNIT7,*) KTIME WRITE(IUNIT8,1001) KTIME 1001 FORMAT(/ / + ' ',I10,' KTIME (NOT USED BY THIS PROGRAM)') READ(IUNIT7,1011) DOPLOT( 1) READ(IUNIT7,1010) DOPLOT( 2),CINT( 2),FBLAND( 2),LOWBLU( 2) READ(IUNIT7,1010) DOPLOT( 3),CINT( 3),FBLAND( 3),LOWBLU( 3) READ(IUNIT7,1010) DOPLOT( 4),CINT( 4),FBLAND( 4),LOWBLU( 4) READ(IUNIT7,1010) DOPLOT( 5),CINT( 5),FBLAND( 5),LOWBLU( 5) READ(IUNIT7,1010) DOPLOT( 6),CINT( 6),FBLAND( 6),LOWBLU( 6) READ(IUNIT7,1010) DOPLOT( 7),CINT( 7),FBLAND( 7),LOWBLU( 7) READ(IUNIT7,1010) DOPLOT( 8),CINT( 8),FBLAND( 8),LOWBLU( 8) READ(IUNIT7,1010) DOPLOT( 9),CINT( 9),FBLAND( 9),LOWBLU( 9) READ(IUNIT7,1010) DOPLOT(10),CINT(10),FBLAND(10),LOWBLU(10) READ(IUNIT7,1010) DOPLOT(11),CINT(11),FBLAND(11),LOWBLU(11) READ(IUNIT7,1010) DOPLOT(12),CINT(12),FBLAND(12),LOWBLU(12) READ(IUNIT7,1010) DOPLOT(13),CINT(13),FBLAND(13),LOWBLU(13) READ(IUNIT7,1011) DOPLOT(14) READ(IUNIT7,1010) DOPLOT(15),CINT(15),FBLAND(15),LOWBLU(15) READ(IUNIT7,1010) DOPLOT(16),CINT(16),FBLAND(16),LOWBLU(16) DO 1005 I=1,16 IF (LOWBLU(I).EQ.0) LOWBLU(I)=+1 1005 CONTINUE 1010 FORMAT(L10,2E10.2,I2) 1011 FORMAT(L10) WRITE(IUNIT8,1101) DOPLOT( 1) WRITE(IUNIT8,1102) DOPLOT( 2),CINT( 2),FBLAND( 2),LOWBLU( 2) WRITE(IUNIT8,1103) DOPLOT( 3),CINT( 3),FBLAND( 3),LOWBLU( 3) WRITE(IUNIT8,1104) DOPLOT( 4),CINT( 4),FBLAND( 4),LOWBLU( 4) WRITE(IUNIT8,1105) DOPLOT( 5),CINT( 5),FBLAND( 5),LOWBLU( 5) WRITE(IUNIT8,1106) DOPLOT( 6),CINT( 6),FBLAND( 6),LOWBLU( 6) WRITE(IUNIT8,1107) DOPLOT( 7),CINT( 7),FBLAND( 7),LOWBLU( 7) WRITE(IUNIT8,1108) DOPLOT( 8),CINT( 8),FBLAND( 8),LOWBLU( 8) WRITE(IUNIT8,1109) DOPLOT( 9),CINT( 9),FBLAND( 9),LOWBLU( 9) WRITE(IUNIT8,1110) DOPLOT(10),CINT(10),FBLAND(10),LOWBLU(10) WRITE(IUNIT8,1111) DOPLOT(11),CINT(11),FBLAND(11),LOWBLU(11) WRITE(IUNIT8,1112) DOPLOT(12),CINT(12),FBLAND(12),LOWBLU(12) WRITE(IUNIT8,1113) DOPLOT(13),CINT(13),FBLAND(13),LOWBLU(13) WRITE(IUNIT8,1114) DOPLOT(14) WRITE(IUNIT8,1115) DOPLOT(15),CINT(15),FBLAND(15),LOWBLU(15) WRITE(IUNIT8,1116) DOPLOT(16),CINT(16),FBLAND(16),LOWBLU(16) 1101 FORMAT(L11,22X, ' GRID OF ELEMENTS') 1102 FORMAT(L11,1P,2E10.2,I2,' ELEVATION') 1103 FORMAT(L11,1P,2E10.2,I2,' HEAT-FLOW') 1104 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL THICKNESS') 1105 FORMAT(L11,1P,2E10.2,I2,' MANTLE LITHOSPHERE THICKNESS') 1106 FORMAT(L11,1P,2E10.2,I2,' MOHO TEMPERATURE') 1107 FORMAT(L11,1P,2E10.2,I2,' TEMPERATURE AT BASE OF PLATE') 1108 FORMAT(L11,1P,2E10.2,I2,' PRESSURE ANOMALY AT BASE OF PLATE') 1109 FORMAT(L11,1P,2E10.2,I2,' VELOCITY VECTORS AT BASE OF PLATE') 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,1P,2E10.2,I2,' GREATEST PRINCIPAL STRAIN RATES') 1114 FORMAT(L11,22X, ' SLIP-RATE OF FAULTS') 1115 FORMAT(L11,1P,2E10.2,I2,' RATE OF CRUSTAL THICKENING') 1116 FORMAT(L11,1P,2E10.2,I2,' PRINCIPAL' + ,' STRESS ANOMALY INTEGRALS') READ(IUNIT7,*) NCONTR NCONTR=MAX(NCONTR,1) WRITE(IUNIT8,1200)NCONTR 1200 FORMAT(' ',I10,' APPROXIMATE NUMBER OF CONTOURS IN PLOTS', + ' WHEN CINT=0 (AUTO-SCALED)') READ(IUNIT7,*) STATES WRITE(IUNIT8,1300) STATES 1300 FORMAT(' ',L10,' THAT STATE OUTLINES ARE SUPERPOSED') READ (IUNIT7,*) RMSVEC WRITE (IUNIT8,1400) RMSVEC 1400 FORMAT(' ',F10.3,' RMS LENGTH OF PLOTTED VECTORS, IN INCHES') READ(IUNIT7,*) SDENOM WRITE(IUNIT8,1426) SDENOM 1426 FORMAT(' ',1PE10.2,' SCALE DENOMINATOR =', + ' (INPUT LENGTH UNITS)/(METER ON PLOT)') READ (IUNIT7,*) XCENTR, YCENTR WRITE (IUNIT8,1427) XCENTR, YCENTR 1427 FORMAT(' (',1P,E9.2,',',E9.2,')=(X,Y) OF PLOT CENTER, IF CLIPPIN' + ,'G IS NEEDED.') READ (IUNIT7,*) PAPRE PAPRE=MAX(PAPRE,6.) PAPRE=MIN(PAPRE,17.) WRITE (IUNIT8,1428) PAPRE 1428 FORMAT(' ',1P,E10.2,' MAXIMUM INCHES OF PAPER TO BE USED IN' + ,' PLOTS (.LE.17.).') READ (IUNIT7,*) IPEN1 IPEN1=MIN(IPEN1,31) IPEN1=MAX(IPEN1,1) WRITE (IUNIT8,1429) IPEN1 1429 FORMAT(' ',I10,' FINEST PEN WIDTH IN UNITS OF POINTS (INTEGER)') READ (IUNIT7,*) IPEN2 IPEN2=MIN(IPEN2,31) IPEN2=MAX(IPEN2,1) WRITE (IUNIT8,1430) IPEN2 1430 FORMAT(' ',I10,' MEDIUM PEN WIDTH IN UNITS OF POINTS (INTEGER)') READ (IUNIT7,*) IPEN3 IPEN3=MIN(IPEN3,31) IPEN3=MAX(IPEN3,1) WRITE (IUNIT8,1431) IPEN3 1431 FORMAT(' ',I10,' WIDEST PEN WIDTH IN UNITS OF POINTS (INTEGER)') READ(IUNIT7,*) COLOR WRITE(IUNIT8,1432) COLOR 1432 FORMAT(' ',L10,' THAT OUTPUT WILL BE IN COLOR (ELSE B & W)') C READ(IUNIT7,*) C THIS WASTED READ IS TO GET PAST THE 2ND '======' LINE IN INFILE. WRITE(IUNIT8,9999) READ(IUNIT7,*) RADIUS WRITE(IUNIT8,2001) RADIUS 2001 FORMAT(' ',1P,E10.3,' RADIUS OF PLANET, SAME UNITS AS ', + '.FEG GRID FILE') READ(IUNIT7,*) CPNLAT WRITE(IUNIT8,2002) CPNLAT 2002 FORMAT(' ',F10.3,' CPNLAT = NORTH LATITUDE (DEGREES) OF', + ' CONIC PROJECTION TANGENT') READ(IUNIT7,*) Y0NLAT WRITE(IUNIT8,2003) Y0NLAT 2003 FORMAT(' ',F10.3,' Y0NLAT = NORTH LATITUDE (DEGREES) AT', + ' WHICH Y = 0 IN PROJECTION PLANE') READ(IUNIT7,*) X0ELON WRITE(IUNIT8,2004) X0ELON 2004 FORMAT(' ',F10.3,' X0ELON = EAST LONGITUDE (DEGREES) AT', + ' WHICH X = 0 IN PROJECTION PLANE') 9999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END SUBROUTINE READPM C C C SUBROUTINE RESULT (INPUT,ALPHAT,ELEV,ERATE, + FDIP,FIMUDZ, + FPEAKS,FSLIPS,FTAN,GEOTHC, + IUNITT, + MXEL,MXFEL,MXNODE,NFL, + NODEF,NODES,NREALN,NUMEL,NUMNOD,N1000, + ONEKM,RHOAST,RHOBAR,RHOH2O,SIGHB, + TAUMAT,TAUZZI, + TLINT,TLNODE, + V,WEDGE,ZMNODE,ZMOHO,ZTRANC,ZTRANF) C C OUTPUT THE SOLUTION: C -DESCRIPTIVE TABLES TO UNIT "IUNITT". C DOUBLE PRECISION V C NOTE: IN VS-FORTRAN, FOLLOWING TYPE COULD BE LOGICAL*1: LOGICAL FSLIPS REAL ANGLE,HEIGHT C DIMENSION ALPHAT(2),ELEV(MXNODE),ERATE(3,7,MXEL), + FDIP(3,MXFEL),FIMUDZ(7,MXFEL),FPEAKS(2,MXFEL), + FSLIPS(MXFEL),FTAN(7,MXFEL), + GEOTHC(4,7,MXEL), + NODEF(6,MXFEL),NODES(6,MXEL), + RHOBAR(2),SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL),TAUZZI(7,MXEL), + TLINT(7,MXEL),TLNODE(MXNODE),V(2,MXNODE), + ZMNODE(MXNODE),ZMOHO(7,MXEL), + ZTRANC(2,7,MXEL),ZTRANF(2,MXFEL) C C------------------------BEGIN WRITING TO UNIT IUNITT--------------- C C VELOCITIES AT NODES: C WRITE (IUNITT,30) 30 FORMAT(/ /' VELOCITIES OF THE NODES:'/ + ' ', + ' ARGUMENT'/ + ' ', + ' (DEGREES'/ + ' NODE X-COMPONENT Y-COMPONENT MAGNI', + 'TUDE FROM +X)'/) DO 100 I=1,NUMNOD IF (I.LE.NREALN) THEN IP=I ELSE IP=N1000+I-NREALN ENDIF VX=V(1,I) VY=V(2,I) AZIMUT=ATAN2F(VY,VX)*57.2957795 VMAG=SQRT(V(1,I)**2+V(2,I)**2) WRITE (IUNITT,40) IP,V(1,I),V(2,I),VMAG,AZIMUT 40 FORMAT(' ',I5,1P,2D20.12,E10.2,0P,F8.2) 100 CONTINUE C C TRIANGULAR CONTINUUM ELEMENT PROPERTIES AT THEIR CENTERS: C WRITE (IUNITT,110) C C (TABLE BROKEN AFTER 69 CHARACTERS, AND PRECEDED BY C'S): C C CONTINUUM ELEMENT PROPERTIES (AT CENTER POINTS): C C E1=MOST E2=MOST ISOSTATIC VERTICAL VERTICAL / C ELEMENT ARGUMENT COMPRESS. EXTENS. UPLIFT INTEGRAL INTEGRAL / C NUMBER OF E1 RATE RATE RATE OF(SZ+P0) OF(S1+P0)/ C 1 154.56 -1.23E-14 -1.23E-14 -1.23E-16 -1.23E+11 -1.23E+11 / C C VERTICAL BRITTLE/ BRITTLE/ BASAL BASAL<-LENGTH 118 BYTES C INTEGRAL DUCTILE DUCTILE SHEAR SHEAR C OF(S2+P0) IN CRUST IN MANTLE STRESS ARGUMENT C-1.23E+11 1.23E+04 4.15E+04 1.23E+06 145.34 C 110 FORMAT (/ /' CONTINUUM ELEMENT PROPERTIES (AT CENTER POINTS):'/ + /' E1=MOST E2=MOST ISOSTATIC VERTIC', +'AL VERTICAL VERTICAL BRITTLE/ BRITTLE/ BASAL BASAL' + /' ELEMENT ARGUMENT COMPRESS. EXTENS. UPLIFT INTEGR', +'AL INTEGRAL INTEGRAL DUCTILE DUCTILE SHEAR SHEAR' + /' NUMBER OF E1 RATE RATE RATE OF(SZ+', +'P0) OF(S1+P0) OF(S2+P0) IN CRUST IN MANTLE STRESS ARGUMENT'/) 120 FORMAT (' ',I7,F10.2,1P,9E10.2,0P,F10.2) 121 FORMAT (' ',I7,F10.2,1P,7E10.2,' --------',E10.2,0P,F10.2) 122 FORMAT (' ',I7,F10.2,1P,6E10.2,' --------',2E10.2,0P,F10.2) M=1 DO 200 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) CALL PRINCE (INPUT,EXX,EYY,EXY, + OUTPUT,E1,E2,U1X,U1Y,U2X,U2Y) ANGLE=ATAN2F(U1Y,U1X)*57.2957795 EZZ= -(EXX+EYY) TMID=GEOTHC(1,M,I)+GEOTHC(2,M,I)*ZMOHO(M,I)/2.+ + GEOTHC(3,M,I)*(ZMOHO(M,I)/2.)**2 RHOC=RHOBAR(1)*(1.-ALPHAT(1)*TMID) HEIGHT=0. DO 150 N=1,6 HEIGHT=HEIGHT+ELEV(NODES(N,I))*PHI(N,M) 150 CONTINUE IF (HEIGHT.GT.0.) THEN FACTOR=(RHOAST-RHOC)/RHOAST ELSE FACTOR=(RHOAST-RHOC)/(RHOAST-RHOH2O) ENDIF VZ=EZZ*ZMOHO(M,I)*FACTOR TXX=TAUMAT(1,M,I)+TAUZZI(M,I) TYY=TAUMAT(2,M,I)+TAUZZI(M,I) TXY=TAUMAT(3,M,I) TZZ=TAUZZI(M,I) CALL PRINCE (INPUT,TXX,TYY,TXY, + OUTPUT,T1,T2,U1X,U1Y,U2X,U2Y) SIGHX=SIGHB(1,M,I) SIGHY=SIGHB(2,M,I) STHETA=57.2958*ATAN2F(SIGHY,SIGHX) SHEAR=SQRT((1.D0*SIGHX)**2+(1.D0*SIGHY)**2) ZTRANS=ZTRANC(1,M,I) IF ((TLINT(M,I).GT.0.).AND. + (ZTRANC(2,M,I).GT.(0.1*ONEKM))) THEN ZTRANM=ZMOHO(M,I)+ZTRANC(2,M,I) IF ((ZTRANS/ZMOHO(M,I)).GT.0.97) THEN WRITE (IUNITT,122) I,ANGLE,E1,E2,VZ, + TZZ,T1,T2, ZTRANM,SHEAR,STHETA ELSE WRITE (IUNITT,120) I,ANGLE,E1,E2,VZ, + TZZ,T1,T2,ZTRANS,ZTRANM,SHEAR,STHETA ENDIF ELSE WRITE (IUNITT,121) I,ANGLE,E1,E2,VZ, + TZZ,T1,T2,ZTRANS, SHEAR,STHETA ENDIF 200 CONTINUE WRITE (IUNITT,210) 210 FORMAT ( + /' THE FIGURES ABOVE INCLUDE VERTICAL INTEGRALS OF', + ' NORMAL STRESSES THROUGH THE PLATE. COMPRESSIVE' + /' STRESSES ARE NEGATIVE. FOR CONVENIENCE, NORMAL STRESSES ARE', + ' FIRST CORRECTED USING A STANDARD PRESSURE CURVE' + /' P0(Z), BASED ON THE STRUCTURE OF MID-OCEAN SPREADING', + ' RISES (SEE SUBPROGRAM -SQUEEZ-).') C C FAULT ELEMENT PROPERTIES, ALSO AT MIDPOINTS: C IF (NFL.GT.0) WRITE (IUNITT,300) C C (TABLE BROKEN AFTER 64 BYTES, AND PRECEDED BY C'S: C C FAULT ELEMENT PROPERTIES (AT MID-POINTS): C C / C FAULT NODES#2,5 HORIZ. ARGUMENT PLUNGE TOTAL RIGHT/ C ELEMENT (N2 MOVES SLIP OF OF SLIP LATERAL/ C NUMBER REL.TO N5) RATE SLIP SLIP RATE RATE/ C 13 236, 237 1.23E-09 145.16 74.16 1.23E-09 1.02E-09/ C C DOWN-DIP BRITTLE/ MANTLE / C PERPEN. RELATIVE INTEGRAL PEAK DUCTILE BRITTLE/ IS THIS /129 C SHORTNING VERTICAL OF SHEAR SHEAR DEPTH DUCTILE FAULT /BYTES C RATE RATE TRACTION TRACTION IN CRUST DEPTH ACTIVE?/ C 1.23E-09 1.23E-09 1.23E+13 1.23E+07 1.23E+04 4.56E+04 T 13/ C 300 FORMAT (/ / /' FAULT ELEMENT PROPERTIES (AT MID-POINTS):'/ + ' ', + ' ', + ' DOWN-DIP BRITTLE/ MANTLE '/ + ' FAULT NODES#2,5 HORIZ. ARGUMENT', + ' PLUNGE TOTAL RIGHT PERPEN. RELATIVE', + ' INTEGRAL PEAK DUCTILE BRITTLE/ IS THIS '/ + ' ELEMENT (N2 MOVES SLIP OF', + ' OF SLIP LATERAL SHORTNING VERTICAL', + ' OF SHEAR SHEAR DEPTH DUCTILE FAULT '/ + ' NUMBER REL.TO N5) RATE SLIP', + ' SLIP RATE RATE RATE RATE', + ' TRACTION TRACTION IN CRUST DEPTH ACTIVE?'/) 310 FORMAT (' ',I7,I5,',',I5,1P,E9.2,0P,F10.2,F7.2, + 1P,E9.2,3E10.2,4E9.2,L3,I6) 311 FORMAT (' ',I7,I5,',',I5,1P,E9.2,0P,F10.2,F7.2, + 1P,E9.2,3E10.2,3E9.2,' --------',L3,I6) 312 FORMAT (' ',I7,I5,',',I5,1P,E9.2,0P,F10.2,F7.2, + 1P,E9.2,3E10.2,2E9.2,' --------',E9.2,L3,I6) M=4 DO 400 I=1,NFL DIP=FDIP(2,I) JM=NODEF(2,I) JB=NODEF(5,I) DU=V(1,JM)-V(1,JB) DV=V(2,JM)-V(2,JB) IF (JM.GT.NREALN) JM=N1000+(JM-NREALN) IF (JB.GT.NREALN) JB=N1000+(JB-NREALN) AZIMHS=ATAN2F(DV,DU) HORS=SQRT((1.D0*DU)**2+(1.D0*DV)**2) C C ANGLE IS THE FAULT STRIKE, IN RADIANS CCLKWS FROM +X. ANGLE=FTAN(M,I) UNITX=COS(ANGLE) UNITY=SIN(ANGLE) CROSSX= -UNITY CROSSY= +UNITX SINIST=DU*UNITX+DV*UNITY IF (ABS(FDIP(2,I)-1.570796).LT.WEDGE) THEN CLOSE=0. VUPDIP=0. ELSE CLOSE=DU*CROSSX+DV*CROSSY VUPDIP=CLOSE/COS(DIP) ENDIF RELV=VUPDIP*SIN(DIP) SNET=SQRT((1.D0*HORS)**2+(1.D0*VUPDIP)**2) IF (SNET.GT.0.0) THEN PLUNGE= -ASIN(RELV/SNET) ELSE PLUNGE=0. ENDIF RLT= -SINIST SHEAR=FIMUDZ(4,I)*SNET/SIN(DIP) AZIMHS=AZIMHS*57.2957795 PLUNGE=PLUNGE*57.2957795 IF ((TLNODE(JM).GT.0.).AND. + (ZTRANF(2,I).GT.(0.1*ONEKM))) THEN FPMAX=MAX(FPEAKS(1,I),FPEAKS(2,I)) ZTRANM=ZMNODE(JM)+ZTRANF(2,I) IF ((ZTRANF(1,I)/ZMNODE(JM)).GT.0.97) THEN WRITE (IUNITT,312) I,JM,JB,HORS,AZIMHS,PLUNGE, + SNET,RLT,CLOSE,RELV,SHEAR,FPMAX, + ZTRANM,FSLIPS(I),I ELSE WRITE (IUNITT,310) I,JM,JB,HORS,AZIMHS,PLUNGE, + SNET,RLT,CLOSE,RELV,SHEAR,FPMAX, + ZTRANF(1,I),ZTRANM,FSLIPS(I),I ENDIF ELSE WRITE (IUNITT,311) I,JM,JB,HORS,AZIMHS,PLUNGE,SNET, + RLT,CLOSE,RELV,SHEAR,FPEAKS(1,I), + ZTRANF(1,I), FSLIPS(I),I ENDIF 400 CONTINUE WRITE (IUNITT,401) 401 FORMAT(' -----------------------------------', + '-----------------------------------') RETURN END SUBROUTINE RESULT C C C SUBROUTINE SQUARE (INPUT,BRIEF,FDIP,IUNIT8, + MXBN,MXEL,MXFEL,MXNODE, + MXSTAR,NFL,NODEF,NODES,NREALN, + NUMEL,NUMNOD,N1000,WEDGE, + MODIFY,FAZ,XNODE,YNODE, + OUTPUT,AREA,DETJ,DXS,DYS,EDGEFS,EDGETS, + FLEN,FTAN,NCOND,NODCON, + WORK,CHECKN,LIST,NODTYP) C C CHECK, CORRECT, AND COMPLETE THE GEOMETRY OF THE GRID C LOGICAL AGREED,ALLOK,BRIEF,FOUND,MATCH C C NOTE: THE FOLLOWING TYPE COULD BE "LOGICAL*1" IN IBM VS-FORTRAN: LOGICAL CHECKN,EDGEFS,EDGETS C C NOTE: THE FOLLOWING COULD BE MADE "INTEGER*2" IN VS-FORTRAN: INTEGER NODTYP C DIMENSION AREA(MXEL),CHECKN(MXNODE), + DETJ(7,MXEL),DXS(6,7,MXEL),DYS(6,7,MXEL), + EDGEFS(2,MXFEL),EDGETS(3,MXEL),FDIP(3,MXFEL), + FAZ(2,MXFEL),FLEN(MXFEL),FTAN(7,MXFEL), + LIST(MXSTAR),NODCON(MXBN), + NODEF(6,MXFEL),NODES(6,MXEL),NODTYP(MXNODE), + XNODE(MXNODE),YNODE(MXNODE) C C (1) CHECK THAT ALL REAL NODES ARE CONNECTED TO AT LEAST ONE C CONTINUUM (TRIANGULAR) ELEMENT OR FAULT ELEMENT; C DO 110 I=1,NREALN CHECKN(I)=.FALSE. 110 CONTINUE DO 130 I=1,NUMEL DO 120 J=1,6 CHECKN(NODES(J,I))=.TRUE. 120 CONTINUE 130 CONTINUE DO 132 I=1,NFL DO 131 J=1,6 CHECKN(NODEF(J,I))=.TRUE. 131 CONTINUE 132 CONTINUE ALLOK=.TRUE. DO 140 I=1,NREALN ALLOK=ALLOK.AND.CHECKN(I) 140 CONTINUE IF (.NOT.ALLOK) THEN WRITE(IUNIT8,150) 150 FORMAT(' BAD GRID TOPOLOGY: FOLLOWING REAL NODES DO NOT'/ 1 ' BELONG TO ANY CONTINUUM ELEMENT OR FAULT:') DO 160 I=1,NREALN IF (.NOT.CHECKN(I)) WRITE (IUNIT8,155) I 155 FORMAT (' ',43X,I6) 160 CONTINUE STOP ENDIF C C (2) CHECK THAT EVERY NODE IS EITHER A CORNER OR A MIDPOINT NODE, C BUT NOT BOTH. C DO 210 I=1,NUMNOD NODTYP(I)=0 210 CONTINUE NTOFIX=0 ALLOK=.TRUE. DO 250 I=1,NUMEL DO 240 J=1,6 IF (J.LE.3) THEN ITYPE=1 ELSE ITYPE=2 ENDIF N=NODES(J,I) IF (NODTYP(N).EQ.0) THEN NODTYP(N)=ITYPE IF (ITYPE.EQ.2) THEN IF ((XNODE(N).EQ.0.).AND.(YNODE(N).EQ.0.)) + NTOFIX=NTOFIX+1 ENDIF ELSE IF (NODTYP(N).NE.ITYPE) THEN ALLOK=.FALSE. WRITE (IUNIT8,220) N 220 FORMAT(' BAD GRID TOPOLOGY: NODE ',I6, + ' CANNOT BE AN ELEMENT CORNER AND AN', + ' ELEMENT SIDE-MIDPOINT AT THE SAME', + ' TIME.') ENDIF ENDIF 240 CONTINUE 250 CONTINUE DO 290 I=1,NFL DO 280 J=1,6 IF ((J.EQ.2).OR.(J.EQ.5)) THEN ITYPE=2 ELSE ITYPE=1 ENDIF N=NODEF(J,I) IF (NODTYP(N).EQ.0) THEN NODTYP(N)=ITYPE ELSE IF (NODTYP(N).NE.ITYPE) THEN ALLOK=.FALSE. WRITE (IUNIT8,220) N ENDIF ENDIF 280 CONTINUE 290 CONTINUE IF (.NOT.ALLOK) STOP C C (3) CHECK THAT EACH FAULT SIDE WITH REAL NODES ALONG IT SHARES C THOSE SAME 3 NODES WITH A TRIANGULAR CONTINUUM ELEMENT. C ALLOK=.TRUE. DO 390 I=1,NFL DO 380 J=2,5,3 N=NODEF(J,I) IF (N.LE.NREALN) THEN DO 320 K=1,NUMEL DO 310 L=4,6 IF (NODES(L,K).EQ.N) THEN LP=L-2 IF (LP.EQ.4) LP=1 LM=L-3 MATCH=((NODEF(J-1,I).EQ.NODES(LP,K)) + .OR.(NODEF(J-1,I).GT.NREALN)) + .AND.((NODEF(J+1,I).EQ.NODES(LM,K)) + .OR.(NODEF(J+1,I).GT.NREALN)) IF (.NOT.MATCH) THEN ALLOK=.FALSE. WRITE(IUNIT8,305) I,K 305 FORMAT(' BAD GRID TOPOLOGY:', + ' FAULT ',I6,' IS NOT PROPERL' + ,'Y CONNECTED TO ELEMENT ',I6) ELSE GO TO 380 ENDIF ENDIF 310 CONTINUE 320 CONTINUE ENDIF 380 CONTINUE 390 CONTINUE IF (.NOT.ALLOK) STOP C C (4) AVERAGE TOGETHER THE COORDINATES OF ALL NODES AT ONE "POINT" C DO 410 I=1,NUMNOD CHECKN(I)=.FALSE. C (MEANS "NOT YET INVOLVED IN AVERAGING') 410 CONTINUE DO 490 I=1,NFL DO 480 J1=1,3,2 NJ1=NODEF(J1,I) C (FAULT ENDS ARE THE ONLY PLACES THAT CAN HAVE PROBLEMS) IF (.NOT.CHECKN(NJ1)) THEN LIST(1)=NJ1 CHECKN(NJ1)=.TRUE. C BEGIN LIST OF NEIGHBORS WITH PAIRED NODE J2=7-J1 NJ2=NODEF(J2,I) LIST(2)=NJ2 CHECKN(NJ2)=.TRUE. NINSUM=2 C FIND SHORTEST FAULT CONNECTED TO EITHER ONE SHORT=SQRT( + (XNODE(NODEF(1,I))-XNODE(NODEF(3,I)))**2+ + (YNODE(NODEF(1,I))-YNODE(NODEF(3,I)))**2) DO 470 K=1,NFL NL1=NODEF(1,K) NL3=NODEF(3,K) NL4=NODEF(4,K) NL6=NODEF(6,K) IF ((NJ1.EQ.NL1).OR.(NJ2.EQ.NL1).OR. + (NJ1.EQ.NL3).OR.(NJ2.EQ.NL3).OR. + (NJ1.EQ.NL4).OR.(NJ2.EQ.NL4).OR. + (NJ1.EQ.NL6).OR.(NJ2.EQ.NL6)) THEN TEST=SQRT( + (XNODE(NL1)-XNODE(NL3))**2+ + (YNODE(NL1)-YNODE(NL3))**2) SHORT=MIN(SHORT,TEST) ENDIF 470 CONTINUE C COLLECT ALL CORNER NODES WITHIN 10% OF THIS TOLER=SHORT/10. T2=TOLER**2 DO 471 K=1,NUMNOD IF (.NOT.CHECKN(K)) THEN IF (NODTYP(K).EQ.1) THEN R2=(XNODE(NJ1)-XNODE(K))**2+ + (YNODE(NJ1)-YNODE(K))**2 IF (R2.LT.T2) THEN NINSUM=NINSUM+1 LIST(NINSUM)=K CHECKN(K)=.TRUE. ENDIF ENDIF ENDIF 471 CONTINUE C (QUICK EXIT IF ALL NODES IN SAME PLACE) AGREED=.TRUE. DO 472 K=2,NINSUM AGREED=AGREED.AND. + (XNODE(K).EQ.XNODE(1)).AND. + (YNODE(K).EQ.YNODE(1)) 472 CONTINUE IF (AGREED) GO TO 480 XSUM=0. YSUM=0. DO 473 K=1,NINSUM XSUM=XSUM+XNODE(LIST(K)) YSUM=YSUM+YNODE(LIST(K)) 473 CONTINUE XMEAN=XSUM/NINSUM YMEAN=YSUM/NINSUM RMAX=0. DO 474 K=1,NINSUM R=SQRT((XNODE(LIST(K))-XMEAN)**2+ + (YNODE(LIST(K))-YMEAN)**2) RMAX=MAX(RMAX,R) 474 CONTINUE DO 475 K=1,NINSUM XNODE(LIST(K))=XMEAN YNODE(LIST(K))=YMEAN 475 CONTINUE IF (.NOT.BRIEF) THEN IF (RMAX.GT.0.) THEN WRITE(IUNIT8,476) NINSUM, + (LIST(N),N=1,NINSUM) 476 FORMAT(/ + ' AVERAGING TOGETHER THE POSITIONS OF', + ' THESE ',I6,' NODES:',(/' ',12I6)) WRITE (IUNIT8,477) RMAX 477 FORMAT (' MAXIMUM CORRECTION TO ', + 'ANY POSITION IS',1P,E10.2/ + ' YOU ARE RESPONSIBLE FOR ', + ' DECIDING WHETHER THIS IS A', + ' SERIOUS ERR0R!') ENDIF ENDIF ENDIF 480 CONTINUE 490 CONTINUE C C (5) SURVEY STRIKE-SLIP (VERTICAL) FAULTS TO CHECK FOR CONFLICTS IN C ARGUMENT THAT WOULD LOCK THE FAULT. C C LOOP ON ALL FAULT ELEMENTS (I): DO 2000 I=1,NFL C LOOP ON 2 TERMINAL NODE PAIRS, 1-6, 4-3 (J = 1 OR 4): DO 1900 J=1,4,3 C DIP MUST BE WITHIN "WEDGE" OF VERTICAL FOR CONSTRAINT: NDIP=1+J/2 IF (ABS(FDIP(NDIP,I)-1.570796).LE.WEDGE) THEN NAZI=1+J/4 N1=J N6=7-J NODE1=NODEF(N1,I) NODE6=NODEF(N6,I) C NO CONSTRAINT APPLIED WHERE A FAULT ENDS: IF (NODE1.NE.NODE6) THEN C ENDPOINT PAIRS MUST BE CHECKED FOR DUPLICATION: C LOOK FOR OTHER STRIKE-SLIP FAULTS SHARING THIS C PAIR OF NODES, AT EITHER END: FOUND=.FALSE. DO 1600 L=1,NFL IF (L.NE.I) THEN IF (ABS(FDIP(1,L)-1.5708).LE.WEDGE) THEN IF (((NODE1.EQ.NODEF(1,L)).AND. + (NODE6.EQ.NODEF(6,L))).OR. + ((NODE1.EQ.NODEF(6,L)).AND. + (NODE6.EQ.NODEF(1,L)))) THEN FOUND=.TRUE. NUMBER=L NAZL=1 GO TO 1601 ENDIF ENDIF IF (ABS(FDIP(3,L)-1.5708).LE.WEDGE) THEN IF (((NODE1.EQ.NODEF(3,L)).AND. + (NODE6.EQ.NODEF(4,L))).OR. + ((NODE1.EQ.NODEF(4,L)).AND. + (NODE6.EQ.NODEF(3,L)))) THEN FOUND=.TRUE. NUMBER=L NAZL=2 GO TO 1601 ENDIF ENDIF ENDIF 1600 CONTINUE C DON'T WORRY IF THIS PAIR ALREADY CHECKED! 1601 IF (FOUND.AND.(NUMBER.GT.I)) THEN C AVERAGE ARGUMENTS TOGETHER (AVOID CYCLE SHIFTS): AZI=MOD(FAZ(NAZI,I)+1.570796,3.14159265) + -1.570796 AZL=MOD(FAZ(NAZL,NUMBER)+1.570796,3.14159265) + -1.570796 AZIMUT=0.5*(AZI+AZL) FAZ(NAZI,I)=AZIMUT FAZ(NAZL,NUMBER)=AZIMUT IF (ABS(AZI-AZL).GT.0.02) THEN DAZI=AZI*57.2957795 DAZL=AZL*57.2957795 DAZ=AZIMUT*57.2957795 IF (NODE1.LE.NREALN) THEN NP1=NODE1 ELSE NP1=N1000+NODE1-NREALN ENDIF IF (NODE6.LE.NREALN) THEN NP6=NODE6 ELSE NP6=N1000+NODE6-NREALN ENDIF WRITE (IUNIT8,1610) I,NUMBER,NP1,NP6, + DAZI,DAZL,DAZ 1610 FORMAT(/' WARNING: STRIKE-SLIP FAULT ELEMENTS' + ,I7,' AND',I7/' SHARE NODES',I7,' AND', + I7/' BUT THEIR ARGUMENTS OF ',F6.1, + ' AND ',F6.1,' DEGREES DIFFER SUBSTAN', + 'TIALLY.'/' THE ARGUMENTS WILL BE AVERAGED,' + ,' AND A VALUE OF ',F6.1,' WILL BE USED.' + /' THIS IS NECESSARY TO PREVENT FAULT', + ' LOCKING;'/' IF YOU -WANT- THE FAULT LOCKED' + ,', THEN USE A SINGLE NODE AT THIS POINT.') ENDIF ENDIF C ^END BLOCK WHICH LOOKS FOR CONSTRAINTS ON REAL NODES ENDIF C ^END BLOCK WHICH CHECKS FOR DISTINCT NODE NUMBERS ENDIF C ^END BLOCK WHICH CHECKS FOR DIP OF OVER 75 DEGREES 1900 CONTINUE C ^END LOOP ON 2 NODE PAIRS IN FAULT ELEMENT 2000 CONTINUE C ^END LOOP ON FAULT ELEMENTS C C (6) COMPUTE COORDINATES OF MIDPOINT NODES THAT WERE NOT INPUT. C C FIRST, FAULTS: IF ((.NOT.BRIEF).AND.(NFL.GT.0)) WRITE (IUNIT8,540) 540 FORMAT(/ /' FOLLOWING FAULT MID-POINT POSITIONS WERE COMPUTED:'/ + /' FAULT NODE2 NODE5 X Y'/) DO 550 I=1,NFL I1=NODEF(1,I) I2=NODEF(2,I) I3=NODEF(3,I) I5=NODEF(5,I) DX= XNODE(I3)- XNODE(I1) DY= YNODE(I3)- YNODE(I1) AZ=ATAN2(DY,DX) PHI1=FAZ(1,I)-AZ PHI1=MOD(PHI1+1.570796,3.14159265)-1.570796 PHI2=AZ-FAZ(2,I) PHI2=MOD(PHI2+1.570796,3.14159265)-1.570796 IF ((ABS(PHI1).GT.0.001).OR.(ABS(PHI2).GT.0.001)) THEN T1=TAN(PHI1) T2=TAN(PHI2) IF (ABS(T2-T1).GE.ABS(T1+T2)) THEN FACTOR=0.99*ABS(T1+T2)/ABS(T2-T1) IF (ABS(T1).GT.ABS(T2)) THEN T2=T1+FACTOR*(T2-T1) ELSE T1=T2+FACTOR*(T1-T2) ENDIF ENDIF PARRAL=(T2-T1)/(4.*(T1+T2)) PERPEN= T1*T2 /(2.*(T1+T2)) XNODE(I2)=XNODE(I1)+DX/2.+PARRAL*DX-PERPEN*DY YNODE(I2)=YNODE(I1)+DY/2.+PERPEN*DX+PARRAL*DY ELSE XNODE(I2)=(XNODE(I1)+XNODE(I3))/2. YNODE(I2)=(YNODE(I1)+YNODE(I3))/2. ENDIF XNODE(I5)= XNODE(I2) YNODE(I5)= YNODE(I2) NTOFIX=NTOFIX-1 IF (.NOT.BRIEF) WRITE (IUNIT8,549) I,I2,I5,XNODE(I2), 1 YNODE(I2) 549 FORMAT(' ',I6,2I10,1P,2E12.4) 550 CONTINUE C C NEXT, OTHER ELEMENT SIDES, IF NEEDED: IF ((.NOT.BRIEF).AND.(NTOFIX.GT.0)) WRITE (IUNIT8,551) 551 FORMAT(/ /' FOLLOWING MID-POINTS OF CONTINUUM ELEMENT SIDES', + ' THAT WERE 0.0 IN THE' + / ' INPUT DATASET ARE NOW COMPUTED, AS FOLLOWS:' + / / ' ELEMENT NODE X Y'/) DO 590 I=1,NUMEL DO 580 J=4,6 N=NODES(J,I) IF ((XNODE(N).EQ.0.).AND.(YNODE(N).EQ.0.)) THEN JP=J-2 IF (J.EQ.6) JP=1 JM=J-3 XNODE(N)=0.5* + (XNODE(NODES(JP,I))+XNODE(NODES(JM,I))) YNODE(N)=0.5* + (YNODE(NODES(JP,I))+YNODE(NODES(JM,I))) IF (.NOT.BRIEF) + WRITE (IUNIT8,579) I,N,XNODE(N),YNODE(N) 579 FORMAT(' ',I6,I10,1P,2E12.4) ENDIF 580 CONTINUE 590 CONTINUE C C (7) COMPUTE AREAS OF ELEMENTS AND COMPUTE DERIVATIVES OF NODAL C FUNCTIONS AT INTEGRATION POINTS; C THEN CHECK FOR NEGATIVE AREAS C CALL AREAS (INPUT,NODES,NUMEL,NUMNOD,XNODE,YNODE, + OUTPUT,AREA) CALL DERIV (INPUT,AREA,NODES,NUMEL,NUMNOD,XNODE,YNODE, + OUTPUT,DETJ,DXS,DYS) ALLOK=.TRUE. DO 620 M=1,7 DO 610 I=1,NUMEL TEST=AREA(I)*DETJ(M,I) IF (TEST.LE.0.) THEN WRITE(IUNIT8,605) M,I 605 FORMAT(/' EXCESSIVELY DISTORTED ELEMENT LEADS TO ' + ,'NEGATIVE AREA AT POINT ',I1,' IN ELEMENT ', + I5) ALLOK=.FALSE. ENDIF 610 CONTINUE 620 CONTINUE IF (.NOT.ALLOK) STOP C C (8) COMPUTE LENGTHS OF FAULT ELEMENTS. C DO 750 I=1,NFL FLEN(I)=0. X1=XNODE(NODEF(1,I)) X2=XNODE(NODEF(2,I)) X3=XNODE(NODEF(3,I)) Y1=YNODE(NODEF(1,I)) Y2=YNODE(NODEF(2,I)) Y3=YNODE(NODEF(3,I)) OLDX=X1 OLDY=Y1 DO 740 J=1,20 S=J/20. F1=1.-3.*S+2.*S**2 F2=4.*S*(1.-S) F3= -S+2.*S**2 X=X1*F1+X2*F2+X3*F3 Y=Y1*F1+Y2*F2+Y3*F3 FLEN(I)=FLEN(I)+SQRT((X-OLDX)**2+(Y-OLDY)**2) OLDX=X OLDY=Y 740 CONTINUE 750 CONTINUE C C (9) MAKE A LIST OF NODES THAT ARE ON THE BOUNDARY AND REQUIRE C BOUNDARY CONDITIONS (NODCON); THESE ARE IN COUNTERCLOCKWISE C ORDER. ALSO MAKE A LISTS OF ELEMENT SIDES WHICH CONTAIN THESE C NODES: EDGETS AND EDGEFS. C WRITE (IUNIT8,800) 800 FORMAT (/' ----------------------------------------' + / /' COMPILING AN ORDERED LIST OF BOUNDARY NODES...'/) NCOND=0 DO 801 I=1,NUMNOD CHECKN(I)=.FALSE. 801 CONTINUE DO 802 I=1,NFL EDGEFS(1,I)=.FALSE. EDGEFS(2,I)=.FALSE. 802 CONTINUE DO 810 I=1,NUMEL DO 809 J=1,3 CALL NEXT (INPUT,I,J,MXEL,MXFEL,NFL,NODEF,NODES,NUMEL, + OUTPUT,KFAULT,KELE) IF (KELE.GT.0) THEN C (ORDINARY INTERIOR SIDE) EDGETS(J,I)=.FALSE. ELSE IF (KFAULT.EQ.0) THEN C (EXTERIOR SIDE) EDGETS(J,I)=.TRUE. N1=NODES(MOD(J, 3)+1,I) N2=NODES(MOD(J, 3)+4,I) N3=NODES(MOD(J+1,3)+1,I) IF (.NOT.CHECKN(N1)) THEN NCOND=NCOND+1 CHECKN(N1)=.TRUE. ENDIF IF (.NOT.CHECKN(N2)) THEN NCOND=NCOND+1 CHECKN(N2)=.TRUE. ENDIF IF (.NOT.CHECKN(N3)) THEN NCOND=NCOND+1 CHECKN(N3)=.TRUE. ENDIF ELSE C (TRIANGULAR ELEMENT HAS AN EXTERIOR FAULT ELEMENT C ADJACENT TO IT) EDGETS(J,I)=.FALSE. N2=NODES(MOD(J, 3)+4,I) IF (NODEF(2,KFAULT).EQ.N2) THEN EDGEFS(2,KFAULT)=.TRUE. DO 806 K=4,6 N=NODEF(K,KFAULT) IF (.NOT.CHECKN(N)) THEN NCOND=NCOND+1 CHECKN(N)=.TRUE. ENDIF 806 CONTINUE ELSE EDGEFS(1,KFAULT)=.TRUE. DO 808 K=1,3 N=NODEF(K,KFAULT) IF (.NOT.CHECKN(N)) THEN NCOND=NCOND+1 CHECKN(N)=.TRUE. ENDIF 808 CONTINUE ENDIF ENDIF 809 CONTINUE 810 CONTINUE IF (NUMNOD.GT.NREALN) THEN DO 824 I=NREALN+1,NUMNOD IF (.NOT.CHECKN(I)) THEN IO=N1000+I-NREALN WRITE(IUNIT8,822) IO 822 FORMAT(' BAD GRID TOPOLOGY; FAKE NODES ARE NOT', + ' PERMITTED IN THE INTERIOR.'/' CHECK NODE ',I6) STOP ENDIF 824 CONTINUE ENDIF C BEGIN CIRCUIT WITH LOWEST-NUMBERED BOUNDARY NODE DO 830 I=1,NUMNOD IF (CHECKN(I)) GO TO 831 830 CONTINUE 831 NODCON(1)=I NDONE=1 NLEFT=NCOND C BEGINNING OF INDEFINATE LOOP WHICH TRACES AROUND THE PERIMETER. C EACH TIME, IT PROGRESSES BY ONE OF 3 STEPS: C -2 NODES AT A TIME ALONG A TRIANGLE SIDE, OR C -2 NODES AT A TIME ALONG A FAULT ELEMENT SIDE, OR C -BY FINDING ANOTHER (CORNER) NODE WHICH SHARES THE SAME LOCATION. C FIRST, BE SURE THAT WE ARE NOT STARTING ON A MIDPOINT: IF (NODTYP(I).EQ.2) THEN DO 833 K=1,NUMEL DO 832 L=1,3 IF (EDGETS(L,K)) THEN N2=NODES(MOD(L, 3)+4,K) IF (N2.EQ.I) THEN J=NODES(MOD(L+1,3)+1,K) GO TO 839 ENDIF ENDIF 832 CONTINUE 833 CONTINUE DO 835 K=1,NFL IF (EDGEFS(1,K)) THEN IF (NODEF(2,K).EQ.I) THEN J=NODEF(3,K) GO TO 839 ENDIF ELSE IF (EDGEFS(2,K)) THEN IF (NODEF(5,K).EQ.I) THEN J=NODEF(6,K) GO TO 839 ENDIF ENDIF 835 CONTINUE 839 NDONE=2 NODCON(2)=J NLEFT=NCOND-1 ENDIF C BEGINNING OF MAIN INDEFINATE LOOP: 840 NODE=NODCON(NDONE) X=XNODE(NODE) Y=YNODE(NODE) C LOOK FOR AN ADJACENT TRIANGULAR ELEMENT USING THIS NODE. DO 844 I=1,NUMEL DO 842 J=1,3 IF (EDGETS(J,I)) THEN N1=NODES(MOD(J,3)+1,I) IF (N1.EQ.NODE) GO TO 846 ENDIF 842 CONTINUE 844 CONTINUE GO TO 850 846 N2=NODES(MOD(J,3)+4,I) NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N2 CHECKN(N2)=.FALSE. N3=NODES(MOD(J+1,3)+1,I) NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N3 CHECKN(N3)=.FALSE. NLEFT=NLEFT-2 IF (NLEFT.GT.0) THEN GO TO 840 ELSE GO TO 870 ENDIF C ELSE, LOOK FOR AN ADJACENT FAULT ELEMENT USING THIS NODE. 850 DO 854 I=1,NFL IF (EDGEFS(1,I)) THEN IF (NODEF(1,I).EQ.NODE) THEN N2=NODEF(2,I) N3=NODEF(3,I) GO TO 856 ENDIF ELSE IF (EDGEFS(2,I)) THEN IF (NODEF(4,I).EQ.NODE) THEN N2=NODEF(5,I) N3=NODEF(6,I) GO TO 856 ENDIF ENDIF 854 CONTINUE GO TO 860 856 NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N2 CHECKN(N2)=.FALSE. NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=N3 CHECKN(N3)=.FALSE. NLEFT=NLEFT-2 IF (NLEFT.GT.0) THEN GO TO 840 ELSE GO TO 870 ENDIF C ELSE, LOOK FOR ANOTHER EXTERIOR CORNER NODE AT SAME LOCATION. 860 DO 865 I=1,NUMNOD IF ((I.NE.NODE).AND.CHECKN(I)) THEN IF ((NODTYP(I).EQ.1).AND. + ((XNODE(I).EQ.X).AND.(YNODE(I).EQ.Y)))GO TO 867 ENDIF 865 CONTINUE WRITE(IUNIT8,866) NDONE, NODE, X, Y 866 FORMAT(/' AFTER CONNECTING ',I6,' NODES AROUND THE', + ' PERIMETER, '/ + ' PROCESS WAS STOPPED BY BAD GRID TOPOLOGY;'/ + ' COULD NOT FIND ANY WAY TO CONTINUE FROM NODE ',I6/ + ' AT (X=',1P,E10.3,',Y=',E10.3,')'/ + ' EITHER THROUGH SHARED BOUNDARY ELEMENTS, OR'/ + ' THROUGH OTHER BOUNDARY NODES SHARING THE SAME ', + 'POSITION.') STOP 867 NDONE=NDONE+1 IF (NDONE.LE.NCOND) NODCON(NDONE)=I CHECKN(I)=.FALSE. NLEFT=NLEFT-1 IF (NLEFT.GT.0) GO TO 840 C END OF INDEFINATE LOOP WHICH TRACES AROUND PERIMETER. 870 IF (.NOT.BRIEF) THEN WRITE(IUNIT8,880) 880 FORMAT(/ /' HERE FOLLOWS A LIST, IN CONSECUTIVE ORDER,'/ + ' OF THE NODES WHICH DEFINE THE PERIMETER'/ + ' OF THE MODEL; THESE NODES REQUIRE BOUNDARY', + ' CONDITIONS:'/' BC# NODE X Y') DO 890 I=1,NCOND N=NODCON(I) IF (N.GT.NREALN) N=N1000+N-NREALN WRITE(IUNIT8,882) I, N, XNODE(I), YNODE(I) 882 FORMAT(' ',2I6,1P,2E11.3) 890 CONTINUE N=NODCON(1) IF (N.GT.NREALN) N=N1000+N-NREALN WRITE (IUNIT8,892) N 892 FORMAT(' (NOTE: NODE ',I6,' COMPLETES THE LOOP, BUT WILL', + ' NOT BE LISTED TWICE.)') ENDIF C C (11) CALCULATE FAULT ARGUMENT (IN RADIANS, MEASURED COUNTERCLOCKWISE C FROM +X) FOR EACH INTEGRATION POINT IN EACH FAULT ELEMENT. C DO 1000 M=1,7 S=FPOINT(M) DF1DS= -3.+4.*S DF2DS=4.-8.*S DF3DS= -1.+4.*S DO 900 I=1,NFL N1=NODEF(1,I) N2=NODEF(2,I) N3=NODEF(3,I) X1=XNODE(N1) X2=XNODE(N2) X3=XNODE(N3) Y1=YNODE(N1) Y2=YNODE(N2) Y3=YNODE(N3) DXDS=X1*DF1DS+X2*DF2DS+X3*DF3DS DYDS=Y1*DF1DS+Y2*DF2DS+Y3*DF3DS FTAN(M,I)=ATAN2(DYDS,DXDS) 900 CONTINUE 1000 CONTINUE C IF (.NOT. BRIEF) WRITE (IUNIT8,9999) 9999 FORMAT (' --------------------------------------------------', + '-----------------------------') RETURN END SUBROUTINE SQUARE 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) INTEGER I,LASTDR,N1,N2,NSTEP LOGICAL CALLED REAL ALPHAT,DENSE,DENSE1,DENSE2,DREF,ELEVAT,FRAC,GEOTH1,GEOTH2, + GEOTH3,GEOTH4,GMEAN,H,OLDPR,OLDSZZ,ONEKM,PR,PREF,RESID, + RHOAST,RHOBAR,RHOH2O,RHOTOP,SIGZZ,T,TAUZZ,TEMLIM,TEMPC, + TEMPM,Z,ZBASE,ZSTOP,ZTOP C INTERNAL ARRAYS: DIMENSION DREF(NDREF),PREF(0:NDREF) C ARGUMENT ARRAYS: DIMENSION ALPHAT(2),RHOBAR(2),TEMLIM(2) SAVE CALLED,DREF,PREF DATA CALLED /.FALSE./ C C STATEMENT FUNCTIONS: TEMPC(H)=MIN(TEMLIM(1),GEOTH1+GEOTH2*H+GEOTH3*H**2 + +GEOTH4*H**3) TEMPM(H)=MIN(TEMLIM(2),GEOTH5+GEOTH6*H+GEOTH7*H**2 + +GEOTH8*H**3) C C CREATE REFERENCE TEMPERATURE & DENSITY PROFILES TO DEPTH OF NDREF KM C IF (.NOT.CALLED) THEN RHOTOP=RHOBAR(1)*(1.-ALPHAT(1)*GEOTH1) DREF(1)=RHOH2O DREF(2)=RHOH2O DREF(3)=0.7*RHOH2O+0.3*RHOTOP DREF(4)=RHOTOP DREF(5)=RHOTOP DREF(6)=RHOTOP DREF(7)=RHOTOP DREF(8)=0.7*RHOTOP+0.3*RHOAST DO 50 J=9,NDREF DREF(J)=RHOAST 50 CONTINUE PREF(0)=0. DO 100 I=1,NDREF PREF(I)=PREF(I-1)+DREF(I)*GMEAN*ONEKM 100 CONTINUE CALLED=.TRUE. ENDIF C C ROUTINE PROCESSING (ON EVERY CALL): C IF (ELEVAT.GT.0.) THEN ZTOP= -ELEVAT ZBASE=ZSTOP-ELEVAT DENSE1=RHOBAR(1)*(1.-GEOTH1*ALPHAT(1)) H=0. ELSE ZTOP=0. ZBASE=ZSTOP+(-ELEVAT) DENSE1=RHOH2O H=ELEVAT ENDIF LASTDR=ZBASE/ONEKM IF (ZBASE.GT.ONEKM*LASTDR) LASTDR=LASTDR+1 IF (LASTDR.GT.NDREF) THEN WRITE(IUNITT,110) LASTDR 110 FORMAT(' IN SUBPROGRAM SQUEEZ, PARAMETER NDREF '/ + ' MUST BE INCREASED TO AT LEAST ',I10) STOP ENDIF NSTEP=(ZBASE-ZTOP)/ONEKM OLDSZZ=0. OLDPR=0. SIGZZ=0. TAUZZ=0. Z=ZTOP DO 200 I=1,NSTEP Z=Z+ONEKM H=H+ONEKM IF (H.GT.0.) THEN IF (H.LE.ZM) THEN T=TEMPC(H) DENSE2=RHOBAR(1)*(1.-T*ALPHAT(1)) ELSE T=TEMPM(H-ZM) DENSE2=RHOBAR(2)*(1.-T*ALPHAT(2)) ENDIF ELSE DENSE2=RHOH2O ENDIF DENSE=0.5*(DENSE1+DENSE2) IF (Z.GT.0.) THEN N1=Z/ONEKM N2=N1+1 FRAC=Z/ONEKM-N1 PR=PREF(N1)+FRAC*(PREF(N2)-PREF(N1)) ELSE PR=0. ENDIF SIGZZ=SIGZZ-DENSE*GMEAN*ONEKM+(PR-OLDPR) TAUZZ=TAUZZ+0.5*(SIGZZ+OLDSZZ)*ONEKM DENSE1=DENSE2 OLDSZZ=SIGZZ OLDPR=PR 200 CONTINUE RESID=ZBASE-Z H=ZSTOP Z=ZBASE IF (ZSTOP.LE.ZM) THEN T=TEMPC(H) DENSE2=RHOBAR(1)*(1.-T*ALPHAT(1)) ELSE T=TEMPM(H-ZM) DENSE2=RHOBAR(2)*(1.-T*ALPHAT(2)) ENDIF DENSE=0.5*(DENSE1+DENSE2) IF (Z.GT.0.) THEN N1=Z/ONEKM N2=N1+1 FRAC=Z/ONEKM-N1 PR=PREF(N1)+FRAC*(PREF(N2)-PREF(N1)) ELSE PR=0. ENDIF SIGZZB=SIGZZ-DENSE*GMEAN*RESID+(PR-OLDPR) TAUZZ=TAUZZ+0.5*(SIGZZB+OLDSZZ)*RESID RETURN END SUBROUTINE SQUEEZ C C C SUBROUTINE TAUDEF (INPUT,ALPHA,ERATE,MXEL,NUMEL,TOFSET, + OUTPUT,TAUMAT) C C COMPUTES VERTICAL INTEGRALS OF RELATIVE C OR DEVIATORIC STRESS (TAUMAT). C C THE COMPONENTS ARE: C TAUMAT(1) = VERTICAL INTEGRAL OF (SXX-SZZ) C TAUMAT(2) = VERTICAL INTEGRAL OF (SYY-SZZ) C TAUMAT(3) = VERTICAL INTEGRAL OF SXY. C DIMENSION ALPHA(3,3,7,MXEL),ERATE(3,7,MXEL), + TAUMAT(3,7,MXEL),TOFSET(3,7,MXEL) C DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) TAUMAT(1,M,I)=TOFSET(1,M,I)+EXX*ALPHA(1,1,M,I)+ + EYY*ALPHA(1,2,M,I)+EXY*ALPHA(1,3,M,I) TAUMAT(2,M,I)=TOFSET(2,M,I)+EXX*ALPHA(2,1,M,I)+ + EYY*ALPHA(2,2,M,I)+EXY*ALPHA(2,3,M,I) TAUMAT(3,M,I)=TOFSET(3,M,I)+EXX*ALPHA(3,1,M,I)+ + EYY*ALPHA(3,2,M,I)+EXY*ALPHA(3,3,M,I) 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE TAUDEF C C C SUBROUTINE THONB (INPUT,ECREEP,ETAMAX,GLUE, + MXEL,MXNODE, + NODES,NUMEL,NUMNOD, + OVB,PULLED,TRHMAX,V, + OUTPUT,DVB,SIGHB, + WORK,OUTVEC) C C CALCULATES SHEAR STRESSES ON BASE OF PLATE (SIGHB), AND C THE VECTOR VELOCITY OF THE LAYER BELOW (OVB), AND C THE SCALAR VELOCITY DIFFERENCE OF THE LAYER BELOW (DVB). C C NOTE: FOLLOWING TYPE CAN BE COMPRESSED TO LOGICAL*1 IN VS-FORTRAN: LOGICAL PULLED C DOUBLE PRECISION V DIMENSION DVB(7,MXEL), + GLUE(7,MXEL), + NODES(6,MXEL),OUTVEC(2,7,MXEL), + OVB(2,7,MXEL),PULLED(7,MXEL), + SIGHB(2,7,MXEL), + V(2,MXNODE) C CALL FLOW (INPUT,NODES,NUMEL,NUMNOD,V, + OUTPUT,OUTVEC) DO 1000 M=1,7 DO 900 I=1,NUMEL VPX=OUTVEC(1,M,I) VPY=OUTVEC(2,M,I) VAX=OVB(1,M,I) VAY=OVB(2,M,I) VRX=VAX-VPX VRY=VAY-VPY VMAG=SQRT((1.D0*VRX)**2+(1.D0*VRY)**2) DVB(M,I)=VMAG IF (PULLED(M,I).AND.(VMAG.GT.0.0)) THEN DVX=VRX/VMAG DVY=VRY/VMAG SHEAR1=GLUE(M,I)*VMAG**ECREEP SHEAR2=ETAMAX*VMAG SHEAR3=TRHMAX SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3) SIGHB(1,M,I)=SHEAR*DVX SIGHB(2,M,I)=SHEAR*DVY ELSE SIGHB(1,M,I)=0. SIGHB(2,M,I)=0. ENDIF 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE THONB C C C SUBROUTINE VISCOS (INPUT,ACREEP,ALPHAT,BCREEP,BIOT, + CCREEP,DCREEP,ECREEP, + ERATE,FRIC,G,GEOTHC,GEOTHM, + MXEL,NUMEL,RHOBAR,RHOH2O, + SIGHB,TAUMAT,TEMLIM,TLINT, + VISMAX,ZMOHO, + OUTPUT,ALPHA,SCOREC,SCORED,TOFSET,ZTRANC) C C Computes tactical partial-derivitive tensor ALPHA(3,3,7,NUMEL) C (partial derivitives of vertically-integrated stresses C tau.ij [where normal components are relative to vertical stress] C with respect to strain-rates e.kl) C in 3 x 3 component form, from 2 x 2 principal-axis form C provided by DIAMND, at each integration point of each element. C Also records intercept values (TOFSET(3,7,NUMEL)) for next iteration C Calculation of TAUMAT = TOFSET + ALPHA*E will give model C relative stress integrals (relative to vertical stress integral). C ZTRANC(2,7,NUMEL) is the depth into the (1:crust, 2:mantle) where C the brittle/ductile transition occurs, for each integration point C of each element. Note: "C" in the name stands for "Continuum" C (as opposed to Fault), not for "Crust". C SCOREC and SCORED are measures of mismatch between current C linearized and actual nonlinear rheologies: C SCOREC is the maximum (absolute value) error in tau [N/m]; C SCORED is the mean-error/mean-value [dimensionless; <=1?]. C C New version, May 5, 1998, by Peter Bird; intended to improve C the convergence behavior of all F-E programs which use it. C For an elementary (not comprehensive) test of VISCOS, C see test program ISOTROPY.for, 1998.4.18, which shows that C it preserves linear-viscous behavior in all 3 branches C of its code (when linear-viscous behavior is reported by DIAMND). C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C External variables and arrays INTEGER I, INPUT, M, MXEL, NUMEL REAL BIOT, ECREEP, FRIC, G, + OUTPUT, RHOH2O, SCOREC, SCORED, VISMAX REAL ACREEP(2), ALPHA(3,3,7,MXEL), + ALPHAT(2), BCREEP(2), + CCREEP(2), DCREEP(2), + ERATE(3,7,MXEL), + GEOTHC(4,7,MXEL), GEOTHM(4,7,MXEL), + RHOBAR(2), SIGHB(2,7,MXEL), + TAUMAT(3,7,MXEL), TEMLIM(2), + TLINT(7,MXEL), TOFSET(3,7,MXEL), + ZMOHO(7,MXEL), ZTRANC(2,7,MXEL) C External function (part of SPHERE): C REAL ATAN2F C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C Internal variables and arrays: REAL CENTER, DELP2, DENOM, DENOM0, DENOM1, DIVER, + DANDEX, DANDEY, DANDES, + DE1DEX, DE1DEY, DE1DES, + DE2DEX, DE2DEY, DE2DES, + DTSDE1, DTSDE2, + DTSDT1, DTSDT2, DTSDAN, + DTXDE1, DTXDE2, + DTXDT1, DTXDT2, DTXDAN, + DTYDE1, DTYDE2, + DTYDT1, DTYDT2, DTYDAN, + DT1DE1, DT1DE2, DT2DE1, DT2DE2, + DXX, DXY, DYY, + EXX, EXY, EYY, E1, E2, PL0, PW0, + PT1DE1, PT1DE2, PT2DE1, PT2DE2, + PT1, PT2, PTXX, PTXY, PTYY, + R, RHOUSE, + SHEAR, SHEAR2, SIGHBI, + THETA, THICKC, THICKM, TMEAN, TXX, TXY, TYY, + ZOFTOP, ZTRAN(2) C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C C Initialize sums to be used in computation of scores: SCOREC=0. SCORED=0. DENOM0=0. DENOM1=0. C DO 1000 M=1,7 DO 900 I=1,NUMEL C C ----------- rheology (& ZTRANC) section ------------ C C Extract data for this integration point, as scalars: SIGHBI=SQRT((1.D0*SIGHB(1,M,I))**2+ + (1.D0*SIGHB(2,M,I))**2) THICKC=ZMOHO(M,I) THICKM=TLINT(M,I) EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) C C Guard against special case of zero strain-rate: IF ((EXX.EQ.0.).AND.(EXY.EQ.0.).AND.(EYY.EQ.0.)) THEN TXX=0. TXY=0. TYY=0. C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) ALPHA(1,1,M,I)=4.*VISMAX*(THICKC+THICKM) ALPHA(1,2,M,I)=2.*VISMAX*(THICKC+THICKM) ALPHA(1,3,M,I)=0. ALPHA(2,1,M,I)=2.*VISMAX*(THICKC+THICKM) ALPHA(2,2,M,I)=4.*VISMAX*(THICKC+THICKM) ALPHA(2,3,M,I)=0. ALPHA(3,1,M,I)=0. ALPHA(3,2,M,I)=0. ALPHA(3,3,M,I)=2.*VISMAX*(THICKC+THICKM) TOFSET(1,M,I)=0. TOFSET(2,M,I)=0. TOFSET(3,M,I)=0. ZTRANC(1,M,I)=0. C Note: "C" is for Continuum, not for Crust! C 1st subscript is: (1:crust; 2:mantle). ZTRANC(2,M,I)=0. ELSE C (strain-rate tensor is not zero) C Find principal strain-rates (E1 <= E2) C in the horizontal plane: DIVER=EXX+EYY R=SQRT((1.D0*EXY)**2+(0.5D0*(EXX-EYY))**2) E1=0.5*DIVER-R E2=0.5*DIVER+R THETA=ATAN2F(2.*EXY,EXX-EYY) C see (29) of Bird (1989); C THETA is like angular coordinate of Mohr's circles C of strain-rate and also of stress; C THETA = 0 when EXX > EYY and EXY =0; C THETA = small, + when EXY > 0, EXX > EYY; C THETA = Pi when EXY = 0, EYY > EXX. C C Prepare to sum tau (and derivitives) over layers: TXX=0. TXY=0. TYY=0. DT1DE1=0. DT1DE2=0. DT2DE1=0. DT2DE2=0. C IF (THICKC.GT.0) THEN ZOFTOP=0. PL0=0. PW0=0. CALL DIAMND (INPUT,ACREEP(1),ALPHAT(1), + BCREEP(1),BIOT, + CCREEP(1),DCREEP(1), + ECREEP, + E1,E2,FRIC,G, + GEOTHC(1,M,I), + GEOTHC(2,M,I), + GEOTHC(3,M,I), + GEOTHC(4,M,I), + PL0,PW0, + RHOBAR(1),RHOH2O,SIGHBI, + THICKC,TEMLIM(1), + VISMAX,ZOFTOP, + OUTPUT,PT1DE1,PT1DE2, + PT2DE1,PT2DE2, + PT1,PT2,ZTRAN(1)) CENTER=0.5*(PT1+PT2) SHEAR=0.5*(PT2-PT1) PTXX=CENTER+SHEAR*COS(THETA) PTYY=CENTER-SHEAR*COS(THETA) PTXY=SHEAR*SIN(THETA) C Add contribution of crust to total: TXX=TXX+PTXX TXY=TXY+PTXY TYY=TYY+PTYY DT1DE1=DT1DE1+PT1DE1 DT1DE2=DT1DE2+PT1DE2 DT2DE1=DT2DE1+PT2DE1 DT2DE2=DT2DE2+PT2DE2 ZTRANC(1,M,I)=ZTRAN(1) ELSE ZTRANC(1,M,I)=0. END IF C IF (THICKM.GT.0) THEN ZOFTOP=THICKC PW0=RHOH2O*G*THICKC TMEAN=GEOTHC(1,M,I)+ + 0.5*GEOTHC(2,M,I)*THICKC+ + 0.333*GEOTHC(3,M,I)*THICKC**2+ + 0.25*GEOTHC(4,M,I)*THICKC**3 RHOUSE=RHOBAR(1)*(1.-ALPHAT(1)*TMEAN) PL0=RHOUSE*G*THICKC CALL DIAMND (INPUT,ACREEP(2),ALPHAT(2), + BCREEP(2),BIOT, + CCREEP(2),DCREEP(2), + ECREEP, + E1,E2,FRIC,G, + GEOTHM(1,M,I), + GEOTHM(2,M,I), + GEOTHM(3,M,I), + GEOTHM(4,M,I), + PL0,PW0, + RHOBAR(2),RHOH2O,SIGHBI, + THICKM,TEMLIM(2), + VISMAX,ZOFTOP, + OUTPUT,PT1DE1,PT1DE2, + PT2DE1,PT2DE2, + PT1,PT2,ZTRAN(2)) CENTER=0.5*(PT1+PT2) SHEAR=0.5*(PT2-PT1) PTXX=CENTER+SHEAR*COS(THETA) PTYY=CENTER-SHEAR*COS(THETA) PTXY=SHEAR*SIN(THETA) TXX=TXX+PTXX TXY=TXY+PTXY TYY=TYY+PTYY DT1DE1=DT1DE1+PT1DE1 DT1DE2=DT1DE2+PT1DE2 DT2DE1=DT2DE1+PT2DE1 DT2DE2=DT2DE2+PT2DE2 ZTRANC(2,M,I)=ZTRAN(2) ELSE ZTRANC(2,M,I)=0. END IF C C ---------- ALPHA and TOFSET section ------------- C (cases of non-zero strain-rate) C IF (R.LE.0.) THEN C Pathological case: EXY = 0, EXX = EYY /= 0. C See notes from derivations of 18 April 1998; C based on (28) of Bird(1989), but not using C (29) because r = 0 and alpha is undefined. C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) ALPHA(1,1,M,I)=DT2DE2 ALPHA(1,2,M,I)=DT1DE2 ALPHA(1,3,M,I)=0. ALPHA(2,1,M,I)=DT1DE2 ALPHA(2,2,M,I)=DT2DE2 ALPHA(2,3,M,I)=0. ALPHA(3,1,M,I)=0. ALPHA(3,2,M,I)=0. ALPHA(3,3,M,I)=0.5*(DT1DE1-DT2DE1- + DT1DE2+DT2DE2) ELSE C typical case, r > 0: see p. 3976 in Bird (1989). DE1DEX=0.5-((EXX-EYY)/(4.*R)) DE1DEY=0.5+((EXX-EYY)/(4.*R)) DE1DES= -EXY/R DE2DEX=DE1DEY DE2DEY=DE1DEX DE2DES= -DE1DES DANDEX= -SIN(THETA)/(2.*R) C Note: Formula above is equivalent to (29) of C Bird (1989), but less likely to be singular. DANDEY= -DANDEX DANDES=COS(THETA)/R C Note: Formula above is equivalent to (29) of C Bird (1989), but less likely to be singular. DTXDT1=0.5*(1.-COS(THETA)) DTXDT2=0.5*(1.+COS(THETA)) DTXDAN= -TXY DTYDT1=DTXDT2 DTYDT2=DTXDT1 DTYDAN=TXY DTSDT1= -0.5*SIN(THETA) DTSDT2= -DTSDT1 SHEAR=SQRT(TXY**2+(0.5*(TXX-TYY))**2) DTSDAN=SHEAR*COS(THETA) C 1st subscript of ALPHA is (1:TXX,2:TYY,3:TXY) C 2nd subscript of ALPHA is (1:EXX,2:EYY,3:EXY) DTXDE1=DTXDT1*DT1DE1+DTXDT2*DT2DE1 DTXDE2=DTXDT1*DT1DE2+DTXDT2*DT2DE2 ALPHA(1,1,M,I)= + DTXDE1*DE1DEX+DTXDE2*DE2DEX+DTXDAN*DANDEX ALPHA(1,2,M,I)= + DTXDE1*DE1DEY+DTXDE2*DE2DEY+DTXDAN*DANDEY ALPHA(1,3,M,I)= + DTXDE1*DE1DES+DTXDE2*DE2DES+DTXDAN*DANDES DTYDE1=DTYDT1*DT1DE1+DTYDT2*DT2DE1 DTYDE2=DTYDT1*DT1DE2+DTYDT2*DT2DE2 ALPHA(2,1,M,I)= + DTYDE1*DE1DEX+DTYDE2*DE2DEX+DTYDAN*DANDEX ALPHA(2,2,M,I)= + DTYDE1*DE1DEY+DTYDE2*DE2DEY+DTYDAN*DANDEY ALPHA(2,3,M,I)= + DTYDE1*DE1DES+DTYDE2*DE2DES+DTYDAN*DANDES DTSDE1=DTSDT1*DT1DE1+DTSDT2*DT2DE1 DTSDE2=DTSDT1*DT1DE2+DTSDT2*DT2DE2 ALPHA(3,1,M,I)= + DTSDE1*DE1DEX+DTSDE2*DE2DEX+DTSDAN*DANDEX ALPHA(3,2,M,I)= + DTSDE1*DE1DEY+DTSDE2*DE2DEY+DTSDAN*DANDEY ALPHA(3,3,M,I)= + DTSDE1*DE1DES+DTSDE2*DE2DES+DTSDAN*DANDES END IF C ----------- TOFSET section ------------------ C (case of non-zero strain rate) TOFSET(1,M,I)=TXX-ALPHA(1,1,M,I)*EXX + -ALPHA(1,2,M,I)*EYY + -ALPHA(1,3,M,I)*EXY TOFSET(2,M,I)=TYY-ALPHA(2,1,M,I)*EXX + -ALPHA(2,2,M,I)*EYY + -ALPHA(2,3,M,I)*EXY TOFSET(3,M,I)=TXY-ALPHA(3,1,M,I)*EXX + -ALPHA(3,2,M,I)*EYY + -ALPHA(3,3,M,I)*EXY END IF CC C ---------- SCORE section ----------------- C C Build tentative denominator for score, based C on old values of TAUMAT (tau relative to vertical). DELP2=(0.5*(TAUMAT(1,M,I)+TAUMAT(2,M,I)))**2 SHEAR2=TAUMAT(3,M,I)**2+ + (0.5*(TAUMAT(1,M,I)-TAUMAT(2,M,I)))**2 DENOM0=DENOM0+SQRT(MAX(DELP2,SHEAR2)) C C Build alternative denominator for score, based C on new values of TXX,TXY,TYY (tau relative to vertical). DELP2=(0.5*(TXX+TYY))**2 SHEAR2=TXY**2+(0.5*(TXX-TYY))**2 DENOM1=DENOM1+SQRT(MAX(DELP2,SHEAR2)) C C Evaluate difference between old and new tau: DXX=TAUMAT(1,M,I)-TXX DYY=TAUMAT(2,M,I)-TYY DXY=TAUMAT(3,M,I)-TXY DELP2=(0.5*(DXX+DYY))**2 SHEAR2=(0.5*(DXX-DYY))**2+DXY**2 SCOREC=MAX(SCOREC,SQRT(DELP2),SQRT(SHEAR2)) SCORED=SCORED+SQRT(MAX(DELP2,SHEAR2)) C 900 CONTINUE 1000 CONTINUE C C In computing SCORED, use larger of (old, new) denominators: DENOM=MAX(DENOM0,DENOM1) IF (DENOM.GT.0.) THEN SCORED=SCORED/DENOM ELSE SCORED=0.0 END IF C C NOTE: SCOREC is already computed in loop above. C RETURN END SUBROUTINE VISCOS C C C SUBROUTINE LIMITS (INPUT,AREA,DETJ,IUNITT,MXEL, + NUMEL,OKDELV,REFSTR,TLINT,ZMOHO, + OUTPUT,CONSTR,ETAMAX,FMUMAX,VISMAX) C C COMPUTE AREA, MEAN THICKNESS, AND OTHER DIMENSIONAL PARAMETERS C OF THE CRUST, THEN DETERMINE VALUES OF STIFFNESS LIMITS NEEDED C TO KEEP VELOCITY ERR0RS DOWN TO ORDER "OKDELV" AT SHEAR STRESS C LEVEL "REFSTR". C DIMENSION AREA(MXEL),DETJ(7,MXEL),TLINT(7,MXEL),ZMOHO(7,MXEL) C C DATA ITEM "NFAULT" GIVES THE TYPICAL NUMBER OF FAULTS WHICH ARE C CROSSED BY ANY STRAIGHT LINE RUNNING ACROSS THE MODEL. IT DOES C NOT NEED TO BE ACCURATE! DATA NFAULT /5/ C TOTALA=0. TOTALV=0. DO 20 M=1,7 DO 10 I=1,NUMEL DA=AREA(I)*DETJ(M,I)*WEIGHT(M) TOTALA=TOTALA+DA TOTALV=TOTALV+DA*(ZMOHO(M,I)+TLINT(M,I)) 10 CONTINUE 20 CONTINUE THICK=TOTALV/TOTALA SIDE=SQRT(TOTALA) CONSTR=NFAULT*REFSTR*THICK/OKDELV ETAMAX=2.*REFSTR*THICK/(SIDE*OKDELV) FMUMAX=NFAULT*REFSTR/OKDELV VISMAX=REFSTR*SIDE/OKDELV WRITE (IUNITT,50) TOTALA,TOTALV,THICK,SIDE,CONSTR,ETAMAX, + FMUMAX,VISMAX 50 FORMAT (/ /' SUBPROGRAM -LIMITS- PERFORMS DIMENSIONAL ANALYSIS'/ + ' AND ESTIMATES NECESSARY STIFFNESS LIMITS TO BALANCE'/1P, + ' THE CONFLICTING OBJECTIVES OF ACCURACY AND PRECISION:'/ / + ' AREA OF MODEL = ',E10.3,' LENGTH**2'/ + ' VOLUME OF CRUST = ',E10.3,' LENGTH**3'/ + ' TYPICAL THICKNESS = ',E10.3,' LENGTH'/ + ' TYPICAL WIDTH = ',E10.3,' LENGTH'/ + ' CONSTR (CONSTRAINT WEIGHT) = ',E10.3,' FORCE-SEC/LENGTH**2'/ + ' ETAMAX (MAX. BASAL COUPLING) = ',E10.3,' FORCE-SEC/LENGTH**3'/ + ' FMUMAX (MAX. FAULT STIFFNESS) = ',E10.3,' FORCE-SEC/LENGTH**3'/ + ' VISMAX (MAX. BLOCK VISCOSITY) = ',E10.3,' FORCE-SEC/LENGTH**2') RETURN END SUBROUTINE LIMITS C C C SUBROUTINE PAINT (NODES,XNOD,YNOD,TITLE,TEXT,JV,NTYPE, + FUNC,CINT,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYSTB,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMT,TAUZZ, + DOFLTS,FDIP,FLEN,FSLIPS,FTAN,NFL,NODEF,WEDGE, + IPEN1,IPEN2,IPEN3) C C PLOTS CONTOUR DIAGRAMS AND (OPTIONALLY) A BASEMAP. C LABELS WITH VARIABLE AND TIME ABOVE, MODEL TITLE BELOW. C PLACES COLORBAR WITH CONTOUR VALUES AND UNITS ON RIGHT. C SYMBOLS FOR VECTORS OR TENSORS MAY BE OVERLAIN IN BLACK; C IF SO, THEY WILL HAVE A GRAPHICAL SCALE AT UPPER RIGHT. C CHARACTER*80 TITLE CHARACTER*42 TEXT,VUNITS CHARACTER*9 CHAR9,SCALEV CHARACTER*8 SCALEA INTEGER N LOGICAL ALLPOS,DASHED,DOAROW,DOAXES, + DOESYM,DOFLTS,DOTICS,DOTRACE,STATES LOGICAL DRAWST,FSLIPS REAL ANGLE, HEIGHT, XINCH DIMENSION DRAWST(NXYSTB),ERATE(3,7,NUMEL),FBLAND(NTYPE), + FDIP(3,NFL),FLEN(NFL),FSLIPS(NFL),FTAN(7,NFL), + FUNC(NUMNOD),LOWBLU(NTYPE), + NODEF(6,NFL),NODES(6,NUMEL),NVCHAR(NTYPE), + NVUCHR(NTYPE),OUTVEC(2,7,NUMEL), + TAUMT(3,7,NUMEL),TAUZZ(7,NUMEL), + TEXT(NTYPE),VUNITS(NTYPE),XIP(7,NUMEL),YIP(7,NUMEL), + XNOD(NUMNOD),YNOD(NUMNOD), + XST(NXYSTB),YST(NXYSTB) C IF (FBLAND(JV).NE.0.) THEN FMIDLE=FBLAND(JV) ELSE FTOPS=FUNC(1) FLOOR=FUNC(1) DO 5 I=2,NUMNOD FTOPS=MAX(FTOPS,FUNC(I)) FLOOR=MIN(FLOOR,FUNC(I)) 5 CONTINUE FMIDLE=(FTOPS+FLOOR)/2. ENDIF IFLIP=LOWBLU(JV) C C ASSUMING CONIC PROJECTION: DEGWID=(((9.00/39.37)*SDENOM)/RADIUS)*57.29578 CALL GOPLOT (INPUT,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + X0ELON,CPNLAT, + XNOD,YNOD, + OUTPUT,DEGPEI,MAPTYP,XWIDE) C CALL PROJCT('LINEAR') C C PRECOMPUTE X-COORDINATE (POINTS) FOR RELATIVE POSITION OF KEY C (STRICTLY BY TRIAL/ERROR, SINCE PAPER SIZE HAS CHANGED) XINCH=(RDI12/72.) - 0.55 C C********************************************************************** C C BEGIN "SEGMENT 1" (CONTOURED ELEMENTS) C CALL CONTEL (NODES,XNOD,YNOD,FUNC,CINT,NUMNOD,NUMEL, + FMAX,FMIN,NCOLOR,FMIDLE,IFLIP, + ALLPOS,IPEN1) C C END SEGMENT OF COLORED ELEMENTS C C************************************************************* C C BEGIN "SEGMENT 2" (VECTORS OR TENSOR SYMBOLS, OR DUMMY) C TENSORS INCLUDED WITH OTHER VARIABLES) C IF (DOAROW) THEN CALL PENCLR('foreground') CALL NEWPEN(IPEN2) SIZEAR=SDENOM*RMSVEC/39.37 C SIZEAR IS NOW IN METERS IN THE X,Y PROJECTION PLANE CALL PROJCT('LINEAR') CALL ARROWS (INPUT,CINT,NUMEL,OUTVEC, + SIZEAR,XIP,YIP, + OUTPUT,BIG,FACTR) C C ELSE IF (DOAXES) THEN IF (COLOR) THEN CALL PENCLR('foreground') ELSE CALL SETPAT(NGRAY+1) ENDIF CALL NEWPEN (IPEN1) CALL PROJCT('LINEAR') SIZEAX=SDENOM*RMSVEC/39.37 CALL AXES (INPUT,CINT,IPEN1,NUMEL,SIZEAX, + TAUMT,TAUZZ, + XIP,YIP, + OUTPUT,BIG,FACTR) C C ELSE IF (DOESYM) THEN CALL CHGCLR('foreground',.TRUE.,.TRUE.) CALL NEWPEN(IPEN1) SIZEIC=SDENOM*RMSVEC/39.37 CALL PROJCT('LINEAR') CALL FICONS (NUMEL,ERATE,SIZEIC, + XIP,YIP) ENDIF C IF (DOFLTS.AND.(NFL.GT.0)) THEN CALL PROJCT ('LINEAR') C C IF COLOR, THEN PLOT ALL FAULTS IN RED SUM=0.0 DO 32 I=1,NFL SUM=SUM+FLEN(I) 32 CONTINUE AVERAG=SUM/NFL IF (NUMNOD.LE.600) THEN NTIC=3 DIPSIZ=0.15*AVERAG ELSE IF (NUMNOD.LE.2000) THEN NTIC=2 DIPSIZ=0.20*AVERAG ELSE NTIC=1 DIPSIZ=0.25*AVERAG ENDIF IF (COLOR) CALL PENCLR('red_______') CALL NEWPEN(IPEN1) CALL BGROUP DO 35 I=1,NFL DASHED=.NOT.FSLIPS(I) DOTRACE=.FALSE. DOTICS=.TRUE. CALL FAULT (INPUT,DASHED,DOTICS,DOTRACE, + FDIP,FTAN,I, + NFL,NUMNOD,NODEF,NTIC,DIPSIZ, + WEDGE,XNOD,YNOD) 35 CONTINUE CALL EGROUP IF (COLOR) CALL PENCLR('red_______') CALL NEWPEN(IPEN2) CALL BGROUP DO 36 I=1,NFL DASHED=.NOT.FSLIPS(I) DOTRACE=.TRUE. DOTICS=.FALSE. CALL FAULT (INPUT,DASHED,DOTICS,DOTRACE, + FDIP,FTAN,I, + NFL,NUMNOD,NODEF,NTIC,DIPSIZ, + WEDGE,XNOD,YNOD) 36 CONTINUE CALL EGROUP ENDIF C C END SEGMENT C C******************************************************************* IF (STATES) THEN C C BEGIN SEGMENT FOR STATE LINES (3) C C USE FOREGROUND PEN TO OVERWRITE OTHER COLORS C CALL PROJCT('LINEAR') C CALL USMAP (INPUT,DRAWST,IPEN3,'foreground', + NXYSTB,XST,YST) C C END SEGMENT WITH STATE LINES C ENDIF C**************************************************************** C CALL PROJCT('CONIC') CALL FRAME(DOGRID=.TRUE.) CALL PROJCT('NONE') C C BEGIN SEGMENT 4 (COLOR BAR AND CONTOUR INTERVALS) C CALL BGROUP C C DETERMINE SCALE FACTORS FOR COLOR BAR C IF (ALLPOS) FMIN=MAX(FMIN,0.) RANGE=FMAX-FMIN STEPS=RANGE/CINT YPERST=MIN(0.5,8.0/MAX(STEPS,0.01)) YTOP=4.25+YPERST*STEPS/2. YBOT=4.25-YPERST*STEPS/2. ORIGIN=4.25-((FMAX+FMIN)/(2.*CINT))*YPERST NSTEPT=IBELOW(FMAX/CINT) NSTEPB=IBELOW(FMIN/CINT) HEIGHT=0.18 WIDTH=HEIGHT*0.87 C C ADD UNITS C WIDE=WIDTH*NVUCHR(JV) IF ((WIDE/2.).LE.(2.-1.65)) THEN X=XINCH+1.65-WIDE/2. ELSE X=XINCH+2.-WIDE ENDIF Y=YTOP+0.7*HEIGHT YOLD=Y YNEXT=Y-1.1*HEIGHT C CALL SYMBOL (X,Y,HEIGHT,VUNITS(JV),IDUMMY,0.,NVUCHR(JV)) C C DRAW BOXES AND CONTOUR LABELS C CALL NEWPEN(IPEN1) DO 1050 I=NSTEPT,NSTEPB,-1 FTOP=(I+1)*CINT IF (I.EQ.NSTEPT) FTOP=FMAX FBOT=I*CINT IF (I.EQ.NSTEPB) FBOT=FMIN YTOP=FTOP*YPERST/CINT+ORIGIN YBOT=FBOT*YPERST/CINT+ORIGIN F=(FTOP+FBOT)/2. IF (COLOR) THEN N=IHUE (NCOLOR,CINT,FMIDLE,IFLIP,F) CALL TONCLR(N) IF (N.LE.0) THEN C OUTLINE off_white WITH black CALL PENCLR('black_____') CALL NEWPEN(IPEN1) C BOTH OUTLINE AND SHADING: IBOX=1 ELSE IF (N.GT.NCOLOR) THEN C OUTLINE gray WITH white CALL PENCLR('white_____') CALL NEWPEN(IPEN1) C BOTH OUTLINE AND SHADING: IBOX=1 ELSE C SHADING ONLY: IBOX=0 ENDIF ELSE N=IHUE (NGRAY,CINT,FMIDLE,IFLIP,F) CALL TONCLR(N) C BOTH OUTLINE AND PATTERN: IBOX=1 ENDIF CALL RECT (XINCH+1.4,XINCH+1.9,YBOT,YTOP,IBOX) C C CONTOUR LEVEL LABELS C CALL NEWPEN(IPEN1) CALL ALNMES(1.0,0.4) CHAR9=ASCII9 (FTOP) X=XINCH+1.4-0.2*WIDTH Y=YTOP IF (Y.LE.YNEXT) THEN YOLD=Y YNEXT=Y-1.1*HEIGHT CALL SYMBOL (X,Y,HEIGHT,CHAR9,IDUMMY,0.,9) ENDIF IF (I.EQ.NSTEPB) THEN CHAR9=ASCII9 (FBOT) X=XINCH+1.4-0.2*WIDTH Y=YBOT IF (Y.LE.YNEXT) + CALL SYMBOL (X,Y,HEIGHT,CHAR9,IDUMMY,0.,9) ENDIF 1050 CONTINUE CALL EGROUP C C END SEGMENT OF COLOR BAR C IF (DOAROW) THEN C PLOT A SAMPLE VECTOR AGAINST UPPER RIGHT CORNER C C SWITCH FROM MAP-PLANE METERS TO INCHES AS INPUT UNITS FACTR=39.37*FACTR/SDENOM CALL BGROUP CALL PENCLR('foreground') CALL NEWPEN(IPEN1) CALL PLOT(XINCH-0.05, 8.15, 3) WIDE=MAX(9*0.12,(0.1+BIG*FACTR+0.1)) HIGH=0.4 CALL PLOT(XINCH-0.05-WIDE,8.15, 2) CALL PLOT(XINCH-0.05-WIDE,8.15-HIGH,2) CALL PLOT(XINCH-0.05, 8.15-HIGH,2) CALL PLOT(XINCH-0.05, 8.15, 2) CALL STROKE CALL NEWPEN(IPEN2) X=XINCH-0.05-0.5*WIDE-0.5*BIG*FACTR Y=8.15-0.15 CALL PLOT(X,Y,3) DX=BIG*FACTR DY=0. XP=X+DX YP=Y+DY CALL PLOT(XP,YP,2) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT(XP+AX,YP+AY,3) CALL PLOT(XP,YP,2) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XP+BX,YP+BY,2) CALL STROKE SCALEV=ASCII9(BIG) CALL ALNMES(0.5,0.0) CALL SYMBOL(XINCH-0.05-0.5*WIDE,8.15-HIGH+0.02, + 0.12,SCALEV,IDUMMY,0.,9) CALL EGROUP C ELSE IF (DOAXES) THEN C C DRAW 2 LARGE SAMPLE TENSORS (ISOTROPIC, + AND - SAMPLES) C IN A BOX UP AGAINST UPPER RIGHT LIMITS OF PLOT AREA. C FACTR=FACTR*39.37/SDENOM C C NOTE: ADJUSTMENT OF BIG JUST DETERMINES HOW LARGE C THE SAMPLE TENSORS ARE, IT DOES NOT THROW OFF C THE ACCURACY OF THE LABEL, SO FEEL FREE TO C CHANGE HERE: BIG=0.4*BIG C CALL BGROUP C C XUR AND YUR ARE UPPER-RIGHT OF BOX, IN INCHES XUR=XINCH-0.3 YUR=8.18 C C SIZE OF IDEALIZED OUTLINE BOX, IN INCHES C (ACTUAL BLACK BOX HAS BOTTOM PULLED DOWN TO ALLOW C ROOM FOR THE NUMBER LABEL) WIDE=1.15*(4.*BIG*FACTR) HIGH=1.10*(2.*BIG*FACTR) C C FIRST, PUT DOWN SLIGHTLY LARGER RECTANGLE OF BACKGROUND: CALL CHGCLR ('background',.FALSE.,.TRUE.) EDGE=0.03 CALL PLOT(XUR+EDGE, YUR+EDGE,3) CALL PLOT(XUR-WIDE-EDGE,YUR+EDGE,2) CALL PLOT(XUR-WIDE-EDGE,YUR-HIGH-0.24-EDGE,2) CALL PLOT(XUR+EDGE, YUR-HIGH-0.24-EDGE,2) CALL PLOT(XUR+EDGE, YUR+EDGE,2) WRITE (99,"('f')") LDI02=.FALSE. C C BLACK BOX CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL PLOT(XUR, YUR,3) CALL PLOT(XUR-WIDE,YUR,2) CALL PLOT(XUR-WIDE,YUR-HIGH-0.24,2) CALL PLOT(XUR, YUR-HIGH-0.24,2) CALL PLOT(XUR, YUR,2) CALL STROKE ANGLE=0. DR=BIG*FACTR C ISOTROPIC COMPRESSIVE TENSOR X=XUR-WIDE+1.1*DR Y=YUR-1.1*DR TZZ= -BIG T1= -BIG T2= -BIG CALL CIRCLE(X,Y,-DR,MIN0(IPEN1,7)) DX=FACTR*T1*COS(ANGLE) DY=FACTR*T1*SIN(ANGLE) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) CALL STROKE DX=FACTR*T2*COS(ANGLE+1.5708) DY=FACTR*T2*SIN(ANGLE+1.5708) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) CALL STROKE C ISOTROPIC EXTENSIONAL TENSOR X=XUR-1.1*DR Y=YUR-1.1*DR TZZ=BIG T1=BIG T2=BIG CALL PLOT(X+0.866*DR,Y-0.5*DR,3) CALL PLOT(X,Y+DR,2) CALL PLOT(X-0.866*DR,Y-0.5*DR,2) CALL PLOT(X+0.866*DR,Y-0.5*DR,2) CALL STROKE DX=FACTR*T1*COS(ANGLE) DY=FACTR*T1*SIN(ANGLE) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) CALL STROKE DX=FACTR*T2*COS(ANGLE+1.5708) DY=FACTR*T2*SIN(ANGLE+1.5708) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) CALL STROKE C WRITE LABEL WRITE (SCALEA,19) BIG 19 FORMAT (1P,E8.1) CALL ALNMES(0.5,0.0) CALL SYMBOL (XUR-WIDE/2., + YUR-HIGH-0.18, + 0.18,SCALEA,IDUMMY,0.,8) C CALL EGROUP END IF C C C******************************************************************* C C BEGIN SEGMENT 5 (TITLE AND VARIABLE DISPLAYED) C CALL PROJCT('NONE') C C WRITE MODEL TITLE C HEIGHT=0.15 CALL NEWPEN(IPEN1) CALL ALNMES(0.0,0.0) TOP=RDI14/72. CALL SYMBOL (0.5,TOP+3.0*HEIGHT,HEIGHT,TEXT(JV), + IDUMMY,0.,NVCHAR(JV)) CALL SYMBOL (0.5,TOP+1.5*HEIGHT,HEIGHT,TITLE, + IDUMMY,0.,80) C C C CLOSE SEGMENT WITH TEXT LABELS C C**************************************************************** C CALL ENDPL(IZERO) C RETURN END SUBROUTINE PAINT C C C SUBROUTINE ETCH (DRAWST,FDIP,FLEN,FTAN,JV,NTYPE,NFL, + MXBN,MXNODE,NCOND,NODCON, + NODEF,NODES,NUMEL,NUMNOD,NVCHAR,NXYSTB, + STATES,TEXT,TITLE, + WEDGE, + XNOD,XST,YNOD,YST, + IPEN1,IPEN2,IPEN3,IUNITT) C C PLOTS THE FINITE ELEMENT GRID AND STATE OUTLINES. C LABELS WITH GRID TITLE ABOVE C CHARACTER*1 ITEXT CHARACTER*42 TEXT CHARACTER*80 TITLE INTEGER INTEG,NINWIN LOGICAL DASHED,DOTICS,DOTRACE,IN,S4,S5,S6,STATES LOGICAL DRAWST REAL HEIGHT,ROTAT,TOP,X,Y DIMENSION DRAWST(NXYSTB), + FDIP(3,NFL),FLEN(NFL),FTAN(7,NFL),NODCON(MAXBN), + NODEF(6,NFL),NODES(6,NUMEL),NVCHAR(NTYPE), + TEXT(NTYPE),XNOD(NUMNOD),YNOD(NUMNOD), + XST(NXYSTB),YST(NXYSTB) C C********************************************************************** C C BEGIN SEGMENT 1 (FINITE ELEMENT GRID) C C ASSUMING CONIC PROJECTION: DEGWID=(((9.00/39.37)*SDENOM)/RADIUS)*57.29578 CALL GOPLOT (INPUT,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + X0ELON,CPNLAT, + XNOD,YNOD, + OUTPUT,DEGPEI,MAPTYP,XWIDE) C CALL PROJCT('LINEAR') 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 CALL NEWPEN (IPEN1) IF (COLOR) THEN CALL PENCLR ('green_____') ELSE CALL DASH ENDIF CALL BGROUP DO 30 I=1,NUMEL S4=.TRUE. NODE=NODES(4,I) DO 14 J=1,NFL IF ((NODEF(2,J).EQ.NODE).OR. + (NODEF(5,J).EQ.NODE)) S4=.FALSE. 14 CONTINUE DO 24 J=1,I-1 IF ((NODES(4,J).EQ.NODE).OR. + (NODES(5,J).EQ.NODE).OR. + (NODES(6,J).EQ.NODE)) S4=.FALSE. 24 CONTINUE S5=.TRUE. NODE=NODES(5,I) DO 15 J=1,NFL IF ((NODEF(2,J).EQ.NODE).OR. + (NODEF(5,J).EQ.NODE)) S5=.FALSE. 15 CONTINUE DO 25 J=1,I-1 IF ((NODES(4,J).EQ.NODE).OR. + (NODES(5,J).EQ.NODE).OR. + (NODES(6,J).EQ.NODE)) S5=.FALSE. 25 CONTINUE S6=.TRUE. NODE=NODES(6,I) DO 16 J=1,NFL IF ((NODEF(2,J).EQ.NODE).OR. + (NODEF(5,J).EQ.NODE)) S6=.FALSE. 16 CONTINUE DO 26 J=1,I-1 IF ((NODES(4,J).EQ.NODE).OR. + (NODES(5,J).EQ.NODE).OR. + (NODES(6,J).EQ.NODE)) S6=.FALSE. 26 CONTINUE CALL AROUND (I,S4,S5,S6,NODES,XNOD,YNOD,NUMNOD,NUMEL) 30 CONTINUE CALL EGROUP CALL RESET('DASH') C C PLOT NODES (IN BLUE, IF COLOR) C NOTE: NODES ARE ONLY PLOTTED IF NUMBER IN THE WINDOW IS NOT C EXCESSIVE. SINCE EACH REQUIRES 4 BEZIER CURVES TO MAKE C A CIRCLE, ADOBE ILLUSTRATOR WILL GIVE THE CRYPTIC C MESSAGE "CAN'T COMPLETE DRAWING" IF THERE ARE TOO MANY. C NINWIN=0 DO 32 I=1,NUMNOD CALL MAP2XY (INPUT,XNOD(I),YNOD(I), + OUTPUT,ROTAT,X,Y) IN=(X.GE.RDI11).AND.(X.LE.RDI12).AND. + (Y.GE.RDI13).AND.(Y.LE.RDI14) IF (IN) NINWIN=NINWIN+1 32 CONTINUE IF (NINWIN.LE.500) THEN CALL NEWPEN(IPEN1) IF (COLOR) THEN CALL PENCLR('dark_blue_') ENDIF C USE CENTERED OCTAGON SYMBOL: INTEG=1 CALL BGROUP DO 40 I=1,NUMNOD CALL MAP2XY (INPUT,XNOD(I),YNOD(I), + OUTPUT,ROTAT,X,Y) IN=(X.GE.RDI11).AND.(X.LE.RDI12).AND. + (Y.GE.RDI13).AND.(Y.LE.RDI14) IF (IN) CALL SYMBOL(XNOD(I),YNOD(I),0.08, + ITEXT,INTEG,0.0,-1) 40 CONTINUE CALL EGROUP END IF C C PLOT FAULTS (IN RED, IF COLOR) C IF (NFL.GT.0) THEN SUM=0.0 DO 50 I=1,NFL SUM=SUM+FLEN(I) 50 CONTINUE AVERAG=SUM/NFL IF (NUMNOD.LE.600) THEN NTIC=3 DIPSIZ=0.10*AVERAG ELSE IF (NUMNOD.LE.2000) THEN NTIC=2 DIPSIZ=0.20*AVERAG ELSE NTIC=1 DIPSIZ=0.25*AVERAG ENDIF C C PLOT FAULTS IN TWO PASSES, FORMING TWO GRAPHIC GROUPS. C THIS WILL ALLOW DIP-TICS TO BE FILLED-IN IF DESIRED. C IF (COLOR) CALL PENCLR('red_______') CALL NEWPEN(IPEN1) CALL BGROUP DO 60 I=1,NFL DASHED=.FALSE. DOTRACE=.FALSE. DOTICS=.TRUE. CALL FAULT (INPUT,DASHED,DOTICS,DOTRACE, + FDIP,FTAN,I, + NFL,NUMNOD,NODEF,NTIC,DIPSIZ, + WEDGE,XNOD,YNOD) 60 CONTINUE CALL EGROUP C IF (COLOR) CALL PENCLR('red_______') CALL NEWPEN(IPEN2) CALL BGROUP DO 61 I=1,NFL DASHED=.FALSE. DOTRACE=.TRUE. DOTICS=.FALSE. CALL FAULT (INPUT,DASHED,DOTICS,DOTRACE, + FDIP,FTAN,I, + NFL,NUMNOD,NODEF,NTIC,DIPSIZ, + WEDGE,XNOD,YNOD) 61 CONTINUE CALL EGROUP ENDIF C C CLOSE SEGMENT OF FINITE ELEMENT GRID C C**************************************************************** IF (STATES) THEN C C BEGIN SEGMENT FOR STATE LINES (3) C C USE foreground PEN TO WRITE OVER OTHER COLORS C CALL USMAP (INPUT,DRAWST,IPEN3,'foreground', + NXYSTB,XST,YST) C C CLOSE SEGMENT WITH STATE LINES C ENDIF C**************************************************************** C CALL PROJCT('CONIC') CALL FRAME(DOGRID=.TRUE.) CALL PROJCT('NONE') C C BEGIN SEGMENT 5 (TITLE) C HEIGHT=0.15 CALL NEWPEN(IPEN1) CALL ALNMES(0.0,0.0) TOP=RDI14/72. CALL SYMBOL (0.5,TOP+3.0*HEIGHT,HEIGHT,TEXT(JV), + IDUMMY,0.,NVCHAR(JV)) CALL SYMBOL (0.5,TOP+1.5*HEIGHT,HEIGHT,TITLE, + IDUMMY,0.,80) C C C CLOSE SEGMENT WITH TEXT LABELS C C**************************************************************** C CALL ENDPL(IZERO) C RETURN END SUBROUTINE ETCH C C C SUBROUTINE AROUND (I,S4,S5,S6,NODES,XNOD,YNOD,NUMNOD,NUMEL) C C DRAW ONE OR MORE SIDE OF AN ELEMENT C (A LOT OF CODE IS NEEDED TO DECIDE IF THE SIDE IS BENT OR NOT. C THIS IS BECAUSE STRAIGHT SIDES CAN BE DRAWN IN ONE STEP, GIVING C A BETTER DASHED LINE IN B/W. OFTEN, A CURVED SIDE DRAWN IN A C NUMBER OF STEPS (NSTEP9) WILL HAVE PROBLEMS WITH ITS DASHES.) C LOGICAL BENT,S4,S5,S6 REAL OFFSET DIMENSION NODES(6,NUMEL),XNOD(NUMNOD),YNOD(NUMNOD) DIMENSION S(3),DS(3) DATA NSTEP9 /6/ PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) I1=NODES(1,I) I2=NODES(2,I) I3=NODES(3,I) I4=NODES(4,I) I5=NODES(5,I) I6=NODES(6,I) X1=XNOD(I1) X2=XNOD(I2) X3=XNOD(I3) X4=XNOD(I4) X5=XNOD(I5) X6=XNOD(I6) Y1=YNOD(I1) Y2=YNOD(I2) Y3=YNOD(I3) Y4=YNOD(I4) Y5=YNOD(I5) Y6=YNOD(I6) DO 100 ISIDE=1,3 IF (ISIDE.EQ.1.AND..NOT.S4) GO TO 100 IF (ISIDE.EQ.2.AND..NOT.S5) GO TO 100 IF (ISIDE.EQ.3.AND..NOT.S6) GO TO 100 J1=ISIDE J2=MOD(ISIDE,3)+1 X0=XNOD(NODES(J1,I)) Y0=YNOD(NODES(J1,I)) XH=XNOD(NODES(J1+3,I)) YH=YNOD(NODES(J1+3,I)) XW=XNOD(NODES(J2,I)) YW=YNOD(NODES(J2,I)) SIDE=SQRT((XW-X0)**2+(YW-Y0)**2) XM=0.5*(X0+XW) YM=0.5*(Y0+YW) OFFSET=SQRT((XH-XM)**2+(YH-YM)**2) BENT=(OFFSET/SIDE).GT.0.05 DO 10 K=1,3 S(K)=0. DS(K)=0. 10 CONTINUE S(J1)=1.00 IF (BENT) THEN NSTEP=NSTEP9 ELSE NSTEP=1 ENDIF STEP=1./(1.*NSTEP) DS(J1)= -STEP DS(J2)= STEP X=PHIVAL(S(1),S(2),S(3),X1,X2,X3,X4,X5,X6) Y=PHIVAL(S(1),S(2),S(3),Y1,Y2,Y3,Y4,Y5,Y6) CALL PLOT(X,Y,3) DO 20 K=1,NSTEP DO 15 L=1,3 S(L)=S(L)+DS(L) 15 CONTINUE X=PHIVAL(S(1),S(2),S(3),X1,X2,X3,X4,X5,X6) Y=PHIVAL(S(1),S(2),S(3),Y1,Y2,Y3,Y4,Y5,Y6) CALL PLOT(X,Y,2) 20 CONTINUE 100 CONTINUE RETURN END SUBROUTINE AROUND C C C SUBROUTINE USMAP (INPUT,DRAWST,IPEN,color_name, + NXYSTB,XST,YST) C C PLOTS OUTLINE OF STATES FROM DIGITIZED DATASET. C CHARACTER*10 color_name INTEGER IPEN,NXYSTB LOGICAL DRAW LOGICAL DRAWST REAL XST,YST DIMENSION DRAWST(NXYSTB),XST(NXYSTB),YST(NXYSTB) C CALL NEWPEN(IPEN) IF (COLOR) CALL PENCLR (color_name) CALL BGROUP DO 100 I=1,NXYSTB XP=XST(I) YP=YST(I) DRAW=DRAWST(I) IF (DRAW) THEN CALL PLOT(XP,YP,2) ELSE CALL PLOT(XP,YP,3) ENDIF 100 CONTINUE CALL EGROUP RETURN END SUBROUTINE USMAP C C C SUBROUTINE ARROWS (INPUT,CINT,NUMEL,OUTVEC, + SIZEAR,XIP,YIP, + OUTPUT,BIG,FACTR) C C DRAWS VECTORS WITH RMS LENGTH SIZEAR (METERS) FROM ELEMENT C CENTERS. C LOGICAL IN REAL AX,AY,BX,BY,DX,DY,ROTAT,XMETER,XPOINT,YMETER,YPOINT DIMENSION OUTVEC(2,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) SUM=0. BIG=0. DO 100 I=1,NUMEL T=OUTVEC(1,1,I)**2+OUTVEC(2,1,I)**2 SUM=SUM+T BIG=MAX(BIG,T) 100 CONTINUE IF (SUM.LE.0.) RETURN FACTR=SIZEAR/SQRT(SUM/NUMEL) C NOTE: SIZEAR IS IN METERS IN THE X,Y PROJECTION PLANE C C SELECT SIZE FOR SAMPLE VECTOR BIG=SQRT(BIG) BIG=MIN(BIG,2.*SIZEAR/FACTR) N=BIG/CINT+0.5 BIG=MAX(N,1)*CINT C C PLOT ALL VECTORS CALL BGROUP DO 200 I=1,NUMEL XMETER=XIP(1,I) YMETER=YIP(1,I) C NOTE: ASSUMING CALL PROJCT('LINEAR') ALREADY DONE: CALL MAP2XY (INPUT,XMETER,YMETER, + OUTPUT,ROTAT,XPOINT,YPOINT) IN=(XPOINT.GT.RDI11).AND. + (XPOINT.LT.RDI12).AND. + (YPOINT.GT.RDI13).AND. + (YPOINT.LT.RDI14) IF (IN) THEN CALL PLOT(XMETER,YMETER,3) DX=FACTR*OUTVEC(1,1,I) DY=FACTR*OUTVEC(2,1,I) XP=XMETER+DX YP=YMETER+DY CALL PLOT(XP,YP,2) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT(XP+AX,YP+AY,3) CALL PLOT(XP,YP,2) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XP+BX,YP+BY,2) END IF 200 CONTINUE CALL STROKE CALL EGROUP RETURN END SUBROUTINE ARROWS C C C SUBROUTINE AXES (INPUT,CINT,IPEN,NUMEL,SIZEAX, + TAUMT,TAUZZ, + XIP,YIP, + OUTPUT,BIG,FACTR) C C DRAWS TENSOR PRINCIPAL AXES, WITH RMS LENGTH SIZEAX, C AT ELEMENT CENTERS. C CONVENTION IS THAT AN AXIS IS COMPRESSIVE (INWARD-POINTING) C IF THE CORRESPONDING PRINCIPAL VALUE OF THE TENSOR IS NEGATIVE. C LOGICAL IN REAL ANGLE,ROTAT,XPOINT,YPOINT DIMENSION TAUMT(3,7,NUMEL),TAUZZ(7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) C SUM=0. BIG=0. DO 100 I=1,NUMEL TZZ=TAUZZ(1,I) TXX=TAUMT(1,1,I)+TZZ TYY=TAUMT(2,1,I)+TZZ TXY=TAUMT(3,1,I) SHEAR=SQRT((1.D0*TXY)**2+0.25D0*(1.D0*TXX-TYY)**2) CENTER=(TXX+TYY)/2. T1=CENTER-SHEAR T2=CENTER+SHEAR SUM=SUM+(MAX(ABS(T1),ABS(T2),ABS(TZZ)))**2 BIG=MAX(BIG,ABS(T1),ABS(T2)) 100 CONTINUE IF (SUM.LE.0.) RETURN FACTR=0.5*SIZEAX/SQRT(SUM/NUMEL) BIG=MIN(0.5*BIG,SIZEAX/FACTR) N=BIG/CINT+0.5 BIG=MAX(N,1)*CINT C DO 200 I=1,NUMEL X=XIP(1,I) Y=YIP(1,I) C C IS IT INSIDE THE MAP WINDOW? C NOTE: ASSUMING CALL PROJCT('LINEAR') ALREADY DONE: C CALL MAP2XY (INPUT,X,Y, + OUTPUT,ROTAT,XPOINT,YPOINT) IN=(XPOINT.GT.RDI11).AND. + (XPOINT.LT.RDI12).AND. + (YPOINT.GT.RDI13).AND. + (YPOINT.LT.RDI14) IF (IN) THEN TZZ=TAUZZ(1,I) TXX=TAUMT(1,1,I)+TZZ TYY=TAUMT(2,1,I)+TZZ TXY=TAUMT(3,1,I) SHEAR=SQRT((1.D0*TXY)**2+0.25D0*(1.D0*TXX-TYY)**2) CENTER=(TXX+TYY)/2. T1=CENTER-SHEAR T2=CENTER+SHEAR ANGLE=0.5*ATAN2F(-TXY,(TYY-TXX)/2.) DR=FACTR*ABS(TZZ) IF (TZZ.LT.0.0) THEN C CIRCLE FOR COMPRESSIVE VERTICAL STRESS CALL CIRCLE(X,Y,-DR,IPEN) ELSE IF (TZZ.GT.0.0) THEN C TRIANGLE FOR TENSILE VERTICAL STRESS CALL PLOT(X+0.866*DR,Y-0.5*DR,3) CALL PLOT(X,Y+DR,2) CALL PLOT(X-0.866*DR,Y-0.5*DR,2) CALL PLOT(X+0.866*DR,Y-0.5*DR,2) CALL STROKE ENDIF DX=FACTR*T1*COS(ANGLE) DY=FACTR*T1*SIN(ANGLE) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) IF (T1.GT.0.0) THEN C TENSILE PRINCIPAL STRESS CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) ELSE C COMPRESSIVE PRINCIPAL STRESS CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) ENDIF DX=FACTR*T2*COS(ANGLE+1.5708) DY=FACTR*T2*SIN(ANGLE+1.5708) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) IF (T2.GT.0.0) THEN C TENSILE PRINCIPAL STRESS CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) ELSE C COMPRESSIVE PRINCIPAL STRESS CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) ENDIF END IF 200 CONTINUE RETURN END SUBROUTINE AXES C C C SUBROUTINE FICONS (NUMEL,ERATE,SIZEIC, + XIP,YIP) C C DRAWS FAULT ICONS, WITH UNIFORM LENGTH OF SIZEIC, C AT ELEMENT CENTERS. C CONVENTION IS THAT STRAIN IS COMPRESSIVE (INWARD-POINTING) C IF PRINCIPAL VALUE(S) OF ERATE ARE NEGATIVE. C ALSO NOTE THAT INTERNAL VARIABLE "ANGLE" IS DIRECTION OF E1 C MEASURED COUNTERCLOCKWISE FROM X (RIGHT). C REAL ANGLE DIMENSION ERATE(3,7,NUMEL),NINARE(10), + XIP(7,NUMEL),YIP(7,NUMEL) DIMENSION XARRAY(20),YARRAY(20) LOGICAL E1PART,E2PART,EZPART C DO 200 I=1,NUMEL X=XIP(1,I) Y=YIP(1,I) EXX=ERATE(1,1,I) EYY=ERATE(2,1,I) EXY=ERATE(3,1,I) DIVER=EXX+EYY SHEAR=SQRT((1.D0*EXY)**2+0.25D0*(1.D0*EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR EZ= -DIVER IF ((E2*EZ).GT.0.) THEN E1PART=.TRUE. E2PART=.FALSE. EZPART=.FALSE. ELSE IF ((E1*EZ).GT.0.) THEN E1PART=.FALSE. E2PART=.TRUE. EZPART=.FALSE. ELSE E1PART=.FALSE. E2PART=.FALSE. EZPART=.TRUE. END IF ANGLE=0.5*ATAN2F(-EXY,(EYY-EXX)/2.) BIGSHR=0. IF (E1*E2.LT.0.) BIGSHR=MAX(BIGSHR,MIN(ABS(E1),ABS(E2))) IF (E1*EZ.LT.0.) BIGSHR=MAX(BIGSHR,MIN(ABS(E1),ABS(EZ))) IF (E2*EZ.LT.0.) BIGSHR=MAX(BIGSHR,MIN(ABS(E2),ABS(EZ))) FACTR=0.5*SIZEIC/MAX(BIGSHR,1.E-30) IF (E1*E2.LT.0.) THEN C STRIKE-SLIP FAULTS IF (E1PART) THEN R=FACTR*ABS(E2) ELSE R=FACTR*ABS(E1) END IF DX=R*COS(ANGLE+0.5236) DY=R*SIN(ANGLE+0.5236) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) DX=R*COS(ANGLE-0.5236) DY=R*SIN(ANGLE-0.5236) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) ENDIF IF (E1.LT.0..AND.EZ.GT.0.) THEN C THRUST FAULTS PERP. TO E1 IF (E1PART) THEN R=FACTR*ABS(EZ) ELSE R=FACTR*ABS(E1) END IF DX=R*COS(ANGLE+1.5708) DY=R*SIN(ANGLE+1.5708) DXP=0.20*R*COS(ANGLE+3.937) DYP=0.20*R*SIN(ANGLE+3.927) XARRAY(1)=X+DX XARRAY(2)=X+DX+DXP XARRAY(3)=X+DX+DXP-DYP XARRAY(4)=X+DX-DYP XARRAY(5)=X+DX YARRAY(1)=Y+DY YARRAY(2)=Y+DY+DYP YARRAY(3)=Y+DY+DYP+DXP YARRAY(4)=Y+DY+DXP YARRAY(5)=Y+DY NINARE(1)=5 CALL POLYGONS(XARRAY,YARRAY,NINARE,1,.FALSE.,.TRUE.) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) XARRAY(1)=X-DX XARRAY(2)=X-DX-DXP XARRAY(3)=X-DX-DXP+DYP XARRAY(4)=X-DX+DYP XARRAY(5)=X-DX YARRAY(1)=Y-DY YARRAY(2)=Y-DY-DYP YARRAY(3)=Y-DY-DYP-DXP YARRAY(4)=Y-DY-DXP YARRAY(5)=Y-DY NINARE(1)=5 CALL POLYGONS(XARRAY,YARRAY,NINARE,1,.FALSE.,.TRUE.) ENDIF IF (E2.LT.0..AND.EZ.GT.0.) THEN C THRUST FAULTS PERP. TO E2 IF (EZPART) THEN R=FACTR*ABS(E2) ELSE R=FACTR*ABS(EZ) END IF DX=R*COS(ANGLE) DY=R*SIN(ANGLE) DXP=0.20*R*COS(ANGLE+2.356) DYP=0.20*R*SIN(ANGLE+2.356) XARRAY(1)=X+DX XARRAY(2)=X+DX+DXP XARRAY(3)=X+DX+DXP-DYP XARRAY(4)=X+DX-DYP XARRAY(5)=X+DX YARRAY(1)=Y+DY YARRAY(2)=Y+DY+DYP YARRAY(3)=Y+DY+DYP+DXP YARRAY(4)=Y+DY+DXP YARRAY(5)=Y+DY NINARE(1)=5 CALL POLYGONS(XARRAY,YARRAY,NINARE,1,.FALSE.,.TRUE.) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) XARRAY(1)=X-DX XARRAY(2)=X-DX-DXP XARRAY(3)=X-DX-DXP+DYP XARRAY(4)=X-DX+DYP XARRAY(5)=X-DX YARRAY(1)=Y-DY YARRAY(2)=Y-DY-DYP YARRAY(3)=Y-DY-DYP-DXP YARRAY(4)=Y-DY-DXP YARRAY(5)=Y-DY NINARE(1)=5 CALL POLYGONS(XARRAY,YARRAY,NINARE,1,.FALSE.,.TRUE.) ENDIF IF (E1.GT.0..AND.EZ.LT.0.) THEN C NORMAL FAULTS PERP. TO E1 IF (E1PART) THEN R=FACTR*ABS(EZ) ELSE R=FACTR*ABS(E1) END IF DX1=R*COS(ANGLE+1.7682) DY1=R*SIN(ANGLE+1.7682) DX2=R*COS(ANGLE+1.3734) DY2=R*SIN(ANGLE+1.3734) XARRAY(1)=X+DX1 XARRAY(2)=X+DX2 XARRAY(3)=X-DX1 XARRAY(4)=X-DX2 XARRAY(5)=X+DX1 YARRAY(1)=Y+DY1 YARRAY(2)=Y+DY2 YARRAY(3)=Y-DY1 YARRAY(4)=Y-DY2 YARRAY(5)=Y+DY1 NINARE(1)=5 CALL POLYGONS(XARRAY,YARRAY,NINARE,1,.FALSE.,.TRUE.) ENDIF IF (E2.GT.0..AND.EZ.LT.0.) THEN C NORMAL FAULTS PERP. TO E2 IF (EZPART) THEN R=FACTR*ABS(E2) ELSE R=FACTR*ABS(EZ) END IF DX1=R*COS(ANGLE+0.1974) DY1=R*SIN(ANGLE+0.1974) DX2=R*COS(ANGLE-0.1974) DY2=R*SIN(ANGLE-0.1974) XARRAY(1)=X+DX1 XARRAY(2)=X+DX2 XARRAY(3)=X-DX1 XARRAY(4)=X-DX2 XARRAY(5)=X+DX1 YARRAY(1)=Y+DY1 YARRAY(2)=Y+DY2 YARRAY(3)=Y-DY1 YARRAY(4)=Y-DY2 YARRAY(5)=Y+DY1 NINARE(1)=5 CALL POLYGONS(XARRAY,YARRAY,NINARE,1,.FALSE.,.TRUE.) ENDIF 200 CONTINUE RETURN END SUBROUTINE FICONS C C C SUBROUTINE SLIPS (DRAWST,FDIP,FLEN,FSLIPS,FTAN,JV,NTYPE, + MXBN,MXNODE,NCOND,NODCON, + NODEF,NODES,NFL,NUMEL,NUMNOD,NVCHAR, + NXYSTB, + RMSVEC,STATES,TEXT,TITLE,V,WEDGE, + XNOD,XST,YNOD,YST, + IPEN1,IPEN2,IPEN3,IUNITT) C C PLOTS THE FAULT ELEMENT AND THEIR SLIP RATES. C FAULT ELEMENTS ARE IN RED WITH DIP SYMBOLS. C FAULTS WITH A VERY LOW SLIP RATE ARE DASHED; NOTE THAT LOGICAL C ARRAY "FSLIPS" IS REDEFINED BY THIS ROUTINE. C A CURVING GRAPH OF SCALAR SLIP-RATE PARALLELS EACH ELEMENT C ON THE OPPOSITE SIDE FROM THE DIP SYMBOLS. YELLOW IS C USED FOR NORMAL SLIP, GREEN FOR DEXTRAL STRIKE-SLIP, C BLACK FOR SINISTRAL STRIKE-SLIP, C AND BLUE FOR REVERSE OR THRUST SLIP. C ON THE SIDE OF THE DIP SYMBOLS, A VECTOR SHOWS THE DIRECTION C OF RELATIVE MOTION. C LABELS WITH MODEL TITLE BELOW. C DOUBLE PRECISION V CHARACTER*80 TITLE CHARACTER*42 TEXT CHARACTER*10 SCOLOR CHARACTER*2 MMPERY INTEGER DOWN,UP,IUNITT LOGICAL DASHED,DOTICS,DOTRACE,STATES LOGICAL DRAWST,FSLIPS REAL DEGWID,DERIVA,HEIGHT,OFFSET,PHIVAL,RMSVEC,SCALE, + VECTOR,XC,XINCH,YC DIMENSION DRAWST(NXYSTB),FDIP(3,NFL),FLEN(NFL),FTAN(7,NFL), + FSLIPS(NFL),NODCON(MXBN),NODEF(6,NFL), + NODES(6,NUMEL),NVCHAR(NTYPE),TEXT(NTYPE), + V(2,NUMNOD),XNOD(NUMNOD),YNOD(NUMNOD), + XST(NXYSTB),YST(NXYSTB) DIMENSION NPOINT(10),XARRAY(63),YARRAY(63) DIMENSION FARG(0:10),HARG(0:10),HRATE(0:10), + SCOLOR(0:10),RATE(0:10) DATA DOWN/2/, UP/3/ C C STATEMENT FUNCTIONS: PHIVAL(S,F1,F2,F3)= + F1*(1.-3.*S+2.*S**2)+ + F2*(4.*S*(1.-S))+ + F3*(2.*S**2-S) DERIVA(S,F1,F2,F3)= + F1*(4.*S-3.)+ + F2*(4.-8.*S)+ + F3*(4.*S-1.) C C ASSUMING CONIC PROJECTION: DEGWID=(((9.00/39.37)*SDENOM)/RADIUS)*57.29578 CALL GOPLOT (INPUT,DEGWID, + IPEN1,IPEN2,IPEN3,IUNITT, + MXBN,MXNODE,NCOND,NODCON, + X0ELON,CPNLAT, + XNOD,YNOD, + OUTPUT,DEGPEI,MAPTYP,XWIDE) CALL PROJCT('LINEAR') C********************************************************************** C IF (STATES) THEN CALL USMAP (INPUT,DRAWST,IPEN3,'foreground', + NXYSTB,XST,YST) C ENDIF C**************************************************************** C C BEGIN FAULT TICS (FIRST, SO SLIP ARROWS WILL OVERLIE THEM) C C PLOT ALL FAULTS IN RED, IF COLOR C SUM=0.0 DO 2 I=1,NFL SUM=SUM+FLEN(I) 2 CONTINUE AVERAG=SUM/NFL IF (NUMNOD.LE.600) THEN NTIC=3 DIPSIZ=0.15*AVERAG ELSE IF (NUMNOD.LE.2000) THEN NTIC=2 DIPSIZ=0.20*AVERAG ELSE NTIC=1 DIPSIZ=0.25*AVERAG ENDIF C IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN(IPEN1) CALL BGROUP DO 5 I=1,NFL DASHED=.NOT.FSLIPS(I) DOTRACE=.FALSE. DOTICS=.TRUE. CALL FAULT (INPUT,DASHED,DOTICS,DOTRACE, + FDIP,FTAN,I,NFL, + NUMNOD,NODEF,NTIC,DIPSIZ, + WEDGE,XNOD,YNOD) 5 CONTINUE CALL EGROUP C C END OF FAULT TICS (FIRST PASS) C C**************************************************************** C C (COLORED-IN GRAPHS AND VECTORS ALONG THE FAULTS) C C CHARACTER HEIGHT, IN INCHES: C HIGH=0.14 C C REFERENCE LOCATION FOR TEXT LABELS IS CENTER OF BASE C CALL ALNMES (0.5,0.0) C C DETERMINE REASONABLE SCALE FOR SLIP BANDS C VMAX=0. DO 10 I=1,NUMNOD V2=V(1,I)**2+V(2,I)**2 VMAX=MAX(VMAX,V2) 10 CONTINUE IF (VMAX.GT.0.) THEN VMAX=SQRT(VMAX) ELSE VMAX=1. ENDIF C NOTE THAT RMSVEC IS IN INCHES; MUST CONVERT TO CONIC-PLANE METERS SCALE=1.5*(SDENOM*RMSVEC/39.37)/VMAX C C PLOT SLIP INFORMATION IN FOUR PASSES (FOR 4 GRAPHICS GROUPS): C 1 = SHADING C 2 = OUTLINES C 3 = ARROWS C 4 = NUMBERS C DO 101 IPASS = 1, 4 CALL BGROUP C C COMPUTE SLIPS AT 11 POINTS PER FAULT C DO 100 I=1,NFL D1=FDIP(1,I) D2=FDIP(2,I) D3=FDIP(3,I) I1=NODEF(1,I) I2=NODEF(2,I) I3=NODEF(3,I) I4=NODEF(4,I) I5=NODEF(5,I) I6=NODEF(6,I) X1=XNOD(I1) X2=XNOD(I2) X3=XNOD(I3) Y1=YNOD(I1) Y2=YNOD(I2) Y3=YNOD(I3) VX1=V(1,I1) VX2=V(1,I2) VX3=V(1,I3) UX1=V(1,I6) UX2=V(1,I5) UX3=V(1,I4) VY1=V(2,I1) VY2=V(2,I2) VY3=V(2,I3) UY1=V(2,I6) UY2=V(2,I5) UY3=V(2,I4) DO 50 IS=0,10 S=0.10*IS DIP=PHIVAL(S,D1,D2,D3) DXDS=DERIVA(S,X1,X2,X3) DYDS=DERIVA(S,Y1,Y2,Y3) ARG=ATAN2(DYDS,DXDS) DVX=PHIVAL(S,VX1,VX2,VX3)-PHIVAL(S,UX1,UX2,UX3) DVY=PHIVAL(S,VY1,VY2,VY3)-PHIVAL(S,UY1,UY2,UY3) AZIMHS=ATAN2F(DVY,DVX) HORS=SQRT((1.D0*DVX)**2+(1.D0*DVY)**2) UNITX=COS(ARG) UNITY=SIN(ARG) CROSSX= -UNITY CROSSY= +UNITX SINIST=DVX*UNITX+DVY*UNITY IF (ABS(DIP-1.570796).LT.WEDGE) THEN CLOSE=0. VUPDIP=0. IF (SINIST.GE.0.) THEN RAKE=0. ELSE RAKE=3.14159 ENDIF ELSE CLOSE=DVX*CROSSX+DVY*CROSSY VUPDIP=CLOSE/COS(DIP) RAKE=ATAN2F(VUPDIP,SINIST) ENDIF RELV=VUPDIP*SIN(DIP) SNET=SQRT((1.D0*SINIST)**2+(1.D0*VUPDIP)**2) IF (SNET.GT.0.) THEN PLUNGE= -ASIN(RELV/SNET) ELSE PLUNGE=0. ENDIF RATE(IS)=SNET HRATE(IS)=HORS HARG(IS)=AZIMHS FARG(IS)=ARG IF ((ABS(DIP-1.570796).LT.WEDGE) .OR. + (ABS(SIN(RAKE)).LT.0.5)) THEN IF (SINIST.LE.0.) THEN C DEXTRAL STRIKE-SLIP SCOLOR(IS)='green_____' ELSE C SINISTRAL STRIKE-SLIP SCOLOR(IS)='brown_____' ENDIF ELSE IF (CLOSE.LT.0.) THEN C NORMAL SLIP SCOLOR(IS)='pink______' ELSE C REVERSE OR THRUST SLIP SCOLOR(IS)='dark_blue_' ENDIF 50 CONTINUE C C IS THIS FAULT SEGMENT ACTIVE (SOLID LINE, VECTOR, AND NUMBER),OR C INACTIVE (DASHED LINE ONLY) ? C FSLIPS(I)=ABS(HRATE(5)).GT.(0.01*VMAX) IF (FSLIPS(I)) THEN C C DRAW COLORED GRAPH ON UPDIP SIDE C DO 60 IS=0,9 S0=0.10*IS S1=0.10*(IS+1) XF0=PHIVAL(S0,X1,X2,X3) XF1=PHIVAL(S1,X1,X2,X3) YF0=PHIVAL(S0,Y1,Y2,Y3) YF1=PHIVAL(S1,Y1,Y2,Y3) IF (IPASS.LE.2) THEN IF (COLOR) THEN CALL CHGCLR (SCOLOR(IS),.TRUE.,.TRUE.) END IF END IF IF (IPASS.EQ.2) CALL NEWPEN (IPEN1) IF (IPASS.EQ.2) CALL PLOT (XF0,YF0,UP) XARRAY(1)=XF0 YARRAY(1)=YF0 ARG=FARG(IS) UNITX=COS(ARG) UNITY=SIN(ARG) DIP=PHIVAL(S0,D1,D2,D3) IF (DIP.LE.(1.570796+WEDGE)) THEN CROSSX= -UNITY CROSSY= +UNITX ELSE CROSSX= +UNITY CROSSY= -UNITX ENDIF XT=XF0+RATE(IS)*SCALE*CROSSX YT=YF0+RATE(IS)*SCALE*CROSSY IF (IPASS.EQ.2) CALL PLOT (XT,YT,DOWN) XARRAY(2)=XT YARRAY(2)=YT ARG=FARG(IS+1) UNITX=COS(ARG) UNITY=SIN(ARG) DIP=PHIVAL(S1,D1,D2,D3) IF (DIP.LE.(1.570796+WEDGE)) THEN CROSSX= -UNITY CROSSY= +UNITX ELSE CROSSX= +UNITY CROSSY= -UNITX ENDIF XT=XF1+RATE(IS+1)*SCALE*CROSSX YT=YF1+RATE(IS+1)*SCALE*CROSSY IF (IPASS.EQ.2) CALL PLOT (XT,YT,DOWN) XARRAY(3)=XT YARRAY(3)=YT IF (IPASS.EQ.2) CALL PLOT (XF1,YF1,DOWN) XARRAY(4)=XF1 YARRAY(4)=YF1 XARRAY(5)=XARRAY(1) YARRAY(5)=YARRAY(1) NPOINT(1)=5 IF (IPASS.EQ.1) THEN IF (COLOR) THEN CALL POLYGONS(XARRAY,YARRAY,NPOINT,1, + .FALSE.,.TRUE.) END IF END IF 60 CONTINUE C C DRAW SINGLE VECTOR AT MIDPOINT C ARG=FARG(5) UNITX=COS(ARG) UNITY=SIN(ARG) DIP=FDIP(2,I) IF (DIP.LE.(1.570796+WEDGE)) THEN CROSSX= +UNITY CROSSY= -UNITX VARG=HARG(5) ELSE CROSSX= -UNITY CROSSY= +UNITX VARG=HARG(5)+3.14159 ENDIF C**************************************************************** C CHOOSE ONE OF THE FOLLOWING LINES TO SELECT VARIABLE- C OR CONSTANT-LENGTH SLIP VECTORS (CONSTANT IS MORE LEGIBLE) CCCCC VECTOR=HRATE(5)*SCALE VECTOR=0.70*(SDENOM*RMSVEC/39.37) C**************************************************************** IF (IPASS.EQ.3) THEN OFFSET=MAX( 1.2*(0.5*VECTOR*ABS(SIN(VARG-ARG))), + 0.10*FLEN(I) ) XC=X2+OFFSET*CROSSX YC=Y2+OFFSET*CROSSY DX=VECTOR*COS(VARG) DY=VECTOR*SIN(VARG) X0=XC-0.5*DX Y0=YC-0.5*DY CALL PLOT (X0,Y0,UP) IF (COLOR) CALL CHGCLR ('foreground',.TRUE., + .FALSE.) CALL NEWPEN (IPEN2) XP=X0+DX YP=Y0+DY CALL PLOT (XP,YP,DOWN) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT (XP+AX,YP+AY,UP) CALL PLOT (XP,YP,DOWN) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT (XP+BX,YP+BY,DOWN) END IF C C LABEL IN MM/YEAR C IF (IPASS.EQ.4) THEN CROSSX= - CROSSX CROSSY= - CROSSY LABEL=RATE(5)*1000.*3.15576E7 + 0.5 WRITE (MMPERY,'(I2)') LABEL XFM=PHIVAL(0.5,X1,X2,X3) YFM=PHIVAL(0.5,Y1,Y2,Y3) ARG=ATAN2F(CROSSY,CROSSX)-1.5708 C (PLOT NUMBER OUTSIDE OF SHADED BAND) HIGHT=RATE(5)*SCALE XFMP=XFM+CROSSX*(HIGHT+0.5*HIGH*SDENOM/39.37) YFMP=YFM+CROSSY*(HIGHT+0.5*HIGH*SDENOM/39.37) IF (COLOR) CALL CHGCLR ('foreground',.TRUE., + .FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XFMP,YFMP,HIGH,MMPERY,IDUMMY, + ARG*57.3,2) END IF ENDIF 100 CONTINUE C CALL EGROUP 101 CONTINUE C (ENDING LOOP ON IPASS = 1, 4 FOR 4 GRAPHICS GROUPS) C C END COLORED GRAPHS AND VECTORS C C******************************************************************* C C BEGIN FAULT TRACES (AGAIN, TO OVERLAY COLORED RIBBONS) C C PLOT ALL FAULTS IN RED, IF COLORED C SUM=0.0 DO 32 I=1,NFL SUM=SUM+FLEN(I) 32 CONTINUE AVERAG=SUM/NFL IF (NUMNOD.LE.600) THEN NTIC=3 DIPSIZ=0.15*AVERAG ELSE IF (NUMNOD.LE.2000) THEN NTIC=2 DIPSIZ=0.20*AVERAG ELSE NTIC=1 DIPSIZ=0.25*AVERAG ENDIF C IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN(IPEN2) CALL BGROUP DO 36 I=1,NFL DASHED=.NOT.FSLIPS(I) DOTRACE=.TRUE. DOTICS=.FALSE. CALL FAULT (INPUT,DASHED,DOTICS,DOTRACE, + FDIP,FTAN,I,NFL, + NUMNOD,NODEF,NTIC,DIPSIZ, + WEDGE,XNOD,YNOD) 36 CONTINUE CALL EGROUP C C END OF FAULT TRACES (SECOND TIME) C C**************************************************************** C CALL PROJCT('CONIC') CALL FRAME(DOGRID=.TRUE.) CALL PROJCT('NONE') C C KEY SEGMENT, CORRESPONDS TO COLOR BAR C INCLUDED WITH OTHER VARIABLES C XINCH = (RDI12/72.) - 0.2 C CALL BGROUP C C CHARACTER SIZE AND (LEFT, BASE) POSITION OF REFERENCE POINT C HIGH=0.12 HEIGHT=HIGH WIDTH=0.87*HEIGHT CALL ALNMES (0.0,0.0) C C SLIP-RATE KEY C YLINE=8.1 IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+.45,YLINE,HIGH,'SLIP-RATE',IDUMMY,0.,9) CALL PLOT (XINCH+.45,YLINE-0.3*HIGH,UP) CALL PLOT (XINCH+.45+9.*WIDTH,YLINE-0.3*HIGH,DOWN) C C SLIP RATE IN MM/YEAR C YLINE=7.3 IF (COLOR) THEN CALL NEWPEN (2) CALL CHGCLR ('brown_____',.TRUE.,.TRUE.) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,0) ELSE CALL NEWPEN (IPEN1) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.56666,XINCH+0.63333,YLINE,YLINE+0.2,-1) ENDIF IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.6-0.4*WIDTH, + YLINE+0.2+0.3*HEIGHT,HEIGHT,'5',IDUMMY,0.,1) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'mm/year',IDUMMY,0.,7) IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) C C LOCKED FAULT C YLINE=6.7 IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'LOCKED',IDUMMY,0.,6) IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) CALL PLOT (XINCH+0.45,YLINE+0.5*HIGH,UP) CALL PLOT (XINCH+0.51,YLINE+0.5*HIGH,DOWN) CALL PLOT (XINCH+0.57,YLINE+0.5*HIGH,UP) CALL PLOT (XINCH+0.63,YLINE+0.5*HIGH,DOWN) CALL PLOT (XINCH+0.69,YLINE+0.5*HIGH,UP) CALL PLOT (XINCH+0.75,YLINE+0.5*HIGH,DOWN) C C DEXTRAL C YLINE=6.0 IF (COLOR) THEN CALL CHGCLR ('green_____',.TRUE.,.TRUE.) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,0) ELSE CALL NEWPEN (IPEN1) CALL RECT (XINCH+0.50,XINCH+0.55,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.55,XINCH+0.60,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.60,XINCH+0.65,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.65,XINCH+0.70,YLINE,YLINE+0.2,-1) ENDIF IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'DEXTRAL',IDUMMY,0.,7) IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) DX= -0.3 DY= 0.0 X0=XINCH+0.75 Y0=YLINE-0.15 CALL PLOT (X0,Y0,UP) IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) XP=X0+DX YP=Y0+DY CALL PLOT (XP,YP,DOWN) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT (XP+AX,YP+AY,UP) CALL PLOT (XP,YP,DOWN) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT (XP+BX,YP+BY,DOWN) C C SINISTRAL C YLINE=5.1 IF (COLOR) THEN CALL CHGCLR ('brown_____',.TRUE.,.TRUE.) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,0) ELSE CALL NEWPEN (IPEN1) CALL RECT (XINCH+0.50,XINCH+0.55,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.55,XINCH+0.60,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.60,XINCH+0.65,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.65,XINCH+0.70,YLINE,YLINE+0.2,-1) ENDIF IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'SINISTRAL',IDUMMY,0.,9) IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) DX= 0.3 DY= 0.0 X0=XINCH+0.45 Y0=YLINE-0.15 CALL PLOT (X0,Y0,UP) IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) XP=X0+DX YP=Y0+DY CALL PLOT (XP,YP,DOWN) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT (XP+AX,YP+AY,UP) CALL PLOT (XP,YP,DOWN) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT (XP+BX,YP+BY,DOWN) C C THRUST C YLINE=4.2 IF (COLOR) THEN CALL CHGCLR ('dark_blue_',.TRUE.,.TRUE.) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,0) ELSE CALL NEWPEN (IPEN1) CALL RECT (XINCH+0.50,XINCH+0.55,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.55,XINCH+0.60,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.60,XINCH+0.65,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.65,XINCH+0.70,YLINE,YLINE+0.2,-1) ENDIF IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'THRUST',IDUMMY,0.,6) IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) DX= 0.0 DY= 0.3 X0=XINCH+0.60 Y0=YLINE-0.35 CALL PLOT (X0,Y0,UP) IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) XP=X0+DX YP=Y0+DY CALL PLOT (XP,YP,DOWN) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT (XP+AX,YP+AY,UP) CALL PLOT (XP,YP,DOWN) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT (XP+BX,YP+BY,DOWN) C C NORMAL C YLINE=3.3 IF (COLOR) THEN CALL CHGCLR ('pink______',.TRUE.,.TRUE.) CALL RECT (XINCH+0.5,XINCH+0.7,YLINE,YLINE+0.2,0) ELSE CALL NEWPEN (IPEN1) CALL RECT (XINCH+0.50,XINCH+0.55,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.55,XINCH+0.60,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.60,XINCH+0.65,YLINE,YLINE+0.2,-1) CALL RECT (XINCH+0.65,XINCH+0.70,YLINE,YLINE+0.2,-1) ENDIF IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.8,YLINE,HIGH,'NORMAL',IDUMMY,0.,6) IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) DX= 0.0 DY= -0.3 X0=XINCH+0.60 Y0=YLINE-0.05 CALL PLOT (X0,Y0,UP) IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) XP=X0+DX YP=Y0+DY CALL PLOT (XP,YP,DOWN) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT (XP+AX,YP+AY,UP) CALL PLOT (XP,YP,DOWN) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT (XP+BX,YP+BY,DOWN) C C DIP-KEY C YLINE=2.3 IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.7,YLINE,HIGH,'DIP',IDUMMY,0.,3) CALL PLOT (XINCH+0.7,YLINE-0.3*HIGH,UP) CALL PLOT (XINCH+0.7+3.*WIDTH,YLINE-0.3*HIGH,DOWN) C C VERTICAL DIP C YLINE=1.8 IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) CALL PLOT (XINCH+0.45,YLINE+0.5*HIGH,UP) CALL PLOT (XINCH+0.75,YLINE+0.5*HIGH,DOWN) IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'90 deg.',IDUMMY,0.,7) C C STEEP DIP C YLINE=1.3 IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) CALL PLOT (XINCH+0.6,YLINE,UP) CALL PLOT (XINCH+0.6,YLINE+0.15,DOWN) IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'65 deg.',IDUMMY,0.,7) C C MEDIUM DIP C YLINE=0.8 IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) CALL PLOT (XINCH+0.53,YLINE,UP) CALL PLOT (XINCH+0.53,YLINE+0.14,DOWN) CALL PLOT (XINCH+0.67,YLINE+0.14,DOWN) CALL PLOT (XINCH+0.67,YLINE,DOWN) IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'45 deg.',IDUMMY,0.,7) C C SHALLOW DIP C YLINE=0.3 IF (COLOR) CALL CHGCLR ('red_______',.TRUE.,.FALSE.) CALL NEWPEN (IPEN2) CALL PLOT (XINCH+0.45,YLINE,UP) CALL PLOT (XINCH+0.75,YLINE,DOWN) CALL PLOT (XINCH+0.53,YLINE,UP) CALL PLOT (XINCH+0.6,YLINE+0.2,DOWN) CALL PLOT (XINCH+0.67,YLINE,DOWN) IF (COLOR) CALL CHGCLR ('foreground',.TRUE.,.FALSE.) CALL NEWPEN (IPEN1) CALL SYMBOL(XINCH+0.9,YLINE,HIGH,'25 deg.',IDUMMY,0.,7) C CALL EGROUP C C END KEY SEGMENT C C******************************************************************* C C BEGIN TITLES C C C WRITE MODEL TITLE C CALL BGROUP C HEIGHT=0.15 CALL NEWPEN(IPEN1) CALL ALNMES(0.0,0.0) TOP=RDI14/72. CALL SYMBOL (0.5,TOP+3.0*HEIGHT,HEIGHT,TEXT(JV), + IDUMMY,0.,NVCHAR(JV)) CALL SYMBOL (0.5,TOP+1.5*HEIGHT,HEIGHT,TITLE, + IDUMMY,0.,80) C CALL EGROUP C C C END OF TITLES C C**************************************************************** C CALL ENDPL(IZERO) C RETURN END SUBROUTINE SLIPS C C C CHARACTER*9 FUNCTION ASCII9 (X) C C RETURNS A RIGHT-JUSTIFIED 9-BYTE ASCII VERSION OF A FLOATING- C POINT NUMBER, IN "HUMAN" FORMAT, WITH NO MORE THAN 3 SIGNIFICANT C DIGITS. C CHARACTER*9 TEMP9 CHARACTER*17 TEMP17 LOGICAL PUNT C IF (X.EQ.0.0) THEN ASCII9=' 0' RETURN END IF C IF (X.GT.0.) THEN PUNT=(X.GT.9990000.).OR.(X.LT.0.0000100) ELSE IF (X.LT.0.) THEN PUNT=(X.LT.-999000.).OR.(X.GT.-0.000100) ELSE PUNT=.FALSE. ENDIF C IF (PUNT) THEN WRITE (TEMP9,'(1P,E9.2)') X IF (TEMP9(7:7).EQ.'+') THEN TEMP17(8:9)=TEMP9(8:9) TEMP17(2:7)=TEMP9(1:6) TEMP17(1:1)=' ' TEMP9=TEMP17(1:9) ENDIF IF (TEMP9(8:8).EQ.'0') THEN TEMP17(9:9)=TEMP9(9:9) TEMP17(2:8)=TEMP9(1:7) TEMP17(1:1)=' ' TEMP9=TEMP17(1:9) ENDIF ASCII9=TEMP9 ELSE WRITE (TEMP17,'(F17.7)') X C C NPLACE IS THE POSITION OF THE FIRST SIG. DIGIT, COUNTING LEFT C FROM THE DECIMAL POINT (WHICH IS THE ZERO ORIGIN) IF (ABS(X).GE.1.) THEN NPLACE=1.00001+LOG10(ABS(X)) ELSE IF (X.NE.0.) THEN NPLACE=0.99999-LOG10(ABS(X)) NPLACE= -NPLACE ELSE NPLACE=0 ENDIF C C ZERO OUT NON-SIG. DIGITS NKEEP1=10-NPLACE IF ((NPLACE.EQ.1).OR.(NPLACE.EQ.2)) THEN NKEEP3=NKEEP1+3 ELSE NKEEP3=NKEEP1+2 ENDIF IF (NKEEP3.LT.17) THEN DO 20 J=NKEEP3+1,17 IF (TEMP17(J:J).NE.'.') THEN TEMP17(J:J)='0' ENDIF 20 CONTINUE ENDIF C C FIND FIRST INFORMATION, FROM RIGHT TO LEFT, AND CHOOSE 9 BYTES DO 90 M=17,11,-1 IF (TEMP17(M:M).NE.'0') THEN K9=M GO TO 99 ENDIF 90 CONTINUE K9=9 99 CONTINUE K1=K9-8 TEMP9=TEMP17(K1:K9) C C INSERT COMMAS FOR LARGE NUMBERS C IF (ABS(X).GT.999.9) THEN TEMP9(1:5)=TEMP9(2:6) TEMP9(6:6)=',' IF (ABS(X).GT.999900.) THEN ASCII9(1:1)=TEMP9(2:2) ASCII9(2:2)=',' ASCII9(3:9)=TEMP9(3:9) ELSE ASCII9=TEMP9 ENDIF ELSE ASCII9=TEMP9 ENDIF ENDIF RETURN END FUNCTION ASCII9 C C C SUBROUTINE READM (INPUT,IUNITP,N, + OUTPUT,EMPTY,EOF,VECTOR) C C AN INPUT UTILITY BASED ON "READN", BUT CUSTOMIZED FOR .DIG FILES C PARAMETER (LENGTH=26) CHARACTER*26 LINE CHARACTER*1 C INTEGER IOS LOGICAL EMPTY,EOF LOGICAL ANYIN,DOTTED,EXPON,SIGNED DIMENSION VECTOR(N) C LINE=' ' READ (IUNITP,'(A)',IOSTAT=IOS) LINE EOF=(IOS.EQ.-1) NUMBER=0 EMPTY=.TRUE. IF (EOF) RETURN C ANYIN=.FALSE. EXPON=.FALSE. SIGNED=.FALSE. DOTTED=.FALSE. DO 10 I=1,LENGTH C=LINE(I:I) IF ((C.EQ.' ').OR.(C.EQ.',').OR.(C.EQ.'/')) THEN SIGNED=.FALSE. EXPON=.FALSE. DOTTED=.FALSE. IF (ANYIN) THEN NUMBER=NUMBER+1 ANYIN=.FALSE. ENDIF ELSE IF ((C.EQ.'+').OR.(C.EQ.'-')) THEN IF (SIGNED) THEN GO TO 50 ELSE SIGNED=.TRUE. ENDIF ELSE IF ((C.EQ.'E').OR.(C.EQ.'D').OR. + (C.EQ.'e').OR.(C.EQ.'d')) THEN IF (EXPON) THEN GO TO 50 ELSE EXPON=.TRUE. SIGNED=.FALSE. DOTTED=.TRUE. ENDIF ELSE IF (C.EQ.'.') THEN IF (DOTTED) THEN GO TO 50 ELSE DOTTED=.TRUE. ENDIF ELSE IF ((C.EQ.'0').OR.(C.EQ.'1').OR.(C.EQ.'2').OR. + (C.EQ.'3').OR.(C.EQ.'4').OR.(C.EQ.'5').OR. + (C.EQ.'6').OR.(C.EQ.'7').OR.(C.EQ.'8').OR. + (C.EQ.'9')) THEN SIGNED=.TRUE. ANYIN=.TRUE. ELSE GO TO 50 ENDIF 10 CONTINUE IF (ANYIN) NUMBER=NUMBER+1 C 50 IF (NUMBER.EQ.0) THEN EMPTY=.TRUE. ELSE EMPTY=.FALSE. NUMBER=MIN(NUMBER,N) BACKSPACE IUNITP READ (IUNITP,*) (VECTOR(I),I=1,NUMBER) IF (NUMBER.LT.N) THEN DO 99 I=NUMBER+1,N VECTOR(I)=0. 99 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE READM C C C SUBROUTINE READN (INPUT,IUNITP,IUNITT,N, + OUTPUT,VECTOR) C C A UTILITY ROUTINE DESIGNED TO PERMIT -FAULTS- INPUT FILES C TO ALSO BE USED BY -PLATES-, WHICH EXPECTS MORE NUMBERS C IN SOME RECORDS. C THIS ROUTINE ATTEMPTS TO READ 'N' FLOATING-POINT VALUES C (USING * FORMAT) FROM THE NEXT RECORD ON DEVICE 'IUNITP'. C IF ANYTHING GOES WRONG, THE MISSING VALUES ARE SET TO ZERO. C CHARACTER*1 C CHARACTER*80 LINE INTEGER IOS LOGICAL ANYIN,DOTTED,EXPON,SIGNED DIMENSION VECTOR(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,*) (VECTOR(I),I=1,NUMBER) IF (NUMBER.LT.N) THEN DO 99 I=NUMBER+1,N VECTOR(I)=0. 99 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE READN C C C SUBROUTINE BOTTOM (INPUT,TRHMAX,VCX,VCY,X,Y, + OUTPUT,RESIST,VMX,VMY) C C COMPUTES HORIZONTAL COMPONENTS OF FLOW AT TOP OF ANY SUBDUCTING C SLABS OR OTHER STRONG ELEMENTS WHICH MAY APPLY TRACTIONS TO THE C BASE OF THE PLATE. C C (BUT, ALL SUCH TRACTIONS ARE TURNED OFF IF TRHMAX=0.) C C**************************************************************** C CAVEAT HACKER !!! C UNLIKE OTHER SUBPROGRAMS IN THIS PACKAGE, "BOTTOM" IS VERY C SPECIFIC TO A PARTICULAR PROBLEM: C -IT ONLY DESCRIBES THE PACIFIC/NORTH AMERICAN BOUNDARY IN THE C REGION OF THE ALASKAN-ALEUTIAN ARC. C -IT ASSUMES A PARTICULAR ORIGIN AND ORIENTATION OF THE X-AXIS. C (ORIGIN AT 61 N, 147 W, WITH +X POINTING E) C -IT ASSUMES THAT INPUT COORDINATES ARE IN METERS. C -IT IS BASED ON A PARTICULAR PLATE MODEL (ROTATION POLE): C THAT OF DEMETS ET. AL. (1990): NUVEL-1. C C YOU WILL PROBABLY NEED TO REPLACE THE CODE GIVEN HERE WITH C NEW CODE OF YOUR OWN !!! C**************************************************************** C PARAMETER (LAST=17) INTEGER I,I1,I2,J LOGICAL CONTAC,RESIST REAL FRAC,TRHMAX,VCX,VCY,VMX,VMY,X,XYARC,Y,YARC C XYARC HOLDS PAIRS OF (X, Y) OF VOLCANIC ARC, WITH X INCREASING: DIMENSION XYARC(2,LAST) DATA ((XYARC(I,J),I=1,2),J=1,17) / + -2.688E+06,+2.382E+05, + -2.564E+06,-9.064E+04, + -2.343E+06,-3.474E+05, + -2.088E+06,-5.215E+05, + -1.682E+06,-6.322E+05, + -1.420E+06,-6.290E+05, + -1.064E+06,-5.516E+05, + -8.054E+05,-4.764E+05, + -6.004E+05,-3.647E+05, + -3.868E+05,-2.185E+05, + -2.812E+05,+5.439E+04, + -2.080E+05,+2.306E+05, + -1.141E+05,+3.241E+05, + +7.915E+04,+1.160E+05, + +2.325E+05,+4.720E+04, + +4.203E+05,-7.314E+04, + +6.269E+05,-2.666E+05/ C IF (TRHMAX.LE.0.) THEN C NO-DRAG OPTION: RESIST=.FALSE. VMX=VCX VMY=VCY ELSE IF ((X.LT.XYARC(1,1)).OR.(X.GT.XYARC(1,LAST)).OR. + (X.GT.(-90000.-Y*1.28)).OR. + (X.GT.(287000.+Y*0.860))) THEN CONTAC=.FALSE. ELSE DO 10 I=2,LAST IF ((X.GE.XYARC(1,I-1)).AND. + (X.LE.XYARC(1,I))) THEN I1=I-1 I2=I FRAC=(X-XYARC(1,I1))/ + (XYARC(1,I2)-XYARC(1,I1)) GO TO 11 ENDIF 10 CONTINUE 11 YARC=XYARC(2,I1)+FRAC*(XYARC(2,I2)-XYARC(2,I1)) CONTAC=Y.LT.YARC ENDIF IF (CONTAC) THEN RESIST=.TRUE. CALL SIDES (INPUT,X,Y, + OUTPUT,VMX,VMY) ELSE RESIST=.FALSE. VMX=VCX VMY=VCY ENDIF ENDIF RETURN END SUBROUTINE BOTTOM C C C SUBROUTINE SIDES (INPUT,X,Y, + OUTPUT,VX,VY) C C COMPUTES HORIZONTAL COMPONENTS OF FLOW AT SIDES OF MODEL, IF C NEEDED FOR IMPOSITION OF TYPE-3 VELOCITY BOUNDARY CONDITIONS. C C**************************************************************** C CAVEAT HACKER !!! C UNLIKE OTHER SUBPROGRAMS IN THIS PACKAGE, "SIDES" IS VERY C SPECIFIC TO A PARTICULAR PROBLEM: C -IT ONLY DESCRIBES THE PLATE BOUNDARIES IN THE ALASKA/BERING SEA C REGION. C -IT ASSUMES A PARTICULAR ORIGIN AND ORIENTATION OF THE X-AXIS. C (ORIGIN AT 61 N, 147 W, WITH +X POINTING E) C -IT IS BASED ON A PARTICULAR PLATE MODELS (ROTATION POLES): C THOSE OF DEMETS ET. AL. (1990): NUVEL-1, AND C COOK ET AL. (1986): OKHOTSK/NORTH AMERICA. C -NOTE THAT ALL VELOCITIES ARE RELATIVE TO NORTH AMERICA. C C YOU WILL PROBABLY NEED TO REPLACE THE CODE GIVEN HERE WITH C NEW CODE OF YOUR OWN !!! C**************************************************************** C LOGICAL PACIFI,EURASI,OKHOTS REAL ARG,DX,DY,N1,N2,N3,P1,P2,P3,PLAT,PLON,QLAT,QLON, + RATE,R1,R2,R3,S,TIME,V1,V2,V3,VE,VN,VSQ,VX,VY,X,XP,Y,YP C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C IF (Y.LT. +5.617E5) THEN PACIFI=.TRUE. EURASI=.FALSE. OKHOTS=.FALSE. ELSE DX=X-(-1.200E6) DY=Y-(+5.617E5) ARG=ATAN2F(DY,DX) IF (ARG.GT.2.3999) THEN OKHOTS=.TRUE. EURASI=.FALSE. PACIFI=.FALSE. ELSE EURASI=.TRUE. OKHOTS=.FALSE. PACIFI=.FALSE. ENDIF ENDIF C CALL XYTOLL (INPUT,X,Y, + OUTPUT,PLAT,PLON) R1=RADIUS*COSDEG(PLON)*COSDEG(PLAT) R2=RADIUS*SINDEG(PLON)*COSDEG(PLAT) R3=RADIUS*SINDEG(PLAT) N1= -COSDEG(PLON)*SINDEG(PLAT) N2= -SINDEG(PLON)*SINDEG(PLAT) N3=COSDEG(PLAT) E1= -SINDEG(PLON) E2=COSDEG(PLON) E3=0. C IF (PACIFI) THEN C (DEMETS ET AL.: C (48.7S, 101.8E, 0.78 DEG./MILLION-YEARS) RATE=SINDEG(0.78)/(1.E6*3.15576E7) P1=COSDEG(101.8)*COSDEG(-48.7)*RATE P2=SINDEG(101.8)*COSDEG(-48.7)*RATE P3=SINDEG(-48.7)*RATE ELSE IF (EURASI) THEN C (DEMETS ET AL.: C (62.4N, 135.8E, 0.22 DEG./MILLION-YEARS) RATE=SINDEG(0.22)/(1.E6*3.15576E7) P1=COSDEG(135.8)*COSDEG(+62.4)*RATE P2=SINDEG(135.8)*COSDEG(+62.4)*RATE P3=SINDEG(+62.4)*RATE ELSE IF (OKHOTS) THEN C (COOK ET AL., 1986; RATE IS REALLY A GUESS!) C (72.4N, 169.8E, 0.4 DEG./MILLION-YEARS) RATE=SINDEG(0.4 )/(1.E6*3.15576E7) P1=COSDEG(169.8)*COSDEG(+72.4)*RATE P2=SINDEG(169.8)*COSDEG(+72.4)*RATE P3=SINDEG(+72.4)*RATE ELSE VX=0. VY=0. RETURN ENDIF V1=P2*R3-P3*R2 V2=P3*R1-P1*R3 V3=P1*R2-P2*R1 VN=N1*V1+N2*V2+N3*V3 VE=E1*V1+E2*V2+E3*V3 VSQ=VN*VN+VE*VE IF (VSQ.GT.0.) THEN TIME=RADIUS*SINDEG(1.)/SQRT(VSQ) ELSE VX=0. VY=0. RETURN ENDIF QLAT=PLAT+57.296*VN*TIME/RADIUS QLON=PLON+57.296*VE*TIME/(RADIUS*COSDEG(PLAT)) CALL LLTOXY (INPUT,QLAT,QLON, + OUTPUT,XP,YP) VX=(XP-X)/TIME VY=(YP-Y)/TIME RETURN END SUBROUTINE SIDES C C C SUBROUTINE FAULT (INPUT,DASHED,DOTICS,DOTRACE, + FDIP,FTAN,I, + MXFEL, + MXNODE,NODEF,NTIC, + SIZE,WEDGE,XNODE,YNODE) C C DRAW ONE FAULT ELEMENT, WITH DIP SYMBOLS C THE DIP SYMBOLS HAVE A CHARACTERISTIC DIMENSION OF "SIZE", C IN PHYSICAL (MAP) LENGTH UNITS, AND THERE ARE "NTIC" C SYMBOLS ALONG EACH ELEMENT. C C IF LOGICAL FLAG "DASH" IS ON, THE LINE IS DASHED. C INTEGER DOWN,UP,I,ISTEP, + I1,I2,I3,K,M,MTIC,NODEF,USETIC LOGICAL DASHED,DOTICS,DOTRACE REAL ARG,DS,D1,D2,D3,DX,DY,FDIP,FROMVE,FTAN, + F1,F2,F3, + PARG,PHIVAL,PX,PY,S,WEDGE,X,XNODE,X0,Y,YNODE DIMENSION USETIC(7,7) DIMENSION FDIP(3,MXFEL),FTAN(7,MXFEL),NODEF(6,MXFEL), + XNODE(MXNODE),YNODE(MXNODE) DATA DOWN/2/, UP/3/ DATA STEP/0.10/, ISTEP/10/ C C STATEMENT FUNCTION: PHIVAL(S,F1,F2,F3)= + F1*(1.-3.*S+2.*S**2)+ + F2*(4.*S*(1.-S))+ + F3*(2.*S**2-S) C I1=NODEF(1,I) I2=NODEF(2,I) I3=NODEF(3,I) X1=XNODE(I1) X2=XNODE(I2) X3=XNODE(I3) Y1=YNODE(I1) Y2=YNODE(I2) Y3=YNODE(I3) S=0. D1=FDIP(1,I) D2=FDIP(2,I) D3=FDIP(3,I) DS=STEP X=PHIVAL(S,X1,X2,X3) Y=PHIVAL(S,Y1,Y2,Y3) IF (DOTRACE) THEN DO 10 K=1,ISTEP CALL PLOT(X,Y,UP) S=S+DS X=PHIVAL(S,X1,X2,X3) Y=PHIVAL(S,Y1,Y2,Y3) IF (DASHED.AND.(MOD(K,2).EQ.0)) THEN CALL PLOT(X,Y,UP) ELSE CALL PLOT(X,Y,DOWN) ENDIF 10 CONTINUE END IF C C ADD DIP SYMBOLS AT CERTAIN INTEGRATION POINTS: C NTIC = 0 -> NONE C NTIC = 1 -> POINT 4 C NTIC = 2 -> POINTS 3, 5 C NTIC = 3 -> POINTS 2, 4, 6 USETIC(1,1)=4 USETIC(1,2)=3 USETIC(2,2)=5 USETIC(1,3)=2 USETIC(2,3)=4 USETIC(3,3)=6 C MTIC=MIN(NTIC,3) IF (DOTICS.AND.(MTIC.GT.0)) THEN DO 100 K=1,MTIC M=USETIC(K,MTIC) S=FPOINT(M) X0=PHIVAL(S,X1,X2,X3) Y0=PHIVAL(S,Y1,Y2,Y3) ARG=FTAN(M,I) DIP=PHIVAL(S,D1,D2,D3) FROMVE=ABS(1.570796-DIP) IF (FROMVE.LT.WEDGE) THEN C VERTICAL STRIKE-SLIP FAULT ELSE IF (FROMVE.LT.0.610865) THEN C NORMAL FAULT IF (DIP.LT.1.5708) THEN PARG=ARG-1.570796 ELSE PARG=ARG+1.570796 ENDIF PX=SIZE*COS(PARG) PY=SIZE*SIN(PARG) CALL PLOT(X0+PX,Y0+PY,UP) CALL PLOT(X0,Y0,DOWN) ELSE IF (FROMVE.LT.0.95993) THEN C INTERMEDIATE-DIP FAULT IF (DIP.LT.1.5708) THEN PARG=ARG-1.570796 ELSE PARG=ARG+1.570796 ENDIF PX=SIZE*COS(PARG) PY=SIZE*SIN(PARG) DX=0.5*SIZE*COS(ARG) DY=0.5*SIZE*SIN(ARG) CALL PLOT(X0+DX, Y0+DY ,UP ) CALL PLOT(X0+DX+PX,Y0+DY+PY,DOWN) CALL PLOT(X0-DX+PX,Y0-DY+PY,DOWN) CALL PLOT(X0-DX ,Y0-DY ,DOWN) ELSE C THRUST FAULT IF (DIP.LT.1.5708) THEN PARG=ARG-1.570796 ELSE PARG=ARG+1.570796 ENDIF PX=SIZE*COS(PARG) PY=SIZE*SIN(PARG) DX=0.3*SIZE*COS(ARG) DY=0.3*SIZE*SIN(ARG) CALL PLOT(X0+DX,Y0+DY,UP ) CALL PLOT(X0+PX,Y0+PY,DOWN) CALL PLOT(X0-DX,Y0-DY,DOWN) ENDIF 100 CONTINUE ENDIF RETURN END SUBROUTINE FAULT C C C C The following 4 INTEGER functions go with the C codiagonal band symmetric storage mode of matrices ABCD and EF, C per Microsoft version of IMSL. Note that element (row #i, col #j) C of the idealized square matrix square_ABCD, or C square_ABCD(i, j) is stored as ABCDEF(ABCDrow(j),ABCDcol(i, j)); C and that only elements with j >= i (upper right) can be stored. C Element (row i) of the linear vector EF is stored in C ABCDEF(EFrow(i), EFcol). C INTEGER FUNCTION ABCDrow(j) INTEGER, INTENT(IN) :: j ABCDrow = j + ncoda ! ncoda is global RETURN END FUNCTION ABCDrow C C C INTEGER FUNCTION ABCDcol(i, j) INTEGER, INTENT(IN) :: i, j ABCDcol = (j - i) + 1 RETURN END FUNCTION ABCDcol C C C INTEGER FUNCTION EFrow(i) INTEGER, INTENT(IN) :: i EFrow = i + ncoda ! ncoda is global RETURN END FUNCTION EFrow C C C INTEGER FUNCTION EFcol EFcol = ncoda + 2 ! ncoda is global RETURN END FUNCTION EFcol C END PROGRAM PLATES2AI