//IRAAGPBM JOB TIME=(0,10) COMPILE MAP-EDITING PROGRAM INTO LOAD MOD. /*SCHEDULE PRIORITY=0.8 //CLEAR EXEC PGM=IEFBR14 FIRST, DELETE ANY OLD LOAD MODULES OF THE //DD1 DD DSN=EFF9GPB.MAPMOD,DISP=(OLD,DELETE) SAME NAME //FORT EXEC PGM=FORTVS,REGION=4000K, RUN FORTRAN COMPILER: // PARM='MAP,NODECK,NOLIST' VS-FORT. 2.4.0+ //STEPLIB DD DISP=(SHR,PASS),DSN=APP1.FORTVS.COMPILER //SYSIN DD * SUBROUTINE MAP C C DUMMY LABEL SO THAT ENTRY CAN BE IN "NORTH" OR "SOUTH" C C PROGRAM MAP C C ( UCLA EDITION OF MAY, 1990) C *** COMPATIBLE WITH MAY, 1990 VERSION OF LARAMY *** C ALLOWS DISPLAY AND INTERACTIVE EDITING OF: C -FILES OF CONSTRUCTION-LINES ("CONSTR01, CONSTR02...") C WHICH CONTAIN PRELIMINARY MAGNETIC ANOMALIES AND FRACTURE ZONE C AND PLATE EDGES; AND C -FORTRAN FILES ("NORTH", "SOUTH") IN BLOCK DATA FORMAT, C WHICH CONTAIN HAND-EDITED MAPS OF RECONSTRUCTED C SEAFLOOR OF THE FARALLON, KULA, AND VANCOUVER PLATES. C C READS CONSTRUCTION-LINES FILES ON UNIT 1 AND WRITES THEM ON 2. C READS FORTRAN (DATA) STATMENTS ON UNIT 3 AND REWRITES ON 4. C USES STRATEGIC AND TACTICAL INPUT PARAMETERS OF LARAMY C FROM DEVICE 7; SHOULD CONFORM TO DATA USED C IN THE INTENDED RUN OF "LARAMY"; ANY PLOT CONTROLS APPENDED C AT THE END OF THE UNIT-7 DATASET ARE NOT USED HERE. C READS FE-GRID FROM DEVICE 8 (NODE LOCATIONS ONLY; OTHER DATA SKIPPED) C READS BASEMAP (STATE OUTLINES) FROM UNIT 11. 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 (213) 825-1126. C C EXTERNAL ROUTINES USED: C -FORTRAN INTRINSIC FUNCTIONS CALLED BY GENERIC NAMES: C ABS,ASIN,ATAN2,COS,EXP,LOG,MAX,MIN,MOD,SIN,SQRT,TAN C -IBM GRAPHICAL DATA DISPLAY MANAGER (GDDM) ROUTINES: C FSINIT,FSEXIT,GSCLP,GSSATI,GSSSEG,GSLSS,GSUWIN, C GSSCLS,GSCOL,GSLW,GSLT,GSLINE,GSMOVE,GSAREA,GSENDA, C GSARC,GSCHAR,GSCHAP,GSCM,GSCS,GSQCB,GSCB,GSCA, C GSPAT,GSSAVE,FSPCLR,FSTERM 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---------------------------------------------------------------- C FOLLOWING LINE SETS MAXIMUM NUMBER OF CONSTRUCTION LINES/POINTS PARAMETER (N1999=2000) 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 CHARACTER*1 TAGFZ,TAGMAG,Z,ZSAVE CHARACTER*2 TAG CHARACTER*5 FIVE,ASCII CHARACTER*8 ASTER,BLANKS CHARACTER*16 ALPHA,BETA CHARACTER*40 TEXT CHARACTER*80 ALINE,TITLE LOGICAL ALDONE,ALLREP,BOXIT,DIMERR,DOFEM,DOREP, + DRAWST,FAILUR,LISTOP,REPLAC,RESTRT, + STATES,TAPE9 LOGICAL ANYDIS,ANYEDS,ATTACH,BACK,BAR,FEGRID,LIST3J, + MENU,NEWTIM,SHOLIN,SHOFZ,SHOAGE,SHOX,VALID EXTERNAL ASCII C C COMMON BLOCKS WHICH CONNECT TO DATA FROM DEVICE 3 C COMMON /SCALAR/ + NKV3J, + NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, + TUMAP COMMON /ARRAYS/ + AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, + FRACZN,NMAG,NPFZ,NPHING, + OMEGAF,OMEGAK,OMEGAP,OMEGAV, + REHING,REKV3J,REMAG,REVF3J, + ROMATF,ROMATK,ROMATP,ROMATV COMMON /TAGS/ + TAGFZ,TAGMAG C C COMMON BLOCK USED ONLY WITHIN THIS PROGRAM, FOR CONVENIENCE C COMMON /PLTPRM/ XCENTR,YCENTR,WIDE C C DIMENSIONS TO MATCH THOSE IN BLOCK DATA PROGRAMS: 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 DIMENSIONS SPECIFIC TO MAP: DIMENSION TFRACZ(2,MAXFZP,MTAPP1), + TREMAG(2,2,MAXMAG,MTAPES) C VARIABLE DIMENSIONS CONTAINING VALUE OF N50: DIMENSION FROMW(7,N50), 5 NODES(6,0:N50),OUTSCA(7,N50),OUTVEC(2,7,N50), 6 OUTV2(2,7,N50),SZZ(7,N50),TOUCH(7,N50), 7 VSLAB(2,7,N50),XIP(7,N50),YIP(7,N50) C VARIABLE DIMENSIONS CONTAINING VALUE OF N121: DIMENSION XNOD(N121),YNOD(N121) C VARIABLE DIMENSION CONTAINING VALUE OF NSTATE: DIMENSION DRAWST(NSTATE), + XST(NSTATE),YST(NSTATE) C VARIABLE DIMENSION CONTAINING VALUE OF N1999: DIMENSION AGELIN(N1999),CXY(2,2,N1999),TAG(N1999),TXY(2,2,N1999) 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 DATA (NODES(J,0),J=1,6)/1,1,1,1,1,1/ DATA RINKM /6371./ DATA BIGNUM/9.99E59/ C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) XPLT(X)=5.5+5.5*(X-XCENTR)/(0.5*WIDE) YPLT(Y)=4.25+5.5*(Y-YCENTR)/(0.5*WIDE) C C INITIALIZE GDDM C WRITE(6,30) 30 FORMAT(/' INITIALIZING GDDM....') CALL FSINIT C C DEFAULT INITIALIZATION SECTION C XCENTR=0.0 YCENTR=0.0 XCURS=XCENTR YCURS=YCENTR WIDE=6.00E8 ATTACH=.FALSE. BAR=.FALSE. FEGRID=.TRUE. MENU=.TRUE. NEWTIM=.TRUE. NWFZ=0 SHOLIN=.TRUE. SHOFZ =.FALSE. SHOAGE=.FALSE. STATES=.TRUE. TIME=0.0 TMY=0.0 TMYNEW=0.0 ANYDIS=.TRUE. ANYEDS=.FALSE. LIST3J=.FALSE. DO 42 I=1,MTAPP1 DO 41 J=1,MAXFZP Z=TAGFZ(J,I) VALID=(Z.EQ.'f').OR.(Z.EQ.'F').OR. + (Z.EQ.'k').OR.(Z.EQ.'K').OR. + (Z.EQ.'p').OR.(Z.EQ.'P').OR. + (Z.EQ.'v').OR.(Z.EQ.'V') IF (.NOT.VALID) TAGFZ(J,I)=' ' 41 CONTINUE 42 CONTINUE DO 44 I=1,MTAPES DO 43 J=1,MAXMAG Z=TAGMAG(J,I) VALID=(Z.EQ.'f').OR.(Z.EQ.'F').OR. + (Z.EQ.'k').OR.(Z.EQ.'K').OR. + (Z.EQ.'p').OR.(Z.EQ.'P').OR. + (Z.EQ.'v').OR.(Z.EQ.'V') IF (.NOT.VALID) TAGMAG(J,I)=' ' 43 CONTINUE 44 CONTINUE C C MODEL PARAMETER INPUT SECTION C WRITE(6,50) 50 FORMAT(/' READING FT07F001=INFILE....') CALL READIN(TITLE ,FRIC ,ACREEP,ECREEP,BCREEP, + CCREEP,DCREEP,CONDUC,DIFFUS, + RADIO ,THICKN,TEMLIM,RHOBAR, + ALPHAT,VPMEAN,DVPDT ,DVPBYE, + RHOAST,RHOH2O,BIOT ,G ,RADIUS, + X0ELON,Y0NLAT,CPNLAT,IBELOW, + 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, + KTIME ,CONRAD,DQDTDA,TSURF , + APLANO,WANDES,VDECOL,OLDGRD, + GWIDE ,GHIGH ,GANGLE) WRITE(6,70) 70 FORMAT(/' CHECKING ADEQUACY OF DIMENSIONED ARRAYS...') CALL SETDIM (N50,N121, + NELROW,NELCOL,NUMNOD, + NUMEL,DIMERR) IF (DIMERR) STOP C C CREATE FINITE ELEMENT GRID BY READING IN NODE LOCATIONS C CALL GRIDDR(INPUT, NELROW,NELCOL,NUMEL, + MODIFY,NODES) WRITE(6,120) 120 FORMAT(/' READING IN FT08F001=FE-GRID...') CALL GOON (INPUT,NUMNOD,OUTPUT,XNOD,YNOD) CALL INTERP (XNOD,NODES,NUMEL,NUMNOD,XIP) CALL INTERP (YNOD,NODES,NUMEL,NUMNOD,YIP) CALL INLAND (INPUT,NUMEL,NUMNOD, + NELROW,XIP,XNOD,YIP,YNOD, + OUTPUT,FROMW) C C READ IN PRESENT-DAY BASEMAP OF NORTH AMERICA C RTAN=RADIUS*TANDEG(90.-CPNLAT) XPOLE=0. YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) WRITE(6,180) 180 FORMAT(/' READING IN FT11F001=STATE OUTLINES...') ONEKM=RADIUS/RINKM NXYST=0 DO 200 I=1,NSTATE READ(11,*,END=201) PLAT, PLON, DRAWST(I) CALL LLTOXY (INPUT,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X,Y) XST(I)=X YST(I)=Y NXYST=NXYST+1 200 CONTINUE 201 NXYST=NXYST-MOD(NXYST,7) DRAWST(1)=.FALSE. C C READ IN CONSTRUCTION-LINES FILE AND CONVERT TO (X,Y) C WRITE(6,205) 205 FORMAT(/' READING FT01F001 FOR CONSTRUCTION LINES...') NCONST=0 DO 250 I=1,N1999 READ(1,210,END=255)TAG(I),AGELIN(I), + ((CXY(L,K,I),L=1,2),K=1,2) 210 FORMAT(A2,F10.2,4F10.2) NCONST=NCONST+1 DO 220 K=1,2 PLON=CXY(1,K,I) PLAT=CXY(2,K,I) CALL LLTOXY (INPUT,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X,Y) CXY(1,K,I)=X CXY(2,K,I)=Y TXY(1,K,I)=X TXY(2,K,I)=Y 220 CONTINUE 250 CONTINUE WRITE(6,251)N1999 251 FORMAT(/' INTERNAL LIMIT OF N1999=',I10,' WAS REACHED.') STOP 255 CONTINUE C C CALL BELOWQ, TO CALL BELOWY, TO PERFORM 1ST-CALL SETUP WORK C CALL BELOWQ(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C C**** BEGINNING OF ENDLESS LOOP ON IMAGES (UNTIL 'Q'=EXIT) ********* 300 CONTINUE C******************************************************************** C C COMPUTE POSITIONS OF CONSTRUCTION LINES AND MAP ELEMENTS C IF (NEWTIM) THEN TMY=TMYNEW TIME=TMY*TUMAP NEWTIM=.FALSE. CALL HOWROT (INPUT,AGEROT,NROMAT,TMY, + OUTPUT,IROT1,IROT2,TFRAC) DO 350 I=1,NCONST IF (TAG(I)(1:1).EQ.'l'.OR.TAG(I)(1:1).EQ.'L') THEN DO 310 K=1,2 BACK=.TRUE. CALL MOVEIT(INPUT,CPNLAT,BACK,X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(I), + RTAN,XPOLE,YPOLE, + CXY(1,K,I),CXY(2,K,I), + OUTPUT,TXY(1,K,I),TXY(2,K,I)) 310 CONTINUE ELSE IF (TAG(I)(1:1).EQ.'p'.OR.TAG(I)(1:1).EQ.'P') THEN BACK=.TRUE. CALL MOVEIT(INPUT,CPNLAT,BACK,X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(I), + RTAN,XPOLE,YPOLE, + CXY(1,1,I),CXY(2,1,I), + OUTPUT,TXY(1,1,I),TXY(2,1,I)) ENDIF 350 CONTINUE DO 380 I=1,NTAPES DO 370 J=1,NMAG(I) DO 360 L=1,2 BACK=.TRUE. CALL MOVEIT(INPUT,CPNLAT,BACK,X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + 'L'//TAGMAG(J,I), + RTAN,XPOLE,YPOLE, + REMAG(1,L,J,I), + REMAG(2,L,J,I), + OUTPUT,TREMAG(1,L,J,I), + TREMAG(2,L,J,I)) 360 CONTINUE 370 CONTINUE 380 CONTINUE DO 400 I=1,NTAPP1 DO 390 J=1,NPFZ(I) BACK=.TRUE. CALL MOVEIT(INPUT,CPNLAT,BACK,X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + 'L'//TAGFZ(J,I), + RTAN,XPOLE,YPOLE, + FRACZN(1,J,I), + FRACZN(2,J,I), + OUTPUT,TFRACZ(1,J,I), + TFRACZ(2,J,I)) 390 CONTINUE 400 CONTINUE ENDIF C C BEGIN A NEW PAGE C CALL FSPCLR C C ESTABLISH COORDINATE SYSTEM FOR ENTIRE PROGRAM C CALL GSUWIN(0.0,11.0,0.0,8.5) C IF (MENU) THEN C C SHOW MENU (ONLY) IN SEGMENTS 1,2 C CALL CHOICE ELSE C C DRAW THE DISPLAY: C GRAPHICS SEGMENT 1 = CONSTRUCTION LINES (AND RAW DATA) C 2,3,4,5...= COLORED AGE MAP (1 SEG. PER PLATE) C 6,7,8 = FINITE ELEMENT GRID & VSLAB VECTORS C 9 = STATE LINES C 10 = CURSOR C 11 = AGESCALE (COLOR BAR) C 12 = LISTS OF TRIPLE-JUNCTION AGES C 13 = V SHOWING CUT IN CONIC-PROJECTION IF (SHOLIN) THEN CALL GSSEG(1) CALL PLTCON (INPUT,AGELIN,NCONST,TAG,TMY,TXY) CALL GSSCLS ENDIF IF (SHOFZ.OR.SHOAGE) THEN ISEG1=2 CALL PLTMAP (INPUT,AGEFZ,AGEMAG,IMSHOW,ISEG1,MAXFZP, + MAXMAG,NMAG,NPFZ,NTAPES,NTAPP1, + NWFZ,SHOAGE,SHOFZ, + TAGFZ,TAGMAG,TFRACZ,TMY,TREMAG) ENDIF IF (FEGRID) THEN CALL GSSEG(6) CALL ETCH (INPUT,NODES,NUMEL,NUMNOD, + XNOD,YNOD) CALL GSSCLS CALL BELOWQ(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB, + WORK,OUTVEC,OUTV2) CALL GSSEG(7) CALL CONTAC(INPUT,NUMEL,TOUCH,XIP,YIP) CALL GSSCLS CALL GSSEG(8) DELTAT=5.0E6*3.1517E7 CALL ARROW (INPUT,DELTAT,NELCOL, + NUMEL,TOUCH,VSLAB,XIP,YIP) CALL DIVIDE (INPUT,REHING,REKV3J,REVF3J,AGEHNG, + AGEKV,AGEVF, + MAXHNG,NKV3J,NPHING,NUMHNG, + NVF3J,TMY, + OUTPUT,XKV,XVF,YKV,YVF) CALL GSSCLS ENDIF IF (STATES) THEN CALL GSSEG(9) CALL USMAP (INPUT,DRAWST,NXYST,XST,YST) CALL GSSCLS ENDIF CALL GSSEG(10) SHOX=.TRUE. CALL CURSOR(INPUT,AGEFZ,AGELIN,AGEMAG,ATTACH,FEGRID, + IMSHOW,MAXFZP,MAXMAG,NCONST,NMAG,NPFZ, + NTAPES,NTAPP1,NWFZ, + SHOAGE,SHOFZ,SHOLIN,SHOX, + TAG,TFRACZ,TMY,TXY,TREMAG, + XCURS,YCURS, + XKV,XVF,YKV,YVF, + OUTPUT,IROW,JCOL,KPICK,LINTYP) CALL GSSCLS IF (BAR) THEN CALL GSSEG(11) CALL AGEBAR (INPUT,AGEMAG,MAXMAG,NMAG,NTAPES) CALL GSSCLS ENDIF LIST3J=LIST3J.AND.ANYEDS IF (LIST3J) THEN CALL GSSEG(12) CALL LISTMY (INPUT,AGEKV,AGEVF,NKV3J,NVF3J, + MKV3J,MVF3J) CALL GSSCLS ENDIF C C PLOT V OF CONIC-PROJECTION CUT IN WHITE C IF (ABS(CPNLAT).GT.10.) THEN CALL GSSEG(13) CALL GSCOL(-2) CALL GSLW(2) XP=XPLT(XPOLE) YP=YPLT(YPOLE) CALL GSMOVE(XP,YP) R=ABS(4.25-YP)+5. IF (CPNLAT.GT.0.) THEN ANGLE=180.*(1.-SINDEG(CPNLAT)) ELSE ANGLE=180.*(1.-SINDEG(-CPNLAT))-180. ENDIF X1=XP+R*SINDEG(ANGLE) Y1=YP+R*COSDEG(ANGLE) CALL GSLINE(X1,Y1) CALL GSMOVE(XP,YP) X2=XP-R*SINDEG(ANGLE) Y2=YP+R*COSDEG(ANGLE) CALL GSLINE(X2,Y2) CALL GSSCLS ENDIF C ENDIF C C DEFINE DISPLAY-CONTROL-CHARACTER AREA AT LOWER RIGHT C WITH EDIT-CONTROL-CHARACTER AREA BELOW IT. C CALL ASDFLD(1,31,55,1,9,2) CALL ASCPUT(1,9,'DISPLAY: ') CALL ASDFLD(2,31,64,1,17,0) CALL ASCPUT(2,0,' ') CALL ASDFLD(3,32,55,1,9,2) CALL ASCPUT(3,9,' EDIT: ') CALL ASDFLD(4,32,64,1,17,0) CALL ASCPUT(4,0,' ') IF (.NOT.MENU) THEN CALL ASDFLD(5,1,1,1,53,2) CALL EPOCH (INPUT,TMY,OUTPUT,NCHAR,TEXT) FIVE=ASCII(TMY) CALL ASCPUT(5,NCHAR+12,' '//FIVE//' M.Y. '//TEXT) ENDIF CALL ASFCUR(2,1,1) IF (ANYEDS) CALL ASFCUR(4,1,1) CALL ASREAD(ITYPE,IVALUE,ICOUNT) C ----------------------------------------------------------- C THIS IS WHERE THE DISPLAY IS INSPECTED AND CHANGES CAN BE C ORDERED IN THE DISPLAY FIELD (WHICH HAS PRIORITY), OR C IN THE EDIT FIELD (IF THE DISPLAY FIELD IS LEFT BLANK). C ----------------------------------------------------------- C C DISPLAY-COMMAND INTERPRETER SECTION C ANYDIS=.FALSE. CALL ASCGET(2,16,ALPHA) IPOINT=1 1000 Z=ALPHA(IPOINT:IPOINT) IPOINT=IPOINT+1 IF (Z.EQ.'m'.OR.Z.EQ.'M') THEN MENU=.NOT.MENU ANYDIS=.TRUE. ELSE IF (Z.EQ.'d'.OR.Z.EQ.'D') THEN SHOLIN=.NOT.SHOLIN ANYDIS=.TRUE. ELSE IF (Z.EQ.'f'.OR.Z.EQ.'F') THEN SHOFZ=.NOT.SHOFZ ANYDIS=.TRUE. ELSE IF (Z.EQ.'a'.OR.Z.EQ.'A') THEN ANYDIS=.TRUE. SHOAGE=.NOT.SHOAGE IF (IPOINT.LE.15) THEN CALL NUMBER (INDATA,15,ALPHA, + MODIFY,IPOINT, + OUTPUT,F) IMSHOW=F+0.5 ELSE IMSHOW=0 ENDIF ELSE IF (Z.EQ.'l'.OR.Z.EQ.'L') THEN STATES=.NOT.STATES ANYDIS=.TRUE. ELSE IF (Z.EQ.'g'.OR.Z.EQ.'G') THEN FEGRID=.NOT.FEGRID ANYDIS=.TRUE. ELSE IF (Z.EQ.'b'.OR.Z.EQ.'B') THEN BAR=.NOT.BAR ANYDIS=.TRUE. ELSE IF (Z.EQ.'t'.OR.Z.EQ.'T') THEN IF (IPOINT.LE.15) THEN NEWTIM=.TRUE. CALL NUMBER (INDATA,15,ALPHA, + MODIFY,IPOINT, + OUTPUT,TMYNEW) ENDIF ANYDIS=.TRUE. ELSE IF (Z.EQ.'x'.OR.Z.EQ.'X') THEN WIDE=WIDE*0.8 ANYDIS=.TRUE. ELSE IF (Z.EQ.'c'.OR.Z.EQ.'C') THEN WIDE=WIDE/0.8 ANYDIS=.TRUE. ELSE IF (Z.EQ.'n'.OR.Z.EQ.'N') THEN YCENTR=YCENTR+WIDE/11. ANYDIS=.TRUE. ELSE IF (Z.EQ.'s'.OR.Z.EQ.'S') THEN YCENTR=YCENTR-WIDE/11. ANYDIS=.TRUE. ELSE IF (Z.EQ.'e'.OR.Z.EQ.'E') THEN XCENTR=XCENTR+WIDE/11. ANYDIS=.TRUE. ELSE IF (Z.EQ.'w'.OR.Z.EQ.'W') THEN XCENTR=XCENTR-WIDE/11. ANYDIS=.TRUE. ELSE IF (Z.EQ.'q'.OR.Z.EQ.'Q') THEN ANYDIS=.TRUE. GO TO 9999 ELSE GO TO 1500 ENDIF IF (IPOINT.LE.15) GO TO 1000 C C EDIT-COMMAND INTERPRETER SECTION C 1500 ANYEDS=.FALSE. CALL ASCGET(4,16,BETA) IPOINT=1 2000 Z=BETA(IPOINT:IPOINT) IPOINT=IPOINT+1 IF (Z.EQ.'c'.OR.Z.EQ.'C') THEN ANYEDS=.TRUE. IF (IPOINT.LE.15) THEN CALL NUMBER (INDATA,15,BETA, + MODIFY,IPOINT, + OUTPUT,T) ANGLE=3.14159*(3.-T)/6. IPOINT=IPOINT+1 IF (IPOINT.LE.14) THEN CALL NUMBER (INDATA,15,BETA, + MODIFY,IPOINT, + OUTPUT,R) DX=R*(WIDE/11.)*COS(ANGLE) DY=R*(WIDE/11.)*SIN(ANGLE) IF ((T.EQ.0.).AND.(R.EQ.0.)) THEN XCURS=XCENTR YCURS=YCENTR ENDIF XCURS=XCURS+DX YCURS=YCURS+DY IF (ATTACH) THEN IF (LINTYP.EQ.1) THEN IF (KPICK.EQ.1) THEN TXY(1,1,IROW)=XCURS TXY(2,1,IROW)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(IROW), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,CXY(1,1,IROW), + CXY(2,1,IROW)) ELSE IF (KPICK.EQ.3) THEN TXY(1,2,IROW)=XCURS TXY(2,2,IROW)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(IROW), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,CXY(1,2,IROW), + CXY(2,2,IROW)) ENDIF ELSE IF (LINTYP.EQ.2) THEN TFRACZ(1,JCOL,IROW)=XCURS TFRACZ(2,JCOL,IROW)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + 'P'//TAGFZ(JCOL,IROW), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,FRACZN(1,JCOL,IROW), + FRACZN(2,JCOL,IROW)) ELSE IF (LINTYP.EQ.3) THEN IF (KPICK.EQ.1) THEN TREMAG(1,1,JCOL,IROW)=XCURS TREMAG(2,1,JCOL,IROW)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + 'L'//TAGMAG(JCOL,IROW), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,REMAG(1,1,JCOL,IROW), + REMAG(2,1,JCOL,IROW)) ELSE IF (KPICK.EQ.3) THEN TREMAG(1,2,JCOL,IROW)=XCURS TREMAG(2,2,JCOL,IROW)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + 'L'//TAGMAG(JCOL,IROW), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,REMAG(1,2,JCOL,IROW), + REMAG(2,2,JCOL,IROW)) ENDIF ELSE IF (LINTYP.EQ.4) THEN LIST3J=.TRUE. CLOSE=BIGNUM IF (KPICK.EQ.1) THEN J=NKV3J DO 2100 I=1,NKV3J DT=ABS(TMY-AGEKV(I)) IF (DT.LT.CLOSE) THEN J=I CLOSE=DT ENDIF 2100 CONTINUE REKV3J(1,J)=XCURS REKV3J(2,J)=YCURS AGEKV(J)=TMY ELSE IF (KPICK.EQ.2) THEN J=NVF3J DO 2110 I=1,NVF3J DT=ABS(TMY-AGEVF(I)) IF (DT.LT.CLOSE) THEN J=I CLOSE=DT ENDIF 2110 CONTINUE REVF3J(1,J)=XCURS REVF3J(2,J)=YCURS AGEVF(J)=TMY ENDIF ENDIF ELSE SHOX=.FALSE. CALL CURSOR(INPUT, + AGEFZ,AGELIN,AGEMAG,ATTACH,FEGRID, + IMSHOW,MAXFZP,MAXMAG,NCONST,NMAG,NPFZ, + NTAPES,NTAPP1,NWFZ, + SHOAGE,SHOFZ,SHOLIN,SHOX, + TAG,TFRACZ,TMY,TXY,TREMAG, + XCURS,YCURS, + XKV,XVF,YKV,YVF, + OUTPUT,IROW,JCOL,KPICK,LINTYP) ENDIF ENDIF ENDIF ELSE IF (Z.EQ.'x'.OR.Z.EQ.'X') THEN ANYEDS=.TRUE. IF (LINTYP.EQ.1) THEN NCONST=NCONST-1 DO 2200 I=IROW,NCONST TAG(I)=TAG(I+1) AGELIN(I)=AGELIN(I+1) CXY(1,1,I)=CXY(1,1,I+1) CXY(2,1,I)=CXY(2,1,I+1) CXY(1,2,I)=CXY(1,2,I+1) CXY(2,2,I)=CXY(2,2,I+1) TXY(1,1,I)=TXY(1,1,I+1) TXY(2,1,I)=TXY(2,1,I+1) TXY(1,2,I)=TXY(1,2,I+1) TXY(2,2,I)=TXY(2,2,I+1) 2200 CONTINUE ELSE IF (LINTYP.EQ.2) THEN NPFZ(IROW)=NPFZ(IROW)-1 DO 2300 J=JCOL,NPFZ(IROW) TAGFZ(J,IROW)=TAGFZ(J+1,IROW) AGEFZ(J,IROW)=AGEFZ(J,IROW) FRACZN(1,J,IROW)=FRACZN(1,J+1,IROW) FRACZN(2,J,IROW)=FRACZN(2,J+1,IROW) TFRACZ(1,J,IROW)=TFRACZ(1,J+1,IROW) TFRACZ(2,J,IROW)=TFRACZ(2,J+1,IROW) 2300 CONTINUE ELSE IF (LINTYP.EQ.3) THEN NMAG(IROW)=NMAG(IROW)-1 DO 2400 J=JCOL,NMAG(IROW) AGEMAG(J,IROW)=AGEMAG(J+1,IROW) TAGMAG(J,IROW)=TAGMAG(J+1,IROW) REMAG(1,1,J,IROW)=REMAG(1,1,J+1,IROW) REMAG(1,2,J,IROW)=REMAG(1,2,J+1,IROW) REMAG(2,1,J,IROW)=REMAG(2,1,J+1,IROW) REMAG(2,2,J,IROW)=REMAG(2,2,J+1,IROW) TREMAG(1,1,J,IROW)=TREMAG(1,1,J+1,IROW) TREMAG(1,2,J,IROW)=TREMAG(1,2,J+1,IROW) TREMAG(2,1,J,IROW)=TREMAG(2,1,J+1,IROW) TREMAG(2,2,J,IROW)=TREMAG(2,2,J+1,IROW) 2400 CONTINUE ELSE IF (LINTYP.EQ.4) THEN LIST3J=.TRUE. CLOSE=BIGNUM IF (KPICK.EQ.1) THEN J=NKV3J DO 2500 I=1,NKV3J DT=ABS(TMY-AGEKV(I)) IF (DT.LT.CLOSE) THEN J=I CLOSE=DT ENDIF 2500 CONTINUE NKV3J=NKV3J-1 DO 2510 I=J,NKV3J AGEKV(I)=AGEKV(I+1) REKV3J(1,I)=REKV3J(1,I+1) REKV3J(2,I)=REKV3J(2,I+1) REKV3J(3,I)=REKV3J(3,I+1) 2510 CONTINUE ELSE IF (KPICK.EQ.2) THEN J=NVF3J DO 2520 I=1,NVF3J DT=ABS(TMY-AGEVF(I)) IF (DT.LT.CLOSE) THEN J=I CLOSE=DT ENDIF 2520 CONTINUE NVF3J=NVF3J-1 DO 2530 I=J,NVF3J AGEVF(I)=AGEVF(I+1) REVF3J(1,I)=REVF3J(1,I+1) REVF3J(2,I)=REVF3J(2,I+1) REVF3J(3,I)=REVF3J(3,I+1) 2530 CONTINUE ENDIF ENDIF SHOX=.FALSE. CALL CURSOR(INPUT, + AGEFZ,AGELIN,AGEMAG,ATTACH,FEGRID, + IMSHOW,MAXFZP,MAXMAG,NCONST,NMAG,NPFZ, + NTAPES,NTAPP1,NWFZ, + SHOAGE,SHOFZ,SHOLIN,SHOX, + TAG,TFRACZ,TMY,TXY,TREMAG, + XCURS,YCURS, + XKV,XVF,YKV,YVF, + OUTPUT,IROW,JCOL,KPICK,LINTYP) ELSE IF (Z.EQ.'p'.OR.Z.EQ.'P') THEN ANYEDS=.TRUE. IF (SHOFZ) THEN IPOINT=IPOINT+1 IF (NWFZ.GT.0) THEN IF (ATTACH) THEN ATTACH=.FALSE. ELSE NPFZ(NWFZ)=MIN(NPFZ(NWFZ)+1,MAXFZP) IF (TFRACZ(1,JCOL,NWFZ).LT. + XCURS) THEN JNEW=JCOL+1 ELSE JNEW=JCOL ENDIF DO 2700 J=NPFZ(NWFZ),JNEW+1,-1 AGEFZ(J,NWFZ)=AGEFZ(J-1,NWFZ) TAGFZ(J,NWFZ)=TAGFZ(J-1,NWFZ) TFRACZ(1,J,NWFZ)=TFRACZ(1,J-1,NWFZ) TFRACZ(2,J,NWFZ)=TFRACZ(2,J-1,NWFZ) FRACZN(1,J,NWFZ)=FRACZN(1,J-1,NWFZ) FRACZN(2,J,NWFZ)=FRACZN(2,J-1,NWFZ) 2700 CONTINUE TFRACZ(1,JNEW,NWFZ)=XCURS TFRACZ(2,JNEW,NWFZ)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + 'P'//TAGFZ(JCOL,IROW), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,FRACZN(1,JNEW,NWFZ), + FRACZN(2,JNEW,NWFZ)) JCOL=JNEW ENDIF ENDIF ELSE IF (SHOLIN) THEN IF (IPOINT.LE.15) THEN Z=BETA(IPOINT:IPOINT) IPOINT=IPOINT+1 NCONST=MIN(NCONST+1,N1999) TAG(NCONST)='P'//Z AGELIN(NCONST)=TMY TXY(1,1,NCONST)=XCURS TXY(2,1,NCONST)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK,X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(NCONST), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,CXY(1,1,NCONST), + CXY(2,1,NCONST)) CXY(1,2,NCONST)=0. CXY(2,2,NCONST)=0. IROW=NCONST ENDIF ENDIF ELSE IF (Z.EQ.'a'.OR.Z.EQ.'A') THEN ANYEDS=.TRUE. ATTACH=.TRUE. IF (LINTYP.EQ.1) THEN IF (KPICK.EQ.1) THEN TXY(1,1,IROW)=XCURS TXY(2,1,IROW)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(IROW), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,CXY(1,1,IROW), + CXY(2,1,IROW)) ELSE IF (KPICK.EQ.3) THEN TXY(1,2,IROW)=XCURS TXY(2,2,IROW)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(IROW), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,CXY(1,2,IROW), + CXY(2,2,IROW)) ENDIF ELSE IF (LINTYP.EQ.2) THEN TFRACZ(1,JCOL,IROW)=XCURS TFRACZ(2,JCOL,IROW)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + 'P'//TAGFZ(JCOL,IROW), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,FRACZN(1,JCOL,IROW), + FRACZN(2,JCOL,IROW)) ELSE IF (LINTYP.EQ.3) THEN IF (KPICK.EQ.1) THEN TREMAG(1,1,JCOL,IROW)=XCURS TREMAG(2,1,JCOL,IROW)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + 'L'//TAGMAG(JCOL,IROW), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,REMAG(1,1,JCOL,IROW), + REMAG(2,1,JCOL,IROW)) ELSE IF (KPICK.EQ.3) THEN TREMAG(1,2,JCOL,IROW)=XCURS TREMAG(2,2,JCOL,IROW)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + 'L'//TAGMAG(JCOL,IROW), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,REMAG(1,2,JCOL,IROW), + REMAG(2,2,JCOL,IROW)) ENDIF ELSE IF (LINTYP.EQ.4) THEN LIST3J=.TRUE. CLOSE=BIGNUM IF (KPICK.EQ.1) THEN J=NKV3J DO 2800 I=1,NKV3J DT=ABS(TMY-AGEKV(I)) IF (DT.LT.CLOSE) THEN J=I CLOSE=DT ENDIF 2800 CONTINUE REKV3J(1,J)=XCURS REKV3J(2,J)=YCURS AGEKV(J)=TMY ELSE IF (KPICK.EQ.2) THEN J=NVF3J DO 2900 I=1,NVF3J DT=ABS(TMY-AGEVF(I)) IF (DT.LT.CLOSE) THEN J=I CLOSE=DT ENDIF 2900 CONTINUE REVF3J(1,J)=XCURS REVF3J(2,J)=YCURS AGEVF(J)=TMY ENDIF ENDIF ELSE IF (Z.EQ.'d'.OR.Z.EQ.'D') THEN ANYEDS=.TRUE. ATTACH=.FALSE. ELSE IF (Z.EQ.'q'.OR.Z.EQ.'Q') THEN ANYEDS=.TRUE. ATTACH=.FALSE. NWFZ=0 SHOX=.FALSE. CALL CURSOR(INPUT, + AGEFZ,AGELIN,AGEMAG,ATTACH,FEGRID, + IMSHOW,MAXFZP,MAXMAG,NCONST,NMAG,NPFZ, + NTAPES,NTAPP1,NWFZ, + SHOAGE,SHOFZ,SHOLIN,SHOX, + TAG,TFRACZ,TMY,TXY,TREMAG, + XCURS,YCURS, + XKV,XVF,YKV,YVF, + OUTPUT,IROW,JCOL,KPICK,LINTYP) ELSE IF (Z.EQ.'l'.OR.Z.EQ.'L') THEN ANYEDS=.TRUE. IF (SHOLIN) THEN IF (IPOINT.LE.15) THEN Z=BETA(IPOINT:IPOINT) IPOINT=IPOINT+1 NCONST=MIN(NCONST+1,N1999) TAG(NCONST)='L'//Z AGELIN(NCONST)=TMY TXY(1,1,NCONST)=XCURS TXY(2,1,NCONST)=YCURS TXY(1,2,NCONST)=XCURS TXY(2,2,NCONST)=YCURS BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK,X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(NCONST), + RTAN,XPOLE,YPOLE, + XCURS,YCURS, + OUTPUT,CXY(1,1,NCONST), + CXY(2,1,NCONST)) CXY(1,2,NCONST)=CXY(1,1,NCONST) CXY(2,2,NCONST)=CXY(2,1,NCONST) IROW=NCONST LINTYP=1 KPICK=3 ATTACH=.TRUE. ENDIF ENDIF ELSE IF (Z.EQ.'n'.OR.Z.EQ.'N') THEN ANYEDS=.TRUE. IF (LINTYP.EQ.1) THEN IF (IPOINT.LE.15) THEN Z=BETA(IPOINT:IPOINT) IPOINT=IPOINT+1 TAG(IROW)(2:2)=Z IF (IPOINT.LE.15) THEN CALL NUMBER (INDATA,15,BETA, + MODIFY,IPOINT, + OUTPUT,T) AGELIN(IROW)=T ENDIF ENDIF ELSE IF (LINTYP.EQ.2) THEN IF (IPOINT.LE.15) THEN Z=BETA(IPOINT:IPOINT) IPOINT=IPOINT+1 TAGFZ(JCOL,IROW)='P'//Z IF (IPOINT.LE.15) THEN CALL NUMBER (INDATA,15,BETA, + MODIFY,IPOINT, + OUTPUT,T) AGEFZ(JCOL,IROW)=T ENDIF ENDIF ELSE IF (LINTYP.EQ.3) THEN IF (IPOINT.LE.15) THEN Z=BETA(IPOINT:IPOINT) IPOINT=IPOINT+1 TAGMAG(JCOL,IROW)='L'//Z IF (IPOINT.LE.15) THEN CALL NUMBER (INDATA,15,BETA, + MODIFY,IPOINT, + OUTPUT,T) AGEMAG(JCOL,IROW)=T ENDIF ENDIF ELSE IF (LINTYP.EQ.3) THEN IF (IPOINT.LE.15) THEN CALL NUMBER (INDATA,15,BETA, + MODIFY,IPOINT, + OUTPUT,T) CLOSE=BIGNUM IF (KPICK.EQ.1) THEN J=NKV3J DO 3100 I=1,NKV3J DT=ABS(TMY-AGEKV(I)) IF (DT.LT.CLOSE) THEN J=I CLOSE=DT ENDIF 3100 CONTINUE AGEKV(J)=T ELSE IF (KPICK.EQ.2) THEN J=NVF3J DO 3200 I=1,NVF3J DT=ABS(TMY-AGEVF(I)) IF (DT.LT.CLOSE) THEN J=I CLOSE=DT ENDIF 3200 CONTINUE AGEVF(J)=T ENDIF ENDIF ENDIF ELSE IF (Z.EQ.'t'.OR.Z.EQ.'T') THEN ANYEDS=.TRUE. IF (IPOINT.LE.15) THEN Z=BETA(IPOINT:IPOINT) IPOINT=IPOINT+1 IF (LINTYP.EQ.1) THEN NCONST=MIN(N1999,NCONST+1) AGELIN(NCONST)=AGELIN(IROW) TAG(NCONST)=TAG(IROW)(1:1)//Z BACK=.TRUE. CALL HOWROT (INPUT,AGEROT,NROMAT,AGELIN(IROW), + OUTPUT,KROT1,KROT2,UFRAC) CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + UFRAC,KROT1,KROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(IROW), + RTAN,XPOLE,YPOLE, + CXY(1,1,IROW),CXY(2,1,IROW), + OUTPUT,X0,Y0) BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + UFRAC,KROT1,KROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(NCONST), + RTAN,XPOLE,YPOLE, + X0,Y0, + OUTPUT,CXY(1,1,NCONST), + CXY(2,1,NCONST)) BACK=.TRUE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(NCONST), + RTAN,XPOLE,YPOLE, + CXY(1,1,NCONST), + CXY(2,1,NCONST), + OUTPUT,TXY(1,1,NCONST), + TXY(2,1,NCONST)) IF (TAG(IROW)(1:1).EQ.'l'.OR.TAG(IROW)(1:1) + .EQ.'L') THEN BACK=.TRUE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + UFRAC,KROT1,KROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(IROW), + RTAN,XPOLE,YPOLE, + CXY(1,2,IROW),CXY(2,2,IROW), + OUTPUT,X0,Y0) BACK=.FALSE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + UFRAC,KROT1,KROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(NCONST), + RTAN,XPOLE,YPOLE, + X0,Y0, + OUTPUT,CXY(1,2,NCONST), + CXY(2,2,NCONST)) BACK=.TRUE. CALL MOVEIT(INPUT,CPNLAT,BACK, + X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG(NCONST), + RTAN,XPOLE,YPOLE, + CXY(1,2,NCONST), + CXY(2,2,NCONST), + OUTPUT,TXY(1,2,NCONST), + TXY(2,2,NCONST)) ENDIF ELSE CALL FSALRM ENDIF ENDIF ELSE IF (Z.EQ.'f'.OR.Z.EQ.'F') THEN ANYEDS=.TRUE. IF (IPOINT.LE.15) THEN ZSAVE=BETA(IPOINT:IPOINT) IPOINT=IPOINT+1 IF (IPOINT.LE.15) THEN CALL NUMBER (INDATA,15,BETA, + MODIFY,IPOINT, + OUTPUT,F) IF (F.EQ.0.) GO TO 8888 F=MIN(F,(NTAPP1+1.0)) F=MAX(F,0.5) NF=F+0.5 RNF=1.*NF REPLAC=(ABS(F-RNF).LT.0.01).AND. + ((F-NTAPP1).LT.0.01) IF (REPLAC) THEN INEW=NF ELSE NTAPP1=NTAPP1+1 NTAPES=NTAPP1-1 INEW=F+0.9 DO 3250 I=INEW,NTAPES NMAG(I)=1 TAGMAG(1,I)=' ' AGEMAG(1,I)= -0.1 REMAG(1,1,1,I)=-10000.*ONEKM REMAG(1,2,1,I)=REMAG(1,1,1,I) REMAG(2,1,1,I)=+10000.*ONEKM REMAG(2,2,1,I)=-10000.*ONEKM TREMAG(1,1,1,I)=-10000.*ONEKM TREMAG(1,2,1,I)=TREMAG(1,1,1,I) TREMAG(2,1,1,I)=+10000.*ONEKM TREMAG(2,2,1,I)=-10000.*ONEKM 3250 CONTINUE ENDIF IF ((.NOT.REPLAC).AND. + (INEW.LT.NTAPP1)) THEN DO 3300 I=NTAPP1,INEW+1,-1 NPFZ(I)=NPFZ(I-1) DO 3290 J=1,NPFZ(I-1) AGEFZ(J,I)=AGEFZ(J,I-1) TAGFZ(J,I)=TAGFZ(J,I-1) FRACZN(1,J,I)=FRACZN(1,J,I-1) FRACZN(2,J,I)=FRACZN(2,J,I-1) TFRACZ(1,J,I)=TFRACZ(1,J,I-1) TFRACZ(2,J,I)=TFRACZ(2,J,I-1) 3290 CONTINUE 3300 CONTINUE ENDIF IF ((.NOT.REPLAC).AND.(INEW.GT.1)) THEN NPFZ(INEW)=NPFZ(INEW-1) DO 3400 J=1,NPFZ(INEW-1) AGEFZ(J,INEW)=AGEFZ(J,INEW-1) FRACZN(1,J,INEW)=FRACZN(1,J,INEW-1) FRACZN(2,J,INEW)=FRACZN(2,J,INEW-1) TFRACZ(1,J,INEW)=TFRACZ(1,J,INEW-1) TFRACZ(2,J,INEW)=TFRACZ(2,J,INEW-1) 3400 CONTINUE ENDIF IF (.NOT.REPLAC) THEN DO 3410 J=1,MAXFZP TAGFZ(J,INEW)=ZSAVE 3410 CONTINUE ENDIF NWFZ=INEW SHOLIN=.TRUE. SHOFZ=.TRUE. SHOAGE=.FALSE. SHOX=.FALSE. CALL CURSOR(INPUT, + AGEFZ,AGELIN,AGEMAG,ATTACH,FEGRID, + IMSHOW,MAXFZP,MAXMAG,NCONST,NMAG,NPFZ, + NTAPES,NTAPP1,NWFZ, + SHOAGE,SHOFZ,SHOLIN,SHOX, + TAG,TFRACZ,TMY,TXY,TREMAG, + XCURS,YCURS, + XKV,XVF,YKV,YVF, + OUTPUT,IROW,JCOL,KPICK,LINTYP) ENDIF ENDIF ELSE IF (Z.EQ.'r'.OR.Z.EQ.'R') THEN ANYEDS=.TRUE. IF (IPOINT.LE.15) THEN CALL NUMBER (INDATA,15,BETA, + MODIFY,IPOINT, + OUTPUT,F) IGO=F+0.5 IF ((IGO.GE.1).AND.(IGO.LE.NTAPP1)) THEN NTAPP1=MAX(0,NTAPP1-1) NTAPES=MIN(NTAPES,NTAPP1-1) NTAPES=MAX(NTAPES,0) DO 3500 I=IGO,NTAPP1 NPFZ(I)=NPFZ(I+1) DO 3490 J=1,NPFZ(I) AGEFZ(J,I)=AGEFZ(J,I+1) TAGFZ(J,I)=TAGFZ(J,I+1) FRACZN(1,J,I)=FRACZN(1,J,I+1) FRACZN(2,J,I)=FRACZN(2,J,I+1) TFRACZ(1,J,I)=TFRACZ(1,J,I+1) TFRACZ(2,J,I)=TFRACZ(2,J,I+1) 3490 CONTINUE 3500 CONTINUE SHOX=.FALSE. CALL CURSOR(INPUT, + AGEFZ,AGELIN,AGEMAG,ATTACH,FEGRID, + IMSHOW,MAXFZP,MAXMAG,NCONST,NMAG,NPFZ, + NTAPES,NTAPP1,NWFZ, + SHOAGE,SHOFZ,SHOLIN,SHOX, + TAG,TFRACZ,TMY,TXY,TREMAG, + XCURS,YCURS, + XKV,XVF,YKV,YVF, + OUTPUT,IROW,JCOL,KPICK,LINTYP) ENDIF ENDIF ELSE IF (Z.EQ.'s'.OR.Z.EQ.'S') THEN ANYEDS=.TRUE. IF (IPOINT.LE.15) THEN CALL NUMBER (INDATA,15,BETA, + MODIFY,IPOINT, + OUTPUT,F) IMS=F+0.1 IF (LINTYP.EQ.1) THEN XC=0.5*(CXY(1,1,IROW)+CXY(1,2,IROW)) JMS=1 DO 3600 J=1,NMAG(IMS) XT=0.5*(REMAG(1,1,J,IMS)+ + REMAG(1,2,J,IMS)) IF (XC.GT.XT) JMS=J+1 3600 CONTINUE IF (JMS.GT.NMAG(IMS)) THEN NMAG(IMS)=NMAG(IMS)+1 ELSE NMAG(IMS)=NMAG(IMS)+1 DO 4000 J=NMAG(IMS),JMS+1,-1 AGEMAG(J,IMS)=AGEMAG(J-1,IMS) TAGMAG(J,IMS)=TAGMAG(J-1,IMS) REMAG(1,1,J,IMS)=REMAG(1,1,J-1,IMS) REMAG(2,1,J,IMS)=REMAG(2,1,J-1,IMS) REMAG(1,2,J,IMS)=REMAG(1,2,J-1,IMS) REMAG(2,2,J,IMS)=REMAG(2,2,J-1,IMS) TREMAG(1,1,J,IMS)=TREMAG(1,1,J-1,IMS) TREMAG(2,1,J,IMS)=TREMAG(2,1,J-1,IMS) TREMAG(1,2,J,IMS)=TREMAG(1,2,J-1,IMS) TREMAG(2,2,J,IMS)=TREMAG(2,2,J-1,IMS) 4000 CONTINUE ENDIF AGEMAG(JMS,IMS)=AGELIN(IROW) TAGMAG(JMS,IMS)=TAG(IROW)(2:2) REMAG(1,1,JMS,IMS)=CXY(1,1,IROW) REMAG(2,1,JMS,IMS)=CXY(2,1,IROW) REMAG(1,2,JMS,IMS)=CXY(1,2,IROW) REMAG(2,2,JMS,IMS)=CXY(2,2,IROW) BACK=.TRUE. CALL MOVEIT(INPUT,CPNLAT,BACK,X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + 'L'//TAGMAG(J,I), + RTAN,XPOLE,YPOLE, + REMAG(1,1,JMS,IMS), + REMAG(2,1,JMS,IMS), + OUTPUT,TREMAG(1,1,JMS,IMS), + TREMAG(2,1,JMS,IMS)) CALL MOVEIT(INPUT,CPNLAT,BACK,X0ELON,Y0NLAT, + TFRAC,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + 'L'//TAGMAG(J,I), + RTAN,XPOLE,YPOLE, + REMAG(1,2,JMS,IMS), + REMAG(2,2,JMS,IMS), + OUTPUT,TREMAG(1,2,JMS,IMS), + TREMAG(2,2,JMS,IMS)) ENDIF ENDIF ELSE IF (Z.EQ.'j'.OR.Z.EQ.'J') THEN LIST3J=.TRUE. ANYEDS=.TRUE. IF (IPOINT.LE.15) THEN Z=BETA(IPOINT:IPOINT) IPOINT=IPOINT+1 IF (IPOINT.LE.15) THEN CALL NUMBER (INDATA,15,BETA, + MODIFY,IPOINT, + OUTPUT,F) ENDIF ENDIF ANGLE=180.*(3.-F)/6. IF (Z.EQ.'k'.OR.Z.EQ.'K') THEN LINTYP=4 KPICK=1 I=1 DO 5000 J=1,NKV3J IF (AGEKV(J).LT.TMY) I=J+1 5000 CONTINUE IF (I.GT.NKV3J) THEN NKV3J=NKV3J+1 ELSE NKV3J=NKV3J+1 DO 5100 J=NKV3J,I+1,-1 AGEKV(J)=AGEKV(J-1) REKV3J(1,J)=REKV3J(1,J-1) REKV3J(2,J)=REKV3J(2,J-1) REKV3J(3,J)=REKV3J(3,J-1) 5100 CONTINUE ENDIF AGEKV(I)=TMY REKV3J(1,I)=XCURS REKV3J(2,I)=YCURS REKV3J(3,I)=angle IROW=I ELSE IF (Z.EQ.'f'.OR.Z.EQ.'F') THEN LINTYP=4 KPICK=2 I=1 DO 5200 J=1,NVF3J IF (AGEVF(J).LT.TMY) I=J+1 5200 CONTINUE IF (I.GT.NVF3J) THEN NVF3J=NVF3J+1 ELSE NVF3J=NVF3J+1 DO 5300 J=NVF3J,I+1,-1 AGEVF(J)=AGEVF(J-1) REVF3J(1,J)=REVF3J(1,J-1) REVF3J(2,J)=REVF3J(2,J-1) REVF3J(3,J)=REVF3J(3,J-1) 5300 CONTINUE ENDIF AGEVF(I)=TMY REVF3J(1,I)=XCURS REVF3J(2,I)=YCURS REVF3J(3,I)=angle IROW=I ENDIF ELSE GO TO 8888 ENDIF IF (IPOINT.LE.15) GO TO 2000 C C**** CONCLUSION OF ENDLESS LOOP ON IMAGES (UNTIL 'Q'=EXIT) ********* 8888 GO TO 300 C******************************************************************** C C SAVE DATA FILES, THEN SHUT DOWN EDITOR C 9999 CONTINUE C C CONVERT CONSTRUCTION LINES BACK TO (LON,LAT) AND WRITE TO FT02 C DO 10100 I=1,NCONST IF (TAG(I)(1:1).EQ.'l'.OR.TAG(I)(1:1).EQ.'L') THEN DO 10020 K=1,2 X=CXY(1,K,I) Y=CXY(2,K,I) CALL XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON, + YPOLE,X,Y, + OUTPUT,PLAT,PLON) CXY(1,K,I)=PLON CXY(2,K,I)=PLAT 10020 CONTINUE WRITE(2,210)TAG(I),AGELIN(I), + ((CXY(L,K,I),L=1,2),K=1,2) ELSE IF (TAG(I)(1:1).EQ.'P'.OR.TAG(I)(1:1).EQ.'p') THEN X=CXY(1,1,I) Y=CXY(2,1,I) CALL XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) CXY(1,1,I)=PLON CXY(2,1,I)=PLAT WRITE(2,210)TAG(I),AGELIN(I), + (CXY(L,1,I),L=1,2) ENDIF 10100 CONTINUE C C COPY "BOILER-PLATE" PART OF FORTRAN FILE TO NEW FILE C DO 10150 I=1,9999 READ(3,10130,END=10151)ALINE 10130 FORMAT(A80) IF (ALINE(1:5).EQ.'C===3') GO TO 10151 WRITE(4,10130)ALINE 10150 CONTINUE 10151 CONTINUE C C WRITE REVISED MAP DATA TO NEW FORTRAN FILE C DO 10180 I=1,NTAPES IF (NMAG(I).LE.0) THEN NMAG(I)=1 TAGMAG(1,I)='N' AGEMAG(1,I)=1.0 REMAG(1,1,1,I)=-10000.*ONEKM REMAG(1,2,1,I)=-10000.*ONEKM REMAG(2,1,1,I)= 10000.*ONEKM REMAG(2,2,1,I)=-10000.*ONEKM ENDIF 10180 CONTINUE C C WRITE(4,10200) 10200 FORMAT('C===3=== DATA MODIFIED BY PROGRAM MAPPER =========='/ + 'C') WRITE(4,10210)NTAPES,NTAPP1,NKV3J,NVF3J 10210 FORMAT('C'/' DATA NTAPES/',I3,'/,NTAPP1/',I3, + '/,NKV3J/',I3,'/,NVF3J/',I3,'/') C C DO 10290 I=1,NKV3J X=REKV3J(1,I) Y=REKV3J(2,I) CALL XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) REKV3J(1,I)=PLAT REKV3J(2,I)=PLON 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 10290 CONTINUE WRITE(4,10300) NKV3J 10300 FORMAT('C'/'C'/'C'/ + ' DATA ((REKV3J(K,I),K=1,3),I=1,',I3,') /') WRITE(4,10301)((REKV3J(K,I),K=1,3),I=1,NKV3J) 10301 FORMAT(' + ',F7.2,',',F7.2,',',F5.0,:,',') WRITE(4,10702) C C DO 10390 I=1,NVF3J X=REVF3J(1,I) Y=REVF3J(2,I) CALL XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) REVF3J(1,I)=PLAT REVF3J(2,I)=PLON 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 10390 CONTINUE WRITE(4,10400) NVF3J 10400 FORMAT(' DATA ((REVF3J(K,I),K=1,3),I=1,',I3,') /') WRITE(4,10301)((REVF3J(K,I),K=1,3),I=1,NVF3J) WRITE(4,10702) C C WRITE(4,10600) NKV3J 10600 FORMAT(' DATA (AGEKV(I),I=1,',I3,') /') WRITE(4,10601) (AGEKV(I),I=1,NKV3J) 10601 FORMAT(' +',F6.2,:,',',F6.2,:,',',F6.2,:,',',F6.2,:,',', + F6.2,:,',',F6.2,:,',',F6.2,:,',',F6.2,:,',') WRITE(4,10702) C C WRITE(4,10650) NVF3J 10650 FORMAT(' DATA (AGEVF(I),I=1,',I3,') /') WRITE(4,10601) (AGEVF(I),I=1,NVF3J) WRITE(4,10702) C C WRITE(4,10700) NTAPP1 10700 FORMAT('C'/'C'/'C'/' DATA (NPFZ(I),I=1,',I3,') /') WRITE(4,10701) (NPFZ(I),I=1,NTAPP1) 10701 FORMAT(' +',I3,:,',',I3,:,',',I3,:,',',I3,:,',',I3,:,',', + I3,:,',',I3,:,',',I3,:,',',I3,:,',',I3,:,',', + I3,:,',',I3,:,',',I3,:,',',I3,:,',',I3,:,',') WRITE(4,10702) 10702 FORMAT(' +/') C C DO 11000 I=1,NTAPP1 WRITE(4,10800)I,NPFZ(I) 10800 FORMAT(' DATA (TAGFZ(K,',I3, + '),K=1,',I3,')/') WRITE(4,10805)(TAGFZ(K,I),K=1,NPFZ(I)) 10805 FORMAT(' +','''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',', + '''',A1,'''',:,',') WRITE(4,10702) C WRITE(4,10850) I,NPFZ(I) 10850 FORMAT(' DATA (AGEFZ(K,',I3,'),K=1,',I3,') /') WRITE(4,10601) (AGEFZ(K,I),K=1,NPFZ(I)) WRITE(4,10702) C DO 10900 M=1,NPFZ(I) X=FRACZN(1,M,I) Y=FRACZN(2,M,I) CALL XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) FRACZN(1,M,I)=PLAT FRACZN(2,M,I)=PLON 10900 CONTINUE WRITE(4,10910)I,NPFZ(I) 10910 FORMAT(' DATA ((FRACZN(K,L,',I3, + '),K=1,2),L=1,',I3,')/') WRITE(4,10920)((FRACZN(K,L,I),K=1,2),L=1,NPFZ(I)) 10920 FORMAT(' +',F7.2,',',F7.2,:,',',F7.2,',',F7.2,:,',', + F7.2,',',F7.2,:,',',F7.2,',',F7.2,:,',') WRITE(4,10702) 11000 CONTINUE C C WRITE(4,11100) NTAPES 11100 FORMAT('C'/'C'/'C'/' DATA (NMAG(I),I=1,',I3,') /') WRITE(4,10701) (NMAG(I),I=1,NTAPES) WRITE(4,10702) C C DO 15000 I=1,NTAPES WRITE(4,11150)I,NMAG(I) 11150 FORMAT(' DATA (TAGMAG(K,',I3, + '),K=1,',I3,')/') WRITE(4,10805)(TAGMAG(K,I),K=1,NMAG(I)) WRITE(4,10702) C WRITE(4,11200) I,NMAG(I) 11200 FORMAT(' DATA (AGEMAG(K,',I3,'),K=1,',I3,') /') WRITE(4,10601) (AGEMAG(K,I),K=1,NMAG(I)) WRITE(4,10702) C C DO 11290 M=1,NMAG(I) X=REMAG(1,1,M,I) Y=REMAG(2,1,M,I) CALL XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) REMAG(1,1,M,I)=PLAT REMAG(2,1,M,I)=PLON X=REMAG(1,2,M,I) Y=REMAG(2,2,M,I) CALL XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) REMAG(1,2,M,I)=PLAT REMAG(2,2,M,I)=PLON 11290 CONTINUE WRITE(4,11300) I,NMAG(I) 11300 FORMAT(' DATA (((REMAG(K,L,M,',I3, + '),K=1,2),L=1,2),M=1,',I3,') /') WRITE(4,10920) (((REMAG(K,L,M,I),K=1,2),L=1,2),M=1,NMAG(I)) WRITE(4,10702) 15000 CONTINUE C C REALLY STOP! C WRITE(4,20000) 20000 FORMAT(' END') CALL FSTERM STOP END C C C CHARACTER*5 FUNCTION ASCII (T) C C CONVERTS REAL*4 FLOATING-POINT VARIABLE TO "-12.3" C OR "123.4" OR " 0.9" C REAL*4 S,T S=ABS(T) IF (T.LE.-100.0) THEN ASCII='-**.*' ELSE IF (T.GE.1000.0) THEN ASCII='***.*' ELSE I1=INT(S/100.) ASCII(1:1)=CHAR(240+I1) I2=INT((S-100.*I1)/10.) ASCII(2:2)=CHAR(240+I2) I3=INT(S-100.*I1-10.*I2) ASCII(3:3)=CHAR(240+I3) ASCII(4:4)='.' I4=INT(10.*(S-100.*I1-10.*I2-I3)) ASCII(5:5)=CHAR(240+I4) IF(ASCII(1:1).EQ.'0')ASCII(1:1)=' ' IF(ASCII(2:2).EQ.'0'.AND.ASCII(1:1).EQ.' ')ASCII(2:2)=' ' IF (T.LT.0.0) THEN IF (ASCII(2:2).EQ.' ') THEN ASCII(2:2)='-' ELSE ASCII(1:1)='-' ENDIF ENDIF DO 10 I=2,5 IF (ASCII(I:I).EQ.'0') ASCII(I:I)='O' 10 CONTINUE ENDIF RETURN END C C C SUBROUTINE LLTOXY (INPUT,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X,Y) C C CONVERT A (NORTH LATITUDE=PLAT, EAST LONGITUDE=PLON) POSITION C INTO AN (X,Y) POSITION ON A CONIC PROJECTION WITH TANGENT C LATITUDE CPNLAT, WHEN THE (X,Y) ORIGIN IS AT C (NORTH LATITUDE=Y0NLAT, EAST LONGITUDE=X0ELON). C THE CUT NECESSARY IN THIS PROJECTION IS FROM THE POLE NEAREST C TO THE TANGENT LATITUDE (CPNLAT), ALONG A MERIDIAN WHICH C IS ON THE OPPOSITE SIDE OF THE EARTH FROM X0ELON. C IF PLAT IS MORE THAN 90 DEGREES DIFFERENT FROM CPNLAT, THE C POINT DOES NOT FALL ONTO THE PROJECTION AT ALL. TO PREVENT C CRASHES, WE MERELY PLACE IT VERY FAR OUT ON THE PROJECTION. C C NOTE: FOLLOWING TWO LINES ARE PRECOMPUTED AND PASSED TO SAVE TIME: C RTAN=RADIUS*TANDEG(90.-CPNLAT) C YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C IF (ABS(PLAT-CPNLAT).GE.90.) PLAT=CPNLAT+89.*(PLAT-CPNLAT)/ + ABS(PLAT-CPNLAT) R=RTAN-RADIUS*TANDEG(PLAT-CPNLAT) DPLON=PLON-X0ELON IF (DPLON.LT.-180.) DPLON=DPLON+360. IF (DPLON.GT. 180.) DPLON=DPLON-360. ANGLE=DPLON*SINDEG(CPNLAT) X=R*SINDEG(ANGLE) Y=YPOLE-R*COSDEG(ANGLE) RETURN END C C C SUBROUTINE XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) C C CONVERT POINTS EXPRESSED AS (X,Y) ON A CONIC PROJECTION PLANE C WITH TANGENT LATITUDE CPNLAT AND ORIGIN AT (Y0NLAT,X0ELON) C TO (PLAT = NORTH_LATITUDE, PLON = EAST_LONGITUDE) C IN DEGREES C C NOTE: FOLLOWING TWO VARIABLES ARE PRECOMPUTED TO SAVE TIME: C RTAN=RADIUS*TANDEG(90.-CPNLAT) C YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C YRP=Y-YPOLE R=SQRT(X**2+YRP**2) ANGLE=57.29578*ATAN2F(X,-YRP) PLON=X0ELON+ANGLE/SINDEG(CPNLAT) PLAT=CPNLAT+57.29578*ATAN((RTAN-R)/RADIUS) PLAT=MIN(90.,MAX(PLAT,-90.)) IF (PLON.GT. 180.) PLON=PLON-360. IF (PLON.LT.-180.) PLON=PLON+360. RETURN END C C C SUBROUTINE CHOICE C C WRITE MENU IN GRAPHICS SEGMENTS 1 & 2 CALL GSSEG(1) C C SET COLOR TO YELLOW C CALL GSCOL(6) CALL GSLW(2) C C OPEN AREA WITH VISIBLE BOUNDARY C CALL GSAREA(1) C C DRAW OUTLINE OF AREA WITH RED PEN C CALL GSCOL(2) CALL GSMOVE(0.1,7.9) CALL GSLINE(5.7,7.9) CALL GSLINE(5.7,1.3) CALL GSLINE(0.1,1.3) CALL GSLINE(0.1,7.9) C C SIGNAL END OF AREA C CALL GSENDA C C SET COLOR TO YELLOW C CALL GSCOL(6) CALL GSLW(2) C C OPEN AREA WITH VISIBLE BOUNDARY C CALL GSAREA(1) C C DRAW OUTLINE OF AREA WITH RED PEN C CALL GSCOL(2) CALL GSMOVE(5.9,7.9) CALL GSLINE(11.1,7.9) CALL GSLINE(11.1,1.3) CALL GSLINE(5.9,1.3) CALL GSLINE(5.9,7.9) C C SIGNAL END OF AREA C CALL GSENDA C C CLOSE FIRST MENU SEGMENT (#1) AND BEGIN SECOND (#2) C CALL GSSCLS C C*************************************** C CALL GSSEG(2) C C WRITE OUT MENU OPTIONS C C SELECT CHARACTER MODE (2 OR 3) C 2 = DEFAULT TYPE, RECTILINEAR, CONSTANT-SPACED C 3 = VECTOR TYPE, ANY ANGLE, PROPORTIONAL SPACING C CALL GSCM(3) C C COMPLETE CONNECTION OF CHARACTER SET C C CALL GSCS(199) C C SET SIZE OF CHARACTER BOXES RELATIVE TO DEFAULT C CALL GSQCB(WIDTH,HEIGHT) WIDTH=1.0*WIDTH HEIGHT=1.0*HEIGHT CALL GSCB(WIDTH,HEIGHT) C C SET LABEL ANGLE TO ZER0 (LIKE THIS) C CALL GSCA(COS(0.0),SIN(0.0)) C C USE BLACK PEN C CALL GSCOL(-1) CALL GSLW(2) C C TEXT OF DISPLAY-COMMAND MENU: CALL GSMOVE(0.6,7.5) CALL GSCHAP(20,'DISPLAY-CONTROL MENU') CALL GSMOVE(0.5,7.0) CALL GSCHAP(31,'M switch this Menu on/off ') CALL GSMOVE(0.5,6.6) CALL GSCHAP(32,'D switch Digitised data on/off ') CALL GSMOVE(0.5,6.3) CALL GSCHAP(31,'F switch Fracture zones on/off ') CALL GSMOVE(0.5,6.0) CALL GSCHAP(31,'A switch Age map on/off ') CALL GSMOVE(0.5,5.7) CALL GSCHAP(31,'L switch state Lines on/off ') CALL GSMOVE(0.5,5.4) CALL GSCHAP(31,'G switch fe-Grid on/off ') CALL GSMOVE(0.5,5.1) CALL GSCHAP(31,'B switch color Bar on/off ') CALL GSMOVE(0.5,4.8) CALL GSCHAP(31,'T63.2 new Time in m.y.b.p. ') CALL GSMOVE(0.5,4.5) CALL GSCHAP(31,'X expand map by 20% ') CALL GSMOVE(0.5,4.2) CALL GSCHAP(31,'C contract map by 20% ') CALL GSMOVE(0.5,3.9) CALL GSCHAP(31,'N move window North by 10% ') CALL GSMOVE(0.5,3.6) CALL GSCHAP(31,'E move window East by 10% ') CALL GSMOVE(0.5,3.3) CALL GSCHAP(31,'S move window South by 10% ') CALL GSMOVE(0.5,3.0) CALL GSCHAP(31,'W move window West by 10% ') CALL GSMOVE(0.5,2.1) CALL GSCHAP(31,'Q Quit and exit this program ') CALL GSMOVE(0.2,1.5) CALL GSCHAP(35,'YOU MAY COMBINE UP TO 15 CHARACTERS') C C TEXT OF EDIT-COMMAND MENU: CALL GSMOVE(6.4,7.5) CALL GSCHAP(17,'EDIT-CONTROL MENU') CALL GSMOVE(6.3,7.1) CALL GSCHAP(31,'C11,1.7 Cursor moves 1.7" ') CALL GSMOVE(6.3,6.9) CALL GSCHAP(31,' toward 11 o-clock ') CALL GSMOVE(6.3,6.5) CALL GSCHAP(31,'X eXpunge highlighted item ') CALL GSMOVE(6.3,6.2) CALL GSCHAP(32,'Pk create a new Point on plate k') CALL GSMOVE(6.3,5.9) CALL GSCHAP(31,'A Attach point to cursor ') CALL GSMOVE(6.3,5.6) CALL GSCHAP(31,'D Detach point from cursor ') CALL GSMOVE(6.3,5.3) CALL GSCHAP(33,'Lk new Line on plate k (end w/D)') CALL GSMOVE(6.3,5.0) CALL GSCHAP(31,'Nk63.2 Name feature with ') CALL GSMOVE(6.3,4.8) CALL GSCHAP(31,' plate letter & age ') CALL GSMOVE(6.3,4.4) CALL GSCHAP(31,'Tk Transfer across ridge to k ') CALL GSMOVE(6.3,4.1) CALL GSCHAP(31,'Fk9 begin Fracture zone #9 on ') CALL GSMOVE(6.3,3.9) CALL GSCHAP(32,' the k plate (use A,D,P,X..Q)') CALL GSMOVE(6.3,3.5) CALL GSCHAP(31,'R9 Remove fracture zone #9 ') CALL GSMOVE(6.3,3.2) CALL GSCHAP(31,'S2 record the highlighted ') CALL GSMOVE(6.3,2.9) CALL GSCHAP(31,' anomaly in strip#2 ) ') CALL GSMOVE(6.3,2.6) CALL GSCHAP(31,'JK2 record point as K/V 3-j at ') CALL GSMOVE(6.3,2.3) CALL GSCHAP(33,' current time, toward 2 oclock') CALL GSMOVE(6.3,2.1) CALL GSCHAP(31,'JF2 record point as V/F 3-j at ') CALL GSMOVE(6.3,1.9) CALL GSCHAP(33,' current time, toward 2 oclock') CALL GSMOVE(6.3,1.5) CALL GSCHAP(31,'YOU MAY COMBINE UP TO 15 CHAR.S') C C CLOSE SECOND MENU SEGMENT C CALL GSSCLS RETURN END 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 ,RADIUS, + X0ELON,Y0NLAT,CPNLAT,IBELOW, + 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, + KTIME ,CONRAD,DQDTDA,TSURF , + APLANO,WANDES,VDECOL,OLDGRD, + GWIDE ,GHIGH ,GANGLE) C C READS STRATEGIC AND TACTICAL INPUT PARAMETERS FROM DEVICE 7 C CHARACTER*80 TITLE LOGICAL ALLREP,OLDGRD,RESTRT,TAPE9 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) 1 FORMAT(A80) READ(7,*) READ(7,1) TITLE READ(7,*) READ(7,*) FRIC(1),FRIC(2) READ(7,*) ACREEP(1),ACREEP(3) READ(7,*) ACREEP(2) READ(7,*) ECREEP(1),ECREEP(3) READ(7,*) ECREEP(2) IF (ECREEP(2).NE.ECREEP(1)) THEN ECREEP(2)=ECREEP(1) ENDIF READ(7,*) BCREEP(1),BCREEP(3) READ(7,*) BCREEP(2) READ(7,*) CCREEP(1),CCREEP(3) READ(7,*) CCREEP(2) READ(7,*) DCREEP(1),DCREEP(3) READ(7,*) DCREEP(2) READ(7,*) CONDUC(1),CONDUC(2) READ(7,*) DIFFUS(1),DIFFUS(2) READ(7,*) RADIO(1),RADIO(2) READ(7,*) THICKN(1),THICKN(2) READ(7,*) TEMLIM(1),TEMLIM(2) READ(7,*)(RHOBAR(I),I=1,2) READ(7,*) ALPHAT(1),ALPHAT(2) READ(7,*) VPMEAN(1),VPMEAN(2) READ(7,*) DVPDT(1),DVPDT(2) READ(7,*) DVPBYE(1,1),DVPBYE(1,2) READ(7,*) DVPBYE(2,1),DVPBYE(2,2) READ(7,*) RHOAST READ(7,*) RHOH2O READ(7,*) BIOT BIOT=MAX(0.0,MIN(1.0,BIOT)) READ(7,*) G READ(7,*) RADIUS READ(7,*) X0ELON READ(7,*) Y0NLAT READ(7,*) CPNLAT IF (ABS(CPNLAT).LT.0.01) CPNLAT=0.01 READ(7,*) IBELOW READ(7,*) READ(7,*) TSURF READ(7,*) TSLAB0 READ(7,*) SIGBOT READ(7,*) WANDES READ(7,*) PUSHHO READ(7,*) ECLOG READ(7,*) SLABSZ READ(7,*) PUSHUP READ(7,*) READ(7,*) NELROW READ(7,*) NELCOL READ(7,*) BEGAGE READ(7,*) DELTAT READ(7,*) ENDAGE READ(7,*) DXMAX READ(7,*) DTHMAX READ(7,*) RAMP READ(7,*) NDIFUS READ(7,*) MAXITR READ(7,*) OKTOQT READ(7,*) VISMAX READ(7,*) ETAMAX READ(7,*) READ(7,*) HMIN(1),HMIN(2) READ(7,*) HMAX(1),HMAX(2) READ(7,*) ALLREP READ(7,*) MIDREP READ(7,*) TAPE9 READ(7,*) READ(7,*) RESTRT READ(7,*) KTIME READ(7,*) READ(7,*) CONRAD READ(7,*) DQDTDA READ(7,*) APLANO IF ((APLANO.LE.0.0).AND.(.NOT.RESTRT)) WANDES=0.0 READ(7,*) VDECOL READ(7,*) OLDGRD IF (RESTRT) OLDGRD=.FALSE. READ(7,*) READ(7,*) READ(7,*) GWIDE READ(7,*) GHIGH READ(7,*) GANGLE RETURN END C C C SUBROUTINE SETDIM (N50,N121, + NELROW,NELCOL,NUMNOD, + NUMEL,DIMERR) C C CALCULATES AMOUNTS OF VARIABLE STORAGE SPACE NEEDED VS. AVAILABLE C LOGICAL DIMERR DATA NXEL/82/,NXNOD/2/,NXCDIM/0/,NXXTR/0/ NUMEL=2*NELROW*NELCOL NUMNOD=(2*NELROW+1)*(2*NELCOL+1) I11=NUMEL*NXEL I12=N50*NXEL I21=NUMNOD*NXNOD I22=N121*NXNOD NSUM1=I11+I21 NSUM2=I12+I22 DIMERR=(NUMEL.GT.N50).OR. + (NUMNOD.GT.N121) IF(DIMERR) WRITE(6,2) 2 FORMAT('0ONE OR MORE VARIABLES ABOVE ARE TOO LARGE.'/ + '0ALL OF THEM MUST BE WITHIN LIMITS BEFORE EXECUTION', + ' CAN PROCEED.'/ + '0INCREASE VALUES OF N50 OR N121', + ' IN PROGRAM MAP PARAMETER STATEMENT.') RETURN END 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 C C C SUBROUTINE GOON (INPUT,NUMNOD,OUTPUT,XNOD,YNOD) C DIMENSION XNOD(NUMNOD), + YNOD(NUMNOD) READ (8,*) READ (8,*) READ (8,*) READ (8,1) (XNOD(I),I=1,NUMNOD) READ (8,*) READ (8,1) (YNOD(I),I=1,NUMNOD) READ (8,*) READ (8,1) (YNOD(I),I=1,NUMNOD) 1 FORMAT(1P,6E13.6) RETURN END C C C SUBROUTINE INTERP (FPOLES,NODES,NUMEL,NUMNOD,VALUES) + C C INTERPOLATES SCALAR FROM NODES TO INTEGRATION POINTS C DOUBLE PRECISION PHI DIMENSION FPOLES(NUMNOD),NODES(6,0:NUMEL), + PHI(6,7),VALUES(7,NUMEL) COMMON /PHITAB/ PHI DO 100 M=1,7 DO 10 I=1,NUMEL VALUES(M,I)=0. 10 CONTINUE 100 CONTINUE DO 200 K=1,6 DO 190 M=1,7 DO 180 I=1,NUMEL VALUES(M,I)=VALUES(M,I)+FPOLES(NODES(K,I))* + PHI(K,M) 180 CONTINUE 190 CONTINUE 200 CONTINUE RETURN END C C C REAL FUNCTION ATAN2F (Y,X) C C CORRECTS FOR PROBLEM OF TWO ZERO ARGUMENTS C IF ((Y.NE.0.).OR.(X.NE.0.)) THEN ATAN2F=ATAN2(Y,X) ELSE ATAN2F=0. ENDIF RETURN END C C C SUBROUTINE AGEBAR (INPUT,AGEMAG,MAXMAG,NMAG,NTAPES) C C PLACES COLORBAR WITH AGE SCALE ON RIGHT. C PARAMETER (NCOLOR=9) CHARACTER*5 TMYCHR,ASCII CHARACTER*6 CLCHR EXTERNAL ASCII DIMENSION AGEMAG(MAXMAG,NTAPES), + ICOLOR(NCOLOR),NMAG(NTAPES) C C SELECT COLORS:128 = WHITE, 9 C 80 = PINK, 8 C 77 = RED, 7 C 93 = ORANGE, 6 C 125 = YELLOW, 5 C 117 = YELLOW/GREEN, 4 C 113 = GREEN 3 C 116 = TURQUOISE, 2----------- C 68 = BLUE 1 ___CINT____ C NOTE: AVOID COLORS WITH BLACK PIXELS, BECAUSE THEY DO NOT OVERLAY C PROPERLY; THEY ARE "TRANSPARENT"!!! C DATA ICOLOR/128,80,77,93,125,117,113,116,68/ C CALL GSLSS(3,'ADMCOLSD',0) CALL GSCM(3) HIGH=0.25 CALL GSQCB(WIDTH,HEIGHT) WIDTH=HIGH*WIDTH/HEIGHT HEIGHT=HIGH AGEMAX=0. DO 5 I=1,NTAPES DO 4 J=1,NMAG(I) AGEMAX=MAX(AGEMAX,AGEMAG(J,I)) 4 CONTINUE 5 CONTINUE AGEMAX=MAX(AGEMAX,1.) CINT=AGEMAX/NCOLOR CALL GSLW(2) C C MASK OUT AREA WITH BLACK C CALL GSCOL(-1) CALL GSMOVE(9.50,-5.) CALL GSAREA(0) CALL GSLINE(9.50,13.5) CALL GSLINE(16.,13.5) CALL GSLINE(16.,-5.) CALL GSLINE(9.50,-5.) CALL GSENDA C C DETERMINE SCALE FACTORS FOR COLOR BAR C RANGE=AGEMAX STEPS=NCOLOR FMIDLE=AGEMAX/2. YPERST=MIN(0.5,6.0/MAX(STEPS,0.01)) YTOP=4.25+YPERST*STEPS/2. YBOT=4.25-YPERST*STEPS/2. ORIGIN=4.25-(FMIDLE/CINT)*YPERST NSTEPT=NCOLOR-1 NSTEPB=0 C C LOAD 64-COLOR PALLETTE CALL GSLSS(3,'ADMCOLSD',0) C C SELECT CHARACTER MODE (2 OR 3) C 2 = DEFAULT TYPE, RECTILINEAR, CONSTANT-SPACED C 3 = VECTOR TYPE, ANY ANGLE, PROPORTIONAL SPACING CALL GSCM(3) C C SET SIZE OF CHARACTER BOXES RELATIVE TO DEFAULT CALL GSCB(WIDTH,HEIGHT) C C SET LABEL ANGLE TO ZER0 (LIKE THIS) CALL GSCA(COS(0.0),SIN(0.0)) C C USE WHITE FOR CONTOUR LEVEL LABELS C CALL GSCOL(-2) CALL GSLW(2) C C DRAW BOXES AND CONTOUR LABELS C IPOW=IUNDER(ALOG10(ABS(CINT))+0.00001) IF (IPOW.EQ.1) IPOW=0 IF (IPOW.EQ.-1)IPOW=0 CIPOW=IPOW CIINT=ABS(CINT)/10.**CIPOW C YNEXT=999. DO 1050 I=NSTEPT,NSTEPB,-1 FTOP=(I+1)*CINT FBOT=I*CINT YTOP=FTOP*YPERST/CINT+ORIGIN YBOT=FBOT*YPERST/CINT+ORIGIN F=(FTOP+FBOT)/2. N=1+F/CINT N=MAX(1,MIN(N,NCOLOR)) CALL GSPAT(ICOLOR(N)) IF (N.EQ.1) THEN ICONT=-1 CALL GSLW(2) ELSE ICONT=8 CALL GSLW(2) ENDIF CALL GSCOL(7) CALL GSAREA(1) CALL GSMOVE(11.0,YBOT) CALL GSCOL(ICONT) CALL GSLINE(11.0,YTOP) CALL GSLINE(10.5,YTOP) CALL GSLINE(10.5,YBOT) CALL GSLINE(11.0,YBOT) CALL GSENDA C C USE WHITE FOR CONTOUR LEVEL LABELS C CALL GSCOL(-2) CALL GSLW(2) C ARG=1.001*F/10.**CIPOW CLCHR=ASCII(1.001*F/10.**CIPOW)//'-' X=10.5-6.5*WIDTH Y=0.5*(YTOP+YBOT)-0.5*HEIGHT IF (Y.LE.YNEXT) THEN YOLD=Y YNEXT=Y-1.1*HEIGHT CALL GSCHAR(X,Y,6,CLCHR) ENDIF 1050 CONTINUE C C ADD 10**N MULTIPLIER C IF (ABS(CIPOW).GT.0.1) THEN X=11.0-8.0*WIDTH Y=YBOT-2.0*HEIGHT CALL GSCHAR(X,Y,4,'X 1O') IF (ABS(CIPOW-1.).GT.0.1) THEN Y=YBOT-1.3*HEIGHT X=11.0-4.0*WIDTH CLCHR=ASCII(CIPOW) IF (CLCHR(1:1).EQ.' ') X=X-WIDTH IF (CLCHR(2:2).EQ.' ') X=X-WIDTH CALL GSCHAR(X,Y,3,CLCHR) ENDIF ENDIF RETURN END C C C SUBROUTINE ETCH (INPUT,NODES,NUMEL,NUMNOD, + XNOD,YNOD) C C PLOTS THE FINITE ELEMENT GRID. C LOGICAL S4,S5,S6 DIMENSION NODES(6,0:NUMEL), + XNOD(NUMNOD), + YNOD(NUMNOD) C C PLOT ALL ELEMENT SIDES (MANY ARE DRAWN TWICE) C C LIGHT GREEN LINES C CALL GSCOL(4) CALL GSLW(1) DO 10 I=1,NUMEL S4=.TRUE. S5=.TRUE. S6=.TRUE. CALL AROUND (I,S4,S5,S6,NODES,XNOD,YNOD,NUMNOD,NUMEL) 10 CONTINUE RETURN END C C C SUBROUTINE AROUND (I,S4,S5,S6,NODES,XNOD,YNOD,NUMNOD,NUMEL) C C DRAW ONE OR MORE SIDE OF AN ELEMENT C LOGICAL S4,S5,S6 COMMON /PLTPRM/ XCENTR,YCENTR,WIDE DIMENSION NODES(6,0:NUMEL),XNOD(NUMNOD),YNOD(NUMNOD) DIMENSION S(3),DS(3) DATA STEP/0.10/, ISTEP/10/ C C STATEMENT FUNCTIONS: 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) XPLT(X)=5.5+5.5*(X-XCENTR)/(0.5*WIDE) YPLT(Y)=4.25+5.5*(Y-YCENTR)/(0.5*WIDE) 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) XP=XPLT(X) YP=YPLT(Y) CALL GSMOVE(XP,YP) 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) XP=XPLT(X) YP=YPLT(Y) CALL GSLINE(XP,YP) 20 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE USMAP (INPUT,DRAWST,NXYST,XST,YST) C C PLOTS OUTLINE OF STATES FROM DIGITIZED DATASET. C LOGICAL DRAW,DRAWST COMMON /PLTPRM/ XCENTR,YCENTR,WIDE DIMENSION DRAWST(NXYST),XST(NXYST),YST(NXYST) C C STATEMENT FUNCTIONS: XPLT(X)=5.5+5.5*(X-XCENTR)/(0.5*WIDE) YPLT(Y)=4.25+5.5*(Y-YCENTR)/(0.5*WIDE) C CALL GSLW(2) CALL GSCOL(1) CALL GSLT(0) DO 100 I=1,NXYST XP=XPLT(XST(I)) YP=YPLT(YST(I)) DRAW=DRAWST(I) IF (DRAW) THEN CALL GSLINE(XP,YP) ELSE CALL GSMOVE(XP,YP) ENDIF 100 CONTINUE RETURN END C C C SUBROUTINE ARROW (INPUT,DELTAT,NELCOL, + NUMEL,TOUCH,VSLAB,XIP,YIP) C C DRAWS VELOCITY VECTORS X TIME INTERVAL DELTAT C IF SLAB IS TOUCHING THE BASE OF THE PLATE C LOGICAL SHOWIT COMMON /PLTPRM/ XCENTR,YCENTR,WIDE DIMENSION TOUCH(7,NUMEL),VSLAB(2,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) C C STATEMENT FUNCTIONS: XPLT(X)=5.5+5.5*(X-XCENTR)/(0.5*WIDE) YPLT(Y)=4.25+5.5*(Y-YCENTR)/(0.5*WIDE) C CALL GSLT(0) CALL GSMS(6) VFACT=DELTAT*5.5/(0.5*WIDE) NEWIDE=2*NELCOL DO 200 I=1,NUMEL DO 190 M=1,7 SHOWIT=((M.EQ.1).AND.(TOUCH(M,I).GT.0.98)).OR. + ((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 (SHOWIT) THEN CALL GSCOL(6) CALL GSLW(2) X=XPLT(XIP(M,I)) Y=YPLT(YIP(M,I)) CALL GSMOVE(X,Y) DX=VFACT*VSLAB(1,M,I) DY=VFACT*VSLAB(2,M,I) XP=X+DX YP=Y+DY CALL GSLINE(XP,YP) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL GSLINE(XP+AX,YP+AY) CALL GSMOVE(XP,YP) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL GSLINE(XP+BX,YP+BY) ENDIF 190 CONTINUE 200 CONTINUE RETURN END C C C SUBROUTINE CONTAC(INPUT,NUMEL,TOUCH,XIP,YIP) C C PLOTS COLORED SYMBOLS TO INDICATE FULL OR PARTIAL C (DELTA P ONLY) CONTACT WITH SUBDUCTED SLAB C COMMON /PLTPRM/ XCENTR,YCENTR,WIDE DIMENSION TOUCH(7,NUMEL),XIP(7,NUMEL),YIP(7,NUMEL) C C STATEMENT FUNCTIONS: XPLT(X)=5.5+5.5*(X-XCENTR)/(0.5*WIDE) YPLT(Y)=4.25+5.5*(Y-YCENTR)/(0.5*WIDE) C C CALL GSMS(4) HIGH=YPLT(100.E5)-YPLT(0.) IF (HIGH.LT.0.03) RETURN DO 100 M=1,7 DO 90 I=1,NUMEL IF (TOUCH(M,I).GT.0.98) THEN CALL GSCOL(2) X=XPLT(XIP(M,I)) Y=YPLT(YIP(M,I)) CALL GSMARK(X,Y) ELSE IF (TOUCH(M,I).GT.0.) THEN CALL GSCOL(6) X=XPLT(XIP(M,I)) Y=YPLT(YIP(M,I)) CALL GSMARK(X,Y) ENDIF 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE DIVIDE (INPUT,REHING,REKV3J,REVF3J,AGEHNG, + AGEKV,AGEVF, + MAXHNG,NKV3J,NPHING,NUMHNG, + NVF3J,TMY, + OUTPUT,XKV,XVF,YKV,YVF) C C PLOTS BOTH TRIPLE-JUNCTIONS ALONG COAST AND THE PLATE-INFLUENCE C DIVIDES WHICH EXTEND FROM THEM. C ALSO PLOTS THE LINES WHICH LIMIT REGION OF CONTACT TO EAST. C COMMON /PLTPRM/ XCENTR,YCENTR,WIDE DIMENSION REHING(2,MAXHNG,NUMHNG),REKV3J(3,NKV3J), + REVF3J(3,NVF3J),AGEHNG(NUMHNG), + AGEKV(NKV3J),AGEVF(NVF3J), + NPHING(NUMHNG) C C STATEMENT FUNCTIONS: XPLT(X)=5.5+5.5*(X-XCENTR)/(0.5*WIDE) YPLT(Y)=4.25+5.5*(Y-YCENTR)/(0.5*WIDE) C CALL GSLW(2) CALL GSCOL(6) C C BOUNDING INDECES FOR KULA/VANCOUVER TRIPLE-JUNCTION LOCATION C IF (NKV3J.GT.0) THEN IKV3J1=1 IKV3J2=NKV3J DO 30 I=2,NKV3J IF (AGEKV(I).LE.TMY) IKV3J1=I J=NKV3J+1-I IF (AGEKV(J).GT.TMY) IKV3J2=J 30 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 PLOT A 1" VECTOR C X=XPLT(XKV) Y=YPLT(YKV) CALL GSMOVE(X,Y) ANGLE=AKV/57.298 X=X+COS(ANGLE) Y=Y+SIN(ANGLE) CALL GSLINE(X,Y) ENDIF C C BOUNDING INDECES FOR VANCOUVER/FARALLON 3-JUNCTION LOCATION C IF (NVF3J.GT.0) THEN IVF3J1=1 IVF3J2=NVF3J DO 35 I=2,NVF3J IF (AGEVF(I).LE.TMY) IVF3J1=I J=NVF3J+1-I IF (AGEVF(J).GT.TMY) IVF3J2=J 35 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 PLOT A 1" VECTOR C X=XPLT(XVF) Y=YPLT(YVF) CALL GSMOVE(X,Y) ANGLE=AVF/57.298 X=X+COS(ANGLE) Y=Y+SIN(ANGLE) CALL GSLINE(X,Y) ENDIF C C BOUNDING INDECES AND FRACTION FOR HINGE LOCATION C IH1=1 IH2=NUMHNG DO 40 I=2,NUMHNG IF (TMY.LE.AGEHNG(I)) IH1=I IP=NUMHNG+1-I IF (TMY.GT.AGEHNG(IP)) IH2=IP 40 CONTINUE FH1=(TMY-AGEHNG(IH2))/MAX(1.,(AGEHNG(IH1)-AGEHNG(IH2))) FH2=1.00-FH1 C C PLOT A RED LINE C CALL GSLW(1) CALL GSCOL(2) YTOP=MIN(REHING(2,1,IH1),REHING(2,1,IH2)) YBOT=MAX(REHING(2,NPHING(IH1),IH1),REHING(2,NPHING(IH2),IH2)) DY=(YTOP-YBOT)/100. DO 100 K=0,100 Y=YTOP-K*DY N1=1 N2=2 DO 60 J=1,NPHING(IH1)-1 J1=J J2=J+1 IF ((REHING(2,J1,IH1).GE.Y).AND. + (REHING(2,J2,IH1).LE.Y)) THEN N1=J1 N2=J2 ENDIF 60 CONTINUE FRAC=(REHING(2,N1,IH1)-Y)/MAX(1., + (REHING(2,N1,IH1)-REHING(2,N2,IH1))) X1=FRAC*REHING(1,N2,IH1)+ + (1.-FRAC)*REHING(1,N1,IH1) N1=1 N2=2 DO 70 J=1,NPHING(IH2)-1 J1=J J2=J+1 IF ((REHING(2,J1,IH2).GE.Y).AND. + (REHING(2,J2,IH2).LE.Y)) THEN N1=J1 N2=J2 ENDIF 70 CONTINUE FRAC=(REHING(2,N1,IH2)-Y)/MAX(1., + (REHING(2,N1,IH2)-REHING(2,N2,IH2))) X2=FRAC*REHING(1,N2,IH2)+ + (1.-FRAC)*REHING(1,N1,IH2) X=FH1*X1+FH2*X2 IF (K.EQ.0) THEN CALL GSMOVE(XPLT(X),YPLT(Y)) ELSE CALL GSLINE(XPLT(X),YPLT(Y)) ENDIF 100 CONTINUE C RETURN END 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 C C C INTEGER FUNCTION IUNDER (X) C C RETURNS INTEGER .LE. X, UNLIKE INT FUNCTION C IUNDER=INT(X) IF (X.LT.(1.*IUNDER)) IUNDER=IUNDER-1 RETURN END C C C SUBROUTINE INLAND (INPUT,NUMEL,NUMNOD, + NELROW,XIP,XNOD,YIP,YNOD, + OUTPUT,FROMW) C C COMPUTE DISTANCE EASTWARD FROM WESTERN EDGE OF CRUSTAL GRID C NOTE: MODIFIED TO COMPUTE AT NODES, INSTEAD OF AT INT. POINTS C DIMENSION FROMW(7,NUMEL),XIP(7,NUMEL),XNOD(NUMNOD), + YIP(7,NUMEL),YNOD(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,XNOD,YNOD) 90 CONTINUE 100 CONTINUE RETURN END 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 A SINGLE POINT. C THIS FUNCTION USES A METHOD OF TRIANGLE-AREA, WHICH IS NOT C SENSITIVE TO THE ORIENTATION OF THE GRID IN THE X/Y PLANE. C FOR STABILITY, IT DOES NOT CONSIDER THE CURVATURE OF THE C LEFT SIDE, BUT REPLACES IT WITH A PIECEWISE-LINEAR CURVE C CONNECTING ALL THE LEFT SIDE NODES. C DIMENSION XNODC(NLL),YNODC(NLL) C D2M=9.99E59 NMID=1 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 C C C SUBROUTINE NUMBER (INPUT,LENGTH,STRING, + MODIFY,IPOINT, + OUTPUT,X) C C READ CHARACTER 'STRING' OF LENGTH 'LENGTH', C BEGINNING AT POSITION 'IPOINT' AND RETURNS FLOATING-POINT C RESULT 'X' IF SOME COMBINATION OF 0-9, ., +, AND/OR - IS C FOUND. (ELSE, RETURNS 0.) C AT RETURN, IPOINT POINTS TO THE NEXT (NON-NUMERIC) CHARACTER. C CHARACTER*80 STRING CHARACTER*1 Z LOGICAL BEGUN,POINT IF (LENGTH.GT.80) THEN WRITE(6,1) LENGTH 1 FORMAT(' VARIABLE STRING IS SUBPROGRAM NUMBER ', + 'NEEDS TO BE LONGER:',I5) STOP ENDIF X=0. BEGUN=.FALSE. POINT=.FALSE. SIGN=+1. FACTOR=1. IPOINT=MIN(IPOINT,LENGTH) JS=IPOINT DO 100 J=IPOINT,LENGTH Z=STRING(J:J) IF (ICHAR(Z).GE.240.AND.ICHAR(Z).LE.249) THEN BEGUN=.TRUE. JS=JS+1 N=ICHAR(Z)-240 IF (POINT) THEN FACTOR=FACTOR*0.10 X=X+SIGN*N*FACTOR ELSE X=X*10.+SIGN*N ENDIF ELSE IF (Z.EQ.'+') THEN IF (BEGUN) THEN GO TO 101 ELSE JS=JS+1 SIGN= +1. ENDIF ELSE IF (Z.EQ.'-') THEN IF (BEGUN) THEN GO TO 101 ELSE JS=JS+1 SIGN= -1. ENDIF ELSE IF (Z.EQ.'.') THEN IF (POINT) THEN GO TO 101 ELSE JS=JS+1 POINT=.TRUE. ENDIF ELSE IF ((.NOT.BEGUN).AND.(Z.EQ.' ')) THEN JS=JS+1 ELSE GO TO 101 ENDIF 100 CONTINUE 101 IPOINT=JS RETURN END C C C BLOCK DATA BD1 C C DEFINE PHI (NODAL FUNCTIONS) AND WEIGHT (GAUSSIAN INTEGRATION C WEIGHTS) OF 6-NODED TRIANGULAR FINITE ELEMENT FOR THE C SEVEN INTEGRATION POINTS IN EACH ELEMENT, DEFINED BY INTERNAL C COORDINATES POINTS(5,7), WHERE POINTS(1-3,M)=L1-3 OF C INTEGRATION POINT NUMBER M. C DOUBLE PRECISION PHI,POINTS,WEIGHT COMMON /L1L2L3/ POINTS COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT DIMENSION PHI(6,7),POINTS(5,7),WEIGHT(7) 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/ END C C C SUBROUTINE MOVEIT(INPUT,CPNLAT,BACK,X0ELON,Y0NLAT, + FRAC2,IROT1,IROT2, + NROMAT,RADIUS, + ROMATF,ROMATK, + ROMATP,ROMATV, + TAG, + RTAN,XPOLE,YPOLE, + X,Y, + OUTPUT,XM,YM) C C MOVE A POINT (X,Y)-IN CARTESIAN COORDINATES WITH KM UNITS C (RELATIVE TO DEVNVER, IN A CONIC PROJECTION AT CPNLAT DEGREES)- C TO ITS PAST POSITION, C WITH RESULT (TX,TY) IN THE SAME SYSTEM OF UNITS C (NORTH AMERICAN COORDINATE FRAME). C USES ROUND-EARTH ROTATIONS FOR GREATER ACCURACY. C CHARACTER*2 TAG LOGICAL BACK,FARALL,KULA,PACIFI,VANCOU DIMENSION ROMATF(3,3,NROMAT),ROMATK(3,3,NROMAT), + ROMATP(3,3,NROMAT),ROMATV(3,3,NROMAT) DIMENSION TM1(3,3),TM2(3,3),TM3(3,3) C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C FARALL=TAG(2:2).EQ.'f'.OR.TAG(2:2).EQ.'F' KULA =TAG(2:2).EQ.'k'.OR.TAG(2:2).EQ.'K' PACIFI=TAG(2:2).EQ.'p'.OR.TAG(2:2).EQ.'P' VANCOU=TAG(2:2).EQ.'v'.OR.TAG(2:2).EQ.'V' IF (.NOT.(FARALL.OR.KULA.OR.PACIFI.OR.VANCOU)) THEN XM=X YM=Y RETURN ENDIF C C CONVERT FROM MAP UNITS TO (LON,LAT) IN DEGREES C CALL XYTOLL (INPUT,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + X,Y, + OUTPUT,PLAT,PLON) C C CONVERT TO CARTESIAN 3-D COORDINATES IN RANGE -1 TO +1 C 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 DO 10 IR=1,3 DO 5 JC=1,3 TM1(IR,JC)=ROMATF(IR,JC,IROT1) TM2(IR,JC)=ROMATF(IR,JC,IROT2) 5 CONTINUE 10 CONTINUE ELSE IF (KULA) THEN DO 20 IR=1,3 DO 15 JC=1,3 TM1(IR,JC)=ROMATK(IR,JC,IROT1) TM2(IR,JC)=ROMATK(IR,JC,IROT2) 15 CONTINUE 20 CONTINUE ELSE IF (PACIFI) THEN DO 30 IR=1,3 DO 25 JC=1,3 TM1(IR,JC)=ROMATP(IR,JC,IROT1) TM2(IR,JC)=ROMATP(IR,JC,IROT2) 25 CONTINUE 30 CONTINUE ELSE IF (VANCOU) THEN DO 40 IR=1,3 DO 35 JC=1,3 TM1(IR,JC)=ROMATV(IR,JC,IROT1) TM2(IR,JC)=ROMATV(IR,JC,IROT2) 35 CONTINUE 40 CONTINUE ENDIF IF (BACK) THEN DO 50 I=1,3 DO 45 J=1,3 TM3(I,J)=TM1(I,J) 45 CONTINUE 50 CONTINUE DO 60 I=1,3 DO 55 J=1,3 TM1(I,J)=TM3(J,I) 55 CONTINUE 60 CONTINUE DO 70 I=1,3 DO 65 J=1,3 TM3(I,J)=TM2(I,J) 65 CONTINUE 70 CONTINUE DO 80 I=1,3 DO 75 J=1,3 TM2(I,J)=TM3(J,I) 75 CONTINUE 80 CONTINUE ENDIF CX1=TM1(1,1)*CX+TM1(1,2)*CY+TM1(1,3)*CZ CY1=TM1(2,1)*CX+TM1(2,2)*CY+TM1(2,3)*CZ CZ1=TM1(3,1)*CX+TM1(3,2)*CY+TM1(3,3)*CZ CX2=TM2(1,1)*CX+TM2(1,2)*CY+TM2(1,3)*CZ CY2=TM2(2,1)*CX+TM2(2,2)*CY+TM2(2,3)*CZ CZ2=TM2(3,1)*CX+TM2(3,2)*CY+TM2(3,3)*CZ 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,CPNLAT, + PLAT1,PLON1, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X1,Y1) CALL LLTOXY (INPUT,CPNLAT, + PLAT2,PLON2, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X2,Y2) XM=X2*FRAC2+X1*(1.-FRAC2) YM=Y2*FRAC2+Y1*(1.-FRAC2) RETURN END C C C SUBROUTINE PLTCON (INPUT,AGELIN,NCONST,TAG,TMY,TXY) + C C PLOTS CONSTRUCTION LINES ON SCREEN IN ESTABLISHED SEGMENT C CHARACTER*2 TAG CHARACTER*5 ASCII,FIVE LOGICAL SHOLET EXTERNAL ASCII COMMON /PLTPRM/ XCENTR,YCENTR,WIDE DIMENSION AGELIN(NCONST),TAG(NCONST),TXY(2,2,NCONST) C C STATEMENT FUNCTIONS: XPLT(X)=5.5+5.5*(X-XCENTR)/(0.5*WIDE) YPLT(Y)=4.25+5.5*(Y-YCENTR)/(0.5*WIDE) C CALL GSCM(3) HIGH=MIN(0.25,(YPLT(150.E5)-YPLT(0.))) SHOLET=HIGH.GE.0.12 IF (SHOLET) THEN CALL GSQCB(WIDTH,HEIGHT) WIDTH=HIGH*WIDTH/HEIGHT HEIGHT=HIGH CALL GSCB(WIDTH,HEIGHT) ENDIF CALL GSMS(6) CALL GSMSC(0.12) C C USE BLUE PEN C CALL GSCOL(1) C C USE LIGHT LINE C CALL GSLW(1) C DO 100 I=1,NCONST IF (AGELIN(I).GE.TMY) THEN IF (TAG(I)(1:1).EQ.'l'.OR.TAG(I)(1:1).EQ.'L') THEN X1=XPLT(TXY(1,1,I)) Y1=YPLT(TXY(2,1,I)) CALL GSMOVE(X1,Y1) X2=XPLT(TXY(1,2,I)) Y2=YPLT(TXY(2,2,I)) CALL GSLINE(X2,Y2) ANGLE=ATAN2F(Y2-Y1,X2-X1) CALL GSCA(COS(ANGLE),SIN(ANGLE)) XB=0.5*(X1+X2)-3.*WIDTH*COS(ANGLE)- + 0.5*HEIGHT*SIN(ANGLE) YB=0.5*(Y1+Y2)-3.*WIDTH*SIN(ANGLE)+ + 0.5*HEIGHT*COS(ANGLE) CALL GSMOVE(XB,YB) FIVE=ASCII(AGELIN(I)) IF (SHOLET) CALL GSCHAR(XB,YB,6,TAG(I)(2:2)//FIVE) ELSE IF (TAG(I)(1:1).EQ.'p'.OR.TAG(I)(1:1).EQ.'P') THEN X1=XPLT(TXY(1,1,I)) Y1=YPLT(TXY(2,1,I)) CALL GSMOVE(X1,Y1) CALL GSMARK(X1,Y1) CALL GSCA(1.0,0.0) XB=X1-3.*WIDTH YB=Y1+0.5*HEIGHT CALL GSMOVE(XB,YB) FIVE=ASCII(AGELIN(I)) IF (SHOLET) CALL GSCHAR(XB,YB,6,TAG(I)(2:2)//FIVE) ENDIF ENDIF 100 CONTINUE RETURN END C C C SUBROUTINE PLTMAP (INPUT,AGEFZ,AGEMAG,IMSHOW,ISEG1,MAXFZP, + MAXMAG,NMAG,NPFZ,NTAPES,NTAPP1, + NWFZ,SHOAGE,SHOFZ, + TAGFZ,TAGMAG,TFRACZ,TMY,TREMAG) C C PLOTS SEAFLOOR AGE MAP ON SCREEN IN SEGMENTS ISEG1, ISEG1+1,... C NOTE THAT DATA STATEMENT FOR "ORDER" DICTATES ORDER IN WHICH C THE PLATES ARE DRAWN; LATER PLATES OVERLAP EARLIER ONES. C PARAMETER (NCOLOR=9,NPLATE=4) C C SELECT COLORS:128 = WHITE, 9 C 80 = PINK, 8 C 77 = RED, 7 C 93 = ORANGE, 6 C 125 = YELLOW, 5 C 117 = YELLOW/GREEN, 4 C 113 = GREEN 3 C 116 = TURQUOISE, 2 ----------- C 68 = BLUE, 1 ___CINT____ C NOTE: DO NOT SELECT PATTERNS WITH BLACK PIXELS. C WHEN YOU OVERLAY PLATES (EVEN IN DIFFERENT GRAPHICS SEGMENTS), C THE BLACK PIXELS ARE "TRANSPARENT" AND SHOW THE PLATE BENEATH! C C CHARACTER*1 NAME1,NAME2,ORDER,TAGFZ,TAGMAG CHARACTER*5 ASCII,FIVE LOGICAL SHOAGE,SHOFZ EXTERNAL ASCII COMMON /PLTPRM/ XCENTR,YCENTR,WIDE DIMENSION AGEFZ(MAXFZP,NTAPP1), + AGEMAG(MAXMAG,NTAPES),ICOLOR(NCOLOR), + NMAG(NTAPES),NPFZ(NTAPP1), + TAGFZ(MAXFZP,NTAPP1),TAGMAG(MAXMAG,NTAPES), + TFRACZ(2,MAXFZP,NTAPP1), + TREMAG(2,2,MAXMAG,NTAPES) DIMENSION ORDER(NPLATE,2) DATA (ORDER(1,I),I=1,2)/'K','k'/, + (ORDER(2,I),I=1,2)/'V','v'/, + (ORDER(3,I),I=1,2)/'F','f'/, + (ORDER(4,I),I=1,2)/'P','p'/ DATA ICOLOR/128,80,77,93,125,117,113,116,68/ C C STATEMENT FUNCTIONS: XPLT(X)=5.5+5.5*(X-XCENTR)/(0.5*WIDE) YPLT(Y)=4.25+5.5*(Y-YCENTR)/(0.5*WIDE) C AGEMAX=0. DO 5 I=1,NTAPES DO 4 J=1,NMAG(I) AGEMAX=MAX(AGEMAX,AGEMAG(J,I)) 4 CONTINUE 5 CONTINUE CINT=AGEMAX/NCOLOR FMIDLE=AGEMAX/2. C C OUTER LOOP ON GRAPHICS SEGMENTS AND PLATES WAS ADDED TO IMPROVE C THE OVERLAP RELATIONSHIPS ON THE SCREEN. C DO 9999 KPLATE=1,NPLATE CALL GSSEG(ISEG1+KPLATE-1) NAME1=ORDER(KPLATE,1) NAME2=ORDER(KPLATE,2) CALL GSLSS(3,'ADMCOLSD',0) CALL GSCM(3) HIGH=MIN(0.25,(YPLT(150.E5)-YPLT(0.))) CALL GSQCB(WIDTH,HEIGHT) WIDTH=HIGH*WIDTH/HEIGHT HEIGHT=HIGH CALL GSCB(WIDTH,HEIGHT) C C USE HEAVY LINES C CALL GSLW(2) C C SEAFLOOR DIVIDED INTO BOXES BOUNDED BY FRACTURE ZONES C AND MAGNETIC ANOMALIES, AND COLORED BY MEAN AGE C IF (SHOAGE) THEN DO 100 I=NTAPES,1,-1 IF ((IMSHOW.EQ.0).OR.(I.EQ.IMSHOW)) THEN DO 90 J=1,NMAG(I)-1 IF (((AGEMAG(J,I)+AGEMAG(J+1,I))/2..GT.TMY) .AND. + ((TAGMAG(J,I).EQ.NAME1).OR.(TAGMAG(J,I).EQ.NAME2))) + THEN TL=MAX(AGEMAG(J,I),0.0) TR=MAX(AGEMAG(J+1,I),0.0) CALL CORNER (INPUT,I+1 ,I ,J , + MAXFZP,MAXMAG,NPFZ,NTAPES,NTAPP1, + TFRACZ,TREMAG, + OUTPUT,JFZUL,K,XUL,YUL) CALL CORNER (INPUT,I ,I ,J , + MAXFZP,MAXMAG,NPFZ,NTAPES,NTAPP1, + TFRACZ,TREMAG, + OUTPUT,JFZLL,K,XLL,YLL) CALL CORNER (INPUT,I ,I ,J+1, + MAXFZP,MAXMAG,NPFZ,NTAPES,NTAPP1, + TFRACZ,TREMAG, + OUTPUT,K,JFZLR,XLR,YLR) CALL CORNER (INPUT,I+1 ,I ,J+1, + MAXFZP,MAXMAG,NPFZ,NTAPES,NTAPP1, + TFRACZ,TREMAG, + OUTPUT,K,JFZUR,XUR,YUR) XUL=XPLT(XUL) XLL=XPLT(XLL) XLR=XPLT(XLR) XUR=XPLT(XUR) YUL=YPLT(YUL) YLL=YPLT(YLL) YLR=YPLT(YLR) YUR=YPLT(YUR) CALL GSMOVE(XUL,YUL) AGE=0.5*(TL+TR)-TMY IC=1+AGE/CINT IC=MAX(1,MIN(IC,NCOLOR)) CALL GSCOL(7) CALL GSPAT(ICOLOR(IC)) CALL GSAREA(1) C C USE YELLOW PEN FOR MAGNETIC BOXES C CALL GSCOL(6) CALL GSLINE(XLL,YLL) IF ((JFZLR-JFZLL).GT.1) THEN DO 27 JT=JFZLL+1,JFZLR-1 XT=XPLT(TFRACZ(1,JT,I)) YT=YPLT(TFRACZ(2,JT,I)) CALL GSLINE(XT,YT) 27 CONTINUE ENDIF CALL GSLINE(XLR,YLR) CALL GSLINE(XUR,YUR) IF ((JFZUR-JFZUL).GT.1) THEN DO 37 JT=JFZUR-1,JFZUL+1,-1 XT=XPLT(TFRACZ(1,JT,I+1)) YT=YPLT(TFRACZ(2,JT,I+1)) CALL GSLINE(XT,YT) 37 CONTINUE ENDIF CALL GSLINE(XUL,YUL) CALL GSENDA ENDIF 90 CONTINUE ENDIF 100 CONTINUE ENDIF C C FRACTURE ZONES IN GREEN, UNLESS SELECTED FOR EDITING (THEN WHITE) C IF (SHOFZ) THEN ITEST1=1 ITEST2=6 ITEST3=11 ITEST4=16 ITEST5=21 ITEST6=26 DO 200 I=1,NTAPP1 IF (I.NE.NWFZ) THEN CALL GSCOL(4) ELSE CALL GSCOL(-2) ENDIF DO 190 J=2,NPFZ(I) IF ((AGEFZ(J,I).GE.TMY.OR.AGEFZ(J-1,I).GE.TMY) .AND. + ((TAGFZ(J,I).EQ.NAME1).OR.(TAGFZ(J,I).EQ.NAME2))) + THEN XW=XPLT(TFRACZ(1,J-1,I)) YW=YPLT(TFRACZ(2,J-1,I)) CALL GSMOVE(XW,YW) XE=XPLT(TFRACZ(1,J,I)) YE=YPLT(TFRACZ(2,J,I)) CALL GSLINE(XE,YE) IT=MOD(J-I,NTAPP1) IF ((IT.EQ.ITEST1).OR.(IT.EQ.ITEST2).OR. + (IT.EQ.ITEST3).OR.(IT.EQ.ITEST4).OR. + (IT.EQ.ITEST5).OR.(IT.EQ.ITEST6)) THEN ANGLE=ATAN2F(YE-YW,XE-XW) XB=XW-0.3*HEIGHT*SIN(ANGLE) YB=YW+0.3*HEIGHT*COS(ANGLE) CALL GSCA(COS(ANGLE),SIN(ANGLE)) CALL GSMOVE(XB,YB) FIVE=ASCII(1.0*I) CALL GSCHAR(XB,YB,4,FIVE(:3)//TAGFZ(J,I)) CALL GSMOVE(XE,YE) ENDIF ENDIF 190 CONTINUE 200 CONTINUE ENDIF CALL GSSCLS 9999 CONTINUE RETURN END C C C SUBROUTINE CORNER (INPUT,IRFZ,IRMG,JMG, + MAXFZP,MAXMAG,NPFZ,NTAPES,NTAPP1, + TFRACZ,TREMAG, + OUTPUT,JFZL,JFZR,X,Y) C C FIND INTERSECTION OF FRACTURE ZONE IRFZ C WITH MAGNETIC ANOMALY JMG IN STRIP IRMG. C DIMENSION NPFZ(NTAPP1), + TFRACZ(2,MAXFZP,NTAPP1), + TREMAG(2,2,MAXMAG,NTAPES) DATA BIGNUM/9.99E59/ C XA1=TREMAG(1,1,JMG,IRMG) YA1=TREMAG(2,1,JMG,IRMG) XA2=TREMAG(1,2,JMG,IRMG) YA2=TREMAG(2,2,JMG,IRMG) URX=(YA1-YA2) URY=(XA2-XA1) IF (IRFZ.GT.IRMG) THEN XT=XA1 YT=YA1 ELSE XT=XA2 YT=YA2 ENDIF JCLOSE=1 R2MIN=BIGNUM DO 10 J=1,NPFZ(IRFZ)-1 DO 9 FRAC=0,1.00,0.05 XF=FRAC*TFRACZ(1,J+1,IRFZ)+(1.-FRAC)*TFRACZ(1,J,IRFZ) YF=FRAC*TFRACZ(2,J+1,IRFZ)+(1.-FRAC)*TFRACZ(2,J,IRFZ) R2=(XT-XF)**2+(YT-YF)**2 IF (R2.LT.R2MIN) THEN R2MIN=R2 IF (FRAC.LE.0.50) THEN JCLOSE=J ELSE JCLOSE=J+1 ENDIF ENDIF 9 CONTINUE 10 CONTINUE DX=TFRACZ(1,JCLOSE,IRFZ)-XT DY=TFRACZ(2,JCLOSE,IRFZ)-YT DOT=DX*URX+DY*URY IF (DOT.LT.0.0) THEN JFZL=MIN(JCLOSE,NPFZ(IRFZ)-1) ELSE JFZL=MAX(JCLOSE-1,1) ENDIF JFZR=JFZL+1 XB1=TFRACZ(1,JFZL,IRFZ) YB1=TFRACZ(2,JFZL,IRFZ) XB2=TFRACZ(1,JFZR,IRFZ) YB2=TFRACZ(2,JFZR,IRFZ) CALL INTSEC (INPUT,XA1,YA1,XA2,YA2, + XB1,YB1,XB2,YB2, + OUTPUT,X,Y) RETURN END C C C SUBROUTINE INTSEC (INPUT,XA1,YA1,XA2,YA2, + XB1,YB1,XB2,YB2, + OUTPUT,X,Y) C C FINDS INTERSECTION OF TWO STRAIGHT LINES C IF (XA1.EQ.XA2) THEN X=XA1 SLOPEB=(YB2-YB1)/(XB2-XB1) Y=YB1-(XB1-X)*SLOPEB ELSE IF (XB1.EQ.XB2) THEN X=XB1 SLOPEA=(YA2-YA1)/(XA2-XA1) Y=YA1-(XA1-X)*SLOPEA ELSE SLOPEA=(YA2-YA1)/(XA2-XA1) SLOPEB=(YB2-YB1)/(XB2-XB1) IF (ABS(SLOPEB).LE.ABS(SLOPEA)) THEN X=(XA1-(SLOPEB/SLOPEA)*XB1+(YB1-YA1)/SLOPEA)/ + (1.-SLOPEB/SLOPEA) Y=YB1+(X-XB1)*SLOPEB ELSE X=(XB1-(SLOPEA/SLOPEB)*XA1+(YA1-YB1)/SLOPEB)/ + (1.-SLOPEA/SLOPEB) Y=YA1+(X-XA1)*SLOPEA ENDIF ENDIF RETURN END C C C SUBROUTINE CURSOR(INPUT,AGEFZ,AGELIN,AGEMAG,ATTACH,FEGRID, + IMSHOW,MAXFZP,MAXMAG,NCONST,NMAG,NPFZ, + NTAPES,NTAPP1,NWFZ, + SHOAGE,SHOFZ,SHOLIN,SHOX, + TAG,TFRACZ,TMY,TXY,TREMAG, + XCURS,YCURS, + XKV,XVF,YKV,YVF, + OUTPUT,IROW,JCOL,KPICK,LINTYP) C C PLOT RED CURSOR OVER PICTURE AT (XCURS,YCURS) FROM ORIGIN C AND HIGHLIGHT THE NEAREST LINE SEGMENT OR POINT C IF NWFZ.GT.0 THEN ONLY THE FRACTURE ZONE #NWFZ CAN BE PICKED. C KPICK=1 IF THE FIRST POINT OF A LINE IS CHOSEN, C =2 IF THE MIDPOINT OF A LINE IS CHOSEN, C =3 IF THE ENDPOINT OF A LINE IS CHOSEN. C LINTYP=1 IF THE POINT PICKED IS ON A CONSTRUCTION LINE OR POINT C =2 IF THE POINT PICKED IS ON A MAGNETIC ANOMALY C =3 IF THE POINT PICKED IS ON A FRACTURE ZONE C =4 IF THE POINT PICKED IS A PLATE TRIPLE-JUNCTION C LOGICAL ATTACH,FEGRID,LINE,POINT,SHOAGE,SHOFZ,SHOLIN,SHOX CHARACTER*2 TAG COMMON /PLTPRM/ XCENTR,YCENTR,WIDE DIMENSION AGEFZ(MAXFZP,NTAPP1),AGELIN(NCONST), + AGEMAG(MAXMAG,NTAPES), + NMAG(NTAPES),NPFZ(NTAPP1),TAG(NCONST), + TFRACZ(2,MAXFZP,NTAPP1), + TXY(2,2,NCONST),TREMAG(2,2,MAXMAG,NTAPES) DATA BIGNUM/9.999E59/ C C STATEMENT FUNCTIONS: XPLT(X)=5.5+5.5*(X-XCENTR)/(0.5*WIDE) YPLT(Y)=4.25+5.5*(Y-YCENTR)/(0.5*WIDE) C IF (SHOX.AND.(FEGRID.OR.SHOAGE.OR.SHOFZ.OR.SHOLIN)) THEN CALL GSCOL(2) CALL GSLW(1) CALL GSMS(6) CALL GSMSC(0.12) XC=XPLT(XCURS) YC=YPLT(YCURS) CALL GSMOVE(XC,YC+0.10) CALL GSLINE(XC,YC-0.10) CALL GSMOVE(XC-0.10,YC) CALL GSLINE(XC+0.10,YC) CALL GSMOVE(XC+1.00,YC) CALL GSARC(XC,YC,360.) ENDIF C C IF (ATTACH) GO TO 1000 C C R2MIN=BIGNUM IF (SHOFZ.AND.(.NOT.SHOAGE)) THEN DO 100 I=1,NTAPP1 IF ((NWFZ.GT.0).AND.(I.NE.NWFZ)) GO TO 100 DO 40 J=1,NPFZ(I) IF (AGEFZ(J,I).LT.TMY) GO TO 40 X=TFRACZ(1,J,I) Y=TFRACZ(2,J,I) R2=(XCURS-X)**2+(YCURS-Y)**2 IF (R2.LT.R2MIN) THEN KPICK=1 LINTYP=2 IROW=I JCOL=J R2MIN=R2 ENDIF 40 CONTINUE 100 CONTINUE ENDIF IF (SHOAGE.AND.(NWFZ.EQ.0)) THEN DO 200 I=1,NTAPES IF ((IMSHOW.EQ.0).OR.(I.EQ.IMSHOW)) THEN DO 190 J=1,NMAG(I) X=TREMAG(1,1,J,I) Y=TREMAG(2,1,J,I) R2=(XCURS-X)**2+(YCURS-Y)**2 IF (R2.LT.R2MIN) THEN KPICK=1 LINTYP=3 IROW=I JCOL=J R2MIN=R2 ENDIF X=TREMAG(1,2,J,I) Y=TREMAG(2,2,J,I) R2=(XCURS-X)**2+(YCURS-Y)**2 IF (R2.LT.R2MIN) THEN KPICK=3 LINTYP=3 IROW=I JCOL=J R2MIN=R2 ENDIF X=0.5*(TREMAG(1,1,J,I)+TREMAG(1,2,J,I)) Y=0.5*(TREMAG(2,1,J,I)+TREMAG(2,2,J,I)) R2=(XCURS-X)**2+(YCURS-Y)**2 IF (R2.LT.R2MIN) THEN KPICK=2 LINTYP=3 IROW=I JCOL=J R2MIN=R2 ENDIF 190 CONTINUE ENDIF 200 CONTINUE ENDIF IF (FEGRID.AND.(NWFZ.EQ.0)) THEN R2=(XCURS-XKV)**2+(YCURS-YKV)**2 IF (R2.LT.R2MIN) THEN KPICK=1 LINTYP=4 IROW=0 JCOL=0 R2MIN=R2 ENDIF R2=(XCURS-XVF)**2+(YCURS-YVF)**2 IF (R2.LT.R2MIN) THEN KPICK=2 LINTYP=4 IROW=0 JCOL=0 R2MIN=R2 ENDIF ENDIF IF (SHOLIN.AND.(NWFZ.EQ.0).AND.(.NOT.SHOAGE)) THEN DO 400 I=1,NCONST IF (AGELIN(I).LT.TMY) GO TO 400 X=TXY(1,1,I) Y=TXY(2,1,I) R2=(XCURS-X)**2+(YCURS-Y)**2 IF (R2.LT.R2MIN) THEN KPICK=1 LINTYP=1 IROW=I JCOL=1 R2MIN=R2 ENDIF IF (TAG(I)(:1).EQ.'l'.OR.TAG(I)(:1).EQ.'L') THEN X=TXY(1,2,I) Y=TXY(2,2,I) R2=(XCURS-X)**2+(YCURS-Y)**2 IF (R2.LT.R2MIN) THEN KPICK=3 LINTYP=1 IROW=I JCOL=2 R2MIN=R2 ENDIF X=0.5*(TXY(1,1,I)+TXY(1,2,I)) Y=0.5*(TXY(2,1,I)+TXY(2,2,I)) R2=(XCURS-X)**2+(YCURS-Y)**2 IF (R2.LT.R2MIN) THEN KPICK=2 LINTYP=1 IROW=I JCOL=1 R2MIN=R2 ENDIF ENDIF 400 CONTINUE ENDIF C C 1000 CALL GSLW(2) IF (LINTYP.EQ.1) THEN IF (TAG(IROW)(:1).EQ.'l'.OR.TAG(IROW)(:1).EQ.'L') THEN X=XPLT(TXY(1,1,IROW)) Y=YPLT(TXY(2,1,IROW)) CALL GSMOVE(X,Y) X=XPLT(TXY(1,2,IROW)) Y=YPLT(TXY(2,2,IROW)) CALL GSLINE(X,Y) ENDIF IF (KPICK.EQ.1) THEN X=XPLT(TXY(1,1,IROW)) Y=YPLT(TXY(2,1,IROW)) CALL GSMARK(X,Y) ELSE IF (KPICK.EQ.2) THEN X=XPLT(0.5*(TXY(1,1,IROW)+TXY(1,2,IROW))) Y=YPLT(0.5*(TXY(2,1,IROW)+TXY(2,2,IROW))) CALL GSMARK(X,Y) ELSE IF (KPICK.EQ.3) THEN X=XPLT(TXY(1,2,IROW)) Y=YPLT(TXY(2,2,IROW)) CALL GSMARK(X,Y) ENDIF ELSE IF (LINTYP.EQ.2) THEN XP=XPLT(TFRACZ(1,JCOL,IROW)) YP=YPLT(TFRACZ(2,JCOL,IROW)) IF (JCOL.GE.2) THEN XL=XPLT(TFRACZ(1,JCOL-1,IROW)) YL=YPLT(TFRACZ(2,JCOL-1,IROW)) CALL GSMOVE(XL,YL) CALL GSLINE(XP,YP) ENDIF IF (JCOL.LT.NPFZ(IROW)) THEN XR=XPLT(TFRACZ(1,JCOL+1,IROW)) YR=YPLT(TFRACZ(2,JCOL+1,IROW)) CALL GSMOVE(XP,YP) CALL GSLINE(XR,YR) ENDIF CALL GSMARK(XP,YP) ELSE IF (LINTYP.EQ.3) THEN X=XPLT(TREMAG(1,1,JCOL,IROW)) Y=YPLT(TREMAG(2,1,JCOL,IROW)) CALL GSMOVE(X,Y) X=XPLT(TREMAG(1,2,JCOL,IROW)) Y=YPLT(TREMAG(2,2,JCOL,IROW)) CALL GSLINE(X,Y) IF (KPICK.EQ.1) THEN X=XPLT(TREMAG(1,1,JCOL,IROW)) Y=YPLT(TREMAG(2,1,JCOL,IROW)) CALL GSMARK(X,Y) ELSE IF (KPICK.EQ.2) THEN X=XPLT(0.5*(TREMAG(1,1,JCOL,IROW)+ + TREMAG(1,2,JCOL,IROW))) Y=YPLT(0.5*(TREMAG(2,1,JCOL,IROW)+ + TREMAG(2,2,JCOL,IROW))) CALL GSMARK(X,Y) ELSE IF (KPICK.EQ.3) THEN X=XPLT(TREMAG(1,2,JCOL,IROW)) Y=YPLT(TREMAG(2,2,JCOL,IROW)) CALL GSMARK(X,Y) ENDIF ELSE IF (LINTYP.EQ.4) THEN IF (KPICK.EQ.1) THEN CALL GSMARK(XPLT(XKV),YPLT(YKV)) ELSE IF (KPICK.EQ.2) THEN CALL GSMARK(XPLT(XVF),YPLT(YVF)) ENDIF ENDIF RETURN END C C C SUBROUTINE HOWROT (INPUT,AGEROT,NROMAT,TMY, + OUTPUT,IROT1,IROT2,TFRAC) C C FINDS INDECES OF ROTATION APPROPRIATE TO TMY (M.Y.) C DIMENSION AGEROT(NROMAT) C IROT1=1 IROT2=NROMAT DO 10 I=2,NROMAT IF (AGEROT(I).LE.TMY) IROT1=I J=NROMAT+1-I IF (AGEROT(J).GT.TMY) IROT2=J 10 CONTINUE TFRAC=(TMY-AGEROT(IROT1))/ + MAX((AGEROT(IROT2)-AGEROT(IROT1)),1.) RETURN END C C C SUBROUTINE LISTMY (INPUT,AGEKV,AGEVF,NKV3J,NVF3J, + MKV3J,MVF3J) C C LIST AGES OF TRIPLE-JUNCTION MARKERS ALONG TOP EDGE OF SCREEN C CHARACTER*78 TEXT DIMENSION AGEKV(MKV3J),AGEVF(MVF3J) C N=NKV3J/10 IF (NKV3J.GT.(N*10)) N=N+1 TEXT(1:8)='AGEKV = ' DO 10 I=1,N J2=10*I J1=J2-9 J2=MIN(J2,NKV3J) WRITE(TEXT(9:78),'(10F7.2)')(AGEKV(J),J=J1,J2) CALL ASDFLD(5+I,I+1,1,1,78,2) CALL ASCPUT(5+I,78,TEXT) 10 CONTINUE M=NVF3J/10 IF (NVF3J.GT.(M*10)) M=M+1 TEXT(1:8)='AGEVF = ' DO 20 I=1,M J2=10*I J1=J2-9 J2=MIN(J2,NVF3J) WRITE(TEXT(9:78),'(10F7.2)')(AGEVF(J),J=J1,J2) CALL ASDFLD(5+N+I,N+I+1,1,1,78,2) CALL ASCPUT(5+N+I,78,TEXT) 20 CONTINUE RETURN END C C C SUBROUTINE BELOWQ(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C THIS IS A GENERIC STAND-IN FOR THE TWO ROUTINES: C C "BELOW1", LINKED TO /NORTH1/,/NORTH2/, AND /NORTH3/, C WHICH REPRESENTS THE NORTHERN OPTION FOR NORTH AMERICA; C C "BELOW2", LINKED TO /SOUTH1/,/SOUTH2/, AND /SOUTH3/, C WHICH REPRESENTS THE SOUTHERN OPTION FOR NORTH AMERICA. 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-------------------------------------------------------------------- COMMON /SCALAR/ + NKV3J, + NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, + TUMAP COMMON /ARRAYS/ + AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, + FRACZN,NMAG,NPFZ,NPHING, + OMEGAF,OMEGAK,OMEGAP,OMEGAV, + REHING,REKV3J,REMAG,REVF3J, + ROMATF,ROMATK,ROMATP,ROMATV COMMON /TAGS/ + 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 C CALL BELOWY(INPUT,CPNLAT,ECLOG,FROMW, 1 NELCOL,NUMEL, 2 PUSHUP,RADIUS,RAMP,SLABSZ,TIME, 3 WANDES,XIP,YIP,X0ELON,Y0NLAT, 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 C C C SUBROUTINE BELOWY(INPUT,CPNLAT,ECLOG,FROMW, 1 NELCOL,NUMEL, 2 PUSHUP,RADIUS,RAMP,SLABSZ,TIME, 3 WANDES,XIP,YIP,X0ELON,Y0NLAT, 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 CHARACTER*1 TAGFZ,TAGMAG,TAGLIN LOGICAL ABOVE,BELOW,FARALL,KULA,PACIFI,VANCOU C COMMON /GROBOW/ HANDES,XANDES,NPOINT,NALT1,NALT2 C DIMENSION HANDES(5),XANDES(5) 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) C SAVE ICALL,NEWIDE, + RTAN,TAGLIN,YPOLE C DATA BIGNUM/9.9E59/ DATA ICALL/0/ C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) 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 RTAN=RADIUS*TANDEG(90.-CPNLAT) YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) 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,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + 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,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + 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,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + 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,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + 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,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + 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,CPNLAT,RADIUS,RTAN,X0ELON,YPOLE, + 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,CPNLAT, + PLAT1,PLON1, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X1,Y1) CALL LLTOXY (INPUT,CPNLAT, + PLAT2,PLON2, + RADIUS,RTAN,X0ELON,YPOLE, + 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 /* //SYSLIN DD DISP=(MOD,PASS),DSN=&&LOADSET, // UNIT=VIO,SPACE=(3040,(40,40),,,ROUND), // DCB=(BLKSIZE=3040,BUFNO=1) //SYSTERM DD SYSOUT=* //SYSPRINT DD SYSOUT=* //LKED EXEC PGM=IEWL,REGION=3500K,COND=(4,LT,FORT),PARM='MAP,LIST' //SYSLIB DD DISP=(SHR,PASS),DSN=APP1.FORTVS.LIBRARY (FORTRAN) // DD DISP=(SHR,PASS),DSN=APP1.GDDM4.LOAD (GRAPHICS) //SYSLIN DD DSN=&&LOADSET,DISP=(OLD,DELETE) // DD DDNAME=SYSIN //SYSLMOD DD DISP=(NEW,CATLG),UNIT=DATA, NEW LOAD MODULE // SPACE=(TRK,(12,4,1)),DSN=EFF9GPB.MAPMOD(MAP) //SYSIN DD * ENTRY MAIN INCLUDE SYSLIB(FSINN) INCLUDE SYSLIB(ADMLSYS1) /* //SYSPRINT DD SYSOUT=* //SYSUT1 DD UNIT=VIO,SPACE=(TRK,(5,5),,,ROUND) //