//EFF9GPBG JOB TIME=(0,30) COMPILE GDDM COLOR GRAPHICS PROGRAMS /*SCHEDULE PRIORITY=0.7 //CLEAR EXEC PGM=IEFBR14 FIRST, DELETE ANY PRE-EXISTING LOAD //DD1 DD DSN=EFF9GPB.GDDMMOD,DISP=(OLD,DELETE) MODULES //FORT1 EXEC PGM=FORTVS,REGION=3072K, USE VS FORTRAN 2.4.0+ // PARM='MAP,NODECK,NOLIST,OPT(2)' //STEPLIB DD DISP=(SHR,PASS),DSN=APP1.FORTVS.COMPILER //SYSIN DD * C PROGRAM DRAW C (UCLA EDITION OF 18 FEBRUARY 1997 C ******* COMPATIBLE WITH 31 JANUARY 1997 VERSION OF LARAMY ***** C TAKES OUTPUT FROM A FINITE ELEMENT SIMULATION OF CONTINENTAL C DEFORMATION PERFORMED BY "LARAMY" AND PLOTS CONTOUR DIAGRAMS C OF THE RESULTS IN COLOR, TO BE VIEWED FROM A 3179-G TERMINAL C USING SEPARATE PROGRAM "VIEW". C C USES STRATEGIC AND TACTICAL INPUT PARAMETERS IN C CARD FORMAT FROM DEVICE 5; SHOULD CONFORM TO DATA USED C IN THE ORIGINAL RUN OF "LARAMY"; PLOT CONTROLS ARE APPENDED C AT THE END OF THIS DATASET (WHERE "LARAMY" WON'T READ THEM). C READS OLD OUTPUT "TAPE" AS SOURCE OF DETAILED DATA FROM DEVICE 8. C OPTIONALLY READS STATE OUTLINES FROM UNIT 11 AND INCLUDES IN PLOTS. C OPTIONALLY READS SHORT DATASET OF FINAL NODE LOCATIONS CORRESPONDING C TO THESE STATE LINES ON DEVICE 12, AND RETRO-PROJECTS THEM. C PRODUCES GRAPHIC OUTPUT FORMATTED FOR LINE PRINTER ON DEVICE 6. C PRODUCES DEVICE-INDEPENDENT GRAPHICS METAFILES (5 FILES PER C FRAME) UNDER CONVENTIONS OF IBM'S GDDM SOFTWARE, AND STORES C THEM AS MEMBERS (WITH NAMES LIKE "V17T09S1") IN PARTITIONED C DATASET "ADMGDF". THIS DATASET MUST BE PREALLOCATED. 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 -ESSL (IBM PRODUCT) ROUTINES: C DGBF AND DGBS (DOUBLE PRECISION FACTOR AND C SOLVE A GENERAL BANDED LINEAR SYSTEM) 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 ASCGET,ASCPUT,ASDFLD,ASFCUR,ASREAD, C DSOPEN,DSUSE, C FSALRM,FSEXIT,FSINIT,FSPCLR,FSQERR,FSTERM, C GSARC,GSAREA,GSCA,GSCB,GSCHAP,GSCHAR,GSCM,GSCOL, C GSCS,GSENDA,GSLINE,GSLOAD,GSLSS,GSLT,GSLW, C GSMARK,GSMOVE,GSMS,GSMSC,GSPAT,GSQCB,GSSAVE, C GSSCLS,GSSDEL,GSSEG,GSUWIN. C CHARACTER*80 TITLE CHARACTER*8 ASTER,BLANKS DOUBLE PRECISION CODE,FLOWIN LOGICAL ALDONE,ALLREP,BOXIT,DIMERR,DOFEM,DOPLOT,DOREP, + DRAWST,FAILUR,LISTOP,RESTRT,RETRO, + STATES,TAPE9 C C FOLLOWING LINE SETS MAXIMUM NUMBER OF ELEMENTS: PARAMETER (N50=280) C FOLLOWING LINE SETS MAXIMUM NUMBER OF NODES: PARAMETER (N121=609) C FOLLOWING LINE SETS SIZE OF STORAGE RESERVED FOR CENTRAL BAND C OF A MATRIX NOMINALLY N121 BY N121: PARAMETER (N9922=86478) C FOLLOWING LINE RESERVES EXTRA STORAGE FOR LINEAR SYSTEM SOLUTIONS PARAMETER (NEXTRA=609) C FOLLOWING LINE SETS MAXIMUM NUMBER OF POINTS IN STATELINE MAPS: PARAMETER (NSTATE=2000) C FOLLOWING LINE SETS NUMBER OF COLORS IN PALETTE: PARAMETER (NCOLOR=12) C C VARIABLE DIMENSIONS CONTAINING VALUE OF N50: DIMENSION ALPHAC(3,3,7,N50),ALPHAM(3,3,7,N50), 2 AREAC(N50),AREAM(N50),CONINT(7,N50),DELVC(2,7,N50), 3 DELVM(2,7,N50),DETJC(7,N50), 4 DETJM(7,N50), 6 DVB(7,N50),DVT(7,N50),DXSC(6,7,N50), 7 DXSM(6,7,N50),DYSC(6,7,N50),DYSM(6,7,N50), 8 EDOTC(4,7,N50),EDOTM(4,7,N50), 9 ERATEC(4,7,N50),ERATEM(4,7,N50), A ESUMC(2,2,7,N50),ESUMM(2,2,7,N50), 1 FLUXC(7,N50),FLUXM(7,N50) DIMENSION FROMWC(7,N50),FROMWM(7,N50),GEOTHA(4,7,N50), 3 GEOTHC(4,7,N50),GEOTHM(4,7,N50), 4 GLUEC(7,N50),GLUEM(7,N50),DNLINK(3,7,N50), 5 UPLINK(3,7,N50),LISTOP(N50), 6 NODES(6,0:N50),OUTSCA(7,N50),OUTVEC(2,7,N50), 7 OUTV2(2,7,N50),OVA(2,7,N50),OVB(2,7,N50), 8 PTSC(2,7,N50),PTSM(2,7,N50), 9 SIGHC(2,7,N50),SIGHBM(2,7,N50),SIGHTM(2,7,N50), A SIGZZC(7,N50),SIGZZM(7,N50), 1 SZZBC(7,N50),SZZBM(7,N50),TAUMTC(3,7,N50), 2 TAUMTM(3,7,N50),TAUZZC(7,N50),TAUZZM(7,N50), 3 THIKC(7,N50),THIKM(7,N50), 4 TOFSTC(3,7,N50),TOFSTM(3,7,N50), 5 TOUCHC(7,N50),TOUCHM(7,N50), 6 VSLABC(2,7,N50),VSLABM(2,7,N50), 7 XIPC(7,N50),XIPM(7,N50),YIPC(7,N50),YIPM(7,N50) C VARIABLE DIMENSIONS CONTAINING VALUE OF N121: DIMENSION CONDNS(N121),CONNOD(N121),FLOWIN(N121),PHINOD(N121), + XNODC(N121),XNODM(N121),YNODC(N121), + YNODM(N121),VC(2,N121),VM(2,N121), + THNKC(N121),THNKM(N121), + WC(N121),WM(N121) C VARIABLE DIMENSION CONTAINING VALUE OF N9922: DIMENSION CODE(N9922) C VARIABLE DIMENSION CONTAINING VALUE OF NEXTRA: DIMENSION LWORK(NEXTRA) C VARIABLE DIMENSION CONTAINING VALUE OF NSTATE: DIMENSION DRAWST(NSTATE),STLINK(3,NSTATE), + XST(NSTATE),XSTP(NSTATE),YST(NSTATE),YSTP(NSTATE) C C FIXED-DIMENSION ARRAYS OF GENERAL USE AND VARIABLE VALUE: DIMENSION ACREEP(3),ALPHAT(2),BCREEP(3),CCREEP(3),CONDUC(2), + CINT(24),DOPLOT(24),DCREEP(3), + DIFFUS(2),DVPBYE(2,2),DVPDT(2),ECREEP(3),FBLAND(24), + FRIC(2),HMAX(2),HMIN(2), + LOWBLU(24),RADIO(2),RHOBAR(2),TEMLIM(2), + THICKN(2),VPMEAN(2) C (FIXED-DIMENSION ARRAYS OF LOCAL USE ARE BUILT INTO SUBROUTINES; C FIXED-DIMENSION ARRAYS OF GENERAL USE BUT CONSTANT VALUE ARE C CONTAINED IN COMMON BLOCKS.) DATA (NODES(J,0),J=1,6)/1,1,1,1,1,1/ DATA RINKM /6371./ DATA ASTER/'L79A3 '/,BLANKS/' '/ DATA NTREAD /0/ C C STATEMENT FUNCTIONS: SINDEG(S)=SIN(S*0.0174533) COSDEG(S)=COS(S*0.0174533) TANDEG(S)=TAN(S*0.0174533) C C INITIALIZE GDDM C CALL FSINIT C C SUPRESS ALL MESSAGES FROM GDDM (ONLY NEEDED FOR DEBUGGING) C CALL FSEXIT(0,20) C C REQUEST OUTPUT SUITABLE FOR A 3179-G COLOR-GRAPHICS TERMINAL C CALL DSOPEN(11,1,ASTER,0,0,1,BLANKS) CALL DSUSE(1,11) C 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, + KTAPE ,CONRAD,DQDTDA,TSURF , + APLANO,WANDES,VDECOL,OLDGRD, + GWIDE ,GHIGH ,GANGLE, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,SCALEC,NCONTR, $ STATES,RETRO,RMSVEC, $ IPENCT,IPENST,IPENLB,COLOR) ONEKM=RADIUS/RINKM RTAN=RADIUS*TANDEG(90.-CPNLAT) YPOLE=RTAN-RADIUS*TANDEG(Y0NLAT-CPNLAT) IF (STATES) THEN NXYST=0 DO 1100 I=1,NSTATE READ(11,*,END=1101) PLAT,PLON,DRAWST(I) CALL LLTOXY (INPUT,CPNLAT, + PLAT,PLON, + RADIUS,RTAN,X0ELON,YPOLE, + OUTPUT,X,Y) XST(I)=X YST(I)=Y XSTP(I)=XST(I) YSTP(I)=YST(I) NXYST=NXYST+1 1100 CONTINUE 1101 NXYST=NXYST-MOD(NXYST,7) DRAWST(1)=.FALSE. ENDIF CALL SETDIM (N50,N121,N9922,NEXTRA,NXL, + NCDIM,NDIFF,NELROW,NELCOL,NUMNOD, + NUMEL,DIMERR) IF (DIMERR) STOP CALL GRIDDR(INPUT,NELROW,NELCOL,NUMEL, + MODIFY,NODES) IF (STATES.AND.RETRO) THEN CALL GOTOND (INPUT,NUMNOD, + OUTPUT,XNODC,YNODC) CALL AREAS (NODES,AREAC,XNODC,YNODC,NUMNOD,NUMEL) NUMEL1=NXYST/7 NUMEL2=NUMEL CALL LINKUS (NELCOL,NUMEL1,NUMEL2,XST,YST, + XNODC,YNODC, + NUMNOD,NODES,AREAC,STLINK,FAILUR) ENDIF IF (KTIME.GE.1) THEN CALL PAST (ACREEP,ALPHAC,ALPHAM,ALPHAT,AREAC,AREAM,BCREEP, 2 BIOT,CCREEP,CODE,CONDNS,CONINT,CONNOD,CONRAD, 3 DCREEP,DELVC,DELVM,DETJC,DETJM, 4 DNLINK,DVB,DVT,DXSC,DXSM,DYSC,DYSM,ECLOG,ECREEP, 5 ERATEC,ERATEM,ESUMC,ESUMM,ETAMAX,FLOWIN,FLUXC, 6 FLUXM,FRIC,G,GEOTHA,GEOTHC,GEOTHM,GLUEC,GLUEM, 7 KTIME,LISTOP,LWORK,NCDIM,NDIFF,NELCOL, 8 NODES,NUMEL,NUMNOD,NXL,ONEKM,OUTSCA,OUTVEC, 9 OUTV2,OVA,OVB,PTSC,PTSM,PUSHHO,PUSHUP,RADIUS, A RAMP,RHOAST,RHOH2O,RHOBAR,SIGBOT,SIGHC, 1 SIGHBM,SIGHTM,SIGZZC,SIGZZM,SLABSZ, 2 CPNLAT,IBELOW,X0ELON,Y0NLAT,SZZBC,SZZBM, 3 TASTH,TAUMTC,TAUMTM,TAUZZC,TAUZZM,TEMLIM, 4 THIKC,THIKM,TIME,THNKC,THNKM,TOFSTC,TOFSTM, 5 TOUCHC,TOUCHM,TSLAB0,TSURF,UPLINK,VC,VM,VISMAX, 6 VSLABC,VSLABM,WC,WM,XIPC,XIPM, 7 XNODC,XNODM,YIPC,YIPM,YNODC,YNODM, 8 ALDONE,NELROW,FROMWC,FROMWM,WANDES, 9 NTREAD,TITLE,HMAX,HMIN) IF (STATES.AND.RETRO) THEN CALL GETSCA (INPUM,XNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,XSTP) CALL GETSCA (INPUM,YNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,YSTP) DO 5678 I=1,NXYST IF (STLINK(1,I).LT.1.0) THEN XSTP(I)=XST(I) YSTP(I)=YST(I) ENDIF 5678 CONTINUE ENDIF ISTEP=1 CALL REPORT (ISTEP,NTREAD,XIPC,XIPM,YIPC,YIPM, 2 XNODC,XNODM,YNODC,YNODM,TITLE,VM,NODES, 3 OUTSCA,OUTVEC,VC,ERATEM,ERATEC, 4 THIKM,THIKC,GEOTHA,GEOTHC,CONDUC, 5 GEOTHM,DNLINK,VPMEAN,DVPBYE,DVPDT, 6 TIME ,NUMNOD,NUMEL,G, 7 HMAX,HMIN,RHOAST,RHOH2O,SIGHC,SIGHBM,SIGZZC, 8 SIGZZM,TAUMTC,TAUMTM,TAUZZC,TAUZZM, 9 TEMLIM,ONEKM,ESUMC,ESUMM,AREAC,AREAM, A CODE,CONDNS,DETJC,DETJM,FAILUR,FLOWIN, 1 NCDIM,NDIFF,NXL,LWORK,WC,WM, 2 SZZBC,SZZBM,TOUCHC,TOUCHM, 3 ECLOG,RADIUS,SLABSZ,CPNLAT,IBELOW,X0ELON, 4 Y0NLAT,VSLABC,VSLABM,OUTV2,RAMP, 5 THNKC,UPLINK,TASTH,TSLAB0, 6 DOPLOT,SCALEC,NCONTR, 7 STATES,RMSVEC,NELCOL,PHINOD,DRAWST, 8 NXYST,XSTP,YSTP,NELROW,THNKM,FBLAND,LOWBLU, 9 CINT,FROMWC,FROMWM,WANDES,CONINT, B CONNOD,TSURF,PUSHUP) ELSE KTIME=1 DO 9999 ITIME=1,999 CALL PAST (ACREEP,ALPHAC,ALPHAM,ALPHAT,AREAC,AREAM,BCREEP, 2 BIOT,CCREEP,CODE,CONDNS,CONINT,CONNOD,CONRAD, 3 DCREEP,DELVC,DELVM,DETJC,DETJM, 4 DNLINK,DVB,DVT,DXSC,DXSM,DYSC,DYSM,ECLOG,ECREEP, 5 ERATEC,ERATEM,ESUMC,ESUMM,ETAMAX,FLOWIN,FLUXC, 6 FLUXM,FRIC,G,GEOTHA,GEOTHC,GEOTHM,GLUEC,GLUEM, 7 KTIME,LISTOP,LWORK,NCDIM,NDIFF,NELCOL, 8 NODES,NUMEL,NUMNOD,NXL,ONEKM,OUTSCA,OUTVEC, 9 OUTV2,OVA,OVB,PTSC,PTSM,PUSHHO,PUSHUP,RADIUS, A RAMP,RHOAST,RHOH2O,RHOBAR,SIGBOT,SIGHC, 1 SIGHBM,SIGHTM,SIGZZC,SIGZZM,SLABSZ, 2 CPNLAT,IBELOW,X0ELON,Y0NLAT,SZZBC,SZZBM, 3 TASTH,TAUMTC,TAUMTM,TAUZZC,TAUZZM,TEMLIM, 4 THIKC,THIKM,TIME,THNKC,THNKM,TOFSTC,TOFSTM, 5 TOUCHC,TOUCHM,TSLAB0,TSURF,UPLINK,VC,VM,VISMAX, 6 VSLABC,VSLABM,WC,WM,XIPC,XIPM, 7 XNODC,XNODM,YIPC,YIPM,YNODC,YNODM, 8 ALDONE,NELROW,FROMWC,FROMWM,WANDES, 9 NTREAD,TITLE,HMAX,HMIN) IF (ALDONE) GO TO 10000 IF (STATES.AND.RETRO) THEN CALL GETSCA (IMPUT,XNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,XSTP) CALL GETSCA (IMPUT,YNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,YSTP) DO 6789 I=1,NXYST IF (STLINK(1,I).LT.1.0) THEN XSTP(I)=XST(I) YSTP(I)=YST(I) ENDIF 6789 CONTINUE ENDIF CALL REPORT (ITIME,NTREAD,XIPC,XIPM,YIPC,YIPM, 2 XNODC,XNODM,YNODC,YNODM,TITLE,VM,NODES, 3 OUTSCA,OUTVEC,VC,ERATEM,ERATEC, 4 THIKM,THIKC,GEOTHA,GEOTHC,CONDUC, 5 GEOTHM,DNLINK,VPMEAN,DVPBYE,DVPDT, 6 TIME ,NUMNOD,NUMEL,G, 7 HMAX,HMIN,RHOAST,RHOH2O,SIGHC,SIGHBM,SIGZZC, 8 SIGZZM,TAUMTC,TAUMTM,TAUZZC,TAUZZM, 9 TEMLIM,ONEKM,ESUMC,ESUMM,AREAC,AREAM, A CODE,CONDNS,DETJC,DETJM,FAILUR,FLOWIN, 1 NCDIM,NDIFF,NXL,LWORK,WC,WM, 2 SZZBC,SZZBM,TOUCHC,TOUCHM, 3 ECLOG,RADIUS,SLABSZ,CPNLAT,IBELOW,X0ELON, 4 Y0NLAT,VSLABC,VSLABM,OUTV2,RAMP, 5 THNKC,UPLINK,TASTH,TSLAB0, 6 DOPLOT,SCALEC,NCONTR, 7 STATES,RMSVEC,NELCOL,PHINOD,DRAWST, 8 NXYST,XSTP,YSTP,NELROW,THNKM,FBLAND,LOWBLU, 9 CINT,FROMWC,FROMWM,WANDES,CONINT, B CONNOD,TSURF,PUSHUP) 9999 CONTINUE 10000 CONTINUE ENDIF C C SHUT DOWN GDDM C CALL FSTERM C STOP 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, + KTAPE ,CONRAD,DQDTDA,TSURF , + APLANO,WANDES,VDECOL,OLDGRD, + GWIDE ,GHIGH ,GANGLE, $ KTIME,DOPLOT,CINT,FBLAND,LOWBLU,SCALEC,NCONTR, $ STATES,RETRO,RMSVEC, $ IPENCT,IPENST,IPENLB,COLOR) C C READS STRATEGIC AND TACTICAL INPUT PARAMETERS FROM DEVICE 5, C AND ECHOES THEM ON DEVICE 6 WITH ANNOTATIONS. C CHARACTER*80 TITLE LOGICAL ALLREP,COLOR,DOPLOT,OLDGRD, + RESTRT,RETRO,STATES,TAPE9 DIMENSION ACREEP(3),ALPHAT(2),BCREEP(3),CCREEP(3),CONDUC(2), + CINT(24),DCREEP(3),DIFFUS(2),DOPLOT(24), + DVPBYE(2,2),DVPDT(2),ECREEP(3),FBLAND(24),FRIC(2), + HMAX(2),HMIN(2),LOWBLU(24),RADIO(2), + RHOBAR(2),TEMLIM(2),THICKN(2),VPMEAN(2) 1 FORMAT(A80) WRITE(6,10) 10 FORMAT(' **************************************************'/ + ' IT IS THE USERS RESPONSIBILITY TO INPUT ALL OF THE'/ + ' FOLLOWING NUMERICAL QUANTITIES IN CONSISTENT UNITS,'/ + ' SUCH AS SYSTEM-INTERNATIONAL (SI) OR CM-G-S (CGS).'/ + ' NOTE THAT TIME UNIT MUST BE THE SECOND (HARD-CODED).'/ + ' **************************************************') READ(5,*) WRITE(6,11) 11 FORMAT(/ / /' ========== STRATEGIC PARAMETERS (DEFINE THE REAL-', + 'EARTH PROBLEM) ======') TITLE=' '// + ' ' READ(5,1) TITLE WRITE(6,101) TITLE 101 FORMAT(/ / /' ',A80/ + ' CRUST MANTLE \ PARAMETER (LINE ABOVE IS TITLE)') READ(5,*) READ(5,*) FRIC(1),FRIC(2) WRITE(6,102) FRIC(1),FRIC(2) 102 FORMAT(' ',2F10.3,' COEFFICIENT OF FRICTION') READ(5,*) ACREEP(1),ACREEP(3) WRITE(6,103) ACREEP(1),ACREEP(3) 103 FORMAT(' ',1P,2E10.2,' PRE-EXPONENTIAL SHEAR STRESS CONSTANT', + ' FOR CREEP') READ(5,*) ACREEP(2) WRITE(6,104) ACREEP(2) 104 FORMAT(' ',1P,E10.2,' N/A PRE-EXPONENTIAL FOR LOWER', + ' CRUST, BELOW CONRAD') READ(5,*) ECREEP(1),ECREEP(3) WRITE(6,105) ECREEP(1),ECREEP(3) 105 FORMAT(' ',2F10.6,' STRAIN-RATE EXPONENT FOR CREEP (1/N)') READ(5,*) ECREEP(2) IF (ECREEP(2).NE.ECREEP(1)) THEN ECREEP(2)=ECREEP(1) WRITE(6,1059) 1059 FORMAT(' ',' WARNING! ALGEBRA IN -PWAZUL- REQUIRES A', + ' UNIFORM CREEP EXPONENT IN CRUST.' + /' YOUR INPUT VALUE FOR THE LOWER CRUST HAS ', + ' BEEN CHANGED TO MAKE THIS TRUE.') ENDIF WRITE(6,106) ECREEP(2) 106 FORMAT(' ',F10.6,' N/A STRAIN-RATE EXPONENT FOR ', + 'LOWER CRUST, BELOW CONRAD') READ(5,*) BCREEP(1),BCREEP(3) WRITE(6,107) BCREEP(1),BCREEP(3) 107 FORMAT(' ',2F10.0,' B FOR CREEP =(ACTIVATION ENERGY)/R/N (IN K)') READ(5,*) BCREEP(2) WRITE(6,108) BCREEP(2) 108 FORMAT(' ',F10.0,' N/A B FOR CREEP OF LOWER CRUST,', + ' BELOW CONRAD') READ(5,*) CCREEP(1),CCREEP(3) WRITE(6,109) CCREEP(1),CCREEP(3) 109 FORMAT(' ',1P,2E10.2,' C FOR CREEP = DERIVATIVE OF B WITH', + ' RESPECT TO DEPTH') READ(5,*) CCREEP(2) WRITE(6,110) CCREEP(2) 110 FORMAT(' ',1P,E10.2,' N/A C FOR CREEP OF LOWER CRUST,', + ' BELOW CONRAD') READ(5,*) DCREEP(1),DCREEP(3) WRITE(6,111) DCREEP(1),DCREEP(3) 111 FORMAT(' ',1P,2E10.2,' MAXIMUM SHEAR STRESS UNDER ANY', + ' CONDITIONS') READ(5,*) DCREEP(2) WRITE(6,112) DCREEP(2) 112 FORMAT(' ',1P,E10.2,' N/A MAXIMUM SHEAR FOR LOWER CRUST,', + ' BELOW CONRAD') READ(5,*) CONDUC(1),CONDUC(2) WRITE(6,113) CONDUC(1),CONDUC(2) 113 FORMAT(' ',1P,2E10.2,' THERMAL CONDUCTIVITY (ENERGY/', + 'LENGTH/SEC/DEG)') READ(5,*) DIFFUS(1),DIFFUS(2) WRITE(6,114) DIFFUS(1),DIFFUS(2) 114 FORMAT(' ',1P,2E10.2,' THERMAL DIFFUSIVITY (LENGTH**2/', + 'SEC)') READ(5,*) RADIO(1),RADIO(2) WRITE(6,115) RADIO(1),RADIO(2) 115 FORMAT(' ',1P,2E10.2,' RADIOACTIVE HEAT PRODUCTION', + ' (ENERGY/VOLUME/SEC)') READ(5,*) THICKN(1),THICKN(2) WRITE(6,116) THICKN(1),THICKN(2) 116 FORMAT(' ',1P,2E10.2,' THICKNESS OF LAYER IN NORMAL', + ' CONTINENT') READ(5,*) TEMLIM(1),TEMLIM(2) WRITE(6,117) TEMLIM(1),TEMLIM(2) 117 FORMAT(' ',2F10.0,' CONVECTING TEMPERATURE (TMAX) IN', + ' DEGREES KELVIN') READ(5,*)(RHOBAR(I),I=1,2) WRITE(6,118) RHOBAR(1),RHOBAR(2) 118 FORMAT(' ',1P,2E10.2,' DENSITY,', + ' CORRECTED TO 0 DEGREES KELVIN') READ(5,*) ALPHAT(1),ALPHAT(2) WRITE(6,119) ALPHAT(1),ALPHAT(2) 119 FORMAT(' ',1P,2E10.2,' VOLUMETRIC THERMAL EXPANSION', + ' (1/VOL)*(D.VOL/D.T)') READ(5,*) VPMEAN(1),VPMEAN(2) WRITE(6,120) VPMEAN(1),VPMEAN(2) 120 FORMAT(' ',1P,2E10.2,' MEAN P-WAVE VELOCITY (VP) AT 0 K', + ' AND HIGH PRESSURE') READ(5,*) DVPDT(1),DVPDT(2) WRITE(6,121) DVPDT(1),DVPDT(2) 121 FORMAT(' ',1P,2E10.2,' (1/VP)*(D.VP/D.T): TEMPERATURE', + ' SENSITIVITY OF VP') READ(5,*) DVPBYE(1,1),DVPBYE(1,2) WRITE(6,122) DVPBYE(1,1),DVPBYE(1,2) 122 FORMAT(' ',1P,2E10.2,' (DELTA.VP/VP): STRAIN(EZZ)-INDU', + 'CED ANISOTROPY IN VP') READ(5,*) DVPBYE(2,1),DVPBYE(2,2) WRITE(6,123) DVPBYE(2,1),DVPBYE(2,2) 123 FORMAT(' ',1P,2E10.2,' CHARACTERISTIC STRAIN TO DEVELOP A', + 'NISOTROPY') READ(5,*) RHOAST WRITE(6,124) RHOAST 124 FORMAT(' ',1P,E10.3,' DENSITY OF ASTHENOSPHERE', + ' (ADJUST TO CORRECT ALL ELEVATION)') READ(5,*) RHOH2O WRITE(6,125) RHOH2O 125 FORMAT(' ',1P,E10.2,' DENSITY OF GROUNDWATER, LAKES, AND OCEANS') READ(5,*) BIOT WRITE(6,126) BIOT 126 FORMAT(' ',F10.4,' EFFECTIVE-PRESSURE (BIOT) COEFFICIENT,', + ' 0.0 TO 1.0') BIOT=MAX(0.0,MIN(1.0,BIOT)) READ(5,*) G WRITE(6,127) G 127 FORMAT(' ',1P,E10.2,' GRAVITATIONAL ACCELERATION', + ' (LENGTH/SEC/SEC)') READ(5,*) RADIUS WRITE(6,128) RADIUS 128 FORMAT(' ',1P,E10.2,' RADIUS OF EARTH', + ' (EFFECTIVELY DEFINES YOUR LENGTH UNIT)') READ(5,*) X0ELON WRITE(6,129) X0ELON 129 FORMAT(' ',F10.2,' LONGITUDE OF X/Y ORIGIN IN DEGREES', + ' (EAST = +, WEST = -)') READ(5,*) Y0NLAT WRITE(6,130) Y0NLAT 130 FORMAT(' ',F10.2,' LATITUDE OF X/Y ORIGIN IN DEGREES', + ' (NORTH = +, SOUTH = -)') READ(5,*) CPNLAT WRITE(6,131) CPNLAT 131 FORMAT(' ',F10.2,' LATITUDE OF BASE-MAP CONIC PROJECTION', + ' TANGENT IN DEGREES (NORTH = +)') IF (ABS(CPNLAT).LT.0.01) CPNLAT=0.01 READ(5,*) IBELOW WRITE(6,132) IBELOW 132 FORMAT(' ',I10,' BELOW-INDEX: SELECTS PLATE MODEL USED', + ' FOR BASAL BOUNDARY'/ + ' CONDITIONS: 0=NONE,1=N.AMER./NORTH,', + '2=N.AMER./SOUTH,3=S.AMER.,4=ASIA') READ(5,*) READ(5,*) TSURF WRITE(6,305) TSURF 305 FORMAT(' ',F10.0,' SURFACE TEMPERATURE IN DEGREES KELVIN') READ(5,*) TSLAB0 WRITE(6,133) TSLAB0 133 FORMAT(' ',1P,E10.2,' TEMPERATURE OF SLAB-TOP SHEAR ZONE', + ' AT 1000 KM INLAND, IN KELVIN') READ(5,*) SIGBOT WRITE(6,134) SIGBOT 134 FORMAT(' ',1P,E10.2,' SHEAR STRESS LIMIT ON BASE OF', + ' CONTINENT (MELANGE STRENGTH)') READ(5,*) WANDES WRITE(6,307) WANDES 307 FORMAT(' ',1P,E10.2,' INITIAL WIDTH OF CORDILLERA,', + ' MEASURED TRENCH-TO-PLAINS', + ' (OR 0.0 FOR NONE)') READ(5,*) PUSHHO WRITE(6,135) PUSHHO 135 FORMAT(' ',1P,E10.2,' EXTRA SHEAR STRESS APPLIED TO', + ' "LEFT" MARGIN FOREARC ONLY') READ(5,*) ECLOG WRITE(6,136) ECLOG 136 FORMAT(' ',1P,E10.2,' EXCESS-WEIGHT/UNIT-AREA OF NEW LITHOSPHER', + 'E WITH RESPECT TO ASTHENOSPHERE') READ(5,*) SLABSZ WRITE(6,137) SLABSZ 137 FORMAT(' ',1P,E10.2,' THERMAL EXCESS-WEIGHT/UNIT-AREA', + ' AT 100 MA WITH REPECT TO NEW LITHOSPHERE') READ(5,*) PUSHUP WRITE(6,138) PUSHUP 138 FORMAT(' ',1P,E10.2,' NON-ISOSTATIC FLEXURAL UPLIFT BY SLAB,', + ' (IN THE FOREARC REGION ONLY)') READ(5,*) WRITE(6,12) 12 FORMAT(/ / /' ============== TACTICAL PARAMETERS', + ' (HOW TO FIND THE SOLUTION) ============') READ(5,*) NELROW WRITE(6,201) NELROW 201 FORMAT(/ / /' ',I10,' NUMBER OF ROWS OF 2-ELEMENT', + ' QUADRILATERALS (ROWS ARE PERPENDICULAR TO TRENCH)') READ(5,*) NELCOL WRITE(6,202) NELCOL 202 FORMAT(' ',I10,' NUMBER OF COLUMNS OF 2-ELEMENT', + ' QUADRILATERALS (COLUMNS ARE PARALLEL TO TRENCH)') READ(5,*) BEGAGE WRITE(6,203) BEGAGE 203 FORMAT(' ',1P,E10.4,' BEGINNING OF CALCULATION', + ' (POSITIVE SECONDS BEFORE PRESENT)') READ(5,*) DELTAT WRITE(6,204) DELTAT 204 FORMAT(' ',1P,E10.4,' SIZE OF TIME STEPS (POSITIVE', + ' SECONDS); MAY BE REDUCED BY PROGRAM') READ(5,*) ENDAGE WRITE(6,205) ENDAGE 205 FORMAT(' ',1P,E10.4,' ENDING OF CALCULATION', + ' (POSITIVE SECONDS BEFORE PRESENT)') READ(5,*) DXMAX WRITE(6,206) DXMAX 206 FORMAT(' ',1P,E10.2,' MAXIMUM HORIZONTAL DISPLACEMENT OF ANY' + ,' NODE IN ONE TIME STEP') READ(5,*) DTHMAX WRITE(6,207) DTHMAX 207 FORMAT(' ',1P,E10.2,' MAXIMUM CHANGE IN LAYER THICKNESS BY PURE' + ,' SHEAR ALLOWED IN ONE TIME STEP') READ(5,*) RAMP WRITE(6,208) RAMP 208 FORMAT(' ',1P,E10.2,' WIDTH OF LINEAR RAMP SMOOTHING OF SLAB', + ' WEIGHT') READ(5,*) NDIFUS WRITE(6,209) NDIFUS 209 FORMAT(' ',I10,' MAXIMUM NUMBER OF CRUSTAL-THICKNESS', + ' SMOOTHINGS EACH TIMESTEP (ABOUT 1000)') READ(5,*) MAXITR WRITE(6,210) MAXITR 210 FORMAT(' ',I10,' MAXIMUM ITERATIONS WITHIN VELOCITY SOLUTION', + ' IN EACH TIMESTEP') READ(5,*) OKTOQT WRITE(6,211) OKTOQT 211 FORMAT(' ',F10.6,' ACCEPTABLE RMS FRACTIONAL ERR0R (STOPS', + ' ITERATION EARLY)') READ(5,*) VISMAX WRITE(6,212) VISMAX 212 FORMAT(' ',1P,E10.2,' MAXIMUM AVERAGE VISCOSITY ALLOWED FOR ANY', + ' LAYER (APPLIES TO WHOLE THICKNESS, NOT LOCALLY)') READ(5,*) ETAMAX WRITE(6,213) ETAMAX 213 FORMAT(' ',1P,E10.2,' MAXIMUM LAYER/LAYER COUPLING ALLOWED', + ' (STRESS/VELOCITY-DIFFERENCE)') READ(5,*) READ(5,*) HMIN(1),HMIN(2) WRITE(6,214) HMIN(1),HMIN(2) 214 FORMAT(/' CRUST MANTLE\ LIMITS ON LAYER THICKNESSES:'/ + ' ',1P,2E10.2,' MINIMUM THICKNESS', + ' (TRIGGERS VOLUME ADDITION)') READ(5,*) HMAX(1),HMAX(2) WRITE(6,215) HMAX(1),HMAX(2) 215 FORMAT(' ',1P,2E10.2,' MAXIMUM THICKNESS', + ' (TRIGGERS VOLUME REDUCTION)') READ(5,*) ALLREP WRITE(6,216) ALLREP 216 FORMAT(' ',L10,' ALLREP: SHOULD REPORTS BE PRODUCED', + ' AT EVERY TIMESTEP ? (USE ONLY FOR DEBUGGING)') READ(5,*) MIDREP WRITE(6,217) MIDREP 217 FORMAT(' ',I10,' NUMBER OF INTERMEDIATE REPORTS (WHEN ALLREP=F)') READ(5,*) TAPE9 WRITE(6,218) TAPE9 218 FORMAT(' ',L10,' THAT DETAILED REPORTS ARE OUTPUT ON DEVICE 9', + ' (USUALLY T)') READ(5,*) WRITE(6,13) 13 FORMAT(/ / /' ================== INITIALIZATION PARAMETERS', + ' (INITIAL CONDITIONS) ========') READ(5,*) RESTRT WRITE(6,301) RESTRT 301 FORMAT(/ / /' ',L10,' RESTART: IF = T, THEN RESTART FROM OLD', + ' REPORT; READ FROM DEVICE 8') READ(5,*) KTAPE WRITE(6,302) KTAPE 302 FORMAT(' ',I10,' IF (RESTART): ORDINAL NUMBER OF OLD REPORT', + ' IN DEVICE 8 FILE') READ(5,*) WRITE(6,14) 14 FORMAT(' ------- NEXT LINES ARE USED ONLY IF RESTRT = F', + '--------------------------') READ(5,*) CONRAD WRITE(6,303) CONRAD 303 FORMAT(' ',1P,E10.2,' INITIAL DEPTH OF CONRAD DISCONTINUITY', + ' IN THE CRUST OF THE PLAINS') READ(5,*) DQDTDA WRITE(6,304) DQDTDA 304 FORMAT(' ',1P,E10.2,' INITIAL HEAT-FLOW OF PLAINS', + ' (ENERGY/LENGTH**2/SEC)') READ(5,*) APLANO WRITE(6,306) APLANO 306 FORMAT(' ',1P,E10.2,' INITIAL HEIGHT OF ALTIPLANO IN CORDILLERA', + ' (OR 0.0 FOR NONE)') IF ((APLANO.LE.0.0).AND.(.NOT.RESTRT)) WANDES=0.0 READ(5,*) VDECOL WRITE(6,308) VDECOL 308 FORMAT(' ',1P,E10.2,' GROSS ESTIMATE OF DETACHMENT', + ' VELOCITY BETWEEN CRUST AND MANTLE') READ(5,*) OLDGRD IF (RESTRT) OLDGRD=.FALSE. WRITE(6,309) OLDGRD 309 FORMAT(' ',L10,' OLDGRD : SHALL EXISTING GRID OF NODES', + ' BE READ (FROM DEVICE 8, IN TRUNCATED REPORT FORMAT)?') READ(5,*) READ(5,*) WRITE(6,15) 15 FORMAT(' -------- FOLLOWING LINES DEFINE AN AUTOMATICALLY-', + 'GENERATED GRID, AND -----'/ + ' ----------- ARE USED ONLY IF RESTRT = F AND ', + 'OLDGRD = F -----------------') READ(5,*) GWIDE WRITE(6,310) GWIDE 310 FORMAT(' ',1P,E10.3,' "WIDTH" OF GRID FROM "LEFT"', + ' (TRENCH SIDE) TO "RIGHT" (INLAND SIDE)') READ(5,*) GHIGH WRITE(6,311) GHIGH 311 FORMAT(' ',1P,E10.3,' "HEIGHT" OF GRID FROM "TOP"', + ' (NODE ROW 1) TO "BOTTOM" (LAST ROW)') READ(5,*) GANGLE WRITE(6,312) GANGLE 312 FORMAT(' ',F10.2,' ANGLE GRID IS ROTATED FROM', + ' ("RIGHT"= +X, "TOP" = +Y), IN DEGREES COUNTERCLOCKWISE') READ(5,*,END=3129) 3129 WRITE(6,16) 16 FORMAT(/ / /' ===== POST-PROCESSING PLOT CONTROL PARAMETERS', + ' (NOT USED BY LARAMY) =====') READ(5,*) KTIME WRITE(6,401) KTIME 401 FORMAT(/ / / + ' ',I10,' ORDINAL NUMBER OF REPORT ON UNIT8 TO BE PLOTTED' + ,','/11X,' OR 999 TO PLOT LAST REPORT IN THE DATASET' + ,','/11X,' OR 0 TO PLOT ALL REPORTS IN THE DATASET') DO 4022 I=1,24 READ(5,4021) DOPLOT(I),CINT(I),FBLAND(I),LOWBLU(I) 4021 FORMAT(L10,2E10.2,I2) 4022 CONTINUE WRITE(6,402) DOPLOT( 1),CINT( 1),FBLAND(1),LOWBLU(1) WRITE(6,403) DOPLOT( 2),CINT( 2),FBLAND(2),LOWBLU(2) WRITE(6,404) DOPLOT( 3),CINT( 3),FBLAND(3),LOWBLU(3) WRITE(6,405) DOPLOT( 4),CINT( 4),FBLAND(4),LOWBLU(4) WRITE(6,406) DOPLOT( 5),CINT( 5),FBLAND(5),LOWBLU(5) WRITE(6,407) DOPLOT( 6),CINT( 6),FBLAND(6),LOWBLU(6) WRITE(6,408) DOPLOT( 7),CINT( 7),FBLAND(7),LOWBLU(7) WRITE(6,409) DOPLOT( 8),CINT( 8),FBLAND(8),LOWBLU(8) WRITE(6,410) DOPLOT( 9),CINT( 9),FBLAND(9),LOWBLU(9) WRITE(6,411) DOPLOT(10),CINT(10),FBLAND(10),LOWBLU(10) WRITE(6,412) DOPLOT(11),CINT(11),FBLAND(11),LOWBLU(11) WRITE(6,413) DOPLOT(12),CINT(12),FBLAND(12),LOWBLU(12) WRITE(6,414) DOPLOT(13),CINT(13),FBLAND(13),LOWBLU(13) WRITE(6,415) DOPLOT(14),CINT(14),FBLAND(14),LOWBLU(14) WRITE(6,416) DOPLOT(15),CINT(15),FBLAND(15),LOWBLU(15) WRITE(6,417) DOPLOT(16),CINT(16),FBLAND(16),LOWBLU(16) WRITE(6,418) DOPLOT(17),CINT(17),FBLAND(17),LOWBLU(17) WRITE(6,419) DOPLOT(18),CINT(18),FBLAND(18),LOWBLU(18) WRITE(6,420) DOPLOT(19),CINT(19),FBLAND(19),LOWBLU(19) WRITE(6,421) DOPLOT(20),CINT(20),FBLAND(20),LOWBLU(20) WRITE(6,422) DOPLOT(21),CINT(21),FBLAND(21),LOWBLU(21) WRITE(6,423) DOPLOT(22),CINT(22),FBLAND(22),LOWBLU(22) WRITE(6,424) DOPLOT(23),CINT(23),FBLAND(23),LOWBLU(23) WRITE(6,425) DOPLOT(24),CINT(24),FBLAND(24),LOWBLU(24) 402 FORMAT(L11,1P,2E10.2,I2,' MANTLE BASAL SHEAR STRESS') 403 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL BASAL SHEAR STRESS') 404 FORMAT(L11,1P,2E10.2,I2,' MANTLE VELOCITY VECTORS') 405 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL VELOCITY VECTORS') 406 FORMAT(L11,1P,2E10.2,I2,' MANTLEGREATEST PRINCIPAL STRAIN RATES') 407 FORMAT(L11,1P,2E10.2,I2,' CRUST GREATEST PRINCIPAL STRAIN RATES') 408 FORMAT(L11,1P,2E10.2,I2,' MANTLE PRINCIPAL STRESS ANOMALY' + , ' INTEGRALS') 409 FORMAT(L11,1P,2E10.2,I2,' CRUST PRINCIPAL STRESS ANOMALY' + ,' INTEGRALS') 410 FORMAT(L11,1P,2E10.2,I2,' MANTLE GRID OF ELEMENTS') 411 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL GRID OF ELEMENTS') 412 FORMAT(L11,1P,2E10.2,I2,' MANTLE RATE OF THICKENING') 413 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL RATE OF THICKENING') 414 FORMAT(L11,1P,2E10.2,I2,' MANTLE THICKNESS') 415 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL THICKNESS') 416 FORMAT(L11,1P,2E10.2,I2,' MANTLE BASAL TEMPERATURE') 417 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL BASAL TEMPERATURE') 418 FORMAT(L11,1P,2E10.2,I2,' TELESEISMIC P TRAVEL-TIME RESIDUAL') 419 FORMAT(L11,1P,2E10.2,I2,' ISOSTATIC ELEVATIONS') 420 FORMAT(L11,1P,2E10.2,I2,' PALEO-HEAT-FLOW') 421 FORMAT(L11,1P,2E10.2,I2,' ELEVATIONS AFTER DELAMINATION') 422 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL LOG GREAT PRINCIPAL STRAIN') 423 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL ROTATION') 424 FORMAT(L11,1P,2E10.2,I2,' UPPER CRUSTAL THICKNESS') 425 FORMAT(L11,1P,2E10.2,I2,' LOWER CRUSTAL THICKNESS') READ(5,*) SCALEC WRITE(6,426)SCALEC 426 FORMAT(' ',1PE10.2,' SCALE OF PLOTS,', + ' (INPUT LENGTH UNITS)/(CM OF PLOT)') READ(5,*) NCONTR NCONTR=MAX(NCONTR,1) WRITE(6,427)NCONTR 427 FORMAT(' ',I10,' APPROXIMATE NUMBER OF CONTOURS IN PLOTS', + ' WHEN CINT=0 (AUTO-SCALED)') READ(5,*) STATES,RETRO WRITE(6,428)STATES,RETRO 428 FORMAT('0',L10,' THAT STATE OUTLINES ARE SUPERPOSED', + ' AND ',L1,' THAT THEY ARE RETRO-DEFORMED') READ(5,*) IPENCT IPENCT=MIN(IPENCT,31) IPENCT=MAX(IPENCT,1) WRITE(6,429)IPENCT 429 FORMAT(' ',I10,' PEN WEIGHT FOR CONTOURS ') READ(5,*) IPENST IPENST=MIN(IPENST,31) IPENST=MAX(IPENST,1) WRITE(6,430)IPENST 430 FORMAT(' ',I10,' PEN WEIGHT FOR STATE LINES') READ(5,*) IPENLB IPENLB=MIN(IPENLB,31) IPENLB=MAX(IPENLB,1) WRITE(6,431)IPENLB 431 FORMAT(' ',I10,' PEN WEIGHT FOR TEXT LABELS') READ(5,*) RMSVEC WRITE(6,432)RMSVEC 432 FORMAT(' ',F10.3,' RMS LENGTH OF PLOTTED VECTORS', + ' (AND TENSOR PRINCIPAL AXES), IN INCHES') READ(5,*) COLOR WRITE(6,433) COLOR 433 FORMAT(' ',L10,' THAT OUTPUT WILL BE IN COLOR (ELSE B & W)') WRITE(6,17) 17 FORMAT(/ / /' ==========================================', + '=========================================') RETURN END C C C SUBROUTINE SETDIM (N50,N121,N9922,NEXTRA,NXL, + NCDIM,NDIFF,NELROW,NELCOL,NUMNOD, + NUMEL,DIMERR) C C CALCULATES AMOUNTS OF VARIABLE STORAGE SPACE NEEDED VS. AVAILABLE C LOGICAL DIMERR DATA NXEL/1011/,NXNOD/20/,NXCDIM/2/,NXXTR/1/ NUMEL=2*NELROW*NELCOL NUMNOD=(2*NELROW+1)*(2*NELCOL+1) NDIFF=2*(2*NELCOL+1) NCDIM=(3*NDIFF+16)*NUMNOD C NCDIM IS PER CONVENTIONS OF SUBROUTINE LIBRARY ESSL, BANDED MATRIX NXL=NUMNOD I11=NUMEL*NXEL I12=N50*NXEL I21=NUMNOD*NXNOD I22=N121*NXNOD I41=NCDIM*NXCDIM I42=N9922*NXCDIM I51=NXL*NXXTR I52=NEXTRA*NXXTR NSUM1=I11+I21+I41+I51 NSUM2=I12+I22+I42+I52 WRITE(6,1)NUMEL,N50,NXEL,I11,I12, + NUMNOD,N121,NXNOD,I21,I22, + NCDIM,N9922,NXCDIM,I41,I42, + NXL,NEXTRA,NXXTR,I51,I52, + NSUM1,NSUM2 1 FORMAT('1VARIABLE STORAGE REPORT FROM SUBR "SETDIM":'/ / / / + ' VARIABLE = FORMULA',29X,' = VALUE VS.ALLOWED', + ' MULTIPLIER WORDS-USED WORDS-ALLOWED'/ / + '0NUMEL = 2*NELROW*NELCOL ',10X,'=', + I7,I12,I12,I12,I15/ + '0NUMNOD = (2*NELROW+1)*(2*NELCOL+1) ','=', + I7,I12,I12,I12,I15/ + '0NCDIM = NUMNOD*(3*NDIFF+16)',15X,'=', + I7,I12,I12,I12,I15/ + ' NDIFF=2*(2*NELCOL+1)'/ + '0NXL = NUMNOD',28X,'=', + I7,I12,I12,I12,I15/ + 78X,' _______ _______'/ + 78X,I12,I15) DIMERR=(NUMEL.GT.N50).OR. + (NUMNOD.GT.N121).OR. + (NCDIM.GT.N9922).OR. + (NXL.GT.NEXTRA) 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, N121,', + ' NEXTRA, AND/OR N9922', + ' IN PROGRAM DRAW 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 PAST(ACREEP,ALPHAC,ALPHAM,ALPHAT,AREAC,AREAM,BCREEP, 2 BIOT,CCREEP,CODE,CONDNS,CONINT,CONNOD,CONRAD, 3 DCREEP,DELVC,DELVM,DETJC,DETJM, 4 DNLINK,DVB,DVT,DXSC,DXSM,DYSC,DYSM,ECLOG,ECREEP, 5 ERATEC,ERATEM,ESUMC,ESUMM,ETAMAX,FLOWIN,FLUXC, 6 FLUXM,FRIC,G,GEOTHA,GEOTHC,GEOTHM,GLUEC,GLUEM, 7 KTIME,LISTOP,LWORK,NCDIM,NDIFF,NELCOL, 8 NODES,NUMEL,NUMNOD,NXL,ONEKM,OUTSCA,OUTVEC, 9 OUTV2,OVA,OVB,PTSC,PTSM,PUSHHO,PUSHUP,RADIUS, A RAMP,RHOAST,RHOH2O,RHOBAR,SIGBOT,SIGHC, 1 SIGHBM,SIGHTM,SIGZZC,SIGZZM,SLABSZ, 2 CPNLAT,IBELOW,X0ELON,Y0NLAT,SZZBC,SZZBM, 3 TASTH,TAUMTC,TAUMTM,TAUZZC,TAUZZM,TEMLIM, 4 THIKC,THIKM,TIME,THNKC,THNKM,TOFSTC,TOFSTM, 5 TOUCHC,TOUCHM,TSLAB0,TSURF,UPLINK,VC,VM,VISMAX, 6 VSLABC,VSLABM,WC,WM,XIPC,XIPM, 7 XNODC,XNODM,YIPC,YIPM,YNODC,YNODM, 8 ALDONE,NELROW,FROMWC,FROMWM,WANDES, 9 NTREAD,TITLE,HMAX,HMIN) C C RE-ESTABLISHES ALL IN-PROGRESS ARRAYS FROM REPORT ON "TAPE" C PREVIOUSLY WRITTEN BY SUBROUTINE "TAPE". C DOUBLE PRECISION CODE,FLOWIN LOGICAL ALDONE,CRUST,FAILUR,LISTOP,LOCKIN,LOCKWC,MANTLE DIMENSION ACREEP(2),ALPHAC(3,3,7,NUMEL),ALPHAM(3,3,7,NUMEL), 2 ALPHAT(2),AREAC(NUMEL),AREAM(NUMEL),BCREEP(2), 3 CCREEP(2),CODE(NCDIM),CONDNS(NUMNOD), 4 CONINT(7,NUMEL),CONNOD(NUMNOD),DCREEP(2), 5 DELVC(2,7,NUMEL),DELVM(2,7,NUMEL),DETJC(7,NUMEL), 6 DETJM(7,NUMEL),DNLINK(3,7,NUMEL),DVB(7,NUMEL), 7 DVT(7,NUMEL),DXSC(6,7,NUMEL),DXSM(6,7,NUMEL), 8 DYSC(6,7,NUMEL),DYSM(6,7,NUMEL),ECREEP(2), 9 ERATEC(4,7,NUMEL),ERATEM(4,7,NUMEL), A ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL),FLOWIN(NUMNOD), 1 FLUXC(7,NUMEL),FLUXM(7,NUMEL),FRIC(2), 2 FROMWC(7,NUMEL),FROMWM(7,NUMEL),GEOTHA(4,7,NUMEL), 3 GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL),GLUEC(7,NUMEL), 4 GLUEM(7,NUMEL),HMAX(2),HMIN(2),LISTOP(NUMEL),LWORK(NXL) 5 ,NODES(6,0:NUMEL),OUTSCA(7,NUMEL),OUTVEC(2,7,NUMEL), 6 OUTV2(2,7,NUMEL),OVA(2,7,NUMEL),OVB(2,7,NUMEL), 7 PTSC(2,7,NUMEL),PTSM(2,7,NUMEL),RHOBAR(2), 8 SIGHC(2,7,NUMEL),SIGHBM(2,7,NUMEL),SIGHTM(2,7,NUMEL), 9 SIGZZC(7,NUMEL),SIGZZM(7,NUMEL),SZZBC(7,NUMEL) DIMENSION SZZBM(7,NUMEL),TAUMTC(3,7,NUMEL),TAUMTM(3,7,NUMEL), 2 TAUZZC(7,NUMEL),TAUZZM(7,NUMEL),TEMLIM(2), 3 THIKC(7,NUMEL),THIKM(7,NUMEL),THNKC(NUMNOD), 4 THNKM(NUMNOD),TOFSTC(3,7,NUMEL),TOFSTM(3,7,NUMEL), 5 TOUCHC(7,NUMEL),TOUCHM(7,NUMEL),UPLINK(3,7,NUMEL), 6 VC(2,NUMNOD),VM(2,NUMNOD),VSLABC(2,7,NUMEL), 7 VSLABM(2,7,NUMEL),WC(NUMNOD),WM(NUMNOD),XIPC(7,NUMEL), 8 XIPM(7,NUMEL),XNODC(NUMNOD),XNODM(NUMNOD), 9 YIPC(7,NUMEL),YIPM(7,NUMEL),YNODC(NUMNOD), A YNODM(NUMNOD) TEMPM(Z,M,I)=MIN(TEMLIM(2),GEOTHM(1,M,I) + +GEOTHM(2,M,I)*Z + +GEOTHM(3,M,I)*Z**2 + +GEOTHM(4,M,I)*Z**3) CALL GOON (KTIME,NTREAD,TITLE,TIME, + XNODC,XNODM,YNODC,YNODM,THNKC,CONNOD,THNKM, + GEOTHC,GEOTHM,GEOTHA,VC,VM,WC,WM,ESUMC,ESUMM, + NUMNOD,NUMEL,ALDONE) CALL INTERP (XNODC,NODES,NUMEL,NUMNOD,XIPC) CALL INTERP (YNODC,NODES,NUMEL,NUMNOD,YIPC) CALL INTERP (XNODM,NODES,NUMEL,NUMNOD,XIPM) CALL INTERP (YNODM,NODES,NUMEL,NUMNOD,YIPM) CALL INTERP (THNKC,NODES,NUMEL,NUMNOD,THIKC) CALL INTERP (THNKM,NODES,NUMEL,NUMNOD,THIKM) CALL INLAND (INPUT,XIPC,YIPC,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMWC) CALL INLAND (INPUT,XIPM,YIPM,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMWM) DO 10 M=1,7 DO 9 I=1,NUMEL THIKC(M,I)=MAX(THIKC(M,I),HMIN(1)) THIKM(M,I)=MAX(THIKM(M,I),HMIN(2)) THIKC(M,I)=MIN(THIKC(M,I),HMAX(1)) THIKM(M,I)=MIN(THIKM(M,I),HMAX(2)) 9 CONTINUE 10 CONTINUE TASTH=TEMPM(THIKM(5,NUMEL),5,NUMEL) CALL AREAS (NODES,AREAC,XNODC,YNODC,NUMNOD,NUMEL) CALL AREAS (NODES,AREAM,XNODM,YNODM,NUMNOD,NUMEL) CALL DERIV (NUMEL,NUMNOD,NODES,XNODC,YNODC,AREAC, + DETJC,DXSC,DYSC,NUMBAD,LISTOP) CALL DERIV (NUMEL,NUMNOD,NODES,XNODM,YNODM,AREAM, + DETJM,DXSM,DYSM,NUMBAD,LISTOP) LOCKIN=.FALSE. LOCKWC=.FALSE. CALL INTERP (CONNOD,NODES,NUMEL,NUMNOD,CONINT) CALL LINKER (NELCOL,NUMEL,XIPM,YIPM, + DETJC,XIPC,YIPC,XNODC,YNODC, + NUMNOD,NODES,AREAC,UPLINK,FAILUR) CALL LINKER (NELCOL,NUMEL,XIPC,YIPC, + DETJM,XIPM,YIPM,XNODM,YNODM, + NUMNOD,NODES,AREAM,DNLINK,FAILUR) DO 60 K=1,3 DO 59 M=1,7 DO 58 I=1,NUMEL TOFSTC(K,M,I)=0. TOFSTM(K,M,I)=0. ALPHAC(1,K,M,I)=0. ALPHAM(1,K,M,I)=0. ALPHAC(2,K,M,I)=0. ALPHAM(2,K,M,I)=0. ALPHAC(3,K,M,I)=0. ALPHAM(3,K,M,I)=0. 58 CONTINUE 59 CONTINUE 60 CONTINUE CALL EDOT (NUMEL,NODES,VC,NUMNOD,DXSC,DYSC,ERATEC, + ALPHAC,TOFSTC,TAUMTC) CALL EDOT (NUMEL,NODES,VM,NUMNOD,DXSM,DYSM,ERATEM, + ALPHAM,TOFSTM,TAUMTM) CALL BELOW (INPUT,CPNLAT,ECLOG,FROMWC,IBELOW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME,WANDES, + XIPC,YIPC,X0ELON,Y0NLAT, + OUTPUT,SZZBC,TOUCHC,VSLABC) CALL BELOW (INPUT,CPNLAT,ECLOG,FROMWM,IBELOW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME,WANDES, + XIPM,YIPM,X0ELON,Y0NLAT, + OUTPUT,SZZBM,TOUCHM,VSLABM) CALL SETCUB (THIKM,NUMEL,GEOTHM,GEOTHA,OUTSCA,TASTH, + THIKC,GEOTHC,DNLINK,TOUCHC,TOUCHM,TSLAB0, + AREAM,CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NODES,NUMNOD,NXL,LWORK, + TSURF,FROMWC,FROMWM,ONEKM) CRUST=.TRUE. CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATEC,FRIC,G,GEOTHC, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIKC,THNKC,UPLINK, + OUTPUT,FLUXC,GLUEC, + WORK,OUTVEC,OUTSCA,OUTV2) CRUST=.FALSE. CALL ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATEM,FRIC,G,GEOTHM, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIKM,THNKC,UPLINK, + OUTPUT,FLUXM,GLUEM, + WORK,OUTVEC,OUTSCA,OUTV2) CALL SQUEZE (G,CONDNS,TOUCHC,TOUCHM,SZZBC,SZZBM, + GEOTHA,GEOTHC,GEOTHM,NUMEL,THIKC,THIKM,TEMLIM, + ALPHAT,RHOBAR,DNLINK,UPLINK,SIGZZC,SIGZZM, + OUTSCA,THNKC,THNKM,DXSC,DXSM,DYSC,DYSM, + TAUZZC,TAUZZM,ONEKM,RHOH2O,RHOAST, + NODES,NUMNOD,PTSC,PTSM, + AREAC,AREAM,CODE,DETJC,DETJM,FAILUR,FLOWIN, + NCDIM,NDIFF,NXL,LWORK,ECLOG,HMAX,HMIN) CALL EXTRAP (AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,GLUEC,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DO 200 M=1,7 DO 100 I=1,NUMEL OUTV2(1,M,I)=OUTSCA(M,I) 100 CONTINUE 200 CONTINUE C C OUTV2(1,M,I) HOLDS GLUEC VALUE AT MANTLE INTEGRATION POINTS M,I C CALL GETSCA (INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) C C OUTSCA HOLDS CRUSTAL THICKNESSES AT MANTLE INTEGRATION POINTS C CALL THONM (NUMEL,NODES,NUMNOD,VM, + SIGHBM,SIGHTM,TOUCHM,VSLABM, + SIGBOT,GLUEM,ECREEP,DELVM,OUTVEC,OUTV2, + ETAMAX,UPLINK,VC,RHOBAR, + G,THIKM,FRIC,VISMAX,DVB,DVT,OVA,OVB, + OUTSCA) CALL THONC (NUMEL,NODES,NUMNOD,VC, + DNLINK,VM,DELVC,GLUEC,ECREEP,SIGHC, + SIGBOT,TOUCHC,VSLABC, + RHOBAR,G,THIKC,FRIC,VISMAX,DVB,OVB, + OUTVEC,ETAMAX,PUSHHO,FROMWC,WANDES) CALL GETSCA (INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) C C OUTSCA HOLDS CRUSTAL THICKNESSES AT MANTLE INTEGRATION POINTS C MANTLE=.FALSE. CALL VISCOS (SCOREC,SCORED,VISMAX,NUMEL,CONINT, + ALPHAC,ERATEC,TAUMTC,TOFSTC,THIKC,GEOTHC, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,RHOBAR,FRIC,TEMLIM, + OUTSCA,SIGHC) MANTLE=.TRUE. CALL VISCOS (SCOREC,SCORED,VISMAX,NUMEL,CONINT, + ALPHAM,ERATEM,TAUMTM,TOFSTM,THIKM,GEOTHM, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,RHOBAR,FRIC,TEMLIM, + OUTSCA,SIGHBM) CALL EDOT (NUMEL,NODES,VC,NUMNOD,DXSC,DYSC,ERATEC, + ALPHAC,TOFSTC,TAUMTC) CALL EDOT (NUMEL,NODES,VM,NUMNOD,DXSM,DYSM,ERATEM, + ALPHAM,TOFSTM,TAUMTM) RETURN END C C C SUBROUTINE GOON (KTIME,NTREAD,TITLE,TIME, + XNODC,XNODM,YNODC,YNODM,THNKC,CONNOD,THNKM, + GEOTHC,GEOTHM,GEOTHA,VC,VM,WC,WM,ESUMC,ESUMM, + NUMNOD,NUMEL,ALDONE) C C READS 'TAPE' WITH THE ARRAYS NEEDED IN ORDER TO C RESTART PROGRAM OR COMPUTE A SET OF PLOTS; C ONLY ESSENTIAL INTEGRATED VARIABLES ARE READ; C PARAMETERS MUST BE RE-INPUT BY "INPUT", AND ALL C RECONSTRUCTABLE ARRAYS MUST BE RECOMPUTED. C CHARACTER*80 TITLE LOGICAL ALDONE DIMENSION CONNOD(NUMNOD),ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL), + GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), + THNKC(NUMNOD),THNKM(NUMNOD), + VC(2,NUMNOD),VM(2,NUMNOD), + WC(NUMNOD),WM(NUMNOD), + XNODC(NUMNOD),XNODM(NUMNOD), + YNODC(NUMNOD),YNODM(NUMNOD) C 1001 FORMAT(A80) 1002 FORMAT(1P,8E9.2) 1003 FORMAT(0P,8F9.5) 1004 FORMAT(10X,E10.4) 1005 FORMAT(1P,6E13.6) 1006 FORMAT(1P,8E10.3) 1007 FORMAT(0P,F10.3,1P,3E10.3,0P,F10.3,1P,3E10.3) 2005 FORMAT(' TIME = ',1P,E10.4,' (',0P,F7.3,')') 2006 FORMAT('0FOLLOWING DATASET WAS READ FOR SOURCE OF PLOTS:'/ + '0',A80/'0LAST TIME IN FOLLOWING LIST IS THE ONE PLOTTED:' + ) C ALDONE=.FALSE. TITLE=' '// + ' ' READ (8,1001,END=8001) TITLE WRITE(6,2006) TITLE DO 2000 ITIME=1,KTIME IF (ITIME.GT.1) THEN TITLE=' '// + ' ' READ (8,1001,END=8001) TITLE END IF READ (8,1004) TIME TMY=TIME/3.15576E13 WRITE(6,2005) TIME,TMY NTREAD=NTREAD+1 READ (8,1001) READ (8,1005) (XNODC(I),I=1,NUMNOD) READ (8,1001) READ (8,1005) (XNODM(I),I=1,NUMNOD) READ (8,1001) READ (8,1005) (YNODC(I),I=1,NUMNOD) READ (8,1001) READ (8,1005) (YNODM(I),I=1,NUMNOD) READ (8,1001) READ (8,1006) (THNKC(I),I=1,NUMNOD) READ (8,1001) READ (8,1006) (CONNOD(I),I=1,NUMNOD) READ (8,1001) READ (8,1006) (THNKM(I),I=1,NUMNOD) READ (8,1001) READ (8,1007) (((GEOTHC(I,J,K),I=1,4),J=1,7),K=1,NUMEL) READ (8,1001) READ (8,1007) (((GEOTHM(I,J,K),I=1,4),J=1,7),K=1,NUMEL) READ (8,1001) READ (8,1007) (((GEOTHA(I,J,K),I=1,4),J=1,7),K=1,NUMEL) READ (8,1001) READ (8,1005) ((VC(I,J),I=1,2),J=1,NUMNOD) READ (8,1001) READ (8,1005) ((VM(I,J),I=1,2),J=1,NUMNOD) READ (8,1001) READ (8,1002) (WC(I),I=1,NUMNOD) READ (8,1001) READ (8,1002) (WM(I),I=1,NUMNOD) READ (8,1001) READ (8,1003) ((ESUMC(1,1,J,K),ESUMC(1,2,J,K), + ESUMC(2,1,J,K),ESUMC(2,2,J,K),J=1,7), + K=1,NUMEL) READ (8,1001) READ (8,1003,END=9001) ((ESUMM(1,1,J,K),ESUMM(1,2,J,K), + ESUMM(2,1,J,K),ESUMM(2,2,J,K),J=1,7), + K=1,NUMEL) 2000 CONTINUE RETURN C C CODE FOR CASE OF MISSING NEXT REPORT C 8001 ALDONE=.TRUE. RETURN C C CODE FOR CASE OF INCOMPLETE LAST REPORT C 9001 DO 9005 I=1,2 DO 9004 J=1,2 DO 9003 K=1,7 DO 9002 L=1,NUMEL ESUMM(I,J,K,L)=0. 9002 CONTINUE 9003 CONTINUE 9004 CONTINUE 9005 CONTINUE WRITE(6,9006) 9006 FORMAT('0INPUT TAPE WAS TRUNCATED WITHIN ARRAY ESUMM;'/ + '0THIS ARRAY HAS BEEN SET TO ZERO;'/ + '0PREDICTIONS OF TELESEISMIC TRAVEL-TIME WILL NOT', + ' BE ACCURATE UNLESS D(VP)/D(E) = 0.') RETURN END C C C SUBROUTINE GOTOND (INPUT,NUMNOD, + OUTPUT,XNODCE,YNODCE) C C READS "TAPE" WITH THE FINAL LOCATIONS OF CRUST NODES ON DEVICE 12. C CHARACTER*80 TITLE DIMENSION XNODCE(NUMNOD), + YNODCE(NUMNOD) 1001 FORMAT(A80) 1002 FORMAT(1P,8E9.2) TITLE=' '// + ' ' READ (12,1001) TITLE READ (12,1004) TIME 1004 FORMAT(10X,E10.4) 1005 FORMAT(1P,6E13.6) C READ XNODC ARRAY READ (12,1001) READ (12,1005) (XNODCE(I),I=1,NUMNOD) C DUMMY READ TO PASS THROUGH XNODM ARRAY READ (12,1001) READ (12,1005) (YNODCE(I),I=1,NUMNOD) C READ YNODC ARRAY READ (12,1001) READ (12,1005) (YNODCE(I),I=1,NUMNOD) RETURN END C C C SUBROUTINE AREAS (NODES,AREA,XNOD,YNOD,NUMNOD,NUMEL) C C COMPUTE AREAS OF ELEMENTS IN GRID AS IF THEY HAD STRAIGHT C SIDES. EFFECT OF SIDE CURVATURE WILL BE HANDLED LATER BY C MULTIPLYING BY DETERMINANT OF JACOBIAN MATRIX FOR THE SIDE- C BENDING MAPPING. NOTE THAT AREA MAY BE NEGATIVE, BUT ELEMENT C IS OK IF DETERMINANT IN DERIV IS ALSO NEGATIVE. C DIMENSION AREA(NUMEL),NODES(6,0:NUMEL),XNOD(NUMNOD),YNOD(NUMNOD) DO 100 INDEX=1,NUMEL I1=NODES(1,INDEX) I2=NODES(2,INDEX) I3=NODES(3,INDEX) AREA(INDEX)= 0.5*(XNOD(I1)*YNOD(I2)-XNOD(I2)*YNOD(I1) + +XNOD(I2)*YNOD(I3)-XNOD(I3)*YNOD(I2) + +XNOD(I3)*YNOD(I1)-XNOD(I1)*YNOD(I3)) 100 CONTINUE RETURN END C C C SUBROUTINE DERIV (NUMEL,NUMNOD,NODES,XNOD,YNOD,AREA, + DETJ,DXS,DYS,NUMBAD,LISTOP) C C CALCULATES DXS AND DYS, THE X-DERIVITIVE AND Y-DERIVITIVE C OF EACH OF THE 6 NODAL FUNCTIONS OF A DEFORMED-TRIANGLE C FINITE ELEMENT, AT EACH OF THE 7 INTEGRATION POINTS IN C THAT ELEMENT. ALSO PROVIDES DETJ, THE DETERMINANT OF THE C JACOBIAN MATRIX FOR THE TRANSFORMATION IN WHICH INTERNAL C POINTS OF A TRIANGLE WITH STRAIGHT SIDES ARE MAPPED INTO C NEW LOCATIONS AS SIDES BEND (BUT CORNERS STAY FIXED). C DOUBLE PRECISION POINTS LOGICAL LISTOP DIMENSION AREA(NUMEL),B(4),C(4),DETJ(7,NUMEL),DN(6,2), + DXS(6,7,NUMEL),DYS(6,7,NUMEL), + LISTOP(NUMEL),NODES(6,0:NUMEL),POINTS(5,7), + X(6),XNOD(NUMNOD),Y(6),YNOD(NUMNOD) COMMON /L1L2L3/ POINTS NUMBAD=0 DO 500 I=1,NUMEL LISTOP(I)=.FALSE. DO 100 J=1,6 NODE=NODES(J,I) X(J)=XNOD(NODE) Y(J)=YNOD(NODE) 100 CONTINUE B(1)=Y(2)-Y(3) B(2)=Y(3)-Y(1) B(3)=Y(1)-Y(2) B(4)=B(1) C(1)=X(3)-X(2) C(2)=X(1)-X(3) C(3)=X(2)-X(1) C(4)=C(1) AI2=1./(2.*AREA(I)) DO 400 M=1,7 DO 200 J=1,3 DN(J,1)=AI2*B(J)*(4.*POINTS(J,M)-1.) DN(J+3,1)=AI2*4.*(B(J)*POINTS(J+1,M) + +B(J+1)*POINTS(J,M)) DN(J,2)=AI2*C(J)*(4.*POINTS(J,M)-1.) DN(J+3,2)=AI2*4.*(C(J)*POINTS(J+1,M) + +C(J+1)*POINTS(J,M)) 200 CONTINUE AJ11=0. AJ12=0. AJ21=0. AJ22=0. DO 300 J=1,6 AJ11=AJ11+DN(J,1)*X(J) AJ12=AJ12+DN(J,1)*Y(J) AJ21=AJ21+DN(J,2)*X(J) AJ22=AJ22+DN(J,2)*Y(J) 300 CONTINUE DETJAC=AJ11*AJ22-AJ12*AJ21 DETJ(M,I)=DETJAC IF ((AREA(I)*DETJAC).LT.0.) LISTOP(I)=.TRUE. AJ11S=AJ11 AJ11=AJ22/DETJAC AJ12=-AJ12/DETJAC AJ21=-AJ21/DETJAC AJ22=AJ11S/DETJAC DO 350 J=1,6 DXS(J,M,I)=AJ11*DN(J,1)+AJ12*DN(J,2) DYS(J,M,I)=AJ21*DN(J,1)+AJ22*DN(J,2) 350 CONTINUE 400 CONTINUE IF (LISTOP(I)) NUMBAD=NUMBAD+1 500 CONTINUE RETURN END C C C SUBROUTINE INLAND (INPUT,XIP,YIP,NUMEL,NUMNOD, + NELROW,XNODC,YNODC, + OUTPUT,FROMW) C C COMPUTES ORTHOGONAL DISTANCE FROM "LEFT" (TRENCH?) EDGE OF THE C CRUSTAL GRID, FOR AN ARRAY OF INTEGRATION POINTS. C DIMENSION FROMW(7,NUMEL),XIP(7,NUMEL),XNODC(NUMNOD), + YIP(7,NUMEL),YNODC(NUMNOD) NELCOL=NUMEL/(2*NELROW) NCOLN=2*NELCOL+1 NLL=NUMNOD-NCOLN+1 DO 100 M=1,7 DO 90 I=1,NUMEL X=XIP(M,I) Y=YIP(M,I) FROMW(M,I)= + HOWFAR(X,Y,NELROW,NCOLN,NLL,XNODC,YNODC) 90 CONTINUE 100 CONTINUE RETURN END C C C REAL FUNCTION HOWFAR (X,Y, + NELROW,NCOLN,NLL,XNODC,YNODC) C C COMPUTES ORTHOGONAL DISTANCE FROM "LEFT" (TRENCH?) EDGE OF THE C CRUSTAL GRID, FOR A SINGLE POINT. C DIMENSION XNODC(NLL),YNODC(NLL) C D2M=9.99E39 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 ONEBAR (INPUT,ACREEP,BCREEP,BIOT,CCREEP,CONINT,CRUST, + DCREEP,ECREEP,ERATE,FRIC,G,GEOTH, + NODES,NUMEL,NUMNOD,RHOH2O,RHOBAR, + TEMLIM,THIK,THNKC,UPLINK, + OUTPUT,FLUX,GLUE, + WORK,ILAYER,OUTSCA,ZBEAM) C C CALCULATES: C *GLUE (SHEAR STRESS REQUIRED TO CREATE UNIT RELATIVE C HORIZONTAL VELOCITY ACROSS A LAYER), AND C *FLUX (VERTICAL INTEGRAL OF HORIZONTAL VELOCITY CAUSED BY A C UNIT OF RELATIVE HORIZONTAL VELOCITY ACROSS A LAYER) C PARAMETER (NINT=100) LOGICAL CRUST,MANTLE DIMENSION ACREEP(3),BCREEP(3),CCREEP(3),DCREEP(3),ECREEP(3), + CONINT(7,NUMEL), + ERATE(4,7,NUMEL), + FLUX(7,NUMEL), + FRIC(2), + GEOTH(4,7,NUMEL), + GLUE(7,NUMEL), + ILAYER(NUMEL), + NODES(6,0:NUMEL), + OUTSCA(7,NUMEL), + RHOBAR(2), + TEMLIM(2), + THIK(7,NUMEL), + THNKC(NUMNOD), + UPLINK(3,7,NUMEL), + ZBEAM(7,NUMEL) C MANTLE=.NOT.CRUST C C INITIALIZE SUMS TO ZERO C (NOTE THAT THESE SUMS DO NOT YET HAVE THE MEANING DESCRIBED ABOVE, C AND THE ARRAYS ARE ONLY BEING USED FOR WORKING STORAGE. C UNTIL THE FINAL LOOP, GLUE WILL HOLD THE VELOCITY AND FLUX WILL C HOLD THE FLUX AT/ABOVE THE CURRENT DEPTH.) C DO 8 M=1,7 C*VDIR: ASSUME COUNT(280) DO 6 I=1,NUMEL FLUX(M,I)=0. GLUE(M,I)=0. 6 CONTINUE 8 CONTINUE C IF (CRUST) THEN ILE=1 TLIM=TEMLIM(1) DO 20 M=1,7 C*VDIR: ASSUME COUNT(280) DO 10 I=1,NUMEL OUTSCA(M,I)=0. 10 CONTINUE 20 CONTINUE ELSE ILE=3 STFRIC=SIN(ATAN(FRIC(2))) TLIM=TEMLIM(2) CALL GETSCA(INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DPEDZ=G*(RHOBAR(2)-RHOH2O*BIOT) C*VDIR: ASSUME COUNT(280) DO 25 I=1,NUMEL ILAYER(I)=3 25 CONTINUE ENDIF C C FIND REFERENCE LEVEL, TO WHICH NODAL VELOCITIES REFER: C IN CRUST, THIS IS ALWAYS THE SURFACE; C IN MANTLE, IT IS THE STRONGEST LEVEL: C DO 28 M=1,7 C*VDIR: ASSUME COUNT(280) DO 27 I=1,NUMEL IF (CRUST) THEN ZBEAM(M,I)=0.0 ELSE PE0=G*OUTSCA(M,I)*(RHOBAR(1)-RHOH2O*BIOT) EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) DIVER=EXX+EYY SHEAR=SQRT(EXY**2+0.25*(EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR EZZ=-DIVER SECINV=E1*E2 + E1*EZZ + E2*EZZ DEFORM=2.*SQRT(ABS(SECINV)) EN=DEFORM**ECREEP(3) ANGLE=ATAN2F(E2,E1)-0.7854 FACTOR=1./(1.+STFRIC*COS(ANGLE)) ZBEAM(M,I)=THIK(M,I) STRMAX=0.0 DO 26 K=0,10,1 Z=(THIK(M,I)*K)/10 ZABS=Z+OUTSCA(M,I) T=GEOTH(1,M,I) + +GEOTH(2,M,I)*Z + +GEOTH(3,M,I)*Z*Z + +GEOTH(4,M,I)*Z*Z*Z TH=MAX(T,200.) TL=MIN(TH,TLIM) SCP=ACREEP(3)*EN* + EXP((BCREEP(3)+CCREEP(3)*ZABS)/TL) SF=STFRIC*(PE0+DPEDZ*Z)*FACTOR SCP=MIN(SCP,DCREEP(3),SF) IF (SCP.GE.STRMAX) THEN ZBEAM(M,I)=Z STRMAX=SCP ENDIF 26 CONTINUE ENDIF 27 CONTINUE 28 CONTINUE C DO 100 M=1,7 DO 60 J=1,NINT C C SEPARATE OUT CHOICE OF MATERIAL ,IN CASE IT BLOCKS VECTORIZATION C IF (CRUST) THEN C*VDIR: ASSUME COUNT(280) DO 30 I=1,NUMEL C C INTEGRATION OF "GLUE" (VELOCITY) IS PERFORMED BY MIDPOINT RULE, C SO ALL QUANTITIES ARE EVALUATED AT MIDDLE OF DEPTH STEP: C Z=ZBEAM(M,I)+(J-0.5)/NINT* + (THIK(M,I)-ZBEAM(M,I)) IF (Z.GT.CONINT(M,I)) THEN ILAYER(I)=2 ELSE ILAYER(I)=1 ENDIF 30 CONTINUE ENDIF C C CRITICAL, TRIPLY-NESTED LOOP; MUST BE VECTORIZED: C C*VDIR: ASSUME COUNT(280) DO 50 I=1,NUMEL Z=ZBEAM(M,I)+(J-0.5)/NINT* + (THIK(M,I)-ZBEAM(M,I)) T=GEOTH(1,M,I) + +GEOTH(2,M,I)*Z + +GEOTH(3,M,I)*Z*Z + +GEOTH(4,M,I)*Z*Z*Z TH=MAX(T,200.) TL=MIN(TH,TLIM) ACI=ACREEP(ILAYER(I)) BCI=BCREEP(ILAYER(I)) CCI=CCREEP(ILAYER(I)) ECINI= -1.0/ECREEP(ILAYER(I)) AILOG=LOG(ACI)*ECINI BI=(BCI+CCI*(Z+OUTSCA(M,I)))*ECINI ARG=MAX(AILOG+BI/TL,-120.) GLUE(M,I)=GLUE(M,I)+EXP(ARG) FLUX(M,I)=FLUX(M,I)+GLUE(M,I) 50 CONTINUE 60 CONTINUE C C CORRECT FOR EXCESSIVE WEIGHT ON LAST VALUE OF "GLUE" (VELOCITY) C IN INTEGRATION OF FLUX (I.E., APPLY TRAPEZOIDAL RULE): C C*VDIR: ASSUME COUNT(280) DO 70 I=1,NUMEL FLUX(M,I)=FLUX(M,I)-0.5*GLUE(M,I) 70 CONTINUE C C MULTIPLY SUMS BY COMMON FACTORS AND TRANSFORM DIMENSIONS C C*VDIR: ASSUME COUNT(280) DO 80 I=1,NUMEL FLUX(M,I)=FLUX(M,I)*(THIK(M,I)-ZBEAM(M,I))/ + (GLUE(M,I)*NINT) 80 CONTINUE C*VDIR: ASSUME COUNT(280) DO 90 I=1,NUMEL GLUE(M,I)=(GLUE(M,I)*MAX(1.,(THIK(M,I)-ZBEAM(M,I)))/ + NINT)**(-ECREEP(ILE)) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE LINKER (NELCOL,NUMEL,XIP1,YIP1, + DETJ2,XIP2,YIP2,XNOD2,YNOD2, + NUMNOD,NODES,AREA,UDLINK,INLOOP) C C FINDS ELEMENT AND INTERNAL COORDINATES IN OPPOSITE GRID MATCHING C LOCATION OF EACH INTEGRATION POINT IN THE FIRST GRID, AND STORES C THEM IN UDLINK(1-3,M,I); WHERE M AND I ARE THE INTEGRATION POINT C AND ELEMENT IN THE FIRST GRID. C UDLINK(1,M,I) HOLDS THE ELEMENT NUMBER (+0.10) FROM THE OTHER; C UDLINK(2,M,I) HOLDS THE S2 INTERNAL COORDINATE; C UDLINK(3,M,I) HOLDS THE S3 INTERNAL COORDINATE. C THE S1 COORDINATE IS NOT STORED: S1=1.00-S2-S3 C LOGICAL INLOOP,ISTRAP,LEFTY,ODD,RIGHT,TRUBBL REAL M11,M12,M13,M21,M22,M23,M31,M32,M33 DIMENSION AREA(NUMEL),DETJ2(7,NUMEL),ITHIST(50), + NODES(6,0:NUMEL),SHIST(3,50),UDLINK(3,7,NUMEL), + XIP1(7,NUMEL),XIP2(7,NUMEL), + XNOD2(NUMNOD), + YIP1(7,NUMEL),YIP2(7,NUMEL), + YNOD2(NUMNOD) C C STATEMENT FUNCTIONS: ODD(I)=MOD(I,2).EQ.1 RIGHT(I)=MOD(I,NELWID).EQ.0 LEFTY(I)=MOD(I,NELWID).EQ.1 PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) C C NELWID=2*NELCOL INLOOP=.FALSE. IT=NUMEL C C LOOP ON POINTS WHOSE COORDINATES ARE TO BE FOUND: DO 1000 I=NUMEL,1,-1 IF(RIGHT(I)) IT=I DO 900 M=1,7 X=XIP1(M,I) Y=YIP1(M,I) NTRIED=0 C C BEGIN LOOP ON ELEMENTS WHICH MIGHT CONTAIN THE POINT: 100 NTRIED=NTRIED+1 ITHIST(NTRIED)=IT TRUBBL=(NTRIED.GE.3).AND.(ITHIST(NTRIED).EQ. + ITHIST(NTRIED-2)) IF (TRUBBL) THEN I1=I M1=M CALL SURVEY (INPUT,I1,M1,NUMEL, + X,XIP2,Y,YIP2, + OUTPUT,UDLINK) GO TO 898 ENDIF I1=NODES(1,IT) I2=NODES(2,IT) I3=NODES(3,IT) I4=NODES(4,IT) I5=NODES(5,IT) I6=NODES(6,IT) X1=XNOD2(I1) X2=XNOD2(I2) X3=XNOD2(I3) Y1=YNOD2(I1) Y2=YNOD2(I2) Y3=YNOD2(I3) ISTRAP=(DETJ2(1,IT).LE.0.2).OR. + (DETJ2(2,IT).LE.0.2).OR. + (DETJ2(3,IT).LE.0.2).OR. + (DETJ2(4,IT).LE.0.2).OR. + (DETJ2(5,IT).LE.0.2).OR. + (DETJ2(6,IT).LE.0.2).OR. + (DETJ2(7,IT).LE.0.2) IF (ISTRAP) THEN X4=0.5*(X1+X2) X5=0.5*(X2+X3) X6=0.5*(X3+X1) Y4=0.5*(Y1+Y2) Y5=0.5*(Y2+Y3) Y6=0.5*(Y3+Y1) ELSE X4=XNOD2(I4) X5=XNOD2(I5) X6=XNOD2(I6) Y4=YNOD2(I4) Y5=YNOD2(I5) Y6=YNOD2(I6) ENDIF S1=1./3. S2=S1 S3=1.-S1-S2 LIMIT=3 NREFIN=0 C C C LOOP TO REFINE ESTIMATE OF INTERNAL COORDINATES 150 NREFIN=NREFIN+1 XT=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YT=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) C C COEF:=MAT((DXDS1,DXDS2,DXDS3),(DYDS1,DYDS2,DYDS3),(1,1,1)); COEF11=4.*S2*X4+4.*S1*X1+4.*X6*S3-X1 COEF12=4.*S2*X2+4.*S1*X4+4.*X5*S3-X2 COEF13=4.*S2*X5+4.*S1*X6+4.*X3*S3-X3 COEF21=4.*S2*Y4+4.*S1*Y1+4.*Y6*S3-Y1 COEF22=4.*S2*Y2+4.*S1*Y4+4.*Y5*S3-Y2 COEF23=4.*S2*Y5+4.*S1*Y6+4.*Y3*S3-Y3 M11=COEF22-COEF23 M12=COEF21-COEF23 M13=COEF21-COEF22 M21=COEF12-COEF13 M22=COEF11-COEF13 M23=COEF11-COEF12 CF11=+M11 CF12=-M12 CF13=+M13 CF21=-M21 CF22=+M22 CF23=-M23 DET=COEF11*CF11+COEF12*CF12+COEF13*CF13 IF (DET.EQ.0.0) THEN UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 898 ENDIF DETI= 1./DET STEP11=CF11 STEP12=CF21 STEP21=CF12 STEP22=CF22 STEP31=CF13 STEP32=CF23 DELX=X-XT DELY=Y-YT DS1=(STEP11*DELX+STEP12*DELY)*DETI DS2=(STEP21*DELX+STEP22*DELY)*DETI DS3=(STEP31*DELX+STEP32*DELY)*DETI ERR=(DS1+DS2+DS3)/3. DS1=DS1-ERR DS2=DS2-ERR DS3=DS3-ERR DSTEP=MAX(ABS(DS1),ABS(DS2),ABS(DS3)) IF (DSTEP.GT. 0.10) THEN LIMIT=LIMIT+1 DS1=DS1*0.1/DSTEP DS2=DS2*0.1/DSTEP DS3=DS3*0.1/DSTEP ENDIF S1=S1+DS1 S2=S2+DS2 S3=S3+DS3 200 IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.40).AND. + (S1.GE.-0.1.AND.S1.LE.1.1).AND. + (S2.GE.-0.1.AND.S2.LE.1.1).AND. + (S3.GE.-0.1.AND.S3.LE.1.1)) GO TO 150 SHIST(1,NTRIED)=S1 SHIST(2,NTRIED)=S2 SHIST(3,NTRIED)=S3 IF (NTRIED.GE.50) THEN INLOOP=.TRUE. WRITE(6,201) M,I,X,Y 201 FORMAT(' INTEGRATION POINT ',I1,' IN ELEMENT ', + I3,' AT (',1P,E10.2,',',E10.2,') CAUSES ', + 'INFINITE LOOP IN LINKER.'/ + ' HISTORY OF SEARCH: ELEMENT S1 S2', + ' S3') 202 FORMAT(22X,I3,2X,3F12.4) DO 203 N=1,50 WRITE(6,202) ITHIST(N),(SHIST(K,N),K=1,3) 203 CONTINUE WRITE(6,204) ITHIST(49),(NODES(J,ITHIST(49)), + J=1,6),(XNOD2(NODES(J,ITHIST(49))),J=1,6), + (YNOD2(NODES(J,ITHIST(49))),J=1,6) WRITE(6,204) ITHIST(50),(NODES(J,ITHIST(50)), + J=1,6),(XNOD2(NODES(J,ITHIST(50))),J=1,6), + (YNOD2(NODES(J,ITHIST(50))),J=1,6) 204 FORMAT(' ELEMENT',I3,' NODES:',I3,5I10/ + 9X,'X:',1P,6E10.2/9X,'Y:',6E10.2) RETURN ENDIF IF (ODD(IT)) THEN IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF (LEFTY(IT)) THEN UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 898 ELSE IT=IT-1 GO TO 100 ENDIF ELSE IF(IT.GT.NELWID) THEN IT=IT-NELWID+1 GO TO 100 ELSE GO TO 500 ENDIF ELSE IT=IT+1 GO TO 100 ENDIF ELSE IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF(MOD(IT,NELWID).NE.0) THEN IT=IT+1 GO TO 100 ELSE GO TO 500 ENDIF ELSE IF ((NUMEL-IT).GE.NELWID) THEN IT=IT+NELWID-1 GO TO 100 ELSE GO TO 500 ENDIF ELSE IT=IT-1 GO TO 100 ENDIF ENDIF 500 UDLINK(1,M,I)=IT+0.10 UDLINK(2,M,I)=S2 UDLINK(3,M,I)=S3 898 CONTINUE 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE SURVEY (INPUT,I1,M1,NUMEL, + X,XIP,Y,YIP, + OUTPUT,UDLINK) C C FIND THE CLOSEST INTEGRATION POINT IN GRID (XIP,YIP) C TO THE GIVEN POINT (X,Y), AND STORES THE COORDINATES C IN UDLINK(1-3,M1,I1); WHERE M1 AND I1 ARE THE INTEGRATION POINT C AND ELEMENT IN THE FIRST GRID. C UDLINK(1,M1,I1) HOLDS THE ELEMENT NUMBER (+0.10); C UDLINK(2,M1,I1) HOLDS THE S2 INTERNAL COORDINATE; C UDLINK(3,M1,I1) HOLDS THE S3 INTERNAL COORDINATE. C THE S1 COORDINATE IS NOT STORED: S1=1.00-S2-S3 C THIS ROUTINE IS A ROUGH REPLACEMENT FOR "LINKER" IN CASES WHERE C IT FAILS DUE TO VERY DISTORTED ELEMENTS. C LOGICAL INSIDE DOUBLE PRECISION POINTS COMMON /L1L2L3/ POINTS DIMENSION POINTS(5,7),UDLINK(3,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) DATA BIGNUM/9.99E59/ C R2MIN=BIGNUM DO 100 M=1,7 DO 90 I=1,NUMEL R2=(X-XIP(M,I))**2+(Y-YIP(M,I))**2 IF (R2.LT.R2MIN) THEN R2MIN=R2 IS=I MS=M ENDIF 90 CONTINUE 100 CONTINUE R2C=(X-XIP(1,IS))**2+(Y-YIP(1,IS))**2 DXA=XIP(1,IS)-XIP(5,IS) DXB=XIP(1,IS)-XIP(6,IS) DXC=XIP(1,IS)-XIP(7,IS) DYA=YIP(1,IS)-YIP(5,IS) DYB=YIP(1,IS)-YIP(6,IS) DYC=YIP(1,IS)-YIP(7,IS) RA2=DXA**2+DYA**2 RB2=DXB**2+DYB**2 RC2=DXC**2+DYC**2 R2CRIT=1.5*MAX(RA2,RB2,RC2) INSIDE=R2C.LE.R2CRIT IF (INSIDE) THEN UDLINK(1,M1,I1)=IS+0.1 UDLINK(2,M1,I1)=POINTS(2,MS) UDLINK(3,M1,I1)=POINTS(3,MS) ELSE UDLINK(1,M1,I1)=0. UDLINK(2,M1,I1)=0. UDLINK(3,M1,I1)=0. ENDIF RETURN END C C C SUBROUTINE LINKUS (NELCOL,NUMEL1,NUMEL2, + XIP1,YIP1,XNOD2,YNOD2, + NUMNOD,NODES,AREA,UDLINK,INLOOP) C C FINDS ELEMENT AND INTERNAL COORDINATES IN OPPOSITE GRID MATCHING C LOCATION OF EACH INTEGRATION POINT IN THE FIRST GRID, AND STORES C THEM IN UDLINK(1-3,M,I); WHERE M AND I ARE THE INTEGRATION POINT C AND ELEMENT IN THE FIRST GRID. C UDLINK(1,M,I) HOLDS THE ELEMENT NUMBER (+0.10) FROM THE OTHER; C UDLINK(2,M,I) HOLDS THE S2 INTERNAL COORDINATE; C UDLINK(3,M,I) HOLDS THE S3 INTERNAL COORDINATE. C C MODIFIED FROM LINKER TO WORK WITH DIGITIZED STATE LINES !!!! C SPECIFICALLY, ARGUMENT NUMEL WAS SPLIT INTO NUMEL1 AND 2; C INITIALIZATION OF TENTATIVE ELEMENT IT WAS CHANGED, AND C INTERNAL COORDINATES ARE NOW REPORTED FOR POINTS OFF THE C LEFT EDGE. C LOGICAL GONOUT,INLOOP,LEFTY,ODD,RIGHT,TRUBBL REAL M11,M12,M13,M21,M22,M23,M31,M32,M33 DIMENSION AREA(NUMEL2),ITHIST(50),UDLINK(3,7,NUMEL1), + NODES(6,0:NUMEL2),SHIST(3,50), + XIP1(7,NUMEL1),YIP1(7,NUMEL1), + XNOD2(NUMNOD),YNOD2(NUMNOD) DATA BIGNUM/9.99E59/ ODD(I)=MOD(I,2).EQ.1 RIGHT(I)=MOD(I,NELWID).EQ.0 LEFTY(I)=MOD(I,NELWID).EQ.1 PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) NELWID=2*NELCOL INLOOP=.FALSE. DO 1000 M=1,7 DO 900 I=1,NUMEL1 X=XIP1(M,I) Y=YIP1(M,I) DIST2=BIGNUM DO 50 JIT=1,NUMEL2 XJT=0.333*(XNOD2(NODES(4,JIT))+ + XNOD2(NODES(5,JIT))+ + XNOD2(NODES(6,JIT))) YJT=0.333*(YNOD2(NODES(4,JIT))+ + YNOD2(NODES(5,JIT))+ + YNOD2(NODES(6,JIT))) R2=(X-XJT)**2+(Y-YJT)**2 IF (R2.LT.DIST2) THEN IT=JIT DIST2=R2 ENDIF 50 CONTINUE NTRIED=0 100 NTRIED=NTRIED+1 ITHIST(NTRIED)=IT TRUBBL=(NTRIED.GE.3).AND.(ITHIST(NTRIED).EQ. + ITHIST(NTRIED-2)) IF (TRUBBL) GO TO 500 I1=NODES(1,IT) I2=NODES(2,IT) I3=NODES(3,IT) I4=NODES(4,IT) I5=NODES(5,IT) I6=NODES(6,IT) X1=XNOD2(I1) X2=XNOD2(I2) X3=XNOD2(I3) X4=XNOD2(I4) X5=XNOD2(I5) X6=XNOD2(I6) Y1=YNOD2(I1) Y2=YNOD2(I2) Y3=YNOD2(I3) Y4=YNOD2(I4) Y5=YNOD2(I5) Y6=YNOD2(I6) S1=1./3. S2=S1 S3=1.-S1-S2 LIMIT=3 NREFIN=0 C LOOP TO REFINE ESTIMATE OF INTERNAL COORDINATES 150 NREFIN=NREFIN+1 XT=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YT=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) C C COEF:=MAT((DXDS1,DXDS2,DXDS3),(DYDS1,DYDS2,DYDS3),(1,1,1)); COEF11=4.*S2*X4+4.*S1*X1+4.*X6*S3-X1 COEF12=4.*S2*X2+4.*S1*X4+4.*X5*S3-X2 COEF13=4.*S2*X5+4.*S1*X6+4.*X3*S3-X3 COEF21=4.*S2*Y4+4.*S1*Y1+4.*Y6*S3-Y1 COEF22=4.*S2*Y2+4.*S1*Y4+4.*Y5*S3-Y2 COEF23=4.*S2*Y5+4.*S1*Y6+4.*Y3*S3-Y3 M11=COEF22-COEF23 M12=COEF21-COEF23 M13=COEF21-COEF22 M21=COEF12-COEF13 M22=COEF11-COEF13 M23=COEF11-COEF12 CF11=+M11 CF12=-M12 CF13=+M13 CF21=-M21 CF22=+M22 CF23=-M23 DET=COEF11*CF11+COEF12*CF12+COEF13*CF13 DETI= 1./DET STEP11=CF11 STEP12=CF21 STEP21=CF12 STEP22=CF22 STEP31=CF13 STEP32=CF23 DELX=X-XT DELY=Y-YT DS1=(STEP11*DELX+STEP12*DELY)*DETI DS2=(STEP21*DELX+STEP22*DELY)*DETI DS3=(STEP31*DELX+STEP32*DELY)*DETI ERR=(DS1+DS2+DS3)/3. DS1=DS1-ERR DS2=DS2-ERR DS3=DS3-ERR DSTEP=MAX(ABS(DS1),ABS(DS2),ABS(DS3)) IF (DSTEP.GT. 0.10) THEN LIMIT=LIMIT+1 DS1=DS1*0.1/DSTEP DS2=DS2*0.1/DSTEP DS3=DS3*0.1/DSTEP ENDIF S1=S1+DS1 S2=S2+DS2 S3=S3+DS3 IF (LEFTY(IT)) THEN IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.40).AND. + (S1.GE.-0.1.AND.S1.LE.3.0).AND. + (S2.GE.-0.1.AND.S2.LE.1.1).AND. + (S3.GE.-3.0.AND.S3.LE.1.1)) GO TO 150 ELSE IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.40).AND. + (S1.GE.-0.1.AND.S1.LE.1.1).AND. + (S2.GE.-0.1.AND.S2.LE.1.1).AND. + (S3.GE.-0.1.AND.S3.LE.1.1)) GO TO 150 ENDIF C C END OF LOOP TO REFINE INTERNAL COORDINATES IN ONE TRIAL ELEMENT C SHIST(1,NTRIED)=S1 SHIST(2,NTRIED)=S2 SHIST(3,NTRIED)=S3 IF (NTRIED.GE.50) THEN INLOOP=.TRUE. WRITE(6,201) M,I,X,Y 201 FORMAT('0INTEGRATION POINT ',I1,' IN ELEMENT ', + I3,' AT (',1P,E10.2,',',E10.2,') CAUSES ', + 'INFINITE LOOP IN LINKER.'/ + ' HISTORY OF SEARCH: ELEMENT S1 S2', + ' S3') 202 FORMAT(22X,I3,2X,3F12.4) DO 203 N=1,50 WRITE(6,202) ITHIST(N),(SHIST(K,N),K=1,3) 203 CONTINUE WRITE(6,204) ITHIST(49),(NODES(J,ITHIST(49)), + J=1,6),(XNOD2(NODES(J,ITHIST(49))),J=1,6), + (YNOD2(NODES(J,ITHIST(49))),J=1,6) WRITE(6,204) ITHIST(50),(NODES(J,ITHIST(50)), + J=1,6),(XNOD2(NODES(J,ITHIST(50))),J=1,6), + (YNOD2(NODES(J,ITHIST(50))),J=1,6) 204 FORMAT('0ELEMENT',I3,' NODES:',I3,5I10/ + 9X,'X:',1P,6E10.2/9X,'Y:',6E10.2) RETURN ENDIF IF (ODD(IT)) THEN IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF (LEFTY(IT)) THEN GO TO 500 ELSE IT=IT-1 GO TO 100 ENDIF ELSE IF(IT.GT.NELWID) THEN IT=IT-NELWID+1 GO TO 100 ELSE UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 900 ENDIF ELSE IT=IT+1 GO TO 100 ENDIF ELSE IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF(MOD(IT,NELWID).NE.0) THEN IT=IT+1 GO TO 100 ELSE UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 900 ENDIF ELSE IF ((NUMEL2-IT).GE.NELWID) THEN IT=IT+NELWID-1 GO TO 100 ELSE UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 900 ENDIF ELSE IT=IT-1 GO TO 100 ENDIF ENDIF 500 UDLINK(1,M,I)=IT+0.10 UDLINK(2,M,I)=S2 UDLINK(3,M,I)=S3 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE SETCUB (THIKM,NUMEL,GEOTHM,GEOTHA,OUTSCA,TASTH, + THIKC,GEOTHC,DNLINK,TOUCHC,TOUCHM,TSLAB0, + AREAM,CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NODES,NUMNOD,NXL,LWORK, + TSURF,FROMWC,FROMWM,ONEKM) C C ADJUSTS LOWER PART OF GEOTHERMS TO BOTTOM BOUNDARY CONDITION C AFTER AN INCREMENT OF SIMPLE SHEAR (NO NEED AFTER PURE SHEAR), C OR WHEN DIFFERENT MATERIAL SHIFTS BENEATH THE LAYER. C LOGICAL FAILUR,LOCKIN,LOCKWC DOUBLE PRECISION CODE,FLOWIN DIMENSION GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), + DNLINK(3,7,NUMEL),OUTSCA(7,NUMEL), + THIKC(7,NUMEL),THIKM(7,NUMEL), + TOUCHC(7,NUMEL),TOUCHM(7,NUMEL), + AREAM(NUMEL),CODE(NCDIM),DETJM(7,NUMEL), + FLOWIN(NUMNOD),CONDNS(NUMNOD), + NODES(6,0:NUMEL),LWORK(NXL), + FROMWC(7,NUMEL),FROMWM(7,NUMEL) DATA BIGNUM /1.E50/, LOCKIN /.FALSE./, LOCKWC /.FALSE./ C C ASTHENOSPHERE LAYER, WITH POTENTIAL THERMAL BOUNDARY LAYER C DO 100 M=1,7 DO 90 I=1,NUMEL IF (TOUCHC(M,I).LE.0.) THEN C C RESET BASE, AND ALLOW THERMAL EVOLUTION C Z=THIKM(5,NUMEL) TBOT=GEOTHA(1,M,I)+ GEOTHA(2,M,I)*Z+ + GEOTHA(3,M,I)*Z**2+GEOTHA(4,M,I)*Z**3 CORREC=TASTH-TBOT GEOTHA(4,M,I)=GEOTHA(4,M,I)+CORREC/Z**3 ELSE C C RESET WHOLE BOUNDARY LAYER (SWEPT AWAY) C GEOTHA(1,M,I)=TASTH GEOTHA(2,M,I)=0. GEOTHA(3,M,I)=0. GEOTHA(4,M,I)=0. ENDIF 90 CONTINUE 100 CONTINUE C C MANTLE LITHOSPHERE LAYER C CALL TMOHO (THIKM,NUMEL,GEOTHM,BIGNUM,OUTSCA) DO 200 M=1,7 DO 190 I=1,NUMEL TBOT=OUTSCA(M,I) XLEFT=FROMWM(M,I) IF (TOUCHM(M,I).GE.0.99) THEN TBOTC=TSLAB(TSURF,TSLAB0,XLEFT,ONEKM) ELSE TBOTC=TASTH ENDIF CORREC=TBOTC-TBOT GEOTHM(4,M,I)=GEOTHM(4,M,I)+CORREC/THIKM(M,I)**3 190 CONTINUE 200 CONTINUE C C CRUSTAL LAYER C DO 220 M=1,7 DO 210 I=1,NUMEL OUTSCA(M,I)=GEOTHM(1,M,I) 210 CONTINUE 220 CONTINUE CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 300 M=1,7 DO 290 I=1,NUMEL D=THIKC(M,I) TBASE=GEOTHC(1,M,I)+ + GEOTHC(2,M,I)*D+ + GEOTHC(3,M,I)*D**2+ + GEOTHC(4,M,I)*D**3 I2=DNLINK(1,M,I) IF (I2.GT.0) THEN TBOT=OUTSCA(M,I) ELSE IF (TOUCHC(M,I).GE.0.99) THEN XLEFT=FROMWC(M,I) TBOT=TSLAB(TSURF,TSLAB0,XLEFT,ONEKM) ELSE TBOT=GEOTHA(1,M,I) ENDIF ENDIF CORREC=TBOT-TBASE GEOTHC(4,M,I)=GEOTHC(4,M,I)+CORREC/THIKC(M,I)**3 290 CONTINUE 300 CONTINUE RETURN END C C C REAL FUNCTION TSLAB(TSURF,TSLAB0,XLEFT,ONEKM) C C COMPUTES SLAB-SURFACE TEMPERATURE BASED ON X**1/3 INCREASE C X=MAX(XLEFT,1.) TSLAB=TSURF+(TSLAB0-TSURF)*(X/(1000.*ONEKM))**0.333 RETURN END C C C SUBROUTINE BELOW (INPUT,CPNLAT,ECLOG,FROMW,IBELOW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C SELECTS ONE OF THE POSSIBLE SLAB MODEL FOR THE BOTTOM BC. C 0 = NO CONTACT OF SLABS WITH BASE OF MODEL (NULL B.C.) C 1 = NORTH AMERICA (NORTHERN OPTION) C 2 = NORTH AMERICA (SOUTHERN OPTION) C 3 = ROUGH VERSION OF SOUTH AMERICAN (SIERRA DE PAMPEANAS) C 4 = ROUGH VERSION OF CHINA (SHORT 200 KM UNDERTHRUST) C 5 = ? C C IF (IBELOW.LE.0) THEN CALL BELOW0(INPUT,NUMEL, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOW.EQ.1) THEN CALL BELOW1(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOW.EQ.2) THEN CALL BELOW2(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOW.EQ.3) THEN CALL BELOW3(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) ELSE IF (IBELOW.EQ.4) THEN CALL BELOW4(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C ELSE IF (IBELOW.EQ.5) THEN C CALL BELOW5(INPUT,CPNLAT,ECLOG,FROMW, C + NELCOL,NUMEL, C + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, C + WANDES,XIP,YIP,X0ELON,Y0NLAT, C + OUTPUT,SZZ,TOUCH,VSLAB) ENDIF RETURN END C C C SUBROUTINE BELOW0(INPUT,NUMEL, + OUTPUT,SZZ,TOUCH,VSLAB) C C NULL BOUNDARY CONDITIONS (NO CONTACT) C DIMENSION SZZ(7,NUMEL),TOUCH(7,NUMEL),VSLAB(2,7,NUMEL) C DO 20 M=1,7 DO 10 I=1,NUMEL SZZ(M,I)=0. TOUCH(M,I)=0. VSLAB(1,M,I)=0. VSLAB(2,M,I)=0. 10 CONTINUE 20 CONTINUE RETURN END C C C SUBROUTINE BELOW1(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C "BELOW1", LINKED TO /NORTH1/,/NORTH2/, AND /NORTH3/, C REPRESENTS THE NORTHERN 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 /NORTH1/ + NKV3J, + NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, + TUMAP COMMON /NORTH2/ + AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, + FRACZN,NMAG,NPFZ,NPHING, + OMEGAF,OMEGAK,OMEGAP,OMEGAV, + REHING,REKV3J,REMAG,REVF3J, + ROMATF,ROMATK,ROMATP,ROMATV COMMON /NORTH3/ + 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 BELOW2(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C "BELOW2", LINKED TO /SOUTH1/,/SOUTH2/, AND /SOUTH3/, C 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 /SOUTH1/ + NKV3J, + NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, + TUMAP COMMON /SOUTH2/ + AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, + FRACZN,NMAG,NPFZ,NPHING, + OMEGAF,OMEGAK,OMEGAP,OMEGAV, + REHING,REKV3J,REMAG,REVF3J, + ROMATF,ROMATK,ROMATP,ROMATV COMMON /SOUTH3/ + 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 BELOW3(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C VERY ROUGH VERSION OF ANDEAN (SIERRA DE PAMPEANAS), 1987? C DIMENSION SZZ(7,NUMEL),TOUCH(7,NUMEL),VSLAB(2,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL), + BETAL(7),COEFF(3,6,2) C DATA NUMHR /6/ DATA RINKM/6371./ DATA BETAL /1.E+20,2185.,1738.,1419.,993.,463.,-1.E+20/ DATA ((COEFF(I,J,1),I=1,3),J=1,6)/ + 1.256000E+3, 0.000000 , 0.000000, + 5.130022E+2, 3.400447E-1, 0.000000, + -2.122960E+3, 4.330471 , -1.423388E-3, + -2.631799E+3, 5.698898 , -2.134993E-3, + 5.504894E+2, -8.305952E-1, 1.213217E-3, + 4.260000E+2, 0.000000 , 0.000000/ C ONEKM=RADIUS/RINKM DO 20 J=1,NUMEL DO 10 I=1,7 VSLAB(1,I,J)=0.3234E-06 VSLAB(2,I,J)=-0.8666E-07 SZZ(I,J)=ECLOG+SLABSZ*SQRT(50./100.) 10 CONTINUE 20 CONTINUE C RAMPKM=RAMP/ONEKM C DO 200 M=1,7 DO 100 I=1,NUMEL X=XIP(M,I) Y=YIP(M,I) ALPHA=(X-2.5831E+08)/ONEKM BETA=(Y+1.9218E+09)/ONEKM C DO 105 J=1,NUMHR IF(BETA.LE.BETAL(J).AND.BETA.GE.BETAL(J+1))THEN ALIM=COEFF(1,J,1)+BETA*COEFF(2,J,1)+BETA**2*COEFF(3,J,1) TOUCHI=AMAX1(0.,AMIN1(1.,(0.5-2.*(ALPHA-ALIM)/RAMPKM))) TOUCH(M,I)=TOUCHI ENDIF 105 CONTINUE 100 CONTINUE 200 CONTINUE RETURN END C C C SUBROUTINE BELOW4(INPUT,CPNLAT,ECLOG,FROMW, + NELCOL,NUMEL, + PUSHUP,RADIUS,RAMP,SLABSZ,TIME, + WANDES,XIP,YIP,X0ELON,Y0NLAT, + OUTPUT,SZZ,TOUCH,VSLAB) C C VERY ROUGH VERSION OF CHINESE SHORT-UNDERTHRUST FOR C NOV. 1989 CALCULATIONS FOR NSF PROPOSAL 4. C LOGICAL MANTLE DIMENSION FROMW(7,NUMEL),SZZ(7,NUMEL),TOUCH(7,NUMEL), + VSLAB(2,7,NUMEL),XIP(7,NUMEL),YIP(7,NUMEL) C NTOUCH=9 C ABOVE DEFINES HOW MANY ROWS (FROM WEST) OF ELEMENTS C WILL TOUCH THE INDIAN PLATE. C CONTACT WILL ONLY BE WITH THE FIRST COLUMN, AND ONLY WITH CRUST. C C C DETECT AND REJECT MANTLE LAYER (NO CONTACT) C FSUM=0. DO 20 IROW=1,NTOUCH I=(IROW-1)*2*NELCOL+1 DO 10 M=1,7 FSUM=FSUM+FROMW(M,I) 10 CONTINUE 20 CONTINUE FMEAN=FSUM/(7.*NTOUCH) MANTLE=FMEAN.GT.100.E+05 IF (MANTLE) THEN DO 40 M=1,7 DO 30 I=1,NUMEL SZZ(M,I)=0. TOUCH(M,I)=0. VSLAB(1,M,I)=0. VSLAB(2,M,I)=0. 30 CONTINUE 40 CONTINUE ELSE DO 100 I=1,NUMEL JCOL=MOD((I-1),(2*NELCOL))+1 IROW=(I-1)/(2*NELCOL)+1 IF (JCOL.LE.2.AND.IROW.LE.NTOUCH) THEN DO 80 M=1,7 SZZ(M,I)=ECLOG TOUCH(M,I)=1. VSLAB(1,M,I)=1.089E-8+1.906E-16*XIP(M,I) VSLAB(2,M,I)=8.869E-8+2.680E-16*XIP(M,I) C THESE ARE MINSTER + JORDAN (1978) RM2* VELOCITIES FOR C WEST INDIA (SEPARATE FROM AUSTRALIA) WITH RESPECT TO C EURASIA. C 80 CONTINUE ELSE DO 90 M=1,7 SZZ(M,I)=0. TOUCH(M,I)=0. VSLAB(1,M,I)=0. VSLAB(2,M,I)=0. 90 CONTINUE ENDIF 100 CONTINUE ENDIF RETURN END 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 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 SQUEZE (G,CONDNS,TOUCHC,TOUCHM,SZZBC,SZZBM, + GEOTHA,GEOTHC,GEOTHM,NUMEL,THIKC,THIKM, + TEMLIM, + ALPHAT,RHOBAR,DNLINK,UPLINK,SIGZZC,SIGZZM, + OUTSCA,THNKC,THNKM, + DXSC,DXSM,DYSC,DYSM, + TAUZZC,TAUZZM,ONEKM,RHOH2O,RHOAST, + NODES,NUMNOD,PTSC,PTSM, + AREAC,AREAM,CODE,DETJC,DETJM,FAILUR,FLOWIN, + NCDIM,NDIFF,NXL,LWORK,ECLOG,HMAX,HMIN) C C CALCULATES LAYER-TOP VALUE (SIGZZ) AND THE LAYER INTEGRAL C (TAUZZ) OF VERTICAL STRESS ANOMALY C (RELATIVE TO A COLUMN OF MANTLE AT ASTHENOSPHERE TEMPERATURE C WITH A 2.7 KM OCEAN ON TOP AND A 5 KM CRUST, LIKE A MID-OCEAN C RIDGE) IN BOTH LAYERS AT ONCE. C ALSO PROVIDES PRESSURE ANOMALY TIMES SLOPE OF LAYER TOP (& BOT). C NOTE THAT ALL DENSITIES IN THIS PROGRAM ARE POTENTIAL C DENSITIES AT ZERO PRESSURE. C PARAMETER(NDREF=500) LOGICAL FAILUR,LOCKIN,LOCKWC DOUBLE PRECISION CODE,FLOWIN DIMENSION DREF(NDREF) DIMENSION ALPHAT(2),AREAC(NUMEL),AREAM(NUMEL), + CODE(NCDIM),CONDNS(NUMNOD), + DETJC(7,NUMEL),DETJM(7,NUMEL), + DXSC(6,7,NUMEL),DXSM(6,7,NUMEL), + DYSC(6,7,NUMEL),DYSM(6,7,NUMEL), + FLOWIN(NUMNOD),GEOTHA(4,7,NUMEL), + GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), + HMAX(2),HMIN(2), + DNLINK(3,7,NUMEL),UPLINK(3,7,NUMEL),NODES(6,0:NUMEL), + OUTSCA(7,NUMEL), + PTSC(2,7,NUMEL),PTSM(2,7,NUMEL), + RHOBAR(2),SIGZZC(7,NUMEL),SIGZZM(7,NUMEL), + SZZBC(7,NUMEL),SZZBM(7,NUMEL), + TAUZZC(7,NUMEL),TAUZZM(7,NUMEL),TEMLIM(2), + THIKC(7,NUMEL),THIKM(7,NUMEL), + THNKC(NUMNOD),THNKM(NUMNOD), + TOUCHC(7,NUMEL),TOUCHM(7,NUMEL), + LWORK(NXL) SAVE ICALL,DREF DATA ICALL /0/, LOCKIN /.FALSE./, LOCKWC /.FALSE./ C C STATEMENT FUNCTIONS: TEMPC(Z,M,I)=MIN(TEMLIM(1),GEOTHC(1,M,I) + +GEOTHC(2,M,I)*Z + +GEOTHC(3,M,I)*Z**2 + +GEOTHC(4,M,I)*Z**3) TEMPM(Z,M,I)=MIN(TEMLIM(2),GEOTHM(1,M,I) + +GEOTHM(2,M,I)*Z + +GEOTHM(3,M,I)*Z**2 + +GEOTHM(4,M,I)*Z**3) TEMPA(Z,M,I)=MIN(TEMLIM(2),GEOTHA(1,M,I) + +GEOTHA(2,M,I)*Z + +GEOTHA(3,M,I)*Z**2 + +GEOTHA(4,M,I)*Z**3) C TASTH=TEMPM(THIKM(5,NUMEL),5,NUMEL) C C CREATE REFERENCE TEMPERATURE & DENSITY PROFILES TO DEPTH OF NDREF KM C ICALL=ICALL+1 IF (ICALL.EQ.1) THEN ITEST=(HMAX(1)+HMAX(2))/ONEKM IF (ITEST.GT.NDREF) THEN WRITE(6,1)ITEST 1 FORMAT(' IN SUBPROGRAM SQUEZE, PARAMETER NDREF '/ + ' MUST BE INCREASED TO AT LEAST ',I10) STOP ENDIF DREF(1)=RHOH2O DREF(2)=RHOH2O DREF(3)=0.7*RHOH2O+0.3*RHOBAR(1) DREF(4)=RHOBAR(1) DREF(5)=RHOBAR(1) DREF(6)=RHOBAR(1) DREF(7)=RHOBAR(1) DREF(8)=0.7*RHOBAR(1)+0.3*RHOAST DO 58 J=9,58 DREF(J)=RHOAST+ECLOG/(G*50.*ONEKM) 58 CONTINUE DO 100 J=59,NDREF DREF(J)=RHOAST 100 CONTINUE ENDIF C C CALCULATION FOR MANTLE C CALL GETSCA(INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) DO 200 M=1,7 DO 190 I=1,NUMEL SLTOPX=0. SLTOPY=0. DO 110 J=1,6 SLTOPX=SLTOPX+CONDNS(NODES(J,I))*DXSM(J,M,I) SLTOPY=SLTOPY+CONDNS(NODES(J,I))*DYSM(J,M,I) 110 CONTINUE SLOPEX=SLTOPX SLOPEY=SLTOPY DO 120 J=1,6 SLOPEX=SLOPEX+THNKM(NODES(J,I))*DXSM(J,M,I) SLOPEY=SLOPEY+THNKM(NODES(J,I))*DYSM(J,M,I) 120 CONTINUE NLNROW=(NDIFF/2)-1 IF (MOD((I-1),NLNROW).GT.1) THEN T=TOUCHM(M,I) ELSE IF (TOUCHM(M,I).GT.0.99) THEN T=1.00 ELSE T=0.0 ENDIF ENDIF SZZ=T*SZZBM(M,I) SZZBOT=SZZ SZZLST=SZZ TZZ=0. ZMOHO=OUTSCA(M,I) ZASTH=ZMOHO+THIKM(M,I) NTOP=ZMOHO/ONEKM+0.5 NBOT=ZASTH/ONEKM+0.5 NTOP=MIN(NDREF,NTOP) NBOT=MIN(NDREF,NBOT) TRES=ZMOHO-NTOP*ONEKM BRES=ZASTH-NBOT*ONEKM DO 180 J=NBOT,NTOP+1,-1 Z=ONEKM*(J-0.5) ZP=Z-ZMOHO T=TEMPM(ZP,M,I) DENSE=RHOBAR(2)*(1.-ALPHAT(2)*T) IF (J.EQ.NBOT) DSAVE=DENSE SZZ=SZZ+G*ONEKM*(DENSE-DREF(J)) SZZM=0.5*(SZZ+SZZLST) SZZLST=SZZ TZZ=TZZ+ONEKM*SZZM 180 CONTINUE SIGZZM(M,I)=SZZ+G*(BRES*(DSAVE-DREF(NBOT))- + TRES*(DENSE-DREF(NTOP))) TAUZZM(M,I)=TZZ+BRES*SZZBOT-TRES*SZZ PTSM(1,M,I)= -SZZBOT*SLOPEX+SZZ*SLTOPX PTSM(2,M,I)= -SZZBOT*SLOPEY+SZZ*SLTOPY 190 CONTINUE 200 CONTINUE C C CALCULATION FOR CRUST C CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,SIGZZM,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 300 M=1,7 DO 290 I=1,NUMEL SLOPEX=0. SLOPEY=0. DO 220 J=1,6 SLOPEX=SLOPEX+THNKC(NODES(J,I))*DXSC(J,M,I) SLOPEY=SLOPEY+THNKC(NODES(J,I))*DYSC(J,M,I) 220 CONTINUE ZMOHO=THIKC(M,I) TMOHO=TEMPC(ZMOHO,M,I) IF (DNLINK(1,M,I).GT.0.) THEN SZZ=OUTSCA(M,I) ELSE IF (TOUCHC(M,I).GT.0.) THEN SZZ=TOUCHC(M,I)*SZZBC(M,I) ELSE SZZ=0. ZMOHO=THIKC(M,I) ZASTH=ZMOHO+THIKM(5,NUMEL) NTOP=ZMOHO/ONEKM+0.5 NBOT=ZASTH/ONEKM+0.5 NTOP=MIN(NDREF,NTOP) NBOT=MIN(NDREF,NBOT) TRES=ZMOHO-NTOP*ONEKM BRES=ZASTH-NBOT*ONEKM DO 250 J=NBOT,NTOP+1,-1 Z=ONEKM*(J-0.5) ZP=Z-ZMOHO T=TEMPA(ZP,M,I) DENSE=RHOBAR(2)*(1.-ALPHAT(2)*T) IF (J.EQ.NBOT) DSAVE=DENSE SZZ=SZZ+G*ONEKM*(DENSE-DREF(J)) 250 CONTINUE SZZ=SZZ+G*(BRES*(DSAVE-DREF(NBOT))- + TRES*(DENSE-DREF(NTOP))) ENDIF ENDIF SZZBOT=SZZ PTSC(1,M,I)= -SZZBOT*SLOPEX PTSC(2,M,I)= -SZZBOT*SLOPEY SZZLST=SZZ TZZ=0. NINT=ZMOHO/ONEKM+0.5 NINT=MIN(NINT,NDREF) RESIDU=ZMOHO-NINT*ONEKM DO 280 J=NINT,1,-1 Z=ONEKM*(J-0.5) T=TEMPC(Z,M,I) DENSE=RHOBAR(1)*(1.-ALPHAT(1)*T) IF (J.EQ.NINT) DSAVE=DENSE SZZ=SZZ+G*ONEKM*(DENSE-DREF(J)) SZZM=0.5*(SZZ+SZZLST) SZZLST=SZZ TZZ=TZZ+ONEKM*SZZM 280 CONTINUE SIGZZC(M,I)=SZZ+RESIDU*G*(DSAVE-DREF(NINT)) TAUZZC(M,I)=TZZ+RESIDU*SZZBOT 290 CONTINUE 300 CONTINUE CALL EXTRAP (AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,SIGZZC,LWORK, + LOCKIN,LOCKWC) CALL INTERP (CONDNS,NODES,NUMEL,NUMNOD,SIGZZC) RETURN END C C C SUBROUTINE EXTRAP (AREA,CODE,DETJ,FAILUR, + FLOWIN,FPOLES,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,VALUES,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) C C SMOOTHS VALUES OF A SCALAR FIELD KNOWN AT THE INTEGRATION C POINTS (VALUES) TO PRODUCE VALUES AT THE NODES (FPOLES). C INCLUDES OPTION (LOCKIN) TO SET VALUES TO ZERO AT INLAND EDGES, C AND AN OPTION TO SET NODE VALUES TO PHINOD(I) AT WEST EDGE. C LOGICAL FAILUR,LOCKIN,LOCKWC DOUBLE PRECISION CODE,FLOWIN,PHI,WEIGHT DIMENSION AREA(NUMEL),CODE(NCDIM),DETJ(7,NUMEL), + FLOWIN(NUMNOD),FPOLES(NUMNOD),NODES(6,0:NUMEL), + PHI(6,7),PHINOD(NUMNOD), + WEIGHT(7),VALUES(7,NUMEL),LWORK(NXL) COMMON /WGTVEC/ WEIGHT COMMON /PHITAB/ PHI CALL BUILDC (AREA,CODE,DETJ, + NCDIM,NDIFF,NODES,NUMEL,NUMNOD) DO 200 I=1,NUMNOD FLOWIN(I)=0. 200 CONTINUE DO 800 M=1,7 WT=WEIGHT(M) DO 700 I=1,NUMEL VALDA=VALUES(M,I)*AREA(I)*DETJ(M,I)*WT DO 600 J=1,6 K=NODES(J,I) FLOWIN(K)=FLOWIN(K)+PHI(J,M)*VALDA 600 CONTINUE 700 CONTINUE 800 CONTINUE IF (LOCKIN) CALL EBCS (NELCOL,FLOWIN,NUMNOD,NDIFF, + CODE,NCDIM) IF (LOCKWC) THEN NACROS=2*NELCOL+1 NROW=NUMNOD/NACROS DO 850 IR=1,NROW IN=(IR-1)*NACROS+1 VALUE=PHINOD(IN) CALL FIXVAL (IN,FLOWIN,NUMNOD,NDIFF,CODE,NCDIM,VALUE) 850 CONTINUE ENDIF CALL SOLVER (CODE,NCDIM,FLOWIN,NUMNOD,NDIFF,LWORK,NXL,FAILUR) DO 900 I=1,NUMNOD FPOLES(I)=FLOWIN(I) 900 CONTINUE 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 SUBROUTINE GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,UDLINK, + OUTPUT,OUTSCA) C C INTERPOLATES SCALAR FROM NODES TO POSITIONS GIVEN IN UDLINK C (ONE VALUE PER INTEGRATION POINT) C DIMENSION CONDNS(NUMNOD),NODES(6,0:NUMEL),OUTSCA(7,NUMEL), + UDLINK(3,7,NUMEL) PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) DO 1000 M=1,7 DO 900 I=1,NUMEL IE=UDLINK(1,M,I) S2=UDLINK(2,M,I) S3=UDLINK(3,M,I) S1=1.00-S2-S3 F1=CONDNS(NODES(1,IE)) F2=CONDNS(NODES(2,IE)) F3=CONDNS(NODES(3,IE)) F4=CONDNS(NODES(4,IE)) F5=CONDNS(NODES(5,IE)) F6=CONDNS(NODES(6,IE)) OUTSCA(M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE GETVEC (INPUT,VECNOD,NODES,NUMEL,NUMNOD,UDLINK, + OUTPUT,OUTVEC) C C INTERPOLATES VECTOR FROM NODES TO POSITIONS GIVEN IN UDLINK C (ONE VALUE PER INTEGRATION POINT) C DIMENSION VECNOD(2,NUMNOD),NODES(6,0:NUMEL),OUTVEC(2,7,NUMEL), + UDLINK(3,7,NUMEL) PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) DO 1000 M=1,7 DO 900 I=1,NUMEL IE=UDLINK(1,M,I) I1=NODES(1,IE) I2=NODES(2,IE) I3=NODES(3,IE) I4=NODES(4,IE) I5=NODES(5,IE) I6=NODES(6,IE) S2=UDLINK(2,M,I) S3=UDLINK(3,M,I) S1=1.00-S2-S3 F1=VECNOD(1,I1) F2=VECNOD(1,I2) F3=VECNOD(1,I3) F4=VECNOD(1,I4) F5=VECNOD(1,I5) F6=VECNOD(1,I6) OUTVEC(1,M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) F1=VECNOD(2,I1) F2=VECNOD(2,I2) F3=VECNOD(2,I3) F4=VECNOD(2,I4) F5=VECNOD(2,I5) F6=VECNOD(2,I6) OUTVEC(2,M,I)=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) 900 CONTINUE 1000 CONTINUE RETURN END @PROCESS NOVECTOR C C SUBROUTINE BUILDC (AREA,CODE,DETJ, + NCDIM,NDIFF,NODES,NUMEL,NUMNOD) C C WARNING!!! THE "@PROCESS NOVECTOR" STATEMENT C ABOVE IS NEEDED FOR BUILDC UNDER VS FORTRAN 2.4.0 C BECAUSE OF A COMPILER BUG. IF THIS ROUTINE IS COMPILED C WITH THE VECTOR (DEFAULT) OPTION, IT WILL BE INCORRECT C AND WILL GIVE VERY ODD RESULTS THAT ARE HARD TO TRACE. C C CREATES SMOOTHING MATRIX CODE (CROSS-PRODUCTS OF PHI) C DOUBLE PRECISION CODE,PHI,WEIGHT DIMENSION AREA(NUMEL),CODE(NCDIM),DETJ(7,NUMEL), + NODES(6,0:NUMEL),PHI(6,7),WEIGHT(7) COMMON /PHITAB/ PHI COMMON /WGTVEC/ WEIGHT INDEXK(IR,JC,NBAND)=2*NBAND+1+IR-JC+(JC-1)*(3*NBAND+16) C USE: INDEXK(IR,JC,NDIFF) C BECAUSE THESE TENSORS HAVE HALF THE RANK OF STIFF DO 10 I=1,NCDIM CODE(I)=0. 10 CONTINUE DO 100 I=1,NUMEL DO 90 I6=1,6 DO 80 J6=1,6 IR=NODES(I6,I) JC=NODES(J6,I) SUM=0. DO 70 M=1,7 SUM=SUM+WEIGHT(M)*DETJ(M,I)* + PHI(I6,M)*PHI(J6,M) 70 CONTINUE K=INDEXK(IR,JC,NDIFF) CODE(K)=CODE(K)+SUM*AREA(I) 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE THONM (NUMEL,NODES,NUMNOD,VM, + SIGHBM,SIGHTM,TOUCHM,VSLABM, + SIGBOT,GLUEM,ECREEP,DELVM,OUTVEC,OUTV2, + ETAMAX,UPLINK,VC,RHOBAR, + G,THIKM,FRIC,VISMAX,DVB,DVT,OVA,OVB, + OUTSCA) C C CALCULATES HORIZONTAL SHEAR STRESSES ON BASE C AND TOP OF THE MANTLE PART OF THE NORTH AMERICAN PLATE, C AND RELATIVE HORIZONTAL VELOCITY WITHIN PLATE WHICH THEY CAUSE. C DIMENSION DELVM(2,7,NUMEL),DVB(7,NUMEL),DVT(7,NUMEL), + ECREEP(3),FRIC(2),GLUEM(7,NUMEL), + UPLINK(3,7,NUMEL),NODES(6,0:NUMEL), + OUTVEC(2,7,NUMEL),OUTV2(2,7,NUMEL), + OVA(2,7,NUMEL),OVB(2,7,NUMEL), + RHOBAR(2),SIGHBM(2,7,NUMEL),SIGHTM(2,7,NUMEL), + THIKM(7,NUMEL), + TOUCHM(7,NUMEL),VSLABM(2,7,NUMEL), + VC(2,NUMNOD),VM(2,NUMNOD),OUTSCA(7,NUMEL) SQRT2(X)=SQRT(MAX(X,1.E-50)) CALL FLOW (VM,NUMNOD,NODES,NUMEL,OUTVEC) CALL GETVEC (INPUT,VC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OVA) DO 1000 M=1,7 DO 900 I=1,NUMEL CRUST=OUTSCA(M,I) GLUEC=OUTV2(1,M,I) VMX=OUTVEC(1,M,I) VMY=OUTVEC(2,M,I) VFX=VSLABM(1,M,I) VFY=VSLABM(2,M,I) IF (TOUCHM(M,I).GE.0.99) THEN OVB(1,M,I)=VFX OVB(2,M,I)=VFY VRX=VFX-VMX VRY=VFY-VMY V=SQRT2(VRX**2+VRY**2) DVB(M,I)=V DVX=VRX/V DVY=VRY/V SHEAR1=GLUEM(M,I)*V**ECREEP(3) SHEAR2=G*FRIC(2)* + (CRUST*RHOBAR(1)+THIKM(M,I)*RHOBAR(2)) SHEAR3=VISMAX*V/THIKM(M,I) SHEAR4=ETAMAX*V SHEAR5=SIGBOT SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4,SHEAR5) DECOLL=(SHEAR/GLUEM(M,I))**(1./ECREEP(3)) SIGHBM(1,M,I)=SHEAR*DVX SIGHBM(2,M,I)=SHEAR*DVY DELVM(1,M,I)=DVX*DECOLL DELVM(2,M,I)=DVY*DECOLL ELSE OVB(1,M,I)=0. OVB(2,M,I)=0. DVB(M,I)=0. SIGHBM(1,M,I)=0. SIGHBM(2,M,I)=0. DELVM(1,M,I)=0. DELVM(2,M,I)=0. ENDIF VCX=OVA(1,M,I) VCY=OVA(2,M,I) VRX=VCX-VMX VRY=VCY-VMY V=SQRT2(VRX**2+VRY**2) DVT(M,I)=V DVX=VRX/V DVY=VRY/V SHEAR1=MAX(GLUEC,0.)*V**ECREEP(2) SHEAR2=RHOBAR(1)*G*CRUST*FRIC(1) SHEAR3=VISMAX*V/CRUST SHEAR4=ETAMAX*V SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4) SIGHTM(1,M,I)=SHEAR*DVX SIGHTM(2,M,I)=SHEAR*DVY 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE THONC (NUMEL,NODES,NUMNOD,VC, + DNLINK,VM,DELVC,GLUEC,ECREEP,SIGHC, + SIGBOT,TOUCHC,VSLABC, + RHOBAR,G,THIKC,FRIC,VISMAX,DVB,OVB, + OUTVEC,ETAMAX,PUSHHO,FROMWC,WANDES) C C CALCULATES SHEAR STRESSES ON BASE OF CRUST, AND C RELATIVE VELOCITY WITHIN CRUST DUE TO SIMPLE SHEAR C COMMON /GROBOW/ HANDES,XANDES,NPOINT,NALT1,NALT2 DIMENSION HANDES(5),XANDES(5) DIMENSION DELVC(2,7,NUMEL),DVB(7,NUMEL),ECREEP(3),FRIC(2), + FROMWC(7,NUMEL),GLUEC(7,NUMEL),DNLINK(3,7,NUMEL), + NODES(6,0:NUMEL),OUTVEC(2,7,NUMEL), + OVB(2,7,NUMEL),RHOBAR(2), + SIGHC(2,7,NUMEL),THIKC(7,NUMEL), + TOUCHC(7,NUMEL),VSLABC(2,7,NUMEL), + VC(2,NUMNOD),VM(2,NUMNOD) SQRT2(X)=SQRT(MAX(X,1.E-50)) CALL FLOW (VC,NUMNOD,NODES,NUMEL,OUTVEC) CALL GETVEC (INPUT,VM,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OVB) DO 1000 M=1,7 DO 900 I=1,NUMEL VCX=OUTVEC(1,M,I) VCY=OUTVEC(2,M,I) XREL=FROMWC(M,I)/MAX(WANDES,1.) IF (XREL.LT.XANDES(NALT1)) THEN SLIMIT=SIGBOT+PUSHHO ELSE SLIMIT=SIGBOT ENDIF I2=DNLINK(1,M,I) IF (I2.NE.0) THEN VMX=OVB(1,M,I) VMY=OVB(2,M,I) VRX=VMX-VCX VRY=VMY-VCY V=SQRT2(VRX**2+VRY**2) DVB(M,I)=V DVX=VRX/V DVY=VRY/V SHEAR1=GLUEC(M,I)*V**ECREEP(2) SHEAR2=RHOBAR(1)*G*THIKC(M,I)*FRIC(1) SHEAR3=VISMAX*V/THIKC(M,I) SHEAR4=ETAMAX*V SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4) DECOLL=(SHEAR/GLUEC(M,I))**(1./ECREEP(2)) SIGHC(1,M,I)=SHEAR*DVX SIGHC(2,M,I)=SHEAR*DVY DELVC(1,M,I)=DVX*DECOLL DELVC(2,M,I)=DVY*DECOLL ELSE VFX=VSLABC(1,M,I) VFY=VSLABC(2,M,I) IF (TOUCHC(M,I).GE.0.99) THEN OVB(1,M,I)=VFX OVB(2,M,I)=VFY VRX=VFX-VCX VRY=VFY-VCY V=SQRT2(VRX**2+VRY**2) DVB(M,I)=V DVX=VRX/V DVY=VRY/V SHEAR1=GLUEC(M,I)*V**ECREEP(2) SHEAR2=RHOBAR(1)*G*THIKC(M,I)*FRIC(1) SHEAR3=VISMAX*V/THIKC(M,I) SHEAR4=ETAMAX*V SHEAR5=SLIMIT SHEAR=MIN(SHEAR1,SHEAR2,SHEAR3,SHEAR4,SHEAR5) DECOLL=(SHEAR/GLUEC(M,I))**(1./ECREEP(2)) SIGHC(1,M,I)=SHEAR*DVX SIGHC(2,M,I)=SHEAR*DVY DELVC(1,M,I)=DVX*DECOLL DELVC(2,M,I)=DVY*DECOLL ELSE OVB(1,M,I)=0. OVB(2,M,I)=0. DVB(M,I)=0. DELVC(1,M,I)=0. DELVC(2,M,I)=0. SIGHC(1,M,I)=0. SIGHC(2,M,I)=0. ENDIF ENDIF 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE VISCOS (SCOREC,SCORED,VISMAX,NUMEL,CONINT, + ALPHA,ERATE,TAUMAT,TOFSET,THIK,GEOTH, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,ROBAR,FRIC,TEMLIM, + OUTSCA,SIGHB) C C CALLS FLOW-LAW "DIAMND" (ONLY POINT IN PROGRAM) AND C COMPUTES SECANT EFFECTIVE VISCOSITY MATRIX ALPHA C IN 3X3 COMPONENT FORM FROM 2X2 PRINCIPAL AXIS FORM C AT EACH INTEGRATION POINT OF A LAYER. C (NOTE THAT ALPHA HAS DIMENSION OF VISCOSITY * THICKNESS) C C ALSO RECORDS OFFSET VALUES (TOFSET(3,7,NUMEL)) FOR NEXT ITERATION C CALCULATION OF TOFSET + ALPHA*E WILL GIVE MODEL DEFORMATIONAL C (DEVIATORIC) STRESS INTEGRAL C LOGICAL MANTLE DIMENSION ACREEP(3),ALPHA(3,3,7,NUMEL),BCREEP(3),CCREEP(3), + CONINT(7,NUMEL),DCREEP(3),ECREEP(3), + ERATE(4,7,NUMEL),FRIC(2),GEOTH(4,7,NUMEL), + OUTSCA(7,NUMEL),ROBAR(2),SIGHB(2,7,NUMEL), + TAUMAT(3,7,NUMEL), + TEMLIM(2),THIK(7,NUMEL),TOFSET(3,7,NUMEL) SQRT2(X)=SQRT(MAX(X,1.E-50)) C IF (MANTLE) THEN FR=FRIC(2) RHO=ROBAR(2) ELSE FR=FRIC(1) RHO=ROBAR(1) ENDIF SCOREC=0. SCORED=0. DENOMV=0. DENOMF=0. EBASE=(RHO*G*ONEKM*0.001)/VISMAX STFRIC=SIN(ATAN(FR)) DO 1000 M=1,7 DO 900 I=1,NUMEL CTAMIP=MAX(OUTSCA(M,I),0.0) SIGHBI=SQRT2(SIGHB(1,M,I)**2+SIGHB(2,M,I)**2) DELP2=0.25*(TAUMAT(1,M,I)+TAUMAT(2,M,I))**2 SHEAR2=TAUMAT(3,M,I)**2+0.25* + (TAUMAT(1,M,I)-TAUMAT(2,M,I))**2 DENOMV=DENOMV+MAX(DELP2,SHEAR2) THICK=THIK(M,I) EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) IF(ABS(EXX-EYY).LT.EBASE) EXX=EYY-EBASE DIVER=EXX+EYY SHEAR=SQRT(EXY**2+0.25*(EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR ANGLE=ATAN2F(EXY,0.5*(EXX-EYY)) CALL DIAMND (I,M,EXX,EYY,EXY,E1,E2,TXX,TYY,TXY, + RADT,IREGON,DT1DE1,DT1DE2,DT2DE1,DT2DE2, + GEOTH,NUMEL,VISMAX,THICK,TEMLIM, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,ROBAR,STFRIC,CTAMIP, + CONINT,SIGHBI) DENOMF=DENOMF+MAX(RADT**2,0.25*(TXX+TYY)**2) DXX=TAUMAT(1,M,I)-TXX DYY=TAUMAT(2,M,I)-TYY DXY=TAUMAT(3,M,I)-TXY DELP2=0.25*(DXX+DYY)**2 SHEAR2=.25*(DXX-DYY)**2+DXY**2 SCOREC=MAX(SCOREC,DELP2,SHEAR2) SCORED=SCORED+MAX(DELP2,SHEAR2) DE1DEX=0.5-(EXX-EYY)/(4.*SHEAR) DE1DEY=0.5+(EXX-EYY)/(4.*SHEAR) DE1DES= -EXY/SHEAR DE2DEX=DE1DEY DE2DEY=DE1DEX DE2DES= -DE1DES U=2.*EXY/(EXX-EYY) TERM=1./(1.+U**2) DANDEX= -TERM*U/(EXX-EYY) DANDEY= -DANDEX DANDES=TERM*2./(EXX-EYY) DTXDT1=0.5*(1.-COS(ANGLE)) DTXDT2=0.5*(1.+COS(ANGLE)) DTXDAN= -TXY DTYDT1=DTXDT2 DTYDT2=DTXDT1 DTYDAN=TXY DTSDT1= -0.5*SIN(ANGLE) DTSDT2= -DTSDT1 DTSDAN=RADT*COS(ANGLE) C FIRST SUBSCRIPT OF ALPHA REFERS TO STRESS (1:TXX,2:TYY,3:TXY) C SECOND SUBSCRIPT OF ALPHA REFERS TO STRAIN (1:EXX,2:EYY,3:EXY) DTXDE1=DTXDT1*DT1DE1+DTXDT2*DT2DE1 DTXDE2=DTXDT1*DT1DE2+DTXDT2*DT2DE2 ALPHA(1,1,M,I)= + DTXDE1*DE1DEX+DTXDE2*DE2DEX+DTXDAN*DANDEX ALPHA(1,2,M,I)= + DTXDE1*DE1DEY+DTXDE2*DE2DEY+DTXDAN*DANDEY ALPHA(1,3,M,I)= + DTXDE1*DE1DES+DTXDE2*DE2DES+DTXDAN*DANDES DTYDE1=DTYDT1*DT1DE1+DTYDT2*DT2DE1 DTYDE2=DTYDT1*DT1DE2+DTYDT2*DT2DE2 ALPHA(2,1,M,I)= + DTYDE1*DE1DEX+DTYDE2*DE2DEX+DTYDAN*DANDEX ALPHA(2,2,M,I)= + DTYDE1*DE1DEY+DTYDE2*DE2DEY+DTYDAN*DANDEY ALPHA(2,3,M,I)= + DTYDE1*DE1DES+DTYDE2*DE2DES+DTYDAN*DANDES DTSDE1=DTSDT1*DT1DE1+DTSDT2*DT2DE1 DTSDE2=DTSDT1*DT1DE2+DTSDT2*DT2DE2 ALPHA(3,1,M,I)= + DTSDE1*DE1DEX+DTSDE2*DE2DEX+DTSDAN*DANDEX ALPHA(3,2,M,I)= + DTSDE1*DE1DEY+DTSDE2*DE2DEY+DTSDAN*DANDEY ALPHA(3,3,M,I)= + DTSDE1*DE1DES+DTSDE2*DE2DES+DTSDAN*DANDES TOFSET(1,M,I)=TXX-ALPHA(1,1,M,I)*EXX + -ALPHA(1,2,M,I)*EYY + -ALPHA(1,3,M,I)*EXY TOFSET(2,M,I)=TYY-ALPHA(2,1,M,I)*EXX + -ALPHA(2,2,M,I)*EYY + -ALPHA(2,3,M,I)*EXY TOFSET(3,M,I)=TXY-ALPHA(3,1,M,I)*EXX + -ALPHA(3,2,M,I)*EYY + -ALPHA(3,3,M,I)*EXY 900 CONTINUE 1000 CONTINUE SCOREC=SQRT(SCOREC) SCORED=SQRT(SCORED/MAX(DENOMV,DENOMF)) RETURN END C C C SUBROUTINE DIAMND(I,M,EXX,EYY,EXY,E1,E2,TXX,TYY,TXY, + RADT,IREGON,DT1DE1,DT1DE2,DT2DE1,DT2DE2, + GEOTH,NUMEL,VISMAX,THICK,TEMLIM, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,ROBAR,STFRIC,CTAMIP, + CONINT,SIGHBI) C C CALCULATES VERTICAL INTEGRAL OF (LOCAL) DEFORMATIONAL (DEVIATORIC) C STRESS COMPONENTS TXX, TYY, TXY FROM STRAIN-RATE COMPONENTS C C ALSO REPORTS TACTICAL CHOICES OF PARTIAL DERIVITIVES: C DT1DE1, DT1DE2, DT2DE1, AND DT2DE2 C IN PRINCIPAL-AXIS FORM. C LOGICAL FAULT,GLIDE,MANTLE DIMENSION ACREEP(3),BCREEP(3),CCREEP(3),CONINT(7,NUMEL), + DCREEP(3),DTF1(4),DTF2(4),DT1(4),DT2(4), + ECREEP(3),ETALPH(4),ETBETA(4),ET1(4),ET2(4), + GEOTH(4,7,NUMEL),ROBAR(2),TEMLIM(2) C C STATEMENT FUNCTION: TEMP(Z,L,J)=MAX(200.,MIN(TLIM,GEOTH(1,L,J) + +GEOTH(2,L,J)*Z + +GEOTH(3,L,J)*Z**2 + +GEOTH(4,L,J)*Z**3)) C Z=0.3*THICK IF (MANTLE) THEN CRUST=CTAMIP PE0=G*CRUST*(ROBAR(1)-RHOH2O*BIOT) ZABS=Z+CRUST DPEDZ=G*(ROBAR(2)-RHOH2O*BIOT) TLIM=TEMLIM(2) ILAYER=3 ELSE PE0=0. ZABS=Z DPEDZ=G*(ROBAR(1)-RHOH2O*BIOT) TLIM=TEMLIM(1) ILAYER=1 ENDIF EZZ=-EXX-EYY SECINV=E1*E2 + E1*EZZ + E2*EZZ DEFORM=2.*SQRT(ABS(SECINV)) EN=DEFORM**ECREEP(ILAYER) ANGLE=ATAN2F(E2,E1)-0.7854 FACTOR=1./(1.+STFRIC*COS(ANGLE)) C C FIND BRITTLE/DUCTILE TRANSITION C DO 100 NITER=1,15 T=TEMP(Z,M,I) ZP=Z+ONEKM TP=TEMP(ZP,M,I) DTDZ=MAX((TP-T),1.)/ONEKM SF=STFRIC*(PE0+DPEDZ*Z)*FACTOR SF=MIN(SF,DCREEP(ILAYER)) TEMPT=1./( LOG(SF/(ACREEP(ILAYER)*EN))/ + (BCREEP(ILAYER)+CCREEP(ILAYER)*ZABS) ) DELZ=(TEMPT-T)/DTDZ IF (ABS(DELZ).LT.(0.03*ONEKM)) GO TO 101 DELZ=DELZ*MIN(1.,0.10*THICK/ABS(DELZ)) Z=Z+DELZ ZABS=ZABS+DELZ IF (Z.LE.0. .OR. Z.GE. THICK) GO TO 101 100 CONTINUE IF ((TEMPT-T).GT.10.) Z=THICK 101 Z=MAX(Z,0.) Z=MIN(Z,THICK) C C DETERMINE FRICTIONAL AND PLASTIC RESISTANCES C SFMIN=PE0*STFRIC*FACTOR SFMAX=(PE0+Z*DPEDZ)*STFRIC*FACTOR IF (SFMAX.LE.DCREEP(ILAYER).OR.Z.EQ.0.) THEN CONST=Z*(SFMAX+SFMIN)/2. PLAST=0. ELSE IF (SFMIN.GE.DCREEP(ILAYER)) THEN PLAST=Z*DCREEP(ILAYER) CONST=0. ELSE ZT=Z*(DCREEP(ILAYER)-SFMIN)/(SFMAX-SFMIN) CONST=0.5*ZT*(SFMIN+DCREEP(ILAYER)) PLAST=(Z-ZT)*DCREEP(ILAYER) ENDIF ENDIF C C FIND REFERENCE LEVEL TO WHICH NODAL VELOCITIES REFER: C IN CRUST, THIS IS ALWAYS THE SURFACE, C IN MANTLE, IT IS THE STRONGEST LEVEL. C IF (MANTLE) THEN ZBEAM=THICK STRMAX=0.0 DO 110 K=0,10,1 ZP=(THICK*K)/10 ZPABS=ZP+CRUST TP=TEMP(ZP,M,I) SCP=ACREEP(3)*EN* + EXP((BCREEP(3)+CCREEP(3)*ZPABS)/TP) SF=STFRIC*(PE0+DPEDZ*ZP)*FACTOR SCP=MIN(SCP,DCREEP(3),SF) IF (SCP.GE.STRMAX) THEN ZBEAM=ZP STRMAX=SCP ENDIF 110 CONTINUE ELSE ZBEAM=0.0 ENDIF C C INTEGRATE CREEP RESISTANCE C VAR=0. IF (Z.LT.THICK) THEN T=TEMP(Z,M,I) ZABS=Z IF (MANTLE) ZABS=Z+CRUST TOPSC=ACREEP(ILAYER)*EN* + EXP((BCREEP(ILAYER)+CCREEP(ILAYER)*ZABS)/T) OLDSC=TOPSC IBASE=THICK/ONEKM DO 120 JITER=1,IBASE ZP=Z+ONEKM ZPABS=ZABS+ONEKM IF (MANTLE) THEN IL=3 ELSE IF (ZPABS.GT.CONINT(M,I)) THEN IL=2 ELSE IL=1 ENDIF ENDIF TP=TEMP(ZP,M,I) SCP=ACREEP(IL)*EN* + EXP((BCREEP(IL)+CCREEP(IL)*ZPABS)/TP) SF=STFRIC*(PE0+DPEDZ*ZP)*FACTOR SCP=MIN(SCP,DCREEP(IL),SF) C NOTE: INTEGRAL STOPS WHEN PASSING THROUGH A DETACHMENT (WHERE C STRAIN-RATES WOULD DIFFER FROM SURFACE VALUES) IF (ZP.GT.ZBEAM.AND.SCP.LE.SIGHBI) GO TO 122 VAR=VAR+ONEKM*0.5*(OLDSC+SCP) IF (ZP.GE.THICK) GO TO 121 Z=ZP ZABS=ZPABS OLDSC=SCP 120 CONTINUE 121 VAR=VAR+(THICK-ZP)*SCP 122 CONTINUE ENDIF VIST=VAR/DEFORM C C MORE PRECISE TREATMENT OF FRICTIONAL RESISTANCE C IF ((CONST+PLAST).GT.0.) THEN CONST=CONST/(STFRIC*FACTOR) RATIO=(1.+STFRIC)/(1.-STFRIC) DTFEXT=CONST*(1.-1./RATIO) DTFCOM=CONST*(1.-RATIO) DT1(1)=DTFEXT+2.*PLAST DT2(1)=DTFEXT+2.*PLAST DT1(2)=0. DT2(2)=DTFEXT+2.*PLAST DT1(3)=DTFCOM-2.*PLAST DT2(3)=0. DT1(4)=DTFCOM-2.*PLAST DT2(4)=DTFCOM-2.*PLAST DO 220 K=1,4 DTF1(K)=DT1(K) DTF2(K)=DT2(K) DO 210 NITER=1,3 ETALPH(K)=DT1(K)/(2.*VISMAX*THICK) ETBETA(K)=DT2(K)/(2.*VISMAX*THICK) ET2(K)=(2.*ETBETA(K)-ETALPH(K))/3. ET1(K)=ETBETA(K)-2.*ET2(K) ETZ= -ET1(K) -ET2(K) SINK=ET1(K)*ET2(K) + ET1(K)*ETZ + ET2(K)*ETZ DEFNK=2.*SQRT(ABS(SINK)) VISP=VIST*(DEFNK/DEFORM)**(ECREEP(ILAYER)-1.) DT1(K)=DTF1(K)+2.*VISP*ETALPH(K) DT2(K)=DTF2(K)+2.*VISP*ETBETA(K) 210 CONTINUE ETALPH(K)=DT1(K)/(2.*VISMAX*THICK) ETBETA(K)=DT2(K)/(2.*VISMAX*THICK) ET2(K)=(2.*ETBETA(K)-ETALPH(K))/3. ET1(K)=ETBETA(K)-2.*ET2(K) 220 CONTINUE FRACZ=(ET1(2)+ET2(2))/((ET1(2)+ET2(2))-(ET1(3)+ET2(3))) SSERR=FRACZ*(DTF1(3)+DTF2(3))+(1.-FRACZ)*(DTF1(2)+DTF2(2)) SLOPE=(DTF1(2)+DTF2(2)-DTF1(3)-DTF2(3)) / + (ET1(2) +ET2(2) -ET1(3) -ET2(3) ) EMOVE=0.5*SSERR/SLOPE ET1(2)=ET1(2)+EMOVE ET2(2)=ET2(2)+EMOVE ET1(3)=ET1(3)+EMOVE ET2(3)=ET2(3)+EMOVE IF(E1.LT.ET1(1)) GO TO 230 IREGON=1 C DOUBLE NORMAL-FAULT CONJUGATE SETS T1=DTF1(1) + +2.*VIST*(2.*E1+E2) T2=DTF2(1) + +2.*VIST*(2.*E2+E1) DT1DE1=DTF1(1)/(2.*E1)+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=DTF2(1)/(2.*E2)+4.*VIST GO TO 290 230 IF(E1.LT.ET1(2)) GO TO 240 FRAC=(ET1(1)-E1)/(ET1(1)-ET1(2)) E2LIM=ET2(1)+(ET2(2)-ET2(1))*FRAC IF(E2.LT.E2LIM) GO TO 235 IREGON=2 C SINGLE NORMAL FAULT SET T1=FRAC*DTF1(2)+(1.-FRAC)*DTF1(1) + +2.*VIST*(2.*E1+E2) T2=FRAC*DTF2(2)+(1.-FRAC)*DTF2(1) + +2.*VIST*(2.*E2+E1) DT1DE1=4.*VISMAX*THICK DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=T2/E2 GO TO 290 235 IREGON=0 C PURELY VISCOUS RANGE T1=2.*VISMAX*(2.*E1+E2)*THICK T2=2.*VISMAX*(2.*E2+E1)*THICK DT1DE1=4.*VISMAX*THICK DT1DE2=2.*VISMAX*THICK DT2DE1=DT1DE2 DT2DE2=DT1DE1 GO TO 290 240 FRAC=((ET1(2)+ET2(2))-(E1+E2))/((ET1(2)+ET2(2))- 1 (ET1(3)+ET2(3))) IF(FRAC.GT.0.) GO TO 250 IREGON=3 C NORMAL + STRIKE-SLIP SETS T1=DTF1(2) + +2.*VIST*(2.*E1+E2) T2=DTF2(2) + +2.*VIST*(2.*E2+E1) IF (E1.LE.-0.5*E2) THEN ESUM=E1+E2 EDIF=E1-E2 TSUM=T1+T2 TDIF=T1-T2 DT1DE1=0.5*(TSUM/ESUM+TDIF/EDIF) DT1DE2=0.5*(TSUM/ESUM-TDIF/EDIF) DT2DE1=DT1DE2 DT2DE2=DT1DE1 ELSE DT1DE1=-0.5*DTF1(1)/E1+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=T2/E2 ENDIF GO TO 290 250 IF(FRAC.GT.1.) GO TO 260 E2LIM=ET2(2)+(ET2(3)-ET2(2))*FRAC IF(E2.LT.E2LIM) GO TO 235 IREGON=4 C CONJUGATE STRIKE-SLIP SET TF1=FRAC*DTF1(3)+(1.-FRAC)*DTF1(2) T1=TF1+2.*VIST*(2.*E1+E2) TF2=FRAC*DTF2(3)+(1.-FRAC)*DTF2(2) T2=TF2+2.*VIST*(2.*E2+E1) Q=((DTF1(2)-DTF2(2))-(DTF1(3)-DTF2(3))) / + ((ET1 (2)+ET2 (2))-(ET1 (3)+ET2 (3))) DT1DE1=3.*VISMAX*THICK+0.5*(T1-T2)/(E1-E2)+0.5*Q DT1DE2=3.*VISMAX*THICK-0.5*(T1-T2)/(E1-E2)+0.5*Q DT2DE1=DT1DE2-Q DT2DE2=DT1DE1-Q GO TO 290 260 IF(E2.LT.ET2(3)) GO TO 270 IREGON=5 C STRIKE-SLIP + THRUST SETS T1=DTF1(3) + +2.*VIST*(2.*E1+E2) T2=DTF2(3) + +2.*VIST*(2.*E2+E1) IF (E2.GE.-0.5*E1) THEN ESUM=E1+E2 EDIF=E1-E2 TSUM=T1+T2 TDIF=T1-T2 DT1DE1=0.5*(TSUM/ESUM+TDIF/EDIF) DT1DE2=0.5*(TSUM/ESUM-TDIF/EDIF) DT2DE1=DT1DE2 DT2DE2=DT1DE1 ELSE DT1DE1=T1/E1 DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=-0.5*DTF2(4)/E2+4.*VIST ENDIF GO TO 290 270 IF(E2.LT.ET2(4)) GO TO 275 FRAC=(ET2(3)-E2)/(ET2(3)-ET2(4)) E1LIM=ET1(3)+(ET1(4)-ET1(3))*FRAC IF(E1.GT.E1LIM) GO TO 235 IREGON=6 C ONE CONJUGATE THRUST SET T1=FRAC*DTF1(4)+(1.-FRAC)*DTF1(3) + +2.*VIST*(2.*E1+E2) T2=FRAC*DTF2(4)+(1.-FRAC)*DTF2(3) + +2.*VIST*(2.*E2+E1) DT1DE1=T1/E1 DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=4.*VISMAX*THICK GO TO 290 275 IREGON=7 C DOUBLE THRUST SETS T1=DTF1(4) + +2.*VIST*(2.*E1+E2) T2=DTF2(4) + +2.*VIST*(2.*E2+E1) DT1DE1=DTF1(4)/(2.*E1)+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=DTF2(4)/(2.*E2)+4.*VIST 290 CONTINUE ELSE VISLIM=VISMAX*THICK VIS=MIN(VIST,VISLIM) IREGON=8 IF (VIS.LT.VIST) IREGON=0 T1=2.*VIS*(2.*E1+E2) T2=2.*VIS*(2.*E2+E1) DT1DE1=4.*VIS DT1DE2=2.*VIS DT2DE1=DT1DE2 DT2DE2=DT1DE1 ENDIF RADT=0.5*(T2-T1) IF((E1-E2).NE.0.) THEN C=(T2-T1)/(E2-E1) ELSE C=0. ENDIF TXX=.5*(C*(EXX-EYY)+T1+T2) TYY=T1+T2-TXX TXY=C*EXY RETURN END C C C SUBROUTINE SOLVER (ABD,NKDIM,BX,NTNM,NBAND,IPVT,NXL,FAILUR) C C SETS UP FOR CALL TO THE LIBRARY ROUTINE WHICH ACTUALLY C SOLVES THE LINEAR EQUATION SYSTEM C C CURRENT VERSION IS PER CONVENTIONS OF IBM'S ESSL LIBRARY, C DOUBLE PRECISION VERSION. C DOUBLE PRECISION ABD,BX LOGICAL FAILUR DIMENSION ABD(NKDIM),BX(NTNM),IPVT(NXL) C C ****************** IMPORTANT ************************************ C ALL INDEXK DEFINITION STATEMENTS IN PACKAGE MUST AGREE ! INDEXK(IR,JC,NBAND)=2*NBAND+1+IR-JC+(JC-1)*(3*NBAND+16) C****************************************************************** C N=NTNM ML=NBAND MU=NBAND LDA=2*ML+MU+16 CALL DGBF(ABD,LDA,N,ML,MU,IPVT) CALL DGBS(ABD,LDA,N,ML,MU,IPVT,BX) C C PREVENT LATER UNDERFLOWS DUE TO SLOPPY ENFORCEMENT OF 0 VALUES C DO 10 I=1,N SIZE=ABS(BX(I)) IF (SIZE.LE.1.E-35) BX(I)=0. 10 CONTINUE RETURN END C C C SUBROUTINE EDOT (NUMEL,NODES,V,NUMNOD,DXS,DYS,ERATE, + ALPHA,TOFSET,TAUMAT) C C COMPUTE STRAIN-RATE COMPONENTS EDOTXX, EDOTYY, AND C EDOTXY (TENSOR FORM) AND THE "FOURTH COMPONENT" C (ROTATION RATE OF STIFF INCLUSIONS) AT INTEGRATION POINTS C C ALSO COMPUTES VERTICAL INTEGRALS OF DEFORMATIONAL (DEVIATORIC) C STRESS: TAUMAT C DIMENSION ALPHA(3,3,7,NUMEL),DXS(6,7,NUMEL),DYS(6,7,NUMEL), + ERATE(4,7,NUMEL),NODES(6,0:NUMEL), + TAUMAT(3,7,NUMEL),TOFSET(3,7,NUMEL),V(2,NUMNOD) DO 1000 M=1,7 DO 900 I=1,NUMEL EXX=0. EYY=0. EXY=0. ROT=0. DO 800 J=1,6 NODE=NODES(J,I) VX=V(1,NODE) VY=V(2,NODE) DX=DXS(J,M,I) DY=DYS(J,M,I) EXX=EXX+VX*DX EYY=EYY+VY*DY EXY=EXY+(VX*DY+VY*DX)*0.5 ROT=ROT+(VY*DX-VX*DY)*0.5 800 CONTINUE ERATE(1,M,I)=EXX ERATE(2,M,I)=EYY ERATE(3,M,I)=EXY ERATE(4,M,I)=ROT TAUMAT(1,M,I)=TOFSET(1,M,I)+EXX*ALPHA(1,1,M,I)+ + EYY*ALPHA(1,2,M,I)+EXY*ALPHA(1,3,M,I) TAUMAT(2,M,I)=TOFSET(2,M,I)+EXX*ALPHA(2,1,M,I)+ + EYY*ALPHA(2,2,M,I)+EXY*ALPHA(2,3,M,I) TAUMAT(3,M,I)=TOFSET(3,M,I)+EXX*ALPHA(3,1,M,I)+ + EYY*ALPHA(3,2,M,I)+EXY*ALPHA(3,3,M,I) 900 CONTINUE 1000 CONTINUE RETURN END C C C SUBROUTINE EBCS (NELCOL,FLOWIN,NUMNOD,NDIFF, + CODE,NCDIM) C C ADDS EDGE BOUNDARY CONDITIONS OF ZERO SCALAR VALUE ON ALL C INLAND BOUNDARY NODES BY OPERATIONS ON MATRIX CODE C AND VECTOR FLOWIN C DOUBLE PRECISION CODE,FLOWIN DIMENSION CODE(NCDIM),FLOWIN(NUMNOD) NACROS=NELCOL*2+1 DO 10 J=1,NACROS CALL FIXVAL (J,FLOWIN,NUMNOD,NDIFF,CODE,NCDIM,0.) 10 CONTINUE JL=NUMNOD JF=JL-NACROS+1 DO 20 J=JF,JL CALL FIXVAL (J,FLOWIN,NUMNOD,NDIFF,CODE,NCDIM,0.) 20 CONTINUE IL=NUMNOD/NACROS-1 DO 30 I=2,IL J=NACROS*I CALL FIXVAL (J,FLOWIN,NUMNOD,NDIFF,CODE,NCDIM,0.) 30 CONTINUE RETURN END C C C SUBROUTINE FIXVAL (I,FLOWIN,NUMNOD,NDIFF,CODE,NCDIM,VALUE) C C SETS SCALAR TO VALUE AT NODE I C CAUTION: C NOTE THAT THIS ROUTINE MAY DESTROY SYMMETRY OF MATRIX CODE C THAT WAS PREVIOUSLY SYMMETRICAL !!! C DOUBLE PRECISION CODE,FLOWIN DIMENSION CODE(NCDIM),FLOWIN(NUMNOD) INDEXK(IR,JC,NBAND)=2*NBAND+1+IR-JC+(JC-1)*(3*NBAND+16) C USE: INDEXK(IR,JC,NDIFF) KD=INDEXK(I,I,NDIFF) PIVOT=CODE(KD) JF=MAX(1,I-NDIFF) JL=MIN(NUMNOD,I+NDIFF) DO 10 J=JF,JL K=INDEXK(I,J,NDIFF) CODE(K)=0. 10 CONTINUE CODE(KD)=MAX(1.,PIVOT) FLOWIN(I)=CODE(KD)*VALUE RETURN END C C C SUBROUTINE REPORT (ISTEP,NTREAD,XIPC,XIPM,YIPC,YIPM, + XNODC,XNODM,YNODC,YNODM,TITLE,VM,NODES, + OUTSCA,OUTVEC,VC,ERATEM,ERATEC, + THIKM,THIKC,GEOTHA,GEOTHC,CONDUC, + GEOTHM,DNLINK,VPMEAN,DVPBYE,DVPDT, + TIME2,NUMNOD,NUMEL,G, + HMAX,HMIN,RHOAST,RHOH2O,SIGHC,SIGHBM,SIGZZC, + SIGZZM,TAUMTC,TAUMTM,TAUZZC,TAUZZM, + TEMLIM,ONEKM,ESUMC,ESUMM,AREAC,AREAM, A CODE,CONDNS,DETJC,DETJM,FAILUR,FLOWIN, + NCDIM,NDIFF,NXL,LWORK,WC,WM, + SZZBC,SZZBM,TOUCHC,TOUCHM, + ECLOG,RADIUS,SLABSZ,CPNLAT,IBELOW,X0ELON, + Y0NLAT,VSLABC,VSLABM,OUTV2,RAMP, + THNKC,UPLINK,TASTH,TSLAB0, + DOPLOT,SCALEC,NCONTR, + STATES,RMSVEC,NELCOL,PHINOD,DRAWST, + NXYST,XST,YST,NELROW,THNKM,FBLAND,LOWBLU, + CINT,FROMWC,FROMWM,WANDES,CONINT, B CONNOD,TSURF,PUSHUP) C C PRINTS MAPS OF IMPORTANT QUANTITIES ON LINE PRINTER. C PLOTS SHOW VALUES AT INTEGRATION POINTS, WITH LOCATION C FUDGED TO NEAREST POINT IN RECTANGULAR PRINTING GRIDS. C WHEN TWO OR MORE POINTS SHARE A PRINT GRID SQUARE, C SCALAR VALUES OR SIMPLE VECTORS ARE AVERAGED ACCORDING TO C THEIR GAUSSIAN WEIGHTS; BUT "VECTORS" REPRESENTING PRINCIPAL C AXES OF SECOND-RANK TENSORS ARE JUST OVERLAID, WITH C PRIORITY ACCORDING TO GAUSSIAN WEIGHT. C SCALARS ARE REPRESENTED BY DIGITS 0,1,2,3,4,5,6,7,8,9,*. C VECTORS (AND PRINCIPAL AXES OF TENSORS, TREATED AS VECTORS) C ARE REPRESENTED BY NUMERICAL DIGIT 0-* AND A LETTER A-L C WHICH REPRESENTS DIRECTION ACCORDING TO CODE A=1 O'CLOCK, C B=2 O'CLOCK....L=12 O'CLOCK. C IN THE CASE OF PRINCIPAL AXIS "VECTORS", THE CONVENTION IS C THAT DIRECTIONS A-F MEAN NEGATIVE PRINCIPAL VALUES, C AND DIRECTIONS G-L MEAN POSITIVE VALUES. C C BEFORE USE, FILL IN THE X (HORIZONTAL) AND Y (VERTICAL) C INCREMENT OF THE PRINTER (IN INCHES): DXPR & DYPR C AND ALSO THE EFFECTIVE NUMBER OF LINES IN A PAGE: NLINES C IN THE DATA STATEMENT BELOW. COLUMNS NPCOL WILL USUALLY BE 132; C THE INVISIBLE FIRST POSITION FOR CARRIAGE CONTROL IS NOT COUNTED. C CHARACTER*1 BLANK,BOARD1(59,63),BOARD2(59,63),CITY CHARACTER*80 TITLE CHARACTER*42 TEXT,VUNITS LOGICAL ALLPOS,AVERAG,DOAROW,DOAXES,DOFLTS,DOPLOT,DRAWST, + FAILUR,LOCKIN,LOCKWC,SOMNEG,STATES DOUBLE PRECISION CODE,FLOWIN DIMENSION AREAC(NUMEL),AREAM(NUMEL), 2 CODE(NCDIM),CONDUC(2),COUNT(59,63),CONDNS(NUMNOD), 3 CINT(24),CONINT(7,NUMEL),CONNOD(NUMNOD), 4 DETJC(7,NUMEL),DETJM(7,NUMEL),DNLINK(3,7,NUMEL), 5 DOPLOT(24),DRAWST(NXYST),DVPBYE(2,2), 6 DVPDT(2),ERATEC(4,7,NUMEL),ERATEM(4,7,NUMEL), 7 ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL),FBLAND(24), 8 FLOWIN(NUMNOD),FROMWC(7,NUMEL),FROMWM(7,NUMEL), 9 GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL),GEOTHM(4,7,NUMEL), A HMAX(2),HMIN(2),LOWBLU(24),LWORK(NXL), 1 NODES(6,0:NUMEL),NVCHAR(24),NVUCHR(24), 2 OUTSCA(7,NUMEL),OUTVEC(2,7,NUMEL),OUTV2(2,7,NUMEL), 3 PHINOD(NUMNOD), 4 SIGHBM(2,7,NUMEL),SIGHC(2,7,NUMEL),SIGZZC(7,NUMEL), 5 SIGZZM(7,NUMEL),STACK(2,59,63), 6 SZZBC(7,NUMEL),SZZBM(7,NUMEL), 7 TAUMTC(3,7,NUMEL),TAUMTM(3,7,NUMEL) DIMENSION TAUZZC(7,NUMEL),TAUZZM(7,NUMEL),TEMLIM(2), 2 TEXT(24),THIKC(7,NUMEL),THIKM(7,NUMEL), 3 THNKC(NUMNOD),THNKM(NUMNOD),UPLINK(3,7,NUMEL), 4 TOUCHC(7,NUMEL),TOUCHM(7,NUMEL), 5 VPMEAN(2),VC(2,NUMNOD),VM(2,NUMNOD), 6 VSLABC(2,7,NUMEL),VSLABM(2,7,NUMEL), 7 VUNITS(24),WC(NUMNOD),WM(NUMNOD), 8 XIPC(7,NUMEL),XIPM(7,NUMEL), 9 XNODC(NUMNOD),XNODM(NUMNOD), A XST(NXYST),YST(NXYST),YIPC(7,NUMEL),YIPM(7,NUMEL), 1 YNODC(NUMNOD),YNODM(NUMNOD) C SAVE COLFAC,COLCON,DX,DY,IORIGI,JORIGI,KRL,KCL,ROWCON,ROWFAC, + SCALEP,XMAX,XMIN,YMAX,YMIN C DATA BLANK/' '/,CITY/'#'/ C UCLA:DATA DXPR/0.100/,DYPR/0.125/,NLINES/63/,NPCOL/132/ C CHEV:DATA DXPR/0.100/,DYPR/0.167/,NLINES/58/,NPCOL/132/ DATA DXPR/0.100/,DYPR/0.125/,NLINES/63/,NPCOL/132/ C DATA TEXT(1)/'MANTLE: BASAL SHEAR STRESS '/ DATA NVCHAR(1)/26/ DATA VUNITS(1)/'DYNE/CM**2 '/ DATA NVUCHR(1)/10/ DATA TEXT(2)/'CRUST: BASAL SHEAR STRESS '/ DATA NVCHAR(2)/25/ DATA VUNITS(2)/'DYNE/CM**2 '/ DATA NVUCHR(2)/10/ DATA TEXT(3)/'MANTLE: VELOCITY '/ DATA NVCHAR(3)/16/ DATA VUNITS(3)/'CM/SEC '/ DATA NVUCHR(3)/6/ DATA TEXT(4)/'CRUST: VELOCITY '/ DATA NVCHAR(4)/15/ DATA VUNITS(4)/'CM/SEC '/ DATA NVUCHR(4)/6/ DATA TEXT(5)/'MANTLE: FAULT PLANES AND MAX. E-RATE '/ DATA NVCHAR(5)/36/ DATA VUNITS(5)/'1/SEC '/ DATA NVUCHR(5)/5/ DATA TEXT(6)/'CRUST: FAULT PLANES AND MAX. E-RATE '/ DATA NVCHAR(6)/35/ DATA VUNITS(6)/'1/SEC '/ DATA NVUCHR(6)/5/ DATA TEXT(7)/'MANTLE: STRESS AXES & SHEAR INTENSITY '/ DATA NVCHAR(7)/37/ DATA VUNITS(7)/'DYNE/CM '/ DATA NVUCHR(7)/7/ DATA TEXT(8)/'CRUST: STRESS AXES & SHEAR INTENSITY '/ DATA NVCHAR(8)/36/ DATA VUNITS(8)/'DYNE/CM '/ DATA NVUCHR(8)/7/ DATA TEXT(9)/'MANTLE: GRID OF ELEMENTS '/ DATA NVCHAR(9)/24/ DATA VUNITS(9)/' '/ DATA NVUCHR(9)/0/ DATA TEXT(10)/'CRUST: GRID OF ELEMENTS '/ DATA NVCHAR(10)/23/ DATA VUNITS(10)/' '/ DATA NVUCHR(10)/0/ DATA TEXT(11)/'MANTLE:RATE OF THICKENING(PURE SHEAR ONLY)'/ DATA NVCHAR(11)/42/ DATA VUNITS(11)/'CM/SEC '/ DATA NVUCHR(11)/6/ DATA TEXT(12)/'CRUST: RATE OF THICKENING(PURE SHEAR ONLY)'/ DATA NVCHAR(12)/42/ DATA VUNITS(12)/'CM/SEC '/ DATA NVUCHR(12)/6/ DATA TEXT(13)/'MANTLE: THICKNESS '/ DATA NVCHAR(13)/17/ DATA VUNITS(13)/'CM '/ DATA NVUCHR(13)/2/ DATA TEXT(14)/'CRUST: THICKNESS '/ DATA NVCHAR(14)/16/ DATA VUNITS(14)/'CM '/ DATA NVUCHR(14)/2/ DATA TEXT(15)/'MANTLE: BASAL TEMPERATURE '/ DATA NVCHAR(15)/25/ DATA VUNITS(15)/'KELVIN '/ DATA NVUCHR(15)/6/ DATA TEXT(16)/'CRUST: BASAL TEMPERATURE '/ DATA NVCHAR(16)/24/ DATA VUNITS(16)/'KELVIN '/ DATA NVUCHR(16)/6/ DATA TEXT(17)/'TELESEISMIC P TRAVEL-TIME RESIDUALS '/ DATA NVCHAR(17)/35/ DATA VUNITS(17)/'SEC (LATE) '/ DATA NVUCHR(17)/10/ DATA TEXT(18)/'ISOSTATIC TOPOGRAPHY '/ DATA NVCHAR(18)/20/ DATA VUNITS(18)/'CM '/ DATA NVUCHR(18)/2/ DATA TEXT(19)/'PALEO-HEAT-FLOW '/ DATA NVCHAR(19)/15/ DATA VUNITS(19)/'ERG/CM**2/S '/ DATA NVUCHR(19)/11/ DATA TEXT(20)/'TOPOGRAPHY AFTER DELAMINATION '/ DATA NVCHAR(20)/29/ DATA VUNITS(20)/'CM '/ DATA NVUCHR(20)/2/ DATA TEXT(21)/'CRUST: LOG (NET STRAIN) AND FAULT PLANES '/ DATA NVCHAR(21)/40/ DATA VUNITS(21)/'COMMON LOG OF E1 OR E3 '/ DATA NVUCHR(21)/22/ DATA TEXT(22)/'CRUST: NET CLOCKWISE ROTATION '/ DATA NVCHAR(22)/29/ DATA VUNITS(22)/'DEGREES '/ DATA NVUCHR(22)/7/ DATA TEXT(23)/'THICKNESS OF CRUST ABOVE CONRAD '/ DATA NVCHAR(23)/31/ DATA VUNITS(23)/'CM '/ DATA NVUCHR(23)/2/ DATA TEXT(24)/'THICKNESS OF CRUST BELOW CONRAD '/ DATA NVCHAR(24)/31/ DATA VUNITS(24)/'CM '/ DATA NVUCHR(24)/2/ C C STATEMENT FUNCTIONS: IROW(Y)=MAX(1,MIN(KRL,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(KCL,INT(COLFAC*X+COLCON+1.5))) C SCALE=2.54*SCALEC IF (ISTEP.EQ.1) THEN KRL=MIN(59,NLINES-5) KCL=MIN(63,(NPCOL-6)/2) XMIN=1.E50 YMIN=1.E50 XMAX= -1.E50 YMAX= -1.E50 DO 10 I=1,NUMNOD XMIN=MIN(XMIN,XNODC(I),XNODM(I)) YMIN=MIN(YMIN,YNODC(I),YNODM(I)) XMAX=MAX(XMAX,XNODC(I),XNODM(I)) YMAX=MAX(YMAX,YNODC(I),YNODM(I)) 10 CONTINUE DX=(XMAX-XMIN)/(KCL-1.) DY=(YMAX-YMIN)/(KRL-1.) DX=MAX(DX,DY*DXPR/DYPR) DY=MAX(DY,DX*DYPR/DXPR) SCALEP=DX/DXPR ROWFAC= -1./DY COLFAC= 1./DX ROWCON= 0.5*((0.0-ROWFAC*YMAX)+(KRL-1.-ROWFAC*YMIN)) COLCON= 0.5*((0.0-COLFAC*XMIN)+(KCL-1.-COLFAC*XMAX)) IORIGI=IROW(0.) JORIGI=JCOL(0.) ENDIF LOCKIN=.FALSE. LOCKWC=.FALSE. T2MA=TIME2/(1.E6*365.25*24.*60.*60.) 20 FORMAT(1H1,A80,' AGE = ',1P,E10.3,' (',0P,F8.3,')') IF (DOPLOT(1).OR.DOPLOT(2)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,101) 101 FORMAT(' HORIZONTAL STRESSES ON:'/ + ' MANTLE (BASE ONLY)',51X, + 'CRUST (BASE ONLY)') AVERAG=.TRUE. ALLPOS=.TRUE. SOMNEG=.NOT.ALLPOS CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,SIGHBM,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(1)) THEN CALL MAGNIT (SIGHBM,NUMEL,OUTSCA,SOMNEG) CALL EXTRAP(AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON1=CINT(1) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.TRUE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,1,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,SIGHBM,RMSVEC,XIPM,YIPM, + DOFLTS) ENDIF CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,SIGHC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(2)) THEN CALL MAGNIT (SIGHC,NUMEL,OUTSCA,SOMNEG) CALL EXTRAP(AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON2=CINT(2) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.TRUE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,2,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,SIGHC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 102 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 102 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(3).OR.DOPLOT(4)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,201) 201 FORMAT(' VELOCITY VECTORS:'/' MANTLE',63X,'CRUST') CALL FLOW (VM,NUMNOD,NODES,NUMEL,OUTVEC) AVERAG=.TRUE. ALLPOS=.TRUE. SOMNEG=.NOT.ALLPOS CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(3)) THEN CALL MAGNIN (VM,NUMNOD,CONDNS) CALL MAGNIT (OUTVEC,NUMEL,OUTSCA,SOMNEG) DFCON1=CINT(3) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.TRUE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,3,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPM,YIPM, + DOFLTS) ENDIF CALL FLOW (VC,NUMNOD,NODES,NUMEL,OUTVEC) CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(4)) THEN CALL MAGNIN (VC,NUMNOD,CONDNS) CALL MAGNIT (OUTVEC,NUMEL,OUTSCA,SOMNEG) DFCON2=CINT(4) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.TRUE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,4,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 202 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 202 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(5).OR.DOPLOT(6)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,301) 301 FORMAT(' LARGEST MAGNITUDE PRINCIPAL STRAIN-RATE (NOTE' + ,': A-F NEGATIVE; G-L POSITIVE.)'/ + ' MANTLE',63X,'CRUST') CALL STRAIN (ERATEM,NUMEL,OUTVEC) AVERAG=.FALSE. ALLPOS=.TRUE. CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(5)) THEN CALL MAXER (ERATEM,NUMEL,OUTSCA) CALL EXTRAP(AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON1=CINT(5) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.TRUE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,5,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPM,YIPM, + DOFLTS,ERATEM) ENDIF CALL STRAIN (ERATEC,NUMEL,OUTVEC) CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(6)) THEN CALL MAXER (ERATEC,NUMEL,OUTSCA) CALL EXTRAP(AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON2=CINT(6) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.TRUE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,6,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS,ERATEC) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 302 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 302 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(7).OR.DOPLOT(8)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,401) 401 FORMAT(' LARGEST MAGNITUDE HORIZONTAL PRINCIPAL', + ' STRESS ANOMALY', + ' INTEGRAL (NOTE: A-F NEGATIVE; G-L', + ' POSITIVE.):'/ + ' MANTLE',63X,'CRUST') CALL STRESS (TAUMTM,TAUZZM,OUTVEC,NUMEL) AVERAG=.FALSE. ALLPOS=.TRUE. CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(7)) THEN CALL MAXSS (TAUMTM,TAUZZM,NUMEL,OUTSCA) CALL EXTRAP(AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON1=CINT(7) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.TRUE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,7,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPM,YIPM, + DOFLTS,ERATEM,TAUMTM,TAUZZM) ENDIF CALL STRESS (TAUMTC,TAUZZC,OUTVEC,NUMEL) CALL VPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(8)) THEN CALL MAXSS (TAUMTC,TAUZZC,NUMEL,OUTSCA) CALL EXTRAP(AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON2=CINT(8) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.TRUE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,8,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS,ERATEC,TAUMTC,TAUZZC) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 402 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 402 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(9).OR.DOPLOT(10)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,501) 501 FORMAT(' GRID OF FINITE ELEMENTS:'/ + ' MANTLE',63X,'CRUST') CALL NET + (BOARD1,XNODM,YNODM, + NUMNOD,NODES,NUMEL,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(9)) THEN CALL ETCH (DRAWST,NTREAD,9, + NODES,NUMEL,NUMNOD,NVCHAR,NXYST, + STATES,TEXT,TITLE,T2MA, + XMIN,XMAX,XNODM,XST,YMIN,YMAX,YNODM,YST) ENDIF CALL NET + (BOARD2,XNODC,YNODC, + NUMNOD,NODES,NUMEL,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(10)) THEN CALL ETCH (DRAWST,NTREAD,10, + NODES,NUMEL,NUMNOD,NVCHAR,NXYST, + STATES,TEXT,TITLE,T2MA, + XMIN,XMAX,XNODC,XST,YMIN,YMAX,YNODC,YST) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 502 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 502 CONTINUE WRITE(6,2100) SCALEP,SCALEP ENDIF IF (DOPLOT(11).OR.DOPLOT(12)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,601) 601 FORMAT(' RATE OF THICKENING OF THE LAYERS:'/ + ' MANTLE',63X,'CRUST (W/O SPREADING)') ALLPOS=.FALSE. CALL INTERP(WM,NODES,NUMEL,NUMNOD,OUTSCA) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(11)) THEN DFCON1=CINT(11) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,WM,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,11,T2MA, + WM,DFCON1,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPM,YIPM, + DOFLTS) ENDIF CALL INTERP(WC,NODES,NUMEL,NUMNOD,OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(12)) THEN DFCON2=CINT(12) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,WC,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,12,T2MA, + WC,DFCON2,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 602 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 602 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(13).OR.DOPLOT(14)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,701) 701 FORMAT(' THICKNESS OF LAYERS:'/ + ' MANTLE',63X,'CRUST') ALLPOS=.TRUE. CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,THIKM,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(13)) THEN DFCON1=CINT(13) IF (DFCON1.LE.0.) + CALL INTRVL (THIKM,NUMEL,THNKM,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,13,T2MA, + THNKM,DFCON1,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPM,YIPM, + DOFLTS) ENDIF CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,THIKC,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(14)) THEN DFCON2=CINT(14) IF (DFCON2.LE.0.) + CALL INTRVL (THIKC,NUMEL,THNKC,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,14,T2MA, + THNKC,DFCON2,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 702 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 702 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(15).OR.DOPLOT(16)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,801) 801 FORMAT(' TEMPERATURE AT BASE OF LAYERS:'/ + ' MANTLE',63X,'CRUST') ALLPOS=.TRUE. CALL TMOHO (THIKM,NUMEL,GEOTHM,TEMLIM(2),OUTSCA) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPM,YIPM, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(15)) THEN CALL EXTRAP(AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON1=CINT(15) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODM,YNODM,TITLE,TEXT,15,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPM,YIPM, + DOFLTS) ENDIF CALL TMOHO (THIKC,NUMEL,GEOTHC,TEMLIM(1),OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(16)) THEN CALL EXTRAP(AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON2=CINT(16) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,16,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 802 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 802 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(17).OR.DOPLOT(18)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,901) 901 FORMAT(' PALEO-SURFACE-OBSERVABLES:'/ + ' TELESEISMIC P-WAVE TRAVEL-TIME RESIDUAL', + 30X,'ISOSTATIC TOPOGRAPHY') CALL DELTP (GEOTHC,TEMLIM,ESUMC,ESUMM, + GEOTHM,GEOTHA,THIKM,THIKC,NUMEL,DNLINK, + VPMEAN,DVPBYE,DVPDT,OUTSCA,ONEKM, + THNKC,NODES,NUMNOD,UPLINK,AREAM, + CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NXL,LWORK,HMAX,HMIN) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(17)) THEN ALLPOS=.FALSE. CALL EXTRAP(AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON1=CINT(17) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,17,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF CALL PEAKS (INPUT,G,NUMEL,RADIUS,RHOAST,RHOH2O,SIGZZC, + TIME2, + OUTPUT,OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(18)) THEN ALLPOS=.FALSE. CALL EXTRAP(AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON2=CINT(18) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,18,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 902 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 902 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(19).OR.DOPLOT(20)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,1001) 1001 FORMAT(' PALEO-HEAT-FLOW:',53X, + 'POST-DELAMINATION ELEVATIONS:'/ + ' AT M.Y.B.P. INDICATED IN ()',42X, + '(WITH MANTLE SHAVED TO .LE. NORMAL WEIGHT)') CALL HEAT(GEOTHC,NUMEL,CONDUC,OUTSCA) CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(19)) THEN ALLPOS=.TRUE. CALL EXTRAP(AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON1=CINT(19) IF (DFCON1.LT.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,19,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF CALL REBOUN (INPUT, AREAC,AREAM,DETJC,DETJM,DNLINK, + G,NCDIM,NDIFF,NODES,NUMEL, + NUMNOD,NXL,RADIUS,RHOAST,RHOH2O, + SIGZZC,SIGZZM,SZZBC,SZZBM, + TOUCHC,TOUCHM,TIME2, + OUTPUT,OUTSCA, + WORK, CODE,CONDNS,FLOWIN,LWORK) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(20)) THEN ALLPOS=.FALSE. CALL EXTRAP(AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON2=CINT(20) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,20,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 1002 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 1002 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(21).OR.DOPLOT(22)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,1101) 1101 FORMAT(' TOTAL DEFORMATION OF THE CRUST:'/ + ' LARGEST MAGNITUDE PRINCIPAL NET STRAIN', + ' (A-F NEGATIVE; G-L POSITIVE)', + 3X,'NET ROTATION (DEGREES CLOCKWISE)') CALL ELONG (ESUMC,NUMEL,OUTVEC) AVERAG=.FALSE. SOMNEG=.TRUE. CALL VPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) IF (DOPLOT(21)) THEN CALL GREENS (INPUT,ESUMC,NUMEL, + OUTPUT,ERATEC) CALL MAXER (ERATEC,NUMEL,OUTSCA) DO 1120 M=1,7 DO 1110 I=1,NUMEL OUTSCA(M,I)=ALOG10(MAX(OUTSCA(M,I),1.E-10)) OUTSCA(M,I)=MAX(OUTSCA(M,I),-2.01) 1110 CONTINUE 1120 CONTINUE ALLPOS=.FALSE. CALL EXTRAP(AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON1=CINT(21) IF (DFCON1.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.TRUE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,21,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS,ERATEC) ENDIF CALL ROTOR (ESUMC,NUMEL,OUTSCA) CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(22)) THEN ALLPOS=.FALSE. CALL EXTRAP(AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC,PHINOD,NELCOL) DFCON2=CINT(22) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,22,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 1152 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 1152 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF IF (DOPLOT(23).OR.DOPLOT(24)) THEN WRITE(6,20) TITLE,TIME2,T2MA WRITE(6,1201) 1201 FORMAT(' THICKNESS OF LAYERS WITHIN CRUST:'/ + ' UPPER',63X,'LOWER (MAY BE NEGATIVE)') ALLPOS=.TRUE. CALL SPLOT + (BOARD1,R1LOW,R1HI,COUNT,STACK,XIPC,YIPC, + NUMEL,CONINT,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(23)) THEN DFCON1=CINT(23) IF (DFCON1.LE.0.) + CALL INTRVL (CONINT,NUMEL,CONNOD,NUMNOD, + DFCON1,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,23,T2MA, + CONNOD,DFCON1,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF DO 1220 I=1,NUMNOD CONDNS(I)=MAX(0.,(THNKC(I)-CONNOD(I))) 1220 CONTINUE DO 1250 M=1,7 DO 1240 I=1,NUMEL OUTSCA(M,I)=MAX(0.,(THIKC(M,I)-CONINT(M,I))) 1240 CONTINUE 1250 CONTINUE CALL SPLOT + (BOARD2,R2LOW,R2HI,COUNT,STACK,XIPC,YIPC, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(24)) THEN DFCON2=CINT(24) IF (DFCON2.LE.0.) + CALL INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD, + DFCON2,NCONTR) DOAROW=.FALSE. DOAXES=.FALSE. DOFLTS=.FALSE. CALL PAINT (NODES,XNODC,YNODC,TITLE,TEXT,24,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XMIN,XMAX,YMIN, + YMAX, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPC,YIPC, + DOFLTS) ENDIF BOARD1(IORIGI,JORIGI)=CITY BOARD2(IORIGI,JORIGI)=CITY DO 1280 IR=1,KRL WRITE(6,1900)(BOARD1(IR,JC),JC=1,63), + (BOARD2(IR,JC),JC=1,63) 1280 CONTINUE WRITE(6,2100) SCALEP,SCALEP CI1=(R1HI-R1LOW)/10. CI2=(R2HI-R2LOW)/10. WRITE(6,2200) R1LOW,R1HI,CI1,R2LOW,R2HI,CI2 ENDIF 1900 FORMAT(1H ,63A1,6X,63A1) 2100 FORMAT(' MAP SCALE = ',1P,E10.3,' PER INCH', + 38X,'MAP SCALE = ',1P,E10.3,' PER INCH') 2200 FORMAT(' RANGE = ',1P,E10.3,' TO ',E10.3,', CI = ',E10.3, + 20X,'RANGE = ',E10.3,' TO ',E10.3,', CI = ',E10.3) RETURN END C C C SUBROUTINE VPLOT (BOARD,RLOW,RHI,COUNT,STACK,XIP,YIP, + NUMEL,OUTVEC,ROWFAC,ROWCON, + COLFAC,COLCON,AVERAG) C C CONVERTS VECTOR FIELD TO 1-DIGIT INTEGERS AND DIRECTION LETTERS C AND LOADS THEM INTO APPROPRIATE CELLS IN PRINT MATRIX C CHARACTER*1 BLANK,BOARD(59,63),DIGIT(11),DIREC(13) LOGICAL AVERAG DOUBLE PRECISION WEIGHT COMMON /WGTVEC/ WEIGHT DIMENSION COUNT(59,63), + OUTVEC(2,7,NUMEL), + STACK(2,59,63),WEIGHT(7),XIP(7,NUMEL),YIP(7,NUMEL) DATA BLANK/' '/, DIGIT/'0','1','2','3','4','5','6','7', + '8','9','*'/, DIREC/'L','A','B','C','D','E','F','G','H', + 'I','J','K','L'/ IROW(Y)=MAX(1,MIN(59,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(63,INT(COLFAC*X+COLCON+1.5))) RLOW=1.E50 RHI= -1.E50 DO 10 I=1,59 DO 9 J=1,63 BOARD(I,J)=BLANK COUNT(I,J)=0. STACK(1,I,J)=0. STACK(2,I,J)=0. 9 CONTINUE 10 CONTINUE IF (AVERAG) THEN DO 100 M=1,7 DO 90 I=1,NUMEL IR=IROW(YIP(M,I)) JC=JCOL(XIP(M,I)) COUNT(IR,JC)=COUNT(IR,JC)+WEIGHT(M) STACK(1,IR,JC)=STACK(1,IR,JC)+ + WEIGHT(M)*OUTVEC(1,M,I) STACK(2,IR,JC)=STACK(2,IR,JC)+ + WEIGHT(M)*OUTVEC(2,M,I) 90 CONTINUE 100 CONTINUE ELSE DO 150 M=1,7 DO 140 I=1,NUMEL IR=IROW(YIP(M,I)) JC=JCOL(XIP(M,I)) IF (WEIGHT(M).GE.COUNT(IR,JC)) THEN STACK(1,IR,JC)= + WEIGHT(M)*OUTVEC(1,M,I) STACK(2,IR,JC)= + WEIGHT(M)*OUTVEC(2,M,I) COUNT(IR,JC)=WEIGHT(M) ENDIF 140 CONTINUE 150 CONTINUE ENDIF DO 200 I=1,59 DO 190 J=1,63 IF(COUNT(I,J).GT.0.) THEN STACK(1,I,J)=STACK(1,I,J)/COUNT(I,J) STACK(2,I,J)=STACK(2,I,J)/COUNT(I,J) VMAG=SQRT(STACK(1,I,J)**2+STACK(2,I,J)**2) BEARNG=ATAN2F(STACK(2,I,J),STACK(1,I,J)) RLOW=MIN(RLOW,VMAG) RHI=MAX(RHI,VMAG) STACK(1,I,J)=VMAG STACK(2,I,J)=BEARNG ENDIF 190 CONTINUE 200 CONTINUE IF(RHI.LE.RLOW) THEN RHI=RHI*1.001 RLOW=RLOW*0.999 ENDIF IF(RHI.EQ.0..AND.RLOW.EQ.0.) RHI=1. DO 300 I=1,59 DO 290 J=1,63 IF(COUNT(I,J).GT.0.) THEN ID=(STACK(1,I,J)-RLOW)/(RHI-RLOW) * 10. + 1.5 BOARD(I,J)=DIGIT(ID) IF (J.LT.63.AND.COUNT(I,J+1).LE.0.) THEN BD= -(STACK(2,I,J)/3.1415927)*6.+3. IF(BD.LT.0.) BD=BD+12. ID=BD+1.5 BOARD(I,J+1)=DIREC(ID) ENDIF ENDIF 290 CONTINUE 300 CONTINUE RETURN END C C C SUBROUTINE FLOW (V,NUMNOD,NODES,NUMEL,OUTVEC) C C CALCULATES VELOCITY VECTORS AT INTEGRATION POINTS, FROM NODAL VALUES C DOUBLE PRECISION PHI COMMON /PHITAB/ PHI DIMENSION NODES(6,0:NUMEL),OUTVEC(2,7,NUMEL), + PHI(6,7),V(2,NUMNOD) DO 50 M=1,7 DO 40 I=1,NUMEL OUTVEC(1,M,I)=0. OUTVEC(2,M,I)=0. 40 CONTINUE 50 CONTINUE DO 100 J=1,6 DO 90 M=1,7 DO 80 I=1,NUMEL OUTVEC(1,M,I)=OUTVEC(1,M,I)+V(1,NODES(J,I)) + *PHI(J,M) OUTVEC(2,M,I)=OUTVEC(2,M,I)+V(2,NODES(J,I)) + *PHI(J,M) 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE STRAIN (ERATE,NUMEL,OUTVEC) + C C CALCULATES LARGEST-MAGNITUDE PRINCIPAL STRAIN-RATE IN VECTOR FORM C NOTE THAT STRAIN WORKS WITH VPLOT TO PUT NEGATIVE VECTORS IN A-F C DIMENSION ERATE(4,7,NUMEL),OUTVEC(2,7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) CENTER=(EXX+EYY)*0.5 R=SQRT((EXX-CENTER)**2+EXY**2) IF (CENTER.GT.0.) THEN E=CENTER+R ANGLE=ATAN2F(EXY,E-EYY) IF (ANGLE.LE.1.308996.AND.ANGLE.GT.-1.832596) + ANGLE=ANGLE+3.141593 ELSE E=CENTER-R ANGLE=ATAN2F(EXY,E-EYY) IF (ANGLE.GT.1.308996.OR.ANGLE.LE.-1.832596) + ANGLE=ANGLE+3.141593 E= -E ENDIF OUTVEC(1,M,I)=E*COS(ANGLE) OUTVEC(2,M,I)=E*SIN(ANGLE) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE STRESS (TAUMAT,TAUZZ,OUTVEC,NUMEL) C C CALCULATES LARGEST-MAGNITUDE HORIZONTAL PRINCIPAL C STRESS ANOMALY INTEGRAL, IN VECTOR FORM. C NOTE THAT STRESS WORKS WITH VPLOT TO PUT NEGATIVES IN A-F. C NOTE ALSO THAT THIS IS THE STRESS ANOMALY INTEGRAL (INCLUDES THE C VERTICAL STRESS ANOMALY INTEGRAL) NOT THE DEVIATORIC STRESS C (WHICH CONTROLS LOCAL STRAIN-RATE), SO SHOULD SATISFY EQUILIBRIUM. C DIMENSION OUTVEC(2,7,NUMEL),TAUMAT(3,7,NUMEL), + TAUZZ(7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL TXX=TAUMAT(1,M,I)+TAUZZ(M,I) TYY=TAUMAT(2,M,I)+TAUZZ(M,I) TXY=TAUMAT(3,M,I) CENTER=(TXX+TYY)*0.5 R=SQRT((TXX-CENTER)**2+TXY**2) IF (CENTER.GT.0.) THEN T=CENTER+R ANGLE=ATAN2F(TXY,T-TYY) IF (ANGLE.LE.1.308996.AND.ANGLE.GT.-1.832596) + ANGLE=ANGLE+3.141593 ELSE T=CENTER-R ANGLE=ATAN2F(TXY,T-TYY) IF (ANGLE.GT.1.308996.OR.ANGLE.LE.-1.832596) + ANGLE=ANGLE+3.141593 T= -T ENDIF OUTVEC(1,M,I)=T*COS(ANGLE) OUTVEC(2,M,I)=T*SIN(ANGLE) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE NET (BOARD,XNOD,YNOD, + NUMNOD,NODES,NUMEL,ROWFAC,ROWCON, + COLFAC,COLCON) C C PUTS SYMBOLS INTO ARRAY BOARD IN ORDER TO PLOT NODES (@) AND C ELEMENT SIDES (@*****@*****@) C IMPLICIT DOUBLE PRECISION(A-H,O-Z) REAL XNOD,YNOD,ROWFAC,ROWCON,COLFAC,COLCON CHARACTER*1 BLANK,BOARD(59,63),DOT,LINE LOGICAL PRINT DIMENSION NODES(6,0:NUMEL),XNOD(NUMNOD),YNOD(NUMNOD) DATA BLANK/' '/,DOT/'@'/, LINE/'*'/ IROW(Y)=MAX(1,MIN(59,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(63,INT(COLFAC*X+COLCON+1.5))) XI(J)=(J-1-COLCON)/COLFAC YI(I)=(I-1-ROWCON)/ROWFAC DO 10 I=1,59 DO 8 J=1,63 BOARD(I,J)=BLANK 8 CONTINUE 10 CONTINUE DO 100 N=1,NUMEL DO 90 K=1,3 C ************************************************* C FOLLOWING OPTIONAL STATEMENT PREVENTS PLOTTING OF C THE DIAGONAL (HYPOTENUSE) OF EACH 2-ELEMENT C QUADRILATERAL CELL: C ************************************************* C IF (K.EQ.2) GO TO 90 C ************************************************* N1=NODES(K,N) N2=NODES((K+3),N) N3=NODES((MOD(K,3)+1),N) DX=XNOD(N3)-XNOD(N1) DY=YNOD(N3)-YNOD(N1) SIDE=SQRT(DX**2+DY**2) IF (ABS(DX).GE.ABS(DY)) THEN IF (DX.LT.0.) THEN NS=N1 N1=N3 N3=NS ENDIF X1=XNOD(N1) X2=XNOD(N2) X3=XNOD(N3) Y1=YNOD(N1) Y2=YNOD(N2) Y3=YNOD(N3) NX1=JCOL(X1) NX3=JCOL(X3) A=2.*X1-4.*X2+2.*X3 IF (ABS(A).GT.0.01*SIDE) THEN B= -3.*X1+4.*X2-X3 DO 20 J=NX1,NX3 X=XI(J) C=X1-X B2M4AC=B**2-4.*A*C IF (B2M4AC.GE.0.) THEN DISC=SQRT(B2M4AC) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) IF (ROOT1.GE.0..AND.ROOT1.LE.1.) THEN F=ROOT1 PRINT=.TRUE. ELSE IF(ROOT2.GE.0..AND.ROOT2.LE.1.) THEN F=ROOT2 PRINT=.TRUE. ELSE F=0. PRINT=.FALSE. ENDIF ELSE F=0. PRINT=.FALSE. ENDIF Y=Y1*(1.-3.*F+2.*F**2) + +Y2*(4.*F-4.*F**2) + +Y3*(-F+2.*F**2) IF (PRINT) BOARD(IROW(Y),J)=LINE 20 CONTINUE ELSE DO 21 J=NX1,NX3 X=XI(J) F=(X-X1)/(X3-X1) Y=Y1+F*(Y3-Y1) BOARD(IROW(Y),J)=LINE 21 CONTINUE ENDIF ELSE IF (DY.GT.0.) THEN NS=N1 N1=N3 N3=NS ENDIF X1=XNOD(N1) X2=XNOD(N2) X3=XNOD(N3) Y1=YNOD(N1) Y2=YNOD(N2) Y3=YNOD(N3) NY1=IROW(Y1) NY3=IROW(Y3) A=2.*Y1-4.*Y2+2.*Y3 IF (ABS(A).GT. 0.01*SIDE) THEN B= -3.*Y1+4.*Y2-Y3 DO 50 J=NY1,NY3 Y=YI(J) C=Y1-Y B2M4AC=B**2-4.*A*C IF (B2M4AC.GE.0.) THEN DISC=SQRT(B2M4AC) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) IF (ROOT1.GE.0..AND.ROOT1.LE.1.) THEN F=ROOT1 PRINT=.TRUE. ELSE IF(ROOT2.GE.0..AND.ROOT2.LE.1.) THEN F=ROOT2 PRINT=.TRUE. ELSE F=0. PRINT=.FALSE. ENDIF ELSE F=0. PRINT=.FALSE. ENDIF X=X1*(1.-3.*F+2.*F**2) + +X2*(4.*F-4.*F**2) + +X3*(-F+2.*F**2) IF (PRINT) BOARD(J,JCOL(X))=LINE 50 CONTINUE ELSE DO 51 J=NY1,NY3 Y=YI(J) F=(Y-Y1)/(Y3-Y1) X=X1+F*(X3-X1) BOARD(J,JCOL(X))=LINE 51 CONTINUE ENDIF ENDIF 90 CONTINUE 100 CONTINUE DO 200 I=1,NUMNOD X=XNOD(I) Y=YNOD(I) BOARD(IROW(Y),JCOL(X))=DOT 200 CONTINUE RETURN END C C C SUBROUTINE SPLOT (BOARD,RLOW,RHI,COUNT,STACK,XIP,YIP, + NUMEL,OUTSCA,ROWFAC,ROWCON, + COLFAC,COLCON) C C CONVERTS SCALAR FIELD TO 1-DIGIT INTEGERS AND LOADS INTO C APPROPRIATE CELLS IN PRINT MATRIX C CHARACTER*1 BLANK,BOARD(59,63),DIGIT(11) DOUBLE PRECISION WEIGHT COMMON /WGTVEC/ WEIGHT DIMENSION COUNT(59,63), + OUTSCA(7,NUMEL), + STACK(2,59,63),WEIGHT(7),XIP(7,NUMEL),YIP(7,NUMEL) DATA BLANK/' '/, DIGIT/'0','1','2','3','4','5','6','7', + '8','9','*'/ IROW(Y)=MAX(1,MIN(59,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(63,INT(COLFAC*X+COLCON+1.5))) RLOW=1.E50 RHI= -1.E50 DO 10 I=1,59 DO 9 J=1,63 BOARD(I,J)=BLANK COUNT(I,J)=0. STACK(1,I,J)=0. 9 CONTINUE 10 CONTINUE DO 100 M=1,7 DO 90 I=1,NUMEL IR=IROW(YIP(M,I)) JC=JCOL(XIP(M,I)) COUNT(IR,JC)=COUNT(IR,JC)+WEIGHT(M) STACK(1,IR,JC)=STACK(1,IR,JC)+WEIGHT(M)*OUTSCA(M,I) 90 CONTINUE 100 CONTINUE DO 200 I=1,59 DO 190 J=1,63 IF(COUNT(I,J).GT.0.) THEN STACK(1,I,J)=STACK(1,I,J)/COUNT(I,J) RLOW=MIN(RLOW,STACK(1,I,J)) RHI=MAX(RHI,STACK(1,I,J)) ENDIF 190 CONTINUE 200 CONTINUE IF(RHI.LE.RLOW) THEN RHI=RHI*1.001 RLOW=RLOW*0.999 ENDIF IF(RHI.EQ.0..AND.RLOW.EQ.0.) RHI=1. DO 300 I=1,59 DO 290 J=1,63 IF(COUNT(I,J).GT.0.) THEN ID=(STACK(1,I,J)-RLOW)/(RHI-RLOW) * 10. + 1.5 BOARD(I,J)=DIGIT(ID) ENDIF 290 CONTINUE 300 CONTINUE RETURN END C C C SUBROUTINE TMOHO (THIK,NUMEL,GEOTH,TEMLIM,OUTSCA) C C CALCULATES TEMPERATURE AT THE BASE OF A LAYER BELOW INTEGRATION C POINTS C DIMENSION GEOTH(4,7,NUMEL),OUTSCA(7,NUMEL),THIK(7,NUMEL) TEMP(Z,L,J)=MIN(TEMLIM,GEOTH(1,L,J) + +GEOTH(2,L,J)*Z + +GEOTH(3,L,J)*Z**2 + +GEOTH(4,L,J)*Z**3) DO 100 M=1,7 DO 90 I=1,NUMEL OUTSCA(M,I)=TEMP(THIK(M,I),M,I) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE HEAT (GEOTH,NUMEL,CONDUC,OUTSCA) + C C CALCULATES SURFACE HEAT-FLOW C DIMENSION CONDUC(2),GEOTH(4,7,NUMEL),OUTSCA(7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL OUTSCA(M,I)=GEOTH(2,M,I)*CONDUC(1) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE PEAKS(INPUT,G,NUMEL,RADIUS,RHOAST,RHOH2O,SIGZZC,TSEC, + OUTPUT,OUTSCA) C C COMPUTES ISOSTATIC TOPOGRAPHY CONSIDERING BOTH CRUST AND C MANTLE DENSITY ANOMALIES, C AND GIVES RESULTS AT CRUSTAL GRID INTEGRATION POINTS, IN OUTSCA. C NOTE THAT WATER (NO SEDIMENT) LOADING IS ASSUMED BELOW SEA LEVEL. C DIMENSION OUTSCA(7,NUMEL),SIGZZC(7,NUMEL) C SEALVL=PITMAN(TSEC,RADIUS) FACTOR=RHOAST/(RHOAST-RHOH2O) DO 100 M=1,7 DO 90 I=1,NUMEL HEIGHT= -SIGZZC(M,I)/(G*RHOAST) HEIGHT=HEIGHT-SEALVL IF (HEIGHT.LT.0.) HEIGHT=HEIGHT*FACTOR OUTSCA(M,I)=HEIGHT 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE REBOUN (INPUT, AREAC,AREAM,DETJC,DETJM,DNLINK, + G,NCDIM,NDIFF,NODES,NUMEL, + NUMNOD,NXL,RADIUS,RHOAST,RHOH2O, + SIGZZC,SIGZZM,SZZBC,SZZBM, + TOUCHC,TOUCHM,TSEC, + OUTPUT,OUTSCA, + WORK, CODE,CONDNS,FLOWIN,LWORK) C C COMPUTES ISOSTATIC TOPOGRAPHY CONSIDERING BOTH CRUST AND C MANTLE DENSITY ANOMALIES, WITH MANTLE LIMITED TO .LE. NORMAL WEIGHT C (NOTE THAT "NORMAL" IS DEFINED BY VALUES AT M=5, I=NUMEL) C AND ALL SUBDUCTING SLABS REMOVED FROM CONTACT, C AND EXPRESSES RESULTS IN TERMS OF CRUSTAL GRID INTEGRATION POINTS. C NOTE THAT WATER (NO SEDIMENT) LOADING IS ASSUMED BELOW SEA LEVEL. C LOGICAL FAILUR,LOCKIN,LOCKWC DOUBLE PRECISION CODE,FLOWIN DIMENSION AREAC(NUMEL),AREAM(NUMEL),CODE(NCDIM),CONDNS(NUMNOD), + DETJC(7,NUMEL),DETJM(7,NUMEL),FLOWIN(NUMNOD), + DNLINK(3,7,NUMEL),NODES(6,0:NUMEL),OUTSCA(7,NUMEL), + SIGZZC(7,NUMEL),SIGZZM(7,NUMEL),LWORK(NXL), + SZZBC(7,NUMEL),SZZBM(7,NUMEL),TOUCHC(7,NUMEL), + TOUCHM(7,NUMEL) DATA LOCKIN /.FALSE./, LOCKWC /.FALSE./ C SEALVL=PITMAN(TSEC,RADIUS) FACTOR=RHOAST/(RHOAST-RHOH2O) C C ELIMINATE SLAB EFFECTS FROM MANTLE ARRAY OF SZZ AT TOP C DO 20 M=1,7 DO 10 I=1,NUMEL OUTSCA(M,I)=SIGZZM(M,I)-TOUCHM(M,I)*SZZBM(M,I) 10 CONTINUE 20 CONTINUE C C TRANSFER VALUES TO CRUSTAL GRID C CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) C C MANTLE LITHOSPHERE IN FAR INLAND CORNER OF GRID IS "NORMAL" C REFSZM=OUTSCA(5,NUMEL) C C SUBTRACT OFF EXCESS LITHOSPHERE, AND ALSO ANY SLAB EFFECTS C DO 100 M=1,7 DO 90 I=1,NUMEL I2=DNLINK(1,M,I) IF (I2.GT.0) THEN SZMNA=OUTSCA(M,I) CORREC= -MAX(SZMNA-REFSZM,0.) + -TOUCHC(M,I)*SZZBC(M,I) ELSE CORREC= -TOUCHC(M,I)*SZZBC(M,I) ENDIF OUTSCA(M,I)=SIGZZC(M,I)+CORREC 90 CONTINUE 100 CONTINUE C C SMOOTH THE RESULTING SZZ AT TOP OF CRUST C CALL EXTRAP (AREAC,CODE,DETJC,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) CALL INTERP (CONDNS,NODES,NUMEL,NUMNOD,OUTSCA) C C COMPUTE ISOSTATIC TOPOGRAPHY C DO 200 M=1,7 DO 190 I=1,NUMEL HEIGHT= -OUTSCA(M,I)/(G*RHOAST) HEIGHT=HEIGHT-SEALVL IF (HEIGHT.LT.0.)HEIGHT=HEIGHT*FACTOR OUTSCA(M,I)=HEIGHT 190 CONTINUE 200 CONTINUE RETURN END C C C C REAL FUNCTION PITMAN (AGESEC,REARTH) C C RETURNS HEIGHT OF SEA LEVEL WITH RESPECT TO PRESENT, C IN CURRENT MEASUREMENT UNITS (DETERMINED FROM C REARTH, THE RADIUS OF THE EARTH), AT THE TIME C BEFORE PRESENT AGESEC (POSITIVE SECONDS). C C BASED ON W.C. PTIMAN, 3RD (1978) GEOLOGICAL SOCIETY OF C AMERICA BULLETIN, V. 89, P. 1389-1403. C PARAMETER (NDATA=9) DIMENSION AGEDAT(NDATA),HDATA(NDATA) DATA AGEDAT /0., 15., 25., 35., 45., 55., 65., 75., 85./ DATA HDATA /0., 58., 98.,164.,200.,264.,327.,335.,344./ C AGEMY=AGESEC/3.15576E13 FACTOR=REARTH/6371000. IF (AGEMY.LT.0.0) THEN WRITE(6,1) 1 FORMAT(' FUNCTION PITMAN HAS BEEN ASKED FOR FUTURE SEALEVEL' + /' AND WILL ASSUME THAT THE PRESENT IS THE KEY TO' + /' THE FUTURE (I.E., NO CHANGE).') PITMAN=0. ELSE IF (AGEMY.GT.AGEDAT(NDATA)) THEN WRITE(6,2) AGEDAT(NDATA) 2 FORMAT(' FUNCTION PITMAN HAS BEEN ASKED FOR SEALEVEL BEFORE' + /' THE BEGINNING OF ITS TABLE, AT ',F3.0,' M.Y.,' + /' SO THE FIRST AVAILABLE VALUE WILL BE RETURNED.') PITMAN=HDATA(NDATA)*FACTOR ELSE N1=1 N2=2 DO 10 J=1,NDATA-1 IF (AGEMY.GE.AGEDAT(J).AND.AGEMY.LE.AGEDAT(J+1)) THEN N1=J N2=J+1 GO TO 11 ENDIF 10 CONTINUE 11 FRAC=(AGEMY-AGEDAT(N1))/(AGEDAT(N2)-AGEDAT(N1)) PITMAN=FACTOR*(HDATA(N1)+FRAC*(HDATA(N2)-HDATA(N1))) ENDIF RETURN END C C C SUBROUTINE DELTP (GEOTHC,TEMLIM,ESUMC,ESUMM, + GEOTHM,GEOTHA,THIKM,THIKC,NUMEL,DNLINK, + VPMEAN,DVPBYE,DVPDT,OUTSCA,ONEKM, + THNKC,NODES,NUMNOD,UPLINK,AREAM, + CODE,DETJM,FLOWIN,CONDNS,NCDIM, + NDIFF,NXL,LWORK,HMAX,HMIN) C C COMPUTES TELESEISMIC P-WAVE VERTICAL TRAVEL-TIME RESIDUALS, C CONSIDERING THICKNESS AND TEMPERATURE VARIATIONS AND STRAIN EZZ, C AND USING ARRAYS UPLINK AND DNLINK TO RELATE GRIDS, C AND EXPRESSES RESULTS IN TERMS OF CRUSTAL GRID INTEGRATION POINTS C NOTE THAT RESIDUAL IS CALIBRATED TO ZERO AT SE CORNER. C NOTE THAT NO PROVISION IS MADE FOR TOPOGRAPHY; C RESIDUALS PRESENTED ARE CORRECTED TO SEA LEVEL. C HORIZONTAL OCEANIC SLABS ARE IGNORED; ASSUMED ABSENT AT PRESENT. C DOUBLE PRECISION CODE,FLOWIN LOGICAL FAILUR,LOCKIN,LOCKWC DIMENSION AREAM(NUMEL),CODE(NCDIM),CONDNS(NUMNOD),DETJM(7,NUMEL), + DNLINK(3,7,NUMEL), + DVPBYE(2,2),DVPDT(2), + ESUMC(2,2,7,NUMEL),ESUMM(2,2,7,NUMEL), + FLOWIN(NUMNOD),GEOTHA(4,7,NUMEL),GEOTHC(4,7,NUMEL), + GEOTHM(4,7,NUMEL),HMAX(2),HMIN(2),LWORK(NXL), + NODES(6,0:NUMEL),OUTSCA(7,NUMEL), + TEMLIM(2),THIKC(7,NUMEL),THIKM(7,NUMEL), + THNKC(NUMNOD),UPLINK(3,7,NUMEL), + VPMEAN(2) DATA LOCKIN /.FALSE./, LOCKWC /.FALSE./ TEMPC(Z,M,I)=MIN(TEMLIM(1),GEOTHC(1,M,I) + +GEOTHC(2,M,I)*Z + +GEOTHC(3,M,I)*Z**2 + +GEOTHC(4,M,I)*Z**3) TEMPM(Z,M,I)=MIN(TEMLIM(2),GEOTHM(1,M,I) + +GEOTHM(2,M,I)*Z + +GEOTHM(3,M,I)*Z**2 + +GEOTHM(4,M,I)*Z**3) TEMPA(Z,M,I)=MIN(TEMLIM(2),GEOTHA(1,M,I) + +GEOTHA(2,M,I)*Z + +GEOTHA(3,M,I)*Z**2 + +GEOTHA(4,M,I)*Z**3) C TASTH=TEMPM(THIKM(5,NUMEL),5,NUMEL) VASTH=VPMEAN(2)*(1.+DVPDT(2)*TASTH) NBL=THIKM(5,NUMEL)/ONEKM BLRES=THIKM(5,NUMEL)-ONEKM*NBL IBASE=(HMAX(1)+HMAX(2))/ONEKM C C PREPARE BY COMPUTING MANTLE LITHOSPHERE TRAVEL TIMES C CALL GETSCA (INPUT,THNKC,NODES,NUMEL,NUMNOD,UPLINK, + OUTPUT,OUTSCA) DO 100 M=1,7 DO 90 I=1,NUMEL CRUST=OUTSCA(M,I) TIME=0. DO 20 J=IBASE,1,-1 Z=ONEKM*(J-0.5) IF (Z.LT.CRUST) GO TO 21 IF (Z.LE.(CRUST+THIKM(M,I))) THEN ZP=Z-CRUST T=TEMPM(ZP,M,I) RELARE=ESUMM(1,1,M,I)*ESUMM(2,2,M,I)- + ESUMM(1,2,M,I)*ESUMM(2,1,M,I) RELARE=MIN(RELARE,5.0) RELARE=MAX(RELARE,0.3) EZZ=(1./RELARE)-1.0 VEL=VPMEAN(2)*(1.+DVPDT(2)*T+ + DVPBYE(1,2)*ATAN(EZZ/DVPBYE(2,2))) ELSE VEL=VASTH ENDIF TIME=TIME+ONEKM/VEL 20 CONTINUE 21 RESID=J*ONEKM-CRUST TIME=TIME+RESID/VEL OUTSCA(M,I)=TIME 90 CONTINUE 100 CONTINUE CALL EXTRAP (AREAM,CODE,DETJM,FAILUR, + FLOWIN,CONDNS,NCDIM,NDIFF, + NODES,NUMEL,NUMNOD,NXL,OUTSCA,LWORK, + LOCKIN,LOCKWC) C C COMPLETE INTEGRAL AT EACH CRUSTAL INTEGRATION POINT C CALL GETSCA (INPUT,CONDNS,NODES,NUMEL,NUMNOD,DNLINK, + OUTPUT,OUTSCA) DO 200 M=1,7 DO 190 I=1,NUMEL C C MANTLE PORTION C I2=DNLINK(1,M,I) IF (I2.GT.0) THEN C C NORMAL MANTLE LITHOSPHERE BELOW C TIME=OUTSCA(M,I) ELSE C C AREA OVER NEW ASTHENOSPHERE, WITH OR WITHOUT C A NEW THERMAL BOUNDARY LAYER C CRUST=THIKC(M,I) TIME=(HMAX(1)+HMAX(2)-CRUST-THIKM(5,NUMEL))/ + VASTH DO 110 J=NBL,1,-1 ZP=ONEKM*(J-0.5) T=TEMPA(ZP,M,I) VEL=VPMEAN(2)*(1.+DVPDT(2)*T) TIME=TIME+ONEKM/VEL 110 CONTINUE TIME=TIME+BLRES/VEL ENDIF C C CRUSTAL PORTION C DO 120 J=1,IBASE Z=ONEKM*(J-0.5) IF (Z.GT.THIKC(M,I)) GO TO 121 T=TEMPC(Z,M,I) RELARE=ESUMC(1,1,M,I)*ESUMC(2,2,M,I)- + ESUMC(1,2,M,I)*ESUMC(2,1,M,I) RELARE=MIN(RELARE,5.0) RELARE=MAX(RELARE,0.3) EZZ=(1./RELARE)-1.0 VEL=VPMEAN(1)*(1.+DVPDT(1)*T+ + DVPBYE(1,1)*ATAN(EZZ/DVPBYE(2,1))) TIME=TIME+ONEKM/VEL 120 CONTINUE 121 RESID=THIKC(M,I)-(J-1)*ONEKM TIME=TIME+RESID/VEL OUTSCA(M,I)=TIME 190 CONTINUE 200 CONTINUE C C CALIBRATE TO SOUTHEAST CORNER VALUES (=0) C STANDR=OUTSCA(5,NUMEL) DO 300 M=1,7 DO 290 I=1,NUMEL OUTSCA(M,I)=OUTSCA(M,I)-STANDR 290 CONTINUE 300 CONTINUE RETURN END C C C SUBROUTINE ELONG (E,NUMEL,OUTVEC) + C C CALCULATES LARGEST-MAGNITUDE PRINCIPAL STRAIN IN VECTOR FORM C NOTE THAT ELONG WORKS WITH VPLOT TO PUT NEGATIVE VECTORS IN A-F C DIMENSION E(2,2,7,NUMEL),OUTVEC(2,7,NUMEL) DO 100 M=1,7 DO 90 I=1,NUMEL RNUM=2.*(E(1,1,M,I)*E(1,2,M,I)+E(2,1,M,I)*E(2,2,M,I)) RDENOM=E(1,1,M,I)**2+E(2,1,M,I)**2- + E(1,2,M,I)**2-E(2,2,M,I)**2 IF (RDENOM.NE.0.) THEN RHS=RNUM/RDENOM TTHETA=ATAN(RHS) THETA=TTHETA/2. ELSE THETA=0. ENDIF THETA2=THETA+1.570796327 S1X=COS(THETA) S1Y=SIN(THETA) S2X=COS(THETA2) S2Y=SIN(THETA2) BIGS1X=E(1,1,M,I)*S1X+E(1,2,M,I)*S1Y BIGS1Y=E(2,1,M,I)*S1X+E(2,2,M,I)*S1Y BIGS2X=E(1,1,M,I)*S2X+E(1,2,M,I)*S2Y BIGS2Y=E(2,1,M,I)*S2X+E(2,2,M,I)*S2Y BIGS1=SQRT(BIGS1X**2+BIGS1Y**2) BIGS2=SQRT(BIGS2X**2+BIGS2Y**2) ALPHA=ATAN2F(BIGS1Y,BIGS1X) ALPHA2=ATAN2F(BIGS2Y,BIGS2X) CENTER=SQRT(BIGS1*BIGS2)-1. R=MAX(ABS(BIGS1-1.-CENTER),ABS(BIGS2-1.-CENTER)) IF (CENTER.GT.0.) THEN EM=CENTER+R IF (BIGS1.GE.BIGS2) THEN ANGLE=ALPHA ELSE ANGLE=ALPHA2 ENDIF IF (ANGLE.LE.1.308996.AND.ANGLE.GT.-1.832596) + ANGLE=ANGLE+3.141593 ELSE EM=CENTER-R IF (BIGS1.LE.BIGS2) THEN ANGLE=ALPHA ELSE ANGLE=ALPHA2 ENDIF IF (ANGLE.GT.1.308996.OR.ANGLE.LE.-1.832596) + ANGLE=ANGLE+3.141593 EM= -EM ENDIF OUTVEC(1,M,I)=EM*COS(ANGLE) OUTVEC(2,M,I)=EM*SIN(ANGLE) 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE GREENS (INPUT,E,NUMEL, + OUTPUT,ER) C C COMPUTES GREENS FINITE-STRAIN TENSOR FROM DISPLACEMENT-GRADIENT C MATRICES "E" AND STORES THEM IN SAME FORMAT AS C STRAIN-RATE TENSORS "ER"; USED ONLY TO PREPARE FOR C PLOTTING OF FINITE STRAINS. C DIMENSION ER(4,7,NUMEL),E(2,2,7,NUMEL),GREENT(2,2) C DO 100 M=1,7 DO 90 I=1,NUMEL GREENT(1,1)=0.5*(E(1,1,M,I)**2+E(2,1,M,I)**2-1.00) GREENT(1,2)=0.5*(E(1,1,M,I)*E(1,2,M,I)+ + E(2,1,M,I)*E(2,2,M,I)) GREENT(2,1)=0.5*(E(1,2,M,I)*E(1,1,M,I)+ + E(2,2,M,I)*E(2,1,M,I)) GREENT(2,2)=0.5*(E(1,2,M,I)**2+E(2,2,M,I)**2-1.00) ER(1,M,I)=GREENT(1,1) ER(2,M,I)=GREENT(2,2) ER(3,M,I)=GREENT(1,2) ER(4,M,I)=0.0 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE ROTOR (ESUM,NUMEL,OUTSCA) C C COMPUTE NET CLOCKWISE ROTATION IN DEGREES C OF A HYPOTHETICAL SOLID INCLUSION, C BY AVERAGING THE ROTATIONS OF THE X AND Y AXES. C DIMENSION ESUM(2,2,7,NUMEL),OUTSCA(7,NUMEL) DO 10 M=1,7 DO 9 I=1,NUMEL ROT1=ATAN2F(ESUM(2,1,M,I),ESUM(1,1,M,I)) ROT2=ATAN2F(-ESUM(1,2,M,I),ESUM(2,2,M,I)) IF(ABS(ROT1-ROT2).GT.3.141592654) THEN IF(ROT1.LT.ROT2) THEN ROT1=ROT1+6.283185307 ELSE ROT2=ROT2+6.283185307 ENDIF ENDIF ROTATE=(ROT1+ROT2)/2. OUTSCA(M,I)= -57.29577951*ROTATE 9 CONTINUE 10 CONTINUE RETURN END 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 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 PAINT (NODES,XNOD,YNOD,TITLE,TEXT,JV,T2MA, + FUNC,CINT,NUMNOD,NUMEL,ALLPOS, + SCALE, + STATES, + XLEFT,XRIGHT,YNADIR,YZENIT, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU,NTREAD, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIP,YIP, + DOFLTS,ERATE,TAUMT,TAUZZ) C C PLOTS CONTOUR DIAGRAMS AND A GRID OF STATE OUTLINES. C LABELS WITH VARIABLE AND TIME ABOVE, MODEL TITLE BELOW. C PLACES COLORBAR WITH CONTOUR VALUES AND UNITS ON RIGHT. C SENDS FRAME TO "ADMGDF" IN 5 MEMBERS (1 PER SEGMENT). C PARAMETER (NCOLOR=12) CHARACTER*80 TITLE,TITLE2 CHARACTER*42 TEXT,TTEXT,VUNITS CHARACTER*8 FILNAM CHARACTER*5 TMYCHR,CLCHR,ASCII EXTERNAL ASCII LOGICAL ALLPOS,DOAROW,DOAXES,DOFLTS,DRAWST,STATES DIMENSION DRAWST(NXYST),ERATE(4,7,NUMEL),FBLAND(24), + FUNC(NUMNOD),ICOLOR(NCOLOR),IDSEG(1),LOWBLU(24), + NODES(6,0:NUMEL),NVCHAR(24),NVUCHR(24), + OUTVEC(2,7,NUMEL),TAUMT(3,7,NUMEL),TAUZZ(7,NUMEL), + TEXT(24),VUNITS(24),XIP(7,NUMEL),YIP(7,NUMEL), + XNOD(NUMNOD),YNOD(NUMNOD), + XST(NXYST),YST(NXYST) C C SELECT COLORS:128 = WHITE, 12 C 80 = PINK, 11 C 77 = RED, 10 C 69 = DARK RED, 9 C 93 = ORANGE, 8 C 125 = YELLOW, 7 C 117 = YELLOW/GREEN, 6 C 113 = GREEN 5 C 116 = TURQUOISE, 4 C 68 = BLUE, 3 ___________ C 66 = DARK BLUE, 2 __CINT___ C 65 = BLACK. 1 C DATA ICOLOR/65,66,68,116,113,117,125,93,69,77,80,128/ C IF (FBLAND(JV).NE.0.) THEN FMIDLE=FBLAND(JV) ELSE FTOPS=FUNC(1) FLOOR=FUNC(1) DO 5 I=2,NUMNOD FTOPS=MAX(FTOPS,FUNC(I)) FLOOR=MIN(FLOOR,FUNC(I)) 5 CONTINUE FMIDLE=(FTOPS+FLOOR)/2. ENDIF IFLIP=LOWBLU(JV) C C CLEAR CURRENT PAGE C CALL FSPCLR C C********************************************************************** C C SCALE TO LEAVE 0.3" AT BOTTOM, 0.5" ON TOP, AND 1.5" ON RIGHT C DXP=(XRIGHT-XLEFT)*11.0/(11.0-1.5) XL=XLEFT XR=XL+DXP DY=YZENIT-YNADIR DYP=DY*8.5/(8.5-0.5-0.3) EDGE=(DYP-DY)/2. YT=YZENIT+EDGE YB=YNADIR-EDGE C C ESTABLISH COORDINATE SYSTEM IN FINITE-ELEMENT UNITS C CALL GSUWIN(XL,XR,YB,YT) C C INITIALIZE SEGMENT 1 (CONTOURED ELEMENTS) C CALL GSSEG(1) C C LOAD 64-COLOR PALLETTE C CALL GSLSS(3,'ADMCOLSD',0) C CALL CONTEL (NODES,XNOD,YNOD,FUNC,CINT,NUMNOD,NUMEL, + FMAX,FMIN,NCOLOR,ICOLOR,FMIDLE,IFLIP, + NBLUE,NYELOW,ALLPOS) C C CLOSE SEGMENT OF COLORED ELEMENTS C CALL GSSCLS C C************************************************************* C C ESTABLISH COORDINATE SYSTEM IN FINITE-ELEMENT UNITS C CALL GSUWIN(XL,XR,YB,YT) C C OPEN SEGMENT 2 (VECTORS OR TENSOR SYMBOLS, OR DUMMY) C TENSORS INCLUDED WITH OTHER VARIABLES) C CALL GSSEG(2) C IF (DOAROW) THEN CALL ARROW (NUMEL,OUTVEC,RMSVEC, + SCALE,XIP,YIP) ELSE IF (DOAXES) THEN CALL AXES (NUMEL,TAUMT,TAUZZ,RMSVEC, + SCALE,XIP,YIP) ELSE IF (DOFLTS) THEN CALL FAULTS (NUMEL,ERATE,RMSVEC, + SCALE,XIP,YIP) ELSE C C DUMMY LINE SO SEGMENT WON'T BE EMPTY C CALL GSCOL(8) CALL GSMOVE(10.5,8.2) CALL GSLINE(10.6,8.2) ENDIF C C CLOSE SEGMENT C CALL GSSCLS C C******************************************************************* IF (STATES) THEN C C ESTABLISH COORDINATE SYSTEM IN FINITE-ELEMENT UNITS C CALL GSUWIN(XL,XR,YB,YT) C C OPEN SEGMENT FOR STATE LINES (3) C CALL GSSEG(3) C C USE BLUE OR YELLOW PEN FOR MAX. CONTRAST C IF (NBLUE.LE.NYELOW) THEN CALL GSCOL(1) ELSE CALL GSCOL(6) ENDIF C C USE HEAVY LINE C CALL GSLW(2) C CALL USMAP (INPUT,DRAWST,NXYST,XST,YST) C C CLOSE SEGMENT WITH STATE LINES C CALL GSSCLS C ENDIF C**************************************************************** C C INITIALIZE WINDOW COORDINATES IN "INCHES" (APPROX.) C CALL GSUWIN(0.0,11.0,0.0,8.5) C C OPEN SEGMENT 4 (COLOR BAR AND CONTOUR INTERVALS) C CALL GSSEG(4) C C MASK OUT AREA WITH BLACK C CALL GSCOL(-1) CALL GSMOVE(9.75,-5.) CALL GSAREA(0) CALL GSLINE(9.75,13.5) CALL GSLINE(16.,13.5) CALL GSLINE(16.,-5.) CALL GSLINE(9.75,-5.) CALL GSENDA C C DETERMINE SCALE FACTORS FOR COLOR BAR C IF (ALLPOS) FMIN=MAX(FMIN,0.) RANGE=FMAX-FMIN STEPS=RANGE/CINT YPERST=MIN(0.5,6.0/MAX(STEPS,0.01)) YTOP=4.25+YPERST*STEPS/2. YBOT=4.25-YPERST*STEPS/2. ORIGIN=4.25-((FMAX+FMIN)/(2.*CINT))*YPERST NSTEPT=IUNDER(FMAX/CINT) NSTEPB=IUNDER(FMIN/CINT) C C LOAD 64-COLOR PALLETTE C CALL GSLSS(3,'ADMCOLSD',0) C C SELECT AND LOAD CHARACTER SET C C CALL GSLSS(2,'ADMUWCRP',199) 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=WIDTH*1.00 HEIGHT=HEIGHT*1.00 CALL GSCB(WIDTH,HEIGHT) C C SET LABEL ANGLE TO ZER0 (LIKE THIS) C CALL GSCA(COS(0.0),SIN(0.0)) C C ADD UNITS C WIDE=WIDTH*NVUCHR(JV) IF (WIDE.LE.0.25) THEN X=10.75-WIDE/2. ELSE X=11.0-WIDE ENDIF Y=YTOP+0.7*HEIGHT YOLD=Y YNEXT=Y-1.1*HEIGHT C C USE WHITE FOR CONTOUR LEVEL LABELS C CALL GSCOL(7) CALL GSLW(2) C CALL GSCHAR(X,Y,NVUCHR(JV),VUNITS(JV)) 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 DO 1050 I=NSTEPT,NSTEPB,-1 FTOP=(I+1)*CINT IF (I.EQ.NSTEPT) FTOP=FMAX FBOT=I*CINT IF (I.EQ.NSTEPB) FBOT=FMIN YTOP=FTOP*YPERST/CINT+ORIGIN YBOT=FBOT*YPERST/CINT+ORIGIN F=(FTOP+FBOT)/2. N=IHUE (NCOLOR,CINT,FMIDLE,IFLIP,F) CALL GSPAT(ICOLOR(N)) IF (N.EQ.1) THEN ICONT=-2 CALL GSLW(1) ELSE IF (N.EQ.NCOLOR) 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(7) CALL GSLW(2) C ARG=1.001*FTOP/10.**CIPOW CLCHR=ASCII(1.001*FTOP/10.**CIPOW) X=10.5-5.5*WIDTH Y=YTOP-0.5*HEIGHT NPRINT=4 IF (CIINT.LT.1.0) NPRINT=5 IF (I.EQ.NSTEPT) NPRINT=5 IF (Y.LE.YNEXT) THEN YOLD=Y YNEXT=Y-1.1*HEIGHT CALL GSCHAR(X,Y,NPRINT,CLCHR) ENDIF IF (I.EQ.NSTEPB) THEN CLCHR=ASCII(1.001*FBOT/10.**CIPOW) X=10.5-5.5*WIDTH Y=YBOT-0.5*HEIGHT IF (Y.LE.YNEXT) CALL GSCHAR(X,Y,5,CLCHR) ENDIF 1050 CONTINUE C C ADD 10**N MULTIPLIER C IF (ABS(CIPOW).GT.0.1) THEN X=11.0-7.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-3.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 C C CLOSE SEGMENT OF COLOR BAR C CALL GSSCLS C C******************************************************************* C C INITIALIZE WINDOW COORDINATES IN "INCHES" (APPROX.) C CALL GSUWIN(0.0,11.0,0.0,8.5) C C OPEN SEGMENT 5 (TITLE + VARIABLE + TIME) C CALL GSSEG(5) C C MASK OUT AREAS WITH BLACK C CALL GSCOL(8) CALL GSMOVE(-5.,-5.) CALL GSAREA(0) CALL GSLINE(-5.,0.5) CALL GSLINE(16.,0.5) CALL GSLINE(16.,-5.) CALL GSLINE(-5.,-5.) CALL GSENDA CALL GSMOVE(-5.,8.08) CALL GSAREA(0) CALL GSLINE(-5.,13.) CALL GSLINE(16.,13.) CALL GSLINE(16.,8.08) CALL GSLINE(-5.,8.08) CALL GSENDA C C SELECT AND LOAD CHARACTER SET C C CALL GSLSS(2,'ADMUWCRP',199) 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.00*WIDTH HEIGHT=1.25*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 WHITE FOR TEXT C CALL GSCOL(7) C C WRITE MODEL TITLE C DO 4010 I=1,80 IF (TITLE(I:I).EQ.'0') THEN TITLE2(I:I)='O' ELSE TITLE2(I:I)=TITLE(I:I) ENDIF 4010 CONTINUE CALL GSCHAR(-0.4,0.1,80,TITLE2) C C WRITE VARIABLE AND TIME IDENTIFIERS C CALL GSCHAR(-0.4,8.1,NVCHAR(JV),TEXT(JV)) CALL GSCHAP(4,' at ') TMYCHR=ASCII(T2MA) CALL GSCHAP(5,TMYCHR) CALL GSCHAP(5,' Ma (') CALL EPOCH (IMPUT,T2MA,OUTPUT,NECHAR,TTEXT) CALL GSCHAP(NECHAR,TTEXT) CALL GSCHAP(1,')') C C CLOSE SEGMENT WITH TEXT LABELS C CALL GSSCLS C C**************************************************************** C C SEND PICTURE SEGMENTS TO 5 PARTITIONED-DATASET MEMBERS C FILNAM(1:1)='V' I1=JV/10 FILNAM(2:2)=CHAR(240+I1) I2=JV-I1*10 FILNAM(3:3)=CHAR(240+I2) FILNAM(4:4)='T' I1=NTREAD/10 FILNAM(5:5)=CHAR(240+I1) I2=NTREAD-I1*10 FILNAM(6:6)=CHAR(240+I2) FILNAM(7:7)='S' DO 9999 ISEG=1,5 FILNAM(8:8)=CHAR(240+ISEG) IDSEG(1)=ISEG CALL GSSAVE(1,IDSEG,FILNAM,0,DUMMY,0,DUMMY) C WRITE(6,9998)FILNAM 9998 FORMAT(' ********** SAVING MEMBER: ',A8,' **************') 9999 CONTINUE RETURN END C C C SUBROUTINE ETCH (DRAWST,NTREAD,JV, + NODES,NUMEL,NUMNOD,NVCHAR,NXYST, + STATES,TEXT,TITLE,T2MA, + XLEFT,XRIGHT,XNOD,XST,YNADIR,YZENIT,YNOD,YST) C C PLOTS THE FINITE ELEMENT GRID AND STATE OUTLINES. C LABELS WITH GRID LEVEL AND TIME ABOVE, MODEL TITLE BELOW. C SENDS FRAME TO "ADMGDF" IN 5 MEMBERS/SEGMENTS. C CHARACTER*80 TITLE,TITLE2 CHARACTER*42 TEXT,TTEXT CHARACTER*8 FILNAM CHARACTER*5 TMYCHR,ASCII EXTERNAL ASCII LOGICAL DRAWST,S4,S5,S6,STATES DIMENSION DRAWST(NXYST),IDSEG(1), + NODES(6,0:NUMEL),NVCHAR(24),TEXT(24), + XNOD(NUMNOD),YNOD(NUMNOD), + XST(NXYST),YST(NXYST) C C CLEAR CURRENT PAGE C CALL FSPCLR C C********************************************************************** C C SCALE TO LEAVE 0.3" AT BOTTOM, 0.5" ON TOP, AND 1.5" ON RIGHT C DXP=(XRIGHT-XLEFT)*11.0/(11.0-1.5) XL=XLEFT XR=XL+DXP DY=YZENIT-YNADIR DYP=DY*8.5/(8.5-0.5-0.3) EDGE=(DYP-DY)/2. YT=YZENIT+EDGE YB=YNADIR-EDGE C C ESTABLISH COORDINATE SYSTEM IN FINITE-ELEMENT UNITS C CALL GSUWIN(XL,XR,YB,YT) C C INITIALIZE SEGMENT 1 (FINITE ELEMENT GRID) C CALL GSSEG(1) C C PLOT ALL ELEMENT SIDES (MANY ARE DRAWN TWICE) C CALL GSCOL(4) CALL GSLW(2) DO 30 I=1,NUMEL S4=.TRUE. S5=.TRUE. S6=.TRUE. CALL AROUND (I,S4,S5,S6,NODES,XNOD,YNOD,NUMNOD,NUMEL) 30 CONTINUE C C PLOT ALL NODES C CALL GSCOL(6) CALL GSLW(1) CALL GSMS(6) CALL GSMSC(0.08) DO 20 I=1,NUMNOD CALL GSMARK(XNOD(I),YNOD(I)) 20 CONTINUE C C CLOSE SEGMENT OF FINITE ELEMENT GRID C CALL GSSCLS C C**************************************************************** C C INITIALIZE WINDOW COORDINATES IN "INCHES" (APPROX.) C CALL GSUWIN(0.0,11.0,0.0,8.5) C C OPEN SEGMENT 2 (DUMMY SEGMENT, CORRESPONDS TO VECTORS AND C TENSORS INCLUDED WITH OTHER VARIABLES) C CALL GSSEG(2) C C DUMMY LINE SO SEGMENT WON'T BE EMPTY C CALL GSCOL(8) CALL GSMOVE(10.5,8.2) CALL GSLINE(10.6,8.2) C C CLOSE DUMMY SEGMENT C CALL GSSCLS C C******************************************************************* IF (STATES) THEN C C ESTABLISH COORDINATE SYSTEM IN FINITE-ELEMENT UNITS C CALL GSUWIN(XL,XR,YB,YT) C C OPEN SEGMENT FOR STATE LINES (3) C CALL GSSEG(3) C C USE BLUE PEN C CALL GSCOL(1) C C USE HEAVY LINE C CALL GSLW(2) C CALL USMAP (INPUT,DRAWST,NXYST,XST,YST) C C CLOSE SEGMENT WITH STATE LINES C CALL GSSCLS C ENDIF C**************************************************************** C C INITIALIZE WINDOW COORDINATES IN "INCHES" (APPROX.) C CALL GSUWIN(0.0,11.0,0.0,8.5) C C OPEN SEGMENT 4 (DUMMY SEGMENT, CORRESPONDS TO COLOR BAR C INCLUDED WITH OTHER VARIABLES) C CALL GSSEG(4) C C DUMMY LINE SO SEGMENT WON'T BE EMPTY C CALL GSCOL(8) CALL GSMOVE(10.5,8.2) CALL GSLINE(10.6,8.2) C C CLOSE DUMMY SEGMENT C CALL GSSCLS C C******************************************************************* C C INITIALIZE WINDOW COORDINATES IN "INCHES" (APPROX.) C CALL GSUWIN(0.0,11.0,0.0,8.5) C C OPEN SEGMENT 5 (TITLE + VARIABLE + TIME) C CALL GSSEG(5) C C MASK OUT AREAS WITH BLACK C CALL GSCOL(8) CALL GSMOVE(-5.,-5.) CALL GSAREA(0) CALL GSLINE(-5.,0.4) CALL GSLINE(16.,0.4) CALL GSLINE(16.,-5.) CALL GSLINE(-5.,-5.) CALL GSENDA CALL GSMOVE(-5.,8.0) CALL GSAREA(0) CALL GSLINE(-5.,13.) CALL GSLINE(16.,13.) CALL GSLINE(16.,8.0) CALL GSLINE(-5.,8.0) CALL GSENDA C C SELECT AND LOAD CHARACTER SET C C CALL GSLSS(2,'ADMUWCRP',199) 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.00*WIDTH HEIGHT=1.25*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 WHITE FOR TEXT C CALL GSCOL(7) C C WRITE MODEL TITLE C DO 4010 I=1,80 IF (TITLE(I:I).EQ.'0') THEN TITLE2(I:I)='O' ELSE TITLE2(I:I)=TITLE(I:I) ENDIF 4010 CONTINUE CALL GSCHAR(-0.4,0.0,80,TITLE2) C C WRITE VARIABLE AND TIME IDENTIFIERS C CALL GSCHAR(-0.4,8.1,NVCHAR(JV),TEXT(JV)) CALL GSCHAP(4,' at ') TMYCHR=ASCII(T2MA) CALL GSCHAP(5,TMYCHR) CALL GSCHAP(5,' Ma (') CALL EPOCH (IMPUT,T2MA,OUTPUT,NECHAR,TTEXT) CALL GSCHAP(NECHAR,TTEXT) CALL GSCHAP(1,')') C C CLOSE SEGMENT WITH TEXT LABELS C CALL GSSCLS C C**************************************************************** C C SEND PICTURE SEGMENTS TO 5 PARTITIONED-DATASET MEMBERS C FILNAM(1:1)='V' I1=JV/10 FILNAM(2:2)=CHAR(240+I1) I2=JV-I1*10 FILNAM(3:3)=CHAR(240+I2) FILNAM(4:4)='T' I1=NTREAD/10 FILNAM(5:5)=CHAR(240+I1) I2=NTREAD-I1*10 FILNAM(6:6)=CHAR(240+I2) FILNAM(7:7)='S' DO 9999 ISEG=1,5 FILNAM(8:8)=CHAR(240+ISEG) IDSEG(1)=ISEG CALL GSSAVE(1,IDSEG,FILNAM,0,DUMMY,0,DUMMY) C WRITE(6,9998)FILNAM 9998 FORMAT(' ********** SAVING MEMBER: ',A8,' **************') 9999 CONTINUE RETURN END C C C SUBROUTINE CONTEL (NODES,XNOD,YNOD,FUNC,DFCON,NUMNOD,NUMEL, + FGMAX,FGMIN,NCOLOR,ICOLOR,FMIDLE,IFLIP, + NBLUE,NYELOW,ALLPOS) C C CONTOURS AND COLORS A SCALAR FIELD ON THE FINITE ELEMENT GRID. C INSTEAD OF FOLLOWING CONTOURS ACROSS ELEMENT BOUNDARIES, IT C CONTOURS EACH ELEMENT SEPARATELY. C PARAMETER(NINLIN=130,NWORK=1300) LOGICAL ALLPOS,ANEDGE,BEGCON,BEGNXT,BITSEG,CENTER,CIRCLE, + COLOR,DASHED,DONE,ENDCON,FINISH,GONOUT, + HITLIM,INSIDE, + NEIGHB,SIDMAX,SIDMIN, + THRU,Z REAL LOWEST DIMENSION NODES(6,0:NUMEL),ICOLOR(NCOLOR), + XNOD(NUMNOD),YNOD(NUMNOD),FUNC(NUMNOD) C C LOCAL STORAGE FOR PROPERTIES OF ONE ELEMENT: DIMENSION IN(6),XN(6),YN(6),FN(6),DS(3),SSE(3),DSIN(3) C C LOCAL STORAGE FOR INITIAL POINTS OF CONTOUR SEGMENTS: DIMENSION PS(5,NINLIN),PS2(5,NINLIN),DONE(NINLIN) C C LOCAL STORAGE FOR SHAPES OF CONTOUR AND EDGE SEGMENTS: DIMENSION SPACE(2,NWORK),ISPPNT(0:NINLIN),ISPLEN(0:NINLIN), & FOFSEG(NINLIN),ANEDGE(NINLIN),MENU(NINLIN), & NTOGO(NINLIN) C DATA DSTEP/0.05/ C C STATEMENT FUNCTION: C PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) C C GLOBAL INITIALIZATION (WHOLE GRID) C LIMINT=4./DSTEP FGMIN= 1.E60 FGMAX=-1.E60 NBLUE=0 NYELOW=0 DO 9999 IEL=1,NUMEL C C LOCAL INITIALIZATION (ONE ELEMENT) C NPS=0 ISPNUM=0 ISPLEN(0)=0 ISPPNT(0)=1 CENTER=.FALSE. TSIDE=1.E60 IHIC= -9999 ILOC= +9999 DO 5 J=1,6 K=NODES(J,IEL) IN(J)=K XN(J)=XNOD(K) YN(J)=YNOD(K) FN(J)=FUNC(K) 5 CONTINUE I1=IN(1) I2=IN(2) I3=IN(3) I4=IN(4) I5=IN(5) I6=IN(6) X1=XN(1) X2=XN(2) X3=XN(3) X4=XN(4) X5=XN(5) X6=XN(6) Y1=YN(1) Y2=YN(2) Y3=YN(3) Y4=YN(4) Y5=YN(5) Y6=YN(6) FMAX=MAX(FN(1),FN(2),FN(3),FN(4),FN(5),FN(6)) FMIN=MIN(FN(1),FN(2),FN(3),FN(4),FN(5),FN(6)) RANGE=MAX((FMAX-FMIN),DFCON) C C PREVENT DEGENERATE CASES WHERE NODES FALL EXACTLY ON CONTOURS C DO 10 J=1,6 I=FN(J)/DFCON IF ((I*DFCON).EQ.FN(J)) FN(J)=FN(J)+0.01*RANGE 10 CONTINUE F1=FN(1) F2=FN(2) F3=FN(3) F4=FN(4) F5=FN(5) F6=FN(6) C C*************************************************************** C C EXAMINE SIDES FOR EXTREMA AND MARK CONTOUR INTERSECTIONS C DO 100 MSIDE=1,3 N1=MSIDE N2=MOD(MSIDE,3)+1 SIDE=SQRT((XN(N1)-XN(N2))**2+(YN(N1)-YN(N2))**2) TSIDE=MIN(TSIDE,SIDE) NM=MSIDE+3 DFDS1= -3.*FN(N1)+4.*FN(NM)- FN(N2) DFDS2= FN(N1)-4.*FN(NM)+3.*FN(N2) D2FDS=4.*FN(N1)-8.*FN(NM)+4.*FN(N2) IF ((DFDS1*DFDS2.GE.0.).OR.(D2FDS.EQ.0.0)) THEN FMX=AMAX1(FN(N1),FN(N2)) FMN=AMIN1(FN(N1),FN(N2)) CALL DOSIDE (FMX,FMN,DFCON,FN,N1,N2,NM,PS,NPS,NINLIN,Z) IF (Z) THEN WRITE(6,401)IEL GO TO 9999 ENDIF ELSE SEXT= -DFDS1/D2FDS FEXT=FN(N1)+ + DFDS1*SEXT+ + 0.5*D2FDS*SEXT**2 FMAX=MAX(FMAX,FEXT) FMIN=MIN(FMIN,FEXT) C C FIND INTERSECTIONS OF CONTOURS WITH SIDE CONTAINING EXTREMUM C FMX=AMAX1(FN(N1),FEXT) FMN=AMIN1(FN(N1),FEXT) CALL DOPART (FEXT,FMX,FMN,DFCON,FN, + N1,N2,NM,0.,SEXT,PS,NPS,NINLIN,Z) IF (Z) THEN WRITE(6,401)IEL GO TO 9999 ENDIF FMX=AMAX1(FEXT,FN(N2)) FMN=AMIN1(FEXT,FN(N2)) CALL DOPART (FEXT,FMX,FMN,DFCON,FN, + N1,N2,NM,SEXT,1.,PS,NPS,NINLIN,Z) IF (Z) THEN WRITE(6,401)IEL GO TO 9999 ENDIF ENDIF 100 CONTINUE RTESTR=TSIDE*DSTEP C C*************************************************************** C C SORT THE POINTS FOUND BY CLOCKWISE PARAMETER S C DO 200 INPS=1,NPS S1=PS(1,INPS) S2=PS(2,INPS) S3=PS(3,INPS) F=PS(4,INPS) IF (F.GE.0.) THEN IC=F/DFCON+0.1 ELSE IT= -F/DFCON+0.1 IC= -IT ENDIF IHIC=MAX(IHIC,IC) ILOC=MIN(ILOC,IC) IF (S3.EQ.0.) THEN SN=S2 ELSE IF (S1.EQ.0.) THEN SN=1.+S3 ELSE SN=2.+S1 ENDIF PS(5,INPS)=SN 200 CONTINUE SNOW= -0.1 DO 300 INPS=1,NPS LOWEST=3.1 JMOVE=INPS DO 250 JNPS=1,NPS IF (PS(5,JNPS).GT.SNOW) THEN IF (PS(5,JNPS).LT.LOWEST) THEN LOWEST=PS(5,JNPS) JMOVE=JNPS ENDIF ENDIF 250 CONTINUE DO 270 K=1,5 PS2(K,INPS)=PS(K,JMOVE) 270 CONTINUE SNOW=LOWEST 300 CONTINUE DO 320 I=1,5 DO 310 J=1,NPS PS(I,J)=PS2(I,J) 310 CONTINUE 320 CONTINUE C C CREATE TABLE OF ELEMENT-SIDE SEGMENTS C S=0. NPSD=0 BEGNXT=.FALSE. C BEGIN NEW SEGMENT 400 ISPNUM=ISPNUM+1 IF (ISPNUM.GT.NINLIN) THEN WRITE(6,401) IEL GO TO 9999 ENDIF ISPPNT(ISPNUM)=ISPPNT(ISPNUM-1)+ISPLEN(ISPNUM-1) IF (ISPPNT(ISPNUM).GT.NWORK) THEN WRITE(6,401) IEL GO TO 9999 ENDIF 401 FORMAT(' INSUFFICIENT WORKSPACE IN CONTEL. ELEMENT ', & I5,' WILL NOT BE SHOWN.') ISPLEN(ISPNUM)=1 NTOGO(ISPNUM)=1 ANEDGE(ISPNUM)=.TRUE. BEGCON=BEGNXT NINSEG=1 IF(S.LE.1.) THEN S1=1.-S S2=S S3=0. ELSE IF (S.LE.2.) THEN S1=0. S2=2.-S S3=S-1. ELSE S1=S-2. S2=0. S3=3.-S ENDIF X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) F=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) SUMSEG=F SPACE(1,ISPPNT(ISPNUM))=X SPACE(2,ISPPNT(ISPNUM))=Y C FIND NEXT POINT 500 IS=IABOVE(S/DSTEP+0.05) IF (S.LT.1.) THEN SLIM=1. ELSE IF (S.LT.2.) THEN SLIM=2. ELSE SLIM=3. ENDIF ST=MIN(SLIM,IS*DSTEP) THRU=.FALSE. ENDCON=.FALSE. BEGNXT=.FALSE. IF (NPSD.LT.NPS) THEN IF (PS(5,NPSD+1).LE.ST) THEN NPSD=NPSD+1 IF ((.NOT.ALLPOS).OR.(PS(4,NPSD).GT.0.0)) THEN THRU=.TRUE. ENDCON=.TRUE. BEGNXT=.TRUE. ST=PS(5,NPSD) ENDIF ENDIF ENDIF IF (ST.EQ.SLIM) THRU=.TRUE. C UPDATE REPRESENTATIVE FUNCTION VALUE FOR SEGMENT NINSEG=NINSEG+1 IF(ST.LE.1.) THEN S1=1.-ST S2=ST S3=0. ELSE IF (ST.LE.2.) THEN S1=0. S2=2.-ST S3=ST-1. ELSE S1=ST-2. S2=0. S3=3.-ST ENDIF F=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) BITSEG=THRU.AND.(NINSEG.EQ.2).AND.BEGCON.AND.ENDCON + .AND.(ABS(F-SUMSEG).LT.(0.1*DFCON)) IF (BITSEG) THEN IF (F.GT.FOFSEG(ISPNUM-1)) THEN FOFSEG(ISPNUM)=F+0.5*ABS(DFCON) ELSE FOFSEG(ISPNUM)=F-0.5*ABS(DFCON) ENDIF ELSE SUMSEG=SUMSEG+F FOFSEG(ISPNUM)=SUMSEG/NINSEG ENDIF C RECORD NEXT POINT IN LIST X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) ISPLEN(ISPNUM)=ISPLEN(ISPNUM)+1 IF ((ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1).GT.NWORK) THEN WRITE(6,401) IEL GO TO 9999 ENDIF SPACE(1,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=X SPACE(2,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=Y S=ST IF (S.LT.3.0) THEN IF (THRU) THEN GO TO 400 ELSE GO TO 500 ENDIF ENDIF C C CLEAN-UP THE SEGMENT F VALUES TO MID-RANGE NUMBERS C DO 550 I=1,ISPNUM T=FOFSEG(I)/DFCON IF (ALLPOS) T=MAX(T,0.0) T=IUNDER(T)+0.5 FOFSEG(I)=T*DFCON 550 CONTINUE C C*************************************************************** C C SEARCH FOR EXTREMUM WITHIN DOMAIN OF ELEMENT C CDET=16.*(-F6**2+2.*F6*F5+2.*F6*F4-2.*F6*F2-F5**2+2.*F5*F4 + -2.*F5*F1-F4**2-2.*F4*F3+F3*F2+F3*F1+F2*F1) IF (ABS(CDET).LT. 1.E-40) GO TO 1000 S2EXT=(4.*F6**2-4.*F6*F5-4.*F6*F4-F6*F3+2.*F6*F2-F6*F1+F5* + F3+3.*F5*F1+3.*F4*F3+F4*F1-F3*F2-2.*F3*F1-F2*F1)/(4.*(F6 + **2-2.*F6*F5-2.*F6*F4+2.*F6*F2+F5**2-2.*F5*F4+2.*F5*F1+F4 + **2+2.*F4*F3-F3*F2-F3*F1-F2*F1)) S3EXT=(-4.*F6*F4+3.*F6*F2+F6*F1-4.*F5*F4+F5*F2+3.*F5*F1+4. + *F4**2+2.*F4*F3-F4*F2-F4*F1-F3*F2-F3*F1-2.*F2*F1)/(4.*(F6 + **2-2.*F6*F5-2.*F6*F4+2.*F6*F2+F5**2-2.*F5*F4+2.*F5*F1+F4 + **2+2.*F4*F3-F3*F2-F3*F1-F2*F1)) S1EXT=1.0-S2EXT-S3EXT IF (S1EXT.GT.0.99999.OR.S1EXT.LT.0.00001) GO TO 1000 IF (S2EXT.GT.0.99999.OR.S2EXT.LT.0.00001) GO TO 1000 IF (S3EXT.GT.0.99999.OR.S3EXT.LT.0.00001) GO TO 1000 C C REJECT SADDLE POINTS C DISCA=F1-2.*F4+F2 DISCB=F2-2.*F5+F3 DISCC=F3-2.*F6+F1 CENTER=((DISCA.GT.0.).AND.(DISCB.GT.0.).AND.(DISCC.GT.0.)) + .OR.((DISCA.LT.0.).AND.(DISCB.LT.0.).AND.(DISCC.LT.0.)) IF (.NOT.CENTER) GO TO 1000 XEXT=PHIVAL(S1EXT,S2EXT,S3EXT,X1,X2,X3,X4,X5,X6) YEXT=PHIVAL(S1EXT,S2EXT,S3EXT,Y1,Y2,Y3,Y4,Y5,Y6) FEXT=PHIVAL(S1EXT,S2EXT,S3EXT,F1,F2,F3,F4,F5,F6) FMAX=MAX(FMAX,FEXT) FMIN=MIN(FMIN,FEXT) C C FIND CONTOUR STARTING/STOPPING POINT ALONG CHORD FROM A NODE TO EXT. C NCL=1 DIFF=ABS(F1-FEXT) DS(1)=S1EXT-1. DS(2)=S2EXT DS(3)=S3EXT DO 600 J=2,6 DFF=ABS(FN(J)-FEXT) IF (DFF.LT.DIFF) THEN NCL=J DIFF=DFF DS(1)=S1EXT DS(2)=S2EXT DS(3)=S3EXT IF (J.EQ.2) DS(2)=S2EXT-1. IF (J.EQ.3) DS(3)=S3EXT-1. IF (J.EQ.4.OR.J.EQ.6) DS(1)=S1EXT-0.5 IF (J.EQ.4.OR.J.EQ.5) DS(2)=S2EXT-0.5 IF (J.EQ.5.OR.J.EQ.6) DS(3)=S3EXT-0.5 ENDIF 600 CONTINUE CALL DOLINE (FEXT,DFCON,FN,NCL,DS,S1EXT,S2EXT,S3EXT, + IHIC,ILOC,PS,NPS,NINLIN,Z) IF (Z) THEN WRITE(6,401) IEL GO TO 9999 ENDIF C C END OF CODE RELATED TO CASE OF AN INTERNAL EXTREMEM C 1000 IF (NPS.EQ.0) GO TO 9001 C C************************************************************* C C INTEGRATE ALL CONTOUR SEGMENTS C DO 1150 K=1,NPS DONE(K)=.FALSE. 1150 CONTINUE DO 9000 N=1,NPS C C INTEGRATE ONE CONTOUR SEGMENT C IF (.NOT.DONE(N)) THEN C C INITIALIZE INTEGRATION OF CONTOUR C DONE(N)=.TRUE. FVALUE=PS(4,N) IF (ALLPOS.AND.(FVALUE.LE.0.0)) GO TO 9000 ISPNUM=ISPNUM+1 IF (ISPNUM.GT.NINLIN) THEN WRITE(6,401) IEL GO TO 9999 ENDIF FOFSEG(ISPNUM)=FVALUE ISPPNT(ISPNUM)=ISPPNT(ISPNUM-1)+ISPLEN(ISPNUM-1) IF (ISPPNT(ISPNUM).GT.NWORK) THEN WRITE(6,401) IEL GO TO 9999 ENDIF ISPLEN(ISPNUM)=1 NTOGO(ISPNUM)=2 ANEDGE(ISPNUM)=.FALSE. S1=PS(1,N) S2=PS(2,N) S3=PS(3,N) INSIDE=(S1*S2*S3).GT.0.0 S1OLD=S1 S2OLD=S2 S3OLD=S3 X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) SPACE(1,ISPPNT(ISPNUM))=X SPACE(2,ISPPNT(ISPNUM))=Y ANGLE=0. IF (CENTER) ANGLE=ATAN2((Y-YEXT),(X-XEXT)) ANGLEP=ANGLE ROT=0. DFDS2=-4.*S3*F6+4.*S3*F5-4.*S3*F4+4.*S3*F1-8.*S2*F4+4.*S2* + F2+4.*S2*F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3*F6+4.*S3*F3+4.*S3*F1-4.*S2*F6+4.*S2*F5-4.*S2* + F4+4.*S2*F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX DS2=ROUNDX*DSTEP*0.1 DS3=ROUNDY*DSTEP*0.1 C C REVERSE INTEGRATION STEP DIRECTION IF CONTOUR POINTS OUTWARD C S2P=S2+DS2 S3P=S3+DS3 S1P=1.00-S2P-S3P COUNTR=1. IF ( (S1P.LT.0..OR.S1P.GT.1.) + .OR.(S2P.LT.0..OR.S2P.GT.1.) + .OR.(S3P.LT.0..OR.S3P.GT.1.)) COUNTR= -1. NSEG=0 C C BEGIN LOOP OF INTEGRATION OF CONTOUR LINE C-------------------------------------------- C 3000 NSEG=NSEG+1 C EXTRAPOLATE TO NEXT POINT BY FORWARD METHOD DS2=ROUNDX*COUNTR*DSTEP DS3=ROUNDY*COUNTR*DSTEP S2P=S2+DS2 S3P=S3+DS3 S1P=1.00-S2P-S3P C RECOMPUTE SAME STEP BY BACKWARD METHOD DFDS2=-4.*S3P*F6+4.*S3P*F5-4.*S3P*F4 + +4.*S3P*F1-8.*S2P*F4+4.*S2P* + F2+4.*S2P*F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3P*F6+4.*S3P*F3+4.*S3P*F1 + -4.*S2P*F6+4.*S2P*F5-4.*S2P* + F4+4.*S2P*F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX DS2P=ROUNDX*DSTEP*COUNTR DS3P=ROUNDY*DSTEP*COUNTR C ACTUAL INTEGRATION STEP BY TRAPEZOIDAL METHOD DS2=0.5*(DS2+DS2P) DS3=0.5*(DS3+DS3P) DSLEN=SQRT(DS2**2+DS3**2) IF((DSLEN/DSTEP).LT.0.10) GO TO 8999 S2=S2+DS2 S3=S3+DS3 S1=1.00-S2-S3 C CORRECT CONTOUR TO ACTUAL VALUE DESIRED TRIAL=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) ERR=TRIAL-FVALUE IF (ABS(ERR).GE.DFCON) GO TO 8999 DFDS2=-4.*S3 *F6+4.*S3 *F5-4.*S3 *F4 + +4.*S3 *F1-8.*S2 *F4+4.*S2 * + F2+4.*S2 *F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3 *F6+4.*S3 *F3+4.*S3 *F1 + -4.*S2 *F6+4.*S2 *F5-4.*S2 * + F4+4.*S2 *F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF DISTNC= -ERR/(GRADF*GSIZE) IF (ABS(DISTNC).GT.DSTEP) DISTNC= + DISTNC*DSTEP/ABS(DISTNC) S2=S2+DISTNC*GRADFX S3=S3+DISTNC*GRADFY S1=1.00-S2-S3 C DECIDE WHETHER CONTOUR IS FINISHED OR NOT HITLIM=NSEG.GE.LIMINT IF (HITLIM) WRITE(6,3501)FVALUE,I 3501 FORMAT(' ',1PE10.2,' CONTOUR IN ELEMENT ',I3, + ' SEEMS TO BE IN LOOP. TERMINATED.') GONOUT=(S1.LT.0..OR.S1.GT.1.).OR. + (S2.LT.0..OR.S2.GT.1.).OR. + (S3.LT.0..OR.S3.GT.1.) FINISH=GONOUT.OR.HITLIM IF (CENTER) THEN XT=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YT=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) ANGLEP=ATAN2((YT-YEXT),(XT-XEXT)) DROT=MIN(ABS(ANGLEP-ANGLE), & 6.2832-ABS(ANGLEP-ANGLE)) ROT=ROT+DROT CIRCLE=ROT.GE.6.2832 FINISH=FINISH.OR.CIRCLE IF (CIRCLE.AND.INSIDE) THEN S1=PS(1,N) S2=PS(2,N) S3=PS(3,N) ENDIF ENDIF C IF VECTOR EXTENDS OUTSIDE OF THE ELEMENT, SHORTEN IT ....... IF (GONOUT) THEN RAT=1.0 IF(S1.GT.1.)RAT=AMIN1(RAT,((1.-S1OLD)/(S1-S1OLD))) IF(S2.GT.1.)RAT=AMIN1(RAT,((1.-S2OLD)/(S2-S2OLD))) IF(S3.GT.1.)RAT=AMIN1(RAT,((1.-S3OLD)/(S3-S3OLD))) IF(S1.LT.0.)RAT=AMIN1(RAT,((0.-S1OLD)/(S1-S1OLD))) IF(S2.LT.0.)RAT=AMIN1(RAT,((0.-S2OLD)/(S2-S2OLD))) IF(S3.LT.0.)RAT=AMIN1(RAT,((0.-S3OLD)/(S3-S3OLD))) RAT=AMAX1(RAT,0.0) S2=S2OLD+(S2-S2OLD)*RAT S3=S3OLD+(S3-S3OLD)*RAT S1=1.00-S2-S3 C .... AND CROSS OFF THE CORRESPONDING SIDE-CROSSING POINT IF ((N.LT.NPS).AND.(.NOT.INSIDE)) THEN XE=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YE=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) MATE=N R2MIN=9.9E59 NP1=N+1 DO 4000 M=NP1,NPS TEST=PS(1,M)*PS(2,M)*PS(3,M) IF ((.NOT.DONE(M)).AND. + (PS(4,M).EQ.FVALUE).AND. + (TEST.EQ.0.0) ) THEN XT=PHIVAL(PS(1,M),PS(2,M),PS(3,M), + X1,X2,X3,X4,X5,X6) YT=PHIVAL(PS(1,M),PS(2,M),PS(3,M), + Y1,Y2,Y3,Y4,Y5,Y6) R2=(XT-XE)**2+(YT-YE)**2 IF(R2.LT.R2MIN) THEN MATE=M R2MIN=R2 ENDIF ENDIF 4000 CONTINUE DONE(MATE)=.TRUE. S1=PS(1,MATE) S2=PS(2,MATE) S3=PS(3,MATE) ENDIF ENDIF C LOCATE (X,Y) COORDINATES OF DESTINATION POINT X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) C STORE (X,Y) COORDINATES FOR LATER ISPLEN(ISPNUM)=ISPLEN(ISPNUM)+1 IF ((ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1).GT.NWORK) THEN WRITE(6,401) IEL GO TO 9999 ENDIF SPACE(1,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=X SPACE(2,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=Y C PREPARE FOR NEXT ITERATION IF ONE IS NEEDED S1OLD=S1 S2OLD=S2 S3OLD=S3 IF (.NOT.FINISH) THEN DFDS2=-4.*S3 *F6+4.*S3 *F5-4.*S3 *F4 + +4.*S3 *F1-8.*S2 *F4+4.*S2 * + F2+4.*S2 *F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3 *F6+4.*S3 *F3+4.*S3 *F1 + -4.*S2 *F6+4.*S2 *F5-4.*S2 * + F4+4.*S2 *F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX ANGLE=ANGLEP C C END LOOP OF PUSHING FORWARD ONE CONTOUR SEGMENT C ------------------------------------------ C GO TO 3000 ENDIF C PROVIDE EMERGENCY TERMINATION POINT FOR BEWILDERED CONTOURS 8999 CONTINUE C END OF CODE EXECUTED IF (SEGMENT NOT ALREADY INTEGRATED) ENDIF C CLOSE LOOP ON ALL CONTOUR SEGMENTS 9000 CONTINUE C C**************************************************************** C C BEGIN C CONNECTION OF CONTOUR SEGMENTS AND EDGE SEGMENTS TO CLOSE AREAS C 9001 LEVEL1=IUNDER(FMIN/DFCON) LEVEL2=IUNDER(FMAX/DFCON) IF (ALLPOS) LEVEL1=MAX(LEVEL1,0) DO 9900 IC=LEVEL1,LEVEL2 FCENTR=(IC+0.5)*DFCON IF (ALLPOS) THEN FCENTC=MAX(FCENTR,0.5*DFCON) ELSE FCENTC=FCENTR ENDIF N=IHUE(NCOLOR,DFCON,FMIDLE,IFLIP,FCENTC) CALL GSPAT(ICOLOR(N)) IF (N.EQ.1) THEN ICONT= -2 IAREA=1 ELSE IF (N.EQ.NCOLOR) THEN ICONT= -1 IAREA=1 ELSE ICONT=8 IAREA=0 IF (N.GE.2.AND.N.LE.4) NBLUE=NBLUE+1 IF (N.GE.6.AND.N.LE.8) NYELOW=NYELOW+1 ENDIF IF (ALLPOS.AND.FCENTR.LT.0.0) THEN ICONT=8 IAREA=0 ENDIF CALL GSCOL(7) CALL GSLW(1) CALL GSAREA(IAREA) C BUILD MENU OF RELEVANT SEGMENTS (SO THAT NONE IS USED TWICE) NMENU=0 DO 9020 I=1,ISPNUM IF(ABS((FOFSEG(I)-FCENTR)/DFCON).LE.0.75) THEN IF (NTOGO(I).GT.0) THEN NMENU=MIN(NMENU+1,NINLIN) NTOGO(I)=NTOGO(I)-1 MENU(NMENU)=I ENDIF ENDIF 9020 CONTINUE C DRAW SET OF CLOSED AREAS FROM MENU OF RELEVANT SEGMENTS 9050 IF (NMENU.LE.0) GO TO 9899 C BEGIN EACH CLOSED AREA WITH THE TOP SEGMENT IN THE MENU IDISH=1 NADD=+1 I1=ISPPNT(MENU(1)) XORIGN=SPACE(1,I1) YORIGN=SPACE(2,I1) CALL GSMOVE(XORIGN,YORIGN) C BEGIN INDEFINATE LOOP ON SEGMENTS IN ONE AREA C ------------------------------------- 9100 NAME=MENU(IDISH) IF (ANEDGE(NAME)) THEN IF (N.EQ.1) THEN IPEN= -1 ELSE IF (N.EQ.NCOLOR) THEN IPEN= -2 ELSE IPEN=8 ENDIF ELSE IPEN=ICONT ENDIF CALL GSCOL(IPEN) IF (NADD.EQ.1) THEN I1=ISPPNT(NAME) I2=I1+ISPLEN(NAME)-1 ELSE I2=ISPPNT(NAME) I1=I2+ISPLEN(NAME)-1 ENDIF DO 9500 I=I1,I2,NADD X=SPACE(1,I) Y=SPACE(2,I) CALL GSLINE(X,Y) 9500 CONTINUE C DROP SEGMENT FROM MENU IMMEDIATELY AFTER DRAWING NMENU=NMENU-1 DO 9510 J=IDISH,NMENU MENU(J)=MENU(J+1) 9510 CONTINUE C IF NECESSARY, STRING TOGETHER OTHER SEGMENTS TO COMPLETE AREA IF (NMENU.LE.0) GO TO 9899 RMIN=1.E60 DO 9600 J=1,NMENU XB=SPACE(1,ISPPNT(MENU(J))) YB=SPACE(2,ISPPNT(MENU(J))) RB=SQRT((X-XB)**2+(Y-YB)**2) IF (RB.LT.RMIN) THEN RMIN=RB IDISH=J NADD=+1 ENDIF XE=SPACE(1,ISPPNT(MENU(J))+ISPLEN(MENU(J))-1) YE=SPACE(2,ISPPNT(MENU(J))+ISPLEN(MENU(J))-1) RE=SQRT((X-XE)**2+(Y-YE)**2) IF (RE.LT.RMIN) THEN RMIN=RE IDISH=J NADD= -1 ENDIF 9600 CONTINUE R=SQRT((X-XORIGN)**2+(Y-YORIGN)**2) IF (R.GT.RMIN) THEN C LOOP NOT CLOSED; GET MORE SEGMENTS GO TO 9100 ELSE C LOOP ESSENTIALLY CLOSED; FINISH IT IF (R.GT.0.) THEN CALL GSLINE(XORIGN,YORIGN) ENDIF C RETURN FOR MORE AREAS OF SAME COLOR (?) IF (NMENU.GT.0) GO TO 9050 ENDIF 9899 CALL GSENDA C C CLOSE LOOP ON COLOR LEVELS IN ONE ELEMENT C 9900 CONTINUE C C *************************************************************** C C CLOSE LOOP ON ALL ELEMENTS FGMAX=MAX(FGMAX,FMAX) FGMIN=MIN(FGMIN,FMIN) 9999 CONTINUE RETURN END C C C SUBROUTINE DOSIDE (FMAX,FMIN,DFCON,FN,N1,N2,NM,PS,NPS,NINLIN,Z) C C FIND BEGINNING/END POINTS OF CONTOURS ALONG SIDE OF ELEMENT C LOGICAL Z DIMENSION FN(6),PS(5,NINLIN) ILOW=IUNDER(FMIN/DFCON) IF (FMIN.EQ.(DFCON*ILOW)) ILOW=ILOW-1 IHI=IABOVE(FMAX/DFCON) IF (FMAX.EQ.(DFCON*IHI)) IHI=IHI+1 NBTWEN=IHI-ILOW-1 IF (NBTWEN.GE.1) THEN NBASE=ILOW A=2.*FN(N1)-4.*FN(NM)+2.*FN(N2) B= -3.*FN(N1)+4.*FN(NM)-FN(N2) DO 10 K=1,NBTWEN N=K+NBASE F=N*DFCON C= FN(N1)-F IF (A.NE.0.) THEN DISC=SQRT(MAX(B**2-4.*A*C,0.)) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) OUT1=MAX(MAX(0.,-ROOT1),MAX(0.,ROOT1-1.)) OUT2=MAX(MAX(0.,-ROOT2),MAX(0.,ROOT2-1.)) IF (OUT1.LE.OUT2) THEN IF (OUT1.GT.0.10)GO TO 10 S=ROOT1 ELSE IF (OUT2.GT.0.10)GO TO 10 S=ROOT2 ENDIF ELSE IF (FN(N2).NE.FN(N1)) THEN S=(F-FN(N1))/(FN(N2)-FN(N1)) ELSE S=0. ENDIF Z=(NPS.GE.NINLIN) IF (Z) RETURN NPS=NPS+1 PS(N1,NPS)=1.-S PS(N2,NPS)=S N3=6-N1-N2 PS(N3,NPS)=0. PS(4,NPS)=F 10 CONTINUE ENDIF RETURN END C C C SUBROUTINE DOPART (FEXT,FMAX,FMIN,DFCON,FN, + N1,N2,NM,S1,S2,PS,NPS,NINLIN,Z) C C FIND CONTOUR END POINTS ALONG PART OF AN ELEMENT SIDE C LOGICAL Z DIMENSION FN(6),PS(5,NINLIN) ILOW=IUNDER(FMIN/DFCON) IF (FMIN.EQ.(DFCON*ILOW)) ILOW=ILOW-1 IHI=IABOVE(FMAX/DFCON) IF (FMAX.EQ.(DFCON*IHI)) IHI=IHI+1 NBTWEN=IHI-ILOW-1 IF (NBTWEN.GE.1) THEN NBASE=ILOW A=2.*FN(N1)-4.*FN(NM)+2.*FN(N2) B= -3.*FN(N1)+4.*FN(NM)-FN(N2) DO 20 K=1,NBTWEN N=K+NBASE F=N*DFCON C= FN(N1)-F IF (A.NE.0.) THEN DISC=SQRT(MAX(B**2-4.*A*C,0.)) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) OUT1=MAX(MAX(0.,S1-ROOT1),MAX(0.,ROOT1-S2)) OUT2=MAX(MAX(0.,S1-ROOT2),MAX(0.,ROOT2-S2)) IF (OUT1.LE.OUT2) THEN IF (OUT1.GT.0.10) GO TO 20 S=ROOT1 ELSE IF (OUT2.GT.0.10) GO TO 20 S=ROOT2 ENDIF ELSE IF (FN(N1).NE.FN(N2)) THEN S=(F-FN(N1))/(FN(N2)-FN(N1)) ELSE S=0. ENDIF Z=(NPS.GE.NINLIN) IF (Z) RETURN NPS=NPS+1 PS(N1,NPS)=1.-S PS(N2,NPS)=S N3=6-N1-N2 PS(N3,NPS)=0. PS(4,NPS)=F 20 CONTINUE ENDIF RETURN END C C C SUBROUTINE DOLINE (FEXT,DFCON,FN,NCL,DS,S1EXT,S2EXT,S3EXT, + IHIC,ILOC,PS,NPS,NINLIN,Z) C C FINDS CONTOUR START/END POINT ALONG LINE FROM A NODE TO AN EXTREMUM C NOTE THAT POINTS ARE STORED ONLY IF (F/DEFCON) FALLS OUTSIDE OF C PREVIOUS RANGE ILOC-IHIC FOUND ALONG ELEMENT SIDES. C LOGICAL Z DIMENSION FN(6),DS(3),PS(5,NINLIN) PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) FMAX=AMAX1(FN(NCL),FEXT) FMIN=AMIN1(FN(NCL),FEXT) ILOW=IUNDER(FMIN/DFCON) IF (FMIN.EQ.(DFCON*ILOW)) ILOW=ILOW-1 IHI=IABOVE(FMAX/DFCON) IF (FMAX.EQ.(DFCON*IHI)) IHI=IHI+1 NBTWEN=IHI-ILOW-1 IF (NBTWEN.GE.1) THEN NBASE=ILOW FMID=PHIVAL((S1EXT-0.5*DS(1)),(S2EXT-0.5*DS(2)), + (S3EXT-0.5*DS(3)),FN(1),FN(2),FN(3), + FN(4),FN(5),FN(6)) A=2.*FN(NCL)-4.*FMID+2.*FEXT B= -3.*FN(NCL)+4.*FMID-FEXT DO 20 K=1,NBTWEN N=K+NBASE F=N*DFCON C= FN(NCL)-F IF (A.NE.0.) THEN DISC=SQRT(MAX(B**2-4.*A*C,0.)) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) OUT1=MAX(MAX(0.,-ROOT1),MAX(0.,ROOT1-1.)) OUT2=MAX(MAX(0.,-ROOT2),MAX(0.,ROOT2-1.)) IF (OUT1.LE.OUT2) THEN IF (OUT1.GT.0.10) GO TO 20 S=ROOT1 ELSE IF (OUT2.GT.0.10) GO TO 20 S=ROOT2 ENDIF ELSE IF (FEXT.NE.FN(NCL)) THEN S=(F-FN(NCL))/(FEXT-FN(NCL)) ELSE S=0. ENDIF Z=(NPS.GE.NINLIN) IF (Z) RETURN IF (F.GE.0.) THEN IC=F/DFCON+0.1 ELSE IT= -F/DFCON+0.1 IC= -IT ENDIF IF ((IC.GT.IHIC).OR.(IC.LT.ILOC)) THEN NPS=NPS+1 PS(1,NPS)=S1EXT-(1.-S)*DS(1) PS(2,NPS)=S2EXT-(1.-S)*DS(2) PS(3,NPS)=S3EXT-(1.-S)*DS(3) PS(4,NPS)=F ENDIF 20 CONTINUE ENDIF RETURN END C C C SUBROUTINE 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 DIMENSION NODES(6,0:NUMEL),XNOD(NUMNOD),YNOD(NUMNOD) DIMENSION S(3),DS(3) DATA STEP/0.10/, ISTEP/10/ PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6)= + F1*(-S1+2.*S1**2)+ + F2*(-S2+2.*S2**2)+ + F3*(-S3+2.*S3**2)+ + F4*(4.*S1*S2)+ + F5*(4.*S2*S3)+ + F6*(4.*S3*S1) I1=NODES(1,I) I2=NODES(2,I) I3=NODES(3,I) I4=NODES(4,I) I5=NODES(5,I) I6=NODES(6,I) X1=XNOD(I1) X2=XNOD(I2) X3=XNOD(I3) X4=XNOD(I4) X5=XNOD(I5) X6=XNOD(I6) Y1=YNOD(I1) Y2=YNOD(I2) Y3=YNOD(I3) Y4=YNOD(I4) Y5=YNOD(I5) Y6=YNOD(I6) DO 100 ISIDE=1,3 IF (ISIDE.EQ.1.AND..NOT.S4) GO TO 100 IF (ISIDE.EQ.2.AND..NOT.S5) GO TO 100 IF (ISIDE.EQ.3.AND..NOT.S6) GO TO 100 J1=ISIDE J2=MOD(ISIDE,3)+1 DO 10 K=1,3 S(K)=0. DS(K)=0. 10 CONTINUE S(J1)=1.00 DS(J1)= -STEP DS(J2)= STEP X=PHIVAL(S(1),S(2),S(3),X1,X2,X3,X4,X5,X6) Y=PHIVAL(S(1),S(2),S(3),Y1,Y2,Y3,Y4,Y5,Y6) CALL GSMOVE(X,Y) DO 20 K=1,ISTEP DO 15 L=1,3 S(L)=S(L)+DS(L) 15 CONTINUE X=PHIVAL(S(1),S(2),S(3),X1,X2,X3,X4,X5,X6) Y=PHIVAL(S(1),S(2),S(3),Y1,Y2,Y3,Y4,Y5,Y6) CALL GSLINE(X,Y) 20 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE MAGNIT (OUTVEC,NUMEL,OUTSCA,SOMNEG) C C CONVERT VECTOR TO SCALAR MAGNITUDE AT INTEGRATION POINTS C INCLUDES OPTION TO MAKE MAGNITUDES OF RIGHT-POINTING C VECTORS BE NEGATIVE, "UNDOING" THE EFFECT OF VPLOT ON C PRINCIPAL-AXIS "VECTORS". C LOGICAL SOMNEG DIMENSION OUTSCA(7,NUMEL),OUTVEC(2,7,NUMEL) DO 10 M=1,7 DO 9 I=1,NUMEL OUTSCA(M,I)=SQRT(OUTVEC(1,M,I)**2+ + OUTVEC(2,M,I)**2) 9 CONTINUE 10 CONTINUE IF (SOMNEG) THEN DO 20 M=1,7 DO 19 I=1,NUMEL IF(OUTVEC(1,M,I).GT.0.) OUTSCA(M,I)= + -OUTSCA(M,I) 19 CONTINUE 20 CONTINUE ENDIF RETURN END C C C SUBROUTINE MAGNIN (V,NUMNOD,CONDNS) C C CONVERT VECTOR TO SCALAR MAGNITUDE AT NODES C DIMENSION CONDNS(NUMNOD),V(2,NUMNOD) DO 10 I=1,NUMNOD CONDNS(I)=SQRT(V(1,I)**2+V(2,I)**2) 10 CONTINUE RETURN END C C C SUBROUTINE INTRVL (OUTSCA,NUMEL,CONDNS,NUMNOD,DFCON,NCONTR) C C COMPUTE CONTOUR INTERVAL ROUNDED TO NEAREST 1,2,3,4,5, X 10**P C DIMENSION CONDNS(NUMNOD),OUTSCA(7,NUMEL) RLOW=9.9E59 RHI=-9.9E59 DO 20 M=1,7 DO 10 I=1,NUMEL RLOW=MIN(RLOW,OUTSCA(M,I)) RHI =MAX(RHI ,OUTSCA(M,I)) 10 CONTINUE 20 CONTINUE DO 30 I=1,NUMNOD RLOW=MIN(RLOW,CONDNS(I)) RHI =MAX(RHI ,CONDNS(I)) 30 CONTINUE GUESS=(RHI-RLOW)/NCONTR IF (GUESS.GT.0.) THEN IZERO=IUNDER(ALOG10(GUESS)) FACTOR=GUESS/10.**IZERO IFACTR=FACTOR+0.5 IFACTR=MIN0(5,IFACTR) IF (FACTOR.GT.7.) IFACTR=10 DFCON=IFACTR*10.**IZERO ELSE DFCON=1.00 ENDIF RETURN END C C C INTEGER FUNCTION IUNDER (X) C C RETURNS INTEGER .LE. X, UNLIKE INT FUNCTION C IUNDER=INT(X) IF (X.LT.(1.*IUNDER)) IUNDER=IUNDER-1 RETURN END C C C INTEGER FUNCTION IABOVE (X) C C RETURNS INTEGER .GE. X, UNLIKE INT FUNCTION C IF (X.LE.0.) THEN IABOVE=INT(X) ELSE IABOVE=INT(X) IF (X.GT.IABOVE) IABOVE=IABOVE+1 ENDIF RETURN END C C C SUBROUTINE USMAP (INPUT,DRAWST,NXYST,XST,YST) C C PLOTS OUTLINE OF STATES FROM DIGITIZED DATASET. C LOGICAL DRAW,DRAWST DIMENSION DRAWST(NXYST),XST(NXYST),YST(NXYST) DO 100 I=1,NXYST XP=XST(I) YP=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 (NUMEL,OUTVEC,RMSVEC, + SCALE,XIP,YIP) C C DRAWS VECTORS WITH RMS LENGTH RMSVEC INCHES FROM ELEMENT C CENTERS C DIMENSION OUTVEC(2,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) CALL GSLW(2) CALL GSLT(0) CALL GSCOL(6) SUM=0. DO 100 I=1,NUMEL SUM=SUM+OUTVEC(1,1,I)**2+OUTVEC(2,1,I)**2 100 CONTINUE IF (SUM.LE.0.) RETURN FACTR=SCALE*RMSVEC/SQRT(SUM/NUMEL) DO 200 I=1,NUMEL X=XIP(1,I) Y=YIP(1,I) CALL GSMOVE(X,Y) DX=FACTR*OUTVEC(1,1,I) DY=FACTR*OUTVEC(2,1,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) 200 CONTINUE RETURN END C C C SUBROUTINE AXES (NUMEL,TAUMT,TAUZZ,RMSVEC, + SCALE,XIP,YIP) C C DRAWS TENSOR PRINCIPAL AXES, WITH RMS LENGTH RMSVEC INCHES, C AT ELEMENT CENTERS. C CONVENTION IS THAT AXIS IS COMPRESSIVE (INWARD-POINTING) C IF PRINCIPAL VALUE(S) OF TENSOR ARE NEGATIVE. C ALSO WRITES VERY SMALL TEXT LABELS GIVING MAGNITUDES OF ONE C PRINCIPAL AXIS; THESE WILL NOT BE NOTICABLE AT NORMAL C MAGNIFICATION. C CHARACTER*8 ASCII DIMENSION TAUMT(3,7,NUMEL),TAUZZ(7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) C 1001 FORMAT(1P,E8.1) CALL GSLW(2) CALL GSLT(0) CALL GSCOL(-1) CALL GSLSS(2,'ADMUWCRP',199) CALL GSCM(3) CALL GSCS(199) CALL GSQCB(WIDTH,HEIGHT) HIGH=0.12*SCALE*RMSVEC WIDE=HIGH*WIDTH/HEIGHT CALL GSCB(WIDE,HIGH) C SUM=0. DO 100 I=1,NUMEL TZZ=TAUZZ(1,I) TXX=TAUMT(1,1,I)+TZZ TYY=TAUMT(2,1,I)+TZZ TXY=TAUMT(3,1,I) SHEAR=SQRT(TXY**2+0.25*(TXX-TYY)**2) CENTER=(TXX+TYY)/2. T1=CENTER-SHEAR T2=CENTER+SHEAR SUM=SUM+(MAX(ABS(T1),ABS(T2),ABS(TZZ)))**2 100 CONTINUE IF (SUM.LE.0.) RETURN FACTR=0.5*SCALE*RMSVEC/SQRT(SUM/NUMEL) C DO 200 I=1,NUMEL X=XIP(1,I) Y=YIP(1,I) TZZ=TAUZZ(1,I) TXX=TAUMT(1,1,I)+TZZ TYY=TAUMT(2,1,I)+TZZ TXY=TAUMT(3,1,I) SHEAR=SQRT(TXY**2+0.25*(TXX-TYY)**2) CENTER=(TXX+TYY)/2. T1=CENTER-SHEAR T2=CENTER+SHEAR ANGLE=0.5*ATAN2F(-TXY,(TYY-TXX)/2.) DR=FACTR*ABS(TZZ) IF (TZZ.LT.0.0) THEN C CIRCLE FOR COMPRESSIVE VERTICAL STRESS ANOMALY CALL GSMOVE(X+DR,Y) CALL GSARC(X,Y,360.) IF (ABS(TZZ).GT.ABS(T1).AND.ABS(TZZ).GT.ABS(T2)) THEN XT=X-3.*WIDE YT=Y-1.0*DR-1.2*HIGH CALL GSMOVE(XT,YT) CALL GSCA(COS(0.0),SIN(0.0)) WRITE(ASCII,1001)TZZ CALL GSCHAR(XT,YT,8,ASCII) ENDIF ELSE IF (TZZ.GT.0.0) THEN C TRIANGLE FOR TENSILE VERTICAL STRESS ANOMALY CALL GSMOVE(X+0.866*DR,Y-0.5*DR) CALL GSLINE(X,Y+DR) CALL GSLINE(X-0.866*DR,Y-0.5*DR) CALL GSLINE(X+0.866*DR,Y-0.5*DR) IF (ABS(TZZ).GT.ABS(T1).AND.ABS(TZZ).GT.ABS(T2)) THEN XT=X-3.*WIDE YT=Y-0.5*DR-1.2*HIGH CALL GSMOVE(XT,YT) CALL GSCA(COS(0.0),SIN(0.0)) WRITE(ASCII,1001)TZZ CALL GSCHAR(XT,YT,8,ASCII) ENDIF ENDIF DX=FACTR*T1*COS(ANGLE) DY=FACTR*T1*SIN(ANGLE) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) IF (T1.GT.0.0) THEN C TENSILE PRINCIPAL STRESS ANOMALY CALL GSMOVE(XN,YN) CALL GSLINE(XP,YP) CALL GSLINE(XP+AX,YP+AY) CALL GSMOVE(XP,YP) CALL GSLINE(XP+BX,YP+BY) CALL GSMOVE(XN-AX,YN-AY) CALL GSLINE(XN,YN) CALL GSLINE(XN-BX,YN-BY) IF (ABS(T1).GT.ABS(TZZ).AND.ABS(T1).GT.ABS(T2)) THEN IF (ABS(ANGLE).LE.1.57) THEN ANGLE2=ANGLE ELSE ANGLE2=ANGLE+3.14159 ENDIF XT=X+T1*FACTR*COS(ANGLE2) YT=Y+T1*FACTR*SIN(ANGLE2) CALL GSMOVE(XT,YT) CALL GSCA(COS(ANGLE2),SIN(ANGLE2)) WRITE(ASCII,1001)T1 CALL GSCHAR(XT,YT,8,ASCII) ENDIF ELSE C COMPRESSIVE PRINCIPAL STRESS ANOMALY CALL GSMOVE(XN,YN) CALL GSLINE(XP,YP) CALL GSMOVE(X+AX,Y+AY) CALL GSLINE(X-AX,Y-AY) CALL GSMOVE(X+BX,Y+BY) CALL GSLINE(X-BX,Y-BY) IF (ABS(T1).GT.ABS(TZZ).AND.ABS(T1).GT.ABS(T2)) THEN IF (ABS(ANGLE).LE.1.57) THEN ANGLE2=ANGLE ELSE ANGLE2=ANGLE+3.14159 ENDIF XT=X-T1*FACTR*COS(ANGLE2) YT=Y-T1*FACTR*SIN(ANGLE2) CALL GSMOVE(XT,YT) CALL GSCA(COS(ANGLE2),SIN(ANGLE2)) WRITE(ASCII,1001)T1 CALL GSCHAR(XT,YT,8,ASCII) ENDIF ENDIF DX=FACTR*T2*COS(ANGLE+1.5708) DY=FACTR*T2*SIN(ANGLE+1.5708) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) IF (T2.GT.0.0) THEN C TENSILE PRINCIPAL STRESS ANOMALY CALL GSMOVE(XN,YN) CALL GSLINE(XP,YP) CALL GSLINE(XP+AX,YP+AY) CALL GSMOVE(XP,YP) CALL GSLINE(XP+BX,YP+BY) CALL GSMOVE(XN-AX,YN-AY) CALL GSLINE(XN,YN) CALL GSLINE(XN-BX,YN-BY) IF (ABS(T2).GT.ABS(TZZ).AND.ABS(T2).GT.ABS(T1)) THEN ANGLE2=ANGLE+1.5708 IF (ABS(ANGLE2).GT.1.5708) ANGLE2=ANGLE2+3.15 XT=X+T2*FACTR*COS(ANGLE2) YT=Y+T2*FACTR*SIN(ANGLE2) CALL GSMOVE(XT,YT) CALL GSCA(COS(ANGLE2),SIN(ANGLE2)) WRITE(ASCII,1001)T2 CALL GSCHAR(XT,YT,8,ASCII) ENDIF ELSE C COMPRESSIVE PRINCIPAL STRESS ANOMALY CALL GSMOVE(XN,YN) CALL GSLINE(XP,YP) CALL GSMOVE(X+AX,Y+AY) CALL GSLINE(X-AX,Y-AY) CALL GSMOVE(X+BX,Y+BY) CALL GSLINE(X-BX,Y-BY) IF (ABS(T2).GT.ABS(TZZ).AND.ABS(T2).GT.ABS(T1)) THEN ANGLE2=ANGLE+1.5708 IF (ABS(ANGLE2).GT.1.5708) ANGLE2=ANGLE2+3.15 XT=X-T2*FACTR*COS(ANGLE2) YT=Y-T2*FACTR*SIN(ANGLE2) CALL GSMOVE(XT,YT) CALL GSCA(COS(ANGLE2),SIN(ANGLE2)) WRITE(ASCII,1001)T2 CALL GSCHAR(XT,YT,8,ASCII) ENDIF ENDIF 200 CONTINUE RETURN END C C C SUBROUTINE MAXER (ERATE,NUMEL,OUTSCA) C C FINDS LARGEST (ABS. VALUE) LINEAR STRETCH RATE IN THE TENSOR ERATE C AND ASSIGNS ITS SCALAR VALUE TO OUTSCA C DIMENSION ERATE(4,7,NUMEL),OUTSCA(7,NUMEL) C DO 100 M=1,7 DO 90 I=1,NUMEL EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) DIVER=EXX+EYY SHEAR=SQRT(EXY**2+0.25*(EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR EZ= -DIVER BIGSHR=MAX(ABS(E1),ABS(E2),ABS(EZ)) OUTSCA(M,I)=BIGSHR 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE MAXSS (TAUMT,TAUZZ,NUMEL,OUTSCA) C C FINDS LARGEST (ABS. VALUE) SHEAR STRESS INTEGRAL IN TENSOR TAUMT C AND ASSIGNS ITS SCALAR VALUE TO OUTSCA C DIMENSION TAUMT(3,7,NUMEL),TAUZZ(7,NUMEL),OUTSCA(7,NUMEL) C DO 100 M=1,7 DO 90 I=1,NUMEL TXX=TAUMT(1,M,I)+TAUZZ(M,I) TYY=TAUMT(2,M,I)+TAUZZ(M,I) TXY=TAUMT(3,M,I) SHEAR=SQRT(TXY**2+0.25*(TXX-TYY)**2) CENTER=(TXX+TYY)/2. T1=CENTER-SHEAR T2=CENTER+SHEAR TZ=TAUZZ(M,I) BIGSHR=MAX(SHEAR,ABS(T2-TZ)/2.,ABS(T1-TZ)/2.) OUTSCA(M,I)=BIGSHR 90 CONTINUE 100 CONTINUE RETURN END C C C SUBROUTINE FAULTS (NUMEL,ERATE,RMSVEC, + XIP,YIP) C C DRAWS FAULT TRACES, WITH UNIFORM LENGTH OF RMSVEC INCHES, C AT ELEMENT CENTERS. C CONVENTION IS THAT STRAIN IS COMPRESSIVE (INWARD-POINTING) C IF PRINCIPAL VALUE(S) OF ERATE ARE NEGATIVE. C ALSO NOTE THAT INTERNAL VARIABLE "ANGLE" IS DIRECTION OF E1 C MEASURED COUNTERCLOCKWISE FROM X (RIGHT). C DIMENSION ERATE(4,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) DIMENSION XARRAY(20),YARRAY(20) LOGICAL E1PART,E2PART,EZPART C DO 200 I=1,NUMEL X=XIP(1,I) Y=YIP(1,I) EXX=ERATE(1,1,I) EYY=ERATE(2,1,I) EXY=ERATE(3,1,I) DIVER=EXX+EYY SHEAR=SQRT(EXY**2+0.25*(EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR EZ= -DIVER IF ((E2*EZ).GT.0.) THEN E1PART=.TRUE. E2PART=.FALSE. EZPART=.FALSE. ELSE IF ((E1*EZ).GT.0.) THEN E1PART=.FALSE. E2PART=.TRUE. EZPART=.FALSE. ELSE E1PART=.FALSE. E2PART=.FALSE. EZPART=.TRUE. END IF ANGLE=0.5*ATAN2F(-EXY,(EYY-EXX)/2.) BIGSHR=0. IF (E1*E2.LT.0.) BIGSHR=MAX(BIGSHR,MIN(ABS(E1),ABS(E2))) IF (E1*EZ.LT.0.) BIGSHR=MAX(BIGSHR,MIN(ABS(E1),ABS(EZ))) IF (E2*EZ.LT.0.) BIGSHR=MAX(BIGSHR,MIN(ABS(E2),ABS(EZ))) FACTR=0.5*RMSVEC/MAX(BIGSHR,1.E-30) IF (E1*E2.LT.0.) THEN C STRIKE-SLIP FAULTS IF (E1PART) THEN R=FACTR*ABS(E2) ELSE R=FACTR*ABS(E1) END IF DX=R*COS(ANGLE+0.5236) DY=R*SIN(ANGLE+0.5236) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) DX=R*COS(ANGLE-0.5236) DY=R*SIN(ANGLE-0.5236) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) ENDIF IF (E1.LT.0..AND.EZ.GT.0.) THEN C THRUST FAULTS PERP. TO E1 IF (E1PART) THEN R=FACTR*ABS(EZ) ELSE R=FACTR*ABS(E1) END IF DX=R*COS(ANGLE+1.5708) DY=R*SIN(ANGLE+1.5708) DXP=0.20*R*COS(ANGLE+3.937) DYP=0.20*R*SIN(ANGLE+3.927) XARRAY(1)=X+DX XARRAY(2)=X+DX+DXP XARRAY(3)=X+DX+DXP-DYP XARRAY(4)=X+DX-DYP XARRAY(5)=X+DX YARRAY(1)=Y+DY YARRAY(2)=Y+DY+DYP YARRAY(3)=Y+DY+DYP+DXP YARRAY(4)=Y+DY+DXP YARRAY(5)=Y+DY CALL TONE(XARRAY,YARRAY,5,1) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) XARRAY(1)=X-DX XARRAY(2)=X-DX-DXP XARRAY(3)=X-DX-DXP+DYP XARRAY(4)=X-DX+DYP XARRAY(5)=X-DX YARRAY(1)=Y-DY YARRAY(2)=Y-DY-DYP YARRAY(3)=Y-DY-DYP-DXP YARRAY(4)=Y-DY-DXP YARRAY(5)=Y-DY CALL TONE(XARRAY,YARRAY,5,1) ENDIF IF (E2.LT.0..AND.EZ.GT.0.) THEN C THRUST FAULTS PERP. TO E2 IF (EZPART) THEN R=FACTR*ABS(E2) ELSE R=FACTR*ABS(EZ) END IF DX=R*COS(ANGLE) DY=R*SIN(ANGLE) DXP=0.20*R*COS(ANGLE+2.356) DYP=0.20*R*SIN(ANGLE+2.356) XARRAY(1)=X+DX XARRAY(2)=X+DX+DXP XARRAY(3)=X+DX+DXP-DYP XARRAY(4)=X+DX-DYP XARRAY(5)=X+DX YARRAY(1)=Y+DY YARRAY(2)=Y+DY+DYP YARRAY(3)=Y+DY+DYP+DXP YARRAY(4)=Y+DY+DXP YARRAY(5)=Y+DY CALL TONE(XARRAY,YARRAY,5,1) CALL PLOT(X+DX,Y+DY,3) CALL PLOT(X-DX,Y-DY,2) XARRAY(1)=X-DX XARRAY(2)=X-DX-DXP XARRAY(3)=X-DX-DXP+DYP XARRAY(4)=X-DX+DYP XARRAY(5)=X-DX YARRAY(1)=Y-DY YARRAY(2)=Y-DY-DYP YARRAY(3)=Y-DY-DYP-DXP YARRAY(4)=Y-DY-DXP YARRAY(5)=Y-DY CALL TONE(XARRAY,YARRAY,5,1) ENDIF IF (E1.GT.0..AND.EZ.LT.0.) THEN C NORMAL FAULTS PERP. TO E1 IF (E1PART) THEN R=FACTR*ABS(EZ) ELSE R=FACTR*ABS(E1) END IF DX1=R*COS(ANGLE+1.7682) DY1=R*SIN(ANGLE+1.7682) DX2=R*COS(ANGLE+1.3734) DY2=R*SIN(ANGLE+1.3734) XARRAY(1)=X+DX1 XARRAY(2)=X+DX2 XARRAY(3)=X-DX1 XARRAY(4)=X-DX2 XARRAY(5)=X+DX1 YARRAY(1)=Y+DY1 YARRAY(2)=Y+DY2 YARRAY(3)=Y-DY1 YARRAY(4)=Y-DY2 YARRAY(5)=Y+DY1 CALL TONE(XARRAY,YARRAY,5,1) ENDIF IF (E2.GT.0..AND.EZ.LT.0.) THEN C NORMAL FAULTS PERP. TO E2 IF (EZPART) THEN R=FACTR*ABS(E2) ELSE R=FACTR*ABS(EZ) END IF DX1=R*COS(ANGLE+0.1974) DY1=R*SIN(ANGLE+0.1974) DX2=R*COS(ANGLE-0.1974) DY2=R*SIN(ANGLE-0.1974) XARRAY(1)=X+DX1 XARRAY(2)=X+DX2 XARRAY(3)=X-DX1 XARRAY(4)=X-DX2 XARRAY(5)=X+DX1 YARRAY(1)=Y+DY1 YARRAY(2)=Y+DY2 YARRAY(3)=Y-DY1 YARRAY(4)=Y-DY2 YARRAY(5)=Y+DY1 CALL TONE(XARRAY,YARRAY,5,1) ENDIF 200 CONTINUE RETURN END C C C CHARACTER*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.) I2=INT((S-100.*I1)/10.) I3=INT(S-100.*I1-10.*I2) I4=INT(10.*(S-100.*I1-10.*I2-I3)+0.5) IF (I4.EQ.10) THEN I4=0 I3=I3+1 IF (I3.EQ.10) THEN I3=0 I2=I2+1 IF (I2.EQ.10) THEN I2=0 I1=I1+1 ENDIF ENDIF ENDIF ASCII(1:1)=CHAR(240+I1) ASCII(2:2)=CHAR(240+I2) ASCII(3:3)=CHAR(240+I3) ASCII(4:4)='.' 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 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 IHUE (NCOLOR,CINT,FMIDLE,IFLIP,F) C C RETURNS ORDINAL NUMBER OF COLOR ASSOCIATED WITH FUNCTION VALUE 'F' C WHEN CONTOURED WITH INTERVAL 'CINT', AND WHEN VALUE 'FMIDLE' IS C ROUNDED TO A CONTOUR LEVEL IN THE CENTER OF THE SPECTRUM. C IF IFLIP=+1, BLUE GOES WITH LOW VALUES AND RED WITH HIGH; C IF IFLIP=-1, THE SPECTRUM IS REVERSED. C OUTPUT VALUE SHOULD BE USED AS INDEX IN "ICOLOR" TO SELECT CODE C NUMBER OF THE SHADING PATTERN APPLIED. C THAT IS, ARRAY "ICOLOR" CONTAINS THE SPECTRUM DEFINITION. C C FMP=IUNDER((FMIDLE/CINT)+0.5)*CINT STEPS=IFLIP*(F-FMP)/CINT IHUE=STEPS+(NCOLOR/2.)+1.0 IHUE=MAX(IHUE,1) IHUE=MIN(IHUE,NCOLOR) RETURN END C C C BLOCK DATA PROFIL C C ESTABLISHES PROFILE OF CORDILLERA, PER MODEL OF C GROW AND BOWIN (1975) JOURNAL OF GEOPHYSICAL RESEARCH, C VOL. 80, NUMBER 11, PAGE 1454. C THIS MODEL IS FOR AN EAST-WEST SECTION OF THE ANDES AT 23 SOUTH. C ITS ORIGINAL PARAMETER VALUES ARE: WANDES = 730 KM, APLANO = 5 KM. C C NOTE: HANDES IS A LIST OF DIMENSIONLESS NUMBERS WHICH REACH A C PLATEAU LEVEL OF +1.0 SOMEWHERE IN THE MIDDLE, DEFINING THE C HEIGHT PROFILE OF THE CORDILLERA RELATIVE TO HEIGHT "APLANO". C XANDES CONTAINS THE DIMENSIONLESS DISTANCES (RELATIVE TO C WANDES) AT WHICH THESE RATIOS ARE GIVEN. C XANDES(1) SHOULD ALWAYS BE ZERO; C XANDES(NPOINT) SHOULD ALWAYS BE 1.00. C LINEAR INTERPOLATION IS USED IN BETWEEN GIVEN POINTS; C THICKNESSES THICKN(2) APPLY AT X.GT.XANDES(NPOINT). C THE ALTIPLANO REGION IS LIMITED BY POINTS NALT1 AND NALT2; C AT X=XANDES(NALT1) THE SUBDUCTING SLAB LOSES CONTACT WITH C THE OVERRIDING PLATE. C AT X=XANDES(NALT2), A WEDGE OF MANTLE LITHOSPHERE IS ADDED C TO THE OVERRIDING PLATE, REACHING THICKNESS THICKN(2) C AT X=XANDES(NPOINT). C COMMON /GROBOW/ HANDES,XANDES,NPOINT,NALT1,NALT2 DIMENSION HANDES(5),XANDES(5) DATA HANDES/-1., 0. , 1.0 , 1.0 , 0. /, + XANDES/ 0.,0.209,0.350,0.694,1.000 /, + NPOINT/ 5/, + NALT1 / 3/, + NALT2 / 4/ END C C C BLOCK DATA NORTH C C ALL DATA NECESSARY TO DEFINE OCEANIC SLAB MOTIONS, AGES, AND C AREAS OF CONTACT WITH NORTH AMERICA UNDER ENGEBRETSON'S C "NORTHERN OPTION": KULA/VANCOUVER TRIPLE JUNCTION IN PACIFIC C NORTHWEST NEAR USA/CANADA BORDER. C C***************************************************************** C CAUTION!!! C WHEN INSTALLING THIS BLOCK DATA PROGRAM INTO ANOTHER CODE, SUCH C AS LARAMY, VERSCOMP, OR GDDMCOMP, IT IS NECESSARY TO MAKE THREE C SMALL EDITING CHANGES! C C IN THE "COMMON" STATEMENTS BELOW, CHANGE THE THREE NAMES AS C FOLLOWS: C C COMMON /SCALAR/ -> COMMON /NORTH1/ C COMMON /ARRAYS/ -> COMMON /NORTH2/ C COMMON /TAGS/ -> COMMON /NORTH3/ C C THIS IS NECESSARY SO THAT THE DATA WILL BE LINKED ONLY INTO C SUBPROGRAM BELOW1 (NORTHERN OPTION) AND NOT INTO BELOW2! C C CONVERSELY, IF YOU ARE BRINGING A BLOCK DATA PROGRAM BACK TO C BE INSPECTED AND/OR EDITED WITH MAPPER, IT IS NECCESARY TO C CHANGE THE COMMON BLOCK NAMES BACK TO THE NAMES IN THE LEFT C COLUMN ABOVE. C****************************************************************** C C COMMENTS ON COORDINATES AND UNITS C MOST OF THE DATA IN THIS UNIT ARE IN ROUND-EARTH COORDINATES C OF (LATITUDE,LONGITUDE). THE UNITS ARE DEGREES; FOR MORE C PRECISION WE USE DECIMAL FRACTIONS OF DEGREES INSTEAD OF C MINUTES AND/OR SECONDS OF ARC. LATITUDE IS POSITIVE IN THE C NORTHERN HEMISPHERE. LONGITUDE IS POSITIVE EAST OF C GREENWICH, ENGLAND. C THE FINITE-ROTATION MATRICES (3 X 3) AND THE ROTATION-AXIS C VECTORS (3 X 1) USE A DIFFERENT COORDINATE SYSTEM. C IT IS CARTESIAN (X,Y,Z), WITH ITS ORIGIN AT THE CENTER C OF THE EARTH. X POINTS TOWARD (LAT=0, LON=0). C Y POINTS TOWARD (LAT=0, LON=90). Z POINTS TOWARD (LAT=90). C THE UNITS DIFFER: THE FINITE-ROTATION MATRICES ARE C DIMENSIONLESS, BUT THE ROTATION-RATE VECTORS ARE IN C RADIANS PER SECOND. C THE GEOLOGIC TIMES WHICH LABEL THE VARIOUS FEATURES ARE C EXPRESSED IN MILLIONS OF YEARS (POSITIVE = PAST). THE C LENGTH OF 1 MILLION YEARS IN THE FUNDAMENTAL TIME UNIT C (THE SECOND) IS EXPRESSED BY "TUMAP". C C---------------------------------------------------------------- C GLOSSARY OF DATA: C -AGEFZ(J,I) IS THE AGE OF FRACTURE ZONE POINT #J C IN STRIP #I. (USED BY EDITOR, NOT BY BELOWY) C -AGEHNG(I) IS THE AGE OF THE HINGELINE CURVE K C DEFINED BY REHING(I=1,2;J=1,40?;K). C -AGEKV(I) IS THE AGE OF THE KULA/VANCOUVER/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REKV3J(1-3,I). C -AGEMAG(I,J) IS THE AGE OF MAGNETIC ANOMALY I (FROM W TO E) C IN STRIPE J (FROM S TO N) ON THE PRESENT-AGE MAP. C -AGEROT(I) IS THE AGE OF THE FINITE ROTATION MATRICES C ROMATF, ROMATK, ROMATP, AND ROMATV WITH AGE INDEX I. C -AGEVEL(I) IS THE AGE OF THE RELATIVE ROTATION-AXIS VECTORS C OMEGAF, OEMGAK, OMEGAP, AND OMEGAV WITH AGE INDEX I. C -AGEVF(I) IS THE AGE OF THE VANCOUVER/FARALLON/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REVF3J(1-3,I). C -FRACZN(2,I,J) ARE THE LAT. AND LON. COORDINATES OF POINTS I C (W TO E) ALONG FRACTURE ZONE J (S TO N) ON THE MAP OF C PRESENT SLAB AGES. C -NKV3J IS THE NUMBER OF KULA/VANCOUVER/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REKV3J(1-3,I) AT AGE AGEKV(I). C -NMAG(K) IS THE NUMBER OF LINEAR MAGNETIC ANOMALIES C WITHIN STRIPE K (S TO N) OF THE MAP OF PRESENT SLAB C AGES. C -NPHING(I) IS THE NUMBER C OF DIGITIZED POINTS IN HINGELINE CURVE #I OF REHING. C -NPFZ(J) IS THE NUMBER OF POINTS (W TO E) DEFINING FRACTURE ZONE C J (S TO N) ON THE MAP OF PRESENT SLAB AGES. C -NROMAT IS THE NUMBER OF FINITE-ROTATION MATRICES C GIVEN FOR EACH PLATE. C -NVF3J IS THE NUMBER OF VANCOUVER/FARALLON/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REVF3J(1-3,I) AT AGE AGEVF(I). C -NTAPES IS THE NUMBER OF STRIPS OF MAGNETIC ANOMALIES ON C THE MAP OF PRESENT SLAB AGES; ONE LESS THAN THE NUMBER OF C FRACTURE ZONES ON THE MAP. C -NUMHNG IS THE NUMBER OF SLAB HINGELINES (AT DIFFERENT TIMES). C -NUMVEL IS THE NUMBER OF AGES AGEVEL(I) WHERE RELATIVE C ROTATION-AXIS VECTORS (OMEGAF/K/P/V) ARE SUPPLIED. C -OMEGAF(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE FARALLON C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAK(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE KULA C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAP(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE PACIFIC C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAV(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE VANCOUVER C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -REHING(I,J,K) ARE THE LAT. (I=1) AND LON. (I=2) COORDINATES C OF THE DIGITIZED POINT #J (N TO S) OF THE HINGELINE C CURVE #K (PAST TO PRESENT). C -REKV3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE KULA/ C VANCOUVER/NORTH AMERICAN TRIPLE-JUNCTION AT AGE AGEKV(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -REMAG(2,2,I,J) ARE THE LAT., LON. COORDINATES (1ST SUB.) C OF THE N AND S ENDS (2ND SUB.) OF THE LINEAR MAGNETIC C ANOMALY I (W TO E) IN STRIPE J (S TO N) OF THE C PRESENT SLAB AGE MAP. C -REVF3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE C VANCOUVER/FARALLON/N.A. TRIPLE-JUNCTION AT AGE AGEVF(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -ROMATF(3,3,K) ARE THE ROTATION MATRICES FOR FARALLON WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATK(3,3,K) ARE THE ROTATION MATRICES FOR KULA WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATP(3,3,K) ARE THE ROTATION MATRICES FOR PACIFIC WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATV(3,3,K) ARE THE ROTATION MATRICES FOR VANCOUVER WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -TAGFZ(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE FRACTURE ZONE POINT #I C IN STRIP #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TAGMAG(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE MAGNETIC ANOM. #I IN STRIP C #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TUMAP IS A CONVENIENCE MULTIPLIER APPLIED TO AGES IN M.Y. C TO OBTAIN THE TRUE AGE IN PROGRAM UNITS (SECONDS). C------------------------------------------------------------------ C C MEMO: ORDER IS: PARAMETER, TYPE, COMMON, DIMENSION, DATA C C********************************************************************* C C NOTE: THESE DIMENSION PARAMETERS MUST AGREE C IN ALL PROGRAMS !!!!!! C C MAXIMUM NUMBER OF DIGITISED SLAB HINGELINES: PARAMETER (MAXHL=20) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED HINGELINE: PARAMETER (MAXHNG=40) C MAXIMUM NUMBER OF FINITE ROTATIONS FOR EACH PLATE: PARAMETER (MAXROT=21) C MAXIMUM NUMBER OF RELATIVE ROTATION-AXIS VECTORS FOR EACH PLATE: PARAMETER (MAXVEL=20) C MAXIMUM NUMBER OF AGES WHEN KULA/VANCOUVER TRIPLE-JUNCTION IS GIVEN: PARAMETER (MXKV3J =50) C MAXIM.NUMBER OF AGES WHEN VANCOUVER/FARALLON TRIPLE-JUNCTION IS GIVEN PARAMETER (MXVF3J =50) C MAXIMUM NUMBER OF STRIPS OF SEAFLOOR (BETWEEN FRACTURE ZONES) ON MAP: PARAMETER (MTAPES =40,MTAPP1=41) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED FRACTURE ZONE: PARAMETER (MAXFZP=100) C MAXIMUM NUMBER OF MAGNETIC ANOMALIES IN ANY ONE STRIP: PARAMETER (MAXMAG=100) C********************************************************************* CHARACTER*1 TAGFZ,TAGMAG C-------------------------------------------------------------------- COMMON /NORTH1/ + NKV3J, + NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, + TUMAP COMMON /NORTH2/ + AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, + FRACZN,NMAG,NPFZ,NPHING, + OMEGAF,OMEGAK,OMEGAP,OMEGAV, + REHING,REKV3J,REMAG,REVF3J, + ROMATF,ROMATK,ROMATP,ROMATV COMMON /NORTH3/ + TAGFZ,TAGMAG C-------------------------------------------------------------------- DIMENSION AGEFZ(MAXFZP,MTAPP1), 2 AGEHNG(MAXHL), 3 AGEKV(MXKV3J), 4 AGEMAG(MAXMAG,MTAPES), 5 AGEROT(MAXROT), 6 AGEVEL(MAXVEL), 7 AGEVF(MXVF3J), 8 FRACZN(2,MAXFZP,MTAPP1), 9 NPFZ(MTAPP1), A NPHING(MAXHNG) DIMENSION NMAG(MTAPES), 2 OMEGAF(3,MAXVEL), 3 OMEGAK(3,MAXVEL), 4 OMEGAP(3,MAXVEL), 5 OMEGAV(3,MAXVEL), 6 REHING(2,MAXHNG,MAXHL), 7 REKV3J(3,MXKV3J), 8 REMAG(2,2,MAXMAG,MTAPES), 9 REVF3J(3,MXVF3J), A ROMATF(3,3,MAXROT), 1 ROMATK(3,3,MAXROT), 2 ROMATP(3,3,MAXROT), 3 ROMATV(3,3,MAXROT), 4 TAGFZ(MAXFZP,MTAPP1), 5 TAGMAG(MAXMAG,MTAPES) C C===1=== SLAB HINGELINES ======================= C DATA NUMHNG / 14/ DATA TUMAP /3.15576E13/ DATA (AGEHNG(I),I=1, 14) / + 90.00, 80.00, 75.00, 65.00, 55.00, 45.00, 40.00, 35.00, + 30.00, 27.50, 20.00, 10.00, 0.00, -3.00 + / DATA (NPHING(I),I=1, 14) / + 29, 29, 33, 34, 31, 35, 32, 26, 31, 30, 30, 27, 31, 31 + / DATA ((REHING(I,J, 1),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.90,-121.85, 43.38,-120.70, 42.52,-119.85, + 41.41,-119.40, 40.22,-119.68, 38.73,-120.43, 37.05,-120.49, + 35.67,-120.08, 34.56,-118.00, 33.44,-115.89, 31.28,-114.73, + 29.55,-112.79, 27.91,-110.89, 26.28,-109.05, 24.78,-107.50, + 23.20,-106.00, 21.79,-104.58, 20.16,-103.23, 18.28,-101.73, + 16.37,-100.36 + / DATA ((REHING(I,J, 2),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.90,-121.85, 43.38,-120.70, 42.52,-119.85, + 41.41,-119.40, 40.22,-119.68, 38.73,-120.43, 37.05,-120.49, + 35.67,-120.08, 34.56,-118.00, 33.44,-115.89, 31.28,-114.73, + 29.55,-112.79, 27.91,-110.89, 26.28,-109.05, 24.78,-107.50, + 23.20,-106.00, 21.79,-104.58, 20.16,-103.23, 18.28,-101.73, + 16.37,-100.36 + / DATA ((REHING(I,J, 3),I=1,2),J=1, 33) / + 60.24,-142.90, 58.27,-136.08, 57.06,-133.84, 55.56,-132.30, + 54.31,-131.06, 52.34,-129.57, 50.99,-128.46, 49.68,-127.62, + 48.64,-126.31, 47.41,-124.10, 46.20,-121.40, 45.21,-118.79, + 44.38,-116.32, 43.59,-113.87, 42.71,-111.45, 41.95,-110.30, + 40.87,-109.75, 39.46,-109.53, 38.07,-109.47, 36.40,-109.69, + 34.97,-110.12, 33.38,-111.48, 32.18,-112.63, 31.23,-113.29, + 30.55,-113.21, 29.70,-112.07, 28.45,-110.41, 26.85,-108.26, + 25.03,-106.06, 22.76,-103.36, 20.40,-100.83, 18.53, -98.91, + 15.76, -95.35 + / DATA ((REHING(I,J, 4),I=1,2),J=1, 34) / + 59.74,-142.93, 57.85,-135.98, 57.15,-134.10, 56.01,-132.85, + 54.68,-131.71, 52.77,-130.21, 50.90,-128.84, 49.63,-127.75, + 48.60,-126.11, 47.65,-124.22, 47.03,-122.13, 46.41,-119.25, + 46.11,-116.86, 45.83,-114.22, 45.56,-111.04, 45.24,-108.41, + 44.65,-106.77, 43.72,-105.66, 42.82,-105.87, 41.25,-106.39, + 39.96,-107.68, 38.23,-109.58, 36.53,-111.05, 34.82,-112.31, + 33.11,-113.12, 32.14,-113.13, 31.23,-112.40, 30.09,-111.04, + 28.34,-108.86, 26.70,-106.84, 24.65,-104.56, 22.44,-102.17, + 18.04, -97.90, 14.33, -93.82 + / DATA ((REHING(I,J, 5),I=1,2),J=1, 31) / + 60.18,-142.67, 58.34,-135.99, 57.39,-133.91, 55.54,-131.68, + 53.24,-129.30, 51.45,-127.33, 49.34,-124.96, 47.58,-122.87, + 45.85,-120.92, 44.34,-118.67, 43.75,-116.92, 43.72,-114.46, + 43.59,-111.55, 43.34,-108.91, 42.86,-107.05, 42.13,-105.45, + 41.13,-104.87, 40.08,-104.90, 38.70,-105.39, 37.13,-106.70, + 35.70,-107.90, 34.13,-109.17, 32.75,-109.71, 31.34,-109.71, + 30.37,-109.16, 29.06,-107.62, 26.11,-104.35, 22.91,-101.21, + 20.18, -98.61, 18.86, -97.37, 15.81, -93.90 + / DATA ((REHING(I,J, 6),I=1,2),J=1, 35) / + 59.65,-143.76, 57.90,-136.31, 57.31,-134.75, 56.45,-133.35, + 55.25,-132.01, 53.95,-130.78, 52.54,-129.43, 50.88,-127.99, + 49.81,-126.43, 49.25,-124.90, 48.58,-123.85, 47.46,-122.86, + 46.31,-121.77, 44.75,-120.30, 43.36,-119.35, 41.49,-118.46, + 40.66,-117.90, 40.03,-116.96, 39.46,-115.55, 39.13,-113.64, + 38.99,-111.33, 38.87,-108.52, 38.77,-106.09, 38.39,-104.45, + 38.00,-103.53, 37.37,-103.42, 35.34,-103.89, 32.58,-104.54, + 29.82,-105.05, 27.44,-105.42, 24.90,-103.03, 22.70,-101.09, + 20.05, -98.86, 17.88, -96.95, 14.95, -94.01 + / DATA ((REHING(I,J, 7),I=1,2),J=1, 32) / + 60.15,-144.12, 58.32,-136.58, 57.58,-134.52, 55.82,-132.18, + 53.60,-130.20, 51.68,-128.54, 50.56,-127.44, 49.48,-125.13, + 48.21,-123.37, 45.85,-121.58, 43.62,-119.92, 41.89,-118.52, + 40.13,-116.35, 39.11,-114.39, 38.47,-112.91, 38.07,-111.01, + 37.86,-108.95, 37.68,-106.27, 37.11,-104.05, 36.49,-103.28, + 35.59,-103.92, 33.92,-105.34, 32.65,-107.07, 31.58,-108.11, + 30.77,-108.67, 30.04,-107.87, 28.35,-106.21, 25.94,-103.92, + 23.23,-101.36, 19.92, -98.62, 18.08, -97.05, 14.58, -93.85 + / DATA ((REHING(I,J, 8),I=1,2),J=1, 26) / + 60.73,-144.29, 58.48,-135.82, 56.96,-132.82, 54.44,-130.45, + 51.91,-128.35, 50.62,-126.85, 49.32,-124.72, 47.04,-122.53, + 45.09,-121.21, 43.27,-119.94, 41.70,-118.85, 39.66,-117.43, + 38.07,-115.05, 37.24,-112.97, 36.83,-110.87, 36.60,-109.39, + 36.22,-108.78, 35.56,-108.94, 33.64,-110.03, 32.23,-110.38, + 31.18,-109.93, 30.10,-108.77, 27.69,-106.20, 24.64,-103.37, + 19.55, -98.74, 14.66, -94.17 + / DATA ((REHING(I,J, 9),I=1,2),J=1, 31) / + 59.94,-142.45, 58.14,-135.36, 56.98,-133.18, 54.87,-131.29, + 52.93,-129.48, 51.68,-128.44, 50.98,-127.72, 50.43,-126.82, + 49.58,-125.10, 48.58,-123.85, 45.67,-121.39, 43.86,-120.19, + 41.92,-118.74, 39.65,-117.67, 38.14,-116.22, 37.34,-114.59, + 36.86,-113.27, 36.59,-112.50, 36.18,-112.04, 35.60,-111.96, + 34.88,-112.15, 34.29,-112.49, 33.70,-112.81, 32.69,-112.03, + 31.73,-110.98, 29.66,-108.65, 27.54,-106.42, 24.80,-103.95, + 23.88,-103.22, 18.54, -98.67, 14.42, -94.83 + / DATA ((REHING(I,J, 10),I=1,2),J=1, 30) / + 60.05,-142.71, 58.15,-135.55, 57.19,-133.78, 55.93,-132.21, + 54.27,-130.67, 53.02,-129.56, 51.61,-128.52, 50.80,-127.58, + 50.24,-126.63, 49.34,-124.96, 48.34,-123.62, 47.04,-122.53, + 45.82,-121.46, 44.32,-120.36, 42.71,-119.19, 40.97,-118.24, + 39.38,-117.47, 38.13,-116.62, 36.88,-115.49, 35.88,-114.63, + 35.07,-113.90, 34.07,-113.38, 32.72,-112.14, 31.60,-110.78, + 29.45,-108.57, 27.14,-106.05, 24.28,-103.50, 21.45,-101.15, + 18.32, -98.45, 14.79, -95.22 + / DATA ((REHING(I,J, 11),I=1,2),J=1, 30) / + 60.40,-143.60, 58.26,-135.89, 57.30,-133.82, 55.79,-132.11, + 54.09,-130.51, 52.22,-128.93, 50.89,-127.65, 50.16,-126.36, + 48.98,-124.38, 47.60,-123.01, 45.84,-122.17, 43.62,-121.86, + 41.51,-121.12, 39.45,-120.08, 37.52,-118.43, 36.38,-117.33, + 35.75,-116.30, 35.15,-114.95, 34.51,-113.95, 33.50,-113.29, + 32.45,-112.66, 31.69,-112.09, 30.03,-110.31, 28.29,-108.49, + 26.74,-106.94, 24.73,-105.04, 22.76,-103.43, 19.82,-100.93, + 18.03, -99.36, 15.25, -96.89 + / DATA ((REHING(I,J, 12),I=1,2),J=1, 27) / + 60.42,-144.51, 58.53,-136.13, 57.88,-134.36, 56.05,-132.25, + 54.05,-130.39, 52.11,-128.80, 50.74,-127.47, 50.15,-126.46, + 49.50,-125.28, 48.27,-123.80, 47.15,-122.81, 46.39,-122.50, + 45.08,-122.44, 43.55,-122.58, 41.65,-121.97, 39.91,-120.91, + 38.15,-119.72, 36.58,-117.83, 34.34,-115.15, 31.39,-111.97, + 28.32,-108.97, 26.00,-106.84, 23.14,-104.47, 21.37,-103.15, + 20.03,-101.83, 18.36,-100.47, 13.50, -94.94 + / DATA ((REHING(I,J, 13),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / DATA ((REHING(I,J, 14),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / C C===2=== CODE GENERATED BY PROGRAM "ALL4" PLATE ROTATER: ===== C DATA NROMAT / 18/ DATA (AGEROT(I),I=1, 18) / + 0.00, 3.63, 10.30, 19.90, 25.80, 30.00, 35.60, 42.00, + 49.55, 58.90, 68.50, 72.40, 85.00, 119.00, 127.00, 135.00, + 145.00, 163.00 + / DATA ((ROMATF(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATF(I,J, 2),J=1,3),I=1,3) +/ 0.9984418, 0.0249586, 0.0499063, + -0.0236761, 0.9993781,-0.0261258, + -0.0505273, 0.0249035, 0.9984120/ DATA ((ROMATF(I,J, 3),J=1,3),I=1,3) +/ 0.9965000,-0.0015017, 0.0835752, + 0.0016967, 0.9999958,-0.0022638, + -0.0835716, 0.0023977, 0.9964986/ DATA ((ROMATF(I,J, 4),J=1,3),I=1,3) +/ 0.9870884,-0.0794135, 0.1391012, + 0.0779809, 0.9968305, 0.0157267, + -0.1399093,-0.0046764, 0.9901530/ DATA ((ROMATF(I,J, 5),J=1,3),I=1,3) +/ 0.9816186,-0.0953112, 0.1653471, + 0.0902718, 0.9952011, 0.0377464, + -0.1681514,-0.0221263, 0.9855123/ DATA ((ROMATF(I,J, 6),J=1,3),I=1,3) +/ 0.9772222,-0.1307292, 0.1671685, + 0.1217395, 0.9905611, 0.0629824, + -0.1738244,-0.0411969, 0.9839141/ DATA ((ROMATF(I,J, 7),J=1,3),I=1,3) +/ 0.9643680,-0.2176023, 0.1504717, + 0.2023463, 0.9730743, 0.1103661, + -0.1704363,-0.0759863, 0.9824339/ DATA ((ROMATF(I,J, 8),J=1,3),I=1,3) +/ 0.9355122,-0.3127865, 0.1642541, + 0.2875628, 0.9442505, 0.1603019, + -0.2052376,-0.1027311, 0.9733049/ DATA ((ROMATF(I,J, 9),J=1,3),I=1,3) +/ 0.8698806,-0.4633711, 0.1690941, + 0.4200012, 0.8755688, 0.2386968, + -0.2586591,-0.1366181, 0.9562580/ DATA ((ROMATF(I,J, 10),J=1,3),I=1,3) +/ 0.7665346,-0.5965531, 0.2377952, + 0.4980173, 0.7859663, 0.3663787, + -0.4054641,-0.1624160, 0.8995655/ DATA ((ROMATF(I,J, 11),J=1,3),I=1,3) +/ 0.6799753,-0.6748897, 0.2866260, + 0.4922036, 0.7098752, 0.5037958, + -0.5434762,-0.2014907, 0.8148823/ DATA ((ROMATF(I,J, 12),J=1,3),I=1,3) +/ 0.6364845,-0.7003338, 0.3231361, + 0.4905679, 0.6908776, 0.5310636, + -0.5951703,-0.1794939, 0.7832956/ DATA ((ROMATF(I,J, 13),J=1,3),I=1,3) +/ 0.5407817,-0.7359961, 0.4072609, + 0.3967867, 0.6501144, 0.6480033, + -0.7416956,-0.1888330, 0.6436048/ DATA ((ROMATF(I,J, 14),J=1,3),I=1,3) +/ 0.1260393,-0.9004962, 0.4161935, + 0.4084943, 0.4294313, 0.8054301, + -0.9040152, 0.0684970, 0.4219739/ DATA ((ROMATF(I,J, 15),J=1,3),I=1,3) +/ 0.0432563,-0.8638376, 0.5019060, + 0.3372753, 0.4855096, 0.8065493, + -0.9404098, 0.1343924, 0.3123534/ DATA ((ROMATF(I,J, 16),J=1,3),I=1,3) +/ -0.0372843,-0.8243719, 0.5648155, + 0.2585098, 0.5380124, 0.8023162, + -0.9652870, 0.1759245, 0.1930498/ DATA ((ROMATF(I,J, 17),J=1,3),I=1,3) +/ -0.0857564,-0.7854440, 0.6129592, + 0.2832710, 0.5706134, 0.7708135, + -0.9551961, 0.2397366, 0.1735606/ DATA ((ROMATF(I,J, 18),J=1,3),I=1,3) +/ -0.3959168,-0.6532624, 0.6453629, + 0.3365481, 0.5506653, 0.7638706, + -0.8543893, 0.5196268, 0.0018373/ DATA ((ROMATK(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATK(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATK(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATK(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATK(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATK(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATK(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATK(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATK(I,J, 9),J=1,3),I=1,3) +/ 0.8926937, 0.3237427, 0.3135092, + -0.3673854, 0.9256842, 0.0902017, + -0.2610084,-0.1957012, 0.9452911/ DATA ((ROMATK(I,J, 10),J=1,3),I=1,3) +/ 0.8382884, 0.2792339, 0.4682950, + -0.4014298, 0.8973089, 0.1835486, + -0.3689522,-0.3418544, 0.8642969/ DATA ((ROMATK(I,J, 11),J=1,3),I=1,3) +/ 0.7479138, 0.2368386, 0.6201060, + -0.4491286, 0.8684335, 0.2100139, + -0.4887816,-0.4355798, 0.7558849/ DATA ((ROMATK(I,J, 12),J=1,3),I=1,3) +/ 0.7069741, 0.2202590, 0.6720657, + -0.4550582, 0.8691026, 0.1938600, + -0.5413948,-0.4428831, 0.7146643/ DATA ((ROMATK(I,J, 13),J=1,3),I=1,3) +/ 0.4927713, 0.2023760, 0.8462971, + -0.5685837, 0.8111188, 0.1371042, + -0.6587012,-0.5487522, 0.5147643/ DATA ((ROMATK(I,J, 14),J=1,3),I=1,3) +/ 0.2884439,-0.0305855, 0.9570071, + -0.2699646, 0.9563414, 0.1119320, + -0.9186499,-0.2906443, 0.2675945/ DATA ((ROMATK(I,J, 15),J=1,3),I=1,3) +/ 0.1826985, 0.0447444, 0.9821491, + -0.2405134, 0.9706448, 0.0005196, + -0.9532956,-0.2363152, 0.1880977/ DATA ((ROMATK(I,J, 16),J=1,3),I=1,3) +/ 0.0730065, 0.1148067, 0.9907003, + -0.2118030, 0.9724770,-0.0970868, + -0.9745805,-0.2027456, 0.0953141/ DATA ((ROMATK(I,J, 17),J=1,3),I=1,3) +/ 0.0737035, 0.1703374, 0.9826242, + -0.1573972, 0.9749421,-0.1572000, + -0.9847798,-0.1430762, 0.0986680/ DATA ((ROMATK(I,J, 18),J=1,3),I=1,3) +/ -0.0087966, 0.2534258, 0.9673132, + 0.1625878, 0.9548408,-0.2486796, + -0.9866534, 0.1550863,-0.0496027/ DATA ((ROMATP(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATP(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATP(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATP(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATP(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATP(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATP(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATP(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATP(I,J, 9),J=1,3),I=1,3) +/ 0.9036663, 0.3323698, 0.2700321, + -0.3557910, 0.9336445, 0.0414807, + -0.2383270,-0.1335597, 0.9619573/ DATA ((ROMATP(I,J, 10),J=1,3),I=1,3) +/ 0.8783061, 0.3137228, 0.3607716, + -0.3583550, 0.9314973, 0.0624035, + -0.3164804,-0.1840937, 0.9305640/ DATA ((ROMATP(I,J, 11),J=1,3),I=1,3) +/ 0.8133826, 0.3327699, 0.4771508, + -0.4012021, 0.9148389, 0.0458976, + -0.4212428,-0.2287661, 0.8776220/ DATA ((ROMATP(I,J, 12),J=1,3),I=1,3) +/ 0.7885006, 0.3410243, 0.5118291, + -0.4008002, 0.9161383, 0.0070450, + -0.4665038,-0.2106962, 0.8590583/ DATA ((ROMATP(I,J, 13),J=1,3),I=1,3) +/ 0.6594428, 0.4211499, 0.6227100, + -0.4718215, 0.8767433,-0.0933034, + -0.5852515,-0.2322797, 0.7768697/ DATA ((ROMATP(I,J, 14),J=1,3),I=1,3) +/ 0.5735050, 0.5730298, 0.5854303, + -0.4726608, 0.8151487,-0.3348495, + -0.6690916,-0.0846720, 0.7383407/ DATA ((ROMATP(I,J, 15),J=1,3),I=1,3) +/ 0.5466521, 0.6209800, 0.5617428, + -0.4979524, 0.7804186,-0.3781402, + -0.6732122,-0.0730101, 0.7358360/ DATA ((ROMATP(I,J, 16),J=1,3),I=1,3) +/ 0.5130962, 0.6671163, 0.5400814, + -0.5285266, 0.7413454,-0.4136018, + -0.6763074,-0.0732298, 0.7329704/ DATA ((ROMATP(I,J, 17),J=1,3),I=1,3) +/ 0.5677590, 0.7006614, 0.4321147, + -0.5501299, 0.7134408,-0.4340037, + -0.6123779, 0.0086904, 0.7905173/ DATA ((ROMATP(I,J, 18),J=1,3),I=1,3) +/ 0.7427920, 0.5855252, 0.3246846, + -0.3852086, 0.7703925,-0.5080448, + -0.5476077, 0.2523004, 0.7977908/ DATA ((ROMATV(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATV(I,J, 2),J=1,3),I=1,3) +/ 0.9993297, 0.0051820, 0.0362338, + -0.0047712, 0.9999232,-0.0114144, + -0.0362902, 0.0112339, 0.9992780/ DATA ((ROMATV(I,J, 3),J=1,3),I=1,3) +/ 0.9966072,-0.0024635, 0.0822646, + 0.0025242, 0.9999963,-0.0006345, + -0.0822628, 0.0008400, 0.9966100/ DATA ((ROMATV(I,J, 4),J=1,3),I=1,3) +/ 0.9874673,-0.0822613, 0.1346872, + 0.0813513, 0.9966096, 0.0122550, + -0.1352387,-0.0011445, 0.9908120/ DATA ((ROMATV(I,J, 5),J=1,3),I=1,3) +/ 0.9769385,-0.0981460, 0.1896242, + 0.0957089, 0.9951658, 0.0219901, + -0.1908659,-0.0033342, 0.9816099/ DATA ((ROMATV(I,J, 6),J=1,3),I=1,3) +/ 0.9672080,-0.1004198, 0.2332878, + 0.0970278, 0.9949411, 0.0260009, + -0.2347188,-0.0025129, 0.9720595/ DATA ((ROMATV(I,J, 7),J=1,3),I=1,3) +/ 0.9578496,-0.1985734, 0.2075841, + 0.1860558, 0.9794068, 0.0783809, + -0.2188739,-0.0364552, 0.9750712/ DATA ((ROMATV(I,J, 8),J=1,3),I=1,3) +/ 0.9285972,-0.3330147, 0.1637273, + 0.3143928, 0.9404002, 0.1296231, + -0.1971359,-0.0688933, 0.9779518/ DATA ((ROMATV(I,J, 9),J=1,3),I=1,3) +/ 0.8519540,-0.5116365, 0.1113576, + 0.4857856, 0.8516892, 0.1965587, + -0.1954090,-0.1133634, 0.9741470/ DATA ((ROMATV(I,J, 10),J=1,3),I=1,3) +/ 0.7341714,-0.6763662, 0.0593198, + 0.6286086, 0.7101420, 0.3170907, + -0.2565954,-0.1955106, 0.9465370/ DATA ((ROMATV(I,J, 11),J=1,3),I=1,3) +/ 0.6687082,-0.7369352, 0.0987580, + 0.6230298, 0.6278643, 0.4664944, + -0.4057837,-0.2504201, 0.8789921/ DATA ((ROMATV(I,J, 12),J=1,3),I=1,3) +/ 0.6332583,-0.7620972, 0.1348656, + 0.6199963, 0.6038375, 0.5009806, + -0.4632338,-0.2336346, 0.8548840/ DATA ((ROMATV(I,J, 13),J=1,3),I=1,3) +/ 0.5726639,-0.7899240, 0.2192550, + 0.5270615, 0.5596170, 0.6395554, + -0.6279004,-0.2506902, 0.7368125/ DATA ((ROMATV(I,J, 14),J=1,3),I=1,3) +/ 0.1862030,-0.9539652, 0.2351070, + 0.4969981, 0.2978723, 0.8150220, + -0.8475366,-0.0349119, 0.5295847/ DATA ((ROMATV(I,J, 15),J=1,3),I=1,3) +/ 0.1202118,-0.9349756, 0.3337152, + 0.4187091, 0.3525420, 0.8368945, + -0.9001268, 0.0391250, 0.4338636/ DATA ((ROMATV(I,J, 16),J=1,3),I=1,3) +/ 0.0559588,-0.9094425, 0.4120423, + 0.3322897, 0.4061266, 0.8512579, + -0.9415139, 0.0892823, 0.3249255/ DATA ((ROMATV(I,J, 17),J=1,3),I=1,3) +/ 0.0035101,-0.8845617, 0.4664051, + 0.3494043, 0.4380954, 0.8282415, + -0.9369633, 0.1600573, 0.3106084/ DATA ((ROMATV(I,J, 18),J=1,3),I=1,3) +/ -0.3217998,-0.7897338, 0.5222647, + 0.3520011, 0.4122773, 0.8403078, + -0.8789400, 0.4542502, 0.1453171/ DATA NUMVEL / 17/ DATA (AGEVEL(I),I=1, 17) / + 1.81, 6.97, 15.10, 22.85, 27.90, 32.80, 38.80, 45.77, + 54.22, 63.70, 70.45, 78.70, 102.00, 123.00, 131.00, 140.00, + 154.00 + / DATA (OMEGAF(I, 1),I=1,3) + / 2.22436E-16, 4.37785E-16,-2.11997E-16/ DATA (OMEGAF(I, 2),I=1,3) + /-1.15243E-16, 1.59143E-16, 1.18424E-16/ DATA (OMEGAF(I, 3),I=1,3) + /-5.20186E-17, 1.86928E-16, 2.53471E-16/ DATA (OMEGAF(I, 4),I=1,3) + /-1.06009E-16, 1.52830E-16, 7.04799E-17/ DATA (OMEGAF(I, 5),I=1,3) + /-1.88225E-16, 3.57680E-17, 2.41271E-16/ DATA (OMEGAF(I, 6),I=1,3) + /-2.80863E-16,-4.69432E-17, 4.60480E-16/ DATA (OMEGAF(I, 7),I=1,3) + /-2.23587E-16, 1.34246E-16, 4.59035E-16/ DATA (OMEGAF(I, 8),I=1,3) + /-3.01794E-16, 1.52210E-16, 6.43195E-16/ DATA (OMEGAF(I, 9),I=1,3) + /-2.67001E-16, 4.56656E-16, 4.83609E-16/ DATA (OMEGAF(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAF(I, 11),I=1,3) + /-7.69435E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAF(I, 12),I=1,3) + /-1.10799E-16, 4.93623E-16, 8.32111E-17/ DATA (OMEGAF(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAF(I, 14),I=1,3) + / 3.42999E-16, 4.32696E-16, 1.46227E-16/ DATA (OMEGAF(I, 15),I=1,3) + / 2.93430E-16, 4.47830E-16, 9.47212E-17/ DATA (OMEGAF(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAF(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAK(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAK(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAK(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAK(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAK(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAK(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAK(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAK(I, 8),I=1,3) + /-3.42895E-16, 3.07318E-16,-7.84280E-18/ DATA (OMEGAK(I, 9),I=1,3) + /-5.24123E-16, 4.21964E-16,-6.28934E-17/ DATA (OMEGAK(I, 10),I=1,3) + /-3.47853E-16, 5.17207E-16,-6.26469E-17/ DATA (OMEGAK(I, 11),I=1,3) + /-1.29789E-16, 5.39917E-16, 7.00136E-17/ DATA (OMEGAK(I, 12),I=1,3) + /-2.25126E-16, 6.46717E-16,-2.10399E-16/ DATA (OMEGAK(I, 13),I=1,3) + /-8.79291E-17, 2.40344E-16, 3.43456E-16/ DATA (OMEGAK(I, 14),I=1,3) + / 3.42972E-16, 4.32656E-16, 1.46203E-16/ DATA (OMEGAK(I, 15),I=1,3) + / 2.93406E-16, 4.47800E-16, 9.47100E-17/ DATA (OMEGAK(I, 16),I=1,3) + / 1.91374E-16, 2.29230E-17, 1.74145E-16/ DATA (OMEGAK(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAP(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAP(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAP(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAP(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAP(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAP(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAP(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAP(I, 8),I=1,3) + /-7.95765E-17, 2.01210E-16, 3.16566E-17/ DATA (OMEGAP(I, 9),I=1,3) + /-1.82793E-16, 2.78850E-16, 6.21172E-18/ DATA (OMEGAP(I, 10),I=1,3) + /-1.10363E-16, 4.11618E-16,-1.28934E-16/ DATA (OMEGAP(I, 11),I=1,3) + / 1.61156E-16, 4.19784E-16, 1.56999E-17/ DATA (OMEGAP(I, 12),I=1,3) + / 7.46968E-17, 4.23581E-16,-2.19155E-16/ DATA (OMEGAP(I, 13),I=1,3) + / 2.04277E-16, 1.08618E-16,-2.84094E-17/ DATA (OMEGAP(I, 14),I=1,3) + / 1.92305E-16, 3.73766E-17,-1.42336E-16/ DATA (OMEGAP(I, 15),I=1,3) + / 1.61534E-16, 3.43348E-17,-1.77105E-16/ DATA (OMEGAP(I, 16),I=1,3) + / 2.87845E-16,-2.68429E-16, 6.23380E-17/ DATA (OMEGAP(I, 17),I=1,3) + / 2.19652E-16,-7.13669E-17, 4.34363E-16/ DATA (OMEGAV(I, 1),I=1,3) + / 9.86981E-17, 3.16045E-16,-4.33668E-17/ DATA (OMEGAV(I, 2),I=1,3) + /-5.14985E-17, 2.19222E-16, 3.33668E-17/ DATA (OMEGAV(I, 3),I=1,3) + /-3.52269E-17, 1.75936E-16, 2.61668E-16/ DATA (OMEGAV(I, 4),I=1,3) + /-2.56065E-17, 3.02977E-16, 8.26955E-17/ DATA (OMEGAV(I, 5),I=1,3) + / 2.38990E-18, 3.39059E-16, 1.81821E-17/ DATA (OMEGAV(I, 6),I=1,3) + /-3.14872E-16,-1.02187E-16, 5.04872E-16/ DATA (OMEGAV(I, 7),I=1,3) + /-3.01822E-16,-1.44934E-16, 6.45606E-16/ DATA (OMEGAV(I, 8),I=1,3) + /-3.48720E-16,-8.07761E-17, 7.85876E-16/ DATA (OMEGAV(I, 9),I=1,3) + /-4.42586E-16, 1.09988E-16, 6.53606E-16/ DATA (OMEGAV(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAV(I, 11),I=1,3) + /-7.83352E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAV(I, 12),I=1,3) + /-1.10796E-16, 4.93633E-16, 8.32232E-17/ DATA (OMEGAV(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAV(I, 14),I=1,3) + / 3.42996E-16, 4.32686E-16, 1.46215E-16/ DATA (OMEGAV(I, 15),I=1,3) + / 2.93417E-16, 4.47842E-16, 9.47149E-17/ DATA (OMEGAV(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAV(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ C C===3=== DATA MODIFIED BY PROGRAM MAPPER ========== C C DATA NTAPES/ 16/,NTAPP1/ 17/,NKV3J/ 10/,NVF3J/ 10/ C C C DATA ((REKV3J(K,I),K=1,3),I=1, 10) / + 47.22,-130.46, 55., + 47.22,-130.46, 55., + 47.37,-132.82, 57., + 46.03,-131.91, 56., + 47.00,-133.97, 57., + 47.00,-133.97, 57., + 45.34,-128.86, 54., + 45.61,-129.99, 60., + 44.68,-129.34, 62., + 43.82,-129.20, 68. +/ DATA ((REVF3J(K,I),K=1,3),I=1, 10) / + 27.33,-117.02, 45., + 27.33,-117.02, 45., + 28.46,-118.67, 47., + 25.76,-113.07, 33., + 25.76,-113.07, 30., + 25.21,-111.68, 35., + 25.21,-111.68, 41., + 25.18,-112.65, 32., + 23.90,-110.19, 13., + 22.30,-107.00, 37. +/ DATA (AGEKV(I),I=1, 10) / + 0.00, 10.00, 20.00, 30.00, 40.00, 50.00, 65.00, 70.00, + 80.00, 85.00 +/ DATA (AGEVF(I),I=1, 10) / + 0.00, 10.00, 20.00, 30.00, 35.00, 40.00, 45.00, 50.00, + 55.00, 59.00 +/ C C C DATA (NPFZ(I),I=1, 17) / + 8, 9, 15, 21, 22, 28, 27, 27, 26, 20, 24, 30, 30, 29, 21, + 20, 11 +/ DATA (TAGFZ(K, 1),K=1, 8)/ +'F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 1),K=1, 8) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 1),K=1,2),L=1, 8)/ + 15.59,-125.04, 13.99,-104.17, 18.00, -94.37, 22.63, -84.11, + 25.16, -72.25, 27.86, -59.95, 30.09, -47.05, 29.56, -29.71 +/ DATA (TAGFZ(K, 2),K=1, 9)/ +'F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 2),K=1, 9) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00 +/ DATA ((FRACZN(K,L, 2),K=1,2),L=1, 9)/ + 15.59,-125.04, 25.72,-127.26, 27.71,-115.36, 23.44,-108.71, + 24.29, -94.18, 26.26, -81.92, 27.86, -59.95, 30.09, -47.05, + 29.56, -29.71 +/ DATA (TAGFZ(K, 3),K=1, 15)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 3),K=1, 15) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 3),K=1,2),L=1, 15)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 33.12,-120.57, + 27.71,-115.36, 23.44,-108.71, 31.30,-106.70, 31.39,-103.19, + 32.24, -96.28, 33.58, -83.48, 33.79, -66.16, 34.07, -56.01, + 33.30, -41.56, 31.31, -28.46, 29.56, -29.71 +/ DATA (TAGFZ(K, 4),K=1, 21)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F','F','F','F' +/ DATA (AGEFZ(K, 4),K=1, 21) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 4),K=1,2),L=1, 21)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 36.45,-130.48, + 36.30,-126.03, 34.39,-122.15, 33.12,-120.57, 27.71,-115.36, + 23.44,-108.71, 31.30,-106.70, 32.70,-101.50, 34.31, -96.22, + 35.02, -88.82, 37.37, -83.32, 39.82, -75.01, 37.48, -62.38, + 37.01, -56.15, 36.54, -44.03, 33.32, -26.81, 31.48, -28.31, + 29.56, -29.71 +/ DATA (TAGFZ(K, 5),K=1, 22)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 5),K=1, 22) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 5),K=1,2),L=1, 22)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 36.45,-130.48, + 36.30,-126.03, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 36.42,-103.96, + 29.31,-101.67, 30.90, -96.66, 31.63, -89.64, 33.99, -84.45, + 36.50, -76.61, 34.42, -64.53, 34.10, -58.57, 33.95, -46.94, + 30.70, -28.71, 28.36, -30.08 +/ DATA (TAGFZ(K, 6),K=1, 28)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 6),K=1, 28) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 6),K=1,2),L=1, 28)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 38.52,-125.98, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 36.42,-103.96, + 35.36,-100.33, 35.80, -96.04, 36.04, -87.64, 38.61, -83.49, + 40.03, -80.83, 40.75, -75.99, 42.08, -66.09, 42.76, -61.85, + 43.50, -58.17, 43.78, -48.52, 43.64, -38.32, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 7),K=1, 27)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 7),K=1, 27) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 7),K=1,2),L=1, 27)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 40.13,-131.75, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 37.83,-103.02, + 37.69, -97.94, 37.99, -94.65, 38.48, -90.74, 40.03, -80.83, + 40.75, -75.99, 42.08, -66.09, 42.76, -61.85, 43.50, -58.17, + 43.78, -48.52, 43.64, -38.32, 39.77, -21.11, 37.19, -23.42, + 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 8),K=1, 27)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 8),K=1, 27) / + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00 +/ DATA ((FRACZN(K,L, 8),K=1,2),L=1, 27)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 40.13,-131.75, 40.10,-126.07, 38.70,-123.94, 38.07,-119.03, + 38.57,-115.98, 38.31,-112.51, 37.79,-107.99, 37.83,-103.02, + 37.69, -97.94, 37.99, -94.65, 38.48, -90.74, 40.81, -81.78, + 43.05, -68.36, 43.82, -63.06, 45.47, -56.57, 45.94, -47.80, + 45.72, -36.12, 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, + 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 9),K=1, 26)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 9),K=1, 26) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00 +/ DATA ((FRACZN(K,L, 9),K=1,2),L=1, 26)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 43.26,-132.97, 42.34,-124.68, 41.51,-118.95, 41.92,-115.31, + 41.70,-109.93, 40.37,-100.85, 40.35, -98.25, 40.77, -95.67, + 41.34, -93.12, 42.06, -90.61, 42.74, -81.88, 43.05, -68.36, + 43.82, -63.06, 45.47, -56.57, 45.94, -47.80, 45.72, -36.12, + 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, + 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 10),K=1, 20)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V' +/ DATA (AGEFZ(K, 10),K=1, 20) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 10),K=1,2),L=1, 20)/ + 43.39,-133.14, 44.73,-133.51, 42.34,-124.68, 43.15,-119.71, + 45.49,-114.27, 45.73,-108.43, 44.73,-102.56, 48.58, -98.79, + 48.87, -94.66, 48.55, -89.67, 46.70, -85.91, 69.49, -10.11, + 69.17, 10.62, 55.83, 1.28, 41.92, -19.06, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 11),K=1, 24)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 11),K=1, 24) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 11),K=1,2),L=1, 24)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 49.49,-131.97, 48.65,-126.37, 49.93,-120.40, + 49.94,-115.54, 49.91,-111.07, 49.39,-107.30, 48.78,-104.25, + 48.58, -98.79, 48.87, -94.66, 48.55, -89.67, 46.70, -85.91, + 69.17, 10.62, 55.83, 1.28, 41.92, -19.06, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 12),K=1, 30)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 12),K=1, 30) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 12),K=1,2),L=1, 30)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 55.58,-138.46, 52.86,-133.79, + 51.31,-131.53, 50.15,-129.79, 50.53,-127.83, 51.55,-125.28, + 54.00,-120.83, 53.90,-116.85, 53.81,-112.33, 53.25,-108.90, + 53.06,-105.09, 48.58, -98.79, 48.87, -94.66, 48.55, -89.67, + 46.70, -85.91, 69.49, -10.11, 69.17, 10.62, 55.83, 1.28, + 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, + 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 13),K=1, 30)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 13),K=1, 30) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 13),K=1,2),L=1, 30)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 55.58,-138.46, 52.86,-133.79, + 51.31,-131.53, 50.15,-129.79, 50.53,-127.83, 51.55,-125.28, + 54.00,-120.83, 55.81,-113.06, 55.98,-108.85, 54.64,-108.33, + 53.06,-105.09, 48.58, -98.79, 48.87, -94.66, 48.55, -89.67, + 46.70, -85.91, 69.49, -10.11, 69.17, 10.62, 55.83, 1.28, + 41.92, -19.06, 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, + 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 14),K=1, 29)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 14),K=1, 29) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 14),K=1,2),L=1, 29)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 55.58,-138.46, 52.86,-133.79, + 51.31,-131.53, 50.15,-129.79, 50.53,-127.83, 51.55,-125.28, + 54.00,-120.83, 55.81,-113.06, 55.98,-108.85, 61.58, -99.29, + 63.17, -92.95, 65.54, -77.50, 70.17, -57.40, 72.85, -26.14, + 69.67, -7.24, 69.17, 10.62, 55.83, 1.28, 41.92, -19.06, + 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, + 29.56, -29.71 +/ DATA (TAGFZ(K, 15),K=1, 21)/ +'K','K','K','K','K','K','K','K','K','K','K','K','K','K','K', +'K','K','K','K','K','K' +/ DATA (AGEFZ(K, 15),K=1, 21) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 15),K=1,2),L=1, 21)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 63.11,-144.77, 69.34,-141.39, + 76.98,-131.11, 80.85, -90.15, 78.29, -32.39, 71.63, -18.19, + 69.67, -7.24, 69.44, 10.88, 55.38, 1.77, 41.92, -19.06, + 39.77, -21.11, 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, + 29.56, -29.71 +/ DATA (TAGFZ(K, 16),K=1, 20)/ +'K','K','K','K','K','K','K','K','K','K','K','K','K','K','K', +'K','K','K','K','K' +/ DATA (AGEFZ(K, 16),K=1, 20) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 16),K=1,2),L=1, 20)/ + 15.59,-125.04, 25.72,-127.26, 32.81,-129.34, 38.54,-131.32, + 50.87,-136.46, 55.63,-139.27, 63.11,-144.77, 71.17,-152.92, + 83.00,-147.32, 85.08, -74.45, 71.63, -18.19, 67.61, -18.68, + 63.46, -11.94, 55.38, 1.77, 41.92, -19.06, 39.77, -21.11, + 37.19, -23.42, 33.32, -26.81, 31.48, -28.31, 29.56, -29.71 +/ DATA (TAGFZ(K, 17),K=1, 11)/ +'K','K','K','K','K','K','K','K','K','K','K' +/ DATA (AGEFZ(K, 17),K=1, 11) / + 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, 85.00, + 85.00, 85.00, 85.00 +/ DATA ((FRACZN(K,L, 17),K=1,2),L=1, 11)/ + 15.59,-125.04, 40.13,-131.75, 55.63,-139.27, 63.11,-144.77, + 71.21,-152.93, 83.00,-147.32, 89.93,-130.41, 69.44, 10.88, + 55.38, 1.77, 47.07, -12.56, 29.56, -29.71 +/ C C C DATA (NMAG(I),I=1, 16) / + 12, 15, 15, 17, 16, 8, 12, 13, 17, 9, 8, 5, 7, 2, 6, + 7 +/ DATA (TAGMAG(K, 1),K=1, 12)/ +'F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 1),K=1, 12) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 59.00, 63.40, + 67.00, 77.00,142.00,240.00 +/ DATA (((REMAG(K,L,M, 1),K=1,2),L=1,2),M=1, 12) / + 22.94,-108.62, 19.57,-110.03, 22.15,-107.81, 19.38,-108.80, + 20.73,-106.17, 18.90,-106.87, 25.27,-102.94, 16.40,-102.97, + 24.14,-101.56, 16.66,-101.66, 24.11, -97.49, 18.53, -96.65, + 25.83, -82.46, 21.44, -81.63, 26.16, -80.77, 21.81, -79.71, + 26.56, -80.43, 22.47, -79.16, 26.83, -75.41, 23.15, -73.96, + 26.47, -61.99, 24.12, -63.58, 35.79, -17.17, 29.70, -28.97 +/ DATA (TAGMAG(K, 2),K=1, 15)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 2),K=1, 15) / + 0.00, 10.00, 20.00, 27.50, 35.70, 49.30, 59.00, 63.40, + 67.00, 77.00,126.00,165.00,200.00,240.00,240.00 +/ DATA (((REMAG(K,L,M, 2),K=1,2),L=1,2),M=1, 15) / + 28.07,-108.81, 23.70,-108.58, 28.08,-108.55, 23.71,-108.33, + 31.00,-106.14, 24.87,-105.49, 31.43,-103.56, 24.04,-103.46, + 31.38, -99.00, 24.02, -98.31, 31.79, -96.01, 24.87, -94.72, + 32.55, -90.64, 25.62, -90.16, 32.71, -88.50, 25.76, -88.05, + 33.05, -87.18, 25.94, -86.84, 33.50, -82.33, 26.27, -82.02, + 33.49, -71.21, 29.07, -70.66, 33.40, -59.78, 27.89, -59.33, + 33.47, -44.61, 30.67, -44.49, 31.24, -28.50, 29.95, -29.65, + 35.78, -17.17, 29.70, -28.97 +/ DATA (TAGMAG(K, 3),K=1, 15)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 3),K=1, 15) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 63.40, 67.00, + 77.00,126.00,134.00,150.00,180.00,220.00,220.00 +/ DATA (((REMAG(K,L,M, 3),K=1,2),L=1,2),M=1, 15) / + 32.05,-106.51, 31.16,-106.49, 32.92,-101.69, 31.43,-102.34, + 35.03, -96.52, 31.78, -96.40, 35.86, -92.66, 32.07, -92.63, + 37.00, -88.90, 32.71, -88.77, 40.00, -82.70, 33.09, -83.14, + 40.55, -80.73, 33.40, -81.29, 41.06, -79.60, 33.70, -80.32, + 41.71, -74.07, 33.98, -74.48, 37.49, -61.88, 34.61, -62.56, + 37.06, -58.84, 35.72, -59.17, 37.31, -53.84, 34.26, -53.85, + 36.15, -42.30, 34.03, -42.67, 33.41, -27.01, 32.02, -29.38, + 32.32, -27.45, 31.81, -28.32 +/ DATA (TAGMAG(K, 4),K=1, 17)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F' +/ DATA (AGEMAG(K, 4),K=1, 17) / + -0.10, -0.10, 27.50, 27.50, 35.70, 42.00, 49.30, 49.30, + 59.00, 63.40, 67.00, 77.00,119.00,126.00,134.00,142.00, +180.00 +/ DATA (((REMAG(K,L,M, 4),K=1,2),L=1,2),M=1, 17) / + 39.48,-125.50, 36.47,-125.64, 33.37,-102.05, 32.77,-102.07, + 33.37,-102.01, 32.76,-102.04, 34.89,-100.23, 32.53,-101.45, + 35.80, -95.98, 33.75, -95.69, 35.91, -91.95, 33.90, -91.90, + 37.00, -88.90, 32.71, -88.77, 36.09, -87.77, 34.12, -87.61, + 38.37, -83.89, 36.72, -83.58, 38.84, -82.31, 37.04, -82.08, + 39.82, -81.29, 38.02, -80.97, 40.77, -75.75, 38.64, -75.29, + 42.43, -64.58, 37.38, -63.68, 42.80, -61.72, 37.48, -61.76, + 43.18, -58.52, 37.61, -58.25, 43.81, -56.52, 36.98, -55.19, + 42.15, -41.18, 36.43, -41.72 +/ DATA (TAGMAG(K, 5),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEMAG(K, 5),K=1, 16) / + 27.50, 27.50, 35.70, 42.00, 49.30, 49.30, 59.00, 63.40, + 67.00, 77.00,119.00,126.00,134.00,142.00,180.00,215.00 +/ DATA (((REMAG(K,L,M, 5),K=1,2),L=1,2),M=1, 16) / + 37.61,-102.97, 36.01,-103.23, 34.89,-100.23, 32.53,-101.45, + 35.80, -95.98, 33.75, -95.69, 35.91, -91.95, 33.90, -91.90, + 37.00, -88.90, 32.71, -88.77, 36.09, -87.77, 34.12, -87.61, + 38.37, -83.89, 36.72, -83.58, 38.84, -82.31, 37.04, -82.08, + 39.82, -81.29, 38.02, -80.97, 40.77, -75.75, 38.64, -75.29, + 42.43, -64.58, 37.38, -63.68, 42.80, -61.72, 37.48, -61.76, + 43.18, -58.52, 37.61, -58.25, 43.81, -56.52, 36.98, -55.19, + 42.15, -41.18, 36.43, -41.72, 39.57, -21.55, 34.89, -25.78 +/ DATA (TAGMAG(K, 6),K=1, 8)/ +'V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 6),K=1, 8) / + 20.00, 27.50, 32.00, 35.70, 42.00, 49.30, 55.00, 71.00 +/ DATA (((REMAG(K,L,M, 6),K=1,2),L=1,2),M=1, 8) / + 38.74,-107.22, 37.20,-107.17, 37.61,-102.97, 36.01,-103.23, + 38.12,-100.16, 35.41,-100.24, 37.64, -97.96, 35.97, -98.10, + 37.75, -94.67, 35.97, -94.69, 37.72, -90.93, 36.00, -90.81, + 38.64, -88.39, 35.91, -87.72, 40.21, -81.16, 39.83, -81.31 +/ DATA (TAGMAG(K, 7),K=1, 12)/ +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 7),K=1, 12) / + 62.00, 79.00, 95.00,110.00,119.00,126.00,134.00,142.00, +150.00,180.00,200.00,225.00 +/ DATA (((REMAG(K,L,M, 7),K=1,2),L=1,2),M=1, 12) / + 39.44, -88.34, 38.22, -88.67, 40.68, -82.76, 39.71, -82.44, + 41.87, -76.97, 40.64, -76.68, 42.45, -71.61, 41.21, -71.43, + 42.89, -66.57, 42.23, -66.39, 43.73, -63.26, 42.95, -63.29, + 44.17, -60.23, 43.21, -60.02, 44.81, -58.21, 43.63, -57.96, + 45.78, -55.81, 43.77, -55.76, 45.91, -43.51, 43.91, -43.72, + 46.09, -37.00, 43.63, -37.73, 41.88, -19.07, 39.99, -21.35 +/ DATA (TAGMAG(K, 8),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 8),K=1, 13) / + 0.10, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 59.00, 63.40, 67.00, 77.00,140.00 +/ DATA (((REMAG(K,L,M, 8),K=1,2),L=1,2),M=1, 13) / + 42.80,-126.60, 40.17,-127.40, 42.45,-125.24, 40.18,-126.21, + 42.51,-123.83, 38.69,-124.00, 41.42,-118.95, 38.25,-119.07, + 41.80,-115.62, 38.70,-116.11, 41.73,-112.10, 38.61,-112.52, + 41.22,-108.00, 38.01,-108.00, 40.63,-103.87, 36.89,-103.78, + 40.11, -97.66, 36.61, -96.10, 40.78, -95.88, 37.24, -94.53, + 41.28, -95.05, 37.77, -93.70, 42.76, -89.98, 39.26, -88.59, + 43.41, -68.81, 43.05, -69.05 +/ DATA (TAGMAG(K, 9),K=1, 17)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V' +/ DATA (AGEMAG(K, 9),K=1, 17) / + 9.50, 27.50, 35.70, 42.00, 49.30, 59.00, 63.40, 67.00, + 77.00,126.00,134.00,142.00,158.00,180.00,200.00,230.00, +240.00 +/ DATA (((REMAG(K,L,M, 9),K=1,2),L=1,2),M=1, 17) / + 42.51,-123.83, 38.69,-124.00, 45.28,-113.55, 41.70,-114.19, + 45.66,-109.22, 41.61,-109.93, 45.23,-105.57, 41.19,-105.83, + 44.74,-102.25, 40.68,-101.27, 48.49, -98.41, 41.04, -94.18, + 49.16, -96.77, 41.62, -92.72, 48.67, -95.63, 41.97, -92.33, + 48.34, -89.32, 43.41, -87.14, 51.47, -70.15, 46.67, -68.59, + 52.83, -66.31, 43.84, -63.15, 53.00, -64.55, 44.39, -60.75, + 54.93, -57.93, 45.45, -55.29, 63.49, -47.57, 46.98, -46.80, + 65.69, -34.67, 45.99, -39.55, 68.71, 10.51, 41.73, -25.13, + 57.25, 0.37, 42.36, -19.36 +/ DATA (TAGMAG(K, 10),K=1, 9)/ +'V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 10),K=1, 9) / + 0.10, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 60.00 +/ DATA (((REMAG(K,L,M, 10),K=1,2),L=1,2),M=1, 9) / + 48.86,-129.11, 44.10,-131.38, 47.85,-128.22, 44.65,-129.45, + 47.92,-125.54, 44.65,-125.76, 49.83,-120.18, 47.58,-120.37, + 49.83,-114.87, 45.98,-115.58, 49.89,-111.38, 45.89,-112.04, + 49.48,-107.86, 45.30,-108.35, 48.95,-104.30, 44.77,-103.58, + 48.60, -99.23, 47.85, -99.31 +/ DATA (TAGMAG(K, 11),K=1, 8)/ +'V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 11),K=1, 8) / + 0.10, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, 60.00 +/ DATA (((REMAG(K,L,M, 11),K=1,2),L=1,2),M=1, 8) / + 49.95,-129.96, 49.31,-130.63, 51.53,-125.42, 48.75,-125.65, + 53.85,-120.86, 50.28,-120.71, 53.84,-116.82, 50.00,-116.45, + 53.79,-112.59, 50.21,-113.72, 53.31,-108.95, 49.63,-109.89, + 52.91,-105.16, 49.01,-105.38, 48.91, -99.38, 48.31, -99.45 +/ DATA (TAGMAG(K, 12),K=1, 5)/ +'V','V','V','V','V' +/ DATA (AGEMAG(K, 12),K=1, 5) / + 14.00, 27.50, 35.70, 42.00, 42.00 +/ DATA (((REMAG(K,L,M, 12),K=1,2),L=1,2),M=1, 5) / + 54.22,-120.58, 53.91,-120.48, 55.81,-113.13, 53.94,-113.12, + 55.83,-108.54, 53.46,-109.23, 53.84,-107.23, 53.24,-107.45, + 53.34,-105.45, 52.87,-105.44 +/ DATA (TAGMAG(K, 13),K=1, 7)/ +'V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 13),K=1, 7) / + 42.00, 43.80, 49.30, 59.00, 67.00, 77.00, 85.00 +/ DATA (((REMAG(K,L,M, 13),K=1,2),L=1,2),M=1, 7) / + 56.52,-108.44, 54.25,-108.27, 61.48, -99.41, 54.64,-108.33, + 63.10, -92.77, 53.20,-105.10, 65.51, -77.34, 48.75, -98.53, + 70.04, -57.53, 48.58, -95.06, 71.04, -26.15, 48.63, -89.31, + 70.21, -6.99, 69.46, -12.71 +/ DATA (TAGMAG(K, 14),K=1, 2)/ +'V','V' +/ DATA (AGEMAG(K, 14),K=1, 2) / + -0.10, -0.10 +/ DATA (((REMAG(K,L,M, 14),K=1,2),L=1,2),M=1, 2) / + 57.02,-140.64, 55.42,-139.28, 72.18, -16.71, 71.47, -21.32 +/ DATA (TAGMAG(K, 15),K=1, 6)/ +'K','K','K','K','K','K' +/ DATA (AGEMAG(K, 15),K=1, 6) / + 42.00, 49.30, 59.00, 67.00, 77.00, 85.00 +/ DATA (((REMAG(K,L,M, 15),K=1,2),L=1,2),M=1, 6) / + 63.38,-145.67, 64.08,-143.46, 66.37,-147.24, 69.08,-141.77, + 70.85,-152.26, 76.54,-131.98, 74.46,-151.71, 80.44, -97.60, + 80.47,-148.87, 78.59, -34.84, 74.94, -20.15, 72.70, -21.28 +/ DATA (TAGMAG(K, 16),K=1, 7)/ +'K','K','K','K','K','K','K' +/ DATA (AGEMAG(K, 16),K=1, 7) / +142.00,142.00,158.00,180.00,200.00,230.00,240.00 +/ DATA (((REMAG(K,L,M, 16),K=1,2),L=1,2),M=1, 7) / + 84.28,-153.66, 83.57,-145.73, 84.28,-153.66, 83.57,-145.73, + 87.37,-138.07, 84.91,-130.52, 83.59, -0.71, 83.56, -59.44, + 76.84, 7.82, 79.05, -32.45, 61.44, 5.79, 64.48, -9.60, + 56.17, 3.42, 57.15, -0.30 +/ END C C C BLOCK DATA SOUTH C C ALL DATA NECESSARY TO DEFINE OCEANIC SLAB MOTIONS, AGES, AND C AREAS OF CONTACT WITH NORTH AMERICA UNDER ENGEBRETSON'S C "SOUTHERN OPTION": KULA/VANCOUVER TRIPLE JUNCTION INITIALLY C IN CENTRAL AMERICA, THEN MIGRATING NORTH ALONG COAST. C C***************************************************************** C CAUTION!!! C WHEN INSTALLING THIS BLOCK DATA PROGRAM INTO ANOTHER CODE, SUCH C AS LARAMY, VERSCOMP, OR GDDMCOMP, IT IS NECESSARY TO MAKE THREE C SMALL EDITING CHANGES! C C IN THE "COMMON" STATEMENTS BELOW, CHANGE THE THREE NAMES AS C FOLLOWS: C C COMMON /SCALAR/ -> COMMON /SOUTH1/ C COMMON /ARRAYS/ -> COMMON /SOUTH2/ C COMMON /TAGS/ -> COMMON /SOUTH3/ C C THIS IS NECESSARY SO THAT THE DATA WILL BE LINKED ONLY INTO C SUBPROGRAM BELOW2 (SOUTHERN OPTION) AND NOT INTO BELOW1! C C CONVERSELY, IF YOU ARE BRINGING A BLOCK DATA PROGRAM BACK TO C BE INSPECTED AND/OR EDITED WITH MAPPER, IT IS NECCESARY TO C CHANGE THE COMMON BLOCK NAMES BACK TO THE NAMES IN THE LEFT C COLUMN ABOVE. C****************************************************************** C C COMMENTS ON COORDINATES AND UNITS C MOST OF THE DATA IN THIS UNIT ARE IN ROUND-EARTH COORDINATES C OF (LATITUDE,LONGITUDE). THE UNITS ARE DEGREES; FOR MORE C PRECISION WE USE DECIMAL FRACTIONS OF DEGREES INSTEAD OF C MINUTES AND/OR SECONDS OF ARC. LATITUDE IS POSITIVE IN THE C NORTHERN HEMISPHERE. LONGITUDE IS POSITIVE EAST OF C GREENWICH, ENGLAND. C THE FINITE-ROTATION MATRICES (3 X 3) AND THE ROTATION-AXIS C VECTORS (3 X 1) USE A DIFFERENT COORDINATE SYSTEM. C IT IS CARTESIAN (X,Y,Z), WITH ITS ORIGIN AT THE CENTER C OF THE EARTH. X POINTS TOWARD (LAT=0, LON=0). C Y POINTS TOWARD (LAT=0, LON=90). Z POINTS TOWARD (LAT=90). C THE UNITS DIFFER: THE FINITE-ROTATION MATRICES ARE C DIMENSIONLESS, BUT THE ROTATION-RATE VECTORS ARE IN C RADIANS PER SECOND. C THE GEOLOGIC TIMES WHICH LABEL THE VARIOUS FEATURES ARE C EXPRESSED IN MILLIONS OF YEARS (POSITIVE = PAST). THE C LENGTH OF 1 MILLION YEARS IN THE FUNDAMENTAL TIME UNIT C (THE SECOND) IS EXPRESSED BY "TUMAP". C C---------------------------------------------------------------- C GLOSSARY OF DATA: C -AGEFZ(J,I) IS THE AGE OF FRACTURE ZONE POINT #J C IN STRIP #I. (USED BY EDITOR, NOT BY BELOWY) C -AGEHNG(I) IS THE AGE OF THE HINGELINE CURVE K C DEFINED BY REHING(I=1,2;J=1,40?;K). C -AGEKV(I) IS THE AGE OF THE KULA/VANCOUVER/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REKV3J(1-3,I). C -AGEMAG(I,J) IS THE AGE OF MAGNETIC ANOMALY I (FROM W TO E) C IN STRIPE J (FROM S TO N) ON THE PRESENT-AGE MAP. C -AGEROT(I) IS THE AGE OF THE FINITE ROTATION MATRICES C ROMATF, ROMATK, ROMATP, AND ROMATV WITH AGE INDEX I. C -AGEVEL(I) IS THE AGE OF THE RELATIVE ROTATION-AXIS VECTORS C OMEGAF, OEMGAK, OMEGAP, AND OMEGAV WITH AGE INDEX I. C -AGEVF(I) IS THE AGE OF THE VANCOUVER/FARALLON/NORTH AMERICAN C TRIPLE-JUNCTION LOCATION GIVEN BY REVF3J(1-3,I). C -FRACZN(2,I,J) ARE THE LAT. AND LON. COORDINATES OF POINTS I C (W TO E) ALONG FRACTURE ZONE J (S TO N) ON THE MAP OF C PRESENT SLAB AGES. C -NKV3J IS THE NUMBER OF KULA/VANCOUVER/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REKV3J(1-3,I) AT AGE AGEKV(I). C -NMAG(K) IS THE NUMBER OF LINEAR MAGNETIC ANOMALIES C WITHIN STRIPE K (S TO N) OF THE MAP OF PRESENT SLAB C AGES. C -NPHING(I) IS THE NUMBER C OF DIGITIZED POINTS IN HINGELINE CURVE #I OF REHING. C -NPFZ(J) IS THE NUMBER OF POINTS (W TO E) DEFINING FRACTURE ZONE C J (S TO N) ON THE MAP OF PRESENT SLAB AGES. C -NROMAT IS THE NUMBER OF FINITE-ROTATION MATRICES C GIVEN FOR EACH PLATE. C -NVF3J IS THE NUMBER OF VANCOUVER/FARALLON/NORTH AMERICAN TRIPLE C JUNCTION POSITIONS GIVEN IN REVF3J(1-3,I) AT AGE AGEVF(I). C -NTAPES IS THE NUMBER OF STRIPS OF MAGNETIC ANOMALIES ON C THE MAP OF PRESENT SLAB AGES; ONE LESS THAN THE NUMBER OF C FRACTURE ZONES ON THE MAP. C -NUMHNG IS THE NUMBER OF SLAB HINGELINES (AT DIFFERENT TIMES). C -NUMVEL IS THE NUMBER OF AGES AGEVEL(I) WHERE RELATIVE C ROTATION-AXIS VECTORS (OMEGAF/K/P/V) ARE SUPPLIED. C -OMEGAF(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE FARALLON C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAK(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE KULA C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAP(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE PACIFIC C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -OMEGAV(1-3,I) IS THE RELATIVE-ROTATION AXIS FOR THE VANCOUVER C PLATE WITH RESPECT TO NORTH AMERICA AT TIME AGEVEL(I); C ITS 3 COMPONENTS (CARTESIAN X,Y,Z) ARE IN RADS/SEC. C -REHING(I,J,K) ARE THE LAT. (I=1) AND LON. (I=2) COORDINATES C OF THE DIGITIZED POINT #J (N TO S) OF THE HINGELINE C CURVE #K (PAST TO PRESENT). C -REKV3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE KULA/ C VANCOUVER/NORTH AMERICAN TRIPLE-JUNCTION AT AGE AGEKV(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -REMAG(2,2,I,J) ARE THE LAT., LON. COORDINATES (1ST SUB.) C OF THE N AND S ENDS (2ND SUB.) OF THE LINEAR MAGNETIC C ANOMALY I (W TO E) IN STRIPE J (S TO N) OF THE C PRESENT SLAB AGE MAP. C -REVF3J(3,I) ARE THE LAT., LON., AND ANGLE VALUES OF THE C VANCOUVER/FARALLON/N.A. TRIPLE-JUNCTION AT AGE AGEVF(I). C THE ANGLE IS MEASURED IN DEGREES COUNTERCLOCKWISE FROM EAST, C AND EXPRESSES THE TREND OF THE PLATE BOUNDARY AWAY FROM C THE POINT GIVEN. C -ROMATF(3,3,K) ARE THE ROTATION MATRICES FOR FARALLON WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATK(3,3,K) ARE THE ROTATION MATRICES FOR KULA WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATP(3,3,K) ARE THE ROTATION MATRICES FOR PACIFIC WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -ROMATV(3,3,K) ARE THE ROTATION MATRICES FOR VANCOUVER WRT N.A. C FROM PAST (AGE K) TO PRESENT. C -TAGFZ(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE FRACTURE ZONE POINT #I C IN STRIP #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TAGMAG(I,J) IS A 1-CHARACTER TAG, EITHER 'F', 'K', 'P', C OR 'V' TO IDENTIFY WHICH PLATE THE MAGNETIC ANOM. #I IN STRIP C #J IS ATTACHED TO. (USED BY EDITOR, NOT BY BELOWY) C -TUMAP IS A CONVENIENCE MULTIPLIER APPLIED TO AGES IN M.Y. C TO OBTAIN THE TRUE AGE IN PROGRAM UNITS (SECONDS). C------------------------------------------------------------------ C C MEMO: ORDER IS: PARAMETER, TYPE, COMMON, DIMENSION, DATA C C********************************************************************* C C NOTE: THESE DIMENSION PARAMETERS MUST AGREE C IN ALL PROGRAMS !!!!!! C C MAXIMUM NUMBER OF DIGITISED SLAB HINGELINES: PARAMETER (MAXHL=20) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED HINGELINE: PARAMETER (MAXHNG=40) C MAXIMUM NUMBER OF FINITE ROTATIONS FOR EACH PLATE: PARAMETER (MAXROT=21) C MAXIMUM NUMBER OF RELATIVE ROTATION-AXIS VECTORS FOR EACH PLATE: PARAMETER (MAXVEL=20) C MAXIMUM NUMBER OF AGES WHEN KULA/VANCOUVER TRIPLE-JUNCTION IS GIVEN: PARAMETER (MXKV3J =50) C MAXIM.NUMBER OF AGES WHEN VANCOUVER/FARALLON TRIPLE-JUNCTION IS GIVEN PARAMETER (MXVF3J =50) C MAXIMUM NUMBER OF STRIPS OF SEAFLOOR (BETWEEN FRACTURE ZONES) ON MAP: PARAMETER (MTAPES =40,MTAPP1=41) C MAXIMUM NUMBER OF POINTS IN ANY DIGITISED FRACTURE ZONE: PARAMETER (MAXFZP=100) C MAXIMUM NUMBER OF MAGNETIC ANOMALIES IN ANY ONE STRIP: PARAMETER (MAXMAG=100) C********************************************************************* CHARACTER*1 TAGFZ,TAGMAG C-------------------------------------------------------------------- COMMON /SOUTH1/ + NKV3J, + NROMAT,NTAPES,NTAPP1,NUMHNG,NUMVEL,NVF3J, + TUMAP COMMON /SOUTH2/ + AGEFZ,AGEHNG,AGEKV,AGEMAG,AGEROT,AGEVEL,AGEVF, + FRACZN,NMAG,NPFZ,NPHING, + OMEGAF,OMEGAK,OMEGAP,OMEGAV, + REHING,REKV3J,REMAG,REVF3J, + ROMATF,ROMATK,ROMATP,ROMATV COMMON /SOUTH3/ + TAGFZ,TAGMAG C-------------------------------------------------------------------- DIMENSION AGEFZ(MAXFZP,MTAPP1), 2 AGEHNG(MAXHL), 3 AGEKV(MXKV3J), 4 AGEMAG(MAXMAG,MTAPES), 5 AGEROT(MAXROT), 6 AGEVEL(MAXVEL), 7 AGEVF(MXVF3J), 8 FRACZN(2,MAXFZP,MTAPP1), 9 NPFZ(MTAPP1), A NPHING(MAXHNG) DIMENSION NMAG(MTAPES), 2 OMEGAF(3,MAXVEL), 3 OMEGAK(3,MAXVEL), 4 OMEGAP(3,MAXVEL), 5 OMEGAV(3,MAXVEL), 6 REHING(2,MAXHNG,MAXHL), 7 REKV3J(3,MXKV3J), 8 REMAG(2,2,MAXMAG,MTAPES), 9 REVF3J(3,MXVF3J), A ROMATF(3,3,MAXROT), 1 ROMATK(3,3,MAXROT), 2 ROMATP(3,3,MAXROT), 3 ROMATV(3,3,MAXROT), 4 TAGFZ(MAXFZP,MTAPP1), 5 TAGMAG(MAXMAG,MTAPES) C C===1=== SLAB HINGELINES ======================= C DATA NUMHNG / 14/ DATA TUMAP /3.15576E13/ DATA (AGEHNG(I),I=1, 14) / + 90.00, 80.00, 75.00, 65.00, 55.00, 45.00, 40.00, 35.00, + 30.00, 27.50, 20.00, 10.00, 0.00, -3.00 + / DATA (NPHING(I),I=1, 14) / + 29, 29, 33, 34, 31, 35, 32, 26, 31, 30, 30, 27, 31, 31 + / DATA ((REHING(I,J, 1),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.93,-121.73, 43.26,-120.79, 42.45,-120.19, + 41.36,-119.63, 40.28,-119.46, 38.96,-119.44, 37.33,-119.31, + 35.93,-118.93, 33.70,-117.83, 31.95,-116.51, 30.19,-114.64, + 28.43,-112.42, 27.31,-110.50, 26.22,-108.89, 24.93,-106.85, + 23.66,-105.23, 22.25,-103.60, 20.84,-102.03, 19.21,-100.57, + 17.67, -99.09 + / DATA ((REHING(I,J, 2),I=1,2),J=1, 29) / + 58.39,-135.70, 55.15,-133.03, 52.37,-130.80, 50.45,-129.28, + 48.54,-127.75, 47.44,-126.80, 46.23,-125.56, 45.39,-124.16, + 44.52,-122.79, 43.93,-121.73, 43.26,-120.79, 42.45,-120.19, + 41.36,-119.63, 40.28,-119.46, 38.96,-119.44, 37.33,-119.31, + 35.93,-118.93, 33.70,-117.83, 31.95,-116.51, 30.19,-114.64, + 28.43,-112.42, 27.31,-110.50, 26.22,-108.89, 24.93,-106.85, + 23.66,-105.23, 22.25,-103.60, 20.84,-102.03, 19.21,-100.57, + 17.67, -99.09 + / DATA ((REHING(I,J, 3),I=1,2),J=1, 33) / + 60.24,-142.90, 58.27,-136.08, 57.06,-133.84, 55.56,-132.30, + 54.31,-131.06, 52.34,-129.57, 50.99,-128.46, 49.68,-127.62, + 48.64,-126.31, 47.41,-124.10, 46.20,-121.40, 45.21,-118.79, + 44.38,-116.32, 43.59,-113.87, 42.71,-111.45, 41.95,-110.30, + 40.87,-109.75, 39.46,-109.53, 38.07,-109.47, 36.40,-109.69, + 34.97,-110.12, 33.38,-111.48, 32.18,-112.63, 31.23,-113.29, + 30.55,-113.21, 29.70,-112.07, 28.45,-110.41, 26.85,-108.26, + 25.03,-106.06, 22.76,-103.36, 20.40,-100.83, 18.53, -98.91, + 15.76, -95.35 + / DATA ((REHING(I,J, 4),I=1,2),J=1, 34) / + 59.74,-142.93, 57.85,-135.98, 57.15,-134.10, 56.01,-132.85, + 54.68,-131.71, 52.77,-130.21, 50.90,-128.84, 49.63,-127.75, + 48.60,-126.11, 47.65,-124.22, 47.03,-122.13, 46.41,-119.25, + 46.11,-116.86, 45.83,-114.22, 45.56,-111.04, 45.24,-108.41, + 44.65,-106.77, 43.72,-105.66, 42.82,-105.87, 41.25,-106.39, + 39.96,-107.68, 38.23,-109.58, 36.53,-111.05, 34.82,-112.31, + 33.11,-113.12, 32.14,-113.13, 31.23,-112.40, 30.09,-111.04, + 28.34,-108.86, 26.70,-106.84, 24.65,-104.56, 22.44,-102.17, + 18.04, -97.90, 14.33, -93.82 + / DATA ((REHING(I,J, 5),I=1,2),J=1, 31) / + 60.18,-142.67, 58.34,-135.99, 57.39,-133.91, 55.54,-131.68, + 53.24,-129.30, 51.45,-127.33, 49.34,-124.96, 47.58,-122.87, + 45.85,-120.92, 44.34,-118.67, 43.75,-116.92, 43.72,-114.46, + 43.59,-111.55, 43.34,-108.91, 42.86,-107.05, 42.13,-105.45, + 41.13,-104.87, 40.08,-104.90, 38.70,-105.39, 37.13,-106.70, + 35.70,-107.90, 34.13,-109.17, 32.75,-109.71, 31.34,-109.71, + 30.37,-109.16, 29.06,-107.62, 26.11,-104.35, 22.91,-101.21, + 20.18, -98.61, 18.86, -97.37, 15.81, -93.90 + / DATA ((REHING(I,J, 6),I=1,2),J=1, 35) / + 59.65,-143.76, 57.90,-136.31, 57.31,-134.75, 56.45,-133.35, + 55.25,-132.01, 53.95,-130.78, 52.54,-129.43, 50.88,-127.99, + 49.81,-126.43, 49.25,-124.90, 48.58,-123.85, 47.46,-122.86, + 46.31,-121.77, 44.75,-120.30, 43.36,-119.35, 41.49,-118.46, + 40.66,-117.90, 40.03,-116.96, 39.46,-115.55, 39.13,-113.64, + 38.99,-111.33, 38.87,-108.52, 38.77,-106.09, 38.39,-104.45, + 38.00,-103.53, 37.37,-103.42, 35.34,-103.89, 32.58,-104.54, + 29.82,-105.05, 27.44,-105.42, 24.90,-103.03, 22.70,-101.09, + 20.05, -98.86, 17.88, -96.95, 14.95, -94.01 + / DATA ((REHING(I,J, 7),I=1,2),J=1, 32) / + 60.15,-144.12, 58.32,-136.58, 57.58,-134.52, 55.82,-132.18, + 53.60,-130.20, 51.68,-128.54, 50.56,-127.44, 49.48,-125.13, + 48.21,-123.37, 45.85,-121.58, 43.62,-119.92, 41.89,-118.52, + 40.13,-116.35, 39.11,-114.39, 38.47,-112.91, 38.07,-111.01, + 37.86,-108.95, 37.68,-106.27, 37.11,-104.05, 36.49,-103.28, + 35.59,-103.92, 33.92,-105.34, 32.65,-107.07, 31.58,-108.11, + 30.77,-108.67, 30.04,-107.87, 28.35,-106.21, 25.94,-103.92, + 23.23,-101.36, 19.92, -98.62, 18.08, -97.05, 14.58, -93.85 + / DATA ((REHING(I,J, 8),I=1,2),J=1, 26) / + 60.73,-144.29, 58.48,-135.82, 56.96,-132.82, 54.44,-130.45, + 51.91,-128.35, 50.62,-126.85, 49.32,-124.72, 47.04,-122.53, + 45.09,-121.21, 43.27,-119.94, 41.70,-118.85, 39.66,-117.43, + 38.07,-115.05, 37.24,-112.97, 36.83,-110.87, 36.60,-109.39, + 36.22,-108.78, 35.56,-108.94, 33.64,-110.03, 32.23,-110.38, + 31.18,-109.93, 30.10,-108.77, 27.69,-106.20, 24.64,-103.37, + 19.55, -98.74, 14.66, -94.17 + / DATA ((REHING(I,J, 9),I=1,2),J=1, 31) / + 59.94,-142.45, 58.14,-135.36, 56.98,-133.18, 54.87,-131.29, + 52.93,-129.48, 51.68,-128.44, 50.98,-127.72, 50.43,-126.82, + 49.58,-125.10, 48.58,-123.85, 45.67,-121.39, 43.86,-120.19, + 41.92,-118.74, 39.65,-117.67, 38.14,-116.22, 37.34,-114.59, + 36.86,-113.27, 36.59,-112.50, 36.18,-112.04, 35.60,-111.96, + 34.88,-112.15, 34.29,-112.49, 33.70,-112.81, 32.69,-112.03, + 31.73,-110.98, 29.66,-108.65, 27.54,-106.42, 24.80,-103.95, + 23.88,-103.22, 18.54, -98.67, 14.42, -94.83 + / DATA ((REHING(I,J, 10),I=1,2),J=1, 30) / + 60.05,-142.71, 58.15,-135.55, 57.19,-133.78, 55.93,-132.21, + 54.27,-130.67, 53.02,-129.56, 51.61,-128.52, 50.80,-127.58, + 50.24,-126.63, 49.34,-124.96, 48.34,-123.62, 47.04,-122.53, + 45.82,-121.46, 44.32,-120.36, 42.71,-119.19, 40.97,-118.24, + 39.38,-117.47, 38.13,-116.62, 36.88,-115.49, 35.88,-114.63, + 35.07,-113.90, 34.07,-113.38, 32.72,-112.14, 31.60,-110.78, + 29.45,-108.57, 27.14,-106.05, 24.28,-103.50, 21.45,-101.15, + 18.32, -98.45, 14.79, -95.22 + / DATA ((REHING(I,J, 11),I=1,2),J=1, 30) / + 60.40,-143.60, 58.26,-135.89, 57.30,-133.82, 55.79,-132.11, + 54.09,-130.51, 52.22,-128.93, 50.89,-127.65, 50.16,-126.36, + 48.98,-124.38, 47.60,-123.01, 45.84,-122.17, 43.62,-121.86, + 41.51,-121.12, 39.45,-120.08, 37.52,-118.43, 36.38,-117.33, + 35.75,-116.30, 35.15,-114.95, 34.51,-113.95, 33.50,-113.29, + 32.45,-112.66, 31.69,-112.09, 30.03,-110.31, 28.29,-108.49, + 26.74,-106.94, 24.73,-105.04, 22.76,-103.43, 19.82,-100.93, + 18.03, -99.36, 15.25, -96.89 + / DATA ((REHING(I,J, 12),I=1,2),J=1, 27) / + 60.42,-144.51, 58.53,-136.13, 57.88,-134.36, 56.05,-132.25, + 54.05,-130.39, 52.11,-128.80, 50.74,-127.47, 50.15,-126.46, + 49.50,-125.28, 48.27,-123.80, 47.15,-122.81, 46.39,-122.50, + 45.08,-122.44, 43.55,-122.58, 41.65,-121.97, 39.91,-120.91, + 38.15,-119.72, 36.58,-117.83, 34.34,-115.15, 31.39,-111.97, + 28.32,-108.97, 26.00,-106.84, 23.14,-104.47, 21.37,-103.15, + 20.03,-101.83, 18.36,-100.47, 13.50, -94.94 + / DATA ((REHING(I,J, 13),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / DATA ((REHING(I,J, 14),I=1,2),J=1, 31) / + 59.32,-148.96, 56.64,-141.40, 54.70,-138.86, 52.76,-136.19, + 50.75,-133.84, 50.12,-132.92, 49.98,-131.59, 49.58,-129.73, + 49.01,-127.38, 48.39,-125.60, 47.54,-124.02, 46.26,-123.07, + 44.55,-123.48, 42.82,-123.56, 41.08,-123.22, 39.41,-122.52, + 37.93,-121.66, 37.11,-121.05, 35.04,-119.70, 33.35,-118.30, + 31.99,-116.93, 29.27,-114.19, 26.96,-111.97, 24.60,-109.89, + 22.03,-107.27, 20.84,-105.28, 20.26,-103.91, 19.78,-103.39, + 18.71,-102.43, 18.28,-102.07, 13.50, -94.94 + / C C===2=== CODE GENERATED BY PROGRAM "ALL4" PLATE ROTATER: ===== C DATA NROMAT / 18/ DATA (AGEROT(I),I=1, 18) / + 0.00, 3.63, 10.30, 19.90, 25.80, 30.00, 35.60, 42.00, + 49.55, 58.90, 68.50, 72.40, 85.00, 119.00, 127.00, 135.00, + 145.00, 163.00 + / DATA ((ROMATF(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATF(I,J, 2),J=1,3),I=1,3) +/ 0.9984418, 0.0249586, 0.0499063, + -0.0236761, 0.9993781,-0.0261258, + -0.0505273, 0.0249035, 0.9984120/ DATA ((ROMATF(I,J, 3),J=1,3),I=1,3) +/ 0.9965000,-0.0015017, 0.0835752, + 0.0016967, 0.9999958,-0.0022638, + -0.0835716, 0.0023977, 0.9964986/ DATA ((ROMATF(I,J, 4),J=1,3),I=1,3) +/ 0.9870884,-0.0794135, 0.1391012, + 0.0779809, 0.9968305, 0.0157267, + -0.1399093,-0.0046764, 0.9901530/ DATA ((ROMATF(I,J, 5),J=1,3),I=1,3) +/ 0.9816186,-0.0953112, 0.1653471, + 0.0902718, 0.9952011, 0.0377464, + -0.1681514,-0.0221263, 0.9855123/ DATA ((ROMATF(I,J, 6),J=1,3),I=1,3) +/ 0.9772222,-0.1307292, 0.1671685, + 0.1217395, 0.9905611, 0.0629824, + -0.1738244,-0.0411969, 0.9839141/ DATA ((ROMATF(I,J, 7),J=1,3),I=1,3) +/ 0.9643680,-0.2176023, 0.1504717, + 0.2023463, 0.9730743, 0.1103661, + -0.1704363,-0.0759863, 0.9824339/ DATA ((ROMATF(I,J, 8),J=1,3),I=1,3) +/ 0.9355122,-0.3127865, 0.1642541, + 0.2875628, 0.9442505, 0.1603019, + -0.2052376,-0.1027311, 0.9733049/ DATA ((ROMATF(I,J, 9),J=1,3),I=1,3) +/ 0.8698806,-0.4633711, 0.1690941, + 0.4200012, 0.8755688, 0.2386968, + -0.2586591,-0.1366181, 0.9562580/ DATA ((ROMATF(I,J, 10),J=1,3),I=1,3) +/ 0.7665346,-0.5965531, 0.2377952, + 0.4980173, 0.7859663, 0.3663787, + -0.4054641,-0.1624160, 0.8995655/ DATA ((ROMATF(I,J, 11),J=1,3),I=1,3) +/ 0.6799753,-0.6748897, 0.2866260, + 0.4922036, 0.7098752, 0.5037958, + -0.5434762,-0.2014907, 0.8148823/ DATA ((ROMATF(I,J, 12),J=1,3),I=1,3) +/ 0.6364845,-0.7003338, 0.3231361, + 0.4905679, 0.6908776, 0.5310636, + -0.5951703,-0.1794939, 0.7832956/ DATA ((ROMATF(I,J, 13),J=1,3),I=1,3) +/ 0.5407817,-0.7359961, 0.4072609, + 0.3967867, 0.6501144, 0.6480033, + -0.7416956,-0.1888330, 0.6436048/ DATA ((ROMATF(I,J, 14),J=1,3),I=1,3) +/ 0.1260393,-0.9004962, 0.4161935, + 0.4084943, 0.4294313, 0.8054301, + -0.9040152, 0.0684970, 0.4219739/ DATA ((ROMATF(I,J, 15),J=1,3),I=1,3) +/ 0.0432563,-0.8638376, 0.5019060, + 0.3372753, 0.4855096, 0.8065493, + -0.9404098, 0.1343924, 0.3123534/ DATA ((ROMATF(I,J, 16),J=1,3),I=1,3) +/ -0.0372843,-0.8243719, 0.5648155, + 0.2585098, 0.5380124, 0.8023162, + -0.9652870, 0.1759245, 0.1930498/ DATA ((ROMATF(I,J, 17),J=1,3),I=1,3) +/ -0.0857564,-0.7854440, 0.6129592, + 0.2832710, 0.5706134, 0.7708135, + -0.9551961, 0.2397366, 0.1735606/ DATA ((ROMATF(I,J, 18),J=1,3),I=1,3) +/ -0.3959168,-0.6532624, 0.6453629, + 0.3365481, 0.5506653, 0.7638706, + -0.8543893, 0.5196268, 0.0018373/ DATA ((ROMATK(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATK(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATK(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATK(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATK(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATK(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATK(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATK(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATK(I,J, 9),J=1,3),I=1,3) +/ 0.8926937, 0.3237427, 0.3135092, + -0.3673854, 0.9256842, 0.0902017, + -0.2610084,-0.1957012, 0.9452911/ DATA ((ROMATK(I,J, 10),J=1,3),I=1,3) +/ 0.8382884, 0.2792339, 0.4682950, + -0.4014298, 0.8973089, 0.1835486, + -0.3689522,-0.3418544, 0.8642969/ DATA ((ROMATK(I,J, 11),J=1,3),I=1,3) +/ 0.7479138, 0.2368386, 0.6201060, + -0.4491286, 0.8684335, 0.2100139, + -0.4887816,-0.4355798, 0.7558849/ DATA ((ROMATK(I,J, 12),J=1,3),I=1,3) +/ 0.7069741, 0.2202590, 0.6720657, + -0.4550582, 0.8691026, 0.1938600, + -0.5413948,-0.4428831, 0.7146643/ DATA ((ROMATK(I,J, 13),J=1,3),I=1,3) +/ 0.4927713, 0.2023760, 0.8462971, + -0.5685837, 0.8111188, 0.1371042, + -0.6587012,-0.5487522, 0.5147643/ DATA ((ROMATK(I,J, 14),J=1,3),I=1,3) +/ 0.2884439,-0.0305855, 0.9570071, + -0.2699646, 0.9563414, 0.1119320, + -0.9186499,-0.2906443, 0.2675945/ DATA ((ROMATK(I,J, 15),J=1,3),I=1,3) +/ 0.1826985, 0.0447444, 0.9821491, + -0.2405134, 0.9706448, 0.0005196, + -0.9532956,-0.2363152, 0.1880977/ DATA ((ROMATK(I,J, 16),J=1,3),I=1,3) +/ 0.0730065, 0.1148067, 0.9907003, + -0.2118030, 0.9724770,-0.0970868, + -0.9745805,-0.2027456, 0.0953141/ DATA ((ROMATK(I,J, 17),J=1,3),I=1,3) +/ 0.0737035, 0.1703374, 0.9826242, + -0.1573972, 0.9749421,-0.1572000, + -0.9847798,-0.1430762, 0.0986680/ DATA ((ROMATK(I,J, 18),J=1,3),I=1,3) +/ -0.0087966, 0.2534258, 0.9673132, + 0.1625878, 0.9548408,-0.2486796, + -0.9866534, 0.1550863,-0.0496027/ DATA ((ROMATP(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATP(I,J, 2),J=1,3),I=1,3) +/ 0.9987488, 0.0373617, 0.0332375, + -0.0375750, 0.9992768, 0.0058163, + -0.0329962,-0.0070580, 0.9994305/ DATA ((ROMATP(I,J, 3),J=1,3),I=1,3) +/ 0.9896211, 0.1192692, 0.0801546, + -0.1217560, 0.9921963, 0.0268703, + -0.0763243,-0.0363507, 0.9964201/ DATA ((ROMATP(I,J, 4),J=1,3),I=1,3) +/ 0.9764168, 0.1700087, 0.1330684, + -0.1745946, 0.9843599, 0.0235017, + -0.1269917,-0.0461805, 0.9908282/ DATA ((ROMATP(I,J, 5),J=1,3),I=1,3) +/ 0.9621986, 0.2228397, 0.1565766, + -0.2303865, 0.9725862, 0.0315939, + -0.1452439,-0.0664726, 0.9871603/ DATA ((ROMATP(I,J, 6),J=1,3),I=1,3) +/ 0.9499563, 0.2615878, 0.1707477, + -0.2714726, 0.9617367, 0.0369465, + -0.1545496,-0.0814509, 0.9846218/ DATA ((ROMATP(I,J, 7),J=1,3),I=1,3) +/ 0.9309399, 0.3084813, 0.1954228, + -0.3219432, 0.9458911, 0.0405280, + -0.1723465,-0.1006442, 0.9798813/ DATA ((ROMATP(I,J, 8),J=1,3),I=1,3) +/ 0.9128593, 0.3438594, 0.2201101, + -0.3608459, 0.9317248, 0.0409754, + -0.1909923,-0.1168305, 0.9746140/ DATA ((ROMATP(I,J, 9),J=1,3),I=1,3) +/ 0.9036663, 0.3323698, 0.2700321, + -0.3557910, 0.9336445, 0.0414807, + -0.2383270,-0.1335597, 0.9619573/ DATA ((ROMATP(I,J, 10),J=1,3),I=1,3) +/ 0.8783061, 0.3137228, 0.3607716, + -0.3583550, 0.9314973, 0.0624035, + -0.3164804,-0.1840937, 0.9305640/ DATA ((ROMATP(I,J, 11),J=1,3),I=1,3) +/ 0.8133826, 0.3327699, 0.4771508, + -0.4012021, 0.9148389, 0.0458976, + -0.4212428,-0.2287661, 0.8776220/ DATA ((ROMATP(I,J, 12),J=1,3),I=1,3) +/ 0.7885006, 0.3410243, 0.5118291, + -0.4008002, 0.9161383, 0.0070450, + -0.4665038,-0.2106962, 0.8590583/ DATA ((ROMATP(I,J, 13),J=1,3),I=1,3) +/ 0.6594428, 0.4211499, 0.6227100, + -0.4718215, 0.8767433,-0.0933034, + -0.5852515,-0.2322797, 0.7768697/ DATA ((ROMATP(I,J, 14),J=1,3),I=1,3) +/ 0.5735050, 0.5730298, 0.5854303, + -0.4726608, 0.8151487,-0.3348495, + -0.6690916,-0.0846720, 0.7383407/ DATA ((ROMATP(I,J, 15),J=1,3),I=1,3) +/ 0.5466521, 0.6209800, 0.5617428, + -0.4979524, 0.7804186,-0.3781402, + -0.6732122,-0.0730101, 0.7358360/ DATA ((ROMATP(I,J, 16),J=1,3),I=1,3) +/ 0.5130962, 0.6671163, 0.5400814, + -0.5285266, 0.7413454,-0.4136018, + -0.6763074,-0.0732298, 0.7329704/ DATA ((ROMATP(I,J, 17),J=1,3),I=1,3) +/ 0.5677590, 0.7006614, 0.4321147, + -0.5501299, 0.7134408,-0.4340037, + -0.6123779, 0.0086904, 0.7905173/ DATA ((ROMATP(I,J, 18),J=1,3),I=1,3) +/ 0.7427920, 0.5855252, 0.3246846, + -0.3852086, 0.7703925,-0.5080448, + -0.5476077, 0.2523004, 0.7977908/ DATA ((ROMATV(I,J, 1),J=1,3),I=1,3) +/ 1.0000000, 0.0000000, 0.0000000, + 0.0000000, 1.0000000, 0.0000000, + 0.0000000, 0.0000000, 1.0000000/ DATA ((ROMATV(I,J, 2),J=1,3),I=1,3) +/ 0.9993297, 0.0051820, 0.0362338, + -0.0047712, 0.9999232,-0.0114144, + -0.0362902, 0.0112339, 0.9992780/ DATA ((ROMATV(I,J, 3),J=1,3),I=1,3) +/ 0.9966072,-0.0024635, 0.0822646, + 0.0025242, 0.9999963,-0.0006345, + -0.0822628, 0.0008400, 0.9966100/ DATA ((ROMATV(I,J, 4),J=1,3),I=1,3) +/ 0.9874673,-0.0822613, 0.1346872, + 0.0813513, 0.9966096, 0.0122550, + -0.1352387,-0.0011445, 0.9908120/ DATA ((ROMATV(I,J, 5),J=1,3),I=1,3) +/ 0.9769385,-0.0981460, 0.1896242, + 0.0957089, 0.9951658, 0.0219901, + -0.1908659,-0.0033342, 0.9816099/ DATA ((ROMATV(I,J, 6),J=1,3),I=1,3) +/ 0.9672080,-0.1004198, 0.2332878, + 0.0970278, 0.9949411, 0.0260009, + -0.2347188,-0.0025129, 0.9720595/ DATA ((ROMATV(I,J, 7),J=1,3),I=1,3) +/ 0.9578496,-0.1985734, 0.2075841, + 0.1860558, 0.9794068, 0.0783809, + -0.2188739,-0.0364552, 0.9750712/ DATA ((ROMATV(I,J, 8),J=1,3),I=1,3) +/ 0.9285972,-0.3330147, 0.1637273, + 0.3143928, 0.9404002, 0.1296231, + -0.1971359,-0.0688933, 0.9779518/ DATA ((ROMATV(I,J, 9),J=1,3),I=1,3) +/ 0.8519540,-0.5116365, 0.1113576, + 0.4857856, 0.8516892, 0.1965587, + -0.1954090,-0.1133634, 0.9741470/ DATA ((ROMATV(I,J, 10),J=1,3),I=1,3) +/ 0.7341714,-0.6763662, 0.0593198, + 0.6286086, 0.7101420, 0.3170907, + -0.2565954,-0.1955106, 0.9465370/ DATA ((ROMATV(I,J, 11),J=1,3),I=1,3) +/ 0.6687082,-0.7369352, 0.0987580, + 0.6230298, 0.6278643, 0.4664944, + -0.4057837,-0.2504201, 0.8789921/ DATA ((ROMATV(I,J, 12),J=1,3),I=1,3) +/ 0.6332583,-0.7620972, 0.1348656, + 0.6199963, 0.6038375, 0.5009806, + -0.4632338,-0.2336346, 0.8548840/ DATA ((ROMATV(I,J, 13),J=1,3),I=1,3) +/ 0.5726639,-0.7899240, 0.2192550, + 0.5270615, 0.5596170, 0.6395554, + -0.6279004,-0.2506902, 0.7368125/ DATA ((ROMATV(I,J, 14),J=1,3),I=1,3) +/ 0.1862030,-0.9539652, 0.2351070, + 0.4969981, 0.2978723, 0.8150220, + -0.8475366,-0.0349119, 0.5295847/ DATA ((ROMATV(I,J, 15),J=1,3),I=1,3) +/ 0.1202118,-0.9349756, 0.3337152, + 0.4187091, 0.3525420, 0.8368945, + -0.9001268, 0.0391250, 0.4338636/ DATA ((ROMATV(I,J, 16),J=1,3),I=1,3) +/ 0.0559588,-0.9094425, 0.4120423, + 0.3322897, 0.4061266, 0.8512579, + -0.9415139, 0.0892823, 0.3249255/ DATA ((ROMATV(I,J, 17),J=1,3),I=1,3) +/ 0.0035101,-0.8845617, 0.4664051, + 0.3494043, 0.4380954, 0.8282415, + -0.9369633, 0.1600573, 0.3106084/ DATA ((ROMATV(I,J, 18),J=1,3),I=1,3) +/ -0.3217998,-0.7897338, 0.5222647, + 0.3520011, 0.4122773, 0.8403078, + -0.8789400, 0.4542502, 0.1453171/ DATA NUMVEL / 17/ DATA (AGEVEL(I),I=1, 17) / + 1.81, 6.97, 15.10, 22.85, 27.90, 32.80, 38.80, 45.77, + 54.22, 63.70, 70.45, 78.70, 102.00, 123.00, 131.00, 140.00, + 154.00 + / DATA (OMEGAF(I, 1),I=1,3) + / 2.22436E-16, 4.37785E-16,-2.11997E-16/ DATA (OMEGAF(I, 2),I=1,3) + /-1.15243E-16, 1.59143E-16, 1.18424E-16/ DATA (OMEGAF(I, 3),I=1,3) + /-5.20186E-17, 1.86928E-16, 2.53471E-16/ DATA (OMEGAF(I, 4),I=1,3) + /-1.06009E-16, 1.52830E-16, 7.04799E-17/ DATA (OMEGAF(I, 5),I=1,3) + /-1.88225E-16, 3.57680E-17, 2.41271E-16/ DATA (OMEGAF(I, 6),I=1,3) + /-2.80863E-16,-4.69432E-17, 4.60480E-16/ DATA (OMEGAF(I, 7),I=1,3) + /-2.23587E-16, 1.34246E-16, 4.59035E-16/ DATA (OMEGAF(I, 8),I=1,3) + /-3.01794E-16, 1.52210E-16, 6.43195E-16/ DATA (OMEGAF(I, 9),I=1,3) + /-2.67001E-16, 4.56656E-16, 4.83609E-16/ DATA (OMEGAF(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAF(I, 11),I=1,3) + /-7.69435E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAF(I, 12),I=1,3) + /-1.10799E-16, 4.93623E-16, 8.32111E-17/ DATA (OMEGAF(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAF(I, 14),I=1,3) + / 3.42999E-16, 4.32696E-16, 1.46227E-16/ DATA (OMEGAF(I, 15),I=1,3) + / 2.93430E-16, 4.47830E-16, 9.47212E-17/ DATA (OMEGAF(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAF(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAK(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAK(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAK(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAK(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAK(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAK(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAK(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAK(I, 8),I=1,3) + /-3.42895E-16, 3.07318E-16,-7.84280E-18/ DATA (OMEGAK(I, 9),I=1,3) + /-5.24123E-16, 4.21964E-16,-6.28934E-17/ DATA (OMEGAK(I, 10),I=1,3) + /-3.47853E-16, 5.17207E-16,-6.26469E-17/ DATA (OMEGAK(I, 11),I=1,3) + /-1.29789E-16, 5.39917E-16, 7.00136E-17/ DATA (OMEGAK(I, 12),I=1,3) + /-2.25126E-16, 6.46717E-16,-2.10399E-16/ DATA (OMEGAK(I, 13),I=1,3) + /-8.79291E-17, 2.40344E-16, 3.43456E-16/ DATA (OMEGAK(I, 14),I=1,3) + / 3.42972E-16, 4.32656E-16, 1.46203E-16/ DATA (OMEGAK(I, 15),I=1,3) + / 2.93406E-16, 4.47800E-16, 9.47100E-17/ DATA (OMEGAK(I, 16),I=1,3) + / 1.91374E-16, 2.29230E-17, 1.74145E-16/ DATA (OMEGAK(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ DATA (OMEGAP(I, 1),I=1,3) + /-5.61048E-17, 2.88638E-16,-3.26565E-16/ DATA (OMEGAP(I, 2),I=1,3) + /-1.17638E-16, 2.14906E-16,-3.98084E-16/ DATA (OMEGAP(I, 3),I=1,3) + /-1.50584E-17, 1.75514E-16,-1.72060E-16/ DATA (OMEGAP(I, 4),I=1,3) + /-6.85319E-17, 1.16433E-16,-3.03108E-16/ DATA (OMEGAP(I, 5),I=1,3) + /-6.64486E-17, 9.50677E-17,-3.17342E-16/ DATA (OMEGAP(I, 6),I=1,3) + /-6.16534E-17, 1.29853E-16,-2.94295E-16/ DATA (OMEGAP(I, 7),I=1,3) + /-4.48367E-17, 1.16808E-16,-2.00231E-16/ DATA (OMEGAP(I, 8),I=1,3) + /-7.95765E-17, 2.01210E-16, 3.16566E-17/ DATA (OMEGAP(I, 9),I=1,3) + /-1.82793E-16, 2.78850E-16, 6.21172E-18/ DATA (OMEGAP(I, 10),I=1,3) + /-1.10363E-16, 4.11618E-16,-1.28934E-16/ DATA (OMEGAP(I, 11),I=1,3) + / 1.61156E-16, 4.19784E-16, 1.56999E-17/ DATA (OMEGAP(I, 12),I=1,3) + / 7.46968E-17, 4.23581E-16,-2.19155E-16/ DATA (OMEGAP(I, 13),I=1,3) + / 2.04277E-16, 1.08618E-16,-2.84094E-17/ DATA (OMEGAP(I, 14),I=1,3) + / 1.92305E-16, 3.73766E-17,-1.42336E-16/ DATA (OMEGAP(I, 15),I=1,3) + / 1.61534E-16, 3.43348E-17,-1.77105E-16/ DATA (OMEGAP(I, 16),I=1,3) + / 2.87845E-16,-2.68429E-16, 6.23380E-17/ DATA (OMEGAP(I, 17),I=1,3) + / 2.19652E-16,-7.13669E-17, 4.34363E-16/ DATA (OMEGAV(I, 1),I=1,3) + / 9.86981E-17, 3.16045E-16,-4.33668E-17/ DATA (OMEGAV(I, 2),I=1,3) + /-5.14985E-17, 2.19222E-16, 3.33668E-17/ DATA (OMEGAV(I, 3),I=1,3) + /-3.52269E-17, 1.75936E-16, 2.61668E-16/ DATA (OMEGAV(I, 4),I=1,3) + /-2.56065E-17, 3.02977E-16, 8.26955E-17/ DATA (OMEGAV(I, 5),I=1,3) + / 2.38990E-18, 3.39059E-16, 1.81821E-17/ DATA (OMEGAV(I, 6),I=1,3) + /-3.14872E-16,-1.02187E-16, 5.04872E-16/ DATA (OMEGAV(I, 7),I=1,3) + /-3.01822E-16,-1.44934E-16, 6.45606E-16/ DATA (OMEGAV(I, 8),I=1,3) + /-3.48720E-16,-8.07761E-17, 7.85876E-16/ DATA (OMEGAV(I, 9),I=1,3) + /-4.42586E-16, 1.09988E-16, 6.53606E-16/ DATA (OMEGAV(I, 10),I=1,3) + /-2.89517E-16, 4.76875E-16, 2.51810E-16/ DATA (OMEGAV(I, 11),I=1,3) + /-7.83352E-20, 4.51192E-16, 3.14338E-16/ DATA (OMEGAV(I, 12),I=1,3) + /-1.10796E-16, 4.93633E-16, 8.32232E-17/ DATA (OMEGAV(I, 13),I=1,3) + /-8.79293E-17, 2.40343E-16, 3.43456E-16/ DATA (OMEGAV(I, 14),I=1,3) + / 3.42996E-16, 4.32686E-16, 1.46215E-16/ DATA (OMEGAV(I, 15),I=1,3) + / 2.93417E-16, 4.47842E-16, 9.47149E-17/ DATA (OMEGAV(I, 16),I=1,3) + / 1.91442E-16, 2.29329E-17, 1.74204E-16/ DATA (OMEGAV(I, 17),I=1,3) + / 1.66065E-16, 2.61346E-16, 5.23447E-16/ C C===3=== DATA MODIFIED BY PROGRAM MAPPER ========== C C DATA NTAPES/ 20/,NTAPP1/ 21/,NKV3J/ 25/,NVF3J/ 10/ C C C DATA ((REKV3J(K,I),K=1,3),I=1, 15) / + 48.02,-132.16, 56., + 49.33,-132.96, 12., + 49.33,-132.96, 12., + 48.01,-132.01, 11., + 47.39,-130.70, 10., + 45.93,-130.92, 10., + 44.32,-127.85, 8., + 41.83,-123.69, 5., + 41.25,-122.81, -14., + 41.25,-122.81, -14., + 41.25,-122.81, -22., + 40.05,-122.54, -22., + 38.85,-122.28, -22., + 37.90,-122.09, -22., + 36.42,-122.04, -27. +/ DATA ((REKV3J(K,I),K=1,3),I=16,25) / + 35.29,-121.58, -30., + 33.41,-121.23, -33., + 30.61,-118.12, -36., + 29.73,-117.83, -39., + 26.99,-113.59, -39., + 19.30,-103.73, -46., + 15.16, -99.67, 33., + 12.16, -99.50, 33., + 9.74, -97.46, 32., + 8.54, -96.87, 31. +/ DATA ((REVF3J(K,I),K=1,3),I=1, 10) / + 28.05,-115.85, 45., + 26.08,-113.70, 43., + 26.14,-112.87, 30., + 26.14,-112.87, 30., + 25.75,-112.18, 29., + 24.61,-111.01, 45., + 24.23,-111.46, 59., + 25.26,-112.76, 36., + 1.70, -92.72, 27., + 1.70, -92.72, 27. +/ DATA (AGEKV(I),I=1, 25) / + 0.00, 10.00, 25.00, 30.00, 35.00, 40.00, 45.00, 50.00, + 51.00, 52.00, 53.00, 54.00, 55.00, 56.00, 57.00, 58.00, + 59.00, 60.00, 61.00, 62.00, 63.00, 64.00, 70.00, 80.00, + 85.00 +/ DATA (AGEVF(I),I=1, 10) / + 0.00, 30.00, 35.00, 40.00, 45.00, 50.00, 55.00, 59.00, + 60.00, 85.00 +/ C C C DATA (NPFZ(I),I=1, 21) / + 7, 6, 12, 13, 14, 18, 18, 20, 16, 16, 19, 13, 14, 15, 16, + 13, 14, 2, 15, 9, 4 +/ DATA (TAGFZ(K, 1),K=1, 7)/ +'F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 1),K=1, 7) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 1),K=1,2),L=1, 7)/ + 14.85,-102.14, 13.45, -88.33, 14.58, -78.99, 16.96, -69.97, + 18.18, -58.64, 18.35, -52.40, 16.02, -31.04 +/ DATA (TAGFZ(K, 2),K=1, 6)/ +'F','F','F','F','F','F' +/ DATA (AGEFZ(K, 2),K=1, 6) / +999.00,999.00,999.00,999.00, 99.00, 99.00 +/ DATA ((FRACZN(K,L, 2),K=1,2),L=1, 6)/ + 18.50,-102.24, 18.23, -96.47, 18.92, -86.37, 20.51, -79.06, + 23.96, -50.14, 20.97, -25.60 +/ DATA (TAGFZ(K, 3),K=1, 12)/ +'F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 3),K=1, 12) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 3),K=1,2),L=1, 12)/ + 22.79,-109.08, 21.70,-105.68, 24.61,-101.95, 24.72, -99.36, + 24.98, -91.24, 26.22, -83.42, 26.90, -75.26, 27.60, -68.02, + 28.57, -59.45, 29.26, -52.83, 23.88, -51.18, 20.97, -25.60 +/ DATA (TAGFZ(K, 4),K=1, 13)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 4),K=1, 13) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 4),K=1,2),L=1, 13)/ + 27.82,-116.19, 25.02,-111.50, 24.46,-105.70, 24.61,-101.95, + 24.72, -99.36, 24.98, -91.24, 26.22, -83.42, 26.90, -75.26, + 27.60, -68.02, 28.57, -59.45, 29.26, -52.83, 23.88, -51.18, + 20.97, -25.60 +/ DATA (TAGFZ(K, 5),K=1, 14)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEFZ(K, 5),K=1, 14) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 5),K=1,2),L=1, 14)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 31.25,-101.62, 31.91, -94.06, 32.63, -88.76, 33.50, -81.67, + 33.67, -74.35, 33.99, -66.95, 34.67, -59.52, 34.95, -54.76, + 23.88, -51.18, 20.97, -25.60 +/ DATA (TAGFZ(K, 6),K=1, 18)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F' +/ DATA (AGEFZ(K, 6),K=1, 18) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00 +/ DATA ((FRACZN(K,L, 6),K=1,2),L=1, 18)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 31.25,-101.62, 31.91, -94.06, 32.63, -88.76, 33.50, -81.67, + 33.67, -74.35, 33.99, -66.95, 34.67, -59.52, 34.95, -54.76, + 29.24, -52.74, 29.00, -50.88, 27.34, -43.02, 23.63, -34.70, + 22.41, -31.83, 20.97, -25.60 +/ DATA (TAGFZ(K, 7),K=1, 18)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F' +/ DATA (AGEFZ(K, 7),K=1, 18) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00 +/ DATA ((FRACZN(K,L, 7),K=1,2),L=1, 18)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 33.14,-101.36, 35.05, -96.68, 36.71, -88.89, 37.85, -82.76, + 38.13, -73.94, 37.64, -61.74, 37.17, -58.77, 34.95, -54.76, + 29.24, -52.74, 29.03, -50.81, 27.34, -43.02, 23.63, -34.70, + 22.41, -31.83, 20.97, -25.60 +/ DATA (TAGFZ(K, 8),K=1, 20)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F','F', +'F','F','F','F','F' +/ DATA (AGEFZ(K, 8),K=1, 20) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 8),K=1,2),L=1, 20)/ + 27.82,-116.19, 25.02,-111.50, 24.87,-108.65, 31.41,-106.08, + 33.14,-101.36, 35.05, -96.68, 36.71, -88.89, 37.85, -82.76, + 38.13, -73.94, 42.88, -64.20, 43.02, -61.57, 42.96, -59.18, + 39.07, -56.76, 34.95, -54.76, 29.24, -52.74, 29.03, -50.81, + 27.34, -43.02, 23.63, -34.70, 22.41, -31.83, 20.97, -25.60 +/ DATA (TAGFZ(K, 9),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEFZ(K, 9),K=1, 16) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 9),K=1,2),L=1, 16)/ + 40.23,-127.34, 40.23,-126.02, 38.68,-123.96, 38.42,-119.01, + 38.54,-115.83, 38.43,-112.65, 37.98,-108.57, 35.87,-103.22, + 32.52,-101.45, 33.29, -95.67, 33.50, -92.15, 34.08, -87.66, + 34.87, -81.11, 36.30, -72.68, 42.44, -64.58, 43.18, -58.92 +/ DATA (TAGFZ(K, 10),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEFZ(K, 10),K=1, 16) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 10),K=1,2),L=1, 16)/ + 40.23,-127.34, 40.23,-126.02, 38.68,-123.96, 38.42,-119.01, + 38.54,-115.83, 38.43,-112.65, 37.79,-108.25, 35.86,-103.28, + 35.04,-100.02, 35.85, -96.03, 35.86, -91.85, 36.10, -88.03, + 37.41, -81.74, 39.62, -74.33, 42.44, -64.58, 43.18, -58.92 +/ DATA (TAGFZ(K, 11),K=1, 19)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V','V','V','V' +/ DATA (AGEFZ(K, 11),K=1, 19) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 11),K=1,2),L=1, 19)/ + 40.23,-127.34, 40.23,-126.02, 38.68,-123.96, 38.42,-119.01, + 38.54,-115.83, 38.43,-112.65, 37.79,-108.25, 37.77,-102.97, + 37.71, -98.10, 37.70, -94.55, 37.83, -91.31, 38.45, -83.72, + 39.29, -82.15, 41.03, -79.69, 41.20, -75.80, 43.06, -66.71, + 43.68, -63.22, 44.20, -60.23, 43.18, -58.92 +/ DATA (TAGFZ(K, 12),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 12),K=1, 13) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 12),K=1,2),L=1, 13)/ + 42.86,-126.48, 42.53,-124.84, 42.39,-123.83, 41.50,-119.02, + 41.88,-115.71, 41.90,-111.99, 41.29,-107.88, 40.67,-103.81, + 40.42, -97.63, 42.27, -90.61, 46.59, -69.00, 47.39, -63.98, + 43.88, -59.85 +/ DATA (TAGFZ(K, 13),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 13),K=1, 14) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 13),K=1,2),L=1, 14)/ + 44.04,-131.51, 42.86,-126.48, 42.53,-124.84, 42.39,-123.83, + 41.50,-119.02, 45.47,-114.02, 45.42,-108.55, 44.77,-103.42, + 44.50,-100.32, 40.42, -97.63, 42.27, -90.61, 46.59, -69.00, + 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 14),K=1, 15)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 14),K=1, 15) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 14),K=1,2),L=1, 15)/ + 49.15,-130.92, 49.01,-129.37, 48.41,-125.70, 49.64,-116.32, + 50.08,-113.29, 49.37,-109.57, 48.78,-104.69, 48.21, -97.40, + 47.75, -94.87, 47.28, -86.55, 46.77, -83.58, 47.70, -70.74, + 48.75, -66.00, 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 15),K=1, 16)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V','V', +'V' +/ DATA (AGEFZ(K, 15),K=1, 16) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 15),K=1,2),L=1, 16)/ + 49.99,-129.92, 50.40,-127.83, 51.58,-125.71, 53.96,-120.53, + 54.07,-119.53, 53.79,-112.80, 52.80,-105.15, 52.43, -97.63, + 50.82, -91.98, 49.03, -90.02, 47.28, -86.55, 46.77, -83.58, + 47.70, -70.74, 48.75, -66.00, 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 16),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 16),K=1, 13) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 16),K=1,2),L=1, 13)/ + 49.99,-129.92, 50.40,-127.83, 51.58,-125.71, 53.96,-120.53, + 54.07,-119.53, 55.84,-113.32, 55.68,-104.45, 54.40, -83.66, + 52.84, -80.13, 47.70, -70.74, 48.75, -66.00, 47.39, -63.98, + 43.88, -59.85 +/ DATA (TAGFZ(K, 17),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEFZ(K, 17),K=1, 14) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 17),K=1,2),L=1, 14)/ + 49.99,-129.92, 50.40,-127.83, 51.58,-125.71, 53.96,-120.53, + 54.07,-119.53, 55.84,-113.32, 57.43,-104.59, 56.93, -98.28, + 54.40, -83.66, 54.00, -74.27, 52.44, -70.98, 48.75, -66.00, + 47.39, -63.98, 43.88, -59.85 +/ DATA (TAGFZ(K, 18),K=1, 2)/ +'K','K' +/ DATA (AGEFZ(K, 18),K=1, 2) / +999.00,999.00 +/ DATA ((FRACZN(K,L, 18),K=1,2),L=1, 2)/ + 46.50,-117.44, 41.33,-114.74 +/ DATA (TAGFZ(K, 19),K=1, 15)/ +'K','K','K','K','K','K','K','K','K','K','K','K','K','K','K' +/ DATA (AGEFZ(K, 19),K=1, 15) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00,999.00,999.00,999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 19),K=1,2),L=1, 15)/ + 56.25,-160.75, 59.67,-142.10, 60.76,-139.41, 63.24,-137.79, + 70.34,-143.21, 63.74,-134.83, 55.35,-124.00, 46.50,-117.44, + 45.56,-101.60, 44.04, -93.75, 43.58, -90.59, 42.85, -93.55, + 41.66,-100.53, 40.83,-114.46, 30.22, -97.48 +/ DATA (TAGFZ(K, 20),K=1, 9)/ +'K','K','K','K','K','K','K','K','K' +/ DATA (AGEFZ(K, 20),K=1, 9) / +999.00,999.00,999.00,999.00,999.00,999.00,999.00,999.00, +999.00 +/ DATA ((FRACZN(K,L, 20),K=1,2),L=1, 9)/ + 55.63,-160.57, 64.90,-174.23, 73.65,-166.35, 70.34,-143.21, + 64.60,-134.40, 55.35,-124.00, 46.50,-117.44, 43.44, -90.90, + 38.95, -80.24 +/ DATA (TAGFZ(K, 21),K=1, 4)/ +'K','K','K','K' +/ DATA (AGEFZ(K, 21),K=1, 4) / +999.00,999.00,999.00,999.00 +/ DATA ((FRACZN(K,L, 21),K=1,2),L=1, 4)/ + 70.70,-170.78, 68.29, 47.63, 49.94, 3.74, 38.14, -79.72 +/ C C C DATA (NMAG(I),I=1, 20) / + 8, 11, 1, 12, 14, 10, 6, 1, 10, 14, 14, 6, 13, 12, 10, + 10, 1, 4, 9, 8 +/ DATA (TAGMAG(K, 1),K=1, 8)/ +'F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 1),K=1, 8) / + 0.00, 20.00, 35.60, 59.00, 77.00,126.00,158.00,175.00 +/ DATA (((REMAG(K,L,M, 1),K=1,2),L=1,2),M=1, 8) / + 18.56,-102.15, 15.69,-102.16, 17.94, -96.02, 14.93, -96.40, + 18.12, -92.07, 14.51, -92.31, 20.95, -75.38, 16.58, -74.58, + 22.88, -67.14, 17.81, -66.34, 23.27, -55.51, 18.18, -55.41, + 22.62, -42.18, 17.60, -42.73, 21.58, -30.28, 16.93, -31.59 +/ DATA (TAGMAG(K, 2),K=1, 11)/ +'F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 2),K=1, 11) / + 0.00, 9.50, 20.00, 27.50, 35.70, 59.00, 63.40, 67.00, + 77.00,126.00,150.00 +/ DATA (((REMAG(K,L,M, 2),K=1,2),L=1,2),M=1, 11) / + 22.94,-108.62, 19.57,-110.03, 20.73,-106.17, 18.90,-106.87, + 25.27,-102.94, 18.54,-102.97, 24.14,-101.56, 18.49,-101.64, + 24.11, -97.49, 18.53, -96.65, 25.83, -82.46, 21.44, -81.63, + 26.16, -80.77, 21.81, -79.71, 26.56, -80.43, 22.47, -79.16, + 26.83, -75.41, 23.15, -73.96, 27.75, -64.59, 24.02, -63.72, + 24.35, -51.14, 23.84, -51.61 +/ DATA (TAGMAG(K, 3),K=1, 1)/ +' ' +/ DATA (AGEMAG(K, 3),K=1, 1) / + 1.00 +/ DATA (((REMAG(K,L,M, 3),K=1,2),L=1,2),M=1, 1) / + -19.43,-148.18, -19.43, -61.82 +/ DATA (TAGMAG(K, 4),K=1, 12)/ +'F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 4),K=1, 12) / + 9.50, 20.00, 27.50, 35.70, 49.30, 59.00, 63.40, 67.00, + 77.00,126.00,150.00,158.00 +/ DATA (((REMAG(K,L,M, 4),K=1,2),L=1,2),M=1, 12) / + 25.31,-108.39, 24.78,-108.37, 31.00,-106.14, 24.87,-105.49, + 31.43,-103.56, 24.04,-103.46, 31.38, -99.00, 24.02, -98.31, + 31.79, -96.01, 24.87, -94.72, 32.55, -90.64, 25.62, -90.16, + 32.71, -88.50, 25.76, -88.05, 33.05, -87.18, 25.94, -86.84, + 33.50, -82.33, 26.27, -82.02, 33.55, -70.63, 28.86, -69.79, + 34.12, -58.08, 29.49, -57.53, 29.87, -52.81, 29.29, -53.33 +/ DATA (TAGMAG(K, 5),K=1, 14)/ +'F','F','F','F','F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 5),K=1, 14) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 77.00,126.00, +134.00,145.00, 63.00, 70.00, 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 5),K=1,2),L=1,2),M=1, 14) / + 31.79,-105.61, 31.33,-105.60, 32.92,-101.69, 31.43,-102.34, + 35.03, -96.52, 31.78, -96.40, 35.86, -92.66, 32.07, -92.63, + 37.00, -88.90, 32.71, -88.77, 37.71, -82.69, 33.09, -83.14, + 39.64, -74.13, 33.98, -74.48, 37.49, -61.88, 34.61, -62.56, + 37.06, -58.84, 35.72, -59.17, 35.06, -54.81, 34.80, -55.03, + 29.09, -51.09, 28.96, -52.66, 27.33, -42.94, 28.04, -52.02, + 23.76, -35.06, 25.63, -51.21, 22.46, -31.91, 22.25, -32.23 +/ DATA (TAGMAG(K, 6),K=1, 10)/ +'F','F','F','F','F','F','F','F','F','F' +/ DATA (AGEMAG(K, 6),K=1, 10) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 77.00,126.00, +134.00,145.00 +/ DATA (((REMAG(K,L,M, 6),K=1,2),L=1,2),M=1, 10) / + 31.79,-105.61, 31.33,-105.60, 32.92,-101.69, 31.43,-102.34, + 35.03, -96.52, 31.78, -96.40, 35.86, -92.66, 32.07, -92.63, + 37.00, -88.90, 32.71, -88.77, 37.71, -82.69, 33.09, -83.14, + 39.64, -74.13, 33.98, -74.48, 37.49, -61.88, 34.61, -62.56, + 37.06, -58.84, 35.72, -59.17, 35.06, -54.81, 34.80, -55.03 +/ DATA (TAGMAG(K, 7),K=1, 6)/ +'F','F','F','F','F','F' +/ DATA (AGEMAG(K, 7),K=1, 6) / + 80.00,119.00,126.00,134.00,142.00,145.00 +/ DATA (((REMAG(K,L,M, 7),K=1,2),L=1,2),M=1, 6) / + 38.41, -73.66, 38.02, -73.74, 42.86, -64.16, 37.77, -64.67, + 42.76, -61.27, 37.56, -62.75, 42.63, -58.05, 37.14, -59.29, + 38.53, -56.43, 36.04, -56.47, 35.06, -54.81, 34.80, -55.03 +/ DATA (TAGMAG(K, 8),K=1, 1)/ +' ' +/ DATA (AGEMAG(K, 8),K=1, 1) / + 1.00 +/ DATA (((REMAG(K,L,M, 8),K=1,2),L=1,2),M=1, 1) / + -19.43,-148.18, -19.43, -61.82 +/ DATA (TAGMAG(K, 9),K=1, 10)/ +'V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 9),K=1, 10) / + 20.00, 27.50, 27.50, 35.70, 42.00, 49.30, 59.00, 77.00, +119.00,126.00 +/ DATA (((REMAG(K,L,M, 9),K=1,2),L=1,2),M=1, 10) / + 37.79,-108.03, 37.41,-108.01, 37.61,-102.97, 36.01,-103.23, + 34.89,-100.23, 32.53,-101.45, 35.80, -95.98, 33.75, -95.69, + 35.91, -91.95, 33.90, -91.90, 36.09, -87.77, 34.12, -87.61, + 36.79, -81.49, 35.13, -81.34, 39.76, -73.75, 37.51, -73.24, + 42.89, -66.57, 42.23, -66.39, 43.69, -63.27, 42.89, -63.28 +/ DATA (TAGMAG(K, 10),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 10),K=1, 14) / + 20.00, 27.50, 35.70, 42.00, 49.30, 59.00, 63.40, 63.20, + 67.00, 77.00,119.00,126.00,134.00,140.00 +/ DATA (((REMAG(K,L,M, 10),K=1,2),L=1,2),M=1, 14) / + 37.79,-108.03, 37.41,-108.01, 37.61,-102.97, 36.01,-103.23, + 37.64, -97.96, 35.97, -98.10, 37.75, -94.67, 35.97, -94.69, + 37.72, -90.93, 36.00, -90.81, 38.38, -83.89, 36.73, -83.58, + 39.08, -82.19, 37.30, -81.95, 40.55, -80.73, 37.93, -80.73, + 41.06, -79.60, 38.27, -79.68, 41.15, -75.80, 39.05, -75.32, + 42.89, -66.57, 42.23, -66.39, 43.69, -63.27, 42.89, -63.28, + 44.12, -60.23, 43.16, -60.01, 43.44, -58.90, 43.03, -59.25 +/ DATA (TAGMAG(K, 11),K=1, 14)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 11),K=1, 14) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 59.00, 67.00, 77.00,126.00,134.00,142.00 +/ DATA (((REMAG(K,L,M, 11),K=1,2),L=1,2),M=1, 14) / + 42.80,-126.60, 40.17,-127.40, 42.45,-125.24, 40.18,-126.21, + 42.51,-123.83, 38.69,-124.00, 41.42,-118.95, 38.25,-119.07, + 41.80,-115.62, 38.70,-116.11, 41.73,-112.10, 38.61,-112.52, + 41.22,-108.00, 38.01,-108.00, 40.63,-103.87, 36.89,-103.78, + 40.11, -97.66, 36.61, -96.10, 41.28, -95.05, 37.77, -93.70, + 42.37, -89.93, 38.82, -88.54, 46.74, -67.31, 43.62, -66.65, + 47.13, -64.52, 43.92, -63.34, 44.44, -59.85, 43.90, -60.31 +/ DATA (TAGMAG(K, 12),K=1, 6)/ +'V','V','V','V','V','V' +/ DATA (AGEMAG(K, 12),K=1, 6) / + 20.00, 27.50, 35.70, 42.00, 49.30, 55.00 +/ DATA (((REMAG(K,L,M, 12),K=1,2),L=1,2),M=1, 6) / + 41.42,-118.95, 38.25,-119.07, 45.28,-113.55, 41.70,-114.19, + 45.66,-109.22, 41.61,-109.93, 45.23,-105.57, 41.19,-105.83, + 44.74,-102.25, 40.68,-101.27, 41.28, -97.71, 40.35, -97.82 +/ DATA (TAGMAG(K, 13),K=1, 13)/ +'V','V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 13),K=1, 13) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 59.00, 67.00, 77.00,126.00,138.00 +/ DATA (((REMAG(K,L,M, 13),K=1,2),L=1,2),M=1, 13) / + 47.52,-129.44, 44.01,-131.35, 47.85,-128.22, 44.65,-129.45, + 47.92,-125.54, 44.65,-125.76, 46.84,-119.55, 43.63,-119.79, + 49.83,-114.87, 45.98,-115.58, 49.89,-111.38, 45.89,-112.04, + 49.48,-107.86, 45.30,-108.35, 48.95,-104.30, 44.77,-103.58, + 48.49, -98.41, 41.04, -94.18, 48.61, -95.69, 41.87, -92.40, + 48.03, -89.23, 43.04, -87.07, 48.19, -69.04, 46.47, -68.60, + 47.91, -64.03, 47.09, -64.69 +/ DATA (TAGMAG(K, 14),K=1, 12)/ +'V','V','V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 14),K=1, 12) / + 0.00, 4.50, 9.50, 20.00, 27.50, 35.70, 42.00, 49.30, + 55.00, 60.00, 70.00, 80.00 +/ DATA (((REMAG(K,L,M, 14),K=1,2),L=1,2),M=1, 12) / + 49.95,-129.96, 49.31,-130.63, 50.47,-127.83, 49.04,-128.48, + 51.53,-125.42, 48.75,-125.65, 53.85,-120.86, 50.28,-120.71, + 53.84,-116.82, 50.00,-116.45, 53.79,-112.59, 50.21,-113.72, + 53.31,-108.95, 49.63,-109.89, 52.91,-105.16, 49.01,-105.38, + 52.35, -97.70, 50.29,-102.04, 50.89, -92.02, 48.29, -97.46, + 50.22, -85.37, 47.95, -94.94, 47.98, -87.21, 47.06, -87.52 +/ DATA (TAGMAG(K, 15),K=1, 10)/ +'V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 15),K=1, 10) / + 20.00, 27.50, 35.70, 42.00, 49.30, 55.00, 60.00, 70.00, + 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 15),K=1,2),L=1,2),M=1, 10) / + 54.36,-119.14, 53.89,-119.00, 55.81,-113.13, 53.94,-113.12, + 55.83,-108.54, 53.46,-109.23, 55.47,-104.55, 53.69,-106.77, + 54.74, -90.64, 52.76,-105.12, 54.29, -83.33, 52.27, -97.86, + 52.67, -80.56, 50.89, -92.02, 51.46, -76.45, 50.20, -85.38, + 48.43, -71.70, 47.38, -86.57, 48.19, -70.92, 47.62, -71.30 +/ DATA (TAGMAG(K, 16),K=1, 10)/ +'V','V','V','V','V','V','V','V','V','V' +/ DATA (AGEMAG(K, 16),K=1, 10) / + 27.50, 35.70, 42.00, 43.80, 49.30, 55.00, 60.00, 70.00, + 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 16),K=1,2),L=1,2),M=1, 10) / + 55.81,-113.13, 53.94,-113.12, 57.13,-107.59, 55.82,-107.83, + 56.87,-104.45, 55.55,-104.70, 56.92, -98.43, 55.82,-104.47, + 54.74, -90.64, 52.76,-105.12, 54.29, -83.33, 52.27, -97.86, + 53.99, -74.13, 52.62, -80.64, 52.69, -70.12, 51.31, -76.44, + 49.62, -66.86, 48.58, -72.30, 49.04, -66.19, 48.61, -66.52 +/ DATA (TAGMAG(K, 17),K=1, 1)/ +' ' +/ DATA (AGEMAG(K, 17),K=1, 1) / + 1.00 +/ DATA (((REMAG(K,L,M, 17),K=1,2),L=1,2),M=1, 1) / + -19.43,-148.18, -19.43, -61.82 +/ DATA (TAGMAG(K, 18),K=1, 4)/ +'K','K','K','K' +/ DATA (AGEMAG(K, 18),K=1, 4) / + 60.00, 70.00, 80.00, 85.00 +/ DATA (((REMAG(K,L,M, 18),K=1,2),L=1,2),M=1, 4) / + 41.90,-115.31, 41.00,-112.55, 42.23,-101.71, 42.77,-112.64, + 43.03, -93.70, 44.73,-113.87, 43.41, -90.97, 46.59,-115.84 +/ DATA (TAGMAG(K, 19),K=1, 9)/ +'K','K','K','K','K','K','K','K','K' +/ DATA (AGEMAG(K, 19),K=1, 9) / + 43.80, 49.30, 55.00, 60.00, 70.00, 80.00, 85.00,120.00, +126.00 +/ DATA (((REMAG(K,L,M, 19),K=1,2),L=1,2),M=1, 9) / + 59.09,-149.03, 59.89,-142.34, 58.82,-156.71, 60.77,-139.67, + 61.45,-156.85, 63.34,-138.15, 62.63,-158.20, 64.48,-142.39, + 63.87,-159.93, 65.64,-146.99, 64.97,-172.94, 67.91,-149.21, + 65.83,-173.24, 68.92,-150.89, 66.15,-173.52, 69.23,-149.53, + 70.48,-143.92, 69.56,-142.41 +/ DATA (TAGMAG(K, 20),K=1, 8)/ +'K','K','K','K','K','K','K','K' +/ DATA (AGEMAG(K, 20),K=1, 8) / +120.00,126.00,134.00,142.00,158.00,175.00,225.00,250.00 +/ DATA (((REMAG(K,L,M, 20),K=1,2),L=1,2),M=1, 8) / + 74.07,-164.86, 73.39,-162.42, 80.84, 164.16, 72.08,-152.08, + 82.40, 148.05, 68.93,-139.56, 83.24, 111.62, 64.66,-127.88, + 75.74,-125.97, 50.70,-118.40, 70.36, 46.54, 46.22,-101.71, + 61.75, 22.89, 42.39, -88.39, 50.97, 4.24, 39.88, -79.37 +/ 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=* //LKED1 EXEC PGM=IEWL,REGION=3500K,COND=(4,LT,FORT1),PARM='MAP,LIST' //SYSLIB DD DISP=(SHR,PASS),DSN=APP1.FORTVS.LIBRARY // DD DISP=(SHR,PASS),DSN=APP1.ESSLV // DD DISP=(SHR,PASS),DSN=APP1.GDDM4.LOAD //SYSLIN DD DSN=&&LOADSET,DISP=(OLD,DELETE) // DD DDNAME=SYSIN //SYSLMOD DD DISP=(NEW,CATLG),UNIT=DATA, // SPACE=(TRK,(20,20,1)),DSN=EFF9GPB.GDDMMOD(DRAW) //SYSIN DD * ENTRY MAIN INCLUDE SYSLIB(FSINN) INCLUDE SYSLIB(ADMLSYS1) /* //SYSPRINT DD SYSOUT=* //SYSUT1 DD UNIT=VIO,SPACE=(TRK,(5,5),,,ROUND) //FORT2 EXEC FORTVCL,LIBB='APP1.GDDM4.LOAD' C PROGRAM VIEW C C SHOW RESULTS OF PROGRAM "DRAW" ON THE IBM 3179-G COLOR TERMINAL C INCLUDES MENU OF SINGLE-LETTER COMMANDS TO CONTROL PLOT OPTIONS C LOGICAL BAR,FAILED,IMAGE,INVENT,MENU,STATES,TITLE INTEGER TSHIFT,VSHIFT CHARACTER*8 FILNAM CHARACTER*6 ALPHA CHARACTER*1 Z C C INITIALIZE GDDM C CALL FSINIT C C SUPRESS INTERUPT HANDLING (SO CALLS TO NON-EXISTENT FILES C AND DELETION OF NON-EXISTANT SEGMENTS WON'T CAUSE C MESSAGES ON THE SCREEN) C CALL FSEXIT(0,20) C C DEFAULT INITIALIZATION SECTION C SCALE=1.00 XRIGHT=11.0 XLEFT=0.0 YTOP=8.5 YBOT=0.0 IMAGE=.TRUE. INVENT=.TRUE. MENU=.TRUE. TITLE=.TRUE. BAR=.TRUE. STATES=.TRUE. FILNAM='V01T01S1' VSHIFT=0 TSHIFT=0 C C***** BEGINNING OF ENDLESS LOOP (UNTIL OPERATOR EXITS) ************* 100 CONTINUE C******************************************************************** C C BEGIN A NEW PAGE C CALL FSPCLR CALL GSSDEL(1) CALL GSSDEL(2) CALL GSSDEL(3) CALL GSSDEL(4) CALL GSSDEL(5) CALL GSSDEL(6) CALL GSSDEL(7) C IF (VSHIFT.NE.0.OR.TSHIFT.NE.0) THEN CALL SEARCH (INPUT,TSHIFT,VSHIFT, & MODIFY,FILNAM, & OUTPUT,FAILED) IF (FAILED) THEN CALL FSALRM CALL STOCK(FILNAM) CALL LOADIT (FILNAM, & XLEFT,XRIGHT,YTOP,YBOT, & .FALSE.,.FALSE.,.FALSE.,.TRUE.) CALL ASDFLD(3,3,1,1,29,2) CALL ASCPUT(3,29,'YOU REQUESTED COMMAND-STRING:') CALL ASDFLD(4,3,31,1,5,2) CALL ASCPUT(4,5,ALPHA) CALL ASDFLD(5,4,1,1,72,2) CALL ASCPUT(5,71,'BUT IMAGES FOR THE REQUESTED TIME OR V &ARIABLE WERE NOT FOUND IN ADMGDF.') CALL ASDFLD(6,5,1,1,26,2) CALL ASCPUT(6,26,'TRY A DIFFERENT COMMAND...') ELSE IF (INVENT) THEN CALL STOCK(FILNAM) CALL LOADIT (FILNAM, & XLEFT,XRIGHT,YTOP,YBOT, & .FALSE.,.FALSE.,.FALSE.,.TRUE.) ELSE CALL GSSDEL(5) CALL LOADIT (FILNAM, & XLEFT,XRIGHT,YTOP,YBOT, & BAR,IMAGE,STATES,TITLE) ENDIF ENDIF ELSE FAILED=.FALSE. IF (INVENT) THEN CALL STOCK(FILNAM) CALL LOADIT (FILNAM, & XLEFT,XRIGHT,YTOP,YBOT, & .FALSE.,.FALSE.,.FALSE.,.TRUE.) ELSE CALL LOADIT (FILNAM, & XLEFT,XRIGHT,YTOP,YBOT, & BAR,IMAGE,STATES,TITLE) ENDIF ENDIF 200 IF (MENU) CALL CHOICE IF (FAILED) THEN C C LABEL WITH VARIABLE AND TIME IDENTIFIERS C CALL ASDFLD(7,32,40,1,26,2) CALL ASCPUT(7,26,'CURRENT VARIABLE AND TIME:') CALL ASDFLD(8,32,67,1,6,2) CALL ASCPUT(8,6,FILNAM) ENDIF C C DEFINE DISPLAY-CONTROL-CHARACTER AREA AT LOWER RIGHT C CALL ASDFLD(2,32,74,1,7,0) 500 CALL ASCPUT(2,0,' ') CALL ASFCUR(2,1,1) CALL ASREAD(ITYPE,IVALUE,ICOUNT) C ----------------------------------------------------------- C THIS IS WHERE THE OUTPUT IS INSPECTED AND A RESPONSE MADE. CALL ASCGET(2,6,ALPHA) C ----------------------------------------------------------- C C CLEAR MESSAGE FIELDS (IF ANY) C CALL ASDFLD(3,0,0,0,0,0) CALL ASDFLD(4,0,0,0,0,0) CALL ASDFLD(5,0,0,0,0,0) CALL ASDFLD(6,0,0,0,0,0) CALL ASDFLD(7,0,0,0,0,0) CALL ASDFLD(8,0,0,0,0,0) C C COMMAND INTERPRETER SECTION C TSHIFT=0 VSHIFT=0 JTENS=0 DO 5000 ICHR=1,5 Z=ALPHA(ICHR:ICHR) IF (Z.EQ.'M'.OR.Z.EQ.'m') THEN MENU=.NOT.MENU JTENS=0 ELSE IF (Z.EQ.'I'.OR.Z.EQ.'i') THEN INVENT=.NOT.INVENT JTENS=0 ELSE IF (Z.EQ.'L'.OR.Z.EQ.'l') THEN STATES=.NOT.STATES JTENS=0 ELSE IF (Z.EQ.'G'.OR.Z.EQ.'g') THEN BAR=.NOT.BAR JTENS=0 ELSE IF (Z.EQ.'T'.OR.Z.EQ.'t') THEN TITLE=.NOT.TITLE JTENS=0 ELSE IF (Z.EQ.'X'.OR.Z.EQ.'x') THEN XC=(XLEFT+XRIGHT)/2. DX=XRIGHT-XC YC=(YTOP+YBOT)/2. DY=YTOP-YC XLEFT=XC-DX*0.8 XRIGHT=XC+DX*0.8 YTOP=YC+DY*0.8 YBOT=YC-DY*0.8 JTENS=0 ELSE IF (Z.EQ.'C'.OR.Z.EQ.'c') THEN XC=(XLEFT+XRIGHT)/2. DX=XRIGHT-XC YC=(YTOP+YBOT)/2. DY=YTOP-YC XLEFT=XC-DX*1.25 XRIGHT=XC+DX*1.25 YTOP=YC+DY*1.25 YBOT=YC-DY*1.25 JTENS=0 ELSE IF (Z.EQ.'N'.OR.Z.EQ.'n') THEN YC=(YTOP+YBOT)/2. DY=YTOP-YC YTOP=YTOP+0.20*DY YBOT=YBOT+0.20*DY JTENS=0 ELSE IF (Z.EQ.'S'.OR.Z.EQ.'s') THEN YC=(YTOP+YBOT)/2. DY=YTOP-YC YTOP=YTOP-0.20*DY YBOT=YBOT-0.20*DY JTENS=0 ELSE IF (Z.EQ.'E'.OR.Z.EQ.'e') THEN XC=(XLEFT+XRIGHT)/2. DX=XRIGHT-XC XRIGHT=XRIGHT+0.20*DX XLEFT=XLEFT+0.20*DX JTENS=0 ELSE IF (Z.EQ.'W'.OR.Z.EQ.'w') THEN XC=(XLEFT+XRIGHT)/2. DX=XRIGHT-XC XRIGHT=XRIGHT-0.20*DX XLEFT=XLEFT-0.20*DX JTENS=0 ELSE IF (Z.EQ.'F'.OR.Z.EQ.'f') THEN TSHIFT=TSHIFT+1 JTENS=0 ELSE IF (Z.EQ.'B'.OR.Z.EQ.'b') THEN TSHIFT=TSHIFT-1 JTENS=0 ELSE IF (ICHAR(Z).GE.240.AND.ICHAR(Z).LE.249) THEN J=ICHAR(Z)-240+JTENS*10 I1=ICHAR(FILNAM(5:5))-240 I2=ICHAR(FILNAM(6:6))-240 I=10*I1+I2 TSHIFT=J-I JTENS=J ELSE IF (Z.EQ.'V'.OR.Z.EQ.'v') THEN VSHIFT=VSHIFT+1 JTENS=0 ELSE IF (Z.EQ.'U'.OR.Z.EQ.'u') THEN VSHIFT=VSHIFT-1 JTENS=0 ELSE IF (Z.EQ.'Q'.OR.Z.EQ.'q') THEN GO TO 9999 ELSE JTENS=0 GO TO 5001 ENDIF 5000 CONTINUE 5001 CONTINUE C C**** CONCLUSION OF ENDLESS LOOP (UNTIL OPERATOR EXITS) ************* GO TO 100 C******************************************************************** C 9999 CALL FSTERM STOP END C C C SUBROUTINE SEARCH (INPUT,TSHIFT,VSHIFT, & MODIFY,FILNAM, & OUTPUT,FAILED) C C READS SETS OF FILES IN GIVEN DIRECTION UNTIL A NON-EMPTY ONE IS FOUND C NOTE THAT FILNAM IS MODIFIED WHETHER SEARCH SUCCEEDS OR NOT. C THAT VARIABLES ARE FOUND EVEN IF THEY ARE NOT SEQUENTIAL, C BUT THAT TIMES PICKED MUST EXIST, OR A MESSAGE IS PRINTED. C LOGICAL FAILED INTEGER TSHIFT,VSHIFT CHARACTER*8 FILNAM C IF (TSHIFT.NE.0) THEN IT=10*(ICHAR(FILNAM(5:5))-240)+ICHAR(FILNAM(6:6))-240 IT=IT+TSHIFT IF (IT.LT.1.OR.IT.GT.99) THEN FAILED=.TRUE. RETURN ELSE I1=IT/10 FILNAM(5:5)=CHAR(240+I1) I2=IT-10*I1 FILNAM(6:6)=CHAR(240+I2) IF (VSHIFT.EQ.0) THEN CALL LOADIT (FILNAM, & 0.0,1.0,1.0,0.0, & .FALSE.,.FALSE.,.FALSE.,.TRUE.) CALL FSQERR(4,IERR) FAILED=IERR.GT.4 ENDIF ENDIF ENDIF IF (VSHIFT.NE.0) THEN IDO=ABS(VSHIFT) IF (VSHIFT.GT.0) THEN IVS= +1 ELSE IVS= -1 ENDIF DO 100 I=1,IDO C ---- BEGIN INDEFINATE LOOP INSIDE OUTER LOOP---- 10 IV=10*(ICHAR(FILNAM(2:2))-240)+ICHAR(FILNAM(3:3))-240 IV=IV+IVS IF (IV.LT.1.OR.IV.GT.24) THEN FAILED=.TRUE. RETURN ELSE I1=IV/10 FILNAM(2:2)=CHAR(240+I1) I2=IV-10*I1 FILNAM(3:3)=CHAR(240+I2) CALL LOADIT (FILNAM, & 0.0,1.0,1.0,0.0, & .FALSE.,.FALSE.,.FALSE.,.TRUE.) CALL FSQERR(4,IERR) IF (IERR.LE.4) THEN FAILED=.FALSE. ELSE GO TO 10 C -----CONDITIONAL RETURN IN INNER LOOP----- ENDIF ENDIF 100 CONTINUE ENDIF RETURN END C C C SUBROUTINE LOADIT (FILNAM, & XLEFT,XRIGHT,YTOP,YBOT, & BAR,IMAGE,STATES,TITLE) C C LOAD A SET OF UP TO 5 SEGMENTS WHICH ARE KNOWN TO EXIST C LOGICAL BAR,IMAGE,STATES,TITLE CHARACTER*8 FILNAM CHARACTER*80 TAG C IF (IMAGE) THEN CALL GSSDEL(1) CALL GSUWIN(XLEFT,XRIGHT,YBOT,YTOP) FILNAM(8:8)='1' CALL GSLOAD(FILNAM,0,DUMMY,ISEG,80,TAG) CALL GSSDEL(2) FILNAM(8:8)='2' CALL FSQERR(4,IERR) CALL GSLOAD(FILNAM,0,DUMMY,ISEG,80,TAG) ENDIF IF (STATES) THEN CALL GSSDEL(3) CALL GSUWIN(XLEFT,XRIGHT,YBOT,YTOP) FILNAM(8:8)='3' CALL FSQERR(4,IERR) CALL GSLOAD(FILNAM,0,DUMMY,ISEG,80,TAG) ENDIF IF (BAR) THEN CALL GSSDEL(4) CALL GSUWIN(0.0,11.0,0.0,8.5) FILNAM(8:8)='4' CALL FSQERR(4,IERR) CALL GSLOAD(FILNAM,0,DUMMY,ISEG,80,TAG) ENDIF IF (TITLE) THEN CALL GSSDEL(5) CALL GSUWIN(0.0,11.0,0.0,8.5) FILNAM(8:8)='5' CALL FSQERR(4,IERR) CALL GSLOAD(FILNAM,0,DUMMY,ISEG,80,TAG) ENDIF RETURN END C C C SUBROUTINE STOCK (FILNAM) C C USE FREE SEGMENTS #1-4 (AT MOST) TO CREATE A GRAPH OF THE C INVENTORY OF AVAILABLE IMAGES, BY VARIABLE AND TIMESTEP C NUMBERS. LEAVE SPACE AT TOP AND BOTTOM FOR OVERLAY OF C TITLES FROM CURRENT IMAGE. C NOTE THAT ENTIRE IMAGE MAY BE OVERLAIN BY MENU. C CHARACTER*8 FILNAM,TESTER CHARACTER*5 ASCII,LABEL CHARACTER*42 TEXT EXTERNAL ASCII LOGICAL SMART,ISTHER DIMENSION ISTHER(24,20),NVCHAR(24),TEXT(24) SAVE SMART,ISTHER DATA SMART/.FALSE./, ISTHER/480*.FALSE./ DATA TEXT(1)/'MANTLE: BASAL SHEAR STRESS '/ DATA NVCHAR(1)/26/ DATA TEXT(2)/'CRUST: BASAL SHEAR STRESS '/ DATA NVCHAR(2)/25/ DATA TEXT(3)/'MANTLE: VELOCITY '/ DATA NVCHAR(3)/16/ DATA TEXT(4)/'CRUST: VELOCITY '/ DATA NVCHAR(4)/15/ DATA TEXT(5)/'MANTLE: FAULT PLANES AND MAX. E-RATE '/ DATA NVCHAR(5)/36/ DATA TEXT(6)/'CRUST: FAULT PLANES AND MAX. E-RATE '/ DATA NVCHAR(6)/35/ DATA TEXT(7)/'MANTLE: STRESS AXES & SHEAR INTENSITY '/ DATA NVCHAR(7)/37/ DATA TEXT(8)/'CRUST: STRESS AXES & SHEAR INTENSITY '/ DATA NVCHAR(8)/36/ DATA TEXT(9)/'MANTLE: GRID OF ELEMENTS '/ DATA NVCHAR(9)/24/ DATA TEXT(10)/'CRUST: GRID OF ELEMENTS '/ DATA NVCHAR(10)/23/ DATA TEXT(11)/'MANTLE:RATE OF THICKENING(PURE SHEAR ONLY)'/ DATA NVCHAR(11)/42/ DATA TEXT(12)/'CRUST: RATE OF THICKENING(PURE SHEAR ONLY)'/ DATA NVCHAR(12)/42/ DATA TEXT(13)/'MANTLE: THICKNESS '/ DATA NVCHAR(13)/17/ DATA TEXT(14)/'CRUST: THICKNESS '/ DATA NVCHAR(14)/16/ DATA TEXT(15)/'MANTLE: BASAL TEMPERATURE '/ DATA NVCHAR(15)/25/ DATA TEXT(16)/'CRUST: BASAL TEMPERATURE '/ DATA NVCHAR(16)/24/ DATA TEXT(17)/'TELESEISMIC P TRAVEL-TIME RESIDUALS '/ DATA NVCHAR(17)/35/ DATA TEXT(18)/'ISOSTATIC TOPOGRAPHY '/ DATA NVCHAR(18)/20/ DATA TEXT(19)/'PALEO-HEAT-FLOW '/ DATA NVCHAR(19)/15/ DATA TEXT(20)/'TOPOGRAPHY AFTER DELAMINATION '/ DATA NVCHAR(20)/29/ DATA TEXT(21)/'CRUST: LOG (NET STRAIN) AND FAULT PLANES '/ DATA NVCHAR(21)/40/ DATA TEXT(22)/'CRUST: NET CLOCKWISE ROTATION '/ DATA NVCHAR(22)/29/ DATA TEXT(23)/'THICKNESS OF CRUST ABOVE CONRAD '/ DATA NVCHAR(23)/31/ DATA TEXT(24)/'THICKNESS OF CRUST BELOW CONRAD '/ DATA NVCHAR(24)/31/ C C C********************************************************************** C C ESTABLISH COORDINATE SYSTEM, SAME UNITS AS THE MENU C CALL GSUWIN(0.0,11.0,0.0,8.5) C C INITIALIZE SEGMENT 1 (RED BACKGROUND RECTANGLE) C CALL GSSDEL(1) CALL GSSEG(1) C C SET COLOR TO RED C CALL GSCOL(2) C C OPEN AREA WITH INVISIBLE BOUNDARY C CALL GSAREA(0) C C DRAW OUTLINE OF AREA C CALL GSMOVE(5.0,7.0) CALL GSLINE(10.0,7.0) CALL GSLINE(10.0,1.0) CALL GSLINE(5.0,1.0) CALL GSLINE(5.0,7.0) C C SIGNAL END OF AREA C CALL GSENDA C C CLOSE SEGMENT C CALL GSSCLS C C************************************************************* C C ESTABLISH COORDINATE SYSTEM, SAME UNITS AS THE MENU C CALL GSUWIN(0.0,11.0,0.0,8.5) C C OPEN SEGMENT 2 (TEXT LABELS AND RULED LINES) C CALL GSSDEL(2) CALL GSSEG(2) C C SELECT AND LOAD CHARACTER SET C C CALL GSLSS(2,'ADMUWCRP',199) 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 SET COLOR TO CYAN C CALL GSCOL(5) CALL GSLW(2) C CALL GSMOVE(1.0,7.5) CALL GSCHAP(19,'INVENTORY OF IMAGES') CALL GSMOVE(6.5,7.5) CALL GSCHAP(15,'TIMESTEP NUMBER') C C WRITE TIMESTEP NUMBERS AND VERTICAL RULES C DO 210 I=1,20 LABEL=ASCII(1.00*I) XL=5.00+(I-1)*0.25-WIDTH CALL GSMOVE(XL,7.0) CALL GSCHAP(3,LABEL) XR=5.00+I*0.25 CALL GSMOVE(XR,7.00) CALL GSLINE(XR,1.00) 210 CONTINUE C C WRITE VARIABLE NAMES AND HORIZONTAL RULES C DO 220 I=1,24 YB=7.00-I*0.25 CALL GSMOVE(-0.45,YB) CALL GSCHAP(NVCHAR(I),TEXT(I)) CALL GSMOVE(4.9,YB) CALL GSLINE(10.0,YB) 220 CONTINUE C C CLOSE SEGMENT C CALL GSSCLS C C******************************************************************* IF (.NOT.SMART) THEN DO 350 IR=1,24 DO 340 JC=1,20 TESTER='V00T00S5' I1=IR/10 TESTER(2:2)=CHAR(240+I1) I2=IR-I1*10 TESTER(3:3)=CHAR(240+I2) I1=JC/10 TESTER(5:5)=CHAR(240+I1) I2=JC-I1*10 TESTER(6:6)=CHAR(240+I2) CALL LOADIT (TESTER, & 0.0,11.0,8.5,0.0, & .FALSE.,.FALSE.,.FALSE.,.TRUE.) CALL FSQERR(4,IERR) ISTHER(IR,JC)=IERR.LE.4 340 CONTINUE 350 CONTINUE SMART=.TRUE. ENDIF C C ESTABLISH COORDINATE SYSTEM, SAME UNITS AS THE MENU C CALL GSUWIN(0.0,11.0,0.0,8.5) C C OPEN SEGMENT (3) OF GREEN BOXES SHOWING AVAILABLE FIGURES C CALL GSSDEL(3) CALL GSSEG(3) C C SET COLOR GREEN C CALL GSCOL(4) C C DRAW A BOX FOR EACH EXISTING FIGURE C DO 390 IR=1,24 DO 380 JC=1,20 IF (ISTHER(IR,JC)) THEN XL=5.00+(JC-1)*0.25 XR=XL+0.25 YB=7.00-IR*0.25 YT=YB+0.25 CALL GSAREA(0) CALL GSMOVE(XL,YB) CALL GSLINE(XR,YB) CALL GSLINE(XR,YT) CALL GSLINE(XL,YT) CALL GSLINE(XL,YB) CALL GSENDA ENDIF 380 CONTINUE 390 CONTINUE C C CLOSE SEGMENT C CALL GSSCLS C C**************************************************************** C C ESTABLISH COORDINATE SYSTEM, SAME UNITS AS THE MENU C CALL GSUWIN(0.0,11.0,0.0,8.5) C C OPEN SEGMENT 4 (MARK CURRENT IMAGE ON MAP) C CALL GSSDEL(4) CALL GSSEG(4) C C USE YELLOW PEN C CALL GSCOL(6) C C DRAW A DOT C I1=ICHAR(FILNAM(2:2))-240 I2=ICHAR(FILNAM(3:3))-240 IR=10*I1+I2 I1=ICHAR(FILNAM(5:5))-240 I2=ICHAR(FILNAM(6:6))-240 JC=10*I1+I2 XC=5.00+0.25*(JC-1)+0.125 YC=7.00-0.25*(IR-1)-0.125 XP=XC+0.100 CALL GSAREA(0) CALL GSMOVE(XP,YC) CALL GSARC(XC,YC,360.) CALL GSENDA C C CLOSE SEGMENT C CALL GSSCLS C C******************************************************************* C RETURN 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.) I2=INT((S-100.*I1)/10.) I3=INT(S-100.*I1-10.*I2) I4=INT(10.*(S-100.*I1-10.*I2-I3)+0.5) IF (I4.EQ.10) THEN I4=0 I3=I3+1 IF (I3.EQ.10) THEN I3=0 I2=I2+1 IF (I2.EQ.10) THEN I2=0 I1=I1+1 ENDIF ENDIF ENDIF ASCII(1:1)=CHAR(240+I1) ASCII(2:2)=CHAR(240+I2) ASCII(3:3)=CHAR(240+I3) ASCII(4:4)='.' 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 CHOICE C C WRITE MENU ON TOP OF ANY PRE-EXISTING SEGMENTS C CALL GSSDEL(6) CALL GSUWIN(0.0,11.0,0.0,8.5) CALL GSSEG(6) 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(2.0,7.5) CALL GSLINE(8.0,7.5) CALL GSLINE(8.0,1.3) CALL GSLINE(2.0,1.3) CALL GSLINE(2.0,7.5) C C SIGNAL END OF AREA C CALL GSENDA C C CLOSE FIRST MENU SEGMENT (#6) AND BEGIN SECOND (#7) C CALL GSSCLS C C*************************************** C CALL GSSDEL(7) CALL GSUWIN(0.0,11.0,0.0,8.5) CALL GSSEG(7) C C WRITE OUT MENU OPTIONS C C SELECT AND LOAD CHARACTER SET C C CALL GSLSS(2,'ADMUWCRP',199) 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 MENU: CALL GSMOVE(2.5,7.0) CALL GSCHAP(31,'M toggle this Menu on/off ') CALL GSMOVE(2.5,6.7) CALL GSCHAP(32,'I toggle Inventory screen on/off') CALL GSMOVE(2.5,6.4) CALL GSCHAP(31,'L toggle state Lines on/off ') CALL GSMOVE(2.5,6.1) CALL GSCHAP(31,'G toggle Graphical scale on/off') CALL GSMOVE(2.5,5.8) CALL GSCHAP(31,'T toggle Titles on/off ') CALL GSMOVE(2.5,5.5) CALL GSCHAP(31,'X eXpand map around center ') CALL GSMOVE(2.5,5.2) CALL GSCHAP(31,'C Contract map around center ') CALL GSMOVE(2.5,4.9) CALL GSCHAP(31,'N move window North by 10% ') CALL GSMOVE(2.5,4.6) CALL GSCHAP(31,'S move window South by 10% ') CALL GSMOVE(2.5,4.3) CALL GSCHAP(31,'E move window East by 10% ') CALL GSMOVE(2.5,4.0) CALL GSCHAP(31,'W move window West by 10% ') CALL GSMOVE(2.5,3.7) CALL GSCHAP(31,'F go Forward in time ') CALL GSMOVE(2.5,3.4) CALL GSCHAP(31,'B go Backwards in time ') CALL GSMOVE(2.1,3.1) CALL GSCHAP(35,'1..99 jump to time window #1,2,..99') CALL GSMOVE(2.5,2.8) CALL GSCHAP(33,'V change to next Variable on file') CALL GSMOVE(2.5,2.5) CALL GSCHAP(31,'U Undo or back up variable ') CALL GSMOVE(2.5,2.2) CALL GSCHAP(31,'Q Quit and exit this program ') CALL GSMOVE(2.2,1.5) CALL GSCHAP(34,'YOU MAY COMBINE UP TO 5 CHARACTERS') C C CLOSE SECOND MENU SEGMENT C CALL GSSCLS RETURN END //LKED.SYSLMOD DD DISP=OLD,UNIT=DATA, // DSN=EFF9GPB.GDDMMOD(VIEW), // SPACE=(TRK,(20,20,1),RLSE) //LKED.SYSIN DD * ENTRY MAIN INCLUDE SYSLIB(FSINN) INCLUDE SYSLIB(ADMLSYS1) //