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) GO TO 10 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=' ' CDI02(1:LEN(TRIM(TYPE)))=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 Laramy2AI, 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,0: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-40) GO TO 1000 S2EXT=(4.*F6**2-4.*F6*F5-4.*F6*F4-F6*F3+2.*F6*F2-F6*F1+F5* + F3+3.*F5*F1+3.*F4*F3+F4*F1-F3*F2-2.*F3*F1-F2*F1)/(4.*(F6 + **2-2.*F6*F5-2.*F6*F4+2.*F6*F2+F5**2-2.*F5*F4+2.*F5*F1+F4 + **2+2.*F4*F3-F3*F2-F3*F1-F2*F1)) S3EXT=(-4.*F6*F4+3.*F6*F2+F6*F1-4.*F5*F4+F5*F2+3.*F5*F1+4. + *F4**2+2.*F4*F3-F4*F2-F4*F1-F3*F2-F3*F1-2.*F2*F1)/(4.*(F6 + **2-2.*F6*F5-2.*F6*F4+2.*F6*F2+F5**2-2.*F5*F4+2.*F5*F1+F4 + **2+2.*F4*F3-F3*F2-F3*F1-F2*F1)) S1EXT=1.0-S2EXT-S3EXT C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7786)S1EXT,S2EXT,S3EXT 7786 FORMAT(/' EXTREMUM AT S1-3=',3F10.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (S1EXT.GT.0.99999.OR.S1EXT.LT.0.00001) GO TO 1000 IF (S2EXT.GT.0.99999.OR.S2EXT.LT.0.00001) GO TO 1000 IF (S3EXT.GT.0.99999.OR.S3EXT.LT.0.00001) GO TO 1000 C C REJECT SADDLE POINTS C DISCA=F1-2.*F4+F2 DISCB=F2-2.*F5+F3 DISCC=F3-2.*F6+F1 CENTER=((DISCA.GT.0.).AND.(DISCB.GT.0.).AND.(DISCC.GT.0.)) + .OR.((DISCA.LT.0.).AND.(DISCB.LT.0.).AND.(DISCC.LT.0.)) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7789) CENTER,DISCA,DISCB,DISCC 7789 FORMAT(/' CENTER=',L2,' BECAUSE DISCA-C=',1P,3E12.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (.NOT.CENTER) GO TO 1000 XEXT=PHIVAL(S1EXT,S2EXT,S3EXT,X1,X2,X3,X4,X5,X6) YEXT=PHIVAL(S1EXT,S2EXT,S3EXT,Y1,Y2,Y3,Y4,Y5,Y6) FEXT=PHIVAL(S1EXT,S2EXT,S3EXT,F1,F2,F3,F4,F5,F6) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8801)XEXT,YEXT,FEXT 8801 FORMAT(/' EXTREMUM IS AT X=',1P,E10.3,', Y=',E10.2, + ', F=',E10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ FMAX=MAX(FMAX,FEXT) FMIN=MIN(FMIN,FEXT) C C FIND CONTOUR STARTING/STOPPING POINT ALONG CHORD FROM A NODE TO EXT. C NCL=1 DIFF=ABS(F1-FEXT) DS(1)=S1EXT-1. DS(2)=S2EXT DS(3)=S3EXT DO 600 J=2,6 DFF=ABS(FN(J)-FEXT) IF (DFF.LT.DIFF) THEN NCL=J DIFF=DFF DS(1)=S1EXT DS(2)=S2EXT DS(3)=S3EXT IF (J.EQ.2) DS(2)=S2EXT-1. IF (J.EQ.3) DS(3)=S3EXT-1. IF (J.EQ.4.OR.J.EQ.6) DS(1)=S1EXT-0.5 IF (J.EQ.4.OR.J.EQ.5) DS(2)=S2EXT-0.5 IF (J.EQ.5.OR.J.EQ.6) DS(3)=S3EXT-0.5 ENDIF 600 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8812)NCL,DIFF,(DS(K),K=1,3) 8812 FORMAT(/' PARTITION LINE:'/ + ' NCL=',I10,' DIFF=',1P,E10.3,' DS(1-3)=',0P, + 3F10.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ CALL DOLINE (FEXT,DFCON,FN,NCL,DS,S1EXT,S2EXT,S3EXT, + IHIC,ILOC,PS,NPS,NINLIN,Z) IF (Z) THEN NCRASH=7 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF C C END OF CODE RELATED TO CASE OF AN INTERNAL EXTREMUM C C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT.AND.(NPS.GT.0)) THEN WRITE(6,8821) 8821 FORMAT(/ /' TABLE OF CONTOUR STARTING POINTS:') DO 8825 I=1,NPS XQ=PHIVAL(PS(1,I),PS(2,I),PS(3,I),X1,X2,X3,X4,X5,X6) YQ=PHIVAL(PS(1,I),PS(2,I),PS(3,I),Y1,Y2,Y3,Y4,Y5,Y6) WRITE(6,8823)I,(PS(K,I),K=1,4),XQ,YQ 8823 FORMAT(' ',I10,0P,3F10.5,1P,3E10.3) 8825 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 1000 IF (NPS.EQ.0) GO TO 9001 C C************************************************************* C C INTEGRATE ALL CONTOUR SEGMENTS C DO 1150 K=1,NPS DONE(K)=.FALSE. 1150 CONTINUE DO 9000 N=1,NPS C C INTEGRATE ONE CONTOUR SEGMENT C IF (.NOT.DONE(N)) THEN C C INITIALIZE INTEGRATION OF CONTOUR C DONE(N)=.TRUE. FVALUE=PS(4,N) IF (ALLPOS.AND.(FVALUE.LE.0.0)) GO TO 9000 ISPNUM=ISPNUM+1 C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8831)ISPNUM,FVALUE 8831 FORMAT(/' HISTORY OF SEGMENT ',I5,' (',1P,E10.3,')') ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (ISPNUM.GT.NINLIN) THEN NCRASH=8 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF FOFSEG(ISPNUM)=FVALUE ISPPNT(ISPNUM)=ISPPNT(ISPNUM-1)+ISPLEN(ISPNUM-1) IF (ISPPNT(ISPNUM).GT.NWORK) THEN NCRASH=9 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF ISPLEN(ISPNUM)=1 NTOGO(ISPNUM)=2 ANEDGE(ISPNUM)=.FALSE. S1=PS(1,N) S2=PS(2,N) S3=PS(3,N) INSIDE=(S1*S2*S3).GT.0.0 S1OLD=S1 S2OLD=S2 S3OLD=S3 X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) SPACE(1,ISPPNT(ISPNUM))=X SPACE(2,ISPPNT(ISPNUM))=Y ANGLE=0. IF (CENTER) ANGLE=ATAN2((Y-YEXT),(X-XEXT)) ANGLEP=ANGLE ROT=0. DFDS2=-4.*S3*F6+4.*S3*F5-4.*S3*F4+4.*S3*F1-8.*S2*F4+4.*S2* + F2+4.*S2*F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3*F6+4.*S3*F3+4.*S3*F1-4.*S2*F6+4.*S2*F5-4.*S2* + F4+4.*S2*F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(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(4,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=============================================================== C C C MODULE PROFIL C C ESTABLISHES PROFILE OF CORDILLERA, PER MODEL OF C GROW AND BOWIN (1975) JOURNAL OF GEOPHYSICAL RESEARCH, C VOL. 80, NUMBER 11, PAGE 1454. C THIS MODEL IS FOR AN EAST-WEST SECTION OF THE ANDES AT 23 SOUTH. C ITS ORIGINAL PARAMETER VALUES ARE: WANDES = 730 KM, APLANO = 5 KM. C C NOTE: HANDES IS A LIST OF DIMENSIONLESS NUMBERS WHICH REACH A C PLATEAU LEVEL OF +1.0 SOMEWHERE IN THE MIDDLE, DEFINING THE C HEIGHT PROFILE OF THE CORDILLERA RELATIVE TO HEIGHT "APLANO". C XANDES CONTAINS THE DIMENSIONLESS DISTANCES (RELATIVE TO C WANDES) AT WHICH THESE RATIOS ARE GIVEN. C XANDES(1) SHOULD ALWAYS BE ZERO; C XANDES(NPOINT) SHOULD ALWAYS BE 1.00. C LINEAR INTERPOLATION IS USED IN BETWEEN GIVEN POINTS; C THICKNESSES THICKN(2) APPLY AT X.GT.XANDES(NPOINT). C THE ALTIPLANO REGION IS LIMITED BY POINTS NALT1 AND NALT2; C AT X=XANDES(NALT1) THE SUBDUCTING SLAB LOSES CONTACT WITH C THE OVERRIDING PLATE. C AT X=XANDES(NALT2), A WEDGE OF MANTLE LITHOSPHERE IS ADDED C TO THE OVERRIDING PLATE, REACHING THICKNESS THICKN(2) C AT X=XANDES(NPOINT). C REAL, DIMENSION(5) :: HANDES = (/-1., 0. , 1.0 , 1.0 , 0. /) REAL, DIMENSION(5) :: XANDES = (/ 0.,0.209,0.350,0.694,1.000 /) INTEGER :: NPOINT = 5 INTEGER :: NALT1 = 3 INTEGER :: NALT2 = 4 END MODULE PROFIL C=================================================================== C PROGRAM Laramy2AI C C (Edition of 24 July 1997) C COMPATIBLE WITH 31 JANUARY 1997 VERSION OF LARAMY. C TAKES OUTPUT FROM A FINITE ELEMENT SIMULATION OF CONTINENTAL C DEFORMATION PERFORMED BY "LARAMY" AND PLOTS CONTOUR DIAGRAMS C OF THE RESULTS IN COLOR OR BLACK-AND-WHITE (on 8.5" by 11" C paper, in landscape format) using the Adobe-Illustrator-4- C for-Windows dialect of the PostScript graphics language. C C USES STRATEGIC AND TACTICAL INPUT PARAMETERS IN C CARD FORMAT FROM DEVICE 1; SHOULD CONFORM TO DATA USED C IN THE ORIGINAL RUN OF "LARAMY"; PLOT CONTROLS ARE APPENDED C AT THE END OF THIS DATASET (WHERE "LARAMY" WON'T READ THEM). C READS OLD OUTPUT "TAPE" AS SOURCE OF DETAILED DATA FROM DEVICE 8. C Reads a model .AI file like LanModel.AI on unit 11. C OPTIONALLY READS STATE OUTLINES FROM UNIT 13 AND INCLUDES IN PLOTS. C OPTIONALLY READS SHORT DATASET OF FINAL NODE LOCATIONS CORRESPONDING C TO THESE STATE LINES ON DEVICE 12, AND RETRO-PROJECTS THEM. C PRODUCES "PRINTER-PLOT" (ASCII-GRID) OUTPUT ON UNIT 6. C Produces PostScript (.AI) file output on unit 99. C C NOTICE: THIS PROGRAM AND ASSOCIATED SUBPROGRAMS WERE CREATED BY C PETER BIRD, DEPARTMENT OF EARTH & SPACE SCIENCES, C UNIVERSITY OF CALIFORNIA, LOS ANGELES. C FIVE YEARS OF SUPPORT FROM THE CRUSTAL STRUCTURE AND TECTONICS C PROGRAM OF THE NATIONAL SCIENCE FOUNDATION ARE GRATEFULLY C ACKNOWLEDGED. C THIS PROGRAM IS PUBLIC PROPERTY AND MAY BE REPRODUCED AND RUN C WITHOUT WRITTEN PERMISSION. HOWEVER, PROPER CREDIT SHOULD C BE GIVEN TO THE AUTHOR IN ANY RESULTING PUBLICATIONS. C USERS ARE ENCOURAGED TO CONTACT THE AUTHOR FOR ADVICE, UPDATES, C AND TECHNICAL SUPPORT, AT (310) 825-1126 or pbird@ess.ucla.edu C C=========================================================== C NECESSARY MODULES (MUST PRECEDE Laramy2AI IN FILE): C USE SPHERE USE DISSPLA2AI USE VERSATEC2AI USE MAPTOOLS C C NOTE: SPECIAL MODULE WITH PROFILE OF ANDES: USE PROFIL C 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. C=========================================================== C CHARACTER*80 TITLE DOUBLE PRECISION PHI,POINTS,WEIGHT INTEGER IBELOWINDEX C INTEGER lda, ncoda C Preceding are global variables used by ABCDrow, ABCDcol, etc. C LOGICAL ALDONE,ALLREP,DIMERR,DOPLOT, + DRAWST,FAILUR,LISTOP,OLDGRD,RESTRT,RETRO, + STATES,TAPE9 C====================================================================== C C FOLLOWING LINE SETS MAXIMUM NUMBER OF ELEMENTS: PARAMETER (N50=280) C FOLLOWING LINE SETS MAXIMUM NUMBER OF NODES: PARAMETER (N121=609) C FOLLOWING LINE SETS MAXIMUM NUMBER OF POINTS IN STATELINE MAPS: PARAMETER (NSTATE=2000) C FOLLOWING LINE SETS NUMBER OF TYPES OF PLOT: PARAMETER (NTYPE=24) C====================================================================== C C VARIABLE DIMENSIONS CONTAINING VALUE OF N50: DIMENSION ALPHAC(3,3,7,N50),ALPHAM(3,3,7,N50), 2 AREAC(N50),AREAM(N50),CONINT(7,N50),DELVC(2,7,N50), 3 DELVM(2,7,N50),DETJC(7,N50), 4 DETJM(7,N50), 6 DVB(7,N50),DVT(7,N50),DXSC(6,7,N50), 7 DXSM(6,7,N50),DYSC(6,7,N50),DYSM(6,7,N50), 8 ERATEC(4,7,N50),ERATEM(4,7,N50), 9 ESUMC(2,2,7,N50),ESUMM(2,2,7,N50), A FLUXC(7,N50),FLUXM(7,N50) DIMENSION FROMWC(7,N50),FROMWM(7,N50), 3 GEOTHA(4,7,N50),GEOTHC(4,7,N50),GEOTHM(4,7,N50), 4 GLUEC(7,N50),GLUEM(7,N50),DNLINK(3,7,N50), 5 UPLINK(3,7,N50),ILAYER(N50),LISTOP(N50), 6 NODES(6,0:N50),OUTSCA(7,N50),OUTVEC(2,7,N50), 7 OUTV2(2,7,N50),OVA(2,7,N50),OVB(2,7,N50), 8 PTSC(2,7,N50),PTSM(2,7,N50), 9 SIGHC(2,7,N50),SIGHBM(2,7,N50),SIGHTM(2,7,N50), A SIGZZC(7,N50),SIGZZM(7,N50), 1 SZZBC(7,N50),SZZBM(7,N50),TAUMTC(3,7,N50), 2 TAUMTM(3,7,N50),TAUZZC(7,N50),TAUZZM(7,N50), 3 THIKC(7,N50),THIKM(7,N50), 4 TOFSTC(3,7,N50),TOFSTM(3,7,N50), 5 TOUCHC(7,N50),TOUCHM(7,N50), 6 VSLABC(2,7,N50),VSLABM(2,7,N50), 7 XIPC(7,N50),XIPM(7,N50),YIPC(7,N50),YIPM(7,N50) C VARIABLE DIMENSIONS CONTAINING VALUE OF N121: DIMENSION CONDNS(N121),CONNOD(N121),NODCON(N121),PHINOD(N121), + XNODC(N121),XNODM(N121),YNODC(N121), + YNODM(N121),VC(2,N121),VM(2,N121), + THNKC(N121),THNKM(N121), + WC(N121),WM(N121) C VARIABLE DIMENSION CONTAINING VALUE OF NSTATE: DIMENSION DRAWST(NSTATE),STLINK(3,NSTATE), + XST(NSTATE),XSTT(NSTATE),YST(NSTATE),YSTT(NSTATE) C VARIABLE DIMENSION CONTAINING VALUE OF NTYPE: DIMENSION CINT(NTYPE),DOPLOT(NTYPE),FBLAND(NTYPE),LOWBLU(NTYPE) C C FIXED-DIMENSION ARRAYS OF GENERAL USE AND VARIABLE VALUE: DIMENSION ACREEP(3),ALPHAT(2),BCREEP(3),CCREEP(3),CONDUC(2), + DCREEP(3), + DIFFUS(2),DVPBYE(2,2),DVPDT(2),ECREEP(3), + FRIC(2),HMAX(2),HMIN(2), + RADIO(2),RHOBAR(2),TEMLIM(2), + THICKN(2),VPMEAN(2) C C DIMENSIONS OF DOUBLE-PRECISION ARRAYS DEFINING 6-NODE ELEMENT: DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) C C (FIXED-DIMENSION ARRAYS OF LOCAL USE ARE BUILT INTO SUBROUTINES) C C C ARRAYS FOR LINEAR SYSTEMS USED FOR EXTRAPOLATION TO NODES: REAL, DIMENSION(:,:), ALLOCATABLE :: ABCDEF REAL, DIMENSION(:), ALLOCATABLE :: u_flag C C====================================================================== DATA (NODES(J,0),J=1,6)/1,1,1,1,1,1/ DATA RINKM /6371./ DATA NTREAD /0/ DATA PHI / + -0.1111111111111111,-0.1111111111111111,-0.1111111111111111, + 0.4444444444444444, 0.4444444444444444, 0.4444444444444444, + -0.0525839022774079,-0.0280749439026853,-0.0280749439026853, + 0.1122997756107412, 0.8841342388612960, 0.1122997756107412, + -0.0280749439026853,-0.0525839022774079,-0.0280749439026853, + 0.1122997756107412, 0.1122997756107412, 0.8841342388612960, + -0.0280749439026853,-0.0280749439026853,-0.0525839022774079, + 0.8841342388612960, 0.1122997756107412, 0.1122997756107412, + 0.4743526114618935,-0.0807685938011933,-0.0807685938011933, + 0.3230743752047730, 0.0410358257309469, 0.3230743752047730, + -0.0807685938011933, 0.4743526114618935,-0.0807685938011933, + 0.3230743752047730, 0.3230743752047730, 0.0410358257309469, + -0.0807685938011933,-0.0807685938011933, 0.4743526114618935, + 0.0410358257309469, 0.3230743752047730, 0.3230743752047730/ DATA POINTS / + 0.3333333333333333, 0.3333333333333333, 0.3333333333333333, + 0.3333333333333333, 0.3333333333333333, + 0.0597158733333333, 0.4701420633333333, 0.4701420633333333, + 0.0597158733333333, 0.4701420633333333, + 0.4701420633333333, 0.0597158733333333, 0.4701420633333333, + 0.4701420633333333, 0.0597158733333333, + 0.4701420633333333, 0.4701420633333333, 0.0597158733333333, + 0.4701420633333333, 0.4701420633333333, + 0.7974269866666667, 0.1012865066666667, 0.1012865066666667, + 0.7974269866666667, 0.1012865066666667, + 0.1012865066666667, 0.7974269866666667, 0.1012865066666667, + 0.1012865066666667, 0.7974269866666667, + 0.1012865066666667, 0.1012865066666667, 0.7974269866666667, + 0.1012865066666667, 0.1012865066666667/ DATA WEIGHT / 0.2250000000000000, + 0.1323941500000000, 0.1323941500000000, 0.1323941500000000, + 0.1259391833333333, 0.1259391833333333, 0.1259391833333333/ C C====================================================================== C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C====================================================================== C CALL READIN (TITLE ,FRIC ,ACREEP,ECREEP,BCREEP, + CCREEP,DCREEP,CONDUC,DIFFUS, + RADIO ,THICKN,TEMLIM,RHOBAR, + ALPHAT,VPMEAN,DVPDT ,DVPBYE, + RHOAST,RHOH2O,BIOT ,G , + IBELOWINDEX,NTYPE, + TSLAB0,SIGBOT,PUSHHO,ECLOG , + SLABSZ,PUSHUP,NELROW,NELCOL, + BEGAGE,DELTAT,ENDAGE,DXMAX ,DTHMAX, + RAMP ,NDIFUS,MAXITR,OKTOQT, + VISMAX,ETAMAX,HMIN ,HMAX , + ALLREP,MIDREP,TAPE9 ,RESTRT, + KTAPE ,CONRAD,DQDTDA,TSURF , + APLANO,WANDES,VDECOL,OLDGRD, + GWIDE ,GHIGH ,GANGLE, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,SCALEC,NCONTR, $ STATES,RETRO,RMSVEC, $ IPENCT,IPENST,IPENLB) C C MEASURES OF THE FINITE ELEMENT GRID TOPOLOGY: NUMEL=2*NELROW*NELCOL NROWN=2*NELROW+1 NCOLN=2*NELCOL+1 NUMNOD=NROWN*NCOLN NDIFF=2*NCOLN MXNODE=N121 MAXBN=N121 MXBN=MAXBN NCOND=NCOLN+NROWN+NCOLN+NROWN-4 C C OUTLINE OF GRID, FOR GRAPHICAL PURPOSES J=0 DO 10 I=1,NCOLN NODE=(NROWN-1)*NCOLN+I J=J+1 NODCON(J)=NODE 10 CONTINUE DO 20 I=2,NROWN NODE=(NROWN+1-I)*NCOLN J=J+1 NODCON(J)=NODE 20 CONTINUE DO 30 I=2,NCOLN NODE=NCOLN+1-I J=J+1 NODCON(J)=NODE 30 CONTINUE DO 40 I=2,NROWN-1 NODE=(I-1)*NCOLN+1 J=J+1 NODCON(J)=NODE 40 CONTINUE C ONEKM=RADIUS/RINKM C IF (STATES) THEN WRITE (6,50) 50 FORMAT (//' Attempting to read BASEMAP in LARAMY format ', + 'from unit 13.') NXYST=0 DO 1100 I=1,NSTATE READ(13,*,END=1101) PLAT,PLON,DRAWST(I) CALL LLTOXY (INPUT,PLAT,PLON, + OUTPUT,X,Y) XST(I)=X YST(I)=Y XSTT(I)=XST(I) YSTT(I)=YST(I) NXYST=NXYST+1 1100 CONTINUE 1101 NXYST=NXYST-MOD(NXYST,7) DRAWST(1)=.FALSE. ENDIF DIMERR=(NUMEL.GT.N50).OR.(NUMNOD.GT.N121).OR.(NXYST.GT.NSTATE) IF (DIMERR) THEN WRITE (*,1110) NUMEL,N50,NUMNOD,N121,NXYST,NSTATE 1110 FORMAT (/' COMPARISON OF ACTUAL AND DIMENSIONED ARRAY ', + 'SIZES:' + /' ACTUAL PARAMETER VALUE' + /' NUMEL = ',I6,' N50 = ',I6, + /' NUMNOD = ',I6,' N121 = ',I6, + /' NXYST = ',I6,' NSTATE = ',I6) STOP 'Dimensions of arrays too small.' END IF CALL GRIDDR(INDATA,NELROW,NELCOL,NUMEL, + MODIFY,NODES) C ncoda = NDIFF lda = NUMNOD + ncoda ALLOCATE ( ABCDEF(lda,ncoda+2) ) ALLOCATE ( u_flag(NUMNOD) ) C IF (STATES.AND.RETRO) THEN CALL GOTOND (INPUT,NUMNOD, + OUTPUT,XNODC,YNODC) CALL AREAS (NODES,AREAC,XNODC,YNODC,NUMNOD,NUMEL) NUMEL1=NXYST/7 NUMEL2=NUMEL CALL LINKUS (NELCOL,NUMEL1,NUMEL2,XST,YST, + XNODC,YNODC, + NUMNOD,NODES,AREAC,STLINK,FAILUR) ENDIF IF (KTIME.GE.1) THEN CALL PAST (ACREEP,ALPHAC,ALPHAM,ALPHAT,AREAC,AREAM,BCREEP, 2 BIOT,CCREEP,CONDNS,CONINT,CONNOD,CONRAD, 3 DCREEP,DELVC,DELVM,DETJC,DETJM, 4 DNLINK,DVB,DVT,DXSC,DXSM,DYSC,DYSM,ECLOG,ECREEP, 5 ERATEC,ERATEM,ESUMC,ESUMM,ETAMAX,FLUXC, 6 FLUXM,FRIC,G,GEOTHA,GEOTHC,GEOTHM,GLUEC,GLUEM, 7 KTIME,ILAYER,LISTOP,NDIFF,NELCOL, 8 NODES,NUMEL,NUMNOD,ONEKM,OUTSCA,OUTVEC, 9 OUTV2,OVA,OVB,PTSC,PTSM,PUSHHO,PUSHUP, A RAMP,RHOAST,RHOH2O,RHOBAR,SIGBOT,SIGHC, 1 SIGHBM,SIGHTM,SIGZZC,SIGZZM,SLABSZ,SZZBC,SZZBM, 2 TASTH,TAUMTC,TAUMTM,TAUZZC,TAUZZM,TEMLIM, 3 THIKC,THIKM,TIME,THNKC,THNKM,TOFSTC,TOFSTM, 4 TOUCHC,TOUCHM,TSLAB0,TSURF,UPLINK,VC,VM,VISMAX, 5 VSLABC,VSLABM,WC,WM,XIPC,XIPM, 6 XNODC,XNODM,YIPC,YIPM,YNODC,YNODM, 7 ALDONE,NELROW,FROMWC,FROMWM,WANDES, 8 IBELOWINDEX,NTREAD,TITLE,HMAX,HMIN) IF (STATES.AND.RETRO) THEN CALL GETSCA (INPUM,XNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,XSTT) CALL GETSCA (INPUM,YNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,YSTT) DO 5678 I=1,NXYST IF (STLINK(1,I).LT.1.0) THEN XSTT(I)=XST(I) YSTT(I)=YST(I) ENDIF 5678 CONTINUE ENDIF ISTEP=1 CALL REPORT (ISTEP,XIPC,XIPM,YIPC,YIPM, 2 XNODC,XNODM,YNODC,YNODM,TITLE,VM,NODES, 3 OUTSCA,OUTVEC,VC,ERATEM,ERATEC, 4 THIKM,THIKC,GEOTHA,GEOTHC,CONDUC, 5 GEOTHM,DNLINK,VPMEAN,DVPBYE,DVPDT, 6 TIME ,NUMNOD,NUMEL, 7 G,HMAX,HMIN,RHOAST,RHOH2O,SIGHC,SIGHBM,SIGZZC, 8 SIGZZM,TAUMTC,TAUMTM,TAUZZC,TAUZZM, 9 TEMLIM,ONEKM,ESUMC,ESUMM,AREAC,AREAM, A CONDNS,DETJC,DETJM,FAILUR, 1 NDIFF,WC,WM, 2 SZZBC,SZZBM,TOUCHC,TOUCHM, 3 ECLOG,SLABSZ, 4 VSLABC,VSLABM,OUTV2,RAMP, 5 THNKC,UPLINK,TASTH,TSLAB0, 6 DOPLOT,SCALEC,NCONTR, 7 STATES,RMSVEC,NELCOL,PHINOD,DRAWST, 8 NXYST,XSTT,YSTT,NELROW,THNKM,FBLAND,LOWBLU, 9 CINT,FROMWC,FROMWM,IBELOWINDEX,WANDES, A CONINT,CONNOD, B TSURF,PUSHUP,IPENCT,IPENST,IPENLB) ELSE KTIME=1 DO 9999 ITIME=1,999 CALL PAST (ACREEP,ALPHAC,ALPHAM,ALPHAT,AREAC,AREAM,BCREEP, 2 BIOT,CCREEP,CONDNS,CONINT,CONNOD,CONRAD, 3 DCREEP,DELVC,DELVM,DETJC,DETJM, 4 DNLINK,DVB,DVT,DXSC,DXSM,DYSC,DYSM,ECLOG,ECREEP, 5 ERATEC,ERATEM,ESUMC,ESUMM,ETAMAX,FLUXC, 6 FLUXM,FRIC,G,GEOTHA,GEOTHC,GEOTHM,GLUEC,GLUEM, 7 KTIME,ILAYER,LISTOP,NDIFF,NELCOL, 8 NODES,NUMEL,NUMNOD,ONEKM,OUTSCA,OUTVEC, 9 OUTV2,OVA,OVB,PTSC,PTSM,PUSHHO,PUSHUP, A RAMP,RHOAST,RHOH2O,RHOBAR,SIGBOT,SIGHC, 1 SIGHBM,SIGHTM,SIGZZC,SIGZZM,SLABSZ,SZZBC,SZZBM, 2 TASTH,TAUMTC,TAUMTM,TAUZZC,TAUZZM,TEMLIM, 3 THIKC,THIKM,TIME,THNKC,THNKM,TOFSTC,TOFSTM, 4 TOUCHC,TOUCHM,TSLAB0,TSURF,UPLINK,VC,VM,VISMAX, 5 VSLABC,VSLABM,WC,WM,XIPC,XIPM, 6 XNODC,XNODM,YIPC,YIPM,YNODC,YNODM, 7 ALDONE,NELROW,FROMWC,FROMWM,WANDES, 8 IBELOWINDEX,NTREAD,TITLE,HMAX,HMIN) IF (ALDONE) GO TO 10000 IF (STATES.AND.RETRO) THEN CALL GETSCA (IMPUT,XNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,XSTT) CALL GETSCA (IMPUT,YNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,YSTT) DO 6789 I=1,NXYST IF (STLINK(1,I).LT.1.0) THEN XSTT(I)=XST(I) YSTT(I)=YST(I) ENDIF 6789 CONTINUE ENDIF CALL REPORT (ITIME,XIPC,XIPM,YIPC,YIPM, 2 XNODC,XNODM,YNODC,YNODM,TITLE,VM,NODES, 3 OUTSCA,OUTVEC,VC,ERATEM,ERATEC, 4 THIKM,THIKC,GEOTHA,GEOTHC,CONDUC, 5 GEOTHM,DNLINK,VPMEAN,DVPBYE,DVPDT, 6 TIME ,NUMNOD,NUMEL, 7 G,HMAX,HMIN,RHOAST,RHOH2O,SIGHC,SIGHBM,SIGZZC, 8 SIGZZM,TAUMTC,TAUMTM,TAUZZC,TAUZZM, 9 TEMLIM,ONEKM,ESUMC,ESUMM,AREAC,AREAM, A CONDNS,DETJC,DETJM,FAILUR, 1 NDIFF,WC,WM, 2 SZZBC,SZZBM,TOUCHC,TOUCHM, 3 ECLOG,SLABSZ, 4 VSLABC,VSLABM,OUTV2,RAMP, 5 THNKC,UPLINK,TASTH,TSLAB0, 6 DOPLOT,SCALEC,NCONTR, 7 STATES,RMSVEC,NELCOL,PHINOD,DRAWST, 8 NXYST,XSTT,YSTT,NELROW,THNKM,FBLAND,LOWBLU, 9 CINT,FROMWC,FROMWM,IBELOWINDEX,WANDES, A CONINT,CONNOD, B TSURF,PUSHUP,IPENCT,IPENST,IPENLB) 9999 CONTINUE 10000 CONTINUE ENDIF C WRITE(6,10001) 10001 FORMAT(/' ===========================================' + /' GRAPHICS JOB COMPLETED. See new .AI files.' + /' ===========================================') STOP ' ' CONTAINS C----------------------------------------------------------- C C C SUBROUTINE READIN(TITLE ,FRIC ,ACREEP,ECREEP,BCREEP, + CCREEP,DCREEP,CONDUC,DIFFUS, + RADIO ,THICKN,TEMLIM,RHOBAR, + ALPHAT,VPMEAN,DVPDT ,DVPBYE, + RHOAST,RHOH2O,BIOT ,G , + IBELOWINDEX,NTYPE, + TSLAB0,SIGBOT,PUSHHO,ECLOG , + SLABSZ,PUSHUP,NELROW,NELCOL, + BEGAGE,DELTAT,ENDAGE,DXMAX ,DTHMAX, + RAMP ,NDIFUS,MAXITR,OKTOQT, + VISMAX,ETAMAX,HMIN ,HMAX , + ALLREP,MIDREP,TAPE9 ,RESTRT, + KTAPE ,CONRAD,DQDTDA,TSURF , + APLANO,WANDES,VDECOL,OLDGRD, + GWIDE ,GHIGH ,GANGLE, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,SCALEC,NCONTR, $ STATES,RETRO,RMSVEC, $ IPENCT,IPENST,IPENLB) C C READS STRATEGIC AND TACTICAL INPUT PARAMETERS FROM DEVICE 5, C AND ECHOES THEM ON DEVICE 6 WITH ANNOTATIONS. C CHARACTER*80 TITLE INTEGER IBELOWINDEX INTEGER :: IUNITP = 1 LOGICAL ALLREP,DOPLOT,OLDGRD, + RESTRT,RETRO,STATES,TAPE9 DIMENSION ACREEP(3),ALPHAT(2),BCREEP(3),CCREEP(3),CONDUC(2), + CINT(NTYPE),DCREEP(3),DIFFUS(2),DOPLOT(NTYPE), + DVPBYE(2,2),DVPDT(2),ECREEP(3),FBLAND(NTYPE),FRIC(2), + HMAX(2),HMIN(2),LOWBLU(NTYPE),RADIO(2), + RHOBAR(2),TEMLIM(2),THICKN(2),VPMEAN(2) 1 FORMAT(A80) WRITE(6,5) IUNITP 5 FORMAT (/' Attempting to read physical and plot-control', + ' PARAMETERS from unit ',I3) WRITE(6,10) 10 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).'/ + ' **************************************************') READ(IUNITP,*) WRITE(6,11) 11 FORMAT(/ / /' ========== STRATEGIC PARAMETERS (DEFINE THE REAL-', + 'EARTH PROBLEM) ======') TITLE=' '// + ' ' READ(IUNITP,1,IOSTAT=IOS) TITLE WRITE(6,101) TITLE 101 FORMAT(/ / /' ',A80/ + ' CRUST MANTLE \ PARAMETER (LINE ABOVE IS TITLE)') READ(IUNITP,*) READ(IUNITP,*) FRIC(1),FRIC(2) WRITE(6,102) FRIC(1),FRIC(2) 102 FORMAT(' ',2F10.3,' COEFFICIENT OF FRICTION') READ(IUNITP,*) ACREEP(1),ACREEP(3) WRITE(6,103) ACREEP(1),ACREEP(3) 103 FORMAT(' ',1P,2E10.2,' PRE-EXPONENTIAL SHEAR STRESS CONSTANT', + ' FOR CREEP') READ(IUNITP,*) ACREEP(2) WRITE(6,104) ACREEP(2) 104 FORMAT(' ',1P,E10.2,' N/A PRE-EXPONENTIAL FOR LOWER', + ' CRUST, BELOW CONRAD') READ(IUNITP,*) ECREEP(1),ECREEP(3) WRITE(6,105) ECREEP(1),ECREEP(3) 105 FORMAT(' ',2F10.6,' STRAIN-RATE EXPONENT FOR CREEP (1/N)') READ(IUNITP,*) ECREEP(2) IF (ECREEP(2).NE.ECREEP(1)) THEN ECREEP(2)=ECREEP(1) WRITE(6,1059) 1059 FORMAT(' ',' WARNING! ALGEBRA IN -PWAZUL- REQUIRES A', + ' UNIFORM CREEP EXPONENT IN CRUST.' + /' YOUR INPUT VALUE FOR THE LOWER CRUST HAS ', + ' BEEN CHANGED TO MAKE THIS TRUE.') ENDIF WRITE(6,106) ECREEP(2) 106 FORMAT(' ',F10.6,' N/A STRAIN-RATE EXPONENT FOR ', + 'LOWER CRUST, BELOW CONRAD') READ(IUNITP,*) BCREEP(1),BCREEP(3) WRITE(6,107) BCREEP(1),BCREEP(3) 107 FORMAT(' ',2F10.0,' B FOR CREEP =(ACTIVATION ENERGY)/R/N (IN K)') READ(IUNITP,*) BCREEP(2) WRITE(6,108) BCREEP(2) 108 FORMAT(' ',F10.0,' N/A B FOR CREEP OF LOWER CRUST,', + ' BELOW CONRAD') READ(IUNITP,*) CCREEP(1),CCREEP(3) WRITE(6,109) CCREEP(1),CCREEP(3) 109 FORMAT(' ',1P,2E10.2,' C FOR CREEP = DERIVATIVE OF B WITH', + ' RESPECT TO DEPTH') READ(IUNITP,*) CCREEP(2) WRITE(6,110) CCREEP(2) 110 FORMAT(' ',1P,E10.2,' N/A C FOR CREEP OF LOWER CRUST,', + ' BELOW CONRAD') READ(IUNITP,*) DCREEP(1),DCREEP(3) WRITE(6,111) DCREEP(1),DCREEP(3) 111 FORMAT(' ',1P,2E10.2,' MAXIMUM SHEAR STRESS UNDER ANY', + ' CONDITIONS') READ(IUNITP,*) DCREEP(2) WRITE(6,112) DCREEP(2) 112 FORMAT(' ',1P,E10.2,' N/A MAXIMUM SHEAR FOR LOWER CRUST,', + ' BELOW CONRAD') READ(IUNITP,*) CONDUC(1),CONDUC(2) WRITE(6,113) CONDUC(1),CONDUC(2) 113 FORMAT(' ',1P,2E10.2,' THERMAL CONDUCTIVITY (ENERGY/', + 'LENGTH/SEC/DEG)') READ(IUNITP,*) DIFFUS(1),DIFFUS(2) WRITE(6,114) DIFFUS(1),DIFFUS(2) 114 FORMAT(' ',1P,2E10.2,' THERMAL DIFFUSIVITY (LENGTH**2/', + 'SEC)') READ(IUNITP,*) RADIO(1),RADIO(2) WRITE(6,115) RADIO(1),RADIO(2) 115 FORMAT(' ',1P,2E10.2,' RADIOACTIVE HEAT PRODUCTION', + ' (ENERGY/VOLUME/SEC)') READ(IUNITP,*) THICKN(1),THICKN(2) WRITE(6,116) THICKN(1),THICKN(2) 116 FORMAT(' ',1P,2E10.2,' THICKNESS OF LAYER IN NORMAL', + ' CONTINENT') READ(IUNITP,*) TEMLIM(1),TEMLIM(2) WRITE(6,117) TEMLIM(1),TEMLIM(2) 117 FORMAT(' ',2F10.0,' CONVECTING TEMPERATURE (TMAX) IN', + ' DEGREES KELVIN') READ(IUNITP,*)(RHOBAR(I),I=1,2) WRITE(6,118) RHOBAR(1),RHOBAR(2) 118 FORMAT(' ',1P,2E10.2,' DENSITY,', + ' CORRECTED TO 0 DEGREES KELVIN') READ(IUNITP,*) ALPHAT(1),ALPHAT(2) WRITE(6,119) ALPHAT(1),ALPHAT(2) 119 FORMAT(' ',1P,2E10.2,' VOLUMETRIC THERMAL EXPANSION', + ' (1/VOL)*(D.VOL/D.T)') READ(IUNITP,*) VPMEAN(1),VPMEAN(2) WRITE(6,120) VPMEAN(1),VPMEAN(2) 120 FORMAT(' ',1P,2E10.2,' MEAN P-WAVE VELOCITY (VP) AT 0 K', + ' AND HIGH PRESSURE') READ(IUNITP,*) DVPDT(1),DVPDT(2) WRITE(6,121) DVPDT(1),DVPDT(2) 121 FORMAT(' ',1P,2E10.2,' (1/VP)*(D.VP/D.T): TEMPERATURE', + ' SENSITIVITY OF VP') READ(IUNITP,*) DVPBYE(1,1),DVPBYE(1,2) WRITE(6,122) DVPBYE(1,1),DVPBYE(1,2) 122 FORMAT(' ',1P,2E10.2,' (DELTA.VP/VP): STRAIN(EZZ)-INDU', + 'CED ANISOTROPY IN VP') READ(IUNITP,*) DVPBYE(2,1),DVPBYE(2,2) WRITE(6,123) DVPBYE(2,1),DVPBYE(2,2) 123 FORMAT(' ',1P,2E10.2,' CHARACTERISTIC STRAIN TO DEVELOP A', + 'NISOTROPY') READ(IUNITP,*) RHOAST WRITE(6,124) RHOAST 124 FORMAT(' ',1P,E10.3,' DENSITY OF ASTHENOSPHERE', + ' (ADJUST TO CORRECT ALL ELEVATION)') READ(IUNITP,*) RHOH2O WRITE(6,125) RHOH2O 125 FORMAT(' ',1P,E10.2,' DENSITY OF GROUNDWATER, LAKES, AND OCEANS') READ(IUNITP,*) BIOT WRITE(6,126) BIOT 126 FORMAT(' ',F10.4,' EFFECTIVE-PRESSURE (BIOT) COEFFICIENT,', + ' 0.0 TO 1.0') BIOT=MAX(0.0,MIN(1.0,BIOT)) READ(IUNITP,*) G WRITE(6,127) G 127 FORMAT(' ',1P,E10.2,' GRAVITATIONAL ACCELERATION', + ' (LENGTH/SEC/SEC)') READ(IUNITP,*) RADIUS WRITE(6,128) RADIUS 128 FORMAT(' ',1P,E10.2,' RADIUS OF EARTH', + ' (EFFECTIVELY DEFINES YOUR LENGTH UNIT)') READ(IUNITP,*) X0ELON WRITE(6,129) X0ELON 129 FORMAT(' ',F10.2,' LONGITUDE OF X/Y ORIGIN IN DEGREES', + ' (EAST = +, WEST = -)') READ(IUNITP,*) Y0NLAT WRITE(6,130) Y0NLAT 130 FORMAT(' ',F10.2,' LATITUDE OF X/Y ORIGIN IN DEGREES', + ' (NORTH = +, SOUTH = -)') READ(IUNITP,*) CPNLAT WRITE(6,131) CPNLAT 131 FORMAT(' ',F10.2,' LATITUDE OF BASE-MAP CONIC PROJECTION', + ' TANGENT IN DEGREES (NORTH = +)') IF (ABS(CPNLAT).LT.0.01) CPNLAT=0.01 READ(IUNITP,*) IBELOWINDEX WRITE(6,132) IBELOWINDEX 132 FORMAT(' ',I10,' BELOW-INDEX: SELECTS PLATE MODEL USED', + ' FOR BASAL BOUNDARY'/ + ' CONDITIONS: 0=NONE,1=N.AMER./NORTH,', + '2=N.AMER./SOUTH,3=S.AMER.,4=ASIA') READ(IUNITP,*) READ(IUNITP,*) TSURF WRITE(6,305) TSURF 305 FORMAT(' ',F10.0,' SURFACE TEMPERATURE IN DEGREES KELVIN') READ(IUNITP,*) TSLAB0 WRITE(6,133) TSLAB0 133 FORMAT(' ',1P,E10.2,' TEMPERATURE OF SLAB-TOP SHEAR ZONE', + ' AT 1000 KM INLAND, IN KELVIN') READ(IUNITP,*) SIGBOT WRITE(6,134) SIGBOT 134 FORMAT(' ',1P,E10.2,' SHEAR STRESS LIMIT ON BASE OF', + ' CONTINENT (MELANGE STRENGTH)') READ(IUNITP,*) WANDES WRITE(6,307) WANDES 307 FORMAT(' ',1P,E10.2,' INITIAL WIDTH OF CORDILLERA,', + ' MEASURED TRENCH-TO-PLAINS', + ' (OR 0.0 FOR NONE)') READ(IUNITP,*) PUSHHO WRITE(6,135) PUSHHO 135 FORMAT(' ',1P,E10.2,' EXTRA SHEAR STRESS APPLIED TO', + ' "LEFT" MARGIN FOREARC ONLY') READ(IUNITP,*) ECLOG WRITE(6,136) ECLOG 136 FORMAT(' ',1P,E10.2,' EXCESS-WEIGHT/UNIT-AREA OF NEW LITHOSPHER', + 'E WITH RESPECT TO ASTHENOSPHERE') READ(IUNITP,*) SLABSZ WRITE(6,137) SLABSZ 137 FORMAT(' ',1P,E10.2,' THERMAL EXCESS-WEIGHT/UNIT-AREA', + ' AT 100 MA WITH REPECT TO NEW LITHOSPHERE') READ(IUNITP,*) PUSHUP WRITE(6,138) PUSHUP 138 FORMAT(' ',1P,E10.2,' NON-ISOSTATIC FLEXURAL UPLIFT BY SLAB,', + ' (IN THE FOREARC REGION ONLY)') READ(IUNITP,*) WRITE(6,12) 12 FORMAT(/ / /' ============== TACTICAL PARAMETERS', + ' (HOW TO FIND THE SOLUTION) ============') READ(IUNITP,*) NELROW WRITE(6,201) NELROW 201 FORMAT(/ / /' ',I10,' NUMBER OF ROWS OF 2-ELEMENT', + ' QUADRILATERALS (ROWS ARE PERPENDICULAR TO TRENCH)') READ(IUNITP,*) NELCOL WRITE(6,202) NELCOL 202 FORMAT(' ',I10,' NUMBER OF COLUMNS OF 2-ELEMENT', + ' QUADRILATERALS (COLUMNS ARE PARALLEL TO TRENCH)') READ(IUNITP,*) BEGAGE WRITE(6,203) BEGAGE 203 FORMAT(' ',1P,E10.4,' BEGINNING OF CALCULATION', + ' (POSITIVE SECONDS BEFORE PRESENT)') READ(IUNITP,*) DELTAT WRITE(6,204) DELTAT 204 FORMAT(' ',1P,E10.4,' SIZE OF TIME STEPS (POSITIVE', + ' SECONDS); MAY BE REDUCED BY PROGRAM') READ(IUNITP,*) ENDAGE WRITE(6,205) ENDAGE 205 FORMAT(' ',1P,E10.4,' ENDING OF CALCULATION', + ' (POSITIVE SECONDS BEFORE PRESENT)') READ(IUNITP,*) DXMAX WRITE(6,206) DXMAX 206 FORMAT(' ',1P,E10.2,' MAXIMUM HORIZONTAL DISPLACEMENT OF ANY' + ,' NODE IN ONE TIME STEP') READ(IUNITP,*) DTHMAX WRITE(6,207) DTHMAX 207 FORMAT(' ',1P,E10.2,' MAXIMUM CHANGE IN LAYER THICKNESS BY PURE' + ,' SHEAR ALLOWED IN ONE TIME STEP') READ(IUNITP,*) RAMP WRITE(6,208) RAMP 208 FORMAT(' ',1P,E10.2,' WIDTH OF LINEAR RAMP SMOOTHING OF SLAB', + ' WEIGHT') READ(IUNITP,*) NDIFUS WRITE(6,209) NDIFUS 209 FORMAT(' ',I10,' MAXIMUM NUMBER OF CRUSTAL-THICKNESS', + ' SMOOTHINGS EACH TIMESTEP (ABOUT 1000)') READ(IUNITP,*) MAXITR WRITE(6,210) MAXITR 210 FORMAT(' ',I10,' MAXIMUM ITERATIONS WITHIN VELOCITY SOLUTION', + ' IN EACH TIMESTEP') READ(IUNITP,*) OKTOQT WRITE(6,211) OKTOQT 211 FORMAT(' ',F10.6,' ACCEPTABLE RMS FRACTIONAL ERR0R (STOPS', + ' ITERATION EARLY)') READ(IUNITP,*) VISMAX WRITE(6,212) VISMAX 212 FORMAT(' ',1P,E10.2,' MAXIMUM AVERAGE VISCOSITY ALLOWED FOR ANY', + ' LAYER (APPLIES TO WHOLE THICKNESS, NOT LOCALLY)') READ(IUNITP,*) ETAMAX WRITE(6,213) ETAMAX 213 FORMAT(' ',1P,E10.2,' MAXIMUM LAYER/LAYER COUPLING ALLOWED', + ' (STRESS/VELOCITY-DIFFERENCE)') READ(IUNITP,*) READ(IUNITP,*) HMIN(1),HMIN(2) WRITE(6,214) HMIN(1),HMIN(2) 214 FORMAT(/' CRUST MANTLE\ LIMITS ON LAYER THICKNESSES:'/ + ' ',1P,2E10.2,' MINIMUM THICKNESS', + ' (TRIGGERS VOLUME ADDITION)') READ(IUNITP,*) HMAX(1),HMAX(2) WRITE(6,215) HMAX(1),HMAX(2) 215 FORMAT(' ',1P,2E10.2,' MAXIMUM THICKNESS', + ' (TRIGGERS VOLUME REDUCTION)') READ(IUNITP,*) ALLREP WRITE(6,216) ALLREP 216 FORMAT(' ',L10,' ALLREP: SHOULD REPORTS BE PRODUCED', + ' AT EVERY TIMESTEP ? (USE ONLY FOR DEBUGGING)') READ(IUNITP,*) MIDREP WRITE(6,217) MIDREP 217 FORMAT(' ',I10,' NUMBER OF INTERMEDIATE REPORTS (WHEN ALLREP=F)') READ(IUNITP,*) TAPE9 WRITE(6,218) TAPE9 218 FORMAT(' ',L10,' THAT DETAILED REPORTS ARE OUTPUT ON DEVICE 9', + ' (USUALLY T)') READ(IUNITP,*) WRITE(6,13) 13 FORMAT(/ / /' ================== INITIALIZATION PARAMETERS', + ' (INITIAL CONDITIONS) ========') READ(IUNITP,*) RESTRT WRITE(6,301) RESTRT 301 FORMAT(/ / /' ',L10,' RESTART: IF = T, THEN RESTART FROM OLD', + ' REPORT; READ FROM DEVICE 8') READ(IUNITP,*) KTAPE WRITE(6,302) KTAPE 302 FORMAT(' ',I10,' IF (RESTART): ORDINAL NUMBER OF OLD REPORT', + ' IN DEVICE 8 FILE') READ(IUNITP,*) WRITE(6,14) 14 FORMAT(' ------- NEXT LINES ARE USED ONLY IF RESTRT = F', + '--------------------------') READ(IUNITP,*) CONRAD WRITE(6,303) CONRAD 303 FORMAT(' ',1P,E10.2,' INITIAL DEPTH OF CONRAD DISCONTINUITY', + ' IN THE CRUST OF THE PLAINS') READ(IUNITP,*) DQDTDA WRITE(6,304) DQDTDA 304 FORMAT(' ',1P,E10.2,' INITIAL HEAT-FLOW OF PLAINS', + ' (ENERGY/LENGTH**2/SEC)') READ(IUNITP,*) APLANO WRITE(6,306) APLANO 306 FORMAT(' ',1P,E10.2,' INITIAL HEIGHT OF ALTIPLANO IN CORDILLERA', + ' (OR 0.0 FOR NONE)') IF ((APLANO.LE.0.0).AND.(.NOT.RESTRT)) WANDES=0.0 READ(IUNITP,*) VDECOL WRITE(6,308) VDECOL 308 FORMAT(' ',1P,E10.2,' GROSS ESTIMATE OF DETACHMENT', + ' VELOCITY BETWEEN CRUST AND MANTLE') READ(IUNITP,*) OLDGRD IF (RESTRT) OLDGRD=.FALSE. WRITE(6,309) OLDGRD 309 FORMAT(' ',L10,' OLDGRD : SHALL EXISTING GRID OF NODES', + ' BE READ(FROM DEVICE 8, IN TRUNCATED REPORT FORMAT)?') READ(IUNITP,*) READ(IUNITP,*) WRITE(6,15) 15 FORMAT(' -------- FOLLOWING LINES DEFINE AN AUTOMATICALLY-', + 'GENERATED GRID, AND -----'/ + ' ----------- ARE USED ONLY IF RESTRT = F AND ', + 'OLDGRD = F -----------------') READ(IUNITP,*) GWIDE WRITE(6,310) GWIDE 310 FORMAT(' ',1P,E10.3,' "WIDTH" OF GRID FROM "LEFT"', + ' (TRENCH SIDE) TO "RIGHT" (INLAND SIDE)') READ(IUNITP,*) GHIGH WRITE(6,311) GHIGH 311 FORMAT(' ',1P,E10.3,' "HEIGHT" OF GRID FROM "TOP"', + ' (NODE ROW 1) TO "BOTTOM" (LAST ROW)') READ(IUNITP,*) GANGLE WRITE(6,312) GANGLE 312 FORMAT(' ',F10.2,' ANGLE GRID IS ROTATED FROM', + ' ("RIGHT"= +X, "TOP" = +Y), IN DEGREES COUNTERCLOCKWISE') READ(IUNITP,*,END=3129) 3129 WRITE(6,16) 16 FORMAT(/ / /' ===== POST-PROCESSING PLOT CONTROL PARAMETERS', + ' (NOT USED BY LARAMY) =====') READ(IUNITP,*) KTIME WRITE(6,401) KTIME 401 FORMAT(/ / / + ' ',I10,' ORDINAL NUMBER OF REPORT ON UNIT8 TO BE PLOTTED' + ,','/11X,' OR 999 TO PLOT LAST REPORT IN THE DATASET' + ,','/11X,' OR 0 TO PLOT ALL REPORTS IN THE DATASET') DO 4022 I=1,24 READ(IUNITP,4021) DOPLOT(I),CINT(I),FBLAND(I),LOWBLU(I) 4021 FORMAT(L10,2E10.2,I2) 4022 CONTINUE WRITE(6,402) DOPLOT( 1),CINT( 1),FBLAND(1),LOWBLU(1) WRITE(6,403) DOPLOT( 2),CINT( 2),FBLAND(2),LOWBLU(2) WRITE(6,404) DOPLOT( 3),CINT( 3),FBLAND(3),LOWBLU(3) WRITE(6,405) DOPLOT( 4),CINT( 4),FBLAND(4),LOWBLU(4) WRITE(6,406) DOPLOT( 5),CINT( 5),FBLAND(5),LOWBLU(5) WRITE(6,407) DOPLOT( 6),CINT( 6),FBLAND(6),LOWBLU(6) WRITE(6,408) DOPLOT( 7),CINT( 7),FBLAND(7),LOWBLU(7) WRITE(6,409) DOPLOT( 8),CINT( 8),FBLAND(8),LOWBLU(8) WRITE(6,410) DOPLOT( 9),CINT( 9),FBLAND(9),LOWBLU(9) WRITE(6,411) DOPLOT(10),CINT(10),FBLAND(10),LOWBLU(10) WRITE(6,412) DOPLOT(11),CINT(11),FBLAND(11),LOWBLU(11) WRITE(6,413) DOPLOT(12),CINT(12),FBLAND(12),LOWBLU(12) WRITE(6,414) DOPLOT(13),CINT(13),FBLAND(13),LOWBLU(13) WRITE(6,415) DOPLOT(14),CINT(14),FBLAND(14),LOWBLU(14) WRITE(6,416) DOPLOT(15),CINT(15),FBLAND(15),LOWBLU(15) WRITE(6,417) DOPLOT(16),CINT(16),FBLAND(16),LOWBLU(16) WRITE(6,418) DOPLOT(17),CINT(17),FBLAND(17),LOWBLU(17) WRITE(6,419) DOPLOT(18),CINT(18),FBLAND(18),LOWBLU(18) WRITE(6,420) DOPLOT(19),CINT(19),FBLAND(19),LOWBLU(19) WRITE(6,421) DOPLOT(20),CINT(20),FBLAND(20),LOWBLU(20) WRITE(6,422) DOPLOT(21),CINT(21),FBLAND(21),LOWBLU(21) WRITE(6,423) DOPLOT(22),CINT(22),FBLAND(22),LOWBLU(22) WRITE(6,424) DOPLOT(23),CINT(23),FBLAND(23),LOWBLU(23) WRITE(6,425) DOPLOT(24),CINT(24),FBLAND(24),LOWBLU(24) 402 FORMAT(L11,1P,2E10.2,I2,' MANTLE BASAL SHEAR STRESS') 403 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL BASAL SHEAR STRESS') 404 FORMAT(L11,1P,2E10.2,I2,' MANTLE VELOCITY VECTORS') 405 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL VELOCITY VECTORS') 406 FORMAT(L11,1P,2E10.2,I2,' MANTLEGREATEST PRINCIPAL STRAIN RATES') 407 FORMAT(L11,1P,2E10.2,I2,' CRUST GREATEST PRINCIPAL STRAIN RATES') 408 FORMAT(L11,1P,2E10.2,I2,' MANTLE PRINCIPAL STRESS ANOMALY' + , ' INTEGRALS') 409 FORMAT(L11,1P,2E10.2,I2,' CRUST PRINCIPAL STRESS ANOMALY' + ,' INTEGRALS') 410 FORMAT(L11,1P,2E10.2,I2,' MANTLE GRID OF ELEMENTS') 411 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL GRID OF ELEMENTS') 412 FORMAT(L11,1P,2E10.2,I2,' MANTLE RATE OF THICKENING') 413 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL RATE OF THICKENING') 414 FORMAT(L11,1P,2E10.2,I2,' MANTLE THICKNESS') 415 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL THICKNESS') 416 FORMAT(L11,1P,2E10.2,I2,' MANTLE BASAL TEMPERATURE') 417 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL BASAL TEMPERATURE') 418 FORMAT(L11,1P,2E10.2,I2,' TELESEISMIC P TRAVEL-TIME RESIDUAL') 419 FORMAT(L11,1P,2E10.2,I2,' ISOSTATIC ELEVATIONS') 420 FORMAT(L11,1P,2E10.2,I2,' PALEO-HEAT-FLOW') 421 FORMAT(L11,1P,2E10.2,I2,' ELEVATIONS AFTER DELAMINATION') 422 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL GREATEST PRINCIPAL STRAIN') 423 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL ROTATION') 424 FORMAT(L11,1P,2E10.2,I2,' UPPER CRUSTAL THICKNESS') 425 FORMAT(L11,1P,2E10.2,I2,' LOWER CRUSTAL THICKNESS') READ(IUNITP,*) SCALEC C ****************************************************** C NEW AI PLOTTING SUBR'S EXPECT INPUT IN METERS, NOT CM. SDENOM=SCALEC*100. C ****************************************************** WRITE(6,426)SCALEC 426 FORMAT(' ',1PE10.2,' SCALE OF PLOTS,', + ' (INPUT LENGTH UNITS)/(CM OF PLOT)') READ(IUNITP,*) NCONTR NCONTR=MAX(NCONTR,1) WRITE(6,427)NCONTR 427 FORMAT(' ',I10,' APPROXIMATE NUMBER OF CONTOURS IN PLOTS', + ' WHEN CINT=0 (AUTO-SCALED)') READ(IUNITP,*) STATES,RETRO WRITE(6,428)STATES,RETRO 428 FORMAT('0',L10,' THAT STATE OUTLINES ARE SUPERPOSED', + ' AND ',L1,' THAT THEY ARE RETRO-DEFORMED') READ(IUNITP,*) IPENCT IPENCT=MIN(IPENCT,31) IPENCT=MAX(IPENCT,1) WRITE(6,429)IPENCT 429 FORMAT(' ',I10,' PEN WEIGHT FOR CONTOURS OR ELEMENT SIDES') READ(IUNITP,*) IPENST IPENST=MIN(IPENST,31) IPENST=MAX(IPENST,1) WRITE(6,430)IPENST 430 FORMAT(' ',I10,' PEN WEIGHT FOR STATE LINES, IF ANY') READ(IUNITP,*) IPENLB IPENLB=MIN(IPENLB,31) IPENLB=MAX(IPENLB,1) WRITE(6,431)IPENLB 431 FORMAT(' ',I10,' PEN WEIGHT FOR TEXT LABELS, AND (IF .GT.1)', + ' NODES') READ(IUNITP,*) RMSVEC WRITE(6,432)RMSVEC 432 FORMAT(' ',F10.3,' RMS LENGTH OF PLOTTED VECTORS', + ' (AND TENSOR PRINCIPAL AXES), IN INCHES') READ(IUNITP,*) COLOR WRITE(6,433) COLOR 433 FORMAT(' ',L10,' THAT OUTPUT WILL BE IN COLOR (ELSE B & W)') READ(IUNITP,*) XCENTR, YCENTR WRITE (6,1427) XCENTR, YCENTR 1427 FORMAT(' (',1P,E9.2,',',E9.2,')=(X,Y) OF PLOT CENTER, IF CLIPPIN' + ,'G IS NEEDED.') WRITE(6,17) 17 FORMAT(/ / /' ==========================================', + '=================================') RETURN END SUBROUTINE READIN C C C SUBROUTINE GRIDDR(INPUT, NELROW,NELCOL,NUMEL, + MODIFY,NODES) C C CREATES TOPOLOGY OF FINITE ELEMENT GRIDS FOR CRUST AND MANTLE C DIMENSION NODES(6,0:NUMEL) C C NOTE:NUMEL=2*NELROW*NELCOL NROWN=2*NELROW+1 NCOLN=2*NELCOL+1 C NOTE:NUMNOD=NROWN*NCOLN DO 30 I=1,NELROW DO 20 J=1,NELCOL K1=2*NELCOL*(I-1)+2*(J-1)+1 NODES(1,K1)=2*NCOLN*(I-1)+2*(J-1)+1 NODES(2,K1)=NODES(1,K1)+2*NCOLN NODES(3,K1)=NODES(1,K1)+2 NODES(4,K1)=NODES(1,K1)+NCOLN NODES(5,K1)=NODES(4,K1)+1 NODES(6,K1)=NODES(1,K1)+1 K2=K1+1 NODES(1,K2)=NODES(2,K1)+2 NODES(2,K2)=NODES(3,K1) NODES(3,K2)=NODES(2,K1) NODES(4,K2)=NODES(5,K1)+1 NODES(5,K2)=NODES(5,K1) NODES(6,K2)=NODES(2,K1)+1 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE GRIDDR C C C SUBROUTINE PAST(ACREEP,ALPHAC,ALPHAM,ALPHAT,AREAC,AREAM,BCREEP, 2 BIOT,CCREEP,CONDNS,CONINT,CONNOD,CONRAD, 3 DCREEP,DELVC,DELVM,DETJC,DETJM, 4 DNLINK,DVB,DVT,DXSC,DXSM,DYSC,DYSM,ECLOG,ECREEP, 5 ERATEC,ERATEM,ESUMC,ESUMM,ETAMAX,FLUXC, 6 FLUXM,FRIC,G,GEOTHA,GEOTHC,GEOTHM,GLUEC,GLUEM, 7 KTIME,ILAYER,LISTOP,NDIFF,NELCOL, 8 NODES,NUMEL,NUMNOD,ONEKM,OUTSCA,OUTVEC, 9 OUTV2,OVA,OVB,PTSC,PTSM,PUSHHO,PUSHUP, A RAMP,RHOAST,RHOH2O,RHOBAR,SIGBOT,SIGHC, 1 SIGHBM,SIGHTM,SIGZZC,SIGZZM,SLABSZ,SZZBC,SZZBM, 2 TASTH,TAUMTC,TAUMTM,TAUZZC,TAUZZM,TEMLIM, 3 THIKC,THIKM,TIME,THNKC,THNKM,TOFSTC,TOFSTM, 4 TOUCHC,TOUCHM,TSLAB0,TSURF,UPLINK,VC,VM,VISMAX, 5 VSLABC,VSLABM,WC,WM,XIPC,XIPM, 6 XNODC,XNODM,YIPC,YIPM,YNODC,YNODM, 7 ALDONE,NELROW,FROMWC,FROMWM,WANDES, 8 IBELOWINDEX,NTREAD,TITLE,HMAX,HMIN) C C RE-ESTABLISHES ALL IN-PROGRESS ARRAYS FROM REPORT ON "TAPE" C PREVIOUSLY WRITTEN BY SUBROUTINE "TAPE". C CHARACTER*80 TITLE LOGICAL ALDONE,CRUST,FAILUR,LISTOP,LOCKIN,LOCKWC,MANTLE DIMENSION ACREEP(3),ALPHAC(3,3,7,NUMEL),ALPHAM(3,3,7,NUMEL), 2 ALPHAT(2),AREAC(NUMEL),AREAM(NUMEL),BCREEP(3), 3 CCREEP(3),CONDNS(NUMNOD), 4 CONINT(7,NUMEL),CONNOD(NUMNOD),DCREEP(3), 5 DELVC(2,7,NUMEL),DELVM(2,7,NUMEL),DETJC(7,NUMEL), 6 DETJM(7,NUMEL),DNLINK(3,7,NUMEL),DVB(7,NUMEL), 7 DVT(7,NUMEL),DXSC(6,7,NUMEL),DXSM(6,7,NUMEL), 8 DYSC(6,7,NUMEL),DYSM(6,7,NUMEL),ECREEP(3), 9 ERATEC(4,7,NUMEL),ERATEM(4,7,NUMEL), A ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL), 1 FLUXC(7,NUMEL),FLUXM(7,NUMEL),FRIC(2), 2 FROMWC(7,NUMEL),FROMWM(7,NUMEL),GEOTHA(4,7,NUMEL), 3 GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL),GLUEC(7,NUMEL), 4 GLUEM(7,NUMEL),HMAX(2),HMIN(2), 5 ILAYER(NUMEL),LISTOP(NUMEL), 6 NODES(6,0:NUMEL),OUTSCA(7,NUMEL),OUTVEC(2,7,NUMEL), 7 OUTV2(2,7,NUMEL),OVA(2,7,NUMEL),OVB(2,7,NUMEL), 8 PTSC(2,7,NUMEL),PTSM(2,7,NUMEL),RHOBAR(2), 9 SIGHC(2,7,NUMEL),SIGHBM(2,7,NUMEL),SIGHTM(2,7,NUMEL), B SIGZZC(7,NUMEL),SIGZZM(7,NUMEL),SZZBC(7,NUMEL) DIMENSION SZZBM(7,NUMEL),TAUMTC(3,7,NUMEL),TAUMTM(3,7,NUMEL), 2 TAUZZC(7,NUMEL),TAUZZM(7,NUMEL),TEMLIM(2), 3 THIKC(7,NUMEL),THIKM(7,NUMEL),THNKC(NUMNOD), 4 THNKM(NUMNOD),TOFSTC(3,7,NUMEL),TOFSTM(3,7,NUMEL), 5 TOUCHC(7,NUMEL),TOUCHM(7,NUMEL),UPLINK(3,7,NUMEL), 6 VC(2,NUMNOD),VM(2,NUMNOD),VSLABC(2,7,NUMEL), 7 VSLABM(2,7,NUMEL),WC(NUMNOD),WM(NUMNOD),XIPC(7,NUMEL), 8 XIPM(7,NUMEL),XNODC(NUMNOD),XNODM(NUMNOD), 9 YIPC(7,NUMEL),YIPM(7,NUMEL),YNODC(NUMNOD), A YNODM(NUMNOD) TEMPM(Z,M,I)=MIN(TEMLIM(2),GEOTHM(1,M,I) + +GEOTHM(2,M,I)*Z + +GEOTHM(3,M,I)*Z**2 + +GEOTHM(4,M,I)*Z**3) CALL GOON (KTIME,NTREAD,TITLE,TIME, + XNODC,XNODM,YNODC,YNODM,THNKC,CONNOD,THNKM, + GEOTHC,GEOTHM,GEOTHA,VC,VM,WC,WM,ESUMC,ESUMM, + NUMNOD,NUMEL,ALDONE) WRITE(6,1) 1 FORMAT(/' Finished reading INTEGRATED ARRAYS dataset.' + /' -------------------------------------------' + /' Now recreating other arrays derived from these', + ' (slow)...') CALL INTERP (XNODC,NODES,NUMEL,NUMNOD,XIPC) CALL INTERP (YNODC,NODES,NUMEL,NUMNOD,YIPC) CALL INTERP (XNODM,NODES,NUMEL,NUMNOD,XIPM) CALL INTERP (YNODM,NODES,NUMEL,NUMNOD,YIPM) CALL INTERP (THNKC,NODES,NUMEL,NUMNOD,THIKC) CALL INTERP (THNKM,NODES,NUMEL,NUMNOD,THIKM) CALL INLAND (INPUT,XIPC,YIPC,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMWC) CALL INLAND (INPUT,XIPM,YIPM,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMWM) DO 10 M=1,7 DO 9 I=1,NUMEL THIKC(M,I)=MAX(THIKC(M,I),HMIN(1)) THIKM(M,I)=MAX(THIKM(M,I),HMIN(2)) THIKC(M,I)=MIN(THIKC(M,I),HMAX(1)) THIKM(M,I)=MIN(THIKM(M,I),HMAX(2)) 9 CONTINUE 10 CONTINUE TASTH=TEMPM(THIKM(5,NUMEL),5,NUMEL) CALL AREAS (NODES,AREAC,XNODC,YNODC,NUMNOD,NUMEL) CALL AREAS (NODES,AREAM,XNODM,YNODM,NUMNOD,NUMEL) CALL DERIV (NUMEL,NUMNOD,NODES,XNODC,YNODC,AREAC, + DETJC,DXSC,DYSC,NUMBAD,LISTOP) CALL DERIV (NUMEL,NUMNOD,NODES,XNODM,YNODM,AREAM, + DETJM,DXSM,DYSM,NUMBAD,LISTOP) LOCKIN=.FALSE. LOCKWC=.FALSE. CALL INTERP (CONNOD,NODES,NUMEL,NUMNOD,CONINT) CALL LINKER (NELCOL,NUMEL,XIPM,YIPM, + DETJC,XIPC,YIPC,XNODC,YNODC, + NUMNOD,NODES,AREAC,UPLINK,FAILUR) CALL LINKER (NELCOL,NUMEL,XIPC,YIPC, + DETJM,XIPM,YIPM,XNODM,YNODM, + NUMNOD,NODES,AREAM,DNLINK,FAILUR) DO 60 K=1,3 DO 59 M=1,7 DO 58 I=1,NUMEL TOFSTC(K,M,I)=0. TOFSTM(K,M,I)=0. ALPHAC(1,K,M,I)=0. ALPHAM(1,K,M,I)=0. ALPHAC(2,K,M,I)=0. ALPHAM(2,K,M,I)=0. ALPHAC(3,K,M,I)=0. ALPHAM(3,K,M,I)=0. 58 CONTINUE 59 CONTINUE 60 CONTINUE CALL EDOT (NUMEL,NODES,VC,NUMNOD,DXSC,DYSC,ERATEC, + ALPHAC,TOFSTC,TAUMTC) CALL EDOT (NUMEL,NODES,VM,NUMNOD,DXSM,DYSM,ERATEM, + ALPHAM,TOFSTM,TAUMTM) CALL BELOW (INPUT,ECLOG,FROMWC,IBELOWINDEX, + NELCOL,NUMEL, + PUSHUP,RAMP,SLABSZ,TIME,WANDES, + XIPC,YIPC, + OUTPUT,SZZBC,TOUCHC,VSLABC) CALL BELOW (INPUT,ECLOG,FROMWM,IBELOWINDEX, + NELCOL,NUMEL, + PUSHUP,RAMP,SLABSZ,TIME,WANDES, + XIPM,YIPM, + OUTPUT,SZZBM,TOUCHM,VSLABM) CALL SETCUB (THIKM,NUMEL,GEOTHM,GEOTHA,OUTSCA,TASTH, + THIKC,GEOTHC,DNLINK,TOUCHC,TOUCHM,TSLAB0, + AREAM,DETJM,CONDNS, + NDIFF,NODES,NUMNOD, + TSURF,FROMWC,FROMWM,ONEKM) CRUST=.TRUE. CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATEC,FRIC,G,GEOTHC, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIKC,THNKC,UPLINK, + OUTPUT,FLUXC,GLUEC, + WORK,ILAYER,OUTSCA,OUTV2) CRUST=.FALSE. CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATEM,FRIC,G,GEOTHM, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIKM,THNKC,UPLINK, + OUTPUT,FLUXM,GLUEM, + WORK,ILAYER,OUTSCA,OUTV2) CALL SQUEZE (G,CONDNS,TOUCHC,TOUCHM,SZZBC,SZZBM, + GEOTHA,GEOTHC,GEOTHM,NUMEL,THIKC,THIKM,TEMLIM, + ALPHAT,RHOBAR,DNLINK,UPLINK,SIGZZC,SIGZZM, + OUTSCA,THNKC,THNKM,DXSC,DXSM,DYSC,DYSM, + TAUZZC,TAUZZM,ONEKM,RHOH2O,RHOAST, + NODES,NUMNOD,PTSC,PTSM, + AREAC,AREAM,DETJC,DETJM,FAILUR, + NDIFF,ECLOG,HMAX,HMIN) CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD,GLUEC, + OUTPUT,CONDNS) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DO 200 M=1,7 DO 100 I=1,NUMEL OUTV2(1,M,I)=OUTSCA(M,I) 100 CONTINUE 200 CONTINUE C C OUTV2(1,M,I) HOLDS GLUEC VALUE AT MANTLE INTEGRATION POINTS M,I C CALL GETSCA (INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) C C OUTSCA HOLDS CRUSTAL THICKNESSES AT MANTLE INTEGRATION POINTS C CALL THONM (NUMEL,NODES,NUMNOD,VM, + SIGHBM,SIGHTM,TOUCHM,VSLABM, + SIGBOT,GLUEM,ECREEP,DELVM,OUTVEC,OUTV2, + ETAMAX,UPLINK,VC,RHOBAR, + G,THIKM,FRIC,VISMAX,DVB,DVT,OVA,OVB, + OUTSCA) CALL THONC (NUMEL,NODES,NUMNOD,VC, + DNLINK,VM,DELVC,GLUEC,ECREEP,SIGHC, + SIGBOT,TOUCHC,VSLABC, + RHOBAR,G,THIKC,FRIC,VISMAX,DVB,OVB, + OUTVEC,ETAMAX,PUSHHO,FROMWC,WANDES) CALL GETSCA (INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) C C OUTSCA HOLDS CRUSTAL THICKNESSES AT MANTLE INTEGRATION POINTS C MANTLE=.FALSE. CALL VISCOS (SCOREC,SCORED,VISMAX,NUMEL,CONINT, + ALPHAC,ERATEC,TAUMTC,TOFSTC,THIKC,GEOTHC, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,RHOBAR,FRIC,TEMLIM, + OUTSCA,SIGHC) MANTLE=.TRUE. CALL VISCOS (SCOREC,SCORED,VISMAX,NUMEL,CONINT, + ALPHAM,ERATEM,TAUMTM,TOFSTM,THIKM,GEOTHM, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,RHOBAR,FRIC,TEMLIM, + OUTSCA,SIGHBM) CALL EDOT (NUMEL,NODES,VC,NUMNOD,DXSC,DYSC,ERATEC, + ALPHAC,TOFSTC,TAUMTC) CALL EDOT (NUMEL,NODES,VM,NUMNOD,DXSM,DYSM,ERATEM, + ALPHAM,TOFSTM,TAUMTM) WRITE(6,99) 99 FORMAT(' PAST finished recreating all arrays.'/ + ' =====================================') RETURN END SUBROUTINE PAST C C C SUBROUTINE GOON (KTIME,NTREAD,TITLE,TIME, + XNODC,XNODM,YNODC,YNODM,THNKC,CONNOD,THNKM, + GEOTHC,GEOTHM,GEOTHA,VC,VM,WC,WM,ESUMC,ESUMM, + NUMNOD,NUMEL,ALDONE) C C READS 'TAPE' WITH THE ARRAYS NEEDED IN ORDER TO C RESTART PROGRAM OR COMPUTE A SET OF PLOTS; C ONLY ESSENTIAL INTEGRATED VARIABLES ARE READ; C PARAMETERS MUST BE RE-INPUT BY "INPUT", AND ALL C RECONSTRUCTABLE ARRAYS MUST BE RECOMPUTED. C CHARACTER*80 TITLE,NEWTITLE LOGICAL ALDONE DIMENSION CONNOD(NUMNOD),ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL), + GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), + THNKC(NUMNOD),THNKM(NUMNOD), + VC(2,NUMNOD),VM(2,NUMNOD), + WC(NUMNOD),WM(NUMNOD), + XNODC(NUMNOD),XNODM(NUMNOD), + YNODC(NUMNOD),YNODM(NUMNOD) C 1001 FORMAT(A80) 1002 FORMAT(1P,8E9.2) 1003 FORMAT(0P,8F9.5) 1004 FORMAT(10X,E10.4) 1005 FORMAT(1P,6E13.6) 1006 FORMAT(1P,8E10.3) 1007 FORMAT(0P,F10.3,1P,3E10.3,0P,F10.3,1P,3E10.3) 2005 FORMAT(' Time = ',1P,E10.4,' (',0P,F7.3,')') 2006 FORMAT('0Following dataset was read for integrated arrays:'/ + '0',A80/'0Last time in following list is the one plotted:' + ) C ALDONE=.FALSE. WRITE (6,50) 50 FORMAT (//' Attempting to read file of INTEGRATED ARRAYS', + ' from unit 8.') TITLE=' '// + ' ' READ (8,1001,IOSTAT=IOS) TITLE IF (IOS.EQ.-1) GO TO 8001 WRITE(6,2006) TITLE DO 2000 ITIME=1,KTIME IF (ITIME.GT.1) THEN NEWTITLE=' '// + ' ' READ (8,1001,IOSTAT=IOS) NEWTITLE IF (IOS.EQ.-1) GO TO 8001 TITLE=NEWTITLE END IF READ (8,1004) TIME TMY=TIME/3.15576E13 WRITE(6,2005) TIME,TMY NTREAD=NTREAD+1 READ (8,1001) READ (8,1005) (XNODC(I),I=1,NUMNOD) READ (8,1001) READ (8,1005) (XNODM(I),I=1,NUMNOD) READ (8,1001) READ (8,1005) (YNODC(I),I=1,NUMNOD) READ (8,1001) READ (8,1005) (YNODM(I),I=1,NUMNOD) READ (8,1001) READ (8,1006) (THNKC(I),I=1,NUMNOD) READ (8,1001) READ (8,1006) (CONNOD(I),I=1,NUMNOD) READ (8,1001) READ (8,1006) (THNKM(I),I=1,NUMNOD) READ (8,1001) READ (8,1007) (((GEOTHC(I,J,K),I=1,4),J=1,7),K=1,NUMEL) READ (8,1001) READ (8,1007) (((GEOTHM(I,J,K),I=1,4),J=1,7),K=1,NUMEL) READ (8,1001) READ (8,1007) (((GEOTHA(I,J,K),I=1,4),J=1,7),K=1,NUMEL) READ (8,1001) READ (8,1005) ((VC(I,J),I=1,2),J=1,NUMNOD) READ (8,1001) READ (8,1005) ((VM(I,J),I=1,2),J=1,NUMNOD) READ (8,1001) READ (8,1002) (WC(I),I=1,NUMNOD) READ (8,1001) READ (8,1002) (WM(I),I=1,NUMNOD) READ (8,1001) READ (8,1003) ((ESUMC(1,1,J,K),ESUMC(1,2,J,K), + ESUMC(2,1,J,K),ESUMC(2,2,J,K),J=1,7), + K=1,NUMEL) READ (8,1001) READ (8,1003,END=9001) ((ESUMM(1,1,J,K),ESUMM(1,2,J,K), + ESUMM(2,1,J,K),ESUMM(2,2,J,K),J=1,7), + K=1,NUMEL) 2000 CONTINUE RETURN C C CODE FOR CASE OF MISSING NEXT REPORT C 8001 ALDONE=.TRUE. RETURN C C CODE FOR CASE OF INCOMPLETE LAST REPORT C 9001 DO 9005 I=1,2 DO 9004 J=1,2 DO 9003 K=1,7 DO 9002 L=1,NUMEL ESUMM(I,J,K,L)=0. 9002 CONTINUE 9003 CONTINUE 9004 CONTINUE 9005 CONTINUE WRITE(6,9006) 9006 FORMAT('0INPUT TAPE WAS TRUNCATED WITHIN ARRAY ESUMM;'/ + '0THIS ARRAY HAS BEEN SET TO ZERO;'/ + '0PREDICTIONS OF TELESEISMIC TRAVEL-TIME WILL NOT', + ' BE ACCURATE UNLESS D(VP)/D(E) = 0.') RETURN END SUBROUTINE GOON C C C SUBROUTINE GOTOND (INPUT,NUMNOD, + OUTPUT,XNODCE,YNODCE) C C READS "TAPE" WITH THE FINAL LOCATIONS OF CRUST NODES ON DEVICE 12. C CHARACTER*80 TITLE DIMENSION XNODCE(NUMNOD), + YNODCE(NUMNOD) C 1 WRITE(6,10) 10 FORMAT( + /' Attempting to read a short file of present-day positions' + /' of the nodes of the crustal grid. This file can be copied' + /' from the beginning of the integrated-array report from the' + /' final timestep of a simulation, possibly by utility GETEND.' + /' These positions are used to compute net strains since' + /' times in the past, and also to restore the basemap.') TITLE=' '// + ' ' READ (12,1001,IOSTAT=IOS) TITLE 1001 FORMAT(A) 1002 FORMAT(1P,8E9.2) IF (IOS.EQ.-1) THEN WRITE(6,20) 20 FORMAT(/' ERROR: Missing or empty file.') STOP ' ' END IF WRITE(6,30) TRIM(TITLE) 30 FORMAT(/' Title line of this file follows:' + /' ',A) READ (12,1004) TIME TMY=TIME/(1.E6*365.25*24.*60.*60.) WRITE (6,40) TIME,TMY 40 FORMAT(/' Time = ',1P,E9.2,' seconds = ',0P,F10.3,' Ma.') 1004 FORMAT(10X,E10.4) 1005 FORMAT(1P,6E13.6) C READ XNODC ARRAY READ (12,1001) READ (12,1005) (XNODCE(I),I=1,NUMNOD) WRITE(6,50) 50 FORMAT(/' Read array XNODC.') C DUMMY READ TO PASS THROUGH XNODM ARRAY READ (12,1001) READ (12,1005) (YNODCE(I),I=1,NUMNOD) WRITE(6,60) 60 FORMAT( ' Read array XNODM (and discarded it).') C READ YNODC ARRAY READ (12,1001) READ (12,1005) (YNODCE(I),I=1,NUMNOD) WRITE(6,70) 70 FORMAT( ' Read array YNODC. Done with file.' + /' ------------------------------------') CLOSE(12) RETURN END SUBROUTINE GOTOND C C C SUBROUTINE AREAS (NODES,AREA,XNOD,YNOD,NUMNOD,NUMEL) C C COMPUTE AREAS OF ELEMENTS IN GRID AS IF THEY HAD STRAIGHT C SIDES. EFFECT OF SIDE CURVATURE WILL BE HANDLED LATER BY C MULTIPLYING BY DETERMINANT OF JACOBIAN MATRIX FOR THE SIDE- C BENDING MAPPING. NOTE THAT AREA MAY BE NEGATIVE, BUT ELEMENT C IS OK IF DETERMINANT IN DERIV IS ALSO NEGATIVE. C DIMENSION AREA(NUMEL),NODES(6,0:NUMEL),XNOD(NUMNOD),YNOD(NUMNOD) DO 100 INDEX=1,NUMEL I1=NODES(1,INDEX) I2=NODES(2,INDEX) I3=NODES(3,INDEX) AREA(INDEX)= 0.5*(XNOD(I1)*YNOD(I2)-XNOD(I2)*YNOD(I1) + +XNOD(I2)*YNOD(I3)-XNOD(I3)*YNOD(I2) + +XNOD(I3)*YNOD(I1)-XNOD(I1)*YNOD(I3)) 100 CONTINUE RETURN END SUBROUTINE AREAS C C C SUBROUTINE DERIV (NUMEL,NUMNOD,NODES,XNOD,YNOD,AREA, + DETJ,DXS,DYS,NUMBAD,LISTOP) C C CALCULATES DXS AND DYS, THE X-DERIVITIVE AND Y-DERIVITIVE C OF EACH OF THE 6 NODAL FUNCTIONS OF A DEFORMED-TRIANGLE C FINITE ELEMENT, AT EACH OF THE 7 INTEGRATION POINTS IN C THAT ELEMENT. ALSO PROVIDES DETJ, THE DETERMINANT OF THE C JACOBIAN MATRIX FOR THE TRANSFORMATION IN WHICH INTERNAL C POINTS OF A TRIANGLE WITH STRAIGHT SIDES ARE MAPPED INTO C NEW LOCATIONS AS SIDES BEND (BUT CORNERS STAY FIXED). C LOGICAL LISTOP DIMENSION AREA(NUMEL),B(4),C(4),DETJ(7,NUMEL),DN(6,2), + DXS(6,7,NUMEL),DYS(6,7,NUMEL), + LISTOP(NUMEL),NODES(6,0:NUMEL), + X(6),XNOD(NUMNOD),Y(6),YNOD(NUMNOD) NUMBAD=0 DO 500 I=1,NUMEL LISTOP(I)=.FALSE. DO 100 J=1,6 NODE=NODES(J,I) X(J)=XNOD(NODE) Y(J)=YNOD(NODE) 100 CONTINUE B(1)=Y(2)-Y(3) B(2)=Y(3)-Y(1) B(3)=Y(1)-Y(2) B(4)=B(1) C(1)=X(3)-X(2) C(2)=X(1)-X(3) C(3)=X(2)-X(1) C(4)=C(1) AI2=1./(2.*AREA(I)) DO 400 M=1,7 DO 200 J=1,3 DN(J,1)=AI2*B(J)*(4.*POINTS(J,M)-1.) DN(J+3,1)=AI2*4.*(B(J)*POINTS(J+1,M) + +B(J+1)*POINTS(J,M)) DN(J,2)=AI2*C(J)*(4.*POINTS(J,M)-1.) DN(J+3,2)=AI2*4.*(C(J)*POINTS(J+1,M) + +C(J+1)*POINTS(J,M)) 200 CONTINUE AJ11=0. AJ12=0. AJ21=0. AJ22=0. DO 300 J=1,6 AJ11=AJ11+DN(J,1)*X(J) AJ12=AJ12+DN(J,1)*Y(J) AJ21=AJ21+DN(J,2)*X(J) AJ22=AJ22+DN(J,2)*Y(J) 300 CONTINUE DETJAC=AJ11*AJ22-AJ12*AJ21 DETJ(M,I)=DETJAC IF ((AREA(I)*DETJAC).LT.0.) LISTOP(I)=.TRUE. AJ11S=AJ11 AJ11=AJ22/DETJAC AJ12=-AJ12/DETJAC AJ21=-AJ21/DETJAC AJ22=AJ11S/DETJAC DO 350 J=1,6 DXS(J,M,I)=AJ11*DN(J,1)+AJ12*DN(J,2) DYS(J,M,I)=AJ21*DN(J,1)+AJ22*DN(J,2) 350 CONTINUE 400 CONTINUE IF (LISTOP(I)) NUMBAD=NUMBAD+1 500 CONTINUE RETURN END SUBROUTINE DERIV C C C SUBROUTINE INLAND (INPUT,XIP,YIP,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMW) C C COMPUTE DISTANCE INLAND FROM "LEFT" EDGE OF CRUSTAL GRID, C FOR A WHOLE ARRAY OF INTEGRATION POINTS AT ONCE C DIMENSION FROMW(7,NUMEL),XIP(7,NUMEL),XNODC(NUMNOD), + YIP(7,NUMEL),YNODC(NUMNOD) NELCOL=NUMEL/(2*NELROW) NCOLN=2*NELCOL+1 NLL=NUMNOD-NCOLN+1 DO 100 M=1,7 DO 90 I=1,NUMEL X=XIP(M,I) Y=YIP(M,I) FROMW(M,I)= + HOWFAR(X,Y,NELROW,NCOLN,NLL,XNODC,YNODC) 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE INLAND C C C REAL FUNCTION HOWFAR (X,Y, + NELROW,NCOLN,NLL,XNODC,YNODC) C C COMPUTES ORTHOGONAL DISTANCE FROM "LEFT" EDGE OF CRUSTAL GRID, C FOR ANY SINGLE POINT. C INTEGER N,NBOT,NCOLN,NELROW,NLL,NM,NMID,NTOP REAL AREA,BASE,D2M,R2,R2BOT,R2TOP,X,X1,X2,X3,XNODC, + Y,Y1,Y2,Y3,YNODC DIMENSION XNODC(NLL),YNODC(NLL) C D2M=9.99E37 DO 10 N=1,NELROW NM=NCOLN*(2*N-1)+1 R2=(X-XNODC(NM))**2+(Y-YNODC(NM))**2 IF (R2.LT.D2M) THEN D2M=R2 NMID=NM ENDIF 10 CONTINUE NTOP=NMID-NCOLN NBOT=NMID+NCOLN R2TOP=(X-XNODC(NTOP))**2+(Y-YNODC(NTOP))**2 R2BOT=(X-XNODC(NBOT))**2+(Y-YNODC(NBOT))**2 X1=X Y1=Y IF (R2TOP.LE.R2BOT) THEN X2=XNODC(NTOP) Y2=YNODC(NTOP) X3=XNODC(NMID) Y3=YNODC(NMID) ELSE X2=XNODC(NMID) Y2=YNODC(NMID) X3=XNODC(NBOT) Y3=YNODC(NBOT) ENDIF BASE=((X2-X3)**2+(Y2-Y3)**2)**0.5 AREA=0.5*(X1*Y2-X2*Y1 + +X2*Y3-X3*Y2 + +X3*Y1-X1*Y3) HOWFAR=MAX(0.,2.*AREA/BASE) RETURN END FUNCTION HOWFAR C C C SUBROUTINE ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATE,FRIC,G,GEOTH, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIK,THNKC,UPLINK, + OUTPUT,FLUX,GLUE, + WORK,ILAYER,OUTSCA,ZBEAM) C C CALCULATES: C *GLUE (SHEAR STRESS REQUIRED TO CREATE UNIT RELATIVE C HORIZONTAL VELOCITY ACROSS A LAYER), AND C *FLUX (VERTICAL INTEGRAL OF HORIZONTAL VELOCITY CAUSED BY A C UNIT OF RELATIVE HORIZONTAL VELOCITY ACROSS A LAYER) C=============================================================== C CAUTION: THIS IS NOT THE SAME AS THE VERSION OF ONEBAR C IN LARAMY. IT HAS BEEN TESTED TO PRODUCE THE SAME C VALUES FOR FLUX AND GLUE (EVEN AFTER SCALING SHEAR C STRESS BY 1.E6 TO PREVENT UNDERFLOWS ON PC'S). C HOWEVER, UNLIKE THE VERSION IN LARAMY, IT DOES NOT C RETURN VALUES OF FLUXUC AND QFRIC(4,M,I). C=============================================================== C PARAMETER (NINT=100) LOGICAL CRUST,MANTLE REAL ANGLE DIMENSION ACREEP(3),BCREEP(3),CCREEP(3),DCREEP(3),ECREEP(3), + CONINT(7,NUMEL), + ERATE(4,7,NUMEL), + FLUX(7,NUMEL), + FRIC(2), + GEOTH(4,7,NUMEL), + GLUE(7,NUMEL), + ILAYER(NUMEL), + NODES(6,0:NUMEL), + OUTSCA(7,NUMEL), + RHOBAR(2), + TEMLIM(2), + THIK(7,NUMEL), + THNKC(NUMNOD), + UPLINK(3,7,NUMEL), + ZBEAM(7,NUMEL) C MANTLE=.NOT.CRUST C C INITIALIZE SUMS TO ZERO C (NOTE THAT THESE SUMS DO NOT YET HAVE THE MEANING DESCRIBED ABOVE, C AND THE ARRAYS ARE ONLY BEING USED FOR WORKING STORAGE. C UNTIL THE FINAL LOOP, GLUE WILL HOLD THE VELOCITY AND FLUX WILL C HOLD THE FLUX AT/ABOVE THE CURRENT DEPTH.) C DO 8 M=1,7 C*VDIR: ASSUME COUNT(280) DO 6 I=1,NUMEL FLUX(M,I)=0. GLUE(M,I)=0. 6 CONTINUE 8 CONTINUE C IF (CRUST) THEN ILE=1 TLIM=TEMLIM(1) DO 20 M=1,7 DO 10 I=1,NUMEL OUTSCA(M,I)=0. 10 CONTINUE 20 CONTINUE ELSE ILE=3 STFRIC=SIN(ATAN(FRIC(2))) TLIM=TEMLIM(2) CALL GETSCA(INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DPEDZ=G*(RHOBAR(2)-RHOH2O*BIOT) C*VDIR: ASSUME COUNT(280) DO 25 I=1,NUMEL ILAYER(I)=3 25 CONTINUE ENDIF C C FIND REFERENCE LEVEL, TO WHICH NODAL VELOCITIES REFER: C IN CRUST, THIS IS ALWAYS THE SURFACE; C IN MANTLE, IT IS THE STRONGEST LEVEL: C DO 28 M=1,7 C*VDIR: ASSUME COUNT(280) DO 27 I=1,NUMEL IF (CRUST) THEN ZBEAM(M,I)=0.0 ELSE PE0=G*OUTSCA(M,I)*(RHOBAR(1)-RHOH2O*BIOT) EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) DIVER=EXX+EYY SHEAR=SQRT(EXY**2+0.25*(EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR EZZ=-DIVER SECINV=E1*E2 + E1*EZZ + E2*EZZ DEFORM=2.*SQRT(ABS(SECINV)) EN=DEFORM**ECREEP(3) ANGLE=ATAN2F(E2,E1)-0.7854 FACTOR=1./(1.+STFRIC*COS(ANGLE)) ZBEAM(M,I)=THIK(M,I) STRMAX=0.0 DO 26 K=0,10,1 Z=(THIK(M,I)*K)/10 ZABS=Z+OUTSCA(M,I) T=GEOTH(1,M,I) + +GEOTH(2,M,I)*Z + +GEOTH(3,M,I)*Z*Z + +GEOTH(4,M,I)*Z*Z*Z TH=MAX(T,200.) TL=MIN(TH,TLIM) SCP=ACREEP(3)*EN* + EXP((BCREEP(3)+CCREEP(3)*ZABS)/TL) SF=STFRIC*(PE0+DPEDZ*Z)*FACTOR SCP=MIN(SCP,DCREEP(3),SF) IF (SCP.GE.STRMAX) THEN ZBEAM(M,I)=Z STRMAX=SCP ENDIF 26 CONTINUE ENDIF 27 CONTINUE 28 CONTINUE C DO 100 M=1,7 DO 60 J=1,NINT C C SEPARATE OUT CHOICE OF MATERIAL ,IN CASE IT BLOCKS VECTORIZATION C IF (CRUST) THEN C*VDIR: ASSUME COUNT(280) DO 30 I=1,NUMEL C C INTEGRATION OF "GLUE" (VELOCITY) IS PERFORMED BY MIDPOINT RULE, C SO ALL QUANTITIES ARE EVALUATED AT MIDDLE OF DEPTH STEP: C Z=ZBEAM(M,I)+(J-0.5)/NINT* + (THIK(M,I)-ZBEAM(M,I)) IF (Z.GT.CONINT(M,I)) THEN ILAYER(I)=2 ELSE ILAYER(I)=1 ENDIF 30 CONTINUE ENDIF C C CRITICAL, TRIPLY-NESTED LOOP; MUST BE VECTORIZED: C C*VDIR: ASSUME COUNT(280) DO 50 I=1,NUMEL Z=ZBEAM(M,I)+(J-0.5)/NINT* + (THIK(M,I)-ZBEAM(M,I)) T=GEOTH(1,M,I) + +GEOTH(2,M,I)*Z + +GEOTH(3,M,I)*Z*Z + +GEOTH(4,M,I)*Z*Z*Z TH=MAX(T,200.) TL=MIN(TH,TLIM) ACI=ACREEP(ILAYER(I)) BCI=BCREEP(ILAYER(I)) CCI=CCREEP(ILAYER(I)) ECINI= -1.0/ECREEP(ILAYER(I)) AILOG=(LOG(ACI)-13.8155)*ECINI C C LINE ABOVE USES SHEAR STRESS OF 1E6 C [ LOG(1.E6) = 13.8155 ] C TO PREVENT UNDERFLOWS ON SMALL-WORD PC'S C BI=(BCI+CCI*(Z+OUTSCA(M,I)))*ECINI ARG=MAX(AILOG+BI/TL,-85.) GLUE(M,I)=GLUE(M,I)+EXP(ARG) FLUX(M,I)=FLUX(M,I)+GLUE(M,I) 50 CONTINUE 60 CONTINUE C C CORRECT FOR EXCESSIVE WEIGHT ON LAST VALUE OF "GLUE" (VELOCITY) C IN INTEGRATION OF FLUX (I.E., APPLY TRAPEZOIDAL RULE): C C*VDIR: ASSUME COUNT(280) DO 70 I=1,NUMEL FLUX(M,I)=FLUX(M,I)-0.5*GLUE(M,I) 70 CONTINUE C C MULTIPLY SUMS BY COMMON FACTORS AND TRANSFORM DIMENSIONS C C*VDIR: ASSUME COUNT(280) DO 80 I=1,NUMEL FLUX(M,I)=FLUX(M,I)*(THIK(M,I)-ZBEAM(M,I))/ + (GLUE(M,I)*NINT) 80 CONTINUE C*VDIR: ASSUME COUNT(280) DO 90 I=1,NUMEL GLUE(M,I)=(GLUE(M,I)*MAX(1., + (THIK(M,I)-ZBEAM(M,I)))/NINT)**(-ECREEP(ILE)) C FINALLY, CORRECT FOR ASSUMPTION OF 1E6 SHEAR STRESS: GLUE(M,I)=GLUE(M,I)*1.E6 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE ONEBAR C C C SUBROUTINE LINKER (NELCOL,NUMEL,XIP1,YIP1, + DETJ2,XIP2,YIP2,XNOD2,YNOD2, + NUMNOD,NODES,AREA,UDLINK,INLOOP) C C FINDS ELEMENT AND INTERNAL COORDINATES IN OPPOSITE GRID MATCHING C LOCATION OF EACH INTEGRATION POINT IN THE FIRST GRID, AND STORES C THEM IN UDLINK(1-3,M,I); WHERE M AND I ARE THE INTEGRATION POINT C AND ELEMENT IN THE FIRST GRID. C UDLINK(1,M,I) HOLDS THE ELEMENT NUMBER (+0.10) FROM THE OTHER; C UDLINK(2,M,I) HOLDS THE S2 INTERNAL COORDINATE; C UDLINK(3,M,I) HOLDS THE S3 INTERNAL COORDINATE. C THE S1 COORDINATE IS NOT STORED: S1=1.00-S2-S3 C LOGICAL INLOOP,ISTRAP,LEFTY,ODD,RIGHT,TRUBBL REAL M11,M12,M13,M21,M22,M23 DIMENSION AREA(NUMEL),DETJ2(7,NUMEL),ITHIST(50), + NODES(6,0:NUMEL),SHIST(3,50),UDLINK(3,7,NUMEL), + XIP1(7,NUMEL),XIP2(7,NUMEL), + XNOD2(NUMNOD), + YIP1(7,NUMEL),YIP2(7,NUMEL), + YNOD2(NUMNOD) C C STATEMENT FUNCTIONS: ODD(I)=MOD(I,2).EQ.1 RIGHT(I)=MOD(I,NELWID).EQ.0 LEFTY(I)=MOD(I,NELWID).EQ.1 PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) C C NELWID=2*NELCOL INLOOP=.FALSE. IT=NUMEL C C LOOP ON POINTS WHOSE COORDINATES ARE TO BE FOUND: DO 1000 I=NUMEL,1,-1 IF(RIGHT(I)) IT=I DO 900 M=1,7 X=XIP1(M,I) Y=YIP1(M,I) NTRIED=0 C C BEGIN LOOP ON ELEMENTS WHICH MIGHT CONTAIN THE POINT: 100 NTRIED=NTRIED+1 ITHIST(NTRIED)=IT TRUBBL=(NTRIED.GE.3).AND.(ITHIST(NTRIED).EQ. + ITHIST(NTRIED-2)) IF (TRUBBL) THEN I1=I M1=M CALL SURVEY (INPUT,I1,M1,NUMEL, + X,XIP2,Y,YIP2, + OUTPUT,UDLINK) GO TO 898 ENDIF I1=NODES(1,IT) I2=NODES(2,IT) I3=NODES(3,IT) I4=NODES(4,IT) I5=NODES(5,IT) I6=NODES(6,IT) X1=XNOD2(I1) X2=XNOD2(I2) X3=XNOD2(I3) Y1=YNOD2(I1) Y2=YNOD2(I2) Y3=YNOD2(I3) ISTRAP=(DETJ2(1,IT).LE.0.2).OR. + (DETJ2(2,IT).LE.0.2).OR. + (DETJ2(3,IT).LE.0.2).OR. + (DETJ2(4,IT).LE.0.2).OR. + (DETJ2(5,IT).LE.0.2).OR. + (DETJ2(6,IT).LE.0.2).OR. + (DETJ2(7,IT).LE.0.2) IF (ISTRAP) THEN X4=0.5*(X1+X2) X5=0.5*(X2+X3) X6=0.5*(X3+X1) Y4=0.5*(Y1+Y2) Y5=0.5*(Y2+Y3) Y6=0.5*(Y3+Y1) ELSE X4=XNOD2(I4) X5=XNOD2(I5) X6=XNOD2(I6) Y4=YNOD2(I4) Y5=YNOD2(I5) Y6=YNOD2(I6) ENDIF S1=1./3. S2=S1 S3=1.-S1-S2 LIMIT=3 NREFIN=0 C C C LOOP TO REFINE ESTIMATE OF INTERNAL COORDINATES 150 NREFIN=NREFIN+1 XT=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YT=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) C C COEF:=MAT((DXDS1,DXDS2,DXDS3),(DYDS1,DYDS2,DYDS3),(1,1,1)); COEF11=4.*S2*X4+4.*S1*X1+4.*X6*S3-X1 COEF12=4.*S2*X2+4.*S1*X4+4.*X5*S3-X2 COEF13=4.*S2*X5+4.*S1*X6+4.*X3*S3-X3 COEF21=4.*S2*Y4+4.*S1*Y1+4.*Y6*S3-Y1 COEF22=4.*S2*Y2+4.*S1*Y4+4.*Y5*S3-Y2 COEF23=4.*S2*Y5+4.*S1*Y6+4.*Y3*S3-Y3 M11=COEF22-COEF23 M12=COEF21-COEF23 M13=COEF21-COEF22 M21=COEF12-COEF13 M22=COEF11-COEF13 M23=COEF11-COEF12 CF11=+M11 CF12=-M12 CF13=+M13 CF21=-M21 CF22=+M22 CF23=-M23 DET=COEF11*CF11+COEF12*CF12+COEF13*CF13 IF (DET.EQ.0.0) THEN UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 898 ENDIF DETI= 1./DET STEP11=CF11 STEP12=CF21 STEP21=CF12 STEP22=CF22 STEP31=CF13 STEP32=CF23 DELX=X-XT DELY=Y-YT DS1=(STEP11*DELX+STEP12*DELY)*DETI DS2=(STEP21*DELX+STEP22*DELY)*DETI DS3=(STEP31*DELX+STEP32*DELY)*DETI ERR=(DS1+DS2+DS3)/3. DS1=DS1-ERR DS2=DS2-ERR DS3=DS3-ERR DSTEP=MAX(ABS(DS1),ABS(DS2),ABS(DS3)) IF (DSTEP.GT. 0.10) THEN LIMIT=LIMIT+1 DS1=DS1*0.1/DSTEP DS2=DS2*0.1/DSTEP DS3=DS3*0.1/DSTEP ENDIF S1=S1+DS1 S2=S2+DS2 S3=S3+DS3 200 IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.40).AND. + (S1.GE.-0.1.AND.S1.LE.1.1).AND. + (S2.GE.-0.1.AND.S2.LE.1.1).AND. + (S3.GE.-0.1.AND.S3.LE.1.1)) GO TO 150 SHIST(1,NTRIED)=S1 SHIST(2,NTRIED)=S2 SHIST(3,NTRIED)=S3 IF (NTRIED.GE.50) THEN INLOOP=.TRUE. WRITE(6,201) M,I,X,Y 201 FORMAT(' INTEGRATION POINT ',I1,' IN ELEMENT ', + I3,' AT (',1P,E10.2,',',E10.2,') CAUSES ', + 'INFINITE LOOP IN LINKER.'/ + ' HISTORY OF SEARCH: ELEMENT S1 S2', + ' S3') 202 FORMAT(22X,I3,2X,3F12.4) DO 203 N=1,50 WRITE(6,202) ITHIST(N),(SHIST(K,N),K=1,3) 203 CONTINUE WRITE(6,204) ITHIST(49),(NODES(J,ITHIST(49)), + J=1,6),(XNOD2(NODES(J,ITHIST(49))),J=1,6), + (YNOD2(NODES(J,ITHIST(49))),J=1,6) WRITE(6,204) ITHIST(50),(NODES(J,ITHIST(50)), + J=1,6),(XNOD2(NODES(J,ITHIST(50))),J=1,6), + (YNOD2(NODES(J,ITHIST(50))),J=1,6) 204 FORMAT(' ELEMENT',I3,' NODES:',I3,5I10/ + 9X,'X:',1P,6E10.2/9X,'Y:',6E10.2) RETURN ENDIF IF (ODD(IT)) THEN IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF (LEFTY(IT)) THEN UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 898 ELSE IT=IT-1 GO TO 100 ENDIF ELSE IF(IT.GT.NELWID) THEN IT=IT-NELWID+1 GO TO 100 ELSE GO TO 500 ENDIF ELSE IT=IT+1 GO TO 100 ENDIF ELSE IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF(MOD(IT,NELWID).NE.0) THEN IT=IT+1 GO TO 100 ELSE GO TO 500 ENDIF ELSE IF ((NUMEL-IT).GE.NELWID) THEN IT=IT+NELWID-1 GO TO 100 ELSE GO TO 500 ENDIF ELSE IT=IT-1 GO TO 100 ENDIF ENDIF 500 UDLINK(1,M,I)=IT+0.10 UDLINK(2,M,I)=S2 UDLINK(3,M,I)=S3 898 CONTINUE 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE LINKER C C C SUBROUTINE SURVEY (INPUT,I1,M1,NUMEL, + X,XIP,Y,YIP, + OUTPUT,UDLINK) C C FIND THE CLOSEST INTEGRATION POINT IN GRID (XIP,YIP) C TO THE GIVEN POINT (X,Y), AND STORES THE COORDINATES C IN UDLINK(1-3,M1,I1); WHERE M1 AND I1 ARE THE INTEGRATION POINT C AND ELEMENT IN THE FIRST GRID. C UDLINK(1,M1,I1) HOLDS THE ELEMENT NUMBER (+0.10); C UDLINK(2,M1,I1) HOLDS THE S2 INTERNAL COORDINATE; C UDLINK(3,M1,I1) HOLDS THE S3 INTERNAL COORDINATE. C THE S1 COORDINATE IS NOT STORED: S1=1.00-S2-S3 C THIS ROUTINE IS A ROUGH REPLACEMENT FOR "LINKER" IN CASES WHERE C IT FAILS DUE TO VERY DISTORTED ELEMENTS. C INTEGER I,IS,M,MS LOGICAL INSIDE REAL DXA,DXB,DXC,DYA,DYB,DYC,RA2,RB2,RC2, + R2,R2MIN,UDLINK DIMENSION UDLINK(3,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) DATA BIGNUM/9.99E37/ C R2MIN=BIGNUM DO 100 M=1,7 DO 90 I=1,NUMEL R2=(X-XIP(M,I))**2+(Y-YIP(M,I))**2 IF (R2.LT.R2MIN) THEN R2MIN=R2 IS=I MS=M ENDIF 90 CONTINUE 100 CONTINUE R2C=(X-XIP(1,IS))**2+(Y-YIP(1,IS))**2 DXA=XIP(1,IS)-XIP(5,IS) DXB=XIP(1,IS)-XIP(6,IS) DXC=XIP(1,IS)-XIP(7,IS) DYA=YIP(1,IS)-YIP(5,IS) DYB=YIP(1,IS)-YIP(6,IS) DYC=YIP(1,IS)-YIP(7,IS) RA2=DXA**2+DYA**2 RB2=DXB**2+DYB**2 RC2=DXC**2+DYC**2 R2CRIT=1.5*MAX(RA2,RB2,RC2) INSIDE=R2C.LE.R2CRIT IF (INSIDE) THEN UDLINK(1,M1,I1)=IS+0.1 UDLINK(2,M1,I1)=POINTS(2,MS) UDLINK(3,M1,I1)=POINTS(3,MS) ELSE UDLINK(1,M1,I1)=0. UDLINK(2,M1,I1)=0. UDLINK(3,M1,I1)=0. ENDIF RETURN END SUBROUTINE SURVEY C C C SUBROUTINE LINKUS (NELCOL,NUMEL1,NUMEL2, + XIP1,YIP1,XNOD2,YNOD2, + NUMNOD,NODES,AREA,UDLINK,INLOOP) C C FINDS ELEMENT AND INTERNAL COORDINATES IN OPPOSITE GRID MATCHING C LOCATION OF EACH INTEGRATION POINT IN THE FIRST GRID, AND STORES C THEM IN UDLINK(1-3,M,I); WHERE M AND I ARE THE INTEGRATION POINT C AND ELEMENT IN THE FIRST GRID. C UDLINK(1,M,I) HOLDS THE ELEMENT NUMBER (+0.10) FROM THE OTHER; C UDLINK(2,M,I) HOLDS THE S2 INTERNAL COORDINATE; C UDLINK(3,M,I) HOLDS THE S3 INTERNAL COORDINATE. C C MODIFIED FROM LINKER TO WORK WITH DIGITIZED STATE LINES !!!! C SPECIFICALLY, ARGUMENT NUMEL WAS SPLIT INTO NUMEL1 AND 2; C INITIALIZATION OF TENTATIVE ELEMENT IT WAS CHANGED, AND C INTERNAL COORDINATES ARE NOW REPORTED FOR POINTS OFF THE C LEFT EDGE. C LOGICAL INLOOP,LEFTY,ODD,RIGHT,TRUBBL REAL M11,M12,M13,M21,M22,M23 DIMENSION AREA(NUMEL2),ITHIST(50),UDLINK(3,7,NUMEL1), + NODES(6,0:NUMEL2),SHIST(3,50), + XIP1(7,NUMEL1),YIP1(7,NUMEL1), + XNOD2(NUMNOD),YNOD2(NUMNOD) DATA BIGNUM/9.99E37/ ODD(I)=MOD(I,2).EQ.1 RIGHT(I)=MOD(I,NELWID).EQ.0 LEFTY(I)=MOD(I,NELWID).EQ.1 PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) NELWID=2*NELCOL INLOOP=.FALSE. DO 1000 M=1,7 DO 900 I=1,NUMEL1 X=XIP1(M,I) Y=YIP1(M,I) DIST2=BIGNUM DO 50 JIT=1,NUMEL2 XJT=0.333*(XNOD2(NODES(4,JIT))+ + XNOD2(NODES(5,JIT))+ + XNOD2(NODES(6,JIT))) YJT=0.333*(YNOD2(NODES(4,JIT))+ + YNOD2(NODES(5,JIT))+ + YNOD2(NODES(6,JIT))) R2=(X-XJT)**2+(Y-YJT)**2 IF (R2.LT.DIST2) THEN IT=JIT DIST2=R2 ENDIF 50 CONTINUE NTRIED=0 100 NTRIED=NTRIED+1 ITHIST(NTRIED)=IT TRUBBL=(NTRIED.GE.3).AND.(ITHIST(NTRIED).EQ. + ITHIST(NTRIED-2)) IF (TRUBBL) GO TO 500 I1=NODES(1,IT) I2=NODES(2,IT) I3=NODES(3,IT) I4=NODES(4,IT) I5=NODES(5,IT) I6=NODES(6,IT) X1=XNOD2(I1) X2=XNOD2(I2) X3=XNOD2(I3) X4=XNOD2(I4) X5=XNOD2(I5) X6=XNOD2(I6) Y1=YNOD2(I1) Y2=YNOD2(I2) Y3=YNOD2(I3) Y4=YNOD2(I4) Y5=YNOD2(I5) Y6=YNOD2(I6) S1=1./3. S2=S1 S3=1.-S1-S2 LIMIT=3 NREFIN=0 C LOOP TO REFINE ESTIMATE OF INTERNAL COORDINATES 150 NREFIN=NREFIN+1 XT=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YT=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) C C COEF:=MAT((DXDS1,DXDS2,DXDS3),(DYDS1,DYDS2,DYDS3),(1,1,1)); COEF11=4.*S2*X4+4.*S1*X1+4.*X6*S3-X1 COEF12=4.*S2*X2+4.*S1*X4+4.*X5*S3-X2 COEF13=4.*S2*X5+4.*S1*X6+4.*X3*S3-X3 COEF21=4.*S2*Y4+4.*S1*Y1+4.*Y6*S3-Y1 COEF22=4.*S2*Y2+4.*S1*Y4+4.*Y5*S3-Y2 COEF23=4.*S2*Y5+4.*S1*Y6+4.*Y3*S3-Y3 M11=COEF22-COEF23 M12=COEF21-COEF23 M13=COEF21-COEF22 M21=COEF12-COEF13 M22=COEF11-COEF13 M23=COEF11-COEF12 CF11=+M11 CF12=-M12 CF13=+M13 CF21=-M21 CF22=+M22 CF23=-M23 DET=COEF11*CF11+COEF12*CF12+COEF13*CF13 DETI= 1./DET STEP11=CF11 STEP12=CF21 STEP21=CF12 STEP22=CF22 STEP31=CF13 STEP32=CF23 DELX=X-XT DELY=Y-YT DS1=(STEP11*DELX+STEP12*DELY)*DETI DS2=(STEP21*DELX+STEP22*DELY)*DETI DS3=(STEP31*DELX+STEP32*DELY)*DETI ERRER=(DS1+DS2+DS3)/3. DS1=DS1-ERRER DS2=DS2-ERRER DS3=DS3-ERRER DSTEP=MAX(ABS(DS1),ABS(DS2),ABS(DS3)) IF (DSTEP.GT. 0.10) THEN LIMIT=LIMIT+1 DS1=DS1*0.1/DSTEP DS2=DS2*0.1/DSTEP DS3=DS3*0.1/DSTEP ENDIF S1=S1+DS1 S2=S2+DS2 S3=S3+DS3 IF (LEFTY(IT)) THEN IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.40).AND. + (S1.GE.-0.1.AND.S1.LE.3.0).AND. + (S2.GE.-0.1.AND.S2.LE.1.1).AND. + (S3.GE.-3.0.AND.S3.LE.1.1)) GO TO 150 ELSE IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.40).AND. + (S1.GE.-0.1.AND.S1.LE.1.1).AND. + (S2.GE.-0.1.AND.S2.LE.1.1).AND. + (S3.GE.-0.1.AND.S3.LE.1.1)) GO TO 150 ENDIF C C END OF LOOP TO REFINE INTERNAL COORDINATES IN ONE TRIAL ELEMENT C SHIST(1,NTRIED)=S1 SHIST(2,NTRIED)=S2 SHIST(3,NTRIED)=S3 IF (NTRIED.GE.50) THEN INLOOP=.TRUE. WRITE(6,201) M,I,X,Y 201 FORMAT('0INTEGRATION POINT ',I1,' IN ELEMENT ', + I3,' AT (',1P,E10.2,',',E10.2,') CAUSES ', + 'INFINITE LOOP IN LINKER.'/ + ' HISTORY OF SEARCH: ELEMENT S1 S2', + ' S3') 202 FORMAT(22X,I3,2X,3F12.4) DO 203 N=1,50 WRITE(6,202) ITHIST(N),(SHIST(K,N),K=1,3) 203 CONTINUE WRITE(6,204) ITHIST(49),(NODES(J,ITHIST(49)), + J=1,6),(XNOD2(NODES(J,ITHIST(49))),J=1,6), + (YNOD2(NODES(J,ITHIST(49))),J=1,6) WRITE(6,204) ITHIST(50),(NODES(J,ITHIST(50)), + J=1,6),(XNOD2(NODES(J,ITHIST(50))),J=1,6), + (YNOD2(NODES(J,ITHIST(50))),J=1,6) 204 FORMAT('0ELEMENT',I3,' NODES:',I3,5I10/ + 9X,'X:',1P,6E10.2/9X,'Y:',6E10.2) RETURN ENDIF IF (ODD(IT)) THEN IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF (LEFTY(IT)) THEN GO TO 500 ELSE IT=IT-1 GO TO 100 ENDIF ELSE IF(IT.GT.NELWID) THEN IT=IT-NELWID+1 GO TO 100 ELSE UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 900 ENDIF ELSE IT=IT+1 GO TO 100 ENDIF ELSE IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF(MOD(IT,NELWID).NE.0) THEN IT=IT+1 GO TO 100 ELSE UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 900 ENDIF ELSE IF ((NUMEL2-IT).GE.NELWID) THEN IT=IT+NELWID-1 GO TO 100 ELSE UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 900 ENDIF ELSE IT=IT-1 GO TO 100 ENDIF ENDIF 500 UDLINK(1,M,I)=IT+0.10 UDLINK(2,M,I)=S2 UDLINK(3,M,I)=S3 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE LINKUS C C C SUBROUTINE SETCUB (THIKM,NUMEL,GEOTHM,GEOTHA,OUTSCA,TASTH, + THIKC,GEOTHC,DNLINK,TOUCHC,TOUCHM,TSLAB0, + AREAM,DETJM,CONDNS, + NDIFF,NODES,NUMNOD, + TSURF,FROMWC,FROMWM,ONEKM) C C ADJUSTS LOWER PART OF GEOTHERMS TO BOTTOM BOUNDARY CONDITION C AFTER AN INCREMENT OF SIMPLE SHEAR (NO NEED AFTER PURE SHEAR), C OR WHEN DIFFERENT MATERIAL SHIFTS BENEATH THE LAYER. C LOGICAL LOCKIN,LOCKWC DIMENSION GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), + DNLINK(3,7,NUMEL),OUTSCA(7,NUMEL), + THIKC(7,NUMEL),THIKM(7,NUMEL), + TOUCHC(7,NUMEL),TOUCHM(7,NUMEL), + AREAM(NUMEL),DETJM(7,NUMEL), + CONDNS(NUMNOD), + NODES(6,0:NUMEL), + FROMWC(7,NUMEL),FROMWM(7,NUMEL) DATA BIGNUM /1.E37/, LOCKIN /.FALSE./, LOCKWC /.FALSE./ C C ASTHENOSPHERE LAYER, WITH POTENTIAL THERMAL BOUNDARY LAYER C DO 100 M=1,7 DO 90 I=1,NUMEL IF ((TOUCHC(M,I).LE.0.).AND. + (DNLINK(1,M,I).LE.0.)) THEN C C RESET BASE, BUT ALLOW THERMAL EVOLUTION C Z=THIKM(5,NUMEL) TBOT=GEOTHA(1,M,I)+ GEOTHA(2,M,I)*Z+ + GEOTHA(3,M,I)*Z**2+GEOTHA(4,M,I)*Z**3 CORREC=TASTH-TBOT GEOTHA(4,M,I)=GEOTHA(4,M,I)+CORREC/Z**3 ELSE C C RESET WHOLE BOUNDARY LAYER C GEOTHA(1,M,I)=TASTH GEOTHA(2,M,I)=0. GEOTHA(3,M,I)=0. GEOTHA(4,M,I)=0. ENDIF 90 CONTINUE 100 CONTINUE C C MANTLE LITHOSPHERE LAYER C CALL TMOHO (THIKM,NUMEL,GEOTHM,BIGNUM,OUTSCA) DO 200 M=1,7 DO 190 I=1,NUMEL TBOT=OUTSCA(M,I) XLEFT=FROMWM(M,I) IF (TOUCHM(M,I).GE.0.99) THEN TBOTC=TSLAB(TSURF,TSLAB0,XLEFT,ONEKM) ELSE TBOTC=TASTH ENDIF CORREC=TBOTC-TBOT GEOTHM(4,M,I)=GEOTHM(4,M,I)+CORREC/THIKM(M,I)**3 190 CONTINUE 200 CONTINUE C C CRUSTAL LAYER C DO 220 M=1,7 DO 210 I=1,NUMEL OUTSCA(M,I)=GEOTHM(1,M,I) 210 CONTINUE 220 CONTINUE CALL EXTRAP (INPUT,AREAM,DETJM,LOCKIN,LOCKWC,PHINOD,OUTSCA, + OUTPUT,CONDNS) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 300 M=1,7 DO 290 I=1,NUMEL D=THIKC(M,I) TBASE=GEOTHC(1,M,I)+ + GEOTHC(2,M,I)*D+ + GEOTHC(3,M,I)*D**2+ + GEOTHC(4,M,I)*D**3 I2=DNLINK(1,M,I) IF (I2.GT.0) THEN TBOT=OUTSCA(M,I) ELSE IF (TOUCHC(M,I).GE.0.99) THEN XLEFT=FROMWC(M,I) TBOT=TSLAB(TSURF,TSLAB0,XLEFT,ONEKM) ELSE TBOT=GEOTHA(1,M,I) ENDIF ENDIF CORREC=TBOT-TBASE GEOTHC(4,M,I)=GEOTHC(4,M,I)+CORREC/THIKC(M,I)**3 290 CONTINUE 300 CONTINUE RETURN END SUBROUTINE SETCUB C C C REAL FUNCTION TSLAB(TSURF,TSLAB0,XLEFT,ONEKM) C C COMPUTES SLAB-SURFACE TEMPERATURE BASED ON X**1/3 INCREASE C REAL ONEKM,TSLAB0,TSURF,X,XLEFT X=MAX(XLEFT,1.) TSLAB=TSURF+(TSLAB0-TSURF)*(X/(1000.*ONEKM))**0.333 RETURN END FUNCTION TSLAB C C C SUBROUTINE BELOW (INPUT,ECLOG,FROMW,IBELOWINDEX, + NELCOL,NUMEL, + PUSHUP,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP, + OUTPUT,SZZ,TOUCH,VSLAB) C C SELECTS ONE OF THE POSSIBLE SLAB MODEL FOR THE BOTTOM BC. C 0 = NO CONTACT OF SLABS WITH BASE OF MODEL (NULL B.C.) C 1 = NORTH AMERICA (NORTHERN OPTION) C 2 = NORTH AMERICA (SOUTHERN OPTION) C 3 = ROUGH VERSION OF SOUTH AMERICAN (SIERRA DE PAMPEANAS) C 4 = ROUGH VERSION OF CHINA (SHORT 200 KM UNDERTHRUST) C 5 = ? C REAL FROMW,SZZ,TOUCH,VSLAB,XIP,YIP DIMENSION FROMW(7,NUMEL),SZZ(7,NUMEL),TOUCH(7,NUMEL), + VSLAB(2,7,NUMEL),XIP(7,NUMEL), + YIP(7,NUMEL) C IF (IBELOWINDEX.EQ.0) THEN CALL BELOW0(INPUT,NUMEL, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOWINDEX.EQ.1) THEN CALL BELOW1(INPUT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOWINDEX.EQ.2) THEN CALL BELOW2(INPUT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOWINDEX.EQ.3) THEN CALL BELOW3(INPUT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOWINDEX.EQ.4) THEN CALL BELOW4(INPUT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP, + OUTPUT,SZZ,TOUCH,VSLAB) C ELSE IF (IBELOWINDEX.EQ.5) THEN C CALL BELOW5(INPUT,ECLOG,FROMW, C + NELCOL,NUMEL, C + PUSHUP,RAMP,SLABSZ,TIME, C + WANDES,XIP,YIP, C + OUTPUT,SZZ,TOUCH,VSLAB) ENDIF RETURN END SUBROUTINE BELOW C C C SUBROUTINE BELOW0(INPUT,NUMEL, + OUTPUT,SZZ,TOUCH,VSLAB) C C NULL BOUNDARY CONDITIONS (NO CONTACT) C DIMENSION SZZ(7,NUMEL),TOUCH(7,NUMEL),VSLAB(2,7,NUMEL) C DO 20 M=1,7 DO 10 I=1,NUMEL SZZ(M,I)=0. TOUCH(M,I)=0. VSLAB(1,M,I)=0. VSLAB(2,M,I)=0. 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE BELOW0 C C C SUBROUTINE BELOW1(INPUT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP, + OUTPUT,SZZ,TOUCH,VSLAB) C C "BELOW1" REPRESENTS THE NORTHERN OPTION FOR NORTH AMERICA C REAL FROMW,SZZ,TOUCH,VSLAB,XIP,YIP DIMENSION FROMW(7,NUMEL),SZZ(7,NUMEL),TOUCH(7,NUMEL), + VSLAB(2,7,NUMEL),XIP(7,NUMEL), + YIP(7,NUMEL) C===================================================================== C C ALL DATA NECESSARY TO DEFINE OCEANIC SLAB MOTIONS, AGES, AND C AREAS OF CONTACT WITH NORTH AMERICA UNDER ENGEBRETSON'S C "NORTHERN OPTION": KULA/VANCOUVER TRIPLE JUNCTION IN PACIFIC C NORTHWEST NEAR USA/CANADA BORDER. C C***************************************************************** C C COMMENTS ON COORDINATES AND UNITS C MOST OF THE DATA IN THIS UNIT ARE IN ROUND-EARTH COORDINATES C OF (LATITUDE,LONGITUDE). THE UNITS ARE DEGREES; FOR MORE C PRECISION WE USE DECIMAL FRACTIONS OF DEGREES INSTEAD OF C MINUTES AND/OR SECONDS OF ARC. LATITUDE IS POSITIVE IN THE C NORTHERN HEMISPHERE. LONGITUDE IS POSITIVE EAST OF C GREENWICH, ENGLAND. C THE FINITE-ROTATION MATRICES (3 X 3) AND THE ROTATION-AXIS C VECTORS (3 X 1) USE A DIFFERENT COORDINATE SYSTEM. C IT IS CARTESIAN (X,Y,Z), WITH ITS ORIGIN AT THE CENTER C OF THE EARTH. X POINTS TOWARD (LAT=0, LON=0). C Y POINTS TOWARD (LAT=0, LON=90). Z POINTS TOWARD (LAT=90). C THE UNITS DIFFER: THE FINITE-ROTATION MATRICES ARE C DIMENSIONLESS, BUT THE ROTATION-RATE VECTORS ARE IN C RADIANS PER SECOND. C THE GEOLOGIC TIMES WHICH LABEL THE VARIOUS FEATURES ARE C EXPRESSED IN MILLIONS OF YEARS (POSITIVE = PAST). THE C LENGTH OF 1 MILLION YEARS IN THE FUNDAMENTAL TIME UNIT C (THE SECOND) IS EXPRESSED BY "TUMAP". C C---------------------------------------------------------------- C GLOSSARY OF DATA: C -AGEFZ(J,I) IS THE AGE OF FRACTURE ZONE POINT #J C IN STRIP #I. (USED BY EDITOR, NOT BY BELOWY) C -AGEHNG(I) IS THE AGE OF THE HINGELINE CURVE K C DEFINED BY REHING(I=1,2;J=1,40?;K). C -AGEKV(I) IS THE AGE OF THE KULA/VANCOUVER/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REKV3J(1-3,I). C -AGEMAG(I,J) IS THE AGE OF MAGNETIC ANOMALY I (FROM W TO E) C IN STRIPE J (FROM S TO N) ON THE PRESENT-AGE MAP. C -AGEROT(I) IS THE AGE OF THE FINITE ROTATION MATRICES C ROMATF, ROMATK, ROMATP, AND ROMATV WITH AGE INDEX I. C -AGEVEL(I) IS THE AGE OF THE RELATIVE ROTATION-AXIS VECTORS C OMEGAF, OEMGAK, OMEGAP, AND OMEGAV WITH AGE INDEX I. C -AGEVF(I) IS THE AGE OF THE VANCOUVER/FARALLON/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REVF3J(1-3,I). C -FRACZN(2,I,J) ARE THE LAT. AND LON. COORDINATES OF POINTS I C (W TO E) ALONG FRACTURE ZONE J (S TO N) ON THE MAP OF C PRESENT SLAB AGES. C -NKV3J IS THE NUMBER OF KULA/VANCOUVER/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REKV3J(1-3,I) AT AGE AGEKV(I). C -NMAG(K) IS THE NUMBER OF LINEAR MAGNETIC ANOMALIES C WITHIN STRIPE K (S TO N) OF THE MAP OF PRESENT SLAB C AGES. C -NPHING(I) IS THE NUMBER C OF DIGITIZED POINTS IN HINGELINE CURVE #I OF REHING. C -NPFZ(J) IS THE NUMBER OF POINTS (W TO E) DEFINING FRACTURE ZONE C J (S TO N) ON THE MAP OF PRESENT SLAB AGES. C -NROMAT IS THE NUMBER OF FINITE-ROTATION MATRICES C GIVEN FOR EACH PLATE. C -NVF3J IS THE NUMBER OF VANCOUVER/FARALLON/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REVF3J(1-3,I) AT AGE AGEVF(I). C -NTAPES IS THE NUMBER OF STRIPS OF MAGNETIC ANOMALIES ON C THE MAP OF PRESENT SLAB AGES; ONE LESS THAN THE NUMBER OF C FRACTURE ZONES ON THE MAP. C -NUMHNG IS THE NUMBER OF SLAB HINGELINES (AT DIFFERENT TIMES). C -NUMVEL IS THE NUMBER OF AGES AGEVEL(I) WHERE RELATIVE C ROTATION-AXIS VECTORS (OMEGAF/K/P/V) ARE SUPPLIED. C -OMEGAF(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE FARALLON C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAK(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE KULA C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAP(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE PACIFIC C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAV(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE VANCOUVER C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -REHING(I,J,K) ARE THE LAT. (I=1) AND LON. (I=2) COORDINATES C OF THE DIGITIZED POINT #J (N TO S) OF THE HINGELINE C CURVE #K (PAST TO PRESENT). C -REKV3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE KULA/ C VANCOUVER/NORTH AMERICAN TRIPLE-JUNCTION AT AGE AGEKV(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -REMAG(2,2,I,J) ARE THE LAT., LON. COORDINATES (1ST SUB.) C OF THE N AND S ENDS (2ND SUB.) OF THE LINEAR MAGNETIC C ANOMALY I (W TO E) IN STRIPE J (S TO N) OF THE C PRESENT SLAB AGE MAP. C -REVF3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE C VANCOUVER/FARALLON/N.A. TRIPLE-JUNCTION AT AGE AGEVF(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -ROMATF(3,3,K) ARE THE ROTATION MATRICES FOR FARALLON WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATK(3,3,K) ARE THE ROTATION MATRICES FOR KULA WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATP(3,3,K) ARE THE ROTATION MATRICES FOR PACIFIC WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATV(3,3,K) ARE THE ROTATION MATRICES FOR VANCOUVER WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -TAGFZ(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE FRACTURE ZONE POINT #I C IN STRIP #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TAGMAG(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE MAGNETIC ANOM. #I IN STRIP C #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TUMAP IS A CONVENIENCE MULTIPLIER APPLIED TO AGES IN M.Y. C TO OBTAIN THE TRUE AGE IN PROGRAM UNITS (SECONDS). C------------------------------------------------------------------ C C MEMO: ORDER IS: PARAMETER, TYPE, COMMON, DIMENSION, DATA C C********************************************************************* C C NOTE: THESE DIMENSION PARAMETERS MUST AGREE C IN ALL PROGRAMS !!!!!! C C MAXIMUM NUMBER OF DIGITISED SLAB HINGELINES: PARAMETER (MAXHL=20) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED HINGELINE: PARAMETER (MAXHNG=40) C MAXIMUM NUMBER OF FINITE ROTATIONS FOR EACH PLATE: PARAMETER (MAXROT=21) C MAXIMUM NUMBER OF RELATIVE ROTATION-AXIS VECTORS FOR EACH PLATE: PARAMETER (MAXVEL=20) C MAXIMUM NUMBER OF AGES WHEN KULA/VANCOUVER TRIPLE-JUNCTION IS GIVEN: PARAMETER (MXKV3J =50) C MAXIM.NUMBER OF AGES WHEN VANCOUVER/FARALLON TRIPLE-JUNCTION IS GIVEN PARAMETER (MXVF3J =50) C MAXIMUM NUMBER OF STRIPS OF SEAFLOOR (BETWEEN FRACTURE ZONES) ON MAP: PARAMETER (MTAPES =40,MTAPP1=41) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED FRACTURE ZONE: PARAMETER (MAXFZP=100) C MAXIMUM NUMBER OF MAGNETIC ANOMALIES IN ANY ONE STRIP: PARAMETER (MAXMAG=100) C********************************************************************* CHARACTER*1 TAGFZ,TAGMAG C-------------------------------------------------------------------- DIMENSION AGEFZ(MAXFZP,MTAPP1), 2 AGEHNG(MAXHL), 3 AGEKV(MXKV3J), 4 AGEMAG(MAXMAG,MTAPES), 5 AGEROT(MAXROT), 6 AGEVEL(MAXVEL), 7 AGEVF(MXVF3J), 8 FRACZN(2,MAXFZP,MTAPP1), 9 NPFZ(MTAPP1), A NPHING(MAXHNG) DIMENSION NMAG(MTAPES), 2 OMEGAF(3,MAXVEL), 3 OMEGAK(3,MAXVEL), 4 OMEGAP(3,MAXVEL), 5 OMEGAV(3,MAXVEL), 6 REHING(2,MAXHNG,MAXHL), 7 REKV3J(3,MXKV3J), 8 REMAG(2,2,MAXMAG,MTAPES), 9 REVF3J(3,MXVF3J), A ROMATF(3,3,MAXROT), 1 ROMATK(3,3,MAXROT), 2 ROMATP(3,3,MAXROT), 3 ROMATV(3,3,MAXROT), 4 TAGFZ(MAXFZP,MTAPP1), 5 TAGMAG(MAXMAG,MTAPES) C C===1=== SLAB HINGELINES ======================= C DATA NUMHNG / 14/ DATA TUMAP /3.15576E13/ DATA (AGEHNG(I),I=1, 14) / + 90.00, 80.00, 75.00, 65.00, 55.00, 45.00, 40.00, 35.00, + 30.00, 27.50, 20.00, 10.00, 0.00, -3.00 + / DATA (NPHING(I),I=1, 14) / + 29, 29, 33, 34, 31, 35, 32, 26, 31, 30, 30, 27, 31, 31 + / DATA ((REHING(I,J, 1),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.90,-121.85, 43.38,-120.70, 42.52,-119.85, + 41.41,-119.40, 40.22,-119.68, 38.73,-120.43, 37.05,-120.49, + 35.67,-120.08, 34.56,-118.00, 33.44,-115.89, 31.28,-114.73, + 29.55,-112.79, 27.91,-110.89, 26.28,-109.05, 24.78,-107.50, + 23.20,-106.00, 21.79,-104.58, 20.16,-103.23, 18.28,-101.73, + 16.37,-100.36 + / DATA ((REHING(I,J, 2),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.90,-121.85, 43.38,-120.70, 42.52,-119.85, + 41.41,-119.40, 40.22,-119.68, 38.73,-120.43, 37.05,-120.49, + 35.67,-120.08, 34.56,-118.00, 33.44,-115.89, 31.28,-114.73, + 29.55,-112.79, 27.91,-110.89, 26.28,-109.05, 24.78,-107.50, + 23.20,-106.00, 21.79,-104.58, 20.16,-103.23, 18.28,-101.73, + 16.37,-100.36 + / DATA ((REHING(I,J, 3),I=1,2),J=1, 33) / + 60.24,-142.90, 58.27,-136.08, 57.06,-133.84, 55.56,-132.30, + 54.31,-131.06, 52.34,-129.57, 50.99,-128.46, 49.68,-127.62, + 48.64,-126.31, 47.41,-124.10, 46.20,-121.40, 45.21,-118.79, + 44.38,-116.32, 43.59,-113.87, 42.71,-111.45, 41.95,-110.30, + 40.87,-109.75, 39.46,-109.53, 38.07,-109.47, 36.40,-109.69, + 34.97,-110.12, 33.38,-111.48, 32.18,-112.63, 31.23,-113.29, + 30.55,-113.21, 29.70,-112.07, 28.45,-110.41, 26.85,-108.26, + 25.03,-106.06, 22.76,-103.36, 20.40,-100.83, 18.53, -98.91, + 15.76, -95.35 + / DATA ((REHING(I,J, 4),I=1,2),J=1, 34) / + 59.74,-142.93, 57.85,-135.98, 57.15,-134.10, 56.01,-132.85, + 54.68,-131.71, 52.77,-130.21, 50.90,-128.84, 49.63,-127.75, + 48.60,-126.11, 47.65,-124.22, 47.03,-122.13, 46.41,-119.25, + 46.11,-116.86, 45.83,-114.22, 45.56,-111.04, 45.24,-108.41, + 44.65,-106.77, 43.72,-105.66, 42.82,-105.87, 41.25,-106.39, + 39.96,-107.68, 38.23,-109.58, 36.53,-111.05, 34.82,-112.31, + 33.11,-113.12, 32.14,-113.13, 31.23,-112.40, 30.09,-111.04, + 28.34,-108.86, 26.70,-106.84, 24.65,-104.56, 22.44,-102.17, + 18.04, -97.90, 14.33, -93.82 + / DATA ((REHING(I,J, 5),I=1,2),J=1, 31) / + 60.18,-142.67, 58.34,-135.99, 57.39,-133.91, 55.54,-131.68, + 53.24,-129.30, 51.45,-127.33, 49.34,-124.96, 47.58,-122.87, + 45.85,-120.92, 44.34,-118.67, 43.75,-116.92, 43.72,-114.46, + 43.59,-111.55, 43.34,-108.91, 42.86,-107.05, 42.13,-105.45, + 41.13,-104.87, 40.08,-104.90, 38.70,-105.39, 37.13,-106.70, + 35.70,-107.90, 34.13,-109.17, 32.75,-109.71, 31.34,-109.71, + 30.37,-109.16, 29.06,-107.62, 26.11,-104.35, 22.91,-101.21, + 20.18, -98.61, 18.86, -97.37, 15.81, -93.90 + / DATA ((REHING(I,J, 6),I=1,2),J=1, 35) / + 59.65,-143.76, 57.90,-136.31, 57.31,-134.75, 56.45,-133.35, + 55.25,-132.01, 53.95,-130.78, 52.54,-129.43, 50.88,-127.99, + 49.81,-126.43, 49.25,-124.90, 48.58,-123.85, 47.46,-122.86, + 46.31,-121.77, 44.75,-120.30, 43.36,-119.35, 41.49,-118.46, + 40.66,-117.90, 40.03,-116.96, 39.46,-115.55, 39.13,-113.64, + 38.99,-111.33, 38.87,-108.52, 38.77,-106.09, 38.39,-104.45, + 38.00,-103.53, 37.37,-103.42, 35.34,-103.89, 32.58,-104.54, + 29.82,-105.05, 27.44,-105.42, 24.90,-103.03, 22.70,-101.09, + 20.05, -98.86, 17.88, -96.95, 14.95, -94.01 + / DATA ((REHING(I,J, 7),I=1,2),J=1, 32) / + 60.15,-144.12, 58.32,-136.58, 57.58,-134.52, 55.82,-132.18, + 53.60,-130.20, 51.68,-128.54, 50.56,-127.44, 49.48,-125.13, + 48.21,-123.37, 45.85,-121.58, 43.62,-119.92, 41.89,-118.52, + 40.13,-116.35, 39.11,-114.39, 38.47,-112.91, 38.07,-111.01, + 37.86,-108.95, 37.68,-106.27, 37.11,-104.05, 36.49,-103.28, + 35.59,-103.92, 33.92,-105.34, 32.65,-107.07, 31.58,-108.11, + 30.77,-108.67, 30.04,-107.87, 28.35,-106.21, 25.94,-103.92, + 23.23,-101.36, 19.92, -98.62, 18.08, -97.05, 14.58, -93.85 + / DATA ((REHING(I,J, 8),I=1,2),J=1, 26) / + 60.73,-144.29, 58.48,-135.82, 56.96,-132.82, 54.44,-130.45, + 51.91,-128.35, 50.62,-126.85, 49.32,-124.72, 47.04,-122.53, + 45.09,-121.21, 43.27,-119.94, 41.70,-118.85, 39.66,-117.43, + 38.07,-115.05, 37.24,-112.97, 36.83,-110.87, 36.60,-109.39, + 36.22,-108.78, 35.56,-108.94, 33.64,-110.03, 32.23,-110.38, + 31.18,-109.93, 30.10,-108.77, 27.69,-106.20, 24.64,-103.37, + 19.55, -98.74, 14.66, -94.17 + / DATA ((REHING(I,J, 9),I=1,2),J=1, 31) / + 59.94,-142.45, 58.14,-135.36, 56.98,-133.18, 54.87,-131.29, + 52.93,-129.48, 51.68,-128.44, 50.98,-127.72, 50.43,-126.82, + 49.58,-125.10, 48.58,-123.85, 45.67,-121.39, 43.86,-120.19, + 41.92,-118.74, 39.65,-117.67, 38.14,-116.22, 37.34,-114.59, + 36.86,-113.27, 36.59,-112.50, 36.18,-112.04, 35.60,-111.96, + 34.88,-112.15, 34.29,-112.49, 33.70,-112.81, 32.69,-112.03, + 31.73,-110.98, 29.66,-108.65, 27.54,-106.42, 24.80,-103.95, + 23.88,-103.22, 18.54, -98.67, 14.42, -94.83 + / DATA ((REHING(I,J, 10),I=1,2),J=1, 30) / + 60.05,-142.71, 58.15,-135.55, 57.19,-133.78, 55.93,-132.21, + 54.27,-130.67, 53.02,-129.56, 51.61,-128.52, 50.80,-127.58, + 50.24,-126.63, 49.34,-124.96, 48.34,-123.62, 47.04,-122.53, + 45.82,-121.46, 44.32,-120.36, 42.71,-119.19, 40.97,-118.24, + 39.38,-117.47, 38.13,-116.62, 36.88,-115.49, 35.88,-114.63, + 35.07,-113.90, 34.07,-113.38, 32.72,-112.14, 31.60,-110.78, + 29.45,-108.57, 27.14,-106.05, 24.28,-103.50, 21.45,-101.15, + 18.32, -98.45, 14.79, -95.22 + / DATA ((REHING(I,J, 11),I=1,2),J=1, 30) / + 60.40,-143.60, 58.26,-135.89, 57.30,-133.82, 55.79,-132.11, + 54.09,-130.51, 52.22,-128.93, 50.89,-127.65, 50.16,-126.36, + 48.98,-124.38, 47.60,-123.01, 45.84,-122.17, 43.62,-121.86, + 41.51,-121.12, 39.45,-120.08, 37.52,-118.43, 36.38,-117.33, + 35.75,-116.30, 35.15,-114.95, 34.51,-113.95, 33.50,-113.29, + 32.45,-112.66, 31.69,-112.09, 30.03,-110.31, 28.29,-108.49, + 26.74,-106.94, 24.73,-105.04, 22.76,-103.43, 19.82,-100.93, + 18.03, -99.36, 15.25, -96.89 + / DATA ((REHING(I,J, 12),I=1,2),J=1, 27) / + 60.42,-144.51, 58.53,-136.13, 57.88,-134.36, 56.05,-132.25, + 54.05,-130.39, 52.11,-128.80, 50.74,-127.47, 50.15,-126.46, + 49.50,-125.28, 48.27,-123.80, 47.15,-122.81, 46.39,-122.50, + 45.08,-122.44, 43.55,-122.58, 41.65,-121.97, 39.91,-120.91, + 38.15,-119.72, 36.58,-117.83, 34.34,-115.15, 31.39,-111.97, + 28.32,-108.97, 26.00,-106.84, 23.14,-104.47, 21.37,-103.15, + 20.03,-101.83, 18.36,-100.47, 13.50, -94.94 + / DATA ((REHING(I,J, 13),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / DATA ((REHING(I,J, 14),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / C C===2=== CODE GENERATED BY PROGRAM "ALL4" PLATE ROTATER: ===== C DATA NROMAT / 18/ DATA (AGEROT(I),I=1, 18) / + 0.00, 3.63, 10.30, 19.90, 25.80, 30.00, 35.60, 42.00, + 49.55, 58.90, 68.50, 72.40, 85.00, 119.00, 127.00, 135.00, + 145.00, 163.00 + / DATA ((ROMATF(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATF(I,J, 2),J=1,3),I=1,3) +/ 0.9984418, 0.0249586, 0.0499063, + -0.0236761, 0.9993781,-0.0261258, + -0.0505273, 0.0249035, 0.9984120/ DATA ((ROMATF(I,J, 3),J=1,3),I=1,3) +/ 0.9965000,-0.0015017, 0.0835752, + 0.0016967, 0.9999958,-0.0022638, + -0.0835716, 0.0023977, 0.9964986/ DATA ((ROMATF(I,J, 4),J=1,3),I=1,3) +/ 0.9870884,-0.0794135, 0.1391012, + 0.0779809, 0.9968305, 0.0157267, + -0.1399093,-0.0046764, 0.9901530/ DATA ((ROMATF(I,J, 5),J=1,3),I=1,3) +/ 0.9816186,-0.0953112, 0.1653471, + 0.0902718, 0.9952011, 0.0377464, + -0.1681514,-0.0221263, 0.9855123/ DATA ((ROMATF(I,J, 6),J=1,3),I=1,3) +/ 0.9772222,-0.1307292, 0.1671685, + 0.1217395, 0.9905611, 0.0629824, + -0.1738244,-0.0411969, 0.9839141/ DATA ((ROMATF(I,J, 7),J=1,3),I=1,3) +/ 0.9643680,-0.2176023, 0.1504717, + 0.2023463, 0.9730743, 0.1103661, + -0.1704363,-0.0759863, 0.9824339/ DATA ((ROMATF(I,J, 8),J=1,3),I=1,3) +/ 0.9355122,-0.3127865, 0.1642541, + 0.2875628, 0.9442505, 0.1603019, + -0.2052376,-0.1027311, 0.9733049/ DATA ((ROMATF(I,J, 9),J=1,3),I=1,3) +/ 0.8698806,-0.4633711, 0.1690941, + 0.4200012, 0.8755688, 0.2386968, + -0.2586591,-0.1366181, 0.9562580/ DATA ((ROMATF(I,J, 10),J=1,3),I=1,3) +/ 0.7665346,-0.5965531, 0.2377952, + 0.4980173, 0.7859663, 0.3663787, + -0.4054641,-0.1624160, 0.8995655/ DATA ((ROMATF(I,J, 11),J=1,3),I=1,3) +/ 0.6799753,-0.6748897, 0.2866260, + 0.4922036, 0.7098752, 0.5037958, + -0.5434762,-0.2014907, 0.8148823/ DATA ((ROMATF(I,J, 12),J=1,3),I=1,3) +/ 0.6364845,-0.7003338, 0.3231361, + 0.4905679, 0.6908776, 0.5310636, + -0.5951703,-0.1794939, 0.7832956/ DATA ((ROMATF(I,J, 13),J=1,3),I=1,3) +/ 0.5407817,-0.7359961, 0.4072609, + 0.3967867, 0.6501144, 0.6480033, + -0.7416956,-0.1888330, 0.6436048/ DATA ((ROMATF(I,J, 14),J=1,3),I=1,3) +/ 0.1260393,-0.9004962, 0.4161935, + 0.4084943, 0.4294313, 0.8054301, + -0.9040152, 0.0684970, 0.4219739/ DATA ((ROMATF(I,J, 15),J=1,3),I=1,3) +/ 0.0432563,-0.8638376, 0.5019060, + 0.3372753, 0.4855096, 0.8065493, + -0.9404098, 0.1343924, 0.3123534/ DATA ((ROMATF(I,J, 16),J=1,3),I=1,3) +/ -0.0372843,-0.8243719, 0.5648155, + 0.2585098, 0.5380124, 0.8023162, + -0.9652870, 0.1759245, 0.1930498/ DATA ((ROMATF(I,J, 17),J=1,3),I=1,3) +/ -0.0857564,-0.7854440, 0.6129592, + 0.2832710, 0.5706134, 0.7708135, + -0.9551961, 0.2397366, 0.1735606/ DATA ((ROMATF(I,J, 18),J=1,3),I=1,3) +/ -0.3959168,-0.6532624, 0.6453629, + 0.3365481, 0.5506653, 0.7638706, + -0.8543893, 0.5196268, 0.0018373/ DATA ((ROMATK(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATK(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATK(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATK(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATK(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATK(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATK(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATK(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATK(I,J, 9),J=1,3),I=1,3) +/ 0.8926937, 0.3237427, 0.3135092, + -0.3673854, 0.9256842, 0.0902017, + -0.2610084,-0.1957012, 0.9452911/ DATA ((ROMATK(I,J, 10),J=1,3),I=1,3) +/ 0.8382884, 0.2792339, 0.4682950, + -0.4014298, 0.8973089, 0.1835486, + -0.3689522,-0.3418544, 0.8642969/ DATA ((ROMATK(I,J, 11),J=1,3),I=1,3) +/ 0.7479138, 0.2368386, 0.6201060, + -0.4491286, 0.8684335, 0.2100139, + -0.4887816,-0.4355798, 0.7558849/ DATA ((ROMATK(I,J, 12),J=1,3),I=1,3) +/ 0.7069741, 0.2202590, 0.6720657, + -0.4550582, 0.8691026, 0.1938600, + -0.5413948,-0.4428831, 0.7146643/ DATA ((ROMATK(I,J, 13),J=1,3),I=1,3) +/ 0.4927713, 0.2023760, 0.8462971, + -0.5685837, 0.8111188, 0.1371042, + -0.6587012,-0.5487522, 0.5147643/ DATA ((ROMATK(I,J, 14),J=1,3),I=1,3) +/ 0.2884439,-0.0305855, 0.9570071, + -0.2699646, 0.9563414, 0.1119320, + -0.9186499,-0.2906443, 0.2675945/ DATA ((ROMATK(I,J, 15),J=1,3),I=1,3) +/ 0.1826985, 0.0447444, 0.9821491, + -0.2405134, 0.9706448, 0.0005196, + -0.9532956,-0.2363152, 0.1880977/ DATA ((ROMATK(I,J, 16),J=1,3),I=1,3) +/ 0.0730065, 0.1148067, 0.9907003, + -0.2118030, 0.9724770,-0.0970868, + -0.9745805,-0.2027456, 0.0953141/ DATA ((ROMATK(I,J, 17),J=1,3),I=1,3) +/ 0.0737035, 0.1703374, 0.9826242, + -0.1573972, 0.9749421,-0.1572000, + -0.9847798,-0.1430762, 0.0986680/ DATA ((ROMATK(I,J, 18),J=1,3),I=1,3) +/ -0.0087966, 0.2534258, 0.9673132, + 0.1625878, 0.9548408,-0.2486796, + -0.9866534, 0.1550863,-0.0496027/ DATA ((ROMATP(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATP(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATP(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATP(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATP(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATP(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATP(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATP(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATP(I,J, 9),J=1,3),I=1,3) +/ 0.9036663, 0.3323698, 0.2700321, + -0.3557910, 0.9336445, 0.0414807, + -0.2383270,-0.1335597, 0.9619573/ DATA ((ROMATP(I,J, 10),J=1,3),I=1,3) +/ 0.8783061, 0.3137228, 0.3607716, + -0.3583550, 0.9314973, 0.0624035, + -0.3164804,-0.1840937, 0.9305640/ DATA ((ROMATP(I,J, 11),J=1,3),I=1,3) +/ 0.8133826, 0.3327699, 0.4771508, + -0.4012021, 0.9148389, 0.0458976, + -0.4212428,-0.2287661, 0.8776220/ DATA ((ROMATP(I,J, 12),J=1,3),I=1,3) +/ 0.7885006, 0.3410243, 0.5118291, + -0.4008002, 0.9161383, 0.0070450, + -0.4665038,-0.2106962, 0.8590583/ DATA ((ROMATP(I,J, 13),J=1,3),I=1,3) +/ 0.6594428, 0.4211499, 0.6227100, + -0.4718215, 0.8767433,-0.0933034, + -0.5852515,-0.2322797, 0.7768697/ DATA ((ROMATP(I,J, 14),J=1,3),I=1,3) +/ 0.5735050, 0.5730298, 0.5854303, + -0.4726608, 0.8151487,-0.3348495, + -0.6690916,-0.0846720, 0.7383407/ DATA ((ROMATP(I,J, 15),J=1,3),I=1,3) +/ 0.5466521, 0.6209800, 0.5617428, + -0.4979524, 0.7804186,-0.3781402, + -0.6732122,-0.0730101, 0.7358360/ DATA ((ROMATP(I,J, 16),J=1,3),I=1,3) +/ 0.5130962, 0.6671163, 0.5400814, + -0.5285266, 0.7413454,-0.4136018, + -0.6763074,-0.0732298, 0.7329704/ DATA ((ROMATP(I,J, 17),J=1,3),I=1,3) +/ 0.5677590, 0.7006614, 0.4321147, + -0.5501299, 0.7134408,-0.4340037, + -0.6123779, 0.0086904, 0.7905173/ DATA ((ROMATP(I,J, 18),J=1,3),I=1,3) +/ 0.7427920, 0.5855252, 0.3246846, + -0.3852086, 0.7703925,-0.5080448, + -0.5476077, 0.2523004, 0.7977908/ DATA ((ROMATV(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATV(I,J, 2),J=1,3),I=1,3) +/ 0.9993297, 0.0051820, 0.0362338, + -0.0047712, 0.9999232,-0.0114144, + -0.0362902, 0.0112339, 0.9992780/ DATA ((ROMATV(I,J, 3),J=1,3),I=1,3) +/ 0.9966072,-0.0024635, 0.0822646, + 0.0025242, 0.9999963,-0.0006345, + -0.0822628, 0.0008400, 0.9966100/ DATA ((ROMATV(I,J, 4),J=1,3),I=1,3) +/ 0.9874673,-0.0822613, 0.1346872, + 0.0813513, 0.9966096, 0.0122550, + -0.1352387,-0.0011445, 0.9908120/ DATA ((ROMATV(I,J, 5),J=1,3),I=1,3) +/ 0.9769385,-0.0981460, 0.1896242, + 0.0957089, 0.9951658, 0.0219901, + -0.1908659,-0.0033342, 0.9816099/ DATA ((ROMATV(I,J, 6),J=1,3),I=1,3) +/ 0.9672080,-0.1004198, 0.2332878, + 0.0970278, 0.9949411, 0.0260009, + -0.2347188,-0.0025129, 0.9720595/ DATA ((ROMATV(I,J, 7),J=1,3),I=1,3) +/ 0.9578496,-0.1985734, 0.2075841, + 0.1860558, 0.9794068, 0.0783809, + -0.2188739,-0.0364552, 0.9750712/ DATA ((ROMATV(I,J, 8),J=1,3),I=1,3) +/ 0.9285972,-0.3330147, 0.1637273, + 0.3143928, 0.9404002, 0.1296231, + -0.1971359,-0.0688933, 0.9779518/ DATA ((ROMATV(I,J, 9),J=1,3),I=1,3) +/ 0.8519540,-0.5116365, 0.1113576, + 0.4857856, 0.8516892, 0.1965587, + -0.1954090,-0.1133634, 0.9741470/ DATA ((ROMATV(I,J, 10),J=1,3),I=1,3) +/ 0.7341714,-0.6763662, 0.0593198, + 0.6286086, 0.7101420, 0.3170907, + -0.2565954,-0.1955106, 0.9465370/ DATA ((ROMATV(I,J, 11),J=1,3),I=1,3) +/ 0.6687082,-0.7369352, 0.0987580, + 0.6230298, 0.6278643, 0.4664944, + -0.4057837,-0.2504201, 0.8789921/ DATA ((ROMATV(I,J, 12),J=1,3),I=1,3) +/ 0.6332583,-0.7620972, 0.1348656, + 0.6199963, 0.6038375, 0.5009806, + -0.4632338,-0.2336346, 0.8548840/ DATA ((ROMATV(I,J, 13),J=1,3),I=1,3) +/ 0.5726639,-0.7899240, 0.2192550, + 0.5270615, 0.5596170, 0.6395554, + -0.6279004,-0.2506902, 0.7368125/ DATA ((ROMATV(I,J, 14),J=1,3),I=1,3) +/ 0.1862030,-0.9539652, 0.2351070, + 0.4969981, 0.2978723, 0.8150220, + -0.8475366,-0.0349119, 0.5295847/ DATA ((ROMATV(I,J, 15),J=1,3),I=1,3) +/ 0.1202118,-0.9349756, 0.3337152, + 0.4187091, 0.3525420, 0.8368945, + -0.9001268, 0.0391250, 0.4338636/ DATA ((ROMATV(I,J, 16),J=1,3),I=1,3) +/ 0.0559588,-0.9094425, 0.4120423, + 0.3322897, 0.4061266, 0.8512579, + -0.9415139, 0.0892823, 0.3249255/ DATA ((ROMATV(I,J, 17),J=1,3),I=1,3) +/ 0.0035101,-0.8845617, 0.4664051, + 0.3494043, 0.4380954, 0.8282415, + -0.9369633, 0.1600573, 0.3106084/ DATA ((ROMATV(I,J, 18),J=1,3),I=1,3) +/ -0.3217998,-0.7897338, 0.5222647, + 0.3520011, 0.4122773, 0.8403078, + -0.8789400, 0.4542502, 0.1453171/ DATA NUMVEL / 17/ DATA (AGEVEL(I),I=1, 17) / + 1.81, 6.97, 15.10, 22.85, 27.90, 32.80, 38.80, 45.77, + 54.22, 63.70, 70.45, 78.70, 102.00, 123.00, 131.00, 140.00, + 154.00 + / DATA (OMEGAF(I, 1),I=1,3) + / 2.22436E-16, 4.37785E-16,-2.11997E-16/ DATA (OMEGAF(I, 2),I=1,3) + /-1.15243E-16, 1.59143E-16, 1.18424E-16/ DATA (OMEGAF(I, 3),I=1,3) + /-5.20186E-17, 1.86928E-16, 2.53471E-16/ DATA (OMEGAF(I, 4),I=1,3) + /-1.06009E-16, 1.52830E-16, 7.04799E-17/ DATA (OMEGAF(I, 5),I=1,3) + /-1.88225E-16, 3.57680E-17, 2.41271E-16/ DATA (OMEGAF(I, 6),I=1,3) + /-2.80863E-16,-4.69432E-17, 4.60480E-16/ DATA (OMEGAF(I, 7),I=1,3) + /-2.23587E-16, 1.34246E-16, 4.59035E-16/ DATA (OMEGAF(I, 8),I=1,3) + /-3.01794E-16, 1.52210E-16, 6.43195E-16/ DATA (OMEGAF(I, 9),I=1,3) + /-2.67001E-16, 4.56656E-16, 4.83609E-16/ DATA (OMEGAF(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAF(I, 11),I=1,3) + /-7.69435E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAF(I, 12),I=1,3) + /-1.10799E-16, 4.93623E-16, 8.32111E-17/ DATA (OMEGAF(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAF(I, 14),I=1,3) + / 3.42999E-16, 4.32696E-16, 1.46227E-16/ DATA (OMEGAF(I, 15),I=1,3) + / 2.93430E-16, 4.47830E-16, 9.47212E-17/ DATA (OMEGAF(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAF(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAK(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAK(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAK(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAK(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAK(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAK(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAK(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAK(I, 8),I=1,3) + /-3.42895E-16, 3.07318E-16,-7.84280E-18/ DATA (OMEGAK(I, 9),I=1,3) + /-5.24123E-16, 4.21964E-16,-6.28934E-17/ DATA (OMEGAK(I, 10),I=1,3) + /-3.47853E-16, 5.17207E-16,-6.26469E-17/ DATA (OMEGAK(I, 11),I=1,3) + /-1.29789E-16, 5.39917E-16, 7.00136E-17/ DATA (OMEGAK(I, 12),I=1,3) + /-2.25126E-16, 6.46717E-16,-2.10399E-16/ DATA (OMEGAK(I, 13),I=1,3) + /-8.79291E-17, 2.40344E-16, 3.43456E-16/ DATA (OMEGAK(I, 14),I=1,3) + / 3.42972E-16, 4.32656E-16, 1.46203E-16/ DATA (OMEGAK(I, 15),I=1,3) + / 2.93406E-16, 4.47800E-16, 9.47100E-17/ DATA (OMEGAK(I, 16),I=1,3) + / 1.91374E-16, 2.29230E-17, 1.74145E-16/ DATA (OMEGAK(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAP(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAP(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAP(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAP(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAP(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAP(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAP(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAP(I, 8),I=1,3) + /-7.95765E-17, 2.01210E-16, 3.16566E-17/ DATA (OMEGAP(I, 9),I=1,3) + /-1.82793E-16, 2.78850E-16, 6.21172E-18/ DATA (OMEGAP(I, 10),I=1,3) + /-1.10363E-16, 4.11618E-16,-1.28934E-16/ DATA (OMEGAP(I, 11),I=1,3) + / 1.61156E-16, 4.19784E-16, 1.56999E-17/ DATA (OMEGAP(I, 12),I=1,3) + / 7.46968E-17, 4.23581E-16,-2.19155E-16/ DATA (OMEGAP(I, 13),I=1,3) + / 2.04277E-16, 1.08618E-16,-2.84094E-17/ DATA (OMEGAP(I, 14),I=1,3) + / 1.92305E-16, 3.73766E-17,-1.42336E-16/ DATA (OMEGAP(I, 15),I=1,3) + / 1.61534E-16, 3.43348E-17,-1.77105E-16/ DATA (OMEGAP(I, 16),I=1,3) + / 2.87845E-16,-2.68429E-16, 6.23380E-17/ DATA (OMEGAP(I, 17),I=1,3) + / 2.19652E-16,-7.13669E-17, 4.34363E-16/ DATA (OMEGAV(I, 1),I=1,3) + / 9.86981E-17, 3.16045E-16,-4.33668E-17/ DATA (OMEGAV(I, 2),I=1,3) + /-5.14985E-17, 2.19222E-16, 3.33668E-17/ DATA (OMEGAV(I, 3),I=1,3) + /-3.52269E-17, 1.75936E-16, 2.61668E-16/ DATA (OMEGAV(I, 4),I=1,3) + /-2.56065E-17, 3.02977E-16, 8.26955E-17/ DATA (OMEGAV(I, 5),I=1,3) + / 2.38990E-18, 3.39059E-16, 1.81821E-17/ DATA (OMEGAV(I, 6),I=1,3) + /-3.14872E-16,-1.02187E-16, 5.04872E-16/ DATA (OMEGAV(I, 7),I=1,3) + /-3.01822E-16,-1.44934E-16, 6.45606E-16/ DATA (OMEGAV(I, 8),I=1,3) + /-3.48720E-16,-8.07761E-17, 7.85876E-16/ DATA (OMEGAV(I, 9),I=1,3) + /-4.42586E-16, 1.09988E-16, 6.53606E-16/ DATA (OMEGAV(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAV(I, 11),I=1,3) + /-7.83352E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAV(I, 12),I=1,3) + /-1.10796E-16, 4.93633E-16, 8.32232E-17/ DATA (OMEGAV(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAV(I, 14),I=1,3) + / 3.42996E-16, 4.32686E-16, 1.46215E-16/ DATA (OMEGAV(I, 15),I=1,3) + / 2.93417E-16, 4.47842E-16, 9.47149E-17/ DATA (OMEGAV(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAV(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ C C===3=== DATA MODIFIED BY PROGRAM MAPPER ========== C C DATA NTAPES/ 16/,NTAPP1/ 17/,NKV3J/ 10/,NVF3J/ 10/ C C C DATA ((REKV3J(K,I),K=1,3),I=1, 10) / + 47.22,-130.46, 55., + 47.22,-130.46, 55., + 47.37,-132.82, 57., + 46.03,-131.91, 56., + 47.00,-133.97, 57., + 47.00,-133.97, 57., + 45.34,-128.86, 54., + 45.61,-129.99, 60., + 44.68,-129.34, 62., + 43.82,-129.20, 68. +/ DATA ((REVF3J(K,I),K=1,3),I=1, 10) / + 27.33,-117.02, 45., + 27.33,-117.02, 45., + 28.46,-118.67, 47., + 25.76,-113.07, 33., + 25.76,-113.07, 30., + 25.21,-111.68, 35., + 25.21,-111.68, 41., + 25.18,-112.65, 32., + 23.90,-110.19, 13., + 22.30,-107.00, 37. +/ DATA (AGEKV(I),I=1, 10) / + 0.00, 10.00, 20.00, 30.00, 40.00, 50.00, 65.00, 70.00, + 80.00, 85.00 +/ DATA (AGEVF(I),I=1, 10) / + 0.00, 10.00, 20.00, 30.00, 35.00, 40.00, 45.00, 50.00, + 55.00, 59.00 +/ C C C DATA (NPFZ(I),I=1, 17) / + 8, 9, 15, 21, 22, 28, 27, 27, 26, 20, 24, 30, 30, 29, 21, + 20, 11 +/ DATA (TAGFZ(K, 1),K=1, 8)/ +'F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 1),K=1, 8) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 1),K=1,2),L=1, 8)/ + 15.59,-125.04, 13.99,-104.17, 18.00, -94.37, 22.63, -84.11, + 25.16, -72.25, 27.86, -59.95, 30.09, -47.05, 29.56, -29.71 +/ DATA (TAGFZ(K, 2),K=1, 9)/ +'F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 2),K=1, 9) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00 +/ DATA ((FRACZN(K,L, 2),K=1,2),L=1, 9)/ + 15.59,-125.04, 25.72,-127.26, 27.71,-115.36, 23.44,-108.71, + 24.29, -94.18, 26.26, -81.92, 27.86, -59.95, 30.09, -47.05, + 29.56, -29.71 +/ DATA (TAGFZ(K, 3),K=1, 15)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 3),K=1, 15) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 3),K=1,2),L=1, 15)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 33.12,-120.57, + 27.71,-115.36, 23.44,-108.71, 31.30,-106.70, 31.39,-103.19, + 32.24, -96.28, 33.58, -83.48, 33.79, -66.16, 34.07, -56.01, + 33.30, -41.56, 31.31, -28.46, 29.56, -29.71 +/ DATA (TAGFZ(K, 4),K=1, 21)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F','F','F','F' +/ DATA (AGEFZ(K, 4),K=1, 21) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 4),K=1,2),L=1, 21)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 36.45,-130.48, + 36.30,-126.03, 34.39,-122.15, 33.12,-120.57, 27.71,-115.36, + 23.44,-108.71, 31.30,-106.70, 32.70,-101.50, 34.31, -96.22, + 35.02, -88.82, 37.37, -83.32, 39.82, -75.01, 37.48, -62.38, + 37.01, -56.15, 36.54, -44.03, 33.32, -26.81, 31.48, -28.31, + 29.56, -29.71 +/ DATA (TAGFZ(K, 5),K=1, 22)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 5),K=1, 22) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 5),K=1,2),L=1, 22)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 36.45,-130.48, + 36.30,-126.03, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 36.42,-103.96, + 29.31,-101.67, 30.90, -96.66, 31.63, -89.64, 33.99, -84.45, + 36.50, -76.61, 34.42, -64.53, 34.10, -58.57, 33.95, -46.94, + 30.70, -28.71, 28.36, -30.08 +/ DATA (TAGFZ(K, 6),K=1, 28)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 6),K=1, 28) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 6),K=1,2),L=1, 28)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 38.52,-125.98, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 36.42,-103.96, + 35.36,-100.33, 35.80, -96.04, 36.04, -87.64, 38.61, -83.49, + 40.03, -80.83, 40.75, -75.99, 42.08, -66.09, 42.76, -61.85, + 43.50, -58.17, 43.78, -48.52, 43.64, -38.32, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 7),K=1, 27)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 7),K=1, 27) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 7),K=1,2),L=1, 27)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 40.13,-131.75, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 37.83,-103.02, + 37.69, -97.94, 37.99, -94.65, 38.48, -90.74, 40.03, -80.83, + 40.75, -75.99, 42.08, -66.09, 42.76, -61.85, 43.50, -58.17, + 43.78, -48.52, 43.64, -38.32, 39.77, -21.11, 37.19, -23.42, + 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 8),K=1, 27)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 8),K=1, 27) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 8),K=1,2),L=1, 27)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 40.13,-131.75, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 37.83,-103.02, + 37.69, -97.94, 37.99, -94.65, 38.48, -90.74, 40.81, -81.78, + 43.05, -68.36, 43.82, -63.06, 45.47, -56.57, 45.94, -47.80, + 45.72, -36.12, 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, + 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 9),K=1, 26)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 9),K=1, 26) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00 +/ DATA ((FRACZN(K,L, 9),K=1,2),L=1, 26)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 43.26,-132.97, 42.34,-124.68, 41.51,-118.95, 41.92,-115.31, + 41.70,-109.93, 40.37,-100.85, 40.35, -98.25, 40.77, -95.67, + 41.34, -93.12, 42.06, -90.61, 42.74, -81.88, 43.05, -68.36, + 43.82, -63.06, 45.47, -56.57, 45.94, -47.80, 45.72, -36.12, + 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, + 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 10),K=1, 20)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V' +/ DATA (AGEFZ(K, 10),K=1, 20) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 10),K=1,2),L=1, 20)/ + 43.39,-133.14, 44.73,-133.51, 42.34,-124.68, 43.15,-119.71, + 45.49,-114.27, 45.73,-108.43, 44.73,-102.56, 48.58, -98.79, + 48.87, -94.66, 48.55, -89.67, 46.70, -85.91, 69.49, -10.11, + 69.17, 10.62, 55.83, 1.28, 41.92, -19.06, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 11),K=1, 24)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 11),K=1, 24) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 11),K=1,2),L=1, 24)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 49.49,-131.97, 48.65,-126.37, 49.93,-120.40, + 49.94,-115.54, 49.91,-111.07, 49.39,-107.30, 48.78,-104.25, + 48.58, -98.79, 48.87, -94.66, 48.55, -89.67, 46.70, -85.91, + 69.17, 10.62, 55.83, 1.28, 41.92, -19.06, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 12),K=1, 30)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 12),K=1, 30) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 12),K=1,2),L=1, 30)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 55.58,-138.46, 52.86,-133.79, + 51.31,-131.53, 50.15,-129.79, 50.53,-127.83, 51.55,-125.28, + 54.00,-120.83, 53.90,-116.85, 53.81,-112.33, 53.25,-108.90, + 53.06,-105.09, 48.58, -98.79, 48.87, -94.66, 48.55, -89.67, + 46.70, -85.91, 69.49, -10.11, 69.17, 10.62, 55.83, 1.28, + 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, + 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 13),K=1, 30)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 13),K=1, 30) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 13),K=1,2),L=1, 30)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 55.58,-138.46, 52.86,-133.79, + 51.31,-131.53, 50.15,-129.79, 50.53,-127.83, 51.55,-125.28, + 54.00,-120.83, 55.81,-113.06, 55.98,-108.85, 54.64,-108.33, + 53.06,-105.09, 48.58, -98.79, 48.87, -94.66, 48.55, -89.67, + 46.70, -85.91, 69.49, -10.11, 69.17, 10.62, 55.83, 1.28, + 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, + 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 14),K=1, 29)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 14),K=1, 29) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 14),K=1,2),L=1, 29)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 55.58,-138.46, 52.86,-133.79, + 51.31,-131.53, 50.15,-129.79, 50.53,-127.83, 51.55,-125.28, + 54.00,-120.83, 55.81,-113.06, 55.98,-108.85, 61.58, -99.29, + 63.17, -92.95, 65.54, -77.50, 70.17, -57.40, 72.85, -26.14, + 69.67, -7.24, 69.17, 10.62, 55.83, 1.28, 41.92, -19.06, + 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, + 29.56, -29.71 +/ DATA (TAGFZ(K, 15),K=1, 21)/ +'K','K','K','K','K','K','K','K','K','K','K','K','K','K','K', +'K','K','K','K','K','K' +/ DATA (AGEFZ(K, 15),K=1, 21) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 15),K=1,2),L=1, 21)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 63.11,-144.77, 69.34,-141.39, + 76.98,-131.11, 80.85, -90.15, 78.29, -32.39, 71.63, -18.19, + 69.67, -7.24, 69.44, 10.88, 55.38, 1.77, 41.92, -19.06, + 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, + 29.56, -29.71 +/ DATA (TAGFZ(K, 16),K=1, 20)/ +'K','K','K','K','K','K','K','K','K','K','K','K','K','K','K', +'K','K','K','K','K' +/ DATA (AGEFZ(K, 16),K=1, 20) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 16),K=1,2),L=1, 20)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 63.11,-144.77, 71.17,-152.92, + 83.00,-147.32, 85.08, -74.45, 71.63, -18.19, 67.61, -18.68, + 63.46, -11.94, 55.38, 1.77, 41.92, -19.06, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 17),K=1, 11)/ +'K','K','K','K','K','K','K','K','K','K','K' +/ DATA (AGEFZ(K, 17),K=1, 11) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 17),K=1,2),L=1, 11)/ + 15.59,-125.04, 40.13,-131.75, 55.63,-139.27, 63.11,-144.77, + 71.21,-152.93, 83.00,-147.32, 89.93,-130.41, 69.44, 10.88, + 55.38, 1.77, 47.07, -12.56, 29.56, -29.71 +/ C C C DATA (NMAG(I),I=1, 16) / + 12, 15, 15, 17, 16, 8, 12, 13, 17, 9, 8, 5, 7, 2, 6, + 7 +/ DATA (TAGMAG(K, 1),K=1, 12)/ +'F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 1),K=1, 12) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 59.00, 63.40, + 67.00, 77.00,142.00,240.00 +/ DATA (((REMAG(K,L,M, 1),K=1,2),L=1,2),M=1, 12) / + 22.94,-108.62, 19.57,-110.03, 22.15,-107.81, 19.38,-108.80, + 20.73,-106.17, 18.90,-106.87, 25.27,-102.94, 16.40,-102.97, + 24.14,-101.56, 16.66,-101.66, 24.11, -97.49, 18.53, -96.65, + 25.83, -82.46, 21.44, -81.63, 26.16, -80.77, 21.81, -79.71, + 26.56, -80.43, 22.47, -79.16, 26.83, -75.41, 23.15, -73.96, + 26.47, -61.99, 24.12, -63.58, 35.79, -17.17, 29.70, -28.97 +/ DATA (TAGMAG(K, 2),K=1, 15)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 2),K=1, 15) / + 0.00, 10.00, 20.00, 27.50, 35.70, 49.30, 59.00, 63.40, + 67.00, 77.00,126.00,165.00,200.00,240.00,240.00 +/ DATA (((REMAG(K,L,M, 2),K=1,2),L=1,2),M=1, 15) / + 28.07,-108.81, 23.70,-108.58, 28.08,-108.55, 23.71,-108.33, + 31.00,-106.14, 24.87,-105.49, 31.43,-103.56, 24.04,-103.46, + 31.38, -99.00, 24.02, -98.31, 31.79, -96.01, 24.87, -94.72, + 32.55, -90.64, 25.62, -90.16, 32.71, -88.50, 25.76, -88.05, + 33.05, -87.18, 25.94, -86.84, 33.50, -82.33, 26.27, -82.02, + 33.49, -71.21, 29.07, -70.66, 33.40, -59.78, 27.89, -59.33, + 33.47, -44.61, 30.67, -44.49, 31.24, -28.50, 29.95, -29.65, + 35.78, -17.17, 29.70, -28.97 +/ DATA (TAGMAG(K, 3),K=1, 15)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 3),K=1, 15) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 63.40, 67.00, + 77.00,126.00,134.00,150.00,180.00,220.00,220.00 +/ DATA (((REMAG(K,L,M, 3),K=1,2),L=1,2),M=1, 15) / + 32.05,-106.51, 31.16,-106.49, 32.92,-101.69, 31.43,-102.34, + 35.03, -96.52, 31.78, -96.40, 35.86, -92.66, 32.07, -92.63, + 37.00, -88.90, 32.71, -88.77, 40.00, -82.70, 33.09, -83.14, + 40.55, -80.73, 33.40, -81.29, 41.06, -79.60, 33.70, -80.32, + 41.71, -74.07, 33.98, -74.48, 37.49, -61.88, 34.61, -62.56, + 37.06, -58.84, 35.72, -59.17, 37.31, -53.84, 34.26, -53.85, + 36.15, -42.30, 34.03, -42.67, 33.41, -27.01, 32.02, -29.38, + 32.32, -27.45, 31.81, -28.32 +/ DATA (TAGMAG(K, 4),K=1, 17)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F' +/ DATA (AGEMAG(K, 4),K=1, 17) / + -0.10, -0.10, 27.50, 27.50, 35.70, 42.00, 49.30, 49.30, + 59.00, 63.40, 67.00, 77.00,119.00,126.00,134.00,142.00, +180.00 +/ DATA (((REMAG(K,L,M, 4),K=1,2),L=1,2),M=1, 17) / + 39.48,-125.50, 36.47,-125.64, 33.37,-102.05, 32.77,-102.07, + 33.37,-102.01, 32.76,-102.04, 34.89,-100.23, 32.53,-101.45, + 35.80, -95.98, 33.75, -95.69, 35.91, -91.95, 33.90, -91.90, + 37.00, -88.90, 32.71, -88.77, 36.09, -87.77, 34.12, -87.61, + 38.37, -83.89, 36.72, -83.58, 38.84, -82.31, 37.04, -82.08, + 39.82, -81.29, 38.02, -80.97, 40.77, -75.75, 38.64, -75.29, + 42.43, -64.58, 37.38, -63.68, 42.80, -61.72, 37.48, -61.76, + 43.18, -58.52, 37.61, -58.25, 43.81, -56.52, 36.98, -55.19, + 42.15, -41.18, 36.43, -41.72 +/ DATA (TAGMAG(K, 5),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEMAG(K, 5),K=1, 16) / + 27.50, 27.50, 35.70, 42.00, 49.30, 49.30, 59.00, 63.40, + 67.00, 77.00,119.00,126.00,134.00,142.00,180.00,215.00 +/ DATA (((REMAG(K,L,M, 5),K=1,2),L=1,2),M=1, 16) / + 37.61,-102.97, 36.01,-103.23, 34.89,-100.23, 32.53,-101.45, + 35.80, -95.98, 33.75, -95.69, 35.91, -91.95, 33.90, -91.90, + 37.00, -88.90, 32.71, -88.77, 36.09, -87.77, 34.12, -87.61, + 38.37, -83.89, 36.72, -83.58, 38.84, -82.31, 37.04, -82.08, + 39.82, -81.29, 38.02, -80.97, 40.77, -75.75, 38.64, -75.29, + 42.43, -64.58, 37.38, -63.68, 42.80, -61.72, 37.48, -61.76, + 43.18, -58.52, 37.61, -58.25, 43.81, -56.52, 36.98, -55.19, + 42.15, -41.18, 36.43, -41.72, 39.57, -21.55, 34.89, -25.78 +/ DATA (TAGMAG(K, 6),K=1, 8)/ +'V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 6),K=1, 8) / + 20.00, 27.50, 32.00, 35.70, 42.00, 49.30, 55.00, 71.00 +/ DATA (((REMAG(K,L,M, 6),K=1,2),L=1,2),M=1, 8) / + 38.74,-107.22, 37.20,-107.17, 37.61,-102.97, 36.01,-103.23, + 38.12,-100.16, 35.41,-100.24, 37.64, -97.96, 35.97, -98.10, + 37.75, -94.67, 35.97, -94.69, 37.72, -90.93, 36.00, -90.81, + 38.64, -88.39, 35.91, -87.72, 40.21, -81.16, 39.83, -81.31 +/ DATA (TAGMAG(K, 7),K=1, 12)/ +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 7),K=1, 12) / + 62.00, 79.00, 95.00,110.00,119.00,126.00,134.00,142.00, +150.00,180.00,200.00,225.00 +/ DATA (((REMAG(K,L,M, 7),K=1,2),L=1,2),M=1, 12) / + 39.44, -88.34, 38.22, -88.67, 40.68, -82.76, 39.71, -82.44, + 41.87, -76.97, 40.64, -76.68, 42.45, -71.61, 41.21, -71.43, + 42.89, -66.57, 42.23, -66.39, 43.73, -63.26, 42.95, -63.29, + 44.17, -60.23, 43.21, -60.02, 44.81, -58.21, 43.63, -57.96, + 45.78, -55.81, 43.77, -55.76, 45.91, -43.51, 43.91, -43.72, + 46.09, -37.00, 43.63, -37.73, 41.88, -19.07, 39.99, -21.35 +/ DATA (TAGMAG(K, 8),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 8),K=1, 13) / + 0.10, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 59.00, 63.40, 67.00, 77.00,140.00 +/ DATA (((REMAG(K,L,M, 8),K=1,2),L=1,2),M=1, 13) / + 42.80,-126.60, 40.17,-127.40, 42.45,-125.24, 40.18,-126.21, + 42.51,-123.83, 38.69,-124.00, 41.42,-118.95, 38.25,-119.07, + 41.80,-115.62, 38.70,-116.11, 41.73,-112.10, 38.61,-112.52, + 41.22,-108.00, 38.01,-108.00, 40.63,-103.87, 36.89,-103.78, + 40.11, -97.66, 36.61, -96.10, 40.78, -95.88, 37.24, -94.53, + 41.28, -95.05, 37.77, -93.70, 42.76, -89.98, 39.26, -88.59, + 43.41, -68.81, 43.05, -69.05 +/ DATA (TAGMAG(K, 9),K=1, 17)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V' +/ DATA (AGEMAG(K, 9),K=1, 17) / + 9.50, 27.50, 35.70, 42.00, 49.30, 59.00, 63.40, 67.00, + 77.00,126.00,134.00,142.00,158.00,180.00,200.00,230.00, +240.00 +/ DATA (((REMAG(K,L,M, 9),K=1,2),L=1,2),M=1, 17) / + 42.51,-123.83, 38.69,-124.00, 45.28,-113.55, 41.70,-114.19, + 45.66,-109.22, 41.61,-109.93, 45.23,-105.57, 41.19,-105.83, + 44.74,-102.25, 40.68,-101.27, 48.49, -98.41, 41.04, -94.18, + 49.16, -96.77, 41.62, -92.72, 48.67, -95.63, 41.97, -92.33, + 48.34, -89.32, 43.41, -87.14, 51.47, -70.15, 46.67, -68.59, + 52.83, -66.31, 43.84, -63.15, 53.00, -64.55, 44.39, -60.75, + 54.93, -57.93, 45.45, -55.29, 63.49, -47.57, 46.98, -46.80, + 65.69, -34.67, 45.99, -39.55, 68.71, 10.51, 41.73, -25.13, + 57.25, 0.37, 42.36, -19.36 +/ DATA (TAGMAG(K, 10),K=1, 9)/ +'V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 10),K=1, 9) / + 0.10, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 60.00 +/ DATA (((REMAG(K,L,M, 10),K=1,2),L=1,2),M=1, 9) / + 48.86,-129.11, 44.10,-131.38, 47.85,-128.22, 44.65,-129.45, + 47.92,-125.54, 44.65,-125.76, 49.83,-120.18, 47.58,-120.37, + 49.83,-114.87, 45.98,-115.58, 49.89,-111.38, 45.89,-112.04, + 49.48,-107.86, 45.30,-108.35, 48.95,-104.30, 44.77,-103.58, + 48.60, -99.23, 47.85, -99.31 +/ DATA (TAGMAG(K, 11),K=1, 8)/ +'V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 11),K=1, 8) / + 0.10, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, 60.00 +/ DATA (((REMAG(K,L,M, 11),K=1,2),L=1,2),M=1, 8) / + 49.95,-129.96, 49.31,-130.63, 51.53,-125.42, 48.75,-125.65, + 53.85,-120.86, 50.28,-120.71, 53.84,-116.82, 50.00,-116.45, + 53.79,-112.59, 50.21,-113.72, 53.31,-108.95, 49.63,-109.89, + 52.91,-105.16, 49.01,-105.38, 48.91, -99.38, 48.31, -99.45 +/ DATA (TAGMAG(K, 12),K=1, 5)/ +'V','V','V','V','V' +/ DATA (AGEMAG(K, 12),K=1, 5) / + 14.00, 27.50, 35.70, 42.00, 42.00 +/ DATA (((REMAG(K,L,M, 12),K=1,2),L=1,2),M=1, 5) / + 54.22,-120.58, 53.91,-120.48, 55.81,-113.13, 53.94,-113.12, + 55.83,-108.54, 53.46,-109.23, 53.84,-107.23, 53.24,-107.45, + 53.34,-105.45, 52.87,-105.44 +/ DATA (TAGMAG(K, 13),K=1, 7)/ +'V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 13),K=1, 7) / + 42.00, 43.80, 49.30, 59.00, 67.00, 77.00, 85.00 +/ DATA (((REMAG(K,L,M, 13),K=1,2),L=1,2),M=1, 7) / + 56.52,-108.44, 54.25,-108.27, 61.48, -99.41, 54.64,-108.33, + 63.10, -92.77, 53.20,-105.10, 65.51, -77.34, 48.75, -98.53, + 70.04, -57.53, 48.58, -95.06, 71.04, -26.15, 48.63, -89.31, + 70.21, -6.99, 69.46, -12.71 +/ DATA (TAGMAG(K, 14),K=1, 2)/ +'V','V' +/ DATA (AGEMAG(K, 14),K=1, 2) / + -0.10, -0.10 +/ DATA (((REMAG(K,L,M, 14),K=1,2),L=1,2),M=1, 2) / + 57.02,-140.64, 55.42,-139.28, 72.18, -16.71, 71.47, -21.32 +/ DATA (TAGMAG(K, 15),K=1, 6)/ +'K','K','K','K','K','K' +/ DATA (AGEMAG(K, 15),K=1, 6) / + 42.00, 49.30, 59.00, 67.00, 77.00, 85.00 +/ DATA (((REMAG(K,L,M, 15),K=1,2),L=1,2),M=1, 6) / + 63.38,-145.67, 64.08,-143.46, 66.37,-147.24, 69.08,-141.77, + 70.85,-152.26, 76.54,-131.98, 74.46,-151.71, 80.44, -97.60, + 80.47,-148.87, 78.59, -34.84, 74.94, -20.15, 72.70, -21.28 +/ DATA (TAGMAG(K, 16),K=1, 7)/ +'K','K','K','K','K','K','K' +/ DATA (AGEMAG(K, 16),K=1, 7) / +142.00,142.00,158.00,180.00,200.00,230.00,240.00 +/ DATA (((REMAG(K,L,M, 16),K=1,2),L=1,2),M=1, 7) / + 84.28,-153.66, 83.57,-145.73, 84.28,-153.66, 83.57,-145.73, + 87.37,-138.07, 84.91,-130.52, 83.59, -0.71, 83.56, -59.44, + 76.84, 7.82, 79.05, -32.45, 61.44, 5.79, 64.48, -9.60, + 56.17, 3.42, 57.15, -0.30 +/ C C===================================================================== CALL BELOWY(INPUT,ECLOG,FROMW, 1 NELCOL,NUMEL, 2 PUSHUP,RAMP,SLABSZ,TIME, 3 WANDES,XIP,YIP, 4 MAXHL,MAXHNG,MAXROT,MAXVEL,MXKV3J,MXVF3J, 5 MTAPES,MTAPP1,MAXFZP,MAXMAG, 6 NKV3J, 7 NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, 8 TUMAP, 9 AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, A FRACZN,NMAG,NPFZ,NPHING, 1 OMEGAF,OMEGAK,OMEGAP,OMEGAV, 2 REHING,REKV3J,REMAG,REVF3J, 3 ROMATF,ROMATK,ROMATP,ROMATV, 4 TAGFZ,TAGMAG, 5 OUTPUT,SZZ,TOUCH,VSLAB) RETURN END SUBROUTINE BELOW1 C C C SUBROUTINE BELOW2(INPUT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP, + OUTPUT,SZZ,TOUCH,VSLAB) C C "BELOW2" REPRESENTS THE SOUTHERN OPTION FOR NORTH AMERICA. C REAL FROMW,SZZ,TOUCH,VSLAB,XIP,YIP DIMENSION FROMW(7,NUMEL),SZZ(7,NUMEL),TOUCH(7,NUMEL), + VSLAB(2,7,NUMEL),XIP(7,NUMEL), + YIP(7,NUMEL) C=============================================================== C ALL DATA NECESSARY TO DEFINE OCEANIC SLAB MOTIONS, AGES, AND C AREAS OF CONTACT WITH NORTH AMERICA UNDER ENGEBRETSON'S C "SOUTHERN OPTION": KULA/VANCOUVER TRIPLE JUNCTION INITIALLY C IN CENTRAL AMERICA, THEN MIGRATING NORTH ALONG COAST. C C***************************************************************** C C COMMENTS ON COORDINATES AND UNITS C MOST OF THE DATA IN THIS UNIT ARE IN ROUND-EARTH COORDINATES C OF (LATITUDE,LONGITUDE). THE UNITS ARE DEGREES; FOR MORE C PRECISION WE USE DECIMAL FRACTIONS OF DEGREES INSTEAD OF C MINUTES AND/OR SECONDS OF ARC. LATITUDE IS POSITIVE IN THE C NORTHERN HEMISPHERE. LONGITUDE IS POSITIVE EAST OF C GREENWICH, ENGLAND. C THE FINITE-ROTATION MATRICES (3 X 3) AND THE ROTATION-AXIS C VECTORS (3 X 1) USE A DIFFERENT COORDINATE SYSTEM. C IT IS CARTESIAN (X,Y,Z), WITH ITS ORIGIN AT THE CENTER C OF THE EARTH. X POINTS TOWARD (LAT=0, LON=0). C Y POINTS TOWARD (LAT=0, LON=90). Z POINTS TOWARD (LAT=90). C THE UNITS DIFFER: THE FINITE-ROTATION MATRICES ARE C DIMENSIONLESS, BUT THE ROTATION-RATE VECTORS ARE IN C RADIANS PER SECOND. C THE GEOLOGIC TIMES WHICH LABEL THE VARIOUS FEATURES ARE C EXPRESSED IN MILLIONS OF YEARS (POSITIVE = PAST). THE C LENGTH OF 1 MILLION YEARS IN THE FUNDAMENTAL TIME UNIT C (THE SECOND) IS EXPRESSED BY "TUMAP". C C---------------------------------------------------------------- C GLOSSARY OF DATA: C -AGEFZ(J,I) IS THE AGE OF FRACTURE ZONE POINT #J C IN STRIP #I. (USED BY EDITOR, NOT BY BELOWY) C -AGEHNG(I) IS THE AGE OF THE HINGELINE CURVE K C DEFINED BY REHING(I=1,2;J=1,40?;K). C -AGEKV(I) IS THE AGE OF THE KULA/VANCOUVER/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REKV3J(1-3,I). C -AGEMAG(I,J) IS THE AGE OF MAGNETIC ANOMALY I (FROM W TO E) C IN STRIPE J (FROM S TO N) ON THE PRESENT-AGE MAP. C -AGEROT(I) IS THE AGE OF THE FINITE ROTATION MATRICES C ROMATF, ROMATK, ROMATP, AND ROMATV WITH AGE INDEX I. C -AGEVEL(I) IS THE AGE OF THE RELATIVE ROTATION-AXIS VECTORS C OMEGAF, OEMGAK, OMEGAP, AND OMEGAV WITH AGE INDEX I. C -AGEVF(I) IS THE AGE OF THE VANCOUVER/FARALLON/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REVF3J(1-3,I). C -FRACZN(2,I,J) ARE THE LAT. AND LON. COORDINATES OF POINTS I C (W TO E) ALONG FRACTURE ZONE J (S TO N) ON THE MAP OF C PRESENT SLAB AGES. C -NKV3J IS THE NUMBER OF KULA/VANCOUVER/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REKV3J(1-3,I) AT AGE AGEKV(I). C -NMAG(K) IS THE NUMBER OF LINEAR MAGNETIC ANOMALIES C WITHIN STRIPE K (S TO N) OF THE MAP OF PRESENT SLAB C AGES. C -NPHING(I) IS THE NUMBER C OF DIGITIZED POINTS IN HINGELINE CURVE #I OF REHING. C -NPFZ(J) IS THE NUMBER OF POINTS (W TO E) DEFINING FRACTURE ZONE C J (S TO N) ON THE MAP OF PRESENT SLAB AGES. C -NROMAT IS THE NUMBER OF FINITE-ROTATION MATRICES C GIVEN FOR EACH PLATE. C -NVF3J IS THE NUMBER OF VANCOUVER/FARALLON/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REVF3J(1-3,I) AT AGE AGEVF(I). C -NTAPES IS THE NUMBER OF STRIPS OF MAGNETIC ANOMALIES ON C THE MAP OF PRESENT SLAB AGES; ONE LESS THAN THE NUMBER OF C FRACTURE ZONES ON THE MAP. C -NUMHNG IS THE NUMBER OF SLAB HINGELINES (AT DIFFERENT TIMES). C -NUMVEL IS THE NUMBER OF AGES AGEVEL(I) WHERE RELATIVE C ROTATION-AXIS VECTORS (OMEGAF/K/P/V) ARE SUPPLIED. C -OMEGAF(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE FARALLON C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAK(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE KULA C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAP(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE PACIFIC C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAV(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE VANCOUVER C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -REHING(I,J,K) ARE THE LAT. (I=1) AND LON. (I=2) COORDINATES C OF THE DIGITIZED POINT #J (N TO S) OF THE HINGELINE C CURVE #K (PAST TO PRESENT). C -REKV3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE KULA/ C VANCOUVER/NORTH AMERICAN TRIPLE-JUNCTION AT AGE AGEKV(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -REMAG(2,2,I,J) ARE THE LAT., LON. COORDINATES (1ST SUB.) C OF THE N AND S ENDS (2ND SUB.) OF THE LINEAR MAGNETIC C ANOMALY I (W TO E) IN STRIPE J (S TO N) OF THE C PRESENT SLAB AGE MAP. C -REVF3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE C VANCOUVER/FARALLON/N.A. TRIPLE-JUNCTION AT AGE AGEVF(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -ROMATF(3,3,K) ARE THE ROTATION MATRICES FOR FARALLON WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATK(3,3,K) ARE THE ROTATION MATRICES FOR KULA WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATP(3,3,K) ARE THE ROTATION MATRICES FOR PACIFIC WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATV(3,3,K) ARE THE ROTATION MATRICES FOR VANCOUVER WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -TAGFZ(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE FRACTURE ZONE POINT #I C IN STRIP #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TAGMAG(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE MAGNETIC ANOM. #I IN STRIP C #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TUMAP IS A CONVENIENCE MULTIPLIER APPLIED TO AGES IN M.Y. C TO OBTAIN THE TRUE AGE IN PROGRAM UNITS (SECONDS). C------------------------------------------------------------------ C C MEMO: ORDER IS: PARAMETER, TYPE, COMMON, DIMENSION, DATA C C********************************************************************* C C NOTE: THESE DIMENSION PARAMETERS MUST AGREE C IN ALL PROGRAMS !!!!!! C C MAXIMUM NUMBER OF DIGITISED SLAB HINGELINES: PARAMETER (MAXHL=20) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED HINGELINE: PARAMETER (MAXHNG=40) C MAXIMUM NUMBER OF FINITE ROTATIONS FOR EACH PLATE: PARAMETER (MAXROT=21) C MAXIMUM NUMBER OF RELATIVE ROTATION-AXIS VECTORS FOR EACH PLATE: PARAMETER (MAXVEL=20) C MAXIMUM NUMBER OF AGES WHEN KULA/VANCOUVER TRIPLE-JUNCTION IS GIVEN: PARAMETER (MXKV3J =50) C MAXIM.NUMBER OF AGES WHEN VANCOUVER/FARALLON TRIPLE-JUNCTION IS GIVEN PARAMETER (MXVF3J =50) C MAXIMUM NUMBER OF STRIPS OF SEAFLOOR (BETWEEN FRACTURE ZONES) ON MAP: PARAMETER (MTAPES =40,MTAPP1=41) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED FRACTURE ZONE: PARAMETER (MAXFZP=100) C MAXIMUM NUMBER OF MAGNETIC ANOMALIES IN ANY ONE STRIP: PARAMETER (MAXMAG=100) C********************************************************************* CHARACTER*1 TAGFZ,TAGMAG C-------------------------------------------------------------------- DIMENSION AGEFZ(MAXFZP,MTAPP1), 2 AGEHNG(MAXHL), 3 AGEKV(MXKV3J), 4 AGEMAG(MAXMAG,MTAPES), 5 AGEROT(MAXROT), 6 AGEVEL(MAXVEL), 7 AGEVF(MXVF3J), 8 FRACZN(2,MAXFZP,MTAPP1), 9 NPFZ(MTAPP1), A NPHING(MAXHNG) DIMENSION NMAG(MTAPES), 2 OMEGAF(3,MAXVEL), 3 OMEGAK(3,MAXVEL), 4 OMEGAP(3,MAXVEL), 5 OMEGAV(3,MAXVEL), 6 REHING(2,MAXHNG,MAXHL), 7 REKV3J(3,MXKV3J), 8 REMAG(2,2,MAXMAG,MTAPES), 9 REVF3J(3,MXVF3J), A ROMATF(3,3,MAXROT), 1 ROMATK(3,3,MAXROT), 2 ROMATP(3,3,MAXROT), 3 ROMATV(3,3,MAXROT), 4 TAGFZ(MAXFZP,MTAPP1), 5 TAGMAG(MAXMAG,MTAPES) C C===1=== SLAB HINGELINES ======================= C DATA NUMHNG / 14/ DATA TUMAP /3.15576E13/ DATA (AGEHNG(I),I=1, 14) / + 90.00, 80.00, 75.00, 65.00, 55.00, 45.00, 40.00, 35.00, + 30.00, 27.50, 20.00, 10.00, 0.00, -3.00 + / DATA (NPHING(I),I=1, 14) / + 29, 29, 33, 34, 31, 35, 32, 26, 31, 30, 30, 27, 31, 31 + / DATA ((REHING(I,J, 1),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.93,-121.73, 43.26,-120.79, 42.45,-120.19, + 41.36,-119.63, 40.28,-119.46, 38.96,-119.44, 37.33,-119.31, + 35.93,-118.93, 33.70,-117.83, 31.95,-116.51, 30.19,-114.64, + 28.43,-112.42, 27.31,-110.50, 26.22,-108.89, 24.93,-106.85, + 23.66,-105.23, 22.25,-103.60, 20.84,-102.03, 19.21,-100.57, + 17.67, -99.09 + / DATA ((REHING(I,J, 2),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.93,-121.73, 43.26,-120.79, 42.45,-120.19, + 41.36,-119.63, 40.28,-119.46, 38.96,-119.44, 37.33,-119.31, + 35.93,-118.93, 33.70,-117.83, 31.95,-116.51, 30.19,-114.64, + 28.43,-112.42, 27.31,-110.50, 26.22,-108.89, 24.93,-106.85, + 23.66,-105.23, 22.25,-103.60, 20.84,-102.03, 19.21,-100.57, + 17.67, -99.09 + / DATA ((REHING(I,J, 3),I=1,2),J=1, 33) / + 60.24,-142.90, 58.27,-136.08, 57.06,-133.84, 55.56,-132.30, + 54.31,-131.06, 52.34,-129.57, 50.99,-128.46, 49.68,-127.62, + 48.64,-126.31, 47.41,-124.10, 46.20,-121.40, 45.21,-118.79, + 44.38,-116.32, 43.59,-113.87, 42.71,-111.45, 41.95,-110.30, + 40.87,-109.75, 39.46,-109.53, 38.07,-109.47, 36.40,-109.69, + 34.97,-110.12, 33.38,-111.48, 32.18,-112.63, 31.23,-113.29, + 30.55,-113.21, 29.70,-112.07, 28.45,-110.41, 26.85,-108.26, + 25.03,-106.06, 22.76,-103.36, 20.40,-100.83, 18.53, -98.91, + 15.76, -95.35 + / DATA ((REHING(I,J, 4),I=1,2),J=1, 34) / + 59.74,-142.93, 57.85,-135.98, 57.15,-134.10, 56.01,-132.85, + 54.68,-131.71, 52.77,-130.21, 50.90,-128.84, 49.63,-127.75, + 48.60,-126.11, 47.65,-124.22, 47.03,-122.13, 46.41,-119.25, + 46.11,-116.86, 45.83,-114.22, 45.56,-111.04, 45.24,-108.41, + 44.65,-106.77, 43.72,-105.66, 42.82,-105.87, 41.25,-106.39, + 39.96,-107.68, 38.23,-109.58, 36.53,-111.05, 34.82,-112.31, + 33.11,-113.12, 32.14,-113.13, 31.23,-112.40, 30.09,-111.04, + 28.34,-108.86, 26.70,-106.84, 24.65,-104.56, 22.44,-102.17, + 18.04, -97.90, 14.33, -93.82 + / DATA ((REHING(I,J, 5),I=1,2),J=1, 31) / + 60.18,-142.67, 58.34,-135.99, 57.39,-133.91, 55.54,-131.68, + 53.24,-129.30, 51.45,-127.33, 49.34,-124.96, 47.58,-122.87, + 45.85,-120.92, 44.34,-118.67, 43.75,-116.92, 43.72,-114.46, + 43.59,-111.55, 43.34,-108.91, 42.86,-107.05, 42.13,-105.45, + 41.13,-104.87, 40.08,-104.90, 38.70,-105.39, 37.13,-106.70, + 35.70,-107.90, 34.13,-109.17, 32.75,-109.71, 31.34,-109.71, + 30.37,-109.16, 29.06,-107.62, 26.11,-104.35, 22.91,-101.21, + 20.18, -98.61, 18.86, -97.37, 15.81, -93.90 + / DATA ((REHING(I,J, 6),I=1,2),J=1, 35) / + 59.65,-143.76, 57.90,-136.31, 57.31,-134.75, 56.45,-133.35, + 55.25,-132.01, 53.95,-130.78, 52.54,-129.43, 50.88,-127.99, + 49.81,-126.43, 49.25,-124.90, 48.58,-123.85, 47.46,-122.86, + 46.31,-121.77, 44.75,-120.30, 43.36,-119.35, 41.49,-118.46, + 40.66,-117.90, 40.03,-116.96, 39.46,-115.55, 39.13,-113.64, + 38.99,-111.33, 38.87,-108.52, 38.77,-106.09, 38.39,-104.45, + 38.00,-103.53, 37.37,-103.42, 35.34,-103.89, 32.58,-104.54, + 29.82,-105.05, 27.44,-105.42, 24.90,-103.03, 22.70,-101.09, + 20.05, -98.86, 17.88, -96.95, 14.95, -94.01 + / DATA ((REHING(I,J, 7),I=1,2),J=1, 32) / + 60.15,-144.12, 58.32,-136.58, 57.58,-134.52, 55.82,-132.18, + 53.60,-130.20, 51.68,-128.54, 50.56,-127.44, 49.48,-125.13, + 48.21,-123.37, 45.85,-121.58, 43.62,-119.92, 41.89,-118.52, + 40.13,-116.35, 39.11,-114.39, 38.47,-112.91, 38.07,-111.01, + 37.86,-108.95, 37.68,-106.27, 37.11,-104.05, 36.49,-103.28, + 35.59,-103.92, 33.92,-105.34, 32.65,-107.07, 31.58,-108.11, + 30.77,-108.67, 30.04,-107.87, 28.35,-106.21, 25.94,-103.92, + 23.23,-101.36, 19.92, -98.62, 18.08, -97.05, 14.58, -93.85 + / DATA ((REHING(I,J, 8),I=1,2),J=1, 26) / + 60.73,-144.29, 58.48,-135.82, 56.96,-132.82, 54.44,-130.45, + 51.91,-128.35, 50.62,-126.85, 49.32,-124.72, 47.04,-122.53, + 45.09,-121.21, 43.27,-119.94, 41.70,-118.85, 39.66,-117.43, + 38.07,-115.05, 37.24,-112.97, 36.83,-110.87, 36.60,-109.39, + 36.22,-108.78, 35.56,-108.94, 33.64,-110.03, 32.23,-110.38, + 31.18,-109.93, 30.10,-108.77, 27.69,-106.20, 24.64,-103.37, + 19.55, -98.74, 14.66, -94.17 + / DATA ((REHING(I,J, 9),I=1,2),J=1, 31) / + 59.94,-142.45, 58.14,-135.36, 56.98,-133.18, 54.87,-131.29, + 52.93,-129.48, 51.68,-128.44, 50.98,-127.72, 50.43,-126.82, + 49.58,-125.10, 48.58,-123.85, 45.67,-121.39, 43.86,-120.19, + 41.92,-118.74, 39.65,-117.67, 38.14,-116.22, 37.34,-114.59, + 36.86,-113.27, 36.59,-112.50, 36.18,-112.04, 35.60,-111.96, + 34.88,-112.15, 34.29,-112.49, 33.70,-112.81, 32.69,-112.03, + 31.73,-110.98, 29.66,-108.65, 27.54,-106.42, 24.80,-103.95, + 23.88,-103.22, 18.54, -98.67, 14.42, -94.83 + / DATA ((REHING(I,J, 10),I=1,2),J=1, 30) / + 60.05,-142.71, 58.15,-135.55, 57.19,-133.78, 55.93,-132.21, + 54.27,-130.67, 53.02,-129.56, 51.61,-128.52, 50.80,-127.58, + 50.24,-126.63, 49.34,-124.96, 48.34,-123.62, 47.04,-122.53, + 45.82,-121.46, 44.32,-120.36, 42.71,-119.19, 40.97,-118.24, + 39.38,-117.47, 38.13,-116.62, 36.88,-115.49, 35.88,-114.63, + 35.07,-113.90, 34.07,-113.38, 32.72,-112.14, 31.60,-110.78, + 29.45,-108.57, 27.14,-106.05, 24.28,-103.50, 21.45,-101.15, + 18.32, -98.45, 14.79, -95.22 + / DATA ((REHING(I,J, 11),I=1,2),J=1, 30) / + 60.40,-143.60, 58.26,-135.89, 57.30,-133.82, 55.79,-132.11, + 54.09,-130.51, 52.22,-128.93, 50.89,-127.65, 50.16,-126.36, + 48.98,-124.38, 47.60,-123.01, 45.84,-122.17, 43.62,-121.86, + 41.51,-121.12, 39.45,-120.08, 37.52,-118.43, 36.38,-117.33, + 35.75,-116.30, 35.15,-114.95, 34.51,-113.95, 33.50,-113.29, + 32.45,-112.66, 31.69,-112.09, 30.03,-110.31, 28.29,-108.49, + 26.74,-106.94, 24.73,-105.04, 22.76,-103.43, 19.82,-100.93, + 18.03, -99.36, 15.25, -96.89 + / DATA ((REHING(I,J, 12),I=1,2),J=1, 27) / + 60.42,-144.51, 58.53,-136.13, 57.88,-134.36, 56.05,-132.25, + 54.05,-130.39, 52.11,-128.80, 50.74,-127.47, 50.15,-126.46, + 49.50,-125.28, 48.27,-123.80, 47.15,-122.81, 46.39,-122.50, + 45.08,-122.44, 43.55,-122.58, 41.65,-121.97, 39.91,-120.91, + 38.15,-119.72, 36.58,-117.83, 34.34,-115.15, 31.39,-111.97, + 28.32,-108.97, 26.00,-106.84, 23.14,-104.47, 21.37,-103.15, + 20.03,-101.83, 18.36,-100.47, 13.50, -94.94 + / DATA ((REHING(I,J, 13),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / DATA ((REHING(I,J, 14),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / C C===2=== CODE GENERATED BY PROGRAM "ALL4" PLATE ROTATER: ===== C DATA NROMAT / 18/ DATA (AGEROT(I),I=1, 18) / + 0.00, 3.63, 10.30, 19.90, 25.80, 30.00, 35.60, 42.00, + 49.55, 58.90, 68.50, 72.40, 85.00, 119.00, 127.00, 135.00, + 145.00, 163.00 + / DATA ((ROMATF(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATF(I,J, 2),J=1,3),I=1,3) +/ 0.9984418, 0.0249586, 0.0499063, + -0.0236761, 0.9993781,-0.0261258, + -0.0505273, 0.0249035, 0.9984120/ DATA ((ROMATF(I,J, 3),J=1,3),I=1,3) +/ 0.9965000,-0.0015017, 0.0835752, + 0.0016967, 0.9999958,-0.0022638, + -0.0835716, 0.0023977, 0.9964986/ DATA ((ROMATF(I,J, 4),J=1,3),I=1,3) +/ 0.9870884,-0.0794135, 0.1391012, + 0.0779809, 0.9968305, 0.0157267, + -0.1399093,-0.0046764, 0.9901530/ DATA ((ROMATF(I,J, 5),J=1,3),I=1,3) +/ 0.9816186,-0.0953112, 0.1653471, + 0.0902718, 0.9952011, 0.0377464, + -0.1681514,-0.0221263, 0.9855123/ DATA ((ROMATF(I,J, 6),J=1,3),I=1,3) +/ 0.9772222,-0.1307292, 0.1671685, + 0.1217395, 0.9905611, 0.0629824, + -0.1738244,-0.0411969, 0.9839141/ DATA ((ROMATF(I,J, 7),J=1,3),I=1,3) +/ 0.9643680,-0.2176023, 0.1504717, + 0.2023463, 0.9730743, 0.1103661, + -0.1704363,-0.0759863, 0.9824339/ DATA ((ROMATF(I,J, 8),J=1,3),I=1,3) +/ 0.9355122,-0.3127865, 0.1642541, + 0.2875628, 0.9442505, 0.1603019, + -0.2052376,-0.1027311, 0.9733049/ DATA ((ROMATF(I,J, 9),J=1,3),I=1,3) +/ 0.8698806,-0.4633711, 0.1690941, + 0.4200012, 0.8755688, 0.2386968, + -0.2586591,-0.1366181, 0.9562580/ DATA ((ROMATF(I,J, 10),J=1,3),I=1,3) +/ 0.7665346,-0.5965531, 0.2377952, + 0.4980173, 0.7859663, 0.3663787, + -0.4054641,-0.1624160, 0.8995655/ DATA ((ROMATF(I,J, 11),J=1,3),I=1,3) +/ 0.6799753,-0.6748897, 0.2866260, + 0.4922036, 0.7098752, 0.5037958, + -0.5434762,-0.2014907, 0.8148823/ DATA ((ROMATF(I,J, 12),J=1,3),I=1,3) +/ 0.6364845,-0.7003338, 0.3231361, + 0.4905679, 0.6908776, 0.5310636, + -0.5951703,-0.1794939, 0.7832956/ DATA ((ROMATF(I,J, 13),J=1,3),I=1,3) +/ 0.5407817,-0.7359961, 0.4072609, + 0.3967867, 0.6501144, 0.6480033, + -0.7416956,-0.1888330, 0.6436048/ DATA ((ROMATF(I,J, 14),J=1,3),I=1,3) +/ 0.1260393,-0.9004962, 0.4161935, + 0.4084943, 0.4294313, 0.8054301, + -0.9040152, 0.0684970, 0.4219739/ DATA ((ROMATF(I,J, 15),J=1,3),I=1,3) +/ 0.0432563,-0.8638376, 0.5019060, + 0.3372753, 0.4855096, 0.8065493, + -0.9404098, 0.1343924, 0.3123534/ DATA ((ROMATF(I,J, 16),J=1,3),I=1,3) +/ -0.0372843,-0.8243719, 0.5648155, + 0.2585098, 0.5380124, 0.8023162, + -0.9652870, 0.1759245, 0.1930498/ DATA ((ROMATF(I,J, 17),J=1,3),I=1,3) +/ -0.0857564,-0.7854440, 0.6129592, + 0.2832710, 0.5706134, 0.7708135, + -0.9551961, 0.2397366, 0.1735606/ DATA ((ROMATF(I,J, 18),J=1,3),I=1,3) +/ -0.3959168,-0.6532624, 0.6453629, + 0.3365481, 0.5506653, 0.7638706, + -0.8543893, 0.5196268, 0.0018373/ DATA ((ROMATK(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATK(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATK(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATK(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATK(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATK(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATK(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATK(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATK(I,J, 9),J=1,3),I=1,3) +/ 0.8926937, 0.3237427, 0.3135092, + -0.3673854, 0.9256842, 0.0902017, + -0.2610084,-0.1957012, 0.9452911/ DATA ((ROMATK(I,J, 10),J=1,3),I=1,3) +/ 0.8382884, 0.2792339, 0.4682950, + -0.4014298, 0.8973089, 0.1835486, + -0.3689522,-0.3418544, 0.8642969/ DATA ((ROMATK(I,J, 11),J=1,3),I=1,3) +/ 0.7479138, 0.2368386, 0.6201060, + -0.4491286, 0.8684335, 0.2100139, + -0.4887816,-0.4355798, 0.7558849/ DATA ((ROMATK(I,J, 12),J=1,3),I=1,3) +/ 0.7069741, 0.2202590, 0.6720657, + -0.4550582, 0.8691026, 0.1938600, + -0.5413948,-0.4428831, 0.7146643/ DATA ((ROMATK(I,J, 13),J=1,3),I=1,3) +/ 0.4927713, 0.2023760, 0.8462971, + -0.5685837, 0.8111188, 0.1371042, + -0.6587012,-0.5487522, 0.5147643/ DATA ((ROMATK(I,J, 14),J=1,3),I=1,3) +/ 0.2884439,-0.0305855, 0.9570071, + -0.2699646, 0.9563414, 0.1119320, + -0.9186499,-0.2906443, 0.2675945/ DATA ((ROMATK(I,J, 15),J=1,3),I=1,3) +/ 0.1826985, 0.0447444, 0.9821491, + -0.2405134, 0.9706448, 0.0005196, + -0.9532956,-0.2363152, 0.1880977/ DATA ((ROMATK(I,J, 16),J=1,3),I=1,3) +/ 0.0730065, 0.1148067, 0.9907003, + -0.2118030, 0.9724770,-0.0970868, + -0.9745805,-0.2027456, 0.0953141/ DATA ((ROMATK(I,J, 17),J=1,3),I=1,3) +/ 0.0737035, 0.1703374, 0.9826242, + -0.1573972, 0.9749421,-0.1572000, + -0.9847798,-0.1430762, 0.0986680/ DATA ((ROMATK(I,J, 18),J=1,3),I=1,3) +/ -0.0087966, 0.2534258, 0.9673132, + 0.1625878, 0.9548408,-0.2486796, + -0.9866534, 0.1550863,-0.0496027/ DATA ((ROMATP(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATP(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATP(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATP(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATP(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATP(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATP(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATP(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATP(I,J, 9),J=1,3),I=1,3) +/ 0.9036663, 0.3323698, 0.2700321, + -0.3557910, 0.9336445, 0.0414807, + -0.2383270,-0.1335597, 0.9619573/ DATA ((ROMATP(I,J, 10),J=1,3),I=1,3) +/ 0.8783061, 0.3137228, 0.3607716, + -0.3583550, 0.9314973, 0.0624035, + -0.3164804,-0.1840937, 0.9305640/ DATA ((ROMATP(I,J, 11),J=1,3),I=1,3) +/ 0.8133826, 0.3327699, 0.4771508, + -0.4012021, 0.9148389, 0.0458976, + -0.4212428,-0.2287661, 0.8776220/ DATA ((ROMATP(I,J, 12),J=1,3),I=1,3) +/ 0.7885006, 0.3410243, 0.5118291, + -0.4008002, 0.9161383, 0.0070450, + -0.4665038,-0.2106962, 0.8590583/ DATA ((ROMATP(I,J, 13),J=1,3),I=1,3) +/ 0.6594428, 0.4211499, 0.6227100, + -0.4718215, 0.8767433,-0.0933034, + -0.5852515,-0.2322797, 0.7768697/ DATA ((ROMATP(I,J, 14),J=1,3),I=1,3) +/ 0.5735050, 0.5730298, 0.5854303, + -0.4726608, 0.8151487,-0.3348495, + -0.6690916,-0.0846720, 0.7383407/ DATA ((ROMATP(I,J, 15),J=1,3),I=1,3) +/ 0.5466521, 0.6209800, 0.5617428, + -0.4979524, 0.7804186,-0.3781402, + -0.6732122,-0.0730101, 0.7358360/ DATA ((ROMATP(I,J, 16),J=1,3),I=1,3) +/ 0.5130962, 0.6671163, 0.5400814, + -0.5285266, 0.7413454,-0.4136018, + -0.6763074,-0.0732298, 0.7329704/ DATA ((ROMATP(I,J, 17),J=1,3),I=1,3) +/ 0.5677590, 0.7006614, 0.4321147, + -0.5501299, 0.7134408,-0.4340037, + -0.6123779, 0.0086904, 0.7905173/ DATA ((ROMATP(I,J, 18),J=1,3),I=1,3) +/ 0.7427920, 0.5855252, 0.3246846, + -0.3852086, 0.7703925,-0.5080448, + -0.5476077, 0.2523004, 0.7977908/ DATA ((ROMATV(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATV(I,J, 2),J=1,3),I=1,3) +/ 0.9993297, 0.0051820, 0.0362338, + -0.0047712, 0.9999232,-0.0114144, + -0.0362902, 0.0112339, 0.9992780/ DATA ((ROMATV(I,J, 3),J=1,3),I=1,3) +/ 0.9966072,-0.0024635, 0.0822646, + 0.0025242, 0.9999963,-0.0006345, + -0.0822628, 0.0008400, 0.9966100/ DATA ((ROMATV(I,J, 4),J=1,3),I=1,3) +/ 0.9874673,-0.0822613, 0.1346872, + 0.0813513, 0.9966096, 0.0122550, + -0.1352387,-0.0011445, 0.9908120/ DATA ((ROMATV(I,J, 5),J=1,3),I=1,3) +/ 0.9769385,-0.0981460, 0.1896242, + 0.0957089, 0.9951658, 0.0219901, + -0.1908659,-0.0033342, 0.9816099/ DATA ((ROMATV(I,J, 6),J=1,3),I=1,3) +/ 0.9672080,-0.1004198, 0.2332878, + 0.0970278, 0.9949411, 0.0260009, + -0.2347188,-0.0025129, 0.9720595/ DATA ((ROMATV(I,J, 7),J=1,3),I=1,3) +/ 0.9578496,-0.1985734, 0.2075841, + 0.1860558, 0.9794068, 0.0783809, + -0.2188739,-0.0364552, 0.9750712/ DATA ((ROMATV(I,J, 8),J=1,3),I=1,3) +/ 0.9285972,-0.3330147, 0.1637273, + 0.3143928, 0.9404002, 0.1296231, + -0.1971359,-0.0688933, 0.9779518/ DATA ((ROMATV(I,J, 9),J=1,3),I=1,3) +/ 0.8519540,-0.5116365, 0.1113576, + 0.4857856, 0.8516892, 0.1965587, + -0.1954090,-0.1133634, 0.9741470/ DATA ((ROMATV(I,J, 10),J=1,3),I=1,3) +/ 0.7341714,-0.6763662, 0.0593198, + 0.6286086, 0.7101420, 0.3170907, + -0.2565954,-0.1955106, 0.9465370/ DATA ((ROMATV(I,J, 11),J=1,3),I=1,3) +/ 0.6687082,-0.7369352, 0.0987580, + 0.6230298, 0.6278643, 0.4664944, + -0.4057837,-0.2504201, 0.8789921/ DATA ((ROMATV(I,J, 12),J=1,3),I=1,3) +/ 0.6332583,-0.7620972, 0.1348656, + 0.6199963, 0.6038375, 0.5009806, + -0.4632338,-0.2336346, 0.8548840/ DATA ((ROMATV(I,J, 13),J=1,3),I=1,3) +/ 0.5726639,-0.7899240, 0.2192550, + 0.5270615, 0.5596170, 0.6395554, + -0.6279004,-0.2506902, 0.7368125/ DATA ((ROMATV(I,J, 14),J=1,3),I=1,3) +/ 0.1862030,-0.9539652, 0.2351070, + 0.4969981, 0.2978723, 0.8150220, + -0.8475366,-0.0349119, 0.5295847/ DATA ((ROMATV(I,J, 15),J=1,3),I=1,3) +/ 0.1202118,-0.9349756, 0.3337152, + 0.4187091, 0.3525420, 0.8368945, + -0.9001268, 0.0391250, 0.4338636/ DATA ((ROMATV(I,J, 16),J=1,3),I=1,3) +/ 0.0559588,-0.9094425, 0.4120423, + 0.3322897, 0.4061266, 0.8512579, + -0.9415139, 0.0892823, 0.3249255/ DATA ((ROMATV(I,J, 17),J=1,3),I=1,3) +/ 0.0035101,-0.8845617, 0.4664051, + 0.3494043, 0.4380954, 0.8282415, + -0.9369633, 0.1600573, 0.3106084/ DATA ((ROMATV(I,J, 18),J=1,3),I=1,3) +/ -0.3217998,-0.7897338, 0.5222647, + 0.3520011, 0.4122773, 0.8403078, + -0.8789400, 0.4542502, 0.1453171/ DATA NUMVEL / 17/ DATA (AGEVEL(I),I=1, 17) / + 1.81, 6.97, 15.10, 22.85, 27.90, 32.80, 38.80, 45.77, + 54.22, 63.70, 70.45, 78.70, 102.00, 123.00, 131.00, 140.00, + 154.00 + / DATA (OMEGAF(I, 1),I=1,3) + / 2.22436E-16, 4.37785E-16,-2.11997E-16/ DATA (OMEGAF(I, 2),I=1,3) + /-1.15243E-16, 1.59143E-16, 1.18424E-16/ DATA (OMEGAF(I, 3),I=1,3) + /-5.20186E-17, 1.86928E-16, 2.53471E-16/ DATA (OMEGAF(I, 4),I=1,3) + /-1.06009E-16, 1.52830E-16, 7.04799E-17/ DATA (OMEGAF(I, 5),I=1,3) + /-1.88225E-16, 3.57680E-17, 2.41271E-16/ DATA (OMEGAF(I, 6),I=1,3) + /-2.80863E-16,-4.69432E-17, 4.60480E-16/ DATA (OMEGAF(I, 7),I=1,3) + /-2.23587E-16, 1.34246E-16, 4.59035E-16/ DATA (OMEGAF(I, 8),I=1,3) + /-3.01794E-16, 1.52210E-16, 6.43195E-16/ DATA (OMEGAF(I, 9),I=1,3) + /-2.67001E-16, 4.56656E-16, 4.83609E-16/ DATA (OMEGAF(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAF(I, 11),I=1,3) + /-7.69435E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAF(I, 12),I=1,3) + /-1.10799E-16, 4.93623E-16, 8.32111E-17/ DATA (OMEGAF(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAF(I, 14),I=1,3) + / 3.42999E-16, 4.32696E-16, 1.46227E-16/ DATA (OMEGAF(I, 15),I=1,3) + / 2.93430E-16, 4.47830E-16, 9.47212E-17/ DATA (OMEGAF(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAF(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAK(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAK(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAK(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAK(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAK(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAK(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAK(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAK(I, 8),I=1,3) + /-3.42895E-16, 3.07318E-16,-7.84280E-18/ DATA (OMEGAK(I, 9),I=1,3) + /-5.24123E-16, 4.21964E-16,-6.28934E-17/ DATA (OMEGAK(I, 10),I=1,3) + /-3.47853E-16, 5.17207E-16,-6.26469E-17/ DATA (OMEGAK(I, 11),I=1,3) + /-1.29789E-16, 5.39917E-16, 7.00136E-17/ DATA (OMEGAK(I, 12),I=1,3) + /-2.25126E-16, 6.46717E-16,-2.10399E-16/ DATA (OMEGAK(I, 13),I=1,3) + /-8.79291E-17, 2.40344E-16, 3.43456E-16/ DATA (OMEGAK(I, 14),I=1,3) + / 3.42972E-16, 4.32656E-16, 1.46203E-16/ DATA (OMEGAK(I, 15),I=1,3) + / 2.93406E-16, 4.47800E-16, 9.47100E-17/ DATA (OMEGAK(I, 16),I=1,3) + / 1.91374E-16, 2.29230E-17, 1.74145E-16/ DATA (OMEGAK(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAP(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAP(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAP(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAP(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAP(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAP(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAP(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAP(I, 8),I=1,3) + /-7.95765E-17, 2.01210E-16, 3.16566E-17/ DATA (OMEGAP(I, 9),I=1,3) + /-1.82793E-16, 2.78850E-16, 6.21172E-18/ DATA (OMEGAP(I, 10),I=1,3) + /-1.10363E-16, 4.11618E-16,-1.28934E-16/ DATA (OMEGAP(I, 11),I=1,3) + / 1.61156E-16, 4.19784E-16, 1.56999E-17/ DATA (OMEGAP(I, 12),I=1,3) + / 7.46968E-17, 4.23581E-16,-2.19155E-16/ DATA (OMEGAP(I, 13),I=1,3) + / 2.04277E-16, 1.08618E-16,-2.84094E-17/ DATA (OMEGAP(I, 14),I=1,3) + / 1.92305E-16, 3.73766E-17,-1.42336E-16/ DATA (OMEGAP(I, 15),I=1,3) + / 1.61534E-16, 3.43348E-17,-1.77105E-16/ DATA (OMEGAP(I, 16),I=1,3) + / 2.87845E-16,-2.68429E-16, 6.23380E-17/ DATA (OMEGAP(I, 17),I=1,3) + / 2.19652E-16,-7.13669E-17, 4.34363E-16/ DATA (OMEGAV(I, 1),I=1,3) + / 9.86981E-17, 3.16045E-16,-4.33668E-17/ DATA (OMEGAV(I, 2),I=1,3) + /-5.14985E-17, 2.19222E-16, 3.33668E-17/ DATA (OMEGAV(I, 3),I=1,3) + /-3.52269E-17, 1.75936E-16, 2.61668E-16/ DATA (OMEGAV(I, 4),I=1,3) + /-2.56065E-17, 3.02977E-16, 8.26955E-17/ DATA (OMEGAV(I, 5),I=1,3) + / 2.38990E-18, 3.39059E-16, 1.81821E-17/ DATA (OMEGAV(I, 6),I=1,3) + /-3.14872E-16,-1.02187E-16, 5.04872E-16/ DATA (OMEGAV(I, 7),I=1,3) + /-3.01822E-16,-1.44934E-16, 6.45606E-16/ DATA (OMEGAV(I, 8),I=1,3) + /-3.48720E-16,-8.07761E-17, 7.85876E-16/ DATA (OMEGAV(I, 9),I=1,3) + /-4.42586E-16, 1.09988E-16, 6.53606E-16/ DATA (OMEGAV(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAV(I, 11),I=1,3) + /-7.83352E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAV(I, 12),I=1,3) + /-1.10796E-16, 4.93633E-16, 8.32232E-17/ DATA (OMEGAV(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAV(I, 14),I=1,3) + / 3.42996E-16, 4.32686E-16, 1.46215E-16/ DATA (OMEGAV(I, 15),I=1,3) + / 2.93417E-16, 4.47842E-16, 9.47149E-17/ DATA (OMEGAV(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAV(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ C C===3=== DATA MODIFIED BY PROGRAM MAPPER ========== C C DATA NTAPES/ 20/,NTAPP1/ 21/,NKV3J/ 25/,NVF3J/ 10/ C C C DATA ((REKV3J(K,I),K=1,3),I=1, 15) / + 48.02,-132.16, 56., + 49.33,-132.96, 12., + 49.33,-132.96, 12., + 48.01,-132.01, 11., + 47.39,-130.70, 10., + 45.93,-130.92, 10., + 44.32,-127.85, 8., + 41.83,-123.69, 5., + 41.25,-122.81, -14., + 41.25,-122.81, -14., + 41.25,-122.81, -22., + 40.05,-122.54, -22., + 38.85,-122.28, -22., + 37.90,-122.09, -22., + 36.42,-122.04, -27. +/ DATA ((REKV3J(K,I),K=1,3),I=16,25) / + 35.29,-121.58, -30., + 33.41,-121.23, -33., + 30.61,-118.12, -36., + 29.73,-117.83, -39., + 26.99,-113.59, -39., + 19.30,-103.73, -46., + 15.16, -99.67, 33., + 12.16, -99.50, 33., + 9.74, -97.46, 32., + 8.54, -96.87, 31. +/ DATA ((REVF3J(K,I),K=1,3),I=1, 10) / + 28.05,-115.85, 45., + 26.08,-113.70, 43., + 26.14,-112.87, 30., + 26.14,-112.87, 30., + 25.75,-112.18, 29., + 24.61,-111.01, 45., + 24.23,-111.46, 59., + 25.26,-112.76, 36., + 1.70, -92.72, 27., + 1.70, -92.72, 27. +/ DATA (AGEKV(I),I=1, 25) / + 0.00, 10.00, 25.00, 30.00, 35.00, 40.00, 45.00, 50.00, + 51.00, 52.00, 53.00, 54.00, 55.00, 56.00, 57.00, 58.00, + 59.00, 60.00, 61.00, 62.00, 63.00, 64.00, 70.00, 80.00, + 85.00 +/ DATA (AGEVF(I),I=1, 10) / + 0.00, 30.00, 35.00, 40.00, 45.00, 50.00, 55.00, 59.00, + 60.00, 85.00 +/ C C C DATA (NPFZ(I),I=1, 21) / + 7, 6, 12, 13, 14, 18, 18, 20, 16, 16, 19, 13, 14, 15, 16, + 13, 14, 2, 15, 9, 4 +/ DATA (TAGFZ(K, 1),K=1, 7)/ +'F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 1),K=1, 7) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 1),K=1,2),L=1, 7)/ + 14.85,-102.14, 13.45, -88.33, 14.58, -78.99, 16.96, -69.97, + 18.18, -58.64, 18.35, -52.40, 16.02, -31.04 +/ DATA (TAGFZ(K, 2),K=1, 6)/ +'F','F','F','F','F','F' +/ DATA (AGEFZ(K, 2),K=1, 6) / +999.00,999.00,999.00,999.00, 99.00, 99.00 +/ DATA ((FRACZN(K,L, 2),K=1,2),L=1, 6)/ + 18.50,-102.24, 18.23, -96.47, 18.92, -86.37, 20.51, -79.06, + 23.96, -50.14, 20.97, -25.60 +/ DATA (TAGFZ(K, 3),K=1, 12)/ +'F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 3),K=1, 12) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 3),K=1,2),L=1, 12)/ + 22.79,-109.08, 21.70,-105.68, 24.61,-101.95, 24.72, -99.36, + 24.98, -91.24, 26.22, -83.42, 26.90, -75.26, 27.60, -68.02, + 28.57, -59.45, 29.26, -52.83, 23.88, -51.18, 20.97, -25.60 +/ DATA (TAGFZ(K, 4),K=1, 13)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 4),K=1, 13) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 4),K=1,2),L=1, 13)/ + 27.82,-116.19, 25.02,-111.50, 24.46,-105.70, 24.61,-101.95, + 24.72, -99.36, 24.98, -91.24, 26.22, -83.42, 26.90, -75.26, + 27.60, -68.02, 28.57, -59.45, 29.26, -52.83, 23.88, -51.18, + 20.97, -25.60 +/ DATA (TAGFZ(K, 5),K=1, 14)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 5),K=1, 14) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 5),K=1,2),L=1, 14)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 31.25,-101.62, 31.91, -94.06, 32.63, -88.76, 33.50, -81.67, + 33.67, -74.35, 33.99, -66.95, 34.67, -59.52, 34.95, -54.76, + 23.88, -51.18, 20.97, -25.60 +/ DATA (TAGFZ(K, 6),K=1, 18)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F' +/ DATA (AGEFZ(K, 6),K=1, 18) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00 +/ DATA ((FRACZN(K,L, 6),K=1,2),L=1, 18)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 31.25,-101.62, 31.91, -94.06, 32.63, -88.76, 33.50, -81.67, + 33.67, -74.35, 33.99, -66.95, 34.67, -59.52, 34.95, -54.76, + 29.24, -52.74, 29.00, -50.88, 27.34, -43.02, 23.63, -34.70, + 22.41, -31.83, 20.97, -25.60 +/ DATA (TAGFZ(K, 7),K=1, 18)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F' +/ DATA (AGEFZ(K, 7),K=1, 18) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00 +/ DATA ((FRACZN(K,L, 7),K=1,2),L=1, 18)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 33.14,-101.36, 35.05, -96.68, 36.71, -88.89, 37.85, -82.76, + 38.13, -73.94, 37.64, -61.74, 37.17, -58.77, 34.95, -54.76, + 29.24, -52.74, 29.03, -50.81, 27.34, -43.02, 23.63, -34.70, + 22.41, -31.83, 20.97, -25.60 +/ DATA (TAGFZ(K, 8),K=1, 20)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F','F','F' +/ DATA (AGEFZ(K, 8),K=1, 20) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 8),K=1,2),L=1, 20)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 33.14,-101.36, 35.05, -96.68, 36.71, -88.89, 37.85, -82.76, + 38.13, -73.94, 42.88, -64.20, 43.02, -61.57, 42.96, -59.18, + 39.07, -56.76, 34.95, -54.76, 29.24, -52.74, 29.03, -50.81, + 27.34, -43.02, 23.63, -34.70, 22.41, -31.83, 20.97, -25.60 +/ DATA (TAGFZ(K, 9),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEFZ(K, 9),K=1, 16) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 9),K=1,2),L=1, 16)/ + 40.23,-127.34, 40.23,-126.02, 38.68,-123.96, 38.42,-119.01, + 38.54,-115.83, 38.43,-112.65, 37.98,-108.57, 35.87,-103.22, + 32.52,-101.45, 33.29, -95.67, 33.50, -92.15, 34.08, -87.66, + 34.87, -81.11, 36.30, -72.68, 42.44, -64.58, 43.18, -58.92 +/ DATA (TAGFZ(K, 10),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEFZ(K, 10),K=1, 16) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 10),K=1,2),L=1, 16)/ + 40.23,-127.34, 40.23,-126.02, 38.68,-123.96, 38.42,-119.01, + 38.54,-115.83, 38.43,-112.65, 37.79,-108.25, 35.86,-103.28, + 35.04,-100.02, 35.85, -96.03, 35.86, -91.85, 36.10, -88.03, + 37.41, -81.74, 39.62, -74.33, 42.44, -64.58, 43.18, -58.92 +/ DATA (TAGFZ(K, 11),K=1, 19)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V' +/ DATA (AGEFZ(K, 11),K=1, 19) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 11),K=1,2),L=1, 19)/ + 40.23,-127.34, 40.23,-126.02, 38.68,-123.96, 38.42,-119.01, + 38.54,-115.83, 38.43,-112.65, 37.79,-108.25, 37.77,-102.97, + 37.71, -98.10, 37.70, -94.55, 37.83, -91.31, 38.45, -83.72, + 39.29, -82.15, 41.03, -79.69, 41.20, -75.80, 43.06, -66.71, + 43.68, -63.22, 44.20, -60.23, 43.18, -58.92 +/ DATA (TAGFZ(K, 12),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 12),K=1, 13) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 12),K=1,2),L=1, 13)/ + 42.86,-126.48, 42.53,-124.84, 42.39,-123.83, 41.50,-119.02, + 41.88,-115.71, 41.90,-111.99, 41.29,-107.88, 40.67,-103.81, + 40.42, -97.63, 42.27, -90.61, 46.59, -69.00, 47.39, -63.98, + 43.88, -59.85 +/ DATA (TAGFZ(K, 13),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 13),K=1, 14) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 13),K=1,2),L=1, 14)/ + 44.04,-131.51, 42.86,-126.48, 42.53,-124.84, 42.39,-123.83, + 41.50,-119.02, 45.47,-114.02, 45.42,-108.55, 44.77,-103.42, + 44.50,-100.32, 40.42, -97.63, 42.27, -90.61, 46.59, -69.00, + 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 14),K=1, 15)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 14),K=1, 15) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 14),K=1,2),L=1, 15)/ + 49.15,-130.92, 49.01,-129.37, 48.41,-125.70, 49.64,-116.32, + 50.08,-113.29, 49.37,-109.57, 48.78,-104.69, 48.21, -97.40, + 47.75, -94.87, 47.28, -86.55, 46.77, -83.58, 47.70, -70.74, + 48.75, -66.00, 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 15),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEFZ(K, 15),K=1, 16) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 15),K=1,2),L=1, 16)/ + 49.99,-129.92, 50.40,-127.83, 51.58,-125.71, 53.96,-120.53, + 54.07,-119.53, 53.79,-112.80, 52.80,-105.15, 52.43, -97.63, + 50.82, -91.98, 49.03, -90.02, 47.28, -86.55, 46.77, -83.58, + 47.70, -70.74, 48.75, -66.00, 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 16),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 16),K=1, 13) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 16),K=1,2),L=1, 13)/ + 49.99,-129.92, 50.40,-127.83, 51.58,-125.71, 53.96,-120.53, + 54.07,-119.53, 55.84,-113.32, 55.68,-104.45, 54.40, -83.66, + 52.84, -80.13, 47.70, -70.74, 48.75, -66.00, 47.39, -63.98, + 43.88, -59.85 +/ DATA (TAGFZ(K, 17),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 17),K=1, 14) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 17),K=1,2),L=1, 14)/ + 49.99,-129.92, 50.40,-127.83, 51.58,-125.71, 53.96,-120.53, + 54.07,-119.53, 55.84,-113.32, 57.43,-104.59, 56.93, -98.28, + 54.40, -83.66, 54.00, -74.27, 52.44, -70.98, 48.75, -66.00, + 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 18),K=1, 2)/ +'K','K' +/ DATA (AGEFZ(K, 18),K=1, 2) / +999.00,999.00 +/ DATA ((FRACZN(K,L, 18),K=1,2),L=1, 2)/ + 46.50,-117.44, 41.33,-114.74 +/ DATA (TAGFZ(K, 19),K=1, 15)/ +'K','K','K','K','K','K','K','K','K','K','K','K','K','K','K' +/ DATA (AGEFZ(K, 19),K=1, 15) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 19),K=1,2),L=1, 15)/ + 56.25,-160.75, 59.67,-142.10, 60.76,-139.41, 63.24,-137.79, + 70.34,-143.21, 63.74,-134.83, 55.35,-124.00, 46.50,-117.44, + 45.56,-101.60, 44.04, -93.75, 43.58, -90.59, 42.85, -93.55, + 41.66,-100.53, 40.83,-114.46, 30.22, -97.48 +/ DATA (TAGFZ(K, 20),K=1, 9)/ +'K','K','K','K','K','K','K','K','K' +/ DATA (AGEFZ(K, 20),K=1, 9) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00 +/ DATA ((FRACZN(K,L, 20),K=1,2),L=1, 9)/ + 55.63,-160.57, 64.90,-174.23, 73.65,-166.35, 70.34,-143.21, + 64.60,-134.40, 55.35,-124.00, 46.50,-117.44, 43.44, -90.90, + 38.95, -80.24 +/ DATA (TAGFZ(K, 21),K=1, 4)/ +'K','K','K','K' +/ DATA (AGEFZ(K, 21),K=1, 4) / +999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 21),K=1,2),L=1, 4)/ + 70.70,-170.78, 68.29, 47.63, 49.94, 3.74, 38.14, -79.72 +/ C C C DATA (NMAG(I),I=1, 20) / + 8, 11, 1, 12, 14, 10, 6, 1, 10, 14, 14, 6, 13, 12, 10, + 10, 1, 4, 9, 8 +/ DATA (TAGMAG(K, 1),K=1, 8)/ +'F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 1),K=1, 8) / + 0.00, 20.00, 35.60, 59.00, 77.00,126.00,158.00,175.00 +/ DATA (((REMAG(K,L,M, 1),K=1,2),L=1,2),M=1, 8) / + 18.56,-102.15, 15.69,-102.16, 17.94, -96.02, 14.93, -96.40, + 18.12, -92.07, 14.51, -92.31, 20.95, -75.38, 16.58, -74.58, + 22.88, -67.14, 17.81, -66.34, 23.27, -55.51, 18.18, -55.41, + 22.62, -42.18, 17.60, -42.73, 21.58, -30.28, 16.93, -31.59 +/ DATA (TAGMAG(K, 2),K=1, 11)/ +'F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 2),K=1, 11) / + 0.00, 9.50, 20.00, 27.50, 35.70, 59.00, 63.40, 67.00, + 77.00,126.00,150.00 +/ DATA (((REMAG(K,L,M, 2),K=1,2),L=1,2),M=1, 11) / + 22.94,-108.62, 19.57,-110.03, 20.73,-106.17, 18.90,-106.87, + 25.27,-102.94, 18.54,-102.97, 24.14,-101.56, 18.49,-101.64, + 24.11, -97.49, 18.53, -96.65, 25.83, -82.46, 21.44, -81.63, + 26.16, -80.77, 21.81, -79.71, 26.56, -80.43, 22.47, -79.16, + 26.83, -75.41, 23.15, -73.96, 27.75, -64.59, 24.02, -63.72, + 24.35, -51.14, 23.84, -51.61 +/ DATA (TAGMAG(K, 3),K=1, 1)/ +' ' +/ DATA (AGEMAG(K, 3),K=1, 1) / + 1.00 +/ DATA (((REMAG(K,L,M, 3),K=1,2),L=1,2),M=1, 1) / + -19.43,-148.18, -19.43, -61.82 +/ DATA (TAGMAG(K, 4),K=1, 12)/ +'F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 4),K=1, 12) / + 9.50, 20.00, 27.50, 35.70, 49.30, 59.00, 63.40, 67.00, + 77.00,126.00,150.00,158.00 +/ DATA (((REMAG(K,L,M, 4),K=1,2),L=1,2),M=1, 12) / + 25.31,-108.39, 24.78,-108.37, 31.00,-106.14, 24.87,-105.49, + 31.43,-103.56, 24.04,-103.46, 31.38, -99.00, 24.02, -98.31, + 31.79, -96.01, 24.87, -94.72, 32.55, -90.64, 25.62, -90.16, + 32.71, -88.50, 25.76, -88.05, 33.05, -87.18, 25.94, -86.84, + 33.50, -82.33, 26.27, -82.02, 33.55, -70.63, 28.86, -69.79, + 34.12, -58.08, 29.49, -57.53, 29.87, -52.81, 29.29, -53.33 +/ DATA (TAGMAG(K, 5),K=1, 14)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 5),K=1, 14) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 77.00,126.00, +134.00,145.00, 63.00, 70.00, 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 5),K=1,2),L=1,2),M=1, 14) / + 31.79,-105.61, 31.33,-105.60, 32.92,-101.69, 31.43,-102.34, + 35.03, -96.52, 31.78, -96.40, 35.86, -92.66, 32.07, -92.63, + 37.00, -88.90, 32.71, -88.77, 37.71, -82.69, 33.09, -83.14, + 39.64, -74.13, 33.98, -74.48, 37.49, -61.88, 34.61, -62.56, + 37.06, -58.84, 35.72, -59.17, 35.06, -54.81, 34.80, -55.03, + 29.09, -51.09, 28.96, -52.66, 27.33, -42.94, 28.04, -52.02, + 23.76, -35.06, 25.63, -51.21, 22.46, -31.91, 22.25, -32.23 +/ DATA (TAGMAG(K, 6),K=1, 10)/ +'F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 6),K=1, 10) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 77.00,126.00, +134.00,145.00 +/ DATA (((REMAG(K,L,M, 6),K=1,2),L=1,2),M=1, 10) / + 31.79,-105.61, 31.33,-105.60, 32.92,-101.69, 31.43,-102.34, + 35.03, -96.52, 31.78, -96.40, 35.86, -92.66, 32.07, -92.63, + 37.00, -88.90, 32.71, -88.77, 37.71, -82.69, 33.09, -83.14, + 39.64, -74.13, 33.98, -74.48, 37.49, -61.88, 34.61, -62.56, + 37.06, -58.84, 35.72, -59.17, 35.06, -54.81, 34.80, -55.03 +/ DATA (TAGMAG(K, 7),K=1, 6)/ +'F','F','F','F','F','F' +/ DATA (AGEMAG(K, 7),K=1, 6) / + 80.00,119.00,126.00,134.00,142.00,145.00 +/ DATA (((REMAG(K,L,M, 7),K=1,2),L=1,2),M=1, 6) / + 38.41, -73.66, 38.02, -73.74, 42.86, -64.16, 37.77, -64.67, + 42.76, -61.27, 37.56, -62.75, 42.63, -58.05, 37.14, -59.29, + 38.53, -56.43, 36.04, -56.47, 35.06, -54.81, 34.80, -55.03 +/ DATA (TAGMAG(K, 8),K=1, 1)/ +' ' +/ DATA (AGEMAG(K, 8),K=1, 1) / + 1.00 +/ DATA (((REMAG(K,L,M, 8),K=1,2),L=1,2),M=1, 1) / + -19.43,-148.18, -19.43, -61.82 +/ DATA (TAGMAG(K, 9),K=1, 10)/ +'V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 9),K=1, 10) / + 20.00, 27.50, 27.50, 35.70, 42.00, 49.30, 59.00, 77.00, +119.00,126.00 +/ DATA (((REMAG(K,L,M, 9),K=1,2),L=1,2),M=1, 10) / + 37.79,-108.03, 37.41,-108.01, 37.61,-102.97, 36.01,-103.23, + 34.89,-100.23, 32.53,-101.45, 35.80, -95.98, 33.75, -95.69, + 35.91, -91.95, 33.90, -91.90, 36.09, -87.77, 34.12, -87.61, + 36.79, -81.49, 35.13, -81.34, 39.76, -73.75, 37.51, -73.24, + 42.89, -66.57, 42.23, -66.39, 43.69, -63.27, 42.89, -63.28 +/ DATA (TAGMAG(K, 10),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 10),K=1, 14) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 63.40, 63.20, + 67.00, 77.00,119.00,126.00,134.00,140.00 +/ DATA (((REMAG(K,L,M, 10),K=1,2),L=1,2),M=1, 14) / + 37.79,-108.03, 37.41,-108.01, 37.61,-102.97, 36.01,-103.23, + 37.64, -97.96, 35.97, -98.10, 37.75, -94.67, 35.97, -94.69, + 37.72, -90.93, 36.00, -90.81, 38.38, -83.89, 36.73, -83.58, + 39.08, -82.19, 37.30, -81.95, 40.55, -80.73, 37.93, -80.73, + 41.06, -79.60, 38.27, -79.68, 41.15, -75.80, 39.05, -75.32, + 42.89, -66.57, 42.23, -66.39, 43.69, -63.27, 42.89, -63.28, + 44.12, -60.23, 43.16, -60.01, 43.44, -58.90, 43.03, -59.25 +/ DATA (TAGMAG(K, 11),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 11),K=1, 14) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 59.00, 67.00, 77.00,126.00,134.00,142.00 +/ DATA (((REMAG(K,L,M, 11),K=1,2),L=1,2),M=1, 14) / + 42.80,-126.60, 40.17,-127.40, 42.45,-125.24, 40.18,-126.21, + 42.51,-123.83, 38.69,-124.00, 41.42,-118.95, 38.25,-119.07, + 41.80,-115.62, 38.70,-116.11, 41.73,-112.10, 38.61,-112.52, + 41.22,-108.00, 38.01,-108.00, 40.63,-103.87, 36.89,-103.78, + 40.11, -97.66, 36.61, -96.10, 41.28, -95.05, 37.77, -93.70, + 42.37, -89.93, 38.82, -88.54, 46.74, -67.31, 43.62, -66.65, + 47.13, -64.52, 43.92, -63.34, 44.44, -59.85, 43.90, -60.31 +/ DATA (TAGMAG(K, 12),K=1, 6)/ +'V','V','V','V','V','V' +/ DATA (AGEMAG(K, 12),K=1, 6) / + 20.00, 27.50, 35.70, 42.00, 49.30, 55.00 +/ DATA (((REMAG(K,L,M, 12),K=1,2),L=1,2),M=1, 6) / + 41.42,-118.95, 38.25,-119.07, 45.28,-113.55, 41.70,-114.19, + 45.66,-109.22, 41.61,-109.93, 45.23,-105.57, 41.19,-105.83, + 44.74,-102.25, 40.68,-101.27, 41.28, -97.71, 40.35, -97.82 +/ DATA (TAGMAG(K, 13),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 13),K=1, 13) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 59.00, 67.00, 77.00,126.00,138.00 +/ DATA (((REMAG(K,L,M, 13),K=1,2),L=1,2),M=1, 13) / + 47.52,-129.44, 44.01,-131.35, 47.85,-128.22, 44.65,-129.45, + 47.92,-125.54, 44.65,-125.76, 46.84,-119.55, 43.63,-119.79, + 49.83,-114.87, 45.98,-115.58, 49.89,-111.38, 45.89,-112.04, + 49.48,-107.86, 45.30,-108.35, 48.95,-104.30, 44.77,-103.58, + 48.49, -98.41, 41.04, -94.18, 48.61, -95.69, 41.87, -92.40, + 48.03, -89.23, 43.04, -87.07, 48.19, -69.04, 46.47, -68.60, + 47.91, -64.03, 47.09, -64.69 +/ DATA (TAGMAG(K, 14),K=1, 12)/ +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 14),K=1, 12) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 55.00, 60.00, 70.00, 80.00 +/ DATA (((REMAG(K,L,M, 14),K=1,2),L=1,2),M=1, 12) / + 49.95,-129.96, 49.31,-130.63, 50.47,-127.83, 49.04,-128.48, + 51.53,-125.42, 48.75,-125.65, 53.85,-120.86, 50.28,-120.71, + 53.84,-116.82, 50.00,-116.45, 53.79,-112.59, 50.21,-113.72, + 53.31,-108.95, 49.63,-109.89, 52.91,-105.16, 49.01,-105.38, + 52.35, -97.70, 50.29,-102.04, 50.89, -92.02, 48.29, -97.46, + 50.22, -85.37, 47.95, -94.94, 47.98, -87.21, 47.06, -87.52 +/ DATA (TAGMAG(K, 15),K=1, 10)/ +'V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 15),K=1, 10) / + 20.00, 27.50, 35.70, 42.00, 49.30, 55.00, 60.00, 70.00, + 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 15),K=1,2),L=1,2),M=1, 10) / + 54.36,-119.14, 53.89,-119.00, 55.81,-113.13, 53.94,-113.12, + 55.83,-108.54, 53.46,-109.23, 55.47,-104.55, 53.69,-106.77, + 54.74, -90.64, 52.76,-105.12, 54.29, -83.33, 52.27, -97.86, + 52.67, -80.56, 50.89, -92.02, 51.46, -76.45, 50.20, -85.38, + 48.43, -71.70, 47.38, -86.57, 48.19, -70.92, 47.62, -71.30 +/ DATA (TAGMAG(K, 16),K=1, 10)/ +'V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 16),K=1, 10) / + 27.50, 35.70, 42.00, 43.80, 49.30, 55.00, 60.00, 70.00, + 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 16),K=1,2),L=1,2),M=1, 10) / + 55.81,-113.13, 53.94,-113.12, 57.13,-107.59, 55.82,-107.83, + 56.87,-104.45, 55.55,-104.70, 56.92, -98.43, 55.82,-104.47, + 54.74, -90.64, 52.76,-105.12, 54.29, -83.33, 52.27, -97.86, + 53.99, -74.13, 52.62, -80.64, 52.69, -70.12, 51.31, -76.44, + 49.62, -66.86, 48.58, -72.30, 49.04, -66.19, 48.61, -66.52 +/ DATA (TAGMAG(K, 17),K=1, 1)/ +' ' +/ DATA (AGEMAG(K, 17),K=1, 1) / + 1.00 +/ DATA (((REMAG(K,L,M, 17),K=1,2),L=1,2),M=1, 1) / + -19.43,-148.18, -19.43, -61.82 +/ DATA (TAGMAG(K, 18),K=1, 4)/ +'K','K','K','K' +/ DATA (AGEMAG(K, 18),K=1, 4) / + 60.00, 70.00, 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 18),K=1,2),L=1,2),M=1, 4) / + 41.90,-115.31, 41.00,-112.55, 42.23,-101.71, 42.77,-112.64, + 43.03, -93.70, 44.73,-113.87, 43.41, -90.97, 46.59,-115.84 +/ DATA (TAGMAG(K, 19),K=1, 9)/ +'K','K','K','K','K','K','K','K','K' +/ DATA (AGEMAG(K, 19),K=1, 9) / + 43.80, 49.30, 55.00, 60.00, 70.00, 80.00, 85.00,120.00, +126.00 +/ DATA (((REMAG(K,L,M, 19),K=1,2),L=1,2),M=1, 9) / + 59.09,-149.03, 59.89,-142.34, 58.82,-156.71, 60.77,-139.67, + 61.45,-156.85, 63.34,-138.15, 62.63,-158.20, 64.48,-142.39, + 63.87,-159.93, 65.64,-146.99, 64.97,-172.94, 67.91,-149.21, + 65.83,-173.24, 68.92,-150.89, 66.15,-173.52, 69.23,-149.53, + 70.48,-143.92, 69.56,-142.41 +/ DATA (TAGMAG(K, 20),K=1, 8)/ +'K','K','K','K','K','K','K','K' +/ DATA (AGEMAG(K, 20),K=1, 8) / +120.00,126.00,134.00,142.00,158.00,175.00,225.00,250.00 +/ DATA (((REMAG(K,L,M, 20),K=1,2),L=1,2),M=1, 8) / + 74.07,-164.86, 73.39,-162.42, 80.84, 164.16, 72.08,-152.08, + 82.40, 148.05, 68.93,-139.56, 83.24, 111.62, 64.66,-127.88, + 75.74,-125.97, 50.70,-118.40, 70.36, 46.54, 46.22,-101.71, + 61.75, 22.89, 42.39, -88.39, 50.97, 4.24, 39.88, -79.37 +/ C C===================================================================== CALL BELOWY(INPUT,ECLOG,FROMW, 1 NELCOL,NUMEL, 2 PUSHUP,RAMP,SLABSZ,TIME, 3 WANDES,XIP,YIP, 4 MAXHL,MAXHNG,MAXROT,MAXVEL,MXKV3J,MXVF3J, 5 MTAPES,MTAPP1,MAXFZP,MAXMAG, 6 NKV3J, 7 NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, 8 TUMAP, 9 AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, A FRACZN,NMAG,NPFZ,NPHING, 1 OMEGAF,OMEGAK,OMEGAP,OMEGAV, 2 REHING,REKV3J,REMAG,REVF3J, 3 ROMATF,ROMATK,ROMATP,ROMATV, 4 TAGFZ,TAGMAG, 5 OUTPUT,SZZ,TOUCH,VSLAB) RETURN END SUBROUTINE BELOW2 C C C SUBROUTINE BELOWY(INPUT,ECLOG,FROMW, 1 NELCOL,NUMEL, 2 PUSHUP,RAMP,SLABSZ,TIME, 3 WANDES,XIP,YIP, 4 MAXHL,MAXHNG,MAXROT,MAXVEL,MXKV3J,MXVF3J, 5 MTAPES,MTAPP1,MAXFZP,MAXMAG, 6 NKV3J, 7 NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, 8 TUMAP, 9 AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, A FRACZN,NMAG,NPFZ,NPHING, 1 OMEGAF,OMEGAK,OMEGAP,OMEGAV, 2 REHING,REKV3J,REMAG,REVF3J, 3 ROMATF,ROMATK,ROMATP,ROMATV, 4 TAGFZ,TAGMAG, 5 OUTPUT,SZZ,TOUCH,VSLAB) C C CUSTOM ROUTINE TO DESCRIBE THE MOTIONS OF THE FOUR OCEANIC C PLATES (FARALLON, KULA, PACIFIC, AND VANCOUVER) IN CONTACT C WITH NORTH AMERICA. C ACCEPTS LOCATIONS OF INTEGRATION POINTS OF EITHER GRID IN C (CONIC-PROJECTION-PLANE) CARTESIAN UNITS, PLUS C POSITION OF X/Y ORIGIN ON EARTH TO DEFINE CARTESIAN SYSTEM, PLUS C EARTH RADIUS AND LATITUDE OF PROJECTION TANGENT TO DEFINE MAP, C TIME BEFORE PRESENT, AND 2 PARAMETERS GOVERNING SLAB WEIGHTS. C OUTPUTS SLAB VERTICAL LOAD, CONTACT INDICATOR, AND SLAB VELOCITY. C ALL NECESSARY DATA ARE PASSED BY PARENT PROGRAM "BELOW1" OR C "BELOW2"-ONLY ONE OF WHICH WILL BE ACTIVE IN CALLING THIS C CODE (FOR NORTHERN OR SOUTHERN OPTIONS, RESPECTIVELY). C C STATEMENT FUNCTIONS: REAL COSDEG,S,SINDEG,TANDEG SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C CHARACTER*1 TAGFZ,TAGMAG,TAGLIN LOGICAL ABOVE,BELOW,FARALL,KULA,PACIFI,VANCOU REAL ANGLE,DOT C DIMENSION AGEFZ(MAXFZP,MTAPP1), 2 AGEHNG(MAXHL), 3 AGEKV(MXKV3J), 4 AGEMAG(MAXMAG,MTAPES), 5 AGEROT(MAXROT), 6 AGEVEL(MAXVEL), 7 AGEVF(MXVF3J), 8 FRACZN(2,MAXFZP,MTAPP1), 9 NPFZ(MTAPP1), A NPHING(MAXHNG) DIMENSION NMAG(MTAPES), 2 OMEGAF(3,MAXVEL), 3 OMEGAK(3,MAXVEL), 4 OMEGAP(3,MAXVEL), 5 OMEGAV(3,MAXVEL), 6 REHING(2,MAXHNG,MAXHL), 7 REKV3J(3,MXKV3J), 8 REMAG(2,2,MAXMAG,MTAPES), 9 REVF3J(3,MXVF3J), A ROMATF(3,3,MAXROT), 1 ROMATK(3,3,MAXROT), 2 ROMATP(3,3,MAXROT), 3 ROMATV(3,3,MAXROT), 4 TAGFZ(MAXFZP,MTAPP1), 5 TAGMAG(MAXMAG,MTAPES) DIMENSION FROMW(7,NUMEL), + SZZ(7,NUMEL),TAGLIN(100), + TOUCH(7,NUMEL),VSLAB(2,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) SAVE ICALL,NEWIDE, + TAGLIN DATA BIGNUM/9.9E37/ DATA ICALL/0/ C ICALL=ICALL+1 C C===================================================================== C SETUP WORK IS PERFORMED ONLY ON THE FIRST CALL: IF (ICALL.EQ.1) THEN C C (1) ALGEBRA C NEWIDE=2*NELCOL UNITE1= -SINDEG(X0ELON) UNITE2= COSDEG(X0ELON) UNITE3=0. UNITN1= -COSDEG(X0ELON)*SINDEG(Y0NLAT) UNITN2= -SINDEG(X0ELON)*SINDEG(Y0NLAT) UNITN3=COSDEG(Y0NLAT) R1=COSDEG(X0ELON)*COSDEG(Y0NLAT) R2=SINDEG(X0ELON)*COSDEG(Y0NLAT) R3=SINDEG(Y0NLAT) A11= -R3*UNITE2+R2*UNITE3 A12= R3*UNITE1-R1*UNITE3 A13= -R2*UNITE1+R1*UNITE2 A21= -R3*UNITN2+R2*UNITN3 A22= R3*UNITN1-R1*UNITN3 A23= -R2*UNITN1+R1*UNITN2 A31=R1 A32=R2 A33=R3 C C (2) CHARACTERIZE FRACTURE ZONES, AS TO WHICH PLATE THEY BELONG TO C DO 20 I=1,NTAPP1 NP=0 NF=0 NV=0 NK=0 DO 10 J=1,NPFZ(I) IF (TAGFZ(J,I).EQ.'p'.OR.TAGFZ(J,I).EQ.'P') THEN NP=NP+1 ELSE IF (TAGFZ(J,I).EQ.'f'.OR.TAGFZ(J,I).EQ.'F') THEN NF=NF+1 ELSE IF (TAGFZ(J,I).EQ.'v'.OR.TAGFZ(J,I).EQ.'V') THEN NV=NV+1 ELSE IF (TAGFZ(J,I).EQ.'k'.OR.TAGFZ(J,I).EQ.'K') THEN NK=NK+1 ENDIF 10 CONTINUE IF ((NP.GT.NF).AND.(NP.GT.NV).AND.(NP.GT.NK)) THEN TAGLIN(I)='P' ELSE IF ((NF.GT.NP).AND.(NF.GT.NV).AND.(NF.GT.NK)) THEN TAGLIN(I)='F' ELSE IF ((NK.GT.NV).AND.(NK.GT.NF).AND.(NK.GT.NP)) THEN TAGLIN(I)='K' ELSE IF ((NV.GT.NF).AND.(NV.GT.NP).AND.(NV.GT.NK)) THEN TAGLIN(I)='V' ENDIF 20 CONTINUE C C (3) CONVERT (LAT,LON) POSITIONS IN DATA ARRAYS TO (X,Y) C DO 40 J=1,NUMHNG DO 30 I=1,NPHING(J) PLAT=REHING(1,I,J) PLON=REHING(2,I,J) CALL LLTOXY (INPUT, + PLAT,PLON, + OUTPUT,X,Y) REHING(1,I,J)=X REHING(2,I,J)=Y 30 CONTINUE 40 CONTINUE DO 60 J=1,NTAPP1 DO 50 I=1,NPFZ(J) PLAT=FRACZN(1,I,J) PLON=FRACZN(2,I,J) CALL LLTOXY (INPUT, + PLAT,PLON, + OUTPUT,X,Y) FRACZN(1,I,J)=X FRACZN(2,I,J)=Y 50 CONTINUE 60 CONTINUE DO 90 J=1,NTAPES DO 80 I=1,NMAG(J) DO 70 K=1,2 PLAT=REMAG(1,K,I,J) PLON=REMAG(2,K,I,J) CALL LLTOXY (INPUT, + PLAT,PLON, + OUTPUT,X,Y) REMAG(1,K,I,J)=X REMAG(2,K,I,J)=Y 70 CONTINUE 80 CONTINUE 90 CONTINUE DO 100 I=1,NKV3J PLAT=REKV3J(1,I) PLON=REKV3J(2,I) DPLON=PLON-X0ELON IF (DPLON.LT.-180.) DPLON=DPLON+360. IF (DPLON.GT. 180.) DPLON=DPLON-360. ANGLE=DPLON*SINDEG(CPNLAT) REKV3J(3,I)=REKV3J(3,I)+ANGLE CALL LLTOXY (INPUT, + PLAT,PLON, + OUTPUT,X,Y) REKV3J(1,I)=X REKV3J(2,I)=Y 100 CONTINUE DO 110 I=1,NKV3J PLAT=REVF3J(1,I) PLON=REVF3J(2,I) DPLON=PLON-X0ELON IF (DPLON.LT.-180.) DPLON=DPLON+360. IF (DPLON.GT. 180.) DPLON=DPLON-360. ANGLE=DPLON*SINDEG(CPNLAT) REVF3J(3,I)=REVF3J(3,I)+ANGLE CALL LLTOXY (INPUT, + PLAT,PLON, + OUTPUT,X,Y) REVF3J(1,I)=X REVF3J(2,I)=Y 110 CONTINUE C C (4) CONVERT ROTATION-AXIS VECTORS FROM (X,Y,Z) CARTESIAN SYSTEM C AND RADIANS/SEC UNITS TO LOCAL VX = VEAST, VY=VNORTH, C AND SPIN RATE AT ORIGIN OF CONIC-PROJECTION (X,Y) SYSTEM. C NEW UNITS WILL BE (PROGRAM LENGTH UNITS)/SEC AND RADS/SEC. C DO 120 I=1,NUMVEL O1=OMEGAF(1,I) O2=OMEGAF(2,I) O3=OMEGAF(3,I) VX=A11*O1+A12*O2+A13*O3 VY=A21*O1+A22*O2+A23*O3 SP=A31*O1+A32*O2+A33*O3 OMEGAF(1,I)=VX*RADIUS OMEGAF(2,I)=VY*RADIUS OMEGAF(3,I)=SP 120 CONTINUE DO 130 I=1,NUMVEL O1=OMEGAK(1,I) O2=OMEGAK(2,I) O3=OMEGAK(3,I) VX=A11*O1+A12*O2+A13*O3 VY=A21*O1+A22*O2+A23*O3 SP=A31*O1+A32*O2+A33*O3 OMEGAK(1,I)=VX*RADIUS OMEGAK(2,I)=VY*RADIUS OMEGAK(3,I)=SP 130 CONTINUE DO 140 I=1,NUMVEL O1=OMEGAP(1,I) O2=OMEGAP(2,I) O3=OMEGAP(3,I) VX=A11*O1+A12*O2+A13*O3 VY=A21*O1+A22*O2+A23*O3 SP=A31*O1+A32*O2+A33*O3 OMEGAP(1,I)=VX*RADIUS OMEGAP(2,I)=VY*RADIUS OMEGAP(3,I)=SP 140 CONTINUE DO 150 I=1,NUMVEL O1=OMEGAV(1,I) O2=OMEGAV(2,I) O3=OMEGAV(3,I) VX=A11*O1+A12*O2+A13*O3 VY=A21*O1+A22*O2+A23*O3 SP=A31*O1+A32*O2+A33*O3 OMEGAV(1,I)=VX*RADIUS OMEGAV(2,I)=VY*RADIUS OMEGAV(3,I)=SP 150 CONTINUE ENDIF C==================================================================== C C SELECT TIME WINDOWS FOR RELATIVE VELOCITY, FINITE ROTATION, 3-J C LOCATION, AND HINGE LOCATION C TMY=TIME/TUMAP C C (1) BOUNDING INDECES AND FRACTION FOR RELATIVE VELOCITY C IT1=1 IT2=NUMVEL DO 210 I=2,NUMVEL IF (AGEVEL(I).LE.TMY) IT1=I J=NUMVEL+1-I IF (AGEVEL(J).GT.TMY) IT2=J 210 CONTINUE FT2=(TMY-AGEVEL(IT1))/MAX(1.,(AGEVEL(IT2)-AGEVEL(IT1))) FT1=1.00-FT2 VXFD= FT1*OMEGAF(1,IT1)+FT2*OMEGAF(1,IT2) VYFD= FT1*OMEGAF(2,IT1)+FT2*OMEGAF(2,IT2) SPINF=FT1*OMEGAF(3,IT1)+FT2*OMEGAF(3,IT2) VXKD= FT1*OMEGAK(1,IT1)+FT2*OMEGAK(1,IT2) VYKD= FT1*OMEGAK(2,IT1)+FT2*OMEGAK(2,IT2) SPINK=FT1*OMEGAK(3,IT1)+FT2*OMEGAK(3,IT2) VXPD= FT1*OMEGAP(1,IT1)+FT2*OMEGAP(1,IT2) VYPD= FT1*OMEGAP(2,IT1)+FT2*OMEGAP(2,IT2) SPINP=FT1*OMEGAP(3,IT1)+FT2*OMEGAP(3,IT2) VXVD= FT1*OMEGAV(1,IT1)+FT2*OMEGAV(1,IT2) VYVD= FT1*OMEGAV(2,IT1)+FT2*OMEGAV(2,IT2) SPINV=FT1*OMEGAV(3,IT1)+FT2*OMEGAV(3,IT2) C C (2) BOUNDING INDECES AND FRACTION FOR FINITE ROTATIONS C IROT1=1 IROT2=NROMAT DO 220 I=2,NROMAT IF (AGEROT(I).LE.TMY) IROT1=I J=NROMAT+1-I IF (AGEROT(J).GT.TMY) IROT2=J 220 CONTINUE TFRAC=(TMY-AGEROT(IROT1))/MAX((AGEROT(IROT2)-AGEROT(IROT1)),1.) C C (3A) BOUNDING INDECES FOR KULA/VANCOUVER TRIPLE-JUNCTION LOCATION C IKV3J1=1 IKV3J2=NKV3J DO 230 I=2,NKV3J IF (AGEKV(I).LE.TMY) IKV3J1=I J=NKV3J+1-I IF (AGEKV(J).GT.TMY) IKV3J2=J 230 CONTINUE FKV3J2=(TMY-AGEKV(IKV3J1))/MAX(1.,(AGEKV(IKV3J2)-AGEKV(IKV3J1))) FKV3J1=1.00-FKV3J2 XKV=FKV3J1*REKV3J(1,IKV3J1)+FKV3J2*REKV3J(1,IKV3J2) YKV=FKV3J1*REKV3J(2,IKV3J1)+FKV3J2*REKV3J(2,IKV3J2) AKV=FKV3J1*REKV3J(3,IKV3J1)+FKV3J2*REKV3J(3,IKV3J2) C C (3B) BOUNDING INDECES FOR VANCOUVER/FARALLON 3-JUNCTION LOCATION C IVF3J1=1 IVF3J2=NVF3J DO 240 I=2,NVF3J IF (AGEVF(I).LE.TMY) IVF3J1=I J=NVF3J+1-I IF (AGEVF(J).GT.TMY) IVF3J2=J 240 CONTINUE FVF3J2=(TMY-AGEVF(IVF3J1))/MAX(1.,(AGEVF(IVF3J2)-AGEVF(IVF3J1))) FVF3J1=1.00-FVF3J2 XVF=FVF3J1*REVF3J(1,IVF3J1)+FVF3J2*REVF3J(1,IVF3J2) YVF=FVF3J1*REVF3J(2,IVF3J1)+FVF3J2*REVF3J(2,IVF3J2) AVF=FVF3J1*REVF3J(3,IVF3J1)+FVF3J2*REVF3J(3,IVF3J2) C C (4) BOUNDING INDECES AND FRACTION FOR HINGE LOCATION C IH1=1 IH2=NUMHNG DO 250 I=2,NUMHNG IF (TMY.LE.AGEHNG(I)) IH1=I IP=NUMHNG+1-I IF (TMY.GT.AGEHNG(IP)) IH2=IP 250 CONTINUE FH1=(TMY-AGEHNG(IH2))/MAX(1.,(AGEHNG(IH1)-AGEHNG(IH2))) FH2=1.00-FH1 C C MAIN (DOUBLE) LOOP ON ALL INTEGRATION POINTS IN FINITE ELEMENT GRID C DO 1000 I=1,NUMEL DO 900 M=1,7 X=XIP(M,I) Y=YIP(M,I) C C TEST FOR CONTACT OF SLABS WITH THE CONTINENT C J1M=1 J1N=2 D1=RADIUS D2=D1*1.1 DO 300 J=1,NPHING(IH1) D=SQRT((X-REHING(1,J,IH1))**2+ + (Y-REHING(2,J,IH1))**2) IF (D.LT.D1) THEN D2=D1 J1N=J1M D1=D J1M=J ELSE IF (D.LT.D2) THEN D2=D J1N=J ENDIF 300 CONTINUE IF (J1N.LT.J1M) THEN J=J1N J1N=J1M J1M=J ENDIF J2M=1 J2N=2 D1=RADIUS D2=D1*1.1 DO 350 J=1,NPHING(IH2) D=SQRT((X-REHING(1,J,IH2))**2+ + (Y-REHING(2,J,IH2))**2) IF (D.LT.D1) THEN D2=D1 J2N=J2M D1=D J2M=J ELSE IF (D.LT.D2) THEN D2=D J2N=J ENDIF 350 CONTINUE IF (J2N.LT.J2M) THEN J=J2N J2N=J2M J2M=J ENDIF X1=REHING(1,J1M,IH1) X2=REHING(1,J1N,IH1) X3=X Y1=REHING(2,J1M,IH1) Y2=REHING(2,J1N,IH1) Y3=Y AREA1=0.5*(X1*Y2-X2*Y1 + +X2*Y3-X3*Y2 + +X3*Y1-X1*Y3) SIDE1=SQRT((X1-X2)**2+(Y1-Y2)**2) DIST1=2.*AREA1/SIDE1 X1=REHING(1,J2M,IH2) X2=REHING(1,J2N,IH2) X3=X Y1=REHING(2,J2M,IH2) Y2=REHING(2,J2N,IH2) Y3=Y AREA2=0.5*(X1*Y2-X2*Y1 + +X2*Y3-X3*Y2 + +X3*Y1-X1*Y3) SIDE2=SQRT((X1-X2)**2+(Y1-Y2)**2) DIST2=2.*AREA2/SIDE2 DIST=FH1*DIST1+FH2*DIST2 TOUCH(M,I)=MIN(1.,MAX(0.,1.-(DIST/RAMP))) C C DETERMINE WHICH SLAB IS BENEATH POINT C DIVN=YKV+(X-XKV)*TANDEG(AKV) DIVS=YVF+(X-XVF)*TANDEG(AVF) KULA= Y.GT.DIVN VANCOU=(Y.LE.DIVN).AND.(Y.GT.DIVS) FARALL= Y.LE.DIVS C C COMPUTE VELOCITY OF SLAB C IF (FARALL) THEN VSLAB(1,M,I)=VXFD-Y*SPINF VSLAB(2,M,I)=VYFD+X*SPINF ELSE IF (KULA) THEN VSLAB(1,M,I)=VXKD-Y*SPINK VSLAB(2,M,I)=VYKD+X*SPINK ELSE IF (VANCOU) THEN VSLAB(1,M,I)=VXVD-Y*SPINV VSLAB(2,M,I)=VYVD+X*SPINV ENDIF C C CONVERT TO CARTESIAN 3-D COORDINATES IN RANGE -1 TO +1 C CALL XYTOLL (INPUT, + X,Y, + OUTPUT,PLAT,PLON) CX=COSDEG(PLAT)*COSDEG(PLON) CY=COSDEG(PLAT)*SINDEG(PLON) CZ=SINDEG(PLAT) C C ROTATE TO TWO NEW (LAT,LON) POINTS WITH BOUNDING ROTATIONS C IF (FARALL) THEN CX1=ROMATF(1,1,IROT1)*CX+ROMATF(1,2,IROT1)*CY + +ROMATF(1,3,IROT1)*CZ CY1=ROMATF(2,1,IROT1)*CX+ROMATF(2,2,IROT1)*CY + +ROMATF(2,3,IROT1)*CZ CZ1=ROMATF(3,1,IROT1)*CX+ROMATF(3,2,IROT1)*CY + +ROMATF(3,3,IROT1)*CZ CX2=ROMATF(1,1,IROT2)*CX+ROMATF(1,2,IROT2)*CY + +ROMATF(1,3,IROT2)*CZ CY2=ROMATF(2,1,IROT2)*CX+ROMATF(2,2,IROT2)*CY + +ROMATF(2,3,IROT2)*CZ CZ2=ROMATF(3,1,IROT2)*CX+ROMATF(3,2,IROT2)*CY + +ROMATF(3,3,IROT2)*CZ ELSE IF (KULA) THEN CX1=ROMATK(1,1,IROT1)*CX+ROMATK(1,2,IROT1)*CY + +ROMATK(1,3,IROT1)*CZ CY1=ROMATK(2,1,IROT1)*CX+ROMATK(2,2,IROT1)*CY + +ROMATK(2,3,IROT1)*CZ CZ1=ROMATK(3,1,IROT1)*CX+ROMATK(3,2,IROT1)*CY + +ROMATK(3,3,IROT1)*CZ CX2=ROMATK(1,1,IROT2)*CX+ROMATK(1,2,IROT2)*CY + +ROMATK(1,3,IROT2)*CZ CY2=ROMATK(2,1,IROT2)*CX+ROMATK(2,2,IROT2)*CY + +ROMATK(2,3,IROT2)*CZ CZ2=ROMATK(3,1,IROT2)*CX+ROMATK(3,2,IROT2)*CY + +ROMATK(3,3,IROT2)*CZ ELSE IF (VANCOU) THEN CX1=ROMATV(1,1,IROT1)*CX+ROMATV(1,2,IROT1)*CY + +ROMATV(1,3,IROT1)*CZ CY1=ROMATV(2,1,IROT1)*CX+ROMATV(2,2,IROT1)*CY + +ROMATV(2,3,IROT1)*CZ CZ1=ROMATV(3,1,IROT1)*CX+ROMATV(3,2,IROT1)*CY + +ROMATV(3,3,IROT1)*CZ CX2=ROMATV(1,1,IROT2)*CX+ROMATV(1,2,IROT2)*CY + +ROMATV(1,3,IROT2)*CZ CY2=ROMATV(2,1,IROT2)*CX+ROMATV(2,2,IROT2)*CY + +ROMATV(2,3,IROT2)*CZ CZ2=ROMATV(3,1,IROT2)*CX+ROMATV(3,2,IROT2)*CY + +ROMATV(3,3,IROT2)*CZ ELSE CX1=CX CX2=CX CY1=CY CY2=CY CZ1=CZ CZ2=CZ ENDIF C C RECONVERT TO (LAT,LON) COORDINATES IN DEGREES C PLAT1=57.29578*ASIN(CZ1) PLON1=57.29578*ATAN2F(CY1,CX1) PLAT2=57.29578*ASIN(CZ2) PLON2=57.29578*ATAN2F(CY2,CX2) C C CONVERT TO CONIC PROJECTION AND AVERAGE C CALL LLTOXY (INPUT, + PLAT1,PLON1, + OUTPUT,X1,Y1) CALL LLTOXY (INPUT, + PLAT2,PLON2, + OUTPUT,X2,Y2) XM=X2*TFRAC+X1*(1.-TFRAC) YM=Y2*TFRAC+Y1*(1.-TFRAC) C C FIND FRACTURE-ZONE LINES ENCLOSING POINT C KROW= -1 DO 500 K=1,NTAPES IF (KULA) THEN IF ((TAGLIN(K ).NE.'K').OR. + (TAGLIN(K+1).NE.'K')) GO TO 500 ELSE IF (VANCOU.OR.FARALL) THEN IF (TMY.GE.59.) THEN IF (.NOT.(TAGLIN(K ).EQ.'V'.OR. + TAGLIN(K ).EQ.'F' ) .OR. + .NOT.(TAGLIN(K+1).EQ.'V'.OR. + TAGLIN(K+1).EQ.'F')) GO TO 500 ELSE IF (VANCOU) THEN IF ((TAGLIN(K ).NE.'V').OR. + (TAGLIN(K+1).NE.'V')) GO TO 500 ELSE IF (FARALL) THEN IF ((TAGLIN(K ).NE.'F').OR. + (TAGLIN(K+1).NE.'F')) GO TO 500 ENDIF ENDIF ENDIF RMIN2=BIGNUM DO 400 J=1,NPFZ(K) R2=(XM-FRACZN(1,J,K))**2+ + (YM-FRACZN(2,J,K))**2 IF (R2.LT.RMIN2) THEN JSAVE=J RMIN2=R2 ENDIF 400 CONTINUE XP=FRACZN(1,JSAVE,K) YP=FRACZN(2,JSAVE,K) IF (JSAVE.EQ.1) THEN XE=FRACZN(1,2,K) YE=FRACZN(2,2,K) XW=2.*XP-FRACZN(1,NPFZ(K),K) YW=2.*YP-FRACZN(2,NPFZ(K),K) ELSE IF (JSAVE.EQ.NPFZ(K)) THEN XE=2.*XP-FRACZN(1,1,K) YE=2.*YP-FRACZN(2,1,K) XW=FRACZN(1,JSAVE-1,K) YW=FRACZN(2,JSAVE-1,K) ELSE XE=FRACZN(1,JSAVE+1,K) YE=FRACZN(2,JSAVE+1,K) XW=FRACZN(1,JSAVE-1,K) YW=FRACZN(2,JSAVE-1,K) ENDIF ANGLEE=ATAN2F(YE-YP,XE-XP) ANGLEW=ATAN2F(YW-YP,XW-XP) IF (ANGLEW.LT.ANGLEE) ANGLEW=ANGLEW+6.283 ANGLEM=ATAN2F(YM-YP,XM-XP) IF (ANGLEM.LT.ANGLEE) ANGLEM=ANGLEM+6.283 ABOVE=ANGLEM.LE.ANGLEW IF (.NOT.ABOVE) GO TO 500 RMIN2=BIGNUM DO 450 J=1,NPFZ(K+1) R2=(XM-FRACZN(1,J,K+1))**2+ + (YM-FRACZN(2,J,K+1))**2 IF (R2.LT.RMIN2) THEN JSAVE=J RMIN2=R2 ENDIF 450 CONTINUE XP=FRACZN(1,JSAVE,K+1) YP=FRACZN(2,JSAVE,K+1) IF (JSAVE.EQ.1) THEN XE=FRACZN(1,2,K+1) YE=FRACZN(2,2,K+1) XW=2.*XP-FRACZN(1,NPFZ(K+1),K+1) YW=2.*YP-FRACZN(2,NPFZ(K+1),K+1) ELSE IF (JSAVE.EQ.NPFZ(K+1)) THEN XE=2.*XP-FRACZN(1,1,K+1) YE=2.*YP-FRACZN(2,1,K+1) XW=FRACZN(1,JSAVE-1,K+1) YW=FRACZN(2,JSAVE-1,K+1) ELSE XE=FRACZN(1,JSAVE+1,K+1) YE=FRACZN(2,JSAVE+1,K+1) XW=FRACZN(1,JSAVE-1,K+1) YW=FRACZN(2,JSAVE-1,K+1) ENDIF ANGLEE=ATAN2F(YE-YP,XE-XP) ANGLEW=ATAN2F(YW-YP,XW-XP) IF (ANGLEW.LT.ANGLEE) ANGLEW=ANGLEW+6.283 ANGLEM=ATAN2F(YM-YP,XM-XP) IF (ANGLEM.LT.ANGLEE) ANGLEM=ANGLEM+6.283 BELOW=ANGLEM.GE.ANGLEW IF (BELOW) THEN KROW=K GO TO 501 ENDIF 500 CONTINUE 501 CONTINUE IF (KROW.GE.1) THEN AGENOW=0. C C FIND MAGNETIC ANOMALIES SURROUNDING POINT AND FIX AGE C DO 600 J=1,NMAG(KROW)-1 XL1=REMAG(1,1,J,KROW) XL2=REMAG(1,2,J,KROW) YL1=REMAG(2,1,J,KROW) YL2=REMAG(2,2,J,KROW) XR1=REMAG(1,1,J+1,KROW) XR2=REMAG(1,2,J+1,KROW) YR1=REMAG(2,1,J+1,KROW) YR2=REMAG(2,2,J+1,KROW) DOT=(XL2-XL1)*(XR2-XR1)+(YL2-YL1)*(YR2-YR1) IF (DOT.LT.0.) THEN XS=XR1 YS=YR1 XR1=XR2 YR1=YR2 XR2=XS YR2=YS ENDIF AREAL=0.5*(XL1*YL2-XL2*YL1 + +XL2*YM-XM*YL2 + +XM*YL1-XL1*YM) SIDEL=SQRT((XL1-XL2)**2+(YL1-YL2)**2) DISTL=2.*AREAL/MAX(SIDEL,1.) AREAR=0.5*(XR1*YR2-XR2*YR1 + +XR2*YM-XM*YR2 + +XM*YR1-XR1*YM) SIDER=SQRT((XR1-XR2)**2+(YR1-YR2)**2) DISTR=2.*AREAR/MAX(SIDER,1.) IF ((DISTL*DISTR).LE.0.) THEN IF (ABS(DISTL-DISTR).GT.0.) THEN FRAC=ABS(DISTL)/ABS(DISTL-DISTR) ELSE FRAC=0. ENDIF AGENOW=MAX(AGENOW, + FRAC *AGEMAG(J+1,KROW)+ + (1.-FRAC)*AGEMAG(J,KROW) ) ENDIF 600 CONTINUE ELSE AGENOW=0. TOUCH(M,I)=0. SZZ(M,I)=0. ENDIF AGETHN=AGENOW-TMY IF (AGETHN.GT.0.) THEN SZZ(M,I)=ECLOG+SLABSZ*SQRT(MIN(AGETHN,100.)/100.) ELSE TOUCH(M,I)=0. SZZ(M,I)=0. ENDIF C C WITHIN FOREARC, NON-ISOSTATIC UPLIFT FROM SLAB IS ADDED C XREL=FROMW(M,I)/MAX(WANDES,1.) IF (XREL.LT.XANDES(NALT1)) THEN SZZ(M,I)=SZZ(M,I)-PUSHUP*TOUCH(M,I) ENDIF C C SPECIAL CASE OF PACIFIC PLATE IN CONTACT WITH COASTAL STRIP C PACIFI=(TOUCH(M,I).EQ.0.0).AND. + (MOD(I,NEWIDE).EQ.1).AND. + ((M.EQ.4).OR.(M.EQ.5).OR.(M.EQ.6)) IF (PACIFI) THEN VSLAB(1,M,I)=VXPD-Y*SPINP VSLAB(2,M,I)=VYPD+X*SPINP ENDIF C************************* KLUDGE **************************** C PREVENT FICTICIOUS "CONTINENTAL COLLISION EVENTS" CAUSED C BY SMALL BUGS IN MAP DATA THAT MAY CAUSE A POINT TO HAVE C TOUCH=0 (AND PACIFI) BEFORE THE PROPER TIME, ESPECIALLY C NEAR THE KULA/FARALLON-VANCOUVER/NORTH AMERICA TRIPLE C JUNCTION C IF (PACIFI.AND.(TMY.GT.43.8)) TOUCH(M,I)=0.1 C C THIS STATEMENT GUARUNTEES THAT PACIFI WILL BE .FALSE. IN C OTHER ROUTINES LIKE SLIPBC (IN LARAMY) AND ARROW (IN MAP). C************************************************************* 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE BELOWY C C C SUBROUTINE BELOW3(INPUT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP, + OUTPUT,SZZ,TOUCH,VSLAB) C C VERY ROUGH VERSION OF ANDEAN (SIERRA DE PAMPEANAS), 1987? C DIMENSION BETAL(7),COEFF(3,6,2),FROMW(7,NUMEL), + SZZ(7,NUMEL),TOUCH(7,NUMEL),VSLAB(2,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) C DATA NUMHR /6/ DATA BETAL /1.E+20,2185.,1738.,1419.,993.,463.,-1.E+20/ DATA RINKM/6371./ DATA ((COEFF(I,J,1),I=1,3),J=1,6)/ + 1.256000E+3, 0.000000 , 0.000000, + 5.130022E+2, 3.400447E-1, 0.000000, + -2.122960E+3, 4.330471 , -1.423388E-3, + -2.631799E+3, 5.698898 , -2.134993E-3, + 5.504894E+2, -8.305952E-1, 1.213217E-3, + 4.260000E+2, 0.000000 , 0.000000/ C ONEKM=RADIUS/RINKM DO 20 J=1,NUMEL DO 10 I=1,7 VSLAB(1,I,J)=0.3234E-06 VSLAB(2,I,J)=-0.8666E-07 SZZ(I,J)=ECLOG+SLABSZ*SQRT(50./100.) 10 CONTINUE 20 CONTINUE C RAMPKM=RAMP/ONEKM C DO 200 M=1,7 DO 100 I=1,NUMEL X=XIP(M,I) Y=YIP(M,I) ALPHA=(X-2.5831E+08)/ONEKM BETA=(Y+1.9218E+09)/ONEKM C DO 105 J=1,NUMHR IF(BETA.LE.BETAL(J).AND.BETA.GE.BETAL(J+1))THEN ALIM=COEFF(1,J,1)+BETA*COEFF(2,J,1)+BETA**2*COEFF(3,J,1) TOUCHI=AMAX1(0.,AMIN1(1.,(0.5-2.*(ALPHA-ALIM)/RAMPKM))) TOUCH(M,I)=TOUCHI ENDIF 105 CONTINUE 100 CONTINUE 200 CONTINUE RETURN END SUBROUTINE BELOW3 C C C SUBROUTINE BELOW4(INPUT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP, + OUTPUT,SZZ,TOUCH,VSLAB) C C VERY ROUGH VERSION OF CHINESE SHORT-UNDERTHRUST FOR C NOV. 1989 CALCULATIONS FOR NSF PROPOSAL 4. C LOGICAL MANTLE DIMENSION FROMW(7,NUMEL),SZZ(7,NUMEL),TOUCH(7,NUMEL), + VSLAB(2,7,NUMEL),XIP(7,NUMEL),YIP(7,NUMEL) C NTOUCH=9 C ABOVE DEFINES HOW MANY ROWS (FROM WEST) OF ELEMENTS C WILL TOUCH THE INDIAN PLATE. C CONTACT WILL ONLY BE WITH THE FIRST COLUMN, AND ONLY WITH CRUST. C C C DETECT AND REJECT MANTLE LAYER (NO CONTACT) C FSUM=0. DO 20 IROW=1,NTOUCH I=(IROW-1)*2*NELCOL+1 DO 10 M=1,7 FSUM=FSUM+FROMW(M,I) 10 CONTINUE 20 CONTINUE FMEAN=FSUM/(7.*NTOUCH) MANTLE=FMEAN.GT.100.E+05 IF (MANTLE) THEN DO 40 M=1,7 DO 30 I=1,NUMEL SZZ(M,I)=0. TOUCH(M,I)=0. VSLAB(1,M,I)=0. VSLAB(2,M,I)=0. 30 CONTINUE 40 CONTINUE ELSE DO 100 I=1,NUMEL JCOL=MOD((I-1),(2*NELCOL))+1 IROW=(I-1)/(2*NELCOL)+1 IF (JCOL.LE.2.AND.IROW.LE.NTOUCH) THEN DO 80 M=1,7 SZZ(M,I)=ECLOG TOUCH(M,I)=1. VSLAB(1,M,I)=1.089E-8+1.906E-16*XIP(M,I) VSLAB(2,M,I)=8.869E-8+2.680E-16*XIP(M,I) C THESE ARE MINSTER + JORDAN (1978) RM2* VELOCITIES FOR C WEST INDIA (SEPARATE FROM AUSTRALIA) WITH RESPECT TO C EURASIA. C 80 CONTINUE ELSE DO 90 M=1,7 SZZ(M,I)=0. TOUCH(M,I)=0. VSLAB(1,M,I)=0. VSLAB(2,M,I)=0. 90 CONTINUE ENDIF 100 CONTINUE ENDIF RETURN END SUBROUTINE BELOW4 C C C SUBROUTINE SQUEZE (G,CONDNS,TOUCHC,TOUCHM,SZZBC,SZZBM, + GEOTHA,GEOTHC,GEOTHM,NUMEL,THIKC,THIKM, + TEMLIM, + ALPHAT,RHOBAR,DNLINK,UPLINK,SIGZZC,SIGZZM, + OUTSCA,THNKC,THNKM, + DXSC,DXSM,DYSC,DYSM, + TAUZZC,TAUZZM,ONEKM,RHOH2O,RHOAST, + NODES,NUMNOD,PTSC,PTSM, + AREAC,AREAM,DETJC,DETJM,FAILUR, + NDIFF,ECLOG,HMAX,HMIN) C C CALCULATES LAYER-TOP VALUE (SIGZZ) AND THE LAYER INTEGRAL C (TAUZZ) OF VERTICAL STRESS ANOMALY C (RELATIVE TO A COLUMN OF MANTLE AT ASTHENOSPHERE TEMPERATURE C WITH A 2.7 KM OCEAN ON TOP AND A 5 KM CRUST, LIKE A MID-OCEAN C RIDGE) IN BOTH LAYERS AT ONCE. C ALSO PROVIDES PRESSURE ANOMALY TIMES SLOPE OF LAYER TOP (& BOT). C NOTE THAT ALL DENSITIES IN THIS PROGRAM ARE POTENTIAL C DENSITIES AT ZERO PRESSURE. C PARAMETER(NDREF=500) LOGICAL FAILUR,LOCKIN,LOCKWC DIMENSION DREF(NDREF) DIMENSION ALPHAT(2),AREAC(NUMEL),AREAM(NUMEL), + CONDNS(NUMNOD), + DETJC(7,NUMEL),DETJM(7,NUMEL), + DXSC(6,7,NUMEL),DXSM(6,7,NUMEL), + DYSC(6,7,NUMEL),DYSM(6,7,NUMEL), + GEOTHA(4,7,NUMEL), + GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), + HMAX(2),HMIN(2), + DNLINK(3,7,NUMEL),UPLINK(3,7,NUMEL),NODES(6,0:NUMEL), + OUTSCA(7,NUMEL), + PTSC(2,7,NUMEL),PTSM(2,7,NUMEL), + RHOBAR(2),SIGZZC(7,NUMEL),SIGZZM(7,NUMEL), + SZZBC(7,NUMEL),SZZBM(7,NUMEL), + TAUZZC(7,NUMEL),TAUZZM(7,NUMEL),TEMLIM(2), + THIKC(7,NUMEL),THIKM(7,NUMEL), + THNKC(NUMNOD),THNKM(NUMNOD), + TOUCHC(7,NUMEL),TOUCHM(7,NUMEL) SAVE ICALL,DREF DATA ICALL /0/, LOCKIN /.FALSE./, LOCKWC /.FALSE./ C C STATEMENT FUNCTIONS: TEMPC(Z,M,I)=MIN(TEMLIM(1),GEOTHC(1,M,I) + +GEOTHC(2,M,I)*Z + +GEOTHC(3,M,I)*Z**2 + +GEOTHC(4,M,I)*Z**3) TEMPM(Z,M,I)=MIN(TEMLIM(2),GEOTHM(1,M,I) + +GEOTHM(2,M,I)*Z + +GEOTHM(3,M,I)*Z**2 + +GEOTHM(4,M,I)*Z**3) TEMPA(Z,M,I)=MIN(TEMLIM(2),GEOTHA(1,M,I) + +GEOTHA(2,M,I)*Z + +GEOTHA(3,M,I)*Z**2 + +GEOTHA(4,M,I)*Z**3) C TASTH=TEMPM(THIKM(5,NUMEL),5,NUMEL) C C CREATE REFERENCE TEMPERATURE & DENSITY PROFILES TO DEPTH OF NDREF KM C ICALL=ICALL+1 IF (ICALL.EQ.1) THEN ITEST=(HMAX(1)+HMAX(2))/ONEKM IF (ITEST.GT.NDREF) THEN WRITE(6,1)ITEST 1 FORMAT(' IN SUBPROGRAM SQUEZE, PARAMETER NDREF '/ + ' MUST BE INCREASED TO AT LEAST ',I10) STOP ENDIF DREF(1)=RHOH2O DREF(2)=RHOH2O DREF(3)=0.7*RHOH2O+0.3*RHOBAR(1) DREF(4)=RHOBAR(1) DREF(5)=RHOBAR(1) DREF(6)=RHOBAR(1) DREF(7)=RHOBAR(1) DREF(8)=0.7*RHOBAR(1)+0.3*RHOAST DO 58 J=9,58 DREF(J)=RHOAST+ECLOG/(G*50.*ONEKM) 58 CONTINUE DO 100 J=59,NDREF DREF(J)=RHOAST 100 CONTINUE ENDIF C C CALCULATION FOR MANTLE C CALL GETSCA(INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) CALL EXTRAP (INPUT,AREAM,DETJM,LOCKIN,LOCKWC,PHINOD,OUTSCA, + OUTPUT,CONDNS) DO 200 M=1,7 DO 190 I=1,NUMEL SLTOPX=0. SLTOPY=0. DO 110 J=1,6 SLTOPX=SLTOPX+CONDNS(NODES(J,I))*DXSM(J,M,I) SLTOPY=SLTOPY+CONDNS(NODES(J,I))*DYSM(J,M,I) 110 CONTINUE SLOPEX=SLTOPX SLOPEY=SLTOPY DO 120 J=1,6 SLOPEX=SLOPEX+THNKM(NODES(J,I))*DXSM(J,M,I) SLOPEY=SLOPEY+THNKM(NODES(J,I))*DYSM(J,M,I) 120 CONTINUE NLNROW=(NDIFF/2)-1 IF (MOD((I-1),NLNROW).GT.1) THEN T=TOUCHM(M,I) ELSE IF (TOUCHM(M,I).GT.0.99) THEN T=1.00 ELSE T=0.0 ENDIF ENDIF SZZ=T*SZZBM(M,I) SZZBOT=SZZ SZZLST=SZZ TZZ=0. ZMOHO=OUTSCA(M,I) ZASTH=ZMOHO+THIKM(M,I) NTOP=ZMOHO/ONEKM+0.5 NBOT=ZASTH/ONEKM+0.5 NTOP=MIN(NDREF,NTOP) NBOT=MIN(NDREF,NBOT) TRES=ZMOHO-NTOP*ONEKM BRES=ZASTH-NBOT*ONEKM DO 180 J=NBOT,NTOP+1,-1 Z=ONEKM*(J-0.5) ZP=Z-ZMOHO T=TEMPM(ZP,M,I) DENSE=RHOBAR(2)*(1.-ALPHAT(2)*T) IF (J.EQ.NBOT) DSAVE=DENSE SZZ=SZZ+G*ONEKM*(DENSE-DREF(J)) SZZM=0.5*(SZZ+SZZLST) SZZLST=SZZ TZZ=TZZ+ONEKM*SZZM 180 CONTINUE SIGZZM(M,I)=SZZ+G*(BRES*(DSAVE-DREF(NBOT))- + TRES*(DENSE-DREF(NTOP))) TAUZZM(M,I)=TZZ+BRES*SZZBOT-TRES*SZZ PTSM(1,M,I)= -SZZBOT*SLOPEX+SZZ*SLTOPX PTSM(2,M,I)= -SZZBOT*SLOPEY+SZZ*SLTOPY 190 CONTINUE 200 CONTINUE C C CALCULATION FOR CRUST C CALL EXTRAP (INPUT,AREAM,DETJM,LOCKIN,LOCKWC,PHINOD,SIGZZM, + OUTPUT,CONDNS) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 300 M=1,7 DO 290 I=1,NUMEL SLOPEX=0. SLOPEY=0. DO 220 J=1,6 SLOPEX=SLOPEX+THNKC(NODES(J,I))*DXSC(J,M,I) SLOPEY=SLOPEY+THNKC(NODES(J,I))*DYSC(J,M,I) 220 CONTINUE ZMOHO=THIKC(M,I) TMOHO=TEMPC(ZMOHO,M,I) IF (DNLINK(1,M,I).GT.0.) THEN SZZ=OUTSCA(M,I) ELSE IF (TOUCHC(M,I).GT.0.) THEN SZZ=TOUCHC(M,I)*SZZBC(M,I) ELSE SZZ=0. ZMOHO=THIKC(M,I) ZASTH=ZMOHO+THIKM(5,NUMEL) NTOP=ZMOHO/ONEKM+0.5 NBOT=ZASTH/ONEKM+0.5 NTOP=MIN(NDREF,NTOP) NBOT=MIN(NDREF,NBOT) TRES=ZMOHO-NTOP*ONEKM BRES=ZASTH-NBOT*ONEKM DO 250 J=NBOT,NTOP+1,-1 Z=ONEKM*(J-0.5) ZP=Z-ZMOHO T=TEMPA(ZP,M,I) DENSE=RHOBAR(2)*(1.-ALPHAT(2)*T) IF (J.EQ.NBOT) DSAVE=DENSE SZZ=SZZ+G*ONEKM*(DENSE-DREF(J)) 250 CONTINUE SZZ=SZZ+G*(BRES*(DSAVE-DREF(NBOT))- + TRES*(DENSE-DREF(NTOP))) ENDIF ENDIF SZZBOT=SZZ PTSC(1,M,I)= -SZZBOT*SLOPEX PTSC(2,M,I)= -SZZBOT*SLOPEY SZZLST=SZZ TZZ=0. NINT=ZMOHO/ONEKM+0.5 NINT=MIN(NINT,NDREF) RESIDU=ZMOHO-NINT*ONEKM DO 280 J=NINT,1,-1 Z=ONEKM*(J-0.5) T=TEMPC(Z,M,I) DENSE=RHOBAR(1)*(1.-ALPHAT(1)*T) IF (J.EQ.NINT) DSAVE=DENSE SZZ=SZZ+G*ONEKM*(DENSE-DREF(J)) SZZM=0.5*(SZZ+SZZLST) SZZLST=SZZ TZZ=TZZ+ONEKM*SZZM 280 CONTINUE SIGZZC(M,I)=SZZ+RESIDU*G*(DSAVE-DREF(NINT)) TAUZZC(M,I)=TZZ+RESIDU*SZZBOT 290 CONTINUE 300 CONTINUE CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD,SIGZZC, + OUTPUT,CONDNS) CALL INTERP (CONDNS,NODES,NUMEL,NUMNOD,SIGZZC) RETURN END SUBROUTINE SQUEZE C C C SUBROUTINE INTERP (FPOLES,NODES,NUMEL,NUMNOD,VALUES) + C C INTERPOLATES SCALAR FROM NODES TO INTEGRATION POINTS C DIMENSION FPOLES(NUMNOD),NODES(6,0:NUMEL), + VALUES(7,NUMEL) 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,CONDNS,NODES,NUMEL,NUMNOD,UDLINK, + OUTPUT,OUTSCA) C C INTERPOLATES SCALAR FROM NODES TO POSITIONS GIVEN IN UDLINK C (ONE VALUE PER INTEGRATION POINT) C DIMENSION CONDNS(NUMNOD),NODES(6,0:NUMEL),OUTSCA(7,NUMEL), + UDLINK(3,7,NUMEL) PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) DO 1000 M=1,7 DO 900 I=1,NUMEL IE=UDLINK(1,M,I) S2=UDLINK(2,M,I) S3=UDLINK(3,M,I) S1=1.00-S2-S3 F1=CONDNS(NODES(1,IE)) F2=CONDNS(NODES(2,IE)) F3=CONDNS(NODES(3,IE)) F4=CONDNS(NODES(4,IE)) F5=CONDNS(NODES(5,IE)) F6=CONDNS(NODES(6,IE)) OUTSCA(M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) 900 CONTINUE 1000 CONTINUE RETURN END 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 DIMENSION VECNOD(2,NUMNOD),NODES(6,0:NUMEL),OUTVEC(2,7,NUMEL), + UDLINK(3,7,NUMEL) PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) DO 1000 M=1,7 DO 900 I=1,NUMEL IE=UDLINK(1,M,I) I1=NODES(1,IE) I2=NODES(2,IE) I3=NODES(3,IE) I4=NODES(4,IE) I5=NODES(5,IE) I6=NODES(6,IE) S2=UDLINK(2,M,I) S3=UDLINK(3,M,I) S1=1.00-S2-S3 F1=VECNOD(1,I1) F2=VECNOD(1,I2) F3=VECNOD(1,I3) F4=VECNOD(1,I4) F5=VECNOD(1,I5) F6=VECNOD(1,I6) OUTVEC(1,M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) F1=VECNOD(2,I1) F2=VECNOD(2,I2) F3=VECNOD(2,I3) F4=VECNOD(2,I4) F5=VECNOD(2,I5) F6=VECNOD(2,I6) OUTVEC(2,M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE GETVEC C C C SUBROUTINE THONM (NUMEL,NODES,NUMNOD,VM, + SIGHBM,SIGHTM,TOUCHM,VSLABM, + SIGBOT,GLUEM,ECREEP,DELVM,OUTVEC,OUTV2, + ETAMAX,UPLINK,VC,RHOBAR, + G,THIKM,FRIC,VISMAX,DVB,DVT,OVA,OVB, + OUTSCA) C C CALCULATES HORIZONTAL SHEAR STRESSES ON BASE C AND TOP OF THE MANTLE PART OF THE NORTH AMERICAN PLATE, C AND RELATIVE HORIZONTAL VELOCITY WITHIN PLATE WHICH THEY CAUSE. C INTEGER I,M,NUMEL REAL CRUST,DVB,DVX,DVY,ECREEP,ETAMAX,FRIC,GLUEC,GLUEM,OUTSCA, + OUTV2,OVB,RHOBAR,SHEAR,SHEAR1,SHEAR2,SHEAR3,SHEAR4,SHEAR5, + SIGBOT,SIGHTM,THIKM,TOUCHM,V,VFX,VFY,VMX,VMY,VRX,VRY,VSLABM DIMENSION DELVM(2,7,NUMEL),DVB(7,NUMEL),DVT(7,NUMEL), + ECREEP(3),FRIC(2),GLUEM(7,NUMEL), + UPLINK(3,7,NUMEL),NODES(6,0:NUMEL), + OUTVEC(2,7,NUMEL),OUTV2(2,7,NUMEL), + OVA(2,7,NUMEL),OVB(2,7,NUMEL), + RHOBAR(2),SIGHBM(2,7,NUMEL),SIGHTM(2,7,NUMEL), + THIKM(7,NUMEL), + TOUCHM(7,NUMEL),VSLABM(2,7,NUMEL), + VC(2,NUMNOD),VM(2,NUMNOD),OUTSCA(7,NUMEL) SQRT2(X)=SQRT(MAX(X,1.E-50)) CALL FLOW (VM,NUMNOD,NODES,NUMEL,OUTVEC) CALL GETVEC (INPUT,VC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OVA) DO 1000 M=1,7 DO 900 I=1,NUMEL CRUST=OUTSCA(M,I) GLUEC=OUTV2(1,M,I) VMX=OUTVEC(1,M,I) VMY=OUTVEC(2,M,I) VFX=VSLABM(1,M,I) VFY=VSLABM(2,M,I) IF (TOUCHM(M,I).GE.0.99) THEN OVB(1,M,I)=VFX OVB(2,M,I)=VFY VRX=VFX-VMX VRY=VFY-VMY V=SQRT2(VRX**2+VRY**2) DVB(M,I)=V DVX=VRX/V DVY=VRY/V SHEAR1=GLUEM(M,I)*V**ECREEP(3) SHEAR2=G*FRIC(2)* + (CRUST*RHOBAR(1)+THIKM(M,I)*RHOBAR(2)) SHEAR3=VISMAX*V/THIKM(M,I) SHEAR4=ETAMAX*V SHEAR5=SIGBOT SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4,SHEAR5) DECOLL=(SHEAR/GLUEM(M,I))**(1./ECREEP(3)) SIGHBM(1,M,I)=SHEAR*DVX SIGHBM(2,M,I)=SHEAR*DVY DELVM(1,M,I)=DVX*DECOLL DELVM(2,M,I)=DVY*DECOLL ELSE OVB(1,M,I)=0. OVB(2,M,I)=0. DVB(M,I)=0. SIGHBM(1,M,I)=0. SIGHBM(2,M,I)=0. DELVM(1,M,I)=0. DELVM(2,M,I)=0. ENDIF VCX=OVA(1,M,I) VCY=OVA(2,M,I) VRX=VCX-VMX VRY=VCY-VMY V=SQRT2(VRX**2+VRY**2) DVT(M,I)=V DVX=VRX/V DVY=VRY/V SHEAR1=MAX(GLUEC,0.)*V**ECREEP(2) SHEAR2=RHOBAR(1)*G*CRUST*FRIC(1) SHEAR3=VISMAX*V/CRUST SHEAR4=ETAMAX*V SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4) SIGHTM(1,M,I)=SHEAR*DVX SIGHTM(2,M,I)=SHEAR*DVY 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE THONM C C C SUBROUTINE THONC (NUMEL,NODES,NUMNOD,VC, + DNLINK,VM,DELVC,GLUEC,ECREEP,SIGHC, + SIGBOT,TOUCHC,VSLABC, + RHOBAR,G,THIKC,FRIC,VISMAX,DVB,OVB, + OUTVEC,ETAMAX,PUSHHO,FROMWC,WANDES) C C CALCULATES SHEAR STRESSES ON BASE OF CRUST, AND C RELATIVE VELOCITY WITHIN CRUST DUE TO SIMPLE SHEAR C DIMENSION DELVC(2,7,NUMEL),DVB(7,NUMEL),ECREEP(3),FRIC(2), + FROMWC(7,NUMEL),GLUEC(7,NUMEL),DNLINK(3,7,NUMEL), + NODES(6,0:NUMEL),OUTVEC(2,7,NUMEL), + OVB(2,7,NUMEL),RHOBAR(2), + SIGHC(2,7,NUMEL),THIKC(7,NUMEL), + TOUCHC(7,NUMEL),VSLABC(2,7,NUMEL), + VC(2,NUMNOD),VM(2,NUMNOD) SQRT2(X)=SQRT(MAX(X,1.E-50)) CALL FLOW (VC,NUMNOD,NODES,NUMEL,OUTVEC) CALL GETVEC (INPUT,VM,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OVB) DO 1000 M=1,7 DO 900 I=1,NUMEL VCX=OUTVEC(1,M,I) VCY=OUTVEC(2,M,I) XREL=FROMWC(M,I)/MAX(WANDES,1.) IF (XREL.LT.XANDES(NALT1)) THEN SLIMIT=SIGBOT+PUSHHO ELSE SLIMIT=SIGBOT ENDIF I2=DNLINK(1,M,I) IF (I2.NE.0) THEN VMX=OVB(1,M,I) VMY=OVB(2,M,I) VRX=VMX-VCX VRY=VMY-VCY V=SQRT2(VRX**2+VRY**2) DVB(M,I)=V DVX=VRX/V DVY=VRY/V SHEAR1=GLUEC(M,I)*V**ECREEP(2) SHEAR2=RHOBAR(1)*G*THIKC(M,I)*FRIC(1) SHEAR3=VISMAX*V/THIKC(M,I) SHEAR4=ETAMAX*V SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4) DECOLL=(SHEAR/GLUEC(M,I))**(1./ECREEP(2)) SIGHC(1,M,I)=SHEAR*DVX SIGHC(2,M,I)=SHEAR*DVY DELVC(1,M,I)=DVX*DECOLL DELVC(2,M,I)=DVY*DECOLL ELSE VFX=VSLABC(1,M,I) VFY=VSLABC(2,M,I) IF (TOUCHC(M,I).GE.0.99) THEN OVB(1,M,I)=VFX OVB(2,M,I)=VFY VRX=VFX-VCX VRY=VFY-VCY V=SQRT2(VRX**2+VRY**2) DVB(M,I)=V DVX=VRX/V DVY=VRY/V SHEAR1=GLUEC(M,I)*V**ECREEP(2) SHEAR2=RHOBAR(1)*G*THIKC(M,I)*FRIC(1) SHEAR3=VISMAX*V/THIKC(M,I) SHEAR4=ETAMAX*V SHEAR5=SLIMIT SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4,SHEAR5) DECOLL=(SHEAR/GLUEC(M,I))**(1./ECREEP(2)) SIGHC(1,M,I)=SHEAR*DVX SIGHC(2,M,I)=SHEAR*DVY DELVC(1,M,I)=DVX*DECOLL DELVC(2,M,I)=DVY*DECOLL ELSE OVB(1,M,I)=0. OVB(2,M,I)=0. DVB(M,I)=0. DELVC(1,M,I)=0. DELVC(2,M,I)=0. SIGHC(1,M,I)=0. SIGHC(2,M,I)=0. ENDIF ENDIF 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE THONC C C C SUBROUTINE VISCOS (SCOREC,SCORED,VISMAX,NUMEL,CONINT, + ALPHA,ERATE,TAUMAT,TOFSET,THIK,GEOTH, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,RHOBAR,FRIC,TEMLIM, + OUTSCA,SIGHB) C C CALLS FLOW-LAW "DIAMND" (ONLY POINT IN PROGRAM) AND C COMPUTES SECANT EFFECTIVE VISCOSITY MATRIX ALPHA C IN 3X3 COMPONENT FORM FROM 2X2 PRINCIPAL AXIS FORM C AT EACH INTEGRATION POINT OF A LAYER. C (NOTE THAT ALPHA HAS DIMENSION OF VISCOSITY * THICKNESS) C C ALSO RECORDS OFFSET VALUES (TOFSET(3,7,NUMEL)) FOR NEXT ITERATION C CALCULATION OF TOFSET + ALPHA*E WILL GIVE MODEL DEFORMATIONAL C (DEVIATORIC) STRESS INTEGRALS C LOGICAL MANTLE REAL ANGLE DIMENSION ACREEP(3),ALPHA(3,3,7,NUMEL),BCREEP(3),CCREEP(3), + CONINT(7,NUMEL),DCREEP(3),ECREEP(3), + ERATE(4,7,NUMEL),FRIC(2),GEOTH(4,7,NUMEL), + OUTSCA(7,NUMEL),RHOBAR(2),SIGHB(2,7,NUMEL), + TAUMAT(3,7,NUMEL), + TEMLIM(2),THIK(7,NUMEL),TOFSET(3,7,NUMEL) SQRT2(X)=SQRT(MAX(X,1.E-50)) C IF (MANTLE) THEN FR=FRIC(2) RHO=RHOBAR(2) ELSE FR=FRIC(1) RHO=RHOBAR(1) ENDIF SCOREC=0. SCORED=0. DENOMV=0. DENOMF=0. EBASE=(RHO*G*ONEKM*0.001)/VISMAX STFRIC=SIN(ATAN(FR)) DO 1000 M=1,7 DO 900 I=1,NUMEL CTAMIP=OUTSCA(M,I) SIGHBI=SQRT2(SIGHB(1,M,I)**2+SIGHB(2,M,I)**2) DELP2=0.25*(TAUMAT(1,M,I)+TAUMAT(2,M,I))**2 SHEAR2=TAUMAT(3,M,I)**2+0.25* + (TAUMAT(1,M,I)-TAUMAT(2,M,I))**2 DENOMV=DENOMV+MAX(DELP2,SHEAR2) THICK=THIK(M,I) EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) IF(ABS(EXX-EYY).LT.EBASE) EXX=EYY-EBASE DIVER=EXX+EYY SHEAR=SQRT(EXY**2+0.25*(EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR ANGLE=ATAN2F(EXY,0.5*(EXX-EYY)) CALL DIAMND (I,M,EXX,EYY,EXY,E1,E2,TXX,TYY,TXY, + RADT,IREGON,DT1DE1,DT1DE2,DT2DE1,DT2DE2, + GEOTH,NUMEL,VISMAX,THICK,TEMLIM, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,RHOBAR,STFRIC,CTAMIP, + CONINT,SIGHBI) DENOMF=DENOMF+MAX(RADT**2,0.25*(TXX+TYY)**2) DXX=TAUMAT(1,M,I)-TXX DYY=TAUMAT(2,M,I)-TYY DXY=TAUMAT(3,M,I)-TXY DELP2=0.25*(DXX+DYY)**2 SHEAR2=.25*(DXX-DYY)**2+DXY**2 SCOREC=MAX(SCOREC,DELP2,SHEAR2) SCORED=SCORED+MAX(DELP2,SHEAR2) DE1DEX=0.5-(EXX-EYY)/(4.*SHEAR) DE1DEY=0.5+(EXX-EYY)/(4.*SHEAR) DE1DES= -EXY/SHEAR DE2DEX=DE1DEY DE2DEY=DE1DEX DE2DES= -DE1DES U=2.*EXY/(EXX-EYY) TERM=1./(1.+U**2) DANDEX= -TERM*U/(EXX-EYY) DANDEY= -DANDEX DANDES=TERM*2./(EXX-EYY) DTXDT1=0.5*(1.-COS(ANGLE)) DTXDT2=0.5*(1.+COS(ANGLE)) DTXDAN= -TXY DTYDT1=DTXDT2 DTYDT2=DTXDT1 DTYDAN=TXY DTSDT1= -0.5*SIN(ANGLE) DTSDT2= -DTSDT1 DTSDAN=RADT*COS(ANGLE) C FIRST SUBSCRIPT OF ALPHA REFERS TO STRESS (1:TXX,2:TYY,3:TXY) C SECOND SUBSCRIPT OF ALPHA REFERS TO STRAIN (1:EXX,2:EYY,3:EXY) DTXDE1=DTXDT1*DT1DE1+DTXDT2*DT2DE1 DTXDE2=DTXDT1*DT1DE2+DTXDT2*DT2DE2 ALPHA(1,1,M,I)= + DTXDE1*DE1DEX+DTXDE2*DE2DEX+DTXDAN*DANDEX ALPHA(1,2,M,I)= + DTXDE1*DE1DEY+DTXDE2*DE2DEY+DTXDAN*DANDEY ALPHA(1,3,M,I)= + DTXDE1*DE1DES+DTXDE2*DE2DES+DTXDAN*DANDES DTYDE1=DTYDT1*DT1DE1+DTYDT2*DT2DE1 DTYDE2=DTYDT1*DT1DE2+DTYDT2*DT2DE2 ALPHA(2,1,M,I)= + DTYDE1*DE1DEX+DTYDE2*DE2DEX+DTYDAN*DANDEX ALPHA(2,2,M,I)= + DTYDE1*DE1DEY+DTYDE2*DE2DEY+DTYDAN*DANDEY ALPHA(2,3,M,I)= + DTYDE1*DE1DES+DTYDE2*DE2DES+DTYDAN*DANDES DTSDE1=DTSDT1*DT1DE1+DTSDT2*DT2DE1 DTSDE2=DTSDT1*DT1DE2+DTSDT2*DT2DE2 ALPHA(3,1,M,I)= + DTSDE1*DE1DEX+DTSDE2*DE2DEX+DTSDAN*DANDEX ALPHA(3,2,M,I)= + DTSDE1*DE1DEY+DTSDE2*DE2DEY+DTSDAN*DANDEY ALPHA(3,3,M,I)= + DTSDE1*DE1DES+DTSDE2*DE2DES+DTSDAN*DANDES TOFSET(1,M,I)=TXX-ALPHA(1,1,M,I)*EXX + -ALPHA(1,2,M,I)*EYY + -ALPHA(1,3,M,I)*EXY TOFSET(2,M,I)=TYY-ALPHA(2,1,M,I)*EXX + -ALPHA(2,2,M,I)*EYY + -ALPHA(2,3,M,I)*EXY TOFSET(3,M,I)=TXY-ALPHA(3,1,M,I)*EXX + -ALPHA(3,2,M,I)*EYY + -ALPHA(3,3,M,I)*EXY 900 CONTINUE 1000 CONTINUE SCOREC=SQRT(SCOREC) SCORED=SQRT(SCORED/MAX(DENOMV,DENOMF)) RETURN END SUBROUTINE VISCOS C C C SUBROUTINE DIAMND(I,M,EXX,EYY,EXY,E1,E2,TXX,TYY,TXY, + RADT,IREGON,DT1DE1,DT1DE2,DT2DE1,DT2DE2, + GEOTH,NUMEL,VISMAX,THICK,TEMLIM, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,RHOBAR,STFRIC,CTAMIP, + CONINT,SIGHBI) C C CALCULATES VERTICAL INTEGRAL OF (LOCAL) DEFORMATIONAL (DEVIATORIC) C STRESS COMPONENTS TXX, TYY, TXY FROM STRAIN-RATE COMPONENTS C C ALSO REPORTS TACTICAL CHOICES OF PARTIAL DERIVITIVES: C DT1DE1, DT1DE2, DT2DE1, AND DT2DE2 C IN PRINCIPAL-AXIS FORM. C INTEGER I,IBASE,IL,ILAYER,IREGON,JITER,K,M,NITER,NUMEL LOGICAL MANTLE REAL ACREEP,ANGLE, + BCREEP,BIOT, + CCREEP,CONINT,CONST,CRUST,CTAMIP, + DCREEP,DEFNK,DEFORM,DELZ,DPEDZ,DT1,DT1DE1,DT1DE2, + DT2,DT2DE1,DT2DE2,DTDZ,DTF1,DTF2,DTFCOM,DTFEXT, + E1,E2,E2LIM,ECREEP,EMOVE,EN,ET1,ET2,ETALPH,ETBETA, + ETZ,EXX,EXY,EYY,EZZ, + FACTOR,FRACZ, + G,GEOTH, + OLDSC,ONEKM, + PE0,PLAST, + RADT,RATIO,RHOBAR,RHOH2O, + SCP,SECINV,SF,SFMAX,SFMIN,SIGHBI,SINK,SLOPE,STRMAX, + T,T1,T2,TEMLIM,TEMPT,THICK,TOPSC,TP,TXX,TXY,TYY, + VAR,VISMAX,VISP,VIST, + ZABS,ZBEAM,ZP,ZPABS,ZT DIMENSION ACREEP(3),BCREEP(3),CCREEP(3),CONINT(7,NUMEL), + DCREEP(3),DTF1(4),DTF2(4),DT1(4),DT2(4), + ECREEP(3),ETALPH(4),ETBETA(4),ET1(4),ET2(4), + GEOTH(4,7,NUMEL),RHOBAR(2),TEMLIM(2) C C STATEMENT FUNCTION: INTEGER J REAL TEMP,TLIM,Z TEMP(Z,L,J)=MAX(200.,MIN(TLIM,GEOTH(1,L,J) + +GEOTH(2,L,J)*Z + +GEOTH(3,L,J)*Z**2 + +GEOTH(4,L,J)*Z**3)) C Z=0.3*THICK IF (MANTLE) THEN CRUST=CTAMIP PE0=G*CRUST*(RHOBAR(1)-RHOH2O*BIOT) ZABS=Z+CRUST DPEDZ=G*(RHOBAR(2)-RHOH2O*BIOT) TLIM=TEMLIM(2) ILAYER=3 ELSE PE0=0. ZABS=Z DPEDZ=G*(RHOBAR(1)-RHOH2O*BIOT) TLIM=TEMLIM(1) ILAYER=1 ENDIF EZZ=-EXX-EYY SECINV=E1*E2 + E1*EZZ + E2*EZZ DEFORM=2.*SQRT(ABS(SECINV)) EN=DEFORM**ECREEP(ILAYER) ANGLE=ATAN2F(E2,E1)-0.7854 FACTOR=1./(1.+STFRIC*COS(ANGLE)) C C FIND BRITTLE/DUCTILE TRANSITION C DO 100 NITER=1,15 T=TEMP(Z,M,I) ZP=Z+ONEKM TP=TEMP(ZP,M,I) DTDZ=MAX((TP-T),1.)/ONEKM SF=STFRIC*(PE0+DPEDZ*Z)*FACTOR SF=MIN(SF,DCREEP(ILAYER)) TEMPT=1./( LOG(SF/(ACREEP(ILAYER)*EN))/ + (BCREEP(ILAYER)+CCREEP(ILAYER)*ZABS) ) DELZ=(TEMPT-T)/DTDZ IF (ABS(DELZ).LT.(0.03*ONEKM)) GO TO 101 DELZ=DELZ*MIN(1.,0.10*THICK/ABS(DELZ)) Z=Z+DELZ ZABS=ZABS+DELZ IF (Z.LE.0. .OR. Z.GE. THICK) GO TO 101 100 CONTINUE IF ((TEMPT-T).GT.10.) Z=THICK 101 Z=MAX(Z,0.) Z=MIN(Z,THICK) C C DETERMINE FRICTIONAL AND PLASTIC RESISTANCES C SFMIN=PE0*STFRIC*FACTOR SFMAX=(PE0+Z*DPEDZ)*STFRIC*FACTOR IF (SFMAX.LE.DCREEP(ILAYER).OR.Z.EQ.0.) THEN CONST=Z*(SFMAX+SFMIN)/2. PLAST=0. ELSE IF (SFMIN.GE.DCREEP(ILAYER)) THEN PLAST=Z*DCREEP(ILAYER) CONST=0. ELSE ZT=Z*(DCREEP(ILAYER)-SFMIN)/(SFMAX-SFMIN) CONST=0.5*ZT*(SFMIN+DCREEP(ILAYER)) PLAST=(Z-ZT)*DCREEP(ILAYER) ENDIF ENDIF C C FIND REFERENCE LEVEL TO WHICH NODAL VELOCITIES REFER: C IN CRUST, THIS IS ALWAYS THE SURFACE, C IN MANTLE, IT IS THE STRONGEST LEVEL. C IF (MANTLE) THEN ZBEAM=THICK STRMAX=0.0 DO 110 K=0,10,1 ZP=(THICK*K)/10 ZPABS=ZP+CRUST TP=TEMP(ZP,M,I) SCP=ACREEP(3)*EN* + EXP((BCREEP(3)+CCREEP(3)*ZPABS)/TP) SF=STFRIC*(PE0+DPEDZ*ZP)*FACTOR SCP=MIN(SCP,DCREEP(3),SF) IF (SCP.GE.STRMAX) THEN ZBEAM=ZP STRMAX=SCP ENDIF 110 CONTINUE ELSE ZBEAM=0.0 ENDIF C C INTEGRATE CREEP RESISTANCE C VAR=0. IF (Z.LT.THICK) THEN T=TEMP(Z,M,I) ZABS=Z IF (MANTLE) ZABS=Z+CRUST TOPSC=ACREEP(ILAYER)*EN* + EXP((BCREEP(ILAYER)+CCREEP(ILAYER)*ZABS)/T) OLDSC=TOPSC IBASE=THICK/ONEKM DO 120 JITER=1,IBASE ZP=Z+ONEKM ZPABS=ZABS+ONEKM IF (MANTLE) THEN IL=3 ELSE IF (ZPABS.GT.CONINT(M,I)) THEN IL=2 ELSE IL=1 ENDIF ENDIF TP=TEMP(ZP,M,I) SCP=ACREEP(IL)*EN* + EXP((BCREEP(IL)+CCREEP(IL)*ZPABS)/TP) SF=STFRIC*(PE0+DPEDZ*ZP)*FACTOR SCP=MIN(SCP,DCREEP(IL),SF) C NOTE: INTEGRAL STOPS WHEN PASSING THROUGH A DETACHMENT (WHERE C STRAIN-RATES WOULD DIFFER FROM SURFACE VALUES) IF (ZP.GT.ZBEAM.AND.SCP.LE.SIGHBI) GO TO 122 VAR=VAR+ONEKM*0.5*(OLDSC+SCP) IF (ZP.GE.THICK) GO TO 121 Z=ZP ZABS=ZPABS OLDSC=SCP 120 CONTINUE 121 VAR=VAR+(THICK-ZP)*SCP 122 CONTINUE ENDIF VIST=VAR/DEFORM C C MORE PRECISE TREATMENT OF FRICTIONAL RESISTANCE C IF ((CONST+PLAST).GT.0.) THEN CONST=CONST/(STFRIC*FACTOR) RATIO=(1.+STFRIC)/(1.-STFRIC) DTFEXT=CONST*(1.-1./RATIO) DTFCOM=CONST*(1.-RATIO) DT1(1)=DTFEXT+2.*PLAST DT2(1)=DTFEXT+2.*PLAST DT1(2)=0. DT2(2)=DTFEXT+2.*PLAST DT1(3)=DTFCOM-2.*PLAST DT2(3)=0. DT1(4)=DTFCOM-2.*PLAST DT2(4)=DTFCOM-2.*PLAST DO 220 K=1,4 DTF1(K)=DT1(K) DTF2(K)=DT2(K) DO 210 NITER=1,3 ETALPH(K)=DT1(K)/(2.*VISMAX*THICK) ETBETA(K)=DT2(K)/(2.*VISMAX*THICK) ET2(K)=(2.*ETBETA(K)-ETALPH(K))/3. ET1(K)=ETBETA(K)-2.*ET2(K) ETZ= -ET1(K) -ET2(K) SINK=ET1(K)*ET2(K) + ET1(K)*ETZ + ET2(K)*ETZ DEFNK=2.*SQRT(ABS(SINK)) VISP=VIST*(DEFNK/DEFORM)**(ECREEP(ILAYER)-1.) DT1(K)=DTF1(K)+2.*VISP*ETALPH(K) DT2(K)=DTF2(K)+2.*VISP*ETBETA(K) 210 CONTINUE ETALPH(K)=DT1(K)/(2.*VISMAX*THICK) ETBETA(K)=DT2(K)/(2.*VISMAX*THICK) ET2(K)=(2.*ETBETA(K)-ETALPH(K))/3. ET1(K)=ETBETA(K)-2.*ET2(K) 220 CONTINUE FRACZ=(ET1(2)+ET2(2))/((ET1(2)+ET2(2))-(ET1(3)+ET2(3))) SSERR=FRACZ*(DTF1(3)+DTF2(3))+(1.-FRACZ)*(DTF1(2)+DTF2(2)) SLOPE=(DTF1(2)+DTF2(2)-DTF1(3)-DTF2(3)) / + (ET1(2) +ET2(2) -ET1(3) -ET2(3) ) EMOVE=0.5*SSERR/SLOPE ET1(2)=ET1(2)+EMOVE ET2(2)=ET2(2)+EMOVE ET1(3)=ET1(3)+EMOVE ET2(3)=ET2(3)+EMOVE IF(E1.LT.ET1(1)) GO TO 230 IREGON=1 C DOUBLE NORMAL-FAULT CONJUGATE SETS T1=DTF1(1) + +2.*VIST*(2.*E1+E2) T2=DTF2(1) + +2.*VIST*(2.*E2+E1) DT1DE1=DTF1(1)/(2.*E1)+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=DTF2(1)/(2.*E2)+4.*VIST GO TO 290 230 IF(E1.LT.ET1(2)) GO TO 240 FRAC=(ET1(1)-E1)/(ET1(1)-ET1(2)) E2LIM=ET2(1)+(ET2(2)-ET2(1))*FRAC IF(E2.LT.E2LIM) GO TO 235 IREGON=2 C SINGLE NORMAL FAULT SET T1=FRAC*DTF1(2)+(1.-FRAC)*DTF1(1) + +2.*VIST*(2.*E1+E2) T2=FRAC*DTF2(2)+(1.-FRAC)*DTF2(1) + +2.*VIST*(2.*E2+E1) DT1DE1=4.*VISMAX*THICK DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=T2/E2 GO TO 290 235 IREGON=0 C PURELY VISCOUS RANGE T1=2.*VISMAX*(2.*E1+E2)*THICK T2=2.*VISMAX*(2.*E2+E1)*THICK DT1DE1=4.*VISMAX*THICK DT1DE2=2.*VISMAX*THICK DT2DE1=DT1DE2 DT2DE2=DT1DE1 GO TO 290 240 FRAC=((ET1(2)+ET2(2))-(E1+E2))/((ET1(2)+ET2(2))- 1 (ET1(3)+ET2(3))) IF(FRAC.GT.0.) GO TO 250 IREGON=3 C NORMAL + STRIKE-SLIP SETS T1=DTF1(2) + +2.*VIST*(2.*E1+E2) T2=DTF2(2) + +2.*VIST*(2.*E2+E1) IF (E1.LE.-0.5*E2) THEN ESUM=E1+E2 EDIF=E1-E2 TSUM=T1+T2 TDIF=T1-T2 DT1DE1=0.5*(TSUM/ESUM+TDIF/EDIF) DT1DE2=0.5*(TSUM/ESUM-TDIF/EDIF) DT2DE1=DT1DE2 DT2DE2=DT1DE1 ELSE DT1DE1=-0.5*DTF1(1)/E1+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=T2/E2 ENDIF GO TO 290 250 IF(FRAC.GT.1.) GO TO 260 E2LIM=ET2(2)+(ET2(3)-ET2(2))*FRAC IF(E2.LT.E2LIM) GO TO 235 IREGON=4 C CONJUGATE STRIKE-SLIP SET TF1=FRAC*DTF1(3)+(1.-FRAC)*DTF1(2) T1=TF1+2.*VIST*(2.*E1+E2) TF2=FRAC*DTF2(3)+(1.-FRAC)*DTF2(2) T2=TF2+2.*VIST*(2.*E2+E1) Q=((DTF1(2)-DTF2(2))-(DTF1(3)-DTF2(3))) / + ((ET1 (2)+ET2 (2))-(ET1 (3)+ET2 (3))) DT1DE1=3.*VISMAX*THICK+0.5*(T1-T2)/(E1-E2)+0.5*Q DT1DE2=3.*VISMAX*THICK-0.5*(T1-T2)/(E1-E2)+0.5*Q DT2DE1=DT1DE2-Q DT2DE2=DT1DE1-Q GO TO 290 260 IF(E2.LT.ET2(3)) GO TO 270 IREGON=5 C STRIKE-SLIP + THRUST SETS T1=DTF1(3) + +2.*VIST*(2.*E1+E2) T2=DTF2(3) + +2.*VIST*(2.*E2+E1) IF (E2.GE.-0.5*E1) THEN ESUM=E1+E2 EDIF=E1-E2 TSUM=T1+T2 TDIF=T1-T2 DT1DE1=0.5*(TSUM/ESUM+TDIF/EDIF) DT1DE2=0.5*(TSUM/ESUM-TDIF/EDIF) DT2DE1=DT1DE2 DT2DE2=DT1DE1 ELSE DT1DE1=T1/E1 DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=-0.5*DTF2(4)/E2+4.*VIST ENDIF GO TO 290 270 IF(E2.LT.ET2(4)) GO TO 275 FRAC=(ET2(3)-E2)/(ET2(3)-ET2(4)) E1LIM=ET1(3)+(ET1(4)-ET1(3))*FRAC IF(E1.GT.E1LIM) GO TO 235 IREGON=6 C ONE CONJUGATE THRUST SET T1=FRAC*DTF1(4)+(1.-FRAC)*DTF1(3) + +2.*VIST*(2.*E1+E2) T2=FRAC*DTF2(4)+(1.-FRAC)*DTF2(3) + +2.*VIST*(2.*E2+E1) DT1DE1=T1/E1 DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=4.*VISMAX*THICK GO TO 290 275 IREGON=7 C DOUBLE THRUST SETS T1=DTF1(4) + +2.*VIST*(2.*E1+E2) T2=DTF2(4) + +2.*VIST*(2.*E2+E1) DT1DE1=DTF1(4)/(2.*E1)+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=DTF2(4)/(2.*E2)+4.*VIST 290 CONTINUE ELSE VISLIM=VISMAX*THICK VIS=MIN(VIST,VISLIM) IREGON=8 IF (VIS.LT.VIST) IREGON=0 T1=2.*VIS*(2.*E1+E2) T2=2.*VIS*(2.*E2+E1) DT1DE1=4.*VIS DT1DE2=2.*VIS DT2DE1=DT1DE2 DT2DE2=DT1DE1 ENDIF RADT=0.5*(T2-T1) IF((E1-E2).NE.0.) THEN C=(T2-T1)/(E2-E1) ELSE C=0. ENDIF TXX=.5*(C*(EXX-EYY)+T1+T2) TYY=T1+T2-TXX TXY=C*EXY RETURN END SUBROUTINE DIAMND C C C SUBROUTINE EDOT (NUMEL,NODES,V,NUMNOD,DXS,DYS,ERATE, + ALPHA,TOFSET,TAUMAT) C C COMPUTE STRAIN-RATE COMPONENTS EDOTXX, EDOTYY, AND C EDOTXY (TENSOR FORM) AND THE "FOURTH COMPONENT" C (ROTATION RATE OF STIFF INCLUSIONS) AT INTEGRATION POINTS C C ALSO COMPUTES VERTICAL INTEGRALS OF DEFORMATIONAL (DEVIATORIC) C STRESS: TAUMAT C DIMENSION ALPHA(3,3,7,NUMEL),DXS(6,7,NUMEL),DYS(6,7,NUMEL), + ERATE(4,7,NUMEL),NODES(6,0:NUMEL), + TAUMAT(3,7,NUMEL),TOFSET(3,7,NUMEL),V(2,NUMNOD) DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=0. EYY=0. EXY=0. ROT=0. DO 800 J=1,6 NODE=NODES(J,I) VX=V(1,NODE) VY=V(2,NODE) DX=DXS(J,M,I) DY=DYS(J,M,I) EXX=EXX+VX*DX EYY=EYY+VY*DY EXY=EXY+(VX*DY+VY*DX)*0.5 ROT=ROT+(VY*DX-VX*DY)*0.5 800 CONTINUE ERATE(1,M,I)=EXX ERATE(2,M,I)=EYY ERATE(3,M,I)=EXY ERATE(4,M,I)=ROT TAUMAT(1,M,I)=TOFSET(1,M,I)+EXX*ALPHA(1,1,M,I)+ + EYY*ALPHA(1,2,M,I)+EXY*ALPHA(1,3,M,I) TAUMAT(2,M,I)=TOFSET(2,M,I)+EXX*ALPHA(2,1,M,I)+ + EYY*ALPHA(2,2,M,I)+EXY*ALPHA(2,3,M,I) TAUMAT(3,M,I)=TOFSET(3,M,I)+EXX*ALPHA(3,1,M,I)+ + EYY*ALPHA(3,2,M,I)+EXY*ALPHA(3,3,M,I) 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE EDOT C C C SUBROUTINE REPORT (ISTEP,XIPC,XIPM,YIPC,YIPM, + XNODC,XNODM,YNODC,YNODM,TITLE,VM,NODES, + OUTSCA,OUTVEC,VC,ERATEM,ERATEC, + THIKM,THIKC,GEOTHA,GEOTHC,CONDUC, + GEOTHM,DNLINK,VPMEAN,DVPBYE,DVPDT, + TIME2,NUMNOD,NUMEL, + G,HMAX,HMIN,RHOAST,RHOH2O,SIGHC,SIGHBM,SIGZZC, + SIGZZM,TAUMTC,TAUMTM,TAUZZC,TAUZZM, + TEMLIM,ONEKM,ESUMC,ESUMM,AREAC,AREAM, A CONDNS,DETJC,DETJM,FAILUR, + NDIFF,WC,WM, + SZZBC,SZZBM,TOUCHC,TOUCHM, + ECLOG,SLABSZ, + VSLABC,VSLABM,OUTV2,RAMP, + THNKC,UPLINK,TASTH,TSLAB0, + DOPLOT,SCALEC,NCONTR, + STATES,RMSVEC,NELCOL,PHINOD,DRAWST, + NXYST,XST,YST,NELROW,THNKM,FBLAND,LOWBLU, 9 CINT,FROMWC,FROMWM,IBELOWINDEX,WANDES, A CONINT,CONNOD, B TSURF,PUSHUP,IPENCT,IPENST,IPENLB) C C PRINTS MAPS OF IMPORTANT QUANTITIES ON LINE PRINTER. C PLOTS SHOW VALUES AT INTEGRATION POINTS, WITH LOCATION C FUDGED TO NEAREST POINT IN RECTANGULAR PRINTING GRIDS. C WHEN TWO OR MORE POINTS SHARE A PRINT GRID SQUARE, C SCALAR VALUES OR SIMPLE VECTORS ARE AVERAGED ACCORDING TO C THEIR GAUSSIAN WEIGHTS; BUT "VECTORS" REPRESENTING PRINCIPAL C AXES OF SECOND-RANK TENSORS ARE JUST OVERLAID, WITH C PRIORITY ACCORDING TO GAUSSIAN WEIGHT. C SCALARS ARE REPRESENTED BY DIGITS 0,1,2,3,4,5,6,7,8,9,*. C VECTORS (AND PRINCIPAL AXES OF TENSORS, TREATED AS VECTORS) C ARE REPRESENTED BY NUMERICAL DIGIT 0-* AND A LETTER A-L C WHICH REPRESENTS DIRECTION ACCORDING TO CODE A=1 O'CLOCK, C B=2 O'CLOCK....L=12 O'CLOCK. C IN THE CASE OF PRINCIPAL AXIS "VECTORS", THE CONVENTION IS C THAT DIRECTIONS A-F MEAN NEGATIVE PRINCIPAL VALUES, C AND DIRECTIONS G-L MEAN POSITIVE VALUES. C C BEFORE USE, FILL IN THE X (HORIZONTAL) AND Y (VERTICAL) C INCREMENT OF THE PRINTER (IN INCHES): DXPR & DYPR C AND ALSO THE EFFECTIVE NUMBER OF LINES IN A PAGE: NLINES C IN THE DATA STATEMENT BELOW. COLUMNS NPCOL WILL USUALLY BE 132; C THE INVISIBLE FIRST POSITION FOR CARRIAGE CONTROL IS NOT COUNTED. C C C FOLLOWING LINE SETS MAXIMUM NUMBER OF ELEMENTS: PARAMETER (N50=280) C FOLLOWING LINE SETS MAXIMUM NUMBER OF NODES: PARAMETER (N121=609) C FOLLOWING LINE SETS MAXIMUM NUMBER OF POINTS IN STATELINE MAPS: PARAMETER (NSTATE=2000) C FOLLOWING LINE SETS NUMBER OF TYPES OF PLOT PARAMETER (NTYPE=24) C CHARACTER*1 BOARD1(59,63),BOARD2(59,63),CITY CHARACTER*80 TITLE CHARACTER*42 TEXT,VUNITS LOGICAL ALLPOS,AVERAG,DOAROW,DOAXES,DOESYM,DOPLOT,DRAWST, + FAILUR,LOCKIN,LOCKWC,SOMNEG,STATES DIMENSION AREAC(NUMEL),AREAM(NUMEL), 2 CONDUC(2),COUNT(59,63),CONDNS(NUMNOD), 3 CINT(NTYPE),CONINT(7,NUMEL),CONNOD(NUMNOD), 4 DETJC(7,NUMEL),DETJM(7,NUMEL),DNLINK(3,7,NUMEL), 5 DOPLOT(NTYPE),DRAWST(NXYST),DVPBYE(2,2), 6 DVPDT(2),ERATEC(4,7,NUMEL),ERATEM(4,7,NUMEL), 7 ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL),FBLAND(NTYPE), 8 FROMWC(7,NUMEL),FROMWM(7,NUMEL), 9 GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), A HMAX(2),HMIN(2),LOWBLU(NTYPE),NODES(6,0:NUMEL), 1 NVCHAR(NTYPE),NVUCHR(NTYPE), 2 OUTSCA(7,NUMEL),OUTVEC(2,7,NUMEL),OUTV2(2,7,NUMEL), 3 PHINOD(NUMNOD), 4 SIGHBM(2,7,NUMEL),SIGHC(2,7,NUMEL),SIGZZC(7,NUMEL), 5 SIGZZM(7,NUMEL),STACK(2,59,63), 6 SZZBC(7,NUMEL),SZZBM(7,NUMEL), 7 TAUMTC(3,7,NUMEL),TAUMTM(3,7,NUMEL) DIMENSION TAUZZC(7,NUMEL),TAUZZM(7,NUMEL),TEMLIM(2), 2 TEXT(NTYPE),THIKC(7,NUMEL),THIKM(7,NUMEL), 3 THNKC(NUMNOD),THNKM(NUMNOD),UPLINK(3,7,NUMEL), 4 TOUCHC(7,NUMEL),TOUCHM(7,NUMEL), 5 VPMEAN(2),VC(2,NUMNOD),VM(2,NUMNOD), 6 VSLABC(2,7,NUMEL),VSLABM(2,7,NUMEL), 7 VUNITS(NTYPE),WC(NUMNOD),WM(NUMNOD), 8 XIPC(7,NUMEL),XIPM(7,NUMEL), 9 XNODC(NUMNOD),XNODM(NUMNOD), A XST(NXYST),YST(NXYST),YIPC(7,NUMEL),YIPM(7,NUMEL), 1 YNODC(NUMNOD),YNODM(NUMNOD) C SAVE COLFAC,COLCON,DX,DY,IORIGI,JORIGI,KRL,KCL,ROWCON,ROWFAC, + SCALEP,XMAX,XMIN,YMAX,YMIN C DATA CITY/'#'/ C UCLA:DATA DXPR/0.100/,DYPR/0.125/,NLINES/63/,NPCOL/132/ C CHEV:DATA DXPR/0.100/,DYPR/0.167/,NLINES/58/,NPCOL/132/ DATA DXPR/0.100/,DYPR/0.125/,NLINES/63/,NPCOL/132/ C DATA TEXT(1)/'MANTLE: BASAL SHEAR STRESS '/ DATA NVCHAR(1)/26/ DATA VUNITS(1)/'DYNE/CM**2 '/ DATA NVUCHR(1)/10/ DATA TEXT(2)/'CRUST: BASAL SHEAR STRESS '/ DATA NVCHAR(2)/25/ DATA VUNITS(2)/'DYNE/CM**2 '/ DATA NVUCHR(2)/10/ DATA TEXT(3)/'MANTLE: VELOCITY '/ DATA NVCHAR(3)/16/ DATA VUNITS(3)/'CM/SEC '/ DATA NVUCHR(3)/6/ DATA TEXT(4)/'CRUST: VELOCITY '/ DATA NVCHAR(4)/15/ DATA VUNITS(4)/'CM/SEC '/ DATA NVUCHR(4)/6/ DATA TEXT(5)/'MANTLE: FAULT PLANES AND MAX. E-RATE '/ DATA NVCHAR(5)/36/ DATA VUNITS(5)/'1/SEC '/ DATA NVUCHR(5)/5/ DATA TEXT(6)/'CRUST: FAULT PLANES AND MAX. E-RATE '/ DATA NVCHAR(6)/35/ DATA VUNITS(6)/'1/SEC '/ DATA NVUCHR(6)/5/ DATA TEXT(7)/'MANTLE: STRESS AXES & SHEAR INTENSITY '/ DATA NVCHAR(7)/37/ DATA VUNITS(7)/'DYNE/CM '/ DATA NVUCHR(7)/7/ DATA TEXT(8)/'CRUST: STRESS AXES & SHEAR INTENSITY '/ DATA NVCHAR(8)/36/ DATA VUNITS(8)/'DYNE/CM '/ DATA NVUCHR(8)/7/ DATA TEXT(9)/'MANTLE: GRID OF ELEMENTS '/ DATA NVCHAR(9)/24/ DATA VUNITS(9)/' '/ DATA NVUCHR(9)/0/ DATA TEXT(10)/'CRUST: GRID OF ELEMENTS '/ DATA NVCHAR(10)/23/ DATA VUNITS(10)/' '/ DATA NVUCHR(10)/0/ DATA TEXT(11)/'MANTLE:RATE OF THICKENING(PURE SHEAR ONLY)'/ DATA NVCHAR(11)/42/ DATA VUNITS(11)/'CM/SEC '/ DATA NVUCHR(11)/6/ DATA TEXT(12)/'CRUST: RATE OF THICKENING(PURE SHEAR ONLY)'/ DATA NVCHAR(12)/42/ DATA VUNITS(12)/'CM/SEC '/ DATA NVUCHR(12)/6/ DATA TEXT(13)/'MANTLE: THICKNESS '/ DATA NVCHAR(13)/17/ DATA VUNITS(13)/'CM '/ DATA NVUCHR(13)/2/ DATA TEXT(14)/'CRUST: THICKNESS '/ DATA NVCHAR(14)/16/ DATA VUNITS(14)/'CM '/ DATA NVUCHR(14)/2/ DATA TEXT(15)/'MANTLE: BASAL TEMPERATURE '/ DATA NVCHAR(15)/25/ DATA VUNITS(15)/'KELVIN '/ DATA NVUCHR(15)/6/ DATA TEXT(16)/'CRUST: BASAL TEMPERATURE '/ DATA NVCHAR(16)/24/ DATA VUNITS(16)/'KELVIN '/ DATA NVUCHR(16)/6/ DATA TEXT(17)/'TELESEISMIC P TRAVEL-TIME RESIDUALS '/ DATA NVCHAR(17)/35/ DATA VUNITS(17)/'SEC (LATE) '/ DATA NVUCHR(17)/10/ DATA TEXT(18)/'ISOSTATIC TOPOGRAPHY '/ DATA NVCHAR(18)/20/ DATA VUNITS(18)/'CM '/ DATA NVUCHR(18)/2/ DATA TEXT(19)/'PALEO-HEAT-FLOW '/ DATA NVCHAR(19)/15/ DATA VUNITS(19)/'ERG/CM**2/S '/ DATA NVUCHR(19)/11/ DATA TEXT(20)/'TOPOGRAPHY AFTER DELAMINATION '/ DATA NVCHAR(20)/29/ DATA VUNITS(20)/'CM '/ DATA NVUCHR(20)/2/ DATA TEXT(21)/'CRUST: LOG(NET STRAIN) AND FAULT PLANES '/ DATA NVCHAR(21)/39/ DATA VUNITS(21)/'COMMON LOG (E1 OR E3) '/ DATA NVUCHR(21)/21/ DATA TEXT(22)/'CRUST: NET CLOCKWISE ROTATION '/ DATA NVCHAR(22)/29/ DATA VUNITS(22)/'DEGREES '/ DATA NVUCHR(22)/7/ DATA TEXT(23)/'THICKNESS OF CRUST ABOVE CONRAD '/ DATA NVCHAR(23)/31/ DATA VUNITS(23)/'CM '/ DATA NVUCHR(23)/2/ DATA TEXT(24)/'THICKNESS OF CRUST BELOW CONRAD '/ DATA NVCHAR(24)/31/ DATA VUNITS(24)/'CM '/ DATA NVUCHR(24)/2/ C C STATEMENT FUNCTIONS FOR PRINTER-PLOTTING: IROW(Y)=MAX(1,MIN(KRL,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(KCL,INT(COLFAC*X+COLCON+1.5))) C SCALE=1.00*SCALEC C WRITE(6,1) 1 FORMAT(/' REPORT will now produce any graphics for this', + ' timestep.'/) IF (ISTEP.EQ.1) THEN KRL=MIN(59,NLINES-5) KCL=MIN(63,(NPCOL-6)/2) XMIN=XNODC(1) YMIN=YNODC(1) XMAX=XMIN YMAX=YMIN DO 10 I=2,NUMNOD XMIN=MIN(XMIN,XNODC(I),XNODM(I)) YMIN=MIN(YMIN,YNODC(I),YNODM(I)) XMAX=MAX(XMAX,XNODC(I),XNODM(I)) YMAX=MAX(YMAX,YNODC(I),YNODM(I)) 10 CONTINUE C C DETERMINE HOW TO PLACE PLOT ON PAPER C HDENOM=(XMAX-XMIN)/((9.00)/39.37) VDENOM=(YMAX-YMIN)/((7.00)/39.37) IF ((SDENOM.GE.HDENOM).AND.(SDENOM.GE.VDENOM)) THEN WRITE (IUNITT,11) SCALEC 11 FORMAT (/' Scale factor of', + 1P,E10.2,' will allow display of whode', + ' grid.' + /' T plot center (XCENTR,YCENTR) will be ' + ,'recomputed to center it.') XCENTR=0.5*(XMAX+XMIN) YCENTR=0.5*(YMAX+YMIN) ELSE WRITE (IUNITT,12) SCALEC, XCENTR, YCENTR 12 FORMAT (/' Scale denominator of',1P,E10.2 + ,' does NOT permit display of whole grid.' + /' Portion shown will depend on center' + ,' coordinates (x,y), which were:' + /' (',E9.2,',',E9.2,').') ENDIF C C SCALE FACTORS FOR ASCII PRINTER-PLOTS C DX=(XMAX-XMIN)/(KCL-1.) DY=(YMAX-YMIN)/(KRL-1.) DX=MAX(DX,DY*DXPR/DYPR) DY=MAX(DY,DX*DYPR/DXPR) SCALEP=DX/DXPR ROWFAC= -1./DY ROWCON= 0.5*((0.0-ROWFAC*YMAX)+(KRL-1.-ROWFAC*YMIN)) COLFAC= 1./DX COLCON= 0.5*((0.0-COLFAC*XMIN)+(KCL-1.-COLFAC*XMAX)) IORIGI=IROW(0.) JORIGI=JCOL(0.) ENDIF LOCKIN=.FALSE. LOCKWC=.FALSE. T2MA=TIME2/(1.E6*365.25*24.*60.*60.) 20 FORMAT(/' ',A,' AGE = ',1P,E10.3,' (',0P,F8.3,')') 50 FORMAT(/' -----------------------------------------------------' + /' Beginning .AI file with plot of ' + /' ',A) IF (DOPLOT(1).OR.DOPLOT(2)) THEN AVERAG=.TRUE. ALLPOS=.TRUE. SOMNEG=.NOT.ALLPOS CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,SIGHBM,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(1)) THEN WRITE(6,50)'HORIZONTAL TRACTION ON BASE OF MANTLE' CALL MAGNIT (SIGHBM,NUMEL,OUTSCA,SOMNEG) CALL EXTRAP (INPUT,AREAM,DETJM,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON1=CINT(1) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.TRUE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,1,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,SIGHBM,RMSVEC,XIPM,YIPM, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,SIGHC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(2)) THEN WRITE(6,50)'HORIZONTAL TRACTIONS ON BASE OF CRUST' CALL MAGNIT (SIGHC,NUMEL,OUTSCA,SOMNEG) CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON2=CINT(2) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.TRUE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,2,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,SIGHC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,101) 101 FORMAT(' HORIZONTAL STRESSES ON:'/ + ' MANTLE (BASE ONLY)',51X, + 'CRUST (BASE ONLY)') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 102 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 102 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(3).OR.DOPLOT(4)) THEN CALL FLOW (VM,NUMNOD,NODES,NUMEL,OUTVEC) AVERAG=.TRUE. ALLPOS=.TRUE. SOMNEG=.NOT.ALLPOS CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(3)) THEN WRITE(6,50)'VELOCITY OF TOP OF MANTLE LITHOSPHERE' CALL MAGNIN (VM,NUMNOD,CONDNS) CALL MAGNIT (OUTVEC,NUMEL,OUTSCA,SOMNEG) DFCON1=CINT(3) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.TRUE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,3,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPM,YIPM, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF CALL FLOW (VC,NUMNOD,NODES,NUMEL,OUTVEC) CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(4)) THEN WRITE(6,50)'VELOCITY VECTORS OF TOP OF CRUST' CALL MAGNIN (VC,NUMNOD,CONDNS) CALL MAGNIT (OUTVEC,NUMEL,OUTSCA,SOMNEG) DFCON2=CINT(4) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.TRUE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,4,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,201) 201 FORMAT(' VELOCITY VECTORS:'/' MANTLE',63X,'CRUST') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 202 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 202 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(5).OR.DOPLOT(6)) THEN CALL STRAIN (ERATEM,NUMEL,OUTVEC) AVERAG=.FALSE. ALLPOS=.TRUE. CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(5)) THEN WRITE(6,50)'LARGEST PRINCIPAL STRAIN-RATE IN MANTLE' CALL MAXER (ERATEM,NUMEL,OUTSCA) CALL EXTRAP (INPUT,AREAM,DETJM,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON1=CINT(5) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.TRUE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,5,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPM,YIPM, + DOESYM,ERATEM, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF CALL STRAIN (ERATEC,NUMEL,OUTVEC) CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(6)) THEN WRITE(6,50)'LARGEST PRINCIPAL STRAIN-RATE IN CRUST' CALL MAXER (ERATEC,NUMEL,OUTSCA) CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON2=CINT(6) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.TRUE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,6,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,301) 301 FORMAT(' LARGEST MAGNITUDE PRINCIPAL STRAIN-RATE (NOTE' + ,': A-F NEGATIVE; G-L POSITIVE.)'/ + ' MANTLE',63X,'CRUST') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 302 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 302 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(7).OR.DOPLOT(8)) THEN CALL STRESS (TAUMTM,TAUZZM,OUTVEC,NUMEL) AVERAG=.FALSE. ALLPOS=.TRUE. CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(7)) THEN WRITE(6,50)'LARGEST STRESS ANOMALY INTEGRAL IN MANTLE' CALL MAXSS (TAUMTM,TAUZZM,NUMEL,OUTSCA) CALL EXTRAP (INPUT,AREAM,DETJM,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON1=CINT(7) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.TRUE. DOESYM=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,7,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPM,YIPM, + DOESYM,ERATEM, + DOAXES,TAUMTM,TAUZZM, + IPENCT,IPENLB,IPENST) ENDIF CALL STRESS (TAUMTC,TAUZZC,OUTVEC,NUMEL) CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(8)) THEN WRITE(6,50)'LARGEST STRESS ANOMALY INTEGRAL IN CRUST' CALL MAXSS (TAUMTC,TAUZZC,NUMEL,OUTSCA) CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON2=CINT(8) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.TRUE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,8,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,401) 401 FORMAT(' LARGEST MAGNITUDE HORIZONTAL PRINCIPAL', + ' STRESS ANOMALY', + ' INTEGRAL (NOTE: A-F NEGATIVE; G-L', + ' POSITIVE.):'/ + ' MANTLE',63X,'CRUST') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 402 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 402 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(9).OR.DOPLOT(10)) THEN CALL NET + (BOARD1,XNODM,YNODM, + NUMNOD,NODES,NUMEL,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(9)) THEN WRITE(6,50)'FINITE ELEMENT GRID FOR MANTLE LITHOSPHERE' CALL ETCH (DRAWST,9,NTYPE, + MXBN,MXNODE,NCOND,NODCON, + NODES,NUMEL,NUMNOD,NVCHAR,NXYST, + STATES,TEXT,TITLE,T2MA, + XNODM,XST,YNODM,YST, + IPENCT,IPENLB,IPENST,6) ENDIF CALL NET + (BOARD2,XNODC,YNODC, + NUMNOD,NODES,NUMEL,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(10)) THEN WRITE(6,50)'FINITE ELEMENT GRID FOR CRUST' CALL ETCH (DRAWST,10,NTYPE, + MXBN,MXNODE,NCOND,NODCON, + NODES,NUMEL,NUMNOD,NVCHAR,NXYST, + STATES,TEXT,TITLE,T2MA, + XNODC,XST,YNODC,YST, + IPENCT,IPENLB,IPENST,6) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,501) 501 FORMAT(' GRID OF FINITE ELEMENTS:'/ + ' MANTLE',63X,'CRUST') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 502 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 502 CONTINUE WRITE(6,2100) SCALEP,SCALEP ENDIF IF (DOPLOT(11).OR.DOPLOT(12)) THEN ALLPOS=.FALSE. CALL INTERP(WM,NODES,NUMEL,NUMNOD,OUTSCA) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(11)) THEN WRITE(6,50)'RATE OF THICKENING OF MANTLE LITHOSPHERE' DFCON1=CINT(11) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,WM,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,11,T2MA, + WM,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPM,YIPM, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF CALL INTERP(WC,NODES,NUMEL,NUMNOD,OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(12)) THEN WRITE(6,50)'RATE OF THICKENING OF CRUST (no spread)' DFCON2=CINT(12) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,WC,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,12,T2MA, + WC,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,601) 601 FORMAT(' RATE OF THICKENING OF THE LAYERS:'/ + ' MANTLE',63X,'CRUST (W/O SPREADING)') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 602 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 602 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(13).OR.DOPLOT(14)) THEN ALLPOS=.TRUE. CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,THIKM,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(13)) THEN WRITE(6,50)'THICKNESS OF MANTLE LITHOSPHERE' DFCON1=CINT(13) IF (DFCON1.LE.0.) + CALL INTRVL (THIKM,NUMEL,THNKM,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,13,T2MA, + THNKM,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPM,YIPM, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,THIKC,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(14)) THEN WRITE(6,50)'THICKNESS OF CRUST' DFCON2=CINT(14) IF (DFCON2.LE.0.) + CALL INTRVL (THIKC,NUMEL,THNKC,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,14,T2MA, + THNKC,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,701) 701 FORMAT(' THICKNESS OF LAYERS:'/ + ' MANTLE',63X,'CRUST') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 702 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 702 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(15).OR.DOPLOT(16)) THEN ALLPOS=.TRUE. CALL TMOHO (THIKM,NUMEL,GEOTHM,TEMLIM(2),OUTSCA) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(15)) THEN WRITE(6,50)'TEMPERATURE AT BASE OF MANTLE LITHOSPHERE' CALL EXTRAP (INPUT,AREAM,DETJM,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON1=CINT(15) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,15,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPM,YIPM, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF CALL TMOHO (THIKC,NUMEL,GEOTHC,TEMLIM(1),OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(16)) THEN WRITE(6,50)'TEMPERATURE AT MOHO' CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON2=CINT(16) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,16,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,801) 801 FORMAT(' TEMPERATURE AT BASE OF LAYERS:'/ + ' MANTLE',63X,'CRUST') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 802 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 802 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(17).OR.DOPLOT(18)) THEN CALL DELTP (GEOTHC,TEMLIM,ESUMC,ESUMM, + GEOTHM,GEOTHA,THIKM,THIKC,NUMEL,DNLINK, + VPMEAN,DVPBYE,DVPDT,OUTSCA,ONEKM, + THNKC,NODES,NUMNOD,UPLINK,AREAM, + DETJM,CONDNS, + NDIFF,HMAX,HMIN) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(17)) THEN WRITE(6,50)'P-WAVE TRAVEL-TIME RESIDUAL' ALLPOS=.FALSE. CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON1=CINT(17) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,17,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF CALL PEAKS (INPUT,G,NUMEL,RHOAST,RHOH2O,SIGZZC, + TIME2, + OUTPUT,OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(18)) THEN WRITE(6,50)'ISOSTATIC TOPOGRAPHY' ALLPOS=.FALSE. CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON2=CINT(18) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,18,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,901) 901 FORMAT(' PALEO-SURFACE-OBSERVABLES:'/ + ' TELESEISMIC P-WAVE TRAVEL-TIME RESIDUAL', + 30X,'ISOSTATIC TOPOGRAPHY') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 902 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 902 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(19).OR.DOPLOT(20)) THEN CALL HEAT(GEOTHC,NUMEL,CONDUC,OUTSCA) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(19)) THEN WRITE(6,50)'PALEO-HEAT-FLOW' ALLPOS=.TRUE. CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON1=CINT(19) IF (DFCON1.LT.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,19,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF CALL REBOUN (INPUT, AREAC,AREAM,DETJC,DETJM,DNLINK, + G,NDIFF,NODES,NUMEL, + NUMNOD,RHOAST,RHOH2O, + SIGZZC,SIGZZM,SZZBC,SZZBM, + TOUCHC,TOUCHM,TIME2, + OUTPUT,OUTSCA, + WORK, CONDNS) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(20)) THEN WRITE(6,50)'DELAMINATED PALEO-ELEVATIONS' ALLPOS=.FALSE. CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON2=CINT(20) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,20,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,1001) 1001 FORMAT(' PALEO-HEAT-FLOW:',53X, + 'POST-DELAMINATION ELEVATIONS:'/ + ' AT M.Y.B.P. INDICATED IN ()',42X, + '(WITH MANTLE SHAVED TO .LE. NORMAL WEIGHT)') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 1002 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 1002 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(21).OR.DOPLOT(22)) THEN CALL ELONG (ESUMC,NUMEL,OUTVEC) AVERAG=.FALSE. SOMNEG=.TRUE. CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(21)) THEN WRITE(6,50)'LARGEST-MAGNITUDE PRINCIPAL NET STRAIN' CALL GREENS (INPUT,ESUMC,NUMEL, + OUTPUT,ERATEC) CALL MAXER (ERATEC,NUMEL,OUTSCA) DO 1120 M=1,7 DO 1110 I=1,NUMEL OUTSCA(M,I)=ALOG10(OUTSCA(M,I)) OUTSCA(M,I)=MAX(OUTSCA(M,I),-2.01) 1110 CONTINUE 1120 CONTINUE ALLPOS=.FALSE. CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON1=CINT(21) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.TRUE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,21,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF CALL ROTOR (ESUMC,NUMEL,OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(22)) THEN WRITE(6,50)'NET ROTATION (degrees clockwise)' ALLPOS=.FALSE. CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) DFCON2=CINT(22) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,22,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,1101) 1101 FORMAT(' TOTAL DEFORMATION OF THE CRUST:'/ + ' LARGEST MAGNITUDE PRINCIPAL NET STRAIN', + ' (A-F NEGATIVE; G-L POSITIVE)', + 3X,'NET ROTATION (DEGREES CLOCKWISE)') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 1152 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 1152 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(23).OR.DOPLOT(24)) THEN ALLPOS=.TRUE. CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,CONINT,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(23)) THEN WRITE(6,50)'THICKNESS OF UPPER CRUSTAL LAYER' DFCON1=CINT(23) IF (DFCON1.LE.0.) + CALL INTRVL (CONINT,NUMEL,CONNOD,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,23,T2MA, + CONNOD,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF DO 1220 I=1,NUMNOD CONDNS(I)=MAX(0.,(THNKC(I)-CONNOD(I))) 1220 CONTINUE DO 1250 M=1,7 DO 1240 I=1,NUMEL OUTSCA(M,I)=MAX(0.,(THIKC(M,I)-CONINT(M,I))) 1240 CONTINUE 1250 CONTINUE CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(24)) THEN WRITE(6,50)'THICKNESS OF LOWER CRUSTAL LAYER' DFCON2=CINT(24) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOESYM=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,24,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIPC,YIPC, + DOESYM,ERATEC, + DOAXES,TAUMTC,TAUZZC, + IPENCT,IPENLB,IPENST) ENDIF WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,1201) 1201 FORMAT(' THICKNESS OF LAYERS WITHIN CRUST:'/ + ' UPPER',63X,'LOWER (MAY BE NEGATIVE)') BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 1280 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 1280 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF 1900 FORMAT(1H ,63A1,6X,63A1) 2100 FORMAT(' MAP SCALE = ',1P,E10.3,' PER INCH', + 38X,'MAP SCALE = ',1P,E10.3,' PER INCH') 2200 FORMAT(' RANGE = ',1P,E10.3,' TO ',E10.3,', CI = ',E10.3, + 20X,'RANGE = ',E10.3,' TO ',E10.3,', CI = ',E10.3) WRITE(6,3000) 3000 FORMAT(/' *** END OF PLOTS FOR THIS TIMESTEP ***' + /' ======================================') RETURN END SUBROUTINE REPORT C C C SUBROUTINE VPLOT (BOARD,RLOW,RHI,COUNT,STACK,XIP,YIP, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) C C CONVERTS VECTOR FIELD TO 1-DIGIT INTEGERS AND DIRECTION LETTERS C AND LOADS THEM INTO APPROPRIATE CELLS IN PRINT MATRIX C CHARACTER*1 BLANK,BOARD(59,63),DIGIT(11),DIREC(13) LOGICAL AVERAG DIMENSION COUNT(59,63), + OUTVEC(2,7,NUMEL), + STACK(2,59,63),XIP(7,NUMEL),YIP(7,NUMEL) DATA BLANK/' '/, DIGIT/'0','1','2','3','4','5','6','7', + '8','9','*'/, DIREC/'L','A','B','C','D','E','F','G','H', + 'I','J','K','L'/ IROW(Y)=MAX(1,MIN(59,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(63,INT(COLFAC*X+COLCON+1.5))) RLOW=1.E37 RHI= -1.E37 DO 10 I=1,59 DO 9 J=1,63 BOARD(I,J)=BLANK COUNT(I,J)=0. STACK(1,I,J)=0. STACK(2,I,J)=0. 9 CONTINUE 10 CONTINUE IF (AVERAG) THEN DO 100 M=1,7 DO 90 I=1,NUMEL IR=IROW(YIP(M,I)) JC=JCOL(XIP(M,I)) COUNT(IR,JC)=COUNT(IR,JC)+WEIGHT(M) STACK(1,IR,JC)=STACK(1,IR,JC)+ + WEIGHT(M)*OUTVEC(1,M,I) STACK(2,IR,JC)=STACK(2,IR,JC)+ + WEIGHT(M)*OUTVEC(2,M,I) 90 CONTINUE 100 CONTINUE ELSE DO 150 M=1,7 DO 140 I=1,NUMEL IR=IROW(YIP(M,I)) JC=JCOL(XIP(M,I)) IF (WEIGHT(M).GE.COUNT(IR,JC)) THEN STACK(1,IR,JC)= + WEIGHT(M)*OUTVEC(1,M,I) STACK(2,IR,JC)= + WEIGHT(M)*OUTVEC(2,M,I) COUNT(IR,JC)=WEIGHT(M) ENDIF 140 CONTINUE 150 CONTINUE ENDIF DO 200 I=1,59 DO 190 J=1,63 IF(COUNT(I,J).GT.0.) THEN STACK(1,I,J)=STACK(1,I,J)/COUNT(I,J) STACK(2,I,J)=STACK(2,I,J)/COUNT(I,J) VMAG=SQRT(STACK(1,I,J)**2+STACK(2,I,J)**2) BEARNG=ATAN2F(STACK(2,I,J),STACK(1,I,J)) RLOW=MIN(RLOW,VMAG) RHI=MAX(RHI,VMAG) STACK(1,I,J)=VMAG STACK(2,I,J)=BEARNG ENDIF 190 CONTINUE 200 CONTINUE IF(RHI.LE.RLOW) THEN RHI=RHI*1.001 RLOW=RLOW*0.999 ENDIF IF(RHI.EQ.0..AND.RLOW.EQ.0.) RHI=1. DO 300 I=1,59 DO 290 J=1,63 IF(COUNT(I,J).GT.0.) THEN ID=(STACK(1,I,J)-RLOW)/(RHI-RLOW) * 10. + 1.5 BOARD(I,J)=DIGIT(ID) IF (J.LT.63.AND.COUNT(I,J+1).LE.0.) THEN BD= -(STACK(2,I,J)/3.1415927)*6.+3. IF(BD.LT.0.) BD=BD+12. ID=BD+1.5 BOARD(I,J+1)=DIREC(ID) ENDIF ENDIF 290 CONTINUE 300 CONTINUE RETURN END SUBROUTINE VPLOT C C C SUBROUTINE FLOW (V,NUMNOD,NODES,NUMEL,OUTVEC) C C CALCULATES VELOCITY VECTORS AT INTEGRATION POINTS, FROM NODAL VALUES C DIMENSION NODES(6,0: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 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(4,7,NUMEL),OUTVEC(2,7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) CENTER=(EXX+EYY)*0.5 R=SQRT((EXX-CENTER)**2+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 INTEGRAL (INCLUDES THE C 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((TXX-CENTER)**2+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 NET (BOARD,XNOD,YNOD, + NUMNOD,NODES,NUMEL,ROWFAC,ROWCON, + COLFAC,COLCON) C C PUTS SYMBOLS INTO ARRAY BOARD IN ORDER TO PLOT NODES (@) AND C ELEMENT SIDES (@*****@*****@) C IMPLICIT DOUBLE PRECISION(A-H,O-Z) C C STATEMENT FUNCTIONS: INTEGER I,IROW,J,JCOL REAL COLCON,COLFAC,ROWCON,ROWFAC,X,XI,Y,YI IROW(Y)=MAX(1,MIN(59,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(63,INT(COLFAC*X+COLCON+1.5))) XI(J)=(J-1-COLCON)/COLFAC YI(I)=(I-1-ROWCON)/ROWFAC C CHARACTER*1 BLANK,BOARD(59,63),DOT,LINE INTEGER K,N,N1,N2,N3,NX1,NX3,NODES,NS LOGICAL PRINT REAL A,B,B2M4AC,C,DISC,DX,DY,F, + ROOT1,ROOT2,SIDE,X1,X2,X3,XNOD,Y1,Y2,Y3,YNOD C DIMENSION NODES(6,0:NUMEL),XNOD(NUMNOD),YNOD(NUMNOD) DATA BLANK/' '/,DOT/'@'/, LINE/'*'/ C DO 10 I=1,59 DO 8 J=1,63 BOARD(I,J)=BLANK 8 CONTINUE 10 CONTINUE DO 100 N=1,NUMEL DO 90 K=1,3 C ************************************************* C FOLLOWING OPTIONAL STATEMENT PREVENTS PLOTTING OF C THE DIAGONAL (HYPOTENUSE) OF EACH 2-ELEMENT C QUADRILATERAL CELL: C ************************************************* C IF (K.EQ.2) GO TO 90 C ************************************************* N1=NODES(K,N) N2=NODES((K+3),N) N3=NODES((MOD(K,3)+1),N) DX=XNOD(N3)-XNOD(N1) DY=YNOD(N3)-YNOD(N1) SIDE=SQRT(DX**2+DY**2) IF (ABS(DX).GE.ABS(DY)) THEN IF (DX.LT.0.) THEN NS=N1 N1=N3 N3=NS ENDIF X1=XNOD(N1) X2=XNOD(N2) X3=XNOD(N3) Y1=YNOD(N1) Y2=YNOD(N2) Y3=YNOD(N3) NX1=JCOL(X1) NX3=JCOL(X3) A=2.*X1-4.*X2+2.*X3 IF (ABS(A).GT.0.01*SIDE) THEN B= -3.*X1+4.*X2-X3 DO 20 J=NX1,NX3 X=XI(J) C=X1-X B2M4AC=B**2-4.*A*C IF (B2M4AC.GE.0.) THEN DISC=SQRT(B2M4AC) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) IF (ROOT1.GE.0..AND.ROOT1.LE.1.) THEN F=ROOT1 PRINT=.TRUE. ELSE IF(ROOT2.GE.0..AND.ROOT2.LE.1.) THEN F=ROOT2 PRINT=.TRUE. ELSE F=0. PRINT=.FALSE. ENDIF ELSE F=0. PRINT=.FALSE. ENDIF Y=Y1*(1.-3.*F+2.*F**2) + +Y2*(4.*F-4.*F**2) + +Y3*(-F+2.*F**2) IF (PRINT) BOARD(IROW(Y),J)=LINE 20 CONTINUE ELSE DO 21 J=NX1,NX3 X=XI(J) F=(X-X1)/(X3-X1) Y=Y1+F*(Y3-Y1) BOARD(IROW(Y),J)=LINE 21 CONTINUE ENDIF ELSE IF (DY.GT.0.) THEN NS=N1 N1=N3 N3=NS ENDIF X1=XNOD(N1) X2=XNOD(N2) X3=XNOD(N3) Y1=YNOD(N1) Y2=YNOD(N2) Y3=YNOD(N3) NY1=IROW(Y1) NY3=IROW(Y3) A=2.*Y1-4.*Y2+2.*Y3 IF (ABS(A).GT. 0.01*SIDE) THEN B= -3.*Y1+4.*Y2-Y3 DO 50 J=NY1,NY3 Y=YI(J) C=Y1-Y B2M4AC=B**2-4.*A*C IF (B2M4AC.GE.0.) THEN DISC=SQRT(B2M4AC) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) IF (ROOT1.GE.0..AND.ROOT1.LE.1.) THEN F=ROOT1 PRINT=.TRUE. ELSE IF(ROOT2.GE.0..AND.ROOT2.LE.1.) THEN F=ROOT2 PRINT=.TRUE. ELSE F=0. PRINT=.FALSE. ENDIF ELSE F=0. PRINT=.FALSE. ENDIF X=X1*(1.-3.*F+2.*F**2) + +X2*(4.*F-4.*F**2) + +X3*(-F+2.*F**2) IF (PRINT) BOARD(J,JCOL(X))=LINE 50 CONTINUE ELSE DO 51 J=NY1,NY3 Y=YI(J) F=(Y-Y1)/(Y3-Y1) X=X1+F*(X3-X1) BOARD(J,JCOL(X))=LINE 51 CONTINUE ENDIF ENDIF 90 CONTINUE 100 CONTINUE DO 200 I=1,NUMNOD X=XNOD(I) Y=YNOD(I) BOARD(IROW(Y),JCOL(X))=DOT 200 CONTINUE RETURN END SUBROUTINE NET C C C SUBROUTINE SPLOT (BOARD,RLOW,RHI,COUNT,STACK,XIP,YIP, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) C C CONVERTS SCALAR FIELD TO 1-DIGIT INTEGERS AND LOADS INTO C APPROPRIATE CELLS IN PRINT MATRIX C CHARACTER*1 BLANK,BOARD(59,63),DIGIT(11) DIMENSION COUNT(59,63), + OUTSCA(7,NUMEL), + STACK(2,59,63),XIP(7,NUMEL),YIP(7,NUMEL) DATA BLANK/' '/, DIGIT/'0','1','2','3','4','5','6','7', + '8','9','*'/ IROW(Y)=MAX(1,MIN(59,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(63,INT(COLFAC*X+COLCON+1.5))) RLOW=1.E37 RHI= -1.E37 DO 10 I=1,59 DO 9 J=1,63 BOARD(I,J)=BLANK COUNT(I,J)=0. STACK(1,I,J)=0. 9 CONTINUE 10 CONTINUE DO 100 M=1,7 DO 90 I=1,NUMEL IR=IROW(YIP(M,I)) JC=JCOL(XIP(M,I)) COUNT(IR,JC)=COUNT(IR,JC)+WEIGHT(M) STACK(1,IR,JC)=STACK(1,IR,JC)+WEIGHT(M)*OUTSCA(M,I) 90 CONTINUE 100 CONTINUE DO 200 I=1,59 DO 190 J=1,63 IF(COUNT(I,J).GT.0.) THEN STACK(1,I,J)=STACK(1,I,J)/COUNT(I,J) RLOW=MIN(RLOW,STACK(1,I,J)) RHI=MAX(RHI,STACK(1,I,J)) ENDIF 190 CONTINUE 200 CONTINUE IF(RHI.LE.RLOW) THEN RHI=RHI*1.001 RLOW=RLOW*0.999 ENDIF IF(RHI.EQ.0..AND.RLOW.EQ.0.) RHI=1. DO 300 I=1,59 DO 290 J=1,63 IF(COUNT(I,J).GT.0.) THEN ID=(STACK(1,I,J)-RLOW)/(RHI-RLOW) * 10. + 1.5 BOARD(I,J)=DIGIT(ID) ENDIF 290 CONTINUE 300 CONTINUE RETURN END SUBROUTINE SPLOT C C C SUBROUTINE TMOHO (THIK,NUMEL,GEOTH,TEMLIM,OUTSCA) C C CALCULATES TEMPERATURE AT THE BASE OF A LAYER BELOW INTEGRATION C POINTS C DIMENSION GEOTH(4,7,NUMEL),OUTSCA(7,NUMEL),THIK(7,NUMEL) TEMP(Z,L,J)=MIN(TEMLIM,GEOTH(1,L,J) + +GEOTH(2,L,J)*Z + +GEOTH(3,L,J)*Z**2 + +GEOTH(4,L,J)*Z**3) DO 100 M=1,7 DO 90 I=1,NUMEL OUTSCA(M,I)=TEMP(THIK(M,I),M,I) 90 CONTINUE 100 CONTINUE RETURN END 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 PEAKS (INPUT,G,NUMEL,RHOAST,RHOH2O,SIGZZC,TSEC, + OUTPUT,OUTSCA) C C COMPUTES ISOSTATIC TOPOGRAPHY CONSIDERING BOTH CRUST AND C MANTLE DENSITY ANOMALIES, C AND GIVES RESULTS AT CRUSTAL GRID INTEGRATION POINTS, IN OUTSCA. C NOTE THAT WATER (NO SEDIMENT) LOADING IS ASSUMED BELOW SEA LEVEL. C REAL HEIGHT DIMENSION OUTSCA(7,NUMEL),SIGZZC(7,NUMEL) C SEALVL=PITMAN(TSEC,RADIUS) FACTOR=RHOAST/(RHOAST-RHOH2O) DO 100 M=1,7 DO 90 I=1,NUMEL HEIGHT= -SIGZZC(M,I)/(G*RHOAST) HEIGHT=HEIGHT-SEALVL IF (HEIGHT.LT.0.) HEIGHT=HEIGHT*FACTOR OUTSCA(M,I)=HEIGHT 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE PEAKS C C C SUBROUTINE REBOUN (INPUT, AREAC,AREAM,DETJC,DETJM,DNLINK, + G,NDIFF,NODES,NUMEL, + NUMNOD,RHOAST,RHOH2O, + SIGZZC,SIGZZM,SZZBC,SZZBM, + TOUCHC,TOUCHM,TSEC, + OUTPUT,OUTSCA, + WORK, CONDNS) C C COMPUTES ISOSTATIC TOPOGRAPHY CONSIDERING BOTH CRUST AND C MANTLE DENSITY ANOMALIES, WITH MANTLE LIMITED TO .LE. NORMAL WEIGHT C (NOTE THAT "NORMAL" IS DEFINED BY VALUES AT M=5, I=NUMEL) C AND ALL SUBDUCTING SLABS REMOVED FROM CONTACT, C AND EXPRESSES RESULTS IN TERMS OF CRUSTAL GRID INTEGRATION POINTS. C NOTE THAT WATER (NO SEDIMENT) LOADING IS ASSUMED BELOW SEA LEVEL. C LOGICAL LOCKIN,LOCKWC REAL HEIGHT DIMENSION AREAC(NUMEL),AREAM(NUMEL),CONDNS(NUMNOD), + DETJC(7,NUMEL),DETJM(7,NUMEL), + DNLINK(3,7,NUMEL),NODES(6,0:NUMEL),OUTSCA(7,NUMEL), + SIGZZC(7,NUMEL),SIGZZM(7,NUMEL), + SZZBC(7,NUMEL),SZZBM(7,NUMEL),TOUCHC(7,NUMEL), + TOUCHM(7,NUMEL) DATA LOCKIN /.FALSE./, LOCKWC /.FALSE./ C SEALVL=PITMAN(TSEC,RADIUS) FACTOR=RHOAST/(RHOAST-RHOH2O) C C ELIMINATE SLAB EFFECTS FROM MANTLE ARRAY OF SZZ AT TOP C DO 20 M=1,7 DO 10 I=1,NUMEL OUTSCA(M,I)=SIGZZM(M,I)-TOUCHM(M,I)*SZZBM(M,I) 10 CONTINUE 20 CONTINUE C C TRANSFER VALUES TO CRUSTAL GRID C CALL EXTRAP (INPUT,AREAM,DETJM,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) C C MANTLE LITHOSPHERE IN FAR INLAND CORNER OF GRID IS "NORMAL" C REFSZM=OUTSCA(5,NUMEL) C C SUBTRACT OFF EXCESS LITHOSPHERE, AND ALSO ANY SLAB EFFECTS C DO 100 M=1,7 DO 90 I=1,NUMEL I2=DNLINK(1,M,I) IF (I2.GT.0) THEN SZMNA=OUTSCA(M,I) CORREC= -MAX(SZMNA-REFSZM,0.) + -TOUCHC(M,I)*SZZBC(M,I) ELSE CORREC= -TOUCHC(M,I)*SZZBC(M,I) ENDIF OUTSCA(M,I)=SIGZZC(M,I)+CORREC 90 CONTINUE 100 CONTINUE C C SMOOTH THE RESULTING SZZ AT TOP OF CRUST C CALL EXTRAP (INPUT,AREAC,DETJC,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) CALL INTERP (CONDNS,NODES,NUMEL,NUMNOD,OUTSCA) C C COMPUTE ISOSTATIC TOPOGRAPHY C DO 200 M=1,7 DO 190 I=1,NUMEL HEIGHT= -OUTSCA(M,I)/(G*RHOAST) HEIGHT=HEIGHT-SEALVL IF (HEIGHT.LT.0.)HEIGHT=HEIGHT*FACTOR OUTSCA(M,I)=HEIGHT 190 CONTINUE 200 CONTINUE RETURN END SUBROUTINE REBOUN C C C REAL FUNCTION PITMAN (AGESEC,REARTH) C C RETURNS HEIGHT OF SEA LEVEL WITH RESPECT TO PRESENT, C IN CURRENT MEASUREMENT UNITS (DETERMINED FROM C REARTH, THE RADIUS OF THE EARTH), AT THE TIME C BEFORE PRESENT AGESEC (POSITIVE SECONDS). C C BASED ON W.C. PTIMAN, 3RD (1978) GEOLOGICAL SOCIETY OF C AMERICA BULLETIN, V. 89, P. 1389-1403. C PARAMETER (NDATA=9) INTEGER J,N1,N2 REAL AGEDAT,AGEMY,AGESEC,FACTOR,FRAC,HDATA,REARTH DIMENSION AGEDAT(NDATA),HDATA(NDATA) DATA AGEDAT /0., 15., 25., 35., 45., 55., 65., 75., 85./ DATA HDATA /0., 58., 98.,164.,200.,264.,327.,335.,344./ C AGEMY=AGESEC/3.15576E13 FACTOR=REARTH/6371000. IF (AGEMY.LT.0.0) THEN WRITE(6,1) 1 FORMAT(' FUNCTION PITMAN HAS BEEN ASKED FOR FUTURE SEALEVEL' + /' AND WILL ASSUME THAT THE PRESENT IS THE KEY TO' + /' THE FUTURE (I.E., NO CHANGE).') PITMAN=0. ELSE IF (AGEMY.GT.AGEDAT(NDATA)) THEN WRITE(6,2) AGEDAT(NDATA) 2 FORMAT(' FUNCTION PITMAN HAS BEEN ASKED FOR SEALEVEL BEFORE' + /' THE BEGINNING OF ITS TABLE, AT ',F3.0,' M.Y.,' + /' SO THE FIRST AVAILABLE VALUE WILL BE RETURNED.') PITMAN=HDATA(NDATA)*FACTOR ELSE N1=1 N2=2 DO 10 J=1,NDATA-1 IF (AGEMY.GE.AGEDAT(J).AND.AGEMY.LE.AGEDAT(J+1)) THEN N1=J N2=J+1 GO TO 11 ENDIF 10 CONTINUE 11 FRAC=(AGEMY-AGEDAT(N1))/(AGEDAT(N2)-AGEDAT(N1)) PITMAN=FACTOR*(HDATA(N1)+FRAC*(HDATA(N2)-HDATA(N1))) ENDIF RETURN END FUNCTION PITMAN C C C SUBROUTINE DELTP (GEOTHC,TEMLIM,ESUMC,ESUMM, + GEOTHM,GEOTHA,THIKM,THIKC,NUMEL,DNLINK, + VPMEAN,DVPBYE,DVPDT,OUTSCA,ONEKM, + THNKC,NODES,NUMNOD,UPLINK,AREAM, + DETJM,CONDNS, + NDIFF,HMAX,HMIN) C C COMPUTES TELESEISMIC P-WAVE VERTICAL TRAVEL-TIME RESIDUALS, C CONSIDERING THICKNESS AND TEMPERATURE VARIATIONS AND STRAIN EZZ, C AND USING ARRAYS UPLINK AND DNLINK TO RELATE GRIDS, C AND EXPRESSES RESULTS IN TERMS OF CRUSTAL GRID INTEGRATION POINTS C NOTE THAT RESIDUAL IS CALIBRATED TO ZERO AT SE CORNER. C NOTE THAT NO PROVISION IS MADE FOR TOPOGRAPHY; C RESIDUALS PRESENTED ARE CORRECTED TO SEA LEVEL. C HORIZONTAL OCEANIC SLABS ARE IGNORED; ASSUMED ABSENT AT PRESENT. C LOGICAL LOCKIN,LOCKWC DIMENSION AREAM(NUMEL),CONDNS(NUMNOD),DETJM(7,NUMEL), + DNLINK(3,7,NUMEL), + DVPBYE(2,2),DVPDT(2), + ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL), + GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL), + GEOTHM(4,7,NUMEL),HMAX(2),HMIN(2), + NODES(6,0:NUMEL),OUTSCA(7,NUMEL), + TEMLIM(2),THIKC(7,NUMEL),THIKM(7,NUMEL), + THNKC(NUMNOD),UPLINK(3,7,NUMEL), + VPMEAN(2) DATA LOCKIN /.FALSE./, LOCKWC /.FALSE./ TEMPC(Z,M,I)=MIN(TEMLIM(1),GEOTHC(1,M,I) + +GEOTHC(2,M,I)*Z + +GEOTHC(3,M,I)*Z**2 + +GEOTHC(4,M,I)*Z**3) TEMPM(Z,M,I)=MIN(TEMLIM(2),GEOTHM(1,M,I) + +GEOTHM(2,M,I)*Z + +GEOTHM(3,M,I)*Z**2 + +GEOTHM(4,M,I)*Z**3) TEMPA(Z,M,I)=MIN(TEMLIM(2),GEOTHA(1,M,I) + +GEOTHA(2,M,I)*Z + +GEOTHA(3,M,I)*Z**2 + +GEOTHA(4,M,I)*Z**3) C TASTH=TEMPM(THIKM(5,NUMEL),5,NUMEL) VASTH=VPMEAN(2)*(1.+DVPDT(2)*TASTH) NBL=THIKM(5,NUMEL)/ONEKM BLRES=THIKM(5,NUMEL)-ONEKM*NBL IBASE=(HMAX(1)+HMAX(2))/ONEKM C C PREPARE BY COMPUTING MANTLE LITHOSPHERE TRAVEL TIMES C CALL GETSCA (INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DO 100 M=1,7 DO 90 I=1,NUMEL CRUST=OUTSCA(M,I) TIME=0. DO 20 J=IBASE,1,-1 Z=ONEKM*(J-0.5) IF (Z.LT.CRUST) GO TO 21 IF (Z.LE.(CRUST+THIKM(M,I))) THEN ZP=Z-CRUST T=TEMPM(ZP,M,I) RELARE=ESUMM(1,1,M,I)*ESUMM(2,2,M,I)- + ESUMM(1,2,M,I)*ESUMM(2,1,M,I) RELARE=MIN(RELARE,5.0) RELARE=MAX(RELARE,0.3) EZZ=(1./RELARE)-1.0 VEL=VPMEAN(2)*(1.+DVPDT(2)*T+ + DVPBYE(1,2)*ATAN(EZZ/DVPBYE(2,2))) ELSE VEL=VASTH ENDIF TIME=TIME+ONEKM/VEL 20 CONTINUE 21 RESID=J*ONEKM-CRUST TIME=TIME+RESID/VEL OUTSCA(M,I)=TIME 90 CONTINUE 100 CONTINUE CALL EXTRAP (INPUT,AREAM,DETJM,LOCKIN,LOCKWC,PHINOD, + OUTSCA, + OUTPUT,CONDNS) C C COMPLETE INTEGRAL AT EACH CRUSTAL INTEGRATION POINT C CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 200 M=1,7 DO 190 I=1,NUMEL C C MANTLE PORTION C I2=DNLINK(1,M,I) IF (I2.GT.0) THEN C C NORMAL MANTLE LITHOSPHERE BELOW C TIME=OUTSCA(M,I) ELSE C C AREA OVER NEW ASTHENOSPHERE, WITH OR WITHOUT C A NEW THERMAL BOUNDARY LAYER C CRUST=THIKC(M,I) TIME=(HMAX(1)+HMAX(2)-CRUST-THIKM(5,NUMEL))/ + VASTH DO 110 J=NBL,1,-1 ZP=ONEKM*(J-0.5) T=TEMPA(ZP,M,I) VEL=VPMEAN(2)*(1.+DVPDT(2)*T) TIME=TIME+ONEKM/VEL 110 CONTINUE TIME=TIME+BLRES/VEL ENDIF C C CRUSTAL PORTION C DO 120 J=1,IBASE Z=ONEKM*(J-0.5) IF (Z.GT.THIKC(M,I)) GO TO 121 T=TEMPC(Z,M,I) RELARE=ESUMC(1,1,M,I)*ESUMC(2,2,M,I)- + ESUMC(1,2,M,I)*ESUMC(2,1,M,I) RELARE=MIN(RELARE,5.0) RELARE=MAX(RELARE,0.3) EZZ=(1./RELARE)-1.0 VEL=VPMEAN(1)*(1.+DVPDT(1)*T+ + DVPBYE(1,1)*ATAN(EZZ/DVPBYE(2,1))) TIME=TIME+ONEKM/VEL 120 CONTINUE 121 RESID=THIKC(M,I)-(J-1)*ONEKM TIME=TIME+RESID/VEL OUTSCA(M,I)=TIME 190 CONTINUE 200 CONTINUE C C CALIBRATE TO SOUTHEAST CORNER VALUES (=0) C STANDR=OUTSCA(5,NUMEL) DO 300 M=1,7 DO 290 I=1,NUMEL OUTSCA(M,I)=OUTSCA(M,I)-STANDR 290 CONTINUE 300 CONTINUE RETURN END SUBROUTINE DELTP C C C SUBROUTINE ELONG (E,NUMEL,OUTVEC) + C C CALCULATES LARGEST-MAGNITUDE PRINCIPAL STRAIN IN VECTOR FORM C NOTE THAT ELONG WORKS WITH VPLOT TO PUT NEGATIVE VECTORS IN A-F C REAL ANGLE DIMENSION E(2,2,7,NUMEL),OUTVEC(2,7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL RNUM=2.*(E(1,1,M,I)*E(1,2,M,I)+E(2,1,M,I)*E(2,2,M,I)) RDENOM=E(1,1,M,I)**2+E(2,1,M,I)**2- + E(1,2,M,I)**2-E(2,2,M,I)**2 IF (RDENOM.NE.0.) THEN RHS=RNUM/RDENOM TTHETA=ATAN(RHS) THETA=TTHETA/2. ELSE THETA=0. ENDIF THETA2=THETA+1.570796327 S1X=COS(THETA) S1Y=SIN(THETA) S2X=COS(THETA2) S2Y=SIN(THETA2) BIGS1X=E(1,1,M,I)*S1X+E(1,2,M,I)*S1Y BIGS1Y=E(2,1,M,I)*S1X+E(2,2,M,I)*S1Y BIGS2X=E(1,1,M,I)*S2X+E(1,2,M,I)*S2Y BIGS2Y=E(2,1,M,I)*S2X+E(2,2,M,I)*S2Y BIGS1=SQRT(BIGS1X**2+BIGS1Y**2) BIGS2=SQRT(BIGS2X**2+BIGS2Y**2) ALPHA=ATAN2F(BIGS1Y,BIGS1X) ALPHA2=ATAN2F(BIGS2Y,BIGS2X) CENTER=SQRT(BIGS1*BIGS2)-1. R=MAX(ABS(BIGS1-1.-CENTER),ABS(BIGS2-1.-CENTER)) IF (CENTER.GT.0.) THEN EM=CENTER+R IF (BIGS1.GE.BIGS2) THEN ANGLE=ALPHA ELSE ANGLE=ALPHA2 ENDIF IF (ANGLE.LE.1.308996.AND.ANGLE.GT.-1.832596) + ANGLE=ANGLE+3.141593 ELSE EM=CENTER-R IF (BIGS1.LE.BIGS2) THEN ANGLE=ALPHA ELSE ANGLE=ALPHA2 ENDIF IF (ANGLE.GT.1.308996.OR.ANGLE.LE.-1.832596) + ANGLE=ANGLE+3.141593 EM= -EM ENDIF OUTVEC(1,M,I)=EM*COS(ANGLE) OUTVEC(2,M,I)=EM*SIN(ANGLE) 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE ELONG C C C SUBROUTINE GREENS (INPUT,E,NUMEL, + OUTPUT,ER) C C COMPUTES GREENS FINITE-STRAIN TENSOR FROM DISPLACEMENT-GRADIENT C MATRICES "E" AND STORES THEM IN SAME FORMAT AS C STRAIN-RATE TENSORS "ER"; USED ONLY TO PREPARE FOR C PLOTTING OF FINITE STRAINS. C DIMENSION ER(4,7,NUMEL),E(2,2,7,NUMEL),GREENT(2,2) C DO 100 M=1,7 DO 90 I=1,NUMEL GREENT(1,1)=0.5*(E(1,1,M,I)**2+E(2,1,M,I)**2-1.00) GREENT(1,2)=0.5*(E(1,1,M,I)*E(1,2,M,I)+ + E(2,1,M,I)*E(2,2,M,I)) GREENT(2,1)=0.5*(E(1,2,M,I)*E(1,1,M,I)+ + E(2,2,M,I)*E(2,1,M,I)) GREENT(2,2)=0.5*(E(1,2,M,I)**2+E(2,2,M,I)**2-1.00) ER(1,M,I)=GREENT(1,1) ER(2,M,I)=GREENT(2,2) ER(3,M,I)=GREENT(1,2) ER(4,M,I)=0.0 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE GREENS C C C SUBROUTINE ROTOR (ESUM,NUMEL,OUTSCA) C C COMPUTE NET CLOCKWISE ROTATION IN DEGREES C OF A HYPOTHETICAL SOLID INCLUSION, C BY AVERAGING THE ROTATIONS OF THE X AND Y AXES. C DIMENSION ESUM(2,2,7,NUMEL),OUTSCA(7,NUMEL) DO 10 M=1,7 DO 9 I=1,NUMEL ROT1=ATAN2F(ESUM(2,1,M,I),ESUM(1,1,M,I)) ROT2=ATAN2F(-ESUM(1,2,M,I),ESUM(2,2,M,I)) IF(ABS(ROT1-ROT2).GT.3.141592654) THEN IF(ROT1.LT.ROT2) THEN ROT1=ROT1+6.283185307 ELSE ROT2=ROT2+6.283185307 ENDIF ENDIF ROTATE=(ROT1+ROT2)/2. OUTSCA(M,I)= -57.29577951*ROTATE 9 CONTINUE 10 CONTINUE RETURN END SUBROUTINE ROTOR 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 INTEGER, INTENT(IN) :: I, NUMNOD, NUMEL LOGICAL, INTENT(IN) :: S4,S5,S6 INTEGER, DIMENSION(6,0:NUMEL), INTENT(IN) :: NODES REAL, DIMENSION(NUMNOD), INTENT(IN) :: XNOD,YNOD DIMENSION S(3),DS(3) DATA STEP/0.10/, ISTEP/10/ C STATEMENT FUNCTION: 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 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 DO 10 K=1,3 S(K)=0. DS(K)=0. 10 CONTINUE S(J1)=1.00 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,ISTEP 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 MAGNIT (OUTVEC,NUMEL,OUTSCA,SOMNEG) 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 LOGICAL SOMNEG DIMENSION OUTSCA(7,NUMEL),OUTVEC(2,7,NUMEL) DO 10 M=1,7 DO 9 I=1,NUMEL OUTSCA(M,I)=SQRT(OUTVEC(1,M,I)**2+ + OUTVEC(2,M,I)**2) 9 CONTINUE 10 CONTINUE IF (SOMNEG) THEN DO 20 M=1,7 DO 19 I=1,NUMEL IF(OUTVEC(1,M,I).GT.0.) OUTSCA(M,I)= + -OUTSCA(M,I) 19 CONTINUE 20 CONTINUE ENDIF RETURN END SUBROUTINE MAGNIT C C C SUBROUTINE MAGNIN (V,NUMNOD,CONDNS) C C CONVERT VECTOR TO SCALAR MAGNITUDE AT NODES C DIMENSION CONDNS(NUMNOD),V(2,NUMNOD) DO 10 I=1,NUMNOD CONDNS(I)=SQRT(V(1,I)**2+V(2,I)**2) 10 CONTINUE RETURN END SUBROUTINE MAGNIN C C C SUBROUTINE INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD,DFCON,NCONTR) C C COMPUTE CONTOUR INTERVAL ROUNDED TO NEAREST 1,2,3,4,5, X 10**P C DIMENSION CONDNS(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,CONDNS(I)) RHI =MAX(RHI ,CONDNS(I)) 30 CONTINUE GUESS=(RHI-RLOW)/NCONTR IF (GUESS.GT.0.) THEN IZERO=IBELOW(ALOG10(GUESS)) FACTOR=GUESS/10.**IZERO IFACTR=FACTOR+0.5 IFACTR=MIN0(5,IFACTR) IF (FACTOR.GT.7.) IFACTR=10 DFCON=IFACTR*10.**IZERO ELSE DFCON=1.00 ENDIF RETURN END SUBROUTINE INTRVL C C C SUBROUTINE MAXER (ERATE,NUMEL,OUTSCA) C C FINDS LARGEST (ABS. VALUE) LINEAR STRETCH RATE IN THE TENSOR ERATE C AND ASSIGNS ITS SCALAR VALUE TO OUTSCA C DIMENSION ERATE(4,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(EXY**2+0.25*(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 (TAUMT,TAUZZ,NUMEL,OUTSCA) C C FINDS LARGEST (ABS. VALUE) SHEAR STRESS INTEGRAL IN TENSOR TAUMT C AND ASSIGNS ITS SCALAR VALUE TO OUTSCA C DIMENSION TAUMT(3,7,NUMEL),TAUZZ(7,NUMEL),OUTSCA(7,NUMEL) C DO 100 M=1,7 DO 90 I=1,NUMEL TXX=TAUMT(1,M,I)+TAUZZ(M,I) TYY=TAUMT(2,M,I)+TAUZZ(M,I) TXY=TAUMT(3,M,I) SHEAR=SQRT(TXY**2+0.25*(TXX-TYY)**2) CENTER=(TXX+TYY)/2. T1=CENTER-SHEAR T2=CENTER+SHEAR TZ=TAUZZ(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 CHARACTER*5 FUNCTION ASCII5 (T) C C CONVERTS REAL*4 FLOATING-POINT VARIABLE TO "-12.3" C OR "123.4" OR " 0.9" C REAL, INTENT(IN) :: T INTEGER I1,I2,I3,I4 INTEGER :: OFFSET = 48 REAL*4 S C S=ABS(T) IF (T.LE.-100.0) THEN ASCII5='-**.*' ELSE IF (T.GE.1000.0) THEN ASCII5='***.*' ELSE I1=INT(S/100.) I2=INT((S-100.*I1)/10.) I3=INT(S-100.*I1-10.*I2) I4=INT(10.*(S-100.*I1-10.*I2-I3)+0.5) IF (I4.EQ.10) THEN I4=0 I3=I3+1 IF (I3.EQ.10) THEN I3=0 I2=I2+1 IF (I2.EQ.10) THEN I2=0 I1=I1+1 ENDIF ENDIF ENDIF ASCII5(1:1)=CHAR(OFFSET+I1) ASCII5(2:2)=CHAR(OFFSET+I2) ASCII5(3:3)=CHAR(OFFSET+I3) ASCII5(4:4)='.' ASCII5(5:5)=CHAR(OFFSET+I4) IF(ASCII5(1:1).EQ.'0')ASCII5(1:1)=' ' IF(ASCII5(2:2).EQ.'0'.AND.ASCII5(1:1).EQ.' ')ASCII5(2:2)=' ' IF (T.LT.0.0) THEN IF (ASCII5(2:2).EQ.' ') THEN ASCII5(2:2)='-' ELSE ASCII5(1:1)='-' ENDIF ENDIF ENDIF RETURN END FUNCTION ASCII5 C C C SUBROUTINE EPOCH (INPUT,T,OUTPUT,NCHAR,TEXT) C C SELECT NAME OF EPOCH CONTAINING TIME = "T" MY BEFORE PRESENT C PER GEOLOGICAL SOCIETY OF AMERICA'S DNAG 1983 GEOLOGIC TIME SCALE C PARAMETER (NTIME=20) REAL*4 T,TTOP INTEGER NCHAR,NC CHARACTER*40 TEXT,LABELS DIMENSION LABELS(NTIME),NC(NTIME),TTOP(NTIME) DATA LABELS/'Holocene ', & 'Pleistocene ', & 'Late Pliocene ', & 'Early Pliocene ', & 'Late Miocene ', & 'Middle Miocene ', & 'Early Miocene ', & 'Late Oligocene ', & 'Early Oligocene ', & 'Late Eocene ', & 'Middle Eocene ', & 'Early Eocene ', & 'Late Paleocene ', & 'Early Paleocene ', & 'Late Cretaceous-Maastrich. ', & 'Late Cretaceous-Campanian ', & 'Late Cretaceous-Santonian ', & 'Late Cretaceous-Coniacian ', & 'Late Cretaceous-Turonian ', & 'Late Cretaceous-Cenomanian '/ DATA NC/8,11,13,14,12,14,13,14,15,11,13,12,14,15, & 28,27,27,27,26,28/ DATA TTOP/0.01, 1.6, 3.4, 5.3, 11.2, 16.6, & 23.7, 30.0, 36.6, 40.0, 52.0, 57.8, & 63.6, 66.4, 74.5, 84.0, 87.5, 88.5, 91.0, 97.5/ IF (ABS(T).LT.0.001) THEN TEXT='Present' NCHAR=7 ELSE IF (T.LT.0.0) THEN TEXT='Future' NCHAR=6 ELSE IF (T.GT.TTOP(NTIME)) THEN TEXT='?' NCHAR=1 ELSE DO 10 I=1,NTIME IF (T.LE.TTOP(I)) THEN TEXT=LABELS(I) NCHAR=NC(I) RETURN ENDIF 10 CONTINUE ENDIF RETURN END SUBROUTINE EPOCH C C C SUBROUTINE EXTRAP (INPUT,AREA,DETJ,LOCKIN,LOCKWC,PHIVAL,VALUES, + OUTPUT,FPOLES) C C FILL COEFFICIENT/RIGHT-HAND-SIDE MATRIX ABCDEF C (DYNAMICALLY ALLOCATED IN MAIN, WITH SPECIAL MSIMSL C STORAGE LOCATION ALGORITHM), C C BUILD RIGHT-HAND-SIDE FROM VALUES AT INTEGRATION POINTS, C C IMPOSE BOUNDARY CONDITIONS (IF DESIRED), C C AND SOLVE LINEAR SYSTEM FOR NODAL VALUES. C INTEGER I,IR,I6,J,JC,J6,K,KC,KR,M LOGICAL LOCKIN,LOCKWC REAL AREA,BC,BIGEST,DETJ,FPOLES,SUM,VALDA,VALUES DIMENSION AREA(NUMEL),DETJ(7,NUMEL),FPOLES(NUMNOD), + PHIVAL(NUMNOD),VALUES(7,NUMEL) C C BEGIN BY ZEROING C ABCDEF = 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 IR=NODES(I6,I) JC=NODES(J6,I) 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) ABCDEF(KR,KC)=ABCDEF(KR,KC)+SUM*AREA(I) ENDIF 80 CONTINUE 90 CONTINUE 100 CONTINUE C BIGEST=0.0 C FIND LARGEST DIAGONAL COEFFICIENT DO 110 I=1,NUMNOD KR=ABCDrow(I) KC=ABCDcol(I,I) BIGEST=MAX(BIGEST,ABCDEF(KR,KC)) 110 CONTINUE C C ZERO THE FORCING VECTOR C DO 200 I=1,NUMNOD KR=EFrow(I) KC=EFcol() ABCDEF(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 K=NODES(J,I) KR=EFrow(K) KC=EFcol() ABCDEF(KR,KC)=ABCDEF(KR,KC)+PHI(J,M)*VALDA 600 CONTINUE 700 CONTINUE 800 CONTINUE C IF (LOCKIN) THEN BC=0.0 DO 810 I=1,NCOLN J=I CALL FIXNOD (J,BC,BIGEST) 810 CONTINUE DO 820 I=1,NROWN J=I*NCOLN CALL FIXNOD (J,BC,BIGEST) 820 CONTINUE DO 830 I=1,NCOLN J=(NROWN-1)*NCOLN+I CALL FIXNOD (J,BC,BIGEST) 830 CONTINUE END IF C IF (LOCKWC) THEN DO 900 I=1,NROWN J=(I-1)*NCOLN+1 CALL FIXNOD (J,PHIVAL(J),BIGEST) 900 CONTINUE END IF C CALL LSLPB (NUMNOD, ABCDEF, 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 ABCDEF EXTENDED MATRIX C DO 1000 I=1,NUMNOD KR=EFrow(I) KC=EFcol() FPOLES(I)=ABCDEF(KR,KC) 1000 CONTINUE C RETURN END SUBROUTINE EXTRAP C C C SUBROUTINE FIXNOD (NODE,BC,BIGEST) C C MODIFIES PACKED LINEAR SYSTEM ABCDEF TO SET VALUE BC AT NODE, C USING WEIGHT BIGEST C INTEGER, INTENT(IN) :: NODE REAL, INTENT(IN) :: BC, BIGEST INTEGER IDIFF,IR,JC,K,KC,KR REAL ZEROED C DO 100 IDIFF=1,NDIFF K=NODE+IDIFF IF (K.LE.NUMNOD) THEN C ZERO THE HALF-ROW TO RIGHT OF THE DIAGONAL; IR=NODE JC=K KR=ABCDrow(JC) KC=ABCDcol(IR,JC) ZEROED=ABCDEF(KR,KC) ABCDEF(KR,KC)=0.0 C C ALSO ADJUST RHS FOR EFFECTS OF ZEROING IMAGE C HALF-COLUMN BELOW DIAGONAL: IR=K KR=EFrow(IR) KC=EFcol() ABCDEF(KR,KC)=ABCDEF(KR,KC)-ZEROED*BC END IF C K=NODE-IDIFF IF (K.GE.1) THEN C ZERO THE HALF-COLUMN ABOVE THE DIAGONAL; IR=K JC=NODE KR=ABCDrow(JC) KC=ABCDcol(IR,JC) ZEROED=ABCDEF(KR,KC) ABCDEF(KR,KC)=0.0 C C ADJUST RHS FOR EFFECTS OF ZEROING KR=EFrow(IR) KC=EFcol() ABCDEF(KR,KC)=ABCDEF(KR,KC)-ZEROED*BC END IF 100 CONTINUE C C SET THE DIAGONAL ELEMENT: IR=NODE JC=NODE KR=ABCDrow(JC) KC=ABCDcol(IR,JC) ABCDEF(KR,KC)=BIGEST C C SET THE RIGHT-HAND SIDE: IR=NODE KR=EFrow(IR) KC=EFcol() ABCDEF(KR,KC)=BIGEST*BC C RETURN END SUBROUTINE FIXNOD 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 C C SUBROUTINE ETCH (DRAWST,JV,NTYPE, + MXBN,MXNODE,NCOND,NODCON, + NODES,NUMEL,NUMNOD,NVCHAR,NXYST, + STATES,TEXT,TITLE,T2MA, + 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*5 TMYCHR CHARACTER*40 TTEXT CHARACTER*42 TEXT CHARACTER*80 TITLE CHARACTER*200 BUFFER200 INTEGER INTEG,NECHAR,NINIT,NINWIN LOGICAL DRAWST,IN,S4,S5,S6,STATES REAL HEIGHT,ROTAT,TOP,T2MA,X,Y DIMENSION DRAWST(NXYST), + NODCON(MAXBN), + NODES(6,0:NUMEL),NVCHAR(NTYPE), + TEXT(NTYPE),XNOD(NUMNOD),YNOD(NUMNOD), + XST(NXYST),YST(NXYST) 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 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 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 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 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 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', + NXYST,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)) NINIT=LEN(TRIM(TITLE)) BUFFER200(1:NINIT)=TRIM(TITLE) BUFFER200(NINIT+1:NINIT+2)=', ' NINIT=NINIT+2 TMYCHR=ASCII5(T2MA) BUFFER200(NINIT+1:NINIT+5)=TMYCHR NINIT=NINIT+5 BUFFER200(NINIT+1:NINIT+5)=' Ma (' NINIT=NINIT+5 CALL EPOCH (IMPUT,T2MA,OUTPUT,NECHAR,TTEXT) BUFFER200(NINIT+1:NINIT+NECHAR)=TTEXT(1:NECHAR) NINIT=NINIT+NECHAR BUFFER200(NINIT+1:NINIT+1)=')' NINIT=NINIT+1 CALL SYMBOL (0.5,TOP+1.5*HEIGHT,HEIGHT,BUFFER200, + IDUMMY,0.,NINIT) C C CLOSE SEGMENT WITH TEXT LABELS C C**************************************************************** C CALL ENDPL(IZERO) C RETURN END SUBROUTINE ETCH C C C SUBROUTINE USMAP (INPUT,DRAWST,IPEN,color_name, + NXYST,XST,YST) C C PLOTS OUTLINE OF STATES FROM DIGITIZED DATASET. C CHARACTER*10 color_name INTEGER IPEN,NXYST LOGICAL DRAW LOGICAL DRAWST REAL XST,YST DIMENSION DRAWST(NXYST),XST(NXYST),YST(NXYST) C CALL NEWPEN(IPEN) IF (COLOR) CALL PENCLR (color_name) CALL BGROUP DO 100 I=1,NXYST XP=XST(I) YP=YST(I) DRAW=DRAWST(I) IF (DRAW) THEN CALL PLOT(XP,YP,2) ELSE CALL PLOT(XP,YP,3) ENDIF 100 CONTINUE CALL EGROUP RETURN END SUBROUTINE USMAP C C C SUBROUTINE PAINT (NODES,XNOD,YNOD,TITLE,TEXT,JV,T2MA, + FUNC,CINT,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,OUTVEC,RMSVEC,XIP,YIP, + DOESYM,ERATE, + DOAXES,TAUMT,TAUZZ, + 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*5 TMYCHR CHARACTER*8 SCALEA CHARACTER*9 CHAR9, SCALEV CHARACTER*40 TTEXT CHARACTER*42 TEXT, VUNITS CHARACTER*80 TITLE CHARACTER*200 BUFFER200 INTEGER N,NINIT LOGICAL ALLPOS,DOAROW,DOAXES, + DOESYM,STATES LOGICAL DRAWST REAL ANGLE, HEIGHT, XINCH DIMENSION DRAWST(NXYST),ERATE(4,7,NUMEL),FBLAND(NTYPE), + FUNC(NUMNOD),LOWBLU(NTYPE), + NODES(6,0:NUMEL),NVCHAR(NTYPE), + NVUCHR(NTYPE),OUTVEC(2,7,NUMEL), + TAUMT(3,7,NUMEL),TAUZZ(7,NUMEL), + TEXT(NTYPE),VUNITS(NTYPE),XIP(7,NUMEL),YIP(7,NUMEL), + XNOD(NUMNOD),YNOD(NUMNOD), + XST(NXYST),YST(NXYST) 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 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', + NXYST,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 CALL ALNMES(1.0,0.0) X=XINCH+1.8 Y=YTOP+0.7*HEIGHT CALL SYMBOL (X,Y,HEIGHT,VUNITS(JV),IDUMMY,0.,NVUCHR(JV)) C C DRAW BOXES AND CONTOUR LABELS C YOLD=Y YNEXT=Y-1.1*HEIGHT 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.8,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)) NINIT=LEN(TRIM(TITLE)) BUFFER200(1:NINIT)=TRIM(TITLE) BUFFER200(NINIT+1:NINIT+2)=', ' NINIT=NINIT+2 TMYCHR=ASCII5(T2MA) BUFFER200(NINIT+1:NINIT+5)=TMYCHR NINIT=NINIT+5 BUFFER200(NINIT+1:NINIT+5)=' Ma (' NINIT=NINIT+5 CALL EPOCH (IMPUT,T2MA,OUTPUT,NECHAR,TTEXT) BUFFER200(NINIT+1:NINIT+NECHAR)=TTEXT(1:NECHAR) NINIT=NINIT+NECHAR BUFFER200(NINIT+1:NINIT+1)=')' NINIT=NINIT+1 CALL SYMBOL (0.5,TOP+1.5*HEIGHT,HEIGHT,BUFFER200, + IDUMMY,0.,NINIT) C C CLOSE SEGMENT WITH TEXT LABELS C C**************************************************************** C CALL ENDPL(IZERO) C RETURN END SUBROUTINE PAINT 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 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(4,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(EXY**2+0.25*(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 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(TXY**2+0.25*(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(TXY**2+0.25*(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 CGPB 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 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----------------------------------------------------------- END PROGRAM Laramy2AI